Changeset 4873

Timestamp:

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

Author:

autrijus

svk:copy_cache_prev:

6641

Message:

* return() from subroutines now work in PIR.

Location:

src

Files:

• Emit/PIR.hs (modified) (3 diffs)
• Pugs/Compile/PIR.hs (modified) (11 diffs)
• perl6/Prelude/PIR.pm (modified) (4 diffs)

src/Emit/PIR.hs

@@ -113 +113 @@
     emit (StmtPad pad _) = vcat $
         [ emit "new_pad" <+> int curPad
-        ] ++ map (\(var, exp) -> emit ("store_lex" .- [lit (-1 :: Int), lit var, exp])) pad
+        ] ++ map (\(var, exp) -> emit ("store_lex" .- [lit curPad, lit var, exp])) pad
     emit (StmtRaw doc) = doc
 
@@ -319 +319 @@
     lit :: x -> y 
 
+instance LiteralClass [[ArgFlag]] Expression where
+    lit = lit . parens . commaSep . map emit
+
+instance LiteralClass [ArgFlag] Expression where
+    lit = lit . emit
+
 instance LiteralClass ObjType Expression where
     lit = ExpLV . VAR . render . emit
 
 instance LiteralClass Doc Expression where
-    lit = ExpLit . LitStr . render
+    lit = lit . render
 
 instance LiteralClass String Expression where
@@ -600 +606 @@
 -}
     -- Control flowy
-    [ sub "&statement_control:loop" [arg0, arg1, arg2, arg3] $
+    [ sub "&return" [slurpy arg0] $
+        [ InsNew tempPMC PerlArray
+        , (KEYED tempPMC (lit False)) <:= arg0
+        , "throw" .- [tempPMC]
+        ]
+    , sub "&statement_control:loop" [arg0, arg1, arg2, arg3] $
         [ InsLabel "sc_loop_next"
         ] ++ callBlock "loopCond" arg1 ++

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')
 

src/perl6/Prelude/PIR.pm

@@ -3 +3 @@
 
 # our &prefix:<?> := &true doesn't work yet.
-sub prefix:<?> ($var) returns Bool { true $var }
+sub prefix:<?> ($var) returns Bool is primitive { true $var }
 
-sub chomp (Str $str is rw) returns Str {
+sub chomp (Str $str is rw) returns Str is primitive {
     if substr($str, -1, 1) eq "\n" {
         $str = substr $str, 0, chars($str) - 1;
@@ -14 +14 @@
 }
 
-sub chop (Str $str is rw) returns Str {
+sub chop (Str $str is rw) returns Str is primitive {
     if chars($str) == 0 {
         undef;
@@ -24 +24 @@
 }
 
-sub sleep (Num $seconds) returns Num {
+sub sleep (Num $seconds) returns Num is primitive {
     my $time = time;
     Pugs::Internals::sleep $seconds;
@@ -31 +31 @@
 }
 
-sub exit (Int ?$status = 0) {
+sub exit (Int ?$status = 0) is primitive {
     Pugs::Internals::exit $status;
 }
 
-sub pi () returns Num {
+sub pi () returns Num is primitive {
     3.14159265358979323846264338327950288419716939937510;
 }
 
-sub lcfirst (Str $str) returns Str {
+sub lcfirst (Str $str) returns Str is primitive {
     lc(substr $str, 0, 1) ~ substr $str, 1, chars($str) - 1;
 }
 
-sub ucfirst (Str $str) returns Str {
+sub ucfirst (Str $str) returns Str is primitive {
     uc(substr $str, 0, 1) ~ substr $str, 1, chars($str) - 1;
 }