Changeset 4876

Timestamp:

06/20/05 19:23:02 (4 years ago)

Author:

autrijus

svk:copy_cache_prev:

6641

Message:

* loop and bare blocks at value position now Really Works (tm).

Location:

src

Files:

• Emit/PIR.hs (modified) (6 diffs)
• Pugs/Compile/PIR.hs (modified) (2 diffs)

src/Emit/PIR.hs

@@ -521 +521 @@
 parrotBrokenXXX = True
 
--- calls and place result in tempPMC
-callBlock :: VarName -> Expression -> [Ins]
-callBlock label fun =
-    [ "newsub" .- [funPMC, bare ".Continuation", bare label]
-    ] ++ callBlockCC fun ++ collectCC label
-
 collectCC :: LabelName -> [Ins]
 collectCC label =
@@ -535 +529 @@
     ]
 
-callBlockCC :: Expression -> [Ins]
-callBlockCC fun | parrotBrokenXXX =
+callThunkCC :: Expression -> [Ins]
+callThunkCC fun | parrotBrokenXXX =
     [ tempINT   <-- "get_addr" $ [fun]
     , tempSTR   <:= tempINT
@@ -542 +536 @@
     , "invoke" .- [fun]
     ]
-callBlockCC fun =
+callThunkCC fun =
     [ "set_args" .- sigList [funPMC]
     , "invoke" .- [fun]
@@ -554 +548 @@
     [ "newsub" .- [funPMC, bare ".Continuation", bare postL]
     , comp .- [arg0, bare altL]
-    ] ++ callBlockCC arg1 ++
+    ] ++ callThunkCC arg1 ++
     [ InsLabel altL
-    ] ++ callBlockCC arg2 ++ collectCC postL) --> [tempPMC]
+    ] ++ callThunkCC arg2 ++ collectCC postL) --> [tempPMC]
     where
     altL = ("sc_" ++ name ++ "_alt")
@@ -572 +566 @@
     , "returncc" .- []
     , InsLabel altL
-    ] ++ callBlockCC arg1 ++ collectCC postL) --> [tempPMC]
+    ] ++ callThunkCC arg1 ++ collectCC postL) --> [tempPMC]
     where
     altL = ("sc_" ++ escaped name ++ "_alt")
@@ -612 +606 @@
     , sub "&statement_control:loop" [arg0, arg1, arg2, arg3] $
         [ InsLabel "sc_loop_next"
-        ] ++ callBlock "loopCond" arg1 ++
-        [ "unless" .- [tempPMC, bare "sc_loop_last"]
-        ] ++ callBlock "loopBody" arg2 ++
-        [ -- ..throw away the result of body...
-        ] ++ callBlock "loopPost" arg3 ++
-        [ "goto" .- [bare "sc_loop_next"]
+        , [reg tempPMC] <-& arg1 $ []
+        , "unless" .- [tempPMC, bare "sc_loop_last"]
+        , [] <-& arg2 $ [] -- throw away the result of body...
+        , [] <-& arg3 $ [] -- ...and the post-condition
+        , "goto" .- [bare "sc_loop_next"]
         , InsLabel "sc_loop_last"
         , "returncc" .- []

src/Pugs/Compile/PIR.hs

@@ -335 +335 @@
     compile (Cxt cxt rest) = enter cxt $ compile rest
     compile (Var name) = return . PExp $ PVar name
+    compile exp@(Val (VCode _)) = compile (Syn "sub" [exp])
     compile (Val val) = fmap PLit (compile val)
     compile Noop = compile (Val undef)
@@ -436 +437 @@
     trans (PApp _ exp@(PBlock _) []) = do
         blockC  <- trans exp
-        [appC] <- genLabel ["invokeBlock"]
-        tell $ map StmtIns $ callBlock appC blockC 
+        tellIns $ [reg tempPMC] <-& blockC $ []
         return tempPMC
     trans (PApp (TCxtLValue _) (PExp (PVar "&postcircumfix:[]")) [(PExp lhs), rhs]) = do