[project @ 2002-04-22 16:06:35 by simonpj]

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

diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 293f1be..5cae204 100644 (file)
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -26,6 +26,7 @@ import Id             ( Id, idType, idInfo, idArity, isDataConId,
                          idNewDemandInfo, setIdInfo,
                          setIdOccInfo, zapLamIdInfo, setOneShotLambda, 
                        )
+import OccName         ( encodeFS )
 import IdInfo          ( OccInfo(..), isLoopBreaker,
                          setArityInfo, 
                          setUnfoldingInfo, 
@@ -40,7 +41,7 @@ import CoreUtils      ( exprIsDupable, exprIsTrivial, needsCaseBinding,
                          exprIsConApp_maybe, mkPiTypes, findAlt, 
                          exprType, exprIsValue, 
                          exprOkForSpeculation, exprArity, 
-                         mkCoerce, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg
+                         mkCoerce, mkCoerce2, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg
                        )
 import Rules           ( lookupRule )
 import BasicTypes      ( isMarkedStrict )
@@ -59,6 +60,7 @@ import BasicTypes     ( TopLevelFlag(..), isTopLevel,
 import OrdList
 import Maybe           ( Maybe )
 import Outputable
+import Util             ( notNull )
 \end{code}
 
 
@@ -246,8 +248,15 @@ simplTopBinds env binds
     drop_bs (NonRec _ _) (_ : bs) = bs
     drop_bs (Rec prs)    bs      = drop (length prs) bs
 
-    simpl_bind env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r
-    simpl_bind env (Rec pairs)  bs'    = simplRecBind      env TopLevel pairs bs'
+    simpl_bind env bind bs 
+      = getDOptsSmpl                           `thenSmpl` \ dflags ->
+        if dopt Opt_D_dump_inlinings dflags then
+          pprTrace "SimplBind" (ppr (bindersOf bind)) $ simpl_bind1 env bind bs
+       else
+          simpl_bind1 env bind bs
+
+    simpl_bind1 env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r
+    simpl_bind1 env (Rec pairs)  bs'    = simplRecBind      env TopLevel pairs bs'
 \end{code}
 
 
@@ -800,7 +809,7 @@ simplNote env (Coerce to from) body cont
                -- But it isn't a common case.
          = let 
                (t1,t2) = splitFunTy t1t2
-               new_arg = mkCoerce s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg)
+               new_arg = mkCoerce2 s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg)
            in
            ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont)
                        
@@ -921,8 +930,8 @@ completeCall env var occ_info cont
     let
        arg_infos = [ interestingArg arg | arg <- args, isValArg arg]
 
-       interesting_cont = interestingCallContext (not (null args)) 
-                                                 (not (null arg_infos))
+       interesting_cont = interestingCallContext (notNull args)
+                                                 (notNull arg_infos)
                                                  call_cont
 
        active_inline = activeInline env var occ_info
@@ -1139,7 +1148,7 @@ mkAtomicArgs is_strict ok_float_unlifted rhs
        | otherwise     -- Don't forget to do it recursively
                        -- E.g.  x = a:b:c:[]
        =  mkAtomicArgs is_strict ok_float_unlifted arg `thenSmpl` \ (arg_binds, arg') ->
-          newId SLIT("a") arg_ty                       `thenSmpl` \ arg_id ->
+          newId FSLIT("a") arg_ty                      `thenSmpl` \ arg_id ->
           go fun ((arg_binds `snocOL` (arg_id,arg')) `appOL` binds) 
              (Var arg_id : rev_args) args
        where
@@ -1187,7 +1196,7 @@ rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
 
 rebuild env expr (Stop _ _ _)                = rebuildDone env expr
 rebuild env expr (ArgOf _ _ _ cont_fn)       = cont_fn env expr
-rebuild env expr (CoerceIt to_ty cont)       = rebuild env (mkCoerce to_ty (exprType expr) expr) cont
+rebuild env expr (CoerceIt to_ty cont)       = rebuild env (mkCoerce to_ty expr) cont
 rebuild env expr (InlinePlease cont)         = rebuild env (Note InlineCall expr) cont
 rebuild env expr (Select _ bndr alts se cont) = rebuildCase (setInScope se env) expr bndr alts cont
 rebuild env expr (ApplyTo _ arg se cont)      = rebuildApp  (setInScope se env) expr arg cont
@@ -1552,7 +1561,7 @@ mkDupableCont env (ApplyTo _ arg se cont)
     if exprIsDupable arg' then
        returnSmpl (emptyFloats env, (ApplyTo OkToDup arg' (zapSubstEnv se) dup_cont, nondup_cont))
     else
-    newId SLIT("a") (exprType arg')                    `thenSmpl` \ arg_id ->
+    newId FSLIT("a") (exprType arg')                   `thenSmpl` \ arg_id ->
 
     tick (CaseOfCase arg_id)                           `thenSmpl_`
        -- Want to tick here so that we go round again,
@@ -1671,14 +1680,14 @@ mkDupableAlt env case_bndr' cont alt@(con, bndrs, rhs)
        -- (the \v alone is enough to make CPR happy) but I think it's rare
 
     ( if null used_bndrs' 
-       then newId SLIT("w") realWorldStatePrimTy       `thenSmpl` \ rw_id ->
+       then newId FSLIT("w") realWorldStatePrimTy      `thenSmpl` \ rw_id ->
             returnSmpl ([rw_id], [Var realWorldPrimId])
        else 
             returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
     )                                                  `thenSmpl` \ (final_bndrs', final_args) ->
 
        -- See comment about "$j" name above
-    newId SLIT("$j") (mkPiTypes final_bndrs' rhs_ty')  `thenSmpl` \ join_bndr ->
+    newId (encodeFS SLIT("$j")) (mkPiTypes final_bndrs' rhs_ty')       `thenSmpl` \ join_bndr ->
        -- Notice the funky mkPiTypes.  If the contructor has existentials
        -- it's possible that the join point will be abstracted over
        -- type varaibles as well as term variables.