Changeset 4873 for src/Pugs/Compile

Timestamp:

06/20/05 18:38:20 (3 years ago)

Author:

autrijus

svk:copy_cache_prev:

6641

Message:

* return() from subroutines now work in PIR.

Files:

• src/Pugs/Compile/PIR.hs (modified) (11 diffs)

src/Pugs/Compile/PIR.hs

@@ -37 +37 @@
     PPad        :: ![(VarName, PIL Expression)] -> !(PIL [Stmt]) -> PIL [Stmt]
 
-    PSub        :: !SubName -> ![TParam] -> !(PIL [Stmt]) -> PIL Decl
+    PSub        :: !SubName -> !SubType -> ![TParam] -> !(PIL [Stmt]) -> PIL Decl
 #endif
 
@@ -78 +78 @@
     show (PBlock x) = "(PBlock " ++ show x ++ ")"
     show (PRawName x) = "(PRawName " ++ show x ++ ")"
-    show (PSub x y z) = "(PSub " ++ show x ++ " " ++ show y ++ " " ++ show z ++ ")"
+    show (PSub x y z w) = unwords ["(PSub", show x, show y, show z, show w, ")"]
 
 data TEnv = MkTEnv
@@ -141 +141 @@
             compile ("&*END", concat decls)
         canCompile _ = return []
-        doCode name vsub = if subType vsub == SubPrim
-            then return []
-            else compile (name, vsub)
+        doCode name vsub = case subBody vsub of
+            Prim _  -> return []
+            _       -> compile (name, vsub)
 
 instance Compile ([Char], [PIL Decl]) [PIL Decl] where
     compile (name, decls) = do
         let bodyC = [ PStmts . PStmt . PExp $ PApp tcVoid (PExp (PVar sub)) []
-                    | PSub sub _ _ <- decls
+                    | PSub sub _ _ _ <- decls
                     ]
-        return (PSub name [] (combine bodyC PNil):decls)
+        return (PSub name SubPrim [] (combine bodyC PNil):decls)
 
 instance Compile ([Char], VCode) [PIL Decl] where
-    compile (name, MkCode{ subBody = Syn "block" [body], subParams = params }) = do
+    compile (name, MkCode{ subType = styp, subBody = Syn "block" [body], subParams = params }) = do
         bodyC   <- enter cxtItemAny $ compile body
         paramsC <- mapM compile params
-        return [PSub name paramsC bodyC]
-    compile x = compError x
+        return [PSub name styp paramsC bodyC]
+    compile (name, code) = compile
+        (name, code{ subBody = Syn "block" [subBody code] })
 
 {-
@@ -274 +275 @@
     compile exp@(Syn "while" _) = compLoop exp
     compile exp@(Syn "until" _) = compLoop exp
+    compile (Syn "given" _) = compile (Var "$_") -- XXX
+    compile (Syn "when" _) = compile (Var "$_") -- XXX
     compile (Syn "{}" (x:xs)) = compile (App (Var "&postcircumfix:{}") (Just x) xs)
     compile (Syn "[]" (x:xs)) = do
@@ -328 +331 @@
     compile (Syn "sub" [Val (VCode sub)]) = do
         -- XXX I'd like to lambda lift... :-/
-        cxt     <- askTCxt
+        _       <- askTCxt
         bodyC   <- compile (subBody sub)
-        return $ PExp $ PApp cxt (PBlock bodyC) []
+        return $ PBlock bodyC
     compile (Syn "for" _) = compile Noop -- XXX TODO
     compile (Syn "module" _) = compile Noop
@@ -342 +345 @@
 
 compError :: forall a b. Compile a b => a -> Comp b
-compError = die $ "Compile error -- invalid PIL "
-    ++ (drop 12 . show $ typeOf (undefined :: b))
+compError = die $ "Compile error -- invalid "
+    ++ (show $ typeOf (undefined :: b))
 
 transError :: forall a b. Translate a b => a -> Trans b
@@ -468 +471 @@
             then "store_global" .- [tempSTR, bodyC] -- XXX HACK
             else "set_args" .- [lit "(0b10)", bodyC]
-        tellIns $ "invoke" .- [reg cc]
+--      tellIns $ "invoke" .- [reg cc]
         tellLabel endC
         return (ExpLV this)
@@ -495 +498 @@
         pmc     <- genName name
         return (ExpLV pmc)
-    trans (PSub name params body) = do
+    trans (PSub name styp params body) = do
         (_, stmts)  <- listen $ do
             let prms = map tpParam params
@@ -501 +504 @@
             tellIns $ "get_params" .- sigList (map prmToSig prms)
             tellIns $ "new_pad" .- [lit curPad]
-            mapM storeLex params
-            trans body
-            bodyC <- lastPMC
-            tellIns $ "set_returns" .- retSigList [bodyC]
-            tellIns $ "returncc" .- []
+
+
+            wrapSub styp $ do
+                mapM storeLex params
+                trans body
+                bodyC <- lastPMC
+                tellIns $ "set_returns" .- retSigList [bodyC]
+                tellIns $ "returncc" .- []
+
         return (DeclSub name [] stmts)
         where
@@ -531 +538 @@
                 tellLabel defC
             tellIns $ "store_lex" .- [lit curPad, lit var, bare name]
+        -- XXX - slow way of implementing "return"
+        wrapSub SubPrim = id
+        wrapSub _ = \body -> do
+            [retL] <- genLabel ["returnHandler"]
+            tellIns $ "push_eh" .- [bare retL]
+            body
+            tellLabel retL
+            tellIns $ tempPMC <:= ExpLV (KEYED (VAR "P5") (lit False))
+            tellIns $ "set_returns" .- sigList [tempPMC]
+            tellIns $ "returncc" .- []
     trans x = transError x
 
@@ -553 +570 @@
     name'   <- liftIO $ liftSTM $ do
         (cur, name) <- readTVar tvar
-        return $ "P" ++ show cur ++ "_" ++ name
+        return $ "P" ++ show cur ++ (if null name then name else ('_':name))
     return $ reg (VAR name')