Changeset 4882

Timestamp:

06/20/05 21:18:37 (4 years ago)

Author:

autrijus

svk:copy_cache_prev:

6641

Message:

* parametric blocks now works as specced!

Location:

src

Files:

• Emit/PIR.hs (modified) (1 diff)
• Pugs/Compile/PIR.hs (modified) (10 diffs)

src/Emit/PIR.hs

@@ -134 +134 @@
     emit (InsFun rets fun args) = emitFun "invokecc" fun args rets
     emit (InsTailFun (ExpLit (LitStr name)) args) = emitFunName "tailcall" name args []
+    emit (InsTailFun fun args) = emitFun "tailcall" fun args []
     emit (InsExp _) = empty
     emit (InsLabel label) = nest (-2) (emit label <> colon)
     emit (InsComment comment ins) = emit (StmtComment comment) $+$ emit ins
-    emit x = error $ "can't emit ins: " ++ show x
 
 emitRets :: [Sig] -> Doc

src/Pugs/Compile/PIR.hs

@@ -35 +35 @@
     PExp        :: !(PIL LValue) -> PIL Expression 
     PLit        :: !(PIL Literal) -> PIL Expression
-    PPos        :: !Pos -> !Exp -> PIL a -> PIL a
+    PPos        :: !Pos -> !Exp -> !(PIL a) -> PIL a
     PStmt       :: !(PIL Expression) -> PIL Stmt 
     PThunk      :: !(PIL Expression) -> PIL Expression 
-    PCode       :: !SubType -> !(PIL [Stmt]) -> PIL Expression 
+    PCode       :: !SubType -> ![TParam] -> !(PIL [Stmt]) -> PIL Expression 
 
     PVal        :: !Val -> PIL Literal
     PVar        :: !VarName -> PIL LValue
 
-    PStmts      :: !(PIL Stmt) -> PIL [Stmt] -> PIL [Stmt]
+    PStmts      :: !(PIL Stmt) -> !(PIL [Stmt]) -> PIL [Stmt]
     PApp        :: !TCxt -> !(PIL Expression) -> ![PIL Expression] -> PIL LValue
     PAssign     :: ![PIL LValue] -> !(PIL Expression) -> PIL LValue
@@ -88 +88 @@
     show (PPad x y) = "(PPad " ++ show x ++ " " ++ show y ++ ")"
     show (PThunk x) = "(PThunk " ++ show x ++ ")"
-    show (PCode x y) = unwords ["(PCode", show x, show y, ")"]
+    show (PCode x y z) = unwords ["(PCode", show x, show y, show z, ")"]
     show (PRawName x) = "(PRawName " ++ show x ++ ")"
     show (PSub x y z w) = unwords ["(PSub", show x, show y, show z, show w, ")"]
@@ -167 +167 @@
     compile (name, MkCode{ subType = styp, subBody = Syn "block" [body], subParams = params }) = do
         bodyC   <- enter cxtItemAny $ compile body
-        paramsC <- mapM compile params
+        paramsC <- compile params
         return [PSub name styp paramsC bodyC]
     compile (name, code) = compile
@@ -247 +247 @@
 
 pBlock :: PIL [Stmt] -> PIL Expression
-pBlock = PCode SubBlock
+pBlock = PCode SubBlock []
 
 {-
@@ -360 +360 @@
             Syn "block" [exp]   -> exp
             exp                 -> exp
-        return $ PCode (subType sub) bodyC
+        paramsC <- compile $ subParams sub
+        return $ PCode (subType sub) paramsC bodyC
     compile (Syn "for" _) = compile Noop -- XXX TODO
     compile (Syn "module" _) = compile Noop
@@ -447 +448 @@
         tell [thisC]
         trans rest
-    trans (PApp _ exp@(PCode _ _) []) = do
+    trans (PApp _ exp@(PCode _ _ _) []) = do
         blockC  <- trans exp
         tellIns $ [reg tempPMC] <-& blockC $ []
@@ -484 +485 @@
             return ([], (StmtPad (map fst pad `zip` valsC) expsC:))
     trans (PExp exp) = fmap ExpLV $ trans exp
-    trans (PCode styp body) = do
+    trans (PCode styp params body) = do
         [begC, endC] <- genLabel ["blockBegin", "blockEnd"]
         this    <- genPMC "block"
@@ -490 +491 @@
         tellIns $ "goto" .- [bare endC]
         tellLabel begC
+        let prms = map tpParam params
+        mapM_ (tellIns . InsLocal RegPMC . prmToIdent) prms
+        tellIns $ "get_params" .- sigList (map prmToSig prms)
         tellIns $ "new_pad" .- [lit curPad]
         wrapSub styp $ do
+            mapM storeLex params
             trans body  -- XXX - consistency check
             bodyC   <- lastPMC
@@ -535 +540 @@
                 tellIns $ "returncc" .- []
         return (DeclSub name [] stmts)
-        where
-        -- XXX - slurpiness
-        prmToSig prm = MkSig (prmToArgs prm) . bare $ prmToIdent prm
-        prmToArgs prm = combine 
-            [ if isSlurpy prm then (MkArgSlurpyArray:) else id
-            , if isOptional prm then (MkArgOptional:) else id
-            ] []
-        prmToIdent = render . varText . paramName
-        storeLex param = do
-            let var = paramName prm
-                name = prmToIdent prm
-                prm = tpParam param
-            -- deal with defaults
-            when (isOptional prm) $ do
-                [defC] <- genLabel ["defaultDone"]
-                tellIns $ "unless_null" .- [bare name, bare defC]
-                case tpDefault param of
-                    Nothing     -> tellIns $ InsNew (VAR name) PerlScalar
-                    (Just exp)  -> do
-                        expC <- trans exp
-                        -- compile it away
-                        tellIns $ VAR name <:= expC
-                tellLabel defC
-            tellIns $ "store_lex" .- [lit curPad, lit var, bare name]
     trans x = transError x
 
@@ -581 +562 @@
     tellIns $ "set_returns" .- sigList [tempPMC]
     tellIns $ "returncc" .- []
+
+-- XXX - slurpiness
+prmToSig prm = MkSig (prmToArgs prm) . bare $ prmToIdent prm
+prmToArgs prm = combine 
+    [ if isSlurpy prm then (MkArgSlurpyArray:) else id
+    , if isOptional prm then (MkArgOptional:) else id
+    ] []
+prmToIdent = render . varText . paramName
+storeLex param = do
+    let var = paramName prm
+        name = prmToIdent prm
+        prm = tpParam param
+    -- deal with defaults
+    when (isOptional prm) $ do
+        [defC] <- genLabel ["defaultDone"]
+        tellIns $ "unless_null" .- [bare name, bare defC]
+        case tpDefault param of
+            Nothing     -> tellIns $ InsNew (VAR name) PerlScalar
+            (Just exp)  -> do
+                expC <- trans exp
+                -- compile it away
+                tellIns $ VAR name <:= expC
+        tellLabel defC
+    tellIns $ "store_lex" .- [lit curPad, lit var, bare name]
 
 tellIns :: Ins -> Trans ()