Show
Ignore:
Timestamp:
06/22/05 20:40:31 (4 years ago)
Author:
bsmith
svk:copy_cache_prev:
6641
Message:

Moved the Compile class to Pugs.Compile. The interface to the compilers
is in Pugs.Trans (for the moment at least).

Files:
1 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs/Compile/PIR.hs

    r4911 r4913  
    1919import Pugs.AST.Internals 
    2020import Emit.Common 
    21 import Pugs.Types 
    22 import Pugs.Eval 
    2321import Emit.PIR 
    2422import Pugs.Pretty 
    … …  
    2624import Pugs.Compile.PIR.Prelude (preludeStr) 
    2725import Pugs.Prim.Eval 
    28  
    29 #ifndef HADDOCK 
    30 -- Type-indexed with GADT; it is a bit too baroque -- refactor toward ANF? 
    31 data (Typeable a) => PIL a where 
    32     PNil        :: PIL [a] 
    33     PNoop       :: PIL Stmt 
    34  
    35     PRawName    :: !VarName -> PIL Expression -- XXX HACK! 
    36  
    37     PExp        :: !(PIL LValue) -> PIL Expression  
    38     PLit        :: !(PIL Literal) -> PIL Expression 
    39     PPos        :: !Pos -> !Exp -> !(PIL a) -> PIL a 
    40     PStmt       :: !(PIL Expression) -> PIL Stmt  
    41     PThunk      :: !(PIL Expression) -> PIL Expression  
    42     PCode       :: !SubType -> ![TParam] -> !(PIL [Stmt]) -> PIL Expression  
    43  
    44     PVal        :: !Val -> PIL Literal 
    45     PVar        :: !VarName -> PIL LValue 
    46  
    47     PStmts      :: !(PIL Stmt) -> !(PIL [Stmt]) -> PIL [Stmt] 
    48     PApp        :: !TCxt -> !(PIL Expression) -> ![PIL Expression] -> PIL LValue 
    49     PAssign     :: ![PIL LValue] -> !(PIL Expression) -> PIL LValue 
    50     PBind       :: ![PIL LValue] -> !(PIL Expression) -> PIL LValue 
    51     PPad        :: !Scope -> ![(VarName, PIL Expression)] -> !(PIL [Stmt]) -> PIL [Stmt] 
    52  
    53     PSub        :: !SubName -> !SubType -> ![TParam] -> !(PIL [Stmt]) -> PIL Decl 
    54 #endif 
    55  
    56 data TParam = MkTParam 
    57     { tpParam   :: !Param 
    58     , tpDefault :: !(Maybe (PIL Expression)) 
    59     } 
    60     deriving (Show, Typeable) 
    61  
    62 data TCxt 
    63     = TCxtVoid | TCxtLValue !Type | TCxtItem !Type | TCxtSlurpy !Type 
    64     | TTailCall !TCxt 
    65     deriving (Show, Eq, Typeable) 
    66  
    67 tcVoid, tcLValue :: TCxt 
    68 tcVoid      = TCxtVoid 
    69 tcLValue    = TCxtLValue anyType 
    70  
    71 {- 
    72 tcItem, tcSlurpy :: TCxt 
    73 tcItem      = TCxtItem anyType 
    74 tcSlurpy    = TCxtSlurpy anyType 
    75 -} 
    76  
    77 instance Show (PIL a) where 
    78     show (PVal x) = "(PVal " ++ show x ++ ")" 
    79     show (PVar x) = "(PVar " ++ show x ++ ")" 
    80     show (PLit x) = "(PLit " ++ show x ++ ")" 
    81     show (PStmts x y) = "(PStmts " ++ show x ++ " " ++ show y ++ ")" 
    82     show PNil = "PNil" 
    83     show PNoop = "PNoop" 
    84     show (PPos x y z) = "(PPos " ++ show x ++ " " ++ show y ++ " " ++ show z ++ ")" 
    85     show (PApp x y z) = "(PApp " ++ show x ++ " " ++ show y ++ " " ++ show z ++ ")" 
    86     show (PExp x) = "(PExp " ++ show x ++ ")" 
    87     show (PStmt x) = "(PStmt " ++ show x ++ ")" 
    88     show (PAssign x y) = "(PAssign " ++ show x ++ " " ++ show y ++ ")" 
    89     show (PBind x y) = "(PBind " ++ show x ++ " " ++ show y ++ ")" 
    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, ")"] 
    93     show (PCode x y z) = unwords ["(PCode", show x, show y, show z, ")"] 
    94     show (PSub x y z w) = unwords ["(PSub", show x, show y, show z, show w, ")"] 
    95  
    96 data TEnv = MkTEnv 
    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 
    102     } 
    103     deriving (Show, Eq) 
    104  
    105 type Comp a = Eval a 
    106 type CompMonad = EvalT (ContT Val (ReaderT Env SIO)) 
     26import Pugs.Compile 
     27 
    10728type Trans a = WriterT [Stmt] (ReaderT TEnv IO) a 
    10829type TransMonad = WriterT [Stmt] (ReaderT TEnv IO) 
    109  
    110 {-| Currently only 'Exp' → 'PIL' -} 
    111 class (Show a, Typeable b) => Compile a b where 
    112     compile :: a -> Comp b 
    113     compile x = fail ("Unrecognized construct: " ++ show x) 
    11430 
    11531{-| Currently only 'PIL' → 'PIR' -} 
    … …  
    11834    trans _ = fail "Untranslatable construct!" 
    11935 
    120 instance Compile (Var, [(TVar Bool, TVar VRef)]) (PIL Decl) where 
    121     compile = compError 
    122  
    123 instance Compile Param TParam where 
    124     compile prm = do 
    125         defC <- if isOptional prm 
    126             then fmap Just $ compile (paramDefault prm) 
    127             else return Nothing 
    128         return $ MkTParam 
    129             { tpParam = prm 
    130             , tpDefault = defC 
    131             } 
    132  
    133 {-| Compiles a 'Pad' to a list of 'PIL Decl's. Currently, only subroutines and 
    134     @\@*END@ are compiled. -} 
    135 instance Compile Pad [PIL Decl] where 
    136     compile pad = do 
    137         entries' <- mapM canCompile entries 
    138         return $ concat entries' 
    139         where 
    140         entries = sortBy padSort $ padToList pad 
    141         canCompile (name@('&':_), [(_, sym)]) = do 
    142             ref <- liftSTM $ readTVar sym 
    143             case ref of 
    144                 MkRef (ICode cv) 
    145                     -> doCode name =<< code_fetch cv 
    146                 MkRef (IScalar sv) | scalar_iType sv == mkType "Scalar::Const" 
    147                     -> doCode name =<< fromVal =<< scalar_fetch sv 
    148                 _ -> return [] 
    149         canCompile ("@*END", [(_, sym)]) = do 
    150             ref     <- liftSTM $ readTVar sym 
    151             cvList  <- fromVals =<< readRef ref :: Comp [VCode] 
    152             decls   <- eachM cvList $ \(i, cv) -> do 
    153                 compile (("&*END_" ++ show i), cv) :: Comp [PIL Decl] 
    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] 
    167         canCompile _ = return [] 
    168         doCode name vsub = case subBody vsub of 
    169             Prim _  -> return [] 
    170             _       -> compile (name, vsub) 
    171  
    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 
    176     compile (name, decls) = do 
    177         let bodyC = [ PStmts . PStmt . PExp $ PApp tcVoid (PExp (PVar sub)) [] 
    178                     | PSub sub _ _ _ <- decls 
    179                     ] 
    180         return (PSub name SubPrim [] (combine bodyC PNil):decls) 
    181  
    182 instance Compile (SubName, VCode) [PIL Decl] where 
    183     compile (name, vsub) | packageOf name /= packageOf (subName vsub) = do 
    184         let storeC  = PBind [PVar $ qualify name] (PExp . PVar . qualify $ subName vsub) 
    185             bodyC   = PStmts (PStmt . PExp $ storeC) PNil 
    186             exportL = "__export_" ++ (render $ varText name) 
    187         return [PSub exportL SubPrim [] bodyC] 
    188     compile (name, vsub) = do 
    189         bodyC   <- enter cxtItemAny . compile $ case subBody vsub of 
    190             Syn "block" [body]  -> body 
    191             body                -> body 
    192         paramsC <- compile $ subParams vsub 
    193         return [PSub name (subType vsub) paramsC bodyC] 
    194  
    195 instance Compile (String, [(TVar Bool, TVar VRef)]) (PIL Expression) where 
    196     compile (name, _) = return $ PRawName name 
    197  
    198 instance Compile Exp (PIL [Stmt]) where 
    199     compile (Pos pos rest) = fmap (PPos pos rest) $ compile rest 
    200     compile (Cxt cxt rest) = enter cxt $ compile rest 
    201     compile (Stmts (Pad SOur _ exp) rest) = do 
    202         compile $ mergeStmts exp rest 
    203     compile (Stmts (Pad _ pad exp) rest) = do 
    204         expC    <- compile $ mergeStmts exp rest 
    205         padC    <- compile $ padToList pad 
    206         return $ PPad SMy ((map fst $ padToList pad) `zip` padC) expC 
    207     compile exp = compileStmts exp 
    208  
    209 class EnterClass m a where 
    210     enter :: a -> m b -> m b 
    211  
    212 instance EnterClass CompMonad VCode where 
    213     enter sub = local (\e -> e{ envLValue = subLValue sub, envContext = CxtItem (subReturns sub) }) 
    214  
    215 instance EnterClass CompMonad Cxt where 
    216     enter cxt = local (\e -> e{ envContext = cxt }) 
    217  
    21836instance EnterClass TransMonad TCxt where 
    21937    enter cxt = local (\e -> e{ tCxt = cxt }) 
    220  
    221 compileStmts :: Exp -> Comp (PIL [Stmt]) 
    222 compileStmts exp = case exp of 
    223     Stmts this Noop -> do 
    224         thisC   <- compile this 
    225         return $ PStmts (tailCall thisC) PNil 
    226         where 
    227         tailCall (PStmt (PExp (PApp cxt fun args))) 
    228             = PStmt $ PExp $ PApp (TTailCall cxt) fun args 
    229         tailCall (PPos pos exp x) = PPos pos exp (tailCall x) 
    230         tailCall x = x 
    231     Stmts this rest -> do 
    232         thisC   <- enter cxtVoid $ compile this 
    233         restC   <- compileStmts rest 
    234         return $ PStmts thisC restC 
    235     Noop        -> return PNil 
    236     _           -> compile (Stmts exp Noop) 
    237  
    238 instance Compile Val (PIL Stmt) where 
    239     compile = fmap PStmt . compile . Val 
    240  
    241 instance Compile Val (PIL Expression) where 
    242     compile = compile . Val 
    243  
    244 instance Compile Exp (PIL Stmt) where 
    245     compile (Pos pos rest) = fmap (PPos pos rest) $ compile rest 
    246     compile (Cxt cxt rest) = enter cxt $ compile rest 
    247     compile Noop = return PNoop 
    248     compile (Val val) = do 
    249         cxt     <- asks envContext 
    250         if isVoidCxt cxt 
    251             then case val of 
    252                 VBool True      -> compile Noop 
    253                 _               -> do 
    254                     warn "Useless use of a constant in void context" val 
    255                     compile Noop 
    256             else compile val 
    257     compile (Syn "loop" [exp]) = 
    258         compile (Syn "loop" $ [emptyExp, Val (VBool True), emptyExp, exp]) 
    259     compile (Syn "loop" [pre, cond, post, (Syn "block" [body])]) = do 
    260         preC    <- compile pre 
    261         condC   <- compile cond 
    262         bodyC   <- compile body 
    263         postC   <- compile post 
    264         funC    <- compile (Var "&statement_control:loop") 
    265         return . PStmt . PExp $ PApp TCxtVoid funC 
    266             [preC, pBlock condC, pBlock bodyC, pBlock postC] 
    267     compile exp@(Syn "unless" _) = fmap (PStmt . PExp) $ compConditional exp 
    268     compile exp@(Syn "while" _) = compLoop exp 
    269     compile exp@(Syn "until" _) = compLoop exp 
    270     compile exp@(Syn "postwhile" _) = compLoop exp 
    271     compile exp@(Syn "postuntil" _) = compLoop exp 
    272     compile (Syn "for" [exp, body]) = do 
    273         expC    <- compile exp 
    274         bodyC   <- compile body 
    275         funC    <- compile (Var "&statement_control:for") 
    276         return . PStmt . PExp $ PApp TCxtVoid funC [expC, bodyC] 
    277     compile (Syn "given" _) = compile (Var "$_") -- XXX 
    278     compile (Syn "when" _) = compile (Var "$_") -- XXX 
    279     compile exp = fmap PStmt $ compile exp 
    280  
    281 pBlock :: PIL [Stmt] -> PIL Expression 
    282 pBlock = PCode SubBlock [] 
    283  
    284 {- 
    285 subTCxt :: VCode -> Eval TCxt 
    286 subTCxt sub = return $ if subLValue sub 
    287     then TCxtLValue (subReturns sub) 
    288     else TCxtItem (subReturns sub) 
    289 -} 
    290  
    291 askTCxt :: Eval TCxt 
    292 askTCxt = do 
    293     env <- ask 
    294     return $ if envLValue env 
    295         then TCxtLValue (typeOfCxt $ envContext env) 
    296         else case envContext env of 
    297             CxtVoid         -> TCxtVoid 
    298             CxtItem typ     -> TCxtItem typ 
    299             CxtSlurpy typ   -> TCxtSlurpy typ 
    300  
    301 instance (Show (m a), FunctorM m, Typeable1 m, Compile a b) => Compile (m a) (m b) where 
    302     compile = fmapM compile 
    303  
    304 instance (Compile a b, Compile a c) => Compile [a] (b, c) where 
    305     compile [x, y] = do { x' <- compile x ; y' <- compile y; return (x', y') } 
    306     compile x = compError x 
    307  
    308 instance (Compile a b, Compile a c, Compile a d) => Compile [a] (b, c, d) where 
    309     compile [x, y, z] = do { x' <- compile x ; y' <- compile y; z' <- compile z; return (x', y', z') } 
    310     compile x = compError x 
    311  
    312 instance Compile Exp (PIL LValue) where 
    313     compile (Pos pos rest) = fmap (PPos pos rest) $ compile rest 
    314     compile (Cxt cxt rest) = enter cxt $ compile rest 
    315     compile (Var name) = return $ PVar name 
    316     compile (Syn (sigil:"::()") exps) = do 
    317         compile $ App (Var "&Pugs::Internals::symbolic_deref") Nothing $ 
    318             (Val . VStr $ sigil:""):exps 
    319     compile (App (Var "&goto") (Just inv) args) = do 
    320         cxt     <- askTCxt 
    321         funC    <- compile inv 
    322         argsC   <- enter cxtItemAny $ compile args 
    323         return $ PApp (TTailCall cxt) funC argsC 
    324     compile (App fun (Just inv) args) = do 
    325         compile (App fun Nothing (inv:args)) -- XXX WRONG 
    326     compile (App fun Nothing args) = do 
    327         cxt     <- askTCxt 
    328         funC    <- compile fun 
    329         argsC   <- enter cxtItemAny $ compile args 
    330         return $ PApp cxt funC argsC 
    331     compile exp@(Syn "if" _) = compConditional exp 
    332     compile (Syn "{}" (x:xs)) = compile $ App (Var "&postcircumfix:{}") (Just x) xs 
    333     compile (Syn "[]" (x:xs)) = do 
    334         compile (App (Var "&postcircumfix:[]") (Just x) xs) 
    335     compile (Syn "," exps) = do 
    336         compile (App (Var "&infix:,") Nothing exps) 
    337     compile (Syn "\\[]" exps) = do 
    338         compile (App (Var "&circumfix:[]") Nothing exps) 
    339     compile (Syn "\\{}" exps) = do 
    340         compile (App (Var "&circumfix:{}") Nothing exps) 
    341     compile (Syn "=" [lhs, rhs]) = do 
    342         lhsC <- enterLValue $ compile lhs 
    343         rhsC <- enterRValue $ compile rhs 
    344         return $ PAssign [lhsC] rhsC 
    345     compile (Syn ":=" exps) = do 
    346         (lhsC, rhsC) <- enterLValue $ compile exps 
    347         return $ PBind [lhsC] rhsC 
    348     compile (Syn syn [lhs, exp]) | last syn == '=' = do 
    349         let op = "&infix:" ++ init syn 
    350         compile $ Syn "=" [lhs, App (Var op) Nothing [lhs, exp]] 
    351     compile exp = compError exp 
    352  
    353 compLoop :: Exp -> Comp (PIL Stmt) 
    354 compLoop (Syn name [cond, body]) = do 
    355     cxt     <- askTCxt 
    356     condC   <- enter (CxtItem $ mkType "Bool") $ compile cond 
    357     bodyC   <- enter CxtVoid $ compile body 
    358     funC    <- compile (Var $ "&statement_control:" ++ name) 
    359     return . PStmt . PExp $ PApp cxt funC [pBlock condC, pBlock bodyC] 
    360 compLoop exp = compError exp 
    361  
    362 {-| Compiles a conditional 'Syn' (@if@ and @unless@) to a call to an 
    363     appropriate function call (@&statement_control:if@ or 
    364     @&statement_control:unless@). -} 
    365 compConditional :: Exp -> Comp (PIL LValue) 
    366 compConditional (Syn name exps) = do 
    367     [condC, trueC, falseC] <- compile exps 
    368     funC    <- compile $ Var ("&statement_control:" ++ name) 
    369     cxt     <- askTCxt 
    370     return $ PApp cxt funC [condC, PThunk trueC, PThunk falseC] 
    371 compConditional exp = compError exp 
    372  
    373 {-| Compiles various 'Exp's to 'PIL Expression's. -} 
    374 instance Compile Exp (PIL Expression) where 
    375     compile (Pos pos rest) = fmap (PPos pos rest) $ compile rest 
    376     compile (Cxt cxt rest) = enter cxt $ compile rest 
    377     compile (Var name) = return . PExp $ PVar name 
    378     compile exp@(Val (VCode _)) = compile $ Syn "sub" [exp] 
    379     compile (Val val) = fmap PLit $ compile val 
    380     compile Noop = compile (Val undef) 
    381     compile (Syn "block" [body]) = do 
    382         cxt     <- askTCxt 
    383         bodyC   <- compile body 
    384         return $ PExp $ PApp cxt (pBlock bodyC) [] 
    385     compile (Syn "sub" [Val (VCode sub)]) = do 
    386         bodyC   <- enter sub $ compile $ case subBody sub of 
    387             Syn "block" [exp]   -> exp 
    388             exp                 -> exp 
    389         paramsC <- compile $ subParams sub 
    390         return $ PCode (subType sub) paramsC bodyC 
    391     compile (Syn "module" _) = compile Noop 
    392     compile (Syn "match" exp) = compile $ Syn "rx" exp -- wrong 
    393     compile (Syn "//" exp) = compile $ Syn "rx" exp 
    394     compile (Syn "rx" [exp, _]) = compile exp -- XXX WRONG - use PCRE 
    395     compile (Syn "subst" [exp, _, _]) = compile exp -- XXX WRONG - use PCRE 
    396     compile exp@(App _ _ _) = fmap PExp $ compile exp 
    397     compile exp@(Syn _ _) = fmap PExp $ compile exp 
    398     compile exp = compError exp 
    399  
    400 compError :: forall a b. Compile a b => a -> Comp b 
    401 compError = die $ "Compile error -- invalid " 
    402     ++ (show $ typeOf (undefined :: b)) 
    40338 
    40439transError :: forall a b. Translate a b => a -> Trans b 
    40540transError = die $ "Translate error -- invalid " 
    40641    ++ (show $ typeOf (undefined :: b)) 
    407  
    408 {-| Compiles a 'Val' to a 'PIL Literal'. -} 
    409 instance Compile Val (PIL Literal) where 
    410     compile val = return $ PVal val 
    411  
    412 die :: (MonadIO m, Show a) => String -> a -> m b 
    413 die x y = do 
    414     warn x y 
    415     liftIO $ exitFailure 
    416  
    417 warn :: (MonadIO m, Show a) => String -> a -> m () 
    418 warn str val = liftIO $ do 
    419     hPutStrLn stderr $ "*** " ++ str ++ ":\n    " ++ show val 
    420  
    421 instance Typeable1 PIL where 
    422     typeOf1 _ = typeOf () 
    42342 
    42443instance (Typeable a) => Translate (PIL a) a where 
    … …  
    589208    trans x = transError x 
    590209 
    591 packageOf :: String -> String 
    592 packageOf name = case isQualified name of 
    593     Just (pkg, _)   -> pkg 
    594     _               -> "main" 
    595  
    596 qualify :: String -> String 
    597 qualify name = case isQualified name of 
    598     Just _  -> name 
    599     _       -> let (sigil, name') = span (not . isAlphaNum) name 
    600         in sigil ++ "main::" ++ name' 
    601  
    602 isQualified :: String -> Maybe (String, String) 
    603 isQualified name | Just (post, pre) <- breakOnGlue "::" (reverse name) = 
    604     let (sigil, pkg) = span (not . isAlphaNum) preName 
    605         name'       = possiblyFixOperatorName (sigil ++ postName) 
    606         preName     = reverse pre 
    607         postName    = reverse post 
    608     in Just (pkg, name') 
    609 isQualified _ = Nothing 
    610  
    611210fetchCC :: LValue -> Expression -> Trans () 
    612211fetchCC cc begL | parrotBrokenXXX = do 
    … …  
    713312    tellIns $ InsNew (VAR var) (read $ render $ varInit name) 
    714313    return $ reg (VAR var) 
    715  
    716 padSort :: (Var, [(TVar Bool, TVar VRef)]) -> (String, [(a, b)]) -> Ordering 
    717 padSort (a, [(_, _)]) (b, [(_, _)]) 
    718     | (head a == ':' && head b == '&') = LT 
    719     | (head b == ':' && head a == '&') = GT 
    720     | otherwise = GT 
    721 padSort _ _ = EQ 
    722  
    723 varText :: String -> Doc 
    724 varText ('$':name)  = text $ "s__" ++ escaped name 
    725 varText ('@':name)  = text $ "a__" ++ escaped name 
    726 varText ('%':name)  = text $ "h__" ++ escaped name 
    727 varText ('&':name)  = text $ "c__" ++ escaped name 
    728 varText x           = error $ "invalid name: " ++ x 
    729314 
    730315varInit :: String -> Doc 
    … …  
    797382 
    798383runTransGlob :: TEnv -> [PIL Decl] -> Eval [Decl] 
    799 runTransGlob tenv = mapM $ fmap fst . liftIO . (`runReaderT` tenv) . runWriterT . trans 
     384runTransGlob tenv = mapM $ fmap fst . runTrans tenv 
    800385 
    801386runTransMain :: TEnv -> PIL [Stmt] -> Eval [Stmt] 
    802 runTransMain tenv = fmap snd . liftIO . (`runReaderT` tenv) . runWriterT . trans 
     387runTransMain tenv = fmap snd . runTrans tenv 
     388 
     389runTrans :: (Translate a b) => TEnv -> a -> Eval (b, [Stmt]) 
     390runTrans tenv = liftIO . (`runReaderT` tenv) . runWriterT . trans 
    803391 
    804392initTEnv :: Eval TEnv