Changeset 8681 for src/Pugs/CodeGen

Timestamp:

01/15/06 16:49:47 (3 years ago)

Author:

audreyt

Message:

* -BPIR now returned to its full glory.
* Test.pm doesn't work yet because of named args.

Files:

• src/Pugs/CodeGen/PIR.hs (modified) (17 diffs)

src/Pugs/CodeGen/PIR.hs

@@ -14 +14 @@
 -}
 
-module Pugs.CodeGen.PIR (genPIR) where
+module Pugs.CodeGen.PIR (genPIR, genPIR_YAML) where
 import Pugs.Internals
 import Pugs.AST
@@ -27 +27 @@
 import Pugs.Compile
 import Pugs.Run (getLibs)
+import DrIFT.YAML
 
 type CodeGen a = WriterT [Stmt] (ReaderT TEnv IO) a
@@ -78 +79 @@
     trans (PExp exp) = fmap ExpLV $ trans exp
     trans (PLit (PVal VUndef)) = do
-        pmc     <- genLV "undef"
+        pmc     <- genScalar "undef"
         return $ ExpLV pmc
     trans (PLit lit) = do
         -- generate fresh supply and things...
         litC    <- trans lit
-        pmc     <- genLV "lit"
-        tellIns $ pmc <== ExpLit litC
+        pmc     <- genScalar "lit"
+        tellIns $ pmc <== litC
         return $ ExpLV pmc
     trans (PThunk exp) = do
-        [begL, sndL, retL, endL] <- genLabel ["thunkBegin", "thunkAgain", "thunkReturn", "thunkEnd"]
-        this    <- genPMC "block"
-        tellIns $ InsNew (reg this) Continuation
-        tellIns $ "set_addr" .- [reg this, bare begL]
-        tellIns $ "goto" .- [bare endL]
-        tellLabel begL
-        cc      <- genPMC "cc"
-        fetchCC cc (reg this)
-        expC    <- trans exp
-        tellIns $ "set_addr" .- [reg this, bare sndL]
-        tellIns $ "goto" .- [bare retL]
-        tellLabel sndL
-        fetchCC cc (reg this)
-        tellLabel retL
-        tellIns $ if parrotBrokenXXX
-            then "store_global" .- [tempSTR, expC]
-            else "set_args" .- [lit "(0b10)", expC]
-        tellIns $ "invokecc" .- [reg cc]
-        tellLabel endL
+        [begL, initL]  <- genLabel ["thunk", "thunkInit"]
+        this    <- genPMC "thunk"
+        let begP = begL ++ "_C"
+        tellIns $ InsConst (VAR begP) Sub (lit begL)
+        tellIns $ reg this <-- "newclosure" $ [bare begP]
+        -- inner subroutine begins
+        censor ((:[]) . StmtSub begL) $ do
+            -- tellIns $ "push_eh" .- [bare initL]
+            expC <- trans exp
+            tellIns $ "set_returns" .- retSigList [expC]
+            tellIns $ "returncc" .- []
         return (ExpLV this)
     trans (PCode styp params _ _ body) = do
-        [begL, endL] <- genLabel ["blockBegin", "blockEnd"]
+        [begL]  <- genLabel ["block"]
         this    <- genPMC "block"
         let begP = begL ++ "_C"
         tellIns $ InsConst (VAR begP) Sub (lit begL)
         tellIns $ reg this <-- "newclosure" $ [bare begP]
-        tellIns $ "goto" .- [bare endL]
-        tellLabel begL
-        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
-            tellIns $ "set_returns" .- retSigList [bodyC]
-            tellIns $ "returncc" .- []
-        tellLabel endL
+        -- inner subroutine begins
+        censor ((:[]) . StmtSub begL) $ do
+            let prms = map tpParam params
+            tell [StmtPad (map prmToPad prms) []]
+            tellIns $ "get_params" .- sigList (map prmToSig prms)
+            wrapSub styp $ do
+                mapM storeLex params
+                bodyC   <- case body of
+                    PNil -> return nullPMC
+                    _    -> trans body >> lastPMC
+                tellIns $ "set_returns" .- retSigList [bodyC]
+                tellIns $ "returncc" .- []
         return (ExpLV this)
