Changeset 9064 for src/Pugs/Compile

Timestamp:

02/19/06 21:56:36 (3 years ago)

Author:

audreyt

Message:

* Pugs.Compile.Pugs: -CPugs now uses FastPackedString?;

the generated code is also much more compact (but we are
not using it for Prelude anymore.)

Files:

• src/Pugs/Compile/Pugs.hs (modified) (8 diffs)

src/Pugs/Compile/Pugs.hs

@@ -10 +10 @@
 
 type Str = Str.FastString
-type Comp a = WriterT a Eval a
+type Comp a = WriterT [a] Eval a
 
 class (Show x) => Compile x where
-    compile :: x -> Comp String
+    compile :: x -> Comp Str
     compile x = fail ("Unrecognized construct: " ++ show x)
-    compileList :: [x] -> Comp String
+    compileList :: [x] -> Comp Str
     compileList xs = do
         xsC <- mapM compile xs
-        return $ "[" ++ joinMany xsC ++ "]"
+        return $ Str.concat [bl, joinMany xsC, br]
 
-joinMany :: [String] -> String
-joinMany xs = concat (intersperse ", " (filter (not . null) xs))
+joinMany :: [Str] -> Str
+joinMany xs = Str.join cm (filter (not . Str.null) xs)
 
 instance (Compile x) => Compile [x] where
     compile = compileList
 
-
 instance Compile (Maybe Exp) where
-    compile Nothing = return "Nothing"
+    compile Nothing = return $ Str.pack "Nothing"
     compile (Just exp) = compWith "Just" [compile exp]
 
-compWith :: String -> [Comp String] -> Comp String
+pl, pr, bl, br :: Str
+pl = Str.pack "("
+pr = Str.pack ")"
+bl = Str.pack "["
+br = Str.pack "]"
+cm = Str.pack ", "
+
+ret :: String -> Comp Str
+ret = return . Str.pack
+
+compWith :: String -> [Comp Str] -> Comp Str
 compWith con xs = do
     xsC <- sequence xs
-    return $ "(" ++ unwords (con:["("++x++")" | x <- xsC]) ++ ")"
+    return $ Str.concat [pl, Str.unwords (Str.pack con:concatMap (\x -> [pl, x, pr]) xsC), pr]
 
 instance Compile Exp where
@@ -40 +49 @@
         compWith "App" [compile exp1, compile exp2, compile exps]
     compile (Syn syn exps) = do
-        compWith "Syn" [return (show syn), compile exps, compile exps]
+        compWith "Syn" [ret (show syn), compile exps]
     compile (Ann ann exp) = do
-        compWith "Ann" [return (show ann), compile exp]
+        compWith "Ann" [ret (show ann), compile exp]
     compile (Pad scope pad exp) = do
-        compWith "Pad" [return (show scope), compile pad, compile exp]
+        compWith "Pad" [ret (show scope), compile pad, compile exp]
     compile (Stmts exp1 exp2) = do
         compWith "Stmts" [compile exp1, compile exp2]
     compile (Val val) = do
         compWith "Val" [compile val]
-    compile exp = return $ "(" ++ show exp ++ ")"
+    compile exp = ret $ "(" ++ show exp ++ ")"
 
 instance Compile Pad where
     compile pad = do
         symsC <- mapM compile syms
-        return $ "(mkPad [" ++ joinMany symsC ++ "])"
+        return $ Str.concat [Str.pack "(mkPad [", joinMany symsC, Str.pack "])"]
         where
         syms = padToList pad
 
 instance Compile (String, [(TVar Bool, TVar VRef)]) where
-    compile ((':':'*':_), _) = return [] -- XXX - :*Bool etc; punt for now
+    compile ((':':'*':_), _) = return Str.empty -- XXX - :*Bool etc; punt for now
     compile (n, tvars) = do
-        tvarsC <- fmap (filter (not . null)) $ mapM compile tvars
-        if null tvarsC then return [] else do
-        return $ "(" ++ show n ++ ", [" ++ joinMany tvarsC ++ "])"
+        tvarsC <- fmap (filter (not . Str.null)) $ mapM compile tvars
+        if null tvarsC then return Str.empty else do
+        return $ Str.concat [pl, Str.pack (show n), Str.pack ", [", joinMany tvarsC, br, pr]
 
 instance (Typeable a) => Compile (Maybe (TVar a)) where
-    compile = const . return $ "Nothing"
+    compile = const . ret $ "Nothing"
 
 instance Compile (TVar Bool, TVar VRef) where
     compile (fresh, tvar) = do
         tvarC  <- compile tvar
-        if null tvarC then return [] else do
+        if Str.null tvarC then return Str.empty else do
         freshC <- compile fresh
-        return $ "(" ++ freshC ++ ", " ++ tvarC ++ ")"
+        return $ Str.concat [pl, freshC, cm, tvarC, pr]
 
 instance Compile Bool where
-    compile bool = return $ "(" ++ show bool ++ ")"
+    compile bool = ret $ "(" ++ show bool ++ ")"
 
 instance Compile a => Compile (Map VStr a) where
