[when floating inward, seperate dupable binds from undupable ones. perform floating inward pass right after floating outward to get rid of spurious bindings, make sure all names floated to the top level are unique.
John Meacham <john@repetae.net>**20060322234301] hunk ./E/LetFloat.hs 160
-    f e xs |  (b,ls@(_:_)) <- fromLam e = letRec xs (foldr ELam (f b []) ls)
+    f e@ELam {} xs = letRec unsafe_to_dup (foldr ELam (f b safe_to_dup) ls) where
+        (unsafe_to_dup,safe_to_dup) = sepDupableBinds (freeVars ls) xs
+        (b,ls) = fromLam e
hunk ./E/LetFloat.hs 174
---type Binds = [(FVarSet,Either (TVr,E) [(TVr,E)])]
hunk ./E/LetFloat.hs 175
+sepDupableBinds :: [Id] -> Binds -> (Binds,Binds)
+sepDupableBinds fvs xs = partition ind xs where
+    g = G.reachable (G.newGraph (concatMap G.fromScc xs) (tvrNum . fst . fst) (Set.toList . snd)) (fvs `mappend` unsafe_ones)
+    uso = map (tvrNum . fst . fst) g
+    --unsafe_ones = map (tvrIdent . fst . fst) $ concatMap G.fromScc $ filter (not . std) xs
+    --std (Left ((_,e),_)) = isCheap e
+    --std (Right zs) = all isCheap (snds $ fsts zs)
+    unsafe_ones = concat [ map (tvrIdent . fst . fst) vs | vs <- map G.fromScc xs,any (not . isCheap) (map (snd . fst) vs)]
+    ind x = any ( (`elem` uso) . tvrNum . fst . fst ) (G.fromScc x)
hunk ./E/LetFloat.hs 290
-                mtick $ "LetFloat.Full-Lazy.float.{" ++ tvrShowName t
-                let nv = t { tvrIdent = toId nn }
-                    nn = lfName (progModule prog) Val (tvrIdent t)
+                mtick $ "LetFloat.Full-Lazy.float.{" ++ maybeShowName t
hunk ./E/LetFloat.hs 292
-                return [] -- (t,(EVar nv))
+                return []
hunk ./E/LetFloat.hs 302
-            (e',fs) <- runWriterT (dofloat e)
-            let (e'',fs') = case e' of
+            (e,fs) <- runWriterT (dofloat e)
+            let (e',fs') = case e of
hunk ./E/LetFloat.hs 305
-                    _ -> (e',snds fs)
-            flip mapM_ (fsts $ fs') $ \t -> do
-                mtick $ "LetFloat.Full-Lazy.top_level.{" ++ tvrShowName t
-            let (fs'',sm') = unzip [ ((n,sm e),(t,EVar n)) | (t,e) <- fs', let n = nn t ]
+                    _ -> (e,snds fs)
+                -- we imediatly float inward to clean up cruft and spurious outwards floatings
+                (e'',fs'') = cDefs $ floatInward mempty (ELetRec fs' e')
+                cDefs (ELetRec ds e) = (e',ds ++ ds') where
+                    (e',ds') = cDefs e
+                cDefs e = (e,[])
+            flip mapM_ (fsts $ fs'') $ \t -> do
+                mtick $ "LetFloat.Full-Lazy.top_level.{" ++ maybeShowName t
+            u <- newUniq
+            let (fs''',sm') = unzip [ ((n,sm e),(t,EVar n)) | (t,e) <- fs'', let n = nn t ]
hunk ./E/LetFloat.hs 316
-                nn tvr = tvr { tvrIdent = toId $ lfName (progModule prog) Val (tvrIdent tvr) }
-            return $ (t,sm e''):fs''
-    let (cds,stats) = runStatM (mapM dtl $ programDs prog)
+                nn tvr = tvr { tvrIdent = toId $ lfName u (progModule prog) Val (tvrIdent tvr) }
+            return $ (t,sm e''):fs'''
+    (cds,stats) <- runStatT (mapM dtl $ programDs prog)
hunk ./E/LetFloat.hs 323
-lfName modName ns x = case fromId x of
-    Just y  -> toName ns (show modName, "fl@"++show y)
-    Nothing -> toName ns (show modName, "fl@"++show x)
+maybeShowName t = if '@' `elem` n then "(epheremal)" else n where
+    n = tvrShowName t
+
+lfName u modName ns x = case fromId x of
+    Just y  -> toName ns (show modName, "fl@"++show y ++ "$" ++ show u)
+    Nothing -> toName ns (show modName, "fl@"++show x ++ "$" ++ show u)
hunk ./E/LetFloat.hs 346
+        ec' <- caseBodiesMapM g ec
hunk ./E/LetFloat.hs 350
-        ec' <- caseBodiesMapM (g . mv) ec
+            nd = fmap mv (eCaseDefault ec')
hunk ./E/LetFloat.hs 352
-        return ec' { eCaseScrutinee = scrut' }
+        return ec' { eCaseScrutinee = scrut', eCaseDefault = nd }