[project @ 2002-10-24 16:54:19 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 79ebf09..303fd65 100644 (file)
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -248,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}
 
 
@@ -788,12 +795,14 @@ simplNote env (Coerce to from) body cont
                                                -- the inner one is redundant
 
        addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont)
-         | Just (s1, s2) <- splitFunTy_maybe s1s2
+         | not (isTypeArg arg),        -- This whole case only works for value args
+                                       -- Could upgrade to have equiv thing for type apps too  
+           Just (s1, s2) <- splitFunTy_maybe s1s2
                --      (coerce (T1->T2) (S1->S2) F) E
                -- ===> 
                --      coerce T2 S2 (F (coerce S1 T1 E))
                --
-               -- t1t2 must be a function type, T1->T2
+               -- t1t2 must be a function type, T1->T2, because it's applied to something
                -- but s1s2 might conceivably not be
                --
                -- When we build the ApplyTo we can't mix the out-types
@@ -909,7 +918,7 @@ completeCall env var occ_info cont
                tick (RuleFired rule_name)                      `thenSmpl_`
                (if dopt Opt_D_dump_inlinings dflags then
                   pprTrace "Rule fired" (vcat [
-                       text "Rule:" <+> ptext rule_name,
+                       text "Rule:" <+> ftext rule_name,
                        text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
                        text "After: " <+> pprCoreExpr rule_rhs,
                        text "Cont:  " <+> ppr call_cont])
@@ -1233,7 +1242,7 @@ rebuildCase env scrut case_bndr alts cont
 
   | otherwise
   = prepareAlts scrut case_bndr alts           `thenSmpl` \ (better_alts, handled_cons) -> 
-
+       
        -- Deal with the case binder, and prepare the continuation;
        -- The new subst_env is in place
     prepareCaseCont env better_alts cont       `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
@@ -1680,7 +1689,7 @@ mkDupableAlt env case_bndr' cont alt@(con, bndrs, rhs)
     )                                                  `thenSmpl` \ (final_bndrs', final_args) ->
 
        -- See comment about "$j" name above
-    newId (encodeFS SLIT("$j")) (mkPiTypes final_bndrs' rhs_ty')       `thenSmpl` \ join_bndr ->
+    newId (encodeFS FSLIT("$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.