Changeset 8681

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.

Location:

src

Files:

• Emit/PIR.hs (modified) (14 diffs)
• Emit/PIR.hs-drift (modified) (1 diff)
• Pugs/CodeGen.hs (modified) (3 diffs)
• Pugs/CodeGen/PIR.hs (modified) (17 diffs)
• Pugs/Embed/Parrot.hsc (modified) (2 diffs)

src/Emit/PIR.hs

@@ -1 +1 @@
 {-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances -fno-warn-orphans -funbox-strict-fields -cpp #-}
+{- Generated by DrIFT (Automatic class derivations for Haskell) -}
+{-# LINE 1 "src/Emit/PIR.hs-drift" #-}
 
 {-|
@@ -18 +20 @@
 import Data.Typeable
 import Emit.Common
+import DrIFT.YAML
 import Text.PrettyPrint
+
+{-! global : YAML !-}
 
 {-| PIR code consists of declarations. -}
@@ -24 +29 @@
 
 data Decl
-    = DeclSub       !SubName ![SubFlag] ![Stmt]  -- ^ Subroutine declaration
-    | DeclNS        !PkgName ![Decl]             -- ^ Namespace declaration
-    | DeclInc       !FilePath                    -- ^ @.include@ directive
+    = DeclSub                           -- ^ Subroutine declaration
+        { dsName    :: !SubName
+        , dsFlags   :: ![SubFlag]
+        , dsBody    :: ![Stmt]
+        } 
+    | DeclNS                            -- ^ Namespace declaration
+        { dnPackage :: !PkgName
+        , dnBody    :: ![Decl]
+        }
+    | DeclInc                           -- ^ @.include@ directive
+        { diFile    :: !FilePath
+        }
     deriving (Show, Eq, Typeable)
 
@@ -35 +49 @@
     | StmtRaw       !Doc                     -- ^ Backdoor into raw @Doc@
     | StmtIns       !Ins                     -- ^ Generic instructions
+    | StmtSub       !SubName ![Stmt]         -- ^ Inner subroutine
     deriving (Show, Eq, Typeable)
 
@@ -73 +88 @@
 {-| Tags a PIR subroutine definition with @\@MAIN@, @\@LOAD@, @\@ANON@,
     @\@METHOD@, or @\@MULTI@. -}
-data SubFlag = SubMAIN | SubLOAD | SubANON | SubMETHOD | SubMULTI [ObjType]
+data SubFlag = SubMAIN | SubLOAD | SubANON | SubMETHOD | SubMULTI ![ObjType] | SubOUTER !SubName
     deriving (Show, Eq, Typeable)
 
@@ -107 +122 @@
         ]
     emit (DeclInc name) = emit ".include" <+> (quotes $ emit name)
+    -- Perform λ-lifting here
     emit (DeclSub name styps stmts)
         =  (emit ".sub" <+> doubleQuotes (emit $ quoted name) <+> commaSep styps)
-        $+$ nested (emitBody stmts)
+        $+$ nested (emitStmts stmts)
         $+$ emit ".end"
-        where
-        emitBody [] = []
-        emitBody [(StmtIns (InsFun _ name args))] = [emit $ StmtIns (InsTailFun name args)]
-        emitBody (x:xs) = emit x : emitBody xs
+        $+$ emit [DeclSub name' [SubANON, SubOUTER name] body' | StmtSub name' body' <- stmts ]
+
+emitStmts :: [Stmt] -> Doc
+emitStmts stmts = vcat (emitLex:emitBody stmts)
+    where
+    emitBody [] = []
+    emitBody [(StmtIns (InsFun _ name args))] = [emit $ StmtIns (InsTailFun name args)]
+    emitBody (x:xs) = emit x : emitBody xs
+    emitLex = vcat (map emitVar $ nub (concat [ pad | StmtPad pad _ <- stmts ]))
+    emitVar :: (VarName, Expression) -> Doc
+    emitVar (var, exp@(ExpLV (VAR name)))
+        = emit (InsLocal RegPMC name)
+        $+$ emit ".lex" <+> commaSep [emit (lit var), emit exp]
+    emitVar _ = empty
 
 {-| Emits PIR code for a 'SubFlag' (e.g. @\@MAIN@, @\@ANON@, etc.). -}
 instance Emit SubFlag where
-    emit = emit . ('@':) . drop 3 . show
+    emit (SubOUTER x) = colon <> text "outer" <> parens (doubleQuotes $ emit x)
+    emit x = (emit . ('@':) . drop 3 . show) x
 
 curPad :: Int
@@ -129 +156 @@
     emit (StmtIns ins) = emit ins
     emit (StmtPad pad _) = vcat $
+        map (\(var, exp) -> emit ("store_lex" .- [lit var, exp])) pad
+        {-
         [ emit "new_pad" <+> int curPad
-        ] ++ map (\(var, exp) -> emit ("store_lex" .- [lit curPad, lit var, exp])) pad
+        ] ++ 
+        -}
     emit (StmtRaw doc) = doc
+    emit StmtSub{} = empty
 
 instance Emit RegType where
@@ -144 +175 @@
     emit (InsBind ident lit) = eqSep ident "set" [lit]
     emit (InsPrim (Just ret) name args) = eqSep ret name args
-    emit (InsPrim Nothing "store_lex" (_:args)) =
-        -- XXX - horrible hack! perl 4!
-        emit (InsPrim Nothing "store_global" args)
+--  emit (InsPrim Nothing "store_lex" (_:args)) =
+--      -- XXX - horrible hack! perl 4!
+--      emit (InsPrim Nothing "store_global" args)
     emit (InsPrim Nothing name args) = emit name <+> commaSep args
     emit (InsFun rets (ExpLit (LitStr name)) args) = emitFunName "invokecc" name args rets
@@ -251 +282 @@
 lit0 :: Expression
 lit0 = lit (0 :: Int)
-
-{-| @P5@ register -}
-errPMC :: (RegClass a) => a
-errPMC = reg (VAR "P5")
 
 {-| @$P0@ register -}
@@ -543 +570 @@
 bare = ExpLV . VAR
 
-parrotBrokenXXX :: Bool
-parrotBrokenXXX = True
-
-collectCC :: LabelName -> [Ins]
-collectCC label =
-    [ InsLabel label
-    , if parrotBrokenXXX
-        then "find_global" .- [tempPMC, tempSTR]
-        else "get_params" .- sigList [tempPMC]
+collectCC :: [Ins]
+collectCC =
+    [ "set_returns" .- retSigList [tempPMC]
+    , "returncc" .- []
     ]
 
 callThunkCC :: Expression -> [Ins]
-callThunkCC fun | parrotBrokenXXX =
-    [ tempINT   <-- "get_addr" $ [fun]
-    , tempSTR   <:= tempINT
-    , "store_global" .- [tempSTR, funPMC]
-    , "invokecc" .- [fun]
-    ]
 callThunkCC fun =
-    [ "set_args" .- sigList [funPMC]
+    [ "set_args" .- sigList []
+    , "get_results" .- sigList [tempPMC]
     , "invokecc" .- [fun]
     ]
@@ -597 +614 @@
     postL = ("sc_" ++ name ++ "_post")
     body = concat
-        [ newCont postL
-        , [ comp .- [arg0, bare altL] ]
+        [ [ comp .- [arg0, bare altL] ]
         , callThunkCC arg1
+        , [ "goto" .- [bare postL] ]
         , [ InsLabel altL ]
-        , callThunkCC arg2,
-        collectCC postL
+        , callThunkCC arg2
+        , [ InsLabel postL ]
+        , collectCC
         ]
-
-newCont :: VarName -> [Ins]
-newCont label =
-    [ InsNew funPMC Continuation
-    , "set_addr" .- [funPMC, bare label]
-    ]
 
 {-| Creates appropriate @&infix:foo@ subs for logical operators (@||@, @&&@,
@@ -619 +631 @@
     where
     altL = ("sc_" ++ escaped name ++ "_alt")
-    postL = ("sc_" ++ escaped name ++ "_post")
-    body = newCont postL ++
+    body =
         [ comp .- [arg0, bare altL]
         , "set_returns" .- retSigList [arg0]
         , "returncc" .- []
         , InsLabel altL
-        ] ++ callThunkCC arg1 ++ collectCC postL
+        ] ++ callThunkCC arg1 ++ collectCC
 
 {-| Escapes characters which have a special meaning in PIR. -}
@@ -639 +650 @@
 preludePIR = emit $
     [ include "iglobals.pasm"
+    , include "errors.pasm"
     -- Control flowy
     , sub "&return" [slurpy arg0]
@@ -955 +967 @@
     ]
 
+instance YAML Doc where
+    asYAML = asYAML . render
+
+------------------------------------------------------------------------
+{-* Generated by DrIFT : Look, but Don't Touch. *-}
+instance YAML Decl where
+    asYAML (DeclSub aa ab ac) = asYAMLmap "DeclSub"
+           [("dsName", asYAML aa) , ("dsFlags", asYAML ab) ,
+            ("dsBody", asYAML ac)]
+    asYAML (DeclNS aa ab) = asYAMLmap "DeclNS"
+           [("dnPackage", asYAML aa) , ("dnBody", asYAML ab)]
+    asYAML (DeclInc aa) = asYAMLmap "DeclInc" [("diFile", asYAML aa)]
+
+instance YAML Stmt where
+    asYAML (StmtComment aa) = asYAMLseq "StmtComment" [asYAML aa]
+    asYAML (StmtLine aa ab) = asYAMLseq "StmtLine"
+           [asYAML aa , asYAML ab]
+    asYAML (StmtPad aa ab) = asYAMLseq "StmtPad"
+           [asYAML aa , asYAML ab]
+    asYAML (StmtRaw aa) = asYAMLseq "StmtRaw" [asYAML aa]
+    asYAML (StmtIns aa) = asYAMLseq "StmtIns" [asYAML aa]
+    asYAML (StmtSub aa ab) = asYAMLseq "StmtSub"
+           [asYAML aa , asYAML ab]
+
+instance YAML Ins where
+    asYAML (InsLocal aa ab) = asYAMLseq "InsLocal"
+           [asYAML aa , asYAML ab]
+    asYAML (InsNew aa ab) = asYAMLseq "InsNew" [asYAML aa , asYAML ab]
+    asYAML (InsBind aa ab) = asYAMLseq "InsBind"
+           [asYAML aa , asYAML ab]
+    asYAML (InsAssign aa ab) = asYAMLseq "InsAssign"
+           [asYAML aa , asYAML ab]
+    asYAML (InsPrim aa ab ac) = asYAMLseq "InsPrim"
+           [asYAML aa , asYAML ab , asYAML ac]
+    asYAML (InsFun aa ab ac) = asYAMLseq "InsFun"
+           [asYAML aa , asYAML ab , asYAML ac]
+    asYAML (InsTailFun aa ab) = asYAMLseq "InsTailFun"
+           [asYAML aa , asYAML ab]
+    asYAML (InsLabel aa) = asYAMLseq "InsLabel" [asYAML aa]
+    asYAML (InsComment aa ab) = asYAMLseq "InsComment"
+           [asYAML aa , asYAML ab]
+    asYAML (InsExp aa) = asYAMLseq "InsExp" [asYAML aa]
+    asYAML (InsConst aa ab ac) = asYAMLseq "InsConst"
+           [asYAML aa , asYAML ab , asYAML ac]
+
+instance YAML Expression where
+    asYAML (ExpLV aa) = asYAMLseq "ExpLV" [asYAML aa]
+    asYAML (ExpLit aa) = asYAMLseq "ExpLit" [asYAML aa]
+
+instance YAML LValue where
+    asYAML (VAR aa) = asYAMLseq "VAR" [asYAML aa]
+    asYAML (PMC aa) = asYAMLseq "PMC" [asYAML aa]
+    asYAML (STR aa) = asYAMLseq "STR" [asYAML aa]
+    asYAML (INT aa) = asYAMLseq "INT" [asYAML aa]
+    asYAML (NUM aa) = asYAMLseq "NUM" [asYAML aa]
+    asYAML (KEYED aa ab) = asYAMLseq "KEYED" [asYAML aa , asYAML ab]
+
+instance YAML Literal where
+    asYAML (LitStr aa) = asYAMLseq "LitStr" [asYAML aa]
+    asYAML (LitInt aa) = asYAMLseq "LitInt" [asYAML aa]
+    asYAML (LitNum aa) = asYAMLseq "LitNum" [asYAML aa]
+
+instance YAML SubFlag where
+    asYAML (SubMAIN) = asYAMLcls "SubMAIN"
+    asYAML (SubLOAD) = asYAMLcls "SubLOAD"
+    asYAML (SubANON) = asYAMLcls "SubANON"
+    asYAML (SubMETHOD) = asYAMLcls "SubMETHOD"
+    asYAML (SubMULTI aa) = asYAMLseq "SubMULTI" [asYAML aa]
+    asYAML (SubOUTER aa) = asYAMLseq "SubOUTER" [asYAML aa]
+
+instance YAML RegType where
+    asYAML (RegInt) = asYAMLcls "RegInt"
+    asYAML (RegNum) = asYAMLcls "RegNum"
+    asYAML (RegStr) = asYAMLcls "RegStr"
+    asYAML (RegPMC) = asYAMLcls "RegPMC"
+
+instance YAML ObjType where
+    asYAML (PerlScalar) = asYAMLcls "PerlScalar"
+    asYAML (PerlArray) = asYAMLcls "PerlArray"
+    asYAML (PerlHash) = asYAMLcls "PerlHash"
+    asYAML (PerlInt) = asYAMLcls "PerlInt"
+    asYAML (PerlPair) = asYAMLcls "PerlPair"
+    asYAML (PerlRef) = asYAMLcls "PerlRef"
+    asYAML (PerlEnv) = asYAMLcls "PerlEnv"
+    asYAML (Sub) = asYAMLcls "Sub"
+    asYAML (Closure) = asYAMLcls "Closure"
+    asYAML (Continuation) = asYAMLcls "Continuation"
+    asYAML (BareType aa) = asYAMLseq "BareType" [asYAML aa]
+
+instance YAML Sig where
+    asYAML (MkSig aa ab) = asYAMLmap "MkSig"
+           [("sigFlags", asYAML aa) , ("sigIdent", asYAML ab)]
+
+instance YAML ArgFlag where
+    asYAML (MkArgFlatten) = asYAMLcls "MkArgFlatten"
+    asYAML (MkArgSlurpyArray) = asYAMLcls "MkArgSlurpyArray"
+    asYAML (MkArgMaybeFlatten) = asYAMLcls "MkArgMaybeFlatten"
+    asYAML (MkArgOptional) = asYAMLcls "MkArgOptional"
+
+--  Imported from other files :-

src/Emit/PIR.hs-drift

@@ -648 +648 @@
 preludePIR = emit $
     [ include "iglobals.pasm"
+    , include "errors.pasm"
     -- Control flowy
     , sub "&return" [slurpy arg0]

src/Pugs/CodeGen.hs

@@ -15 +15 @@
 import Pugs.CodeGen.PIL1 (genPIL1)
 import Pugs.CodeGen.PIL2 (genPIL2, genPIL2Perl5, genPIL2Binary, genPIL2JSON, genPIL2YAML)
-import Pugs.CodeGen.PIR (genPIR)
+import Pugs.CodeGen.PIR (genPIR, genPIR_YAML)
 import Pugs.CodeGen.Perl5 (genPerl5)
 import Pugs.CodeGen.YAML (genYAML)
@@ -31 +31 @@
     [ ("GHC",         genGHC)
     , ("PIR",         genPIR)
+    , ("PIR-YAML",    genPIR_YAML)
     , ("PIL1",        genPIL1)
     , ("PIL1-Perl5",  genPerl5)
@@ -54 +55 @@
     norm' "parrot" = "!PIR"
     norm' "pir"    = "PIR"
+    norm' "piryaml"= "PIR-YAML"
     norm' "pil"    = "!PIL1"
     norm' "pil1"   = "PIL1"

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)