[brand new lambda lifter that preserves tail calls properly and is smarter about recursive groups
John Meacham <john@repetae.net>**20051004044015] hunk ./E/E.hs 259
-    f (TVr { tvrIdent = i },_) (TVr { tvrIdent = j } ,_) = compare i j
+    f (TVr { tvrIdent = i },_) (TVr { tvrIdent = j } ,_) = compare (maybe (show i) show $ fromId i) (maybe (show j) show $ fromId j)
hunk ./E/LambdaLift.hs 61
-etaReduce (ELam t (EAp x (EVar t'))) | t == t' && not (tvrNum t `Set.member` freeVars x) = case etaReduce x of
-    (x',i) -> (x',i + 1)
-etaReduce e = (e,0)
+etaReduce e = case f e 0 of
+        (ELam {},_) -> (e,0)
+        x -> x
+    where
+        f (ELam t (EAp x (EVar t'))) n | n `seq` True, t == t' && not (tvrNum t `Set.member` freeVars x) = f x (n + 1)
+        f e n = (e,n)
hunk ./E/LambdaLift.hs 80
-                h (concatMap G.fromScc ds') e' []
+                h ds' e' []
hunk ./E/LambdaLift.hs 117
-        h ((t,e):ds) rest ds' | shouldLift e = do
+        h (Left (t,e):ds) rest ds' | shouldLift e = do
hunk ./E/LambdaLift.hs 123
-        h ((t,e):ds) rest ds'  = do
+        h (Left (t,e):ds) rest ds'  = do
hunk ./E/LambdaLift.hs 130
-        h ((t,e):ds) e' ds' = local (isStrict_s False) (f e) >>= \e'' -> h ds e' ((t,e''):ds')
+        --h (Left (t,e):ds) e' ds' = local (isStrict_s False) (f e) >>= \e'' -> h ds e' ((t,e''):ds')
+        h (Right rs:ds) rest ds' | any shouldLift (snds rs)  = do
+            gs <- asks topVars
+            let fvs =  freeVars (snds rs)--   (Set.fromList (map tvrIdent $ fsts rs) `Set.union` gs)
+            let fvs' = filter (not . (`Set.member` (Set.fromList (map tvrIdent $ fsts rs) `Set.union` gs) ) . tvrIdent) fvs
+                fvs'' = reverse $ topSort $ newGraph fvs' tvrNum freeVars
+            case fvs'' of
+                [] -> doLiftR rs (h ds rest ds')  -- We always lift CAFS to the top level for now. (GC?)
+                fs -> doBigLiftR rs fs (\rs' -> h ds rest (rs' ++ ds'))
+        h (Right rs:ds) e' ds'   = do
+            local (isStrict_s False) $ do
+                rs' <- flip mapM rs $ \ (t,e) -> do
+                    e'' <- f e
+                    return (t,e'')
+                h ds e' (rs' ++ ds')
hunk ./E/LambdaLift.hs 146
-        shouldLift EError {} = True
-        shouldLift ECase {} = True
-        shouldLift ELam {} = True
-        shouldLift _ = False
hunk ./E/LambdaLift.hs 147
-            (e,tn) <- return $ etaReduce e
+            --(e,tn) <- return $ etaReduce e
hunk ./E/LambdaLift.hs 149
-            mtick (toAtom $ "E.LambdaLift.doLift." ++ show (length ls))
-            mticks tn (toAtom $ "E.LambdaLift.doLift.etaReduce")
+            mtick (toAtom $ "E.LambdaLift.doLift." ++ typeLift e ++ "." ++ show (length ls))
+            --mticks tn (toAtom $ "E.LambdaLift.doLift.etaReduce")
hunk ./E/LambdaLift.hs 154
+        doLiftR rs r = local (topVars_u (Set.union (Set.fromList (map (tvrNum . fst) rs)) )) $ do
+            flip mapM_ rs $ \ (t,e) -> do
+                --(e,tn) <- return $ etaReduce e
+                let (e',ls) = fromLam e
+                mtick (toAtom $ "E.LambdaLift.doLiftR." ++ typeLift e ++ "." ++ show (length ls))
+                --mticks tn (toAtom $ "E.LambdaLift.doLift.etaReduce")
+                e'' <- local (isStrict_s True) $ f e'
+                tell [(t,ls,e'')]
+            r
hunk ./E/LambdaLift.hs 166
-            return $ tVr (atomIndex (n `mappend` toAtom '$' `mappend` toAtom (show  un))) tt
+            return $ tVr (atomIndex (n `mappend` toAtom ("$" ++ show un))) tt
hunk ./E/LambdaLift.hs 168
-            mtick (toAtom $ "E.LambdaLift.doBigLift." ++ show (length fs))
+            mtick (toAtom $ "E.LambdaLift.doBigLift." ++ typeLift e ++ "." ++ show (length fs))
hunk ./E/LambdaLift.hs 177
+        doBigLiftR rs fs dr = do
+            ds <- asks declEnv
+            rst <- flip mapM rs $ \ (t,e) -> do
+                case shouldLift e of
+                    True -> do
+                        mtick (toAtom $ "E.LambdaLift.doBigLiftR." ++ typeLift e ++ "." ++ show (length fs))
+                        let tt = typeInfer' dataTable ds (foldr ELam e fs)
+                        tvr <- newName tt
+                        let (e',ls) = fromLam e
+                        e'' <- local (isStrict_s True) $ f e'
+                        --tell [(tvr,fs ++ ls,e'')]
+                        let e''' = foldl EAp (EVar tvr) (map EVar fs)
+                        return ((t,e'''),[(tvr,fs ++ ls,e'')])
+                    False -> do
+                        mtick (toAtom $ "E.LambdaLift.skipBigLiftR." ++ show (length fs))
+                        return ((t,e),[])
+            let (rs',ts) = unzip rst
+            tell [ (t,ls,eLetRec rs' e) | (t,ls,e) <- concat ts]
+            dr rs'
hunk ./E/LambdaLift.hs 204
+shouldLift EError {} = True
+shouldLift ECase {} = True
+shouldLift ELam {} = True
+shouldLift _ = False
+
+typeLift EError {} = "Error"
+typeLift ECase {} = "Case"
+typeLift ELam {} = "Lambda"
+typeLift _ = "Other"
hunk ./E/Subst.hs 200
+{-
hunk ./E/Subst.hs 202
+-- Monadic code is so much nicer
+typeSubst :: Map.Map Int (Maybe E) -> E -> E
+typeSubst bm e  = f e (False,bm) where
+    f :: E -> Map.Map Int (Maybe E) -> E
+    f eo@(EVar tvr@(TVr { tvrIdent = i, tvrType =  t })) = do
+        (v,mp) <- ask
+        case (v,Map.lookup i mp) of
+          (True,Just (Just v)) -> return v
+          _ -> return eo
+    f (ELam tvr e) = lp ELam tvr e
+    f (EPi tvr e) = lp EPi tvr e
+    f (EAp a b) = liftM2 EAp (f a) (f b)
+    f (EError x e) = liftM (EError x) (f e)
+    f (EPrim x es e) = liftM2 (EPrim x) (mapM f es) (f e)
+    f (ELetRec dl e) = do
+        (as,rs) <- liftM unzip $ mapMntvr (fsts dl)
+        local (mconcat rs) $ do
+            ds <- mapM f (snds dl)
+            e' <- f e
+            return $ ELetRec (zip as ds) e'
+    f (ELit l) = liftM ELit $ litSMapM f l
+    f Unknown = return Unknown
+    f e@(ESort {}) = return e
+    f ec@(ECase {}) = do
+        e' <- f $ eCaseScrutinee ec
+        (b',r) <- ntvr [] $ eCaseBind ec
+        d <- local r $ fmapM f $ eCaseDefault ec
+        let da (Alt (LitCons s vs t) e) = do
+                t' <- f t
+                (as,rs) <- liftM unzip $ mapMntvr vs
+                e' <- local (mconcat rs) $ f e
+                return $ Alt (LitCons s as t') e'
+            da (Alt l e) = do
+                l' <- fmapM f l
+                e' <- f e
+                return $ Alt l' e'
+        alts <- (mapM da $ eCaseAlts ec)
+        return  ECase { eCaseScrutinee = e', eCaseDefault = d, eCaseBind = b', eCaseAlts = alts }
+        lp lam tvr@(TVr { tvrIdent = n, tvrType = t}) e | n == 0 = do
+        t' <- f t
+        e' <- local (Map.insert n Nothing) $ f e
+        return $ lam (tvr { tvrIdent =  0, tvrType =  t'}) e'
+    lp lam tvr e = do
+        (tv,r) <- ntvr [] tvr
+        e' <- local r $ f e
+        return $ lam tv e'
+    mapMntvr ts = f ts [] where
+        f [] xs = return $ reverse xs
+        f (t:ts) rs = do
+            (t',r) <- ntvr vs t
+            local r $ f ts ((t',r):rs)
+        vs = [ tvrNum x | x <- ts ]
+
+    --mapMntvr [] = return []
+    --mapMntvr (t:ts) = do
+    --    (t',r) <- ntvr t
+    --    ts' <- local r (mapMntvr ts)
+    --    return ((t',r):ts')
+    --ntvr :: TVr -> Map Int (Maybe E) -> (TVr, Map Int (Maybe E) -> Map Int (Maybe E))
+    ntvr xs tvr@(TVr { tvrIdent = 0, tvrType =  t}) = do
+        t' <- f t
+        let nvr = (tvr { tvrType =  t'})
+        return (nvr,id)
+    ntvr xs tvr@(TVr {tvrIdent = i, tvrType =  t}) = do
+        t' <- f t
+        i' <- mnv allShadow xs i
+        let nvr = (tvr { tvrIdent =  i', tvrType =  t'})
+        case i == i' of
+            True -> return (nvr,Map.insert i (Just $ EVar nvr))
+            False -> return (nvr,Map.insert i (Just $ EVar nvr) . Map.insert i' Nothing)
+-}
hunk ./E/TypeCheck.hs 174
-        withContextDoc (hsep [text "fceq:", parens $ prettyE e1, parens $ prettyE t2]) $ do
+        withContextDoc (hsep [text "fceq:", align $ vcat [parens $ prettyE e1,  parens $ prettyE t2]]) $ do
hunk ./Main.hs 284
-    mapM_ putErrLn $  sort [ tshow x <+> "->" <+> tshow y | (x@(E.Strictness.V i),y@Lam {}) <- vs, odd i]
+    -- mapM_ putErrLn $  sort [ tshow x <+> "->" <+> tshow y | (x@(E.Strictness.V i),y@Lam {}) <- vs, odd i]
hunk ./Main.hs 292
-    let ELetRec ds _ = lc in mapM_ (\t -> putStrLn (prettyE (EVar t) <+> show (tvrInfo t))) (fsts ds)
+    -- let ELetRec ds _ = lc in mapM_ (\t -> putStrLn (prettyE (EVar t) <+> show (tvrInfo t))) (fsts ds)
hunk ./Main.hs 295
-    lc <- mangle dataTable (return ()) True "LambdaLift" (lambdaLiftE stats dataTable) lc
-    lc <- mangle dataTable (return ()) True  "FixupLets..." (\x -> atomizeApps mempty stats x >>= coalesceLets stats)  lc
+    finalStats <- Stats.new
+    lc <- mangle dataTable (return ()) True "LambdaLift" (lambdaLiftE finalStats dataTable) lc
+    let SC v rs = eToSC dataTable lc
+
+    rs' <- flip mapM rs $ \ (t,ls,e) -> do
+        let cm stats e = do
+            let sopt = mempty {  SS.so_dataTable = dataTable }
+            let (e',stat,occ) = SS.simplify sopt e
+            Stats.tickStat stats stat
+            return e'
+        e' <- doopt (mangle dataTable) False finalStats "SuperSimplify" cm e
+        return (t,ls,e')
+    wdump FD.Progress $ Stats.print "PostLifting" finalStats
+
+    lc <- return $ scToE (SC v rs')
+
+    --lc <- mangle dataTable (return ()) True  "FixupLets..." (\x -> atomizeApps mempty stats x >>= coalesceLets stats)  lc
hunk ./Main.hs 471
-        putErrLn $ "\n>>> internal error:\n" ++ unlines (tail ss)
+        putErrLn $ "\n>>> internal error:\n" ++ unlines (intersperse "----" $ tail ss)