Changeset 4907
- Timestamp:
- 06/22/05 02:41:05 (4 years ago)
- svk:copy_cache_prev:
- 6641
- Location:
- src
- Files:
-
- 3 modified
-
Emit/PIR.hs (modified) (14 diffs)
-
Main.hs (modified) (1 diff)
-
Pugs/Compile/PIR.hs (modified) (35 diffs)
Legend:
- Unmodified
- Added
- Removed
-
src/Emit/PIR.hs
r4891 r4907 12 12 13 13 data Decl 14 = DeclSub !SubName ![SubFlag] ![Stmt] -- ^ Subroutine declaration15 | DeclNS !PkgName-- ^ Namespace declaration16 | DeclInc !FilePath -- ^ @.include@ directive14 = DeclSub !SubName ![SubFlag] ![Stmt] -- ^ Subroutine declaration 15 | DeclNS !PkgName ![Decl] -- ^ Namespace declaration 16 | DeclInc !FilePath -- ^ @.include@ directive 17 17 deriving (Show, Eq, Typeable) 18 18 … … 20 20 = StmtComment !String -- ^ Comment 21 21 | StmtLine !FilePath !Int -- ^ @#line@ directive 22 | StmtIns !Ins 23 | StmtPad ![(VarName, Expression)] ![Stmt] 24 | StmtRaw !Doc -- ^ Backdoor into 25 -- "Pugs.Compile.Parrot". 22 | StmtPad ![(VarName, Expression)] ![Stmt] -- ^ Lexical Pad 23 | StmtRaw !Doc -- ^ Backdoor into raw @Doc@ 24 | StmtIns !Ins -- ^ Generic instructions 26 25 deriving (Show, Eq, Typeable) 27 26 28 27 data Ins 29 = InsLocal !RegType !VarName -- ^ Inserts a@.local@ directive30 | InsNew !LValue !ObjType -- ^ Inserts a@new@ opcode31 | InsBind !LValue !Expression -- ^ Inserts a@set@ opcode32 | InsAssign !LValue !Expression -- ^ Inserts an@assign@ opcode33 | Ins Exp !Expression34 | InsFun ![Sig] !Expression ![Expression] -- ^ Inserts a function call35 | InsTailFun !Expression ![Expression] -- ^ Inserts a tailcall36 | Ins Prim !(Maybe LValue) !PrimName ![Expression]37 | Ins Label !LabelName -- ^ Inserts a label38 | Ins Comment !String !(Maybe Ins) -- ^ Inserts a comment28 = InsLocal !RegType !VarName -- ^ @.local@ directive 29 | InsNew !LValue !ObjType -- ^ @new@ opcode 30 | InsBind !LValue !Expression -- ^ @set@ opcode 31 | InsAssign !LValue !Expression -- ^ @assign@ opcode 32 | InsPrim !(Maybe LValue) !PrimName ![Expression] -- ^ Other opcodes 33 | InsFun ![Sig] !Expression ![Expression]-- ^ Function call 34 | InsTailFun !Expression ![Expression] -- ^ Tail call 35 | InsLabel !LabelName -- ^ Label 36 | InsComment !String !(Maybe Ins) -- ^ Comment 37 | InsExp !Expression -- ^ Generic expressions 39 38 deriving (Show, Eq, Typeable) 40 39 41 {-| Tags a PIR subroutine definition with @\@MAIN@, @\@LOAD@, @\@ANON@, 42 @\@METHOD@, or @\@MULTI@. -}43 data SubFlag = SubMAIN | SubLOAD | SubANON | SubMETHOD | SubMULTI [ObjType] 40 data Expression 41 = ExpLV !LValue -- ^ Variables 42 | ExpLit !Literal -- ^ Literals 44 43 deriving (Show, Eq, Typeable) 45 46 data RegType47 = RegInt -- ^ @I@ (integer) register48 | RegNum -- ^ @N@ (number) register49 | RegStr -- ^ @S@ (string) register50 | RegPMC -- ^ @P@ (PMC) register51 deriving (Show, Eq, Typeable)52 53 {-| Appears to be unused. -}54 data RelOp = RelLT | RelLE | RelEQ | RelNE | RelGE | RelGT55 deriving (Show, Eq, Typeable)56 57 {-| A PMC type, which, for example, can be given as an argument to the @new@58 opcode (e.g. @new .PerlScalar@). -}59 data ObjType60 = PerlScalar | PerlArray | PerlHash61 | PerlInt | PerlPair | PerlRef | PerlEnv62 deriving (Show, Eq, Typeable, Read)63 64 type LabelName = String65 type SubName = String66 type VarName = String67 type PrimName = String68 type PkgName = String69 type CallConv = String70 44 71 45 data LValue … … 78 52 deriving (Show, Eq, Typeable) 79 53 80 data Expression81 = ExpLV !LValue82 | ExpLit !Literal83 deriving (Show, Eq, Typeable)84 85 54 data Literal 86 55 = LitStr !String -- ^ A literal string … … 89 58 deriving (Show, Eq, Typeable) 90 59 60 {-| Tags a PIR subroutine definition with @\@MAIN@, @\@LOAD@, @\@ANON@, 61 @\@METHOD@, or @\@MULTI@. -} 62 data SubFlag = SubMAIN | SubLOAD | SubANON | SubMETHOD | SubMULTI [ObjType] 63 deriving (Show, Eq, Typeable) 64 65 data RegType 66 = RegInt -- ^ @I@ (Integer) register 67 | RegNum -- ^ @N@ (Number) register 68 | RegStr -- ^ @S@ (String) register 69 | RegPMC -- ^ @P@ (PMC) register 70 deriving (Show, Eq, Typeable) 71 72 {-| A PMC type, which, for example, can be given as an argument to the @new@ 73 opcode (e.g. @new .PerlScalar@). -} 74 data ObjType 75 = PerlScalar | PerlArray | PerlHash 76 | PerlInt | PerlPair | PerlRef | PerlEnv 77 deriving (Show, Eq, Typeable, Read) 78 79 type LabelName = String 80 type SubName = String 81 type VarName = String 82 type PrimName = String 83 type PkgName = String 84 type CallConv = String 85 91 86 {-| Emits PIR code for declarations (namespace, include, or sub declarations). -} 92 87 instance Emit Decl where 93 emit (DeclNS name) = emit ".namespace" <+> brackets (quotes $ emit name) 88 emit (DeclNS name decls) = vcat 89 [ emit ".namespace" <+> brackets (quotes $ emit name) 90 , emit decls 91 , emit ".namespace" <+> brackets (quotes $ emit "main") 92 ] 94 93 emit (DeclInc name) = emit ".include" <+> (quotes $ emit name) 95 94 emit (DeclSub name styps stmts) … … 207 206 #endif 208 207 209 {-| @.namespace@ directive. -}210 namespace :: PkgName -> Decl211 208 {-| @.include@ directive. -} 212 209 include :: PkgName -> Decl … … 224 221 (.&) :: Expression -> [Expression] -> Ins 225 222 226 namespace = DeclNS227 223 include = DeclInc 228 224 … … 237 233 lit0 :: Expression 238 234 lit0 = lit (0 :: Int) 235 236 {-| @P5@ register -} 237 errPMC :: (RegClass a) => a 238 errPMC = reg (VAR "P5") 239 239 240 240 {-| @$P0@ register -} … … 604 604 where 605 605 esc :: Char -> String 606 esc '|' = "_or_" 607 esc '&' = "_and_" 608 esc '?' = "_q_" 609 esc '_' = "__" 610 esc x = [x] 606 esc c | isAlphaNum c = [c] 607 esc c = ('_':show (ord c)) 611 608 612 609 {-| The Prelude, defining primitives like @&say@, @&infix:+@, etc. -} … … 617 614 , sub "&return" [slurpy arg0] 618 615 [ InsNew tempPMC PerlArray 619 , ( KEYED tempPMC (lit False)) <:= arg0616 , (tempPMC `KEYED` lit False) <:= arg0 620 617 , "throw" .- [tempPMC] 621 618 ] … … 653 650 654 651 -- IO 655 , sub "&Pugs::Internals::sleep" [arg0]656 [ tempNUM <:= arg0657 , "sleep" .- [tempNUM]658 ]659 652 , sub "&print" [slurpy arg0] 660 653 [ tempSTR <-- "join" $ [lit "", arg0] … … 666 659 , "print" .- [lit "\n"] 667 660 ] --> [lit True] 668 , sub "&Pugs::Internals::exit" [arg0]669 [ lit "&*END" .& []670 , tempINT <:= arg0671 , "exit" .- [tempINT]672 ]673 661 , vop1is "&system" "spawnw" 674 662 … … 745 733 , sub "&infix:=>" [arg0, arg1] 746 734 [ InsNew rv PerlPair 747 , KEYED rvarg0 <:= arg1735 , rv `KEYED` arg0 <:= arg1 748 736 ] --> [rv] 749 737 , sub "&infix:.." [arg0, arg1] … … 813 801 ] --> [rv] 814 802 815 --, namespace"Perl6::Internals"816 , sub "&Pugs::Internals::symbolic_deref" [arg0, slurpy arg1]803 , DeclNS "Perl6::Internals" 804 [ sub "&symbolic_deref" [arg0, slurpy arg1] 817 805 -- find_name($arg0 ~ join "::", @arg1) 818 806 [ tempSTR <-- "join" $ [lit "::", arg1] … … 822 810 , rv <-- "find_name" $ [tempSTR] 823 811 ] --> [rv] 824 812 , sub "&exit" [arg0] 813 [ lit "&*END" .& [] 814 , tempINT <:= arg0 815 , "exit" .- [tempINT] 816 ] 817 , sub "&sleep" [arg0] 818 [ tempNUM <:= arg0 819 , "sleep" .- [tempNUM] 820 ] 821 ] 825 822 -- Supporting Math::Basic 826 823 , sub "&abs" [arg0] -
src/Main.hs
r4852 r4907 301 301 302 302 compPIR :: String -> IO () 303 compPIR = (putStr =<<) . doCompile "PIR" "-" 303 compPIR prog = do 304 pir <- doCompile "PIR" "-" prog 305 putStr $ (subMain ++ (last $ split subMain pir)) 306 where 307 subMain = ".sub main" 304 308 305 309 runPIR :: String -> IO () -
src/Pugs/Compile/PIR.hs
r4905 r4907 1 {-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -funbox-strict-fields -fallow-undecidable-instances -cpp #-} 1 {-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fno-warn-orphans -funbox-strict-fields -cpp #-} 2 {-# OPTIONS_GHC -#include "UnicodeC.h" #-} 2 3 3 4 {-| … … 7 8 The general plan is to first compile the environment (subroutines, 8 9 statements, etc.) to an abstract syntax tree ('PIL' -- Pugs Intermediate 9 Representation) using the 'compile' function and 'Compile' class, and then10 Language) using the 'compile' function and 'Compile' class, and then 10 11 translate the PIL to a data structure of type 'PIR' using the 'trans' 11 12 function and 'Translate' class. This data structure is then reduced to … … 27 28 28 29 #ifndef HADDOCK 29 data PIL a where 30 -- Type-indexed with GADT; it is a bit too baroque -- refactor toward ANF? 31 data (Typeable a) => PIL a where 30 32 PNil :: PIL [a] 31 33 PNoop :: PIL Stmt … … 47 49 PAssign :: ![PIL LValue] -> !(PIL Expression) -> PIL LValue 48 50 PBind :: ![PIL LValue] -> !(PIL Expression) -> PIL LValue 49 PPad :: ! [(VarName, PIL Expression)] -> !(PIL [Stmt]) -> PIL [Stmt]51 PPad :: !Scope -> ![(VarName, PIL Expression)] -> !(PIL [Stmt]) -> PIL [Stmt] 50 52 51 53 PSub :: !SubName -> !SubType -> ![TParam] -> !(PIL [Stmt]) -> PIL Decl … … 86 88 show (PAssign x y) = "(PAssign " ++ show x ++ " " ++ show y ++ ")" 87 89 show (PBind x y) = "(PBind " ++ show x ++ " " ++ show y ++ ")" 88 show (PPad x y) = "(PPad " ++ show x ++ " " ++ show y ++ ")"89 90 show (PThunk x) = "(PThunk " ++ show x ++ ")" 91 show (PRawName x) = "(PRawName " ++ show x ++ ")" 92 show (PPad x y z) = unwords ["(PPad", show x, show y, show z, ")"] 90 93 show (PCode x y z) = unwords ["(PCode", show x, show y, show z, ")"] 91 show (PRawName x) = "(PRawName " ++ show x ++ ")"92 94 show (PSub x y z w) = unwords ["(PSub", show x, show y, show z, show w, ")"] 93 95 94 96 data TEnv = MkTEnv 95 { tLexDepth :: !Int 96 , tTokDepth :: !Int 97 , tEnv :: !Env 98 , tCxt :: !TCxt 99 , tReg :: !(TVar (Int, String)) 100 , tLabel :: !(TVar Int) 97 { tLexDepth :: !Int -- ^ Lexical scope depth 98 , tTokDepth :: !Int -- ^ Exp nesting depth 99 , tCxt :: !TCxt -- ^ Current context 100 , tReg :: !(TVar (Int, String))-- ^ Register name supply 101 , tLabel :: !(TVar Int) -- ^ Label name supply 101 102 } 102 103 deriving (Show, Eq) … … 149 150 ref <- liftSTM $ readTVar sym 150 151 cvList <- fromVals =<< readRef ref :: Comp [VCode] 151 decls <- forM ([0..] `zip` cvList) $ \(i :: Int, cv) -> do152 decls <- eachM cvList $ \(i, cv) -> do 152 153 compile (("&*END_" ++ show i), cv) :: Comp [PIL Decl] 153 154 compile ("&*END", concat decls) 155 canCompile ((_:twigil:_), _) | not (isAlphaNum twigil) = return [] 156 canCompile (name, [(_, sym)]) = do 157 -- translate them into store_global calls? 158 -- placing them each into one separate init function? 159 val <- readRef =<< liftSTM (readTVar sym) 160 valC <- compile val 161 let assignC = PAssign [PVar name'] valC 162 bodyC = PStmts (PStmt . PExp $ assignC) PNil 163 initL = "__init_" ++ (render $ varText name) 164 name' | ':' `elem` name = name 165 | otherwise = "main::" ++ name -- XXX wrong 166 return [PSub initL SubPrim [] bodyC] 154 167 canCompile _ = return [] 155 168 doCode name vsub = case subBody vsub of … … 157 170 _ -> compile (name, vsub) 158 171 159 instance Compile ([Char], [PIL Decl]) [PIL Decl] where 172 eachM :: (Monad m) => [a] -> ((Int, a) -> m b) -> m [b] 173 eachM = forM . ([0..] `zip`) 174 175 instance Compile (SubName, [PIL Decl]) [PIL Decl] where 160 176 compile (name, decls) = do 161 177 let bodyC = [ PStmts . PStmt . PExp $ PApp tcVoid (PExp (PVar sub)) [] … … 164 180 return (PSub name SubPrim [] (combine bodyC PNil):decls) 165 181 166 instance Compile ([Char], VCode) [PIL Decl] where 167 compile (name, MkCode{ subType = styp, subBody = Syn "block" [body], subParams = params }) = do 168 bodyC <- enter cxtItemAny $ compile body 169 paramsC <- compile params 170 return [PSub name styp paramsC bodyC] 171 compile (name, code) = compile 172 (name, code{ subBody = Syn "block" [subBody code] }) 173 174 {- 175 instance Compile [(TVar Bool, TVar VRef)] (PIL Expression) where 176 compile _ = return (PLit $ PVal undef) 177 -} 182 instance Compile (SubName, VCode) [PIL Decl] where 183 compile (name, vsub) | packageOf name /= packageOf (subName vsub) = do 184 -- This is an export! Huzzah Buzzah! 185 warn "export" (name, subName vsub) 186 let storeC = PBind [PVar $ qualify name] (PExp . PVar . qualify $ subName vsub) 187 bodyC = PStmts (PStmt . PExp $ storeC) PNil 188 exportL = "__export_" ++ (render $ varText name) 189 return [PSub exportL SubPrim [] bodyC] 190 compile (name, vsub) = do 191 bodyC <- enter cxtItemAny . compile $ case subBody vsub of 192 Syn "block" [body] -> body 193 body -> body 194 paramsC <- compile $ subParams vsub 195 return [PSub name (subType vsub) paramsC bodyC] 178 196 179 197 instance Compile (String, [(TVar Bool, TVar VRef)]) (PIL Expression) where … … 183 201 compile (Pos pos rest) = fmap (PPos pos rest) $ compile rest 184 202 compile (Cxt cxt rest) = enter cxt $ compile rest 185 compile (Stmts (Pad SMy pad exp) rest) = do 203 compile (Stmts (Pad SOur _ exp) rest) = do 204 compile $ mergeStmts exp rest 205 compile (Stmts (Pad _ pad exp) rest) = do 186 206 expC <- compile $ mergeStmts exp rest 187 207 padC <- compile $ padToList pad 188 return $ PPad ((map fst (padToList pad)) `zip` padC) expC208 return $ PPad SMy ((map fst $ padToList pad) `zip` padC) expC 189 209 compile exp = compileStmts exp 190 210 … … 208 228 where 209 229 tailCall (PStmt (PExp (PApp cxt fun args))) 210 = PStmt (PExp (PApp (TTailCall cxt) fun args))230 = PStmt $ PExp $ PApp (TTailCall cxt) fun args 211 231 tailCall (PPos pos exp x) = PPos pos exp (tailCall x) 212 232 tailCall x = x … … 220 240 instance Compile Val (PIL Stmt) where 221 241 compile = fmap PStmt . compile . Val 242 243 instance Compile Val (PIL Expression) where 244 compile = compile . Val 222 245 223 246 instance Compile Exp (PIL Stmt) where … … 242 265 postC <- compile post 243 266 funC <- compile (Var "&statement_control:loop") 244 return $ PStmt $PExp $ PApp TCxtVoid funC267 return . PStmt . PExp $ PApp TCxtVoid funC 245 268 [preC, pBlock condC, pBlock bodyC, pBlock postC] 246 269 compile exp@(Syn "unless" _) = fmap (PStmt . PExp) $ compConditional exp … … 253 276 bodyC <- compile body 254 277 funC <- compile (Var "&statement_control:for") 255 return $ PStmt $PExp $ PApp TCxtVoid funC [expC, bodyC]278 return . PStmt . PExp $ PApp TCxtVoid funC [expC, bodyC] 256 279 compile (Syn "given" _) = compile (Var "$_") -- XXX 257 280 compile (Syn "when" _) = compile (Var "$_") -- XXX … … 309 332 return $ PApp cxt funC argsC 310 333 compile exp@(Syn "if" _) = compConditional exp 311 compile (Syn "{}" (x:xs)) = compile (App (Var "&postcircumfix:{}") (Just x) xs)334 compile (Syn "{}" (x:xs)) = compile $ App (Var "&postcircumfix:{}") (Just x) xs 312 335 compile (Syn "[]" (x:xs)) = do 313 336 compile (App (Var "&postcircumfix:[]") (Just x) xs) … … 345 368 compConditional (Syn name exps) = do 346 369 [condC, trueC, falseC] <- compile exps 347 funC <- compile (Var $"&statement_control:" ++ name)370 funC <- compile $ Var ("&statement_control:" ++ name) 348 371 cxt <- askTCxt 349 372 return $ PApp cxt funC [condC, PThunk trueC, PThunk falseC] … … 355 378 compile (Cxt cxt rest) = enter cxt $ compile rest 356 379 compile (Var name) = return . PExp $ PVar name 357 compile exp@(Val (VCode _)) = compile (Syn "sub" [exp])358 compile (Val val) = fmap PLit (compile val)380 compile exp@(Val (VCode _)) = compile $ Syn "sub" [exp] 381 compile (Val val) = fmap PLit $ compile val 359 382 compile Noop = compile (Val undef) 360 383 compile (Syn "block" [body]) = do … … 363 386 return $ PExp $ PApp cxt (pBlock bodyC) [] 364 387 compile (Syn "sub" [Val (VCode sub)]) = do 365 -- XXX I'd like to lambda lift... :-/366 388 bodyC <- enter sub $ compile $ case subBody sub of 367 389 Syn "block" [exp] -> exp … … 406 428 trans PNoop = return (StmtComment "") 407 429 trans (PPos pos exp rest) = do 408 -- tell [StmtLine (posName pos) (posBeginLine pos)] 409 dep <- asks tTokDepth 430 dep <- asks tTokDepth 410 431 tell [StmtComment $ (replicate dep ' ') ++ "{{{ " ++ pretty exp] 411 x<- local (\e -> e{ tTokDepth = dep + 1 }) $ trans rest432 expC <- local (\e -> e{ tTokDepth = dep + 1 }) $ trans rest 412 433 tell [StmtComment $ (replicate dep ' ') ++ "}}} " ++ pretty pos] 413 return x434 return expC 414 435 trans (PLit (PVal VUndef)) = do 415 436 pmc <- genLV "undef" 416 return (ExpLV pmc)437 return $ ExpLV pmc 417 438 trans (PLit lit) = do 418 439 -- generate fresh supply and things... … … 420 441 pmc <- genLV "lit" 421 442 tellIns $ pmc <== ExpLit litC 422 return (ExpLV pmc)443 return $ ExpLV pmc 423 444 trans (PVal (VBool bool)) = return $ LitInt (toInteger $ fromEnum bool) 424 445 trans (PVal (VStr str)) = return $ LitStr str … … 427 448 trans (PVal (VRat rat)) = return $ LitNum (ratToNum rat) 428 449 trans val@(PVal _) = transError val 450 trans (PVar name) | Just (pkg, name') <- isQualified name = do 451 -- XXX - this is terribly ugly. Fix at parrot side perhaps? 452 pmc <- genLV "glob" 453 let initL = "init_" ++ pmcStr 454 doneL = "done_" ++ pmcStr 455 pmcStr = render (emit pmc) 456 tellIns $ "push_eh" .- [bare initL] 457 tellIns $ pmc <-- "find_global" $ [lit pkg, lit name'] 458 tellIns $ "goto" .- [bare doneL] 459 tellLabel initL 460 tellIns $ "store_global" .- [lit pkg, lit name', reg pmc] 461 tellLabel doneL 462 tellIns $ "clear_eh" .- [] 463 return pmc 429 464 trans (PVar name) = do 430 pmc <- genLV " var"465 pmc <- genLV "lex" 431 466 tellIns $ pmc <-- "find_name" $ [lit $ possiblyFixOperatorName name] 432 467 return pmc 433 {- XXX - this interferes with the prototype checking :-(434 trans (PStmt (PExp (PApp TCxtVoid (PExp (PVar name)) args))) = do435 argsC <- mapM trans args436 return $ StmtIns $ InsFun [] (lit name) argsC437 -}438 468 trans (PStmt (PLit (PVal VUndef))) = return $ StmtComment "" 439 469 trans (PStmt exp) = do … … 458 488 tellIns $ [reg tempPMC] <-& blockC $ [] 459 489 return tempPMC 460 trans (PApp (TCxtLValue _) (PExp (PVar "&postcircumfix:[]")) [ (PExp lhs), rhs]) = do490 trans (PApp (TCxtLValue _) (PExp (PVar "&postcircumfix:[]")) [PExp lhs, rhs]) = do 461 491 lhsC <- trans lhs 462 492 rhsC <- trans rhs 463 return (KEYED lhsC rhsC)493 return $ lhsC `KEYED` rhsC 464 494 trans (PApp cxt fun args) = do 465 funC <- case fun of495 funC <- trans fun {- case fun of 466 496 PExp (PVar name) -> return $ lit name 467 497 _ -> trans fun 498 -} 468 499 argsC <- if isLogicalLazy fun 469 500 then mapM trans (head args : map PThunk (tail args)) … … 485 516 isLogicalLazy (PExp (PVar "&infix:&&")) = True 486 517 isLogicalLazy _ = False 487 trans (PPad pad exps) = do518 trans (PPad SMy pad exps) = do 488 519 valsC <- mapM trans (map snd pad) 489 520 pass $ do … … 492 523 trans (PExp exp) = fmap ExpLV $ trans exp 493 524 trans (PCode styp params body) = do 494 [beg C, endC] <- genLabel ["blockBegin", "blockEnd"]525 [begL, endL] <- genLabel ["blockBegin", "blockEnd"] 495 526 this <- genPMC "block" 496 tellIns $ "newsub" .- [reg this, bare ".Closure", bare beg C]497 tellIns $ "goto" .- [bare end C]498 tellLabel beg C527 tellIns $ "newsub" .- [reg this, bare ".Closure", bare begL] 528 tellIns $ "goto" .- [bare endL] 529 tellLabel begL 499 530 let prms = map tpParam params 500 531 mapM_ (tellIns . InsLocal RegPMC . prmToIdent) prms … … 507 538 tellIns $ "set_returns" .- retSigList [bodyC] 508 539 tellIns $ "returncc" .- [] 509 tellLabel end C540 tellLabel endL 510 541 return (ExpLV this) 511 542 trans (PThunk exp) = do 512 [beg C, sndC, retC, endC] <- genLabel ["thunkBegin", "thunkAgain", "thunkReturn", "thunkEnd"]543 [begL, sndL, retL, endL] <- genLabel ["thunkBegin", "thunkAgain", "thunkReturn", "thunkEnd"] 513 544 this <- genPMC "block" 514 tellIns $ "newsub" .- [reg this, bare ".Continuation", bare beg C]515 tellIns $ "goto" .- [bare end C]516 tellLabel beg C545 tellIns $ "newsub" .- [reg this, bare ".Continuation", bare begL] 546 tellIns $ "goto" .- [bare endL] 547 tellLabel begL 517 548 cc <- genPMC "cc" 518 549 fetchCC cc (reg this) 519 550 expC <- trans exp 520 tellIns $ "set_addr" .- [reg this, bare snd C]521 tellIns $ "goto" .- [bare ret C]522 tellLabel snd C551 tellIns $ "set_addr" .- [reg this, bare sndL] 552 tellIns $ "goto" .- [bare retL] 553 tellLabel sndL 523 554 fetchCC cc (reg this) 524 tellLabel ret C555 tellLabel retL 525 556 tellIns $ if parrotBrokenXXX 526 then "store_global" .- [tempSTR, expC] -- XXX HACK557 then "store_global" .- [tempSTR, expC] 527 558 else "set_args" .- [lit "(0b10)", expC] 528 559 tellIns $ "invoke" .- [reg cc] 529 tellLabel end C560 tellLabel endL 530 561 return (ExpLV this) 531 trans (PRawName name) = do532 -- generate fresh supply and things...533 pmc <- genName name534 return (ExpLV pmc)562 trans (PRawName name) = fmap ExpLV $ genName name 563 trans (PSub name styp params body) | Just (pkg, name') <- isQualified name = do 564 declC <- trans $ PSub name' styp params body 565 return $ DeclNS pkg [declC] 535 566 trans (PSub name styp params body) = do 536 567 (_, stmts) <- listen $ do … … 548 579 trans x = transError x 549 580 581 packageOf :: String -> String 582 packageOf name = case isQualified name of 583 Just (pkg, _) -> pkg 584 _ -> "main" 585 586 qualify :: String -> String 587 qualify name = case isQualified name of 588 Just _ -> name 589 _ -> let (sigil, name') = span (not . isAlphaNum) name 590 in sigil ++ "main::" ++ name' 591 592 isQualified :: String -> Maybe (String, String) 593 isQualified name | Just (post, pre) <- breakOnGlue "::" (reverse name) = 594 let (sigil, pkg) = span (not . isAlphaNum) preName 595 name' = possiblyFixOperatorName (sigil ++ postName) 596 preName = reverse pre 597 postName = reverse post 598 in Just (pkg, name') 599 isQualified _ = Nothing 600 550 601 fetchCC :: LValue -> Expression -> Trans () 551 fetchCC cc beg C| parrotBrokenXXX = do552 tellIns $ tempINT <-- "get_addr" $ [beg C]602 fetchCC cc begL | parrotBrokenXXX = do 603 tellIns $ tempINT <-- "get_addr" $ [begL] 553 604 tellIns $ tempSTR <:= tempINT 554 605 tellIns $ "find_global" .- [reg cc, tempSTR]