[remove old grin back end.
John Meacham <john@repetae.net>**20070509094922] hunk ./C/FromGrin.hs 1
-
-module C.FromGrin(compileGrin) where
-
-import Control.Monad.Identity
-import Control.Monad.Reader
-import Control.Monad.RWS
-import Control.Monad.State
-import Data.Monoid
-import List(intersperse)
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified Text.PrettyPrint.HughesPJ as P
-import Text.PrettyPrint.HughesPJ(nest,($$))
-
-import Atom
-import PackedString
-import Support.CanType
-import Grin.Noodle
-import C.FFI
-import C.Generate
-import C.Prims
-import Doc.DocLike
-import Doc.PPrint
-import Support.FreeVars
-import GenUtil
-import Grin.Grin
-import Grin.Val
-import Grin.HashConst
-import Grin.Show
-import RawFiles(hsffi_h,jhc_rts_header_h,jhc_rts_alloc_c,jhc_rts_c)
-import Util.UniqueMonad
-
-
-newtype C a = C (RWST (Todo,Map.Map Atom (Name,[Expression])) Requires HcHash Uniq a)
-    deriving(Monad,UniqueProducer,MonadState HcHash)
-
-data Todo = TodoReturn | TodoExp Expression | TodoNothing
-
-runC :: C a -> (a,HcHash,Requires)
-runC (C m) =  execUniq1 (runRWST m (TodoNothing,mempty) emptyHcHash)
-
-
-fetchVar :: Var -> Ty -> C Expression
-fetchVar v@(V n) _ | n < 0 = return $ (variable  $ varName v)
-fetchVar v ty = do
-    t <- convertType ty
-    return $ (localVariable t (varName v))
-
-varName (V n) | n < 0 = name $ 'g':show (- n)
-varName (V n) = name $ 'v':show n
-
-node_t = basicType "node_t"
-pnode_t = ptrType node_t
-ppnode_t = ptrType (ptrType node_t)
-size_t = basicType "size_t"
-tag_t = basicType "tag_t"
-
-profile_update_inc = expr $ functionCall (name "jhc_update_inc") []
-profile_case_inc = expr $ functionCall (name "jhc_case_inc") []
-profile_function_inc = expr $ functionCall (name "jhc_function_inc") []
-
-convertVal :: Val -> C Expression
-convertVal (Var v ty) = fetchVar v ty
-convertVal (Const (NodeC h _)) | h == tagHole = return nullPtr
-convertVal (Const h) = do
-    (_,i) <- newConst h
-    return $ variable (name $  'c':show i )
-convertVal h@NodeC {} | valIsConstant h = do
-    (_,i) <- newConst h
-    return $ variable (name $  'c':show i )
-convertVal (Lit i _) = return (constant $ number (fromIntegral i))
-convertVal (Tup [x]) = convertVal x
-convertVal (Tup []) = return emptyExpression
---convertVal (Index x y) = do
---    x <- convertVal x
---    y <- convertVal y
---    return $ indexArray x y
-convertVal (Tup xs) = do
-    ts <- mapM convertType (map getType xs)
-    xs <- mapM convertVal xs
-    return (structAnon (zip xs ts))
-convertVal (Tag t) = return $ constant (enum $ nodeTagName t)
-convertVal (ValPrim (APrim p _) [] _) = case p of
-    CConst s _ -> return $ expressionRaw s
-    AddrOf t -> return $ expressionRaw ('&':unpackPS t)
-    PrimTypeInfo { primArgType = arg, primTypeInfo = PrimSizeOf } -> return $ expressionRaw ("sizeof(" ++ arg ++ ")")
-    PrimString s -> return $ expressionRaw (show s)
-    x -> return $ err ("convertVal: " ++ show x)
-convertVal (ValPrim (APrim p _) [x] _) = do
-    x' <- convertVal x
-    case p of
-        CCast _ to -> return $ cast (basicType to) x'
-        Operator n [_] r ->  return $ cast (basicType r) (uoperator n x')
-        x -> return $ err ("convertVal: " ++ show x)
-convertVal (ValPrim (APrim p _) [x,y] _) = do
-    x' <- convertVal x
-    y' <- convertVal y
-    case p of
-        Operator n [_,_] r -> return $ cast (basicType r) (operator n x' y')
-        x -> return $ err ("convertVal: " ++ show x)
-
-convertVal x = return $ err ("convertVal: " ++ show x)
-
-convertExp :: Exp -> C (Statement,Expression)
-convertExp (Error s t) = do
-    let f (TyPtr _) = return nullPtr
-        f TyNode = return nullPtr
-        f (TyTup []) = return emptyExpression
-        f (TyTup xs) = do ts <- mapM convertType xs; xs <- mapM f xs ; return $ structAnon (zip xs ts)
-        f (Ty x) = return $ cast (basicType (show x)) (constant $ number 0)
-        f TyTag  = return $ constant (enum $ nodeTagName tagHole)
-        f x = return $ err $ "error-type " ++ show x
-    ev <- f t
-    if null s
-      then return (expr $ functionCall (name "jhc_exit") [constant $ number 255],ev)
-       else return (expr $ functionCall (name "jhc_error") [string s],ev)
-convertExp (App a vs _) = do
-    lm <- C $ asks snd
-    vs' <- mapM convertVal vs
-    case a `Map.lookup` lm of
-        Just (nm,as) -> do
-            let ss = [ a `assign` v | a <- as | v <- vs' ]
-            return (mconcat ss `mappend` goto nm, emptyExpression)
-        Nothing -> return $ (mempty, functionCall (toName (toString a)) vs')
-convertExp (Fetch v) | getType v == TyPtr TyNode = do
-    v <- convertVal v
-    return (mempty,v)
-convertExp (Fetch (Index base off)) | getType base == TyPtr (TyPtr TyNode) = do
-    base <- convertVal base
-    off <- convertVal off
-    return (mempty,indexArray base off)
-convertExp (Fetch v) | getType v == TyPtr (TyPtr TyNode) = do
-    v <- convertVal v
-    return (mempty,dereference v)
-convertExp (Store n@NodeV {}) = newNode n
-convertExp (Return n@NodeV {}) = newNode n
-convertExp (Store n@NodeC {}) = newNode n
-convertExp (Return n@NodeC {}) = newNode n
-
-convertExp (Store n@Var {}) | getType n == TyNode = do
-    (ss,nn) <- newNode (NodeC tagHole [])
-    tmp <- newVar pnode_t
-    n <- convertVal n
-    let tag = project' anyTag n
-        update = expr (functionCall (name "memcpy") [tmp,n,functionCall  (name "jhc_sizeof") [tag]])
-    return (ss `mappend` (tmp `assign` nn) `mappend` update, tmp)
-convertExp (Store v) | TyPtr TyNode == getType v = do
-    v <- convertVal v
-    tmp <- newVar ppnode_t
-    return ((tmp `assign` jhc_malloc (sizeof pnode_t)) `mappend` (dereference tmp `assign` v),tmp)
-convertExp Alloc { expValue = v, expCount = c, expRegion = r } | r == region_heap, TyPtr TyNode == getType v  = do
-    v' <- convertVal v
-    c' <- convertVal c
-    tmp <- newVar ppnode_t
-    let malloc = tmp `assign` jhc_malloc (operator "*" (sizeof pnode_t) c')
-    fill <- case v of
-        ValUnknown _ -> return mempty
-        _ -> do
-            i <- newVar (basicType "int")
-            return $ forLoop i (expressionRaw "0") c' $ indexArray tmp i `assign` v'
-    return (malloc `mappend` fill, tmp)
-convertExp (Return v) = do
-    v <- convertVal v
-    return (mempty,v)
-convertExp (Prim p vs) | APrim _ req <- primAPrim p  =  do
-    addRequires req
-    e <- convertPrim p vs
-    return (mempty,e)
-convertExp e@(Update v z) | getType v /= TyPtr (getType z) = do
-    return (err (show e),err "nothing")
-convertExp (Update v@Var {} (NodeC t as)) | getType v == TyPtr TyNode = do
-    v' <- convertVal v
-    as' <- mapM convertVal as
-    nt <- nodeTypePtr t
-    let tmp' = cast nt v'
-        s = project' tag tmp' `assign` constant (enum (nodeTagName t))
-        ass = [project' (arg i) tmp' `assign` a | a <- as' | i <- [(1 :: Int) ..] ]
-    return (mconcat $ profile_update_inc:s:ass,emptyExpression)
-convertExp (Update v@Var {} (NodeV t [])) | getType v == TyPtr TyNode = do
-    v' <- convertVal v
-    t' <- convertVal (Var t TyTag)
-    let tag = project' anyTag v'
-    return (tag `assign` t',emptyExpression)
-convertExp (Update (Index base off) z) | getType z == TyPtr TyNode = do
-    base <- convertVal base
-    off <- convertVal off
-    z' <- convertVal z
-    return $ (indexArray base off `assign` z',emptyExpression)
-convertExp (Update v z) | getType z == TyPtr TyNode = do
-    v' <- convertVal v
-    z' <- convertVal z
-    return $ (dereference v' `assign` z',emptyExpression)
-convertExp (Update v z) | getType z == TyNode = do  -- TODO eliminate unknown updates
-    v' <- convertVal v
-    z' <- convertVal z
-    let tag = project' anyTag z'
-    return $ (profile_update_inc,functionCall (name "memcpy") [v',z',functionCall  (name "jhc_sizeof") [tag]])
-convertExp e = return (err (show e),err "nothing")
-
-convertType TyTag = return tag_t
-convertType TyNode = return pnode_t
-convertType (TyPtr TyNode) = return pnode_t
-convertType (TyPtr (TyPtr TyNode)) = return ppnode_t
-convertType (Ty t) = return (basicType (toString t))
-convertType (TyTup []) = return voidType
-convertType (TyTup [x]) = convertType x
-convertType (TyTup xs) = do
-    xs <- mapM convertType xs
-    return (anonStructType xs)
-
-addRequires req = C $ tell req
-
-nodeTagName :: Atom -> Name
-nodeTagName a = toName (toString a)
-
-nodeFuncName :: Atom -> Name
-nodeFuncName a = toName (toString a)
-
-nodeStructName :: Atom -> Name
-nodeStructName a = toName ('s':toString a)
-
-nodeType a = return $ structType (nodeStructName a)
-nodeTypePtr a = liftM ptrType (nodeType a)
-
-jhc_malloc sz = functionCall (name "jhc_malloc") [sz]
-jhc_malloc_atomic sz = functionCall (name "jhc_malloc_atomic") [sz]
-tag = name "tag"
-anyTag = name "any.tag"
-arg i = name $ 'a':show i
-
-newNode (NodeV t []) = do
-    tmp <- newVar pnode_t
-    var <- fetchVar t TyTag
-    let tmp' = project' anyTag tmp
-        malloc =  tmp `assign` jhc_malloc (sizeof  node_t)
-        tagassign = tmp' `assign` var
-    return (mappend malloc tagassign, tmp)
-newNode (NodeC t _) | t == tagHole = do
-    return $  (mempty,jhc_malloc (sizeof node_t))
-newNode (NodeC t as) = do
-    st <- nodeType t
-    as' <- mapM convertVal as
-    tmp <- newVar pnode_t
-    let tmp' = project' (nodeStructName t) tmp
-        malloc =  tmp `assign` wmalloc (sizeof  (if tagIsWHNF t then st else node_t))
-        tagassign = project tag tmp' `assign` constant (enum $ nodeTagName t)
-        wmalloc = if tagIsWHNF t && all (nonPtr . getType) as then jhc_malloc_atomic else jhc_malloc
-        ass = [ if isValUnknown aa then mempty else project (arg i) tmp' `assign` a | a <- as' | aa <- as | i <- [(1 :: Int) ..] ]
-        nonPtr TyPtr {} = False
-        nonPtr TyNode = False
-        nonPtr (TyTup xs) = all nonPtr xs
-        nonPtr _ = True
-    return (mconcat $ malloc:tagassign:ass, cast pnode_t tmp)
-
---convertPrim p vs = return (mempty,err $ show p)
-convertPrim p vs
-    | APrim (CConst s _) _ <- primAPrim p = do
-        return $ expressionRaw s
-    | APrim (CCast _ to) _ <- primAPrim p, [a] <- vs = do
-        a' <- convertVal a
-        return $ cast (basicType to) a'
-    | APrim (Operator n [ta] r) _ <- primAPrim p, [a] <- vs = do
-        a' <- convertVal a
-        return $ cast (basicType r) (uoperator n a')
-    | APrim (Operator n [ta,tb] r) _ <- primAPrim p, [a,b] <- vs = do
-        a' <- convertVal a
-        b' <- convertVal b
-        return $ cast (basicType r) (operator n a' b')
-    | APrim (Func _ n as r) _ <- primAPrim p = do
-        vs' <- mapM convertVal vs
-        return $ cast (basicType r) (functionCall (name $ unpackPS n) [ cast (basicType t) v | v <- vs' | t <- as ])
-    | APrim (Peek t) _ <- primAPrim p, [v] <- vs = do
-        v' <- convertVal v
-        return $ expressionRaw ("*((" <> t <+> "*)" <> (parens $ renderG v') <> char ')')
-    | APrim (Poke t) _ <- primAPrim p, [v,x] <- vs = do
-        v' <- convertVal v
-        x' <- convertVal x
-        return $ expressionRaw ("*((" <> t <+> "*)" <> (parens $ renderG v') <> text ") = " <> renderG x')
-    | APrim (AddrOf t) _ <- primAPrim p, [] <- vs = do
-        return $ expressionRaw ('&':unpackPS t)
-
-
-localJumps xs (C action) = C $ local (\ (x,y) -> (x,Map.fromList xs `mappend` y)) action
-
-convertBody :: Exp -> C Statement
-convertBody (Prim p [a,b] :>>= Tup [q,r] :-> e') | primName p == toAtom "@primQuotRem" = do
-    a' <- convertVal a
-    b' <- convertVal b
-    r' <- convertVal r
-    q' <- convertVal q
-    ss' <- convertBody e'
-    return $ mconcat [ assign q' (operator "/" a' b'), assign r' (operator "%" a' b'), ss' ]
-
-convertBody Let { expDefs = defs, expBody = body } = do
-    u <- newUniq
-    nn <- flip mapM defs $ \FuncDef { funcDefName = name, funcDefBody = Tup as :-> _ } -> do
-        vs' <- mapM convertVal as
-        let nm = (toName (show name ++ show u))
-        return (name,(nm,vs'))
-    localJumps nn $ do
-    let done = (toName $ "done" ++ show u)
-    ss <- (convertBody body)
-    rs <- flip mapM defs $ \FuncDef { funcDefName = name, funcDefBody = Tup as :-> b } -> do
-       ss <- convertBody b
-       return (annotate (show as) (label (toName (show name ++ show u))) `mappend` indentBlock ss)
-    return (ss `mappend` goto done `mappend` mconcat (intersperse (goto done) rs) `mappend` label done);
-
-
-
-convertBody (Return v :>>= (NodeC t as) :-> e') = nodeAssign v t as e'
-convertBody (Fetch v :>>= (NodeC t as) :-> e') = nodeAssign v t as e'
-convertBody (Return v :>>= (NodeV t []) :-> e') = nodeAssignV v t e'
-convertBody (Fetch v :>>= (NodeV t []) :-> e') = nodeAssignV v t e'
-convertBody (e :>>= v@(Var _ _) :-> e') = do
-    v' <- convertVal v
-    ss <- localTodo (TodoExp v')  (convertBody e)
-    ss' <- convertBody e'
-    return (ss `mappend` ss')
-convertBody (e :>>= Tup [] :-> e') = do
-    ss <- localTodo TodoNothing (convertBody e)
-    ss' <- convertBody e'
-    return (ss `mappend` ss')
-convertBody (e :>>= Tup [x] :-> e') = convertBody (e :>>= x :-> e')
-convertBody (e :>>= Tup xs :-> e') = do
-    ts <- mapM ( convertType . getType) xs
-    st <- newVar (anonStructType ts)
-    ss <- localTodo (TodoExp st) (convertBody e)
-    ss' <- convertBody e'
-    vs <- mapM convertVal xs
-    return $  ss `mappend` mconcat [ v `assign` projectAnon i st | v <- vs | i <- [0..] ] `mappend` ss'
-
-convertBody (Case v@(Var _ ty) [p1@(NodeC t _) :-> e1,p2 :-> e2]) | ty == TyNode = do
-    scrut <- convertVal v
-    let tag = project' anyTag scrut
-        da v@Var {} _ = do
-            v'' <- convertVal v
-            return $ assign v'' scrut
-        da n1@(NodeC t _) (Return n2@NodeC {}) | n1 == n2 = convertBody (Return v)
-        da (NodeC t as) e = do
-            as' <- mapM convertVal as
-            let tmp = project' (nodeStructName t) scrut
-                ass = mconcat [if needed a then assign  a' (project (arg i) tmp) else mempty | a' <- as' | a <- as | i <- [(1 :: Int) ..] ]
-                fve = freeVars e
-                needed (Var v _) = v `Set.member` fve
-            return ass
-        am | isVar p2 = id
-           | otherwise = annotate (show p2)
-    e1' <- convertBody e1
-    e2' <- convertBody e2
-    p1' <- da p1 e1
-    p2' <- liftM am $ da p2 e2
-    return $ profile_case_inc `mappend` cif (operator "==" (constant $ enum (nodeTagName t)) tag) (p1' `mappend` e1') (p2' `mappend` e2')
-
-convertBody (Case v@(Var _ t) ls) | t == TyNode = do
-    scrut <- convertVal v
-    let tag = project' anyTag scrut
-        da (v@(Var {}) :-> e) = do
-            v'' <- convertVal v
-            e' <- convertBody e
-            return $ (Nothing,assign v'' scrut `mappend` e')
-        da (n1@(NodeC t _) :-> Return n2@NodeC {}) | n1 == n2 = do
-            e' <- convertBody (Return v)
-            return (Just (enum (nodeTagName t)),e')
-        da ((NodeC t as) :-> e) = do
-            as' <- mapM convertVal as
-            e' <- convertBody e
-            let tmp = project' (nodeStructName t) scrut
-                ass = mconcat [if needed a then assign  a' (project (arg i) tmp) else mempty | a' <- as' | a <- as | i <- [(1 :: Int) ..] ]
-                fve = freeVars e
-                needed (Var v _) = v `Set.member` fve
-            return $ (Just (enum (nodeTagName t)), ass `mappend` e')
-    ls' <- mapM da ls
-    return $ profile_case_inc `mappend` switch' tag ls'
-
-convertBody (Case v@(Var _ t) [p1 :-> e1, p2 :-> e2]) | Set.null ((freeVars p2 :: Set.Set Var) `Set.intersection` freeVars e2) = do
-    scrut <- convertVal v
-    let ptrs = [Ty $ toAtom "HsPtr", Ty $ toAtom "HsFunPtr"]
-        scrut' = (if t `elem` ptrs then cast (basicType "uintptr_t") scrut else scrut)
-        cp (Lit i _) = constant (number $ fromIntegral i)
-        cp (Tag t) = constant (enum (nodeTagName t))
-        am | isVar p2 = id
-           | otherwise = annotate (show p2)
-    e1' <- convertBody e1
-    e2' <- convertBody e2
-    return $ profile_case_inc `mappend` cif (operator "==" (cp p1) scrut') e1' (am e2')
-
-convertBody (Case v@(Var _ t) ls) = do
-    scrut <- convertVal v
-    let ptrs = [Ty $ toAtom "HsPtr", Ty $ toAtom "HsFunPtr"]
-        scrut' = (if t `elem` ptrs then cast (basicType "uintptr_t") scrut else scrut)
-        da (v@(Var {}) :-> e) = do
-            v'' <- convertVal v
-            e' <- convertBody e
-            return (Nothing,assign v'' scrut `mappend` e')
-        da ((Lit i _) :-> e) = do
-            e' <- convertBody e
-            return $ (Just (number $ fromIntegral i), e')
-        da (Tag t :-> e) = do
-            e' <- convertBody e
-            return $ (Just (enum (nodeTagName t)), e')
-        da (Tup [x] :-> e) = da ( x :-> e )
-    ls' <- mapM da ls
-    return $ profile_case_inc `mappend` switch' scrut' ls'
-
-
-convertBody e = do
-    (x,_) <- C ask
-    (ss,er) <- convertExp e -- lift $  runSubCGen $ cexp e
-    case x of
-        TodoReturn -> return (ss `mappend` creturn er)
-        TodoExp v | isEmptyExpression er -> return ss
-        TodoExp v -> return (ss `mappend` (v `assign` er))
-        TodoNothing | isEmptyExpression er -> return ss
-        TodoNothing -> return (ss `mappend` expr er)
-
-convertBody e = return $ err (show e)
-
-nodeAssign v t as e' = do
-    v' <- convertVal v
-    let tmp = project' (nodeStructName t) v'
-        fve = freeVars e'
-    as' <- mapM convertVal as
-    let ass = concat [perhapsM (a `Set.member` fve) $ assign  a' (project (arg i) tmp) | a' <- as' | Var a _ <- as |  i <- [( 1 :: Int) ..] ]
-    ss' <- convertBody e'
-    return $  mconcat ass `mappend` ss'
-
-nodeAssignV v t e' = do
-    v' <- convertVal v
-    var <- fetchVar t TyTag
-    ss' <- convertBody e'
-    return $ assign var (project' anyTag v') `mappend` ss'
-
-
-localTodo :: Todo -> C a -> C a
-localTodo todo (C act) = C $ local (\ (_,y) -> (todo,y)) act
-
-
-convertFunc :: (Atom,Lam) -> C Function
-convertFunc (n,Tup as :-> body) = do
-        s <- localTodo TodoReturn (convertBody body)
-        let bt = getType body
-            mmalloc (TyPtr _) = [Attribute "A_MALLOC"]
-            mmalloc TyNode = [Attribute "A_MALLOC"]
-            mmalloc _ = []
-            ats = Attribute "A_REGPARM":mmalloc bt
-        fr <- convertType bt
-        as' <- flip mapM as $ \ (Var v t) -> do
-            t' <- convertType t
-            return (varName v,t')
-        return $ function (nodeFuncName n) fr as' ats (profile_function_inc `mappend` s)
-
-
-convertFfiExport :: (Atom,Lam) -> FfiExport -> C Function
-convertFfiExport (n,Tup as :-> body) (FfiExport cn Safe CCall) = do
-        s <- localTodo TodoReturn (convertBody body)
-        let bt = getType body
-            mmalloc (TyPtr _) = [Attribute "A_MALLOC"]
-            mmalloc TyNode = [Attribute "A_MALLOC"]
-            mmalloc _ = []
-            ats = Public : mmalloc bt
-        fr <- convertType bt
-        as' <- flip mapM as $ \ (Var v t) -> do
-            t' <- convertType t
-            return (varName v,t')
-        return $ function (name cn) fr as' ats (profile_function_inc `mappend` s)
-
-
-{-# NOINLINE compileGrin #-}
-compileGrin :: Grin -> (String,[String])
-compileGrin grin = (hsffi_h ++ jhc_rts_header_h ++ jhc_rts_alloc_c ++ jhc_rts_c ++ "\ntypedef union node node_t;\n" ++ P.render ans ++ "\n", snub (reqLibraries req))  where
-    ans = vsep $ [vcat includes,enum_tag_t,header,union_node,text "/* CAFS */", vcat $ map ccaf (grinCafs grin), text "/* Constant Data */", jhc_sizeof_data, buildConstants finalHcHash,text  "/* Functions */",jhc_sizeof,body]
-    includes =  map include (snub $ reqIncludes req)
-    (header,body) = generateC True functions structs
-
-    -- this is a list of every tag used in the program
-    tags = (tagHole,[]):sortUnder (show . fst) [ (t,runIdentity $ findArgs (grinTypeEnv grin) t) | t <- Set.toList $ freeVars (snds $ grinFuncs grin) `mappend` freeVars (snds $ grinCafs grin), tagIsTag t]
-    ((functions,structs),finalHcHash,req) = runC $ do
-        funcs <- flip mapM (grinFuncs grin) $ \(a,l) -> do
-                   case Map.lookup a (grinEntryPoints grin) of
-                     Nothing -> convertFunc  (a,l)
-                     Just fe -> convertFfiExport (a,l) fe
-        sts <- flip mapM tags $ \ (n,ts) -> do
-            ts' <- mapM convertType ts
-            return (nodeStructName n,zip [ name $ 'a':show i | i <-  [1 ..] ] ts')
-        return (funcs,sts)
-
-
-    enum_tag_t = text "typedef enum {" $$ nest 4 (P.fsep (punctuate P.comma (map (tshow . nodeTagName . fst) tags))) $$ text  "} tag_t;"
-    jhc_sizeof_data =  text $ "static const uint8_t JHC_SIZEOF[] = {\n" ++ concatMap sizeof (fsts tags) ++ "};"  where
-        sizeof t = text "  sizeof(struct " <> tshow (nodeStructName t) <>  text "),\n"
-    jhc_sizeof = text "static inline size_t jhc_sizeof(tag_t tag) { return (size_t) JHC_SIZEOF[tag]; }"
-    union_node = text $  "union node {\n  struct { tag_t tag; } any;\n" <> mconcat (map cu (fsts tags)) <> text "};" where
-        cu t = text "  struct" <+> (tshow $ nodeStructName t) <+> (tshow $ nodeStructName t) <> text ";\n"
-
-include fn = text "#include <" <> text fn <> text ">"
-line = text ""
-vsep xs = vcat $ intersperse line xs
-
-buildConstants fh = 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 " <> tshow (nodeStructName a) <+> text "_c" <> tshow i <+> text "= {" <> hsep (punctuate P.comma (tshow (nodeTagName a):rs)) <> text "};"
-        def = text "#define c" <> tshow i <+> text "((node_t *)&_c" <> tshow i <> text ")"
-        rs = [ f z undefined |  z <- zs ]
-        f (Right i) = text $ 'c':show i
-        f (Left (Var n _)) = tshow $ varName n
-        f (Left v) | Just e <- convertConst v = text (show $ drawG e)
---        f (Left (Lit i _)) = tshow i
---        f (Left vp@(ValPrim {})) = tshow i
---        f (Left (Tag t)) = tshow (nodeTagName t)
-
-convertConst :: Monad m => Val -> m Expression
-convertConst (Const (NodeC h _)) | h == tagHole = return nullPtr
-convertConst (Lit i _) = return (constant $ number (fromIntegral i))
-convertConst (Tup [x]) = convertConst x
-convertConst (Tup []) = return emptyExpression
-convertConst (Tag t) = return $ constant (enum $ nodeTagName t)
-convertConst (ValPrim (APrim p _) [] _) = case p of
-    CConst s _ -> return $ expressionRaw s
-    AddrOf t -> return $ expressionRaw ('&':unpackPS t)
-    x -> return $ err (show x)
-convertConst (ValPrim (APrim p _) [x] _) = do
-    x' <- convertConst x
-    case p of
-        CCast _ to -> return $ cast (basicType to) x'
-        Operator n [_] r ->  return $ cast (basicType r) (uoperator n x')
-        x -> return $ err (show x)
-convertConst (ValPrim (APrim p _) [x,y] _) = do
-    x' <- convertConst x
-    y' <- convertConst y
-    case p of
-        Operator n [_,_] r -> return $ cast (basicType r) (operator n x' y')
-        x -> return $ err (show x)
-
-convertConst x = fail "convertConst"
-
-
-
-ccaf :: (Var,Val) -> P.Doc
-ccaf (v,val) = text "/* " <> text (show v) <> text " = " <> (text $ render (prettyVal val)) <> text "*/\n" <> text "static node_t _" <> tshow (varName v) <> text ";\n" <> text "#define " <> tshow (varName v) <+>  text "(&_" <> tshow (varName v) <> text ")\n";
-
-
-
-
rmfile ./C/FromGrin.hs
hunk ./Grin/Linear.hs 1
-module Grin.Linear(grinLinear,W(..)) where
-
-import Control.Monad.State
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-
-import Fixer.Fixer
-import Fixer.Supply
-import GenUtil
-import Grin.Grin
-import Support.FreeVars
-import Util.SetLike
-
-data W = Zero | One | Omega
-    deriving(Ord,Eq,Show)
-
-instance Fixable W where
-    bottom = Zero
-    isBottom Zero = True
-    isBottom _ = False
-    lub a b = max a b
-    minus a b | a > b = a
-    minus _ _ = bottom
-
-
-{-# NOINLINE grinLinear #-}
-grinLinear :: Grin -> IO [(Var,W)]
-grinLinear  grin@(Grin { grinTypeEnv = typeEnv, grinCafs = cafs }) = do
-    fixer <- newFixer
-    argSupply <- newSupply fixer
-    varSupply <- newSupply fixer
-    mapM_ (go argSupply varSupply) (grinFuncs grin)
-    calcFixpoint "linear nodes" fixer
-    as <- supplyReadValues argSupply
-    mapM_ print $ sortGroupUnderFG fst (snd . snd)  [ (n,(a,v)) | ((n,a),v) <- as ]
-    supplyReadValues varSupply
-
-go argSupply varSupply (fn,~(Tup vs) :-> fb) = ans where
-    ans = do
-        ms <- flip mapM [ (v,z) | ~(Var v _) <- vs | z <- [ 0::Int ..]] $ \ (v,z) -> do
-            vv <- supplyValue argSupply (fn,z)
-            return (v,(0::Int,vv))
-        f fb (Map.fromList ms)
-    f (e@Store {} :>>= (Var v (TyPtr TyNode)) :-> fb) mp = do
-        mp' <- g e mp
-        ee <- supplyValue varSupply v
-        mp' <- f fb (Map.insert v (0,ee) mp')
-        return mp'
-    f (e :>>= _ :-> fb) mp = do
-        mp' <- g e mp
-        f fb mp'
-    f e mp = g e mp
-    g (Case _ ls) mp = do
-        ms <- sequence [ f e mp |  _ :-> e <- ls ]
-        let z (x,y) (x',y') = (max x x',y)
-        return (Map.unionsWith z ms)
-    g Let { expDefs = defs, expBody = body } mp = do
-        mp' <- execStateT (mapM_ omegaize (map (\v -> Var v undefined) $ Set.toList $ freeVars defs)) mp
-        f body mp'
-    g e mp = execStateT (h e) mp
-    h (App a [_,b] _) | a == funcApply = omegaize b
-    h (App a [Var v _] _) | a == funcEval = eval v
-    h (Fetch (Var v _)) = eval v -- XXX can this be weakened?
-    h (Fetch (Index (Var v _) _)) = eval v -- XXX can this be weakened?
-    h (App a vs _) = fuse a vs
-    -- TODO if result of a P1_ partial ap is used once, then the function arguments should be fuse'd rather than omegaized
-    h Store { expValue = NodeC a vs } | tagIsSuspFunction a =  fuse (tagFlipFunction a) vs
-    h Alloc { expValue = NodeC a vs } | tagIsSuspFunction a =  fuse (tagFlipFunction a) vs
-    h Update { expValue = NodeC a vs } | tagIsSuspFunction a =  fuse (tagFlipFunction a) vs
-    h Return { expValue = NodeC a vs } | tagIsSuspFunction a =  fuse (tagFlipFunction a) vs
-    h Store { expValue = NodeC a vs } = mapM_ omegaize vs
-    h Alloc { expValue = NodeC a vs } = mapM_ omegaize vs
-    h Update { expValue = NodeC a vs } = mapM_ omegaize vs
-    h Return { expValue = NodeC a vs } = mapM_ omegaize vs
-    h Prim {} = return ()
-    h Error {} = return ()
-    h Return { } = return ()
-    h Store {} = return ()
-    h Alloc {} = return ()
-    h Update {} = return ()
-
-    h e = fail ("Grin.Linear.h: " ++ show e)
-    fuse a vs = mapM_ farg $ zip (zip (repeat a) [0..]) vs
-    omegaize Const {} = return ()
-    omegaize Lit {} = return ()
-    omegaize ValUnknown {} = return ()
-    omegaize ValPrim {} = return ()
-    omegaize (Var v _) = do
-        mp <- get
-        case mlookup v mp of
-            Nothing -> return ()
-            Just (_,v) -> toOmega v
-    omegaize x = fail $ "omegaize: " ++ show x
-    farg (_,Const {}) = return ()
-    farg (_,Lit {}) = return ()
-    farg (_,ValPrim {}) = return ()
-    farg z@(an,Var v _) = do
-        eval v
-        ea <-  supplyValue argSupply an
-        mp <- get
-        case mlookup v mp of
-            Just (_,ev) -> addRule $ ev `isSuperSetOf` ea
-            Nothing -> return ()
-    farg x = fail ("Grin.Linear.farg: " ++ show x)
-    eval v = do
-        mp <- get
-        case mlookup v mp of
-            Just (0,e) -> do
-                addRule $ e `isSuperSetOf` value One
-                modify (Map.insert v (1,e))
-            Just (1,e) -> toOmega e
-            Nothing -> return ()
-
-
-toOmega e = addRule $ e `isSuperSetOf` value Omega
-
-
-
rmfile ./Grin/Linear.hs
hunk ./Grin/PointsToAnalysis.hs 1
-module Grin.PointsToAnalysis(grinInlineEvalApply) where
-
-import Control.Monad.Identity
-import Control.Monad.State
-import Control.Monad.Writer
-import Control.Monad.RWS
-import Data.IORef
-import Data.Monoid
-import List(sort,intersperse)
-import Maybe
-import Monad
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-
-import Atom
-import CharIO
-import Doc.DocLike
-import Fixer.Fixer
-import Fixer.Supply
-import GenUtil
-import Grin.EvalInline
-import Grin.Simplify
-import Grin.Grin
-import Grin.HashConst
-import Grin.Linear
-import Grin.Noodle
-import Grin.Show()
-import Options
-import Stats
-import Support.CanType
-import Util.Gen
-import Util.Once
-import Util.SameShape
-import Util.UniqueMonad
-import qualified Doc.Chars as U
-import qualified FlagDump as FD
-
-
-
-
--- These names make no sense
--- this analysis could probably be strongly typed.
-data Pos =
-    Union [Pos]
-    | Variable {-# UNPACK #-} !Var
-    | Func {-# UNPACK #-} !Atom
-    | Basic
-    | PCase Pos [(Atom,Pos)] Pos
-    | PIf {-# UNPACK #-} !Bool Pos Atom Pos
-    | Ptr {-# UNPACK #-}!Int
-    | Down Pos {-# UNPACK #-}!Atom {-# UNPACK #-}!Int
-    | DownTup Pos {-# UNPACK #-}!Int
-    | Arg {-# UNPACK #-} !Atom {-# UNPACK #-}!Int
-    | Con {-# UNPACK #-} !Atom [Pos]
-    | Tuple [Pos]
-    | Complex {-# UNPACK #-}!Atom [Pos]
-    deriving(Ord,Eq)
-
-instance Show Pos where
-    showsPrec n (Variable v) xs = showsPrec n v xs
-    showsPrec n (Func a) xs = U.lArrow ++ showsPrec n a  xs
-    showsPrec _ Basic xs = 'B':'A':'S':xs
-    showsPrec n (Ptr i) xs = '*':showsPrec n i xs
-    showsPrec n (Down p a i) xs = show p ++ U.dArrow ++ show a ++ U.dArrow ++ show i ++ xs
-    showsPrec n (DownTup p i) xs = show p ++ U.dArrow ++ show i ++ xs
-    showsPrec n (Arg p i) xs = show p ++ U.rArrow ++ show i ++ xs
-    showsPrec n (Con p i) xs = show p ++ show i ++ xs
-    showsPrec n (Tuple ps) xs = (parens $ hcat (intersperse "," $ map show ps)) ++ xs
-    showsPrec n (Complex a p) xs = show a ++ tupled (map show p) ++ xs
-    showsPrec n (Union ps) xs =  text "{" ++ hcat (intersperse "," $ map show ps) ++ "}" ++ xs
-    showsPrec n (PCase p as p') xs = text "case" <+> shows p <+> shows as <+> shows p'  $ xs
-    showsPrec n (PIf True p a p') xs = text "if" <+> shows a <+> U.elem <+>  shows p <+> text "then"  <+> shows p' $ xs
-    showsPrec n (PIf False p a p') xs = text "if" <+> shows a <+> U.notElem <+>  shows p <+> text "then"  <+> shows p' $ xs
-
-instance Monoid Pos where
-    mempty = Union []
-    mappend (Union []) x = x
-    mappend x (Union []) = x
-    mappend (Union xs) (Union ys) = mconcat (xs ++ ys)
-    mappend (Union xs) x = mconcat (x:xs)
-    mappend x (Union xs) = mconcat (x:xs)
-    mappend x y = mconcat [x,y]
-    mconcat xs = f (snub xs) [] where
-        f [] [] = Union []
-        f [] [x] = x
-        f [] xs = Union xs
-        f (Tuple ps:Tuple ps':xs) ys | sameLength ps ps'  = f (Tuple [ mappend x y | x <- ps | y <- ps']:xs) ys
-        f (Con a ps:Con a' ps':xs) ys | a == a' && sameLength ps ps'  = f (Con a [ mappend x y | x <- ps | y <- ps']:xs) ys
-        f (DownTup (Tuple vs) n:xs) ys = f ((vs !! n):xs) ys
-        f (x:xs) ys = f xs (x:ys)
-
-
-data ValueSet = VsEmpty | VsNodes (Map.Map (Atom,Int) ValueSet) (Set.Set Atom)  | VsHeaps !(Set.Set Int) | VsBas String
-    deriving(Eq,Ord)
-    {-! derive: is !-}
-
-getHeaps' s VsEmpty = Set.empty
-getHeaps' s (VsHeaps h) = h
-getHeaps' s x = error $ "getHeaps: " ++ s ++ " " ++ show x
-
-getHeaps VsEmpty = Set.empty
-getHeaps (VsHeaps s) = s
-getHeaps x = error $ "getHeaps: " ++ show x
-
-mgetHeaps (VsHeaps s) = s
-mgetHeaps _ = mempty
-
-getNodes VsEmpty = Set.empty
-getNodes (VsNodes _ s) = s
-getNodes x = error $ "getNodes: " ++ show x
-
-getNodeArgs VsEmpty = Map.empty
-getNodeArgs (VsNodes s _) = s
-getNodeArgs x = error $ "getNodeArgs: " ++ show x
-
-vsBas = VsBas ""
-setNodes [] = VsEmpty
-setNodes xs = pruneNodes $ VsNodes (Map.fromList $ concat [ [ ((n,i),a) | a <- as | i <- naturals ] | (n,as) <- xs]) (Set.fromList (fsts xs))
-setHeaps [] = VsEmpty
-setHeaps xs = VsHeaps (Set.fromList xs)
-
-pruneNodes (VsNodes x y) = VsNodes (Map.filter (not . isBottom) x) y
-pruneNodes x = x
-
-instance Monoid ValueSet where
-    mempty = VsEmpty
-    mappend VsEmpty x = x
-    mappend x VsEmpty = x
-    mappend (VsBas a) (VsBas b) = VsBas a
-    --mappend (VsBas a) (VsBas b) = VsBas (a ++ b)
-    mappend (VsHeaps a) (VsHeaps b) = VsHeaps (Set.union a b)
-    mappend (VsNodes a a') (VsNodes b b') = pruneNodes $ VsNodes (Map.unionWith mappend a b) (Set.union a' b')
-    mappend x y = error $ "mappend: " ++ show x <+> show y
-
-instance Fixable ValueSet where
-    bottom = mempty
-    lub = mappend
-    isBottom VsEmpty = True
-    isBottom (VsHeaps s) | Set.null s = True
-    isBottom (VsNodes n s) | Map.null n && Set.null s = True
-    isBottom _ = False
-    minus a VsEmpty = a
-    minus VsEmpty _ = VsEmpty
-    minus (VsBas _) (VsBas _) = VsEmpty
-    minus (VsHeaps h1) (VsHeaps h2) = VsHeaps (h1 Set.\\ h2)
-    minus (VsNodes n1 w1) (VsNodes n2 w2) = pruneNodes $ VsNodes (Map.fromList $ concat [
-            case Map.lookup (a,i) n2 of
-                Just v' ->  [((a,i),v `minus` v')]
-                Nothing ->  [((a,i),v)]
-        | ((a,i),v) <- Map.toList n1 ] ) (w1 Set.\\ w2)
-    minus x y = error $ "minus: " ++ show x <+> show y
-
-instance Show ValueSet where
-    showsPrec x VsEmpty = \xs -> '{':'}':xs
-    showsPrec x (VsBas a) = \xs -> '(':'B':'a':'s':':':a ++ ")" ++ xs
-    showsPrec x (VsHeaps s)
-        | Set.size s > 7  = braces (hcat (intersperse (char ',') $ map tshow  (take 7 $ Set.toAscList s)) <> text ",...")
-        | otherwise  = braces (hcat (intersperse (char ',') $ map tshow  ( Set.toAscList s)) )
-
-    showsPrec x (VsNodes n s) = braces (hcat (intersperse (char ',') $ (map f $ snub $ fsts  (Map.keys n) ++ Set.toList s) )) where
-        f a = (if a `Set.member` s then tshow a else char '#' <> tshow a) <> tshow (g a)
-        g a = sort [ (i,v) | ((a',i),v) <- Map.toList n, a' == a ]
-
-
-data PointsTo = PointsTo {
-    ptVars :: Map.Map Var ValueSet,
-    ptFunc :: Map.Map Atom ValueSet,
-    ptConstMap :: Map.Map Int Val,
-    ptFuncArgs :: Map.Map (Atom,Int) (Ty,ValueSet),
-    ptHeap :: Map.Map Int ValueSet,
-    ptHeapType :: Map.Map Int HeapType
-    }
-    deriving(Show)
-    {-! derive: Monoid, update !-}
-
-pointsToStats :: PointsTo -> String
-pointsToStats pt = text "PointsTo Analysis results:" <$> buildTable ["Total", "Empty", "Basic", "Max", "Average" ] [f "Variables" (ptVars pt), f "Functions" (ptFunc pt), f "Heap" (ptHeap pt)] where
-    f n mp = {- text n <> char ':' <+> -}  vs n (Map.elems mp)
-    vs n xs = (n,[tshow $ length xs, show (count isVsEmpty xs),show (count isVsBas xs),show (maximum $ 0:map num xs), show ((fromIntegral (sum (map num xs)) ::Double ) / fromIntegral (length xs))] )
-    num (VsNodes x s) = Set.size s
-    num (VsHeaps x) = Set.size x
-    num _ = 0
-
-
-
-
-data PointsToEq = PointsToEq {
-    varEq  :: [(Var, Pos)],
-    funcEq :: [(Atom,Pos)],
-    heapEq :: [(Int,(HeapType,Pos))],
-    updateEq :: [(Pos,Pos)],
-    constValEq :: [(Int,Val)],
-    applyEq :: [(Pos,Pos)],
-    appEq  :: [(Atom,[Pos])]
-
-    }
-    deriving(Show)
-    {-! derive: Monoid, update !-}
-
-flattenPointsToEq eq = varEq_u f . funcEq_u f . heapEq_u h . appEq_u g $ eq  where
-    f xs = [ (x, mconcat $ snds xs)  | xs@((x,_):_) <- sortGroupUnder fst xs]
-    --g xs = [ (x, map mconcat $ transpose (snds xs))  | xs@((x,_):_) <- sortGroupUnder fst xs]
-    g xs = xs
-    h xs = [ (x, (t,mconcat $ snds $ snds xs))  | xs@((x,(t,_)):_) <- sortGroupUnder fst xs]
-
-
-collectFuncDefs e = execWriter (f e) where
-    f e@Let { expDefs = defs } = tell defs >> mapExpExp f e >> return e
-    f e = mapExpExp f e >> return e
-
-
---newHeap ht p@(Con a ps)
---    | tagIsSuspFunction a, Identity t <- tagToFunction a = newHeap' ht (mappend p (Func t))
-newHeap ht p = newHeap' ht p
-
-
-newHeap' ht p = do
-    h <- newUniq
-    tell mempty { heapEq = [(h,(ht,p))] }
-    return (Ptr h)
-
-bind (Var v _) p = tell mempty { varEq = [(v, p)] }
-bind (NodeC t [Lit {}]) _ = return ()
-bind (NodeC t [ValPrim {}]) _ = return ()
-bind (NodeC t vs) p | sameLength vs vs' = tell mempty { varEq = vs' }  where
-    vs' = [ (v,if basicType ty then Basic else Down p t i) | Var v ty <- vs | i <- naturals ]
-    basicType (Ty _) = True
-    basicType _ = False
-bind (Tup []) _ = return ()
-bind (Tup vs) p | sameLength vs vs' = tell mempty { varEq = vs'  }  where
-    vs' = [ (v,if basicType ty then Basic else DownTup p i) | Var v ty <- vs | i <- naturals ]
-    basicType (Ty _) = True
-    basicType _ = False
--- TODO - follow tags through
--- bind (NodeV t []) _ = tell mempty { varEq = [(t, Basic)] }
-bind x y = error $ unwords ["bind:",show x,show y]
-
-analyze :: Grin -> IO PointsTo
-analyze grin@(Grin { grinTypeEnv = typeEnv, grinCafs = cafs }) = do
-    wdump FD.Progress $ CharIO.putErrLn "Linear nodes analysis..."
-    lr <- Grin.Linear.grinLinear grin
-    flip mapM_ lr $ \ (x,y) -> CharIO.putStrLn $ show x ++ " - " ++ show y
-
-    let f (eq,hc) (n,l) | n == funcEval = (eq,hc)
-        f (eq,hc) (n,l) | n == funcApply = (eq,hc)
-        f (eq,hc) (n,l) = mapFst (mappend eq) $ collect (Map.fromList lr) hc (mh eq + 1) n l
-        mh PointsToEq { heapEq = xs } = maximum $ 1:fsts xs
-        --toHEq (NodeC t []) | not (tagIsWHNF t) = return (SharedEval,Union [Con t [], func (fromAtom t) ] )
-        toHEq (NodeC t []) | not (tagIsWHNF t) = return (SharedEval,Con t []  )
-        toHEq node = toPos node >>= return . (,) Constant
-        (((heapEq',feq),hc')) = runState (runWriterT $ sequence [ toHEq node >>= return . (,) h | (v,node) <- cafs | h <- [1..] ]) emptyHcHash
-        eq = feq {
-            --heapEq = [ (h,(SharedEval,Union [Con t [], func (fromAtom t) ] )) | (v,NodeC t []) <- cafs | h <- [1..] ],
-            --varEq =  [ (v,Ptr h) | (v,NodeC t []) <- cafs | h <- [1..] ]
-            heapEq = heapEq', -- [ (h,toHEq node) | (v,node) <- cafs | h <- [1..] ],
-            varEq =  [ (v,Ptr h) | (v,_) <- cafs | h <- [1..] ]
-            }
-        (neq,hc) = mapFst flattenPointsToEq $ foldl f  (eq,hc') (grinFuncs grin)
-        func ('B':xs) = Func $ toAtom $ 'b':xs
-        func ('F':xs) = Func $ toAtom $ 'f':xs
-        func x = error $ "func:" ++ x
-    when (dump FD.Eval) $ do
-        CharIO.putStrLn "vars:"
-        mapM_ CharIO.print $ sort $ varEq neq
-        CharIO.putStrLn "apps:"
-        mapM_ CharIO.print $ Map.toList (Map.fromListWith (zipWith mappend) (appEq neq))
-        CharIO.putStrLn "funcs:"
-        mapM_ CharIO.print $ sort $ funcEq neq
-        CharIO.putStrLn "updates:"
-        mapM_ CharIO.print $ sort $ updateEq neq
-        CharIO.putStrLn "heaps:"
-        mapM_ CharIO.print $ sort $ heapEq neq
-        let vm = Map.fromList (varEq neq)
-            (HcHash _ mp) = hc
-            cheaps = sort [ ((-x),setNodes [(t,(map z xs))]) | (HcNode t xs,x) <- Map.toList mp ] where
-            z (Right n) = setHeaps [(-n)]
-            z (Left (Var v _)) = case Map.lookup v vm of
-                Just (Ptr h) -> setHeaps [h]
-                _ -> error "cheaps"
-            z (Left x) = VsBas (show x)
-        mapM_ CharIO.print $ sort $ cheaps
-        CharIO.putStrLn "applys:"
-        mapM_ CharIO.print $ sort $ applyEq neq
-    doTime "findFixpoint" $ findFixpoint' grin hc neq
-
--- create an eval suitable for inlining.
-createStore ::  TyEnv -> [Tag] -> Lam
-createStore  te ts
-    | null cs = n1 :-> Error "Empty Store" (TyPtr TyNode)
-    | otherwise = n1 :->
-        Case n1 cs
-    where
-    cs = [f t | t <- ts, tagIsTag t ]
-    f t = (NodeC t vs :-> Store (NodeC t vs)) where
-        (ts,_) = runIdentity $ findArgsType te t
-        vs = [ Var v ty |  v <- [V 4 .. ] | ty <- ts]
-
-{-# NOINLINE grinInlineEvalApply #-}
-grinInlineEvalApply :: Stats -> Grin -> IO Grin
-grinInlineEvalApply  stats grin@(Grin { grinTypeEnv = typeEnv,  grinCafs = cafs }) = do
-    grin <- return $ renameUniqueGrin grin
-    pt <- analyze grin
-    wdump FD.Progress $ do
-        CharIO.putStrLn (pointsToStats pt)
-    wdump FD.Eval $ do
-        CharIO.putStrLn "funcs:"
-        mapM_ CharIO.print [ v  | v@(_,_) <-  Map.toList (ptFunc pt)]
-        CharIO.putStrLn "vars:"
-        mapM_ CharIO.print [ v  | v@(_,_) <-  Map.toList (ptVars pt)]
-        CharIO.putStrLn "heap:"
-        mapM_ CharIO.print [ v  | v@(_,_) <-  Map.toList (ptHeap pt)]
-        CharIO.putStrLn "heapType:"
-        mapM_ CharIO.print [ v  | v@(_,_) <-  Map.toList (ptHeapType pt)]
-
-    let f (l :-> e) = do e' <- g e; return $ l :-> e'
-        g (App a [vr@(Var v _)] _ :>>= vb :-> Return vb' :>>= node@(NodeC {}) :-> e) | vb == vb', a == funcEval = do
-                mtick "Grin.eval.hoisted"
-                e' <- g e
-                return $ (Return vr :>>= createEval (HoistedUpdate node) typeEnv (tagsp v)) :>>= vb :-> Return vb' :>>= node :-> e'
-        --g (App a [vr@(Var v _)] _ :>>= vb :-> Case vb' rs :>>= rl ) | vb == vb', a == funcEval = trailingCase vr vb rs (Just rl)
-        --g (App a [vr@(Var v _)] _ :>>= vb :-> Case vb' rs ) | vb == vb', a == funcEval = trailingCase vr vb rs Nothing
-        g (App a [vr@(Var v _)] _ :>>= vb@(Var vbv _) :-> e) | a == funcEval = do
-                let Just stags = tags vbv
-                case stags of
-                    [] ->  do
-                        mtick "Grin.eval.update-no-alts"
-                        e' <- g e
-                        return $ (Return vr :>>= createEval NoUpdate typeEnv (tagsp v)) :>>= vb :-> e'
-                    [t] -> do
-                        e' <- g e
-                        mtick "Grin.eval.hoisted2"
-                        let node = NodeC t vs
-                            (ts,_) = runIdentity $ findArgsType typeEnv t
-                            vs = [ Var v ty |  v <- [V 4 .. ] | ty <- ts]
-                        update <- getNeedUpdate (HoistedUpdate node) v
-                        return $ (Return vr :>>= createEval update typeEnv (tagsp v)) :>>= vb :-> e'
-                    _ -> do
-                        e' <- g e
-                        mtick "Grin.eval.switched"
-                        update <- getNeedUpdate (SwitchingUpdate stags) v
-                        return $ (Return vr :>>= createEval update typeEnv (tagsp v)) :>>= vb :-> e'
-        g (e1 :>>= l) = do e1' <- g e1; l' <- f l; return $ e1' :>>= l'
-        g lt@Let { expDefs = defs, expBody = body } = do
-            body' <- g body
-            ds <- sequence [ f l >>= return . (,) n | FuncDef { funcDefName = n, funcDefBody = l } <- defs ]
-            return $ updateLetProps lt { expDefs = map (uncurry $ createFuncDef True) ds, expBody = body' }
-        g (App a [vr@(Var v _)] _) | a == funcEval = do
-            mtick "Grin.eval.trailing"
-            return $ Return vr :>>= createEval TrailingUpdate typeEnv (tagsp v)
-        g app@(App a [vr@(Var v _),y] ty) | a == funcApply = do
-            mtick "Grin.eval.apply"
-            case (tags v) of
-                Just ts ->  return $ Return (Tup [vr,y]) :>>= createApply (getType y) ty typeEnv ts
-                Nothing -> error $ "InlineEvalApply: " ++ show app
-        g n@(App a _ _) | a == funcApply || a == funcEval = error $ "Invalid evap: " ++ show n
-        g (Store vr@(Var v _)) | Just ts <- tags v = return $ Return vr :>>= createStore typeEnv ts
-        g st@(Store (Var {})) = return $ Error ("Store of basic: " ++ show st) (TyPtr TyNode)
-        g (Case v@(Var vr _) xs) = do xs' <- mapM f xs;  docase v xs' (tags vr)
-        g (Case v xs) = do xs' <- mapM f xs;  return $ Case v xs'
-        g x = return x
-        tags v = if isVsBas x then Nothing else Just [ t | t <- Set.toList vs] where
-              vs = getNodes   x
-              x = case Map.lookup v (ptVars pt) of
-                Just x -> x
-                Nothing -> error $ "Tags: " ++ show v
-        --tagsp v = snub (concat [ f n |  n <- Set.toList vs ]) where
-        --    f n = [ t | t <- Set.toList $ getNodes h ]  where
-        --        Just h = Map.lookup  n (ptHeap pt)
-        --    vs = getHeaps x
-        --    Just x = Map.lookup v (ptVars pt)
-        tagsp v = tagsp' x where Just x = Map.lookup v (ptVars pt)
-        tagsp' v = Set.toList (Set.unions [ f n |  n <- Set.toList vs ]) where
-            f n = getNodes h  where
-                Just h = Map.lookup  n (ptHeap pt)
-            vs = mgetHeaps v
-        getNeedUpdate u v | notNeedUpdate v = do
-            mtick "Grin.eval.update-linear"
-            return NoUpdate
-        getNeedUpdate u _ = return u
-
-        notNeedUpdate v = all (== UnsharedEval) hs where
-            hs = concatMap (`Map.lookup` ptHeapType pt) hls
-            hls = Set.toList $ getHeaps x
-            Just x = Map.lookup v (ptVars pt)
-        docase v xs Nothing =  return $ Case v xs
-        docase _ ((_ :-> x):_) (Just []) = return $ Error "No Valid alternatives. This Should Not be reachable." (getType x)
-        docase v xs (Just ts) = do
-            let (ns,vs) = span isNodeC (filter g xs)
-                g (NodeC t _ :-> _) = t `elem` ts
-                g (Var {} :-> _ ) = True
-                g _ = False
-                isNodeC (NodeC {} :-> _) = True
-                isNodeC _ = False
-                xs' = if sameShape1 ns ts  then  ns else (ns ++ vs)
-            mticks (length xs - length xs') "Grin.eval.case-elim"
-            return $ if null xs' then  Error "No Valid alternatives. This Should Not be reachable." (getType (Case v xs)) else (Case v xs')
-        vsToItem = valueSetToItem te pt
-        te = extendTyEnv fds typeEnv
-        fds = concatMap (collectFuncDefs . lamExp) (snds $ grinFuncs grin)
-        convertArgs fa = Map.fromList $ map f (Map.keys $ ptFunc pt) where
-            f atom = (atom,[ uncurry vsToItem $ Map.findWithDefault (t,VsEmpty) (atom,i) fa  |  t <- ts | i <- naturals]) where
-                Just (ts,_) = findArgsType te atom
-                --ts = case findArgsType te atom of
-                --    Just (ts,_) -> ts
-                --    _ -> []
-    let (sts,funcs) = unzip [ (stat,(a,l')) | (a,l) <- grinFuncs grin, let (l',stat) = runStatM (f l) ]
-    tickStat stats (mconcat sts)
-    return $ setGrinFunctions funcs grin {
-        grinPhase = PostInlineEval,
-        grinArgTags = convertArgs $ ptFuncArgs pt,
-        grinReturnTags = Map.mapWithKey (funcReturn te pt) $ ptFunc pt
-        }
-
-
-funcReturn te pt fn vs =
-  case findArgsType te fn of
-    Just (_,ty) -> valueSetToItem te pt ty vs
-    Nothing     -> error ("funcReturn: "++show fn)
-    --Nothing     -> valueSetToItem te pt TyUnknown vs -- error ("funcReturn: "++show fn)
-
-valueSetToItem :: TyEnv -> PointsTo -> Ty -> ValueSet -> Item
-valueSetToItem _ _ ty VsEmpty = itemEmpty ty
-valueSetToItem _ _ ty (VsBas "()") = TupledValue []
-valueSetToItem _ _ ty VsBas {} = BasicValue ty
-valueSetToItem te pt TyNode (VsNodes as n) = NodeValue (Set.mapMonotonic f n) where  -- depends on tag being first value in NodeValue
-    f n = NV n [ valueSetToItem te pt ty (Map.findWithDefault VsEmpty (n,i) as)  | ty <- ts | i <- naturals ] where
-        Just (ts,_) = findArgsType te n
-      --  ts = case findArgsType te n of
-    --     Just (ts,_) -> ts
-      --      _ -> []
-valueSetToItem te pt (TyPtr _) (VsHeaps ss) = HeapValue (Set.mapMonotonic f ss) where -- depends on int being first value in HeapValue
-    f n | n < 0 = HV n (Right val) where
-        Just val = Map.lookup n (ptConstMap pt)
-    f n = HV n (Left (hType,(valueSetToItem te pt TyNode vs))) where   -- TODO heap locations of different types
-        Just hType = Map.lookup n (ptHeapType pt)
-        Just vs = Map.lookup n (ptHeap pt)
-valueSetToItem te pt (TyTup xs) (VsNodes as n)
-    | tupleName `Set.member` n = TupledValue [ valueSetToItem te pt t (Map.findWithDefault VsEmpty (tupleName,i) as) | i <- naturals | t <- xs]
-    | otherwise = itemEmpty (TyTup xs)
-valueSetToItem _ pt ty v = error $ "valueSetToItem " ++ show (pt,ty,v)
-
-
-
-itemEmpty TyNode = NodeValue mempty
-itemEmpty (TyPtr _) = HeapValue mempty
-itemEmpty (TyTup xs) = TupledValue (map itemEmpty xs)
-itemEmpty ty  = BasicValue ty
-
-
-
-getTags (VsNodes _ s) = Set.toList s
-getTags _ = []
-
-newtype CM a = CM (RWS (Map.Map Var W) PointsToEq (Int,HcHash) a)
-    deriving(Monad,MonadWriter PointsToEq,Functor,MonadReader (Map.Map Var W))
-
-instance MonadState HcHash CM where
-    get = CM $ gets snd
-    put n = CM $ modify (\ (x,y) -> (x,n))
-
-
-instance UniqueProducer CM where
-    newUniq = CM $ do
-        modify (\ (x,y) -> (x + 1,y))
-        gets fst
-
-
-
-collect :: Map.Map Var W -> HcHash -> Int -> Atom -> Lam -> (PointsToEq,HcHash)
-collect lmap hc st fname lam = (eq,hc')  where
-    CM cm = collectM fname lam
-    ((_,hc'),eq) = execRWS cm lmap (st,hc)
-
-collectM :: Atom -> Lam -> CM ()
-collectM  fname (~(Tup vs) :-> exp') = ans where
-    ans = do
-        v <- f exp'
-        tell mempty { funcEq = [(fname,v)], varEq = avs }
-    avs = [ (v,Arg fname n) |  ~(Var v _) <- vs | n <- [0..] ]
-
- --   ans = (eq { funcEq = (fname,v):funcEq eq, varEq = varEq eq ++ avs },hc')   where
-    --((v,eq),hc') = execUniq st $ (runStateT ((runWriterT (f exp'))) hc)
- --   ((v,hc'),eq) = execUniq st $ (runWriterT (runStateT (f exp') hc))
-    --((v,hc'),eq) = runWriter $ execUniqT st $ (runStateT  (f exp') hc)
-    --tell x = lift $ Control.Monad.Writer.tell x
-    --isHole (Con t _) | t == tagHole = True
-    --isHole _ = False
-
-    f (Store { expValue = val } :>>= var@(Var v _) :-> exp2) = do
-        p <- toPos val
-        lmap <- ask
-        p' <- if Map.lookup v lmap == Just One then newHeap UnsharedEval p else newHeap SharedEval p
-        bind var p'
-        f exp2
-    f (Alloc { expValue = val } :>>= var@(Var v _) :-> exp2) = do
-        p <- toPos val
-        lmap <- ask
-        p' <- if Map.lookup v lmap == Just One then newHeap UnsharedEval p else newHeap SharedEval p
-        bind var p'
-        f exp2
-
-    f (exp :>>= v :-> exp2) = do
-        p <- g exp
-        bind v p
-        f exp2
-    f exp = g exp
-
-    g Let { expDefs = defs, expBody = body } = do
-        mapM_ (uncurry collectM) [ (funcDefName d, funcDefBody d) | d <- defs]
-        f body
-    g (App fe [v] _) | fe == funcEval = do
-        x <- toPos v
-        tell mempty { appEq = [(funcEval,[x])] }
-        return $ Complex funcEval [Complex funcFetch [x]]
-    g (App fe [v,x] _) | fe == funcApply = do
-        v <- toPos v
-        x <- toPos x
-        tell mempty { applyEq = [(v,x)] }
-        return $ Complex funcApply [v,x]
-    g (App a vs _) | a `notElem` [funcEval,funcApply]  = do
-        vs' <- mapM toPos vs
-        tell mempty { appEq = [(a,vs')] }
-        return $ Func a
-    g Return { expValue = n@(NodeC _ (_:_)) } = do
-        p@(Con a ts) <- toPos n
-        --case fromAtom a of
-        --    'F':rs -> tell mempty { appEq = [(toAtom ('f':rs),ts)] }
-        --    'B':rs -> tell mempty { appEq = [(toAtom ('b':rs),ts)] }
-        --    _ -> return ()
-        return p
-    g (Return { expValue = val }) = toPos val
-    g Store { expValue = NodeC t _ } | t == tagHole = do
-        newHeap RecursiveThunk mempty
-    g Store { expValue = NodeC t vs } | any isValUnknown vs = do
-        newHeap RecursiveThunk mempty
-    g Store { expValue = n@(NodeC _ (_:_)) } = do
-        p@(Con a ts) <- toPos n
-        --case fromAtom a of
-        --    'F':rs -> tell mempty { appEq = [(toAtom ('f':rs),ts)] }
-        --    'B':rs -> tell mempty { appEq = [(toAtom ('b':rs),ts)] }
-        --    _ -> return ()
-        newHeap SharedEval p
-    g (Store { expValue = val }) = do
-        v <- toPos val
-        newHeap SharedEval v
-    g (Alloc { expValue = val }) = do
-        v <- toPos val
-        newHeap SharedEval v
-    g Fetch { expAddress = val } = do
-        p <- toPos val
-        return $ Complex funcFetch [p]
-    g (Prim p vs)
-        | Just as <- primRets p = return $ Union [ Con a [] | a <- as]
-        | (_,TyTup []) <- primType p = return Basic
-        | (_,TyTup ts) <- primType p = return $ Tuple (replicate (length ts) Basic)
-        | otherwise = return Basic
-    g (Error {}) = return mempty
-    g (Case d ls) = do
-        p <- toPos d
-        --xs <- sequence [ bind v p >> f exp |  v :-> exp <- ls ]
-        let f'' bnd tg exp = do
-                (v,w) <- listen (bnd >> f exp)
-                let t x = PIf True p tg x -- [(tg,x)] mempty
-                    z xs = [ (t x,t y) |  (x,y) <- xs ]
-                    z' as = [  (a,map t ts)   |  (a,ts) <- as   ]
-                tell (applyEq_u z $ updateEq_u z $ appEq_u z' $  w)
-                return v
-            f' bnd _ exp = bnd >> f exp
-        xs <- sequence [  f' (bind v p) t exp >>= \x -> return (t,x) |  v@(NodeC t _) :-> exp <- ls ]
-        els <- sequence [ bind v p >> f exp |  v@(Var _ _) :-> exp <- ls ]
-        let els' = head (els ++ [mempty])
-        if (length xs + length els == length ls) then
-            return (PCase p xs els')
-              else sequence [ f e | _ :-> e <- ls ] >>= return . mconcat
-        --return $ mconcat xs
-    g (Update p v) = do
-        p <- toPos p
-        v <- toPos v
-        tell mempty { updateEq = [(p,v)] }
-        return Basic
-    g x = error $ unwords ["Grin.PointsToAnalysis.collect.g",show x]
-
-toPos (NodeC tag vs) = do
-    vs' <- mapM toPos vs
-    return $ Con tag vs'
-toPos (Const v) = do
-    (_,h) <- newConst' False v
-    tell mempty { constValEq = [(negate h,v)] }
-    toPos v -- XXX discard
-    return $ Ptr (-h)
-toPos (Tup []) = return Basic
-toPos (Tup xs) = do
-    vs' <- mapM toPos xs
-    return $ Tuple vs'
-toPos (Lit {}) = return Basic
-toPos (ValPrim {}) = return Basic
-toPos Tag {} = return Basic
-toPos ValUnknown {} = return mempty
-toPos (Var v _)  = return $ Variable v
-toPos (Index v _) = toPos v
-toPos x  = error $ unwords ["toPos:",show x]
-
-
-
-hcHashGetNodes (HcHash _ hc) = [ (x,n) | (n,x) <- Map.toList hc ]
-
-
-tupleName = toAtom ""
-
-constPos Basic = return vsBas
-constPos (Con a []) = return (setNodes [(a,[])])
-constPos (Con a xs) = do
-    cs <- mapM constPos xs
-    return (setNodes [(a,cs)])
-constPos (Tuple []) = return $ VsBas "()"
-constPos (Tuple ts) = constPos (Con tupleName ts)
-constPos (Union cs) = do
-    cs' <- mapM constPos cs
-    return (mconcat cs')
-constPos (Ptr i)  = return $ setHeaps [i]
-constPos _ = fail "not a constant Pos"
-
-findFixpoint' :: Grin -> HcHash -> PointsToEq -> IO PointsTo
-findFixpoint' grin (HcHash _ mp) eq = do
-    fr <- newFixer
-    let cmap eql = do
-            vs <- flip mapM eql $ \ (v,p) -> do
-                x <- newValue fr bottom
-                return (v,(x,p))
-            return $ Map.fromList vs
-    varMap <- cmap (varEq eq)
-    heapMap <- cmap (heapEq eq)
-    argMap <- newIORef mempty
-    funcSupply <- newSupply fr
-    funcMap <- do
-        vs <- flip mapM (funcEq eq) $ \ (v,p) -> do
-            x <- supplyValue funcSupply v
-            return (v,(x,p))
-        return $ Map.fromList vs
-
-
-    let cheaps = Map.fromList [ ((-x),setNodes [(t,(map z xs))]) | (HcNode t xs,x) <- Map.toList mp ] where
-        z (Right n) = setHeaps [(-n)]
-        z (Left (Var v _)) = case Map.lookup v varMap of
-            Just (_,(Ptr h)) -> setHeaps [h]
-            _ -> error "cheaps"
-        z (Left i) = VsBas (show i)
-
-    let procPos self p = pp p where
-            pp p | Just c <- constPos p = addRule $ self `isSuperSetOf` value c
-            pp p | Just e <- simplePos p = addRule $ self `isSuperSetOf` e
-            pp (Union ps) = mapM_ pp ps
-            pp (Tuple ts) = pp (Con tupleName ts)
-            pp (DownTup p n) = pp (Down p tupleName n)
-            pp (PIf True p a t) = do
-                p' <- newVal p
-                t' <- newVal t
-                addRule $ conditionalRule (Set.member a . getNodes) p' $  self `isSuperSetOf` t'
-            pp (PCase p vs e) = do
-                p' <- newVal p
-                e' <- newVal e
-                flip mapM_ vs $ \ (a,w) -> do
-                    w' <- newVal w
-                    addRule $ conditionalRule (Set.member a . getNodes) p' $  self `isSuperSetOf` w'
-                once <- newOnce
-                addRule $ conditionalRule (\x -> not $ or [ Set.member a (getNodes x) | (a,_) <- vs]) p' $ ioToRule $  runOnce once (addRule $ self `isSuperSetOf` e')
-            pp cc@(Complex a [p])
-                | a == funcEval = do
-                    p' <- newVal p
-                    let evaledSuperSetOf a b =  modifiedSuperSetOf a b (\n -> pruneNodes $ VsNodes (Map.filterWithKey (\ (t,_) _ -> tagIsWHNF t) (getNodeArgs n)) (Set.filter tagIsWHNF (getNodes n)))
-                    addRule $ evaledSuperSetOf self p'
-                    addRule $ dynamicRule p' $ \p -> ioToRule $ do
-                        addRule $ mconcatMap (self `evaledSuperSetOf`) [ sValue funcSupply (tagFlipFunction n) | n <- (Set.toList $ getNodes p), tagIsSuspFunction n ]
-                        flip mapM_ (Map.toList $ getNodeArgs p) $ \ ((n,i),v) -> do
-                            when (tagIsSuspFunction n) $ do
-                                a <- getArg (tagFlipFunction n) i
-                                addRule $ a `isSuperSetOf` value v
-                | a == funcFetch = do
-                    p' <- newVal p
-                    addRule $ dynamicRule p' $ \v -> mconcat $ flip map (Set.toList (getHeaps' ("funcFetch" ++ show cc) v)) $ \u -> ioToRule $ do
-                        case Map.lookup u heapMap of
-                            Just (x,_) -> addRule $ self `isSuperSetOf` x
-                            Nothing -> do
-                                z <- Map.lookup u cheaps
-                                addRule $ self `isSuperSetOf` value z
-            pp cc@(Complex a [v,x]) | a == funcApply = do
-                v' <- newVal v
-                x' <- newVal x
-                addRule $ modifiedSuperSetOf self v' $ \v -> let
-                    ns = Set.fromList $ concatMap incp (Set.toList (getNodes v))
-                    as = Map.fromList $  [ ((nn,i),v) | ((n,i),v) <- Map.toList (getNodeArgs v), nn <- incp n ]
-                   in VsNodes as ns
-
-                addRule $ dynamicRule v' $ \v -> ioToRule $ do
-                    flip mapM_ (concat [  fmap ((,) n) (incp n)  | n <- (allNodes v) ]) $ \(on,n) -> do
-                        (ts,_) <- findArgsType (grinTypeEnv grin) n
-                        --let mm = Map.fromList $ concat [ Map.lookup (on,i) (getNodeArgs v) >>= return . ((,) (n,i)) |  i <- [0 .. length ts ]]
-                        --self `isSuperSetOf` value (pruneNodes $ VsNodes mm mempty)
-                        addRule $ modifiedSuperSetOf self x' $ \x ->
-                                pruneNodes $ VsNodes (Map.singleton (n,length ts - 1) x) Set.empty
-                        return ()
-                    flip mapM_ (Set.toList (getNodes v)) $ \n -> do
-                         case tagUnfunction n of
-                            Just (1,fn) -> addRule $ self `isSuperSetOf` sValue funcSupply fn
-                            _ -> return ()
-                    --sequence_ $ concat [  papp'' n i a | ((n,i),a) <- Map.toList (getNodeArgs v) ]
-            pp (Down p a i) = do
-                p' <- newVal p
-                addRule $ modifiedSuperSetOf self p' $ \p -> case Map.lookup (a,i) (getNodeArgs p) of
-                    Just v -> v
-                    Nothing -> mempty
-            pp arg@(Arg a i) = do
-                x <- getArg a i
-                addRule $ self `isSuperSetOf` x
-            pp (Con n as) = do
-                as'' <- mapM newVal as
-                addRule $ self `isSuperSetOf` value (VsNodes mempty (Set.singleton n))
-                flip mapM_ (zip [(0 :: Int) ..] as'') $ \ (i,a) -> do
-                    addRule $ modifiedSuperSetOf self a $ \a' -> pruneNodes $ VsNodes (Map.singleton (n,i) a') (Set.singleton n)
-            pp e = fail $ "pp: " ++ show e
-            incp t | Just (n,fn) <- tagUnfunction t, n > 1 = return (partialTag fn (n - 1))
-            incp _ = fail "not incp"
-            allNodes x = snub $ (Set.toList $ getNodes x) ++ (fsts $ Map.keys (getNodeArgs x))
-        procUpdate p1 p2 = do
-            p1' <- newVal p1
-            p2' <- newVal p2
-            addRule $ dynamicRule p1' $ \p1 -> ioToRule $ flip mapM_ (Set.toList (getHeaps' "update" p1)) $ \h ->
-                case Map.lookup h heapMap of
-                    Just (e,_) -> addRule $ e `isSuperSetOf` p2'
-                    Nothing -> return ()
-        procApply xp1 xp2 = do
-            p1' <- newVal xp1
-            p2' <- newVal xp2
-            addRule $ dynamicRule p1' $ \p1 -> ioToRule $ do
-                argMap <- readIORef argMap
-                flip mapM_ (Map.toList (getNodeArgs p1)) $ \ ((a,i),v) -> do
-                    case tagUnfunction a of
-                        Just (1,fn) -> do
-                            case Map.lookup (fn,i) argMap of
-                                Just arg -> do
-                                    addRule $ arg `isSuperSetOf` value v
-                                _  -> return ()
-                        _ -> return ()
-
-                flip mapM_ (Set.toList (getNodes p1)) $ \ a -> do
-                    case tagUnfunction a of
-                        Just (1,fn) -> do
-                            case Map.lookup (fn,length (fst $ runIdentity $  findArgsType (grinTypeEnv grin) fn) - 1) argMap of
-                                Just arg -> addRule $ arg `isSuperSetOf` p2'
-                                _ -> return ()
-                        _ -> return ()
-        procApp a [p] | a == funcEval = do
-            p' <- newVal p
-            addRule $ dynamicRule p' $ \p -> ioToRule $ flip mapM_ (Set.toList (getHeaps p)) $ \h -> do
-                case Map.lookup h heapMap of
-                    Just (e',(x,_)) | x /= UnsharedEval -> addRule $ dynamicRule e' $ \e ->
-                        mconcatMap (e' `isSuperSetOf`) [ sValue funcSupply (tagFlipFunction n) | n <- (Set.toList $ getNodes e), tagIsSuspFunction n ]
-                    _ -> return ()
-
-        procApp a ps = do
-            unless (tagIsFunction a) $ fail "procApp: not function"
-            argMap <- readIORef argMap
-            flip mapM_ (zip [0..] ps) $ \ (i,p) -> do
-                case Map.lookup (a,i) argMap of
-                    Just v -> procPos v p
-                    Nothing -> return ()
-
-        simplePos p | Just x <- constPos p = return $ value x
-        simplePos var@(Variable v) = case Map.lookup v varMap of
-            Just (x,_) -> return x
-            Nothing -> error $ "varMap has no var:" ++ show var
-        simplePos (Func v) = return $ sValue funcSupply v
-        simplePos _ = fail "this pos is not simple"
-        getArg a i = do
-            when (not $ tagIsFunction a) $ fail $ "getArg: tag not function" ++ show (a,i)
-            am <- readIORef argMap
-            case Map.lookup (a,i) am of
-                Just e -> return e
-                Nothing -> do
-                    x <- newValue fr mempty
-                    modifyIORef argMap (Map.insert (a,i) x)
-                    return x
-        newVal p | Just v <- simplePos p = return v
-        newVal p = do
-            v <- newValue fr mempty
-            procPos v p
-            return v
-
-    flip mapM_ (Map.elems varMap) $ \ (e,p) -> procPos e p
-    flip mapM_ (Map.elems funcMap) $ \ (e,p) -> procPos e p
-    flip mapM_ (Map.elems heapMap) $ \ (e,(_,p)) -> procPos e p
-    mapM_ (uncurry procUpdate) (updateEq eq)
-    mapM_ (uncurry procApply) (applyEq eq)
-    mapM_ (uncurry procApp) (appEq eq)
-
-    calcFixpoint "points-to" fr
-
-    let readMap m = fmap Map.fromList $ flip mapM (Map.toList m) $ \ (v,(e,_)) -> do
-                x <- readValue e
-                return (v,x)
-    ptVars <- readMap varMap
-    ptFunc <- readMap funcMap
-    ptHeap <- readMap heapMap
-
-
-    let makeEntry v i n ty | Just x <- Map.lookup v ptVars = ((n,i),(ty,x))
-        ptFuncArgs = [ makeEntry v i n ty | (n,~(Tup xs) :-> _) <- grinFuncs grin, (i,~(Var v ty)) <- zip naturals xs]
-
-
-    wdump FD.Eval $ do
-        CharIO.putStrLn "argMap"
-        argMap <- readIORef argMap
-        mapM_  (\ (ai,x) -> readValue x >>= \x' -> CharIO.print (ai,x')) (Map.toList argMap)
-    --CharIO.putStrLn "ConstValEq"
-    --mapM_ CharIO.print (snubUnder fst $ constValEq eq)
-
-    return PointsTo {
-        ptVars = ptVars,
-        ptFunc = ptFunc,
-        ptConstMap = Map.fromList (constValEq eq),
-        ptFuncArgs = Map.fromList ptFuncArgs,
-        ptHeap = ptHeap `Map.union`  cheaps,
-        ptHeapType = Map.fromList [ (h,t) | (h,(t,_)) <- heapEq eq ]
-        }
-
-
rmfile ./Grin/PointsToAnalysis.hs
hunk ./C/Arch.hs 2
-module C.Arch(determineArch,primitiveInfo,genericPrimitiveInfo,isFGrin) where
+module C.Arch(determineArch,primitiveInfo,genericPrimitiveInfo) where
hunk ./C/Arch.hs 69
-isFGrin :: Bool
-isFGrin = case optArch options of
-    Nothing -> True
-    Just o -> "grin" `isPrefixOf` o
hunk ./Grin/EvalInline.hs 170
-        teval = if isFGrin then [] else [eval]
-    return $ setGrinFunctions (apps ++ teval ++ funcs) grin { grinTypeEnv = TyEnv (tyEnv `Map.union` appTyEnv) }
+    return $ setGrinFunctions (apps ++ funcs) grin { grinTypeEnv = TyEnv (tyEnv `Map.union` appTyEnv) }
hunk ./Grin/FromE.hs 337
-        Nothing | not isFGrin, Just CaseDefault <- Info.lookup (tvrInfo tvr) -> do
-            mtick "Grin.FromE.strict-casedefault"
-            return (Fetch (toVal tvr))
+--        Nothing | not isFGrin, Just CaseDefault <- Info.lookup (tvrInfo tvr) -> do
+--            mtick "Grin.FromE.strict-casedefault"
+--            return (Fetch (toVal tvr))
hunk ./Grin/Simplify.hs 171
-    getCS (b@Var {},Store v@(NodeC t as)) | Just (0,fn) <- tagUnfunction t = return $ Map.fromList [(Store v,Return b)]
+--    getCS (b@Var {},Store v@(NodeC t as)) | Just (0,fn) <- tagUnfunction t = return $ Map.fromList [(Store v,Return b)]
hunk ./Main.hs 19
-import C.FromGrin
hunk ./Main.hs 56
-import Grin.Unboxing
hunk ./Main.hs 81
-import qualified Grin.PointsToAnalysis
hunk ./Main.hs 727
-    if fopts FO.EvalOptimize && not isFGrin then do
-        lintCheckGrin x
-        wdump FD.GrinPreeval $ printGrin x
-        progress "Points-to analysis..."
-        stats <- Stats.new
-        x <- Grin.PointsToAnalysis.grinInlineEvalApply stats x
-        wdump FD.Progress $ Stats.print "EvalInline" stats
-        lintCheckGrin x
-        wdump FD.GrinPosteval $ printGrin x
-        stats <- Stats.new
-        x <- opt "AE Optimization 1" x
-        x <- unboxReturnValues x
-        lintCheckGrin x
-        x <- deadCode stats (grinEntryPointNames x) x
-        lintCheckGrin x
-        x <- return $ normalizeGrin x
-        lintCheckGrin x
-        x <- opt "AE Optimization 2" x
-        x <- unboxReturnValues x
-        lintCheckGrin x
-        x <- deadCode stats (grinEntryPointNames x) x
-        lintCheckGrin x
-        x <- opt "AE Optimization 3" x
-        wdump FD.OptimizationStats $ Stats.print "AE Optimization" stats
-        x <- return $ normalizeGrin x
-        lintCheckGrin x
-
-        printTable "Return points-to" (grinReturnTags x)
-        printTable "Argument points-to" (grinArgTags x)
-        x <- devolveGrin x
-        x <- opt "After Devolve Optimization" x
-        x <- return $ normalizeGrin x
-        x <- devolveGrin x
-        x <- opt "After Devolve Optimization 2" x
-        x <- return $ normalizeGrin x
-        x <- devolveGrin x
-        x <- return $ normalizeGrin x
-        dumpFinalGrin x
-        compileGrinToC x
-     else do
-        x <- nodeAnalyze x
-        lintCheckGrin x
-        x <- createEvalApply x
-        lintCheckGrin x
-        x <- return $ normalizeGrin x
-        lintCheckGrin x
-        x <- devolveGrin x
-        x <- opt "After Devolve Optimization" x
-        x <- return $ normalizeGrin x
-        dumpFinalGrin x
-        compileGrinToC x
+    x <- nodeAnalyze x
+    lintCheckGrin x
+    x <- createEvalApply x
+    lintCheckGrin x
+    x <- return $ normalizeGrin x
+    --x <- unboxReturnValues x
+    lintCheckGrin x
+    x <- devolveGrin x
+    x <- opt "After Devolve Optimization" x
+    x <- return $ normalizeGrin x
+    dumpFinalGrin x
+    compileGrinToC x
hunk ./Main.hs 765
-    let (cg,rls) = if isFGrin then FG2.compileGrin grin else compileGrin grin
+    let (cg,rls) = FG2.compileGrin grin