Changeset 6229
- Timestamp:
- 08/13/05 21:16:15 (3 years ago)
- svk:copy_cache_prev:
- 8452
- Location:
- src/Pugs
- Files:
-
- 3 modified
-
CodeGen/PIL.hs (modified) (2 diffs)
-
CodeGen/PIR.hs (modified) (10 diffs)
-
Compile.hs (modified) (18 diffs)
Legend:
- Unmodified
- Added
- Removed
-
src/Pugs/CodeGen/PIL.hs
r5891 r6229 5 5 import Pugs.Internals 6 6 import Pugs.AST 7 import Emit.PIR8 7 import Pugs.Compile 9 8 … … 12 11 glob <- askGlobal 13 12 main <- asks envBody 14 globPIL <- compile glob :: Eval [PIL 15 mainPIL <- compile main :: Eval (PIL [Stmt])13 globPIL <- compile glob :: Eval [PIL_Decl] 14 mainPIL <- compile main :: Eval PIL_Stmts 16 15 return . VStr . unlines $ 17 16 [ "PIL_Environment" -
src/Pugs/CodeGen/PIR.hs
r5891 r6229 9 9 statements, etc.) to an abstract syntax tree ('PIL' -- Pugs Intermediate 10 10 Language) using the 'compile' function and 'Compile' class, and then 11 translate the PIL 11 translate the PIL_to a data structure of type 'PIR' using the 'trans' 12 12 function and 'Translate' class. This data structure is then reduced to 13 13 final PIR code by "Emit.PIR". … … 45 45 ++ (show $ typeOf (undefined :: b)) 46 46 47 instance (Typeable a) => Translate (PIL a) awhere47 instance Translate PIL_Stmts [Stmt] where 48 48 trans PNil = return [] 49 trans (PStmts this rest) = do 50 thisC <- trans this 51 tell [thisC] 52 trans rest 53 trans (PPad SMy pad exps) = do 54 valsC <- mapM trans (map snd pad) 55 pass $ do 56 expsC <- trans exps 57 return ([], (StmtPad (map fst pad `zip` valsC) expsC:)) 58 trans (PPad _ pad exps) = do 59 -- XXX - maybe warn about bad pads? 60 trans (PPad SMy pad exps) 61 62 instance Translate PIL_Stmt Stmt where 49 63 trans PNoop = return (StmtComment "") 64 trans (PStmt (PLit (PVal VUndef))) = return $ StmtComment "" 65 trans (PStmt exp) = do 66 expC <- trans exp 67 return $ StmtIns $ InsExp expC 50 68 trans (PPos pos exp rest) = do 51 69 dep <- asks tTokDepth … … 54 72 tell [StmtComment $ (replicate dep ' ') ++ "}}} " ++ pretty pos] 55 73 return expC 74 75 instance Translate PIL_Expr Expression where 76 trans (PRawName name) = fmap ExpLV $ genName name 77 trans (PExp exp) = fmap ExpLV $ trans exp 56 78 trans (PLit (PVal VUndef)) = do 57 79 pmc <- genLV "undef" … … 63 85 tellIns $ pmc <== ExpLit litC 64 86 return $ ExpLV pmc 87 trans (PThunk exp) = do 88 [begL, sndL, retL, endL] <- genLabel ["thunkBegin", "thunkAgain", "thunkReturn", "thunkEnd"] 89 this <- genPMC "block" 90 tellIns $ "newsub" .- [reg this, bare ".Continuation", bare begL] 91 tellIns $ "goto" .- [bare endL] 92 tellLabel begL 93 cc <- genPMC "cc" 94 fetchCC cc (reg this) 95 expC <- trans exp 96 tellIns $ "set_addr" .- [reg this, bare sndL] 97 tellIns $ "goto" .- [bare retL] 98 tellLabel sndL 99 fetchCC cc (reg this) 100 tellLabel retL 101 tellIns $ if parrotBrokenXXX 102 then "store_global" .- [tempSTR, expC] 103 else "set_args" .- [lit "(0b10)", expC] 104 tellIns $ "invoke" .- [reg cc] 105 tellLabel endL 106 return (ExpLV this) 107 trans (PCode styp params body) = do 108 [begL, endL] <- genLabel ["blockBegin", "blockEnd"] 109 this <- genPMC "block" 110 tellIns $ "newsub" .- [reg this, bare ".Closure", bare begL] 111 tellIns $ "goto" .- [bare endL] 112 tellLabel begL 113 let prms = map tpParam params 114 mapM_ (tellIns . InsLocal RegPMC . prmToIdent) prms 115 tellIns $ "get_params" .- sigList (map prmToSig prms) 116 tellIns $ "new_pad" .- [lit curPad] 117 wrapSub styp $ do 118 mapM storeLex params 119 trans body -- XXX - consistency check 120 bodyC <- lastPMC 121 tellIns $ "set_returns" .- retSigList [bodyC] 122 tellIns $ "returncc" .- [] 123 tellLabel endL 124 return (ExpLV this) 125 126 instance Translate PIL_Decl Decl where 127 trans (PSub name styp params body) | Just (pkg, name') <- isQualified name = do 128 declC <- trans $ PSub name' styp params body 129 return $ DeclNS pkg [declC] 130 trans (PSub name styp params body) = do 131 (_, stmts) <- listen $ do 132 let prms = map tpParam params 133 mapM_ (tellIns . InsLocal RegPMC . prmToIdent) prms 134 tellIns $ "get_params" .- sigList (map prmToSig prms) 135 tellIns $ "new_pad" .- [lit curPad] 136 wrapSub styp $ do 137 mapM storeLex params 138 trans body 139 bodyC <- lastPMC 140 tellIns $ "set_returns" .- retSigList [bodyC] 141 tellIns $ "returncc" .- [] 142 return (DeclSub name [] stmts) 143 144 instance Translate PIL_Literal Literal where 65 145 trans (PVal (VBool bool)) = return $ LitInt (toInteger $ fromEnum bool) 66 146 trans (PVal (VStr str)) = return $ LitStr str … … 70 150 trans (PVal (VList [])) = return $ LitInt 0 -- XXX Wrong 71 151 trans val@(PVal _) = transError val 152 153 instance Translate PIL_LValue LValue where 72 154 trans (PVar name) | Just (pkg, name') <- isQualified name = do 73 155 -- XXX - this is terribly ugly. Fix at parrot side perhaps? … … 88 170 tellIns $ pmc <-- "find_name" $ [lit $ possiblyFixOperatorName name] 89 171 return pmc 90 trans (PStmt (PLit (PVal VUndef))) = return $ StmtComment ""91 trans (PStmt exp) = do92 expC <- trans exp93 return $ StmtIns $ InsExp expC94 172 trans (PAssign [lhs] rhs) = do 95 173 lhsC <- enter tcLValue $ trans lhs … … 107 185 tellIns $ lhsC <:= rhsC 108 186 return lhsC 109 trans (PStmts this rest) = do110 thisC <- trans this111 tell [thisC]112 trans rest113 187 trans (PApp _ exp@(PCode _ _ _) Nothing []) = do 114 188 blockC <- trans exp … … 143 217 return pmc 144 218 -} 145 trans (PPad SMy pad exps) = do146 valsC <- mapM trans (map snd pad)147 pass $ do148 expsC <- trans exps149 return ([], (StmtPad (map fst pad `zip` valsC) expsC:))150 trans (PExp exp) = fmap ExpLV $ trans exp151 trans (PCode styp params body) = do152 [begL, endL] <- genLabel ["blockBegin", "blockEnd"]153 this <- genPMC "block"154 tellIns $ "newsub" .- [reg this, bare ".Closure", bare begL]155 tellIns $ "goto" .- [bare endL]156 tellLabel begL157 let prms = map tpParam params158 mapM_ (tellIns . InsLocal RegPMC . prmToIdent) prms159 tellIns $ "get_params" .- sigList (map prmToSig prms)160 tellIns $ "new_pad" .- [lit curPad]161 wrapSub styp $ do162 mapM storeLex params163 trans body -- XXX - consistency check164 bodyC <- lastPMC165 tellIns $ "set_returns" .- retSigList [bodyC]166 tellIns $ "returncc" .- []167 tellLabel endL168 return (ExpLV this)169 trans (PThunk exp) = do170 [begL, sndL, retL, endL] <- genLabel ["thunkBegin", "thunkAgain", "thunkReturn", "thunkEnd"]171 this <- genPMC "block"172 tellIns $ "newsub" .- [reg this, bare ".Continuation", bare begL]173 tellIns $ "goto" .- [bare endL]174 tellLabel begL175 cc <- genPMC "cc"176 fetchCC cc (reg this)177 expC <- trans exp178 tellIns $ "set_addr" .- [reg this, bare sndL]179 tellIns $ "goto" .- [bare retL]180 tellLabel sndL181 fetchCC cc (reg this)182 tellLabel retL183 tellIns $ if parrotBrokenXXX184 then "store_global" .- [tempSTR, expC]185 else "set_args" .- [lit "(0b10)", expC]186 tellIns $ "invoke" .- [reg cc]187 tellLabel endL188 return (ExpLV this)189 trans (PRawName name) = fmap ExpLV $ genName name190 trans (PSub name styp params body) | Just (pkg, name') <- isQualified name = do191 declC <- trans $ PSub name' styp params body192 return $ DeclNS pkg [declC]193 trans (PSub name styp params body) = do194 (_, stmts) <- listen $ do195 let prms = map tpParam params196 mapM_ (tellIns . InsLocal RegPMC . prmToIdent) prms197 tellIns $ "get_params" .- sigList (map prmToSig prms)198 tellIns $ "new_pad" .- [lit curPad]199 wrapSub styp $ do200 mapM storeLex params201 trans body202 bodyC <- lastPMC203 tellIns $ "set_returns" .- retSigList [bodyC]204 tellIns $ "returncc" .- []205 return (DeclSub name [] stmts)206 219 trans x = transError x 207 220 … … 372 385 , InsNew tempPMC PerlScalar 373 386 , "store_global" .- [lit "$_", tempPMC] 374 ]) ++ [ StmtRaw (text (name ++ "()")) | PSub name@('_':'_':_) _ _ _ <- globPIL 387 ]) ++ [ StmtRaw (text (name ++ "()")) | PSub name@('_':'_':_) _ _ _ <- globPIL] ++ 375 388 [ StmtRaw (text "main()") 376 389 , StmtIns $ tempPMC <-- "find_global" $ [lit "Perl6::Internals", lit "&exit"] … … 386 399 } 387 400 388 runCodeGenGlob :: TEnv -> [PIL 401 runCodeGenGlob :: TEnv -> [PIL_Decl] -> Eval [Decl] 389 402 runCodeGenGlob tenv = mapM $ fmap fst . runCodeGen tenv 390 403 391 runCodeGenMain :: TEnv -> PIL [Stmt]-> Eval [Stmt]404 runCodeGenMain :: TEnv -> PIL_Stmts -> Eval [Stmt] 392 405 runCodeGenMain tenv = fmap snd . runCodeGen tenv 393 406 -
src/Pugs/Compile.hs
r6195 r6229 12 12 13 13 module Pugs.Compile ( 14 PIL (..),14 PIL_Stmts(..), PIL_Stmt(..), PIL_Expr(..), PIL_Decl(..), PIL_Literal(..), PIL_LValue(..), 15 15 Compile(..), 16 16 TEnv(..), initTEnv, … … 35 35 -} 36 36 37 #ifndef HADDOCK 38 -- Type-indexed with GADT; it is a bit too baroque -- refactor toward ANF? 39 data (Typeable a) => PIL a where 40 PNil :: PIL [a] 41 PNoop :: PIL Stmt 42 43 PPos :: !Pos -> !Exp -> !(PIL a) -> PIL a 44 PRawName :: !VarName -> PIL Expression -- XXX HACK! 45 46 PVal :: !Val -> PIL Literal 47 PVar :: !VarName -> PIL LValue 48 49 PExp :: !(PIL LValue) -> PIL Expression 50 PLit :: !(PIL Literal) -> PIL Expression 51 PThunk :: !(PIL Expression) -> PIL Expression 52 PCode :: !SubType -> ![TParam] -> !(PIL [Stmt]) -> PIL Expression 53 54 PStmt :: !(PIL Expression) -> PIL Stmt 55 PStmts :: !(PIL Stmt) -> !(PIL [Stmt]) -> PIL [Stmt] 56 57 PApp :: !TCxt -> !(PIL Expression) -> !(Maybe (PIL Expression)) -> ![PIL Expression] -> PIL LValue 58 PAssign :: ![PIL LValue] -> !(PIL Expression) -> PIL LValue 59 PBind :: ![PIL LValue] -> !(PIL Expression) -> PIL LValue 60 61 -- The New Pad: Occurs at whenever a variable may occur 62 -- PPad :: !Scope -> !VarName -> PIL LValue 63 64 PPad :: !Scope -> ![(VarName, PIL Expression)] -> !(PIL [Stmt]) -> PIL [Stmt] 65 PSub :: !SubName -> !SubType -> ![TParam] -> !(PIL [Stmt]) -> PIL Decl 66 #endif 67 68 instance Typeable1 PIL where 69 typeOf1 _ = typeOf () 37 data PIL_Stmts = PNil 38 | PStmts 39 { pStmt :: !PIL_Stmt 40 , pStmts :: !PIL_Stmts 41 } 42 | PPad 43 { pScope :: !Scope 44 , pSyms :: ![(VarName, PIL_Expr)] 45 , pStmts :: !PIL_Stmts 46 } 47 deriving (Show, Eq, Ord, Typeable) 48 49 data PIL_Stmt = PNoop | PStmt { pExpr :: !PIL_Expr } | PPos 50 { pPos :: !Pos 51 , pExp :: !Exp 52 , pNode :: !PIL_Stmt 53 } 54 deriving (Show, Eq, Ord, Typeable) 55 56 data PIL_Expr 57 = PRawName { pRawName :: !VarName } 58 | PExp { pLV :: !PIL_LValue } 59 | PLit { pLit :: !PIL_Literal } 60 | PThunk { pThunk :: !PIL_Expr } 61 | PCode 62 { pType :: !SubType 63 , pParams :: ![TParam] 64 , pBody :: !PIL_Stmts 65 } 66 deriving (Show, Eq, Ord, Typeable) 67 68 data PIL_Decl = PSub 69 { pSubName :: !SubName 70 , pSubType :: !SubType 71 , pSubParams :: ![TParam] 72 , pSubBody :: !PIL_Stmts 73 } 74 deriving (Show, Eq, Ord, Typeable) 75 76 data PIL_Literal = PVal { pVal :: Val } 77 deriving (Show, Eq, Ord, Typeable) 78 79 data PIL_LValue = PVar { pVarName :: !VarName } 80 | PApp 81 { pCxt :: !TCxt 82 , pFun :: !PIL_Expr 83 , pInv :: !(Maybe PIL_Expr) 84 , pArgs :: ![PIL_Expr] 85 } 86 | PAssign 87 { pLHS :: ![PIL_LValue] 88 , pRHS :: !PIL_Expr 89 } 90 | PBind 91 { pLHS :: ![PIL_LValue] 92 , pRHS :: !PIL_Expr 93 } 94 deriving (Show, Eq, Ord, Typeable) 70 95 71 96 data TParam = MkTParam 72 97 { tpParam :: !Param 73 , tpDefault :: !(Maybe (PIL Expression))98 , tpDefault :: !(Maybe (PIL_Expr)) 74 99 } 75 deriving (Show, Typeable)100 deriving (Show, Eq, Ord, Typeable) 76 101 77 102 data TCxt 78 103 = TCxtVoid | TCxtLValue !Type | TCxtItem !Type | TCxtSlurpy !Type 79 104 | TTailCall !TCxt 80 deriving (Show, Eq, Typeable)105 deriving (Show, Eq, Ord, Typeable) 81 106 82 107 tcVoid, tcLValue :: TCxt … … 89 114 tcSlurpy = TCxtSlurpy anyType 90 115 -} 91 92 instance Show (PIL a) where93 show (PVal x) = "(PVal " ++ show x ++ ")"94 show (PVar x) = "(PVar " ++ show x ++ ")"95 show (PLit x) = "(PLit " ++ show x ++ ")"96 show (PStmts x y) = "(PStmts " ++ show x ++ " " ++ show y ++ ")"97 show PNil = "PNil"98 show PNoop = "PNoop"99 -- We don't show the raw Exp here to ease writing parsers for PIL (Exp100 -- contains things like MkEnv, etc.).101 show (PPos x _ z) = "(PPos " ++ show x ++ " Noop " ++ show z ++ ")"102 show (PApp x y i z) = "(PApp " ++ show x ++ " " ++ show y ++ " " ++ show i ++ " " ++ show z ++ ")"103 show (PExp x) = "(PExp " ++ show x ++ ")"104 show (PStmt x) = "(PStmt " ++ show x ++ ")"105 show (PAssign x y) = "(PAssign " ++ show x ++ " " ++ show y ++ ")"106 show (PBind x y) = "(PBind " ++ show x ++ " " ++ show y ++ ")"107 show (PThunk x) = "(PThunk " ++ show x ++ ")"108 show (PRawName x) = "(PRawName " ++ show x ++ ")"109 show (PPad x y z) = unwords ["(PPad", show x, show y, show z, ")"]110 show (PCode x y z) = unwords ["(PCode", show x, show y, show z, ")"]111 show (PSub x y z w) = unwords ["(PSub", show x, show y, show z, show w, ")"]112 116 113 117 data TEnv = MkTEnv … … 118 122 , tLabel :: !(TVar Int) -- ^ Label name supply 119 123 } 120 deriving (Show, Eq )124 deriving (Show, Eq, Ord, Typeable) 121 125 122 126 type Comp a = Eval a … … 129 133 130 134 -- Compile instances 131 instance Compile (Var, [(TVar Bool, TVar VRef)]) (PIL 135 instance Compile (Var, [(TVar Bool, TVar VRef)]) (PIL_Decl) where 132 136 compile = compError 133 137 … … 142 146 } 143 147 144 {-| Compiles a 'Pad' to a list of 'PIL 148 {-| Compiles a 'Pad' to a list of 'PIL_Decl's. Currently, only subroutines and 145 149 @\@*END@ are compiled. -} 146 instance Compile Pad [PIL 150 instance Compile Pad [PIL_Decl] where 147 151 compile pad = do 148 152 entries' <- mapM canCompile entries … … 164 168 cvList <- fromVals =<< readRef ref :: Comp [VCode] 165 169 decls <- eachM cvList $ \(i, cv) -> do 166 compile (("&*END_" ++ show i), cv) :: Comp [PIL 170 compile (("&*END_" ++ show i), cv) :: Comp [PIL_Decl] 167 171 compile ("&*END", concat decls) 168 172 canCompile ((_:twigil:_), _) | not (isAlphaNum twigil) = return [] … … 186 190 eachM = forM . ([0..] `zip`) 187 191 188 instance Compile (SubName, [PIL Decl]) [PILDecl] where192 instance Compile (SubName, [PIL_Decl]) [PIL_Decl] where 189 193 compile (name, decls) = do 190 194 let bodyC = [ PStmts . PStmt . PExp $ PApp tcVoid (PExp (PVar sub)) Nothing [] … … 193 197 return (PSub name SubPrim [] (combine bodyC PNil):decls) 194 198 195 instance Compile (SubName, VCode) [PIL 199 instance Compile (SubName, VCode) [PIL_Decl] where 196 200 compile (name, vsub) | packageOf name /= packageOf (subName vsub) = do 197 201 let storeC = PBind [PVar $ qualify name] (PExp . PVar . qualify $ subName vsub) … … 206 210 return [PSub name (subType vsub) paramsC bodyC] 207 211 208 instance Compile (String, [(TVar Bool, TVar VRef)]) (PIL Expression) where212 instance Compile (String, [(TVar Bool, TVar VRef)]) (PIL_Expr) where 209 213 compile (name, _) = return $ PRawName name 210 214 211 instance Compile Exp (PIL [Stmt]) where212 compile (Pos pos rest) =fmap (PPos pos rest) $ compile rest215 instance Compile Exp (PIL_Stmts) where 216 compile (Pos _ rest) = compile rest -- fmap (PPos pos rest) $ compile rest 213 217 compile (Cxt cxt rest) = enter cxt $ compile rest 214 218 compile (Stmts (Pad SOur _ exp) rest) = do … … 229 233 enter cxt = local (\e -> e{ envContext = cxt }) 230 234 231 compileStmts :: Exp -> Comp (PIL [Stmt])235 compileStmts :: Exp -> Comp (PIL_Stmts) 232 236 compileStmts exp = case exp of 233 237 Stmts this Noop -> do … … 250 254 _ -> compile (Stmts exp Noop) 251 255 252 instance Compile Val (PIL 256 instance Compile Val (PIL_Stmt) where 253 257 compile = fmap PStmt . compile . Val 254 258 255 instance Compile Val (PIL Expression) where259 instance Compile Val (PIL_Expr) where 256 260 compile = compile . Val 257 261 258 instance Compile Exp (PIL 262 instance Compile Exp (PIL_Stmt) where 259 263 compile (Pos pos rest) = fmap (PPos pos rest) $ compile rest 260 264 compile (Cxt cxt rest) = enter cxt $ compile rest … … 299 303 compile exp = fmap PStmt $ compile exp 300 304 301 pBlock :: PIL [Stmt] -> PIL Expression305 pBlock :: PIL_Stmts -> PIL_Expr 302 306 pBlock = PCode SubBlock [] 303 307 … … 330 334 compile x = compError x 331 335 332 instance Compile Exp (PIL 333 compile (Pos pos rest) =fmap (PPos pos rest) $ compile rest336 instance Compile Exp (PIL_LValue) where 337 compile (Pos _ rest) = compile rest -- fmap (PPos pos rest) $ compile rest 334 338 compile (Cxt cxt rest) = enter cxt $ compile rest 335 339 compile (Var name) = return $ PVar name … … 391 395 compile exp = compError exp 392 396 393 compLoop :: Exp -> Comp (PIL 397 compLoop :: Exp -> Comp (PIL_Stmt) 394 398 compLoop (Syn name [cond, body]) = do 395 399 cxt <- askTCxt … … 403 407 appropriate function call (@&statement_control:if@ or 404 408 @&statement_control:unless@). -} 405 compConditional :: Exp -> Comp (PIL 409 compConditional :: Exp -> Comp (PIL_LValue) 406 410 compConditional (Syn name exps) = do 407 411 [condC, trueC, falseC] <- compile exps … … 411 415 compConditional exp = compError exp 412 416 413 {-| Compiles various 'Exp's to 'PIL Expression's. -}414 instance Compile Exp (PIL Expression) where415 compile (Pos pos rest) =fmap (PPos pos rest) $ compile rest417 {-| Compiles various 'Exp's to 'PIL_Expr's. -} 418 instance Compile Exp (PIL_Expr) where 419 compile (Pos _ rest) = compile rest -- fmap (PPos pos rest) $ compile rest 416 420 compile (Cxt cxt rest) = enter cxt $ compile rest 417 421 compile (Var name) = return . PExp $ PVar name … … 442 446 ++ (show $ typeOf (undefined :: b)) 443 447 444 {-| Compiles a 'Val' to a 'PIL 445 instance Compile Val (PIL 448 {-| Compiles a 'Val' to a 'PIL_Literal'. -} 449 instance Compile Val (PIL_Literal) where 446 450 compile val = return $ PVal val 447 451
