[add case hoisting via jumppoint optimization
John Meacham <john@repetae.net>**20060818045030] hunk ./Grin/Grin.hs 283
-data Phase = PhaseInit | PostInlineEval
+data Phase = PhaseInit | PostInlineEval | PostAeOptimize | PostDevolve
hunk ./Grin/Grin.hs 286
-phaseEvalInlined PostInlineEval = True
-phaseEvalInlined _ = False
+phaseEvalInlined e = e >= PostInlineEval
hunk ./Grin/PointsToAnalysis.hs 760
-            when (not $ tagIsFunction a) $ fail "getArg: tag not function"
+            when (not $ tagIsFunction a) $ fail $ "getArg: tag not function" ++ show (a,i)
hunk ./Grin/Simplify.hs 19
-import qualified Util.Histogram as Hist
hunk ./Grin/Simplify.hs 23
-import Util.HasSize
hunk ./Grin/Simplify.hs 24
+import Util.HasSize
hunk ./Grin/Simplify.hs 27
+import Util.UniqueMonad
+import qualified Util.Histogram as Hist
hunk ./Grin/Simplify.hs 298
-optimize1 ::  Bool -> (Atom,Lam) -> StatM Lam
-optimize1 postEval (n,l) = g l where
+optimize1 ::  Grin -> Bool -> (Atom,Lam) -> StatM Lam
+optimize1 grin postEval (n,l) = execUniqT 1 (g l) where
hunk ./Grin/Simplify.hs 371
-        f (mc cc :>>= tuple as :-> Return (NodeC t as) :>>= v :-> lr)
+        return (mc cc :>>= tuple as :-> Return (NodeC t as) :>>= v :-> lr)
hunk ./Grin/Simplify.hs 378
-        f (mc lt :>>= tuple as :-> Return (NodeC t as) :>>= v :-> lr)
+        return (mc lt :>>= tuple as :-> Return (NodeC t as) :>>= v :-> lr)
hunk ./Grin/Simplify.hs 389
+
+{-
hunk ./Grin/Simplify.hs 397
-
+  -}
hunk ./Grin/Simplify.hs 424
+    f cs@(Case x as) | postEval && all isEnum [ p | p :-> _ <- as] = do
+        mtick "Optimize.optimize.case-enum"
+        let fv = freeVars cs `Set.union` freeVars [ p | p :-> _ <- as ]
+            (va:vb:_vr) = [ v | v <- [v1..], not $ v `Set.member` fv ]
+        return (Return x :>>= NodeV va [] :-> Case (Var va TyTag) (Prelude.map (untagPat vb) as))
+
+    -- hoisting must come last
+    f (Case x as :>>= v@(Var vnum _) :-> rc@(Case v' as') :>>= lr) | v == v', not (vnum `Set.member` freeVars lr) = do
+        c <- caseHoist x as v as' (getType rc)
+        lr <- g lr
+        return $ c :>>= lr
+    f (Case x as :>>= v@Var {} :-> rc@(Case v' as')) | v == v'  = do
+        caseHoist x as v as' (getType rc)
hunk ./Grin/Simplify.hs 454
-    f cs@(Case x as) | postEval && all isEnum [ p | p :-> _ <- as] = do
-        mtick "Optimize.optimize.case-enum"
-        let fv = freeVars cs `Set.union` freeVars [ p | p :-> _ <- as ]
-            (va:vb:_vr) = [ v | v <- [v1..], not $ v `Set.member` fv ]
-        f (Return x :>>= NodeV va [] :-> Case (Var va TyTag) (Prelude.map (untagPat vb) as))
hunk ./Grin/Simplify.hs 467
-    caseHoist x as v as' ty = do
+    notReturnNode (ReturnNode (Just _,_)) = False
+    notReturnNode _ = True
+    --caseHoist x as v as' ty | sizeLTE 1 (filter (\x -> x /= ReturnError && notReturnNode x ) (getReturnInfo (Case undefined as)))= do
+    caseHoist x as v as' ty | sizeLTE 1 (filter (== Nothing ) (Prelude.map (isManifestNode . lamExp) as))  = do
hunk ./Grin/Simplify.hs 472
-        let nc = Case x [ b :-> e :>>= v :-> Case v as' | b :-> e <- as ]
-            z (Error s _) = Error s ty
-            z (e1 :>>= b :-> e2) = e1 :>>= b :-> z e2
-            z e = e :>>= v :-> Case v as'
-        return nc
+        nic <- f (Case v as')
+        True <- return $ Set.null $ Set.intersection (freeVars nic) (freeVars (map lamBind as) :: Set.Set Var)
+        return $ modifyTail (v :-> nic) (Case x as) -- Case x [ b :-> e :>>= v :-> Case v as' | b :-> e <- as ]
+    caseHoist x as v as' ty | grinPhase grin >= PostDevolve  = do
+        mtick $ "Optimize.optimize.case-hoist-jumppoint" -- .{" ++ show (Prelude.map (isManifestNode . lamExp) as :: [Maybe [Atom]])
+        uniq <- newUniq
+        let fname = toAtom $ "fjumppoint-" ++ show n ++ "-" ++ show uniq
+            nbody = modifyTail (v :-> App fname [v] (getType $ Case v as')) (Case x as)
+            fbody = Tup [v] :-> Case v as'
+        return $ grinLet [createFuncDef True fname fbody] nbody
+    caseHoist x as v as' ty = do
+       ras <- sequence [ f e >>= return . (b :->)| b :-> e <- as ]
+       mfc <- f (Case x as)
+       fc <- f (Case v as')
+       return $ mfc :>>= v :-> fc
hunk ./Grin/Simplify.hs 584
-                let (nl',stat) = runStatM (optimize1 postEval (a,nl''))
+                let (nl',stat) = runStatM (optimize1 grin postEval (a,nl''))