Changeset 4879

Timestamp:

06/20/05 20:52:17 (4 years ago)

Author:

autrijus

svk:copy_cache_prev:

6641

Message:

* inline subroutine: my &x = sub { return 3 }; say x()

Files:

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

src/Pugs/Compile/PIR.hs

@@ -38 +38 @@
     PStmt       :: !(PIL Expression) -> PIL Stmt 
     PThunk      :: !(PIL Expression) -> PIL Expression 
-    PBlock      :: !(PIL [Stmt]) -> PIL Expression 
+    PCode       :: !SubType -> !(PIL [Stmt]) -> PIL Expression 
 
     PVal        :: !Val -> PIL Literal
@@ -88 +88 @@
     show (PPad x y) = "(PPad " ++ show x ++ " " ++ show y ++ ")"
     show (PThunk x) = "(PThunk " ++ show x ++ ")"
-    show (PBlock x) = "(PBlock " ++ show x ++ ")"
+    show (PCode x y) = unwords ["(PCode", show x, show y, ")"]
     show (PRawName x) = "(PRawName " ++ show x ++ ")"
     show (PSub x y z w) = unwords ["(PSub", show x, show y, show z, show w, ")"]
@@ -242 +242 @@
         postC   <- compile post
         funC    <- compile (Var "&statement_control:loop")
-        return $ PStmt $ PExp $ PApp TCxtVoid funC [preC, PBlock condC, PBlock bodyC, PBlock postC]
+        return $ PStmt $ PExp $ PApp TCxtVoid funC
+            [preC, pBlock condC, pBlock bodyC, pBlock postC]
     compile exp = fmap PStmt $ compile exp
+
+pBlock :: PIL [Stmt] -> PIL Expression
+pBlock = PCode SubBlock
 
 {-
@@ -325 +329 @@
     bodyC   <- compile body
     funC    <- compile (Var $ "&statement_control:" ++ name)
-    return $ PApp cxt funC [PBlock condC, PBlock bodyC]
+    return $ PApp cxt funC [pBlock condC, pBlock bodyC]
 compLoop exp = compError exp
 
@@ -350 +354 @@
         cxt     <- askTCxt
         bodyC   <- compile body
-        return $ PExp $ PApp cxt (PBlock bodyC) []
+        return $ PExp $ PApp cxt (pBlock bodyC) []
     compile (Syn "sub" [Val (VCode sub)]) = do
         -- XXX I'd like to lambda lift... :-/
@@ -356 +360 @@
             Syn "block" [exp]   -> exp
             exp                 -> exp
-        return $ PBlock bodyC
+        return $ PCode (subType sub) bodyC
     compile (Syn "for" _) = compile Noop -- XXX TODO
     compile (Syn "module" _) = compile Noop
@@ -443 +447 @@
         tell [thisC]
         trans rest
-    trans (PApp _ exp@(PBlock _) []) = do
+    trans (PApp _ exp@(PCode _ _) []) = do
         blockC  <- trans exp
         tellIns $ [reg tempPMC] <-& blockC $ []
@@ -480 +484 @@
             return ([], (StmtPad (map fst pad `zip` valsC) expsC:))
     trans (PExp exp) = fmap ExpLV $ trans exp
-    trans (PBlock body) = do
+    trans (PCode styp body) = do
         [begC, endC] <- genLabel ["blockBegin", "blockEnd"]
         this    <- genPMC "block"
@@ -486 +490 @@
         tellIns $ "goto" .- [bare endC]
         tellLabel begC
-        trans body  -- XXX - consistency check
-        bodyC   <- lastPMC
-        tellIns $ "set_returns" .- retSigList [bodyC]
-        tellIns $ "returncc" .- []
+        tellIns $ "new_pad" .- [lit curPad]
+        wrapSub styp $ do
+            trans body  -- XXX - consistency check
+            bodyC   <- lastPMC
+            tellIns $ "set_returns" .- retSigList [bodyC]
+            tellIns $ "returncc" .- []
         tellLabel endC
         return (ExpLV this)
@@ -522 +528 @@
             tellIns $ "get_params" .- sigList (map prmToSig prms)
             tellIns $ "new_pad" .- [lit curPad]
-
-
             wrapSub styp $ do
                 mapM storeLex params
@@ -530 +534 @@
                 tellIns $ "set_returns" .- retSigList [bodyC]
                 tellIns $ "returncc" .- []
-
         return (DeclSub name [] stmts)
         where
@@ -556 +559 @@
                 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
 
@@ -575 +568 @@
 fetchCC cc _ = do
     tellIns $ "get_params" .- sigList [reg cc]
+
+-- XXX - slow way of implementing "return"
+wrapSub :: SubType -> Trans () -> Trans ()
+wrapSub SubPrim = id
+wrapSub SubBlock = id -- XXX not really
+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" .- []
 
 tellIns :: Ins -> Trans ()