[don't lambda lift local functions that are only called strictly and never appear in a closure
John Meacham <john@repetae.net>**20060814123547] hunk ./E/LambdaLift.hs 17
+import Fixer.Fixer
+import Fixer.Supply
hunk ./E/LambdaLift.hs 20
-import Info.Types
hunk ./E/LambdaLift.hs 46
+calculateLiftees :: Program -> IO IdSet
+calculateLiftees prog = do
+    fixer <- newFixer
+    sup <- newSupply fixer
+
+    let f v env ELetRec { eDefs = ds, eBody = e } = do
+            let nenv = fromList [ (tvrIdent t,length (snd (fromLam e))) | (t,e) <- ds ]  `mappend` env
+                nenv :: IdMap Int
+                g (t,e@ELam {}) = do
+                    v <- supplyValue sup (tvrIdent t)
+                    let (a,_as) = fromLam e
+                    f v nenv a
+                g (t,e) = do
+                    f (value True) nenv e
+            mapM_ g ds
+            f v nenv e
+        f v env e@ESort {} = return ()
+        f v env e@Unknown {} = return ()
+        f v env e@EError {} = return ()
+        f v env (EVar TVr { tvrIdent = vv }) = do
+            nv <- supplyValue sup vv
+            assert nv
+        f v env e | (EVar TVr { tvrIdent = vv }, as@(_:_)) <- fromAp e, Just n <- mlookup vv env = do
+            nv <- supplyValue sup vv
+            if length as >= n then v `implies` nv else assert nv
+            mapM_ (f (value True) env) as
+        f v env e | (a, as@(_:_)) <- fromAp e = do
+            mapM_ (f (value True) env) as
+            f v env a
+        f v env (ELit (LitCons _ as _)) = mapM_ (f (value True) env) as
+        f v env ELit {} = return ()
+        f v env (EPi TVr { tvrType = a } b) = f (value True) env a >> f (value True) env b
+        f v env (EPrim _ as _) = mapM_ (f (value True) env) as
+        f v env ec@ECase {} = do
+            f v env (eCaseScrutinee ec)
+            mapM_ (f v env) (caseBodies ec)
+        f v env (ELam _ e) = f (value True) env e
+        f _ _ EAp {} = error "this should not happen"
+    mapM_ (f (value False) mempty) [ fst (fromLam e) | (_,e) <- programDs prog]
+
+    calcFixpoint "Liftees" fixer
+    vs <- supplyReadValues sup
+    mapM_ Prelude.print [ (tvr { tvrIdent = id },"Not Lifted") | (id,False) <- vs ]
+    return (fromList [ x | (x,False) <- vs])
+
+implies :: Value Bool -> Value Bool -> IO ()
+implies x y = addRule $ y `isSuperSetOf` x
+
+assert x = value True `implies` x
+
+
hunk ./E/LambdaLift.hs 99
+    noLift <- calculateLiftees prog
hunk ./E/LambdaLift.hs 107
+        shouldLift t _ | tvrIdent t `member` noLift = False
+        shouldLift _ ECase {} = True
+        shouldLift _ ELam {} = True
+        shouldLift _ _ = False
hunk ./E/LambdaLift.hs 119
-            if (isELam e || (shouldLift tvr e && not st)) then do
+            if ((tvrIdent tvr `notMember` noLift && isELam e) || (shouldLift tvr e && not st)) then do
hunk ./E/LambdaLift.hs 139
+        g (ELam t e) = do
+            e' <- local (isStrict_s True) (g e)
+            return (ELam t e')
hunk ./E/LambdaLift.hs 161
+        h (Left (t,e@ELam {}):ds) rest ds' = do
+            let (a,as) = fromLam e
+            a' <- local (isStrict_s True) (f a)
+            h ds rest ((t,foldr ELam a' as):ds')
hunk ./E/LambdaLift.hs 184
-                rs' <- flip mapM rs $ \ (t,e) -> do
-                    e'' <- f e
-                    return (t,e'')
+                rs' <- flip mapM rs $ \te -> case te of
+                    (t,e@ELam {}) -> do
+                        let (a,as) = fromLam e
+                        a' <- local (isStrict_s True) (f a)
+                        return (t,foldr ELam a' as)
+                    (t,e) -> do
+                        e'' <- f e
+                        return (t,e'')
hunk ./E/LambdaLift.hs 253
-shouldLift _ ECase {} = True
-shouldLift t ELam {} | getProperty prop_JOINPOINT t = False
-shouldLift _ ELam {} = True
---shouldLift t ELetRec {eBody = e } = shouldLift t e
-shouldLift _ _ = False