[project @ 1996-07-25 20:43:49 by partain]

[ghc-hetmet.git] / ghc / compiler / simplCore / FloatIn.lhs

diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs
index 27b6c08..29ce8a9 100644 (file)
--- a/ghc/compiler/simplCore/FloatIn.lhs
+++ b/ghc/compiler/simplCore/FloatIn.lhs
@@ -14,22 +14,18 @@ then discover that they aren't needed in the chosen branch.
 \begin{code}
 #include "HsVersions.h"
 
-module FloatIn (
-       floatInwards
+module FloatIn ( floatInwards ) where
 
-       -- and to make the interface self-sufficient...
-    ) where
-
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
 
 import AnnCoreSyn
 import CoreSyn
 
 import FreeVars
 import Id              ( emptyIdSet, unionIdSets, unionManyIdSets,
-                         elementOfIdSet, IdSet(..)
+                         elementOfIdSet, SYN_IE(IdSet), GenId
                        )
-import Util            ( panic )
+import Util            ( nOfThem, panic, zipEqual )
 \end{code}
 
 Top-level interface function, @floatInwards@.  Note that we do not
@@ -172,12 +168,11 @@ fiExpr to_drop (_,AnnLam b@(TyBinder tyvar) body)
   where
     whnf :: CoreExprWithFVs -> Bool
 
-    whnf (_,AnnLit _)              = True
-    whnf (_,AnnCon _ _)                    = True
-    whnf (_,AnnLam (ValBinder _) _) = True
-    whnf (_,AnnLam _             e) = whnf e
-    whnf (_,AnnSCC _ e)                    = whnf e
-    whnf _                         = False
+    whnf (_,AnnLit _)  = True
+    whnf (_,AnnCon _ _)        = True
+    whnf (_,AnnLam x e) = if isValBinder x then True else whnf e
+    whnf (_,AnnSCC _ e)        = whnf e
+    whnf _             = False
 \end{code}
 
 Applications: we could float inside applications, but it's probably
@@ -201,6 +196,12 @@ fiExpr to_drop (_, AnnSCC cc expr)
   = mkCoLets' to_drop (SCC cc (fiExpr [] expr))
 \end{code}
 
+\begin{code}
+fiExpr to_drop (_, AnnCoerce c ty expr)
+  = --trace "fiExpr:Coerce:wimping out" $
+    mkCoLets' to_drop (Coerce c ty (fiExpr [] expr))
+\end{code}
+
 For @Lets@, the possible ``drop points'' for the \tr{to_drop}
 bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
 or~(b2), in each of the RHSs of the pairs of a @Rec@.
@@ -267,7 +268,7 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
            -> [(Id, CoreExpr)]
 
     fi_bind to_drops pairs
-      = [ (binder, fiExpr to_drop rhs) | ((binder, rhs), to_drop) <- zip pairs to_drops ]
+      = [ (binder, fiExpr to_drop rhs) | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
 \end{code}
 
 For @Case@, the possible ``drop points'' for the \tr{to_drop}
@@ -302,13 +303,13 @@ fiExpr to_drop (_, AnnCase scrut alts)
     fi_alts to_drop_deflt to_drop_alts (AnnAlgAlts alts deflt)
       = AlgAlts
            [ (con, params, fiExpr to_drop rhs)
-           | ((con, params, rhs), to_drop) <- alts `zip` to_drop_alts ]
+           | ((con, params, rhs), to_drop) <- zipEqual "fi_alts" alts to_drop_alts ]
            (fi_default to_drop_deflt deflt)
 
     fi_alts to_drop_deflt to_drop_alts (AnnPrimAlts alts deflt)
       = PrimAlts
            [ (lit, fiExpr to_drop rhs)
-           | ((lit, rhs), to_drop) <- alts `zip` to_drop_alts ]
+           | ((lit, rhs), to_drop) <- zipEqual "fi_alts2" alts to_drop_alts ]
            (fi_default to_drop_deflt deflt)
 
     fi_default to_drop AnnNoDefault          = NoDefault
@@ -353,8 +354,7 @@ sepBindsByDropPoint drop_pts floaters
        (per_drop_pt, must_stay_here, _)
            --= sep drop_pts emptyIdSet{-fvs of prev drop_pts-} floaters
            = split' drop_pts floaters [] empty_boxes
-       empty_boxes = take (length drop_pts) (repeat [])
-
+       empty_boxes = nOfThem (length drop_pts) []
     in
     (map reverse per_drop_pt, reverse must_stay_here)
   where
@@ -386,9 +386,9 @@ sepBindsByDropPoint drop_pts floaters
     -------------------------
     fvsOfBind (_,fvs)  = fvs
 
---floatedBindsFVs ::
+floatedBindsFVs :: FloatingBinds -> FreeVarsSet
 floatedBindsFVs binds = unionManyIdSets (map snd binds)
 
---mkCoLets' :: [FloatingBinds] -> CoreExpr -> CoreExpr
+mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr
 mkCoLets' to_drop e = mkCoLetsNoUnboxed (reverse (map fst to_drop)) e
 \end{code}