[collect internal function definitions, add Let support to some combinators
John Meacham <john@repetae.net>**20060815122024] hunk ./Grin/Grin.hs 16
+    mapFBodies,
hunk ./Grin/Grin.hs 18
+    updateFuncDefProps,
hunk ./Grin/Grin.hs 215
-createFuncDef local name body@(args :-> rest)  = FuncDef { funcDefName = name, funcDefBody = body, funcDefCall = call, funcDefProps = props } where
+createFuncDef local name body@(args :-> rest)  = updateFuncDefProps FuncDef { funcDefName = name, funcDefBody = body, funcDefCall = call, funcDefProps = funcProps } where
hunk ./Grin/Grin.hs 217
-    props = funcProps { funcFreeVars = freeVars body, funcTags = freeVars body, funcType = (map getType (fromTuple args),getType rest) }
+
+
+updateFuncDefProps fd@FuncDef { funcDefBody = body@(args :-> rest) } =  fd { funcDefProps = props } where
+    props = (funcDefProps fd) { funcFreeVars = freeVars body, funcTags = freeVars body, funcType = (map getType (fromTuple args),getType rest) }
hunk ./Grin/Grin.hs 335
+mapExpExp f l@Let { expBody = b, expDefs = defs } = do
+    b <- f b
+    defs' <- mapFBodies f defs
+    return l { expBody = b, expDefs = defs' }
hunk ./Grin/Grin.hs 341
+mapFBodies f xs = mapM f' xs where
+    f' fd@FuncDef { funcDefBody = l :-> r } = do
+        r' <- f r
+        return $  updateFuncDefProps fd { funcDefBody = l :-> r' }
+
hunk ./Grin/PointsToAnalysis.hs 205
+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
hunk ./Grin/PointsToAnalysis.hs 395
-        te = grinTypeEnv grin
+        te = extendTyEnv fds typeEnv
+        fds = concatMap (collectFuncDefs . lamExp) (snds $ grinFuncs grin)
hunk ./Grin/PointsToAnalysis.hs 399
-                ts = case findArgsType te atom of
-                    Just (ts,_) -> ts
-                    _ -> []
+                Just (ts,_) = findArgsType te atom
+                --ts = case findArgsType te atom of
+                --    Just (ts,_) -> ts
+                --    _ -> []
hunk ./Grin/PointsToAnalysis.hs 415
-    Nothing     -> valueSetToItem te pt TyUnknown vs -- error ("funcReturn: "++show fn)
+    Nothing     -> error ("funcReturn: "++show fn)
+    --Nothing     -> valueSetToItem te pt TyUnknown vs -- error ("funcReturn: "++show fn)
hunk ./Grin/PointsToAnalysis.hs 422
-valueSetToItem te pt ~TyNode (VsNodes as n) = NodeValue (Set.mapMonotonic f n) where  -- depends on tag being first value in NodeValue
+valueSetToItem te pt TyNode (VsNodes as n) = NodeValue (Set.mapMonotonic f n) where  -- depends on tag being first value in NodeValue
hunk ./Grin/PointsToAnalysis.hs 424
-        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
+        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
hunk ./Grin/PointsToAnalysis.hs 434
-valueSetToItem te pt ~(TyTup xs) (VsNodes as n)
+valueSetToItem te pt (TyTup xs) (VsNodes as n)
hunk ./Grin/Simplify.hs 220
+    f _ (_ :-> Let {}) = False
+    f _ (_ :-> MkCont {}) = False
hunk ./Grin/Simplify.hs 363
+    f lt@(Let { expDefs = defs, expBody = e :>>= l :-> r } :>>= lr) | Set.null (freeVars r `Set.intersect` (Set.fromList $ map funcDefName defs)) = do
+        mtick "Optimize.optimize.let-shrink-tail"
+        f ((lt { expDefs = defs, expBody = e } :>>= l :-> r) :>>= lr)
hunk ./Grin/Simplify.hs 405
+    f e@Let {} = mapExpExp f e