[project @ 1998-02-10 14:15:51 by simonpj]

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

diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs
index 4c17f20..8d21ed0 100644 (file)
--- a/ghc/compiler/simplCore/LiberateCase.lhs
+++ b/ghc/compiler/simplCore/LiberateCase.lhs
@@ -1,19 +1,24 @@
 %
-% (c) The AQUA Project, Glasgow University, 1994
+% (c) The AQUA Project, Glasgow University, 1994-1996
 %
 \section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}
 
+96/03: We aren't using this at the moment
 
 \begin{code}
+module LiberateCase ( liberateCase ) where
+
 #include "HsVersions.h"
 
-module LiberateCase ( liberateCase ) where
+import Util            ( panic )
+
+liberateCase = panic "LiberateCase.liberateCase: ToDo"
 
-import CoreUnfold      ( UnfoldingGuidance(..) )
-import Id              ( localiseId, toplevelishId{-debugging-} )
+{- LATER: to end of file:
+import CoreUnfold      ( UnfoldingGuidance(..), PragmaInfo(..) )
+import Id              ( localiseId )
 import Maybes
 import Outputable
-import Pretty
 import Util
 \end{code}
 
@@ -162,7 +167,7 @@ libCaseBind env (Rec pairs)
 
        -- Why "localiseId" above?  Because we're creating a new local
        -- copy of the original binding.  In particular, the original
-       -- binding might have been for a TopLevId, and this copy clearly
+       -- binding might have been for a top-level, and this copy clearly
        -- will not be top-level!
 
        -- It is enough to change just the binder, because subsequent
@@ -173,7 +178,7 @@ libCaseBind env (Rec pairs)
        -- to think that something is top-level when it isn't.
 
     rhs_small_enough rhs
-      = case (calcUnfoldingGuidance True{-sccs OK-} lIBERATE_BOMB_SIZE rhs) of
+      = case (calcUnfoldingGuidance NoPragmaInfo lIBERATE_BOMB_SIZE rhs) of
          UnfoldNever -> False
          _           -> True   -- we didn't BOMB, so it must be OK
 
@@ -189,14 +194,15 @@ libCase :: LibCaseEnv
        -> CoreExpr
        -> CoreExpr
 
-libCase env (Lit lit)           = Lit lit
-libCase env (Var v)             = mkCoLetsNoUnboxed (libCaseId env v) (Var v)
-libCase env (App fun arg)      = mkCoLetsNoUnboxed (libCaseAtom env arg) (App (libCase env fun) arg)
-libCase env (CoTyApp fun ty)     = CoTyApp (libCase env fun) ty
-libCase env (Con con tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Con con tys args)
-libCase env (Prim op tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Prim op tys args)
-libCase env (CoTyLam tyvar body) = CoTyLam tyvar (libCase env body)
-libCase env (SCC cc body)      = SCC cc (libCase env body)
+libCase env (Lit lit)          = Lit lit
+libCase env (Var v)            = mkCoLetsNoUnboxed (libCaseId env v) (Var v)
+libCase env (App fun arg)       = mkCoLetsNoUnboxed (libCaseAtom env arg) (App (libCase env fun) arg)
+libCase env (CoTyApp fun ty)    = CoTyApp (libCase env fun) ty
+libCase env (Con con tys args)  = mkCoLetsNoUnboxed (libCaseAtoms env args) (Con con tys args)
+libCase env (Prim op tys args)  = mkCoLetsNoUnboxed (libCaseAtoms env args) (Prim op tys args)
+libCase env (CoTyLam tv body)   = CoTyLam tv (libCase env body)
+libCase env (SCC cc body)       = SCC cc (libCase env body)
+libCase env (Coerce c ty body) = Coerce c ty (libCase env body)
 
 libCase env (Lam binder body)
   = Lam binder (libCase (addBinders env [binder]) body)
@@ -298,8 +304,7 @@ addScrutedVar env@(LibCaseEnv bomb lvl lvl_env rec_env scruts) scrut_var
     scruts'  = (scrut_var, lvl) : scruts
     bind_lvl = case lookupIdEnv lvl_env scrut_var of
                 Just lvl -> lvl
-                Nothing  -> --false: ASSERT(toplevelishId scrut_var)
-                            topLevel
+                Nothing  -> topLevel
 
 lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBinding
 lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
@@ -308,16 +313,14 @@ lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
 #else
   = case (lookupIdEnv rec_env id) of
       xxx@(Just _) -> xxx
-      xxx         -> --false: ASSERT(toplevelishId id)
-                     xxx
+      xxx         -> xxx
 #endif
 
 lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
 lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
   = case lookupIdEnv lvl_env id of
       Just lvl -> lvl
-      Nothing  -> ASSERT(toplevelishId id)
-                 topLevel
+      Nothing  -> topLevel
 
 freeScruts :: LibCaseEnv
           -> LibCaseLevel      -- Level of the recursive Id
@@ -327,4 +330,5 @@ freeScruts (LibCaseEnv bomb lvl lvl_env rec_env scruts) rec_bind_lvl
   = not (null free_scruts)
   where
     free_scruts = [v | (v,lvl) <- scruts, lvl > rec_bind_lvl]
+-}
 \end{code}