Rollback INLINE patches

rolling back:

Fri Dec  5 16:54:00 GMT 2008  simonpj@microsoft.com
  * Completely new treatment of INLINE pragmas (big patch)
  
  This is a major patch, which changes the way INLINE pragmas work.
  Although lots of files are touched, the net is only +21 lines of
  code -- and I bet that most of those are comments!
  
  HEADS UP: interface file format has changed, so you'll need to
  recompile everything.
  
  There is not much effect on overall performance for nofib, 
  probably because those programs don't make heavy use of INLINE pragmas.
  
          Program           Size    Allocs   Runtime   Elapsed
              Min         -11.3%     -6.9%     -9.2%     -8.2%
              Max          -0.1%     +4.6%     +7.5%     +8.9%
   Geometric Mean          -2.2%     -0.2%     -1.0%     -0.8%
  
  (The +4.6% for on allocs is cichelli; see other patch relating to
  -fpass-case-bndr-to-join-points.)
  
  The old INLINE system
  ~~~~~~~~~~~~~~~~~~~~~
  The old system worked like this. A function with an INLINE pragam
  got a right-hand side which looked like
       f = __inline_me__ (\xy. e)
  The __inline_me__ part was an InlineNote, and was treated specially
  in various ways.  Notably, the simplifier didn't inline inside an
  __inline_me__ note.  
  
  As a result, the code for f itself was pretty crappy. That matters
  if you say (map f xs), because then you execute the code for f,
  rather than inlining a copy at the call site.
  
  The new story: InlineRules
  ~~~~~~~~~~~~~~~~~~~~~~~~~~
  The new system removes the InlineMe Note altogether.  Instead there
  is a new constructor InlineRule in CoreSyn.Unfolding.  This is a 
  bit like a RULE, in that it remembers the template to be inlined inside
  the InlineRule.  No simplification or inlining is done on an InlineRule,
  just like RULEs.  
  
  An Id can have an InlineRule *or* a CoreUnfolding (since these are two
  constructors from Unfolding). The simplifier treats them differently:
  
    - An InlineRule is has the substitution applied (like RULES) but 
      is otherwise left undisturbed.
  
    - A CoreUnfolding is updated with the new RHS of the definition,
      on each iteration of the simplifier.
  
  An InlineRule fires regardless of size, but *only* when the function
  is applied to enough arguments.  The "arity" of the rule is specified
  (by the programmer) as the number of args on the LHS of the "=".  So
  it makes a difference whether you say
    	{-# INLINE f #-}
  	f x = \y -> e     or     f x y = e
  This is one of the big new features that InlineRule gives us, and it
  is one that Roman really wanted.
  
  In contrast, a CoreUnfolding can fire when it is applied to fewer
  args than than the function has lambdas, provided the result is small
  enough.
  
  
  Consequential stuff
  ~~~~~~~~~~~~~~~~~~~
  * A 'wrapper' no longer has a WrapperInfo in the IdInfo.  Instead,
    the InlineRule has a field identifying wrappers.
  
  * Of course, IfaceSyn and interface serialisation changes appropriately.
  
  * Making implication constraints inline nicely was a bit fiddly. In
    the end I added a var_inline field to HsBInd.VarBind, which is why
    this patch affects the type checker slightly
  
  * I made some changes to the way in which eta expansion happens in
    CorePrep, mainly to ensure that *arguments* that become let-bound
    are also eta-expanded.  I'm still not too happy with the clarity
    and robustness fo the result.
  
  * We now complain if the programmer gives an INLINE pragma for
    a recursive function (prevsiously we just ignored it).  Reason for
    change: we don't want an InlineRule on a LoopBreaker, because then
    we'd have to check for loop-breaker-hood at occurrence sites (which
    isn't currenlty done).  Some tests need changing as a result.
  
  This patch has been in my tree for quite a while, so there are
  probably some other minor changes.
  

    M ./compiler/basicTypes/Id.lhs -11
    M ./compiler/basicTypes/IdInfo.lhs -82
    M ./compiler/basicTypes/MkId.lhs -2 +2
    M ./compiler/coreSyn/CoreFVs.lhs -2 +25
    M ./compiler/coreSyn/CoreLint.lhs -5 +1
    M ./compiler/coreSyn/CorePrep.lhs -59 +53
    M ./compiler/coreSyn/CoreSubst.lhs -22 +31
    M ./compiler/coreSyn/CoreSyn.lhs -66 +92
    M ./compiler/coreSyn/CoreUnfold.lhs -112 +112
    M ./compiler/coreSyn/CoreUtils.lhs -185 +184
    M ./compiler/coreSyn/MkExternalCore.lhs -1
    M ./compiler/coreSyn/PprCore.lhs -4 +40
    M ./compiler/deSugar/DsBinds.lhs -70 +118
    M ./compiler/deSugar/DsForeign.lhs -2 +4
    M ./compiler/deSugar/DsMeta.hs -4 +3
    M ./compiler/hsSyn/HsBinds.lhs -3 +3
    M ./compiler/hsSyn/HsUtils.lhs -2 +7
    M ./compiler/iface/BinIface.hs -11 +25
    M ./compiler/iface/IfaceSyn.lhs -13 +21
    M ./compiler/iface/MkIface.lhs -24 +19
    M ./compiler/iface/TcIface.lhs -29 +23
    M ./compiler/main/TidyPgm.lhs -55 +49
    M ./compiler/parser/ParserCore.y -5 +6
    M ./compiler/simplCore/CSE.lhs -2 +1
    M ./compiler/simplCore/FloatIn.lhs -6 +1
    M ./compiler/simplCore/FloatOut.lhs -23
    M ./compiler/simplCore/OccurAnal.lhs -36 +5
    M ./compiler/simplCore/SetLevels.lhs -59 +54
    M ./compiler/simplCore/SimplCore.lhs -48 +52
    M ./compiler/simplCore/SimplEnv.lhs -26 +22
    M ./compiler/simplCore/SimplUtils.lhs -28 +4
    M ./compiler/simplCore/Simplify.lhs -91 +109
    M ./compiler/specialise/Specialise.lhs -15 +18
    M ./compiler/stranal/WorkWrap.lhs -14 +11
    M ./compiler/stranal/WwLib.lhs -2 +2
    M ./compiler/typecheck/Inst.lhs -1 +3
    M ./compiler/typecheck/TcBinds.lhs -17 +27
    M ./compiler/typecheck/TcClassDcl.lhs -1 +2
    M ./compiler/typecheck/TcExpr.lhs -4 +6
    M ./compiler/typecheck/TcForeign.lhs -1 +1
    M ./compiler/typecheck/TcGenDeriv.lhs -14 +13
    M ./compiler/typecheck/TcHsSyn.lhs -3 +2
    M ./compiler/typecheck/TcInstDcls.lhs -5 +4
    M ./compiler/typecheck/TcRnDriver.lhs -2 +11
    M ./compiler/typecheck/TcSimplify.lhs -10 +17
    M ./compiler/vectorise/VectType.hs +7

Mon Dec  8 12:43:10 GMT 2008  simonpj@microsoft.com
  * White space only

    M ./compiler/simplCore/Simplify.lhs -2

Mon Dec  8 12:48:40 GMT 2008  simonpj@microsoft.com
  * Move simpleOptExpr from CoreUnfold to CoreSubst

    M ./compiler/coreSyn/CoreSubst.lhs -1 +87
    M ./compiler/coreSyn/CoreUnfold.lhs -72 +1

Mon Dec  8 17:30:18 GMT 2008  simonpj@microsoft.com
  * Use CoreSubst.simpleOptExpr in place of the ad-hoc simpleSubst (reduces code too)

    M ./compiler/deSugar/DsBinds.lhs -50 +16

Tue Dec  9 17:03:02 GMT 2008  simonpj@microsoft.com
  * Fix Trac #2861: bogus eta expansion
  
  Urghlhl!  I "tided up" the treatment of the "state hack" in CoreUtils, but
  missed an unexpected interaction with the way that a bottoming function
  simply swallows excess arguments.  There's a long
       Note [State hack and bottoming functions]
  to explain (which accounts for most of the new lines of code).
  

    M ./compiler/coreSyn/CoreUtils.lhs -16 +53

Mon Dec 15 10:02:21 GMT 2008  Simon Marlow <marlowsd@gmail.com>
  * Revert CorePrep part of "Completely new treatment of INLINE pragmas..."
  
  The original patch said:
  
  * I made some changes to the way in which eta expansion happens in
    CorePrep, mainly to ensure that *arguments* that become let-bound
    are also eta-expanded.  I'm still not too happy with the clarity
    and robustness fo the result.
    
  Unfortunately this change apparently broke some invariants that were
  relied on elsewhere, and in particular lead to panics when compiling
  with profiling on.
  
  Will re-investigate in the new year.

    M ./compiler/coreSyn/CorePrep.lhs -53 +58
    M ./configure.ac -1 +1

Mon Dec 15 12:28:51 GMT 2008  Simon Marlow <marlowsd@gmail.com>
  * revert accidental change to configure.ac

    M ./configure.ac -1 +1

3 files changed, 125 insertions, 140 deletions

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index add2c34a85..4c144b8e50 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -23,13 +23,12 @@ import {-# SOURCE #-}	Match( matchWrapper )
 import DsMonad
 import DsGRHSs
 import DsUtils
+import OccurAnal
 
 import HsSyn		-- lots of things
 import CoreSyn		-- lots of things
-import CoreSubst
 import MkCore
 import CoreUtils
-import CoreUnfold
 import CoreFVs
 
 import TcHsSyn	( mkArbitraryType )	-- Mis-placed?
@@ -49,7 +48,7 @@ import Bag
 import BasicTypes hiding ( TopLevel )
 import FastString
 import StaticFlags	( opt_DsMultiTyVar )
-import Util		( count, mapAndUnzip, lengthExceeds )
+import Util		( mapSnd, mapAndUnzip, lengthExceeds )
 
 import Control.Monad
 import Data.List
@@ -71,7 +70,6 @@ dsLHsBinds binds = ds_lhs_binds NoSccs binds
 
 ------------------------
 ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
-
 	 -- scc annotation policy (see below)
 ds_lhs_binds auto_scc binds =  foldM (dsLHsBind auto_scc) [] (bagToList binds)
 
@@ -87,30 +85,25 @@ dsHsBind :: AutoScc
 	 -> HsBind Id
 	 -> DsM [(Id,CoreExpr)] -- Result
 
-dsHsBind _ rest (VarBind var expr inline_regardless)
-  = do	{ core_expr <- dsLExpr expr
-
-	        -- Dictionary bindings are always VarBinds,
-	        -- so we only need do this here
-	; core_expr' <- addDictScc var core_expr
-	; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr'
-		   | otherwise	       = var
+dsHsBind _ rest (VarBind var expr) = do
+    core_expr <- dsLExpr expr
 
-	; return ((var', core_expr') : rest) }
+        -- Dictionary bindings are always VarMonoBinds, so
+        -- we only need do this here
+    core_expr' <- addDictScc var core_expr
+    return ((var, core_expr') : rest)
 
-dsHsBind _ rest 
-	 (FunBind { fun_id = L _ fun, fun_matches = matches, 
-		    fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf }) 
- = do	{ (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
-	; body' <- mkOptTickBox tick body
-	; rhs   <- dsCoercion co_fn (return (mkLams args body'))
-	; return ((fun,rhs) : rest) }
+dsHsBind _ rest (FunBind { fun_id = L _ fun, fun_matches = matches, 
+				  fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf }) = do
+    (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
+    body' <- mkOptTickBox tick body
+    rhs <- dsCoercion co_fn (return (mkLams args body'))
+    return ((fun,rhs) : rest)
 
-dsHsBind _ rest 
-	 (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
-  = do	{ body_expr <- dsGuarded grhss ty
-	; sel_binds <- mkSelectorBinds pat body_expr
-	; return (sel_binds ++ rest) }
+dsHsBind _ rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) = do
+    body_expr <- dsGuarded grhss ty
+    sel_binds <- mkSelectorBinds pat body_expr
+    return (sel_binds ++ rest)
 
 {-  Note [Rules and inlining]
     ~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -139,14 +132,10 @@ dsHsBind _ rest
 dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
   = do	{ core_prs <- ds_lhs_binds NoSccs binds
 	; let env = mkABEnv exports
-	      ar_env = mkArityEnv binds
-	      do_one (lcl_id, rhs) 
-		| Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id
-		= makeCorePair gbl_id (lookupArity ar_env lcl_id) prags $
-		  addAutoScc auto_scc gbl_id rhs
-
-		| otherwise = (lcl_id, rhs)
-
+	      do_one (lcl_id, rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id
+				   = addInlinePrags prags gbl_id $
+				     addAutoScc auto_scc gbl_id rhs
+				   | otherwise = (lcl_id, rhs)
 	      locals'  = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
 			-- Note [Rules and inlining]
 	; return (map do_one core_prs ++ locals' ++ rest) }
@@ -214,18 +203,17 @@ dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
 		where
 		  fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
 
-	      ar_env = mkArityEnv binds
 	      env = mkABEnv exports
 
 	      do_one (lcl_id, rhs) 
 		| Just (id_tvs, gbl_id, _, prags) <- lookupVarEnv env lcl_id
-		= let rhs' = addAutoScc auto_scc gbl_id  $
-			     mkLams id_tvs $
-			     mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
-			            | tv <- tyvars, not (tv `elem` id_tvs)] $
-		             add_lets rhs
-		  in (NonRec lcl_id (mkTyApps (Var gbl_id) (mkTyVarTys id_tvs)),
-		      makeCorePair gbl_id (lookupArity ar_env lcl_id) prags rhs')
+		= (NonRec lcl_id (mkTyApps (Var gbl_id) (mkTyVarTys id_tvs)),
+		   addInlinePrags prags gbl_id $
+		   addAutoScc auto_scc gbl_id  $
+		   mkLams id_tvs $
+		   mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
+		          | tv <- tyvars, not (tv `elem` id_tvs)] $
+	           add_lets rhs)
 		| otherwise
 		= (NonRec lcl_id (mkTyApps (Var non_exp_gbl_id) (mkTyVarTys tyvars)),
 		   (non_exp_gbl_id, mkLams tyvars (add_lets rhs)))
@@ -236,35 +224,30 @@ dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
 
 	-- Another common case: one exported variable
 	-- Non-recursive bindings come through this way
-	-- So do self-recursive bindings, and recursive bindings
-	-- that have been chopped up with type signatures
 dsHsBind auto_scc rest
      (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds)
-  = ASSERT( all (`elem` tyvars) all_tyvars )
-    do	{ core_prs <- ds_lhs_binds NoSccs binds
-
-	; let	-- Always treat the binds as recursive, because the typechecker
-	        -- makes rather mixed-up dictionary bindings
-	        core_bind = Rec core_prs
-		inl_arity = lookupArity (mkArityEnv binds) local
+  = ASSERT( all (`elem` tyvars) all_tyvars ) do
+    core_prs <- ds_lhs_binds NoSccs binds
+    let
+        -- Always treat the binds as recursive, because the typechecker
+        -- makes rather mixed-up dictionary bindings
+        core_bind = Rec core_prs
     
-	; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global 
-				   local inl_arity core_bind) prags
-
-	; let   (spec_binds, rules) = unzip (catMaybes mb_specs)
-	        global'   = addIdSpecialisations global rules
-	        rhs       = addAutoScc auto_scc global $
-			    mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
-		main_bind = makeCorePair global' (inl_arity + length dicts) prags rhs
+    mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind) prags
+    let
+        (spec_binds, rules) = unzip (catMaybes mb_specs)
+        global' = addIdSpecialisations global rules
+        rhs'    = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
+        bind    = addInlinePrags prags global' $ addAutoScc auto_scc global' rhs'
     
-	; return (main_bind : spec_binds ++ rest) }
+    return (bind  : spec_binds ++ rest)
 
 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
   = do	{ core_prs <- ds_lhs_binds NoSccs binds
 	; let env = mkABEnv exports
-	      ar_env = mkArityEnv binds
-	      do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
-			          = (lcl_id, addAutoScc auto_scc gbl_id rhs)
+	      do_one (lcl_id,rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id
+			          = addInlinePrags prags lcl_id $
+				    addAutoScc auto_scc gbl_id rhs
 				  | otherwise = (lcl_id,rhs)
 	       
 		-- Rec because of mixed-up dictionary bindings
@@ -277,12 +260,6 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 	      locals        = [local | (_, _, local, _) <- exports]
 	      local_tys     = map idType locals
 
-	      inl_prags :: [(Id, SrcSpan)]
-	      inl_prags = [(id, loc) | (_, id, _, prags) <- exports
-				     , L loc (InlinePrag {}) <- prags ]
-
-	; mapM_ discardedInlineWarning inl_prags
-
 	; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)
 
 	; let dict_args = map Var dicts
@@ -294,8 +271,7 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 		     ; let substitute = substTyWith all_tyvars ty_args
 		     ; locals' <- newSysLocalsDs (map substitute local_tys)
 		     ; tup_id  <- newSysLocalDs  (substitute tup_ty)
-		     ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local 
-					        (lookupArity ar_env local) core_bind) 
+		     ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind) 
 				      	 prags
 		     ; let (spec_binds, rules) = unzip (catMaybes mb_specs)
 			   global' = addIdSpecialisations global rules
@@ -309,60 +285,19 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 	      		| otherwise		  = dsMkArbitraryType all_tyvar
 
 	; export_binds_s <- mapM mk_bind (exports `zip` [0..])
-	     -- Don't scc (auto-)annotate the tuple itself.
+	     -- don't scc (auto-)annotate the tuple itself.
 
 	; return ((poly_tup_id, poly_tup_expr) : 
 		    (concat export_binds_s ++ rest)) }
 
-------------------------
-makeCorePair :: Id-> Arity -> [LPrag] -> CoreExpr -> (Id, CoreExpr)
-makeCorePair gbl_id arity prags rhs
-  = (addInline gbl_id arity rhs prags, rhs)
-
-------------------------
-discardedInlineWarning :: (Id, SrcSpan) -> DsM ()
-discardedInlineWarning (id, loc) 
-  = putSrcSpanDs loc $
-    warnDs $ sep [ ptext (sLit "Discarding INLINE pragma for") <+> ppr id
-		 , ptext (sLit "because it is bound by a pattern, or a mutual recursion") ]
-
-------------------------
-type AbsBindEnv = VarEnv ([TyVar], Id, Id, [LPrag])
-	-- Maps the "lcl_id" for an AbsBind to
-	-- its "gbl_id" and associated pragmas, if any
-
-mkABEnv :: [([TyVar], Id, Id, [LPrag])] -> AbsBindEnv
+mkABEnv :: [([TyVar], Id, Id, [LPrag])] -> VarEnv ([TyVar], Id, Id, [LPrag])
 -- Takes the exports of a AbsBinds, and returns a mapping
 --	lcl_id -> (tyvars, gbl_id, lcl_id, prags)
 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
 
-mkArityEnv :: LHsBinds Id -> IdEnv Arity
-	-- Maps a local to the arity of its definition
-mkArityEnv binds = mkVarEnv (mapCatMaybes get_arity (bagToList binds))
-  where
-    get_arity (L _ (FunBind { fun_id = id, fun_matches = ms })) = Just (unLoc id, matchGroupArity ms)
-    get_arity _ = Nothing
-
-lookupArity :: IdEnv Arity -> Id -> Arity
-lookupArity ar_env id = lookupVarEnv ar_env id `orElse` 0
-
-addInline :: Id -> Arity -> CoreExpr -> [LPrag] -> Id
-addInline id arity rhs prags
-  = case [inl | L _ (InlinePrag inl) <- prags] of
-      []             -> id
-      (inl_spec : _) -> addInlineToId id arity rhs inl_spec
 
-addInlineToId :: Id -> Arity -> CoreExpr -> InlineSpec -> Id
-addInlineToId id inl_arity rhs (Inline phase is_inline)
-  = id `setInlinePragma` phase
-       `setIdUnfolding`  inline_rule
-  where
-    inline_rule | is_inline = mkInlineRule rhs inl_arity
-		| otherwise = noUnfolding
-
-------------------------
 dsSpec :: [TyVar] -> [DictId] -> [TyVar]
-       -> Id -> Id -> Arity		-- Global, local, arity of local
+       -> Id -> Id		-- Global, local
        -> CoreBind -> LPrag
        -> DsM (Maybe ((Id,CoreExpr), 	-- Binding for specialised Id
 		      CoreRule))	-- Rule for the Global Id
@@ -390,10 +325,10 @@ dsSpec :: [TyVar] -> [DictId] -> [TyVar]
 --
 -- It is *possible* that 'es' does not mention all of the dictionaries 'ds'
 -- (a bit silly, because then the 
-dsSpec _ _ _ _ _ _ _ (L _ (InlinePrag {}))
+dsSpec _ _ _ _ _ _ (L _ (InlinePrag {}))
   = return Nothing
 
-dsSpec all_tvs dicts tvs poly_id mono_id inl_arity mono_bind
+dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
        (L loc (SpecPrag spec_expr spec_ty inl))
   = putSrcSpanDs loc $ 
     do	{ let poly_name = idName poly_id
@@ -415,8 +350,6 @@ dsSpec all_tvs dicts tvs poly_id mono_id inl_arity mono_bind
 			-- Very important to make the 'f' non-exported,
 			-- else it won't be inlined!
 		  spec_id     = mkLocalId spec_name spec_ty
-		  spec_id1    = addInlineToId spec_id (inl_arity + count isDictId bndrs) 
-					      spec_rhs inl
 		  spec_rhs    = Let (NonRec local_poly poly_f_body) ds_spec_expr
 		  poly_f_body = mkLams (tvs ++ dicts) f_body
 			   	
@@ -429,7 +362,7 @@ dsSpec all_tvs dicts tvs poly_id mono_id inl_arity mono_bind
 				AlwaysActive poly_name
 			        (extra_dict_bndrs ++ bndrs) args
 				(mkVarApps (Var spec_id) bndrs)
-	; return (Just ((spec_id1, spec_rhs), rule))
+	; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
 	} } } }
   where
 	-- Bind to Any any of all_ptvs that aren't 
@@ -526,21 +459,72 @@ decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr])
 -- That is, the RULE binders are lambda-bound
 -- Returns Nothing if the LHS isn't of the expected shape
 decomposeRuleLhs lhs 
-  = case collectArgs body of
-        (Var fn, args) -> Just (bndrs, fn, args)
-	_other	       -> Nothing	-- Unexpected shape
+  = case (decomp emptyVarEnv body) of
+	Nothing 	-> Nothing
+	Just (fn, args) -> Just (bndrs, fn, args)
   where
-    (bndrs, body) = collectBinders (simpleOptExpr lhs)
-	-- simpleOptExpr occurrence-analyses and simplifies the lhs
-	-- and thereby
-	-- (a) identifies unused binders: Note [Unused spec binders]
-	-- (b) sorts dict bindings into NonRecs 
-	--	so they can be inlined by 'decomp'
-	-- (c) substitute trivial lets so that they don't get in the way
-	--     Note that we substitute the function too; we might 
-	--     have this as a LHS:  let f71 = M.f Int in f71
-        -- NB: tcSimplifyRuleLhs is very careful not to generate complicated
-	--     dictionary expressions that we might have to match
+    occ_lhs = occurAnalyseExpr lhs
+		-- The occurrence-analysis does two things
+		-- (a) identifies unused binders: Note [Unused spec binders]
+		-- (b) sorts dict bindings into NonRecs 
+		--	so they can be inlined by 'decomp'
+    (bndrs, body) = collectBinders occ_lhs
+
+        -- Substitute dicts in the LHS args, so that there 
+        -- aren't any lets getting in the way
+        -- Note that we substitute the function too; we might have this as
+        -- a LHS:       let f71 = M.f Int in f71
+    decomp env (Let (NonRec dict rhs) body) 
+        = decomp (extendVarEnv env dict (simpleSubst env rhs)) body
+    decomp env body 
+        = case collectArgs (simpleSubst env body) of
+            (Var fn, args) -> Just (fn, args)
+            _              -> Nothing
+
+simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr
+-- Similar to CoreSubst.substExpr, except that 
+-- (a) Takes no account of capture; at this point there is no shadowing
+-- (b) Can have a GlobalId (imported) in its domain
+-- (c) Ids only; no types are substituted
+-- (d) Does not insist (as does CoreSubst.lookupIdSubst) that the 
+--     in-scope set mentions all LocalIds mentioned in the argument of the subst
+--
+-- (b) and (d) are the reasons we can't use CoreSubst
+-- 
+-- (I had a note that (b) is "no longer relevant", and indeed it doesn't
+--  look relevant here. Perhaps there was another caller of simpleSubst.)
+
+simpleSubst subst expr
+  = go expr
+  where
+    go (Var v)	       = lookupVarEnv subst v `orElse` Var v
+    go (Cast e co)     = Cast (go e) co
+    go (Type ty)       = Type ty
+    go (Lit lit)       = Lit lit
+    go (App fun arg)   = App (go fun) (go arg)
+    go (Note note e)   = Note note (go e)
+    go (Lam bndr body) = Lam bndr (go body)
+    go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body)
+    go (Let (Rec pairs) body)       = Let (Rec (mapSnd go pairs)) (go body)
+    go (Case scrut bndr ty alts)    = Case (go scrut) bndr ty 
+					   [(c,bs,go r) | (c,bs,r) <- alts]
+
+addInlinePrags :: [LPrag] -> Id -> CoreExpr -> (Id,CoreExpr)
+addInlinePrags prags bndr rhs
+  = case [inl | L _ (InlinePrag inl) <- prags] of
+	[]      -> (bndr, rhs)
+	(inl:_) -> addInlineInfo inl bndr rhs
+
+addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
+addInlineInfo (Inline phase is_inline) bndr rhs
+  = (attach_phase bndr phase, wrap_inline is_inline rhs)
+  where
+    attach_phase bndr phase 
+	| isAlwaysActive phase = bndr	-- Default phase
+	| otherwise  	       = bndr `setInlinePragma` phase
+
+    wrap_inline True  body = mkInlineMe body
+    wrap_inline False body = body
 \end{code}
 
 
@@ -611,6 +595,8 @@ dsCoercion (WpApp v)         thing_inside
 		{- An Id -}		       ; return (App expr (Var v)) }
 dsCoercion (WpTyApp ty)      thing_inside = do { expr <- thing_inside
 					       ; return (App expr (Type ty)) }
+dsCoercion WpInline 	     thing_inside = do { expr <- thing_inside
+					       ; return (mkInlineMe expr) }
 dsCoercion (WpLet bs)        thing_inside = do { prs <- dsLHsBinds bs
 					       ; expr <- thing_inside
 					       ; return (Let (Rec prs) expr) }
diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 007edb9b3d..080289e8f9 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -19,7 +19,6 @@ import DsMonad
 import HsSyn
 import DataCon
 import CoreUtils
-import CoreUnfold
 import Id
 import Literal
 import Module
@@ -231,10 +230,9 @@ dsFCall fn_id fcall = do
         -- Build the wrapper
         work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
         wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
-        wrap_rhs     = mkLams (tvs ++ args) wrapper_body
-        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineRule wrap_rhs (length args)
+        wrap_rhs     = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
     
-    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty)
+    return ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty)
 \end{code}
 
 
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index b0c314bca0..554a9453ea 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -13,7 +13,7 @@
 -- a Royal Pain (triggers other recompilation).
 -----------------------------------------------------------------------------
 
-{-# OPTIONS -fwarn-unused-imports #-}
+{-# OPTIONS -fno-warn-unused-imports #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
 -- any warnings in the module. See
@@ -33,6 +33,7 @@ module DsMeta( dsBracket,
 import {-# SOURCE #-}	DsExpr ( dsExpr )
 
 import MatchLit
+import DsUtils
 import DsMonad
 
 import qualified Language.Haskell.TH as TH
@@ -44,11 +45,11 @@ import PrelNames
 -- OccName.varName we do this by removing varName from the import of
 -- OccName above, making a qualified instance of OccName and using
 -- OccNameAlias.varName where varName ws previously used in this file.
-import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName ) 
+import qualified OccName
 
 import Module
 import Id
-import Name hiding( isVarOcc, isTcOcc, varName, tcName ) 
+import Name
 import NameEnv
 import TcType
 import TyCon