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

1 files changed, 59 insertions, 54 deletions

diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs
index c32b83ddb5..270ce17095 100644
--- a/compiler/simplCore/SetLevels.lhs
+++ b/compiler/simplCore/SetLevels.lhs
@@ -48,7 +48,7 @@ module SetLevels (
 	Level(..), tOP_LEVEL,
 	LevelledBind, LevelledExpr,
 
-	incMinorLvl, ltMajLvl, ltLvl, isTopLvl
+	incMinorLvl, ltMajLvl, ltLvl, isTopLvl, isInlineCtxt
     ) where
 
 #include "HsVersions.h"
@@ -56,14 +56,13 @@ module SetLevels (
 import CoreSyn
 
 import DynFlags		( FloatOutSwitches(..) )
-import CoreUtils	( exprType, exprIsTrivial, exprBotStrictness_maybe, mkPiTypes )
+import CoreUtils	( exprType, exprIsTrivial, mkPiTypes )
 import CoreFVs		-- all of it
-import CoreSubst	( Subst, emptySubst, extendInScope, extendInScopeList,
-			  extendIdSubst, cloneIdBndr, cloneRecIdBndrs )
+import CoreSubst	( Subst, emptySubst, extendInScope, extendIdSubst,
+			  cloneIdBndr, cloneRecIdBndrs )
 import Id		( Id, idType, mkSysLocal, isOneShotLambda,
 			  zapDemandIdInfo, transferPolyIdInfo,
-			  idSpecialisation, idUnfolding, setIdInfo, 
-			  setIdNewStrictness, setIdArity
+			  idSpecialisation, idWorkerInfo, setIdInfo
 			)
 import IdInfo
 import Var
@@ -86,7 +85,9 @@ import FastString
 %************************************************************************
 
 \begin{code}
-data Level = Level Int	-- Level number of enclosing lambdas
+data Level = InlineCtxt	-- A level that's used only for
+			-- the context parameter ctxt_lvl
+	   | Level Int	-- Level number of enclosing lambdas
 	  	   Int	-- Number of big-lambda and/or case expressions between
 			-- here and the nearest enclosing lambda
 \end{code}
@@ -149,37 +150,55 @@ the worker at all.
 type LevelledExpr  = TaggedExpr Level
 type LevelledBind  = TaggedBind Level
 
-tOP_LEVEL :: Level
+tOP_LEVEL, iNLINE_CTXT :: Level
 tOP_LEVEL   = Level 0 0
+iNLINE_CTXT = InlineCtxt
 
 incMajorLvl :: Level -> Level
+-- For InlineCtxt we ignore any inc's; we don't want
+-- to do any floating at all; see notes above
+incMajorLvl InlineCtxt      = InlineCtxt
 incMajorLvl (Level major _) = Level (major + 1) 0
 
 incMinorLvl :: Level -> Level
+incMinorLvl InlineCtxt		= InlineCtxt
 incMinorLvl (Level major minor) = Level major (minor+1)
 
 maxLvl :: Level -> Level -> Level
+maxLvl InlineCtxt l2  = l2
+maxLvl l1  InlineCtxt = l1
 maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2)
   | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
   | otherwise					   = l2
 
 ltLvl :: Level -> Level -> Bool
+ltLvl _          InlineCtxt  = False
+ltLvl InlineCtxt (Level _ _) = True
 ltLvl (Level maj1 min1) (Level maj2 min2)
   = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
 
 ltMajLvl :: Level -> Level -> Bool
     -- Tells if one level belongs to a difft *lambda* level to another
+ltMajLvl _              InlineCtxt     = False
+ltMajLvl InlineCtxt     (Level maj2 _) = 0 < maj2
 ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
 
 isTopLvl :: Level -> Bool
 isTopLvl (Level 0 0) = True
 isTopLvl _           = False
 
+isInlineCtxt :: Level -> Bool
+isInlineCtxt InlineCtxt = True
+isInlineCtxt _          = False
+
 instance Outputable Level where
+  ppr InlineCtxt      = text "<INLINE>"
   ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
 
 instance Eq Level where
+  InlineCtxt        == InlineCtxt        = True
   (Level maj1 min1) == (Level maj2 min2) = maj1 == maj2 && min1 == min2
+  _                 == _                 = False
 \end{code}
 
 
