[rework code generator to use CGen monad
John Meacham <john@repetae.net>**20051005042759] hunk ./C/FromGrin.hs 28
+import CanType
hunk ./C/FromGrin.hs 31
-toType TyTag = tag_t
-toType (TyNode) = pnode_t
-toType (TyTup []) = CTypeBasic "void"
+toType TyTag = return tag_t
+toType (TyNode) = return pnode_t
+toType (TyTup []) = return $ CTypeBasic "void"
hunk ./C/FromGrin.hs 35
+toType (TyTup [x]) = toType x
+toType (TyTup xs) = do xs' <- mapM toType xs; newAnonStruct xs'
+toType (Ty s) = return $ CTypeBasic $ fromAtom s
+
+toType' TyTag = return tag_t
+toType' (TyNode) = return pnode_t
+toType' (TyTup []) = return $ CTypeBasic "void"
+toType' (TyPtr TyNode) = toType' TyNode  -- for now, we use pointers to nodes for everything
+toType' (TyTup [x]) = toType' x
+toType' (Ty s) = return $ CTypeBasic $ fromAtom s
+
hunk ./C/FromGrin.hs 47
-toType (Ty s) = CTypeBasic $ fromAtom s
hunk ./C/FromGrin.hs 69
+ccaf :: (Var,Val) -> P.Doc
hunk ./C/FromGrin.hs 71
+
+--cfunc :: Monad m => TyEnv -> (Atom,Lam) -> m CFunction
hunk ./C/FromGrin.hs 75
-        return $ cfunction { cFuncComments = show n, cFuncReturnType = toType r, cFuncName = toTag n, cFuncArgs = [ (toType t, toVName v) | Var v t <- as  ], cFuncBody = s  } where
+        fr <-  toType r
+        as' <- flip mapM as $ \ (Var v t) -> do
+            t' <- toType t
+            return (t',toVName v)
+        return $ cfunction { cFuncComments = show n, cFuncReturnType = fr, cFuncName = toTag n, cFuncArgs = as', cFuncBody = s  } where
hunk ./C/FromGrin.hs 83
-
-cVal :: MonadState HcHash m => Val -> m CExpr
+--cVal :: Val -> ReaderT Todo (CGen (State HcHash)) CExpr
hunk ./C/FromGrin.hs 91
+cVal (Tup [x]) = cVal x
+--cVal (Tup xs) = do
+--    xs' <- mapM cVal xs
+--    ts <-   mapM (toType . getType) xs
+--    t <-   newAnonStruct ts
+--    tup <-  newAuto t
+--    addStmts [ anonField tup i `CSAssign` x  | i <- [0..] | x <- xs' ]
+--    return tup
+
+
+
hunk ./C/FromGrin.hs 107
-statement s = tell $ (Seq.single s,mempty)
+--statement s = tell $ (Seq.single s,mempty)
+
+statement s = addStatement s
+newAuto t = do
+    nn <- newIdent
+    let n = "auto" ++ n
+    addStatement (CSAuto t n)
+    return $ CEIdent n
hunk ./C/FromGrin.hs 149
-cexp (Cast x t) = cVal x >>= return . CECast (toType t)
+cexp (Cast x t) = do
+    x' <- cVal x
+    t' <-  toType t
+    return $ CECast t' x'
hunk ./C/FromGrin.hs 155
-    return $ CECast (toType t) (CEDoc "0")
+    t' <- toType t
+    return $ CECast t' (CEDoc "0")
hunk ./C/FromGrin.hs 160
-cexp (Prim p vs) | APrim _ req <- primAPrim p  = tell (mempty,req) >> convertPrim p vs
+cexp (Prim p vs) | APrim _ req <- primAPrim p  =  (addRequires req) >> convertPrim p vs
hunk ./C/FromGrin.hs 236
-declVar (Var n t) = CSAuto (toType t) (toVName n)
+declVar (Var n t) = do
+    t' <- toType t
+    return $ CSAuto t' (toVName n)
hunk ./C/FromGrin.hs 240
+cb :: Exp -> ReaderT Todo (CGen (State HcHash)) [CStatement]
hunk ./C/FromGrin.hs 247
-    return $ [declVar q, declVar r, CSAssign q' (CEOp "/" a' b'), CSAssign r' (CEOp "%" a' b') ] ++ ss'
+    q'' <- declVar q
+    r'' <- declVar r
+    return $ [q'', r'' , CSAssign q' (CEOp "/" a' b'), CSAssign r' (CEOp "%" a' b') ] ++ ss'
hunk ./C/FromGrin.hs 259
-    return (map declVar as  ++ ass ++ ss')
+    as' <- mapM declVar as
+    return (as'  ++ ass ++ ss')
hunk ./C/FromGrin.hs 269
-    return (map declVar as  ++ ass ++ ss')
+    as' <- mapM declVar as
+    return (as'  ++ ass ++ ss')
hunk ./C/FromGrin.hs 279
-    return (declVar v:ss ++ ss')
+    v'' <- declVar v
+    return (v'':ss ++ ss')
hunk ./C/FromGrin.hs 287
-            return $ (Nothing,[declVar v,CSAssign v'' v'] ++ e')
+            v''' <- declVar v
+            return $ (Nothing,[v''',CSAssign v'' v'] ++ e')
hunk ./C/FromGrin.hs 296
-            return $ (Just (toTag t), map declVar as ++ ass ++ e')
+            as' <- mapM declVar as
+            return $ (Just (toTag t), as' ++ ass ++ e')
hunk ./C/FromGrin.hs 306
-            return $ (Nothing,[declVar v,CSAssign v'' v'] ++ e')
+            v''' <- declVar v
+            return $ (Nothing,[v''',CSAssign v'' v'] ++ e')
hunk ./C/FromGrin.hs 311
+        da (Tup [x] :-> e) = da ( x :-> e )
hunk ./C/FromGrin.hs 319
-    (e,(ss',req)) <- runWriterT $ cexp e
-    tell req
-    let ss = Seq.toList ss'
+    (ss,e) <- lift $  runSubCGen $ cexp e
hunk ./C/FromGrin.hs 338
-    cst (i,t) = (toType t, text $ 'a':show i)
+    cst (i,t) = (runIdentity $ toType' t, text $ 'a':show i)
hunk ./C/FromGrin.hs 345
-    ((funcs',req),fh) = runState  (runWriterT (mapM (cfunc $ grinTypeEnv grin) $ grinFunctions grin)) emptyHcHash
+    ((funcs',CGenState { genStateRequires = req, genStateDecls = d }),fh) = runState  (runCGen 1 (mapM (cfunc $ grinTypeEnv grin) $ grinFunctions grin)) emptyHcHash
hunk ./C/Gen.hs 1
-module C.Gen where
+module C.Gen(
+    CType(..),
+    CDecl(..),
+    CStatement(..),
+    CExpr(..),
+    CLit(..),
+    CFunction(..),
+    CGenState(..),
+    CIdent,
+    CGen,
+    runCGen,
+    runSubCGen,
+    addDecl,
+    addStmts,
+    addStatement,
+    MonadCGen(..),
+    addRequires,
+    prettyC,
+    ceIdent,
+    ceFunCall,
+    cAssign,
+    addComment,
+    ToCIdent(..),
+    cfunction,
+    prettyFuncP,
+    prettyFunc,
+    prettyDecl,
+    anonField,
+    addFunction
+
+    ) where
hunk ./C/Gen.hs 34
---import Pretty
-import qualified Text.PrettyPrint.HughesPJ as P
-import Text.PrettyPrint.HughesPJ(nest,render,($$),($+$))
-import List(partition)
+import Char
hunk ./C/Gen.hs 36
-import GenUtil
+import Data.Monoid
+import List
+import Maybe
hunk ./C/Gen.hs 40
-import Char
+import qualified Data.Map as Map
+import qualified Text.PrettyPrint.HughesPJ as P
+import Text.PrettyPrint.HughesPJ(nest,render,($$),($+$))
+
hunk ./C/Gen.hs 45
+import C.Prims
hunk ./C/Gen.hs 48
-import List
-import Maybe
+import GenUtil
hunk ./C/Gen.hs 87
-
hunk ./C/Gen.hs 88
-data CCode = CCode {
-    cCodeIncludes :: [String],
-    cCodeFunctions :: [CFunction]
-    --cCodeGlobalVars :: [(CType,String)]
-    }
hunk ./C/Gen.hs 120
+    genStateAnonStructs :: Map.Map [CType] CType,
hunk ./C/Gen.hs 123
+    genStateFunctions :: [CFunction],
+    genStateRequires :: Requires,
hunk ./C/Gen.hs 127
+    {-! derive: update !-}
hunk ./C/Gen.hs 130
+    genStateAnonStructs = Map.empty,
hunk ./C/Gen.hs 133
+    genStateFunctions = [],
+    genStateRequires = mempty,
hunk ./C/Gen.hs 139
-    deriving(Monad, MonadState CGenState, MonadTrans)
+    deriving(Monad, MonadTrans)
+
+
+class Monad m => MonadCGen m where
+    addDecls :: [CDecl] -> m ()
+    addStatements :: [CStatement] -> m ()
+    newIdent :: m String
+    newAnonStruct :: [CType] -> m CType
+
+
+instance (Monad (m t), MonadTrans m, MonadCGen t) => MonadCGen (m t) where
+    newIdent = lift newIdent
+    addStatements x = lift $ addStatements x
+    addDecls x = lift $ addDecls x
+    newAnonStruct xs = lift $ newAnonStruct xs
+
+instance Monad m => MonadCGen (CGen m) where
+    addDecls d' = CGen $ modify f where
+        f cg = cg { genStateDecls = genStateDecls cg ++ d'}
+    addStatements s' = CGen $ modify f where
+        f cg  =  cg { genStateStatements = genStateStatements cg ++ s'}
+    newIdent = newIdent'
+    newAnonStruct xs =  newAnonStruct' xs
+
hunk ./C/Gen.hs 165
+unCGen (CGen x) = x
+
+addStmts x = addStatements x
hunk ./C/Gen.hs 170
-runSubCGen x = do
+runSubCGen (CGen x) = CGen $ do
hunk ./C/Gen.hs 172
-    (r,CGenState { genStateDecls = d, genStateStatements = s, genUnique = v' }) <- lift $ runCGen v x -- runStateT x ([],[],v)
-    addDecls d
+    --(r,CGenState { genStateDecls = d, genStateStatements = s, genUnique = v' }) <- lift $ runCGen v x -- runStateT x ([],[],v)
+    (r,CGenState { genStateDecls = d, genStateStatements = s, genUnique = v' }) <- lift $ runStateT x cGenState { genUnique = v }
+    unCGen $ addDecls d
hunk ./C/Gen.hs 177
+
+addDecl d = addDecls [d]
+
+addStatement s = addStmts [s]
+addRequires r = CGen $ modify (genStateRequires_u (mappend r))
hunk ./C/Gen.hs 183
-addDecls :: Monad m => [CDecl] -> CGen m ()
-addDecls d' = modify f where
-    f cg = cg { genStateDecls = genStateDecls cg ++ d'}
hunk ./C/Gen.hs 184
-addStmts :: Monad m => [CStatement] -> CGen m ()
-addStmts s' = modify f where
-    f cg  =  cg { genStateStatements = genStateStatements cg ++ s'}
+addFunction :: Monad m => CFunction -> CGen m ()
+addFunction fn = CGen $ modify f where
+    f cg = cg { genStateFunctions = genStateFunctions cg ++ [fn]}
hunk ./C/Gen.hs 188
-newIdent :: Monad m => CGen m String
-newIdent = do
+newIdent' :: Monad m => CGen m String
+newIdent' = CGen $ do
hunk ./C/Gen.hs 248
-{-
-cCase :: Monad m => CExpr -> ([(CLit,(CGen m CExpr))],(CGen m CExpr)) -> (CGen m CExpr)
-cCase e (as,d) = do
-    r <- newIdent
-    te <- newIdent
-    fas <- mapM (f r) as
-    gd <- g r d
-    addStmts [CSAuto cVoidStar r, CSAuto tEv te,CSAssign (ceIdent te) e]
-    addStmts  [CSDoc ( text "switch" <> parens (prettyExpr $ CECast ctInt e) <> text "{" $$ nest 8 (vcat fas $$ gd) $$ text "}")]
-    return (ceIdent r)  where
-	f r (l,v)  = do
-	    s <- cBlock (v >>= \e -> addStmts [CSAssign (ceIdent r) e])
-	    return $ (text "case" <+> prettyLit l <> colon ) $$  prettyCode s $$ text "break;"
-	g r v = do
-	    s <- cBlock (v >>= \e -> addStmts [CSAssign (ceIdent r) e])
-	    return $ text "default:" $$ prettyCode s $$ text "break;"
--}
-{-
-cCase :: Monad m => CExpr -> ([(CLit,(CGen m CExpr))],(CGen m CExpr)) -> (CGen m CExpr)
-cCase e (as,d) = do
-    r <- newIdent
-    te <- newIdent
-    fas <- mapM (f r) as
-    gd <- g r d
-    addStmts [CSAuto cVoidStar r, CSAuto tEv te,CSAssign (ceIdent te) e]
-    addStmts  [CSDoc ( text "switch" <> parens (prettyExpr $ CECast ctInt (CEEval (ceIdent te))) <> text "{" $$ nest 8 (vcat fas $$ gd) $$ text "}")]
-    return (ceIdent r)  where
-	f r (l,v)  = do
-	    s <- cBlock (v >>= \e -> addStmts [CSAssign (ceIdent r) e])
-	    return $ (text "case" <+> prettyLit l <> colon ) $$  prettyCode s $$ text "break;"
-	g r v = do
-	    s <- cBlock (v >>= \e -> addStmts [CSAssign (ceIdent r) e])
-	    return $ text "default:" $$ prettyCode s $$ text "break;"
--}
hunk ./C/Gen.hs 249
+{-
hunk ./C/Gen.hs 256
-{-
+  -}
+
hunk ./C/Gen.hs 259
-cBlock v = do
-    (_,_,i) <- get
-    ((),(d,s,ni)) <- lift ( runCGen i v) -- runStateT v ([],[], i))
-    addDecls d
-    let (as, ns) = partition isAuto s
-    addStmts as
-    modify $ liftT3 (id,id,const ni)
-    return ns
+tup_names = [ 't':show i | i <- [ (1::Int) .. ]]
hunk ./C/Gen.hs 261
--}
hunk ./C/Gen.hs 263
-declThunk :: String -> CDecl
-declThunk n = CVar (CTypePointer (CTypeBasic "thunk_t")) n
hunk ./C/Gen.hs 264
-cThunkInd :: String -> CExpr
-cThunkInd n = CEIndirect (ceIdent "thunk") n
+anonField :: CExpr -> Int -> CExpr
+anonField c i = CEDot c (tup_names !! i)
hunk ./C/Gen.hs 267
-cInd n v = CEIndirect (autoE n) ('v':show v)
-cTInd n = CEIndirect (ceIdent "thunk") ('v':show n)
+newAnonStruct' :: Monad m => [CType] -> CGen m CType
+newAnonStruct' ts = CGen $ do
+    x <- gets genStateAnonStructs
+    case Map.lookup ts x of
+        Just t -> return t
+        Nothing -> do
+            id <- unCGen newIdent
+            let nid = ("tup" ++ id)
+            unCGen $ addDecls [CStruct  nid (zip ts tup_names)]
+            let tp = (CTypeStruct nid)
+            modify (genStateAnonStructs_u $ Map.insert ts tp)
+            return tp
hunk ./C/Gen.hs 280
-cStructClosure n vs = [CStruct n ((cVoidStar, "eval"):map f vs)] where
-    f n = (cThunk, n)
hunk ./C/Gen.hs 281
-cAlloc t = CECast (CTypePointer t) $ CEFunCall "malloc" [CESizeof t]
-cAllocThunk i = cAlloc (CTypeStruct ('s':show i))
hunk ./C/Gen.hs 376
+
+
hunk ./C/Gen.hs 379
+instance MonadState x m => MonadState x (CGen m) where
+    get = lift $ get
+    put x = lift $ put x