Changeset 4907 for src/Pugs/Compile

Show
Ignore:
Timestamp:
06/22/05 02:41:05 (3 years ago)
Author:
autrijus
svk:copy_cache_prev:
6641
Message:

* better handling of modules and qualified names in PIR generation.

Files:
1 modified

Legend:

Unmodified
Added
Removed

  • 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" #-} 
    23 
    34{-| 
    … …  
    78    The general plan is to first compile the environment (subroutines, 
    89    statements, etc.) to an abstract syntax tree ('PIL' -- Pugs Intermediate 
    9     Representation) using the 'compile' function and 'Compile' class, and then 
     10    Language) using the 'compile' function and 'Compile' class, and then 
    1011    translate the PIL to a data structure of type 'PIR' using the 'trans' 
    1112    function and 'Translate' class. This data structure is then reduced to 
    … …  
    2728 
    2829#ifndef HADDOCK 
    29 data PIL a where 
     30-- Type-indexed with GADT; it is a bit too baroque -- refactor toward ANF? 
     31data (Typeable a) => PIL a where 
    3032    PNil        :: PIL [a] 
    3133    PNoop       :: PIL Stmt 
    … …  
    4749    PAssign     :: ![PIL LValue] -> !(PIL Expression) -> PIL LValue 
    4850    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] 
    5052 
    5153    PSub        :: !SubName -> !SubType -> ![TParam] -> !(PIL [Stmt]) -> PIL Decl 
    … …  
    8688    show (PAssign x y) = "(PAssign " ++ show x ++ " " ++ show y ++ ")" 
    8789    show (PBind x y) = "(PBind " ++ show x ++ " " ++ show y ++ ")" 
    88     show (PPad x y) = "(PPad " ++ show x ++ " " ++ show y ++ ")" 
    8990    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, ")"] 
    9093    show (PCode x y z) = unwords ["(PCode", show x, show y, show z, ")"] 
    91     show (PRawName x) = "(PRawName " ++ show x ++ ")" 
    9294    show (PSub x y z w) = unwords ["(PSub", show x, show y, show z, show w, ")"] 
    9395 
    9496data 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 
    101102    } 
    102103    deriving (Show, Eq) 
    … …  
    149150            ref     <- liftSTM $ readTVar sym 
    150151            cvList  <- fromVals =<< readRef ref :: Comp [VCode] 
    151             decls   <- forM ([0..] `zip` cvList) $ \(i :: Int, cv) -> do 
     152            decls   <- eachM cvList $ \(i, cv) -> do 
    152153                compile (("&*END_" ++ show i), cv) :: Comp [PIL Decl] 
    153154            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] 
    154167        canCompile _ = return [] 
    155168        doCode name vsub = case subBody vsub of 
    … …  
    157170            _       -> compile (name, vsub) 
    158171 
    159 instance Compile ([Char], [PIL Decl]) [PIL Decl] where 
     172eachM :: (Monad m) => [a] -> ((Int, a) -> m b) -> m [b] 
     173eachM = forM . ([0..] `zip`) 
     174 
     175instance Compile (SubName, [PIL Decl]) [PIL Decl] where 
    160176    compile (name, decls) = do 
    161177        let bodyC = [ PStmts . PStmt . PExp $ PApp tcVoid (PExp (PVar sub)) [] 
    … …  
    164180        return (PSub name SubPrim [] (combine bodyC PNil):decls) 
    165181 
    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 -} 
     182instance 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] 
    178196 
    179197instance Compile (String, [(TVar Bool, TVar VRef)]) (PIL Expression) where 
    … …  
    183201    compile (Pos pos rest) = fmap (PPos pos rest) $ compile rest 
    184202    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 
    186206        expC    <- compile $ mergeStmts exp rest 
    187207        padC    <- compile $ padToList pad 
    188         return $ PPad ((map fst (padToList pad)) `zip` padC) expC 
     208        return $ PPad SMy ((map fst $ padToList pad) `zip` padC) expC 
    189209    compile exp = compileStmts exp 
    190210 
    … …  
    208228        where 
    209229        tailCall (PStmt (PExp (PApp cxt fun args))) 
    210             = PStmt (PExp (PApp (TTailCall cxt) fun args)) 
     230            = PStmt $ PExp $ PApp (TTailCall cxt) fun args 
    211231        tailCall (PPos pos exp x) = PPos pos exp (tailCall x) 
    212232        tailCall x = x 
    … …  
    220240instance Compile Val (PIL Stmt) where 
    221241    compile = fmap PStmt . compile . Val 
     242 
     243instance Compile Val (PIL Expression) where 
     244    compile = compile . Val 
    222245 
    223246instance Compile Exp (PIL Stmt) where 
    … …  
    242265        postC   <- compile post 
    243266        funC    <- compile (Var "&statement_control:loop") 
    244         return $ PStmt $ PExp $ PApp TCxtVoid funC 
     267        return . PStmt . PExp $ PApp TCxtVoid funC 
    245268            [preC, pBlock condC, pBlock bodyC, pBlock postC] 
    246269    compile exp@(Syn "unless" _) = fmap (PStmt . PExp) $ compConditional exp 
    … …  
    253276        bodyC   <- compile body 
    254277        funC    <- compile (Var "&statement_control:for") 
    255         return $ PStmt $ PExp $ PApp TCxtVoid funC [expC, bodyC] 
     278        return . PStmt . PExp $ PApp TCxtVoid funC [expC, bodyC] 
    256279    compile (Syn "given" _) = compile (Var "$_") -- XXX 
    257280    compile (Syn "when" _) = compile (Var "$_") -- XXX 
    … …  
    309332        return $ PApp cxt funC argsC 
    310333    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 
    312335    compile (Syn "[]" (x:xs)) = do 
    313336        compile (App (Var "&postcircumfix:[]") (Just x) xs) 
    … …  
    345368compConditional (Syn name exps) = do 
    346369    [condC, trueC, falseC] <- compile exps 
    347     funC    <- compile (Var $ "&statement_control:" ++ name) 
     370    funC    <- compile $ Var ("&statement_control:" ++ name) 
    348371    cxt     <- askTCxt 
    349372    return $ PApp cxt funC [condC, PThunk trueC, PThunk falseC] 
    … …  
    355378    compile (Cxt cxt rest) = enter cxt $ compile rest 
    356379    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 
    359382    compile Noop = compile (Val undef) 
    360383    compile (Syn "block" [body]) = do 
    … …  
    363386        return $ PExp $ PApp cxt (pBlock bodyC) [] 
    364387    compile (Syn "sub" [Val (VCode sub)]) = do 
    365         -- XXX I'd like to lambda lift... :-/ 
    366388        bodyC   <- enter sub $ compile $ case subBody sub of 
    367389            Syn "block" [exp]   -> exp 
    … …  
    406428    trans PNoop = return (StmtComment "") 
    407429    trans (PPos pos exp rest) = do 
    408         -- tell [StmtLine (posName pos) (posBeginLine pos)] 
    409         dep <- asks tTokDepth 
     430        dep     <- asks tTokDepth 
    410431        tell [StmtComment $ (replicate dep ' ') ++ "{{{ " ++ pretty exp] 
    411         x   <- local (\e -> e{ tTokDepth = dep + 1 }) $ trans rest 
     432        expC    <- local (\e -> e{ tTokDepth = dep + 1 }) $ trans rest 
    412433        tell [StmtComment $ (replicate dep ' ') ++ "}}} " ++ pretty pos] 
    413         return x 
     434        return expC 
    414435    trans (PLit (PVal VUndef)) = do 
    415436        pmc     <- genLV "undef" 
    416         return (ExpLV pmc) 
     437        return $ ExpLV pmc 
    417438    trans (PLit lit) = do 
    418439        -- generate fresh supply and things... 
    … …  
    420441        pmc     <- genLV "lit" 
    421442        tellIns $ pmc <== ExpLit litC 
    422         return (ExpLV pmc) 
     443        return $ ExpLV pmc 
    423444    trans (PVal (VBool bool)) = return $ LitInt (toInteger $ fromEnum bool) 
    424445    trans (PVal (VStr str)) = return $ LitStr str 
    … …  
    427448    trans (PVal (VRat rat)) = return $ LitNum (ratToNum rat) 
    428449    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 
    429464    trans (PVar name) = do 
    430         pmc     <- genLV "var" 
     465        pmc     <- genLV "lex" 
    431466        tellIns $ pmc <-- "find_name" $ [lit $ possiblyFixOperatorName name] 
    432467        return pmc 
    433 {- XXX - this interferes with the prototype checking :-( 
    434     trans (PStmt (PExp (PApp TCxtVoid (PExp (PVar name)) args))) = do 
    435         argsC   <- mapM trans args 
    436         return $ StmtIns $ InsFun [] (lit name) argsC 
    437 -} 
    438468    trans (PStmt (PLit (PVal VUndef))) = return $ StmtComment "" 
    439469    trans (PStmt exp) = do 
    … …  
    458488        tellIns $ [reg tempPMC] <-& blockC $ [] 
    459489        return tempPMC 
    460     trans (PApp (TCxtLValue _) (PExp (PVar "&postcircumfix:[]")) [(PExp lhs), rhs]) = do 
     490    trans (PApp (TCxtLValue _) (PExp (PVar "&postcircumfix:[]")) [PExp lhs, rhs]) = do 
    461491        lhsC    <- trans lhs 
    462492        rhsC    <- trans rhs 
    463         return (KEYED lhsC rhsC)  
     493        return $ lhsC `KEYED` rhsC 
    464494    trans (PApp cxt fun args) = do 
    465         funC    <- case fun of 
     495        funC    <- trans fun {- case fun of 
    466496            PExp (PVar name) -> return $ lit name 
    467497            _           -> trans fun 
     498        -} 
    468499        argsC   <- if isLogicalLazy fun 
    469500            then mapM trans (head args : map PThunk (tail args)) 
    … …  
    485516        isLogicalLazy (PExp (PVar "&infix:&&"))     = True 
    486517        isLogicalLazy _ = False 
    487     trans (PPad pad exps) = do 
     518    trans (PPad SMy pad exps) = do 
    488519        valsC   <- mapM trans (map snd pad) 
    489520        pass $ do 
    … …  
    492523    trans (PExp exp) = fmap ExpLV $ trans exp 
    493524    trans (PCode styp params body) = do 
    494         [begC, endC] <- genLabel ["blockBegin", "blockEnd"] 
     525        [begL, endL] <- genLabel ["blockBegin", "blockEnd"] 
    495526        this    <- genPMC "block" 
    496         tellIns $ "newsub" .- [reg this, bare ".Closure", bare begC] 
    497         tellIns $ "goto" .- [bare endC] 
    498         tellLabel begC 
     527        tellIns $ "newsub" .- [reg this, bare ".Closure", bare begL] 
     528        tellIns $ "goto" .- [bare endL] 
     529        tellLabel begL 
    499530        let prms = map tpParam params 
    500531        mapM_ (tellIns . InsLocal RegPMC . prmToIdent) prms 
    … …  
    507538            tellIns $ "set_returns" .- retSigList [bodyC] 
    508539            tellIns $ "returncc" .- [] 
    509         tellLabel endC 
     540        tellLabel endL 
    510541        return (ExpLV this) 
    511542    trans (PThunk exp) = do 
    512         [begC, sndC, retC, endC] <- genLabel ["thunkBegin", "thunkAgain", "thunkReturn", "thunkEnd"] 
     543        [begL, sndL, retL, endL] <- genLabel ["thunkBegin", "thunkAgain", "thunkReturn", "thunkEnd"] 
    513544        this    <- genPMC "block" 
    514         tellIns $ "newsub" .- [reg this, bare ".Continuation", bare begC] 
    515         tellIns $ "goto" .- [bare endC] 
    516         tellLabel begC 
     545        tellIns $ "newsub" .- [reg this, bare ".Continuation", bare begL] 
     546        tellIns $ "goto" .- [bare endL] 
     547        tellLabel begL 
    517548        cc      <- genPMC "cc" 
    518549        fetchCC cc (reg this) 
    519550        expC    <- trans exp 
    520         tellIns $ "set_addr" .- [reg this, bare sndC] 
    521         tellIns $ "goto" .- [bare retC] 
    522         tellLabel sndC 
     551        tellIns $ "set_addr" .- [reg this, bare sndL] 
     552        tellIns $ "goto" .- [bare retL] 
     553        tellLabel sndL 
    523554        fetchCC cc (reg this) 
    524         tellLabel retC 
     555        tellLabel retL 
    525556        tellIns $ if parrotBrokenXXX 
    526             then "store_global" .- [tempSTR, expC] -- XXX HACK 
     557            then "store_global" .- [tempSTR, expC] 
    527558            else "set_args" .- [lit "(0b10)", expC] 
    528559        tellIns $ "invoke" .- [reg cc] 
    529         tellLabel endC 
     560        tellLabel endL 
    530561        return (ExpLV this) 
    531     trans (PRawName name) = do 
    532         -- generate fresh supply and things... 
    533         pmc     <- genName name 
    534         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] 
    535566    trans (PSub name styp params body) = do 
    536567        (_, stmts)  <- listen $ do 
    … …  
    548579    trans x = transError x 
    549580 
     581packageOf :: String -> String 
     582packageOf name = case isQualified name of 
     583    Just (pkg, _)   -> pkg 
     584    _               -> "main" 
     585 
     586qualify :: String -> String 
     587qualify name = case isQualified name of 
     588    Just _  -> name 
     589    _       -> let (sigil, name') = span (not . isAlphaNum) name 
     590        in sigil ++ "main::" ++ name' 
     591 
     592isQualified :: String -> Maybe (String, String) 
     593isQualified 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') 
     599isQualified _ = Nothing 
     600 
    550601fetchCC :: LValue -> Expression -> Trans () 
    551 fetchCC cc begC | parrotBrokenXXX = do 
    552     tellIns $ tempINT   <-- "get_addr" $ [begC] 
     602fetchCC cc begL | parrotBrokenXXX = do 
     603    tellIns $ tempINT   <-- "get_addr" $ [begL] 
    553604    tellIns $ tempSTR   <:= tempINT 
    554605    tellIns $ "find_global" .- [reg cc, tempSTR] 
    … …  
    561612wrapSub SubBlock = id -- XXX not really 
    562613wrapSub _ = \body -> do 
    563     [retL] <- genLabel ["returnHandler"] 
     614    [retL, errL] <- genLabel ["returnHandler", "errHandler"] 
    564615    tellIns $ "push_eh" .- [bare retL] 
    565616    body 
    566617    tellLabel retL 
    567     tellIns $ tempPMC <:= ExpLV (KEYED (VAR "P5") (lit False)) 
     618    tellIns $ tempPMC <:= ExpLV (errPMC `KEYED` lit False) 
     619    tellIns $ "clear_eh" .- [] 
     620    tellIns $ tempSTR <-- "typeof" $ [errPMC] 
     621    tellIns $ "eq" .- [tempSTR, lit "Exception", bare errL] 
    568622    tellIns $ "set_returns" .- sigList [tempPMC] 
    569623    tellIns $ "returncc" .- [] 
     624    tellLabel errL 
     625    tellIns $ "throw" .- [errPMC] 
    570626 
    571627prmToSig :: Param -> Sig 
    … …  
    574630prmToArgs :: Param -> [ArgFlag] 
    575631prmToArgs prm = combine  
    576     [ if isSlurpy prm then (MkArgSlurpyArray:) else id 
    577     , if isOptional prm then (MkArgOptional:) else id 
     632    [ isSlurpy   ==> MkArgSlurpyArray 
     633    , isOptional ==> MkArgOptional 
    578634    ] [] 
     635    where 
     636    f ==> arg = if f prm then (arg:) else id 
    579637 
    580638prmToIdent :: Param -> String 
    … …  
    583641storeLex :: TParam -> Trans () 
    584642storeLex param = do 
    585     let var = paramName prm 
    586         name = prmToIdent prm 
    587         prm = tpParam param 
    588     -- deal with defaults 
    589643    when (isOptional prm) $ do 
    590644        [defC] <- genLabel ["defaultDone"] 
    … …  
    598652        tellLabel defC 
    599653    tellIns $ "store_lex" .- [lit curPad, lit var, bare name] 
     654    where 
     655    var     = paramName prm 
     656    name    = prmToIdent prm 
     657    prm     = tpParam param 
    600658 
    601659tellIns :: Ins -> Trans () 
    … …  
    611669    name'   <- liftIO $ liftSTM $ do 
    612670        (cur, name) <- readTVar tvar 
    613         return $ "P" ++ show cur ++ (if null name then name else ('_':name)) 
     671        return $ ('P':show cur) ++ (if null name then name else ('_':name)) 
    614672    return $ reg (VAR name') 
    615673 
    … …  
    620678        (cur, _) <- readTVar tvar 
    621679        writeTVar tvar (cur + 1, name) 
    622         return $ "P" ++ show (cur + 1) ++ "_" ++ name 
     680        return $ ('P':show (cur + 1)) ++ ('_':name) 
    623681    tellIns $ InsLocal RegPMC name' 
    624682    return $ reg (VAR name') 
    … …  
    637695        writeTVar tvar (cur + 1) 
    638696        return cur 
    639     return $ map (\name -> "LABEL_" ++ show cnt ++ "_" ++ name) names 
     697    return $ map (\name -> "LABEL_" ++ show cnt ++ ('_':name)) names 
    640698 
    641699genName :: (RegClass a) => String -> Trans a 
    … …  
    647705 
    648706padSort :: (Var, [(TVar Bool, TVar VRef)]) -> (String, [(a, b)]) -> Ordering 
    649 padSort ((a::[Char]), [(_, _)]) ((b::[Char]), [(_, _)]) 
     707padSort (a, [(_, _)]) (b, [(_, _)]) 
    650708    | (head a == ':' && head b == '&') = LT 
    651709    | (head b == ':' && head a == '&') = GT 
    … …  
    678736    globPIL     <- compile glob 
    679737    mainPIL     <- compile main 
    680     globPIR     <- runTransGlob tenv globPIL :: Eval [Decl] 
    681     mainPIR     <- runTransMain tenv mainPIL :: Eval [Stmt] 
     738    globPIR     <- runTransGlob tenv globPIL 
     739    mainPIR     <- runTransMain tenv mainPIL 
    682740    return . VStr . unlines $ 
    683741        [ "#!/usr/bin/env parrot" 
    684         -- , renderStyle (Style PageMode 0 0) init 
    685742        , renderStyle (Style PageMode 0 0) $ preludePIR $+$ vcat 
    686             -- Namespaces have bugs in both pugs and parrot. 
    687             -- [ emit $ namespace "main" 
    688             [ emit globPIR 
    689             , emit $ DeclSub "init" [SubMAIN, SubANON] $ map StmtIns 
    690                 -- Eventually, we'll have to write our own find_name wrapper (or 
    691                 -- fix Parrot's find_name appropriately). See Pugs.Eval.Var. 
    692                 -- For now, we simply store $P0 twice. 
    693                 [ "new_pad" .- [lit0] 
    694                 , InsNew tempPMC PerlEnv 
    695                 , "store_global"    .- [lit "%*ENV", tempPMC] 
    696                 , "store_global"    .- [lit "%ENV", tempPMC] 
    697                 , InsNew tempPMC PerlArray 
    698                 , "store_global"    .- [lit "@*END", tempPMC] 
    699                 , "store_global"    .- [lit "@END", tempPMC] 
    700                 , "getstdin"        .- [tempPMC] 
    701                 , "store_global"    .- [lit "$*IN", tempPMC] 
    702                 , "store_global"    .- [lit "$IN", tempPMC] 
    703                 , "getstdout"       .- [tempPMC] 
    704                 , "store_global"    .- [lit "$*OUT", tempPMC] 
    705                 , "store_global"    .- [lit "$OUT", tempPMC] 
    706                 , "getstderr"       .- [tempPMC] 
    707                 , "store_global"    .- [lit "$*ERR", tempPMC] 
    708                 , "store_global"    .- [lit "$ERR", tempPMC] 
    709                 , "getinterp"       .- [tempPMC] 
    710                 , tempPMC   <:= ExpLV (KEYED tempPMC (bare ".IGLOBALS_ARGV_LIST")) 
    711                 , tempPMC2  <-- "shift" $ [tempPMC] 
    712                 , "store_global"    .- [lit "@*ARGS", tempPMC] 
    713                 , "store_global"    .- [lit "@ARGS", tempPMC] 
    714                 , "store_global"    .- [lit "$*PROGRAM_NAME", tempPMC2] 
    715                 , "store_global"    .- [lit "$PROGRAM_NAME", tempPMC2] 
    716                 -- XXX wrong, should be lexical 
    717                 , InsNew tempPMC PerlScalar 
    718                 , "store_global"    .- [lit "$_", tempPMC] 
    719                 ] ++ [ StmtRaw (text "main()"), StmtIns (lit "&exit" .& [lit0]) ] 
    720             , text ".sub main @ANON" 
    721             , nest 4 (emit mainPIR) 
    722             , text ".end" 
     743        -- Namespaces have bugs in both pugs and parrot. 
     744        [ emit globPIR 
     745        , emit $ DeclNS "main" 
     746        [ DeclSub "init" [SubMAIN, SubANON] $ map StmtIns 
     747            -- Eventually, we'll have to write our own find_name wrapper (or 
     748            -- fix Parrot's find_name appropriately). See Pugs.Eval.Var. 
     749            -- For now, we simply store $P0 twice. 
     750            [ "new_pad" .- [lit0] 
     751            , InsNew tempPMC PerlEnv 
     752            , "store_global"    .- [lit "%*ENV", tempPMC] 
     753            , "store_global"    .- [lit "%ENV", tempPMC] 
     754            , InsNew tempPMC PerlArray 
     755            , "store_global"    .- [lit "@*END", tempPMC] 
     756            , "store_global"    .- [lit "@END", tempPMC] 
     757            , "getstdin"        .- [tempPMC] 
     758            , "store_global"    .- [lit "$*IN", tempPMC] 
     759            , "store_global"    .- [lit "$IN", tempPMC] 
     760            , "getstdout"       .- [tempPMC] 
     761            , "store_global"    .- [lit "$*OUT", tempPMC] 
     762            , "store_global"    .- [lit "$OUT", tempPMC] 
     763            , "getstderr"       .- [tempPMC] 
     764            , "store_global"    .- [lit "$*ERR", tempPMC] 
     765            , "store_global"    .- [lit "$ERR", tempPMC] 
     766            , "getinterp"       .- [tempPMC] 
     767            , tempPMC   <:= ExpLV (tempPMC `KEYED` bare ".IGLOBALS_ARGV_LIST") 
     768            , tempPMC2  <-- "shift" $ [tempPMC] 
     769            , "store_global"    .- [lit "@*ARGS", tempPMC] 
     770            , "store_global"    .- [lit "@ARGS", tempPMC] 
     771            , "store_global"    .- [lit "$*PROGRAM_NAME", tempPMC2] 
     772            , "store_global"    .- [lit "$PROGRAM_NAME", tempPMC2] 
     773            -- XXX wrong, should be lexical 
     774            , InsNew tempPMC PerlScalar 
     775            , "store_global"    .- [lit "$_", tempPMC] 
     776            ] ++ [ StmtRaw (text (name ++ "()")) | PSub name@('_':'_':_) _ _ _ <- globPIL ] ++ 
     777            [ StmtRaw (text "main()") 
     778            , StmtIns ("exit" .- [lit0]) 
    723779            ] 
    724         ] 
     780        , DeclSub "main" [SubANON] [ StmtRaw $ nest 4 (emit mainPIR) ] 
     781        ] ] ] 
    725782    where 
    726     style = MkEvalStyle{evalResult=EvalResultModule 
    727                        ,evalError =EvalErrorFatal} 
     783    style = MkEvalStyle 
     784        { evalResult = EvalResultModule 
     785        , evalError  = EvalErrorFatal 
     786        } 
    728787 
    729788runTransGlob :: TEnv -> [PIL Decl] -> Eval [Decl] 
    … …  
    735794initTEnv :: Eval TEnv 
    736795initTEnv = do 
    737     env         <- ask 
    738     zero        <- liftSTM $ newTVar (0, "") 
    739     none        <- liftSTM $ newTVar 0 
     796    initReg <- liftSTM $ newTVar (0, "") 
     797    initLbl <- liftSTM $ newTVar 0 
    740798    return $ MkTEnv 
    741799        { tLexDepth = 0 
    742800        , tTokDepth = 0 
    743801        , tCxt      = tcVoid 
    744         , tEnv      = env 
    745         , tReg      = zero 
    746         , tLabel    = none 
     802        , tReg      = initReg 
     803        , tLabel    = initLbl 
    747804        } 
     805