[remove old code generator
John Meacham <john@repetae.net>**20060126170239] hunk ./C/FromGrin.hs 1
-module C.FromGrin(compileGrin) where
-
-import Control.Monad.Identity
-import Control.Monad.Reader
-import Control.Monad.State
-import Control.Monad.Writer
-import Data.Monoid
-import List
-import qualified Data.Set as Set
-import qualified Text.PrettyPrint.HughesPJ as P
-import Text.PrettyPrint.HughesPJ(nest,($$))
-
-import Atom
-import C.Gen
-import C.Prims
-import Doc.DocLike
-import Doc.PPrint
-import FreeVars
-import GenUtil
-import Grin.Grin
-import Grin.HashConst
-import Grin.Show
-import RawFiles
-import CanType
-
-
-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 (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
-
---toType (TyPtr t) = CTypePointer (toType t)
---    | a == tIntzh = CTypeBasic "HsInt"
---    | a == tCharzh = CTypeBasic "HsChar"
---    | otherwise = CTypeBasic (fromAtom s)
-
-
-toStruct t = text $ 's':(show $ toCIdent $ t)
-toTag t = text $ (show $ toCIdent $ t)
-
-toStructT t = CTypeStruct (toStruct t)
-toStructTP t = CTypePointer (toStructT t)
-
-size_t = CTypeBasic "size_t"
-tag_t = CTypeBasic "tag_t"
-pnode_t = CTypePointer node_t
-node_t = (CTypeBasic "node_t")
-
-toVName (V n) | n < 0 = text $ 'g':show (- n)
-toVName (V n) = text $ 'v':show n
-
-
-data Todo = TodoReturn | TodoExp CExpr | TodoNothing
-
-ccaf :: (Var,Val) -> P.Doc
-ccaf (v,val) = text "/* " <> text (show v) <> text " = " <> (text $ render (prettyVal val)) <> text "*/\n" <> text "static node_t _" <> toVName v <> text ";\n" <> text "#define " <> toVName v <+>  text "(&_" <> toVName v <> text ")\n";
-
---cfunc :: Monad m => TyEnv -> (Atom,Lam) -> m CFunction
-cfunc te (n,Tup as :-> body) = do
-        s <- runReaderT (cb body) TodoReturn
-        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 = finc:s  } where
-    Identity (_,r) = findArgsType te n
-    finc = CSExpr (CEFunCall "function_inc" [])
-
-
---cVal :: Val -> ReaderT Todo (CGen (State HcHash)) CExpr
-cVal (Var n _) = return $  CEIdent (toVName n)
-cVal (Const (NodeC h _)) | h == tagHole = return $ CEIdent "NULL"
-cVal (Const h) = do
-    (_,i) <- newConst h
-    return $ CEIdent ( 'c':show i )
-cVal (Lit i _) = return $ CEDoc (show i)
-cVal (Tag t) = return $ CEIdent (toTag t)
-cVal (Tup [x]) = cVal x
-cVal (Tup []) = return $ CEDoc "/* () */"
-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
-
-
-
-cVal x = return $  CEDoc  ("/* ERROR cVal: " ++ show x  ++ " */")
-
-
--- cb (Fetch (Var n _) :>>= Var n' t :-> e ) = return [CSAuto (toType t) (toVName n'), CSAssign (CEIdent (]
-
---statement s = tell $ (Seq.single s,mempty)
-
-statement s = addStatement s
-newAuto t = do
-    nn <- newIdent
-    let n = "auto" ++ nn
-    addStatement (CSAuto t n)
-    return $ CEIdent n
-
-newNode (NodeC t _) | t == tagHole = do
-    return $  CEFunCall "jhc_malloc" [CESizeof node_t]
-newNode (NodeC t as) = do
-    statement (CSAuto pnode_t "tmp")
-    --let tmp = CEVar (CTypePointer (toStructT t)) "tmp"
-    let tmp = CEIdent "tmp"
-        --tmp' = CECast (toStructTP t) tmp
-        tmp' = CEIndirect tmp (toStruct t)
-    statement (CSAssign tmp $ CEFunCall "jhc_malloc" [CESizeof (if tagIsWHNF t then toStructT t else node_t)])
-    statement (CSAssign  (CEDot tmp' "tag") (CEDoc (toTag t)) )
-    as' <- mapM cVal as
-    mapM_ statement [CSAssign  (CEDot tmp' ('a':show i)) a | a <- as' | i <- [(1 :: Int) ..] ]
-    return $ CECast pnode_t tmp
-
-
-cexp (Update v@Var {} (NodeC t as)) = do
-    v' <- cVal v
-    as' <- mapM cVal as
-    let tmp' = CECast (toStructTP t) v'
-    statement (CSExpr $ CEFunCall "update_inc" [])
-    statement (CSAssign  (CEIndirect tmp' "tag") (CEDoc (toTag t)) )
-    as' <- mapM cVal as
-    mapM_ statement [CSAssign  (CEIndirect tmp' ('a':show i)) a | a <- as' | i <- [(1 :: Int) ..] ]
-    return $ CEDoc ""
-
-cexp (Update v z) = do  -- TODO eliminate unknown updates
-    v' <- cVal v
-    z' <- cVal z
-    let tag = CEIndirect z' "any.tag"
-    statement (CSExpr $ CEFunCall "update_inc" [])
-    return $ CEFunCall "memcpy" [v',z',CEFunCall "jhc_sizeof" [tag]]
-cexp (Fetch v) = cVal v
-cexp (Store n@NodeC {}) = newNode n
-cexp (Return n@NodeC {}) = newNode n
-cexp (Return x) = cVal x
-cexp (Cast x t) = do
-    x' <- cVal x
-    t' <-  toType t
-    return $ CECast t' x'
-cexp (Error s t) = do
-    statement (CSExpr (CEFunCall "jhc_error" [CEDoc (show s)]))
-    t' <- toType t
-    case t' of
-        CTypeStruct _ -> newAuto t'
-        _ -> return $ CECast t' (CEDoc "0")
-cexp (App a vs _) = do
-    vs' <- mapM cVal vs
-    return $ CEFunCall (toTag a) vs'
-cexp (Prim p vs) | APrim _ req <- primAPrim p  =  (addRequires req) >> convertPrim p vs
-cexp e = return $ CEDoc ("/* ERROR " ++ show e ++ " */")
-
-convertPrim p vs
-    | APrim (CConst s _) _ <- primAPrim p = do
-        return $ CEDoc s
-    | APrim (CCast _ to) _ <- primAPrim p, [a] <- vs = do
-        a' <- cVal a
-        return $ CECast (CTypeBasic to) a'
-    | APrim (Operator n [ta] r) _ <- primAPrim p, [a] <- vs = do
-        a' <- cVal a
-        return $ CECast (CTypeBasic r) (CEUOp n a')
-    | APrim (Operator n [ta,tb] r) _ <- primAPrim p, [a,b] <- vs = do
-        a' <- cVal a
-        b' <- cVal b
-        return $ CECast (CTypeBasic r) (CEOp n a' b') -- (CECast (CTypeBasic ta) a') (CECast  | v <- vs' | t <- as ])
-    | APrim (Func _ n as r) _ <- primAPrim p = do
-        vs' <- mapM cVal vs
-        return $ CECast (CTypeBasic r) (CEFunCall n [ CECast (CTypeBasic t) v | v <- vs' | t <- as ])
-    | APrim (Peek t) _ <- primAPrim p, [v] <- vs = do
-        v' <- cVal v
-        return $ CEDoc ("*((" <> t <+> "*)" <> (parens $ pprint v') <> char ')')
-    | APrim (Poke t) _ <- primAPrim p, [v,x] <- vs = do
-        v' <- cVal v
-        x' <- cVal x
-        return $ CEDoc ("*((" <> t <+> "*)" <> (parens $ pprint v') <> text ") = " <> pprint x')
-    | APrim (AddrOf t) _ <- primAPrim p, [] <- vs = do
-        return $ CEDoc ('&':t)
-
---    | Just r <- getPrefix "prim_const." pName , [] <- vs = do
---        return $ CEDoc r
---    | Just r <- getPrefix "prim_op_aaa." pName , [a,b] <- vs = do
---        a' <- cVal a
---        b' <- cVal b
---        return $ CEOp r a' b'
---    | Just r <- getPrefix "prim_op_aaB." pName , [a,b] <- vs = do
---        a' <- cVal a
---        b' <- cVal b
---        return $ CEOp r a' b'
---    | Just r <- getPrefix "prim_op_aa." pName , [a] <- vs = do
---        a' <- cVal a
---        return $ CEUOp r a'
---    |  "@primEq" `isPrefixOf` pName, [a,b] <- vs = do
---        a' <- cVal a
---        b' <- cVal b
---        (_,true) <- newConst vTrue
---        (_,false) <- newConst vFalse
---        return $ CETernary (CEOp "==" a' b') (CEIdent ('c':show true)) (CEIdent ('c':show false))
---    |  "@primCompare" `isPrefixOf` pName, [a,b] <- vs = do
---        a' <- cVal a
---        b' <- cVal b
---        (_,eq) <- newConst $ vOrdering EQ
---        (_,gt) <- newConst $ vOrdering GT
---        (_,lt) <- newConst $ vOrdering LT
---        let ti x = CEIdent ('c':show x)
---        return $ CETernary (CEOp ">" a' b') (ti gt)  (CETernary (CEOp "==" a' b') (ti eq) (ti lt))
---    |  toAtom "@primNegate" ==  primName p, [a] <- vs = do
---        a' <- cVal a
---        return $  (CEOp "-" (CEDoc "0") a')
---    | toAtom "@putChar" == primName p, [a] <- vs = do
---        a' <- cVal a
---        return $ CEFunCall "putchar" [a']
---    | toAtom "@getChar" == primName p, [] <- vs = do
---        tell [CSAuto (CTypeBasic "int") "gc"]
---        tell [CSAssign (CEIdent "gc") (CEFunCall "getchar" [])]
---        return $ CEIdent "gc"
- --   | Just n <- lookup (primName p) bops, [a,b] <- vs = doBop n a b
---    where pName = fromAtom $ primName p
-
---doBop n a b = do
---    a' <- cVal a
---    b' <- cVal b
---    return $ CEOp n a' b'
-
---bops = [(toAtom "@primTimes", "*"), (toAtom "@primPlus", "+"), (toAtom "@primMinus","-")]
-
-declVar (Var n t) = do
-    t' <- toType t
-    return $ CSAuto t' (toVName n)
-
-cb :: Exp -> ReaderT Todo (CGen (State HcHash)) [CStatement]
-cb (Prim p [a,b] :>>= Tup [q,r] :-> e') | primName p == toAtom "@primQuotRem" = do
-    a' <- cVal a
-    b' <- cVal b
-    r' <- cVal r
-    q' <- cVal q
-    ss' <- cb e'
-    q'' <- declVar q
-    r'' <- declVar r
-    return $ [q'', r'' , CSAssign q' (CEOp "/" a' b'), CSAssign r' (CEOp "%" a' b') ] ++ ss'
-
-cb (Return v :>>= (NodeC t as) :-> e') = do
-    v' <- cVal v
-    --let tmp = CECast (toStructTP t)  v'
-    let tmp = CEIndirect v' (toStruct t)
-    as' <- mapM cVal as
-    --let ass = [CSAssign  a (CEIndirect tmp ('a':show i)) | a <- as' | i <- [1 ..] ]
-    let ass = [CSAssign  a (CEDot tmp ('a':show i)) | a <- as' | i <- [( 1 :: Int) ..] ]
-    ss' <- cb e'
-    as' <- mapM declVar as
-    return (as'  ++ ass ++ ss')
-cb (Fetch v :>>= (NodeC t as) :-> e') = do
-    v' <- cVal v
-    --let tmp = CECast (toStructTP t)  v'
-    let tmp = CEIndirect v' (toStruct t)
-    as' <- mapM cVal as
-    --let ass = [CSAssign  a (CEIndirect tmp ('a':show i)) | a <- as' | i <- [1 ..] ]
-    let ass = [CSAssign  a (CEDot tmp ('a':show i)) | a <- as' | i <- [(1 :: Int) ..] ]
-    ss' <- cb e'
-    as' <- mapM declVar as
-    return (as'  ++ ass ++ ss')
-cb (e :>>= Tup [] :-> e') = do
-    ss <- local (const (TodoNothing)) (cb e)
-    ss' <- cb e'
-    return (ss ++ ss')
-cb (e :>>= v@(Var _ _) :-> e') = do
-    v' <- cVal v
-    ss <- local (const (TodoExp v')) (cb e)
-    ss' <- cb e'
-    v'' <- declVar v
-    return (v'':ss ++ ss')
-cb (e :>>= Tup [x] :-> e') = cb (e :>>= x :-> e')
-cb (e :>>= Tup xs :-> e') = do
-    (rs,ret) <- lift $ runSubCGen $ do
-        ts <- mapM (toType . getType) xs
-        st <- newAnonStruct ts
-        ret <- newAuto st
-        return ret
-    ss <- local (const (TodoExp ret)) (cb e)
-    ss' <- cb e'
-    vs <- mapM cVal xs
-    vds <- mapM declVar xs
-    return $ vds ++ rs ++ ss ++ [ v `CSAssign` anonField ret i | v <- vs | i <- [0..] ]  ++ ss'
-
-{-
-    return []
-
-    v' <- cVal v
-    ss <- local (const (TodoExp v')) (cb e)
-    ss' <- cb e'
-    v'' <- declVar v
-    return (v'':ss ++ ss')
-    -}
-cb (Case v@(Var _ t) ls) | t == TyNode = do
-    v' <- cVal v
-    let tag = CEIndirect v' "any.tag"
-        da (v@(Var {}) :-> e) = do
-            v'' <- cVal v
-            e' <- cb e
-            v''' <- declVar v
-            return $ (Nothing,[v''',CSAssign v'' v'] ++ e')
-        da ((NodeC t as) :-> e) = do
-            as' <- mapM cVal as
-            e' <- cb e
-            --let tmp = CECast (toStructTP t)  v'
-            let tmp = CEIndirect v' (toStruct t)
-            --let ass = [CSAssign  a (CEIndirect tmp ('a':show i)) | a <- as' | i <- [1 ..] ]
-            let ass = [CSAssign  a (CEDot tmp ('a':show i)) | a <- as' | i <- [(1 :: Int) ..] ]
-            as' <- mapM declVar as
-            return $ (Just (toTag t), as' ++ ass ++ e')
-    ls' <- mapM da ls
-    return [case_inc, CSSwitch tag ls' ]
-cb (Case v@(Var _ t) ls) = do
-    v' <- cVal v
-    v'' <- return (if t `elem` ptrs then CECast (CTypeBasic "uintptr_t") v' else v')
-    let da (v@(Var {}) :-> e) = do
-            v'' <- cVal v
-            e' <- cb e
-            v''' <- declVar v
-            return $ (Nothing,[v''',CSAssign v'' v'] ++ e')
-        da ((Lit i _) :-> e) = do
-            e' <- cb e
-            return $ (Just (show i), e')
-        da (Tup [x] :-> e) = da ( x :-> e )
-    ls' <- mapM da ls
-    return [case_inc, CSSwitch v'' ls' ]
-
-
-
-cb e = do
-    x <- ask
-    (ss,e) <- lift $  runSubCGen $ cexp e
-    case x of
-        TodoReturn -> return $ ss ++ [CSReturn e]
-        TodoExp v -> return $ ss ++ [CSAssign v e]
-        TodoNothing | e == CEDoc "" -> return ss
-        TodoNothing -> return $ ss ++ [CSExpr e]
-
-case_inc = (CSExpr $ CEFunCall "case_inc" [])
-
-ptrs = [Ty $ toAtom "HsPtr", Ty $ toAtom "HsFunPtr"]
-
-include fn = text "#include <" <> text fn <> text ">"
-
-{-# NOINLINE compileGrin #-}
-compileGrin :: Grin -> (String,[String])
-compileGrin grin = (hsffi_h ++ jhc_rts_c ++ P.render ans ++ "\n", snub (reqLibraries req))  where
-    tags = (tagHole,[]):sortUnder (show . fst) [ (t,runIdentity $ findArgs (grinTypeEnv grin) t) | t <- Set.toList $ freeVars (snds $ grinFunctions grin) `mappend` freeVars (snds $ grinCafs grin), tagIsTag t]
-    et = text "typedef enum {" $$ nest 4 (P.fsep (punctuate P.comma (map (toTag . fst) tags))) $$ text  "} tag_t;"
-    --ans = vcat $ [text "#include \"HsFFI.h\"",text "#include <stdlib.h>",text "#include <stdio.h>",text "#include <string.h>",text "#include <unistd.h>",text "#include <malloc.h>",text "",et,text "",text "typedef union node node_t;",text ""] ++ map cs tags ++ [text "",cn,text "",so,text "",text "/* Begin CAFS */"] ++ map ccaf (grinCafs grin) ++ [text "", consts, text "",text  "/* Begin Functions */",jhc_error] ++ map prettyFuncP funcs ++ (map prettyFunc funcs) ++ [mf]
-    ans = vcat $ map include (snub $ reqIncludes req) ++ [text "",et,text ""] ++ decls' ++ map cs tags ++ [text "",cn,text "",so,text "",text "/* Begin CAFS */"] ++ map ccaf (grinCafs grin) ++ [text "", consts, text "",text  "/* Begin Functions */"] ++ map prettyFuncP funcs ++ (map prettyFunc funcs)
-    cs (t,ts) = prettyDecl $ CStruct (toStruct t) ((tag_t, "tag"):map cst (zip [1..] ts))
-    cst (i,t) = (runIdentity $ toType' t, text $ 'a':show i)
-    cn = text $  "union node {\n  struct { tag_t tag; } any;\n" <> mconcat (map cu (fsts tags)) <> text "};"
-    cu t = text "  struct" <+> (toStruct t) <+> toStruct t <> text ";\n"
-    so = prettyDecl $ CFunc size_t "jhc_sizeof" [(tag_t,"tag")] [CSDoc $ "switch(tag) {\n" ++ concatMap cs (fsts tags) ++ "}\n_exit(33);"]  where
-        cs t = text "  case " <> toTag t <> char ':' <+> text "return sizeof(struct " <> toStruct t <> text ");\n"
-    funcs = sortUnder cFuncName funcs'
-    decls' = map prettyDecl decls
-    --(funcs',fh) =  runState sdo emptyHcHash
-    ((funcs',CGenState { genStateRequires = req, genStateDecls = decls }),fh) = runState  (runCGen 1 (mapM (cfunc $ grinTypeEnv grin) $ grinFunctions grin)) emptyHcHash
-    consts = P.vcat (map cc (Grin.HashConst.toList fh)) where
-        cc nn@(HcNode a zs,i) = comm $$ cd $$ def where
-            comm = text "/* " <> tshow (nn) <> text " */"
-            cd = text "static struct " <> toStruct a <+> text "_c" <> tshow i <+> text "= {" <> hsep (punctuate P.comma (toTag a:rs)) <> text "};"
-            def = text "#define c" <> tshow i <+> text "((node_t *)&_c" <> tshow i <> text ")"
-            rs = [ f z undefined |  z <- zs ]
-            --ts = findArgs (grinTypeEnv grin) a
-            f (Right i) _ = text $ 'c':show i
-            --f (Left i) _ = tshow i
-            f (Left (Var n _)) _ =  toVName n
-            f (Left (Lit i _)) _ = tshow i
-            f (Left (Tag t)) _ = toTag t
-
-
-
---mf = text "int main(int argc, char *argv[]) { XAmain(); return 0; }"
---jhc_error = text "static void jhc_error(char *s) { fputs(s,stderr); fputs(\"\\n\",stderr);  exit(1); }"
-
-
rmfile ./C/FromGrin.hs
move ./C/FromGrin2.hs ./C/FromGrin.hs
hunk ./C/Gen.hs 1
-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
-
-
-import Char
-import Control.Monad.State
-import Data.Monoid
-import List
-import Maybe
-import Numeric
-import qualified Data.Map as Map
-import qualified Text.PrettyPrint.HughesPJ as P
-import Text.PrettyPrint.HughesPJ(nest,render,($$),($+$))
-
-import Atom
-import C.Prims
-import Doc.DocLike
-import Doc.PPrint
-import GenUtil
-
-
-data CType = CTypeBasic String | CTypePointer CType | CTypeStruct String
-    deriving(Ord,Eq)
-data CDecl = CFunc CType String [(CType,String)] [CStatement] | CVar CType String | CStruct String [(CType,String)]
-    deriving(Ord,Eq)
-data CStatement = CSAssign CExpr CExpr | CSExpr CExpr | CSAuto CType String | CSReturn CExpr | CSDoc String | CSSDoc P.Doc | CSSwitch CExpr [(Maybe String,[CStatement])]
-    deriving(Ord,Eq)
-data CExpr = CEIdent String | CEFunCall String [CExpr] | CELiteral CLit | CEDot CExpr String | CEIndirect CExpr String | CESizeof CType | CECast CType CExpr | CEEval CExpr | CEDoc String | CEVar CType String | CETernary CExpr CExpr CExpr | CEOp String CExpr CExpr  | CEUOp String CExpr
-    deriving(Ord,Eq)
-data CLit = CLitChar Char | CLitInt Int | CLitNull
-    deriving(Ord,Eq)
-
-instance Ord P.Doc where
-    compare _ _ = EQ
-
-instance Eq P.Doc where
-    _ == _ = True
-
-data CFunction = CFunction {
-    cFuncComments :: String,
-    cFuncName :: String,
-    cFuncReturnType :: CType,
-    cFuncArgs :: [(CType,String)],
-    cFuncPublic :: Bool,
-    cFuncBody :: [CStatement]
-    }
-
-cfunction = CFunction { cFuncComments = "", cFuncName = "_unknown", cFuncReturnType = CTypeBasic "void", cFuncArgs = [], cFuncPublic = False, cFuncBody = [] }
-
-instance PPrint P.Doc CFunction where
-    pprint = prettyFunc
-
-instance DocLike d => PPrint d CExpr where
-    pprint = prettyExpr
-
-prettyFunc :: CFunction -> P.Doc
-prettyFunc cf =  ans where
-    comm = if null (cFuncComments cf) then empty else  text "/*" <+> text (cFuncComments cf) <+> text "*/"
-    ans = comm $$ prettyDecl (fdecl cf)
-
-prettyFuncP cf = prettyProto (fdecl cf)
-
-fdecl cf = CFunc (cFuncReturnType cf) (cFuncName cf) (cFuncArgs cf) (cFuncBody cf)
-
-
-newtype CIdent = CIdent String
-
-class ToCIdent a where
-    toCIdent :: a -> CIdent
-
-
-instance ToCIdent String where
-    toCIdent xs = CIdent $ concatMap f xs where
-        f '.' = "XD"
-        f '@' = "XA"
-        f ',' = "XC"
-        f '(' = "XL"
-        f ')' = "XR"
-        f '_' = "_"
-        f 'X' = "XX"
-        f c | isAlphaNum c = [c]
-        f c = 'X':showHex (ord c) ""
-
-instance ToCIdent Atom where
-    toCIdent a = toCIdent (fromAtom a :: String)
-
-instance Show CIdent where
-    show (CIdent x) = x
-
-
------------------------------------------
--- high level monad for generating C code
------------------------------------------
-
-
-data CGenState = CGenState {
-    genStateAnonStructs :: Map.Map [CType] CType,
-    genStateDecls :: [CDecl],
-    genStateStatements :: [CStatement],
-    genStateFunctions :: [CFunction],
-    genStateRequires :: Requires,
-    genUnique :: {-# UNPACK #-} !Int
-    }
-    {-! derive: update !-}
-
-cGenState = CGenState {
-    genStateAnonStructs = Map.empty,
-    genStateDecls = [],
-    genStateStatements = [],
-    genStateFunctions = [],
-    genStateRequires = mempty,
-    genUnique = 1
-    }
-
-newtype CGen m a = CGen (StateT CGenState m a)
-    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
-
-
-runCGen u (CGen x) = runStateT x (cGenState { genUnique = u })
-unCGen (CGen x) = x
-
-addStmts x = addStatements x
-
-runSubCGen :: Monad m => CGen m a -> CGen m ([CStatement], a)
-runSubCGen (CGen x) = CGen $ do
-    CGenState { genUnique = v, genStateAnonStructs = anonS } <- get
-    (r,CGenState { genStateRequires = req, genStateAnonStructs = as, genStateDecls = d, genStateStatements = s, genUnique = v' }) <- lift $ runStateT x cGenState { genUnique = v, genStateAnonStructs = anonS }
-    unCGen $ addDecls d
-    modify (genUnique_s v' . genStateRequires_u (mappend req) . genStateAnonStructs_s as)
-    return (s,r)
-
-addDecl d = addDecls [d]
-
-addStatement s = addStmts [s]
-addRequires r = CGen $ modify (genStateRequires_u (mappend r))
-
-
-addFunction :: Monad m => CFunction -> CGen m ()
-addFunction fn = CGen $ modify f where
-    f cg = cg { genStateFunctions = genStateFunctions cg ++ [fn]}
-
-newIdent' :: Monad m => CGen m String
-newIdent' = CGen $ do
-    let f cg  =  cg { genUnique = genUnique cg + 1}
-    CGenState { genUnique = i } <- get
-    modify f
-    return ('_':show i)
-
----------------------------------------
--- utility functions for declaring code
----------------------------------------
-
--- naming helpers
-
-func n = 'f':show n
-auto n = 'a':show n
-var n = 'v':show n
-
-funcE n = ceIdent (func n)
-autoE n = ceIdent (auto n)
-varE n = ceIdent (var n)
-
--- simple constructors
-
-ptr p = CTypePointer p
-cInt i = (CELiteral (CLitInt i))
-cVar v = (ceIdent v)
-
-structT n = ptr $ CTypeStruct ('s':show n)
-ceIdent = CEIdent
-ceFunCall = CEFunCall
-ceError s = CEDoc (text "error_thunk" <> parens (text (show s)))
-
--- simple values
-tEval = CTypeBasic "eval_fn_t"
-cVoid = CTypeBasic "void"
-cThunk = CTypePointer (CTypeBasic "thunk_t")
-cNull = (CELiteral CLitNull)
-cVoidStar = CTypePointer cVoid
-ctInt = CTypeBasic "int"
-tEv = (CTypePointer $ CTypeBasic "eval_thunk_t")
-
-
-
-
-cAssign n e = CSAssign (autoE n) e
-
-addComment s = addStmts [CSDoc (text "/* " <> text s <> text " */")]
-
-
-{-
-cBlock :: Monad m => CGen m () -> CGen m [CStatement]
-cBlock v = do
-    (s,()) <- runSubCGen v
-    let (as, ns) = partition isAuto s
-    addStmts as
-    return ns
-  -}
-
-
-tup_names = [ 't':show i | i <- [ (1::Int) .. ]]
-
-
-
-
-anonField :: CExpr -> Int -> CExpr
-anonField c i = CEDot c (tup_names !! i)
-
-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
-
-
-
-
-----------------------------------
--- code emmission, Pretty Printing
-----------------------------------
-
-
-prettyC :: [CDecl] -> String
-prettyC (cf) = render (header $$$
-    ((vcat $ map prettyDecl sts) $$$ (vcat $ map prettyProto fns) $$$
-	(vcat $ map prettyDecl vars) $$$ (vcat $ map prettyDecl fns)) $$$ text "")  where
-    vars = filter isVar cf
-    fns = filter isFn cf
-    sts = filter isStruct cf
-    isVar (CVar _ _) = True
-    isVar _ = False
-    isFn (CFunc _ _ _ _) = True
-    isFn _ = False
-    isStruct (CStruct _ _) = True
-    isStruct _ = False
-    header =  text "#include <malloc.h>" $$
-	text "#include \"jhc_rts.h\"" $$ text ""
-
---a $$ b = a <> char '\n' <>  b
-
---a $+$ b = a $$ b
---semi = char ';'
---nest _ x = x
-
-a $$$ b = a $$ text "" $$ b
-
-
-attributes CTypePointer {} = text "A_REGPARM" <+> text "A_MALLOC"
-attributes _ = text "A_REGPARM"
-
-prettyArgs [] = text "void"
-prettyArgs args = hcat (punctuate (text ", ") (map (\(t,i) -> prettyType t <+> text i) $ args))
-
-prettyDecl (CFunc rt n args code) = text "static" <+> prettyType rt <+> attributes rt $$ text n <> text "(" <> prettyArgs args <> text ")" $+$
-    text "{" $+$ nest 8 (prettyCode code) $+$ text "}"
-prettyDecl  (CVar t n) = prettyType t <+> text n <> semi
-prettyDecl (CStruct n vs) = text "struct" <+> text n <+> text "{" $$ nest 8 (vcat (map sd vs)) $$ text "};" where
-    sd (t,n) = prettyType t <+> text n <> semi
-
-prettyProto (CFunc rt n args _) = text "static" <+> prettyType rt <+> text n <> parens (prettyArgs args) <+> attributes rt <> semi
-prettyProto (CStruct n _) = text "struct" <+> text n <> semi
---prettyProto (CStruct n vs) = text "struct" <+> text n <+> text "{" $$ nest 8 (vcat (map sd vs)) $$ text "};" where
---    sd (t,n) = prettyType t <+> text n <> semi
-
-prettyCode = prettyCode' True
-prettyCode' showSa (ss) = vcat $ map ps ((if showSa then snub sa else [])  ++ sb) where
-    ps (CSAssign n e) = prettyExpr n <+> text "=" <+> prettyExpr e <> text ";"
-    ps (CSExpr e) = prettyExpr e <> semi
-    ps (CSAuto t n) = prettyType t <+> text n <> semi
-    ps (CSReturn e) = text "return" <+> prettyExpr e <> semi
-    ps (CSSwitch e ts) = text "switch" <+> parens (prettyExpr e) <+> char '{' <$> vcat (map sc ts) <$> md <$>  char '}' where
-        sc (Just x,ss) = text "case" <+> text x <> char ':' $$ nest 4  (prettyCode' False ss $$ text "break;")
-        sc (Nothing,ss) = text "default:" $$ nest 4  (prettyCode' False ss) $$ text "break;"
-        md = if any isNothing (fsts ts) then empty else text "default: jhc_case_fell_off(__LINE__);"
-    ps (CSDoc d) = text d
-    ps (CSSDoc d) = d
-    sa = collectAuto ss
-    sb = filter (not . isAuto) ss
-    collectAuto ss = filter isAuto ss ++ concatMap f ss where
-        f (CSSwitch _ ts) = concat [collectAuto x | (_,x) <- ts]
-        f _ = []
-    --(sa, sb) = partition isAuto ss
-
-isAuto (CSAuto _ _) = True
-isAuto _ = False
-
-prettyLit :: DocLike d => CLit -> d
-prettyLit (CLitInt i) = text (show i)
-prettyLit (CLitChar c) = text $ show c
-prettyLit CLitNull = text "NULL"
-
-
-
-prettyExpr :: DocLike d => CExpr -> d
-prettyExpr (CEIdent n) = text n
-prettyExpr (CELiteral l) = prettyLit l
-prettyExpr (CEFunCall n ce) = text n <> parens (hcat (intersperse (text ", ") (map prettyExpr ce)))
-prettyExpr (CEDot (CEIndirect (CEIdent n) x) y) = text n <> text "->" <> text x <> text "." <> text y
-prettyExpr (CEDot (CEIndirect e x) y) = (parens $ prettyExpr e) <> text "->" <> text x <> text "." <> text y
-prettyExpr (CEIndirect e "") = text "*" <> (parens $ prettyExpr e)
-prettyExpr (CEIndirect (CEIdent i) n) = text i <> text "->" <> text n
-prettyExpr (CEIndirect e n) = (parens $ prettyExpr e) <> text "->" <> text n
-prettyExpr (CEDot e n) = (parens $ prettyExpr e) <> text "." <> text n
-prettyExpr (CESizeof t) = text "sizeof" <>(parens $ prettyType t)
-prettyExpr (CECast t e) = parens (prettyType t) <> prettyExpr e
-prettyExpr (CEEval e) = (prettyExpr (CEIndirect e "eval"))  <>  parens (prettyExpr e)
-prettyExpr (CEDoc d) = text d
-prettyExpr (CEOp s a b) = parens $ prettyExpr a <+> text s <+> prettyExpr b
-prettyExpr (CEUOp s a) = parens $ text s <+> prettyExpr a
-prettyExpr (CETernary x a b) = parens $ prettyExpr x <+> char '?' <+> prettyExpr a <+> char ':' <+> prettyExpr b
-
-prettyType :: DocLike d => CType -> d
-prettyType (CTypeBasic s) = text s
-prettyType (CTypePointer t) = prettyType t <> text "*"
-prettyType (CTypeStruct s) = text "struct" <+> text s
-
-
-
-instance MonadState x m => MonadState x (CGen m) where
-    get = lift $ get
-    put x = lift $ put x
-
rmfile ./C/Gen.hs
hunk ./C/FromGrin.hs 2
-module C.FromGrin2(compileGrin) where
+module C.FromGrin(compileGrin) where
hunk ./Main.hs 15
-import C.FromGrin2
+import C.FromGrin