Do not call preInlineUnconditionally in simplNonRecX

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

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index dd2a22b..4a71774 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -15,11 +15,11 @@ import SimplMonad
 import SimplEnv        
 import SimplUtils      ( mkCase, mkLam,
                          SimplCont(..), DupFlag(..), LetRhsFlag(..), 
-                         mkRhsStop, mkBoringStop,  pushContArgs,
+                         mkRhsStop, mkBoringStop,  mkLazyArgStop, pushContArgs,
                          contResultType, countArgs, contIsDupable, contIsRhsOrArg,
                          getContArgs, interestingCallContext, interestingArg, isStrictType,
                          preInlineUnconditionally, postInlineUnconditionally, 
-                         inlineMode, activeInline, activeRule
+                         interestingArgContext, inlineMode, activeInline, activeRule
                        )
 import Id              ( Id, idType, idInfo, idArity, isDataConWorkId, 
                          idUnfolding, setIdUnfolding, isDeadBinder,
@@ -364,6 +364,7 @@ simplNonRecX env bndr new_rhs thing_inside
     let body' = wrapFloats floats body in 
     returnSmpl (emptyFloats env, Case new_rhs bndr' (exprType body') [(DEFAULT, [], body')])
 
+{- No, no, no!  Do not try preInlineUnconditionally 
   | preInlineUnconditionally env NotTopLevel bndr new_rhs
        -- This happens; for example, the case_bndr during case of
        -- known constructor:  case (a,b) of x { (p,q) -> ... }
@@ -374,6 +375,7 @@ simplNonRecX env bndr new_rhs thing_inside
        -- e.g.  case (f x, g y) of (a,b) -> ....
        -- If a,b occur once we can avoid constructing the let binding for them.
   = thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
+-}
 
   | otherwise
   = simplBinder env bndr       `thenSmpl` \ (env, bndr') ->
@@ -869,9 +871,6 @@ simplNote env (SCC cc) e cont
   = simplExpr (setEnclosingCC env currentCCS) e        `thenSmpl` \ e' ->
     rebuild env (mkSCC cc e') cont
 
-simplNote env InlineCall e cont
-  = simplExprF env e (InlinePlease cont)
-
 -- See notes with SimplMonad.inlineMode
 simplNote env InlineMe e cont
   | contIsRhsOrArg cont                -- Totally boring continuation; see notes above
@@ -919,11 +918,12 @@ completeCall env var occ_info cont
   =     -- Simplify the arguments
     getDOptsSmpl                                       `thenSmpl` \ dflags ->
     let
-       chkr                           = getSwitchChecker env
-       (args, call_cont, inline_call) = getContArgs chkr var cont
-       fn_ty                          = idType var
+       chkr              = getSwitchChecker env
+       (args, call_cont) = getContArgs chkr var cont
+       fn_ty             = idType var
     in
-    simplifyArgs env fn_ty args (contResultType call_cont)     $ \ env args ->
+    simplifyArgs env fn_ty (interestingArgContext var call_cont) args 
+                (contResultType call_cont)     $ \ env args ->
 
        -- Next, look for rules or specialisations that match
        --
@@ -976,13 +976,11 @@ completeCall env var occ_info cont
        -- Next, look for an inlining
     let
        arg_infos = [ interestingArg arg | arg <- args, isValArg arg]
-
        interesting_cont = interestingCallContext (notNull args)
                                                  (notNull arg_infos)
                                                  call_cont
-
        active_inline = activeInline env var occ_info
-       maybe_inline  = callSiteInline dflags active_inline inline_call occ_info
+       maybe_inline  = callSiteInline dflags active_inline occ_info
                                       var arg_infos interesting_cont
     in
     case maybe_inline of {
@@ -1053,6 +1051,7 @@ makeThatCall env var fun args cont
 
 simplifyArgs :: SimplEnv 
             -> OutType                         -- Type of the function
+            -> Bool                            -- True if the fn has RULES
             -> [(InExpr, SimplEnv, Bool)]      -- Details of the arguments
             -> OutType                         -- Type of the continuation
             -> (SimplEnv -> [OutExpr] -> SimplM FloatsWithExpr)
@@ -1083,19 +1082,19 @@ simplifyArgs :: SimplEnv
 -- discard the entire application and replace it with (error "foo").  Getting
 -- all this at once is TOO HARD!
 
-simplifyArgs env fn_ty args cont_ty thing_inside
+simplifyArgs env fn_ty has_rules args cont_ty thing_inside
   = go env fn_ty args thing_inside
   where
     go env fn_ty []        thing_inside = thing_inside env []
-    go env fn_ty (arg:args) thing_inside = simplifyArg env fn_ty arg cont_ty           $ \ env arg' ->
+    go env fn_ty (arg:args) thing_inside = simplifyArg env fn_ty has_rules arg cont_ty $ \ env arg' ->
                                           go env (applyTypeToArg fn_ty arg') args      $ \ env args' ->
                                           thing_inside env (arg':args')
 
-simplifyArg env fn_ty (Type ty_arg, se, _) cont_ty thing_inside
+simplifyArg env fn_ty has_rules (Type ty_arg, se, _) cont_ty thing_inside
   = simplType (setInScope se env) ty_arg       `thenSmpl` \ new_ty_arg ->
     thing_inside env (Type new_ty_arg)
 
-simplifyArg env fn_ty (val_arg, arg_se, is_strict) cont_ty thing_inside 
+simplifyArg env fn_ty has_rules (val_arg, arg_se, is_strict) cont_ty thing_inside 
   | is_strict 
   = simplStrictArg AnArg env val_arg arg_se arg_ty cont_ty thing_inside
 
@@ -1105,8 +1104,8 @@ simplifyArg env fn_ty (val_arg, arg_se, is_strict) cont_ty thing_inside
                -- have to be very careful about bogus strictness through 
                -- floating a demanded let.
   = simplExprC (setInScope arg_se env) val_arg
-              (mkBoringStop arg_ty)            `thenSmpl` \ arg1 ->
-   thing_inside env arg1
+              (mkLazyArgStop arg_ty has_rules)         `thenSmpl` \ arg1 ->
+    thing_inside env arg1
   where
     arg_ty = funArgTy fn_ty
 
@@ -1255,7 +1254,6 @@ 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 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
 
@@ -1806,10 +1804,6 @@ mkDupableCont env (CoerceIt ty cont)
   = mkDupableCont env cont             `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
     returnSmpl (floats, (CoerceIt ty dup_cont, nondup_cont))
 
-mkDupableCont env (InlinePlease cont)
-  = mkDupableCont env cont             `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
-    returnSmpl (floats, (InlinePlease dup_cont, nondup_cont))
-
 mkDupableCont env cont@(ArgOf _ arg_ty _ _)
   =  returnSmpl (emptyFloats env, (mkBoringStop arg_ty, cont))
        -- Do *not* duplicate an ArgOf continuation