[after node analysis, modify function bodies.
John Meacham <john@repetae.net>**20090828074755
 Ignore-this: d4b0f23de082233ed4a2665eb743094b
] hunk ./src/Grin/FromE.hs 341
+istore (NodeC t ts) | tagIsWHNF t = dstore (NodeC t ts) :>>= [Var v1 TyNode] :-> demote (Var v1 TyNode)
hunk ./src/Grin/FromE.hs 600
-    cc e | Just [z] <- con e = return $ BaseOp (StoreNode (not $ isLifted e)) [z] -- if isLifted e then Store z else Return [z]
+    cc e | Just [z] <- con e = return $ bool (isLifted e) istore dstore z -- BaseOp (StoreNode (not $ isLifted e)) [z] -- if isLifted e then Store z else Return [z]
hunk ./src/Grin/FromE.hs 684
+    doUpdate vr (BaseOp StoreNode {} [n@(NodeC t ts)] :>>= [p] :-> BaseOp Demote [p']) | p == p' = (BaseOp Overwrite [vr,n],t,map getType ts)
hunk ./src/Grin/FromE.hs 757
+
+bool b x y = if b then x else y
hunk ./src/Grin/Grin.hs 194
---    | Store     { expValue :: Val }                                       -- ^ Allocate a new heap node
hunk ./src/Grin/Grin.hs 502
---    getType (Store v) = case getType v of
---        TyNode -> [TyINode]
---        t -> [TyPtr t]
hunk ./src/Grin/Grin.hs 505
+    getType (BaseOp Demote _) = [TyINode]
hunk ./src/Grin/NodeAnalyze.hs 33
-data NodeType =
-    WHNF         -- ^ guarenteed to be a WHNF
---    | LazyWHNF   -- ^ WHNF or an indirection to a WHNF
+data NodeType
+    = WHNF       -- ^ guarenteed to be a WHNF
hunk ./src/Grin/NodeAnalyze.hs 133
-    nfs <- mapM (fixupFunc cmap) (grinFuncs grin)
-    return $ setGrinFunctions nfs grin
+    nfs <- mapM (fixupFunc (grinSuspFunctions grin `Set.union` grinPartFunctions grin) cmap) (grinFuncs grin)
+    let grin' = setGrinFunctions nfs grin
+    return $ grin' { grinTypeEnv = extendTyEnv (grinFunctions grin') (grinTypeEnv grin') }
hunk ./src/Grin/NodeAnalyze.hs 138
-data Todo = Todo Bool [V] | TodoNothing
+data Todo = Todo !Bool [V] | TodoNothing
hunk ./src/Grin/NodeAnalyze.hs 142
+    ans = do
+        let rts = getType body
+        forMn_ rts $ \ (t,i) -> dVar (fr name i t) t
+        forMn_ arg $ \ (~(Var v vt),i) -> do
+            dVar (vr v vt) vt
+            tell $ Left (fa name i vt) `equals` Left (vr v vt)
+        fn (Todo True [ fr name i t | i <- naturals | t <- rts ]) body
hunk ./src/Grin/NodeAnalyze.hs 157
-    ans = do
-        let rts = getType body
-        forMn_ rts $ \ (t,i) -> dVar (fr name i t) t
-        forMn_ arg $ \ (~(Var v vt),i) -> do
-            dVar (vr v vt) vt
-            tell $ Left (fa name i vt) `equals` Left (vr v vt)
-        fn (Todo True [ fr name i t | i <- naturals | t <- rts ]) body
hunk ./src/Grin/NodeAnalyze.hs 228
+        f (BaseOp Demote [w]) = do
+            ww <- convertVal w
+            --dres [ww]
+            dres [Right (N WHNF Top)]
hunk ./src/Grin/NodeAnalyze.hs 298
+--data WhatToDo
+--    = WhatDelete
+--    | WhatNothing
+--    | WhatSubs (Var -> Exp) (Var -> Exp)
+
+
+--type TFunc = [()]
hunk ./src/Grin/NodeAnalyze.hs 306
+--transformFuncs :: (Atom -> (TFunc,TFunc)) -> Grin -> Grin
+
+
+
+fixupFunc sfuncs cmap (name,l :-> body) = fmap (\b -> (name, l' :-> b)) (f body >>= g fixups') where
+    (l',fixups') | name `Set.member` sfuncs = (l,[])
+                 | otherwise = ((map f $ zip l ll),fixups) where
+        ll = map lupVar l
+        fixups = [ v | (v@(Var _ TyINode),Just (N WHNF _)) <- zip l ll]
+        f (Var v _,Just (N WHNF _)) = Var v TyNode
+        f (v,_) = v
hunk ./src/Grin/NodeAnalyze.hs 318
-fixupFunc cmap (name,l :-> body) = fmap (\b -> (name, l :-> b)) (f body) where
hunk ./src/Grin/NodeAnalyze.hs 323
-    lupVar _ = fail "lupVar"
+    lupArg a (x,i) =  case Map.lookup (fa a i (getType x)) cmap of
+        Just (ResultJust _ lb) -> return lb
+        Just ResultBounded { resultLB = Just lb } -> return lb
+        _ -> fail "lupArg"
+    g [] e = return e
+    g (Var v TyINode:xs) e = do e' <- g xs e ; return $ BaseOp Demote [Var v TyNode] :>>= [Var v TyINode] :-> e'
+    f (App a xs ts)  | a `Set.notMember` sfuncs, not $ null mvars = return res where
+        largs = map (lupArg a) (zip xs [0 ..  ])
+        largs' =  [ (Var v (getType x),la) | (x,v,la) <- zip3 xs [ v1 .. ] largs ]
+        mvars = [ (Var v TyINode) | (Var v TyINode,Just (N WHNF _)) <- largs' ]
+        mvars' = [ case (v,la) of (Var v' TyINode,Just (N WHNF _)) -> Var v' TyNode ; _ -> v  | (v,la) <- largs' ]
+        res = Return xs :>>= fsts largs' :-> f mvars (App a mvars' ts)
+        f (Var v TyINode:rs) e = BaseOp Promote [Var v TyINode] :>>= [Var v TyNode] :-> f rs e
+        f [] e = e
+    f Let { expDefs = ds, expBody = e } = do
+        ds' <- forM ds $ \d -> do
+            (_,l) <- fixupFunc sfuncs cmap (funcDefName d, funcDefBody d)
+            return $ updateFuncDefProps  d { funcDefBody = l }
+        e' <- f e
+        return $ grinLet ds' e'
+
hunk ./src/Grin/NodeAnalyze.hs 345
-        N WHNF _ -> do
-                --putStrLn $ "NA-EVAL-WHNF-" ++ show fn
-                return (BaseOp Promote [arg])
+        N WHNF _ -> return (BaseOp Promote [arg])
hunk ./src/Grin/SSimplify.hs 116
-                Just (n,e') -> do mtick n; return e'
+                Just (n,e') -> do mtick n; tellFV e'; return e'
hunk ./src/Grin/SSimplify.hs 161
---    f (BaseOp Promote [Const x]) rs = do
---        mtick "Grin.Simplify.fetch-const"
---        f (Return [x]) rs
+    f (BaseOp Promote [Const x]) rs = do
+        mtick "Grin.Simplify.fetch-const"
+        f (Return [x]) rs