+
+prmToPad :: Param -> (VarName, Expression)
+prmToPad prm = (paramName prm, ExpLV (VAR $ prmToIdent prm))
 
 instance Translate PIL_Decl Decl where
@@ -135 +130 @@
         (_, stmts)  <- listen $ do
             let prms = map tpParam params
-            mapM_ (tellIns . InsLocal RegPMC . prmToIdent) prms
+            tell [StmtPad (map prmToPad prms) []]
             tellIns $ "get_params" .- sigList (map prmToSig prms)
-            tellIns $ "new_pad" .- [lit curPad]
+            -- tellIns $ "new_pad" .- [lit curPad]
             wrapSub styp $ do
                 mapM storeLex params
-                trans body
-                bodyC <- lastPMC
+                bodyC   <- case body of
+                    PNil -> return nullPMC
+                    _    -> trans body >> lastPMC
                 tellIns $ "set_returns" .- retSigList [bodyC]
                 tellIns $ "returncc" .- []
-        return (DeclSub name [] stmts)
-
-instance Translate PIL_Literal Literal where
-    trans (PVal (VBool bool)) = return $ LitInt (toInteger $ fromEnum bool)
-    trans (PVal (VStr str)) = return $ LitStr str
-    trans (PVal (VInt int)) = return $ LitInt int
-    trans (PVal (VNum num)) = return $ LitNum num
-    trans (PVal (VRat rat)) = return $ LitNum (ratToNum rat)
-    trans (PVal (VList [])) = return $ LitInt 0 -- XXX Wrong
+        return (DeclSub name [SubOUTER "main"] stmts)
+
+instance Translate PIL_Literal Expression where
+    trans (PVal (VBool bool)) = return $ ExpLit (LitInt (toInteger $ fromEnum bool))
+    trans (PVal (VStr str)) = return $ ExpLit (LitStr str)
+    trans (PVal (VInt int)) = return $ ExpLit (LitInt int)
+    trans (PVal (VNum num)) = return $ ExpLit (LitNum num)
+    trans (PVal (VRat rat)) = return $ ExpLit (LitNum (ratToNum rat))
+    -- trans (PVal (VList [])) = return $ LitInt 0 -- XXX Wrong
+    trans (PVal (VList vs)) = do
+        pmc <- genArray "vlist"
+        forM vs $ \val -> do
+            valC <- trans (PVal val)
+            tellIns $ "push" .- [pmc, valC]
+        return pmc
     trans val@(PVal _) = transError val
 
 instance Translate PIL_LValue LValue where
     trans (PVar name) | Just (pkg, name') <- isQualified name = do
-        -- XXX - this is terribly ugly.  Fix at parrot side perhaps?
-        pmc     <- genLV "glob"
-        let initL   = "init_" ++ pmcStr
-            doneL   = "done_" ++ pmcStr
-            pmcStr  = render (emit pmc)
-        tellIns $ "push_eh" .- [bare initL]
-        tellIns $ pmc <-- "find_global" $ [lit pkg, lit name']
-        tellIns $ "goto" .- [bare doneL]
-        tellLabel initL
+        [globL] <- genLabel ["glob"]
+        pmc     <- genScalar "glob"
+        tell [StmtRaw (text "errorsoff .PARROT_ERRORS_GLOBALS_FLAG")]
+        tellIns $ pmc       <-- "find_global" $ [lit pkg, lit name']
+        tellIns $ tempINT   <-- "defined" $ [reg pmc]
+        tellIns $ "if" .- [tempINT, bare globL]
+        tellIns $ InsNew pmc PerlScalar
         tellIns $ "store_global" .- [lit pkg, lit name', reg pmc]
-        tellLabel doneL
-        tellIns $ "clear_eh" .- []
+        tellLabel globL
+        tell [StmtRaw (text "errorson .PARROT_ERRORS_GLOBALS_FLAG")]
         return pmc
     trans (PVar name) = do
-        pmc     <- genLV "lex"
+        pmc     <- genScalar "lex"
         tellIns $ pmc <-- "find_name" $ [lit $ possiblyFixOperatorName name]
         return pmc
@@ -179 +179 @@
         tellIns $ lhsC <== rhsC
         return lhsC
-    trans (PBind [PVar name] rhs)
-        | Just (pkg, name') <- isQualified (qualify name) = do
+    trans (PBind [PVar name] rhs) = do
         rhsC    <- trans rhs
-        tellIns $ "store_global" .- [lit pkg, lit name', rhsC]
+        tellIns $ "store_lex" .- [lit name, rhsC]
         trans (PVar name)
     trans (PBind [lhs] rhs) = do
@@ -189 +188 @@
         tellIns $ lhsC <:= rhsC
         return lhsC
-    trans (PApp _ exp@(PCode _ _ _ _ _) Nothing []) = do
+    trans (PApp _ exp@PCode{} Nothing []) = do
         blockC  <- trans exp
         tellIns $ [reg tempPMC] <-& blockC $ []
@@ -200 +199 @@
         trans (PApp ctx fun Nothing (inv:args))  -- XXX wrong
     trans (PApp _ fun Nothing args) = do
-        funC    <- trans fun {- case fun of
+        funC <- trans fun {- case fun of
             PExp (PVar name) -> return $ lit name
             _           -> trans fun
@@ -206 +205 @@
         argsC   <- mapM trans args
         -- XXX WORKAROUND PARROT BUG (see below)
-        pmc     <- genLV "app"
+        pmc     <- genScalar "app"
         -- XXX - probe if funC is slurpy, then modify ExpLV pmc accordingly
         tellIns $ [reg pmc] <-& funC $ argsC
@@ -216 +215 @@
                 return nullPMC
             _ -> do
-                pmc     <- genLV "app"
+                pmc     <- genScalar "app"
                 -- XXX - probe if funC is slurpy, then modify ExpLV pmc accordingly
                 tellIns $ [reg pmc] <-& funC $ argsC
@@ -222 +221 @@
         -}
     trans x = transError x
-
-fetchCC :: LValue -> Expression -> CodeGen ()
-fetchCC cc begL | parrotBrokenXXX = do
-    tellIns $ tempINT   <-- "get_addr" $ [begL]
-    tellIns $ tempSTR   <:= tempINT
-    tellIns $ "find_global" .- [reg cc, tempSTR]
-fetchCC cc _ = do
-    tellIns $ "get_params" .- sigList [reg cc]
 
 -- XXX - slow way of implementing "return"
@@ -240 +231 @@
     body
     tellLabel retL
-    tellIns $ tempPMC <:= ExpLV (errPMC `KEYED` lit False)
+    tellIns $ ("get_results" .- sigList [tempPMC, tempSTR])
     tellIns $ "clear_eh" .- []
-    tellIns $ tempSTR <-- "typeof" $ [errPMC]
+    tellIns $ tempSTR <-- "typeof" $ [tempPMC]
     tellIns $ "eq" .- [tempSTR, lit "Exception", bare errL]
     tellIns $ "set_returns" .- sigList [tempPMC]
     tellIns $ "returncc" .- []
     tellLabel errL
-    tellIns $ "throw" .- [errPMC]
+    tellIns $ "throw" .- [tempPMC]
 
 prmToSig :: Param -> Sig
@@ -275 +266 @@
                 tellIns $ VAR name <:= expC
         tellLabel defC
-    tellIns $ "store_lex" .- [lit curPad, lit var, bare name]
+    tellIns $ "store_lex" .- [lit var, bare name]
     where
     var     = paramName prm
@@ -291 +282 @@
 lastPMC = do
     tvar    <- asks tReg
-    name'   <- liftIO $ liftSTM $ do
+    liftIO $ liftSTM $ do
         (cur, name) <- readTVar tvar
-        return $ ('P':show cur) ++ (if null name then name else ('_':name))
-    return $ reg (VAR name')
+        return $ case cur of
+            0 -> nullPMC
+            _ -> reg (VAR (('p':show cur) ++ (if null name then name else ('_':name))))
 
 genPMC :: (RegClass a) => String -> CodeGen a
@@ -302 +294 @@
         (cur, _) <- readTVar tvar
         writeTVar tvar (cur + 1, name)
-        return $ ('P':show (cur + 1)) ++ ('_':name)
+        return $ ('p':show (cur + 1)) ++ ('_':name)
     tellIns $ InsLocal RegPMC name'
     return $ reg (VAR name')
 
-genLV :: (RegClass a) => String -> CodeGen a
-genLV name = do
+genWith :: (RegClass a) => (LValue -> Ins) -> String -> CodeGen a
+genWith f name = do
     pmc <- genPMC name
-    tellIns $ InsNew pmc PerlScalar
+    tellIns $ f pmc
     return $ reg pmc
+
+genScalar :: (RegClass a) => String -> CodeGen a
+genScalar = genWith (`InsNew` PerlScalar)
+
+genArray :: (RegClass a) => String -> CodeGen a
+genArray = genWith (`InsNew` PerlArray)
+
+genHash :: (RegClass a) => String -> CodeGen a
+genHash = genWith (`InsNew` PerlHash)
 
 genLabel :: [String] -> CodeGen [LabelName]
@@ -335 +336 @@
 varInit x       = internalError $ "Invalid name: " ++ x
 
+genPIR_YAML :: Eval Val
+genPIR_YAML = genPIRWith $ \globPIR mainPIR _ -> do
+    yaml <- liftIO (showYaml (mainPIR, globPIR))
+    return (VStr yaml)
+
 {-| Compiles the current environment to PIR code. -}
 genPIR :: Eval Val
-genPIR = do
-    tenv        <- initTEnv
-    -- Load the PIR Prelude.
-    local (\env -> env{ envDebug = Nothing }) $ do
-        opEval style "<prelude-pir>" preludeStr
-    penv        <- compile ()
-    globPIR     <- runCodeGenGlob tenv (pilGlob penv)
-    mainPIR     <- runCodeGenMain tenv (pilMain penv)
+genPIR = genPIRWith $ \globPIR mainPIR penv -> do
     libs        <- liftIO $ getLibs
     return . VStr . unlines $
@@ -350 +349 @@
         , renderStyle (Style PageMode 0 0) $ preludePIR $+$ vcat
         -- Namespaces have bugs in both pugs and parrot.
-        [ emit globPIR
-        , emit $ DeclNS "main"
+        [ emit $ DeclNS "main"
         [ DeclSub "init" [SubMAIN, SubANON] $ map StmtIns (
             -- Eventually, we'll have to write our own find_name wrapper (or
             -- fix Parrot's find_name appropriately). See Pugs.Eval.Var.
             -- For now, we simply store $P0 twice.
-            [ "new_pad" .- [lit0]
-            , InsNew tempPMC PerlEnv
+            [ InsNew tempPMC PerlEnv
             , "store_global"    .- [lit "%*ENV", tempPMC]
             , "store_global"    .- [lit "%ENV", tempPMC]
@@ -392 +389 @@
             , StmtIns $ "invokecc" .- [tempPMC]
             ]
-        , DeclSub "main" [SubANON] [ StmtRaw $ emit mainPIR ]
-        ] ] ]
+        , DeclSub "main" [SubANON] (concatMap vivifySub globPIR ++ mainPIR) ]
+        , emit globPIR ] ]
+
+vivifySub :: Decl -> [Stmt]
+vivifySub (DeclNS "main" decls) = concatMap vivifySub decls
+vivifySub (DeclSub name@('&':c:_') [SubOUTER "main"] _)
+    | c /= '*'
+    = map StmtIns
+        [ tempPMC <-- "find_name" $ [lit name]
+        , tempPMC <-- "newclosure" $ [tempPMC]
+        , "store_global" .- [lit "main", lit name, tempPMC]
+        ]
+vivifySub _ = []
+
+genPIRWith f = do
+    tenv        <- initTEnv
+    -- Load the PIR Prelude.
+    local (\env -> env{ envDebug = Nothing }) $ do
+        opEval style "<prelude-pir>" preludeStr
+    penv        <- compile ()
+    globPIR     <- runCodeGenGlob tenv (pilGlob penv)
+    mainPIR     <- runCodeGenMain tenv (pilMain penv)
+    f globPIR mainPIR penv
     where
     style = MkEvalStyle