[perform apply analysis to transform applications into direct calls to functions
John Meacham <john@repetae.net>**20090831100751
 Ignore-this: efe4cd7697c221278dea78be2d060190
] hunk ./src/Grin/Grin.hs 43
+    tagInfo,
+    TagInfo(..),
hunk ./src/Grin/Grin.hs 133
--- For historical reasons, some of the grin expressions do different things depending on the arguments type and whether it is a variable.
---
---
---
--- Store : NodeC:TyNode  -> TyINode   - this allocates a new indirect node
--- Store : var:TyNode -> TyINode - this demotes a node to an indirect node. called 'demote'
--- Update : var:TyINode, TyNode - this stores an indirection to the second argument in the first
--- Update : TyPtr t, t - this sets the memory pointed to by the first argumnet to the second. it is called 'poke'
--- Update : var:TyNode, x:TyNode - this copies the contents of the second argument over the first
--- Update : var:TyINode, x:TyINode - this copies the contents of the second argument over the first
--- Fetch  : TyINode -> TyNode - follow an indirection, also called 'promote'
--- Fetch  : TyPtr t -> t - read a pointer, also called 'peek'
---
---
-
hunk ./src/Grin/Grin.hs 360
+data TagInfo
+    = TagPApp !Int !Atom   -- partial application, number is how many more arguments needed
+    | TagSusp !Bool !Atom  -- a suspended version of the function, true if an update is required
+    | TagDataCons          -- data constructor
+    | TagTypeCons          -- type constructor
+    | TagTypePApp !Int Tag -- type partial app
+    | TagFunc
+
+tagInfo t = case fromAtom t of
+    'F':xs ->  TagSusp True (toAtom $ 'f':xs)
+    'B':xs ->  TagSusp True (toAtom $ 'b':xs)
+    'f':_  -> TagFunc
+    'b':_  -> TagFunc
+    'P':is | (n@(_:_),('_':xs)) <- span isDigit is -> TagPApp (read n) (toAtom $ 'f':xs)
+    'Y':is | (n@(_:_),('_':xs)) <- span isDigit is -> TagTypePApp (read n) (toAtom $ 'T':xs)
+    'C':_ -> TagDataCons
+    'T':_ -> TagTypeCons
+    t -> error $ "tagInfo: bad tag " ++  t
+
hunk ./src/Grin/NodeAnalyze.hs 9
+import Control.Monad.Trans
hunk ./src/Grin/NodeAnalyze.hs 17
+import Text.Printf
hunk ./src/Grin/NodeAnalyze.hs 28
+import Support.Tickle
hunk ./src/Grin/NodeAnalyze.hs 32
+import qualified Stats
hunk ./src/Grin/NodeAnalyze.hs 128
-    let cmap = Map.map (fromJust . flip Map.lookup res) rm
hunk ./src/Grin/NodeAnalyze.hs 135
-    --nfs <- mapM (fixupFunc (grinSuspFunctions grin `Set.union` grinPartFunctions grin) cmap) (grinFuncs grin)
-    --let grin' = setGrinFunctions nfs grin
hunk ./src/Grin/NodeAnalyze.hs 136
-    return $ transformFuncs (fixupFuncs (grinSuspFunctions grin) (grinPartFunctions grin) cmap) grin
+    let cmap = Map.map (fromJust . flip Map.lookup res) rm
+    (grin',stats) <- Stats.runStatT $ mapGrinFuncsM (fixupfs cmap (grinTypeEnv grin)) grin
+    return $ transformFuncs (fixupFuncs (grinSuspFunctions grin) (grinPartFunctions grin) cmap) grin' { grinStats = stats `mappend` grinStats grin' }
hunk ./src/Grin/NodeAnalyze.hs 208
-            forMn_ (zip vs vs') $ \ ((tv,v),i) -> when (isGood tv) $ do
+            forMn_ (zip vs vs') $ \ ((tv,v),i) -> do
hunk ./src/Grin/NodeAnalyze.hs 213
-            forMn_ (zip vs vs') $ \ ((tv,v),i) -> when (isGood tv) $ do
+            forMn_ (zip vs vs') $ \ ((tv,v),i) ->  do
hunk ./src/Grin/NodeAnalyze.hs 384
---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
---
---    lupVar (Var v t) =  case Map.lookup (vr v t) cmap of
---        _ | v < v0 -> fail "nocafyet"
---        Just (ResultJust _ lb) -> return lb
---        Just ResultBounded { resultLB = Just lb } -> return lb
---        _ -> 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'
---
---    f a@(BaseOp Eval [arg]) | Just n <- lupVar arg = case n of
---        N WHNF _ -> return (BaseOp Promote [arg])
---        _ -> return a
---    f e = mapExpExp f e
+fixupfs cmap tyEnv l = tickleM f (l::Lam) where
+    lupVar (Var v t) =  case Map.lookup (vr v t) cmap of
+        _ | v < v0 -> fail "nocafyet"
+        Just (ResultJust _ lb) -> return lb
+        Just ResultBounded { resultLB = Just lb } -> return lb
+        _ -> fail "lupVar"
+    pstuff x arg n@(N w t) = liftIO $ printf "-- %s %s %s\n" x (show arg) (show n)
+    f a@(BaseOp Eval [arg]) | Just n <- lupVar arg = case n of
+        N WHNF _ -> do
+            pstuff "eval" arg n
+            Stats.mtick (toAtom "Optimize.NodeAnalyze.eval-promote")
+            return (BaseOp Promote [arg])
+        _ -> return a
+    f a@(BaseOp (Apply ty) (papp:args)) | Just nn <- lupVar papp = case nn of
+        N WHNF tset | Only set <- tset, [sv] <- Set.toList set, TagPApp n fn <- tagInfo sv, Just (ts,_) <- findArgsType tyEnv sv -> do
+            pstuff "apply" papp nn
+            case (n,args) of
+                (1,[arg]) -> do
+                    Stats.mtick (toAtom "Optimize.NodeAnalyze.apply-inline")
+                    let va = Var v1 (getType arg)
+                        vars = zipWith Var [ v2 .. ] ts
+                    return $ Return [arg,papp] :>>= [va,NodeC sv vars] :-> App fn (vars ++ [va]) ty
+                (1,[]) -> do
+                    Stats.mtick (toAtom "Optimize.NodeAnalyze.apply-inline")
+                    let vars = zipWith Var [ v2 .. ] ts
+                    return $ Return [papp] :>>= [NodeC sv vars] :-> App fn vars ty
+                (pn,[arg]) -> do
+                    Stats.mtick (toAtom "Optimize.NodeAnalyze.apply-inline")
+                    let va = Var v1 (getType arg)
+                        vars = zipWith Var [ v2 .. ] ts
+                    return $ Return [arg,papp] :>>= [va,NodeC sv vars] :-> dstore (NodeC (partialTag fn (pn - 1)) (vars ++ [va]))
+                (pn,[]) -> do
+                    Stats.mtick (toAtom "Optimize.NodeAnalyze.apply-inline")
+                    let vars = zipWith Var [ v2 .. ] ts
+                    return $ Return [papp] :>>= [NodeC sv vars] :-> dstore (NodeC (partialTag fn (pn - 1)) vars)
+                _ -> return a
+        _ -> return a
+    f e = mapExpExp f e
+
+dstore x = BaseOp (StoreNode True) [x]
+
hunk ./src/Grin/Noodle.hs 17
+import Support.Tickle
hunk ./src/Grin/Noodle.hs 37
+instance Tickleable Exp Lam where
+    tickleM = mapBodyM
hunk ./src/Grin/Noodle.hs 40
+instance Tickleable Exp Exp where
+    tickleM = mapExpExp
+instance Tickleable Val Exp where
+    tickleM = mapExpVal
+instance Tickleable Val Val where
+    tickleM = mapValVal
+    tickleM_ = mapValVal_
+
+mapBodyM :: Monad m => (Exp -> m Exp) -> Lam -> m Lam
hunk ./src/Main.hs 666
+    wdump FD.GrinPreeval $ dumpGrin "preeval2" x
+    x <- transformGrin nodeAnalyzeParms x
+    x <- transformGrin simplifyParms x
hunk ./src/Util/UnionSolve.hs 7
-    islte,isgte,equals
+    islte,isgte,equals,
+    varIsInteresting
hunk ./src/Util/UnionSolve.hs 13
+import qualified Data.Sequence as S
+import qualified Data.Foldable as S
hunk ./src/Util/UnionSolve.hs 45
-newtype C l v = C ([CL l v] -> [CL l v])
+-- we make the fields strict because many empty values will be
+-- mappended together when used in a writer monad.
+data C l v = C !(S.Seq (CL l v)) !(Set.Set v)
hunk ./src/Util/UnionSolve.hs 49
-instance Monoid (C l v) where
-    mempty = C id
-    mappend (C a) (C b) = C (a . b)
+instance Ord v => Monoid (C l v) where
+    mempty = C mempty mempty
+    mappend (C a b) (C c d) = C (a `mappend` c) (b `mappend` d)
hunk ./src/Util/UnionSolve.hs 56
-
hunk ./src/Util/UnionSolve.hs 57
-    showsPrec _ (C xs) = showString "" . foldr (.) id (intersperse (showString "\n") (map shows (xs []))) . showString "\n"
+    showsPrec _ (C xs _) = showString "" . foldr (.) id (intersperse (showString "\n") (map shows (S.toList xs))) . showString "\n"
hunk ./src/Util/UnionSolve.hs 67
-islte,isgte,equals :: Either v l -> Either v l -> C l v
-islte  x y = C ((x `Clte` y):)
+islte,isgte,equals :: Ord v => Either v l -> Either v l -> C l v
+islte  x y = C (S.singleton (x `Clte` y)) mempty
hunk ./src/Util/UnionSolve.hs 70
-equals x y = C ((x `Cset` y):)
+equals x y = C (S.singleton (x `Cset` y)) mempty
+
+varIsInteresting :: v -> C l v
+varIsInteresting v = C mempty (Set.singleton v)
hunk ./src/Util/UnionSolve.hs 116
-solve putLog (C csp) = do
+solve putLog (C csp _vset) = do
hunk ./src/Util/UnionSolve.hs 118
-        cs = csp []
+        cs = S.toList csp