Changeset 6229 for src/Pugs/CodeGen/PIR.hs

Timestamp:

08/13/05 21:16:15 (3 years ago)

Author:

autrijus

svk:copy_cache_prev:

8452

Message:

* de-GADT PIL structure -- likely to break all PIL2JS work

Files:

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

src/Pugs/CodeGen/PIR.hs

@@ -9 +9 @@
     statements, etc.) to an abstract syntax tree ('PIL' -- Pugs Intermediate
     Language) using the 'compile' function and 'Compile' class, and then
-    translate the PIL to a data structure of type 'PIR' using the 'trans'
+    translate the PIL_to a data structure of type 'PIR' using the 'trans'
     function and 'Translate' class. This data structure is then reduced to
     final PIR code by "Emit.PIR".
@@ -45 +45 @@
     ++ (show $ typeOf (undefined :: b))
 
-instance (Typeable a) => Translate (PIL a) a where
+instance Translate PIL_Stmts [Stmt] where
     trans PNil = return []
+    trans (PStmts this rest) = do
+        thisC   <- trans this
+        tell [thisC]
+        trans rest
+    trans (PPad SMy pad exps) = do
+        valsC   <- mapM trans (map snd pad)
+        pass $ do
+            expsC   <- trans exps
+            return ([], (StmtPad (map fst pad `zip` valsC) expsC:))
+    trans (PPad _ pad exps) = do
+        -- XXX - maybe warn about bad pads?
+        trans (PPad SMy pad exps)
+
+instance Translate PIL_Stmt Stmt where
     trans PNoop = return (StmtComment "")
+    trans (PStmt (PLit (PVal VUndef))) = return $ StmtComment ""
+    trans (PStmt exp) = do
+        expC    <- trans exp
+        return $ StmtIns $ InsExp expC
     trans (PPos pos exp rest) = do
         dep     <- asks tTokDepth
@@ -54 +72 @@
         tell [StmtComment $ (replicate dep ' ') ++ "}}} " ++ pretty pos]
         return expC
+
+instance Translate PIL_Expr Expression where
+    trans (PRawName name) = fmap ExpLV $ genName name
+    trans (PExp exp) = fmap ExpLV $ trans exp
     trans (PLit (PVal VUndef)) = do
         pmc     <- genLV "undef"
@@ -63 +85 @@
         tellIns $ pmc <== ExpLit litC
         return $ ExpLV pmc
+    trans (PThunk exp) = do
+        [begL, sndL, retL, endL] <- genLabel ["thunkBegin", "thunkAgain", "thunkReturn", "thunkEnd"]
+        this    <- genPMC "block"
+        tellIns $ "newsub" .- [reg this, bare ".Continuation", 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 $ "invoke" .- [reg cc]
+        tellLabel endL
+        return (ExpLV this)
+    trans (PCode styp params body) = do
+        [begL, endL] <- genLabel ["blockBegin", "blockEnd"]
+        this    <- genPMC "block"
+        tellIns $ "newsub" .- [reg this, bare ".Closure", bare begL]
+        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
+        return (ExpLV this)
+
+instance Translate PIL_Decl Decl where
+    trans (PSub name styp params body) | Just (pkg, name') <- isQualified name = do
+        declC <- trans $ PSub name' styp params body
+        return $ DeclNS pkg [declC]
+    trans (PSub name styp params body) = do
+        (_, stmts)  <- listen $ do
+            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
+                bodyC <- 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
@@ -70 +150 @@
     trans (PVal (VList [])) = return $ LitInt 0 -- XXX Wrong
     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?
@@ -88 +170 @@
         tellIns $ pmc <-- "find_name" $ [lit $ possiblyFixOperatorName name]
         return pmc
-    trans (PStmt (PLit (PVal VUndef))) = return $ StmtComment ""
-    trans (PStmt exp) = do
-        expC    <- trans exp
-        return $ StmtIns $ InsExp expC
     trans (PAssign [lhs] rhs) = do
         lhsC    <- enter tcLValue $ trans lhs
@@ -107 +185 @@
         tellIns $ lhsC <:= rhsC
         return lhsC
-    trans (PStmts this rest) = do
-        thisC   <- trans this
-        tell [thisC]
-        trans rest
     trans (PApp _ exp@(PCode _ _ _) Nothing []) = do
         blockC  <- trans exp
@@ -143 +217 @@
                 return pmc
         -}
-    trans (PPad SMy pad exps) = do
-        valsC   <- mapM trans (map snd pad)
-        pass $ do
-            expsC   <- trans exps
-            return ([], (StmtPad (map fst pad `zip` valsC) expsC:))
-    trans (PExp exp) = fmap ExpLV $ trans exp
-    trans (PCode styp params body) = do
-        [begL, endL] <- genLabel ["blockBegin", "blockEnd"]
-        this    <- genPMC "block"
-        tellIns $ "newsub" .- [reg this, bare ".Closure", bare begL]
-        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
-        return (ExpLV this)
-    trans (PThunk exp) = do
-        [begL, sndL, retL, endL] <- genLabel ["thunkBegin", "thunkAgain", "thunkReturn", "thunkEnd"]
-        this    <- genPMC "block"
-        tellIns $ "newsub" .- [reg this, bare ".Continuation", 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 $ "invoke" .- [reg cc]
-        tellLabel endL
-        return (ExpLV this)
-    trans (PRawName name) = fmap ExpLV $ genName name
-    trans (PSub name styp params body) | Just (pkg, name') <- isQualified name = do
-        declC <- trans $ PSub name' styp params body
-        return $ DeclNS pkg [declC]
-    trans (PSub name styp params body) = do
-        (_, stmts)  <- listen $ do
-            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
-                bodyC <- lastPMC
-                tellIns $ "set_returns" .- retSigList [bodyC]
-                tellIns $ "returncc" .- []
-        return (DeclSub name [] stmts)
     trans x = transError x
 
@@ -372 +385 @@
             , InsNew tempPMC PerlScalar
             , "store_global"    .- [lit "$_", tempPMC]
-            ]) ++ [ StmtRaw (text (name ++ "()")) | PSub name@('_':'_':_) _ _ _ <- globPIL ] ++
+            ]) ++ [ StmtRaw (text (name ++ "()")) | PSub name@('_':'_':_) _ _ _ <- globPIL] ++
             [ StmtRaw (text "main()")
             , StmtIns $ tempPMC  <-- "find_global" $ [lit "Perl6::Internals", lit "&exit"]
@@ -386 +399 @@
         }
 
-runCodeGenGlob :: TEnv -> [PIL Decl] -> Eval [Decl]
+runCodeGenGlob :: TEnv -> [PIL_Decl] -> Eval [Decl]
 runCodeGenGlob tenv = mapM $ fmap fst . runCodeGen tenv
 
-runCodeGenMain :: TEnv -> PIL [Stmt] -> Eval [Stmt]
+runCodeGenMain :: TEnv -> PIL_Stmts -> Eval [Stmt]
 runCodeGenMain tenv = fmap snd . runCodeGen tenv