X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=d8f9506b23c0c42fb20ca431ad52ea333fce8f85;hb=7d44782fdfab8c280ae8de1846cb40a78b6edb95;hp=dd2a22b63e96914c9986d05e7157de0df983e0f4;hpb=b812bfb914a0164f5ce3b206cb9769dc70253374;p=ghc-hetmet.git

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index dd2a22b..d8f9506 100644
--- 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,
@@ -869,9 +869,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 +916,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 +974,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 +1049,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 +1080,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 +1102,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 +1252,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 +1802,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