@@ -196,16 +215,20 @@ setLevels :: FloatOutSwitches
 	  -> [LevelledBind]
 
 setLevels float_lams binds us
-  = initLvl us (do_them init_env binds)
+  = initLvl us (do_them binds)
   where
-    init_env = initialEnv float_lams
+    -- "do_them"'s main business is to thread the monad along
+    -- It gives each top binding the same empty envt, because
+    -- things unbound in the envt have level number zero implicitly
+    do_them :: [CoreBind] -> LvlM [LevelledBind]
+
+    do_them [] = return []
+    do_them (b:bs) = do
+        (lvld_bind, _) <- lvlTopBind init_env b
+        lvld_binds <- do_them bs
+        return (lvld_bind : lvld_binds)
 
-    do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind]
-    do_them _ [] = return []
-    do_them env (b:bs)
-      = do { (lvld_bind, env') <- lvlTopBind env b
-           ; lvld_binds <- do_them env' bs
-           ; return (lvld_bind : lvld_binds) }
+    init_env = initialEnv float_lams
 
 lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv)
 lvlTopBind env (NonRec binder rhs)
@@ -260,6 +283,11 @@ lvlExpr ctxt_lvl env (_, AnnApp fun arg) = do
 	-- We don't do MFE on partial applications generally,
 	-- but we do if the function is big and hairy, like a case
 
