[make manifest node and modifying tail handle local recursive tail-calls properly, add let-hoist-return optimization
John Meacham <john@repetae.net>**20060817042602] hunk ./Grin/Noodle.hs 14
+import Debug.Trace
hunk ./Grin/Noodle.hs 18
-modifyTail lam@(_ :-> lb) e = f e where
-    f (Error s ty) = Error s (getType lb)
-    f (Case x ls) = Case x (map g ls)
-    f lt@Let {expBody = body } = lt { expBody = f body }
-    f lt@MkCont {expLam = lam, expCont = cont } = lt { expLam = g lam, expCont = g cont }
-    f (e1 :>>= p :-> e2) = e1 :>>= p :-> f e2
-    f e = e :>>= lam
-    g (p :-> e) = p :-> f e
+modifyTail lam@(_ :-> lb) te = trace "modifyTail: returning" (f mempty te) where
+    f lf e | False && trace ("modifyTail: " ++ show (lf,e)) False = undefined
+    f _ (Error s ty) = Error s (getType lb)
+    f lf (Case x ls) = Case x (map (g lf) ls)
+    f _ lt@Let {expIsNormal = False } = lt :>>= lam
+    f lf lt@Let {expDefs = defs, expBody = body, expIsNormal = True } = updateLetProps lt { expBody = f nlf body, expDefs = defs' } where
+        nlf = lf `Set.union` Set.fromList (map funcDefName defs)
+        defs' = [ updateFuncDefProps d { funcDefBody = g nlf (funcDefBody d) } | d <- defs ]
+    f lf lt@MkCont {expLam = lam, expCont = cont } = lt { expLam = g lf lam, expCont = g lf cont }
+    f lf (e1 :>>= p :-> e2) = e1 :>>= p :-> f lf e2
+    f lf e@(App a _ _) | a `Set.member` lf = e
+    f lf e = e :>>= lam
+    g lf (p :-> e) = p :-> f lf e
hunk ./Grin/Noodle.hs 45
-    return l { expBody = b, expDefs = defs' }
+    return $ updateLetProps l { expBody = b, expDefs = defs' }
hunk ./Grin/Noodle.hs 59
-isManifestNode (Return (Tag t)) = return [t]
-isManifestNode (Return (NodeC t _)) = return [t]
-isManifestNode Error {} = return []
-isManifestNode (Case _ ls) = do
-    cs <- Prelude.mapM isManifestNode [ e | _ :-> e <- ls ]
-    return $ concat cs
-isManifestNode (_ :>>= _ :-> e) = isManifestNode e
-isManifestNode _ = fail "not manifest node"
+isManifestNode e = f mempty e where
+    f lf _ | False && trace ("isManifestNode: " ++ show lf) False = undefined
+    f lf (Return (Tag t)) = return [t]
+    f lf (Return (NodeC t _)) = return [t]
+    f lf Error {} = return []
+    f lf (App a _ _) | a `Set.member` lf = return []
+    f lf Let { expBody = body, expIsNormal = False } = f lf body
+    f lf Let { expBody = body, expDefs = defs, expIsNormal = True } = ans where
+        nlf = lf `Set.union` Set.fromList (map funcDefName defs)
+        ans = do
+            xs <- mapM (f nlf . lamExp . funcDefBody) defs
+            b <- f nlf body
+            return (concat (b:xs))
+    f lf (Case _ ls) = do
+        cs <- Prelude.mapM (f lf) [ e | _ :-> e <- ls ]
+        return $ concat cs
+    f lf (_ :>>= _ :-> e) = isManifestNode e
+    f lf _ = fail "not manifest node"
hunk ./Grin/Noodle.hs 122
+        cfunc e | False && trace ("isManifestNode: " ++ show e) False = undefined
hunk ./Grin/Noodle.hs 151
-    expIsNormal = False,
+    expIsNormal = undefined,
hunk ./Grin/Optimize.hs 76
-            f r = return lt {  expBody = r }
+            f r = return $ updateLetProps lt {  expBody = r }
hunk ./Grin/PointsToAnalysis.hs 395
-        vsToItem = valueSetToItem (grinTypeEnv grin) pt
+        vsToItem = valueSetToItem te pt
hunk ./Grin/Simplify.hs 342
-    f (Case x alts :>>= v :-> Return v' :>>= NodeC t as :-> lr ) | v == v' = do
+    f (cc@Case {} :>>= v :-> Return v' :>>= NodeC t as :-> lr ) | v == v' = do
hunk ./Grin/Simplify.hs 348
-        f (mc (Case x alts) :>>= tuple as :-> Return (NodeC t as) :>>= v :-> lr)
+        f (mc cc :>>= tuple as :-> Return (NodeC t as) :>>= v :-> lr)
+    f (lt@Let { expIsNormal = True } :>>= v :-> Return v' :>>= NodeC t as :-> lr ) | v == v' = do
+        mtick "Optimize.optimize.let-hoist-return"
+        let (va:_) = [ v | v <- [v1..], not $ v `Set.member` fv ]
+            var = Var va TyNode
+            fv = freeVars as
+            mc = modifyTail ( var :-> Return var :>>=  NodeC t as :-> Return (tuple as))
+        f (mc lt :>>= tuple as :-> Return (NodeC t as) :>>= v :-> lr)
hunk ./Grin/Simplify.hs 360
-    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 ((updateLetProps lt { expBody = e } :>>= l :-> r) :>>= lr)
+--    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 ((updateLetProps lt { expBody = e } :>>= l :-> r) :>>= lr)