-    compile map | Map.null map = return $ "(Map.empty)"
+    compile map | Map.null map = ret $ "(Map.empty)"
     compile map = error (show map) 
 
@@ -86 +95 @@
         val     <- lift $ readIVar iv
         valC    <- compile val
-        return $ "(newScalar " ++ valC ++ ")"
+        return $ Str.concat [Str.pack "(newScalar ", valC, pr]
 
 instance (Typeable a, Compile a) => Compile (TVar a) where
@@ -92 +101 @@
         vref    <- liftIO $ atomically (readTVar fresh)
         vrefC   <- compile vref
-        if null vrefC then return [] else do
-        tv      <- liftIO $ fmap (('t':) . show . hashUnique) newUnique
-        tell $ tv ++ " <- liftSTM (newTVar " ++ vrefC ++ ");\n"
+        if Str.null vrefC then return Str.empty else do
+        tv      <- liftIO $ fmap (Str.pack . ('t':) . show . hashUnique) newUnique
+        tell [Str.concat [tv, Str.pack " <- liftSTM (newTVar ", vrefC, Str.pack ");\n"]]
         return tv
 
@@ -101 +110 @@
         vsub    <- lift $ code_fetch cv
         vsubC   <- compile vsub
-        if null vsubC then return [] else do
-        return $ "(MkRef (ICode " ++ vsubC ++ "))"
+        if Str.null vsubC then return Str.empty else do
+        return $ Str.concat [Str.pack "(MkRef (ICode ", vsubC, pr, pr]
     compile (MkRef (IScalar sv)) | scalar_iType sv == mkType "Scalar::Const" = do
         sv  <- lift $ scalar_fetch sv
         svC <- compile sv
-        if null svC then return [] else do
-        return $ "(MkRef (IScalar " ++ svC ++ "))"
+        if Str.null svC then return Str.empty else do
+        return $ Str.concat [Str.pack "(MkRef (IScalar ", svC, pr, pr]
     compile ref = do
-        objc   <- liftIO $ fmap (('o':) . show . hashUnique) newUnique
-        tell $ objc ++ " <- newObject (mkType \"" ++ showType (refType ref) ++ "\");\n"
+        objc   <- liftIO $ fmap (Str.pack . ('o':) . show . hashUnique) newUnique
+        tell [Str.append objc (Str.pack (" <- newObject (mkType \"" ++ showType (refType ref) ++ "\");\n"))]
         return objc
 
@@ -118 +127 @@
     compile (VObject obj) = do
         compWith "VObject" [compile obj]
-    compile val = return $ "(" ++ show val ++ ")"
+    compile val = ret $ "(" ++ show val ++ ")"
 
 instance Compile VObject where
     compile (MkObject typ attrs Nothing _) = do
         attrsC <- compile attrs
-        uniq   <- liftIO $ fmap (('u':) . show . hashUnique) newUnique
-        tell $ uniq ++ " <- liftIO newUnique;\n"
-        return $ "(" ++ unwords ["MkObject", show typ, attrsC, "Nothing", uniq] ++ ")"
+        uniq   <- liftIO $ fmap (Str.pack . ('u':) . show . hashUnique) newUnique
+        tell [Str.append uniq (Str.pack " <- liftIO newUnique;\n")]
+        return $ Str.unwords [pl, Str.pack "MkObject", Str.pack (show typ), attrsC, Str.pack "Nothing", uniq, pr]
     compile obj = fail $ "Cannot compile Object of Dynamic type: " ++ show obj
 
@@ -131 +140 @@
 instance Compile VCode where
     -- compile MkCode{ subBody = Prim _ } = return $ text "return mkPrim"
-    compile MkCode{ subBody = Prim _ } = return []
+    compile MkCode{ subBody = Prim _ } = return Str.empty
     compile (MkCode v1 v2 v3 _ v4 v5 v6 v7 v8 v9 v10 _) = do 
         compWith "MkCode"
             [ compile v1
-            , return (show v2)
-            , return (show v3)
-            , return (show v4)
-            , return "Nothing"
-            , return (show v5)
-            , return (show v6)
-            , return (show v7)
-            , return (show v8)
+            , ret (show v2)
+            , ret (show v3)
+            , ret "Nothing"
+            , ret (show v4)
+            , ret (show v5)
+            , ret (show v6)
+            , ret (show v7)
+            , ret (show v8)
             , compile v9
             , compile v10
-            , return "Nothing"
+            , ret "Nothing"
             ]
 
@@ -168 +177 @@
         , "    runAST glob exp"
         , ""
-        , "globC = do {" ++ globT ++ "return " ++ globC ++ "}"
+        , "globC = do {" ++ Str.unpack (Str.concat globT) ++ "return " ++ Str.unpack globC ++ "}"
         , ""
-        , "expC = do {" ++ expT ++ "return " ++ expC ++ "}"
+        , "expC = do {" ++ Str.unpack (Str.concat expT) ++ "return " ++ Str.unpack expC ++ "}"
         , ""
         ]