[add case unboxing transformation
John Meacham <john@repetae.net>**20060128051350] hunk ./Grin/Simplify.hs 19
-import Stats
+import Stats hiding(combine)
hunk ./Grin/Simplify.hs 21
+import Support.Tuple
hunk ./Grin/Simplify.hs 216
+-- returns nothing if can return a tag, or just atom if can return an atom
+isCombinable :: Monad m => Bool -> Exp -> m (Maybe (Atom,[Ty]))
+isCombinable postEval e = ans where
+    ans = do
+        mn <- f e
+        equal mn
+    equal [] = fail "empty isCombinable"
+    equal [x] = return x
+    equal (x:y:rs) = if x == y then equal (y:rs) else fail "not equal"
+    f (Return (NodeV t [])) | postEval = return [Nothing]
+    f (Return (NodeC t [])) | postEval = return [Nothing]
+    f (Return (NodeC t xs)) = return [Just (t,map getType xs)]
+    f Error {} = return []
+    f (Case _ ls) = do
+        cs <- Prelude.mapM f [ e | _ :-> e <- ls ]
+        return $ concat cs
+    f (_ :>>= _ :-> e) = f e
+    f _ = fail "not combinable"
+
+combine nty (Return (NodeV t [])) = Return (Var t TyTag)
+combine nty (Return (NodeC t [])) = Return (Tag t)
+combine nty (Return (NodeC t xs)) = Return (tuple xs)
+combine nty (Error s ty) = Error s nty
+combine nty (Case x ls) = Case x (map (combineLam nty) ls)
+combine nty (e1 :>>= p :-> e2) = e1 :>>= p :-> combine nty e2
+combineLam nty (p :-> e) = p :-> combine nty e
+
+
hunk ./Grin/Simplify.hs 318
+    f cs@(Case x as) | Just Nothing <- isCombinable postEval cs = do
+        mtick "Optimize.optimize.case-unbox-tag"
+        let fv = freeVars cs `Set.union` freeVars [ p | p :-> _ <- as ]
+            (va:_vr) = [ v | v <- [v1..], not $ v `Set.member` fv ]
+        f (Case x (map (combineLam TyTag) as) :>>= Var va TyTag :-> Return (NodeV va []))
+    f cs@(Case x as) | Just (Just (t,ts)) <- isCombinable postEval cs = do
+        mtick $ "Optimize.optimize.case-unbox-node.{" ++ show t
+        let fv = freeVars cs `Set.union` freeVars [ p | p :-> _ <- as ]
+            vs = [ v | v <- [v1..], not $ v `Set.member` fv ]
+            vars = [ Var v t | v <- vs | t <- ts ]
+        f (Case x (map (combineLam (tuple ts)) as) :>>= tuple vars  :-> Return (NodeC t vars))
hunk ./Grin/Simplify.hs 372
+            ttags = [ bd | bd@(Tag t:-> _) <- as, t `notElem` [ t | Tag t :-> _ <- as' ] ]
hunk ./Grin/Simplify.hs 374
+            f (v@Var {} :-> b) | getType v == TyTag = v :-> Case v ttags :>>= unit :-> b
hunk ./Grin/Simplify.hs 378
+            f (n@(Tag t) :-> b) = case [ a | a@(Tag t' :-> _) <-  as, t == t'] of
+                [bind :-> body] -> n :-> Return n :>>= bind :-> body :>>= unit :-> b