+lvlExpr _ env (_, AnnNote InlineMe expr) = do
+-- Don't float anything out of an InlineMe; hence the iNLINE_CTXT
+    expr' <- lvlExpr iNLINE_CTXT env expr
+    return (Note InlineMe expr')
+
 lvlExpr ctxt_lvl env (_, AnnNote note expr) = do
     expr' <- lvlExpr ctxt_lvl env expr
     return (Note note expr')
@@ -331,25 +359,13 @@ lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr ty alts) = do
 the expression, so that it can itself be floated.
 
 Note [Unlifted MFEs]
-~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~
 We don't float unlifted MFEs, which potentially loses big opportunites.
 For example:
 	\x -> f (h y)
 where h :: Int -> Int# is expensive. We'd like to float the (h y) outside
 the \x, but we don't because it's unboxed.  Possible solution: box it.
 
-Note [Bottoming floats]
-~~~~~~~~~~~~~~~~~~~~~~~
-If we see
-	f = \x. g (error "urk")
-we'd like to float the call to error, to get
-	lvl = error "urk"
-	f = \x. g lvl
-But, it's very helpful for lvl to get a strictness signature, so that,
-for example, its unfolding is not exposed in interface files (unnecessary).
-But this float-out might occur after strictness analysis. So we use the
-cheap-and-cheerful exprBotStrictness_maybe function.
-
 \begin{code}
 lvlMFE ::  Bool			-- True <=> strict context [body of case or let]
 	-> Level		-- Level of innermost enclosing lambda/tylam
@@ -360,20 +376,17 @@ lvlMFE ::  Bool			-- True <=> strict context [body of case or let]
 lvlMFE _ _ _ (_, AnnType ty)
   = return (Type ty)
 
--- No point in floating out an expression wrapped in a coercion or note
+-- No point in floating out an expression wrapped in a coercion;
 -- If we do we'll transform  lvl = e |> co 
 --			 to  lvl' = e; lvl = lvl' |> co
 -- and then inline lvl.  Better just to float out the payload.
-lvlMFE strict_ctxt ctxt_lvl env (_, AnnNote n e)
-  = do { e' <- lvlMFE strict_ctxt ctxt_lvl env e
-       ; return (Note n e') }
-
 lvlMFE strict_ctxt ctxt_lvl env (_, AnnCast e co)
-  = do	{ e' <- lvlMFE strict_ctxt ctxt_lvl env e
-	; return (Cast e' co) }
+  = do	{ expr' <- lvlMFE strict_ctxt ctxt_lvl env e
+	; return (Cast expr' co) }
 
 lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
   |  isUnLiftedType ty			-- Can't let-bind it; see Note [Unlifted MFEs]
+  || isInlineCtxt ctxt_lvl		-- Don't float out of an __inline__ context
   || exprIsTrivial expr			-- Never float if it's trivial
   || not good_destination
   = 	-- Don't float it out
@@ -382,13 +395,8 @@ lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
   | otherwise	-- Float it out!
   = do expr' <- lvlFloatRhs abs_vars dest_lvl env ann_expr
        var <- newLvlVar "lvl" abs_vars ty
-		-- Note [Bottoming floats]
-       let var_w_str = case exprBotStrictness_maybe expr of
-			  Just (arity,str) -> var `setIdArity` arity
-						  `setIdNewStrictness` str
-			  Nothing  -> var
-       return (Let (NonRec (TB var_w_str dest_lvl) expr') 
-                   (mkVarApps (Var var_w_str) abs_vars))
+       return (Let (NonRec (TB var dest_lvl) expr') 
+                   (mkVarApps (Var var) abs_vars))
   where
     expr     = deAnnotate ann_expr
     ty       = exprType expr
@@ -483,6 +491,7 @@ lvlBind :: TopLevelFlag		-- Used solely to decide whether to clone
 lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
   |  isTyVar bndr 		-- Don't do anything for TyVar binders
 				--   (simplifier gets rid of them pronto)
+  || isInlineCtxt ctxt_lvl	-- Don't do anything inside InlineMe
   = do rhs' <- lvlExpr ctxt_lvl env rhs
        return (NonRec (TB bndr ctxt_lvl) rhs', env)
 
@@ -507,6 +516,10 @@ lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
 
 \begin{code}
 lvlBind top_lvl ctxt_lvl env (AnnRec pairs)
+  | isInlineCtxt ctxt_lvl	-- Don't do anything inside InlineMe
+  = do rhss' <- mapM (lvlExpr ctxt_lvl env) rhss
+       return (Rec ([TB b ctxt_lvl | b <- bndrs] `zip` rhss'), env)
+
   | null abs_vars
   = do (new_env, new_bndrs) <- cloneRecVars top_lvl env bndrs ctxt_lvl dest_lvl
        new_rhss <- mapM (lvlExpr ctxt_lvl new_env) rhss
@@ -708,12 +721,6 @@ extendLvlEnv (float_lams, lvl_env, subst, id_env) prs
   -- incorrectly, because the SubstEnv was still lying around.  Ouch!
   -- KSW 2000-07.
 
-extendInScopeEnv :: LevelEnv -> Var -> LevelEnv
-extendInScopeEnv (fl, le, subst, ids) v = (fl, le, extendInScope subst v, ids)
-
-extendInScopeEnvList :: LevelEnv -> [Var] -> LevelEnv
-extendInScopeEnvList (fl, le, subst, ids) vs = (fl, le, extendInScopeList subst vs, ids)
-
 -- extendCaseBndrLvlEnv adds the mapping case-bndr->scrut-var if it can
 -- (see point 4 of the module overview comment)
 extendCaseBndrLvlEnv :: LevelEnv -> Expr (TaggedBndr Level) -> Var -> Level
@@ -801,7 +808,7 @@ abstractVars dest_lvl (_, lvl_env, _, id_env) fvs
 
 	-- We are going to lambda-abstract, so nuke any IdInfo,
 	-- and add the tyvars of the Id (if necessary)
-    zap v | isIdVar v = WARN( isInlineRule (idUnfolding v) ||
+    zap v | isIdVar v = WARN( workerExists (idWorkerInfo v) ||
 		           not (isEmptySpecInfo (idSpecialisation v)),
 		           text "absVarsOf: discarding info on" <+> ppr v )
 		     setIdInfo v vanillaIdInfo
@@ -862,9 +869,7 @@ newLvlVar str vars body_ty = do
 
 cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> Level -> LvlM (LevelEnv, Id)
 cloneVar TopLevel env v _ _
-  = return (extendInScopeEnv env v, v)	-- Don't clone top level things
-		-- But do extend the in-scope env, to satisfy the in-scope invariant
-
+  = return (env, v)	-- Don't clone top level things
 cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl
   = ASSERT( isIdVar v ) do
     us <- getUniqueSupplyM
@@ -876,7 +881,7 @@ cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl
 
 cloneRecVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> Level -> LvlM (LevelEnv, [Id])
 cloneRecVars TopLevel env vs _ _
-  = return (extendInScopeEnvList env vs, vs)	-- Don't clone top level things
+  = return (env, vs)	-- Don't clone top level things
 cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl
   = ASSERT( all isIdVar vs ) do
     us <- getUniqueSupplyM