Changeset 9059

Show
Ignore:
Timestamp:
02/19/06 13:40:54 (3 years ago)
Author:
audreyt
Message:

* -CPugs: Massively speeded up compilation speed and loading speed.

Files:
1 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs/Compile/Pugs.hs

    r8155 r9059  
    1 {-# OPTIONS_GHC -cpp -fglasgow-exts #-} 
    2  
    3 #include "../pugs_config.h" 
     1{-# OPTIONS_GHC -fglasgow-exts #-} 
    42 
    53module Pugs.Compile.Pugs (genPugs) where 
    … …  
    86import Pugs.Internals 
    97import Text.PrettyPrint 
     8import qualified Data.FastPackedString as Str 
    109import qualified Data.Map as Map 
    1110 
     11type Str = Str.FastString 
     12type Comp a = WriterT a Eval a 
     13 
    1214class (Show x) => Compile x where 
    13     compile :: x -> Eval Doc 
     15    compile :: x -> Comp String 
    1416    compile x = fail ("Unrecognized construct: " ++ show x) 
    15     compileList :: [x] -> Eval Doc 
    16     compileList = fmap prettyList . mapM compile 
     17    compileList :: [x] -> Comp String 
     18    compileList xs = do 
     19        xsC <- mapM compile xs 
     20        return $ "[" ++ joinMany xsC ++ "]" 
     21 
     22joinMany :: [String] -> String 
     23joinMany xs = concat (intersperse ", " (filter (not . null) xs)) 
    1724 
    1825instance (Compile x) => Compile [x] where 
    1926    compile = compileList 
    2027 
    21 sep1 :: Doc -> Doc -> Doc 
    22 sep1 a b = sep [a, b] 
    23  
    24 prettyList :: [Doc] -> Doc 
    25 prettyList = brackets . vcat . punctuate comma 
    26  
    27 prettyDo :: [Doc] -> Doc 
    28 prettyDo docs = parens $ text "do" <+> braces (sep $ punctuate semi docs) 
    29  
    30 prettyRecord :: String -> [(String, Doc)] -> Doc 
    31 prettyRecord con = (text con <+>) . braces . sep . punctuate comma . map assign 
    32     where assign (name, val) = text name <+> char '=' <+> val 
    33  
    34 prettyBind :: String -> Doc -> Doc 
    35 prettyBind var doc = text var <+> text "<-" <+> doc 
    3628 
    3729instance Compile (Maybe Exp) where 
    38     compile Nothing = return $ text "return Nothing" 
    39     compile (Just exp) = do 
    40         expC <- compile exp 
    41         return $ prettyDo  
    42             [ prettyBind "exp" expC 
    43             , text "return (Just exp)" 
    44             ] 
     30    compile Nothing = return "Nothing" 
     31    compile (Just exp) = compWith "Just" [compile exp] 
     32 
     33compWith :: String -> [Comp String] -> Comp String 
     34compWith con xs = do 
     35    xsC <- sequence xs 
     36    return $ "(" ++ unwords (con:["("++x++")" | x <- xsC]) ++ ")" 
    4537 
    4638instance Compile Exp where 
    4739    compile (App exp1 exp2 exps) = do 
    48         exp1C <- compile exp1 
    49         exp2C <- compile exp2 
    50         expsC <- compileList exps 
    51         return $ prettyDo  
    52             [ prettyBind "exp1" exp1C 
    53             , prettyBind "exp2" exp2C 
    54             , prettyBind "exps" (text "sequence" `sep1` expsC) 
    55             , text "return (App exp1 exp2 exps)" 
    56             ] 
     40        compWith "App" [compile exp1, compile exp2, compile exps] 
    5741    compile (Syn syn exps) = do 
    58         expsC <- compileList exps 
    59         return $ prettyDo 
    60             [ prettyBind "exps" (text "sequence" `sep1` expsC) 
    61             , text "return" <+> parens (text $ "Syn " ++ show syn ++ " exps") 
    62             ] 
    63     compile (Ann ann exp) = compileShow2 "Ann" ann exp 
     42        compWith "Syn" [return (show syn), compile exps, compile exps] 
     43    compile (Ann ann exp) = do 
     44        compWith "Ann" [return (show ann), compile exp] 
    6445    compile (Pad scope pad exp) = do 
    65         padC <- compile pad 
    66         expC <- compile exp 
    67         return $ prettyDo 
    68             [ prettyBind "pad" padC 
    69             , prettyBind "exp" expC 
    70             , text ("return (Pad " ++ show scope ++ " pad exp)") 
    71             ] 
     46        compWith "Pad" [return (show scope), compile pad, compile exp] 
    7247    compile (Stmts exp1 exp2) = do 
    73         exp1C <- compile exp1 
    74         exp2C <- compile exp2 
    75         return $ prettyDo  
    76             [ prettyBind "exp1" exp1C 
    77             , prettyBind "exp2" exp2C 
    78             , text "return (Stmts exp1 exp2)" 
    79             ] 
     48        compWith "Stmts" [compile exp1, compile exp2] 
    8049    compile (Val val) = do 
    81         valC <- compile val 
    82         return $ prettyDo  
    83             [ prettyBind "val" valC 
    84             , text "return (Val val)" 
    85             ] 
    86     compile exp = return $ text "return" $+$ parens (text $ show exp) 
    87  
    88 compileShow2 :: Show a => String -> a -> Exp -> Eval Doc 
    89 compileShow2 con anno exp = do 
    90     expC <- compile exp 
    91     return $ prettyDo 
    92         [ prettyBind "exp" expC 
    93         , text ("return (" ++ con ++ " (" ++ show anno ++ ") exp)") 
    94         ] 
     50        compWith "Val" [compile val] 
     51    compile exp = return $ "(" ++ show exp ++ ")" 
    9552 
    9653instance Compile Pad where 
    9754    compile pad = do 
    9855        symsC <- mapM compile syms 
    99         return $ text "fmap mkPad . sequence $ " 
    100             $+$ nest 4 (prettyList $ filter (not . isEmpty) symsC) 
     56        return $ "(mkPad [" ++ joinMany symsC ++ "])" 
    10157        where 
    10258        syms = padToList pad 
    10359 
    10460instance Compile (String, [(TVar Bool, TVar VRef)]) where 
    105     compile ((':':'*':_), _) = return empty -- XXX - :*Bool etc; punt for now 
     61    compile ((':':'*':_), _) = return [] -- XXX - :*Bool etc; punt for now 
    10662    compile (n, tvars) = do 
    107         tvarsC <- fmap (filter (not . isEmpty)) $ mapM compile tvars 
    108         if null tvarsC then return empty else do 
    109         return $ prettyDo  
    110                 [ prettyBind "tvars" (text "sequence" `sep1` prettyList tvarsC) 
    111                 , text ("return (" ++ show n ++ ", tvars)") 
    112                 ] 
     63        tvarsC <- fmap (filter (not . null)) $ mapM compile tvars 
     64        if null tvarsC then return [] else do 
     65        return $ "(" ++ show n ++ ", [" ++ joinMany tvarsC ++ "])" 
    11366 
    11467instance (Typeable a) => Compile (Maybe (TVar a)) where 
    115     compile = const . return $ text "Nothing" 
     68    compile = const . return $ "Nothing" 
    11669 
    11770instance Compile (TVar Bool, TVar VRef) where 
    11871    compile (fresh, tvar) = do 
     72        tvarC  <- compile tvar 
     73        if null tvarC then return [] else do 
    11974        freshC <- compile fresh 
    120         tvarC  <- compile tvar 
    121         if isEmpty tvarC then return empty else do 
    122         return $ prettyDo  
    123                 [ prettyBind "fresh" freshC 
    124                 , prettyBind "tvar" tvarC 
    125                 , text "return (fresh, tvar)" 
    126                 ] 
     75        return $ "(" ++ freshC ++ ", " ++ tvarC ++ ")" 
    12776 
    12877instance Compile Bool where 
    129     compile bool = return $ text "return" <+> parens (text $ show bool) 
     78    compile bool = return $ "(" ++ show bool ++ ")" 
    13079 
    13180instance Compile a => Compile (Map VStr a) where 
    132     compile map | Map.null map = return (text "return Map.empty") 
     81    compile map | Map.null map = return $ "(Map.empty)" 
    13382    compile map = error (show map)  
    13483 
    13584instance Compile (IVar VScalar) where 
    13685    compile iv = do 
    137         val     <- readIVar iv 
     86        val     <- lift $ readIVar iv 
    13887        valC    <- compile val 
    139         return $ prettyDo 
    140             [ prettyBind "val" valC 
    141             , text "newScalar val" 
    142             ] 
     88        return $ "(newScalar " ++ valC ++ ")" 
    14389 
    14490instance (Typeable a, Compile a) => Compile (TVar a) where 
    14591    compile fresh = do 
    146         vref    <- liftSTM $ readTVar fresh 
     92        vref    <- liftIO $ atomically (readTVar fresh) 
    14793        vrefC   <- compile vref 
    148         if isEmpty vrefC then return empty else do 
    149         return $ prettyDo 
    150             [ prettyBind "vref" vrefC 
    151             , text "liftSTM (newTVar vref)" 
    152             ] 
     94        if null vrefC then return [] else do 
     95        tv      <- liftIO $ fmap (('t':) . show . hashUnique) newUnique 
     96        tell $ tv ++ " <- liftSTM (newTVar " ++ vrefC ++ ");\n" 
     97        return tv 
    15398 
    15499instance Compile VRef where 
    155100    compile (MkRef (ICode cv)) = do 
    156         vsub    <- code_fetch cv 
     101        vsub    <- lift $ code_fetch cv 
    157102        vsubC   <- compile vsub 
    158         if isEmpty vsubC then return empty else do 
    159         return $ prettyDo 
    160             [ prettyBind "vsub" vsubC 
    161             , text "return (MkRef $ ICode vsub)" 
    162             ] 
     103        if null vsubC then return [] else do 
     104        return $ "(MkRef (ICode " ++ vsubC ++ "))" 
    163105    compile (MkRef (IScalar sv)) | scalar_iType sv == mkType "Scalar::Const" = do 
    164         sv  <- scalar_fetch sv 
     106        sv  <- lift $ scalar_fetch sv 
    165107        svC <- compile sv 
    166         if isEmpty svC then return empty else do 
    167         return $ prettyDo 
    168             [ prettyBind "sv" svC 
    169             , text "return (MkRef $ IScalar sv)" 
    170             ] 
     108        if null svC then return [] else do 
     109        return $ "(MkRef (IScalar " ++ svC ++ "))" 
    171110    compile ref = do 
    172         return $ text $ "newObject (mkType \"" ++ showType (refType ref) ++ "\")" 
     111        objc   <- liftIO $ fmap (('o':) . show . hashUnique) newUnique 
     112        tell $ objc ++ " <- newObject (mkType \"" ++ showType (refType ref) ++ "\");\n" 
     113        return objc 
    173114 
    174115instance Compile Val where 
    175116    compile (VCode code) = do 
    176         codeC <- compile code 
    177         return $ prettyDo 
    178             [ prettyBind "code" codeC 
    179             , text "return $ VCode code" 
    180             ] 
     117        compWith "VCode" [compile code] 
    181118    compile (VObject obj) = do 
    182         objC <- compile obj 
    183         return $ prettyDo 
    184             [ prettyBind "obj" objC 
    185             , text "return $ VObject obj" 
    186             ] 
    187     compile x = return $ text "return" $+$ parens (text $ show x) 
     119        compWith "VObject" [compile obj] 
     120    compile val = return $ "(" ++ show val ++ ")" 
    188121 
    189122instance Compile VObject where 
    190123    compile (MkObject typ attrs Nothing _) = do 
    191124        attrsC <- compile attrs 
    192         let vobj = prettyRecord "MkObject" $ 
    193                 [ ("objType",   text (show typ)) 
    194                 , ("objAttrs",  text "attrs") 
    195                 , ("objOpaque", text "Nothing") 
    196                 , ("objId",     text "id") 
    197                 ] 
    198         return $ prettyDo 
    199             [ prettyBind "attrs" attrsC 
    200             , prettyBind "id" (text "liftIO newUnique") 
    201             , text "return" <+> parens vobj 
    202             ] 
     125        uniq   <- liftIO $ fmap (('u':) . show . hashUnique) newUnique 
     126        tell $ uniq ++ " <- liftIO newUnique;\n" 
     127        return $ "(" ++ unwords ["MkObject", show typ, attrsC, "Nothing", uniq] ++ ")" 
    203128    compile obj = fail $ "Cannot compile Object of Dynamic type: " ++ show obj 
    204129 
    … …  
    206131instance Compile VCode where 
    207132    -- compile MkCode{ subBody = Prim _ } = return $ text "return mkPrim" 
    208     compile MkCode{ subBody = Prim _ } = return empty 
    209     compile code = do  
    210         bodyC <- compile $ subBody code 
    211         let comp :: Show a => (VCode -> a) -> Doc 
    212             comp f = text $ show (f code) 
    213             vsub = prettyRecord "MkCode" $ 
    214                 [ ("isMulti",       comp isMulti) 
    215                 , ("subName",       comp subName) 
    216                 , ("subType",       comp subType) 
    217                 , ("subEnv",        text "Nothing") 
    218                 , ("subAssoc",      comp subAssoc) 
    219                 , ("subParams",     comp subParams) 
    220                 , ("subBindings",   comp subBindings) 
    221                 , ("subSlurpLimit", comp subSlurpLimit) 
    222                 , ("subReturns",    comp subReturns) 
    223                 , ("subLValue",     comp subLValue) 
    224                 , ("subBody",       text "body") 
    225                 , ("subCont",       text "Nothing") 
    226                 ] 
    227         return $ prettyDo 
    228             [ prettyBind "body" bodyC 
    229             , text "return" <+> parens vsub 
     133    compile MkCode{ subBody = Prim _ } = return [] 
     134    compile (MkCode v1 v2 v3 _ v4 v5 v6 v7 v8 v9 v10 _) = do  
     135        compWith "MkCode" 
     136            [ compile v1 
     137            , return (show v2) 
     138            , return (show v3) 
     139            , return (show v4) 
     140            , return "Nothing" 
     141            , return (show v5) 
     142            , return (show v6) 
     143            , return (show v7) 
     144            , return (show v8) 
     145            , compile v9 
     146            , compile v10 
     147            , return "Nothing" 
    230148            ] 
    231149 
    232150genPugs :: Eval Val 
    233151genPugs = do 
    234     exp     <- asks envBody 
    235     glob    <- askGlobal 
    236     globC   <- compile glob 
    237     expC    <- compile exp 
     152    exp             <- asks envBody 
     153    glob            <- askGlobal 
     154    (globC, globT)  <- runWriterT $ compile glob 
     155    (expC, expT)    <- runWriterT $ compile exp 
    238156    return . VStr . unlines $ 
    239157        [ "{-# OPTIONS_GHC -fglasgow-exts -fno-warn-unused-imports -fno-warn-unused-binds #-}" 
    … …  
    250168        , "    runAST glob exp" 
    251169        , "" 
    252         , renderStyle (Style PageMode 100 0) $ text "globC =" <+> globC 
     170        , "globC = do {" ++ globT ++ "return " ++ globC ++ "}" 
    253171        , "" 
    254         , renderStyle (Style PageMode 100 0) $ text "expC =" <+> expC 
     172        , "expC = do {" ++ expT ++ "return " ++ expC ++ "}" 
    255173        , "" 
    256174        ]