The Big INLINE Patch: totally reorganise way that INLINE pragmas work

author simonpj@microsoft.com <unknown>

Thu, 29 Oct 2009 14:30:51 +0000 (14:30 +0000)

committer simonpj@microsoft.com <unknown>

Thu, 29 Oct 2009 14:30:51 +0000 (14:30 +0000)
author simonpj@microsoft.com <unknown>
Thu, 29 Oct 2009 14:30:51 +0000 (14:30 +0000)
committer simonpj@microsoft.com <unknown>
Thu, 29 Oct 2009 14:30:51 +0000 (14:30 +0000)
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs

index 0182139..9b21399 100644 (file)
--- a/compiler/basicTypes/BasicTypes.lhs
+++ b/compiler/basicTypes/BasicTypes.lhs
@@ -54,12 +54,12 @@ module BasicTypes(
         StrictnessMark(..), isMarkedUnboxed, isMarkedStrict,
  
         CompilerPhase, 
         StrictnessMark(..), isMarkedUnboxed, isMarkedStrict,
  
         CompilerPhase, 
-       Activation(..), isActive, isNeverActive, isAlwaysActive,
-        RuleMatchInfo(..), isConLike, isFunLike,
-        InlinePragma(..), defaultInlinePragma, isDefaultInlinePragma,
+       Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive,
+        RuleMatchInfo(..), isConLike, isFunLike, 
+        InlinePragma(..), defaultInlinePragma, neverInlinePragma, dfunInlinePragma,
+       isDefaultInlinePragma, isInlinePragma,
          inlinePragmaActivation, inlinePragmaRuleMatchInfo,
          setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
          inlinePragmaActivation, inlinePragmaRuleMatchInfo,
          setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
-       InlineSpec(..), defaultInlineSpec, alwaysInlineSpec, neverInlineSpec,
  
         SuccessFlag(..), succeeded, failed, successIf
     ) where
  
         SuccessFlag(..), succeeded, failed, successIf
     ) where
@@ -585,10 +585,69 @@ data Activation = NeverActive
                 | ActiveAfter CompilerPhase     -- Active in this phase and later
                 deriving( Eq )                  -- Eq used in comparing rules in HsDecls
  
                 | ActiveAfter CompilerPhase     -- Active in this phase and later
                 deriving( Eq )                  -- Eq used in comparing rules in HsDecls
  
-data RuleMatchInfo = ConLike
+data RuleMatchInfo = ConLike                   -- See Note [CONLIKE pragma]
                     | FunLike
                     deriving( Eq )
  
                     | FunLike
                     deriving( Eq )
  
+data InlinePragma           -- Note [InlinePragma]
+  = InlinePragma
+      { inl_inline :: Bool           -- True <=> INLINE, 
+                                    -- False <=> no pragma at all, or NOINLINE
+      , inl_act    :: Activation     -- Says during which phases inlining is allowed
+      , inl_rule   :: RuleMatchInfo  -- Should the function be treated like a constructor?
+    } deriving( Eq )
+\end{code}
+
+Note [InlinePragma]
+~~~~~~~~~~~~~~~~~~~
+This data type mirrors what you can write in an INLINE or NOINLINE pragma in 
+the source program.
+
+If you write nothing at all, you get defaultInlinePragma:
+   inl_inline = False
+   inl_act    = AlwaysActive
+   inl_rule   = FunLike
+
+It's not possible to get that combination by *writing* something, so 
+if an Id has defaultInlinePragma it means the user didn't specify anything.
+
+Note [CONLIKE pragma]
+~~~~~~~~~~~~~~~~~~~~~
+The ConLike constructor of a RuleMatchInfo is aimed at the following.
+Consider first
+    {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-}
+    g b bs = let x = b:bs in ..x...x...(r x)...
+Now, the rule applies to the (r x) term, because GHC "looks through" 
+the definition of 'x' to see that it is (b:bs).
+
+Now consider
+    {-# RULE "r/f" forall v. r (f v) = f (v+1) #-}
+    g v = let x = f v in ..x...x...(r x)...
+Normally the (r x) would *not* match the rule, because GHC would be
+scared about duplicating the redex (f v), so it does not "look
+through" the bindings.  
+
+However the CONLIKE modifier says to treat 'f' like a constructor in
+this situation, and "look through" the unfolding for x.  So (r x)
+fires, yielding (f (v+1)).
+
+This is all controlled with a user-visible pragma:
+     {-# NOINLINE CONLIKE [1] f #-}
+
+The main effects of CONLIKE are:
+
+    - The occurrence analyser (OccAnal) and simplifier (Simplify) treat
+      CONLIKE thing like constructors, by ANF-ing them
+
+    - New function coreUtils.exprIsExpandable is like exprIsCheap, but
+      additionally spots applications of CONLIKE functions
+
+    - A CoreUnfolding has a field that caches exprIsExpandable
+
+    - The rule matcher consults this field.  See
+      Note [Expanding variables] in Rules.lhs.
+
+\begin{code}
  isConLike :: RuleMatchInfo -> Bool
  isConLike ConLike = True
  isConLike _            = False
  isConLike :: RuleMatchInfo -> Bool
  isConLike ConLike = True
  isConLike _            = False
@@ -597,55 +656,39 @@ isFunLike :: RuleMatchInfo -> Bool
  isFunLike FunLike = True
  isFunLike _            = False
  
  isFunLike FunLike = True
  isFunLike _            = False
  
-data InlinePragma
-  = InlinePragma
-      Activation        -- Says during which phases inlining is allowed
-      RuleMatchInfo     -- Should the function be treated like a constructor?
-  deriving( Eq )
-
-defaultInlinePragma :: InlinePragma
-defaultInlinePragma = InlinePragma AlwaysActive FunLike
+defaultInlinePragma, neverInlinePragma, dfunInlinePragma :: InlinePragma
+defaultInlinePragma 
+  = InlinePragma { inl_act = AlwaysActive, inl_rule = FunLike, inl_inline = False }
+neverInlinePragma   
+   = InlinePragma { inl_act = NeverActive, inl_rule = FunLike, inl_inline = False }
+dfunInlinePragma   
+   = InlinePragma { inl_act = AlwaysActive, inl_rule = ConLike, inl_inline = False }
+                                    
  
  isDefaultInlinePragma :: InlinePragma -> Bool
  
  isDefaultInlinePragma :: InlinePragma -> Bool
-isDefaultInlinePragma (InlinePragma activation match_info)
-  = isAlwaysActive activation && isFunLike match_info
+isDefaultInlinePragma (InlinePragma { inl_act = activation
+                                    , inl_rule = match_info
+                                    , inl_inline = inline })
+  = not inline && isAlwaysActive activation && isFunLike match_info
+
+isInlinePragma :: InlinePragma -> Bool
+isInlinePragma prag = inl_inline prag
  
  inlinePragmaActivation :: InlinePragma -> Activation
  
  inlinePragmaActivation :: InlinePragma -> Activation
-inlinePragmaActivation (InlinePragma activation _) = activation
+inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation
  
  inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo
  
  inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo
-inlinePragmaRuleMatchInfo (InlinePragma _ info) = info
+inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info
  
  setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma
  
  setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma
-setInlinePragmaActivation (InlinePragma _ info) activation
-  = InlinePragma activation info
+setInlinePragmaActivation prag activation = prag { inl_act = activation }
  
  setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma
  
  setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma
-setInlinePragmaRuleMatchInfo (InlinePragma activation _) info
-  = InlinePragma activation info
-
-data InlineSpec
-  = Inline
-        InlinePragma
-       Bool            -- True  <=> INLINE
-                       -- False <=> NOINLINE
-  deriving( Eq )
-
-defaultInlineSpec :: InlineSpec
-alwaysInlineSpec, neverInlineSpec :: RuleMatchInfo -> InlineSpec
-
-defaultInlineSpec = Inline defaultInlinePragma False
-                                                -- Inlining is OK, but not forced
-alwaysInlineSpec match_info
-                = Inline (InlinePragma AlwaysActive match_info) True
-                                                -- INLINE always
-neverInlineSpec match_info
-                = Inline (InlinePragma NeverActive  match_info) False
-                                                -- NOINLINE
+setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info }
  
  instance Outputable Activation where
  
  instance Outputable Activation where
-   ppr NeverActive      = ptext (sLit "NEVER")
     ppr AlwaysActive     = ptext (sLit "ALWAYS")
     ppr AlwaysActive     = ptext (sLit "ALWAYS")
+   ppr NeverActive      = ptext (sLit "NEVER")
     ppr (ActiveBefore n) = brackets (char '~' <> int n)
     ppr (ActiveAfter n)  = brackets (int n)
  
     ppr (ActiveBefore n) = brackets (char '~' <> int n)
     ppr (ActiveAfter n)  = brackets (int n)
  
@@ -654,25 +697,17 @@ instance Outputable RuleMatchInfo where
     ppr FunLike = ptext (sLit "FUNLIKE")
  
  instance Outputable InlinePragma where
     ppr FunLike = ptext (sLit "FUNLIKE")
  
  instance Outputable InlinePragma where
-  ppr (InlinePragma activation FunLike)
-       = ppr activation
-  ppr (InlinePragma activation match_info)
-       = ppr match_info <+> ppr activation
-    
-instance Outputable InlineSpec where
-   ppr (Inline (InlinePragma act match_info) is_inline)  
-       | is_inline = ptext (sLit "INLINE")
-                      <+> ppr_match_info
-                     <+> case act of
-                            AlwaysActive -> empty
-                            _            -> ppr act
-       | otherwise = ptext (sLit "NOINLINE")
-                      <+> ppr_match_info
-                     <+> case act of
-                            NeverActive  -> empty
-                            _            -> ppr act
-     where
-       ppr_match_info = if isFunLike match_info then empty else ppr match_info
+  ppr (InlinePragma { inl_inline = inline, inl_act = activation, inl_rule = info })
+    = pp_inline <+> pp_info <+> pp_activation
+    where
+      pp_inline | inline    = ptext (sLit "INLINE")
+                | otherwise = ptext (sLit "NOINLINE")
+      pp_info | isFunLike info = empty
+              | otherwise      = ppr info
+      pp_activation 
+        | inline     && isAlwaysActive activation = empty
+        | not inline && isNeverActive  activation = empty
+        | otherwise                               = ppr activation    
  
  isActive :: CompilerPhase -> Activation -> Bool
  isActive _ NeverActive      = False
  
  isActive :: CompilerPhase -> Activation -> Bool
  isActive _ NeverActive      = False
@@ -680,11 +715,15 @@ isActive _ AlwaysActive     = True
  isActive p (ActiveAfter n)  = p <= n
  isActive p (ActiveBefore n) = p >  n
  
  isActive p (ActiveAfter n)  = p <= n
  isActive p (ActiveBefore n) = p >  n
  
-isNeverActive, isAlwaysActive :: Activation -> Bool
+isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool
  isNeverActive NeverActive = True
  isNeverActive _           = False
  
  isAlwaysActive AlwaysActive = True
  isAlwaysActive _            = False
  isNeverActive NeverActive = True
  isNeverActive _           = False
  
  isAlwaysActive AlwaysActive = True
  isAlwaysActive _            = False
+
+isEarlyActive AlwaysActive      = True
+isEarlyActive (ActiveBefore {}) = True
+isEarlyActive _                        = False
  \end{code}
  
  \end{code}
  
diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs

index b7aeb45..8712db1 100644 (file)
--- a/compiler/basicTypes/Id.lhs
+++ b/compiler/basicTypes/Id.lhs
@@ -69,7 +69,6 @@ module Id (
         idArity, 
         idNewDemandInfo, idNewDemandInfo_maybe,
         idNewStrictness, idNewStrictness_maybe, 
         idArity, 
         idNewDemandInfo, idNewDemandInfo_maybe,
         idNewStrictness, idNewStrictness_maybe, 
-       idWorkerInfo,
         idUnfolding,
         idSpecialisation, idCoreRules, idHasRules,
         idCafInfo,
         idUnfolding,
         idSpecialisation, idCoreRules, idHasRules,
         idCafInfo,
@@ -87,7 +86,6 @@ module Id (
         setIdArity,
         setIdNewDemandInfo, 
         setIdNewStrictness, zapIdNewStrictness,
         setIdArity,
         setIdNewDemandInfo, 
         setIdNewStrictness, zapIdNewStrictness,
-       setIdWorkerInfo,
         setIdSpecialisation,
         setIdCafInfo,
         setIdOccInfo, zapIdOccInfo,
         setIdSpecialisation,
         setIdCafInfo,
         setIdOccInfo, zapIdOccInfo,
@@ -140,7 +138,6 @@ infixl      1 `setIdUnfolding`,
           `setIdArity`,
           `setIdNewDemandInfo`,
           `setIdNewStrictness`,
           `setIdArity`,
           `setIdNewDemandInfo`,
           `setIdNewStrictness`,
-         `setIdWorkerInfo`,
           `setIdSpecialisation`,
           `setInlinePragma`,
           `idCafInfo`
           `setIdSpecialisation`,
           `setInlinePragma`,
           `idCafInfo`
@@ -289,9 +286,7 @@ instantiated before use.
  -- | Workers get local names. "CoreTidy" will externalise these if necessary
  mkWorkerId :: Unique -> Id -> Type -> Id
  mkWorkerId uniq unwrkr ty
  -- | Workers get local names. "CoreTidy" will externalise these if necessary
  mkWorkerId :: Unique -> Id -> Type -> Id
  mkWorkerId uniq unwrkr ty
-  = mkLocalId wkr_name ty
-  where
-    wkr_name = mkInternalName uniq (mkWorkerOcc (getOccName unwrkr)) (getSrcSpan unwrkr)
+  = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty
  
  -- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings
  mkTemplateLocal :: Int -> Type -> Id
  
  -- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings
  mkTemplateLocal :: Int -> Type -> Id
@@ -350,8 +345,8 @@ isPrimOpId id = case Var.idDetails id of
                          _          -> False
  
  isDFunId id = case Var.idDetails id of
                          _          -> False
  
  isDFunId id = case Var.idDetails id of
-                        DFunId -> True
-                        _      -> False
+                        DFunId _ -> True
+                        _        -> False
  
  isPrimOpId_maybe id = case Var.idDetails id of
                          PrimOpId op -> Just op
  
  isPrimOpId_maybe id = case Var.idDetails id of
                          PrimOpId op -> Just op
@@ -409,11 +404,11 @@ isImplicitId :: Id -> Bool
  -- file, even if it's mentioned in some other interface unfolding.
  isImplicitId id
    = case Var.idDetails id of
  -- file, even if it's mentioned in some other interface unfolding.
  isImplicitId id
    = case Var.idDetails id of
-        FCallId _       -> True
-       ClassOpId _     -> True
-        PrimOpId _      -> True
-        DataConWorkId _ -> True
-       DataConWrapId _ -> True
+        FCallId {}       -> True
+       ClassOpId {}     -> True
+        PrimOpId {}      -> True
+        DataConWorkId {} -> True
+       DataConWrapId {} -> True
                 -- These are are implied by their type or class decl;
                 -- remember that all type and class decls appear in the interface file.
                 -- The dfun id is not an implicit Id; it must *not* be omitted, because 
                 -- These are are implied by their type or class decl;
                 -- remember that all type and class decls appear in the interface file.
                 -- The dfun id is not an implicit Id; it must *not* be omitted, because 
@@ -513,14 +508,6 @@ isStrictId id
             (isStrictType (idType id))
  
         ---------------------------------
             (isStrictType (idType id))
  
         ---------------------------------
-       -- WORKER ID
-idWorkerInfo :: Id -> WorkerInfo
-idWorkerInfo id = workerInfo (idInfo id)
-
-setIdWorkerInfo :: Id -> WorkerInfo -> Id
-setIdWorkerInfo id work_info = modifyIdInfo (`setWorkerInfo` work_info) id
-
-       ---------------------------------
         -- UNFOLDING
  idUnfolding :: Id -> Unfolding
  idUnfolding id = unfoldingInfo (idInfo id)
         -- UNFOLDING
  idUnfolding :: Id -> Unfolding
  idUnfolding id = unfoldingInfo (idInfo id)
@@ -549,6 +536,9 @@ setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` Just dmd) id
  
         ---------------------------------
         -- SPECIALISATION
  
         ---------------------------------
         -- SPECIALISATION
+
+-- See Note [Specialisations and RULES in IdInfo] in IdInfo.lhs
+
  idSpecialisation :: Id -> SpecInfo
  idSpecialisation id = specInfo (idInfo id)
  
  idSpecialisation :: Id -> SpecInfo
  idSpecialisation id = specInfo (idInfo id)
  
@@ -617,7 +607,7 @@ idInlineActivation :: Id -> Activation
  idInlineActivation id = inlinePragmaActivation (idInlinePragma id)
  
  setInlineActivation :: Id -> Activation -> Id
  idInlineActivation id = inlinePragmaActivation (idInlinePragma id)
  
  setInlineActivation :: Id -> Activation -> Id
-setInlineActivation id act = modifyInlinePragma id (\(InlinePragma _ match_info) -> InlinePragma act match_info)
+setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act)
  
  idRuleMatchInfo :: Id -> RuleMatchInfo
  idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id)
  
  idRuleMatchInfo :: Id -> RuleMatchInfo
  idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id)
diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs

index fb18c81..9446f7d 100644 (file)
--- a/compiler/basicTypes/IdInfo.lhs
+++ b/compiler/basicTypes/IdInfo.lhs
@@ -49,11 +49,6 @@ module IdInfo (
          cprInfoFromNewStrictness,
  #endif
  
          cprInfoFromNewStrictness,
  #endif
  
-        -- ** The WorkerInfo type
-        WorkerInfo(..),
-        workerExists, wrapperArity, workerId,
-        workerInfo, setWorkerInfo, ppWorkerInfo,
-
         -- ** Unfolding Info
         unfoldingInfo, setUnfoldingInfo, setUnfoldingInfoLazily,
  
         -- ** Unfolding Info
         unfoldingInfo, setUnfoldingInfo, setUnfoldingInfoLazily,
  
@@ -94,7 +89,6 @@ import CoreSyn ( CoreRule, setRuleIdName, seqRules, Unfolding, noUnfolding )
  import Class
  import PrimOp
  import Name
  import Class
  import PrimOp
  import Name
-import Var
  import VarSet
  import BasicTypes
  import DataCon
  import VarSet
  import BasicTypes
  import DataCon
@@ -119,7 +113,6 @@ infixl      1 `setSpecInfo`,
           `setArityInfo`,
           `setInlinePragInfo`,
           `setUnfoldingInfo`,
           `setArityInfo`,
           `setInlinePragInfo`,
           `setUnfoldingInfo`,
-         `setWorkerInfo`,
           `setLBVarInfo`,
           `setOccInfo`,
           `setCafInfo`,
           `setLBVarInfo`,
           `setOccInfo`,
           `setCafInfo`,
@@ -165,8 +158,8 @@ seqNewStrictnessInfo Nothing = ()
  seqNewStrictnessInfo (Just ty) = seqStrictSig ty
  
  pprNewStrictness :: Maybe StrictSig -> SDoc
  seqNewStrictnessInfo (Just ty) = seqStrictSig ty
  
  pprNewStrictness :: Maybe StrictSig -> SDoc
-pprNewStrictness Nothing = empty
-pprNewStrictness (Just sig) = ftext (fsLit "Str:") <+> ppr sig
+pprNewStrictness Nothing    = empty
+pprNewStrictness (Just sig) = ppr sig
  
  #ifdef OLD_STRICTNESS
  oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo
  
  #ifdef OLD_STRICTNESS
  oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo
@@ -260,35 +253,38 @@ data IdDetails
                                 --  b) when desugaring a RecordCon we can get 
                                 --     from the Id back to the data con]
  
                                 --  b) when desugaring a RecordCon we can get 
                                 --     from the Id back to the data con]
  
-  | ClassOpId Class            -- ^ The 'Id' is an operation of a class
+  | ClassOpId Class            -- ^ The 'Id' is an superclass selector or class operation of a class
  
    | PrimOpId PrimOp            -- ^ The 'Id' is for a primitive operator
    | FCallId ForeignCall                -- ^ The 'Id' is for a foreign call
  
    | TickBoxOpId TickBoxOp      -- ^ The 'Id' is for a HPC tick box (both traditional and binary)
  
  
    | PrimOpId PrimOp            -- ^ The 'Id' is for a primitive operator
    | FCallId ForeignCall                -- ^ The 'Id' is for a foreign call
  
    | TickBoxOpId TickBoxOp      -- ^ The 'Id' is for a HPC tick box (both traditional and binary)
  
-  | DFunId                     -- ^ A dictionary function.  We don't use this in an essential way,
-                               -- currently, but it's kind of nice that we can keep track of
-                               -- which Ids are DFuns, across module boundaries too
+  | DFunId Bool                        -- ^ A dictionary function.  
+                               --   True <=> the class has only one method, so may be 
+                               --            implemented with a newtype, so it might be bad 
+                               --            to be strict on this dictionary
  
  
  instance Outputable IdDetails where
      ppr = pprIdDetails
  
  pprIdDetails :: IdDetails -> SDoc
  
  
  instance Outputable IdDetails where
      ppr = pprIdDetails
  
  pprIdDetails :: IdDetails -> SDoc
-pprIdDetails VanillaId         = empty
-pprIdDetails (DataConWorkId _) = ptext (sLit "[DataCon]")
-pprIdDetails (DataConWrapId _) = ptext (sLit "[DataConWrapper]")
-pprIdDetails (ClassOpId _)     = ptext (sLit "[ClassOp]")
-pprIdDetails (PrimOpId _)      = ptext (sLit "[PrimOp]")
-pprIdDetails (FCallId _)       = ptext (sLit "[ForeignCall]")
-pprIdDetails (TickBoxOpId _)   = ptext (sLit "[TickBoxOp]")
-pprIdDetails DFunId            = ptext (sLit "[DFunId]")
-pprIdDetails (RecSelId { sel_naughty = is_naughty })
-  = brackets $ ptext (sLit "RecSel") <> pp_naughty
-  where
-    pp_naughty | is_naughty = ptext (sLit "(naughty)")
-              | otherwise  = empty
+pprIdDetails VanillaId = empty
+pprIdDetails other     = brackets (pp other)
+ where
+   pp VanillaId         = panic "pprIdDetails"
+   pp (DataConWorkId _) = ptext (sLit "DataCon")
+   pp (DataConWrapId _) = ptext (sLit "DataConWrapper")
+   pp (ClassOpId {})    = ptext (sLit "ClassOp")
+   pp (PrimOpId _)      = ptext (sLit "PrimOp")
+   pp (FCallId _)       = ptext (sLit "ForeignCall")
+   pp (TickBoxOpId _)   = ptext (sLit "TickBoxOp")
+   pp (DFunId b)        = ptext (sLit "DFunId") <> 
+                            ppWhen b (ptext (sLit "(newtype)"))
+   pp (RecSelId { sel_naughty = is_naughty })
+                        = brackets $ ptext (sLit "RecSel") 
+                           <> ppWhen is_naughty (ptext (sLit "(naughty)"))
  \end{code}
  
  
  \end{code}
  
  
@@ -314,20 +310,12 @@ data IdInfo
    = IdInfo {
         arityInfo       :: !ArityInfo,          -- ^ 'Id' arity
         specInfo        :: SpecInfo,            -- ^ Specialisations of the 'Id's function which exist
    = IdInfo {
         arityInfo       :: !ArityInfo,          -- ^ 'Id' arity
         specInfo        :: SpecInfo,            -- ^ Specialisations of the 'Id's function which exist
+                                               -- See Note [Specialisations and RULES in IdInfo]
  #ifdef OLD_STRICTNESS
         cprInfo         :: CprInfo,             -- ^ If the 'Id's function always constructs a product result
         demandInfo      :: Demand.Demand,       -- ^ Whether or not the 'Id' is definitely demanded
         strictnessInfo  :: StrictnessInfo,      -- ^ 'Id' strictness properties
  #endif
  #ifdef OLD_STRICTNESS
         cprInfo         :: CprInfo,             -- ^ If the 'Id's function always constructs a product result
         demandInfo      :: Demand.Demand,       -- ^ Whether or not the 'Id' is definitely demanded
         strictnessInfo  :: StrictnessInfo,      -- ^ 'Id' strictness properties
  #endif
-        workerInfo      :: WorkerInfo,          -- ^ Pointer to worker function.
-                                               -- Within one module this is irrelevant; the 
-                                               -- inlining of a worker is handled via the 'Unfolding'.
-                                               -- However, when the module is imported by others, the
-                                               -- 'WorkerInfo' is used /only/ to indicate the form of
-                                               -- the RHS, so that interface files don't actually 
-                                               -- need to contain the RHS; it can be derived from
-                                               -- the strictness info
-
         unfoldingInfo   :: Unfolding,           -- ^ The 'Id's unfolding
         cafInfo         :: CafInfo,             -- ^ 'Id' CAF info
          lbvarInfo      :: LBVarInfo,           -- ^ Info about a lambda-bound variable, if the 'Id' is one
         unfoldingInfo   :: Unfolding,           -- ^ The 'Id's unfolding
         cafInfo         :: CafInfo,             -- ^ 'Id' CAF info
          lbvarInfo      :: LBVarInfo,           -- ^ Info about a lambda-bound variable, if the 'Id' is one
@@ -353,7 +341,6 @@ seqIdInfo (IdInfo {}) = ()
  megaSeqIdInfo :: IdInfo -> ()
  megaSeqIdInfo info
    = seqSpecInfo (specInfo info)                        `seq`
  megaSeqIdInfo :: IdInfo -> ()
  megaSeqIdInfo info
    = seqSpecInfo (specInfo info)                        `seq`
-    seqWorker (workerInfo info)                        `seq`
  
  -- Omitting this improves runtimes a little, presumably because
  -- some unfoldings are not calculated at all
  
  -- Omitting this improves runtimes a little, presumably because
  -- some unfoldings are not calculated at all
@@ -376,8 +363,6 @@ megaSeqIdInfo info
  Setters
  
  \begin{code}
  Setters
  
  \begin{code}
-setWorkerInfo :: IdInfo -> WorkerInfo -> IdInfo
-setWorkerInfo     info wk = wk `seq` info { workerInfo = wk }
  setSpecInfo :: IdInfo -> SpecInfo -> IdInfo
  setSpecInfo      info sp = sp `seq` info { specInfo = sp }
  setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo
  setSpecInfo :: IdInfo -> SpecInfo -> IdInfo
  setSpecInfo      info sp = sp `seq` info { specInfo = sp }
  setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo
@@ -433,7 +418,6 @@ vanillaIdInfo
             strictnessInfo      = NoStrictnessInfo,
  #endif
             specInfo            = emptySpecInfo,
             strictnessInfo      = NoStrictnessInfo,
  #endif
             specInfo            = emptySpecInfo,
-           workerInfo          = NoWorker,
             unfoldingInfo       = noUnfolding,
             lbvarInfo           = NoLBVarInfo,
             inlinePragInfo      = defaultInlinePragma,
             unfoldingInfo       = noUnfolding,
             lbvarInfo           = NoLBVarInfo,
             inlinePragInfo      = defaultInlinePragma,
@@ -505,6 +489,25 @@ type InlinePragInfo = InlinePragma
  %*                                                                     *
  %************************************************************************
  
  %*                                                                     *
  %************************************************************************
  
+Note [Specialisations and RULES in IdInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generally speaking, a GlobalIdshas an *empty* SpecInfo.  All their
+RULES are contained in the globally-built rule-base.  In principle,
+one could attach the to M.f the RULES for M.f that are defined in M.
+But we don't do that for instance declarations and so we just treat
+them all uniformly.
+
+The EXCEPTION is PrimOpIds, which do have rules in their IdInfo. That is
+jsut for convenience really.
+
+However, LocalIds may have non-empty SpecInfo.  We treat them 
+differently because:
+  a) they might be nested, in which case a global table won't work
+  b) the RULE might mention free variables, which we use to keep things alive
+
+In TidyPgm, when the LocalId becomes a GlobalId, its RULES are stripped off
+and put in the global list.
+
  \begin{code}
  -- | Records the specializations of this 'Id' that we know about
  -- in the form of rewrite 'CoreRule's that target them
  \begin{code}
  -- | Records the specializations of this 'Id' that we know about
  -- in the form of rewrite 'CoreRule's that target them
@@ -542,67 +545,6 @@ seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs
  
  %************************************************************************
  %*                                                                     *
  
  %************************************************************************
  %*                                                                     *
-\subsection[worker-IdInfo]{Worker info about an @Id@}
-%*                                                                     *
-%************************************************************************
-
-There might not be a worker, even for a strict function, because:
-(a) the function might be small enough to inline, so no need 
-    for w/w split
-(b) the strictness info might be "SSS" or something, so no w/w split.
-
-Sometimes the arity of a wrapper changes from the original arity from
-which it was generated, so we always emit the "original" arity into
-the interface file, as part of the worker info.
-
-How can this happen?  Sometimes we get
-       f = coerce t (\x y -> $wf x y)
-at the moment of w/w split; but the eta reducer turns it into
-       f = coerce t $wf
-which is perfectly fine except that the exposed arity so far as
-the code generator is concerned (zero) differs from the arity
-when we did the split (2).  
-
-All this arises because we use 'arity' to mean "exactly how many
-top level lambdas are there" in interface files; but during the
-compilation of this module it means "how many things can I apply
-this to".
-
-\begin{code}
-
--- | If this Id has a worker then we store a reference to it. Worker
--- functions are generated by the worker\/wrapper pass, using information
--- information from strictness analysis.
-data WorkerInfo = NoWorker              -- ^ No known worker function
-               | HasWorker Id Arity    -- ^ The 'Arity' is the arity of the /wrapper/ at the moment of the
-                                       -- worker\/wrapper split, which may be different from the current 'Id' 'Aritiy'
-
-seqWorker :: WorkerInfo -> ()
-seqWorker (HasWorker id a) = id `seq` a `seq` ()
-seqWorker NoWorker        = ()
-
-ppWorkerInfo :: WorkerInfo -> SDoc
-ppWorkerInfo NoWorker            = empty
-ppWorkerInfo (HasWorker wk_id _) = ptext (sLit "Worker") <+> ppr wk_id
-
-workerExists :: WorkerInfo -> Bool
-workerExists NoWorker        = False
-workerExists (HasWorker _ _) = True
-
--- | The 'Id' of the worker function if it exists, or a panic otherwise
-workerId :: WorkerInfo -> Id
-workerId (HasWorker id _) = id
-workerId NoWorker = panic "workerId: NoWorker"
-
--- | The 'Arity' of the worker function at the time of the split if it exists, or a panic otherwise
-wrapperArity :: WorkerInfo -> Arity
-wrapperArity (HasWorker _ a) = a
-wrapperArity NoWorker = panic "wrapperArity: NoWorker"
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
  \subsection[CG-IdInfo]{Code generator-related information}
  %*                                                                     *
  %************************************************************************
  \subsection[CG-IdInfo]{Code generator-related information}
  %*                                                                     *
  %************************************************************************
@@ -634,6 +576,9 @@ mayHaveCafRefs _           = False
  seqCaf :: CafInfo -> ()
  seqCaf c = c `seq` ()
  
  seqCaf :: CafInfo -> ()
  seqCaf c = c `seq` ()
  
+instance Outputable CafInfo where
+   ppr = ppCafInfo
+
  ppCafInfo :: CafInfo -> SDoc
  ppCafInfo NoCafRefs = ptext (sLit "NoCafRefs")
  ppCafInfo MayHaveCafRefs = empty
  ppCafInfo :: CafInfo -> SDoc
  ppCafInfo NoCafRefs = ptext (sLit "NoCafRefs")
  ppCafInfo MayHaveCafRefs = empty
@@ -777,7 +722,6 @@ zapFragileInfo :: IdInfo -> Maybe IdInfo
  -- ^ Zap info that depends on free variables
  zapFragileInfo info 
    = Just (info `setSpecInfo` emptySpecInfo
  -- ^ Zap info that depends on free variables
  zapFragileInfo info 
    = Just (info `setSpecInfo` emptySpecInfo
-              `setWorkerInfo` NoWorker
                 `setUnfoldingInfo` noUnfolding
                `setOccInfo` if isFragileOcc occ then NoOccInfo else occ)
    where
                 `setUnfoldingInfo` noUnfolding
                `setOccInfo` if isFragileOcc occ then NoOccInfo else occ)
    where
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs

index 7060c80..449f09f 100644 (file)
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -345,8 +345,8 @@ mkDataConIds wrap_name wkr_name data_con
          --      ...(let w = C x in ...(w p q)...)...
          -- we want to see that w is strict in its two arguments
  
          --      ...(let w = C x in ...(w p q)...)...
          -- we want to see that w is strict in its two arguments
  
-    wrap_unf = mkImplicitUnfolding $ Note InlineMe $
-               mkLams wrap_tvs $ 
+    wrap_unf = mkInlineRule InlSat wrap_rhs (length dict_args + length id_args)
+    wrap_rhs = mkLams wrap_tvs $ 
                 mkLams eq_args $
                 mkLams dict_args $ mkLams id_args $
                 foldr mk_case con_app 
                 mkLams eq_args $
                 mkLams dict_args $ mkLams id_args $
                 foldr mk_case con_app 
@@ -460,12 +460,25 @@ mkDictSelId no_unf name clas
      info = noCafIdInfo
                  `setArityInfo`          1
                  `setAllStrictnessInfo`  Just strict_sig
      info = noCafIdInfo
                  `setArityInfo`          1
                  `setAllStrictnessInfo`  Just strict_sig
-                `setUnfoldingInfo`      (if no_unf then noUnfolding
-                                                  else mkImplicitUnfolding rhs)
+               `setSpecInfo`       mkSpecInfo [rule]
+               `setInlinePragInfo` neverInlinePragma
+                `setUnfoldingInfo`  (if no_unf then noUnfolding
+                                      else mkImplicitUnfolding rhs)
+       -- Experimental: NOINLINE, so that their rule matches
  
          -- We no longer use 'must-inline' on record selectors.  They'll
          -- inline like crazy if they scrutinise a constructor
  
  
          -- We no longer use 'must-inline' on record selectors.  They'll
          -- inline like crazy if they scrutinise a constructor
  
+    n_ty_args = length tyvars
+
+    -- This is the built-in rule that goes
+    --             op (dfT d1 d2) --->  opT d1 d2
+    rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` 
+                                    occNameFS (getOccName name)
+                       , ru_fn    = name
+                      , ru_nargs = n_ty_args + 1
+                       , ru_try   = dictSelRule index n_ty_args }
+
          -- The strictness signature is of the form U(AAAVAAAA) -> T
          -- where the V depends on which item we are selecting
          -- It's worth giving one, so that absence info etc is generated
          -- The strictness signature is of the form U(AAAVAAAA) -> T
          -- where the V depends on which item we are selecting
          -- It's worth giving one, so that absence info etc is generated
@@ -480,7 +493,8 @@ mkDictSelId no_unf name clas
      tyvars     = dataConUnivTyVars data_con
      arg_tys    = {- ASSERT( isVanillaDataCon data_con ) -} dataConRepArgTys data_con
      eq_theta   = dataConEqTheta data_con
      tyvars     = dataConUnivTyVars data_con
      arg_tys    = {- ASSERT( isVanillaDataCon data_con ) -} dataConRepArgTys data_con
      eq_theta   = dataConEqTheta data_con
-    the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name
+    index      = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` [0..]) name
+    the_arg_id = arg_ids !! index
  
      pred       = mkClassPred clas (mkTyVarTys tyvars)
      dict_id    = mkTemplateLocal     1 $ mkPredTy pred
  
      pred       = mkClassPred clas (mkTyVarTys tyvars)
      dict_id    = mkTemplateLocal     1 $ mkPredTy pred
@@ -496,6 +510,20 @@ mkDictSelId no_unf name clas
      rhs_body | isNewTyCon tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
               | otherwise        = Case (Var dict_id) dict_id (idType the_arg_id)
                                         [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)]
      rhs_body | isNewTyCon tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
               | otherwise        = Case (Var dict_id) dict_id (idType the_arg_id)
                                         [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)]
+
+dictSelRule :: Int -> Arity -> [CoreExpr] -> Maybe CoreExpr
+-- Oh, very clever
+--       op_i t1..tk (df s1..sn d1..dm) = op_i_helper s1..sn d1..dm
+--       op_i t1..tk (D t1..tk op1 ... opm) = opi
+--
+-- NB: the data constructor has the same number of type args as the class op
+
+dictSelRule index n_ty_args args
+  | (dict_arg : _) <- drop n_ty_args args
+  , Just (_, _, val_args) <- exprIsConApp_maybe dict_arg
+  = Just (val_args !! index)
+  | otherwise
+  = Nothing
  \end{code}
  
  
  \end{code}
  
  
@@ -825,8 +853,9 @@ mkDictFunId :: Name      -- Name to use for the dict fun;
              -> Id
  
  mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys
              -> Id
  
  mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys
-  = mkExportedLocalVar DFunId dfun_name dfun_ty vanillaIdInfo
+  = mkExportedLocalVar (DFunId is_nt) dfun_name dfun_ty vanillaIdInfo
    where
    where
+    is_nt = isNewTyCon (classTyCon clas)
      dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
  \end{code}
  
      dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
  \end{code}
  
@@ -934,7 +963,7 @@ c) It has quite a bit of desugaring magic.
  
  d) There is some special rule handing: Note [RULES for seq]
  
  
  d) There is some special rule handing: Note [RULES for seq]
  
-Note [Rules for seq]
+Note [RULES for seq]
  ~~~~~~~~~~~~~~~~~~~~
  Roman found situations where he had
        case (f n) of _ -> e
  ~~~~~~~~~~~~~~~~~~~~
  Roman found situations where he had
        case (f n) of _ -> e
diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs

index cb6785a..c3a1bd1 100644 (file)
--- a/compiler/basicTypes/Name.lhs
+++ b/compiler/basicTypes/Name.lhs
@@ -37,7 +37,7 @@ module Name (
         BuiltInSyntax(..),
  
         -- ** Creating 'Name's
         BuiltInSyntax(..),
  
         -- ** Creating 'Name's
-       mkInternalName, mkSystemName,
+       mkInternalName, mkSystemName, mkDerivedInternalName, 
         mkSystemVarName, mkSysTvName, 
         mkFCallName, mkIPName,
          mkTickBoxOpName,
         mkSystemVarName, mkSysTvName, 
         mkFCallName, mkIPName,
          mkTickBoxOpName,
@@ -249,6 +249,11 @@ mkInternalName uniq occ loc = Name { n_uniq = getKeyFastInt uniq, n_sort = Inter
         --      * for interface files we tidyCore first, which puts the uniques
         --        into the print name (see setNameVisibility below)
  
         --      * for interface files we tidyCore first, which puts the uniques
         --        into the print name (see setNameVisibility below)
  
+mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name
+mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc })
+  = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal
+         , n_occ = derive_occ occ, n_loc = loc }
+
  -- | Create a name which definitely originates in the given module
  mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name
  mkExternalName uniq mod occ loc 
  -- | Create a name which definitely originates in the given module
  mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name
  mkExternalName uniq mod occ loc 
diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs

index 3a2338e..a48922a 100644 (file)
--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -49,7 +49,7 @@ module OccName (
         -- ** Derived 'OccName's
          isDerivedOccName,
         mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc,
         -- ** Derived 'OccName's
          isDerivedOccName,
         mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc,
-       mkDerivedTyConOcc, mkNewTyCoOcc, 
+       mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc,
          mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
         mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, 
         mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
          mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
         mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, 
         mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
@@ -58,7 +58,7 @@ module OccName (
         mkInstTyCoOcc, mkEqPredCoOcc,
          mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc,
          mkPDataTyConOcc, mkPDataDataConOcc,
         mkInstTyCoOcc, mkEqPredCoOcc,
          mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc,
          mkPDataTyConOcc, mkPDataDataConOcc,
-        mkPReprTyConOcc,
+        mkPReprTyConOcc, 
          mkPADFunOcc,
  
         -- ** Deconstruction
          mkPADFunOcc,
  
         -- ** Deconstruction
@@ -526,7 +526,7 @@ mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc,
         mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, 
         mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
         mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
         mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, 
         mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
         mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
-       mkInstTyCoOcc, mkEqPredCoOcc, 
+       mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
          mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
         mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc,
         mkPDataTyConOcc, mkPDataDataConOcc, mkPReprTyConOcc, mkPADFunOcc
          mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
         mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc,
         mkPDataTyConOcc, mkPDataDataConOcc, mkPReprTyConOcc, mkPADFunOcc
@@ -536,6 +536,7 @@ mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc,
  mkDataConWrapperOcc = mk_simple_deriv varName  "$W"
  mkWorkerOcc         = mk_simple_deriv varName  "$w"
  mkDefaultMethodOcc  = mk_simple_deriv varName  "$dm"
  mkDataConWrapperOcc = mk_simple_deriv varName  "$W"
  mkWorkerOcc         = mk_simple_deriv varName  "$w"
  mkDefaultMethodOcc  = mk_simple_deriv varName  "$dm"
+mkClassOpAuxOcc     = mk_simple_deriv varName  "$c"
  mkDerivedTyConOcc   = mk_simple_deriv tcName   ":"     -- The : prefix makes sure it classifies
  mkClassTyConOcc     = mk_simple_deriv tcName   "T:"    -- as a tycon/datacon
  mkClassDataConOcc   = mk_simple_deriv dataName "D:"    -- We go straight to the "real" data con
  mkDerivedTyConOcc   = mk_simple_deriv tcName   ":"     -- The : prefix makes sure it classifies
  mkClassTyConOcc     = mk_simple_deriv tcName   "T:"    -- as a tycon/datacon
  mkClassDataConOcc   = mk_simple_deriv dataName "D:"    -- We go straight to the "real" data con
@@ -544,9 +545,9 @@ mkDictOcc       = mk_simple_deriv varName  "$d"
  mkIPOcc                    = mk_simple_deriv varName  "$i"
  mkSpecOcc          = mk_simple_deriv varName  "$s"
  mkForeignExportOcc  = mk_simple_deriv varName  "$f"
  mkIPOcc                    = mk_simple_deriv varName  "$i"
  mkSpecOcc          = mk_simple_deriv varName  "$s"
  mkForeignExportOcc  = mk_simple_deriv varName  "$f"
-mkNewTyCoOcc        = mk_simple_deriv tcName  "NTCo:"  -- Coercion for newtypes
-mkInstTyCoOcc       = mk_simple_deriv tcName  "TFCo:"   -- Coercion for type functions
-mkEqPredCoOcc      = mk_simple_deriv tcName  "$co"
+mkNewTyCoOcc        = mk_simple_deriv tcName   "NTCo:" -- Coercion for newtypes
+mkInstTyCoOcc       = mk_simple_deriv tcName   "TFCo:"   -- Coercion for type functions
+mkEqPredCoOcc      = mk_simple_deriv tcName   "$co"
  
  -- used in derived instances
  mkCon2TagOcc        = mk_simple_deriv varName  "$con2tag_"
  
  -- used in derived instances
  mkCon2TagOcc        = mk_simple_deriv varName  "$con2tag_"
diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs

index 28732b3..94297ad 100644 (file)
--- a/compiler/coreSyn/CoreArity.lhs
+++ b/compiler/coreSyn/CoreArity.lhs
@@ -8,7 +8,7 @@
  \begin{code}
  -- | Arit and eta expansion
  module CoreArity (
  \begin{code}
  -- | Arit and eta expansion
  module CoreArity (
-       manifestArity, exprArity, 
+       manifestArity, exprArity, exprBotStrictness_maybe,
         exprEtaExpandArity, etaExpand
      ) where
  
         exprEtaExpandArity, etaExpand
      ) where
  
@@ -138,6 +138,15 @@ exprEtaExpandArity dflags e
      = applyStateHack e (arityType dicts_cheap e)
    where
      dicts_cheap = dopt Opt_DictsCheap dflags
      = applyStateHack e (arityType dicts_cheap e)
    where
      dicts_cheap = dopt Opt_DictsCheap dflags
+
+exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig)
+-- A cheap and cheerful function that identifies bottoming functions
+-- and gives them a suitable strictness signatures.  It's used during
+-- float-out
+exprBotStrictness_maybe e
+  = case arityType False e of
+       AT _ ATop -> Nothing
+       AT a ABot -> Just (a, mkStrictSig (mkTopDmdType (replicate a topDmd) BotRes))
  \end{code}     
  
  Note [Definition of arity]
  \end{code}     
  
  Note [Definition of arity]
@@ -430,6 +439,13 @@ simplification but it's not too hard.  The alernative, of relying on
  a subsequent clean-up phase of the Simplifier to de-crapify the result,
  means you can't really use it in CorePrep, which is painful.
  
  a subsequent clean-up phase of the Simplifier to de-crapify the result,
  means you can't really use it in CorePrep, which is painful.
  
+Note [Eta expansion and SCCs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note that SCCs are not treated specially by etaExpand.  If we have
+       etaExpand 2 (\x -> scc "foo" e)
+       = (\xy -> (scc "foo" e) y)
+So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
+
  \begin{code}
  -- | @etaExpand n us e ty@ returns an expression with
  -- the same meaning as @e@, but with arity @n@.
  \begin{code}
  -- | @etaExpand n us e ty@ returns an expression with
  -- the same meaning as @e@, but with arity @n@.
@@ -444,11 +460,6 @@ means you can't really use it in CorePrep, which is painful.
  etaExpand :: Arity             -- ^ Result should have this number of value args
           -> CoreExpr           -- ^ Expression to expand
           -> CoreExpr
  etaExpand :: Arity             -- ^ Result should have this number of value args
           -> CoreExpr           -- ^ Expression to expand
           -> CoreExpr
--- Note that SCCs are not treated specially.  If we have
---     etaExpand 2 (\x -> scc "foo" e)
---     = (\xy -> (scc "foo" e) y)
--- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
-
  -- etaExpand deals with for-alls. For example:
  --             etaExpand 1 E
  -- where  E :: forall a. a -> a
  -- etaExpand deals with for-alls. For example:
  --             etaExpand 1 E
  -- where  E :: forall a. a -> a
@@ -468,7 +479,6 @@ etaExpand n orig_expr
      go 0 expr = expr
      go n (Lam v body) | isTyVar v = Lam v (go n     body)
                               | otherwise = Lam v (go (n-1) body)
      go 0 expr = expr
      go n (Lam v body) | isTyVar v = Lam v (go n     body)
                               | otherwise = Lam v (go (n-1) body)
-    go n (Note InlineMe expr) = Note InlineMe (go n expr)
      go n (Cast expr co) = Cast (go n expr) co
      go n expr           = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $
                                   etaInfoAbs etas (etaInfoApp subst' expr etas)
      go n (Cast expr co) = Cast (go n expr) co
      go n expr           = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $
                                   etaInfoAbs etas (etaInfoApp subst' expr etas)
diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs

index e2eb3a2..f94f61d 100644 (file)
--- a/compiler/coreSyn/CoreFVs.lhs
+++ b/compiler/coreSyn/CoreFVs.lhs
@@ -16,6 +16,7 @@ Taken quite directly from the Peyton Jones/Lester paper.
  module CoreFVs (
          -- * Free variables of expressions and binding groups
         exprFreeVars,   -- CoreExpr   -> VarSet -- Find all locally-defined free Ids or tyvars
  module CoreFVs (
          -- * Free variables of expressions and binding groups
         exprFreeVars,   -- CoreExpr   -> VarSet -- Find all locally-defined free Ids or tyvars
+       exprFreeIds,    -- CoreExpr   -> IdSet  -- Find all locally-defined free Ids
         exprsFreeVars,  -- [CoreExpr] -> VarSet
         bindFreeVars,   -- CoreBind   -> VarSet
  
         exprsFreeVars,  -- [CoreExpr] -> VarSet
         bindFreeVars,   -- CoreBind   -> VarSet
  
@@ -25,7 +26,9 @@ module CoreFVs (
         exprFreeNames, exprsFreeNames,
  
          -- * Free variables of Rules, Vars and Ids
         exprFreeNames, exprsFreeNames,
  
          -- * Free variables of Rules, Vars and Ids
-       idRuleVars, idFreeVars, varTypeTyVars, varTypeTcTyVars, 
+        varTypeTyVars, varTypeTcTyVars, 
+       idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
+       idRuleVars, idRuleRhsVars,
         ruleRhsFreeVars, rulesFreeVars,
         ruleLhsFreeNames, ruleLhsFreeIds, 
  
         ruleRhsFreeVars, rulesFreeVars,
         ruleLhsFreeNames, ruleLhsFreeIds, 
  
@@ -71,6 +74,10 @@ but not those that are free in the type of variable occurrence.
  exprFreeVars :: CoreExpr -> VarSet
  exprFreeVars = exprSomeFreeVars isLocalVar
  
  exprFreeVars :: CoreExpr -> VarSet
  exprFreeVars = exprSomeFreeVars isLocalVar
  
+-- | Find all locally-defined free Ids in an expression
+exprFreeIds :: CoreExpr -> IdSet       -- Find all locally-defined free Ids
+exprFreeIds = exprSomeFreeVars isLocalId
+
  -- | Find all locally-defined free Ids or type variables in several expressions
  exprsFreeVars :: [CoreExpr] -> VarSet
  exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet
  -- | Find all locally-defined free Ids or type variables in several expressions
  exprsFreeVars :: [CoreExpr] -> VarSet
  exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet
@@ -194,7 +201,8 @@ expr_fvs (Let (Rec pairs) body)
  
  ---------
  rhs_fvs :: (Id,CoreExpr) -> FV
  
  ---------
  rhs_fvs :: (Id,CoreExpr) -> FV
-rhs_fvs (bndr, rhs) = expr_fvs rhs `union` someVars (bndrRuleVars bndr)
+rhs_fvs (bndr, rhs) = expr_fvs rhs `union` 
+                      someVars (bndrRuleAndUnfoldingVars bndr)
         -- Treat any RULES as extra RHSs of the binding
  
  ---------
         -- Treat any RULES as extra RHSs of the binding
  
  ---------
@@ -271,6 +279,7 @@ ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs })
  
  -- | Those variables free in the both the left right hand sides of a rule
  ruleFreeVars :: CoreRule -> VarSet
  
  -- | Those variables free in the both the left right hand sides of a rule
  ruleFreeVars :: CoreRule -> VarSet
+ruleFreeVars (BuiltinRule {}) = noFVs
  ruleFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args })
    = delFromUFM fvs fn  -- Note [Rule free var hack]
    where
  ruleFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args })
    = delFromUFM fvs fn  -- Note [Rule free var hack]
    where
@@ -334,8 +343,8 @@ delBinderFV :: Var -> VarSet -> VarSet
  
  -- (b `delBinderFV` s) removes the binder b from the free variable set s,
  -- but *adds* to s
  
  -- (b `delBinderFV` s) removes the binder b from the free variable set s,
  -- but *adds* to s
---     (a) the free variables of b's type
---     (b) the idSpecVars of b
+--
+--     the free variables of b's type
  --
  -- This is really important for some lambdas:
  --     In (\x::a -> x) the only mention of "a" is in the binder.
  --
  -- This is really important for some lambdas:
  --     In (\x::a -> x) the only mention of "a" is in the binder.
@@ -378,14 +387,41 @@ varTypeTcTyVars var
    | otherwise = emptyVarSet    -- Global Ids and non-coercion TyVars
  
  idFreeVars :: Id -> VarSet
    | otherwise = emptyVarSet    -- Global Ids and non-coercion TyVars
  
  idFreeVars :: Id -> VarSet
-idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` varTypeTyVars id
-
-bndrRuleVars ::Var -> VarSet
-bndrRuleVars v | isTyVar v = emptyVarSet
-              | otherwise = idRuleVars v
-
-idRuleVars ::Id -> VarSet
+-- Type variables, rule variables, and inline variables
+idFreeVars id = ASSERT( isId id) 
+               varTypeTyVars id `unionVarSet`
+               idRuleAndUnfoldingVars id
+
+bndrRuleAndUnfoldingVars ::Var -> VarSet
+-- A 'let' can bind a type variable, and idRuleVars assumes 
+-- it's seeing an Id. This function tests first.
+bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet
+                          | otherwise = idRuleAndUnfoldingVars v
+
+idRuleAndUnfoldingVars :: Id -> VarSet
+idRuleAndUnfoldingVars id = ASSERT( isId id) 
+                           idRuleVars id    `unionVarSet` 
+                           idUnfoldingVars id
+
+idRuleVars ::Id -> VarSet  -- Does *not* include CoreUnfolding vars
  idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
  idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
+
+idRuleRhsVars :: Id -> VarSet   -- Does *not* include the CoreUnfolding vars
+-- Just the variables free on the *rhs* of a rule
+-- See Note [Choosing loop breakers] in Simplify.lhs
+idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars) 
+                        emptyVarSet
+                        (idCoreRules id)
+
+idUnfoldingVars :: Id -> VarSet
+-- Produce free vars for an unfolding, but NOT for an ordinary
+-- (non-inline) unfolding, since it is a dup of the rhs
+idUnfoldingVars id
+  = case idUnfolding id of
+      CoreUnfolding { uf_tmpl = rhs, uf_guidance = InlineRule {} }
+                          -> exprFreeVars rhs
+      DFunUnfolding _ args -> exprsFreeVars args
+      _                    -> emptyVarSet
  \end{code}
  
  
  \end{code}
  
  
@@ -436,7 +472,9 @@ freeVars (Case scrut bndr ty alts)
                              rhs2 = freeVars rhs
  
  freeVars (Let (NonRec binder rhs) body)
                              rhs2 = freeVars rhs
  
  freeVars (Let (NonRec binder rhs) body)
-  = (freeVarsOf rhs2 `unionFVs` body_fvs `unionFVs` bndrRuleVars binder,
+  = (freeVarsOf rhs2 
+       `unionFVs` body_fvs 
+       `unionFVs` bndrRuleAndUnfoldingVars binder,
                 -- Remember any rules; cf rhs_fvs above
       AnnLet (AnnNonRec binder rhs2) body2)
    where
                 -- Remember any rules; cf rhs_fvs above
       AnnLet (AnnNonRec binder rhs2) body2)
    where
@@ -452,7 +490,7 @@ freeVars (Let (Rec binds) body)
  
      rhss2     = map freeVars rhss
      rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2
  
      rhss2     = map freeVars rhss
      rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2
-    all_fvs      = foldr (unionFVs . idRuleVars) rhs_body_fvs binders
+    all_fvs      = foldr (unionFVs . idRuleAndUnfoldingVars) rhs_body_fvs binders
         -- The "delBinderFV" happens after adding the idSpecVars,
         -- since the latter may add some of the binders as fvs
  
         -- The "delBinderFV" happens after adding the idSpecVars,
         -- since the latter may add some of the binders as fvs
  
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs

index a3ba3ae..5156bbc 100644 (file)
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -7,11 +7,7 @@
  A ``lint'' pass to check for Core correctness
  
  \begin{code}
  A ``lint'' pass to check for Core correctness
  
  \begin{code}
-module CoreLint (
-       lintCoreBindings,
-       lintUnfolding, 
-       showPass, endPass, endPassIf, endIteration
-    ) where
+module CoreLint ( lintCoreBindings, lintUnfolding ) where
  
  #include "HsVersions.h"
  
  
  #include "HsVersions.h"
  
@@ -28,7 +24,6 @@ import VarEnv
  import VarSet
  import Name
  import Id
  import VarSet
  import Name
  import Id
-import IdInfo
  import PprCore
  import ErrUtils
  import SrcLoc
  import PprCore
  import ErrUtils
  import SrcLoc
@@ -47,43 +42,6 @@ import Data.Maybe
  
  %************************************************************************
  %*                                                                     *
  
  %************************************************************************
  %*                                                                     *
-\subsection{End pass}
-%*                                                                     *
-%************************************************************************
-
-@showPass@ and @endPass@ don't really belong here, but it makes a convenient
-place for them.  They print out stuff before and after core passes,
-and do Core Lint when necessary.
-
-\begin{code}
-endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
-endPass = dumpAndLint dumpIfSet_core
-
-endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
-endPassIf cond = dumpAndLint (dumpIf_core cond)
-
-endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
-endIteration = dumpAndLint dumpIfSet_dyn
-
-dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
-            -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
-dumpAndLint dump dflags pass_name dump_flag binds
-  = do 
-       -- Report result size if required
-       -- This has the side effect of forcing the intermediate to be evaluated
-       debugTraceMsg dflags 2 $
-               (text "    Result size =" <+> int (coreBindsSize binds))
-
-       -- Report verbosely, if required
-       dump dflags dump_flag pass_name (pprCoreBindings binds)
-
-       -- Type check
-       lintCoreBindings dflags pass_name binds
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
  \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
  %*                                                                     *
  %************************************************************************
  \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
  %*                                                                     *
  %************************************************************************
@@ -226,10 +184,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
     where
      binder_ty                  = idType binder
      maybeDmdTy                 = idNewStrictness_maybe binder
     where
      binder_ty                  = idType binder
      maybeDmdTy                 = idNewStrictness_maybe binder
-    bndr_vars                  = varSetElems (idFreeVars binder `unionVarSet` wkr_vars)
-    wkr_vars | workerExists wkr_info = unitVarSet (workerId wkr_info)
-            | otherwise             = emptyVarSet
-    wkr_info = idWorkerInfo binder
+    bndr_vars                  = varSetElems (idFreeVars binder)
      lintBinder var | isId var  = lintIdBndr var $ \_ -> (return ())
                    | otherwise = return ()
  \end{code}
      lintBinder var | isId var  = lintIdBndr var $ \_ -> (return ())
                    | otherwise = return ()
  \end{code}
diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs

index 2a5987c..36b6f5c 100644 (file)
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -15,7 +15,7 @@ import PrelNames      ( lazyIdKey, hasKey )
  import CoreUtils
  import CoreArity
  import CoreFVs
  import CoreUtils
  import CoreArity
  import CoreFVs
-import CoreLint
+import CoreMonad       ( endPass )
  import CoreSyn
  import Type
  import Coercion
  import CoreSyn
  import Type
  import Coercion
@@ -147,7 +147,7 @@ corePrepPgm dflags binds data_tycons = do
                        floats2 <- corePrepTopBinds implicit_binds
                        return (deFloatTop (floats1 `appendFloats` floats2))
  
                        floats2 <- corePrepTopBinds implicit_binds
                        return (deFloatTop (floats1 `appendFloats` floats2))
  
-    endPass dflags "CorePrep" Opt_D_dump_prep binds_out
+    endPass dflags "CorePrep" Opt_D_dump_prep binds_out []
      return binds_out
  
  corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
      return binds_out
  
  corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
@@ -640,7 +640,6 @@ ignoreNote :: Note -> Bool
  -- want to get this:
  --     unzip = /\ab \xs. (__inline_me__ ...) a b xs
  ignoreNote (CoreNote _) = True 
  -- want to get this:
  --     unzip = /\ab \xs. (__inline_me__ ...) a b xs
  ignoreNote (CoreNote _) = True 
-ignoreNote InlineMe     = True
  ignoreNote _other       = False
  
  
  ignoreNote _other       = False
  
  
diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs

index f63968e..f1f02d9 100644 (file)
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -11,12 +11,12 @@ module CoreSubst (
         Subst, TvSubstEnv, IdSubstEnv, InScopeSet,
  
          -- ** Substituting into expressions and related types
         Subst, TvSubstEnv, IdSubstEnv, InScopeSet,
  
          -- ** Substituting into expressions and related types
-       deShadowBinds,
-       substTy, substExpr, substBind, substSpec, substWorker,
-       lookupIdSubst, lookupTvSubst, 
+       deShadowBinds, substSpec, substRulesForImportedIds,
+       substTy, substExpr, substBind, substUnfolding,
+       substInlineRuleGuidance, lookupIdSubst, lookupTvSubst, substIdOcc,
  
          -- ** Operations on substitutions
  
          -- ** Operations on substitutions
-       emptySubst, mkEmptySubst, mkSubst, substInScope, isEmptySubst, 
+       emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, 
         extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList,
         extendSubst, extendSubstList, zapSubstEnv,
         extendInScope, extendInScopeList, extendInScopeIds, 
         extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList,
         extendSubst, extendSubstList, zapSubstEnv,
         extendInScope, extendInScopeList, extendInScopeIds, 
@@ -24,7 +24,10 @@ module CoreSubst (
  
         -- ** Substituting and cloning binders
         substBndr, substBndrs, substRecBndrs,
  
         -- ** Substituting and cloning binders
         substBndr, substBndrs, substRecBndrs,
-       cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs
+       cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs,
+
+       -- ** Simple expression optimiser
+       simpleOptExpr
      ) where
  
  #include "HsVersions.h"
      ) where
  
  #include "HsVersions.h"
@@ -32,12 +35,14 @@ module CoreSubst (
  import CoreSyn
  import CoreFVs
  import CoreUtils
  import CoreSyn
  import CoreFVs
  import CoreUtils
+import OccurAnal( occurAnalyseExpr )
  
  import qualified Type
  import Type     ( Type, TvSubst(..), TvSubstEnv )
  import VarSet
  import VarEnv
  import Id
  
  import qualified Type
  import Type     ( Type, TvSubst(..), TvSubstEnv )
  import VarSet
  import VarEnv
  import Id
+import Name    ( Name )
  import Var      ( Var, TyVar, setVarUnique )
  import IdInfo
  import Unique
  import Var      ( Var, TyVar, setVarUnique )
  import IdInfo
  import Unique
@@ -211,13 +216,22 @@ lookupIdSubst (Subst in_scope ids _) v
    | Just e  <- lookupVarEnv ids       v = e
    | Just v' <- lookupInScope in_scope v = Var v'
         -- Vital! See Note [Extending the Subst]
    | Just e  <- lookupVarEnv ids       v = e
    | Just v' <- lookupInScope in_scope v = Var v'
         -- Vital! See Note [Extending the Subst]
-  | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v ) 
+  | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v $$ ppr in_scope ) 
                 Var v
  
  -- | Find the substitution for a 'TyVar' in the 'Subst'
  lookupTvSubst :: Subst -> TyVar -> Type
  lookupTvSubst (Subst _ _ tvs) v = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v
  
                 Var v
  
  -- | Find the substitution for a 'TyVar' in the 'Subst'
  lookupTvSubst :: Subst -> TyVar -> Type
  lookupTvSubst (Subst _ _ tvs) v = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v
  
+-- | Simultaneously substitute for a bunch of variables
+--   No left-right shadowing
+--   ie the substitution for   (\x \y. e) a1 a2
+--      so neither x nor y scope over a1 a2
+mkOpenSubst :: [(Var,CoreArg)] -> Subst
+mkOpenSubst pairs = Subst (mkInScopeSet (exprsFreeVars (map snd pairs)))
+                         (mkVarEnv [(id,e)  | (id, e) <- pairs, isId id])
+                         (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs])
+
  ------------------------------
  isInScope :: Var -> Subst -> Bool
  isInScope v (Subst in_scope _ _) = v `elemInScopeSet` in_scope
  ------------------------------
  isInScope :: Var -> Subst -> Bool
  isInScope v (Subst in_scope _ _) = v `elemInScopeSet` in_scope
@@ -315,6 +329,9 @@ substBind subst (Rec pairs) = (subst', Rec pairs')
  --
  -- (Actually, within a single /type/ there might still be shadowing, because 
  -- 'substTy' is a no-op for the empty substitution, but that's probably OK.)
  --
  -- (Actually, within a single /type/ there might still be shadowing, because 
  -- 'substTy' is a no-op for the empty substitution, but that's probably OK.)
+--
+-- [Aug 09] This function is not used in GHC at the moment, but seems so 
+--          short and simple that I'm going to leave it here
  deShadowBinds :: [CoreBind] -> [CoreBind]
  deShadowBinds binds = snd (mapAccumL substBind emptySubst binds)
  \end{code}
  deShadowBinds :: [CoreBind] -> [CoreBind]
  deShadowBinds binds = snd (mapAccumL substBind emptySubst binds)
  \end{code}
@@ -474,49 +491,87 @@ substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo
  substIdInfo subst new_id info
    | nothing_to_do = Nothing
    | otherwise     = Just (info `setSpecInfo`             substSpec subst new_id old_rules
  substIdInfo subst new_id info
    | nothing_to_do = Nothing
    | otherwise     = Just (info `setSpecInfo`             substSpec subst new_id old_rules
-                              `setWorkerInfo`    substWorker subst old_wrkr
-                              `setUnfoldingInfo` noUnfolding)
+                              `setUnfoldingInfo` substUnfolding subst old_unf)
    where
      old_rules    = specInfo info
    where
      old_rules    = specInfo info
-    old_wrkr     = workerInfo info
-    nothing_to_do = isEmptySpecInfo old_rules &&
-                   not (workerExists old_wrkr) &&
-                   not (hasUnfolding (unfoldingInfo info))
+    old_unf      = unfoldingInfo info
+    nothing_to_do = isEmptySpecInfo old_rules && isClosedUnfolding old_unf
      
  
  ------------------
      
  
  ------------------
--- | Substitutes for the 'Id's within the 'WorkerInfo'
-substWorker :: Subst -> WorkerInfo -> WorkerInfo
-       -- Seq'ing on the returned WorkerInfo is enough to cause all the 
-       -- substitutions to happen completely
-
-substWorker _ NoWorker
-  = NoWorker
-substWorker subst (HasWorker w a)
-  = case lookupIdSubst subst w of
-       Var w1 -> HasWorker w1 a
-       other  -> WARN( not (exprIsTrivial other), text "CoreSubst.substWorker:" <+> ppr w )
-                 NoWorker      -- Worker has got substituted away altogether
-                               -- (This can happen if it's trivial, 
-                               --  via postInlineUnconditionally, hence warning)
+-- | Substitutes for the 'Id's within an unfolding
+substUnfolding :: Subst -> Unfolding -> Unfolding
+       -- Seq'ing on the returned Unfolding is enough to cause
+       -- all the substitutions to happen completely
+substUnfolding subst (DFunUnfolding con args)
+  = DFunUnfolding con (map (substExpr subst) args)
+
+substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_guidance = guide@(InlineRule {}) })
+       -- Retain an InlineRule!
+  = seqExpr new_tmpl `seq` 
+    new_mb_wkr `seq`
+    unf { uf_tmpl = new_tmpl, uf_guidance = guide { ug_ir_info = new_mb_wkr } }
+  where
+    new_tmpl   = substExpr subst tmpl
+    new_mb_wkr = substInlineRuleGuidance subst (ug_ir_info guide)
+
+substUnfolding _ (CoreUnfolding {}) = NoUnfolding      -- Discard
+       -- Always zap a CoreUnfolding, to save substitution work
+
+substUnfolding _ unf = unf     -- Otherwise no substitution to do
+
+-------------------
+substInlineRuleGuidance :: Subst -> InlineRuleInfo -> InlineRuleInfo
+substInlineRuleGuidance subst (InlWrapper wkr)
+  = case lookupIdSubst subst wkr of
+      Var w1 -> InlWrapper w1
+      other  -> WARN( not (exprIsTrivial other), text "CoreSubst.substWorker:" <+> ppr wkr )
+               InlUnSat   -- Worker has got substituted away altogether
+                          -- (This can happen if it's trivial, via
+                          --  postInlineUnconditionally, hence only warning)
+substInlineRuleGuidance _ info = info
+
+------------------
+substIdOcc :: Subst -> Id -> Id
+-- These Ids should not be substituted to non-Ids
+substIdOcc subst v = case lookupIdSubst subst v of
+                       Var v' -> v'
+                       other  -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst])
  
  ------------------
  -- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id'
  substSpec :: Subst -> Id -> SpecInfo -> SpecInfo
  
  ------------------
  -- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id'
  substSpec :: Subst -> Id -> SpecInfo -> SpecInfo
-substSpec subst new_fn (SpecInfo rules rhs_fvs)
-  = seqSpecInfo new_rules `seq` new_rules
+substSpec subst new_id (SpecInfo rules rhs_fvs)
+  = seqSpecInfo new_spec `seq` new_spec
    where
    where
-    new_name = idName new_fn
-    new_rules = SpecInfo (map do_subst rules) (substVarSet subst rhs_fvs)
-
-    do_subst rule@(BuiltinRule {}) = rule
-    do_subst rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
-       = rule { ru_bndrs = bndrs', 
-                ru_fn = new_name,      -- Important: the function may have changed its name!
-                ru_args  = map (substExpr subst') args,
-                ru_rhs   = substExpr subst' rhs }
-       where
-         (subst', bndrs') = substBndrs subst bndrs
+    subst_ru_fn = const (idName new_id)
+    new_spec = SpecInfo (map (substRule subst subst_ru_fn) rules)
+                         (substVarSet subst rhs_fvs)
+
+------------------
+substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule]
+substRulesForImportedIds subst rules 
+  = map (substRule subst (\name -> name)) rules
+
+------------------
+substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule
+
+-- The subst_ru_fn argument is applied to substitute the ru_fn field
+-- of the rule:
+--    - Rules for *imported* Ids never change ru_fn
+--    - Rules for *local* Ids are in the IdInfo for that Id,
+--      and the ru_fn field is simply replaced by the new name 
+--     of the Id
+
+substRule _ _ rule@(BuiltinRule {}) = rule
+substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
+                                       , ru_fn = fn_name, ru_rhs = rhs })
+  = rule { ru_bndrs = bndrs', 
+          ru_fn    = subst_ru_fn fn_name,
+          ru_args  = map (substExpr subst') args,
+          ru_rhs   = substExpr subst' rhs }
+  where
+    (subst', bndrs') = substBndrs subst bndrs
  
  ------------------
  substVarSet :: Subst -> VarSet -> VarSet
  
  ------------------
  substVarSet :: Subst -> VarSet -> VarSet
@@ -527,3 +582,103 @@ substVarSet subst fvs
         | isId fv   = exprFreeVars (lookupIdSubst subst fv)
         | otherwise = Type.tyVarsOfType (lookupTvSubst subst fv)
  \end{code}
         | isId fv   = exprFreeVars (lookupIdSubst subst fv)
         | otherwise = Type.tyVarsOfType (lookupTvSubst subst fv)
  \end{code}
+
+%************************************************************************
+%*                                                                     *
+       The Very Simple Optimiser
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+simpleOptExpr :: CoreExpr -> CoreExpr
+-- Do simple optimisation on an expression
+-- The optimisation is very straightforward: just
+-- inline non-recursive bindings that are used only once, 
+-- or where the RHS is trivial
+--
+-- The result is NOT guaranteed occurence-analysed, becuase
+-- in  (let x = y in ....) we substitute for x; so y's occ-info
+-- may change radically
+
+simpleOptExpr expr
+  = go init_subst (occurAnalyseExpr expr)
+  where
+    init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
+       -- It's potentially important to make a proper in-scope set
+       -- Consider  let x = ..y.. in \y. ...x...
+       -- Then we should remember to clone y before substituting
+       -- for x.  It's very unlikely to occur, because we probably
+       -- won't *be* substituting for x if it occurs inside a
+       -- lambda.  
+       --
+       -- It's a bit painful to call exprFreeVars, because it makes
+       -- three passes instead of two (occ-anal, and go)
+
+    go subst (Var v)          = lookupIdSubst subst v
+    go subst (App e1 e2)      = App (go subst e1) (go subst e2)
+    go subst (Type ty)        = Type (substTy subst ty)
+    go _     (Lit lit)        = Lit lit
+    go subst (Note note e)    = Note note (go subst e)
+    go subst (Cast e co)      = Cast (go subst e) (substTy subst co)
+    go subst (Let bind body)  = go_let subst bind body
+    go subst (Lam bndr body)  = Lam bndr' (go subst' body)
+                             where
+                               (subst', bndr') = substBndr subst bndr
+
+    go subst (Case e b ty as) = Case (go subst e) b' 
+                                    (substTy subst ty)
+                                    (map (go_alt subst') as)
+                             where
+                                (subst', b') = substBndr subst b
+
+
+    ----------------------
+    go_alt subst (con, bndrs, rhs) = (con, bndrs', go subst' rhs)
+                                where
+                                  (subst', bndrs') = substBndrs subst bndrs
+
+    ----------------------
+    go_let subst (Rec prs) body
+      = Let (Rec (reverse rev_prs')) (go subst'' body)
+      where
+       (subst', bndrs')    = substRecBndrs subst (map fst prs)
+       (subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs')
+       do_pr (subst, prs) ((b,r), b') = case go_bind subst b r of
+                                          Left subst' -> (subst', prs)
+                                          Right r'    -> (subst,  (b',r'):prs)
+
+    go_let subst (NonRec b r) body
+      = case go_bind subst b r of
+          Left subst' -> go subst' body
+         Right r'    -> Let (NonRec b' r') (go subst' body)
+                     where
+                        (subst', b') = substBndr subst b
+
+
+    ----------------------
+    go_bind :: Subst -> Var -> CoreExpr -> Either Subst CoreExpr
+        -- (go_bind subst old_var old_rhs)  
+       --   either extends subst with (old_var -> new_rhs)
+       --   or     return new_rhs for a binding new_var = new_rhs
+    go_bind subst b r
+      | Type ty <- r
+      , isTyVar b      -- let a::* = TYPE ty in <body>
+      = Left (extendTvSubst subst b (substTy subst ty))
+
+      | isId b         -- let x = e in <body>
+      , safe_to_inline (idOccInfo b) || exprIsTrivial r'
+      = Left (extendIdSubst subst b r')
+      
+      | otherwise
+      = Right r'
+      where
+        r' = go subst r
+
+    ----------------------
+       -- Unconditionally safe to inline
+    safe_to_inline :: OccInfo -> Bool
+    safe_to_inline IAmDead                  = True
+    safe_to_inline (OneOcc in_lam one_br _) = not in_lam && one_br
+    safe_to_inline (IAmALoopBreaker {})     = False
+    safe_to_inline NoOccInfo                = False
+\end{code}
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs

index 4d8f3cb..01e2be7 100644 (file)
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -35,16 +35,19 @@ module CoreSyn (
         isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
  
         -- * Unfolding data types
         isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
  
         -- * Unfolding data types
-       Unfolding(..),  UnfoldingGuidance(..),  -- Both abstract everywhere but in CoreUnfold.lhs
+       Unfolding(..),  UnfoldingGuidance(..), InlineRuleInfo(..),
+               -- Abstract everywhere but in CoreUnfold.lhs
         
         -- ** Constructing 'Unfolding's
         noUnfolding, evaldUnfolding, mkOtherCon,
         
         -- ** Predicates and deconstruction on 'Unfolding'
         
         -- ** Constructing 'Unfolding's
         noUnfolding, evaldUnfolding, mkOtherCon,
         
         -- ** Predicates and deconstruction on 'Unfolding'
-       unfoldingTemplate, maybeUnfoldingTemplate, otherCons, 
+       unfoldingTemplate, setUnfoldingTemplate,
+       maybeUnfoldingTemplate, otherCons, unfoldingArity,
         isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
         isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
-        isExpandableUnfolding, isCompulsoryUnfolding,
-       hasUnfolding, hasSomeUnfolding, neverUnfold,
+        isExpandableUnfolding, 
+       isInlineRule, isInlineRule_maybe, isClosedUnfolding, hasSomeUnfolding, 
+       isStableUnfolding, canUnfold, neverUnfoldGuidance,
  
         -- * Strictness
         seqExpr, seqExprs, seqUnfolding, 
  
         -- * Strictness
         seqExpr, seqExprs, seqUnfolding, 
@@ -272,21 +275,7 @@ See #type_let#
  -- | Allows attaching extra information to points in expressions rather than e.g. identifiers.
  data Note
    = SCC CostCentre      -- ^ A cost centre annotation for profiling
  -- | Allows attaching extra information to points in expressions rather than e.g. identifiers.
  data Note
    = SCC CostCentre      -- ^ A cost centre annotation for profiling
-
-  | InlineMe           -- ^ Instructs the core simplifer to treat the enclosed expression
-                       -- as very small, and inline it at its call sites
-
    | CoreNote String     -- ^ A generic core annotation, propagated but not used by GHC
    | CoreNote String     -- ^ A generic core annotation, propagated but not used by GHC
-
--- NOTE: we also treat expressions wrapped in InlineMe as
--- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable)
--- What this means is that we obediently inline even things that don't
--- look like valuse.  This is sometimes important:
---     {-# INLINE f #-}
---     f = g . h
--- Here, f looks like a redex, and we aren't going to inline (.) because it's
--- inside an INLINE, so it'll stay looking like a redex.  Nevertheless, we 
--- should inline f even inside lambdas.  In effect, we should trust the programmer.
  \end{code}
  
  
  \end{code}
  
  
@@ -324,6 +313,8 @@ data CoreRule
         
         -- And the right-hand side
         ru_rhs   :: CoreExpr,           -- ^ Right hand side of the rule
         
         -- And the right-hand side
         ru_rhs   :: CoreExpr,           -- ^ Right hand side of the rule
+                                       -- Occurrence info is guaranteed correct
+                                       -- See Note [OccInfo in unfoldings and rules]
  
         -- Locality
         ru_local :: Bool        -- ^ @True@ iff the fn at the head of the rule is
  
         -- Locality
         ru_local :: Bool        -- ^ @True@ iff the fn at the head of the rule is
@@ -338,10 +329,10 @@ data CoreRule
    -- | Built-in rules are used for constant folding
    -- and suchlike.  They have no free variables.
    | BuiltinRule {               
    -- | Built-in rules are used for constant folding
    -- and suchlike.  They have no free variables.
    | BuiltinRule {               
-       ru_name :: RuleName,    -- ^ As above
-       ru_fn :: Name,          -- ^ As above
-       ru_nargs :: Int,        -- ^ Number of arguments that 'ru_try' expects,
-                               -- including type arguments
+       ru_name  :: RuleName,   -- ^ As above
+       ru_fn    :: Name,       -- ^ As above
+       ru_nargs :: Int,        -- ^ Number of arguments that 'ru_try' consumes,
+                               -- if it fires, including type arguments
         ru_try  :: [CoreExpr] -> Maybe CoreExpr
                 -- ^ This function does the rewrite.  It given too many
                 -- arguments, it simply discards them; the returned 'CoreExpr'
         ru_try  :: [CoreExpr] -> Maybe CoreExpr
                 -- ^ This function does the rewrite.  It given too many
                 -- arguments, it simply discards them; the returned 'CoreExpr'
@@ -392,59 +383,105 @@ The @Unfolding@ type is declared here to avoid numerous loops
  -- identifier would have if we substituted its definition in for the identifier.
  -- This type should be treated as abstract everywhere except in "CoreUnfold"
  data Unfolding
  -- identifier would have if we substituted its definition in for the identifier.
  -- This type should be treated as abstract everywhere except in "CoreUnfold"
  data Unfolding
-  = NoUnfolding                 -- ^ We have no information about the unfolding
-
-  | OtherCon [AltCon]          -- ^ It ain't one of these constructors.
-                               -- @OtherCon xs@ also indicates that something has been evaluated
-                               -- and hence there's no point in re-evaluating it.
-                               -- @OtherCon []@ is used even for non-data-type values
-                               -- to indicated evaluated-ness.  Notably:
-                               --
-                               -- > data C = C !(Int -> Int)
-                               -- > case x of { C f -> ... }
-                               --
-                               -- Here, @f@ gets an @OtherCon []@ unfolding.
-
-  | CompulsoryUnfolding CoreExpr       -- ^ There is /no original definition/,
-                                       -- so you'd better unfold.
-
-  | CoreUnfolding
-               CoreExpr
-               Bool
-               Bool
-               Bool
-                Bool
-               UnfoldingGuidance
+  = NoUnfolding        -- ^ We have no information about the unfolding
+
+  | OtherCon [AltCon]  -- ^ It ain't one of these constructors.
+                      -- @OtherCon xs@ also indicates that something has been evaluated
+                      -- and hence there's no point in re-evaluating it.
+                      -- @OtherCon []@ is used even for non-data-type values
+                      -- to indicated evaluated-ness.  Notably:
+                      --
+                      -- > data C = C !(Int -> Int)
+                      -- > case x of { C f -> ... }
+                      --
+                      -- Here, @f@ gets an @OtherCon []@ unfolding.
+
+  | DFunUnfolding DataCon [CoreExpr]   
+                        -- The Unfolding of a DFunId
+                       --     df = /\a1..am. \d1..dn. MkD (op1 a1..am d1..dn)
+                       --                                 (op2 a1..am d1..dn)
+                       -- where Arity = n, the number of dict args to the dfun
+                       -- The [CoreExpr] are the superclasses and methods [op1,op2], 
+                       -- in positional order.
+                       -- They are usually variables, but can be trivial expressions
+                       -- instead (e.g. a type application).  
+
+  | CoreUnfolding {            -- An unfolding for an Id with no pragma, or perhaps a NOINLINE pragma
+                               -- (For NOINLINE, the phase, if any, is in the InlinePragInfo for this Id.)
+       uf_tmpl       :: CoreExpr,      -- Template; occurrence info is correct
+       uf_arity      :: Arity,         -- Number of value arguments expected
+       uf_is_top     :: Bool,          -- True <=> top level binding
+       uf_is_value   :: Bool,          -- exprIsHNF template (cached); it is ok to discard a `seq` on
+                                       --      this variable
+       uf_is_cheap   :: Bool,          -- True <=> doesn't waste (much) work to expand inside an inlining
+                                       --      Cached version of exprIsCheap
+       uf_expandable :: Bool,          -- True <=> can expand in RULE matching
+                                       --      Cached version of exprIsExpandable
+       uf_guidance   :: UnfoldingGuidance      -- Tells about the *size* of the template.
+    }
    -- ^ An unfolding with redundant cached information. Parameters:
    --
    -- ^ An unfolding with redundant cached information. Parameters:
    --
-  --  1) Template used to perform unfolding; binder-info is correct
+  --  uf_tmpl: Template used to perform unfolding; 
+  --           NB: Occurrence info is guaranteed correct: 
+  --              see Note [OccInfo in unfoldings and rules]
    --
    --
-  --  2) Is this a top level binding?
+  --  uf_is_top: Is this a top level binding?
    --
    --
-  --  3) 'exprIsHNF' template (cached); it is ok to discard a 'seq' on
+  --  uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on
    --     this variable
    --
    --     this variable
    --
-  --  4) Does this waste only a little work if we expand it inside an inlining?
+  --  uf_is_cheap:  Does this waste only a little work if we expand it inside an inlining?
    --     Basically this is a cached version of 'exprIsCheap'
    --
    --     Basically this is a cached version of 'exprIsCheap'
    --
-  --  5) Tells us about the /size/ of the unfolding template
+  --  uf_guidance:  Tells us about the /size/ of the unfolding template
  
  
--- | When unfolding should take place
+------------------------------------------------
+-- | 'UnfoldingGuidance' says when unfolding should take place
  data UnfoldingGuidance
  data UnfoldingGuidance
-  = UnfoldNever
-  | UnfoldIfGoodArgs   Int     -- and "n" value args
-
-                       [Int]   -- Discount if the argument is evaluated.
-                               -- (i.e., a simplification will definitely
-                               -- be possible).  One elt of the list per *value* arg.
-
-                       Int     -- The "size" of the unfolding; to be elaborated
-                               -- later. ToDo
-
-                       Int     -- Scrutinee discount: the discount to substract if the thing is in
-                               -- a context (case (thing args) of ...),
-                               -- (where there are the right number of arguments.)
-
+  = UnfoldAlways       -- There is /no original definition/, so you'd better unfold.
+                       -- The unfolding is guaranteed to have no free variables
+                       -- so no need to think about it during dependency analysis
+
+  | InlineRule {       -- See Note [InlineRules]
+                        -- Be very keen to inline this
+                       -- The uf_tmpl is the *original* RHS; do *not* replace it on
+                       --   each simlifier run.  Hence, the *actual* RHS of the function 
+                       --   may be different by now, because it may have been optimised.
+      ug_ir_info :: InlineRuleInfo,    -- Supplementary info about the InlineRule
+      ug_small :: Bool                 -- True <=> the RHS is so small (eg no bigger than a call) 
+                                       --          that you should always inline a saturated call,
+    }                                  --           regardless of how boring the context is
+                                       -- See Note [INLINE for small functions] in CoreUnfold]
+
+  | UnfoldIfGoodArgs { -- Arose from a normal Id; the info here is the
+                       -- result of a simple analysis of the RHS
+
+      ug_args ::  [Int],  -- Discount if the argument is evaluated.
+                         -- (i.e., a simplification will definitely
+                         -- be possible).  One elt of the list per *value* arg.
+
+      ug_size :: Int,    -- The "size" of the unfolding.
+
+      ug_res :: Int      -- Scrutinee discount: the discount to substract if the thing is in
+    }                    -- a context (case (thing args) of ...),
+                         -- (where there are the right number of arguments.)
+
+  | UnfoldNever
+
+data InlineRuleInfo
+  = InlSat             -- A user-specifed or compiler injected INLINE pragma
+                       -- ONLY inline when it's applied to 'arity' arguments
+
+  | InlUnSat           -- The compiler decided to "capture" the RHS into an
+                       -- InlineRule, but do not require that it appears saturated
+
+  | InlWrapper Id      -- This unfolding is a the wrapper in a 
+                       --     worker/wrapper split from the strictness analyser
+                       -- Used to abbreviate the uf_tmpl in interface files
+                       --      which don't need to contain the RHS; 
+                       --      it can be derived from the strictness info
+
+------------------------------------------------
  noUnfolding :: Unfolding
  -- ^ There is no known 'Unfolding'
  evaldUnfolding :: Unfolding
  noUnfolding :: Unfolding
  -- ^ There is no known 'Unfolding'
  evaldUnfolding :: Unfolding
@@ -457,27 +494,30 @@ mkOtherCon :: [AltCon] -> Unfolding
  mkOtherCon = OtherCon
  
  seqUnfolding :: Unfolding -> ()
  mkOtherCon = OtherCon
  
  seqUnfolding :: Unfolding -> ()
-seqUnfolding (CoreUnfolding e top b1 b2 b3 g)
-  = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` seqGuidance g
+seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, 
+               uf_is_value = b1, uf_is_cheap = b2, 
+               uf_expandable = b3, uf_arity = a, uf_guidance = g})
+  = seqExpr e `seq` top `seq` b1 `seq` a `seq` b2 `seq` b3 `seq` seqGuidance g
+
  seqUnfolding _ = ()
  
  seqGuidance :: UnfoldingGuidance -> ()
  seqUnfolding _ = ()
  
  seqGuidance :: UnfoldingGuidance -> ()
-seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
-seqGuidance _                           = ()
+seqGuidance (UnfoldIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` ()
+seqGuidance _                         = ()
  \end{code}
  
  \begin{code}
  -- | Retrieves the template of an unfolding: panics if none is known
  unfoldingTemplate :: Unfolding -> CoreExpr
  \end{code}
  
  \begin{code}
  -- | Retrieves the template of an unfolding: panics if none is known
  unfoldingTemplate :: Unfolding -> CoreExpr
-unfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = expr
-unfoldingTemplate (CompulsoryUnfolding expr)     = expr
-unfoldingTemplate _ = panic "getUnfoldingTemplate"
+unfoldingTemplate = uf_tmpl
+
+setUnfoldingTemplate :: Unfolding -> CoreExpr -> Unfolding
+setUnfoldingTemplate unf rhs = unf { uf_tmpl = rhs }
  
  -- | Retrieves the template of an unfolding if possible
  maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
  
  -- | Retrieves the template of an unfolding if possible
  maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
-maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = Just expr
-maybeUnfoldingTemplate (CompulsoryUnfolding expr)     = Just expr
-maybeUnfoldingTemplate _                              = Nothing
+maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr })       = Just expr
+maybeUnfoldingTemplate _                                       = Nothing
  
  -- | The constructors that the unfolding could never be: 
  -- returns @[]@ if no information is available
  
  -- | The constructors that the unfolding could never be: 
  -- returns @[]@ if no information is available
@@ -488,51 +528,106 @@ otherCons _               = []
  -- | Determines if it is certainly the case that the unfolding will
  -- yield a value (something in HNF): returns @False@ if unsure
  isValueUnfolding :: Unfolding -> Bool
  -- | Determines if it is certainly the case that the unfolding will
  -- yield a value (something in HNF): returns @False@ if unsure
  isValueUnfolding :: Unfolding -> Bool
-isValueUnfolding (CoreUnfolding _ _ is_evald _ _ _) = is_evald
-isValueUnfolding _                                  = False
+       -- Returns False for OtherCon
+isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
+isValueUnfolding _                                          = False
  
  -- | Determines if it possibly the case that the unfolding will
  -- yield a value. Unlike 'isValueUnfolding' it returns @True@
  -- for 'OtherCon'
  isEvaldUnfolding :: Unfolding -> Bool
  
  -- | Determines if it possibly the case that the unfolding will
  -- yield a value. Unlike 'isValueUnfolding' it returns @True@
  -- for 'OtherCon'
  isEvaldUnfolding :: Unfolding -> Bool
-isEvaldUnfolding (OtherCon _)                      = True
-isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _ _) = is_evald
-isEvaldUnfolding _                                  = False
+       -- Returns True for OtherCon
+isEvaldUnfolding (OtherCon _)                              = True
+isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
+isEvaldUnfolding _                                          = False
  
  -- | Is the thing we will unfold into certainly cheap?
  isCheapUnfolding :: Unfolding -> Bool
  
  -- | Is the thing we will unfold into certainly cheap?
  isCheapUnfolding :: Unfolding -> Bool
-isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _ _) = is_cheap
-isCheapUnfolding _                                  = False
+isCheapUnfolding (CoreUnfolding { uf_is_cheap = is_cheap }) = is_cheap
+isCheapUnfolding _                                          = False
  
  isExpandableUnfolding :: Unfolding -> Bool
  
  isExpandableUnfolding :: Unfolding -> Bool
-isExpandableUnfolding (CoreUnfolding _ _ _ _ is_expable _) = is_expable
-isExpandableUnfolding _                                    = False
+isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable
+isExpandableUnfolding _                                              = False
+
+isInlineRule :: Unfolding -> Bool
+isInlineRule (CoreUnfolding { uf_guidance = InlineRule {}}) = True
+isInlineRule _                                             = False
+
+isInlineRule_maybe :: Unfolding -> Maybe InlineRuleInfo
+isInlineRule_maybe (CoreUnfolding {
+                       uf_guidance = InlineRule { ug_ir_info = inl } }) = Just inl
+isInlineRule_maybe _                                                   = Nothing
  
  
--- | Must this unfolding happen for the code to be executable?
-isCompulsoryUnfolding :: Unfolding -> Bool
-isCompulsoryUnfolding (CompulsoryUnfolding _) = True
-isCompulsoryUnfolding _                       = False
+isStableUnfolding :: Unfolding -> Bool
+-- True of unfoldings that should not be overwritten 
+-- by a CoreUnfolding for the RHS of a let-binding
+isStableUnfolding (CoreUnfolding { uf_guidance = InlineRule {} }) = True
+isStableUnfolding (DFunUnfolding {})                             = True
+isStableUnfolding _                                               = False
  
  
--- | Do we have an available or compulsory unfolding?
-hasUnfolding :: Unfolding -> Bool
-hasUnfolding (CoreUnfolding _ _ _ _ _ _) = True
-hasUnfolding (CompulsoryUnfolding _)     = True
-hasUnfolding _                           = False
+unfoldingArity :: Unfolding -> Arity
+unfoldingArity (CoreUnfolding { uf_arity = arity }) = arity
+unfoldingArity _                                   = panic "unfoldingArity"
+
+isClosedUnfolding :: Unfolding -> Bool         -- No free variables
+isClosedUnfolding (CoreUnfolding {}) = False
+isClosedUnfolding _                  = True
  
  -- | Only returns False if there is no unfolding information available at all
  hasSomeUnfolding :: Unfolding -> Bool
  hasSomeUnfolding NoUnfolding = False
  hasSomeUnfolding _           = True
  
  
  -- | Only returns False if there is no unfolding information available at all
  hasSomeUnfolding :: Unfolding -> Bool
  hasSomeUnfolding NoUnfolding = False
  hasSomeUnfolding _           = True
  
--- | Similar to @not . hasUnfolding@, but also returns @True@
--- if it has an unfolding that says it should never occur
-neverUnfold :: Unfolding -> Bool
-neverUnfold NoUnfolding                                  = True
-neverUnfold (OtherCon _)                         = True
-neverUnfold (CoreUnfolding _ _ _ _ _ UnfoldNever) = True
-neverUnfold _                                     = False
+neverUnfoldGuidance :: UnfoldingGuidance -> Bool
+neverUnfoldGuidance UnfoldNever = True
+neverUnfoldGuidance _           = False
+
+canUnfold :: Unfolding -> Bool
+canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g)
+canUnfold _                                  = False
  \end{code}
  
  \end{code}
  
+Note [InlineRule]
+~~~~~~~~~~~~~~~~~
+When you say 
+      {-# INLINE f #-}
+      f x = <rhs>
+you intend that calls (f e) are replaced by <rhs>[e/x] So we
+should capture (\x.<rhs>) in the Unfolding of 'f', and never meddle
+with it.  Meanwhile, we can optimise <rhs> to our heart's content,
+leaving the original unfolding intact in Unfolding of 'f'.
+
+So the representation of an Unfolding has changed quite a bit
+(see CoreSyn).  An INLINE pragma gives rise to an InlineRule 
+unfolding.  
+
+Moreover, it's only used when 'f' is applied to the
+specified number of arguments; that is, the number of argument on 
+the LHS of the '=' sign in the original source definition. 
+For example, (.) is now defined in the libraries like this
+   {-# INLINE (.) #-}
+   (.) f g = \x -> f (g x)
+so that it'll inline when applied to two arguments. If 'x' appeared
+on the left, thus
+   (.) f g x = f (g x)
+it'd only inline when applied to three arguments.  This slightly-experimental
+change was requested by Roman, but it seems to make sense.
+
+See also Note [Inlining an InlineRule] in CoreUnfold.
+
+
+Note [OccInfo in unfoldings and rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In unfoldings and rules, we guarantee that the template is occ-analysed,
+so that the occurence info on the binders is correct.  This is important,
+because the Simplifier does not re-analyse the template when using it. If
+the occurrence info is wrong
+  - We may get more simpifier iterations than necessary, because
+    once-occ info isn't there
+  - More seriously, we may get an infinite loop if there's a Rec
+    without a loop breaker marked
+
  
  %************************************************************************
  %*                                                                     *
  
  %************************************************************************
  %*                                                                     *
diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs

index ff68b12..f634197 100644 (file)
--- a/compiler/coreSyn/CoreTidy.lhs
+++ b/compiler/coreSyn/CoreTidy.lhs
@@ -153,7 +153,7 @@ tidyLetBndr env (id,rhs)
         -- separate compilation boundaries
      final_id = new_id `setIdInfo` new_info
      idinfo   = idInfo id
         -- separate compilation boundaries
      final_id = new_id `setIdInfo` new_info
      idinfo   = idInfo id
-    new_info = vanillaIdInfo
+    new_info = idInfo new_id
                 `setArityInfo`          exprArity rhs
                 `setAllStrictnessInfo`  newStrictnessInfo idinfo
                 `setNewDemandInfo`      newDemandInfo idinfo
                 `setArityInfo`          exprArity rhs
                 `setAllStrictnessInfo`  newStrictnessInfo idinfo
                 `setNewDemandInfo`      newDemandInfo idinfo
@@ -166,7 +166,7 @@ tidyLetBndr env (id,rhs)
  -- Non-top-level variables
  tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)
  tidyIdBndr env@(tidy_env, var_env) id
  -- Non-top-level variables
  tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)
  tidyIdBndr env@(tidy_env, var_env) id
-  = -- do this pattern match strictly, otherwise we end up holding on to
+  = -- Do this pattern match strictly, otherwise we end up holding on to
      -- stuff in the OccName.
      case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> 
      let 
      -- stuff in the OccName.
      case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> 
      let 
@@ -174,24 +174,36 @@ tidyIdBndr env@(tidy_env, var_env) id
         -- The SrcLoc isn't important now, 
         -- though we could extract it from the Id
         -- 
         -- The SrcLoc isn't important now, 
         -- though we could extract it from the Id
         -- 
-       -- All nested Ids now have the same IdInfo, namely vanillaIdInfo,
-       -- which should save some space; except that we hang onto dead-ness
-       -- (at the moment, solely to make printing tidy core nicer)
-       -- But note that tidyLetBndr puts some of it back.
          ty'      = tidyType env (idType id)
          name'    = mkInternalName (idUnique id) occ' noSrcSpan
         id'      = mkLocalIdWithInfo name' ty' new_info
         var_env' = extendVarEnv var_env id id'
          ty'      = tidyType env (idType id)
          name'    = mkInternalName (idUnique id) occ' noSrcSpan
         id'      = mkLocalIdWithInfo name' ty' new_info
         var_env' = extendVarEnv var_env id id'
-        new_info | isDeadOcc (idOccInfo id) = deadIdInfo
-                | otherwise                = vanillaIdInfo
+
+       -- Note [Tidy IdInfo]
+        new_info = vanillaIdInfo `setOccInfo` occInfo old_info
+       old_info = idInfo id
      in
      in
-     ((tidy_env', var_env'), id')
+    ((tidy_env', var_env'), id')
     }
     }
-
-deadIdInfo :: IdInfo
-deadIdInfo = vanillaIdInfo `setOccInfo` IAmDead
  \end{code}
  
  \end{code}
  
+Note [Tidy IdInfo]
+~~~~~~~~~~~~~~~~~~
+All nested Ids now have the same IdInfo, namely vanillaIdInfo, which
+should save some space; except that we preserve occurrence info for
+two reasons:
+
+  (a) To make printing tidy core nicer
+
+  (b) Because we tidy RULES and InlineRules, which may then propagate
+      via --make into the compilation of the next module, and we want
+      the benefit of that occurrence analysis when we use the rule or
+      or inline the function.  In particular, it's vital not to lose
+      loop-breaker info, else we get an infinite inlining loop
+      
+Note that tidyLetBndr puts more IdInfo back.
+
+
  \begin{code}
  (=:) :: a -> (a -> b) -> b
  m =: k = m `seq` k m
  \begin{code}
  (=:) :: a -> (a -> b) -> b
  m =: k = m `seq` k m
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs

index 0c7e9e4..f32d5b1 100644 (file)
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -18,12 +18,10 @@ find, unsurprisingly, a Core expression.
  module CoreUnfold (
         Unfolding, UnfoldingGuidance,   -- Abstract types
  
  module CoreUnfold (
         Unfolding, UnfoldingGuidance,   -- Abstract types
  
-       noUnfolding, mkTopUnfolding, mkImplicitUnfolding, mkUnfolding, 
-       mkCompulsoryUnfolding, seqUnfolding,
-       evaldUnfolding, mkOtherCon, otherCons,
-       unfoldingTemplate, maybeUnfoldingTemplate,
-       isEvaldUnfolding, isValueUnfolding, isExpandableUnfolding, isCompulsoryUnfolding,
-       hasUnfolding, hasSomeUnfolding, neverUnfold,
+       noUnfolding, mkImplicitUnfolding, 
+       mkTopUnfolding, mkUnfolding, mkCoreUnfolding,
+       mkInlineRule, mkWwInlineRule,
+       mkCompulsoryUnfolding, mkDFunUnfolding,
  
         interestingArg, ArgSummary(..),
  
  
         interestingArg, ArgSummary(..),
  
@@ -32,24 +30,32 @@ module CoreUnfold (
  
         callSiteInline, CallCtxt(..), 
  
  
         callSiteInline, CallCtxt(..), 
  
+       exprIsConApp_maybe
+
      ) where
  
      ) where
  
+#include "HsVersions.h"
+
  import StaticFlags
  import DynFlags
  import CoreSyn
  import PprCore         ()      -- Instances
  import OccurAnal
  import StaticFlags
  import DynFlags
  import CoreSyn
  import PprCore         ()      -- Instances
  import OccurAnal
-import CoreSubst       ( Subst, emptySubst, substTy, extendIdSubst, extendTvSubst
-                       , lookupIdSubst, substBndr, substBndrs, substRecBndrs )
+import CoreSubst hiding( substTy )
  import CoreUtils
  import Id
  import DataCon
  import CoreUtils
  import Id
  import DataCon
+import TyCon
  import Literal
  import PrimOp
  import IdInfo
  import Literal
  import PrimOp
  import IdInfo
-import Type hiding( substTy, extendTvSubst )
+import BasicTypes      ( Arity )
+import TcType          ( tcSplitDFunTy )
+import Type 
+import Coercion
  import PrelNames
  import Bag
  import PrelNames
  import Bag
+import Util
  import FastTypes
  import FastString
  import Outputable
  import FastTypes
  import FastString
  import Outputable
@@ -69,28 +75,34 @@ mkTopUnfolding expr = mkUnfolding True {- Top level -} expr
  
  mkImplicitUnfolding :: CoreExpr -> Unfolding
  -- For implicit Ids, do a tiny bit of optimising first
  
  mkImplicitUnfolding :: CoreExpr -> Unfolding
  -- For implicit Ids, do a tiny bit of optimising first
-mkImplicitUnfolding expr 
-  = CoreUnfolding (simpleOptExpr emptySubst expr)
-                 True
-                 (exprIsHNF expr)
-                  (exprIsCheap expr)
-                  (exprIsExpandable expr)
-                 (calcUnfoldingGuidance opt_UF_CreationThreshold expr)
-
-mkUnfolding :: Bool -> CoreExpr -> Unfolding
-mkUnfolding top_lvl expr
-  = CoreUnfolding (occurAnalyseExpr expr)
-                 top_lvl
-
-                 (exprIsHNF expr)
-                       -- Already evaluated
+mkImplicitUnfolding expr = mkTopUnfolding (simpleOptExpr expr)
  
  
-                 (exprIsCheap expr)
-                       -- OK to inline inside a lambda
+mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
+mkWwInlineRule id = mkInlineRule (InlWrapper id)
  
  
-                  (exprIsExpandable expr)
+mkInlineRule :: InlineRuleInfo -> CoreExpr -> Arity -> Unfolding
+mkInlineRule inl_info expr arity 
+  = mkCoreUnfolding True        -- Note [Top-level flag on inline rules]
+                   expr' arity 
+                   (InlineRule { ug_ir_info = inl_info, ug_small = small })
+  where
+    expr' = simpleOptExpr expr
+    small = case calcUnfoldingGuidance (arity+1) expr' of
+              (arity_e, UnfoldIfGoodArgs { ug_size = size_e }) 
+                   -> uncondInline arity_e size_e
+              _other {- actually UnfoldNever -} -> False
+
+-- Note [Top-level flag on inline rules]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Slight hack: note that mk_inline_rules conservatively sets the
+-- top-level flag to True.  It gets set more accurately by the simplifier
+-- Simplify.simplUnfolding.
  
  
-                 (calcUnfoldingGuidance opt_UF_CreationThreshold expr)
+mkUnfolding :: Bool -> CoreExpr -> Unfolding
+mkUnfolding top_lvl expr
+  = mkCoreUnfolding top_lvl expr arity guidance
+  where
+    (arity, guidance) = calcUnfoldingGuidance opt_UF_CreationThreshold expr
         -- Sometimes during simplification, there's a large let-bound thing     
         -- which has been substituted, and so is now dead; so 'expr' contains
         -- two copies of the thing while the occurrence-analysed expression doesn't
         -- Sometimes during simplification, there's a large let-bound thing     
         -- which has been substituted, and so is now dead; so 'expr' contains
         -- two copies of the thing while the occurrence-analysed expression doesn't
@@ -100,17 +112,23 @@ mkUnfolding top_lvl expr
         -- This can occasionally mean that the guidance is very pessimistic;
         -- it gets fixed up next round
  
         -- This can occasionally mean that the guidance is very pessimistic;
         -- it gets fixed up next round
  
-instance Outputable Unfolding where
-  ppr NoUnfolding = ptext (sLit "No unfolding")
-  ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs
-  ppr (CompulsoryUnfolding e) = ptext (sLit "Compulsory") <+> ppr e
-  ppr (CoreUnfolding e top hnf cheap expable g) 
-       = ptext (sLit "Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr expable <+> ppr g, 
-                                    ppr e]
+mkCoreUnfolding :: Bool -> CoreExpr -> Arity -> UnfoldingGuidance -> Unfolding
+-- Occurrence-analyses the expression before capturing it
+mkCoreUnfolding top_lvl expr arity guidance 
+  = CoreUnfolding { uf_tmpl      = occurAnalyseExpr expr,
+                   uf_arity      = arity,
+                   uf_is_top     = top_lvl,
+                   uf_is_value   = exprIsHNF expr,
+                   uf_is_cheap   = exprIsCheap expr,
+                   uf_expandable = exprIsExpandable expr,
+                   uf_guidance   = guidance }
+
+mkDFunUnfolding :: DataCon -> [Id] -> Unfolding
+mkDFunUnfolding con ops = DFunUnfolding con (map Var ops)
  
  mkCompulsoryUnfolding :: CoreExpr -> Unfolding
  mkCompulsoryUnfolding expr     -- Used for things that absolutely must be unfolded
  
  mkCompulsoryUnfolding :: CoreExpr -> Unfolding
  mkCompulsoryUnfolding expr     -- Used for things that absolutely must be unfolded
-  = CompulsoryUnfolding (occurAnalyseExpr expr)
+  = mkCoreUnfolding True expr 0 UnfoldAlways      -- Arity of unfolding doesn't matter
  \end{code}
  
  
  \end{code}
  
  
@@ -121,75 +139,26 @@ mkCompulsoryUnfolding expr        -- Used for things that absolutely must be unfolded
  %************************************************************************
  
  \begin{code}
  %************************************************************************
  
  \begin{code}
-instance Outputable UnfoldingGuidance where
-    ppr UnfoldNever    = ptext (sLit "NEVER")
-    ppr (UnfoldIfGoodArgs v cs size discount)
-      = hsep [ ptext (sLit "IF_ARGS"), int v,
-              brackets (hsep (map int cs)),
-              int size,
-              int discount ]
-\end{code}
-
-
-\begin{code}
  calcUnfoldingGuidance
         :: Int                  -- bomb out if size gets bigger than this
         -> CoreExpr             -- expression to look at
  calcUnfoldingGuidance
         :: Int                  -- bomb out if size gets bigger than this
         -> CoreExpr             -- expression to look at
-       -> UnfoldingGuidance
+       -> (Arity, UnfoldingGuidance)
  calcUnfoldingGuidance bOMB_OUT_SIZE expr
  calcUnfoldingGuidance bOMB_OUT_SIZE expr
-  = case collect_val_bndrs expr of { (inline, val_binders, body) ->
+  = case collectBinders expr of { (binders, body) ->
      let
      let
+        val_binders = filter isId binders
         n_val_binders = length val_binders
         n_val_binders = length val_binders
-
-       max_inline_size = n_val_binders+2
-       -- The idea is that if there is an INLINE pragma (inline is True)
-       -- and there's a big body, we give a size of n_val_binders+2.  This
-       -- This is just enough to fail the no-size-increase test in callSiteInline,
-       --   so that INLINE things don't get inlined into entirely boring contexts,
-       --   but no more.
-
      in
      case (sizeExpr (iUnbox bOMB_OUT_SIZE) val_binders body) of
      in
      case (sizeExpr (iUnbox bOMB_OUT_SIZE) val_binders body) of
-
-      TooBig 
-       | not inline -> UnfoldNever
-               -- A big function with an INLINE pragma must
-               -- have an UnfoldIfGoodArgs guidance
-       | otherwise  -> UnfoldIfGoodArgs n_val_binders
-                                        (map (const 0) val_binders)
-                                        max_inline_size 0
-
+      TooBig -> (n_val_binders, UnfoldNever)
        SizeIs size cased_args scrut_discount
        SizeIs size cased_args scrut_discount
-       -> UnfoldIfGoodArgs
-                       n_val_binders
-                       (map discount_for val_binders)
-                       final_size
-                       (iBox scrut_discount)
+       -> (n_val_binders, UnfoldIfGoodArgs { ug_args  = map discount_for val_binders
+                                           , ug_size  = iBox size
+                                           , ug_res   = iBox scrut_discount })
         where        
         where        
-           boxed_size    = iBox size
-
-           final_size | inline     = boxed_size `min` max_inline_size
-                      | otherwise  = boxed_size
-
-               -- Sometimes an INLINE thing is smaller than n_val_binders+2.
-               -- A particular case in point is a constructor, which has size 1.
-               -- We want to inline this regardless, hence the `min`
-
             discount_for b = foldlBag (\acc (b',n) -> if b==b' then acc+n else acc) 
                                       0 cased_args
             discount_for b = foldlBag (\acc (b',n) -> if b==b' then acc+n else acc) 
                                       0 cased_args
-       }
-  where
-    collect_val_bndrs e = go False [] e
-       -- We need to be a bit careful about how we collect the
-       -- value binders.  In ptic, if we see 
-       --      __inline_me (\x y -> e)
-       -- We want to say "2 value binders".  Why?  So that 
-       -- we take account of information given for the arguments
-
-    go _      rev_vbs (Note InlineMe e)     = go True   rev_vbs     e
-    go inline rev_vbs (Lam b e) | isId b    = go inline (b:rev_vbs) e
-                               | otherwise = go inline rev_vbs     e
-    go inline rev_vbs e                            = (inline, reverse rev_vbs, e)
+    }
  \end{code}
  
  Note [Computing the size of an expression]
  \end{code}
  
  Note [Computing the size of an expression]
@@ -222,18 +191,28 @@ Notice that 'x' counts 0, while (f x) counts 2.  That's deliberate: there's
  a function call to account for.  Notice also that constructor applications 
  are very cheap, because exposing them to a caller is so valuable.
  
  a function call to account for.  Notice also that constructor applications 
  are very cheap, because exposing them to a caller is so valuable.
  
-Thing to watch out for
-
-* We inline *unconditionally* if inlined thing is smaller (using sizeExpr)
-  than the thing it's replacing.  Notice that
+Note [Unconditional inlining]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We inline *unconditionally* if inlined thing is smaller (using sizeExpr)
+than the thing it's replacing.  Notice that
        (f x) --> (g 3)            -- YES, unconditionally
        (f x) --> x : []           -- YES, *even though* there are two
                                   --      arguments to the cons
        x     --> g 3              -- NO
        x            --> Just v            -- NO
  
        (f x) --> (g 3)            -- YES, unconditionally
        (f x) --> x : []           -- YES, *even though* there are two
                                   --      arguments to the cons
        x     --> g 3              -- NO
        x            --> Just v            -- NO
  
-  It's very important not to unconditionally replace a variable by
-  a non-atomic term.
+It's very important not to unconditionally replace a variable by
+a non-atomic term.
+
+\begin{code}
+uncondInline :: Arity -> Int -> Bool
+-- Inline unconditionally if there no size increase
+-- Size of call is arity (+1 for the function)
+-- See Note [Unconditional inlining]
+uncondInline arity size 
+  | arity == 0 = size == 0
+  | otherwise  = size <= arity + 1
+\end{code}
  
  
  \begin{code}
  
  
  \begin{code}
@@ -248,20 +227,12 @@ sizeExpr :: FastInt           -- Bomb out if it gets bigger than this
  sizeExpr bOMB_OUT_SIZE top_args expr
    = size_up expr
    where
  sizeExpr bOMB_OUT_SIZE top_args expr
    = size_up expr
    where
+    size_up (Cast e _) = size_up e
+    size_up (Note _ e) = size_up e
      size_up (Type _)   = sizeZero           -- Types cost nothing
      size_up (Lit lit)  = sizeN (litSize lit)
      size_up (Type _)   = sizeZero           -- Types cost nothing
      size_up (Lit lit)  = sizeN (litSize lit)
-    size_up (Var f)    = size_up_call f 0   -- Make sure we get constructor
+    size_up (Var f)    = size_up_call f []  -- Make sure we get constructor
                                             -- discounts even on nullary constructors
                                             -- discounts even on nullary constructors
-    size_up (Cast e _) = size_up e
-
-    size_up (Note InlineMe _)  = sizeOne         -- Inline notes make it look very small
-       -- This can be important.  If you have an instance decl like this:
-       --      instance Foo a => Foo [a] where
-       --         {-# INLINE op1, op2 #-}
-       --         op1 = ...
-       --         op2 = ...
-       -- then we'll get a dfun which is a pair of two INLINE lambdas
-    size_up (Note _      body) = size_up body  -- Other notes cost nothing
  
      size_up (App fun (Type _)) = size_up fun
      size_up (App fun arg)      = size_up_app fun [arg]
  
      size_up (App fun (Type _)) = size_up fun
      size_up (App fun arg)      = size_up_app fun [arg]
@@ -324,17 +295,18 @@ sizeExpr bOMB_OUT_SIZE top_args expr
         | isTypeArg arg            = size_up_app fun args
         | otherwise                = size_up_app fun (arg:args)
                                      `addSize` nukeScrutDiscount (size_up arg)
         | isTypeArg arg            = size_up_app fun args
         | otherwise                = size_up_app fun (arg:args)
                                      `addSize` nukeScrutDiscount (size_up arg)
-    size_up_app (Var fun)     args = size_up_call fun (length args)
+    size_up_app (Var fun)     args = size_up_call fun args
      size_up_app other         args = size_up other `addSizeN` length args
  
      ------------ 
      size_up_app other         args = size_up other `addSizeN` length args
  
      ------------ 
-    size_up_call :: Id -> Int -> ExprSize
-    size_up_call fun n_val_args
+    size_up_call :: Id -> [CoreExpr] -> ExprSize
+    size_up_call fun val_args
         = case idDetails fun of
             FCallId _        -> sizeN opt_UF_DearOp
         = case idDetails fun of
             FCallId _        -> sizeN opt_UF_DearOp
-           DataConWorkId dc -> conSize    dc n_val_args
-           PrimOpId op      -> primOpSize op n_val_args
-          _                -> funSize top_args fun n_val_args
+           DataConWorkId dc -> conSize    dc (length val_args)
+           PrimOpId op      -> primOpSize op (length val_args)
+          ClassOpId _      -> classOpSize top_args val_args
+          _                -> funSize top_args fun (length val_args)
  
      ------------ 
      size_up_alt (_con, _bndrs, rhs) = size_up rhs
  
      ------------ 
      size_up_alt (_con, _bndrs, rhs) = size_up rhs
@@ -365,6 +337,22 @@ litSize _other = 0    -- Must match size of nullary constructors
                       -- Key point: if  x |-> 4, then x must inline unconditionally
                       --            (eg via case binding)
  
                       -- Key point: if  x |-> 4, then x must inline unconditionally
                       --            (eg via case binding)
  
+classOpSize :: [Id] -> [CoreExpr] -> ExprSize
+-- See Note [Conlike is interesting]
+classOpSize _ [] 
+  = sizeZero
+classOpSize top_args (arg1 : other_args)
+  = SizeIs (iUnbox size) arg_discount (_ILIT(0))
+  where
+    size = 2 + length other_args
+    -- If the class op is scrutinising a lambda bound dictionary then
+    -- give it a discount, to encourage the inlining of this function
+    -- The actual discount is rather arbitrarily chosen
+    arg_discount = case arg1 of
+                    Var dict | dict `elem` top_args 
+                             -> unitBag (dict, opt_UF_DictDiscount)
+                    _other   -> emptyBag
+                    
  funSize :: [Id] -> Id -> Int -> ExprSize
  -- Size for functions that are not constructors or primops
  -- Note [Function applications]
  funSize :: [Id] -> Id -> Int -> ExprSize
  -- Size for functions that are not constructors or primops
  -- Note [Function applications]
@@ -450,6 +438,35 @@ lamScrutDiscount (SizeIs n vs _) = SizeIs n vs (iUnbox opt_UF_FunAppDiscount)
  lamScrutDiscount TooBig          = TooBig
  \end{code}
  
  lamScrutDiscount TooBig          = TooBig
  \end{code}
  
+Note [Discounts and thresholds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Constants for discounts and thesholds are defined in main/StaticFlags,
+all of form opt_UF_xxxx.   They are:
+
+opt_UF_CreationThreshold (45)
+     At a definition site, if the unfolding is bigger than this, we
+     may discard it altogether
+
+opt_UF_UseThreshold (6)
+     At a call site, if the unfolding, less discounts, is smaller than
+     this, then it's small enough inline
+
+opt_UF_KeennessFactor (1.5)
+     Factor by which the discounts are multiplied before 
+     subtracting from size
+
+opt_UF_DictDiscount (1)
+     The discount for each occurrence of a dictionary argument
+     as an argument of a class method.  Should be pretty small
+     else big functions may get inlined
+
+opt_UF_FunAppDiscount (6)
+     Discount for a function argument that is applied.  Quite
+     large, because if we inline we avoid the higher-order call.
+
+opt_UF_DearOp (4)
+     The size of a foreign call or not-dupable PrimOp
+
  
  Note [Function applications]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  
  Note [Function applications]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -508,52 +525,38 @@ sizeN n  = SizeIs (iUnbox n) emptyBag (_ILIT(0))
  %*                                                                     *
  %************************************************************************
  
  %*                                                                     *
  %************************************************************************
  
-We have very limited information about an unfolding expression: (1)~so
-many type arguments and so many value arguments expected---for our
-purposes here, we assume we've got those.  (2)~A ``size'' or ``cost,''
-a single integer.  (3)~An ``argument info'' vector.  For this, what we
-have at the moment is a Boolean per argument position that says, ``I
-will look with great favour on an explicit constructor in this
-position.'' (4)~The ``discount'' to subtract if the expression
-is being scrutinised. 
-
-Assuming we have enough type- and value arguments (if not, we give up
-immediately), then we see if the ``discounted size'' is below some
-(semi-arbitrary) threshold.  It works like this: for every argument
-position where we're looking for a constructor AND WE HAVE ONE in our
-hands, we get a (again, semi-arbitrary) discount [proportion to the
-number of constructors in the type being scrutinized].
-
-If we're in the context of a scrutinee ( \tr{(case <expr > of A .. -> ...;.. )})
-and the expression in question will evaluate to a constructor, we use
-the computed discount size *for the result only* rather than
-computing the argument discounts. Since we know the result of
-the expression is going to be taken apart, discounting its size
-is more accurate (see @sizeExpr@ above for how this discount size
-is computed).
-
-We use this one to avoid exporting inlinings that we ``couldn't possibly
-use'' on the other side.  Can be overridden w/ flaggery.
-Just the same as smallEnoughToInline, except that it has no actual arguments.
+We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that
+we ``couldn't possibly use'' on the other side.  Can be overridden w/
+flaggery.  Just the same as smallEnoughToInline, except that it has no
+actual arguments.
  
  \begin{code}
  couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool
  
  \begin{code}
  couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool
-couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold rhs of
-                                                UnfoldNever -> False
-                                                _           -> True
-
-certainlyWillInline :: Unfolding -> Bool
-  -- Sees if the unfolding is pretty certain to inline 
-certainlyWillInline (CoreUnfolding _ _ _ is_cheap _ (UnfoldIfGoodArgs n_vals _ size _))
-  = is_cheap && size - (n_vals+1) <= opt_UF_UseThreshold
-certainlyWillInline _
-  = False
+couldBeSmallEnoughToInline threshold rhs 
+  = case calcUnfoldingGuidance threshold rhs of
+       (_, UnfoldNever) -> False
+       _                -> True
  
  
+----------------
  smallEnoughToInline :: Unfolding -> Bool
  smallEnoughToInline :: Unfolding -> Bool
-smallEnoughToInline (CoreUnfolding _ _ _ _ _ (UnfoldIfGoodArgs _ _ size _))
+smallEnoughToInline (CoreUnfolding {uf_guidance = UnfoldIfGoodArgs {ug_size = size}})
    = size <= opt_UF_UseThreshold
  smallEnoughToInline _
    = False
    = size <= opt_UF_UseThreshold
  smallEnoughToInline _
    = False
+
+----------------
+certainlyWillInline :: Unfolding -> Bool
+  -- Sees if the unfolding is pretty certain to inline 
+certainlyWillInline (CoreUnfolding { uf_is_cheap = is_cheap, uf_arity = n_vals, uf_guidance = guidance })
+  = case guidance of
+      UnfoldAlways {} -> True
+      UnfoldNever     -> False
+      InlineRule {}   -> True
+      UnfoldIfGoodArgs { ug_size = size} 
+                    -> is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold
+
+certainlyWillInline _
+  = False
  \end{code}
  
  %************************************************************************
  \end{code}
  
  %************************************************************************
@@ -610,87 +613,81 @@ data CallCtxt = BoringCtxt
  
  instance Outputable CallCtxt where
    ppr BoringCtxt    = ptext (sLit "BoringCtxt")
  
  instance Outputable CallCtxt where
    ppr BoringCtxt    = ptext (sLit "BoringCtxt")
-  ppr (ArgCtxt _ _) = ptext (sLit "ArgCtxt")
+  ppr (ArgCtxt rules disc) = ptext (sLit "ArgCtxt") <> ppr (rules,disc)
    ppr CaseCtxt             = ptext (sLit "CaseCtxt")
    ppr ValAppCtxt    = ptext (sLit "ValAppCtxt")
  
  callSiteInline dflags active_inline id lone_variable arg_infos cont_info
    ppr CaseCtxt             = ptext (sLit "CaseCtxt")
    ppr ValAppCtxt    = ptext (sLit "ValAppCtxt")
  
  callSiteInline dflags active_inline id lone_variable arg_infos cont_info
-  = case idUnfolding id of {
-       NoUnfolding -> Nothing ;
-       OtherCon _  -> Nothing ;
-
-       CompulsoryUnfolding unf_template -> Just unf_template ;
-               -- CompulsoryUnfolding => there is no top-level binding
-               -- for these things, so we must inline it.
-               -- Only a couple of primop-like things have 
-               -- compulsory unfoldings (see MkId.lhs).
-               -- We don't allow them to be inactive
-
-       CoreUnfolding unf_template is_top is_value is_cheap is_expable guidance ->
-
+  = let
+       n_val_args  = length arg_infos
+    in
+    case idUnfolding id of {
+       NoUnfolding      -> Nothing ;
+       OtherCon _       -> Nothing ;
+       DFunUnfolding {} -> Nothing ;   -- Never unfold a DFun
+       CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top, uf_is_value = is_value,
+                       uf_is_cheap = is_cheap, uf_arity = uf_arity, uf_guidance = guidance } ->
+                       -- uf_arity will typically be equal to (idArity id), 
+                       -- but may be less for InlineRules
      let
         result | yes_or_no = Just unf_template
                | otherwise = Nothing
  
      let
         result | yes_or_no = Just unf_template
                | otherwise = Nothing
  
-       n_val_args  = length arg_infos
-
-       yes_or_no = active_inline && is_cheap && consider_safe
-               -- We consider even the once-in-one-branch
-               -- occurrences, because they won't all have been
-               -- caught by preInlineUnconditionally.  In particular,
-               -- if the occurrence is once inside a lambda, and the
-               -- rhs is cheap but not a manifest lambda, then
-               -- pre-inline will not have inlined it for fear of
-               -- invalidating the occurrence info in the rhs.
-
-       consider_safe
-               -- consider_safe decides whether it's a good idea to
-               -- inline something, given that there's no
-               -- work-duplication issue (the caller checks that).
+       interesting_args = any nonTriv arg_infos 
+               -- NB: (any nonTriv arg_infos) looks at the
+               -- over-saturated args too which is "wrong"; 
+               -- but if over-saturated we inline anyway.
+
+              -- some_benefit is used when the RHS is small enough
+              -- and the call has enough (or too many) value
+              -- arguments (ie n_val_args >= arity). But there must
+              -- be *something* interesting about some argument, or the
+              -- result context, to make it worth inlining
+       some_benefit =  interesting_args
+                     || n_val_args > uf_arity      -- Over-saturated
+                     || interesting_saturated_call  -- Exactly saturated
+
+       interesting_saturated_call 
+         = case cont_info of
+             BoringCtxt -> not is_top && uf_arity > 0          -- Note [Nested functions]
+             CaseCtxt   -> not (lone_variable && is_value)     -- Note [Lone variables]
+             ArgCtxt {} -> uf_arity > 0                        -- Note [Inlining in ArgCtxt]
+             ValAppCtxt -> True                                -- Note [Cast then apply]
+
+       yes_or_no
           = case guidance of
               UnfoldNever  -> False
           = case guidance of
               UnfoldNever  -> False
-             UnfoldIfGoodArgs n_vals_wanted arg_discounts size res_discount
-                 | uncond_inline -> True
-                 | otherwise     -> some_benefit && small_enough && inline_enough_args
-
-                 where
-                       -- Inline unconditionally if there no size increase
-                       -- Size of call is n_vals_wanted (+1 for the function)
-                   uncond_inline 
-                      | n_vals_wanted == 0 = size == 0
-                      | otherwise          = enough_args && (size <= n_vals_wanted + 1)
-
-                   enough_args = n_val_args >= n_vals_wanted
-                    inline_enough_args =
-                      not (dopt Opt_InlineIfEnoughArgs dflags) || enough_args
-
-
-                   some_benefit = any nonTriv arg_infos || really_interesting_cont
-                               -- There must be something interesting
-                               -- about some argument, or the result
-                               -- context, to make it worth inlining
- 
-                               -- NB: (any nonTriv arg_infos) looks at the over-saturated
-                               -- args too which is wrong; but if over-saturated
-                               -- we'll probably inline anyway.
-
-                   really_interesting_cont 
-                       | n_val_args <  n_vals_wanted = False   -- Too few args
-                       | n_val_args == n_vals_wanted = interesting_saturated_call
-                       | otherwise                   = True    -- Extra args
-                       -- really_interesting_cont tells if the result of the
-                       -- call is in an interesting context.
-
-                   interesting_saturated_call 
-                       = case cont_info of
-                           BoringCtxt -> not is_top && n_vals_wanted > 0       -- Note [Nested functions] 
-                           CaseCtxt   -> not lone_variable || not is_value     -- Note [Lone variables]
-                           ArgCtxt {} -> n_vals_wanted > 0                     -- Note [Inlining in ArgCtxt]
-                           ValAppCtxt -> True                                  -- Note [Cast then apply]
-
-                   small_enough = (size - discount) <= opt_UF_UseThreshold
-                   discount = computeDiscount n_vals_wanted arg_discounts 
-                                              res_discount arg_infos cont_info
+
+             UnfoldAlways -> True
+               -- UnfoldAlways => there is no top-level binding for
+               -- these things, so we must inline it.  Only a few
+               -- primop-like things have compulsory unfoldings (see
+               -- MkId.lhs).  Ignore is_active because we want to
+               -- inline even if SimplGently is on.
+
+             InlineRule { ug_ir_info = inl_info, ug_small = uncond_inline }
+                | not active_inline     -> False
+                | n_val_args < uf_arity -> yes_unsat    -- Not enough value args
+                | uncond_inline         -> True         -- Note [INLINE for small functions]
+                | otherwise             -> some_benefit -- Saturated or over-saturated
+                where
+                  -- See Note [Inlining an InlineRule]
+                  yes_unsat = case inl_info of
+                                 InlSat -> False
+                                 _other -> interesting_args
+
+             UnfoldIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
+                | not active_inline          -> False
+                | not is_cheap               -> False
+                | n_val_args < uf_arity      -> interesting_args && small_enough       
+                                                       -- Note [Unsaturated applications]
+                | uncondInline uf_arity size -> True
+                | otherwise                  -> some_benefit && small_enough
+
+                where
+                  small_enough = (size - discount) <= opt_UF_UseThreshold
+                  discount = computeDiscount uf_arity arg_discounts 
+                                             res_discount arg_infos cont_info
                 
      in    
      if dopt Opt_D_dump_inlinings dflags then
                 
      in    
      if dopt Opt_D_dump_inlinings dflags then
@@ -700,7 +697,6 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
                         text "interesting continuation" <+> ppr cont_info,
                         text "is value:" <+> ppr is_value,
                          text "is cheap:" <+> ppr is_cheap,
                         text "interesting continuation" <+> ppr cont_info,
                         text "is value:" <+> ppr is_value,
                          text "is cheap:" <+> ppr is_cheap,
-                       text "is expandable:" <+> ppr is_expable,
                         text "guidance" <+> ppr guidance,
                         text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"])
                   result
                         text "guidance" <+> ppr guidance,
                         text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"])
                   result
@@ -709,6 +705,44 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
      }
  \end{code}
  
      }
  \end{code}
  
+Note [Unsaturated applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When a call is not saturated, we *still* inline if one of the
+arguments has interesting structure.  That's sometimes very important.
+A good example is the Ord instance for Bool in Base:
+
+ Rec {
+    $fOrdBool =GHC.Classes.D:Ord
+                @ Bool
+                ...
+                $cmin_ajX
+
+    $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool
+    $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool
+  }
+
+But the defn of GHC.Classes.$dmmin is:
+
+  $dmmin :: forall a. GHC.Classes.Ord a => a -> a -> a
+    {- Arity: 3, HasNoCafRefs, Strictness: SLL,
+       Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a ->
+                   case @ a GHC.Classes.<= @ a $dOrd x y of wild {
+                     GHC.Bool.False -> y GHC.Bool.True -> x }) -}
+
+We *really* want to inline $dmmin, even though it has arity 3, in
+order to unravel the recursion.
+
+
+Note [INLINE for small functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider       {-# INLINE f #-}
+                f x = Just x
+                g y = f y
+Then f's RHS is no larger than its LHS, so we should inline it
+into even the most boring context.  (We do so if there is no INLINE
+pragma!)  That's the reason for the 'inl_small' flag on an InlineRule.
+
+
  Note [Things to watch]
  ~~~~~~~~~~~~~~~~~~~~~~
  *   { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... }
  Note [Things to watch]
  ~~~~~~~~~~~~~~~~~~~~~~
  *   { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... }
@@ -720,6 +754,21 @@ Note [Things to watch]
      Make sure that x does not inline unconditionally!  
      Lest we get extra allocation.
  
      Make sure that x does not inline unconditionally!  
      Lest we get extra allocation.
  
+Note [Inlining an InlineRule]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+An InlineRules is used for
+  (a) pogrammer INLINE pragmas
+  (b) inlinings from worker/wrapper
+
+For (a) the RHS may be large, and our contract is that we *only* inline
+when the function is applied to all the arguments on the LHS of the
+source-code defn.  (The uf_arity in the rule.)
+
+However for worker/wrapper it may be worth inlining even if the 
+arity is not satisfied (as we do in the CoreUnfolding case) so we don't
+require saturation.
+
+
  Note [Nested functions]
  ~~~~~~~~~~~~~~~~~~~~~~~
  If a function has a nested defn we also record some-benefit, on the
  Note [Nested functions]
  ~~~~~~~~~~~~~~~~~~~~~~~
  If a function has a nested defn we also record some-benefit, on the
@@ -744,7 +793,7 @@ no value arguments.  The ValAppCtxt gives it enough incentive to inline.
  
  Note [Inlining in ArgCtxt]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~
  
  Note [Inlining in ArgCtxt]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~
-The condition (n_vals_wanted > 0) here is very important, because otherwise
+The condition (arity > 0) here is very important, because otherwise
  we end up inlining top-level stuff into useless places; eg
     x = I# 3#
     f = \y.  g x
  we end up inlining top-level stuff into useless places; eg
     x = I# 3#
     f = \y.  g x
@@ -760,11 +809,13 @@ Note [Lone variables]
  The "lone-variable" case is important.  I spent ages messing about
  with unsatisfactory varaints, but this is nice.  The idea is that if a
  variable appears all alone
  The "lone-variable" case is important.  I spent ages messing about
  with unsatisfactory varaints, but this is nice.  The idea is that if a
  variable appears all alone
-       as an arg of lazy fn, or rhs    Stop
-       as scrutinee of a case          Select
-       as arg of a strict fn           ArgOf
+
+       as an arg of lazy fn, or rhs    BoringCtxt
+       as scrutinee of a case          CaseCtxt
+       as arg of a fn                  ArgCtxt
  AND
         it is bound to a value
  AND
         it is bound to a value
+
  then we should not inline it (unless there is some other reason,
  e.g. is is the sole occurrence).  That is what is happening at 
  the use of 'lone_variable' in 'interesting_saturated_call'.
  then we should not inline it (unless there is some other reason,
  e.g. is is the sole occurrence).  That is what is happening at 
  the use of 'lone_variable' in 'interesting_saturated_call'.
@@ -798,6 +849,11 @@ However, watch out:
     important: in the NDP project, 'bar' generates a closure data
     structure rather than a list. 
  
     important: in the NDP project, 'bar' generates a closure data
     structure rather than a list. 
  
+   So the non-inlining of lone_variables should only apply if the
+   unfolding is regarded as cheap; because that is when exprIsConApp_maybe
+   looks through the unfolding.  Hence the "&& is_cheap" in the
+   InlineRule branch.
+
   * Even a type application or coercion isn't a lone variable.
     Consider
         case $fMonadST @ RealWorld of { :DMonad a b c -> c }
   * Even a type application or coercion isn't a lone variable.
     Consider
         case $fMonadST @ RealWorld of { :DMonad a b c -> c }
@@ -873,10 +929,21 @@ But we don't regard (f x y) as interesting, unless f is unsaturated.
  If it's saturated and f hasn't inlined, then it's probably not going
  to now!
  
  If it's saturated and f hasn't inlined, then it's probably not going
  to now!
  
+Note [Conlike is interesting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+       f d = ...((*) d x y)...
+       ... f (df d')...
+where df is con-like. Then we'd really like to inline so that the
+rule for (*) (df d) can fire.  To do this 
+  a) we give a discount for being an argument of a class-op (eg (*) d)
+  b) we say that a con-like argument (eg (df d)) is interesting
+
  \begin{code}
  data ArgSummary = TrivArg      -- Nothing interesting
                 | NonTrivArg    -- Arg has structure
                 | ValueArg      -- Arg is a con-app or PAP
  \begin{code}
  data ArgSummary = TrivArg      -- Nothing interesting
                 | NonTrivArg    -- Arg has structure
                 | ValueArg      -- Arg is a con-app or PAP
+                               -- ..or con-like. Note [Conlike is interesting]
  
  interestingArg :: CoreExpr -> ArgSummary
  -- See Note [Interesting arguments]
  
  interestingArg :: CoreExpr -> ArgSummary
  -- See Note [Interesting arguments]
@@ -885,7 +952,8 @@ interestingArg e = go e 0
      -- n is # value args to which the expression is applied
      go (Lit {}) _         = ValueArg
      go (Var v)  n
      -- n is # value args to which the expression is applied
      go (Lit {}) _         = ValueArg
      go (Var v)  n
-       | isDataConWorkId v = ValueArg
+       | isConLikeId v     = ValueArg  -- Experimenting with 'conlike' rather that
+                                               --    data constructors here
         | idArity v > n    = ValueArg   -- Catches (eg) primops with arity but no unfolding
         | n > 0            = NonTrivArg -- Saturated or unknown call
         | evald_unfolding   = ValueArg  -- n==0; look for a value
         | idArity v > n    = ValueArg   -- Catches (eg) primops with arity but no unfolding
         | n > 0            = NonTrivArg -- Saturated or unknown call
         | evald_unfolding   = ValueArg  -- n==0; look for a value
@@ -910,75 +978,169 @@ nonTriv TrivArg = False
  nonTriv _       = True
  \end{code}
  
  nonTriv _       = True
  \end{code}
  
-
  %************************************************************************
  %*                                                                     *
  %************************************************************************
  %*                                                                     *
-       The Very Simple Optimiser
+         exprIsConApp_maybe
  %*                                                                     *
  %************************************************************************
  
  %*                                                                     *
  %************************************************************************
  
+Note [exprIsConApp_maybe]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+exprIsConApp_maybe is a very important function.  There are two principal
+uses:
+  * case e of { .... }
+  * cls_op e, where cls_op is a class operation
+
+In both cases you want to know if e is of form (C e1..en) where C is
+a data constructor.
+
+However e might not *look* as if 
  
  \begin{code}
  
  \begin{code}
-simpleOptExpr :: Subst -> CoreExpr -> CoreExpr
--- Return an occur-analysed and slightly optimised expression
--- The optimisation is very straightforward: just
--- inline non-recursive bindings that are used only once, 
--- or wheere the RHS is trivial
-
-simpleOptExpr subst expr
-  = go subst (occurAnalyseExpr expr)
+-- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is 
+-- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@,
+-- where t1..tk are the *universally-qantified* type args of 'dc'
+exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
+
+exprIsConApp_maybe (Note _ expr)
+  = exprIsConApp_maybe expr
+       -- We ignore all notes.  For example,
+       --      case _scc_ "foo" (C a b) of
+       --                      C a b -> e
+       -- should be optimised away, but it will be only if we look
+       -- through the SCC note.
+
+exprIsConApp_maybe (Cast expr co)
+  =     -- Here we do the KPush reduction rule as described in the FC paper
+       -- The transformation applies iff we have
+       --      (C e1 ... en) `cast` co
+       -- where co :: (T t1 .. tn) ~ to_ty
+       -- The left-hand one must be a T, because exprIsConApp returned True
+       -- but the right-hand one might not be.  (Though it usually will.)
+
+    case exprIsConApp_maybe expr of {
+       Nothing                          -> Nothing ;
+       Just (dc, _dc_univ_args, dc_args) -> 
+
+    let (_from_ty, to_ty) = coercionKind co
+       dc_tc = dataConTyCon dc
+    in
+    case splitTyConApp_maybe to_ty of {
+       Nothing -> Nothing ;
+       Just (to_tc, to_tc_arg_tys) 
+               | dc_tc /= to_tc -> Nothing
+               -- These two Nothing cases are possible; we might see 
+               --      (C x y) `cast` (g :: T a ~ S [a]),
+               -- where S is a type function.  In fact, exprIsConApp
+               -- will probably not be called in such circumstances,
+               -- but there't nothing wrong with it 
+
+               | otherwise  ->
+    let
+       tc_arity       = tyConArity dc_tc
+       dc_univ_tyvars = dataConUnivTyVars dc
+        dc_ex_tyvars   = dataConExTyVars dc
+        arg_tys        = dataConRepArgTys dc
+
+        dc_eqs :: [(Type,Type)]          -- All equalities from the DataCon
+        dc_eqs = [(mkTyVarTy tv, ty)   | (tv,ty) <- dataConEqSpec dc] ++
+                 [getEqPredTys eq_pred | eq_pred <- dataConEqTheta dc]
+
+        (ex_args, rest1)    = splitAtList dc_ex_tyvars dc_args
+       (co_args, val_args) = splitAtList dc_eqs rest1
+
+       -- Make the "theta" from Fig 3 of the paper
+        gammas = decomposeCo tc_arity co
+        theta  = zipOpenTvSubst (dc_univ_tyvars ++ dc_ex_tyvars)
+                                (gammas         ++ stripTypeArgs ex_args)
+
+          -- Cast the existential coercion arguments
+        cast_co (ty1, ty2) (Type co) 
+          = Type $ mkSymCoercion (substTy theta ty1)
+                  `mkTransCoercion` co
+                  `mkTransCoercion` (substTy theta ty2)
+        cast_co _ other_arg = pprPanic "cast_co" (ppr other_arg)
+        new_co_args = zipWith cast_co dc_eqs co_args
+  
+          -- Cast the value arguments (which include dictionaries)
+       new_val_args = zipWith cast_arg arg_tys val_args
+       cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg
+    in
+#ifdef DEBUG
+    let dump_doc = vcat [ppr dc,      ppr dc_univ_tyvars, ppr dc_ex_tyvars,
+                         ppr arg_tys, ppr dc_args,        ppr _dc_univ_args,
+                         ppr ex_args, ppr val_args]
+    ASSERT2( coreEqType from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc )
+    ASSERT2( all isTypeArg (ex_args ++ co_args), dump_doc )
+    ASSERT2( equalLength val_args arg_tys, dump_doc )
+#endif
+
+    Just (dc, to_tc_arg_tys, ex_args ++ new_co_args ++ new_val_args)
+    }}
+
+exprIsConApp_maybe expr 
+  = analyse expr [] 
    where
    where
-    go subst (Var v)          = lookupIdSubst subst v
-    go subst (App e1 e2)      = App (go subst e1) (go subst e2)
-    go subst (Type ty)        = Type (substTy subst ty)
-    go _     (Lit lit)        = Lit lit
-    go subst (Note note e)    = Note note (go subst e)
-    go subst (Cast e co)      = Cast (go subst e) (substTy subst co)
-    go subst (Let bind body)  = go_bind subst bind body
-    go subst (Lam bndr body)  = Lam bndr' (go subst' body)
-                             where
-                               (subst', bndr') = substBndr subst bndr
-
-    go subst (Case e b ty as) = Case (go subst e) b' 
-                                    (substTy subst ty)
-                                    (map (go_alt subst') as)
-                             where
-                                (subst', b') = substBndr subst b
-
-
-    ----------------------
-    go_alt subst (con, bndrs, rhs) = (con, bndrs', go subst' rhs)
-                                where
-                                  (subst', bndrs') = substBndrs subst bndrs
-
-    ----------------------
-    go_bind subst (Rec prs) body = Let (Rec (bndrs' `zip` rhss'))
-                                      (go subst' body)
-                           where
-                             (bndrs, rhss)    = unzip prs
-                             (subst', bndrs') = substRecBndrs subst bndrs
-                             rhss'            = map (go subst') rhss
-
-    go_bind subst (NonRec b r) body = go_nonrec subst b (go subst r) body
-
-    ----------------------
-    go_nonrec subst b (Type ty') body
-      | isTyVar b = go (extendTvSubst subst b ty') body
-       -- let a::* = TYPE ty in <body>
-    go_nonrec subst b r' body
-      | isId b -- let x = e in <body>
-      , exprIsTrivial r' || safe_to_inline (idOccInfo b)
-      = go (extendIdSubst subst b r') body
-    go_nonrec subst b r' body
-      = Let (NonRec b' r') (go subst' body)
-      where
-       (subst', b') = substBndr subst b
-
-    ----------------------
-       -- Unconditionally safe to inline
-    safe_to_inline :: OccInfo -> Bool
-    safe_to_inline IAmDead                  = True
-    safe_to_inline (OneOcc in_lam one_br _) = not in_lam && one_br
-    safe_to_inline (IAmALoopBreaker {})     = False
-    safe_to_inline NoOccInfo                = False
-\end{code}
\ No newline at end of file
+    analyse (App fun arg) args = analyse fun (arg:args)
+    analyse fun@(Lam {})  args = beta fun [] args 
+
+    analyse (Var fun) args
+       | Just con <- isDataConWorkId_maybe fun
+        , is_saturated
+       , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars con) args
+       = Just (con, stripTypeArgs univ_ty_args, rest_args)
+
+       -- Look through dictionary functions; see Note [Unfolding DFuns]
+        | DFunUnfolding con ops <- unfolding
+        , is_saturated
+        , let (dfun_tvs, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
+             subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
+        = Just (con, substTys subst dfun_res_tys, 
+                     [mkApps op args | op <- ops])
+
+       -- Look through unfoldings, but only cheap ones, because
+       -- we are effectively duplicating the unfolding
+       | CoreUnfolding { uf_expandable = expand_me, uf_tmpl = rhs } <- unfolding
+       , expand_me = -- pprTrace "expanding" (ppr fun $$ ppr rhs) $
+                      analyse rhs args
+        where
+         is_saturated = count isValArg args == idArity fun
+          unfolding = idUnfolding fun
+
+    analyse _ _ = Nothing
+
+    -----------
+    beta (Lam v body) pairs (arg : args) 
+        | isTypeArg arg
+        = beta body ((v,arg):pairs) args 
+
+    beta (Lam {}) _ _    -- Un-saturated, or not a type lambda
+       = Nothing
+
+    beta fun pairs args
+        = case analyse (substExpr (mkOpenSubst pairs) fun) args of
+           Nothing  -> -- pprTrace "Bale out! exprIsConApp_maybe" doc $
+                       Nothing
+           Just ans -> -- pprTrace "Woo-hoo! exprIsConApp_maybe" doc $
+                        Just ans
+        where
+         -- doc = vcat [ppr fun, ppr expr, ppr pairs, ppr args]
+
+
+stripTypeArgs :: [CoreExpr] -> [Type]
+stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args )
+                     [ty | Type ty <- args]
+\end{code}
+
+Note [Unfolding DFuns]
+~~~~~~~~~~~~~~~~~~~~~~
+DFuns look like
+
+  df :: forall a b. (Eq a, Eq b) -> Eq (a,b)
+  df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b)
+                               ($c2 a b d_a d_b)
+
+So to split it up we just need to apply the ops $c1, $c2 etc
+to the very same args as the dfun.  It takes a little more work
+to compute the type arguments to the dictionary constructor.
+
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs

index d48d69e..56a84a5 100644 (file)
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -16,7 +16,7 @@ Utility functions on @Core@ syntax
  -- | Commonly useful utilites for manipulating the Core language
  module CoreUtils (
         -- * Constructing expressions
  -- | Commonly useful utilites for manipulating the Core language
  module CoreUtils (
         -- * Constructing expressions
-       mkInlineMe, mkSCC, mkCoerce, mkCoerceI,
+       mkSCC, mkCoerce, mkCoerceI,
         bindNonRec, needsCaseBinding,
         mkAltExpr, mkPiType, mkPiTypes,
  
         bindNonRec, needsCaseBinding,
         mkAltExpr, mkPiType, mkPiTypes,
  
@@ -27,7 +27,6 @@ module CoreUtils (
         exprType, coreAltType, coreAltsType,
         exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable,
         exprIsHNF,exprOkForSpeculation, exprIsBig, 
         exprType, coreAltType, coreAltsType,
         exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable,
         exprIsHNF,exprOkForSpeculation, exprIsBig, 
-       exprIsConApp_maybe, exprIsBottom,
         rhsIsStatic,
  
         -- * Expression and bindings size
         rhsIsStatic,
  
         -- * Expression and bindings size
@@ -62,7 +61,6 @@ import DataCon
  import PrimOp
  import Id
  import IdInfo
  import PrimOp
  import Id
  import IdInfo
-import NewDemand
  import Type
  import Coercion
  import TyCon
  import Type
  import Coercion
  import TyCon
@@ -193,47 +191,6 @@ panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty
  %*                                                                     *
  %************************************************************************
  
  %*                                                                     *
  %************************************************************************
  
-mkNote removes redundant coercions, and SCCs where possible
-
-\begin{code}
-#ifdef UNUSED
-mkNote :: Note -> CoreExpr -> CoreExpr
-mkNote (SCC cc)        expr               = mkSCC cc expr
-mkNote InlineMe expr              = mkInlineMe expr
-mkNote note     expr              = Note note expr
-#endif
-\end{code}
-
-Drop trivial InlineMe's.  This is somewhat important, because if we have an unfolding
-that looks like        (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
-not be *applied* to anything.
-
-We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
-bindings like
-       fw = ...
-       f  = inline_me (coerce t fw)
-As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
-We want the split, so that the coerces can cancel at the call site.  
-
-However, we can get left with tiresome type applications.  Notably, consider
-       f = /\ a -> let t = e in (t, w)
-Then lifting the let out of the big lambda gives
-       t' = /\a -> e
-       f = /\ a -> let t = inline_me (t' a) in (t, w)
-The inline_me is to stop the simplifier inlining t' right back
-into t's RHS.  In the next phase we'll substitute for t (since
-its rhs is trivial) and *then* we could get rid of the inline_me.
-But it hardly seems worth it, so I don't bother.
-
-\begin{code}
--- | Wraps the given expression in an inlining hint unless the expression
--- is trivial in some sense, so that doing so would usually hurt us
-mkInlineMe :: CoreExpr -> CoreExpr
-mkInlineMe e@(Var _)           = e
-mkInlineMe e@(Note InlineMe _) = e
-mkInlineMe e                  = Note InlineMe e
-\end{code}
-
  \begin{code}
  -- | Wrap the given expression in the coercion, dropping identity coercions and coalescing nested coercions
  mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr
  \begin{code}
  -- | Wrap the given expression in the coercion, dropping identity coercions and coalescing nested coercions
  mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr
@@ -418,10 +375,9 @@ Similar things can happen (augmented by GADTs) when the Simplifier
  filters down the matching alternatives in Simplify.rebuildCase.
  
  
  filters down the matching alternatives in Simplify.rebuildCase.
  
  
-
  %************************************************************************
  %*                                                                     *
  %************************************************************************
  %*                                                                     *
-\subsection{Figuring out things about expressions}
+         Figuring out things about expressions
  %*                                                                     *
  %************************************************************************
  
  %*                                                                     *
  %************************************************************************
  
@@ -478,12 +434,11 @@ exprIsTrivial _                = False
  
  \begin{code}
  exprIsDupable :: CoreExpr -> Bool
  
  \begin{code}
  exprIsDupable :: CoreExpr -> Bool
-exprIsDupable (Type _)          = True
-exprIsDupable (Var _)           = True
-exprIsDupable (Lit lit)         = litIsDupable lit
-exprIsDupable (Note InlineMe _) = True
-exprIsDupable (Note _ e)        = exprIsDupable e
-exprIsDupable (Cast e _)        = exprIsDupable e
+exprIsDupable (Type _)   = True
+exprIsDupable (Var _)    = True
+exprIsDupable (Lit lit)  = litIsDupable lit
+exprIsDupable (Note _ e) = exprIsDupable e
+exprIsDupable (Cast e _) = exprIsDupable e
  exprIsDupable expr
    = go expr 0
    where
  exprIsDupable expr
    = go expr 0
    where
@@ -530,7 +485,6 @@ exprIsCheap' :: (Id -> Bool) -> CoreExpr -> Bool
  exprIsCheap' _          (Lit _)           = True
  exprIsCheap' _          (Type _)          = True
  exprIsCheap' _          (Var _)           = True
  exprIsCheap' _          (Lit _)           = True
  exprIsCheap' _          (Type _)          = True
  exprIsCheap' _          (Var _)           = True
-exprIsCheap' _          (Note InlineMe _) = True
  exprIsCheap' is_conlike (Note _ e)        = exprIsCheap' is_conlike e
  exprIsCheap' is_conlike (Cast e _)        = exprIsCheap' is_conlike e
  exprIsCheap' is_conlike (Lam x e)         = isRuntimeVar x
  exprIsCheap' is_conlike (Note _ e)        = exprIsCheap' is_conlike e
  exprIsCheap' is_conlike (Cast e _)        = exprIsCheap' is_conlike e
  exprIsCheap' is_conlike (Lam x e)         = isRuntimeVar x
@@ -559,7 +513,7 @@ exprIsCheap' is_conlike other_expr  -- Applications and variables
      go (Var f) args
         = case idDetails f of
                 RecSelId {}  -> go_sel args
      go (Var f) args
         = case idDetails f of
                 RecSelId {}  -> go_sel args
-               ClassOpId _  -> go_sel args
+               ClassOpId {} -> go_sel args
                 PrimOpId op  -> go_primop op args
  
                 _ | is_conlike f -> go_pap args
                 PrimOpId op  -> go_primop op args
  
                 _ | is_conlike f -> go_pap args
@@ -597,7 +551,7 @@ exprIsCheap :: CoreExpr -> Bool
  exprIsCheap = exprIsCheap' isDataConWorkId
  
  exprIsExpandable :: CoreExpr -> Bool
  exprIsCheap = exprIsCheap' isDataConWorkId
  
  exprIsExpandable :: CoreExpr -> Bool
-exprIsExpandable = exprIsCheap' isConLikeId
+exprIsExpandable = exprIsCheap' isConLikeId    -- See Note [CONLIKE pragma] in BasicTypes
  \end{code}
  
  \begin{code}
  \end{code}
  
  \begin{code}
@@ -665,6 +619,10 @@ exprOkForSpeculation other_expr
                                 -- A bit conservative: we don't really need
                                 -- to care about lazy arguments, but this is easy
  
                                 -- A bit conservative: we don't really need
                                 -- to care about lazy arguments, but this is easy
  
+    spec_ok (DFunId new_type) _ = not new_type 
+         -- DFuns terminate, unless the dict is implemented with a newtype
+        -- in which case they may not
+
      spec_ok _ _ = False
  
  -- | True of dyadic operators that can fail only if the second arg is zero!
      spec_ok _ _ = False
  
  -- | True of dyadic operators that can fail only if the second arg is zero!
@@ -682,8 +640,9 @@ isDivOp _                = False
  \end{code}
  
  \begin{code}
  \end{code}
  
  \begin{code}
+{-     Never used -- omitting
  -- | True of expressions that are guaranteed to diverge upon execution
  -- | True of expressions that are guaranteed to diverge upon execution
-exprIsBottom :: CoreExpr -> Bool
+exprIsBottom :: CoreExpr -> Bool       -- True => definitely bottom
  exprIsBottom e = go 0 e
                 where
                  -- n is the number of args
  exprIsBottom e = go 0 e
                 where
                  -- n is the number of args
@@ -699,6 +658,7 @@ exprIsBottom e = go 0 e
  
  idAppIsBottom :: Id -> Int -> Bool
  idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
  
  idAppIsBottom :: Id -> Int -> Bool
  idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
+-}
  \end{code}
  
  \begin{code}
  \end{code}
  
  \begin{code}
@@ -754,8 +714,8 @@ exprIsHNF _                = False
  -- There is at least one value argument
  app_is_value :: CoreExpr -> [CoreArg] -> Bool
  app_is_value (Var fun) args
  -- There is at least one value argument
  app_is_value :: CoreExpr -> [CoreArg] -> Bool
  app_is_value (Var fun) args
-  = idArity fun > valArgCount args     -- Under-applied function
-    ||  isDataConWorkId fun            --  or data constructor
+  = idArity fun > valArgCount args       -- Under-applied function
+    || isDataConWorkId fun               --  or data constructor
  app_is_value (Note _ f) as = app_is_value f as
  app_is_value (Cast f _) as = app_is_value f as
  app_is_value (App f a)  as = app_is_value f (a:as)
  app_is_value (Note _ f) as = app_is_value f as
  app_is_value (Cast f _) as = app_is_value f as
  app_is_value (App f a)  as = app_is_value f (a:as)
@@ -854,131 +814,11 @@ dataConInstPat arg_fun fss uniqs con inst_tys
      mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan
      arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys
  
      mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan
      arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys
  
--- | Returns @Just (dc, [x1..xn])@ if the argument expression is 
--- a constructor application of the form @dc x1 .. xn@
-exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
-exprIsConApp_maybe (Cast expr co)
-  =     -- Here we do the KPush reduction rule as described in the FC paper
-    case exprIsConApp_maybe expr of {
-       Nothing            -> Nothing ;
-       Just (dc, dc_args) -> 
-
-       -- The transformation applies iff we have
-       --      (C e1 ... en) `cast` co
-       -- where co :: (T t1 .. tn) ~ (T s1 ..sn)
-       -- That is, with a T at the top of both sides
-       -- The left-hand one must be a T, because exprIsConApp returned True
-       -- but the right-hand one might not be.  (Though it usually will.)
-
-    let (from_ty, to_ty)          = coercionKind co
-       (from_tc, from_tc_arg_tys) = splitTyConApp from_ty
-               -- The inner one must be a TyConApp
-    in
-    case splitTyConApp_maybe to_ty of {
-       Nothing -> Nothing ;
-       Just (to_tc, to_tc_arg_tys) 
-               | from_tc /= to_tc -> Nothing
-               -- These two Nothing cases are possible; we might see 
-               --      (C x y) `cast` (g :: T a ~ S [a]),
-               -- where S is a type function.  In fact, exprIsConApp
-               -- will probably not be called in such circumstances,
-               -- but there't nothing wrong with it 
-
-               | otherwise  ->
-    let
-       tc_arity = tyConArity from_tc
-
-        (univ_args, rest1)        = splitAt tc_arity dc_args
-        (ex_args, rest2)          = splitAt n_ex_tvs rest1
-       (co_args_spec, rest3)     = splitAt n_cos_spec rest2
-       (co_args_theta, val_args) = splitAt n_cos_theta rest3
-
-        arg_tys            = dataConRepArgTys dc
-       dc_univ_tyvars      = dataConUnivTyVars dc
-        dc_ex_tyvars        = dataConExTyVars dc
-       dc_eq_spec          = dataConEqSpec dc
-        dc_eq_theta         = dataConEqTheta dc
-        dc_tyvars           = dc_univ_tyvars ++ dc_ex_tyvars
-        n_ex_tvs            = length dc_ex_tyvars
-       n_cos_spec          = length dc_eq_spec
-       n_cos_theta         = length dc_eq_theta
-
-       -- Make the "theta" from Fig 3 of the paper
-        gammas              = decomposeCo tc_arity co
-        new_tys             = gammas ++ map (\ (Type t) -> t) ex_args
-        theta               = zipOpenTvSubst dc_tyvars new_tys
-
-          -- First we cast the existential coercion arguments
-        cast_co_spec (tv, ty) co 
-          = cast_co_theta (mkEqPred (mkTyVarTy tv, ty)) co
-        cast_co_theta eqPred (Type co) 
-          | (ty1, ty2) <- getEqPredTys eqPred
-          = Type $ mkSymCoercion (substTy theta ty1)
-                  `mkTransCoercion` co
-                  `mkTransCoercion` (substTy theta ty2)
-        new_co_args = zipWith cast_co_spec  dc_eq_spec  co_args_spec ++
-                      zipWith cast_co_theta dc_eq_theta co_args_theta
-  
-          -- ...and now value arguments
-       new_val_args = zipWith cast_arg arg_tys val_args
-       cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg
-
-    in
-    ASSERT( length univ_args == tc_arity )
-    ASSERT( from_tc == dataConTyCon dc )
-    ASSERT( and (zipWith coreEqType [t | Type t <- univ_args] from_tc_arg_tys) )
-    ASSERT( all isTypeArg (univ_args ++ ex_args) )
-    ASSERT2( equalLength val_args arg_tys, ppr dc $$ ppr dc_tyvars $$ ppr dc_ex_tyvars $$ ppr arg_tys $$ ppr dc_args $$ ppr univ_args $$ ppr ex_args $$ ppr val_args $$ ppr arg_tys  )
-
-    Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args)
-    }}
-
-{-
--- We do not want to tell the world that we have a
--- Cons, to *stop* Case of Known Cons, which removes
--- the TickBox.
-exprIsConApp_maybe (Note (TickBox {}) expr)
-  = Nothing
-exprIsConApp_maybe (Note (BinaryTickBox {}) expr)
-  = Nothing
--}
-
-exprIsConApp_maybe (Note _ expr)
-  = exprIsConApp_maybe expr
-    -- We ignore InlineMe notes in case we have
-    -- x = __inline_me__ (a,b)
-    -- All part of making sure that INLINE pragmas never hurt
-    -- Marcin tripped on this one when making dictionaries more inlinable
-    --
-    -- In fact, we ignore all notes.  For example,
-    --         case _scc_ "foo" (C a b) of
-    --                 C a b -> e
-    -- should be optimised away, but it will be only if we look
-    -- through the SCC note.
-
-exprIsConApp_maybe expr = analyse (collectArgs expr)
-  where
-    analyse (Var fun, args)
-       | Just con <- isDataConWorkId_maybe fun,
-         args `lengthAtLeast` dataConRepArity con
-               -- Might be > because the arity excludes type args
-       = Just (con,args)
-
-       -- Look through unfoldings, but only cheap ones, because
-       -- we are effectively duplicating the unfolding
-    analyse (Var fun, [])
-       | let unf = idUnfolding fun,
-         isExpandableUnfolding unf
-       = exprIsConApp_maybe (unfoldingTemplate unf)
-
-    analyse _ = Nothing
  \end{code}
  
  \end{code}
  
-
-
  %************************************************************************
  %*                                                                     *
  %************************************************************************
  %*                                                                     *
-\subsection{Equality}
+         Equality
  %*                                                                     *
  %************************************************************************
  
  %*                                                                     *
  %************************************************************************
  
@@ -1007,6 +847,7 @@ exprIsBig :: Expr b -> Bool
  exprIsBig (Lit _)      = False
  exprIsBig (Var _)      = False
  exprIsBig (Type _)     = False
  exprIsBig (Lit _)      = False
  exprIsBig (Var _)      = False
  exprIsBig (Type _)     = False
+exprIsBig (Lam _ e)    = exprIsBig e
  exprIsBig (App f a)    = exprIsBig f || exprIsBig a
  exprIsBig (Cast e _)   = exprIsBig e   -- Hopefully coercions are not too big!
  exprIsBig _            = True
  exprIsBig (App f a)    = exprIsBig f || exprIsBig a
  exprIsBig (Cast e _)   = exprIsBig e   -- Hopefully coercions are not too big!
  exprIsBig _            = True
@@ -1039,7 +880,6 @@ exprSize (Type t)        = seqType t `seq` 1
  
  noteSize :: Note -> Int
  noteSize (SCC cc)       = cc `seq` 1
  
  noteSize :: Note -> Int
  noteSize (SCC cc)       = cc `seq` 1
-noteSize InlineMe       = 1
  noteSize (CoreNote s)   = s `seq` 1  -- hdaume: core annotations
   
  varSize :: Var -> Int
  noteSize (CoreNote s)   = s `seq` 1  -- hdaume: core annotations
   
  varSize :: Var -> Int
@@ -1195,7 +1035,7 @@ rhsIsStatic :: PackageId -> CoreExpr -> Bool
  -- This is a bit like CoreUtils.exprIsHNF, with the following differences:
  --    a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
  --
  -- This is a bit like CoreUtils.exprIsHNF, with the following differences:
  --    a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
  --
---    b) (C x xs), where C is a contructors is updatable if the application is
+--    b) (C x xs), where C is a contructor is updatable if the application is
  --        dynamic
  -- 
  --    c) don't look through unfolding of f in (f x).
  --        dynamic
  -- 
  --    c) don't look through unfolding of f in (f x).
diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs

index 6288b7e..3eb9cd9 100644 (file)
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ b/compiler/coreSyn/MkExternalCore.lhs
@@ -160,7 +160,6 @@ make_exp (Case e v ty alts) = do
    return $ C.Case scrut (make_vbind v) (make_ty ty) newAlts
  make_exp (Note (SCC _) e) = make_exp e >>= (return . C.Note "SCC") -- temporary
  make_exp (Note (CoreNote s) e) = make_exp e >>= (return . C.Note s)  -- hdaume: core annotations
    return $ C.Case scrut (make_vbind v) (make_ty ty) newAlts
  make_exp (Note (SCC _) e) = make_exp e >>= (return . C.Note "SCC") -- temporary
  make_exp (Note (CoreNote s) e) = make_exp e >>= (return . C.Note s)  -- hdaume: core annotations
-make_exp (Note InlineMe e) = make_exp e >>= (return . C.Note "InlineMe")
  make_exp _ = error "MkExternalCore died: make_exp"
  
  make_alt :: CoreAlt -> CoreM C.Alt
  make_exp _ = error "MkExternalCore died: make_exp"
  
  make_alt :: CoreAlt -> CoreM C.Alt
diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs

index 84bf868..55e192d 100644 (file)
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -32,6 +32,7 @@ import BasicTypes
  import Util
  import Outputable
  import FastString
  import Util
  import Outputable
  import FastString
+import Data.Maybe
  \end{code}
  
  %************************************************************************
  \end{code}
  
  %************************************************************************
@@ -215,9 +216,6 @@ ppr_expr add_par (Let bind expr)
  ppr_expr add_par (Note (SCC cc) expr)
    = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr])
  
  ppr_expr add_par (Note (SCC cc) expr)
    = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr])
  
-ppr_expr add_par (Note InlineMe expr)
-  = add_par $ ptext (sLit "__inline_me") <+> pprParendExpr expr
-
  ppr_expr add_par (Note (CoreNote s) expr)
    = add_par $ 
      sep [sep [ptext (sLit "__core_note"), pprHsString (mkFastString s)],
  ppr_expr add_par (Note (CoreNote s) expr)
    = add_par $ 
      sep [sep [ptext (sLit "__core_note"), pprHsString (mkFastString s)],
@@ -255,11 +253,8 @@ instance OutputableBndr Var where
  pprCoreBinder :: BindingSite -> Var -> SDoc
  pprCoreBinder LetBind binder
    | isTyVar binder = pprKindedTyVarBndr binder
  pprCoreBinder :: BindingSite -> Var -> SDoc
  pprCoreBinder LetBind binder
    | isTyVar binder = pprKindedTyVarBndr binder
-  | otherwise
-  = vcat [sig, pprIdExtras binder, pragmas]
-  where
-    sig     = pprTypedBinder binder
-    pragmas = ppIdInfo binder (idInfo binder)
+  | otherwise      = pprTypedBinder binder $$ 
+                    ppIdInfo binder (idInfo binder)
  
  -- Lambda bound type variables are preceded by "@"
  pprCoreBinder LambdaBind bndr 
  
  -- Lambda bound type variables are preceded by "@"
  pprCoreBinder LambdaBind bndr 
@@ -274,6 +269,9 @@ pprCoreBinder LambdaBind bndr
  
  -- Case bound things don't get a signature or a herald, unless we have debug on
  pprCoreBinder CaseBind bndr 
  
  -- Case bound things don't get a signature or a herald, unless we have debug on
  pprCoreBinder CaseBind bndr 
+  | isDeadBinder bndr   -- False for tyvars
+  = ptext (sLit "_")
+  | otherwise
    = getPprStyle $ \ sty ->
      if debugStyle sty then
         parens (pprTypedBinder bndr)
    = getPprStyle $ \ sty ->
      if debugStyle sty then
         parens (pprTypedBinder bndr)
@@ -290,7 +288,7 @@ pprTypedBinder :: Var -> SDoc
  -- Print binder with a type or kind signature (not paren'd)
  pprTypedBinder binder
    | isTyVar binder  = pprKindedTyVarBndr binder
  -- Print binder with a type or kind signature (not paren'd)
  pprTypedBinder binder
    | isTyVar binder  = pprKindedTyVarBndr binder
-  | otherwise      = pprIdBndr binder <+> dcolon <+> pprType (idType binder)
+  | otherwise      = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
  
  pprKindedTyVarBndr :: TyVar -> SDoc
  -- Print a type variable binder with its kind (but not if *)
  
  pprKindedTyVarBndr :: TyVar -> SDoc
  -- Print a type variable binder with its kind (but not if *)
@@ -316,55 +314,111 @@ pprIdBndrInfo info
      dmd_info  = newDemandInfo info
      lbv_info  = lbvarInfo info
  
      dmd_info  = newDemandInfo info
      lbv_info  = lbvarInfo info
  
-    no_info = isDefaultInlinePragma prag_info && isNoOcc occ_info && 
-             (case dmd_info of { Nothing -> True; Just d -> isTop d }) &&
-             hasNoLBVarInfo lbv_info
-
-    doc | no_info = empty
-       | otherwise
-        = brackets $ hsep [ppr prag_info, ppr occ_info, 
-                          ppr dmd_info, ppr lbv_info
-#ifdef OLD_STRICTNESS
-                          , ppr (demandInfo id)
-#endif
-                         ]
+    has_prag = not (isDefaultInlinePragma prag_info)
+    has_occ  = not (isNoOcc occ_info)
+    has_dmd  = case dmd_info of { Nothing -> False; Just d -> not (isTop d) }
+    has_lbv  = not (hasNoLBVarInfo lbv_info)
+
+    doc = showAttributes 
+         [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info)
+         , (has_occ,  ptext (sLit "Occ=") <> ppr occ_info)
+         , (has_dmd,  ptext (sLit "Dmd=") <> ppr dmd_info)
+         , (has_lbv , ptext (sLit "Lbv=") <> ppr lbv_info)
+         ]
  \end{code}
  
  
  \end{code}
  
  
+-----------------------------------------------------
+--     IdDetails and IdInfo
+-----------------------------------------------------
+
  \begin{code}
  \begin{code}
-pprIdExtras :: Id -> SDoc
-pprIdExtras id = pp_scope <> ppr (idDetails id)
+ppIdInfo :: Id -> IdInfo -> SDoc
+ppIdInfo id info
+  = showAttributes
+    [ (True, pp_scope <> ppr (idDetails id))
+    , (has_arity,      ptext (sLit "Arity=") <> int arity)
+    , (has_caf_info,   ptext (sLit "Caf=") <> ppr caf_info)
+    , (has_strictness, ptext (sLit "Str=") <> pprNewStrictness str_info)
+    , (has_unf,        ptext (sLit "Unf=") <> ppr unf_info)
+    , (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules))
+    ]  -- Inline pragma, occ, demand, lbvar info
+       -- printed out with all binders (when debug is on); 
+       -- see PprCore.pprIdBndr
    where
      pp_scope | isGlobalId id   = ptext (sLit "GblId")
              | isExportedId id = ptext (sLit "LclIdX")
              | otherwise       = ptext (sLit "LclId")
  
    where
      pp_scope | isGlobalId id   = ptext (sLit "GblId")
              | isExportedId id = ptext (sLit "LclIdX")
              | otherwise       = ptext (sLit "LclId")
  
-ppIdInfo :: Id -> IdInfo -> SDoc
-ppIdInfo _ info
-  = brackets $
-    vcat [  ppArityInfo a,
-           ppWorkerInfo (workerInfo info),
-           ppCafInfo (cafInfo info),
-#ifdef OLD_STRICTNESS
-           ppStrictnessInfo s,
-            ppCprInfo m,
-#endif
-           pprNewStrictness (newStrictnessInfo info),
-           if null rules then empty
-           else ptext (sLit "RULES:") <+> vcat (map pprRule rules)
-       -- Inline pragma, occ, demand, lbvar info
-       -- printed out with all binders (when debug is on); 
-       -- see PprCore.pprIdBndr
-       ]
-  where
-    a = arityInfo info
-#ifdef OLD_STRICTNESS
-    s = strictnessInfo info
-    m = cprInfo info
-#endif
+    arity = arityInfo info
+    has_arity = arity /= 0
+
+    caf_info = cafInfo info
+    has_caf_info = not (mayHaveCafRefs caf_info)
+
+    str_info = newStrictnessInfo info
+    has_strictness = isJust str_info
+
+    unf_info = unfoldingInfo info
+    has_unf = hasSomeUnfolding unf_info
+
      rules = specInfoRules (specInfo info)
      rules = specInfoRules (specInfo info)
+
+showAttributes :: [(Bool,SDoc)] -> SDoc
+showAttributes stuff 
+  | null docs = empty
+  | otherwise = brackets (sep (punctuate comma docs))
+  where
+    docs = [d | (True,d) <- stuff]
+\end{code}
+
+-----------------------------------------------------
+--     Unfolding and UnfoldingGuidance
+-----------------------------------------------------
+
+\begin{code}
+instance Outputable UnfoldingGuidance where
+    ppr UnfoldNever  = ptext (sLit "NEVER")
+    ppr UnfoldAlways = ptext (sLit "ALWAYS")
+    ppr (InlineRule { ug_ir_info = inl_info, ug_small = small })
+      = ptext (sLit "InlineRule") <> ppr (inl_info,small)
+    ppr (UnfoldIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
+      = hsep [ ptext (sLit "IF_ARGS"), 
+              brackets (hsep (map int cs)),
+              int size,
+              int discount ]
+
+instance Outputable InlineRuleInfo where
+  ppr (InlWrapper w) = ptext (sLit "worker=") <> ppr w
+  ppr InlSat         = ptext (sLit "sat")
+  ppr InlUnSat       = ptext (sLit "unsat")
+
+instance Outputable Unfolding where
+  ppr NoUnfolding             = ptext (sLit "No unfolding")
+  ppr (OtherCon cs)           = ptext (sLit "OtherCon") <+> ppr cs
+  ppr (DFunUnfolding con ops) = ptext (sLit "DFun") <+> ppr con
+                                 <+> brackets (pprWithCommas pprParendExpr ops)
+  ppr (CoreUnfolding { uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf, uf_is_cheap=cheap
+                    , uf_expandable=exp, uf_guidance=g, uf_arity=arity}) 
+       = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs)
+    where
+      pp_info = hsep [ ptext (sLit "TopLvl=") <> ppr top 
+                     , ptext (sLit "Arity=") <> int arity
+                     , ptext (sLit "Value=") <> ppr hnf
+                     , ptext (sLit "Cheap=") <> ppr cheap
+                     , ptext (sLit "Expandable=") <> ppr exp
+                     , ppr g ]
+      pp_rhs = case g of
+                 UnfoldNever         -> usually_empty
+                 UnfoldIfGoodArgs {} -> usually_empty
+                  _other              -> ppr rhs
+      usually_empty = ifPprDebug (ppr rhs)
+            -- In this case show 'rhs' only in debug mode
  \end{code}
  
  \end{code}
  
+-----------------------------------------------------
+--     Rules
+-----------------------------------------------------
  
  \begin{code}
  instance Outputable CoreRule where
  
  \begin{code}
  instance Outputable CoreRule where
diff --git a/compiler/cprAnalysis/CprAnalyse.lhs b/compiler/cprAnalysis/CprAnalyse.lhs

index f28336b..14c8017 100644 (file)
--- a/compiler/cprAnalysis/CprAnalyse.lhs
+++ b/compiler/cprAnalysis/CprAnalyse.lhs
@@ -14,7 +14,7 @@ module CprAnalyse ( cprAnalyse ) where
  #include "HsVersions.h"
  
  import DynFlags
  #include "HsVersions.h"
  
  import DynFlags
-import CoreLint
+import CoreMonad
  import CoreSyn
  import CoreUtils
  import Id
  import CoreSyn
  import CoreUtils
  import Id
@@ -142,7 +142,7 @@ cprAnalyse dflags binds
          showPass dflags "Constructed Product analysis" ;
          let { binds_plus_cpr = do_prog binds } ;
          endPass dflags "Constructed Product analysis"
          showPass dflags "Constructed Product analysis" ;
          let { binds_plus_cpr = do_prog binds } ;
          endPass dflags "Constructed Product analysis"
-                Opt_D_dump_cpranal binds_plus_cpr
+                Opt_D_dump_cpranal binds_plus_cpr []
          return binds_plus_cpr
      }
    where
          return binds_plus_cpr
      }
    where
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs

index 521d1ad..7e284ae 100644 (file)
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -27,10 +27,8 @@ import DsExpr                ()      -- Forces DsExpr to be compiled; DsBinds only
  import Module
  import RdrName
  import NameSet
  import Module
  import RdrName
  import NameSet
-import VarSet
  import Rules
  import Rules
-import CoreLint
-import CoreFVs
+import CoreMonad       ( endPass )
  import ErrUtils
  import Outputable
  import SrcLoc
  import ErrUtils
  import Outputable
  import SrcLoc
@@ -107,7 +105,7 @@ deSugar hsc_env
         {       -- Add export flags to bindings
           keep_alive <- readIORef keep_var
         ; let final_prs = addExportFlags target export_set
         {       -- Add export flags to bindings
           keep_alive <- readIORef keep_var
         ; let final_prs = addExportFlags target export_set
-                                 keep_alive all_prs ds_rules
+                                 keep_alive all_prs 
               ds_binds  = [Rec final_prs]
         -- Notice that we put the whole lot in a big Rec, even the foreign binds
         -- When compiling PrelFloat, which defines data Float = F# Float#
               ds_binds  = [Rec final_prs]
         -- Notice that we put the whole lot in a big Rec, even the foreign binds
         -- When compiling PrelFloat, which defines data Float = F# Float#
@@ -116,7 +114,7 @@ deSugar hsc_env
         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
  
         -- Lint result if necessary
         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
  
         -- Lint result if necessary
-       ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds
+       ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds ds_rules
  
         -- Dump output
         ; doIfSet (dopt Opt_D_dump_ds dflags) 
  
         -- Dump output
         ; doIfSet (dopt Opt_D_dump_ds dflags) 
@@ -206,26 +204,17 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
  -- it's just because the type checker is rather busy already and
  -- I didn't want to pass in yet another mapping.
  
  -- it's just because the type checker is rather busy already and
  -- I didn't want to pass in yet another mapping.
  
-addExportFlags :: HscTarget -> NameSet -> NameSet -> [(Id, t)] -> [CoreRule]
+addExportFlags :: HscTarget -> NameSet -> NameSet -> [(Id, t)]
                 -> [(Id, t)]
                 -> [(Id, t)]
-addExportFlags target exports keep_alive prs rules
+addExportFlags target exports keep_alive prs
    = [(add_export bndr, rhs) | (bndr,rhs) <- prs]
    where
      add_export bndr
         | dont_discard bndr = setIdExported bndr
         | otherwise         = bndr
  
    = [(add_export bndr, rhs) | (bndr,rhs) <- prs]
    where
      add_export bndr
         | dont_discard bndr = setIdExported bndr
         | otherwise         = bndr
  
-    orph_rhs_fvs = unionVarSets [ ruleRhsFreeVars rule
-                               | rule <- rules, 
-                                 not (isLocalRule rule) ]
-       -- A non-local rule keeps alive the free vars of its right-hand side. 
-       -- (A "non-local" is one whose head function is not locally defined.)
-       -- Local rules are (later, after gentle simplification) 
-       -- attached to the Id, and that keeps the rhs free vars alive.
-
      dont_discard bndr = is_exported name
                      || name `elemNameSet` keep_alive
      dont_discard bndr = is_exported name
                      || name `elemNameSet` keep_alive
-                    || bndr `elemVarSet` orph_rhs_fvs 
                      where
                         name = idName bndr
  
                      where
                         name = idName bndr
  
@@ -260,7 +249,10 @@ dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
  dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
    = putSrcSpanDs loc $ 
      do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
  dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
    = putSrcSpanDs loc $ 
      do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
-       ; lhs'  <- dsLExpr lhs
+
+       ; lhs'  <- unsetOptM Opt_EnableRewriteRules $
+                  dsLExpr lhs  -- Note [Desugaring RULE lhss]
+
         ; rhs'  <- dsLExpr rhs
  
         -- Substitute the dict bindings eagerly,
         ; rhs'  <- dsLExpr rhs
  
         -- Substitute the dict bindings eagerly,
@@ -273,15 +265,21 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
                 -- NB: isLocalId is False of implicit Ids.  This is good becuase
                 -- we don't want to attach rules to the bindings of implicit Ids, 
                 -- because they don't show up in the bindings until just before code gen
                 -- NB: isLocalId is False of implicit Ids.  This is good becuase
                 -- we don't want to attach rules to the bindings of implicit Ids, 
                 -- because they don't show up in the bindings until just before code gen
-             fn_name   = idName fn_id
-
-             rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act,
-                           ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs', 
-                           ru_rough = roughTopNames args, 
-                           ru_local = local_rule }
+             fn_name = idName fn_id
+             rule    = mkRule local_rule name act fn_name bndrs args rhs' 
         ; return (Just rule)
         } } }
    where
      msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar; ignored"))
              2 (ppr lhs)
  \end{code}
         ; return (Just rule)
         } } }
    where
      msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar; ignored"))
              2 (ppr lhs)
  \end{code}
+
+Note [Desugaring RULE left hand sides]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For the LHS of a RULE we do *not* want to desugar
+    [x]   to    build (\cn. x `c` n)
+We want to leave explicit lists simply as chains
+of cons's. We can achieve that slightly indirectly by
+switching off EnableRewriteRules.
+
+That keeps the desugaring of list comprehensions simple too.
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs

index 515ac85..0222594 100644 (file)
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -17,18 +17,19 @@ module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs,
  
  #include "HsVersions.h"
  
  
  #include "HsVersions.h"
  
-import {-# SOURCE #-}  DsExpr( dsLExpr, dsExpr )
+import {-# SOURCE #-}  DsExpr( dsLExpr )
  import {-# SOURCE #-}  Match( matchWrapper )
  
  import DsMonad
  import DsGRHSs
  import DsUtils
  import {-# SOURCE #-}  Match( matchWrapper )
  
  import DsMonad
  import DsGRHSs
  import DsUtils
-import OccurAnal
  
  import HsSyn           -- lots of things
  import CoreSyn         -- lots of things
  
  import HsSyn           -- lots of things
  import CoreSyn         -- lots of things
+import CoreSubst
  import MkCore
  import CoreUtils
  import MkCore
  import CoreUtils
+import CoreUnfold
  import CoreFVs
  
  import TcType
  import CoreFVs
  
  import TcType
@@ -38,6 +39,7 @@ import Module
  import Id
  import MkId    ( seqId )
  import Var     ( Var, TyVar, tyVarKind )
  import Id
  import MkId    ( seqId )
  import Var     ( Var, TyVar, tyVarKind )
+import IdInfo  ( vanillaIdInfo )
  import VarSet
  import Rules
  import VarEnv
  import VarSet
  import Rules
  import VarEnv
@@ -48,8 +50,9 @@ import Bag
  import BasicTypes hiding ( TopLevel )
  import FastString
  import StaticFlags     ( opt_DsMultiTyVar )
  import BasicTypes hiding ( TopLevel )
  import FastString
  import StaticFlags     ( opt_DsMultiTyVar )
-import Util            ( mapSnd, mapAndUnzip, lengthExceeds )
+import Util            ( count, lengthExceeds )
  
  
+import MonadUtils
  import Control.Monad
  import Data.List
  \end{code}
  import Control.Monad
  import Data.List
  \end{code}
@@ -70,6 +73,7 @@ dsLHsBinds binds = ds_lhs_binds NoSccs binds
  
  ------------------------
  ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
  
  ------------------------
  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)
  
          -- scc annotation policy (see below)
  ds_lhs_binds auto_scc binds =  foldM (dsLHsBind auto_scc) [] (bagToList binds)
  
@@ -85,25 +89,30 @@ dsHsBind :: AutoScc
          -> HsBind Id
          -> DsM [(Id,CoreExpr)] -- Result
  
          -> HsBind Id
          -> DsM [(Id,CoreExpr)] -- Result
  
-dsHsBind _ rest (VarBind var expr) = do
-    core_expr <- dsLExpr expr
+dsHsBind _ rest (VarBind { var_id = var, var_rhs = expr, var_inline = 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
  
  
-        -- Dictionary bindings are always VarMonoBinds, so
-        -- we only need do this here
-    core_expr' <- addDictScc var core_expr
-    return ((var, core_expr') : rest)
+       ; 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
+       ; wrap_fn' <- dsCoercion co_fn 
+       ; return ((fun, wrap_fn' (mkLams args body')) : 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]
      ~~~~~~~~~~~~~~~~~~~~~~~~~
  
  {-  Note [Rules and inlining]
      ~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -132,10 +141,15 @@ dsHsBind _ rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) =
  dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
    = do { core_prs <- ds_lhs_binds NoSccs binds
         ; let env = mkABEnv exports
  dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
    = do { core_prs <- ds_lhs_binds NoSccs binds
         ; let env = mkABEnv exports
-             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)
+             ar_env = mkArityEnv binds
+             do_one (lcl_id, rhs) 
+               | Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
+               = ASSERT( null spec_prags )       -- Not overloaded
+                  makeCorePair gbl_id (lookupArity ar_env lcl_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) }
               locals'  = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
                         -- Note [Rules and inlining]
         ; return (map do_one core_prs ++ locals' ++ rest) }
@@ -192,63 +206,74 @@ dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
                         -- see if it has any impact; it is on by default
    =    -- Note [Abstracting over tyvars only]
      do { core_prs <- ds_lhs_binds NoSccs binds
                         -- see if it has any impact; it is on by default
    =    -- Note [Abstracting over tyvars only]
      do { core_prs <- ds_lhs_binds NoSccs binds
-       ; 
         ; let arby_env = mkArbitraryTypeEnv tyvars exports
         ; let arby_env = mkArbitraryTypeEnv tyvars exports
-              (lg_binds, core_prs') = mapAndUnzip do_one core_prs
               bndrs = mkVarSet (map fst core_prs)
  
               add_lets | core_prs `lengthExceeds` 10 = add_some
               bndrs = mkVarSet (map fst core_prs)
  
               add_lets | core_prs `lengthExceeds` 10 = add_some
-                      | otherwise                   = mkLets lg_binds
-             add_some rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
-                                   , b `elemVarSet` fvs] rhs
+                      | otherwise                   = mkLets
+             add_some lg_binds rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
+                                                         , b `elemVarSet` fvs] rhs
                 where
                   fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
  
                 where
                   fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
  
+             ar_env = mkArityEnv binds
               env = mkABEnv exports
  
               env = mkABEnv exports
  
-             do_one (lcl_id, rhs) 
-               | Just (id_tvs, gbl_id, _, prags) <- lookupVarEnv env lcl_id
-               = (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)
+             mk_lg_bind lcl_id gbl_id tyvars
+                = NonRec (setIdInfo lcl_id vanillaIdInfo)
+                               -- Nuke the IdInfo so that no old unfoldings
+                               -- confuse use (it might mention something not
+                               -- even in scope at the new site
+                         (mkTyApps (Var gbl_id) (mkTyVarTys tyvars))
+
+             do_one lg_binds (lcl_id, rhs) 
+               | Just (id_tvs, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
+               = ASSERT( null spec_prags )       -- Not overloaded
+                  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 lg_binds rhs
+                 in return (mk_lg_bind lcl_id gbl_id id_tvs,
+                            makeCorePair gbl_id (lookupArity ar_env lcl_id) rhs')
                 | otherwise
                 | otherwise
-               = (NonRec lcl_id (mkTyApps (Var non_exp_gbl_id) (mkTyVarTys tyvars)),
-                  (non_exp_gbl_id, mkLams tyvars (add_lets rhs)))
-               where
-                 non_exp_gbl_id = setIdType lcl_id (mkForAllTys tyvars (idType lcl_id))
+               = do { non_exp_gbl_id <- newUniqueId lcl_id (mkForAllTys tyvars (idType lcl_id))
+                    ; return (mk_lg_bind lcl_id non_exp_gbl_id tyvars,
+                             (non_exp_gbl_id, mkLams tyvars (add_lets lg_binds rhs))) }
                                                   
                                                   
+       ; (_, core_prs') <- fixDs (\ ~(lg_binds, _) -> mapAndUnzipM (do_one lg_binds) core_prs)
         ; return (core_prs' ++ rest) }
  
         -- Another common case: one exported variable
         -- Non-recursive bindings come through this way
         ; return (core_prs' ++ rest) }
  
         -- 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)
  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
+  = 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
      
      
-    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'
+       ; (spec_binds, rules) <- dsSpecs all_tyvars dicts tyvars global 
+                                        local inl_arity core_bind prags
+
+       ; let   global'   = addIdSpecialisations global rules
+               rhs       = addAutoScc auto_scc global $
+                           mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
+               main_bind = makeCorePair global' (inl_arity + dictArity dicts) rhs
      
      
-    return (bind  : spec_binds ++ rest)
+       ; return (main_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
  
  dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
    = do { core_prs <- ds_lhs_binds NoSccs binds
         ; let env = mkABEnv exports
-             do_one (lcl_id,rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id
-                                 = addInlinePrags prags lcl_id $
-                                   addAutoScc auto_scc gbl_id rhs
+             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)
                                   | otherwise = (lcl_id,rhs)
                
                 -- Rec because of mixed-up dictionary bindings
                                   | otherwise = (lcl_id,rhs)
                
                 -- Rec because of mixed-up dictionary bindings
@@ -263,18 +288,17 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
  
         ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)
  
  
         ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)
  
-       ; let mk_bind ((tyvars, global, local, prags), n)  -- locals!!n == local
+       ; let mk_bind ((tyvars, global, local, spec_prags), n)  -- locals!!n == local
                 =       -- Need to make fresh locals to bind in the selector,
                         -- because some of the tyvars will be bound to 'Any'
                   do { let ty_args = map mk_ty_arg all_tyvars
                            substitute = substTyWith all_tyvars ty_args
                      ; locals' <- newSysLocalsDs (map substitute local_tys)
                      ; tup_id  <- newSysLocalDs  (substitute tup_ty)
                 =       -- Need to make fresh locals to bind in the selector,
                         -- because some of the tyvars will be bound to 'Any'
                   do { let ty_args = map mk_ty_arg all_tyvars
                            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 core_bind) 
-                                        prags
-                    ; let (spec_binds, rules) = unzip (catMaybes mb_specs)
-                          global' = addIdSpecialisations global rules
+                    ; (spec_binds, rules) <- dsSpecs all_tyvars dicts tyvars global local 
+                                                     (lookupArity ar_env local) core_bind 
+                                                     spec_prags
+                    ; let global' = addIdSpecialisations global rules
                            rhs = mkLams tyvars $ mkLams dicts $
                                  mkTupleSelector locals' (locals' !! n) tup_id $
                                  mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
                            rhs = mkLams tyvars $ mkLams dicts $
                                  mkTupleSelector locals' (locals' !! n) tup_id $
                                  mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
@@ -286,23 +310,85 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
                         | otherwise               = dsMkArbitraryType all_tyvar
  
         ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
                         | 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)) }
  
  
         ; return ((poly_tup_id, poly_tup_expr) : 
                     (concat export_binds_s ++ rest)) }
  
-mkABEnv :: [([TyVar], Id, Id, [LPrag])] -> VarEnv ([TyVar], Id, Id, [LPrag])
+------------------------
+makeCorePair :: Id-> Arity -> CoreExpr -> (Id, CoreExpr)
+makeCorePair gbl_id arity rhs
+  = (addInline gbl_id arity rhs, rhs)
+
+------------------------
+type AbsBindEnv = VarEnv ([TyVar], Id, Id, [LSpecPrag])
+       -- Maps the "lcl_id" for an AbsBind to
+       -- its "gbl_id" and associated pragmas, if any
+
+mkABEnv :: [([TyVar], Id, Id, [LSpecPrag])] -> AbsBindEnv
  -- 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]
  
  -- 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 = foldrBag (plusVarEnv . lhsBindArity) emptyVarEnv binds
+
+lhsBindArity :: LHsBind Id -> IdEnv Arity
+lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) 
+  = unitVarEnv (unLoc id) (matchGroupArity ms)
+lhsBindArity (L _ (AbsBinds { abs_exports = exports
+                            , abs_dicts = dicts
+                            , abs_binds = binds })) 
+  = mkVarEnv [ (gbl, lookupArity ar_env lcl + n_val_dicts) 
+             | (_, gbl, lcl, _) <- exports]
+  where             -- See Note [Nested arities] 
+    ar_env = mkArityEnv binds
+    n_val_dicts = dictArity dicts      
+
+lhsBindArity _ = emptyVarEnv   -- PatBind/VarBind
+
+dictArity :: [Var] -> Arity
+-- Don't count coercion variables in arity
+dictArity dicts = count isId dicts
+
+lookupArity :: IdEnv Arity -> Id -> Arity
+lookupArity ar_env id = lookupVarEnv ar_env id `orElse` 0
+
+addInline :: Id -> Arity -> CoreExpr -> Id
+addInline id arity rhs 
+  | isInlinePragma (idInlinePragma id)
+       -- Add an Unfolding for an INLINE (but not for NOINLINE)
+  = id `setIdUnfolding` mkInlineRule InlSat rhs arity
+  | otherwise
+  = id
+\end{code}
+
+Nested arities
+~~~~~~~~~~~~~~
+For reasons that are not entirely clear, method bindings come out looking like
+this:
+
+  AbsBinds [] [] [$cfromT <= [] fromT]
+    $cfromT [InlPrag=INLINE] :: T Bool -> Bool
+    { AbsBinds [] [] [fromT <= [] fromT_1]
+        fromT :: T Bool -> Bool
+        { fromT_1 ((TBool b)) = not b } } }
+
+Note the nested AbsBind.  The arity for the InlineRule on $cfromT should be
+gotten from the binding for fromT_1.
+
+It might be better to have just one level of AbsBinds, but that requires more
+thought!
  
  
-dsSpec :: [TyVar] -> [DictId] -> [TyVar]
-       -> Id -> Id             -- Global, local
-       -> CoreBind -> LPrag
-       -> DsM (Maybe ((Id,CoreExpr),   -- Binding for specialised Id
-                     CoreRule))        -- Rule for the Global Id
  
  
+\begin{code}
+------------------------
+dsSpecs :: [TyVar] -> [DictId] -> [TyVar]
+        -> Id -> Id -> Arity           -- Global, local, arity of local
+        -> CoreBind -> [LSpecPrag]
+        -> DsM ( [(Id,CoreExpr)]       -- Binding for specialised Ids
+              , [CoreRule] )           -- Rules for the Global Ids
  -- Example:
  --     f :: (Eq a, Ix b) => a -> b -> b
  --     {-# SPECIALISE f :: Ix b => Int -> b -> b #-}
  -- Example:
  --     f :: (Eq a, Ix b) => a -> b -> b
  --     {-# SPECIALISE f :: Ix b => Int -> b -> b #-}
@@ -326,46 +412,60 @@ dsSpec :: [TyVar] -> [DictId] -> [TyVar]
  --
  -- It is *possible* that 'es' does not mention all of the dictionaries 'ds'
  -- (a bit silly, because then the 
  --
  -- It is *possible* that 'es' does not mention all of the dictionaries 'ds'
  -- (a bit silly, because then the 
-dsSpec _ _ _ _ _ _ (L _ (InlinePrag {}))
-  = return Nothing
-
-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
-       ; spec_name <- newLocalName poly_name
-       ; ds_spec_expr  <- dsExpr spec_expr
-       ; case (decomposeRuleLhs ds_spec_expr) of {
-           Nothing -> do { warnDs decomp_msg; return Nothing } ;
-
-           Just (bndrs, _fn, args) ->
-
-       -- Check for dead binders: Note [Unused spec binders]
-         case filter isDeadBinder bndrs of {
-               bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } 
-                  | otherwise -> do
-
-       { let     f_body = fix_up (Let mono_bind (Var mono_id))
-
-                 local_poly  = setIdNotExported poly_id
-                       -- Very important to make the 'f' non-exported,
-                       -- else it won't be inlined!
-                 spec_id     = mkLocalId spec_name spec_ty
-                 spec_rhs    = Let (NonRec local_poly poly_f_body) ds_spec_expr
-                 poly_f_body = mkLams (tvs ++ dicts) f_body
-                               
-                 extra_dict_bndrs = [localiseId d  -- See Note [Constant rule dicts]
-                                    | d <- varSetElems (exprFreeVars ds_spec_expr)
-                                    , isDictId d]
-                       -- Note [Const rule dicts]
-
-                 rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
-                               AlwaysActive poly_name
-                               (extra_dict_bndrs ++ bndrs) args
-                               (mkVarApps (Var spec_id) bndrs)
-       ; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
-       } } } }
-  where
+
+dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags
+  = do { pairs <- mapMaybeM spec_one prags
+       ; let (spec_binds_s, rules) = unzip pairs
+       ; return (concat spec_binds_s, rules) }
+ where 
+    spec_one :: LSpecPrag -> DsM (Maybe ([(Id,CoreExpr)], CoreRule))
+    spec_one (L loc (SpecPrag spec_co spec_inl))
+      = putSrcSpanDs loc $ 
+        do { let poly_name = idName poly_id
+          ; spec_name <- newLocalName poly_name
+          ; wrap_fn   <- dsCoercion spec_co
+           ; let ds_spec_expr = wrap_fn (Var poly_id)
+          ; case decomposeRuleLhs ds_spec_expr of {
+              Nothing -> do { warnDs (decomp_msg spec_co)
+                             ; return Nothing } ;
+
+              Just (bndrs, _fn, args) ->
+
+          -- Check for dead binders: Note [Unused spec binders]
+            case filter isDeadBinder bndrs of {
+               bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } 
+                  | otherwise -> do
+
+          { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (idUnfolding poly_id)
+
+          ; let f_body = fix_up (Let mono_bind (Var mono_id))
+                 spec_ty = exprType ds_spec_expr
+                spec_id  = mkLocalId spec_name spec_ty 
+                           `setInlinePragma` inl_prag
+                           `setIdUnfolding`  spec_unf
+                inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
+                         | otherwise                      = spec_inl
+                     -- Get the INLINE pragma from SPECIALISE declaration, or,
+                      -- failing that, from the original Id
+
+                spec_id_arity = inl_arity + count isDictId bndrs
+
+                extra_dict_bndrs = [ localiseId d  -- See Note [Constant rule dicts]
+                                        | d <- varSetElems (exprFreeVars ds_spec_expr)
+                                        , isDictId d]
+                               -- Note [Const rule dicts]
+
+                rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
+                               AlwaysActive poly_name
+                               (extra_dict_bndrs ++ bndrs) args
+                               (mkVarApps (Var spec_id) bndrs)
+
+                 spec_rhs = wrap_fn (mkLams (tvs ++ dicts) f_body)
+                 spec_pair = makeCorePair spec_id spec_id_arity spec_rhs
+
+           ; return (Just (spec_pair : unf_pairs, rule))
+           } } } }
+
         -- Bind to Any any of all_ptvs that aren't 
         -- relevant for this particular function 
      fix_up body | null void_tvs = body
         -- Bind to Any any of all_ptvs that aren't 
         -- relevant for this particular function 
      fix_up body | null void_tvs = body
@@ -380,10 +480,19 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
                        , ptext (sLit "SPECIALISE pragma ignored")]
      get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
  
                        , ptext (sLit "SPECIALISE pragma ignored")]
      get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
  
-    decomp_msg = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
-                   2 (ppr spec_expr)
+    decomp_msg spec_co 
+        = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
+            2 (pprHsWrapper (ppr poly_id) spec_co)
              
  
              
  
+specUnfolding :: (CoreExpr -> CoreExpr) -> Unfolding -> DsM (Unfolding, [(Id,CoreExpr)])
+specUnfolding wrap_fn (DFunUnfolding con ops)
+  = do { let spec_rhss = map wrap_fn ops
+       ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
+       ; return (DFunUnfolding con (map Var spec_ids), spec_ids `zip` spec_rhss) }
+specUnfolding _ _
+  = return (noUnfolding, [])
+
  mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
  -- If any of the tyvars is missing from any of the lists in 
  -- the second arg, return a binding in the result
  mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
  -- If any of the tyvars is missing from any of the lists in 
  -- the second arg, return a binding in the result
@@ -431,7 +540,7 @@ So for example when you have
         {-# SPECIALISE f :: Int -> Int #-}
  
  Then we get the SpecPrag
         {-# SPECIALISE f :: Int -> Int #-}
  
  Then we get the SpecPrag
-       SpecPrag (f Int dInt) Int
+       SpecPrag (f Int dInt) 
  
  And from that we want the rule
         
  
  And from that we want the rule
         
@@ -457,81 +566,31 @@ 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 
  -- That is, the RULE binders are lambda-bound
  -- Returns Nothing if the LHS isn't of the expected shape
  decomposeRuleLhs lhs 
-  = case (decomp emptyVarEnv body) of
-       Nothing         -> Nothing
-       Just (fn, args) -> Just (bndrs, fn, args)
-  where
-    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 (Case scrut bndr ty [(DEFAULT, _, body)])
-        | isDeadBinder bndr    -- Note [Matching seqId]
-        = Just (seqId, [Type (idType bndr), Type ty, 
-                        simpleSubst env scrut, simpleSubst env 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.)
+  = case collectArgs body of
+        (Var fn, args) -> Just (bndrs, fn, args)
  
  
-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 prag is_inline) bndr rhs
-  = (attach_pragma bndr prag, wrap_inline is_inline rhs)
+        (Case scrut bndr ty [(DEFAULT, _, body)], args)
+               | isDeadBinder bndr     -- Note [Matching seqId]
+               -> Just (bndrs, seqId, args' ++ args)
+               where
+                  args' = [Type (idType bndr), Type ty, scrut, body]
+          
+       _other -> Nothing       -- Unexpected shape
    where
    where
-    attach_pragma bndr prag
-        | isDefaultInlinePragma prag = bndr
-        | otherwise                  = bndr `setInlinePragma` prag
-
-    wrap_inline True  body = mkInlineMe body
-    wrap_inline False body = body
+    (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
  \end{code}
  
  \end{code}
  
-Note [Matching seq]
+Note [Matching seqId]
  ~~~~~~~~~~~~~~~~~~~
  The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
  and this code turns it back into an application of seq!  
  ~~~~~~~~~~~~~~~~~~~
  The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
  and this code turns it back into an application of seq!  
@@ -589,25 +648,19 @@ addDictScc _ rhs = return rhs
  
  
  \begin{code}
  
  
  \begin{code}
-dsCoercion :: HsWrapper -> DsM CoreExpr -> DsM CoreExpr
-dsCoercion WpHole           thing_inside = thing_inside
-dsCoercion (WpCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
-dsCoercion (WpCast co)       thing_inside = do { expr <- thing_inside
-                                              ; return (Cast expr co) }
-dsCoercion (WpLam id)        thing_inside = do { expr <- thing_inside
-                                              ; return (Lam id expr) }
-dsCoercion (WpTyLam tv)      thing_inside = do { expr <- thing_inside
-                                              ; return (Lam tv expr) }
-dsCoercion (WpApp v)         thing_inside   
-          | isTyVar v                    = do { expr <- thing_inside
-               {- Probably a coercion var -}  ; return (App expr (Type (mkTyVarTy v))) }
-          | otherwise                    = do { expr <- 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) }
+dsCoercion :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
+dsCoercion WpHole           = return (\e -> e)
+dsCoercion (WpCompose c1 c2) = do { k1 <- dsCoercion c1 
+                                  ; k2 <- dsCoercion c2
+                                  ; return (k1 . k2) }
+dsCoercion (WpCast co)       = return (\e -> Cast e co) 
+dsCoercion (WpLam id)        = return (\e -> Lam id e) 
+dsCoercion (WpTyLam tv)      = return (\e -> Lam tv e) 
+dsCoercion (WpApp v)         | isTyVar v   -- Probably a coercion var
+                             = return (\e -> App e (Type (mkTyVarTy v)))
+                            | otherwise
+                             = return (\e -> App e (Var v))
+dsCoercion (WpTyApp ty)      = return (\e -> App e (Type ty))
+dsCoercion (WpLet bs)        = do { prs <- dsLHsBinds bs
+                                 ; return (\e -> Let (Rec prs) e) }
  \end{code}
  \end{code}
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs

index 6d7d762..94009fd 100644 (file)
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -51,6 +51,7 @@ import StaticFlags
  import CostCentre
  import Id
  import Var
  import CostCentre
  import Id
  import Var
+import VarSet
  import PrelInfo
  import DataCon
  import TysWiredIn
  import PrelInfo
  import DataCon
  import TysWiredIn
@@ -210,7 +211,9 @@ dsExpr (HsVar var)                = return (Var var)
  dsExpr (HsIPVar ip)                  = return (Var (ipNameName ip))
  dsExpr (HsLit lit)                   = dsLit lit
  dsExpr (HsOverLit lit)               = dsOverLit lit
  dsExpr (HsIPVar ip)                  = return (Var (ipNameName ip))
  dsExpr (HsLit lit)                   = dsLit lit
  dsExpr (HsOverLit lit)               = dsOverLit lit
-dsExpr (HsWrap co_fn e)       = dsCoercion co_fn (dsExpr e)
+dsExpr (HsWrap co_fn e)       = do { co_fn' <- dsCoercion co_fn
+                                   ; e' <- dsExpr e
+                                   ; return (co_fn' e') }
  
  dsExpr (NegApp expr neg_expr) 
    = App <$> dsExpr neg_expr <*> dsLExpr expr
  
  dsExpr (NegApp expr neg_expr) 
    = App <$> dsExpr neg_expr <*> dsLExpr expr
@@ -645,7 +648,6 @@ makes all list literals be generated via the simple route.
  
  
  \begin{code}
  
  
  \begin{code}
-
  dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
  -- See Note [Desugaring explicit lists]
  dsExplicitList elt_ty xs
  dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
  -- See Note [Desugaring explicit lists]
  dsExplicitList elt_ty xs
diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs

index 83dac63..5340039 100644 (file)
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -19,6 +19,7 @@ import DsMonad
  import HsSyn
  import DataCon
  import CoreUtils
  import HsSyn
  import DataCon
  import CoreUtils
+import CoreUnfold
  import Id
  import Literal
  import Module
  import Id
  import Literal
  import Module
@@ -205,9 +206,10 @@ 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
          -- Build the wrapper
          work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
          wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
-        wrap_rhs     = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
+        wrap_rhs     = mkLams (tvs ++ args) wrapper_body
+        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineRule InlSat wrap_rhs (length args)
      
      
-    return ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty)
+    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty)
  \end{code}
  
  
  \end{code}
  
  
@@ -567,8 +569,8 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
                                                 <> comma <> text "cap") <> semi
       ,   assignCResult
       ,   ptext (sLit "rts_unlock(cap);")
                                                 <> comma <> text "cap") <> semi
       ,   assignCResult
       ,   ptext (sLit "rts_unlock(cap);")
-     ,   if res_hty_is_unit then empty
-            else if libffi 
+     ,   ppUnless res_hty_is_unit $
+         if libffi 
                    then char '*' <> parens (cResType <> char '*') <> 
                         ptext (sLit "resp = cret;")
                    else ptext (sLit "return cret;")
                    then char '*' <> parens (cResType <> char '*') <> 
                         ptext (sLit "resp = cret;")
                    else ptext (sLit "return cret;")
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs

index 162e90f..d0d3f4c 100644 (file)
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -36,11 +36,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.
  -- 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
+import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName ) 
  
  import Module
  import Id
  
  import Module
  import Id
-import Name
+import Name hiding( isVarOcc, isTcOcc, varName, tcName ) 
  import NameEnv
  import TcType
  import TyCon
  import NameEnv
  import TcType
  import TyCon
@@ -435,35 +435,38 @@ rep_proto nm ty loc
         ; return [(loc, sig)]
         }
  
         ; return [(loc, sig)]
         }
  
-rep_inline :: Located Name -> InlineSpec -> SrcSpan 
+rep_inline :: Located Name 
+           -> InlinePragma     -- Never defaultInlinePragma
+           -> SrcSpan 
             -> DsM [(SrcSpan, Core TH.DecQ)]
  rep_inline nm ispec loc
    = do { nm1 <- lookupLOcc nm
             -> DsM [(SrcSpan, Core TH.DecQ)]
  rep_inline nm ispec loc
    = do { nm1 <- lookupLOcc nm
-       ; (_, ispec1) <- rep_InlineSpec ispec
+       ; ispec1 <- rep_InlinePrag ispec
         ; pragma <- repPragInl nm1 ispec1
         ; return [(loc, pragma)]
         }
  
         ; pragma <- repPragInl nm1 ispec1
         ; return [(loc, pragma)]
         }
  
-rep_specialise :: Located Name -> LHsType Name -> InlineSpec -> SrcSpan 
+rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan 
                 -> DsM [(SrcSpan, Core TH.DecQ)]
  rep_specialise nm ty ispec loc
    = do { nm1 <- lookupLOcc nm
         ; ty1 <- repLTy ty
                 -> DsM [(SrcSpan, Core TH.DecQ)]
  rep_specialise nm ty ispec loc
    = do { nm1 <- lookupLOcc nm
         ; ty1 <- repLTy ty
-       ; (hasSpec, ispec1) <- rep_InlineSpec ispec
-       ; pragma <- if hasSpec
-                   then repPragSpecInl nm1 ty1 ispec1
-                   else repPragSpec    nm1 ty1 
+       ; pragma <- if isDefaultInlinePragma ispec
+                   then repPragSpec nm1 ty1                  -- SPECIALISE
+                   else do { ispec1 <- rep_InlinePrag ispec  -- SPECIALISE INLINE
+                           ; repPragSpecInl nm1 ty1 ispec1 } 
         ; return [(loc, pragma)]
         }
  
         ; return [(loc, pragma)]
         }
  
--- extract all the information needed to build a TH.InlineSpec
+-- Extract all the information needed to build a TH.InlinePrag
  --
  --
-rep_InlineSpec :: InlineSpec -> DsM (Bool, Core TH.InlineSpecQ)
-rep_InlineSpec (Inline (InlinePragma activation match) inline)
+rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma
+               -> DsM (Core TH.InlineSpecQ)
+rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline })
    | Nothing            <- activation1 
    | Nothing            <- activation1 
-    = liftM ((,) False) $ repInlineSpecNoPhase inline1 match1
+    = repInlineSpecNoPhase inline1 match1
    | Just (flag, phase) <- activation1 
    | Just (flag, phase) <- activation1 
-    = liftM ((,) True)  $ repInlineSpecPhase inline1 match1 flag phase
+    = repInlineSpecPhase inline1 match1 flag phase
    | otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec"
      where
        match1      = coreBool (rep_RuleMatchInfo match)
    | otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec"
      where
        match1      = coreBool (rep_RuleMatchInfo match)
@@ -473,8 +476,8 @@ rep_InlineSpec (Inline (InlinePragma activation match) inline)
        rep_RuleMatchInfo FunLike = False
        rep_RuleMatchInfo ConLike = True
  
        rep_RuleMatchInfo FunLike = False
        rep_RuleMatchInfo ConLike = True
  
-      rep_Activation NeverActive          = Nothing
-      rep_Activation AlwaysActive         = Nothing
+      rep_Activation NeverActive          = Nothing    -- We never have NOINLINE/AlwaysActive
+      rep_Activation AlwaysActive         = Nothing    -- or            INLINE/NeverActive
        rep_Activation (ActiveBefore phase) = Just (coreBool False, 
                                                    MkC $ mkIntExprInt phase)
        rep_Activation (ActiveAfter phase)  = Just (coreBool True, 
        rep_Activation (ActiveBefore phase) = Just (coreBool False, 
                                                    MkC $ mkIntExprInt phase)
        rep_Activation (ActiveAfter phase)  = Just (coreBool True, 
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs

index fa96811..5245eaa 100644 (file)
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -9,7 +9,7 @@
  module DsMonad (
         DsM, mapM, mapAndUnzipM,
         initDs, initDsTc, fixDs,
  module DsMonad (
         DsM, mapM, mapAndUnzipM,
         initDs, initDsTc, fixDs,
-       foldlM, foldrM, ifOptM,
+       foldlM, foldrM, ifOptM, unsetOptM,
         Applicative(..),(<$>),
  
         newLocalName,
         Applicative(..),(<$>),
  
         newLocalName,
@@ -221,8 +221,8 @@ it easier to read debugging output.
  
  \begin{code}
  -- Make a new Id with the same print name, but different type, and new unique
  
  \begin{code}
  -- Make a new Id with the same print name, but different type, and new unique
-newUniqueId :: Name -> Type -> DsM Id
-newUniqueId id = mkSysLocalM (occNameFS (nameOccName id))
+newUniqueId :: Id -> Type -> DsM Id
+newUniqueId id = mkSysLocalM (occNameFS (nameOccName (idName id)))
  
  duplicateLocalDs :: Id -> DsM Id
  duplicateLocalDs old_local 
  
  duplicateLocalDs :: Id -> DsM Id
  duplicateLocalDs old_local 
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs

index d90f904..d676911 100644 (file)
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -344,10 +344,11 @@ matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
  -- Apply the coercion to the match variable and then match that
  matchCoercion (var:vars) ty (eqns@(eqn1:_))
    = do { let CoPat co pat _ = firstPat eqn1
  -- Apply the coercion to the match variable and then match that
  matchCoercion (var:vars) ty (eqns@(eqn1:_))
    = do { let CoPat co pat _ = firstPat eqn1
-       ; var' <- newUniqueId (idName var) (hsPatType pat)
+       ; var' <- newUniqueId var (hsPatType pat)
         ; match_result <- match (var':vars) ty (map decomposeFirst_Coercion eqns)
         ; match_result <- match (var':vars) ty (map decomposeFirst_Coercion eqns)
-       ; rhs <- dsCoercion co (return (Var var))
-       ; return (mkCoLetMatchResult (NonRec var' rhs) match_result) }
+       ; co' <- dsCoercion co
+        ; let rhs' = co' (Var var)
+       ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) }
  
  matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
  -- Apply the view function to the match variable and then match that
  
  matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
  -- Apply the view function to the match variable and then match that
@@ -357,7 +358,7 @@ matchView (var:vars) ty (eqns@(eqn1:_))
           -- to figure out the type of the fresh variable
           let ViewPat viewExpr (L _ pat) _ = firstPat eqn1
           -- do the rest of the compilation 
           -- to figure out the type of the fresh variable
           let ViewPat viewExpr (L _ pat) _ = firstPat eqn1
           -- do the rest of the compilation 
-       ; var' <- newUniqueId (idName var) (hsPatType pat)
+       ; var' <- newUniqueId var (hsPatType pat)
         ; match_result <- match (var':vars) ty (map decomposeFirst_View eqns)
           -- compile the view expressions
         ; viewExpr' <- dsLExpr viewExpr
         ; match_result <- match (var':vars) ty (map decomposeFirst_View eqns)
           -- compile the view expressions
         ; viewExpr' <- dsLExpr viewExpr
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs

index 56ec2d7..0ff2691 100644 (file)
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -394,20 +394,22 @@ cvtPragmaD (SpecialiseP nm ty opt_ispec)
         ; ty' <- cvtType ty
         ; return $ SpecSig nm' ty' (cvtInlineSpec opt_ispec) }
  
         ; ty' <- cvtType ty
         ; return $ SpecSig nm' ty' (cvtInlineSpec opt_ispec) }
  
-cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlineSpec
+cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlinePragma
  cvtInlineSpec Nothing 
  cvtInlineSpec Nothing 
-  = defaultInlineSpec
+  = defaultInlinePragma
  cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) 
  cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) 
-  = mkInlineSpec opt_activation' matchinfo inline
+  = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo, inl_inline = inline }
    where
      matchinfo       = cvtRuleMatchInfo conlike
    where
      matchinfo       = cvtRuleMatchInfo conlike
-    opt_activation' = fmap cvtActivation opt_activation
+    opt_activation' = cvtActivation opt_activation
  
      cvtRuleMatchInfo False = FunLike
      cvtRuleMatchInfo True  = ConLike
  
  
      cvtRuleMatchInfo False = FunLike
      cvtRuleMatchInfo True  = ConLike
  
-    cvtActivation (False, phase) = ActiveBefore phase
-    cvtActivation (True , phase) = ActiveAfter  phase
+    cvtActivation Nothing | inline      = AlwaysActive
+                          | otherwise   = NeverActive
+    cvtActivation (Just (False, phase)) = ActiveBefore phase
+    cvtActivation (Just (True , phase)) = ActiveAfter  phase
  
  ---------------------------------------------------
  --             Declarations
  
  ---------------------------------------------------
  --             Declarations
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs

index 0cf7966..a6d8523 100644 (file)
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -16,7 +16,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
  
  module HsBinds where
  
  
  module HsBinds where
  
-import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr,
+import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
                                MatchGroup, pprFunBind,
                                GRHSs, pprPatBind )
  import {-# SOURCE #-} HsPat  ( LPat )
                                MatchGroup, pprFunBind,
                                GRHSs, pprPatBind )
  import {-# SOURCE #-} HsPat  ( LPat )
@@ -130,8 +130,10 @@ data HsBindLR idL idR
      }
  
    | VarBind {  -- Dictionary binding and suchlike 
      }
  
    | VarBind {  -- Dictionary binding and suchlike 
-       var_id :: idL,          -- All VarBinds are introduced by the type checker
-       var_rhs :: LHsExpr idR  -- Located only for consistency
+       var_id     :: idL,           -- All VarBinds are introduced by the type checker
+       var_rhs    :: LHsExpr idR,   -- Located only for consistency
+       var_inline :: Bool           -- True <=> inline this binding regardless
+                                    -- (used for implication constraints only)
      }
  
    | AbsBinds {                                 -- Binds abstraction; TRANSLATION
      }
  
    | AbsBinds {                                 -- Binds abstraction; TRANSLATION
@@ -141,7 +143,7 @@ data HsBindLR idL idR
         -- AbsBinds only gets used when idL = idR after renaming,
         -- but these need to be idL's for the collect... code in HsUtil to have
         -- the right type
         -- AbsBinds only gets used when idL = idR after renaming,
         -- but these need to be idL's for the collect... code in HsUtil to have
         -- the right type
-       abs_exports :: [([TyVar], idL, idL, [LPrag])],  -- (tvs, poly_id, mono_id, prags)
+       abs_exports :: [([TyVar], idL, idL, [LSpecPrag])],      -- (tvs, poly_id, mono_id, prags)
         abs_binds   :: LHsBinds idL             -- The dictionary bindings and typechecked user bindings
                                                 -- mixed up together; you can tell the dict bindings because
                                                 -- they are all VarBinds
         abs_binds   :: LHsBinds idL             -- The dictionary bindings and typechecked user bindings
                                                 -- mixed up together; you can tell the dict bindings because
                                                 -- they are all VarBinds
@@ -363,7 +365,6 @@ data HsWrapper
  
    | WpLam Var                  -- \d. []       the 'd' is a type-class dictionary or coercion variable
    | WpTyLam TyVar              -- \a. []       the 'a' is a type variable (not coercion var)
  
    | WpLam Var                  -- \d. []       the 'd' is a type-class dictionary or coercion variable
    | WpTyLam TyVar              -- \a. []       the 'a' is a type variable (not coercion var)
-  | WpInline                   -- inline_me []   Wrap inline around the thing
  
         -- Non-empty bindings, so that the identity coercion
         -- is always exactly WpHole
  
         -- Non-empty bindings, so that the identity coercion
         -- is always exactly WpHole
@@ -384,7 +385,6 @@ pprHsWrapper it wrap =
          help it (WpLam id)    = sep [ptext (sLit "\\") <> pprBndr LambdaBind id <> dot, it]
          help it (WpTyLam tv)  = sep [ptext (sLit "/\\") <> pprBndr LambdaBind tv <> dot, it]
          help it (WpLet binds) = sep [ptext (sLit "let") <+> braces (ppr binds), it]
          help it (WpLam id)    = sep [ptext (sLit "\\") <> pprBndr LambdaBind id <> dot, it]
          help it (WpTyLam tv)  = sep [ptext (sLit "/\\") <> pprBndr LambdaBind tv <> dot, it]
          help it (WpLet binds) = sep [ptext (sLit "let") <+> braces (ppr binds), it]
-        help it WpInline      = sep [ptext (sLit "_inline_me_"), it]
      in
        -- in debug mode, print the wrapper
        -- otherwise just print what's inside
      in
        -- in debug mode, print the wrapper
        -- otherwise just print what's inside
@@ -452,13 +452,15 @@ data Sig name     -- Signatures and pragmas
         -- An inline pragma
         -- {#- INLINE f #-}
    | InlineSig  (Located name)  -- Function name
         -- An inline pragma
         -- {#- INLINE f #-}
    | InlineSig  (Located name)  -- Function name
-               InlineSpec
+               InlinePragma    -- Never defaultInlinePragma
  
         -- A specialisation pragma
         -- {-# SPECIALISE f :: Int -> Int #-}
    | SpecSig    (Located name)  -- Specialise a function or datatype ...
                 (LHsType name)  -- ... to these types
  
         -- A specialisation pragma
         -- {-# SPECIALISE f :: Int -> Int #-}
    | SpecSig    (Located name)  -- Specialise a function or datatype ...
                 (LHsType name)  -- ... to these types
-               InlineSpec
+               InlinePragma    -- The pragma on SPECIALISE_INLINE form
+                               -- If it's just defaultInlinePragma, then we said
+                               --    SPECIALISE, not SPECIALISE_INLINE
  
         -- A specialisation pragma for instance declarations only
         -- {-# SPECIALISE instance Eq [Int] #-}
  
         -- A specialisation pragma for instance declarations only
         -- {-# SPECIALISE instance Eq [Int] #-}
@@ -470,23 +472,11 @@ type LFixitySig name = Located (FixitySig name)
  data FixitySig name = FixitySig (Located name) Fixity 
  
  -- A Prag conveys pragmas from the type checker to the desugarer
  data FixitySig name = FixitySig (Located name) Fixity 
  
  -- A Prag conveys pragmas from the type checker to the desugarer
-type LPrag = Located Prag
-data Prag 
-  = InlinePrag 
-       InlineSpec
-
-  | SpecPrag   
-       (HsExpr Id)     -- An expression, of the given specialised type, which
-       PostTcType      -- specialises the polymorphic function
-       InlineSpec      -- Inlining spec for the specialised function
-
-isInlinePrag :: Prag -> Bool
-isInlinePrag (InlinePrag _) = True
-isInlinePrag _              = False
-
-isSpecPrag :: Prag -> Bool
-isSpecPrag (SpecPrag {}) = True
-isSpecPrag _             = False
+type LSpecPrag = Located SpecPrag
+data SpecPrag 
+  = SpecPrag   
+       HsWrapper       -- An wrapper, that specialises the polymorphic function
+       InlinePragma    -- Inlining spec for the specialised function
  \end{code}
  
  \begin{code}
  \end{code}
  
  \begin{code}
@@ -585,10 +575,10 @@ instance (OutputableBndr name) => Outputable (Sig name) where
      ppr sig = ppr_sig sig
  
  ppr_sig :: OutputableBndr name => Sig name -> SDoc
      ppr sig = ppr_sig sig
  
  ppr_sig :: OutputableBndr name => Sig name -> SDoc
-ppr_sig (TypeSig var ty)         = pprVarSig (unLoc var) ty
-ppr_sig (IdSig id)               = pprVarSig id (varType id)
+ppr_sig (TypeSig var ty)         = pprVarSig (unLoc var) (ppr ty)
+ppr_sig (IdSig id)               = pprVarSig id (ppr (varType id))
  ppr_sig (FixSig fix_sig)         = ppr fix_sig
  ppr_sig (FixSig fix_sig)         = ppr fix_sig
-ppr_sig (SpecSig var ty inl)     = pragBrackets (pprSpec var ty inl)
+ppr_sig (SpecSig var ty inl)     = pragBrackets (pprSpec var (ppr ty) inl)
  ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> ppr var)
  ppr_sig (SpecInstSig ty)         = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
  
  ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> ppr var)
  ppr_sig (SpecInstSig ty)         = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
  
@@ -598,14 +588,16 @@ instance Outputable name => Outputable (FixitySig name) where
  pragBrackets :: SDoc -> SDoc
  pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}") 
  
  pragBrackets :: SDoc -> SDoc
  pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}") 
  
-pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc
-pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)]
+pprVarSig :: (Outputable id) => id -> SDoc -> SDoc
+pprVarSig var pp_ty = sep [ppr var <+> dcolon, nest 2 pp_ty]
  
  
-pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc
-pprSpec var ty inl = sep [ptext (sLit "SPECIALIZE") <+> ppr inl <+> pprVarSig var ty]
+pprSpec :: (Outputable id) => id -> SDoc -> InlinePragma -> SDoc
+pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var pp_ty
+  where
+    pp_inl | isDefaultInlinePragma inl = empty
+           | otherwise = ppr inl
  
  
-pprPrag :: Outputable id => id -> LPrag -> SDoc
-pprPrag var (L _ (InlinePrag inl))        = ppr inl <+> ppr var
-pprPrag var (L _ (SpecPrag _expr ty inl)) = pprSpec var ty inl
+pprPrag :: Outputable id => id -> LSpecPrag -> SDoc
+pprPrag var (L _ (SpecPrag _expr inl)) = pprSpec var (ptext (sLit "<type>")) inl
  \end{code}
  
  \end{code}
  
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs

index 66d9ed3..d629bae 100644 (file)
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -1,3 +1,4 @@
+
  %
  % (c) The University of Glasgow, 1992-2006
  %
  %
  % (c) The University of Glasgow, 1992-2006
  %
@@ -319,8 +320,12 @@ mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatc
                             fun_tick = Nothing }
  
  
                             fun_tick = Nothing }
  
  
-mkVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
-mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
+mkHsVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
+mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
+
+mkVarBind :: id -> LHsExpr id -> LHsBind id
+mkVarBind var rhs = L (getLoc rhs) $
+                   VarBind { var_id = var, var_rhs = rhs, var_inline = False }
  
  ------------
  mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
  
  ------------
  mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs

index b04e6e1..323e269 100644 (file)
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -600,14 +600,16 @@ instance Binary RuleMatchInfo where
                        else return FunLike
  
  instance Binary InlinePragma where
                        else return FunLike
  
  instance Binary InlinePragma where
-    put_ bh (InlinePragma activation match_info) = do
-            put_ bh activation
-            put_ bh match_info
+    put_ bh (InlinePragma a b c) = do
+            put_ bh a
+            put_ bh b
+            put_ bh c
  
      get bh = do
  
      get bh = do
-           act  <- get bh
-           info <- get bh
-           return (InlinePragma act info)
+           a <- get bh
+           b <- get bh
+           c <- get bh
+           return (InlinePragma a b c)
  
  instance Binary StrictnessMark where
      put_ bh MarkedStrict    = putByte bh 0
  
  instance Binary StrictnessMark where
      put_ bh MarkedStrict    = putByte bh 0
@@ -1167,10 +1169,6 @@ instance Binary IfaceInfoItem where
             put_ bh ad
      put_ bh HsNoCafRefs = do
             putByte bh 4
             put_ bh ad
      put_ bh HsNoCafRefs = do
             putByte bh 4
-    put_ bh (HsWorker ae af) = do
-           putByte bh 5
-           put_ bh ae
-           put_ bh af
      get bh = do
             h <- getByte bh
             case h of
      get bh = do
             h <- getByte bh
             case h of
@@ -1182,17 +1180,43 @@ instance Binary IfaceInfoItem where
                       return (HsUnfold ad)
               3 -> do ad <- get bh
                       return (HsInline ad)
                       return (HsUnfold ad)
               3 -> do ad <- get bh
                       return (HsInline ad)
-             4 -> do return HsNoCafRefs
-             _ -> do ae <- get bh
-                     af <- get bh
-                     return (HsWorker ae af)
+             _ -> do return HsNoCafRefs
+
+instance Binary IfaceUnfolding where
+    put_ bh (IfCoreUnfold e) = do
+       putByte bh 0
+       put_ bh e
+    put_ bh (IfInlineRule a b e) = do
+       putByte bh 1
+       put_ bh a
+       put_ bh b
+       put_ bh e
+    put_ bh (IfWrapper a n) = do
+       putByte bh 2
+       put_ bh a
+       put_ bh n
+    put_ bh (IfDFunUnfold as) = do
+       putByte bh 3
+       put_ bh as
+    get bh = do
+       h <- getByte bh
+       case h of
+         0 -> do e <- get bh
+                 return (IfCoreUnfold e)
+         1 -> do a <- get bh
+                 b <- get bh
+                 e <- get bh
+                 return (IfInlineRule a b e)
+         2 -> do a <- get bh
+                 n <- get bh
+                 return (IfWrapper a n)
+         _ -> do as <- get bh
+                 return (IfDFunUnfold as)
  
  instance Binary IfaceNote where
      put_ bh (IfaceSCC aa) = do
             putByte bh 0
             put_ bh aa
  
  instance Binary IfaceNote where
      put_ bh (IfaceSCC aa) = do
             putByte bh 0
             put_ bh aa
-    put_ bh IfaceInlineMe = do
-           putByte bh 3
      put_ bh (IfaceCoreNote s) = do
              putByte bh 4
              put_ bh s
      put_ bh (IfaceCoreNote s) = do
              putByte bh 4
              put_ bh s
@@ -1201,7 +1225,6 @@ instance Binary IfaceNote where
             case h of
               0 -> do aa <- get bh
                       return (IfaceSCC aa)
             case h of
               0 -> do aa <- get bh
                       return (IfaceSCC aa)
-             3 -> do return IfaceInlineMe
                4 -> do ac <- get bh
                        return (IfaceCoreNote ac)
                _ -> panic ("get IfaceNote " ++ show h)
                4 -> do ac <- get bh
                        return (IfaceCoreNote ac)
                _ -> panic ("get IfaceNote " ++ show h)
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs

index 129ebd0..2e2967d 100644 (file)
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -9,7 +9,8 @@ module IfaceSyn (
  
         IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
         IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
  
         IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
         IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
-       IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceIdDetails(..),
+       IfaceBinding(..), IfaceConAlt(..), 
+       IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
         IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
         IfaceInst(..), IfaceFamInst(..),
  
         IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
         IfaceInst(..), IfaceFamInst(..),
  
@@ -201,15 +202,21 @@ data IfaceInfoItem
    = HsArity     Arity
    | HsStrictness StrictSig
    | HsInline     InlinePragma
    = HsArity     Arity
    | HsStrictness StrictSig
    | HsInline     InlinePragma
-  | HsUnfold    IfaceExpr
+  | HsUnfold    IfaceUnfolding
    | HsNoCafRefs
    | HsNoCafRefs
-  | HsWorker    Name Arity     -- Worker, if any see IdInfo.WorkerInfo
-                                       -- for why we want arity here.
-       -- NB: we need IfaceExtName (not just OccName) because the worker
-       --     can simplify to a function in another module.
+
  -- NB: Specialisations and rules come in separately and are
  -- only later attached to the Id.  Partial reason: some are orphans.
  
  -- NB: Specialisations and rules come in separately and are
  -- only later attached to the Id.  Partial reason: some are orphans.
  
+data IfaceUnfolding 
+  = IfCoreUnfold IfaceExpr
+  | IfInlineRule Arity 
+                 Bool          -- Sat/UnSat
+                 IfaceExpr 
+  | IfWrapper    Arity Name      -- NB: we need a Name (not just OccName) because the worker
+                                 --     can simplify to a function in another module.
+  | IfDFunUnfold [IfaceExpr]
+
  --------------------------------
  data IfaceExpr
    = IfaceLcl   FastString
  --------------------------------
  data IfaceExpr
    = IfaceLcl   FastString
@@ -227,7 +234,6 @@ data IfaceExpr
    | IfaceTick   Module Int
  
  data IfaceNote = IfaceSCC CostCentre
    | IfaceTick   Module Int
  
  data IfaceNote = IfaceSCC CostCentre
-              | IfaceInlineMe
                 | IfaceCoreNote String
  
  type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
                 | IfaceCoreNote String
  
  type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
@@ -504,10 +510,10 @@ pprIfaceConDecl tc
    = sep [main_payload,
          if is_infix then ptext (sLit "Infix") else empty,
          if has_wrap then ptext (sLit "HasWrapper") else empty,
    = sep [main_payload,
          if is_infix then ptext (sLit "Infix") else empty,
          if has_wrap then ptext (sLit "HasWrapper") else empty,
-        if null strs then empty 
-             else nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr strs)),
-        if null fields then empty
-             else nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
+        ppUnless (null strs) $
+           nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr strs)),
+        ppUnless (null fields) $
+           nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
    where
      main_payload = ppr name <+> dcolon <+> 
                    pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
    where
      main_payload = ppr name <+> dcolon <+> 
                    pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
@@ -632,7 +638,6 @@ pprIfaceApp fun                    args = sep (pprIfaceExpr parens fun : args)
  ------------------
  instance Outputable IfaceNote where
      ppr (IfaceSCC cc)     = pprCostCentreCore cc
  ------------------
  instance Outputable IfaceNote where
      ppr (IfaceSCC cc)     = pprCostCentreCore cc
-    ppr IfaceInlineMe     = ptext (sLit "__inline_me")
      ppr (IfaceCoreNote s) = ptext (sLit "__core_note") <+> pprHsString (mkFastString s)
  
  
      ppr (IfaceCoreNote s) = ptext (sLit "__core_note") <+> pprHsString (mkFastString s)
  
  
@@ -652,16 +657,22 @@ instance Outputable IfaceIdDetails where
  
  instance Outputable IfaceIdInfo where
    ppr NoInfo       = empty
  
  instance Outputable IfaceIdInfo where
    ppr NoInfo       = empty
-  ppr (HasInfo is) = ptext (sLit "{-") <+> fsep (map ppr is) <+> ptext (sLit "-}")
+  ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is <+> ptext (sLit "-}")
  
  instance Outputable IfaceInfoItem where
  
  instance Outputable IfaceInfoItem where
-  ppr (HsUnfold unf)    = ptext (sLit "Unfolding:") <+>
-                                       parens (pprIfaceExpr noParens unf)
+  ppr (HsUnfold unf)    = ptext (sLit "Unfolding:") <+> ppr unf
    ppr (HsInline prag)    = ptext (sLit "Inline:") <+> ppr prag
    ppr (HsArity arity)    = ptext (sLit "Arity:") <+> int arity
    ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str
    ppr HsNoCafRefs       = ptext (sLit "HasNoCafRefs")
    ppr (HsInline prag)    = ptext (sLit "Inline:") <+> ppr prag
    ppr (HsArity arity)    = ptext (sLit "Arity:") <+> int arity
    ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str
    ppr HsNoCafRefs       = ptext (sLit "HasNoCafRefs")
-  ppr (HsWorker w a)    = ptext (sLit "Worker:") <+> ppr w <+> int a
+
+instance Outputable IfaceUnfolding where
+  ppr (IfCoreUnfold e)     = parens (ppr e)
+  ppr (IfInlineRule a b e) = ptext (sLit "InlineRule:")
+                             <+> parens (ptext (sLit "arity") <+> int a <+> ppr b) 
+                            <+> parens (ppr e)
+  ppr (IfWrapper a wkr)    = ptext (sLit "Worker:") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a)
+  ppr (IfDFunUnfold ns)    = ptext (sLit "DFun:") <+> brackets (pprWithCommas (pprIfaceExpr parens) ns)
  
  
  -- -----------------------------------------------------------------------------
  
  
  -- -----------------------------------------------------------------------------
@@ -775,10 +786,15 @@ freeNamesIfIdInfo NoInfo = emptyNameSet
  freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i
  
  freeNamesItem :: IfaceInfoItem -> NameSet
  freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i
  
  freeNamesItem :: IfaceInfoItem -> NameSet
-freeNamesItem (HsUnfold u)     = freeNamesIfExpr u
-freeNamesItem (HsWorker wkr _) = unitNameSet wkr
+freeNamesItem (HsUnfold u)     = freeNamesIfUnfold u
  freeNamesItem _                = emptyNameSet
  
  freeNamesItem _                = emptyNameSet
  
+freeNamesIfUnfold :: IfaceUnfolding -> NameSet
+freeNamesIfUnfold (IfCoreUnfold e)     = freeNamesIfExpr e
+freeNamesIfUnfold (IfInlineRule _ _ e) = freeNamesIfExpr e
+freeNamesIfUnfold (IfWrapper _ v)      = unitNameSet v
+freeNamesIfUnfold (IfDFunUnfold vs)    = fnList freeNamesIfExpr vs
+
  freeNamesIfExpr :: IfaceExpr -> NameSet
  freeNamesIfExpr (IfaceExt v)     = unitNameSet v
  freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
  freeNamesIfExpr :: IfaceExpr -> NameSet
  freeNamesIfExpr (IfaceExt v)     = unitNameSet v
  freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs

index 15fa778..549fce6 100644 (file)
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1390,12 +1390,12 @@ instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag,
      is_local name = nameIsLocalOrFrom mod name
  
         -- Compute orphanhood.  See Note [Orphans] in IfaceSyn
      is_local name = nameIsLocalOrFrom mod name
  
         -- Compute orphanhood.  See Note [Orphans] in IfaceSyn
-    (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
+    (_, cls, tys) = tcSplitDFunTy (idType dfun_id)
                 -- Slightly awkward: we need the Class to get the fundeps
      (tvs, fds) = classTvsFds cls
      arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys]
      orph | is_local cls_name = Just (nameOccName cls_name)
                 -- Slightly awkward: we need the Class to get the fundeps
      (tvs, fds) = classTvsFds cls
      arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys]
      orph | is_local cls_name = Just (nameOccName cls_name)
-        | all isJust mb_ns  = head mb_ns
+        | all isJust mb_ns  = ASSERT( not (null mb_ns) ) head mb_ns
          | otherwise         = Nothing
      
      mb_ns :: [Maybe OccName]   -- One for each fundep; a locally-defined name
          | otherwise         = Nothing
      
      mb_ns :: [Maybe OccName]   -- One for each fundep; a locally-defined name
@@ -1442,7 +1442,7 @@ toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))
  --------------------------
  toIfaceIdDetails :: IdDetails -> IfaceIdDetails
  toIfaceIdDetails VanillaId                     = IfVanillaId
  --------------------------
  toIfaceIdDetails :: IdDetails -> IfaceIdDetails
  toIfaceIdDetails VanillaId                     = IfVanillaId
-toIfaceIdDetails DFunId                        = IfVanillaId               
+toIfaceIdDetails (DFunId {})                           = IfDFunId
  toIfaceIdDetails (RecSelId { sel_naughty = n
                            , sel_tycon = tc })  = IfRecSelId (toIfaceTyCon tc) n
  toIfaceIdDetails other                         = pprTrace "toIfaceIdDetails" (ppr other) 
  toIfaceIdDetails (RecSelId { sel_naughty = n
                            , sel_tycon = tc })  = IfRecSelId (toIfaceTyCon tc) n
  toIfaceIdDetails other                         = pprTrace "toIfaceIdDetails" (ppr other) 
@@ -1451,7 +1451,7 @@ toIfaceIdDetails other                            = pprTrace "toIfaceIdDetails" (ppr other)
  toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
  toIfaceIdInfo id_info
    = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, 
  toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
  toIfaceIdInfo id_info
    = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, 
-              inline_hsinfo, wrkr_hsinfo,  unfold_hsinfo] 
+              inline_hsinfo,  unfold_hsinfo] 
    where
      ------------  Arity  --------------
      arity_info = arityInfo id_info
    where
      ------------  Arity  --------------
      arity_info = arityInfo id_info
@@ -1470,35 +1470,32 @@ toIfaceIdInfo id_info
                         Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
                         _other                        -> Nothing
  
                         Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
                         _other                        -> Nothing
  
-    ------------  Worker  --------------
-    work_info   = workerInfo id_info
-    has_worker  = workerExists work_info
-    wrkr_hsinfo = case work_info of
-                   HasWorker work_id wrap_arity -> 
-                       Just (HsWorker ((idName work_id)) wrap_arity)
-                   NoWorker -> Nothing
-
      ------------  Unfolding  --------------
      ------------  Unfolding  --------------
-    -- The unfolding is redundant if there is a worker
-    unfold_info  = unfoldingInfo id_info
-    rhs                 = unfoldingTemplate unfold_info
-    no_unfolding = neverUnfold unfold_info
-                       -- The CoreTidy phase retains unfolding info iff
-                       -- we want to expose the unfolding, taking into account
-                       -- unconditional NOINLINE, etc.  See TidyPgm.addExternal
-    unfold_hsinfo | no_unfolding = Nothing                     
-                 | has_worker   = Nothing      -- Unfolding is implicit
-                 | otherwise    = Just (HsUnfold (toIfaceExpr rhs))
+    unfold_hsinfo = toIfUnfolding (unfoldingInfo id_info)
                                         
      ------------  Inline prag  --------------
      inline_prag = inlinePragInfo id_info
      inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
                                         
      ------------  Inline prag  --------------
      inline_prag = inlinePragInfo id_info
      inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
-                 | no_unfolding && not has_worker 
-                      && isFunLike (inlinePragmaRuleMatchInfo inline_prag)
-                                                      = Nothing
-                       -- If the iface file give no unfolding info, we 
-                       -- don't need to say when inlining is OK!
-                 | otherwise                         = Just (HsInline inline_prag)
+                  | otherwise = Just (HsInline inline_prag)
+
+--------------------------
+toIfUnfolding :: Unfolding -> Maybe IfaceInfoItem
+toIfUnfolding (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity, uf_guidance = guidance })
+  = case guidance of
+       InlineRule { ug_ir_info = InlSat }       -> Just (HsUnfold (IfInlineRule arity True  (toIfaceExpr rhs)))
+       InlineRule { ug_ir_info = InlUnSat }     -> Just (HsUnfold (IfInlineRule arity False (toIfaceExpr rhs)))
+       InlineRule { ug_ir_info = InlWrapper w } -> Just (HsUnfold (IfWrapper arity (idName w)))
+       UnfoldNever         -> Nothing
+       UnfoldIfGoodArgs {} -> Just (HsUnfold (IfCoreUnfold (toIfaceExpr rhs)))
+       UnfoldAlways        -> panic "toIfUnfolding:UnfoldAlways"
+                               -- Never happens because we never have 
+                               -- bindings for unfold-always things
+toIfUnfolding (DFunUnfolding _con ops)
+  = Just (HsUnfold (IfDFunUnfold (map toIfaceExpr ops)))
+      -- No need to serialise the data constructor; 
+      -- we can recover it from the type of the dfun
+toIfUnfolding _
+  = Nothing
  
  --------------------------
  coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule
  
  --------------------------
  coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule
@@ -1555,7 +1552,6 @@ toIfaceExpr (Note n e)    = IfaceNote (toIfaceNote n) (toIfaceExpr e)
  ---------------------
  toIfaceNote :: Note -> IfaceNote
  toIfaceNote (SCC cc)      = IfaceSCC cc
  ---------------------
  toIfaceNote :: Note -> IfaceNote
  toIfaceNote (SCC cc)      = IfaceSCC cc
-toIfaceNote InlineMe      = IfaceInlineMe
  toIfaceNote (CoreNote s)  = IfaceCoreNote s
  
  ---------------------
  toIfaceNote (CoreNote s)  = IfaceCoreNote s
  
  ---------------------
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs

index 6a55957..689dd4b 100644 (file)
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -19,6 +19,7 @@ import LoadIface
  import IfaceEnv
  import BuildTyCl
  import TcRnMonad
  import IfaceEnv
  import BuildTyCl
  import TcRnMonad
+import TcType
  import Type
  import TypeRep
  import HscTypes
  import Type
  import TypeRep
  import HscTypes
@@ -43,6 +44,7 @@ import qualified Var
  import VarEnv
  import Name
  import NameEnv
  import VarEnv
  import Name
  import NameEnv
+import OccurAnal       ( occurAnalyseExpr )
  import Module
  import LazyUniqFM
  import UniqSupply
  import Module
  import LazyUniqFM
  import UniqSupply
@@ -53,7 +55,6 @@ import SrcLoc
  import DynFlags
  import Util
  import FastString
  import DynFlags
  import Util
  import FastString
-import BasicTypes (Arity)
  
  import Control.Monad
  import Data.List
  
  import Control.Monad
  import Data.List
@@ -416,7 +417,7 @@ tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type,
                                    ifIdDetails = details, ifIdInfo = info})
    = do { name <- lookupIfaceTop occ_name
         ; ty <- tcIfaceType iface_type
                                    ifIdDetails = details, ifIdInfo = info})
    = do { name <- lookupIfaceTop occ_name
         ; ty <- tcIfaceType iface_type
-       ; details <- tcIdDetails details
+       ; details <- tcIdDetails ty details
         ; info <- tcIdInfo ignore_prags name ty info
         ; return (AnId (mkGlobalId details name ty info)) }
  
         ; info <- tcIdInfo ignore_prags name ty info
         ; return (AnId (mkGlobalId details name ty info)) }
  
@@ -631,7 +632,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
         ; let mb_tcs = map ifTopFreeName args
         ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act, 
                           ru_bndrs = bndrs', ru_args = args', 
         ; let mb_tcs = map ifTopFreeName args
         ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act, 
                           ru_bndrs = bndrs', ru_args = args', 
-                         ru_rhs = rhs', 
+                         ru_rhs = occurAnalyseExpr rhs', 
                           ru_rough = mb_tcs,
                           ru_local = False }) } -- An imported RULE is never for a local Id
                                                 -- or, even if it is (module loop, perhaps)
                           ru_rough = mb_tcs,
                           ru_local = False }) } -- An imported RULE is never for a local Id
                                                 -- or, even if it is (module loop, perhaps)
@@ -885,7 +886,6 @@ tcIfaceExpr (IfaceCast expr co) = do
  tcIfaceExpr (IfaceNote note expr) = do
      expr' <- tcIfaceExpr expr
      case note of
  tcIfaceExpr (IfaceNote note expr) = do
      expr' <- tcIfaceExpr expr
      case note of
-        IfaceInlineMe     -> return (Note InlineMe   expr')
          IfaceSCC cc       -> return (Note (SCC cc)   expr')
          IfaceCoreNote n   -> return (Note (CoreNote n) expr')
  
          IfaceSCC cc       -> return (Note (SCC cc)   expr')
          IfaceCoreNote n   -> return (Note (CoreNote n) expr')
  
@@ -964,10 +964,14 @@ do_one (IfaceRec pairs) thing_inside
  %************************************************************************
  
  \begin{code}
  %************************************************************************
  
  \begin{code}
-tcIdDetails :: IfaceIdDetails -> IfL IdDetails
-tcIdDetails IfVanillaId = return VanillaId
-tcIdDetails IfDFunId    = return DFunId
-tcIdDetails (IfRecSelId tc naughty)
+tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
+tcIdDetails _  IfVanillaId = return VanillaId
+tcIdDetails ty IfDFunId
+  = return (DFunId (isNewTyCon (classTyCon cls)))
+  where
+    (_, cls, _) = tcSplitDFunTy ty
+
+tcIdDetails _ (IfRecSelId tc naughty)
    = do { tc' <- tcIfaceTyCon tc
         ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }
  
    = do { tc' <- tcIfaceTyCon tc
         ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }
  
@@ -983,52 +987,62 @@ tcIdInfo ignore_prags name ty info
      init_info = vanillaIdInfo
  
      tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
      init_info = vanillaIdInfo
  
      tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
-    tcPrag info HsNoCafRefs         = return (info `setCafInfo`   NoCafRefs)
-    tcPrag info (HsArity arity)     = return (info `setArityInfo` arity)
-    tcPrag info (HsStrictness str)  = return (info `setAllStrictnessInfo` Just str)
+    tcPrag info HsNoCafRefs        = return (info `setCafInfo`   NoCafRefs)
+    tcPrag info (HsArity arity)    = return (info `setArityInfo` arity)
+    tcPrag info (HsStrictness str) = return (info `setAllStrictnessInfo` Just str)
+    tcPrag info (HsInline prag)    = return (info `setInlinePragInfo` prag)
  
         -- The next two are lazy, so they don't transitively suck stuff in
  
         -- The next two are lazy, so they don't transitively suck stuff in
-    tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity
-    tcPrag info (HsInline inline_prag) = return (info `setInlinePragInfo` inline_prag)
-    tcPrag info (HsUnfold expr) = do
-          maybe_expr' <- tcPragExpr name expr
-         let
-               -- maybe_expr' doesn't get looked at if the unfolding
-               -- is never inspected; so the typecheck doesn't even happen
-               unfold_info = case maybe_expr' of
-                               Nothing    -> noUnfolding
-                               Just expr' -> mkTopUnfolding expr' 
-          return (info `setUnfoldingInfoLazily` unfold_info)
+    tcPrag info (HsUnfold if_unf)  = do { unf <- tcUnfolding name ty info if_unf
+                                       ; return (info `setUnfoldingInfoLazily` unf) }
  \end{code}
  
  \begin{code}
  \end{code}
  
  \begin{code}
-tcWorkerInfo :: Type -> IdInfo -> Name -> Arity -> IfL IdInfo
-tcWorkerInfo ty info wkr arity
-  = do         { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
+tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
+tcUnfolding name _ _ (IfCoreUnfold if_expr)
+  = do         { mb_expr <- tcPragExpr name if_expr
+       ; return (case mb_expr of
+                   Nothing -> NoUnfolding
+                   Just expr -> mkTopUnfolding expr) }
+
+tcUnfolding name _ _ (IfInlineRule arity sat if_expr)
+  = do         { mb_expr <- tcPragExpr name if_expr
+       ; return (case mb_expr of
+                   Nothing   -> NoUnfolding
+                   Just expr -> mkInlineRule inl_info expr arity) }
+  where
+    inl_info | sat       = InlSat
+            | otherwise = InlUnSat
  
  
-       -- We return without testing maybe_wkr_id, but as soon as info is
-       -- looked at we will test it.  That's ok, because its outside the
-       -- knot; and there seems no big reason to further defer the
-       -- tcIfaceId lookup.  (Contrast with tcPragExpr, where postponing walking
-       -- over the unfolding until it's actually used does seem worth while.)
+tcUnfolding name ty info (IfWrapper arity wkr)
+  = do         { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
         ; us <- newUniqueSupply
         ; us <- newUniqueSupply
-
         ; return (case mb_wkr_id of
         ; return (case mb_wkr_id of
-                    Nothing     -> info
-                    Just wkr_id -> add_wkr_info us wkr_id info) }
+                    Nothing     -> noUnfolding
+                    Just wkr_id -> make_inline_rule wkr_id us) }
    where
    where
-    doc = text "Worker for" <+> ppr wkr
-    add_wkr_info us wkr_id info
-       = info `setUnfoldingInfoLazily`  mk_unfolding us wkr_id
-              `setWorkerInfo`           HasWorker wkr_id arity
+    doc = text "Worker for" <+> ppr name
  
  
-    mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id)
+    make_inline_rule wkr_id us 
+       = mkWwInlineRule wkr_id
+                        (initUs_ us (mkWrapper ty strict_sig) wkr_id) 
+                        arity
  
         -- We are relying here on strictness info always appearing 
         -- before worker info,  fingers crossed ....
      strict_sig = case newStrictnessInfo info of
                    Just sig -> sig
                    Nothing  -> pprPanic "Worker info but no strictness for" (ppr wkr)
  
         -- We are relying here on strictness info always appearing 
         -- before worker info,  fingers crossed ....
      strict_sig = case newStrictnessInfo info of
                    Just sig -> sig
                    Nothing  -> pprPanic "Worker info but no strictness for" (ppr wkr)
+
+tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
+  = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
+       ; return (case mb_ops1 of
+                           Nothing   -> noUnfolding
+                    Just ops1 -> DFunUnfolding data_con ops1) }
+  where
+    doc = text "Class ops for dfun" <+> ppr name
+    (_, cls, _) = tcSplitDFunTy dfun_ty
+    data_con = classDataCon cls
  \end{code}
  
  For unfoldings we try to do the job lazily, so that we never type check
  \end{code}
  
  For unfoldings we try to do the job lazily, so that we never type check
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs

index 88a3059..2918875 100644 (file)
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -16,8 +16,7 @@ import CoreSyn
  import CoreUnfold
  import CoreFVs
  import CoreTidy
  import CoreUnfold
  import CoreFVs
  import CoreTidy
-import PprCore
-import CoreLint
+import CoreMonad
  import CoreUtils
  import CoreArity       ( exprArity )
  import Class           ( classSelIds )
  import CoreUtils
  import CoreArity       ( exprArity )
  import Class           ( classSelIds )
@@ -297,28 +296,19 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
                                 mg_hpc_info = hpc_info,
                                  mg_modBreaks = modBreaks })
  
                                 mg_hpc_info = hpc_info,
                                  mg_modBreaks = modBreaks })
  
-  = do { let dflags = hsc_dflags hsc_env
-       ; showPass dflags "Tidy Core"
-
-       ; let { omit_prags = dopt Opt_OmitInterfacePragmas dflags
+  = do { let { dflags     = hsc_dflags hsc_env
+             ; omit_prags = dopt Opt_OmitInterfacePragmas dflags
               ; th         = dopt Opt_TemplateHaskell      dflags
                }
               ; th         = dopt Opt_TemplateHaskell      dflags
                }
+       ; showPass dflags "Tidy Core"
  
         ; let { implicit_binds = getImplicitBinds type_env }
  
          ; (unfold_env, tidy_occ_env)
  
         ; let { implicit_binds = getImplicitBinds type_env }
  
          ; (unfold_env, tidy_occ_env)
-              <- chooseExternalIds hsc_env mod omit_prags binds implicit_binds
-
-        ; let { ext_rules 
-                  | omit_prags = []
-                  | otherwise  = findExternalRules binds imp_rules unfold_env
-               -- findExternalRules filters imp_rules to avoid binders that 
-               -- aren't externally visible; but the externally-visible binders 
-               -- are computed (by findExternalIds) assuming that all orphan
-               -- rules are exported (they get their Exported flag set in the desugarer)
-               -- So in fact we may export more than we need. 
-               -- (It's a sort of mutual recursion.)
-       }
+              <- chooseExternalIds hsc_env mod omit_prags binds implicit_binds imp_rules
+
+        ; let { ext_rules = findExternalRules omit_prags binds imp_rules unfold_env }
+               -- See Note [Which rules to expose]
  
         ; let { (tidy_env, tidy_binds)
                   = tidyTopBinds hsc_env unfold_env tidy_occ_env binds }
  
         ; let { (tidy_env, tidy_binds)
                   = tidyTopBinds hsc_env unfold_env tidy_occ_env binds }
@@ -348,11 +338,7 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
               ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
               }
  
               ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
               }
  
-       ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds
-       ; dumpIfSet_core dflags Opt_D_dump_simpl
-               "Tidy Core Rules"
-               (pprRules tidy_rules)
-
+       ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds tidy_rules
          ; let dir_imp_mods = moduleEnvKeys dir_imps
  
         ; return (CgGuts { cg_module   = mod, 
          ; let dir_imp_mods = moduleEnvKeys dir_imps
  
         ; return (CgGuts { cg_module   = mod, 
@@ -578,8 +564,8 @@ Sete Note [choosing external names].
  
  \begin{code}
  type UnfoldEnv  = IdEnv (Name{-new name-}, Bool {-show unfolding-})
  
  \begin{code}
  type UnfoldEnv  = IdEnv (Name{-new name-}, Bool {-show unfolding-})
-  -- maps each top-level Id to its new Name (the Id is tidied in step 2)
-  -- The Unique is unchanged.  If the new Id is external, it will be
+  -- Maps each top-level Id to its new Name (the Id is tidied in step 2)
+  -- The Unique is unchanged.  If the new Name is external, it will be
    -- visible in the interface file.  
    --
    -- Bool => expose unfolding or not.
    -- visible in the interface file.  
    --
    -- Bool => expose unfolding or not.
@@ -589,34 +575,38 @@ chooseExternalIds :: HscEnv
                    -> Bool
                   -> [CoreBind]
                    -> [CoreBind]
                    -> Bool
                   -> [CoreBind]
                    -> [CoreBind]
+                 -> [CoreRule]
                    -> IO (UnfoldEnv, TidyOccEnv)
         -- Step 1 from the notes above
  
                    -> IO (UnfoldEnv, TidyOccEnv)
         -- Step 1 from the notes above
  
-chooseExternalIds hsc_env mod omit_prags binds implicit_binds
-  = do
-    (unfold_env1,occ_env1) 
-        <- search (zip sorted_exports sorted_exports) emptyVarEnv init_occ_env
-    let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders
-    tidy_internal internal_ids unfold_env1 occ_env1
+chooseExternalIds hsc_env mod omit_prags binds implicit_binds imp_id_rules
+  = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env
+       ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders
+       ; tidy_internal internal_ids unfold_env1 occ_env1 }
   where
    nc_var = hsc_NC hsc_env 
  
   where
    nc_var = hsc_NC hsc_env 
  
-  -- the exports, sorted by OccName.  This is a deterministic list of
-  -- Ids (i.e. it's the same list every time this module is compiled),
-  -- in contrast to the bindings, which are ordered
-  -- non-deterministically.
-  --
-  -- This list will serve as a starting point for finding a
+  -- init_ext_ids is the intial list of Ids that should be
+  -- externalised.  It serves as the starting point for finding a
    -- deterministic, tidy, renaming for all external Ids in this
    -- module.
    -- deterministic, tidy, renaming for all external Ids in this
    -- module.
-  sorted_exports = sortBy (compare `on` getOccName) $
-                     filter isExportedId binders
-
-  binders = bindersOfBinds binds
+  -- 
+  -- It is sorted, so that it has adeterministic order (i.e. it's the
+  -- same list every time this module is compiled), in contrast to the
+  -- bindings, which are ordered non-deterministically.
+  init_work_list = zip init_ext_ids init_ext_ids
+  init_ext_ids   = sortBy (compare `on` getOccName) $
+                   filter is_external binders
+
+  -- An Id should be external if either (a) it is exported or
+  -- (b) it appears in the RHS of a local rule for an imported Id.   
+  -- See Note [Which rules to expose]
+  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars
+  rule_rhs_vars = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet imp_id_rules
+
+  binders          = bindersOfBinds binds
    implicit_binders = bindersOfBinds implicit_binds
    implicit_binders = bindersOfBinds implicit_binds
-
-  bind_env :: IdEnv (Id,CoreExpr)
-  bind_env = mkVarEnv (zip (map fst bs) bs) where bs = flattenBinds binds
+  binder_set       = mkVarSet binders
  
    avoids   = [getOccName name | bndr <- binders ++ implicit_binders,
                                  let name = idName bndr,
  
    avoids   = [getOccName name | bndr <- binders ++ implicit_binders,
                                  let name = idName bndr,
@@ -641,7 +631,12 @@ chooseExternalIds hsc_env mod omit_prags binds implicit_binds
    init_occ_env = initTidyOccEnv avoids
  
  
    init_occ_env = initTidyOccEnv avoids
  
  
-  search :: [(Id,Id)]    -- (external id, referrring id)
+  search :: [(Id,Id)]    -- The work-list: (external id, referrring id)
+                        -- Make a tidy, external Name for the external id,
+                         --   add it to the UnfoldEnv, and do the same for the
+                         --   transitive closure of Ids it refers to
+                        -- The referring id is used to generate a tidy
+                        ---  name for the external id
           -> UnfoldEnv    -- id -> (new Name, show_unfold)
           -> TidyOccEnv   -- occ env for choosing new Names
           -> IO (UnfoldEnv, TidyOccEnv)
           -> UnfoldEnv    -- id -> (new Name, show_unfold)
           -> TidyOccEnv   -- occ env for choosing new Names
           -> IO (UnfoldEnv, TidyOccEnv)
@@ -653,19 +648,19 @@ chooseExternalIds hsc_env mod omit_prags binds implicit_binds
      | otherwise = do
        (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc
        let 
      | otherwise = do
        (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc
        let 
-          (id, rhs) = expectJust (showSDoc (text "chooseExternalIds: " <>
-                                            ppr idocc)) $
-                                 lookupVarEnv bind_env idocc
-          -- NB. idocc might be an *occurrence* of an Id, whereas we want
-          -- the Id from the binding site, because only the latter is
-          -- guaranteed to have the unfolding attached.  This is why we
-          -- keep binding site Ids in the bind_env.
            (new_ids, show_unfold)
                  | omit_prags = ([], False)
            (new_ids, show_unfold)
                  | omit_prags = ([], False)
-                | otherwise  = addExternal id rhs
-          unfold_env' = extendVarEnv unfold_env id (name',show_unfold)
-          referrer' | isExportedId id = id
-                    | otherwise       = referrer
+                | otherwise  = addExternal refined_id
+
+               -- 'idocc' is an *occurrence*, but we need to see the
+               -- unfolding in the *definition*; so look up in binder_set
+          refined_id = case lookupVarSet binder_set idocc of
+                         Just id -> id
+                         Nothing -> WARN( True, ppr idocc ) idocc
+
+          unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold)
+          referrer' | isExportedId refined_id = refined_id
+                    | otherwise               = referrer
        --
        search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env'
  
        --
        search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env'
  
@@ -677,45 +672,36 @@ chooseExternalIds hsc_env mod omit_prags binds implicit_binds
        let unfold_env' = extendVarEnv unfold_env id (name',False)
        tidy_internal ids unfold_env' occ_env'
  
        let unfold_env' = extendVarEnv unfold_env id (name',False)
        tidy_internal ids unfold_env' occ_env'
  
-addExternal :: Id -> CoreExpr -> ([Id],Bool)
-addExternal id rhs = (new_needed_ids, show_unfold)
+addExternal :: Id -> ([Id],Bool)
+addExternal id = (new_needed_ids, show_unfold)
    where
      new_needed_ids = unfold_ids ++
                       filter (\id -> isLocalId id &&
                                      not (id `elemVarSet` unfold_set))
    where
      new_needed_ids = unfold_ids ++
                       filter (\id -> isLocalId id &&
                                      not (id `elemVarSet` unfold_set))
-                       (varSetElems worker_ids ++ 
-                        varSetElems spec_ids) -- XXX non-det ordering
+                       (varSetElems spec_ids) -- XXX non-det ordering
  
      idinfo        = idInfo id
      dont_inline           = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))
      loop_breaker   = isNonRuleLoopBreaker (occInfo idinfo)
      bottoming_fn   = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
      spec_ids      = specInfoFreeVars (specInfo idinfo)
  
      idinfo        = idInfo id
      dont_inline           = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))
      loop_breaker   = isNonRuleLoopBreaker (occInfo idinfo)
      bottoming_fn   = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
      spec_ids      = specInfoFreeVars (specInfo idinfo)
-    worker_info           = workerInfo idinfo
  
         -- Stuff to do with the Id's unfolding
  
         -- Stuff to do with the Id's unfolding
-       -- The simplifier has put an up-to-date unfolding
-       -- in the IdInfo, but the RHS will do just as well
-    unfolding   = unfoldingInfo idinfo
-    rhs_is_small = not (neverUnfold unfolding)
-
         -- We leave the unfolding there even if there is a worker
         -- In GHCI the unfolding is used by importers
         -- We leave the unfolding there even if there is a worker
         -- In GHCI the unfolding is used by importers
-       -- When writing an interface file, we omit the unfolding 
-       -- if there is a worker
-    show_unfold = not bottoming_fn      &&     -- Not necessary
-                 not dont_inline        &&
-                 not loop_breaker       &&
-                 rhs_is_small                  -- Small enough
-
-    (unfold_set, unfold_ids)
-               | show_unfold = freeVarsInDepthFirstOrder rhs
-              | otherwise   = (emptyVarSet, [])
-
-    worker_ids = case worker_info of
-                  HasWorker work_id _ -> unitVarSet work_id
-                  _otherwise          -> emptyVarSet
-
+    show_unfold = isJust mb_unfold_ids
+    (unfold_set, unfold_ids) = mb_unfold_ids `orElse` (emptyVarSet, [])
+
+    mb_unfold_ids :: Maybe (IdSet, [Id])       -- Nothing => don't unfold
+    mb_unfold_ids = case unfoldingInfo idinfo of
+                     CoreUnfolding { uf_tmpl = unf_rhs, uf_guidance = guide } 
+                       | not bottoming_fn              -- Not necessary
+                       , not dont_inline        
+                       , not loop_breaker       
+                       , not (neverUnfoldGuidance guide)
+                       -> Just (exprFvsInOrder unf_rhs)
+                     DFunUnfolding _ ops -> Just (exprsFvsInOrder ops)
+                     _ -> Nothing
  
  -- We want a deterministic free-variable list.  exprFreeVars gives us
  -- a VarSet, which is in a non-deterministic order when converted to a
  
  -- We want a deterministic free-variable list.  exprFreeVars gives us
  -- a VarSet, which is in a non-deterministic order when converted to a
@@ -724,11 +710,15 @@ addExternal id rhs = (new_needed_ids, show_unfold)
  --
  -- Note [choosing external names]
  
  --
  -- Note [choosing external names]
  
-freeVarsInDepthFirstOrder :: CoreExpr -> (VarSet, [Id])
-freeVarsInDepthFirstOrder e = 
-  case dffvExpr e of
-    DFFV m -> case m emptyVarSet [] of
-                (set,ids,_) -> (set,ids)
+exprFvsInOrder :: CoreExpr -> (VarSet, [Id])
+exprFvsInOrder e = run (dffvExpr e)
+
+exprsFvsInOrder :: [CoreExpr] -> (VarSet, [Id])
+exprsFvsInOrder es = run (mapM_ dffvExpr es)
+
+run :: DFFV () -> (VarSet, [Id])
+run (DFFV m) = case m emptyVarSet [] of
+                 (set,ids,_) -> (set,ids)
  
  newtype DFFV a = DFFV (VarSet -> [Var] -> (VarSet,[Var],a))
  
  
  newtype DFFV a = DFFV (VarSet -> [Var] -> (VarSet,[Var],a))
  
@@ -848,15 +838,17 @@ tidyTopName mod nc_var maybe_ref occ_env id
  \end{code}
  
  \begin{code}
  \end{code}
  
  \begin{code}
-findExternalRules :: [CoreBind]
-                 -> [CoreRule] -- Non-local rules (i.e. ones for imported fns)
+findExternalRules :: Bool      -- Omit pragmas
+                  -> [CoreBind]
+                 -> [CoreRule] -- Local rules for imported fns
                   -> UnfoldEnv  -- Ids that are exported, so we need their rules
                   -> [CoreRule]
    -- The complete rules are gotten by combining
                   -> UnfoldEnv  -- Ids that are exported, so we need their rules
                   -> [CoreRule]
    -- The complete rules are gotten by combining
-  --   a) the non-local rules
+  --   a) local rules for imported Ids
    --   b) rules embedded in the top-level Ids
    --   b) rules embedded in the top-level Ids
-findExternalRules binds non_local_rules unfold_env
-  = filter (not . internal_rule) (non_local_rules ++ local_rules)
+findExternalRules omit_prags binds imp_id_rules unfold_env
+  | omit_prags = []
+  | otherwise  = filterOut internal_rule (imp_id_rules ++ local_rules)
    where
      local_rules  = [ rule
                    | id <- bindersOfBinds binds,
    where
      local_rules  = [ rule
                    | id <- bindersOfBinds binds,
@@ -875,7 +867,14 @@ findExternalRules binds non_local_rules unfold_env
        | otherwise = False
  \end{code}
  
        | otherwise = False
  \end{code}
  
-
+Note [Which rules to expose]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+findExternalRules filters imp_rules to avoid binders that 
+aren't externally visible; but the externally-visible binders 
+are computed (by findExternalIds) assuming that all orphan
+rules are externalised (see init_ext_ids in function 
+'search'). So in fact we may export more than we need. 
+(It's a sort of mutual recursion.)
  
  %************************************************************************
  %*                                                                     *
  
  %************************************************************************
  %*                                                                     *
@@ -978,12 +977,24 @@ tidyTopPair show_unfold rhs_tidy_env caf_info name' (bndr, rhs)
      rhs'    = tidyExpr rhs_tidy_env rhs
      idinfo  = idInfo bndr
      idinfo' = tidyTopIdInfo (isExternalName name')
      rhs'    = tidyExpr rhs_tidy_env rhs
      idinfo  = idInfo bndr
      idinfo' = tidyTopIdInfo (isExternalName name')
-                           idinfo unfold_info worker_info
+                           idinfo unfold_info
                             arity caf_info
  
                             arity caf_info
  
-    unfold_info | show_unfold = mkTopUnfolding rhs'
+    unfold_info | show_unfold = tidyUnfolding rhs_tidy_env rhs' (unfoldingInfo idinfo)
                 | otherwise   = noUnfolding
                 | otherwise   = noUnfolding
-    worker_info = tidyWorker rhs_tidy_env show_unfold (workerInfo idinfo)
+    -- NB: do *not* expose the worker if show_unfold is off,
+    --     because that means this thing is a loop breaker or
+    --     marked NOINLINE or something like that
+    -- This is important: if you expose the worker for a loop-breaker
+    -- then you can make the simplifier go into an infinite loop, because
+    -- in effect the unfolding is exposed.  See Trac #1709
+    -- 
+    -- You might think that if show_unfold is False, then the thing should
+    -- not be w/w'd in the first place.  But a legitimate reason is this:
+    --           the function returns bottom
+    -- In this case, show_unfold will be false (we don't expose unfoldings
+    -- for bottoming functions), but we might still have a worker/wrapper
+    -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.lhs
  
      -- Usually the Id will have an accurate arity on it, because
      -- the simplifier has just run, but not always. 
  
      -- Usually the Id will have an accurate arity on it, because
      -- the simplifier has just run, but not always. 
@@ -1007,9 +1018,9 @@ tidyTopPair show_unfold rhs_tidy_env caf_info name' (bndr, rhs)
  --     unfoldings, which are inside Ids imported by GHCi. Ditto RULES.
  --     CoreToStg makes use of this when constructing SRTs.
  tidyTopIdInfo :: Bool -> IdInfo -> Unfolding
  --     unfoldings, which are inside Ids imported by GHCi. Ditto RULES.
  --     CoreToStg makes use of this when constructing SRTs.
  tidyTopIdInfo :: Bool -> IdInfo -> Unfolding
-              -> WorkerInfo -> ArityInfo -> CafInfo
+              -> ArityInfo -> CafInfo
                -> IdInfo
                -> IdInfo
-tidyTopIdInfo is_external idinfo unfold_info worker_info arity caf_info
+tidyTopIdInfo is_external idinfo unfold_info arity caf_info
    | not is_external    -- For internal Ids (not externally visible)
    = vanillaIdInfo      -- we only need enough info for code generation
                         -- Arity and strictness info are enough;
    | not is_external    -- For internal Ids (not externally visible)
    = vanillaIdInfo      -- we only need enough info for code generation
                         -- Arity and strictness info are enough;
@@ -1025,32 +1036,26 @@ tidyTopIdInfo is_external idinfo unfold_info worker_info arity caf_info
         `setAllStrictnessInfo` newStrictnessInfo idinfo
         `setInlinePragInfo`    inlinePragInfo idinfo
         `setUnfoldingInfo`     unfold_info
         `setAllStrictnessInfo` newStrictnessInfo idinfo
         `setInlinePragInfo`    inlinePragInfo idinfo
         `setUnfoldingInfo`     unfold_info
-       `setWorkerInfo`        worker_info
                 -- NB: we throw away the Rules
                 -- They have already been extracted by findExternalRules
  
  
  
                 -- NB: we throw away the Rules
                 -- They have already been extracted by findExternalRules
  
  
  
-------------  Worker  --------------
-tidyWorker :: TidyEnv -> Bool -> WorkerInfo -> WorkerInfo
-tidyWorker _tidy_env _show_unfold NoWorker
-  = NoWorker
-tidyWorker tidy_env show_unfold (HasWorker work_id wrap_arity) 
-  | show_unfold = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
-  | otherwise   = NoWorker
-    -- NB: do *not* expose the worker if show_unfold is off,
-    --     because that means this thing is a loop breaker or
-    --     marked NOINLINE or something like that
-    -- This is important: if you expose the worker for a loop-breaker
-    -- then you can make the simplifier go into an infinite loop, because
-    -- in effect the unfolding is exposed.  See Trac #1709
-    -- 
-    -- You might think that if show_unfold is False, then the thing should
-    -- not be w/w'd in the first place.  But a legitimate reason is this:
-    --           the function returns bottom
-    -- In this case, show_unfold will be false (we don't expose unfoldings
-    -- for bottoming functions), but we might still have a worker/wrapper
-    -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.lhs
+------------ Unfolding  --------------
+tidyUnfolding :: TidyEnv -> CoreExpr -> Unfolding -> Unfolding
+tidyUnfolding tidy_env _ unf@(CoreUnfolding { uf_tmpl = rhs 
+                                           , uf_guidance = guide@(InlineRule {}) })
+  = unf { uf_tmpl     = tidyExpr tidy_env rhs,            -- Preserves OccInfo
+         uf_guidance = guide { ug_ir_info = tidyInl tidy_env (ug_ir_info guide) } }
+tidyUnfolding tidy_env _ (DFunUnfolding con ids)
+  = DFunUnfolding con (map (tidyExpr tidy_env) ids)
+tidyUnfolding _ tidy_rhs (CoreUnfolding {})
+  = mkTopUnfolding tidy_rhs
+tidyUnfolding _ _ unf = unf
+
+tidyInl :: TidyEnv -> InlineRuleInfo -> InlineRuleInfo
+tidyInl tidy_env (InlWrapper w) = InlWrapper (tidyVarOcc tidy_env w)
+tidyInl _        inl_info       = inl_info
  \end{code}
  
  %************************************************************************
  \end{code}
  
  %************************************************************************
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp

index 3aec9e3..9068502 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -48,7 +48,7 @@ import StaticFlags    ( opt_SccProfilingOn, opt_Hpc )
  import Type            ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind )
  import Class           ( FunDep )
  import BasicTypes      ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
  import Type            ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind )
  import Class           ( FunDep )
  import BasicTypes      ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
-                         Activation(..), RuleMatchInfo(..), defaultInlineSpec )
+                         Activation(..), RuleMatchInfo(..), defaultInlinePragma )
  import DynFlags
  import OrdList
  import HaddockUtils
  import DynFlags
  import OrdList
  import HaddockUtils
@@ -559,8 +559,8 @@ topdecl :: { OrdList (LHsDecl RdrName) }
          | stand_alone_deriving                  { unitOL (LL (DerivD (unLoc $1))) }
         | 'default' '(' comma_types0 ')'        { unitOL (LL $ DefD (DefaultDecl $3)) }
         | 'foreign' fdecl                       { unitOL (LL (unLoc $2)) }
          | stand_alone_deriving                  { unitOL (LL (DerivD (unLoc $1))) }
         | 'default' '(' comma_types0 ')'        { unitOL (LL $ DefD (DefaultDecl $3)) }
         | 'foreign' fdecl                       { unitOL (LL (unLoc $2)) }
-        | '{-# DEPRECATED' deprecations '#-}' { $2 }
-        | '{-# WARNING' warnings '#-}'        { $2 }
+        | '{-# DEPRECATED' deprecations '#-}'   { $2 }
+        | '{-# WARNING' warnings '#-}'          { $2 }
         | '{-# RULES' rules '#-}'               { $2 }
         | annotation { unitOL $1 }
         | decl                                  { unLoc $1 }
         | '{-# RULES' rules '#-}'               { $2 }
         | annotation { unitOL $1 }
         | decl                                  { unLoc $1 }
@@ -1228,17 +1228,17 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
         | infix prec ops        { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
                                              | n <- unLoc $3 ] }
         | '{-# INLINE'   activation qvar '#-}'        
         | infix prec ops        { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
                                              | n <- unLoc $3 ] }
         | '{-# INLINE'   activation qvar '#-}'        
-                               { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 FunLike (getINLINE $1)))) }
+               { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma $2 FunLike (getINLINE $1)))) }
          | '{-# INLINE_CONLIKE' activation qvar '#-}'
          | '{-# INLINE_CONLIKE' activation qvar '#-}'
-                                { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 ConLike (getINLINE_CONLIKE $1)))) }
+                { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma $2 ConLike (getINLINE_CONLIKE $1)))) }
         | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
         | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
-                               { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlineSpec) 
+               { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlinePragma) 
                                             | t <- $4] }
         | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
                                             | t <- $4] }
         | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
-                               { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 FunLike (getSPEC_INLINE $1)))
+               { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma $2 FunLike (getSPEC_INLINE $1)))
                                             | t <- $5] }
         | '{-# SPECIALISE' 'instance' inst_type '#-}'
                                             | t <- $5] }
         | '{-# SPECIALISE' 'instance' inst_type '#-}'
-                               { LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
+               { LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
  
  -----------------------------------------------------------------------------
  -- Expressions
  
  -----------------------------------------------------------------------------
  -- Expressions
diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y

index 8ae9030..6839fa2 100644 (file)
--- a/compiler/parser/ParserCore.y
+++ b/compiler/parser/ParserCore.y
@@ -269,11 +269,12 @@ exp       :: { IfaceExpr }
         | '%case' '(' ty ')' aexp '%of' id_bndr
           '{' alts1 '}'               { IfaceCase $5 (fst $7) $3 $9 }
          | '%cast' aexp aty { IfaceCast $2 $3 }
         | '%case' '(' ty ')' aexp '%of' id_bndr
           '{' alts1 '}'               { IfaceCase $5 (fst $7) $3 $9 }
          | '%cast' aexp aty { IfaceCast $2 $3 }
-       | '%note' STRING exp       
-           { case $2 of
-              --"SCC"      -> IfaceNote (IfaceSCC "scc") $3
-              "InlineMe"   -> IfaceNote IfaceInlineMe $3
-            }
+-- No InlineMe any more
+--     | '%note' STRING exp       
+--         { case $2 of
+--            --"SCC"      -> IfaceNote (IfaceSCC "scc") $3
+--            "InlineMe"   -> IfaceNote IfaceInlineMe $3
+--            }
          | '%external' STRING aty   { IfaceFCall (ForeignCall.CCall 
                                                      (CCallSpec (StaticTarget (mkFastString $2)) 
                                                                 CCallConv (PlaySafe False))) 
          | '%external' STRING aty   { IfaceFCall (ForeignCall.CCall 
                                                      (CCallSpec (StaticTarget (mkFastString $2)) 
                                                                 CCallConv (PlaySafe False))) 
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs

index 03ca542..92c7415 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -12,7 +12,7 @@ module RdrHsSyn (
         mkHsIntegral, mkHsFractional, mkHsIsString,
         mkHsDo, mkHsSplice, mkTopSpliceDecl,
          mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
         mkHsIntegral, mkHsFractional, mkHsIsString,
         mkHsDo, mkHsSplice, mkTopSpliceDecl,
          mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
-        splitCon, mkInlineSpec,        
+        splitCon, mkInlinePragma,      
         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
  
         cvBindGroup,
         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
  
         cvBindGroup,
@@ -54,9 +54,8 @@ import Class            ( FunDep )
  import TypeRep          ( Kind )
  import RdrName         ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, 
                           isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
  import TypeRep          ( Kind )
  import RdrName         ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, 
                           isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
-import BasicTypes      ( maxPrecedence, Activation, RuleMatchInfo,
-                          InlinePragma(..),  InlineSpec(..),
-                          alwaysInlineSpec, neverInlineSpec )
+import BasicTypes      ( maxPrecedence, Activation(..), RuleMatchInfo,
+                          InlinePragma(..) )
  import Lexer
  import TysWiredIn      ( unitTyCon ) 
  import ForeignCall
  import Lexer
  import TysWiredIn      ( unitTyCon ) 
  import ForeignCall
@@ -960,13 +959,20 @@ mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
  mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
  mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
  
  mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
  mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
  
-mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec
--- The Maybe is becuase the user can omit the activation spec (and usually does)
-mkInlineSpec Nothing    match_info True  = alwaysInlineSpec match_info
-                                                                -- INLINE
-mkInlineSpec Nothing   match_info False = neverInlineSpec  match_info
-                                                                -- NOINLINE
-mkInlineSpec (Just act) match_info inl   = Inline (InlinePragma act match_info) inl
+mkInlinePragma :: Maybe Activation -> RuleMatchInfo -> Bool -> InlinePragma
+-- The Maybe is because the user can omit the activation spec (and usually does)
+mkInlinePragma mb_act match_info inl 
+  = InlinePragma { inl_inline = inl
+                 , inl_act    = act
+                 , inl_rule   = match_info }
+  where
+    act = case mb_act of
+            Just act -> act
+            Nothing | inl       -> AlwaysActive
+                    | otherwise -> NeverActive
+        -- If no specific phase is given then:
+       --   NOINLINE => NeverActive
+        --   INLINE   => Active
  
  -----------------------------------------------------------------------------
  -- utilities for foreign declarations
  
  -----------------------------------------------------------------------------
  -- utilities for foreign declarations
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs

index e35d8db..236cee6 100644 (file)
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -35,7 +35,8 @@ import PrimOp         ( PrimOp(..), tagToEnumKey )
  import TysWiredIn      ( boolTy, trueDataConId, falseDataConId )
  import TyCon           ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
  import DataCon         ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
  import TysWiredIn      ( boolTy, trueDataConId, falseDataConId )
  import TyCon           ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
  import DataCon         ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
-import CoreUtils       ( cheapEqExpr, exprIsConApp_maybe )
+import CoreUtils       ( cheapEqExpr )
+import CoreUnfold      ( exprIsConApp_maybe )
  import Type            ( tyConAppTyCon, coreEqType )
  import OccName         ( occNameFS )
  import PrelNames       ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
  import Type            ( tyConAppTyCon, coreEqType )
  import OccName         ( occNameFS )
  import PrelNames       ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
@@ -457,7 +458,7 @@ dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
    = Just tag   -- dataToTag (tagToEnum x)   ==>   x
  
  dataToTagRule [_, val_arg]
    = Just tag   -- dataToTag (tagToEnum x)   ==>   x
  
  dataToTagRule [_, val_arg]
-  | Just (dc,_) <- exprIsConApp_maybe val_arg
+  | Just (dc,_,_) <- exprIsConApp_maybe val_arg
    = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
      Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
  
    = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
      Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
  
diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs

index 54490f4..8c38661 100644 (file)
--- a/compiler/simplCore/CSE.lhs
+++ b/compiler/simplCore/CSE.lhs
@@ -114,7 +114,7 @@ Note [CSE for INLINE and NOINLINE]
  We are careful to do no CSE inside functions that the user has marked as
  INLINE or NOINLINE.  In terms of Core, that means 
  
  We are careful to do no CSE inside functions that the user has marked as
  INLINE or NOINLINE.  In terms of Core, that means 
  
-       a) we do not do CSE inside (Note InlineMe e)
+       a) we do not do CSE inside an InlineRule
  
         b) we do not do CSE on the RHS of a binding b=e
            unless b's InlinePragma is AlwaysActive
  
         b) we do not do CSE on the RHS of a binding b=e
            unless b's InlinePragma is AlwaysActive
@@ -218,7 +218,6 @@ cseExpr _   (Type t)               = Type t
  cseExpr _   (Lit lit)              = Lit lit
  cseExpr env (Var v)               = Var (lookupSubst env v)
  cseExpr env (App f a)             = App (cseExpr env f) (tryForCSE env a)
  cseExpr _   (Lit lit)              = Lit lit
  cseExpr env (Var v)               = Var (lookupSubst env v)
  cseExpr env (App f a)             = App (cseExpr env f) (tryForCSE env a)
-cseExpr _   (Note InlineMe e)      = Note InlineMe e    -- See Note [CSE for INLINE and NOINLINE]
  cseExpr env (Note n e)            = Note n (cseExpr env e)
  cseExpr env (Cast e co)            = Cast (cseExpr env e) co
  cseExpr env (Lam b e)             = let (env', b') = addBinder env b
  cseExpr env (Note n e)            = Note n (cseExpr env e)
  cseExpr env (Cast e co)            = Cast (cseExpr env e) co
  cseExpr env (Lam b e)             = let (env', b') = addBinder env b
diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs

index c49ac17..f806089 100644 (file)
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -24,6 +24,9 @@ module CoreMonad (
      -- ** Dealing with annotations
      findAnnotations, deserializeAnnotations, addAnnotation,
      
      -- ** Dealing with annotations
      findAnnotations, deserializeAnnotations, addAnnotation,
      
+    -- ** Debug output
+    endPass, endPassIf, 
+
      -- ** Screen output
      putMsg, putMsgS, errorMsg, errorMsgS, 
      fatalErrorMsg, fatalErrorMsgS, 
      -- ** Screen output
      putMsg, putMsgS, errorMsg, errorMsgS, 
      fatalErrorMsg, fatalErrorMsgS, 
@@ -39,6 +42,10 @@ module CoreMonad (
  #ifdef GHCI
  import Name( Name )
  #endif
  #ifdef GHCI
  import Name( Name )
  #endif
+import CoreSyn
+import PprCore
+import CoreUtils
+import CoreLint                ( lintCoreBindings )
  import PrelNames        ( iNTERACTIVE )
  import HscTypes
  import Module           ( Module )
  import PrelNames        ( iNTERACTIVE )
  import HscTypes
  import Module           ( Module )
@@ -54,6 +61,7 @@ import TcEnv            ( tcLookupGlobal )
  import TcRnMonad        ( TcM, initTc )
  
  import Outputable
  import TcRnMonad        ( TcM, initTc )
  
  import Outputable
+import FastString
  import qualified ErrUtils as Err
  import Maybes
  import UniqSupply
  import qualified ErrUtils as Err
  import Maybes
  import UniqSupply
@@ -72,7 +80,50 @@ import qualified Language.Haskell.TH as TH
  #endif
  \end{code}
  
  #endif
  \end{code}
  
-\subsection{Monad and carried data structure definitions}
+%************************************************************************
+%*                                                                     *
+                       Debug output
+%*                                                                     *
+%************************************************************************
+
+These functions are not CoreM monad stuff, but they probably ought to
+be, and it makes a conveneint place.  place for them.  They print out
+stuff before and after core passes, and do Core Lint when necessary.
+
+\begin{code}
+endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
+endPass = dumpAndLint Err.dumpIfSet_core
+
+endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
+endPassIf cond = dumpAndLint (Err.dumpIf_core cond)
+
+dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
+            -> DynFlags -> String -> DynFlag 
+            -> [CoreBind] -> [CoreRule] -> IO ()
+dumpAndLint dump dflags pass_name dump_flag binds rules
+  = do {  -- Report result size if required
+         -- This has the side effect of forcing the intermediate to be evaluated
+       ; Err.debugTraceMsg dflags 2 $
+               (text "    Result size =" <+> int (coreBindsSize binds))
+
+       -- Report verbosely, if required
+       ; dump dflags dump_flag pass_name
+              (pprCoreBindings binds $$ ppUnless (null rules) pp_rules)
+
+       -- Type check
+       ; lintCoreBindings dflags pass_name binds }
+  where
+    pp_rules = vcat [ blankLine
+                    , ptext (sLit "------ Local rules for imported ids --------")
+                    , pprRules rules ]
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+             Monad and carried data structure definitions
+%*                                                                     *
+%************************************************************************
  
  \begin{code}
  data CoreState = CoreState {
  
  \begin{code}
  data CoreState = CoreState {
@@ -160,7 +211,12 @@ runCoreM hsc_env ann_env rule_base us mod m =
  
  \end{code}
  
  
  \end{code}
  
-\subsection{Core combinators, not exported}
+
+%************************************************************************
+%*                                                                     *
+             Core combinators, not exported
+%*                                                                     *
+%************************************************************************
  
  \begin{code}
  
  
  \begin{code}
  
@@ -200,7 +256,12 @@ liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> re
  
  \end{code}
  
  
  \end{code}
  
-\subsection{Reader, writer and state accessors}
+
+%************************************************************************
+%*                                                                     *
+             Reader, writer and state accessors
+%*                                                                     *
+%************************************************************************
  
  \begin{code}
  
  
  \begin{code}
  
@@ -233,7 +294,12 @@ getOrigNameCache = do
  
  \end{code}
  
  
  \end{code}
  
-\subsection{Dealing with annotations}
+
+%************************************************************************
+%*                                                                     *
+             Dealing with annotations
+%*                                                                     *
+%************************************************************************
  
  \begin{code}
  
  
  \begin{code}
  
@@ -268,7 +334,12 @@ addAnnotationToEnv annotation = modifyS (\state -> state { cs_ann_env = extendAn
  
  \end{code}
  
  
  \end{code}
  
-\subsection{Direct screen output}
+
+%************************************************************************
+%*                                                                     *
+                Direct screen output
+%*                                                                     *
+%************************************************************************
  
  \begin{code}
  
  
  \begin{code}
  
@@ -312,7 +383,6 @@ debugTraceMsg = msg (flip Err.debugTraceMsg 3)
  -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
  dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
  dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
  -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
  dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
  dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
-
  \end{code}
  
  \begin{code}
  \end{code}
  
  \begin{code}
@@ -322,18 +392,25 @@ initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc
  
  \end{code}
  
  
  \end{code}
  
-\subsection{Finding TyThings}
  
  
-\begin{code}
+%************************************************************************
+%*                                                                     *
+               Finding TyThings
+%*                                                                     *
+%************************************************************************
  
  
+\begin{code}
  instance MonadThings CoreM where
      lookupThing name = do
          hsc_env <- getHscEnv
          liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
  instance MonadThings CoreM where
      lookupThing name = do
          hsc_env <- getHscEnv
          liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
-
  \end{code}
  
  \end{code}
  
-\subsection{Template Haskell interoperability}
+%************************************************************************
+%*                                                                     *
+               Template Haskell interoperability
+%*                                                                     *
+%************************************************************************
  
  \begin{code}
  #ifdef GHCI
  
  \begin{code}
  #ifdef GHCI
diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs

index 36e3d4d..cf53e91 100644 (file)
--- a/compiler/simplCore/FloatIn.lhs
+++ b/compiler/simplCore/FloatIn.lhs
@@ -18,7 +18,7 @@ module FloatIn ( floatInwards ) where
  
  import CoreSyn
  import CoreUtils       ( exprIsHNF, exprIsDupable )
  
  import CoreSyn
  import CoreUtils       ( exprIsHNF, exprIsDupable )
-import CoreFVs         ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleVars )
+import CoreFVs         ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleAndUnfoldingVars )
  import Id              ( isOneShotBndr, idType )
  import Var
  import Type            ( isUnLiftedType )
  import Id              ( isOneShotBndr, idType )
  import Var
  import Type            ( isUnLiftedType )
@@ -213,10 +213,6 @@ fiExpr to_drop (_, AnnNote note@(SCC _) expr)
    =    -- Wimp out for now
      mkCoLets' to_drop (Note note (fiExpr [] expr))
  
    =    -- Wimp out for now
      mkCoLets' to_drop (Note note (fiExpr [] expr))
  
-fiExpr to_drop (_, AnnNote InlineMe expr)
-  =    -- Ditto... don't float anything into an INLINE expression
-    mkCoLets' to_drop (Note InlineMe (fiExpr [] expr))
-
  fiExpr to_drop (_, AnnNote note@(CoreNote _) expr)
    = Note note (fiExpr to_drop expr)
  \end{code}
  fiExpr to_drop (_, AnnNote note@(CoreNote _) expr)
    = Note note (fiExpr to_drop expr)
  \end{code}
@@ -263,10 +259,12 @@ arrange to dump bindings that bind extra_fvs before the entire let.
  
  Note [extra_fvs (s): free variables of rules]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  
  Note [extra_fvs (s): free variables of rules]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider let x{rule mentioning y} = rhs in body
+Consider 
+  let x{rule mentioning y} = rhs in body 
  Here y is not free in rhs or body; but we still want to dump bindings
  that bind y outside the let.  So we augment extra_fvs with the
  Here y is not free in rhs or body; but we still want to dump bindings
  that bind y outside the let.  So we augment extra_fvs with the
-idRuleVars of x.
+idRuleAndUnfoldingVars of x.  No need for type variables, hence not using
+idFreeVars.
  
  
  \begin{code}
  
  
  \begin{code}
@@ -275,7 +273,7 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
    where
      body_fvs = freeVarsOf body
  
    where
      body_fvs = freeVarsOf body
  
-    rule_fvs = idRuleVars id   -- See Note [extra_fvs (2): free variables of rules]
+    rule_fvs = idRuleAndUnfoldingVars id       -- See Note [extra_fvs (2): free variables of rules]
      extra_fvs | noFloatIntoRhs ann_rhs
               || isUnLiftedType (idType id) = rule_fvs `unionVarSet` rhs_fvs
               | otherwise                   = rule_fvs
      extra_fvs | noFloatIntoRhs ann_rhs
               || isUnLiftedType (idType id) = rule_fvs `unionVarSet` rhs_fvs
               | otherwise                   = rule_fvs
@@ -304,7 +302,7 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
      body_fvs = freeVarsOf body
  
         -- See Note [extra_fvs (1,2)]
      body_fvs = freeVarsOf body
  
         -- See Note [extra_fvs (1,2)]
-    rule_fvs = foldr (unionVarSet . idRuleVars) emptyVarSet ids
+    rule_fvs = foldr (unionVarSet . idRuleAndUnfoldingVars) emptyVarSet ids
      extra_fvs = rule_fvs `unionVarSet` 
                 unionVarSets [ fvs | (fvs, rhs) <- rhss
                              , noFloatIntoRhs rhs ]
      extra_fvs = rule_fvs `unionVarSet` 
                 unionVarSets [ fvs | (fvs, rhs) <- rhss
                              , noFloatIntoRhs rhs ]
@@ -359,8 +357,7 @@ fiExpr to_drop (_, AnnCase scrut case_bndr ty alts)
      fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs)
  
  noFloatIntoRhs :: AnnExpr' Var (UniqFM Var) -> Bool
      fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs)
  
  noFloatIntoRhs :: AnnExpr' Var (UniqFM Var) -> Bool
-noFloatIntoRhs (AnnNote InlineMe _) = True
-noFloatIntoRhs (AnnLam b _)        = not (is_one_shot b)
+noFloatIntoRhs (AnnLam b _) = not (is_one_shot b)
         -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top.
         -- This makes a big difference for things like
         --      f x# = let x = I# x#
         -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top.
         -- This makes a big difference for things like
         --      f x# = let x = I# x#
diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs

index 27a39df..9dd4d68 100644 (file)
--- a/compiler/simplCore/FloatOut.lhs
+++ b/compiler/simplCore/FloatOut.lhs
@@ -297,13 +297,6 @@ floatExpr lvl (Note note@(SCC cc) expr)
         ann_bind (Rec pairs)
           = Rec [(binder, mkSCC dupd_cc rhs) | (binder, rhs) <- pairs]
  
         ann_bind (Rec pairs)
           = Rec [(binder, mkSCC dupd_cc rhs) | (binder, rhs) <- pairs]
  
-floatExpr _ (Note InlineMe expr)       -- Other than SCCs
-  = (zeroStats, [], Note InlineMe (unTag expr))
-       -- Do no floating at all inside INLINE.
-       -- The SetLevels pass did not clone the bindings, so it's
-       -- unsafe to do any floating, even if we dump the results
-       -- inside the Note (which is what we used to do).
-
  floatExpr lvl (Note note expr) -- Other than SCCs
    = case (floatExpr lvl expr)    of { (fs, floating_defns, expr') ->
      (fs, floating_defns, Note note expr') }
  floatExpr lvl (Note note expr) -- Other than SCCs
    = case (floatExpr lvl expr)    of { (fs, floating_defns, expr') ->
      (fs, floating_defns, Note note expr') }
@@ -344,22 +337,6 @@ floatList _ [] = (zeroStats, [], [])
  floatList f (a:as) = case f a           of { (fs_a,  binds_a,  b)  ->
                      case floatList f as of { (fs_as, binds_as, bs) ->
                      (fs_a `add_stats` fs_as, binds_a ++ binds_as, b:bs) }}
  floatList f (a:as) = case f a           of { (fs_a,  binds_a,  b)  ->
                      case floatList f as of { (fs_as, binds_as, bs) ->
                      (fs_a `add_stats` fs_as, binds_a ++ binds_as, b:bs) }}
-
-unTagBndr :: TaggedBndr tag -> CoreBndr
-unTagBndr (TB b _) = b
-
-unTag :: TaggedExpr tag -> CoreExpr
-unTag (Var v)            = Var v
-unTag (Lit l)            = Lit l
-unTag (Type ty)   = Type ty
-unTag (Note n e)  = Note n (unTag e)
-unTag (App e1 e2) = App (unTag e1) (unTag e2)
-unTag (Lam b e)   = Lam (unTagBndr b) (unTag e)
-unTag (Cast e co) = Cast (unTag e) co
-unTag (Let (Rec prs) e)    = Let (Rec [(unTagBndr b,unTag r) | (b, r) <- prs]) (unTag e)
-unTag (Let (NonRec b r) e) = Let (NonRec (unTagBndr b) (unTag r)) (unTag e)
-unTag (Case e b ty alts)   = Case (unTag e) (unTagBndr b) ty
-                                 [(c, map unTagBndr bs, unTag r) | (c,bs,r) <- alts]
  \end{code}
  
  %************************************************************************
  \end{code}
  
  %************************************************************************
diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs

index ae5c291..91e34f8 100644 (file)
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -23,7 +23,6 @@ import CoreUtils        ( exprIsTrivial, isDefaultAlt )
  import Coercion                ( mkSymCoercion )
  import Id
  import Name            ( localiseName )
  import Coercion                ( mkSymCoercion )
  import Id
  import Name            ( localiseName )
-import IdInfo
  import BasicTypes
  
  import VarSet
  import BasicTypes
  
  import VarSet
@@ -50,13 +49,16 @@ import Data.List
  Here's the externally-callable interface:
  
  \begin{code}
  Here's the externally-callable interface:
  
  \begin{code}
-occurAnalysePgm :: [CoreBind] -> [CoreBind]
-occurAnalysePgm binds
+occurAnalysePgm :: [CoreBind] -> [CoreRule] -> [CoreBind]
+occurAnalysePgm binds rules
    = snd (go initOccEnv binds)
    where
    = snd (go initOccEnv binds)
    where
+    initial_details = addIdOccs emptyDetails (rulesFreeVars rules)
+    -- The RULES keep things alive!
+
      go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
      go _ []
      go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
      go _ []
-        = (emptyDetails, [])
+        = (initial_details, [])
      go env (bind:binds)
          = (final_usage, bind' ++ binds')
          where
      go env (bind:binds)
          = (final_usage, bind' ++ binds')
          where
@@ -221,13 +223,15 @@ However things are made quite a bit more complicated by RULES.  Remember
  
      So we must *not* postInlineUnconditionally 'g', even though
      its RHS turns out to be trivial.  (I'm assuming that 'g' is
  
      So we must *not* postInlineUnconditionally 'g', even though
      its RHS turns out to be trivial.  (I'm assuming that 'g' is
-    not choosen as a loop breaker.)
+    not choosen as a loop breaker.)  Why not?  Because then we
+    drop the binding for 'g', which leaves it out of scope in the
+    RULE!
  
      We "solve" this by making g a "weak" or "rules-only" loop breaker,
      with OccInfo = IAmLoopBreaker True.  A normal "strong" loop breaker
      has IAmLoopBreaker False.  So
  
  
      We "solve" this by making g a "weak" or "rules-only" loop breaker,
      with OccInfo = IAmLoopBreaker True.  A normal "strong" loop breaker
      has IAmLoopBreaker False.  So
  
-                                Inline  postInlineUnconditinoally
+                                Inline  postInlineUnconditionally
          IAmLoopBreaker False    no      no
          IAmLoopBreaker True     yes     no
          other                   yes     yes
          IAmLoopBreaker False    no      no
          IAmLoopBreaker True     yes     no
          other                   yes     yes
@@ -247,6 +251,14 @@ However things are made quite a bit more complicated by RULES.  Remember
      rule's LHS too, so we'd better ensure the dependency is respected
  
  
      rule's LHS too, so we'd better ensure the dependency is respected
  
  
+  * Note [Inline rules]
+    ~~~~~~~~~~~~~~~~~~~
+    None of the above stuff about RULES applies to Inline Rules,
+    stored in a CoreUnfolding.  The unfolding, if any, is simplified
+    at the same time as the regular RHS of the function, so it should
+    be treated *exactly* like an extra RHS.
+
+
  Example [eftInt]
  ~~~~~~~~~~~~~~~
  Example (from GHC.Enum):
  Example [eftInt]
  ~~~~~~~~~~~~~~~
  Example (from GHC.Enum):
@@ -299,9 +311,10 @@ occAnalBind env (Rec pairs) body_usage
      rec_edges = {-# SCC "occAnalBind.assoc" #-}  map make_node pairs
      
      make_node (bndr, rhs)
      rec_edges = {-# SCC "occAnalBind.assoc" #-}  map make_node pairs
      
      make_node (bndr, rhs)
-       = (ND bndr rhs' rhs_usage rhs_fvs, idUnique bndr, out_edges)
+       = (ND bndr rhs' all_rhs_usage rhs_fvs, idUnique bndr, out_edges)
         where
           (rhs_usage, rhs') = occAnalRhs env bndr rhs
         where
           (rhs_usage, rhs') = occAnalRhs env bndr rhs
+         all_rhs_usage = addRuleUsage rhs_usage bndr    -- Note [Rules are extra RHSs]
           rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
           out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars bndr)
          -- (a -> b) means a mentions b
           rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
           out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars bndr)
          -- (a -> b) means a mentions b
@@ -324,7 +337,7 @@ occAnalRec (AcyclicSCC (ND bndr rhs rhs_usage _, _, _)) (body_usage, binds)
    = (body_usage, binds)
  
    | otherwise                  -- It's mentioned in the body
    = (body_usage, binds)
  
    | otherwise                  -- It's mentioned in the body
-  = (body_usage' +++ addRuleUsage rhs_usage bndr,      -- Note [Rules are extra RHSs]
+  = (body_usage' +++ rhs_usage,        
       NonRec tagged_bndr rhs : binds)
    where
      (body_usage', tagged_bndr) = tagBinder body_usage bndr
       NonRec tagged_bndr rhs : binds)
    where
      (body_usage', tagged_bndr) = tagBinder body_usage bndr
@@ -346,8 +359,7 @@ occAnalRec (CyclicSCC nodes) (body_usage, binds)
         ----------------------------
         -- Tag the binders with their occurrence info
      total_usage = foldl add_usage body_usage nodes
         ----------------------------
         -- Tag the binders with their occurrence info
      total_usage = foldl add_usage body_usage nodes
-    add_usage body_usage (ND bndr _ rhs_usage _, _, _)
-       = body_usage +++ addRuleUsage rhs_usage bndr
+    add_usage usage_so_far (ND _ _ rhs_usage _, _, _) = usage_so_far +++ rhs_usage
      (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes
  
      tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details)
      (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes
  
      tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details)
@@ -371,7 +383,7 @@ occAnalRec (CyclicSCC nodes) (body_usage, binds)
           | otherwise = foldr (reOrderRec 0) [] $
                         stronglyConnCompFromEdgedVerticesR loop_breaker_edges
  
           | otherwise = foldr (reOrderRec 0) [] $
                         stronglyConnCompFromEdgedVerticesR loop_breaker_edges
  
-       -- See Note [Choosing loop breakers] for looop_breaker_edges
+       -- See Note [Choosing loop breakers] for loop_breaker_edges
      loop_breaker_edges = map mk_node tagged_nodes
      mk_node (details@(ND _ _ _ rhs_fvs), k, _) = (details, k, new_ks)
         where
      loop_breaker_edges = map mk_node tagged_nodes
      mk_node (details@(ND _ _ _ rhs_fvs), k, _) = (details, k, new_ks)
         where
@@ -401,11 +413,6 @@ occAnalRec (CyclicSCC nodes) (body_usage, binds)
                  where
                    new_fvs = extendFvs env emptyVarSet fvs
  
                  where
                    new_fvs = extendFvs env emptyVarSet fvs
  
-idRuleRhsVars :: Id -> VarSet
--- Just the variables free on the *rhs* of a rule
--- See Note [Choosing loop breakers]
-idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet (idCoreRules id)
-
  extendFvs :: IdEnv IdSet -> IdSet -> IdSet -> IdSet
  -- (extendFVs env fvs s) returns (fvs `union` env(s))
  extendFvs env fvs id_set
  extendFvs :: IdEnv IdSet -> IdSet -> IdSet -> IdSet
  -- (extendFVs env fvs s) returns (fvs `union` env(s))
  extendFvs env fvs id_set
@@ -456,9 +463,14 @@ type Node details = (details, Unique, [Unique])    -- The Ints are gotten from the
                                                 -- which is gotten from the Id.
  data Details = ND Id           -- Binder
                   CoreExpr      -- RHS
                                                 -- which is gotten from the Id.
  data Details = ND Id           -- Binder
                   CoreExpr      -- RHS
-                 UsageDetails  -- Full usage from RHS (*not* including rules)
-                 IdSet         -- Other binders from this Rec group mentioned on RHS
-                               -- (derivable from UsageDetails but cached here)
+
+                 UsageDetails  -- Full usage from RHS, 
+                                -- including *both* RULES *and* InlineRule unfolding
+
+                 IdSet         -- Other binders *from this Rec group* mentioned in
+                               --   * the  RHS
+                               --   * any InlineRule unfolding
+                               -- but *excluding* any RULES
  
  reOrderRec :: Int -> SCC (Node Details)
             -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
  
  reOrderRec :: Int -> SCC (Node Details)
             -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
@@ -514,17 +526,21 @@ reOrderCycle depth (bind : binds) pairs
  
      score :: Node Details -> Int        -- Higher score => less likely to be picked as loop breaker
      score (ND bndr rhs _ _, _, _)
  
      score :: Node Details -> Int        -- Higher score => less likely to be picked as loop breaker
      score (ND bndr rhs _ _, _, _)
-        | workerExists (idWorkerInfo bndr)      = 10
-                -- Note [Worker inline loop]
-
-        | exprIsTrivial rhs        = 5  -- Practically certain to be inlined
+        | exprIsTrivial rhs        = 10  -- Practically certain to be inlined
                  -- Used to have also: && not (isExportedId bndr)
                  -- But I found this sometimes cost an extra iteration when we have
                  --      rec { d = (a,b); a = ...df...; b = ...df...; df = d }
                  -- where df is the exported dictionary. Then df makes a really
                  -- bad choice for loop breaker
  
                  -- Used to have also: && not (isExportedId bndr)
                  -- But I found this sometimes cost an extra iteration when we have
                  --      rec { d = (a,b); a = ...df...; b = ...df...; df = d }
                  -- where df is the exported dictionary. Then df makes a really
                  -- bad choice for loop breaker
  
-        | is_con_app rhs = 3    -- Data types help with cases
+        | Just inl_rule_info <- isInlineRule_maybe (idUnfolding bndr)
+       = case inl_rule_info of
+            InlWrapper {} -> 10  -- Note [INLINE pragmas]
+            _other        ->  3  -- Data structures are more important than this
+                                 -- so that dictionary/method recursion unravels
+                
+        | is_con_app rhs = 5    -- Data types help with cases
+                               -- Includes dict funs
                  -- Note [Constructor applictions]
  
  -- If an Id is marked "never inline" then it makes a great loop breaker
                  -- Note [Constructor applictions]
  
  -- If an Id is marked "never inline" then it makes a great loop breaker
@@ -533,34 +549,16 @@ reOrderCycle depth (bind : binds) pairs
  -- so it probably isn't worth the time to test on every binder
  --     | isNeverActive (idInlinePragma bndr) = -10
  
  -- so it probably isn't worth the time to test on every binder
  --     | isNeverActive (idInlinePragma bndr) = -10
  
-        | inlineCandidate bndr rhs = 2  -- Likely to be inlined
-                -- Note [Inline candidates]
+        | isOneOcc (idOccInfo bndr) = 2  -- Likely to be inlined
  
  
-        | not (neverUnfold (idUnfolding bndr)) = 1
+        | canUnfold (idUnfolding bndr) = 1
                  -- the Id has some kind of unfolding
  
          | otherwise = 0
                  -- the Id has some kind of unfolding
  
          | otherwise = 0
+        where
+         
  
  
-    inlineCandidate :: Id -> CoreExpr -> Bool
-    inlineCandidate _  (Note InlineMe _) = True
-    inlineCandidate id _                 = isOneOcc (idOccInfo id)
-
-        -- Note [conapp]
-        --
-        -- It's really really important to inline dictionaries.  Real
-        -- example (the Enum Ordering instance from GHC.Base):
-        --
-        --      rec     f = \ x -> case d of (p,q,r) -> p x
-        --              g = \ x -> case d of (p,q,r) -> q x
-        --              d = (v, f, g)
-        --
-        -- Here, f and g occur just once; but we can't inline them into d.
-        -- On the other hand we *could* simplify those case expressions if
-        -- we didn't stupidly choose d as the loop breaker.
-        -- But we won't because constructor args are marked "Many".
-        -- Inlining dictionaries is really essential to unravelling
-        -- the loops in static numeric dictionaries, see GHC.Float.
-
+       -- Checking for a constructor application
          -- Cheap and cheerful; the simplifer moves casts out of the way
          -- The lambda case is important to spot x = /\a. C (f a)
          -- which comes up when C is a dictionary constructor and
          -- Cheap and cheerful; the simplifer moves casts out of the way
          -- The lambda case is important to spot x = /\a. C (f a)
          -- which comes up when C is a dictionary constructor and
@@ -569,7 +567,7 @@ reOrderCycle depth (bind : binds) pairs
          --
          -- However we *also* treat (\x. C p q) as a con-app-like thing,
          --      Note [Closure conversion]
          --
          -- However we *also* treat (\x. C p q) as a con-app-like thing,
          --      Note [Closure conversion]
-    is_con_app (Var v)    = isDataConWorkId v
+    is_con_app (Var v)    = isConLikeId v
      is_con_app (App f _)  = is_con_app f
      is_con_app (Lam _ e)  = is_con_app e
      is_con_app (Note _ e) = is_con_app e
      is_con_app (App f _)  = is_con_app f
      is_con_app (Lam _ e)  = is_con_app e
      is_con_app (Note _ e) = is_con_app e
@@ -634,8 +632,18 @@ strict (and hence it gets an auto-generated wrapper).  Result: an
  infinite inlining in the importing scope.  So be a bit careful if you
  change this.  A good example is Tree.repTree in
  nofib/spectral/minimax. If the repTree wrapper is chosen as the loop
  infinite inlining in the importing scope.  So be a bit careful if you
  change this.  A good example is Tree.repTree in
  nofib/spectral/minimax. If the repTree wrapper is chosen as the loop
-breaker then compiling Game.hs goes into an infinite loop (this
-happened when we gave is_con_app a lower score than inline candidates).
+breaker then compiling Game.hs goes into an infinite loop.  This
+happened when we gave is_con_app a lower score than inline candidates:
+
+  Tree.repTree
+    = __inline_me (/\a. \w w1 w2 -> 
+                   case Tree.$wrepTree @ a w w1 w2 of
+                    { (# ww1, ww2 #) -> Branch @ a ww1 ww2 })
+  Tree.$wrepTree
+    = /\a w w1 w2 -> 
+      (# w2_smP, map a (Tree a) (Tree.repTree a w1 w) (w w2) #)
+
+Here we do *not* want to choose 'repTree' as the loop breaker.
  
  Note [Constructor applications]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  
  Note [Constructor applications]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -693,10 +701,13 @@ occAnalRhs :: OccEnv
                                  -- For non-recs the binder is alrady tagged
                                  -- with occurrence info
             -> (UsageDetails, CoreExpr)
                                  -- For non-recs the binder is alrady tagged
                                  -- with occurrence info
             -> (UsageDetails, CoreExpr)
+             -- Returned usage details includes any INLINE rhs
  
  occAnalRhs env id rhs
  
  occAnalRhs env id rhs
-  = occAnal ctxt rhs
+  = (addIdOccs rhs_usage (idUnfoldingVars id), rhs')
+       -- Include occurrences for the "extra RHS" from a CoreUnfolding
    where
    where
+    (rhs_usage, rhs') = occAnal ctxt rhs
      ctxt | certainly_inline id = env
           | otherwise           = rhsCtxt env
          -- Note that we generally use an rhsCtxt.  This tells the occ anal n
      ctxt | certainly_inline id = env
           | otherwise           = rhsCtxt env
          -- Note that we generally use an rhsCtxt.  This tells the occ anal n
@@ -724,12 +735,15 @@ occAnalRhs env id rhs
  \begin{code}
  addRuleUsage :: UsageDetails -> Id -> UsageDetails
  -- Add the usage from RULES in Id to the usage
  \begin{code}
  addRuleUsage :: UsageDetails -> Id -> UsageDetails
  -- Add the usage from RULES in Id to the usage
-addRuleUsage usage id
-  = foldVarSet add usage (idRuleVars id)
+addRuleUsage usage id = addIdOccs usage (idRuleVars id)
          -- idRuleVars here: see Note [Rule dependency info]
          -- idRuleVars here: see Note [Rule dependency info]
+
+addIdOccs :: UsageDetails -> VarSet -> UsageDetails
+addIdOccs usage id_set = foldVarSet add usage id_set
    where
    where
-    add v u = addOneOcc u v NoOccInfo
-       -- Give a non-committal binder info (i.e manyOcc) because
+    add v u | isId v    = addOneOcc u v NoOccInfo
+            | otherwise = u
+       -- Give a non-committal binder info (i.e NoOccInfo) because
         --   a) Many copies of the specialised thing can appear
         --   b) We don't want to substitute a BIG expression inside a RULE
         --      even if that's the only occurrence of the thing
         --   a) Many copies of the specialised thing can appear
         --   b) We don't want to substitute a BIG expression inside a RULE
         --      even if that's the only occurrence of the thing
@@ -774,11 +788,6 @@ occAnal _   expr@(Lit _) = (emptyDetails, expr)
  \end{code}
  
  \begin{code}
  \end{code}
  
  \begin{code}
-occAnal env (Note InlineMe body)
-  = case occAnal env body of { (usage, body') ->
-    (mapVarEnv markMany usage, Note InlineMe body')
-    }
-
  occAnal env (Note note@(SCC _) body)
    = case occAnal env body of { (usage, body') ->
      (mapVarEnv markInsideSCC usage, Note note body')
  occAnal env (Note note@(SCC _) body)
    = case occAnal env body of { (usage, body') ->
      (mapVarEnv markInsideSCC usage, Note note body')
@@ -823,7 +832,9 @@ occAnal env (Lam x body) | isTyVar x
  occAnal env expr@(Lam _ _)
    = case occAnal env_body body of { (body_usage, body') ->
      let
  occAnal env expr@(Lam _ _)
    = case occAnal env_body body of { (body_usage, body') ->
      let
-        (final_usage, tagged_binders) = tagBinders body_usage binders
+        (final_usage, tagged_binders) = tagLamBinders body_usage binders'
+                     -- Use binders' to put one-shot info on the lambdas
+
          --      URGH!  Sept 99: we don't seem to be able to use binders' here, because
          --      we get linear-typed things in the resulting program that we can't handle yet.
          --      (e.g. PrelShow)  TODO
          --      URGH!  Sept 99: we don't seem to be able to use binders' here, because
          --      we get linear-typed things in the resulting program that we can't handle yet.
          --      (e.g. PrelShow)  TODO
@@ -847,8 +858,7 @@ occAnal env (Case scrut bndr ty alts)
      case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts')   ->
      let
          alts_usage  = foldr1 combineAltsUsageDetails alts_usage_s
      case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts')   ->
      let
          alts_usage  = foldr1 combineAltsUsageDetails alts_usage_s
-        alts_usage' = addCaseBndrUsage alts_usage
-        (alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr
+        (alts_usage1, tagged_bndr) = tag_case_bndr alts_usage bndr
          total_usage = scrut_usage +++ alts_usage1
      in
      total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
          total_usage = scrut_usage +++ alts_usage1
      in
      total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
@@ -862,9 +872,10 @@ occAnal env (Case scrut bndr ty alts)
          --      case x of w { (p,q) -> f w }
          -- into
          --      case x of w { (p,q) -> f (p,q) }
          --      case x of w { (p,q) -> f w }
          -- into
          --      case x of w { (p,q) -> f (p,q) }
-    addCaseBndrUsage usage = case lookupVarEnv usage bndr of
-                                Nothing -> usage
-                                Just _  -> extendVarEnv usage bndr NoOccInfo
+    tag_case_bndr usage bndr
+      = case lookupVarEnv usage bndr of
+          Nothing -> (usage,                  setIdOccInfo bndr IAmDead)
+          Just _  -> (usage `delVarEnv` bndr, setIdOccInfo bndr NoOccInfo)
  
      alt_env = mkAltEnv env bndr_swap
          -- Consider     x = case v of { True -> (p,q); ... }
  
      alt_env = mkAltEnv env bndr_swap
          -- Consider     x = case v of { True -> (p,q); ... }
@@ -915,6 +926,7 @@ occAnalApp env (Var fun, args)
      fun_uniq = idUnique fun
      fun_uds  = mkOneOcc env fun (valArgCount args > 0)
      is_pap = isConLikeId fun || valArgCount args < idArity fun
      fun_uniq = idUnique fun
      fun_uds  = mkOneOcc env fun (valArgCount args > 0)
      is_pap = isConLikeId fun || valArgCount args < idArity fun
+          -- See Note [CONLIKE pragma] in BasicTypes
  
                  -- Hack for build, fold, runST
      args_stuff  | fun_uniq == buildIdKey    = appSpecial env 2 [True,True]  args
  
                  -- Hack for build, fold, runST
      args_stuff  | fun_uniq == buildIdKey    = appSpecial env 2 [True,True]  args
@@ -1128,9 +1140,9 @@ Consider
      case x of y { (a,b) -> f y }
  We treat 'a', 'b' as dead, because they don't physically occur in the
  case alternative.  (Indeed, a variable is dead iff it doesn't occur in
      case x of y { (a,b) -> f y }
  We treat 'a', 'b' as dead, because they don't physically occur in the
  case alternative.  (Indeed, a variable is dead iff it doesn't occur in
-its scope in the output of OccAnal.)  This invariant is It really
-helpe to know when binders are unused.  See esp the call to
-isDeadBinder in Simplify.mkDupableAlt
+its scope in the output of OccAnal.)  It really helps to know when
+binders are unused.  See esp the call to isDeadBinder in
+Simplify.mkDupableAlt
  
  In this example, though, the Simplifier will bring 'a' and 'b' back to
  life, beause it binds 'y' to (a,b) (imagine got inlined and
  
  In this example, though, the Simplifier will bring 'a' and 'b' back to
  life, beause it binds 'y' to (a,b) (imagine got inlined and
@@ -1145,7 +1157,7 @@ occAnalAlt :: OccEnv
  occAnalAlt env case_bndr mb_scrut_var (con, bndrs, rhs)
    = case occAnal env rhs of { (rhs_usage, rhs') ->
      let
  occAnalAlt env case_bndr mb_scrut_var (con, bndrs, rhs)
    = case occAnal env rhs of { (rhs_usage, rhs') ->
      let
-        (alt_usg, tagged_bndrs) = tagBinders rhs_usage bndrs
+        (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage bndrs
          bndrs' = tagged_bndrs      -- See Note [Binders in case alternatives]
      in
      case mb_scrut_var of
          bndrs' = tagged_bndrs      -- See Note [Binders in case alternatives]
      in
      case mb_scrut_var of
@@ -1213,7 +1225,7 @@ type CtxtTy = [Bool]
          --                      the CtxtTy inside applies
  
  initOccEnv :: OccEnv
          --                      the CtxtTy inside applies
  
  initOccEnv :: OccEnv
-initOccEnv = OccEnv { occ_encl = OccRhs
+initOccEnv = OccEnv { occ_encl = OccVanilla
                     , occ_ctxt = []
                     , occ_scrut_ids = emptyVarSet }
  
                     , occ_ctxt = []
                     , occ_scrut_ids = emptyVarSet }
  
@@ -1302,17 +1314,21 @@ v `usedIn`      details =  isExportedId v || v `localUsedIn` details
  
  type IdWithOccInfo = Id
  
  
  type IdWithOccInfo = Id
  
-tagBinders :: UsageDetails          -- Of scope
-           -> [Id]                  -- Binders
-           -> (UsageDetails,        -- Details with binders removed
-              [IdWithOccInfo])    -- Tagged binders
-
-tagBinders usage binders
- = let
-     usage' = usage `delVarEnvList` binders
-     uss    = map (setBinderOcc usage) binders
-   in
-   usage' `seq` (usage', uss)
+tagLamBinders :: UsageDetails          -- Of scope
+              -> [Id]                  -- Binders
+              -> (UsageDetails,        -- Details with binders removed
+                 [IdWithOccInfo])    -- Tagged binders
+-- Used for lambda and case binders
+-- It copes with the fact that lambda bindings can have InlineRule 
+-- unfoldings, used for join points
+tagLamBinders usage binders = usage' `seq` (usage', bndrs')
+  where
+    (usage', bndrs') = mapAccumR tag_lam usage binders
+    tag_lam usage bndr = (usage2, setBinderOcc usage bndr)
+      where
+        usage1 = usage `delVarEnv` bndr
+        usage2 | isId bndr = addIdOccs usage1 (idUnfoldingVars bndr)
+               | otherwise = usage1
  
  tagBinder :: UsageDetails           -- Of scope
            -> Id                     -- Binders
  
  tagBinder :: UsageDetails           -- Of scope
            -> Id                     -- Binders
diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs

index 0797ad7..c9b0601 100644 (file)
--- a/compiler/simplCore/SetLevels.lhs
+++ b/compiler/simplCore/SetLevels.lhs
@@ -48,7 +48,7 @@ module SetLevels (
         Level(..), tOP_LEVEL,
         LevelledBind, LevelledExpr,
  
         Level(..), tOP_LEVEL,
         LevelledBind, LevelledExpr,
  
-       incMinorLvl, ltMajLvl, ltLvl, isTopLvl, isInlineCtxt
+       incMinorLvl, ltMajLvl, ltLvl, isTopLvl
      ) where
  
  #include "HsVersions.h"
      ) where
  
  #include "HsVersions.h"
@@ -57,12 +57,14 @@ import CoreSyn
  
  import DynFlags                ( FloatOutSwitches(..) )
  import CoreUtils       ( exprType, exprIsTrivial, mkPiTypes )
  
  import DynFlags                ( FloatOutSwitches(..) )
  import CoreUtils       ( exprType, exprIsTrivial, mkPiTypes )
+import CoreArity       ( exprBotStrictness_maybe )
  import CoreFVs         -- all of it
  import CoreFVs         -- all of it
-import CoreSubst       ( Subst, emptySubst, extendInScope, extendIdSubst,
-                         cloneIdBndr, cloneRecIdBndrs )
+import CoreSubst       ( Subst, emptySubst, extendInScope, extendInScopeList,
+                         extendIdSubst, cloneIdBndr, cloneRecIdBndrs )
  import Id              ( idType, mkSysLocal, isOneShotLambda,
                           zapDemandIdInfo, transferPolyIdInfo,
  import Id              ( idType, mkSysLocal, isOneShotLambda,
                           zapDemandIdInfo, transferPolyIdInfo,
-                         idSpecialisation, idWorkerInfo, setIdInfo
+                         idSpecialisation, idUnfolding, setIdInfo, 
+                         setIdNewStrictness, setIdArity
                         )
  import IdInfo
  import Var
                         )
  import IdInfo
  import Var
@@ -85,9 +87,7 @@ import FastString
  %************************************************************************
  
  \begin{code}
  %************************************************************************
  
  \begin{code}
-data Level = InlineCtxt        -- A level that's used only for
-                       -- the context parameter ctxt_lvl
-          | Level Int  -- Level number of enclosing lambdas
+data Level = 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}
                    Int  -- Number of big-lambda and/or case expressions between
                         -- here and the nearest enclosing lambda
  \end{code}
@@ -150,55 +150,37 @@ the worker at all.
  type LevelledExpr  = TaggedExpr Level
  type LevelledBind  = TaggedBind Level
  
  type LevelledExpr  = TaggedExpr Level
  type LevelledBind  = TaggedBind Level
  
-tOP_LEVEL, iNLINE_CTXT :: Level
+tOP_LEVEL :: Level
  tOP_LEVEL   = Level 0 0
  tOP_LEVEL   = Level 0 0
-iNLINE_CTXT = InlineCtxt
  
  incMajorLvl :: Level -> Level
  
  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
  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
  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
  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
  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
  
  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
  instance Outputable Level where
-  ppr InlineCtxt      = text "<INLINE>"
    ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
  
  instance Eq Level where
    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
    (Level maj1 min1) == (Level maj2 min2) = maj1 == maj2 && min1 == min2
-  _                 == _                 = False
  \end{code}
  
  
  \end{code}
  
  
@@ -215,21 +197,17 @@ setLevels :: FloatOutSwitches
           -> [LevelledBind]
  
  setLevels float_lams binds us
           -> [LevelledBind]
  
  setLevels float_lams binds us
-  = initLvl us (do_them binds)
+  = initLvl us (do_them init_env binds)
    where
    where
-    -- "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)
-
      init_env = initialEnv float_lams
  
      init_env = initialEnv float_lams
  
+    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) }
+
  lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv)
  lvlTopBind env (NonRec binder rhs)
    = lvlBind TopLevel tOP_LEVEL env (AnnNonRec binder (freeVars rhs))
  lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv)
  lvlTopBind env (NonRec binder rhs)
    = lvlBind TopLevel tOP_LEVEL env (AnnNonRec binder (freeVars rhs))
@@ -283,11 +261,6 @@ 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
  
         -- 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')
  lvlExpr ctxt_lvl env (_, AnnNote note expr) = do
      expr' <- lvlExpr ctxt_lvl env expr
      return (Note note expr')
@@ -359,13 +332,25 @@ lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr ty alts) = do
  the expression, so that it can itself be floated.
  
  Note [Unlifted MFEs]
  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.
  
  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.
+
  Note [Case MFEs]
  ~~~~~~~~~~~~~~~~
  We don't float a case expression as an MFE from a strict context.  Why not?
  Note [Case MFEs]
  ~~~~~~~~~~~~~~~~
  We don't float a case expression as an MFE from a strict context.  Why not?
@@ -384,13 +369,17 @@ lvlMFE ::  Bool                   -- True <=> strict context [body of case or let]
  lvlMFE _ _ _ (_, AnnType ty)
    = return (Type ty)
  
  lvlMFE _ _ _ (_, AnnType ty)
    = return (Type ty)
  
--- No point in floating out an expression wrapped in a coercion;
+-- No point in floating out an expression wrapped in a coercion or note
  -- 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.
  -- 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)
  lvlMFE strict_ctxt ctxt_lvl env (_, AnnCast e co)
-  = do { expr' <- lvlMFE strict_ctxt ctxt_lvl env e
-       ; return (Cast expr' co) }
+  = do { e' <- lvlMFE strict_ctxt ctxt_lvl env e
+       ; return (Cast e' co) }
  
  -- Note [Case MFEs]
  lvlMFE True ctxt_lvl env e@(_, AnnCase {})
  
  -- Note [Case MFEs]
  lvlMFE True ctxt_lvl env e@(_, AnnCase {})
@@ -398,7 +387,6 @@ lvlMFE True ctxt_lvl env e@(_, AnnCase {})
  
  lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
    |  isUnLiftedType ty                 -- Can't let-bind it; see Note [Unlifted MFEs]
  
  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
    || exprIsTrivial expr                        -- Never float if it's trivial
    || not good_destination
    =    -- Don't float it out
@@ -407,8 +395,13 @@ 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
    | otherwise  -- Float it out!
    = do expr' <- lvlFloatRhs abs_vars dest_lvl env ann_expr
         var <- newLvlVar "lvl" abs_vars ty
-       return (Let (NonRec (TB var dest_lvl) expr') 
-                   (mkVarApps (Var var) abs_vars))
+               -- 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))
    where
      expr     = deAnnotate ann_expr
      ty       = exprType expr
    where
      expr     = deAnnotate ann_expr
      ty       = exprType expr
@@ -503,7 +496,6 @@ 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)
  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)
  
    = do rhs' <- lvlExpr ctxt_lvl env rhs
         return (NonRec (TB bndr ctxt_lvl) rhs', env)
  
@@ -528,10 +520,6 @@ lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
  
  \begin{code}
  lvlBind top_lvl ctxt_lvl env (AnnRec pairs)
  
  \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
    | 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
@@ -733,6 +721,12 @@ extendLvlEnv (float_lams, lvl_env, subst, id_env) prs
    -- incorrectly, because the SubstEnv was still lying around.  Ouch!
    -- KSW 2000-07.
  
    -- 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
  -- 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
@@ -820,7 +814,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)
  
         -- We are going to lambda-abstract, so nuke any IdInfo,
         -- and add the tyvars of the Id (if necessary)
-    zap v | isId v = WARN( workerExists (idWorkerInfo v) ||
+    zap v | isId v = WARN( isInlineRule (idUnfolding v) ||
                            not (isEmptySpecInfo (idSpecialisation v)),
                            text "absVarsOf: discarding info on" <+> ppr v )
                      setIdInfo v vanillaIdInfo
                            not (isEmptySpecInfo (idSpecialisation v)),
                            text "absVarsOf: discarding info on" <+> ppr v )
                      setIdInfo v vanillaIdInfo
@@ -881,7 +875,9 @@ newLvlVar str vars body_ty = do
  
  cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> Level -> LvlM (LevelEnv, Id)
  cloneVar TopLevel env v _ _
  
  cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> Level -> LvlM (LevelEnv, Id)
  cloneVar TopLevel env v _ _
-  = return (env, v)    -- Don't clone top level things
+  = return (extendInScopeEnv env v, v) -- Don't clone top level things
+               -- But do extend the in-scope env, to satisfy the in-scope invariant
+
  cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl
    = ASSERT( isId v ) do
      us <- getUniqueSupplyM
  cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl
    = ASSERT( isId v ) do
      us <- getUniqueSupplyM
@@ -893,7 +889,7 @@ cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl
  
  cloneRecVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> Level -> LvlM (LevelEnv, [Id])
  cloneRecVars TopLevel env vs _ _
  
  cloneRecVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> Level -> LvlM (LevelEnv, [Id])
  cloneRecVars TopLevel env vs _ _
-  = return (env, vs)   -- Don't clone top level things
+  = return (extendInScopeEnvList env vs, vs)   -- Don't clone top level things
  cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl
    = ASSERT( all isId vs ) do
      us <- getUniqueSupplyM
  cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl
    = ASSERT( all isId vs ) do
      us <- getUniqueSupplyM
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs

index bb83283..62c3c35 100644 (file)
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -19,6 +19,7 @@ import DynFlags               ( CoreToDo(..), SimplifierSwitch(..),
                           SimplifierMode(..), DynFlags, DynFlag(..), dopt,
                           getCoreToDo, shouldDumpSimplPhase )
  import CoreSyn
                           SimplifierMode(..), DynFlags, DynFlag(..), dopt,
                           getCoreToDo, shouldDumpSimplPhase )
  import CoreSyn
+import CoreSubst
  import HscTypes
  import CSE             ( cseProgram )
  import Rules           ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
  import HscTypes
  import CSE             ( cseProgram )
  import Rules           ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
@@ -30,11 +31,12 @@ import OccurAnal    ( occurAnalysePgm, occurAnalyseExpr )
  import IdInfo
  import CoreUtils       ( coreBindsSize )
  import Simplify                ( simplTopBinds, simplExpr )
  import IdInfo
  import CoreUtils       ( coreBindsSize )
  import Simplify                ( simplTopBinds, simplExpr )
-import SimplEnv                ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
+import SimplEnv
  import SimplMonad
  import CoreMonad
  import SimplMonad
  import CoreMonad
-import qualified ErrUtils as Err        ( dumpIfSet_dyn, dumpIfSet, showPass )
-import CoreLint                ( showPass, endPass, endPassIf, endIteration )
+import qualified ErrUtils as Err 
+import CoreLint
+import CoreMonad       ( endPass )
  import FloatIn         ( floatInwards )
  import FloatOut                ( floatOutwards )
  import FamInstEnv
  import FloatIn         ( floatInwards )
  import FloatOut                ( floatOutwards )
  import FamInstEnv
@@ -89,7 +91,7 @@ core2core hsc_env guts = do
      ann_env <- prepareAnnotations hsc_env (Just guts)
  
      -- COMPUTE THE RULE BASE TO USE
      ann_env <- prepareAnnotations hsc_env (Just guts)
  
      -- COMPUTE THE RULE BASE TO USE
-    (imp_rule_base, guts1) <- prepareRules hsc_env guts ru_us
+    (hpt_rule_base, guts1) <- prepareRules hsc_env guts ru_us
  
      -- Get the module out of the current HscEnv so we can retrieve it from the monad.
      -- This is very convienent for the users of the monad (e.g. plugins do not have to
  
      -- Get the module out of the current HscEnv so we can retrieve it from the monad.
      -- This is very convienent for the users of the monad (e.g. plugins do not have to
@@ -97,7 +99,7 @@ core2core hsc_env guts = do
      -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
      -- would mean our cached value would go out of date.
      let mod = mg_module guts
      -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
      -- would mean our cached value would go out of date.
      let mod = mg_module guts
-    (guts2, stats) <- runCoreM hsc_env ann_env imp_rule_base cp_us mod $ do
+    (guts2, stats) <- runCoreM hsc_env ann_env hpt_rule_base cp_us mod $ do
          -- FIND BUILT-IN PASSES
          let builtin_core_todos = getCoreToDo dflags
  
          -- FIND BUILT-IN PASSES
          let builtin_core_todos = getCoreToDo dflags
  
@@ -223,10 +225,10 @@ describePass :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> Co
  describePass name dflag pass guts = do
      dflags <- getDynFlags
      
  describePass name dflag pass guts = do
      dflags <- getDynFlags
      
-    liftIO $ showPass dflags name
+    liftIO $ Err.showPass dflags name
      guts' <- pass guts
      guts' <- pass guts
-    liftIO $ endPass dflags name dflag (mg_binds guts')
-    
+    liftIO $ endPass dflags name dflag (mg_binds guts') (mg_rules guts')
+
      return guts'
  
  describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
      return guts'
  
  describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
@@ -319,64 +321,74 @@ prepareRules :: HscEnv
  
                     ModGuts)            -- Modified fields are 
                                         --      (a) Bindings have rules attached,
  
                     ModGuts)            -- Modified fields are 
                                         --      (a) Bindings have rules attached,
+                                       --              and INLINE rules simplified
                                         --      (b) Rules are now just orphan rules
  
  prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
              guts@(ModGuts { mg_binds = binds, mg_deps = deps 
                            , mg_rules = local_rules, mg_rdr_env = rdr_env })
              us 
                                         --      (b) Rules are now just orphan rules
  
  prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
              guts@(ModGuts { mg_binds = binds, mg_deps = deps 
                            , mg_rules = local_rules, mg_rdr_env = rdr_env })
              us 
-  = do { let   -- Simplify the local rules; boringly, we need to make an in-scope set
+  = do { us <- mkSplitUniqSupply 'w'
+
+       ; let   -- Simplify the local rules; boringly, we need to make an in-scope set
                 -- from the local binders, to avoid warnings from Simplify.simplVar
               local_ids        = mkInScopeSet (mkVarSet (bindersOfBinds binds))
               env              = setInScopeSet gentleSimplEnv local_ids 
                 -- from the local binders, to avoid warnings from Simplify.simplVar
               local_ids        = mkInScopeSet (mkVarSet (bindersOfBinds binds))
               env              = setInScopeSet gentleSimplEnv local_ids 
-             (better_rules,_) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
-                                (mapM (simplRule env) local_rules)
-             home_pkg_rules   = hptRules hsc_env (dep_mods deps)
-
-               -- Find the rules for locally-defined Ids; then we can attach them
-               -- to the binders in the top-level bindings
-               -- 
-               -- Reason
-               --      - It makes the rules easier to look up
-               --      - It means that transformation rules and specialisations for
-               --        locally defined Ids are handled uniformly
-               --      - It keeps alive things that are referred to only from a rule
-               --        (the occurrence analyser knows about rules attached to Ids)
-               --      - It makes sure that, when we apply a rule, the free vars
-               --        of the RHS are more likely to be in scope
-               --      - The imported rules are carried in the in-scope set
-               --        which is extended on each iteration by the new wave of
-               --        local binders; any rules which aren't on the binding will
-               --        thereby get dropped
-             (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules
-             local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
-             binds_w_rules   = updateBinders local_rule_base binds
-
-             hpt_rule_base = mkRuleBase home_pkg_rules
-             imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps
+             (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
+                                mapM (simplRule env) local_rules
+
+       ; let (rules_for_locals, rules_for_imps) = partition isLocalRule simpl_rules
+
+             home_pkg_rules = hptRules hsc_env (dep_mods deps)
+             hpt_rule_base  = mkRuleBase home_pkg_rules
+             binds_w_rules  = updateBinders rules_for_locals binds
+
  
         ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
                 (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
  
         ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
                 (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
-                vcat [text "Local rules", pprRules better_rules,
-                      text "",
-                      text "Imported rules", pprRuleBase imp_rule_base])
+                vcat [text "Local rules", pprRules simpl_rules,
+                      blankLine,
+                      text "Imported rules", pprRuleBase hpt_rule_base])
  
  
-       ; return (imp_rule_base, guts { mg_binds = binds_w_rules, 
+       ; return (hpt_rule_base, guts { mg_binds = binds_w_rules, 
                                         mg_rules = rules_for_imps })
      }
  
                                         mg_rules = rules_for_imps })
      }
  
-updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
-updateBinders local_rules binds
-  = map update_bndrs binds
+-- Note [Attach rules to local ids]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Find the rules for locally-defined Ids; then we can attach them
+-- to the binders in the top-level bindings
+-- 
+-- Reason
+--     - It makes the rules easier to look up
+--     - It means that transformation rules and specialisations for
+--       locally defined Ids are handled uniformly
+--     - It keeps alive things that are referred to only from a rule
+--       (the occurrence analyser knows about rules attached to Ids)
+--     - It makes sure that, when we apply a rule, the free vars
+--       of the RHS are more likely to be in scope
+--     - The imported rules are carried in the in-scope set
+--       which is extended on each iteration by the new wave of
+--       local binders; any rules which aren't on the binding will
+--       thereby get dropped
+
+updateBinders :: [CoreRule] -> [CoreBind] -> [CoreBind]
+updateBinders rules_for_locals binds
+  = map update_bind binds
    where
    where
-    update_bndrs (NonRec b r) = NonRec (update_bndr b) r
-    update_bndrs (Rec prs)    = Rec [(update_bndr b, r) | (b,r) <- prs]
-
-    update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of
-                         Nothing    -> bndr
-                         Just rules -> bndr `addIdSpecialisations` rules
-                               -- The binder might have some existing rules,
-                               -- arising from specialisation pragmas
+    local_rules = extendRuleBaseList emptyRuleBase rules_for_locals
+
+    update_bind (NonRec b r) = NonRec (add_rules b) r
+    update_bind (Rec prs)    = Rec (mapFst add_rules prs)
+
+       -- See Note [Attach rules to local ids]
+       -- NB: the binder might have some existing rules,
+       -- arising from specialisation pragmas
+    add_rules bndr
+       | Just rules <- lookupNameEnv local_rules (idName bndr)
+       = bndr `addIdSpecialisations` rules
+       | otherwise
+       = bndr
  \end{code}
  
  Note [Simplifying the left-hand side of a RULE]
  \end{code}
  
  Note [Simplifying the left-hand side of a RULE]
@@ -393,6 +405,9 @@ we do not want to get
  otherwise we don't match when given an argument like
         augment (\a. h a a) (build h)
  
  otherwise we don't match when given an argument like
         augment (\a. h a a) (build h)
  
+The simplifier does indeed do eta reduction (it's in
+Simplify.completeLam) but only if -O is on.
+
  \begin{code}
  simplRule env rule@(BuiltinRule {})
    = return rule
  \begin{code}
  simplRule env rule@(BuiltinRule {})
    = return rule
@@ -400,18 +415,8 @@ simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
    = do (env, bndrs') <- simplBinders env bndrs
         args' <- mapM (simplExprGently env) args
         rhs' <- simplExprGently env rhs
    = do (env, bndrs') <- simplBinders env bndrs
         args' <- mapM (simplExprGently env) args
         rhs' <- simplExprGently env rhs
-       return (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' })
-
--- It's important that simplExprGently does eta reduction.
--- For example, in a rule like:
---     augment g (build h) 
--- we do not want to get
---     augment (\a. g a) (build h)
--- otherwise we don't match when given an argument like
---     (\a. h a a)
---
--- The simplifier does indeed do eta reduction (it's in
--- Simplify.completeLam) but only if -O is on.
+       return (rule { ru_bndrs = bndrs', ru_args = args'
+                    , ru_rhs = occurAnalyseExpr rhs' })
  \end{code}
  
  \begin{code}
  \end{code}
  
  \begin{code}
@@ -494,45 +499,49 @@ simplifyPgm mode switches
      do { hsc_env <- getHscEnv
         ; us <- getUniqueSupplyM
         ; rb <- getRuleBase
      do { hsc_env <- getHscEnv
         ; us <- getUniqueSupplyM
         ; rb <- getRuleBase
-       ; let fam_inst_env = mg_fam_inst_env guts
-             dump_phase = shouldDumpSimplPhase (hsc_dflags hsc_env) mode
-            simplify_pgm = simplifyPgmIO dump_phase mode switches 
-                                          hsc_env us rb fam_inst_env
-
-       ; doPassM (liftIOWithCount . simplify_pgm) guts }
+       ; liftIOWithCount $  
+                simplifyPgmIO mode switches hsc_env us rb guts }
    where
      doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode) 
  
    where
      doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode) 
  
-simplifyPgmIO :: Bool
-            -> SimplifierMode
-           -> [SimplifierSwitch]
-           -> HscEnv
-           -> UniqSupply
-           -> RuleBase
-           -> FamInstEnv
-           -> [CoreBind]
-           -> IO (SimplCount, [CoreBind])  -- New bindings
-
-simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env binds
+simplifyPgmIO :: SimplifierMode
+             -> [SimplifierSwitch]
+             -> HscEnv
+             -> UniqSupply
+             -> RuleBase
+             -> ModGuts
+             -> IO (SimplCount, ModGuts)  -- New bindings
+
+simplifyPgmIO mode switches hsc_env us hpt_rule_base 
+              guts@(ModGuts { mg_binds = binds, mg_rules = rules
+                            , mg_fam_inst_env = fam_inst_env })
    = do {
    = do {
-       (termination_msg, it_count, counts_out, binds') 
-          <- do_iteration us 1 (zeroSimplCount dflags) binds ;
+       (termination_msg, it_count, counts_out, guts') 
+          <- do_iteration us 1 (zeroSimplCount dflags) binds rules ;
  
         Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
                   "Simplifier statistics for following pass"
                   (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
  
         Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
                   "Simplifier statistics for following pass"
                   (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
-                        text "",
+                        blankLine,
                          pprSimplCount counts_out]);
  
                          pprSimplCount counts_out]);
  
-       return (counts_out, binds')
+       return (counts_out, guts')
      }
    where
      }
    where
-    dflags        = hsc_dflags hsc_env
+    dflags              = hsc_dflags hsc_env
+    dump_phase          = shouldDumpSimplPhase dflags mode
                    
      sw_chkr       = isAmongSimpl switches
      max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
   
                    
      sw_chkr       = isAmongSimpl switches
      max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
   
-    do_iteration us iteration_no counts binds
+    do_iteration :: UniqSupply
+                 -> Int                -- Counts iterations
+                -> SimplCount  -- Logs optimisations performed
+                -> [CoreBind]  -- Bindings in
+                -> [CoreRule]  -- and orphan rules
+                -> IO (String, Int, SimplCount, ModGuts)
+
+    do_iteration us iteration_no counts binds rules
         -- iteration_no is the number of the iteration we are
         -- about to begin, with '1' for the first
        | iteration_no > max_iterations  -- Stop if we've run out of iterations
         -- iteration_no is the number of the iteration we are
         -- about to begin, with '1' for the first
        | iteration_no > max_iterations  -- Stop if we've run out of iterations
@@ -542,14 +551,15 @@ simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env bin
                                 " iterations; bailing out.  Size = " ++ show (coreBindsSize binds) ++ "\n" ))
                 -- Subtract 1 from iteration_no to get the
                 -- number of iterations we actually completed
                                 " iterations; bailing out.  Size = " ++ show (coreBindsSize binds) ++ "\n" ))
                 -- Subtract 1 from iteration_no to get the
                 -- number of iterations we actually completed
-           return ("Simplifier bailed out", iteration_no - 1, counts, binds)
+           return ("Simplifier bailed out", iteration_no - 1, counts, 
+                    guts { mg_binds = binds, mg_rules = rules })
  
        -- Try and force thunks off the binds; significantly reduces
        -- space usage, especially with -O.  JRS, 000620.
        | let sz = coreBindsSize binds in sz == sz
        = do {
                 -- Occurrence analysis
  
        -- Try and force thunks off the binds; significantly reduces
        -- space usage, especially with -O.  JRS, 000620.
        | let sz = coreBindsSize binds in sz == sz
        = do {
                 -- Occurrence analysis
-          let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds } ;
+          let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ;
            Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
                      (pprCoreBindings tagged_binds);
  
            Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
                      (pprCoreBindings tagged_binds);
  
@@ -559,7 +569,8 @@ simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env bin
                 -- behind the scenes.  Otherwise there's a danger we'll simply
                 -- miss the rules for Ids hidden inside imported inlinings
            eps <- hscEPS hsc_env ;
                 -- behind the scenes.  Otherwise there's a danger we'll simply
                 -- miss the rules for Ids hidden inside imported inlinings
            eps <- hscEPS hsc_env ;
-          let  { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps)
+          let  { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
+               ; rule_base2 = extendRuleBaseList rule_base1 rules
                 ; simpl_env  = mkSimplEnv mode sw_chkr 
                 ; simpl_binds = {-# SCC "SimplTopBinds" #-} 
                                 simplTopBinds simpl_env tagged_binds
                 ; simpl_env  = mkSimplEnv mode sw_chkr 
                 ; simpl_binds = {-# SCC "SimplTopBinds" #-} 
                                 simplTopBinds simpl_env tagged_binds
@@ -576,19 +587,18 @@ simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env bin
                 --      case t of {(_,counts') -> if counts'=0 then ... }
                 -- So the conditional didn't force counts', because the
                 -- selection got duplicated.  Sigh!
                 --      case t of {(_,counts') -> if counts'=0 then ... }
                 -- So the conditional didn't force counts', because the
                 -- selection got duplicated.  Sigh!
-          case initSmpl dflags rule_base' fam_envs us1 simpl_binds of {
-               (binds', counts') -> do {
+          case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of {
+               (env1, counts1) -> do {
  
  
-          let  { all_counts = counts `plusSimplCount` counts'
-               ; herald     = "Simplifier mode " ++ showPpr mode ++ 
-                             ", iteration " ++ show iteration_no ++
-                             " out of " ++ show max_iterations
+          let  { all_counts = counts `plusSimplCount` counts1
+               ; binds1 = getFloats env1
+                ; rules1 = substRulesForImportedIds (mkCoreSubst env1) rules
                 } ;
  
                 -- Stop if nothing happened; don't dump output
                 } ;
  
                 -- Stop if nothing happened; don't dump output
-          if isZeroSimplCount counts' then
-               return ("Simplifier reached fixed point", iteration_no, 
-                       all_counts, binds')
+          if isZeroSimplCount counts1 then
+               return ("Simplifier reached fixed point", iteration_no, all_counts,
+                       guts { mg_binds = binds1, mg_rules = rules1 })
            else do {
                 -- Short out indirections
                 -- We do this *after* at least one run of the simplifier 
            else do {
                 -- Short out indirections
                 -- We do this *after* at least one run of the simplifier 
@@ -598,18 +608,30 @@ simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env bin
                 --
                 -- ToDo: alas, this means that indirection-shorting does not happen at all
                 --       if the simplifier does nothing (not common, I know, but unsavoury)
                 --
                 -- ToDo: alas, this means that indirection-shorting does not happen at all
                 --       if the simplifier does nothing (not common, I know, but unsavoury)
-          let { binds'' = {-# SCC "ZapInd" #-} shortOutIndirections binds' } ;
+          let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
  
                 -- Dump the result of this iteration
  
                 -- Dump the result of this iteration
-          Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
-                        (pprSimplCount counts') ;
-          endIteration dflags herald Opt_D_dump_simpl_iterations binds'' ;
+          endIteration dflags mode iteration_no max_iterations counts1 binds2 rules1 ;
  
                 -- Loop
  
                 -- Loop
-          do_iteration us2 (iteration_no + 1) all_counts binds''
+          do_iteration us2 (iteration_no + 1) all_counts binds2 rules1
         }  } } }
        where
           (us1, us2) = splitUniqSupply us
         }  } } }
        where
           (us1, us2) = splitUniqSupply us
+
+-------------------
+endIteration :: DynFlags -> SimplifierMode -> Int -> Int 
+             -> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
+-- Same as endPass but with simplifier counts
+endIteration dflags mode iteration_no max_iterations counts binds rules
+  = do { Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations pass_name
+                            (pprSimplCount counts) ;
+
+       ; endPass dflags pass_name Opt_D_dump_simpl_iterations binds rules }
+  where
+    pass_name = "Simplifier mode " ++ showPpr mode ++ 
+               ", iteration " ++ show iteration_no ++
+               " out of " ++ show max_iterations
  \end{code}
  
  
  \end{code}
  
  
@@ -822,7 +844,7 @@ transferIdInfo exported_id local_id
    where
      local_info = idInfo local_id
      transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
    where
      local_info = idInfo local_id
      transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
-                                `setWorkerInfo`        workerInfo local_info
+                                `setUnfoldingInfo`     unfoldingInfo local_info
                                  `setInlinePragInfo`    inlinePragInfo local_info
                                  `setSpecInfo`          addSpecInfo (specInfo exp_info) new_info
      new_info = setSpecInfoHead (idName exported_id) 
                                  `setInlinePragInfo`    inlinePragInfo local_info
                                  `setSpecInfo`          addSpecInfo (specInfo exp_info) new_info
      new_info = setSpecInfoHead (idName exported_id) 
diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs

index 0a7575a..c10ad90 100644 (file)
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -23,13 +23,13 @@ module SimplEnv (
         mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, 
         zapSubstEnv, setSubstEnv, 
         getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
         mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, 
         zapSubstEnv, setSubstEnv, 
         getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
-       getSimplRules, 
+       getSimplRules, inGentleMode,
  
         SimplSR(..), mkContEx, substId, lookupRecBndr,
  
         simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, 
         simplBinder, simplBinders, addBndrRules,
  
         SimplSR(..), mkContEx, substId, lookupRecBndr,
  
         simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, 
         simplBinder, simplBinders, addBndrRules,
-       substExpr, substWorker, substTy, 
+       substExpr, substTy, mkCoreSubst,
  
         -- Floats
         Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
  
         -- Floats
         Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
@@ -49,7 +49,7 @@ import VarEnv
  import VarSet
  import OrdList
  import Id
  import VarSet
  import OrdList
  import Id
-import qualified CoreSubst     ( Subst, mkSubst, substExpr, substSpec, substWorker )
+import qualified CoreSubst     ( Subst, mkSubst, substExpr, substSpec, substUnfolding )
  import qualified Type          ( substTy, substTyVarBndr )
  import Type hiding             ( substTy, substTyVarBndr )
  import Coercion
  import qualified Type          ( substTy, substTyVarBndr )
  import Type hiding             ( substTy, substTyVarBndr )
  import Coercion
@@ -225,6 +225,11 @@ getMode env = seMode env
  setMode :: SimplifierMode -> SimplEnv -> SimplEnv
  setMode mode env = env { seMode = mode }
  
  setMode :: SimplifierMode -> SimplEnv -> SimplEnv
  setMode mode env = env { seMode = mode }
  
+inGentleMode :: SimplEnv -> Bool
+inGentleMode env = case seMode env of
+                       SimplGently -> True
+                       _other      -> False
+
  ---------------------
  getEnclosingCC :: SimplEnv -> CostCentreStack
  getEnclosingCC env = seCC env
  ---------------------
  getEnclosingCC :: SimplEnv -> CostCentreStack
  getEnclosingCC env = seCC env
@@ -660,29 +665,6 @@ addBndrRules env in_id out_id
      old_rules = idSpecialisation in_id
      new_rules = CoreSubst.substSpec subst out_id old_rules
      final_id  = out_id `setIdSpecialisation` new_rules
      old_rules = idSpecialisation in_id
      new_rules = CoreSubst.substSpec subst out_id old_rules
      final_id  = out_id `setIdSpecialisation` new_rules
-
-------------------
-substIdType :: SimplEnv -> Id -> Id
-substIdType (SimplEnv { seInScope = in_scope,  seTvSubst = tv_env}) id
-  | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
-  | otherwise  = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
-               -- The tyVarsOfType is cheaper than it looks
-               -- because we cache the free tyvars of the type
-               -- in a Note in the id's type itself
-  where
-    old_ty = idType id
-
-------------------
-substUnfolding :: SimplEnv -> Unfolding -> Unfolding
-substUnfolding _   NoUnfolding                = NoUnfolding
-substUnfolding _   (OtherCon cons)            = OtherCon cons
-substUnfolding env (CompulsoryUnfolding rhs)   = CompulsoryUnfolding (substExpr env rhs)
-substUnfolding env (CoreUnfolding rhs t u v w g) = CoreUnfolding (substExpr env rhs) t u v w g
-
-------------------
-substWorker :: SimplEnv -> WorkerInfo -> WorkerInfo
-substWorker _   NoWorker = NoWorker
-substWorker env wkr_info = CoreSubst.substWorker (mkCoreSubst env) wkr_info
  \end{code}
  
  
  \end{code}
  
  
@@ -718,9 +700,24 @@ mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id
      fiddle (DoneId v)       = Var v
      fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
  
      fiddle (DoneId v)       = Var v
      fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
  
+------------------
+substIdType :: SimplEnv -> Id -> Id
+substIdType (SimplEnv { seInScope = in_scope,  seTvSubst = tv_env}) id
+  | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
+  | otherwise  = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
+               -- The tyVarsOfType is cheaper than it looks
+               -- because we cache the free tyvars of the type
+               -- in a Note in the id's type itself
+  where
+    old_ty = idType id
+
+------------------
  substExpr :: SimplEnv -> CoreExpr -> CoreExpr
  substExpr env expr = CoreSubst.substExpr (mkCoreSubst env) expr
    -- Do *not* short-cut in the case of an empty substitution
    -- See CoreSubst: Note [Extending the Subst]
  substExpr :: SimplEnv -> CoreExpr -> CoreExpr
  substExpr env expr = CoreSubst.substExpr (mkCoreSubst env) expr
    -- Do *not* short-cut in the case of an empty substitution
    -- See CoreSubst: Note [Extending the Subst]
+
+substUnfolding :: SimplEnv -> Unfolding -> Unfolding
+substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst env) unf
  \end{code}
  
  \end{code}
  
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs

index 663f543..c541096 100644 (file)
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -10,14 +10,14 @@ module SimplUtils (
  
         -- Inlining,
         preInlineUnconditionally, postInlineUnconditionally, 
  
         -- Inlining,
         preInlineUnconditionally, postInlineUnconditionally, 
-       activeInline, activeRule, inlineMode,
+       activeInline, activeRule, 
  
         -- The continuation type
         SimplCont(..), DupFlag(..), ArgInfo(..),
         contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, 
  
         -- The continuation type
         SimplCont(..), DupFlag(..), ArgInfo(..),
         contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, 
-       countValArgs, countArgs, splitInlineCont,
+       countValArgs, countArgs, 
         mkBoringStop, mkLazyArgStop, contIsRhsOrArg,
         mkBoringStop, mkLazyArgStop, contIsRhsOrArg,
-       interestingCallContext, interestingArgContext,
+       interestingCallContext, 
  
         interestingArg, mkArgInfo,
         
  
         interestingArg, mkArgInfo,
         
@@ -215,34 +215,6 @@ dropArgs :: Int -> SimplCont -> SimplCont
  dropArgs 0 cont = cont
  dropArgs n (ApplyTo _ _ _ cont) = dropArgs (n-1) cont
  dropArgs n other               = pprPanic "dropArgs" (ppr n <+> ppr other)
  dropArgs 0 cont = cont
  dropArgs n (ApplyTo _ _ _ cont) = dropArgs (n-1) cont
  dropArgs n other               = pprPanic "dropArgs" (ppr n <+> ppr other)
-
---------------------
-splitInlineCont :: SimplCont -> Maybe (SimplCont, SimplCont)
--- Returns Nothing if the continuation should dissolve an InlineMe Note
--- Return Just (c1,c2) otherwise, 
---     where c1 is the continuation to put inside the InlineMe 
---     and   c2 outside
-
--- Example: (__inline_me__ (/\a. e)) ty
---     Here we want to do the beta-redex without dissolving the InlineMe
--- See test simpl017 (and Trac #1627) for a good example of why this is important
-
-splitInlineCont (ApplyTo dup (Type ty) se c)
-  | Just (c1, c2) <- splitInlineCont c = Just (ApplyTo dup (Type ty) se c1, c2)
-splitInlineCont cont@(Stop {})         = Just (mkBoringStop, cont)
-splitInlineCont cont@(StrictBind {})   = Just (mkBoringStop, cont)
-splitInlineCont _                      = Nothing
-       -- NB: we dissolve an InlineMe in any strict context, 
-       --     not just function aplication.  
-       -- E.g.  foldr k z (__inline_me (case x of p -> build ...))
-       --     Here we want to get rid of the __inline_me__ so we
-       --     can float the case, and see foldr/build
-       --
-       -- However *not* in a strict RHS, else we get
-       --         let f = __inline_me__ (\x. e) in ...f...
-       -- Now if f is guaranteed to be called, hence a strict binding
-       -- we don't thereby want to dissolve the __inline_me__; for
-       -- example, 'f' might be a  wrapper, so we'd inline the worker
  \end{code}
  
  
  \end{code}
  
  
@@ -320,24 +292,25 @@ interestingCallContext cont
  
  -------------------
  mkArgInfo :: Id
  
  -------------------
  mkArgInfo :: Id
+         -> [CoreRule] -- Rules for function
           -> Int        -- Number of value args
           -> SimplCont  -- Context of the call
           -> ArgInfo
  
           -> Int        -- Number of value args
           -> SimplCont  -- Context of the call
           -> ArgInfo
  
-mkArgInfo fun n_val_args call_cont
+mkArgInfo fun rules n_val_args call_cont
    | n_val_args < idArity fun           -- Note [Unsaturated functions]
    = ArgInfo { ai_rules = False
             , ai_strs = vanilla_stricts 
             , ai_discs = vanilla_discounts }
    | otherwise
    | n_val_args < idArity fun           -- Note [Unsaturated functions]
    = ArgInfo { ai_rules = False
             , ai_strs = vanilla_stricts 
             , ai_discs = vanilla_discounts }
    | otherwise
-  = ArgInfo { ai_rules = interestingArgContext fun call_cont
+  = ArgInfo { ai_rules = interestingArgContext rules call_cont
             , ai_strs  = add_type_str (idType fun) arg_stricts
             , ai_discs = arg_discounts }
    where
      vanilla_discounts, arg_discounts :: [Int]
      vanilla_discounts = repeat 0
      arg_discounts = case idUnfolding fun of
             , ai_strs  = add_type_str (idType fun) arg_stricts
             , ai_discs = arg_discounts }
    where
      vanilla_discounts, arg_discounts :: [Int]
      vanilla_discounts = repeat 0
      arg_discounts = case idUnfolding fun of
-                       CoreUnfolding _ _ _ _ _ (UnfoldIfGoodArgs _ discounts _ _)
+                       CoreUnfolding {uf_guidance = UnfoldIfGoodArgs {ug_args = discounts}}
                               -> discounts ++ vanilla_discounts
                         _     -> vanilla_discounts
  
                               -> discounts ++ vanilla_discounts
                         _     -> vanilla_discounts
  
@@ -391,7 +364,7 @@ it'll just be floated out again.  Even if f has lots of discounts
  on its first argument -- it must be saturated for these to kick in
  -}
  
  on its first argument -- it must be saturated for these to kick in
  -}
  
-interestingArgContext :: Id -> SimplCont -> Bool
+interestingArgContext :: [CoreRule] -> SimplCont -> Bool
  -- If the argument has form (f x y), where x,y are boring,
  -- and f is marked INLINE, then we don't want to inline f.
  -- But if the context of the argument is
  -- If the argument has form (f x y), where x,y are boring,
  -- and f is marked INLINE, then we don't want to inline f.
  -- But if the context of the argument is
@@ -402,16 +375,18 @@ interestingArgContext :: Id -> SimplCont -> Bool
  -- where h has rules, then we do want to inline f; hence the
  -- call_cont argument to interestingArgContext
  --
  -- where h has rules, then we do want to inline f; hence the
  -- call_cont argument to interestingArgContext
  --
--- The interesting_arg_ctxt flag makes this happen; if it's
+-- The ai-rules flag makes this happen; if it's
  -- set, the inliner gets just enough keener to inline f 
  -- regardless of how boring f's arguments are, if it's marked INLINE
  --
  -- The alternative would be to *always* inline an INLINE function,
  -- regardless of how boring its context is; but that seems overkill
  -- For example, it'd mean that wrapper functions were always inlined
  -- set, the inliner gets just enough keener to inline f 
  -- regardless of how boring f's arguments are, if it's marked INLINE
  --
  -- The alternative would be to *always* inline an INLINE function,
  -- regardless of how boring its context is; but that seems overkill
  -- For example, it'd mean that wrapper functions were always inlined
-interestingArgContext fn call_cont
-  = idHasRules fn || go call_cont
+interestingArgContext rules call_cont
+  = notNull rules || enclosing_fn_has_rules
    where
    where
+    enclosing_fn_has_rules = go call_cont
+
      go (Select {})          = False
      go (ApplyTo {})         = False
      go (StrictArg _ cci _ _) = interesting cci
      go (Select {})          = False
      go (ApplyTo {})         = False
      go (StrictArg _ cci _ _) = interesting cci
@@ -458,13 +433,7 @@ unboxed tuples and suchlike.
  
  INLINE pragmas
  ~~~~~~~~~~~~~~
  
  INLINE pragmas
  ~~~~~~~~~~~~~~
-SimplGently is also used as the mode to simplify inside an InlineMe note.
-
-\begin{code}
-inlineMode :: SimplifierMode
-inlineMode = SimplGently
-\end{code}
-
+We don't simplify inside InlineRules (which come from INLINE pragmas).
  It really is important to switch off inlinings inside such
  expressions.  Consider the following example 
  
  It really is important to switch off inlinings inside such
  expressions.  Consider the following example 
  
@@ -589,7 +558,7 @@ preInlineUnconditionally env top_lvl bndr rhs
    where
      phase = getMode env
      active = case phase of
    where
      phase = getMode env
      active = case phase of
-                  SimplGently    -> isAlwaysActive act
+                  SimplGently    -> isEarlyActive act
                    SimplPhase n _ -> isActive n act
      act = idInlineActivation bndr
  
                    SimplPhase n _ -> isActive n act
      act = idInlineActivation bndr
  
@@ -674,7 +643,7 @@ story for now.
  \begin{code}
  postInlineUnconditionally 
      :: SimplEnv -> TopLevelFlag
  \begin{code}
  postInlineUnconditionally 
      :: SimplEnv -> TopLevelFlag
-    -> InId            -- The binder (an OutId would be fine too)
+    -> OutId           -- The binder (an InId would be fine too)
      -> OccInfo                 -- From the InId
      -> OutExpr
      -> Unfolding
      -> OccInfo                 -- From the InId
      -> OutExpr
      -> Unfolding
@@ -684,6 +653,7 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
    | isLoopBreaker occ_info = False     -- If it's a loop-breaker of any kind, don't inline
                                         -- because it might be referred to "earlier"
    | isExportedId bndr      = False
    | isLoopBreaker occ_info = False     -- If it's a loop-breaker of any kind, don't inline
                                         -- because it might be referred to "earlier"
    | isExportedId bndr      = False
+  | isInlineRule unfolding = False     -- Note [InlineRule and postInlineUnconditionally]
    | exprIsTrivial rhs     = True
    | otherwise
    = case occ_info of
    | exprIsTrivial rhs     = True
    | otherwise
    = case occ_info of
@@ -788,6 +758,23 @@ activeRule dflags env
         SimplPhase n _ -> Just (isActive n)
  \end{code}
  
         SimplPhase n _ -> Just (isActive n)
  \end{code}
  
+Note [InlineRule and postInlineUnconditionally]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Do not do postInlineUnconditionally if the Id has an InlineRule, otherwise
+we lose the unfolding.  Example
+
+     -- f has InlineRule with rhs (e |> co)
+     --   where 'e' is big
+     f = e |> co
+
+Then there's a danger we'll optimise to
+
+     f' = e
+     f = f' |> co
+
+and now postInlineUnconditionally, losing the InlineRule on f.  Now f'
+won't inline because 'e' is too big.
+
  
  %************************************************************************
  %*                                                                     *
  
  %************************************************************************
  %*                                                                     *
@@ -803,7 +790,7 @@ mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplM OutExpr
  
  mkLam _b [] body 
    = return body
  
  mkLam _b [] body 
    = return body
-mkLam _env bndrs body
+mkLam env bndrs body
    = do { dflags <- getDOptsSmpl
         ; mkLam' dflags bndrs body }
    where
    = do { dflags <- getDOptsSmpl
         ; mkLam' dflags bndrs body }
    where
@@ -824,7 +811,9 @@ mkLam _env bndrs body
            ; return etad_lam }
  
        | dopt Opt_DoLambdaEtaExpansion dflags,
            ; return etad_lam }
  
        | dopt Opt_DoLambdaEtaExpansion dflags,
-       any isRuntimeVar bndrs
+        not (inGentleMode env),              -- In gentle mode don't eta-expansion
+       any isRuntimeVar bndrs        -- because it can clutter up the code
+                                     -- with casts etc that may not be removed
        = do { let body' = tryEtaExpansion dflags body
            ; return (mkLams bndrs body') }
     
        = do { let body' = tryEtaExpansion dflags body
            ; return (mkLams bndrs body') }
     
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs

index 18b3fc6..1b46aa9 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -20,12 +20,14 @@ import Var
  import IdInfo
  import Coercion
  import FamInstEnv       ( topNormaliseType )
  import IdInfo
  import Coercion
  import FamInstEnv       ( topNormaliseType )
-import DataCon          ( dataConRepStrictness, dataConUnivTyVars )
+import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness )
  import CoreSyn
  import NewDemand        ( isStrictDmd, splitStrictSig )
  import PprCore          ( pprParendExpr, pprCoreExpr )
  import CoreSyn
  import NewDemand        ( isStrictDmd, splitStrictSig )
  import PprCore          ( pprParendExpr, pprCoreExpr )
-import CoreUnfold       ( mkUnfolding, callSiteInline, CallCtxt(..) )
+import CoreUnfold       ( mkUnfolding, mkCoreUnfolding, mkInlineRule, 
+                          exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
  import CoreUtils
  import CoreUtils
+import qualified CoreSubst
  import CoreArity       ( exprArity )
  import Rules            ( lookupRule, getRules )
  import BasicTypes       ( isMarkedStrict, Arity )
  import CoreArity       ( exprArity )
  import Rules            ( lookupRule, getRules )
  import BasicTypes       ( isMarkedStrict, Arity )
@@ -34,6 +36,7 @@ import TysPrim          ( realWorldStatePrimTy )
  import PrelInfo         ( realWorldPrimId )
  import BasicTypes       ( TopLevelFlag(..), isTopLevel,
                            RecFlag(..), isNonRuleLoopBreaker )
  import PrelInfo         ( realWorldPrimId )
  import BasicTypes       ( TopLevelFlag(..), isTopLevel,
                            RecFlag(..), isNonRuleLoopBreaker )
+import MonadUtils      ( foldlM )
  import Maybes           ( orElse )
  import Data.List        ( mapAccumL )
  import Outputable
  import Maybes           ( orElse )
  import Data.List        ( mapAccumL )
  import Outputable
@@ -201,7 +204,7 @@ expansion at a let RHS can concentrate solely on the PAP case.
  %************************************************************************
  
  \begin{code}
  %************************************************************************
  
  \begin{code}
-simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind]
+simplTopBinds :: SimplEnv -> [InBind] -> SimplM SimplEnv
  
  simplTopBinds env0 binds0
    = do  {       -- Put all the top-level binders into scope at the start
  
  simplTopBinds env0 binds0
    = do  {       -- Put all the top-level binders into scope at the start
@@ -214,7 +217,7 @@ simplTopBinds env0 binds0
                            dopt Opt_D_dump_rule_firings dflags
          ; env2 <- simpl_binds dump_flag env1 binds0
          ; freeTick SimplifierDone
                            dopt Opt_D_dump_rule_firings dflags
          ; env2 <- simpl_binds dump_flag env1 binds0
          ; freeTick SimplifierDone
-        ; return (getFloats env2) }
+        ; return env2 }
    where
          -- We need to track the zapped top-level binders, because
          -- they should have their fragile IdInfo zapped (notably occurrence info)
    where
          -- We need to track the zapped top-level binders, because
          -- they should have their fragile IdInfo zapped (notably occurrence info)
@@ -351,7 +354,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
                       do { tick LetFloatFromLet
                          ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
                          ; rhs' <- mkLam env tvs' body3
                       do { tick LetFloatFromLet
                          ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
                          ; rhs' <- mkLam env tvs' body3
-                        ; let env' = foldl (addPolyBind top_lvl) env poly_binds
+                        ; env' <- foldlM (addPolyBind top_lvl) env poly_binds
                          ; return (env', rhs') }
  
          ; completeBind env' top_lvl bndr bndr1 rhs' }
                          ; return (env', rhs') }
  
          ; completeBind env' top_lvl bndr bndr1 rhs' }
@@ -462,6 +465,7 @@ prepareRhs env0 rhs0
            is_val = n_val_args > 0       -- There is at least one arg
                                          -- ...and the fun a constructor or PAP
                   && (isConLikeId fun || n_val_args < idArity fun)
            is_val = n_val_args > 0       -- There is at least one arg
                                          -- ...and the fun a constructor or PAP
                   && (isConLikeId fun || n_val_args < idArity fun)
+                                  -- See Note [CONLIKE pragma] in BasicTypes
      go _ env other
          = return (False, env, other)
  \end{code}
      go _ env other
          = return (False, env, other)
  \end{code}
@@ -566,29 +570,23 @@ completeBind :: SimplEnv
  --      * or by adding to the floats in the envt
  
  completeBind env top_lvl old_bndr new_bndr new_rhs
  --      * or by adding to the floats in the envt
  
  completeBind env top_lvl old_bndr new_bndr new_rhs
-  | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding
-                -- Inline and discard the binding
-  = do  { tick (PostInlineUnconditionally old_bndr)
-        ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> ppr new_bndr <+> ppr new_rhs) $
-          return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
-        -- Use the substitution to make quite, quite sure that the
-        -- substitution will happen, since we are going to discard the binding
+  = do { let old_info = idInfo old_bndr
+             old_unf  = unfoldingInfo old_info
+             occ_info = occInfo old_info
  
  
-  | otherwise
-  = return (addNonRecWithUnf env new_bndr new_rhs unfolding wkr)
-  where
-    unfolding | omit_unfolding = NoUnfolding
-             | otherwise      = mkUnfolding (isTopLevel top_lvl) new_rhs
-    old_info    = idInfo old_bndr
-    occ_info    = occInfo old_info
-    wkr                = substWorker env (workerInfo old_info)
-    omit_unfolding = isNonRuleLoopBreaker occ_info 
-                  --       or not (activeInline env old_bndr)
-                  -- Do *not* trim the unfolding in SimplGently, else
-                  -- the specialiser can't see it!
-
------------------
-addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplEnv
+       ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info new_rhs old_unf
+
+       ; if postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs new_unfolding
+                       -- Inline and discard the binding
+         then do  { tick (PostInlineUnconditionally old_bndr)
+                   ; return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
+               -- Use the substitution to make quite, quite sure that the
+               -- substitution will happen, since we are going to discard the binding
+
+         else return (addNonRecWithUnf env new_bndr new_rhs new_unfolding) }
+
+------------------------------
+addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv
  -- Add a new binding to the environment, complete with its unfolding
  -- but *do not* do postInlineUnconditionally, because we have already
  -- processed some of the scope of the binding
  -- Add a new binding to the environment, complete with its unfolding
  -- but *do not* do postInlineUnconditionally, because we have already
  -- processed some of the scope of the binding
@@ -601,71 +599,73 @@ addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplEnv
  -- opportunity to inline 'y' too.
  
  addPolyBind top_lvl env (NonRec poly_id rhs)
  -- opportunity to inline 'y' too.
  
  addPolyBind top_lvl env (NonRec poly_id rhs)
-  = addNonRecWithUnf env poly_id rhs unfolding NoWorker
-  where
-    unfolding | not (activeInline env poly_id) = NoUnfolding
-             | otherwise                      = mkUnfolding (isTopLevel top_lvl) rhs
-               -- addNonRecWithInfo adds the new binding in the
-               -- proper way (ie complete with unfolding etc),
-               -- and extends the in-scope set
+  = do { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo rhs noUnfolding
+                       -- Assumes that poly_id did not have an INLINE prag
+                       -- which is perhaps wrong.  ToDo: think about this
+        ; return (addNonRecWithUnf env poly_id rhs unfolding) }
  
  
-addPolyBind _ env bind@(Rec _) = extendFloats env bind
+addPolyBind _ env bind@(Rec _) = return (extendFloats env bind)
                 -- Hack: letrecs are more awkward, so we extend "by steam"
                 -- without adding unfoldings etc.  At worst this leads to
                 -- more simplifier iterations
  
                 -- Hack: letrecs are more awkward, so we extend "by steam"
                 -- without adding unfoldings etc.  At worst this leads to
                 -- more simplifier iterations
  
------------------
+------------------------------
  addNonRecWithUnf :: SimplEnv
  addNonRecWithUnf :: SimplEnv
-                 -> OutId -> OutExpr        -- New binder and RHS
-                 -> Unfolding -> WorkerInfo -- and unfolding
-                 -> SimplEnv
--- Add suitable IdInfo to the Id, add the binding to the floats, and extend the in-scope set
-addNonRecWithUnf env new_bndr rhs unfolding wkr
-  = ASSERT( isId new_bndr )
+                -> OutId -> OutExpr    -- New binder and RHS
+                -> Unfolding           -- New unfolding
+                -> SimplEnv
+addNonRecWithUnf env new_bndr new_rhs new_unfolding
+  = let new_arity = exprArity new_rhs
+       old_arity = idArity new_bndr
+        info1 = idInfo new_bndr `setArityInfo` new_arity
+       
+              -- Unfolding info: Note [Setting the new unfolding]
+       info2 = info1 `setUnfoldingInfo` new_unfolding
+
+        -- Demand info: Note [Setting the demand info]
+        info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2
+              | otherwise                      = info2
+
+        final_id = new_bndr `setIdInfo` info3
+       dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr
+    in
+    ASSERT( isId new_bndr )
      WARN( new_arity < old_arity || new_arity < dmd_arity, 
            (ptext (sLit "Arity decrease:") <+> ppr final_id <+> ppr old_arity
      WARN( new_arity < old_arity || new_arity < dmd_arity, 
            (ptext (sLit "Arity decrease:") <+> ppr final_id <+> ppr old_arity
-               <+> ppr new_arity <+> ppr dmd_arity) $$ ppr rhs )
+               <+> ppr new_arity <+> ppr dmd_arity) $$ ppr new_rhs )
         -- Note [Arity decrease]
         -- Note [Arity decrease]
-    final_id `seq`      -- This seq forces the Id, and hence its IdInfo,
-                       -- and hence any inner substitutions
-    addNonRec env final_id rhs
-       -- The addNonRec adds it to the in-scope set too
-  where
-       dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr
-       old_arity = idArity new_bndr
  
  
-        --      Arity info
-       new_arity = exprArity rhs
-        new_bndr_info = idInfo new_bndr `setArityInfo` new_arity
-
-        --      Unfolding info
-        -- Add the unfolding *only* for non-loop-breakers
-        -- Making loop breakers not have an unfolding at all
-        -- means that we can avoid tests in exprIsConApp, for example.
-        -- This is important: if exprIsConApp says 'yes' for a recursive
-        -- thing, then we can get into an infinite loop
-
-        --      Demand info
-        -- If the unfolding is a value, the demand info may
-        -- go pear-shaped, so we nuke it.  Example:
-        --      let x = (a,b) in
-        --      case x of (p,q) -> h p q x
-        -- Here x is certainly demanded. But after we've nuked
-        -- the case, we'll get just
-        --      let x = (a,b) in h a b x
-        -- and now x is not demanded (I'm assuming h is lazy)
-        -- This really happens.  Similarly
-        --      let f = \x -> e in ...f..f...
-        -- After inlining f at some of its call sites the original binding may
-        -- (for example) be no longer strictly demanded.
-        -- The solution here is a bit ad hoc...
-        info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
-                                  `setWorkerInfo`    wkr
-
-        final_info | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
-                   | otherwise                  = info_w_unf
-       
-        final_id = new_bndr `setIdInfo` final_info
+    final_id `seq`   -- This seq forces the Id, and hence its IdInfo,
+                    -- and hence any inner substitutions
+           -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
+    addNonRec env final_id new_rhs
+               -- The addNonRec adds it to the in-scope set too
+
+------------------------------
+simplUnfolding :: SimplEnv-> TopLevelFlag
+              -> Id    -- Debug output only
+              -> OccInfo -> OutExpr
+              -> Unfolding -> SimplM Unfolding
+-- Note [Setting the new unfolding]
+simplUnfolding env _ _ _ _ (DFunUnfolding con ops)
+  = return (DFunUnfolding con ops')
+  where
+    ops' = map (CoreSubst.substExpr (mkCoreSubst env)) ops
+
+simplUnfolding env top_lvl _ _ _ 
+    (CoreUnfolding { uf_tmpl = expr, uf_arity = arity
+                   , uf_guidance = guide@(InlineRule {}) })
+  = do { expr' <- simplExpr (setMode SimplGently env) expr
+       ; let mb_wkr' = CoreSubst.substInlineRuleGuidance (mkCoreSubst env) (ug_ir_info guide)
+       ; return (mkCoreUnfolding (isTopLevel top_lvl) expr' arity 
+                                 (guide { ug_ir_info = mb_wkr' })) }
+               -- See Note [Top-level flag on inline rules] in CoreUnfold
+
+simplUnfolding _ top_lvl _ occ_info new_rhs _
+  | omit_unfolding = return NoUnfolding        
+  | otherwise     = return (mkUnfolding (isTopLevel top_lvl) new_rhs)
+  where
+    omit_unfolding = isNonRuleLoopBreaker occ_info
  \end{code}
  
  Note [Arity decrease]
  \end{code}
  
  Note [Arity decrease]
@@ -691,6 +691,38 @@ Here opInt has arity 1; but when we apply the rule its arity drops to 0.
  That's why Specialise goes to a little trouble to pin the right arity
  on specialised functions too.
  
  That's why Specialise goes to a little trouble to pin the right arity
  on specialised functions too.
  
+Note [Setting the new unfolding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* If there's an INLINE pragma, we simplify the RHS gently.  Maybe we
+  should do nothing at all, but simplifying gently might get rid of 
+  more crap.
+
+* If not, we make an unfolding from the new RHS.  But *only* for
+  non-loop-breakers. Making loop breakers not have an unfolding at all
+  means that we can avoid tests in exprIsConApp, for example.  This is
+  important: if exprIsConApp says 'yes' for a recursive thing, then we
+  can get into an infinite loop
+
+If there's an InlineRule on a loop breaker, we hang on to the inlining.
+It's pretty dodgy, but the user did say 'INLINE'.  May need to revisit
+this choice.
+
+Note [Setting the demand info]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the unfolding is a value, the demand info may
+go pear-shaped, so we nuke it.  Example:
+     let x = (a,b) in
+     case x of (p,q) -> h p q x
+Here x is certainly demanded. But after we've nuked
+the case, we'll get just
+     let x = (a,b) in h a b x
+and now x is not demanded (I'm assuming h is lazy)
+This really happens.  Similarly
+     let f = \x -> e in ...f..f...
+After inlining f at some of its call sites the original binding may
+(for example) be no longer strictly demanded.
+The solution here is a bit ad hoc...
+
  
  %************************************************************************
  %*                                                                      *
  
  %************************************************************************
  %*                                                                      *
@@ -954,7 +986,7 @@ simplLam env bndrs body cont
  
  ------------------
  simplNonRecE :: SimplEnv
  
  ------------------
  simplNonRecE :: SimplEnv
-             -> InId                    -- The binder
+             -> InBndr                  -- The binder
               -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)
               -> ([InBndr], InExpr)      -- Body of the let/lambda
                                          --      \xs.e
               -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)
               -> ([InBndr], InExpr)      -- Body of the let/lambda
                                          --      \xs.e
@@ -1016,21 +1048,9 @@ simplNote env (SCC cc) e cont
    = do  { e' <- simplExpr (setEnclosingCC env currentCCS) e
          ; rebuild env (mkSCC cc e') cont }
  
    = do  { e' <- simplExpr (setEnclosingCC env currentCCS) e
          ; rebuild env (mkSCC cc e') cont }
  
--- See notes with SimplMonad.inlineMode
-simplNote env InlineMe e cont
-  | Just (inside, outside) <- splitInlineCont cont  -- Boring boring continuation; see notes above
-  = do  {                       -- Don't inline inside an INLINE expression
-          e' <- simplExprC (setMode inlineMode env) e inside
-        ; rebuild env (mkInlineMe e') outside }
-
-  | otherwise   -- Dissolve the InlineMe note if there's
-                -- an interesting context of any kind to combine with
-                -- (even a type application -- anything except Stop)
-  = simplExprF env e cont
-
-simplNote env (CoreNote s) e cont = do
-    e' <- simplExpr env e
-    rebuild env (Note (CoreNote s) e') cont
+simplNote env (CoreNote s) e cont
+  = do { e' <- simplExpr env e
+       ; rebuild env (Note (CoreNote s) e') cont }
  \end{code}
  
  
  \end{code}
  
  
@@ -1080,7 +1100,9 @@ completeCall env var cont
          -- later phase, so but now we just try RULES first
         -- 
         -- See also Note [Rules for recursive functions]
          -- later phase, so but now we just try RULES first
         -- 
         -- See also Note [Rules for recursive functions]
-       ; mb_rule <- tryRules env var args call_cont
+        ; rule_base <- getSimplRules
+       ; let rules = getRules rule_base var
+       ; mb_rule <- tryRules env var rules args call_cont
         ; case mb_rule of {
              Just (n_args, rule_rhs) -> simplExprF env rule_rhs (dropArgs n_args cont) ;
                   -- The ruleArity says how many args the rule consumed
         ; case mb_rule of {
              Just (n_args, rule_rhs) -> simplExprF env rule_rhs (dropArgs n_args cont) ;
                   -- The ruleArity says how many args the rule consumed
@@ -1113,7 +1135,8 @@ completeCall env var cont
          -- Next, look for rules or specialisations that match
          --
          rebuildCall env (Var var)
          -- Next, look for rules or specialisations that match
          --
          rebuildCall env (Var var)
-                    (mkArgInfo var n_val_args call_cont) cont
+                    (mkArgInfo var rules n_val_args call_cont) 
+                    cont
      }}}}
  
  rebuildCall :: SimplEnv
      }}}}
  
  rebuildCall :: SimplEnv
@@ -1203,33 +1226,33 @@ all this at once is TOO HARD!
  %************************************************************************
  
  \begin{code}
  %************************************************************************
  
  \begin{code}
-tryRules :: SimplEnv -> Id -> [OutExpr] -> SimplCont 
+tryRules :: SimplEnv
+         -> Id -> [CoreRule] -> [OutExpr] -> SimplCont 
          -> SimplM (Maybe (Arity, CoreExpr))         -- The arity is the number of
                                                      -- args consumed by the rule
          -> SimplM (Maybe (Arity, CoreExpr))         -- The arity is the number of
                                                      -- args consumed by the rule
-tryRules env fn args call_cont
-  = do {  dflags <- getDOptsSmpl
-        ; rule_base <- getSimplRules
-        ; let   in_scope   = getInScope env
-               rules      = getRules rule_base fn
-                maybe_rule = case activeRule dflags env of
-                                Nothing     -> Nothing  -- No rules apply
-                                Just act_fn -> lookupRule act_fn in_scope
-                                                          fn args rules 
-        ; case (rules, maybe_rule) of {
-           ([], _)                     -> return Nothing ;
-           (_,  Nothing)               -> return Nothing ;
-            (_,  Just (rule, rule_rhs)) -> do
-
-        { tick (RuleFired (ru_name rule))
-        ; (if dopt Opt_D_dump_rule_firings dflags then
-                   pprTrace "Rule fired" (vcat [
+tryRules env fn rules args call_cont
+  | null rules
+  = return Nothing
+  | otherwise
+  = do { dflags <- getDOptsSmpl
+       ; case activeRule dflags env of {
+           Nothing     -> return Nothing  ; -- No rules apply
+           Just act_fn -> 
+
+         case lookupRule act_fn (getInScope env) fn args rules of {
+           Nothing               -> return Nothing ;   -- No rule matches
+           Just (rule, rule_rhs) ->
+
+             do { tick (RuleFired (ru_name rule))
+                ; (if dopt Opt_D_dump_rule_firings dflags then
+                     pprTrace "Rule fired" (vcat [
                          text "Rule:" <+> ftext (ru_name rule),
                          text "Before:" <+> ppr fn <+> sep (map pprParendExpr args),
                          text "After: " <+> pprCoreExpr rule_rhs,
                          text "Cont:  " <+> ppr call_cont])
                          text "Rule:" <+> ftext (ru_name rule),
                          text "Before:" <+> ppr fn <+> sep (map pprParendExpr args),
                          text "After: " <+> pprCoreExpr rule_rhs,
                          text "Cont:  " <+> ppr call_cont])
-                 else
+                   else
                          id)             $
                          id)             $
-           return (Just (ruleArity rule, rule_rhs)) }}}
+                   return (Just (ruleArity rule, rule_rhs)) }}}}
  \end{code}
  
  Note [Rules for recursive functions]
  \end{code}
  
  Note [Rules for recursive functions]
@@ -1356,14 +1379,27 @@ rebuildCase, reallyRebuildCase
  --------------------------------------------------
  
  rebuildCase env scrut case_bndr alts cont
  --------------------------------------------------
  
  rebuildCase env scrut case_bndr alts cont
-  | Just (con,args) <- exprIsConApp_maybe scrut
-        -- Works when the scrutinee is a variable with a known unfolding
-        -- as well as when it's an explicit constructor application
-  = knownCon env scrut (DataAlt con) args case_bndr alts cont
-
    | Lit lit <- scrut    -- No need for same treatment as constructors
                          -- because literals are inlined more vigorously
    | Lit lit <- scrut    -- No need for same treatment as constructors
                          -- because literals are inlined more vigorously
-  = knownCon env scrut (LitAlt lit) [] case_bndr alts cont
+  = do  { tick (KnownBranch case_bndr)
+        ; case findAlt (LitAlt lit) alts of
+           Nothing           -> missingAlt env case_bndr alts cont
+           Just (_, bs, rhs) -> simple_rhs bs rhs }
+
+  | Just (con, ty_args, other_args) <- exprIsConApp_maybe scrut
+        -- Works when the scrutinee is a variable with a known unfolding
+        -- as well as when it's an explicit constructor application
+  = do  { tick (KnownBranch case_bndr)
+        ; case findAlt (DataAlt con) alts of
+           Nothing  -> missingAlt env case_bndr alts cont
+            Just (DEFAULT, bs, rhs) -> simple_rhs bs rhs
+           Just (_, bs, rhs)       -> knownCon env scrut con ty_args other_args 
+                                                case_bndr bs rhs cont
+       }
+  where
+    simple_rhs bs rhs = ASSERT( null bs ) 
+                        do { env' <- simplNonRecX env case_bndr scrut
+                          ; simplExprF env' rhs cont }
  
  
  --------------------------------------------------
  
  
  --------------------------------------------------
@@ -1417,7 +1453,10 @@ rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
               out_args = [Type (substTy env (idType case_bndr)), 
                          Type (exprType rhs'), scrut, rhs']
                       -- Lazily evaluated, so we don't do most of this
               out_args = [Type (substTy env (idType case_bndr)), 
                          Type (exprType rhs'), scrut, rhs']
                       -- Lazily evaluated, so we don't do most of this
-       ; mb_rule <- tryRules env seqId out_args cont
+
+       ; rule_base <- getSimplRules
+       ; let rules = getRules rule_base seqId
+       ; mb_rule <- tryRules env seqId rules out_args cont
         ; case mb_rule of 
             Just (n_args, res) -> simplExprF (zapSubstEnv env) 
                                             (mkApps res (drop n_args out_args))
         ; case mb_rule of 
             Just (n_args, res) -> simplExprF (zapSubstEnv env) 
                                             (mkApps res (drop n_args out_args))
@@ -1471,6 +1510,19 @@ The point is that we bring into the envt a binding
  after the outer case, and that makes (a,b) alive.  At least we do unless
  the case binder is guaranteed dead.
  
  after the outer case, and that makes (a,b) alive.  At least we do unless
  the case binder is guaranteed dead.
  
+In practice, the scrutinee is almost always a variable, so we pretty
+much always zap the OccInfo of the binders.  It doesn't matter much though.
+
+
+Note [Case of cast]
+~~~~~~~~~~~~~~~~~~~
+Consider        case (v `cast` co) of x { I# ->
+                ... (case (v `cast` co) of {...}) ...
+We'd like to eliminate the inner case.  We can get this neatly by
+arranging that inside the outer case we add the unfolding
+        v |-> x `cast` (sym co)
+to v.  Then we should inline v at the inner case, cancel the casts, and away we go
+
  Note [Improving seq]
  ~~~~~~~~~~~~~~~~~~~
  Consider
  Note [Improving seq]
  ~~~~~~~~~~~~~~~~~~~
  Consider
@@ -1720,26 +1772,15 @@ and then
  All this should happen in one sweep.
  
  \begin{code}
  All this should happen in one sweep.
  
  \begin{code}
-knownCon :: SimplEnv -> OutExpr -> AltCon
-        -> [OutExpr]           -- Args *including* the universal args
-         -> InId -> [InAlt] -> SimplCont
-         -> SimplM (SimplEnv, OutExpr)
-
-knownCon env scrut con args bndr alts cont
-  = do  { tick (KnownBranch bndr)
-        ; case findAlt con alts of
-           Nothing  -> missingAlt env bndr alts cont
-           Just alt -> knownAlt env scrut args bndr alt cont
-       }
-
--------------------
-knownAlt :: SimplEnv -> OutExpr -> [OutExpr]
-         -> InId -> InAlt -> SimplCont
+knownCon :: SimplEnv           
+         -> OutExpr                            -- The scrutinee
+         -> DataCon -> [OutType] -> [OutExpr]  -- The scrutinee (in pieces)
+         -> InId -> [InBndr] -> InExpr         -- The alternative
+         -> SimplCont
           -> SimplM (SimplEnv, OutExpr)
  
           -> SimplM (SimplEnv, OutExpr)
  
-knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont
-  = do  { let n_drop_tys = length (dataConUnivTyVars dc)
-        ; env' <- bind_args env bs (drop n_drop_tys the_args)
+knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
+  = do  { env' <- bind_args env bs dc_args
          ; let
                  -- It's useful to bind bndr to scrut, rather than to a fresh
                  -- binding      x = Con arg1 .. argn
          ; let
                  -- It's useful to bind bndr to scrut, rather than to a fresh
                  -- binding      x = Con arg1 .. argn
@@ -1748,12 +1789,12 @@ knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont
                  -- BUT, if scrut is a not a variable, we must be careful
                  -- about duplicating the arg redexes; in that case, make
                  -- a new con-app from the args
                  -- BUT, if scrut is a not a variable, we must be careful
                  -- about duplicating the arg redexes; in that case, make
                  -- a new con-app from the args
-                bndr_rhs  = case scrut of
-                                Var _ -> scrut
-                                _     -> con_app
-                con_app = mkConApp dc (take n_drop_tys the_args ++ con_args)
-                con_args = [substExpr env' (varToCoreExpr b) | b <- bs]
-                                -- args are aready OutExprs, but bs are InIds
+                bndr_rhs | exprIsTrivial scrut = scrut
+                        | otherwise           = con_app
+                con_app = Var (dataConWorkId dc) 
+                          `mkTyApps` dc_ty_args
+                          `mkApps`   [substExpr env' (varToCoreExpr b) | b <- bs]
+                         -- dc_ty_args are aready OutTypes, but bs are InBndrs
  
          ; env'' <- simplNonRecX env' bndr bndr_rhs
          ; simplExprF env'' rhs cont }
  
          ; env'' <- simplNonRecX env' bndr bndr_rhs
          ; simplExprF env'' rhs cont }
@@ -1779,15 +1820,9 @@ knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont
             ; bind_args env'' bs' args }
  
      bind_args _ _ _ =
             ; bind_args env'' bs' args }
  
      bind_args _ _ _ =
-      pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr the_args $$
+      pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$
                               text "scrut:" <+> ppr scrut
  
                               text "scrut:" <+> ppr scrut
  
-knownAlt env scrut _ bndr (_, bs, rhs) cont
-  = ASSERT( null bs )    -- Works for LitAlt and DEFAULT
-    do  { env' <- simplNonRecX env bndr scrut
-        ; simplExprF env' rhs cont }
-
-
  -------------------
  missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr)
                 -- This isn't strictly an error, although it is unusual. 
  -------------------
  missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr)
                 -- This isn't strictly an error, although it is unusual. 
@@ -1920,12 +1955,31 @@ mkDupableAlts env case_bndr' the_alts
  
  mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr)
                -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr))
  
  mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr)
                -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr))
-mkDupableAlt env case_bndr' (con, bndrs', rhs')
+mkDupableAlt env case_bndr (con, bndrs', rhs')
    | exprIsDupable rhs'  -- Note [Small alternative rhs]
    = return (env, (con, bndrs', rhs'))
    | otherwise
    | exprIsDupable rhs'  -- Note [Small alternative rhs]
    = return (env, (con, bndrs', rhs'))
    | otherwise
-  = do  { let rhs_ty'     = exprType rhs'
-              used_bndrs' = filter abstract_over (case_bndr' : bndrs')
+  = do  { let rhs_ty'  = exprType rhs'
+             scrut_ty = idType case_bndr
+             case_bndr_w_unf   
+                = case con of 
+                     DEFAULT    -> case_bndr                                   
+                     DataAlt dc -> setIdUnfolding case_bndr unf
+                         where
+                                -- See Note [Case binders and join points]
+                            unf = mkInlineRule InlSat rhs 0
+                            rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty)
+                                               ++ varsToCoreExprs bndrs')
+
+                     LitAlt {} -> WARN( True, ptext (sLit "mkDupableAlt")
+                                               <+> ppr case_bndr <+> ppr con )
+                                  case_bndr
+                          -- The case binder is alive but trivial, so why has 
+                          -- it not been substituted away?
+
+              used_bndrs' | isDeadBinder case_bndr = filter abstract_over bndrs'
+                         | otherwise              = bndrs' ++ [case_bndr_w_unf]
+             
                abstract_over bndr
                    | isTyVar bndr = True -- Abstract over all type variables just in case
                    | otherwise    = not (isDeadBinder bndr)
                abstract_over bndr
                    | isTyVar bndr = True -- Abstract over all type variables just in case
                    | otherwise    = not (isDeadBinder bndr)
@@ -1950,10 +2004,42 @@ mkDupableAlt env case_bndr' (con, bndrs', rhs')
                  join_rhs  = mkLams really_final_bndrs rhs'
                  join_call = mkApps (Var join_bndr) final_args
  
                  join_rhs  = mkLams really_final_bndrs rhs'
                  join_call = mkApps (Var join_bndr) final_args
  
-        ; return (addPolyBind NotTopLevel env (NonRec join_bndr join_rhs), (con, bndrs', join_call)) }
+       ; env' <- addPolyBind NotTopLevel env (NonRec join_bndr join_rhs)
+        ; return (env', (con, bndrs', join_call)) }
                  -- See Note [Duplicated env]
  \end{code}
  
                  -- See Note [Duplicated env]
  \end{code}
  
+Note [Case binders and join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this 
+   case (case .. ) of c {
+     I# c# -> ....c....
+
+If we make a join point with c but not c# we get
+  $j = \c -> ....c....
+
+But if later inlining scrutines the c, thus
+
+  $j = \c -> ... case c of { I# y -> ... } ...
+
+we won't see that 'c' has already been scrutinised.  This actually
+happens in the 'tabulate' function in wave4main, and makes a significant
+difference to allocation.
+
+An alternative plan is this:
+
+   $j = \c# -> let c = I# c# in ...c....
+
+but that is bad if 'c' is *not* later scrutinised.  
+
+So instead we do both: we pass 'c' and 'c#' , and record in c's inlining
+that it's really I# c#, thus
+   
+   $j = \c# -> \c[=I# c#] -> ...c....
+
+Absence analysis may later discard 'c'.
+
+   
  Note [Duplicated env]
  ~~~~~~~~~~~~~~~~~~~~~
  Some of the alternatives are simplified, but have not been turned into a join point
  Note [Duplicated env]
  ~~~~~~~~~~~~~~~~~~~~~
  Some of the alternatives are simplified, but have not been turned into a join point
diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs

index 028ec83..cc5054a 100644 (file)
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -22,9 +22,9 @@ module Rules (
         addIdSpecialisations, 
         
         -- * Misc. CoreRule helpers
         addIdSpecialisations, 
         
         -- * Misc. CoreRule helpers
-        rulesOfBinds, getRules, pprRulesForUser,
+        rulesOfBinds, getRules, pprRulesForUser, expandId,
          
          
-        lookupRule, mkLocalRule, roughTopNames
+        lookupRule, mkRule, mkLocalRule, roughTopNames
      ) where
  
  #include "HsVersions.h"
      ) where
  
  #include "HsVersions.h"
@@ -96,11 +96,18 @@ mkLocalRule :: RuleName -> Activation
             -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
  -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being 
  -- compiled. See also 'CoreSyn.CoreRule'
             -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
  -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being 
  -- compiled. See also 'CoreSyn.CoreRule'
-mkLocalRule name act fn bndrs args rhs
+mkLocalRule = mkRule True
+
+mkRule :: Bool -> RuleName -> Activation 
+       -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
+-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being 
+-- compiled. See also 'CoreSyn.CoreRule'
+mkRule is_local name act fn bndrs args rhs
    = Rule { ru_name = name, ru_fn = fn, ru_act = act,
            ru_bndrs = bndrs, ru_args = args,
    = Rule { ru_name = name, ru_fn = fn, ru_act = act,
            ru_bndrs = bndrs, ru_args = args,
-          ru_rhs = rhs, ru_rough = roughTopNames args,
-          ru_local = True }
+          ru_rhs = occurAnalyseExpr rhs, 
+          ru_rough = roughTopNames args,
+          ru_local = is_local }
  
  --------------
  roughTopNames :: [CoreExpr] -> [Maybe Name]
  
  --------------
  roughTopNames :: [CoreExpr] -> [Maybe Name]
@@ -192,18 +199,32 @@ rulesOfBinds :: [CoreBind] -> [CoreRule]
  rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds
  
  getRules :: RuleBase -> Id -> [CoreRule]
  rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds
  
  getRules :: RuleBase -> Id -> [CoreRule]
-       -- The rules for an Id come from two places:
-       --      (a) the ones it is born with (idCoreRules fn)
-       --      (b) rules added in subsequent modules (extra_rules)
-       -- PrimOps, for example, are born with a bunch of rules under (a)
+-- See Note [Where rules are found]
  getRules rule_base fn
  getRules rule_base fn
-  | isLocalId fn  = idCoreRules fn
-  | otherwise     = WARN( not (isPrimOpId fn) && notNull (idCoreRules fn), 
-                         ppr fn <+> ppr (idCoreRules fn) )
-                   idCoreRules fn ++ (lookupNameEnv rule_base (idName fn) `orElse` [])
-       -- Only PrimOpIds have rules inside themselves, and perhaps more besides
+  = idCoreRules fn ++ imp_rules
+  where
+    imp_rules = lookupNameEnv rule_base (idName fn) `orElse` []
  \end{code}
  
  \end{code}
  
+Note [Where rules are found]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The rules for an Id come from two places:
+  (a) the ones it is born with, stored inside the Id iself (idCoreRules fn),
+  (b) rules added in other modules, stored in the global RuleBase (imp_rules)
+
+It's tempting to think that 
+     - LocalIds have only (a)
+     - non-LocalIds have only (b)
+
+but that isn't quite right:
+
+     - PrimOps and ClassOps are born with a bunch of rules inside the Id,
+       even when they are imported
+
+     - The rules in PrelRules.builtinRules should be active even
+       in the module defining the Id (when it's a LocalId), but 
+       the rules are kept in the global RuleBase
+
  
  %************************************************************************
  %*                                                                     *
  
  %************************************************************************
  %*                                                                     *
@@ -355,6 +376,7 @@ matchRule :: (Activation -> Bool) -> InScopeSet
  
  matchRule _is_active _in_scope args _rough_args
           (BuiltinRule { ru_try = match_fn })
  
  matchRule _is_active _in_scope args _rough_args
           (BuiltinRule { ru_try = match_fn })
+-- Built-in rules can't be switched off, it seems
    = case match_fn args of
         Just expr -> Just expr
         Nothing   -> Nothing
    = case match_fn args of
         Just expr -> Just expr
         Nothing   -> Nothing
@@ -828,7 +850,6 @@ eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && eqExpr (rnBndrs2 env vs1  vs2) r1
  eq_note :: RnEnv2 -> Note -> Note -> Bool
  eq_note _ (SCC cc1)     (SCC cc2)      = cc1 == cc2
  eq_note _ (CoreNote s1) (CoreNote s2)  = s1 == s2
  eq_note :: RnEnv2 -> Note -> Note -> Bool
  eq_note _ (SCC cc1)     (SCC cc2)      = cc1 == cc2
  eq_note _ (CoreNote s1) (CoreNote s2)  = s1 == s2
-eq_note _ (InlineMe)    (InlineMe)     = True
  eq_note _ _             _              = False
  \end{code}
  
  eq_note _ _             _              = False
  \end{code}
  
diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs

index 590e689..c51b27d 100644 (file)
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -17,7 +17,7 @@ module Specialise ( specProgram ) where
  import Id
  import TcType
  import CoreSubst 
  import Id
  import TcType
  import CoreSubst 
-import CoreUnfold      ( mkUnfolding )
+import CoreUnfold      ( mkUnfolding, mkInlineRule )
  import VarSet
  import VarEnv
  import CoreSyn
  import VarSet
  import VarEnv
  import CoreSyn
@@ -29,6 +29,7 @@ import Name
  import MkId            ( voidArgId, realWorldPrimId )
  import FiniteMap
  import Maybes          ( catMaybes, isJust )
  import MkId            ( voidArgId, realWorldPrimId )
  import FiniteMap
  import Maybes          ( catMaybes, isJust )
+import BasicTypes      ( Arity )
  import Bag
  import Util
  import Outputable
  import Bag
  import Util
  import Outputable
@@ -800,17 +801,27 @@ specDefn subst body_uds fn rhs
    where
      fn_type           = idType fn
      fn_arity          = idArity fn
    where
      fn_type           = idType fn
      fn_arity          = idArity fn
+    fn_unf             = idUnfolding fn
      (tyvars, theta, _) = tcSplitSigmaTy fn_type
      n_tyvars          = length tyvars
      n_dicts           = length theta
      inline_act         = idInlineActivation fn
  
      (tyvars, theta, _) = tcSplitSigmaTy fn_type
      n_tyvars          = length tyvars
      n_dicts           = length theta
      inline_act         = idInlineActivation fn
  
-    (body_uds_without_me, calls_for_me) = callsForMe fn body_uds
+       -- Figure out whether the function has an INLINE pragma
+       -- See Note [Inline specialisations]
+    fn_has_inline_rule :: Maybe (InlineRuleInfo, Arity)         -- Gives arity of the *specialised* inline rule
+    fn_has_inline_rule
+      | Just inl <- isInlineRule_maybe fn_unf 
+      = case inl of
+          InlWrapper _ -> Just (InlUnSat, spec_arity)
+          _            -> Just (inl,      spec_arity)
+      | otherwise = Nothing
+      where
+        spec_arity = unfoldingArity fn_unf - n_dicts
  
  
-       -- It's important that we "see past" any INLINE pragma
-       -- else we'll fail to specialise an INLINE thing
-    (inline_rhs, rhs_inside) = dropInline rhs
-    (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs_inside
+    (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs
+
+    (body_uds_without_me, calls_for_me) = callsForMe fn body_uds
  
      rhs_dict_ids = take n_dicts rhs_ids
      body         = mkLams (drop n_dicts rhs_ids) rhs_body
  
      rhs_dict_ids = take n_dicts rhs_ids
      body         = mkLams (drop n_dicts rhs_ids) rhs_body
@@ -898,10 +909,14 @@ specDefn subst body_uds fn rhs
                 -- Add the { d1' = dx1; d2' = dx2 } usage stuff
                 final_uds = foldr consDictBind rhs_uds dx_binds
  
                 -- Add the { d1' = dx1; d2' = dx2 } usage stuff
                 final_uds = foldr consDictBind rhs_uds dx_binds
  
-               spec_pr | inline_rhs = (spec_f_w_arity `setInlineActivation` inline_act, Note InlineMe spec_rhs)
-                       | otherwise  = (spec_f_w_arity,                                  spec_rhs)
-
-          ; return (Just (spec_pr, final_uds, spec_env_rule)) } }
+               -- See Note [Inline specialisations]
+               final_spec_f | Just (inl, spec_arity) <- fn_has_inline_rule
+                            = spec_f_w_arity `setInlineActivation` inline_act
+                                             `setIdUnfolding` mkInlineRule inl spec_rhs spec_arity
+                                               -- I'm not sure this should be unconditionally InlSat
+                            | otherwise 
+                            = spec_f_w_arity
+          ; return (Just ((final_spec_f, spec_rhs), final_uds, spec_env_rule)) } }
        where
         my_zipEqual xs ys zs
          | debugIsOn && not (equalLength xs ys && equalLength ys zs)
        where
         my_zipEqual xs ys zs
          | debugIsOn && not (equalLength xs ys && equalLength ys zs)
@@ -1157,11 +1172,6 @@ specialised version.
  A case in point is dictionary functions, which are current marked
  INLINE, but which are worth specialising.
  
  A case in point is dictionary functions, which are current marked
  INLINE, but which are worth specialising.
  
-\begin{code}
-dropInline :: CoreExpr -> (Bool, CoreExpr)
-dropInline (Note InlineMe rhs) = (True,  rhs)
-dropInline rhs                = (False, rhs)
-\end{code}
  
  %************************************************************************
  %*                                                                     *
  
  %************************************************************************
  %*                                                                     *
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs

index 6dc0fb7..789e77a 100644 (file)
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -50,11 +50,11 @@ import UniqFM               ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly,
                           keysUFM, minusUFM, ufmToList, filterUFM )
  import Type            ( isUnLiftedType, coreEqType, splitTyConApp_maybe )
  import Coercion         ( coercionKind )
                           keysUFM, minusUFM, ufmToList, filterUFM )
  import Type            ( isUnLiftedType, coreEqType, splitTyConApp_maybe )
  import Coercion         ( coercionKind )
-import CoreLint                ( showPass, endPass )
  import Util            ( mapAndUnzip, lengthIs )
  import BasicTypes      ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
                           RecFlag(..), isRec )
  import Maybes          ( orElse, expectJust )
  import Util            ( mapAndUnzip, lengthIs )
  import BasicTypes      ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
                           RecFlag(..), isRec )
  import Maybes          ( orElse, expectJust )
+import ErrUtils                ( showPass )
  import Outputable
  
  import Data.List
  import Outputable
  
  import Data.List
diff --git a/compiler/stranal/StrictAnal.lhs b/compiler/stranal/StrictAnal.lhs

index a5efe30..920f841 100644 (file)
--- a/compiler/stranal/StrictAnal.lhs
+++ b/compiler/stranal/StrictAnal.lhs
@@ -29,7 +29,6 @@ import Id             ( setIdStrictness, setInlinePragma,
                           idDemandInfo, setIdDemandInfo, isBottomingId,
                           Id
                         )
                           idDemandInfo, setIdDemandInfo, isBottomingId,
                           Id
                         )
-import CoreLint                ( showPass, endPass )
  import ErrUtils                ( dumpIfSet_dyn )
  import SaAbsInt
  import SaLib
  import ErrUtils                ( dumpIfSet_dyn )
  import SaAbsInt
  import SaLib
diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs

index 7b124f3..d23e83e 100644 (file)
--- a/compiler/stranal/WorkWrap.lhs
+++ b/compiler/stranal/WorkWrap.lhs
@@ -7,11 +7,14 @@
  module WorkWrap ( wwTopBinds, mkWrapper ) where
  
  import CoreSyn
  module WorkWrap ( wwTopBinds, mkWrapper ) where
  
  import CoreSyn
-import CoreUnfold      ( certainlyWillInline )
-import CoreUtils       ( exprType, exprIsHNF, mkInlineMe )
+import CoreUnfold      ( certainlyWillInline, mkInlineRule, mkWwInlineRule )
+import CoreUtils       ( exprType, exprIsHNF )
  import CoreArity       ( exprArity )
  import Var
  import CoreArity       ( exprArity )
  import Var
-import Id
+import Id              ( idType, isOneShotLambda, idUnfolding,
+                         setIdNewStrictness, mkWorkerId,
+                         setInlineActivation, setIdUnfolding,
+                         setIdArity )
  import Type            ( Type )
  import IdInfo
  import NewDemand        ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), 
  import Type            ( Type )
  import IdInfo
  import NewDemand        ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), 
@@ -102,11 +105,9 @@ matching by looking for strict arguments of the correct type.
  \begin{code}
  wwExpr :: CoreExpr -> UniqSM CoreExpr
  
  \begin{code}
  wwExpr :: CoreExpr -> UniqSM CoreExpr
  
-wwExpr e@(Type {})         = return e
-wwExpr e@(Lit  {})         = return e
-wwExpr e@(Var  {})         = return e
-wwExpr e@(Note InlineMe _) = return e
-       -- Don't w/w inside InlineMe's
+wwExpr e@(Type {}) = return e
+wwExpr e@(Lit  {}) = return e
+wwExpr e@(Var  {}) = return e
  
  wwExpr (Lam binder expr)
    = Lam binder <$> wwExpr expr
  
  wwExpr (Lam binder expr)
    = Lam binder <$> wwExpr expr
@@ -155,7 +156,10 @@ The only reason this is monadised is for the unique supply.
  Note [Don't w/w inline things (a)]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  It's very important to refrain from w/w-ing an INLINE function
  Note [Don't w/w inline things (a)]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  It's very important to refrain from w/w-ing an INLINE function
-If we do so by mistake we transform
+because the wrapepr will then overwrite the InlineRule unfolding.
+
+It was wrong with the old InlineMe Note too: if we do so by mistake 
+we transform
         f = __inline (\x -> E)
  into
         f = __inline (\x -> case x of (a,b) -> fw E)
         f = __inline (\x -> E)
  into
         f = __inline (\x -> case x of (a,b) -> fw E)
@@ -242,14 +246,22 @@ tryWW is_rec fn_id rhs
      is_thunk  = not is_fun && not (exprIsHNF rhs)
  
  ---------------------
      is_thunk  = not is_fun && not (exprIsHNF rhs)
  
  ---------------------
-checkSize :: Id -> CoreExpr -> UniqSM [(Id,CoreExpr)] -> UniqSM [(Id,CoreExpr)]
+checkSize :: Id -> CoreExpr
+         -> UniqSM [(Id,CoreExpr)] -> UniqSM [(Id,CoreExpr)]
   -- See Note [Don't w/w inline things (a) and (b)]
  checkSize fn_id rhs thing_inside
   -- See Note [Don't w/w inline things (a) and (b)]
  checkSize fn_id rhs thing_inside
-  | certainlyWillInline unfolding = return [ (fn_id, mkInlineMe rhs) ]
+  | isStableUnfolding unfolding           -- For DFuns and INLINE things, leave their
+  = return [ (fn_id, rhs) ]       -- unfolding unchanged; but still attach 
+                                  -- strictness info to the Id 
+
+  | certainlyWillInline unfolding
+  = return [ (fn_id `setIdUnfolding` inline_rule, rhs) ]
                 -- Note [Don't w/w inline things (b)]
                 -- Note [Don't w/w inline things (b)]
+
    | otherwise = thing_inside
    where
      unfolding = idUnfolding fn_id
    | otherwise = thing_inside
    where
      unfolding = idUnfolding fn_id
+    inline_rule = mkInlineRule InlUnSat rhs (unfoldingArity unfolding)
  
  ---------------------
  splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Activation -> Expr Var
  
  ---------------------
  splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Activation -> Expr Var
@@ -279,7 +291,7 @@ splitFun fn_id fn_info wrap_dmds res_info inline_act rhs
                                  -- arity is consistent with the demand type goes through
  
         wrap_rhs = wrap_fn work_id
                                  -- arity is consistent with the demand type goes through
  
         wrap_rhs = wrap_fn work_id
-       wrap_id  = fn_id `setIdWorkerInfo` HasWorker work_id arity
+       wrap_id  = fn_id `setIdUnfolding` mkWwInlineRule work_id wrap_rhs arity
  
      ; return ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) })
         -- Worker first, because wrapper mentions it
  
      ; return ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) })
         -- Worker first, because wrapper mentions it
diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs

index bceb453..2c3581c 100644 (file)
--- a/compiler/stranal/WwLib.lhs
+++ b/compiler/stranal/WwLib.lhs
@@ -134,7 +134,7 @@ mkWwBodies fun_ty demands res_info one_shots
  
         ; let (work_lam_args, work_call_args) = mkWorkerArgs work_args res_ty
         ; return ([idNewDemandInfo v | v <- work_call_args, isId v],
  
         ; let (work_lam_args, work_call_args) = mkWorkerArgs work_args res_ty
         ; return ([idNewDemandInfo v | v <- work_call_args, isId v],
-                  Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var,
+                  wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var,
                    mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args) }
          -- We use an INLINE unconditionally, even if the wrapper turns out to be
          -- something trivial like
                    mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args) }
          -- We use an INLINE unconditionally, even if the wrapper turns out to be
          -- something trivial like
diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs

index a45422a..b237778 100644 (file)
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -246,7 +246,9 @@ tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
  --------------------------
  instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
  instToDictBind inst rhs 
  --------------------------
  instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
  instToDictBind inst rhs 
-  = unitBag (L (instSpan inst) (VarBind (instToId inst) rhs))
+  = unitBag (L (instSpan inst) (VarBind { var_id = instToId inst
+                                       , var_rhs = rhs
+                                       , var_inline = False }))
  
  addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
  addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
  
  addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
  addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs

index 7a7edb4..f21bbe6 100644 (file)
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -45,6 +45,7 @@ import BasicTypes
  import Outputable
  import FastString
  
  import Outputable
  import FastString
  
+import Data.List( partition )
  import Control.Monad
  \end{code}
  
  import Control.Monad
  \end{code}
  
@@ -350,7 +351,8 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds
  
          -- BUILD THE POLYMORPHIC RESULT IDs
    ; let dict_vars = map instToVar dicts -- May include equality constraints
  
          -- BUILD THE POLYMORPHIC RESULT IDs
    ; let dict_vars = map instToVar dicts -- May include equality constraints
-  ; exports <- mapM (mkExport top_lvl prag_fn tyvars_to_gen (map varType dict_vars))
+  ; exports <- mapM (mkExport top_lvl rec_group (length mono_bind_infos > 1)
+                              prag_fn tyvars_to_gen (map varType dict_vars))
                      mono_bind_infos
  
    ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
                      mono_bind_infos
  
    ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
@@ -365,9 +367,12 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds
  
  
  --------------
  
  
  --------------
-mkExport :: TopLevelFlag -> TcPragFun -> [TyVar] -> [TcType]
+mkExport :: TopLevelFlag -> RecFlag
+        -> Bool         -- More than one variable is bound, so we'll desugar to
+                        -- a tuple, so INLINE pragmas won't work
+         -> TcPragFun -> [TyVar] -> [TcType]
           -> MonoBindInfo
           -> MonoBindInfo
-         -> TcM ([TyVar], Id, Id, [LPrag])
+         -> TcM ([TyVar], Id, Id, [LSpecPrag])
  -- mkExport generates exports with 
  --      zonked type variables, 
  --      zonked poly_ids
  -- mkExport generates exports with 
  --      zonked type variables, 
  --      zonked poly_ids
@@ -379,16 +384,18 @@ mkExport :: TopLevelFlag -> TcPragFun -> [TyVar] -> [TcType]
  
  -- Pre-condition: the inferred_tvs are already zonked
  
  
  -- Pre-condition: the inferred_tvs are already zonked
  
-mkExport top_lvl prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id)
+mkExport top_lvl rec_group multi_bind prag_fn inferred_tvs dict_tys
+         (poly_name, mb_sig, mono_id)
    = do  { warn_missing_sigs <- doptM Opt_WarnMissingSigs
          ; let warn = isTopLevel top_lvl && warn_missing_sigs
          ; (tvs, poly_id) <- mk_poly_id warn mb_sig
                  -- poly_id has a zonked type
  
    = do  { warn_missing_sigs <- doptM Opt_WarnMissingSigs
          ; let warn = isTopLevel top_lvl && warn_missing_sigs
          ; (tvs, poly_id) <- mk_poly_id warn mb_sig
                  -- poly_id has a zonked type
  
-        ; prags <- tcPrags poly_id (prag_fn poly_name)
+        ; (poly_id', spec_prags) <- tcPrags rec_group multi_bind (notNull dict_tys)
+                                            poly_id (prag_fn poly_name)
                  -- tcPrags requires a zonked poly_id
  
                  -- tcPrags requires a zonked poly_id
  
-        ; return (tvs, poly_id, mono_id, prags) }
+        ; return (tvs, poly_id', mono_id, spec_prags) }
    where
      poly_ty = mkForAllTys inferred_tvs (mkFunTys dict_tys (idType mono_id))
  
    where
      poly_ty = mkForAllTys inferred_tvs (mkFunTys dict_tys (idType mono_id))
  
@@ -411,34 +418,89 @@ mkPragFun sigs = \n -> lookupNameEnv env n `orElse` []
            env = foldl add emptyNameEnv prs
            add env (n,p) = extendNameEnv_Acc (:) singleton env n p
  
            env = foldl add emptyNameEnv prs
            add env (n,p) = extendNameEnv_Acc (:) singleton env n p
  
-tcPrags :: Id -> [LSig Name] -> TcM [LPrag]
-tcPrags poly_id prags = mapM (wrapLocM tc_prag) prags
-  where
-    tc_prag prag = addErrCtxt (pragSigCtxt prag) $ 
-                   tcPrag poly_id prag
-
-pragSigCtxt :: Sig Name -> SDoc
-pragSigCtxt prag = hang (ptext (sLit "In the pragma")) 2 (ppr prag)
-
-tcPrag :: TcId -> Sig Name -> TcM Prag
+tcPrags :: RecFlag
+       -> Bool     -- True <=> AbsBinds binds more than one variable
+        -> Bool     -- True <=> function is overloaded
+        -> Id -> [LSig Name]
+        -> TcM (Id, [LSpecPrag])
+-- Add INLINE and SPECLIASE pragmas
+--    INLINE prags are added to the Id directly
+--    SPECIALISE prags are passed to the desugarer via [LSpecPrag]
  -- Pre-condition: the poly_id is zonked
  -- Reason: required by tcSubExp
  -- Pre-condition: the poly_id is zonked
  -- Reason: required by tcSubExp
--- Most of the work of specialisation is done by 
--- the desugarer, guided by the SpecPrag
-tcPrag poly_id (SpecSig _ hs_ty inl) 
-  = do  { let name = idName poly_id
+tcPrags _rec_group _multi_bind _is_overloaded_id poly_id prag_sigs
+  = do { poly_id' <- tc_inl inl_sigs
+
+       ; spec_prags <- mapM (wrapLocM (tcSpecPrag poly_id')) spec_sigs
+
+-- Commented out until bytestring library removes redundant pragmas
+-- for packWith and unpackWith
+--       ; unless (null spec_sigs || is_overloaded_id) warn_discarded_spec
+
+       ; unless (null bad_sigs) warn_discarded_sigs
+
+       ; return (poly_id', spec_prags) }
+  where
+    (inl_sigs, other_sigs) = partition isInlineLSig prag_sigs
+    (spec_sigs, bad_sigs)  = partition isSpecLSig   other_sigs
+
+--    warn_discarded_spec = warnPrags poly_id spec_sigs $
+--                          ptext (sLit "SPECIALISE pragmas for non-overloaded function")
+    warn_dup_inline    = warnPrags poly_id inl_sigs $
+                         ptext (sLit "Duplicate INLINE pragmas for")
+    warn_discarded_sigs = warnPrags poly_id bad_sigs $
+                          ptext (sLit "Discarding unexpected pragmas for")
+
+    -----------
+    tc_inl [] = return poly_id
+    tc_inl (L loc (InlineSig _ prag) : other_inls)
+       = do { unless (null other_inls) (setSrcSpan loc warn_dup_inline)
+            ; return (poly_id `setInlinePragma` prag) }
+    tc_inl _ = panic "tc_inl"
+
+{- Earlier we tried to warn about
+   (a) INLINE for recursive function
+   (b) INLINE for function that is part of a multi-binder group
+   Code fragments below. But we want to allow
+       {-# INLINE f #-}
+       f x = x : g y
+       g y = ....f...f....
+   even though they are mutually recursive.  
+   So I'm just omitting the warnings for now
+
+       | multi_bind && isInlinePragma prag
+       = do { setSrcSpan loc $ addWarnTc multi_bind_warn
+            ; return poly_id }
+       | otherwise
+            ; when (isInlinePragma prag && isRec rec_group)
+                   (setSrcSpan loc (addWarnTc rec_inline_warn))
+
+    rec_inline_warn = ptext (sLit "INLINE pragma for recursive binder")
+                      <+> quotes (ppr poly_id) <+> ptext (sLit "may be discarded")
+ 
+    multi_bind_warn = hang (ptext (sLit "Discarding INLINE pragma for") <+> quotes (ppr poly_id))
+                        2 (ptext (sLit "because it is bound by a pattern, or mutual recursion") )
+-}
+
+
+warnPrags :: Id -> [LSig Name] -> SDoc -> TcM ()
+warnPrags id bad_sigs herald
+  = addWarnTc (hang (herald <+> quotes (ppr id))
+                  2 (ppr_sigs bad_sigs))
+  where
+    ppr_sigs sigs = vcat (map (ppr . getLoc) sigs)
+
+--------------
+tcSpecPrag :: TcId -> Sig Name -> TcM SpecPrag
+tcSpecPrag poly_id prag@(SpecSig _ hs_ty inl) 
+  = addErrCtxt (spec_ctxt prag) $
+    do  { let name = idName poly_id
          ; spec_ty <- tcHsSigType (FunSigCtxt name) hs_ty
          ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty
          ; spec_ty <- tcHsSigType (FunSigCtxt name) hs_ty
          ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty
-        ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty inl) }
-tcPrag poly_id (SpecInstSig hs_ty)
-  = do  { let name = idName poly_id
-        ; (tyvars, theta, tau) <- tcHsInstHead hs_ty   
-        ; let spec_ty = mkSigmaTy tyvars theta tau
-        ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty
-        ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty defaultInlineSpec) }
-
-tcPrag _  (InlineSig _ inl) = return (InlinePrag inl)
-tcPrag _  sig              = pprPanic "tcPrag" (ppr sig)
+        ; return (SpecPrag co_fn inl) }
+  where
+    spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
+tcSpecPrag _ sig = pprPanic "tcSpecPrag" (ppr sig)
  
  
  --------------
  
  
  --------------
diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs

index 33b02de..23ee423 100644 (file)
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -7,7 +7,7 @@ Typechecking class declarations
  
  \begin{code}
  module TcClassDcl ( tcClassSigs, tcClassDecl2, 
  
  \begin{code}
  module TcClassDcl ( tcClassSigs, tcClassDecl2, 
-                   findMethodBind, tcInstanceMethodBody, 
+                   findMethodBind, instantiateMethod, tcInstanceMethodBody,
                     mkGenericDefMethBind, getGenericInstances, mkDefMethRdrName,
                     tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
                   ) where
                     mkGenericDefMethBind, getGenericInstances, mkDefMethRdrName,
                     tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
                   ) where
@@ -160,11 +160,11 @@ tcClassSig _ s = pprPanic "tcClassSig" (ppr s)
  
  \begin{code}
  tcClassDecl2 :: LTyClDecl Name         -- The class declaration
  
  \begin{code}
  tcClassDecl2 :: LTyClDecl Name         -- The class declaration
-            -> TcM (LHsBinds Id, [Id])
+            -> TcM ([Id], LHsBinds Id)
  
  tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, 
                                 tcdMeths = default_binds}))
  
  tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, 
                                 tcdMeths = default_binds}))
-  = recoverM (return (emptyLHsBinds, []))      $
+  = recoverM (return ([], emptyLHsBinds))      $
      setSrcSpan loc                             $
      do  { clas <- tcLookupLocatedClass class_name
  
      setSrcSpan loc                             $
      do  { clas <- tcLookupLocatedClass class_name
  
@@ -186,7 +186,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
         ; inst_loc <- getInstLoc (SigOrigin rigid_info)
         ; this_dict <- newDictBndr inst_loc pred
  
         ; inst_loc <- getInstLoc (SigOrigin rigid_info)
         ; this_dict <- newDictBndr inst_loc pred
  
-       ; let tc_dm = tcDefMeth rigid_info clas clas_tyvars [pred] 
+       ; let tc_dm = tcDefMeth clas clas_tyvars
                                 this_dict default_binds
                                 sig_fn prag_fn
                 -- tc_dm is called only for a sel_id
                                 this_dict default_binds
                                 sig_fn prag_fn
                 -- tc_dm is called only for a sel_id
@@ -200,39 +200,110 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
               -- the programmer supplied an explicit default decl for the class.  
               -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
  
               -- the programmer supplied an explicit default decl for the class.  
               -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
  
-       ; (defm_binds, dm_ids) <- tcExtendTyVarEnv clas_tyvars  $
+       ; (dm_ids, defm_binds) <- tcExtendTyVarEnv clas_tyvars  $
                                   mapAndUnzipM tc_dm dm_sel_ids
  
                                   mapAndUnzipM tc_dm dm_sel_ids
  
-       ; return (unionManyBags defm_binds, dm_ids) }
+       ; return (dm_ids, listToBag defm_binds) }
  
  tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
      
  
  tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
      
-tcDefMeth :: SkolemInfo -> Class -> [TyVar] -> ThetaType -> Inst -> LHsBinds Name
+tcDefMeth :: Class -> [TyVar] -> Inst -> LHsBinds Name
            -> TcSigFun -> TcPragFun -> Id
            -> TcSigFun -> TcPragFun -> Id
-          -> TcM (LHsBinds Id, Id)
-tcDefMeth rigid_info clas tyvars theta this_dict binds_in sig_fn prag_fn sel_id
+          -> TcM (Id, LHsBind Id)
+tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn sel_id
    = do { let sel_name = idName sel_id
    = do { let sel_name = idName sel_id
-       ; local_dm_name <- newLocalName sel_name
+       ; dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_name)
+       ; local_dm_name <- newLocalName sel_name
+         -- Base the local_dm_name on the selector name, becuase
+         -- type errors from tcInstanceMethodBody come from here
+
+               -- See Note [Silly default-method bind]
+               -- (possibly out of date)
+
         ; let meth_bind = findMethodBind sel_name local_dm_name binds_in
                           `orElse` pprPanic "tcDefMeth" (ppr sel_id)
                 -- We only call tcDefMeth on selectors for which 
                 -- there is a binding in binds_in
  
         ; let meth_bind = findMethodBind sel_name local_dm_name binds_in
                           `orElse` pprPanic "tcDefMeth" (ppr sel_id)
                 -- We only call tcDefMeth on selectors for which 
                 -- there is a binding in binds_in
  
-             meth_sig_fn  _ = sig_fn sel_name
-             meth_prag_fn _ = prag_fn sel_name
+             dm_sig_fn  _ = sig_fn sel_name
+             dm_ty = idType sel_id
+             dm_id = mkDefaultMethodId dm_name dm_ty
+             local_dm_type = instantiateMethod clas sel_id (mkTyVarTys tyvars)
+             local_dm_id   = mkLocalId local_dm_name local_dm_type
+
+        ; (dm_id_w_inline, spec_prags) 
+                <- tcPrags NonRecursive False True dm_id (prag_fn sel_name)
+
+        ; tcInstanceMethodBody (instLoc this_dict) 
+                               tyvars [this_dict]
+                               ([], emptyBag)
+                               dm_id_w_inline local_dm_id
+                               dm_sig_fn spec_prags meth_bind }
+
+---------------
+tcInstanceMethodBody :: InstLoc -> [TcTyVar] -> [Inst]
+                    -> ([Inst], LHsBinds Id) -> Id -> Id
+                    -> TcSigFun -> [LSpecPrag] -> LHsBind Name 
+                    -> TcM (Id, LHsBind Id)
+tcInstanceMethodBody inst_loc tyvars dfun_dicts
+                    (this_dict, this_bind) meth_id local_meth_id
+                    meth_sig_fn spec_prags bind@(L loc _)
+  = do {       -- Typecheck the binding, first extending the envt
+               -- so that when tcInstSig looks up the local_meth_id to find
+               -- its signature, we'll find it in the environment
+       ; ((tc_bind, _), lie) <- getLIE $
+                                tcExtendIdEnv [local_meth_id] $
+                                tcPolyBinds TopLevel meth_sig_fn no_prag_fn 
+                                            NonRecursive NonRecursive
+                                            (unitBag bind)
+
+       ; let avails = this_dict ++ dfun_dicts
+               -- Only need the this_dict stuff if there are type 
+               -- variables involved; otherwise overlap is not possible
+               -- See Note [Subtle interaction of recursion and overlap]
+               -- in TcInstDcls
+       ; lie_binds <- tcSimplifyCheck inst_loc tyvars avails lie
+
+       ; let full_bind = AbsBinds tyvars dfun_lam_vars
+                                 [(tyvars, meth_id, local_meth_id, spec_prags)]
+                                 (this_bind `unionBags` lie_binds 
+                                  `unionBags` tc_bind)
  
  
-       ; (top_dm_id, bind) <- tcInstanceMethodBody rigid_info
-                          clas tyvars [this_dict] theta (mkTyVarTys tyvars)
-                          Nothing sel_id
-                          local_dm_name
-                          meth_sig_fn meth_prag_fn
-                          meth_bind
+             dfun_lam_vars = map instToVar dfun_dicts  -- Includes equalities
  
  
-       ; return (bind, top_dm_id) }
+        ; return (meth_id, L loc full_bind) } 
+  where
+    no_prag_fn  _ = []         -- No pragmas for local_meth_id; 
+                               -- they are all for meth_id
+\end{code}
  
  
+\begin{code}
  mkDefMethRdrName :: Name -> RdrName
  mkDefMethRdrName sel_name = mkDerivedRdrName sel_name mkDefaultMethodOcc
  
  mkDefMethRdrName :: Name -> RdrName
  mkDefMethRdrName sel_name = mkDerivedRdrName sel_name mkDefaultMethodOcc
  
+instantiateMethod :: Class -> Id -> [TcType] -> TcType
+-- Take a class operation, say  
+--     op :: forall ab. C a => forall c. Ix c => (b,c) -> a
+-- Instantiate it at [ty1,ty2]
+-- Return the "local method type": 
+--     forall c. Ix x => (ty2,c) -> ty1
+instantiateMethod clas sel_id inst_tys
+  = ASSERT( ok_first_pred ) local_meth_ty
+  where
+    (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
+    rho_ty = ASSERT( length sel_tyvars == length inst_tys )
+            substTyWith sel_tyvars inst_tys sel_rho
+
+    (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
+               `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
+
+    ok_first_pred = case getClassPredTys_maybe first_pred of
+                     Just (clas1, _tys) -> clas == clas1
+                      Nothing -> False
+             -- The first predicate should be of form (C a b)
+             -- where C is the class in question
+
+
  ---------------------------
  -- The renamer just puts the selector ID as the binder in the method binding
  -- but we must use the method name; so we substitute it here.  Crude but simple.
  ---------------------------
  -- The renamer just puts the selector ID as the binder in the method binding
  -- but we must use the method name; so we substitute it here.  Crude but simple.
@@ -246,65 +317,6 @@ findMethodBind sel_name meth_name binds
                  | op_name == sel_name
                  = Just (L loc1 (bind { fun_id = L loc2 meth_name }))
         f _other = Nothing
                  | op_name == sel_name
                  = Just (L loc1 (bind { fun_id = L loc2 meth_name }))
         f _other = Nothing
-
----------------
-tcInstanceMethodBody :: SkolemInfo -> Class -> [TcTyVar] -> [Inst]
-                    -> TcThetaType -> [TcType]
-                    -> Maybe (Inst, LHsBind Id) -> Id
-                    -> Name            -- The local method name
-                    -> TcSigFun -> TcPragFun -> LHsBind Name 
-                    -> TcM (Id, LHsBinds Id)
-tcInstanceMethodBody rigid_info clas tyvars dfun_dicts theta inst_tys
-                    mb_this_bind sel_id  local_meth_name
-                    sig_fn prag_fn bind@(L loc _)
-  = do { let (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
-             rho_ty = ASSERT( length sel_tyvars == length inst_tys )
-                      substTyWith sel_tyvars inst_tys sel_rho
-
-             (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
-                       `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
-
-             local_meth_id = mkLocalId local_meth_name local_meth_ty
-             meth_ty       = mkSigmaTy tyvars theta local_meth_ty
-             sel_name      = idName sel_id
-
-                     -- The first predicate should be of form (C a b)
-                     -- where C is the class in question
-       ; MASSERT( case getClassPredTys_maybe first_pred of
-                       { Just (clas1, _tys) -> clas == clas1 ; Nothing -> False } )
-
-               -- Typecheck the binding, first extending the envt
-               -- so that when tcInstSig looks up the local_meth_id to find
-               -- its signature, we'll find it in the environment
-       ; ((tc_bind, _), lie) <- getLIE $
-               tcExtendIdEnv [local_meth_id] $
-               tcPolyBinds TopLevel sig_fn prag_fn 
-                           NonRecursive NonRecursive
-                           (unitBag bind)
-
-       ; meth_id <- case rigid_info of
-                      ClsSkol _ -> do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_name)
-                                      ; return (mkDefaultMethodId dm_name meth_ty) }
-                      _other    -> do { meth_name <- newLocalName sel_name
-                                      ; return (mkLocalId meth_name meth_ty) }
-       
-       ; let (avails, this_dict_bind) 
-               = case mb_this_bind of
-                   Nothing           -> (dfun_dicts, emptyBag)
-                   Just (this, bind) -> (this : dfun_dicts, unitBag bind)
-
-       ; inst_loc <- getInstLoc (SigOrigin rigid_info)
-       ; lie_binds <- tcSimplifyCheck inst_loc tyvars avails lie
-
-       ; let full_bind = L loc $ 
-                         AbsBinds tyvars dfun_lam_vars
-                                 [(tyvars, meth_id, local_meth_id, [])]
-                                 (this_dict_bind `unionBags` lie_binds 
-                                  `unionBags` tc_bind)
-
-             dfun_lam_vars = map instToVar dfun_dicts  -- Includes equalities
-
-        ; return (meth_id, unitBag full_bind) } 
  \end{code}
  
  Note [Polymorphic methods]
  \end{code}
  
  Note [Polymorphic methods]
@@ -363,7 +375,6 @@ gives rise to the instance declarations
         instance C 1 where
           op Unit      = ...
  
         instance C 1 where
           op Unit      = ...
  
-
  \begin{code}
  mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
  mkGenericDefMethBind clas inst_tys sel_id meth_name
  \begin{code}
  mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
  mkGenericDefMethBind clas inst_tys sel_id meth_name
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs

index d7c80c4..3cfaaa9 100644 (file)
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -362,8 +362,8 @@ renameDeriv is_boot gen_binds insts
               ; let binds' = VanillaInst rn_binds [] standalone_deriv
               ; return (InstInfo { iSpec = inst, iBinds = binds' }, fvs) }
         where
               ; let binds' = VanillaInst rn_binds [] standalone_deriv
               ; return (InstInfo { iSpec = inst, iBinds = binds' }, fvs) }
         where
-         (tyvars,_,clas,_) = instanceHead inst
-         clas_nm           = className clas
+         (tyvars,_, clas,_) = instanceHead inst
+         clas_nm            = className clas
  
  -----------------------------------------
  mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName)
  
  -----------------------------------------
  mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName)
@@ -1147,9 +1147,9 @@ mkNewTypeEqn orig dflags tvs
                                          
         cant_derive_err
            = vcat [ ptext (sLit "even with cunning newtype deriving:")
                                          
         cant_derive_err
            = vcat [ ptext (sLit "even with cunning newtype deriving:")
-                 , if arity_ok then empty else arity_msg
-                 , if eta_ok then empty else eta_msg
-                 , if ats_ok then empty else ats_msg ]
+                 , ppUnless arity_ok arity_msg
+                 , ppUnless eta_ok eta_msg
+                 , ppUnless ats_ok ats_msg ]
          arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
         eta_msg   = ptext (sLit "cannot eta-reduce the representation type enough")
         ats_msg   = ptext (sLit "the class has associated types")
          arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
         eta_msg   = ptext (sLit "cannot eta-reduce the representation type enough")
         ats_msg   = ptext (sLit "the class has associated types")
diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs

index 073ca25..83f719b 100644 (file)
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -235,7 +235,7 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
     -- is *stable* (i.e. the compiler won't change it later),
     -- because this name will be referred to by the C code stub.
     id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
     -- is *stable* (i.e. the compiler won't change it later),
     -- because this name will be referred to by the C code stub.
     id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
-   return (L loc (VarBind id rhs), ForeignExport (L loc id) undefined spec)
+   return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec)
  tcFExport d = pprPanic "tcFExport" (ppr d)
  \end{code}
  
  tcFExport d = pprPanic "tcFExport" (ppr d)
  \end{code}
  
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs

index 2192531..8bbc27a 100644 (file)
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -566,8 +566,8 @@ gen_Bounded_binds loc tycon
      data_cons = tyConDataCons tycon
  
      ----- enum-flavored: ---------------------------
      data_cons = tyConDataCons tycon
  
      ----- enum-flavored: ---------------------------
-    min_bound_enum = mkVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
-    max_bound_enum = mkVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
+    min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
+    max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
  
      data_con_1   = head data_cons
      data_con_N   = last data_cons
  
      data_con_1   = head data_cons
      data_con_N   = last data_cons
@@ -577,9 +577,9 @@ gen_Bounded_binds loc tycon
      ----- single-constructor-flavored: -------------
      arity         = dataConSourceArity data_con_1
  
      ----- single-constructor-flavored: -------------
      arity         = dataConSourceArity data_con_1
  
-    min_bound_1con = mkVarBind loc minBound_RDR $
+    min_bound_1con = mkHsVarBind loc minBound_RDR $
                      nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
                      nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
-    max_bound_1con = mkVarBind loc maxBound_RDR $
+    max_bound_1con = mkHsVarBind loc maxBound_RDR $
                      nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
  \end{code}
  
                      nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
  \end{code}
  
@@ -808,16 +808,16 @@ gen_Read_binds get_fixity loc tycon
    where
      -----------------------------------------------------------------------
      default_readlist 
    where
      -----------------------------------------------------------------------
      default_readlist 
-       = mkVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)
+       = mkHsVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)
  
      default_readlistprec
  
      default_readlistprec
-       = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
+       = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
      -----------------------------------------------------------------------
  
      data_cons = tyConDataCons tycon
      (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
      
      -----------------------------------------------------------------------
  
      data_cons = tyConDataCons tycon
      (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
      
-    read_prec = mkVarBind loc readPrec_RDR
+    read_prec = mkHsVarBind loc readPrec_RDR
                               (nlHsApp (nlHsVar parens_RDR) read_cons)
  
      read_cons            = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
                               (nlHsApp (nlHsVar parens_RDR) read_cons)
  
      read_cons            = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
@@ -961,7 +961,7 @@ gen_Show_binds get_fixity loc tycon
    = (listToBag [shows_prec, show_list], [])
    where
      -----------------------------------------------------------------------
    = (listToBag [shows_prec, show_list], [])
    where
      -----------------------------------------------------------------------
-    show_list = mkVarBind loc showList_RDR
+    show_list = mkHsVarBind loc showList_RDR
                   (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
      -----------------------------------------------------------------------
      shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
                   (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
      -----------------------------------------------------------------------
      shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
@@ -1616,7 +1616,7 @@ genAuxBind loc (GenTag2Con tycon)
      rdr_name = tag2con_RDR tycon
  
  genAuxBind loc (GenMaxTag tycon)
      rdr_name = tag2con_RDR tycon
  
  genAuxBind loc (GenMaxTag tycon)
-  = mkVarBind loc rdr_name 
+  = mkHsVarBind loc rdr_name 
                   (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
    where
      rdr_name = maxtag_RDR tycon
                   (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
    where
      rdr_name = maxtag_RDR tycon
@@ -1624,16 +1624,16 @@ genAuxBind loc (GenMaxTag tycon)
                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
  
  genAuxBind loc (MkTyCon tycon) --  $dT
                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
  
  genAuxBind loc (MkTyCon tycon) --  $dT
-  = mkVarBind loc (mk_data_type_name tycon)
-                 ( nlHsVar mkDataType_RDR 
+  = mkHsVarBind loc (mk_data_type_name tycon)
+                   ( nlHsVar mkDataType_RDR 
                      `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
                      `nlHsApp` nlList constrs )
    where
      constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
  
  genAuxBind loc (MkDataCon dc)  --  $cT1 etc
                      `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
                      `nlHsApp` nlList constrs )
    where
      constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
  
  genAuxBind loc (MkDataCon dc)  --  $cT1 etc
-  = mkVarBind loc (mk_constr_name dc) 
-                 (nlHsApps mkConstr_RDR constr_args)
+  = mkHsVarBind loc (mk_constr_name dc) 
+                   (nlHsApps mkConstr_RDR constr_args)
    where
      constr_args 
         = [ -- nlHsIntLit (toInteger (dataConTag dc)),    -- Tag
    where
      constr_args 
         = [ -- nlHsIntLit (toInteger (dataConTag dc)),    -- Tag
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs

index fbe3c9f..ee6de33 100644 (file)
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -333,10 +333,10 @@ zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
         ; new_ty    <- zonkTcTypeToType env ty
         ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
  
         ; new_ty    <- zonkTcTypeToType env ty
         ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
  
-zonk_bind env (VarBind { var_id = var, var_rhs = expr })
+zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
    = zonkIdBndr env var                         `thenM` \ new_var ->
      zonkLExpr env expr                 `thenM` \ new_expr ->
    = zonkIdBndr env var                         `thenM` \ new_var ->
      zonkLExpr env expr                 `thenM` \ new_expr ->
-    returnM (VarBind { var_id = new_var, var_rhs = new_expr })
+    returnM (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl })
  
  zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn })
    = wrapLocM (zonkIdBndr env) var      `thenM` \ new_var ->
  
  zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn })
    = wrapLocM (zonkIdBndr env) var      `thenM` \ new_var ->
@@ -365,11 +365,9 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts,
         = zonkIdBndr env global                 `thenM` \ new_global ->
           mapM zonk_prag prags                  `thenM` \ new_prags -> 
           returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
         = zonkIdBndr env global                 `thenM` \ new_global ->
           mapM zonk_prag prags                  `thenM` \ new_prags -> 
           returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
-    zonk_prag prag@(L _ (InlinePrag {}))  = return prag
-    zonk_prag (L loc (SpecPrag expr ty inl))
-       = do { expr' <- zonkExpr env expr 
-            ; ty'   <- zonkTcTypeToType env ty
-            ; return (L loc (SpecPrag expr' ty' inl)) }
+    zonk_prag (L loc (SpecPrag co_fn inl))
+       = do { (_, co_fn') <- zonkCoFn env co_fn
+            ; return (L loc (SpecPrag co_fn' inl)) }
  \end{code}
  
  %************************************************************************
  \end{code}
  
  %************************************************************************
@@ -600,7 +598,6 @@ zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
  -------------------------------------------------------------------------
  zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
  zonkCoFn env WpHole   = return (env, WpHole)
  -------------------------------------------------------------------------
  zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
  zonkCoFn env WpHole   = return (env, WpHole)
-zonkCoFn env WpInline = return (env, WpInline)
  zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
                                     ; (env2, c2') <- zonkCoFn env1 c2
                                     ; return (env2, WpCompose c1' c2') }
  zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
                                     ; (env2, c2') <- zonkCoFn env1 c2
                                     ; return (env2, WpCompose c1' c2') }
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs

index 479bd67..426da52 100644 (file)
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -32,6 +32,8 @@ import TyCon
  import DataCon
  import Class
  import Var
  import DataCon
  import Class
  import Var
+import CoreUnfold ( mkDFunUnfolding )
+import PrelNames  ( inlineIdName )
  import Id
  import MkId
  import Name
  import Id
  import MkId
  import Name
@@ -91,6 +93,7 @@ Running example:
  
         -- A top-level definition for each instance method
         -- Here op1_i, op2_i are the "instance method Ids"
  
         -- A top-level definition for each instance method
         -- Here op1_i, op2_i are the "instance method Ids"
+       -- The INLINE pragma comes from the user pragma
         {-# INLINE [2] op1_i #-}  -- From the instance decl bindings
         op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
         op1_i = /\a. \(d:C a). 
         {-# INLINE [2] op1_i #-}  -- From the instance decl bindings
         op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
         op1_i = /\a. \(d:C a). 
@@ -109,14 +112,16 @@ Running example:
         op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) 
  
         -- The dictionary function itself
         op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) 
  
         -- The dictionary function itself
-       {-# INLINE df_i #-}     -- Always inline dictionary functions
+       {-# NOINLINE CONLIKE df_i #-}   -- Never inline dictionary functions
         df_i :: forall a. C a -> C [a]
         df_i :: forall a. C a -> C [a]
-       df_i = /\a. \d:C a. letrec d' = MkC (op1_i  a   d)
-                                            ($dmop2 [a] d')
-                           in d'
+       df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)
                 -- But see Note [Default methods in instances]
                 -- We can't apply the type checker to the default-method call
  
                 -- But see Note [Default methods in instances]
                 -- We can't apply the type checker to the default-method call
  
+        -- Use a RULE to short-circuit applications of the class ops
+       {-# RULE "op1@C[a]" forall a, d:C a. 
+                            op1 [a] (df_i d) = op1_i a d #-}
+
  * The dictionary function itself is inlined as vigorously as we
    possibly can, so that we expose that dictionary constructor to
    selectors as much as poss.  That is why the op_i stuff is in 
  * The dictionary function itself is inlined as vigorously as we
    possibly can, so that we expose that dictionary constructor to
    selectors as much as poss.  That is why the op_i stuff is in 
@@ -180,7 +185,7 @@ to have C [a] available.  That is why we have the strange local
  definition for 'this' in the definition of op1_i in the example above.
  We can typecheck the defintion of local_op1, and when doing tcSimplifyCheck
  we supply 'this' as a given dictionary.  Only needed, though, if there
  definition for 'this' in the definition of op1_i in the example above.
  We can typecheck the defintion of local_op1, and when doing tcSimplifyCheck
  we supply 'this' as a given dictionary.  Only needed, though, if there
-are some type variales involved; otherwise there can be no overlap and
+are some type variables involved; otherwise there can be no overlap and
  none of this arises.
  
  Note [Tricky type variable scoping]
  none of this arises.
  
  Note [Tricky type variable scoping]
@@ -551,18 +556,19 @@ tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
  
  tcInstDecls2 tycl_decls inst_decls
    = do  { -- (a) Default methods from class decls
  
  tcInstDecls2 tycl_decls inst_decls
    = do  { -- (a) Default methods from class decls
-          (dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $
-                                    filter (isClassDecl.unLoc) tycl_decls
-        ; tcExtendIdEnv (concat dm_ids_s) $ do
+          let class_decls = filter (isClassDecl . unLoc) tycl_decls
+        ; (dm_ids_s, dm_binds_s) <- mapAndUnzipM tcClassDecl2 class_decls
+                                    
+       ; tcExtendIdEnv (concat dm_ids_s) $ do 
  
            -- (b) instance declarations
  
            -- (b) instance declarations
-        ; inst_binds_s <- mapM tcInstDecl2 inst_decls
+        { inst_binds_s <- mapM tcInstDecl2 inst_decls
  
            -- Done
          ; let binds = unionManyBags dm_binds_s `unionBags`
                        unionManyBags inst_binds_s
          ; tcl_env <- getLclEnv -- Default method Ids in here
  
            -- Done
          ; let binds = unionManyBags dm_binds_s `unionBags`
                        unionManyBags inst_binds_s
          ; tcl_env <- getLclEnv -- Default method Ids in here
-        ; return (binds, tcl_env) }
+        ; return (binds, tcl_env) } }
  
  tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
  tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
  
  tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
  tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
@@ -571,8 +577,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
      addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ 
      tc_inst_decl2 dfun_id ibinds
   where
      addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ 
      tc_inst_decl2 dfun_id ibinds
   where
-        dfun_id    = instanceDFunId ispec
-        loc        = getSrcSpan dfun_id
+    dfun_id = instanceDFunId ispec
+    loc     = getSrcSpan dfun_id
  \end{code}
  
  
  \end{code}
  
  
@@ -661,7 +667,7 @@ tc_inst_decl2 dfun_id (NewTypeDerived coi)
          ; let coerced_rep_dict = wrapId wrapper (instToId rep_dict)
  
          ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
          ; let coerced_rep_dict = wrapId wrapper (instToId rep_dict)
  
          ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
-        ; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body)
+       ; let dict_bind = mkVarBind (instToId this_dict) (noLoc body)
  
          ; return (unitBag $ noLoc $
                    AbsBinds inst_tvs' (map instToVar dfun_dicts)
  
          ; return (unitBag $ noLoc $
                    AbsBinds inst_tvs' (map instToVar dfun_dicts)
@@ -708,6 +714,7 @@ tc_inst_decl2 dfun_id (NewTypeDerived coi)
  tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
    = do { let rigid_info = InstSkol
               inst_ty    = idType dfun_id
  tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
    = do { let rigid_info = InstSkol
               inst_ty    = idType dfun_id
+             loc        = getSrcSpan dfun_id
  
          -- Instantiate the instance decl with skolem constants
         ; (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty
  
          -- Instantiate the instance decl with skolem constants
         ; (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty
@@ -716,69 +723,67 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
                  -- bizarre, but OK so long as you realise it!
         ; let
              (clas, inst_tys') = tcSplitDFunHead inst_head'
                  -- bizarre, but OK so long as you realise it!
         ; let
              (clas, inst_tys') = tcSplitDFunHead inst_head'
-            (class_tyvars, sc_theta, _, op_items) = classBigSig clas
+            (class_tyvars, sc_theta, sc_sels, op_items) = classBigSig clas
  
               -- Instantiate the super-class context with inst_tys
              sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
              origin    = SigOrigin rigid_info
  
           -- Create dictionary Ids from the specified instance contexts.
  
               -- Instantiate the super-class context with inst_tys
              sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
              origin    = SigOrigin rigid_info
  
           -- Create dictionary Ids from the specified instance contexts.
-       ; sc_loc     <- getInstLoc InstScOrigin
-       ; sc_dicts   <- newDictOccs sc_loc sc_theta'            -- These are wanted
         ; inst_loc   <- getInstLoc origin
         ; dfun_dicts <- newDictBndrs inst_loc dfun_theta'       -- Includes equalities
         ; this_dict  <- newDictBndr inst_loc (mkClassPred clas inst_tys')
         ; inst_loc   <- getInstLoc origin
         ; dfun_dicts <- newDictBndrs inst_loc dfun_theta'       -- Includes equalities
         ; this_dict  <- newDictBndr inst_loc (mkClassPred clas inst_tys')
-
                  -- Default-method Ids may be mentioned in synthesised RHSs,
                  -- but they'll already be in the environment.
  
                  -- Default-method Ids may be mentioned in synthesised RHSs,
                  -- but they'll already be in the environment.
  
-        -- Typecheck the methods
-       ; let this_dict_id  = instToId this_dict
+       
+       -- Cook up a binding for "this = df d1 .. dn",
+       -- to use in each method binding
+       -- Need to clone the dict in case it is floated out, and
+       -- then clashes with its friends
+       ; cloned_this <- cloneDict this_dict
+       ; let cloned_this_bind = mkVarBind (instToId cloned_this) $ 
+                               L loc $ wrapId app_wrapper dfun_id
+            app_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars')
              dfun_lam_vars = map instToVar dfun_dicts   -- Includes equalities
              dfun_lam_vars = map instToVar dfun_dicts   -- Includes equalities
-            prag_fn    = mkPragFun uprags 
-             loc        = getSrcSpan dfun_id
-            tc_meth    = tcInstanceMethod loc standalone_deriv 
-                                 clas inst_tyvars' dfun_dicts
-                                dfun_theta' inst_tys'
-                                this_dict dfun_id
-                                prag_fn monobinds
-       ; (meth_exprs, meth_binds) <- tcExtendTyVarEnv inst_tyvars'  $
-                                    mapAndUnzipM tc_meth op_items 
+            nested_this_pair 
+               | null inst_tyvars' && null dfun_theta' = (this_dict, emptyBag)
+               | otherwise = (cloned_this, unitBag cloned_this_bind)
+
+       -- Deal with 'SPECIALISE instance' pragmas
+       -- See Note [SPECIALISE instance pragmas]
+       ; let spec_inst_sigs = filter isSpecInstLSig uprags
+                    -- The filter removes the pragmas for methods
+       ; spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) spec_inst_sigs
+
+        -- Typecheck the methods
+       ; let prag_fn = mkPragFun uprags 
+             tc_meth = tcInstanceMethod loc standalone_deriv
+                                        clas inst_tyvars'
+                                       dfun_dicts inst_tys'
+                                       nested_this_pair 
+                                       prag_fn spec_inst_prags monobinds
+
+       ; (meth_ids, meth_binds) <- tcExtendTyVarEnv inst_tyvars' $
+                                  mapAndUnzipM tc_meth op_items 
  
           -- Figure out bindings for the superclass context
  
           -- Figure out bindings for the superclass context
-         -- Don't include this_dict in the 'givens', else
-         -- sc_dicts get bound by just selecting  from this_dict!!
-       ; sc_binds <- addErrCtxt superClassCtxt $
-                     tcSimplifySuperClasses inst_loc this_dict dfun_dicts sc_dicts
-               -- Note [Recursive superclasses]
+       ; sc_loc   <- getInstLoc InstScOrigin
+       ; sc_dicts <- newDictOccs sc_loc sc_theta'              -- These are wanted
+       ; let tc_sc = tcSuperClass inst_loc inst_tyvars' dfun_dicts nested_this_pair
+       ; (sc_ids, sc_binds) <- mapAndUnzipM tc_sc (sc_sels `zip` sc_dicts)
  
  
-       -- It's possible that the superclass stuff might unified something
-       -- in the envt with one of the inst_tyvars'
+       -- It's possible that the superclass stuff might unified
+       -- something in the envt with one of the inst_tyvars'
         ; checkSigTyVars inst_tyvars'
  
         ; checkSigTyVars inst_tyvars'
  
-       -- Deal with 'SPECIALISE instance' pragmas
-       ;  prags <- tcPrags dfun_id (filter isSpecInstLSig uprags)
-
         -- Create the result bindings
         ; let dict_constr   = classDataCon clas
         -- Create the result bindings
         ; let dict_constr   = classDataCon clas
-             inline_prag | null dfun_dicts  = []
-                         | otherwise        = [L loc (InlinePrag (alwaysInlineSpec FunLike))]
-                     -- Always inline the dfun; this is an experimental decision
-                     -- because it makes a big performance difference sometimes.
-                     -- Often it means we can do the method selection, and then
-                     -- inline the method as well.  Marcin's idea; see comments below.
-                     --
-                     -- BUT: don't inline it if it's a constant dictionary;
-                     -- we'll get all the benefit without inlining, and we get
-                     -- a **lot** of code duplication if we inline it
-                     --
-                     --      See Note [Inline dfuns] below
-
-             sc_dict_vars  = map instToVar sc_dicts
-             dict_bind     = L loc (VarBind this_dict_id dict_rhs)
-             dict_rhs      = foldl (\ f a -> L loc (HsApp f (L loc a))) inst_constr meth_exprs
-            inst_constr   = L loc $ wrapId (mkWpApps sc_dict_vars <.> mkWpTyApps inst_tys')
-                                      (dataConWrapId dict_constr)
+             this_dict_id  = instToId this_dict
+            dict_bind     = mkVarBind this_dict_id dict_rhs
+             dict_rhs      = foldl mk_app inst_constr (sc_ids ++ meth_ids)
+            inst_constr   = L loc $ wrapId (mkWpTyApps inst_tys')
+                                           (dataConWrapId dict_constr)
                       -- We don't produce a binding for the dict_constr; instead we
                       -- rely on the simplifier to unfold this saturated application
                       -- We do this rather than generate an HsCon directly, because
                       -- We don't produce a binding for the dict_constr; instead we
                       -- rely on the simplifier to unfold this saturated application
                       -- We do this rather than generate an HsCon directly, because
@@ -786,15 +791,57 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
                       -- member) are dealt with by the common MkId.mkDataConWrapId code rather
                       -- than needing to be repeated here.
  
                       -- member) are dealt with by the common MkId.mkDataConWrapId code rather
                       -- than needing to be repeated here.
  
+            mk_app :: LHsExpr Id -> Id -> LHsExpr Id
+            mk_app fun arg_id = L loc (HsApp fun (L loc (wrapId arg_wrapper arg_id)))
+            arg_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars')
+
+             dfun_id_w_fun = dfun_id 
+                             `setIdUnfolding` mkDFunUnfolding dict_constr (sc_ids ++ meth_ids)
+                             `setInlinePragma` dfunInlinePragma
  
               main_bind = noLoc $ AbsBinds
                                   inst_tyvars'
                                   dfun_lam_vars
  
               main_bind = noLoc $ AbsBinds
                                   inst_tyvars'
                                   dfun_lam_vars
-                                 [(inst_tyvars', dfun_id, this_dict_id, inline_prag ++ prags)]
-                                 (dict_bind `consBag` sc_binds)
+                                 [(inst_tyvars', dfun_id_w_fun, this_dict_id, spec_inst_prags)]
+                                 (unitBag dict_bind)
  
         ; showLIE (text "instance")
  
         ; showLIE (text "instance")
-       ; return (main_bind `consBag` unionManyBags meth_binds) }
+       ; return (unitBag main_bind    `unionBags` 
+                listToBag meth_binds `unionBags` 
+                 listToBag sc_binds) }
+
+
+------------------------------
+tcSuperClass :: InstLoc -> [TyVar] -> [Inst]
+            -> (Inst, LHsBinds Id)
+            -> (Id, Inst) -> TcM (Id, LHsBind Id)
+-- Build a top level decl like
+--     sc_op = /\a \d. let this = ... in 
+--                     let sc = ... in
+--                     sc
+-- The "this" part is just-in-case (discarded if not used)
+-- See Note [Recursive superclasses]
+tcSuperClass inst_loc tyvars dicts (this_dict, this_bind)
+            (sc_sel, sc_dict)
+  = addErrCtxt superClassCtxt $
+    do { sc_binds <- tcSimplifySuperClasses inst_loc 
+                               this_dict dicts [sc_dict]
+         -- Don't include this_dict in the 'givens', else
+         -- sc_dicts get bound by just selecting  from this_dict!!
+
+       ; uniq <- newUnique
+       ; let sc_op_ty = mkSigmaTy tyvars (map dictPred dicts) 
+                                 (mkPredTy (dictPred sc_dict))
+            sc_op_name = mkDerivedInternalName mkClassOpAuxOcc uniq
+                                               (getName sc_sel)
+            sc_op_id   = mkLocalId sc_op_name sc_op_ty
+            sc_id      = instToVar sc_dict
+            sc_op_bind = AbsBinds tyvars 
+                            (map instToVar dicts) 
+                             [(tyvars, sc_op_id, sc_id, [])]
+                             (this_bind `unionBags` sc_binds)
+
+       ; return (sc_op_id, noLoc sc_op_bind) }
  \end{code}
  
  Note [Recursive superclasses]
  \end{code}
  
  Note [Recursive superclasses]
@@ -805,6 +852,62 @@ get satisfied by selection from this_dict, and that leads to an immediate
  loop.  What we need is to add this_dict to Avails without adding its 
  superclasses, and we currently have no way to do that.
  
  loop.  What we need is to add this_dict to Avails without adding its 
  superclasses, and we currently have no way to do that.
  
+Note [SPECIALISE instance pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+   instance (Ix a, Ix b) => Ix (a,b) where
+     {-# SPECIALISE instance Ix (Int,Int) #-}
+     range (x,y) = ...
+
+We do *not* want to make a specialised version of the dictionary
+function.  Rather, we want specialised versions of each method.
+Thus we should generate something like this:
+
+  $dfIx :: (Ix a, Ix x) => Ix (a,b)
+  {- DFUN [$crange, ...] -}
+  $dfIx da db = Ix ($crange da db) (...other methods...)
+
+  $dfIxPair :: (Ix a, Ix x) => Ix (a,b)
+  {- DFUN [$crangePair, ...] -}
+  $dfIxPair = Ix ($crangePair da db) (...other methods...)
+
+  $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
+  {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
+  $crange da db = <blah>
+
+  {-# RULE  range ($dfIx da db) = $crange da db #-}
+
+Note that  
+
+  * The RULE is unaffected by the specialisation.  We don't want to
+    specialise $dfIx, because then it would need a specialised RULE
+    which is a pain.  The single RULE works fine at all specialisations.
+    See Note [How instance declarations are translated] above
+
+  * Instead, we want to specialise the *method*, $crange
+
+In practice, rather than faking up a SPECIALISE pragama for each
+method (which is painful, since we'd have to figure out its
+specialised type), we call tcSpecPrag *as if* were going to specialise
+$dfIx -- you can see that in the call to tcSpecInst.  That generates a
+SpecPrag which, as it turns out, can be used unchanged for each method.
+The "it turns out" bit is delicate, but it works fine!
+
+\begin{code}
+tcSpecInst :: Id -> Sig Name -> TcM SpecPrag
+tcSpecInst dfun_id prag@(SpecInstSig hs_ty) 
+  = addErrCtxt (spec_ctxt prag) $
+    do  { let name = idName dfun_id
+        ; (tyvars, theta, tau) <- tcHsInstHead hs_ty   
+        ; let spec_ty = mkSigmaTy tyvars theta tau
+        ; co_fn <- tcSubExp (SpecPragOrigin name) (idType dfun_id) spec_ty
+        ; return (SpecPrag co_fn defaultInlinePragma) }
+  where
+    spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
+
+tcSpecInst _  _ = panic "tcSpecInst"
+\end{code}
  
  %************************************************************************
  %*                                                                      *
  
  %************************************************************************
  %*                                                                      *
@@ -822,93 +925,118 @@ tcInstanceMethod
  
  \begin{code}
  tcInstanceMethod :: SrcSpan -> Bool -> Class -> [TcTyVar] -> [Inst]
  
  \begin{code}
  tcInstanceMethod :: SrcSpan -> Bool -> Class -> [TcTyVar] -> [Inst]
-                -> TcThetaType -> [TcType]
-                -> Inst -> Id
-                -> TcPragFun -> LHsBinds Name 
+                -> [TcType]
+                -> (Inst, LHsBinds Id)  -- "This" and its binding
+                -> TcPragFun            -- Local prags
+                -> [LSpecPrag]          -- Arising from 'SPECLALISE instance'
+                 -> LHsBinds Name 
                  -> (Id, DefMeth)
                  -> (Id, DefMeth)
-                -> TcM (HsExpr Id, LHsBinds Id)
+                -> TcM (Id, LHsBind Id)
         -- The returned inst_meth_ids all have types starting
         --      forall tvs. theta => ...
  
         -- The returned inst_meth_ids all have types starting
         --      forall tvs. theta => ...
  
-tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts theta inst_tys 
-                this_dict dfun_id prag_fn binds_in (sel_id, dm_info)
-  = do { cloned_this <- cloneDict this_dict
-               -- Need to clone the dict in case it is floated out, and
-               -- then clashes with its friends
-       ; uniq1 <- newUnique
-       ; let local_meth_name = mkInternalName uniq1 sel_occ loc   -- Same OccName
-             this_dict_bind  = L loc $ VarBind (instToId cloned_this) $ 
-                               L loc $ wrapId meth_wrapper dfun_id
-             mb_this_bind | null tyvars = Nothing
-                          | otherwise   = Just (cloned_this, this_dict_bind)
-               -- Only need the this_dict stuff if there are type variables
-               -- involved; otherwise overlap is not possible
-               -- See Note [Subtle interaction of recursion and overlap]       
-
+tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts inst_tys 
+                (this_dict, this_dict_bind)
+                prag_fn spec_inst_prags binds_in (sel_id, dm_info)
+  = do  { uniq <- newUnique
+       ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
+        ; local_meth_name <- newLocalName sel_name
+         -- Base the local_meth_name on the selector name, becuase
+         -- type errors from tcInstanceMethodBody come from here
+
+        ; let local_meth_ty = instantiateMethod clas sel_id inst_tys
+             meth_ty = mkSigmaTy tyvars (map dictPred dfun_dicts) local_meth_ty
+             meth_id       = mkLocalId meth_name meth_ty
+              local_meth_id = mkLocalId local_meth_name local_meth_ty
+
+           --------------
               tc_body rn_bind 
                  = add_meth_ctxt rn_bind $
               tc_body rn_bind 
                  = add_meth_ctxt rn_bind $
-                  do { (meth_id, tc_binds) <- tcInstanceMethodBody 
-                                               InstSkol clas tyvars dfun_dicts theta inst_tys
-                                               mb_this_bind sel_id 
-                                               local_meth_name
-                                               meth_sig_fn meth_prag_fn rn_bind
-                    ; return (wrapId meth_wrapper meth_id, tc_binds) }
-
-       ; case (findMethodBind sel_name local_meth_name binds_in, dm_info) of
-               -- There is a user-supplied method binding, so use it
-           (Just user_bind, _) -> tc_body user_bind
-
+                  do { (meth_id1, spec_prags) <- tcPrags NonRecursive False True 
+                                                    meth_id (prag_fn sel_name)
+                     ; tcInstanceMethodBody (instLoc this_dict)
+                                    tyvars dfun_dicts
+                                   ([this_dict], this_dict_bind)
+                                    meth_id1 local_meth_id
+                                   meth_sig_fn 
+                                    (spec_inst_prags ++ spec_prags) 
+                                    rn_bind }
+
+           --------------
+             tc_default :: DefMeth -> TcM (Id, LHsBind Id)
                 -- The user didn't supply a method binding, so we have to make 
                 -- up a default binding, in a way depending on the default-method info
  
                 -- The user didn't supply a method binding, so we have to make 
                 -- up a default binding, in a way depending on the default-method info
  
-           (Nothing, GenDefMeth) -> do         -- Derivable type classes stuff
-                       { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id local_meth_name
-                       ; tc_body meth_bind }
-
-           (Nothing, NoDefMeth) -> do          -- No default method in the class
-                       { warn <- doptM Opt_WarnMissingMethods          
-                        ; warnTc (warn  -- Warn only if -fwarn-missing-methods
-                                 && not (startsWithUnderscore (getOccName sel_id)))
-                                       -- Don't warn about _foo methods
-                                omitted_meth_warn
-                       ; return (error_rhs, emptyBag) }
-
-           (Nothing, DefMeth) -> do    -- An polymorphic default method
-                       {   -- Build the typechecked version directly, 
-                           -- without calling typecheck_method; 
-                           -- see Note [Default methods in instances]
-                         dm_name <- lookupGlobalOccRn (mkDefMethRdrName sel_name)
+              tc_default NoDefMeth         -- No default method at all
+               = do { warnMissingMethod sel_id
+                    ; return (meth_id, mkVarBind meth_id $ 
+                                        mkLHsWrap lam_wrapper error_rhs) }
+             
+             tc_default GenDefMeth    -- Derivable type classes stuff
+                = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id local_meth_name
+                     ; tc_body meth_bind }
+                 
+             tc_default DefMeth        -- An polymorphic default method
+               = do {   -- Build the typechecked version directly, 
+                        -- without calling typecheck_method; 
+                        -- see Note [Default methods in instances]
+                        -- Generate   /\as.\ds. let this = df as ds 
+                         --                      in $dm inst_tys this
+                        -- The 'let' is necessary only because HsSyn doesn't allow
+                        -- you to apply a function to a dictionary *expression*.
+                      dm_name <- lookupGlobalOccRn (mkDefMethRdrName sel_name)
                                         -- Might not be imported, but will be an OrigName
                                         -- Might not be imported, but will be an OrigName
-                       ; dm_id   <- tcLookupId dm_name
-                       ; return (wrapId dm_wrapper dm_id, emptyBag) } }
+                    ; dm_id <- tcLookupId dm_name
+                    ; inline_id <- tcLookupId inlineIdName
+                     ; let dm_inline_prag = idInlinePragma dm_id
+                           dm_app = HsWrap (WpApp (instToId this_dict) <.> mkWpTyApps inst_tys) $
+                                   HsVar dm_id 
+                           rhs | isInlinePragma dm_inline_prag  -- See Note [INLINE and default methods]
+                               = HsApp (L loc (HsWrap (WpTyApp local_meth_ty) (HsVar inline_id)))
+                                       (L loc dm_app)
+                               | otherwise = dm_app
+
+                          meth_bind = L loc $ VarBind { var_id = local_meth_id
+                                                       , var_rhs = L loc rhs 
+                                                      , var_inline = False }
+                           meth_id1 = meth_id `setInlinePragma` dm_inline_prag
+                                   -- Copy the inline pragma (if any) from the default
+                                   -- method to this version. Note [INLINE and default methods]
+                                   
+                           bind = AbsBinds { abs_tvs = tyvars, abs_dicts =  dfun_lam_vars
+                                           , abs_exports = [( tyvars, meth_id1
+                                                            , local_meth_id, spec_inst_prags)]
+                                           , abs_binds = this_dict_bind `unionBags` unitBag meth_bind }
+                    -- Default methods in an instance declaration can't have their own 
+                    -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
+                    -- currently they are rejected with 
+                    --           "INLINE pragma lacks an accompanying binding"
+
+                    ; return (meth_id1, L loc bind) } 
+
+        ; case findMethodBind sel_name local_meth_name binds_in of
+           Just user_bind -> tc_body user_bind    -- User-supplied method binding
+           Nothing        -> tc_default dm_info   -- None supplied
+       }
    where
      sel_name = idName sel_id
    where
      sel_name = idName sel_id
-    sel_occ  = nameOccName sel_name
-    this_dict_id = instToId this_dict
-
-    meth_prag_fn _ = prag_fn sel_name
-    meth_sig_fn _  = Just []   -- The 'Just' says "yes, there's a type sig"
-                       -- But there are no scoped type variables from local_method_id
-                       -- Only the ones from the instance decl itself, which are already
-                       -- in scope.  Example:
-                       --      class C a where { op :: forall b. Eq b => ... }
-                       --      instance C [c] where { op = <rhs> }
-                       -- In <rhs>, 'c' is scope but 'b' is not!
-
-    error_rhs    = HsApp error_fun error_msg
+
+    meth_sig_fn _ = Just []    -- The 'Just' says "yes, there's a type sig"
+       -- But there are no scoped type variables from local_method_id
+       -- Only the ones from the instance decl itself, which are already
+       -- in scope.  Example:
+       --      class C a where { op :: forall b. Eq b => ... }
+       --      instance C [c] where { op = <rhs> }
+       -- In <rhs>, 'c' is scope but 'b' is not!
+
+    error_rhs    = L loc $ HsApp error_fun error_msg
      error_fun    = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
      error_msg    = L loc (HsLit (HsStringPrim (mkFastString error_string)))
      meth_tau     = funResultTy (applyTys (idType sel_id) inst_tys)
      error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
  
      error_fun    = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
      error_msg    = L loc (HsLit (HsStringPrim (mkFastString error_string)))
      meth_tau     = funResultTy (applyTys (idType sel_id) inst_tys)
      error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
  
-    dm_wrapper   = WpApp this_dict_id <.> mkWpTyApps inst_tys 
-
-    omitted_meth_warn :: SDoc
-    omitted_meth_warn = ptext (sLit "No explicit method nor default method for")
-                        <+> quotes (ppr sel_id)
-
      dfun_lam_vars = map instToVar dfun_dicts
      dfun_lam_vars = map instToVar dfun_dicts
-    meth_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys tyvars)
+    lam_wrapper   = mkWpTyLams tyvars <.> mkWpLams dfun_lam_vars
  
         -- For instance decls that come from standalone deriving clauses
         -- we want to print out the full source code if there's an error
  
         -- For instance decls that come from standalone deriving clauses
         -- we want to print out the full source code if there's an error
@@ -925,29 +1053,89 @@ derivBindCtxt clas tys bind
     = vcat [ ptext (sLit "When typechecking a standalone-derived method for")
             <+> quotes (pprClassPred clas tys) <> colon
           , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
     = vcat [ ptext (sLit "When typechecking a standalone-derived method for")
             <+> quotes (pprClassPred clas tys) <> colon
           , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
+
+warnMissingMethod :: Id -> TcM ()
+warnMissingMethod sel_id
+  = do { warn <- doptM Opt_WarnMissingMethods          
+       ; warnTc (warn  -- Warn only if -fwarn-missing-methods
+                 && not (startsWithUnderscore (getOccName sel_id)))
+                                       -- Don't warn about _foo methods
+               (ptext (sLit "No explicit method nor default method for")
+                 <+> quotes (ppr sel_id)) }
  \end{code}
  
  \end{code}
  
+Note [Export helper functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We arrange to export the "helper functions" of an instance declaration,
+so that they are not subject to preInlineUnconditionally, even if their
+RHS is trivial.  Reason: they are mentioned in the DFunUnfolding of
+the dict fun as Ids, not as CoreExprs, so we can't substitute a 
+non-variable for them.
+
+We could change this by making DFunUnfoldings have CoreExprs, but it
+seems a bit simpler this way.
+
  Note [Default methods in instances]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  Consider this
  
     class Baz v x where
        foo :: x -> x
  Note [Default methods in instances]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  Consider this
  
     class Baz v x where
        foo :: x -> x
-      foo y = y
+      foo y = <blah>
  
     instance Baz Int Int
  
  From the class decl we get
  
     $dmfoo :: forall v x. Baz v x => x -> x
  
     instance Baz Int Int
  
  From the class decl we get
  
     $dmfoo :: forall v x. Baz v x => x -> x
+   $dmfoo y = <blah>
  
  Notice that the type is ambiguous.  That's fine, though. The instance decl generates
  
  
  Notice that the type is ambiguous.  That's fine, though. The instance decl generates
  
-   $dBazIntInt = MkBaz ($dmfoo Int Int $dBazIntInt)
+   $dBazIntInt = MkBaz fooIntInt
+   fooIntInt = $dmfoo Int Int $dBazIntInt
+
+BUT this does mean we must generate the dictionary translation of
+fooIntInt directly, rather than generating source-code and
+type-checking it.  That was the bug in Trac #1061. In any case it's
+less work to generate the translated version!
+
+Note [INLINE and default methods]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We *copy* any INLINE pragma from the default method to the instance.
+Example:
+  class Foo a where
+    op1, op2 :: Bool -> a -> a
+
+    {-# INLINE op1 #-}
+    op1 b x = op2 (not b) x
+
+  instance Foo Int where
+    op2 b x = <blah>
+
+Then we generate:
+
+  {-# INLINE $dmop1 #-}
+  $dmop1 d b x = op2 d (not b) x
+
+  $fFooInt = MkD $cop1 $cop2
+
+  {-# INLINE $cop1 #-}
+  $cop1 = inline $dmop1 $fFooInt
+
+  $cop2 = <blah>
+
+Note carefully:
+  a) We copy $dmop1's inline pragma to $cop1.  Otherwise 
+     we'll just inline the former in the latter and stop, which 
+     isn't what the user expected
+
+  b) We use the magic 'inline' Id to ensure that $dmop1 really is
+     inlined in $cop1, even though the latter itself has an INLINE pragma
+     That is important to allow the mutual recursion between $fooInt and
+     $cop1 to be broken
  
  
-BUT this does mean we must generate the dictionary translation directly, rather
-than generating source-code and type-checking it.  That was the bug ing
-Trac #1061. In any case it's less work to generate the translated version!
+This is all regrettably delicate.
  
  
  %************************************************************************
  
  
  %************************************************************************
@@ -967,7 +1155,7 @@ instDeclCtxt2 :: Type -> SDoc
  instDeclCtxt2 dfun_ty
    = inst_decl_ctxt (ppr (mkClassPred cls tys))
    where
  instDeclCtxt2 dfun_ty
    = inst_decl_ctxt (ppr (mkClassPred cls tys))
    where
-    (_,_,cls,tys) = tcSplitDFunTy dfun_ty
+    (_,cls,tys) = tcSplitDFunTy dfun_ty
  
  inst_decl_ctxt :: SDoc -> SDoc
  inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
  
  inst_decl_ctxt :: SDoc -> SDoc
  inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs

index f7acc19..5a669b4 100644 (file)
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -555,6 +555,15 @@ checkHiBootIface
                 -- Check the exports of the boot module, one by one
         ; mapM_ check_export boot_exports
  
                 -- Check the exports of the boot module, one by one
         ; mapM_ check_export boot_exports
  
+               -- Check instance declarations
+       ; mb_dfun_prs <- mapM check_inst boot_insts
+       ; let tcg_env' = tcg_env { tcg_binds    = binds `unionBags` dfun_binds,
+                                  tcg_type_env = extendTypeEnvWithIds local_type_env boot_dfuns }
+             dfun_prs   = catMaybes mb_dfun_prs
+             boot_dfuns = map fst dfun_prs
+             dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
+                                    | (boot_dfun, dfun) <- dfun_prs ]
+
                 -- Check for no family instances
         ; unless (null boot_fam_insts) $
             panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
                 -- Check for no family instances
         ; unless (null boot_fam_insts) $
             panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
@@ -569,7 +578,7 @@ checkHiBootIface
               final_type_env = extendTypeEnvWithIds local_type_env boot_dfuns
               dfun_prs   = catMaybes mb_dfun_prs
               boot_dfuns = map fst dfun_prs
               final_type_env = extendTypeEnvWithIds local_type_env boot_dfuns
               dfun_prs   = catMaybes mb_dfun_prs
               boot_dfuns = map fst dfun_prs
-             dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun)
+             dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
                                      | (boot_dfun, dfun) <- dfun_prs ]
  
          ; failIfErrsM
                                      | (boot_dfun, dfun) <- dfun_prs ]
  
          ; failIfErrsM
@@ -929,7 +938,7 @@ check_main dflags tcg_env
                                                     (mkTyConApp ioTyCon [res_ty])
               ; co  = mkWpTyApps [res_ty]
               ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
                                                     (mkTyConApp ioTyCon [res_ty])
               ; co  = mkWpTyApps [res_ty]
               ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
-             ; main_bind = noLoc (VarBind root_main_id rhs) }
+             ; main_bind = mkVarBind root_main_id rhs }
  
         ; return (tcg_env { tcg_binds = tcg_binds tcg_env 
                                         `snocBag` main_bind,
  
         ; return (tcg_env { tcg_binds = tcg_binds tcg_env 
                                         `snocBag` main_bind,
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs

index 2ad5b2f..af99bc2 100644 (file)
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -1018,16 +1018,17 @@ makeImplicationBind loc all_tvs
                      <.> mkWpTyApps eq_cotvs
                      <.> mkWpTyApps (mkTyVarTys all_tvs)
               bind | [dict_irred_id] <- dict_irred_ids  
                      <.> mkWpTyApps eq_cotvs
                      <.> mkWpTyApps (mkTyVarTys all_tvs)
               bind | [dict_irred_id] <- dict_irred_ids  
-                   = VarBind dict_irred_id rhs
+                   = mkVarBind dict_irred_id rhs
                    | otherwise        
                    | otherwise        
-                   = PatBind { pat_lhs = lpat
+                   = L span $ 
+                     PatBind { pat_lhs = lpat
                              , pat_rhs = unguardedGRHSs rhs 
                              , pat_rhs_ty = hsLPatType lpat
                              , bind_fvs = placeHolderNames 
                               }
  
         ; traceTc $ text "makeImplicationBind" <+> ppr implic_inst
                              , pat_rhs = unguardedGRHSs rhs 
                              , pat_rhs_ty = hsLPatType lpat
                              , bind_fvs = placeHolderNames 
                               }
  
         ; traceTc $ text "makeImplicationBind" <+> ppr implic_inst
-       ; return ([implic_inst], unitBag (L span bind)) 
+       ; return ([implic_inst], unitBag bind) 
          }
  
  -----------------------------------------------------------
          }
  
  -----------------------------------------------------------
@@ -2381,11 +2382,7 @@ reduceImplication env
                eq_cotvs = map instToVar extra_eq_givens
               dict_ids = map instToId  extra_dict_givens 
  
                eq_cotvs = map instToVar extra_eq_givens
               dict_ids = map instToId  extra_dict_givens 
  
-                        -- Note [Always inline implication constraints]
-              wrap_inline | null dict_ids = idHsWrapper
-                          | otherwise    = WpInline
-              co         = wrap_inline
-                           <.> mkWpTyLams tvs
+              co         = mkWpTyLams tvs
                             <.> mkWpTyLams eq_cotvs
                             <.> mkWpLams dict_ids
                             <.> WpLet (binds `unionBags` bind)
                             <.> mkWpTyLams eq_cotvs
                             <.> mkWpLams dict_ids
                             <.> WpLet (binds `unionBags` bind)
@@ -2397,12 +2394,15 @@ reduceImplication env
                             . filter (not . isEqInst) 
                             $ wanteds
                payload    = mkBigLHsTup dict_bndrs
                             . filter (not . isEqInst) 
                             $ wanteds
                payload    = mkBigLHsTup dict_bndrs
-
         
         ; traceTc (vcat [text "reduceImplication" <+> ppr name,
                          ppr simpler_implic_insts,
                          text "->" <+> ppr rhs])
         
         ; traceTc (vcat [text "reduceImplication" <+> ppr name,
                          ppr simpler_implic_insts,
                          text "->" <+> ppr rhs])
-       ; return (unitBag (L loc (VarBind (instToId orig_implic) rhs)),
+       ; return (unitBag (L loc (VarBind { var_id= instToId orig_implic
+                                         , var_rhs = rhs
+                                         , var_inline = notNull dict_ids }
+                               -- See Note [Always inline implication constraints]
+                         )),
                   simpler_implic_insts)
         } 
      }
                   simpler_implic_insts)
         } 
      }
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs

index 71fee4c..dad167c 100644 (file)
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -643,7 +643,6 @@ getDFunTyKey ty                  = pprPanic "getDFunTyKey" (pprType ty)
  These tcSplit functions are like their non-Tc analogues, but
         a) they do not look through newtypes
         b) they do not look through PredTys
  These tcSplit functions are like their non-Tc analogues, but
         a) they do not look through newtypes
         b) they do not look through PredTys
-       c) [future] they ignore usage-type annotations
  
  However, they are non-monadic and do not follow through mutable type
  variables.  It's up to you to make sure this doesn't matter.
  
  However, they are non-monadic and do not follow through mutable type
  variables.  It's up to you to make sure this doesn't matter.
@@ -804,18 +803,29 @@ tcIsTyVarTy :: Type -> Bool
  tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty)
  
  -----------------------
  tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty)
  
  -----------------------
-tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
+tcSplitDFunTy :: Type -> ([TyVar], Class, [Type])
  -- Split the type of a dictionary function
  -- Split the type of a dictionary function
+-- We don't use tcSplitSigmaTy,  because a DFun may (with NDP)
+-- have non-Pred arguments, such as
+--     df :: forall m. (forall b. Eq b => Eq (m b)) -> C m
  tcSplitDFunTy ty 
  tcSplitDFunTy ty 
-  = case tcSplitSigmaTy ty   of { (tvs, theta, tau) ->
-    case tcSplitDFunHead tau of { (clas, tys) -> 
-    (tvs, theta, clas, tys) }}
+  = case tcSplitForAllTys ty                 of { (tvs, rho)  ->
+    case tcSplitDFunHead (drop_pred_tys rho) of { (clas, tys) -> 
+    (tvs, clas, tys) }}
+  where
+    -- Discard the context of the dfun.  This can be a mix of
+    -- coercion and class constraints; or (in the general NDP case)
+    -- some other function argument
+    drop_pred_tys ty | Just ty' <- tcView ty = drop_pred_tys ty'
+    drop_pred_tys (ForAllTy tv ty) = ASSERT( isCoVar tv ) drop_pred_tys ty
+    drop_pred_tys (FunTy _ ty)     = drop_pred_tys ty
+    drop_pred_tys ty               = ty
  
  tcSplitDFunHead :: Type -> (Class, [Type])
  tcSplitDFunHead tau  
    = case tcSplitPredTy_maybe tau of 
         Just (ClassP clas tys) -> (clas, tys)
  
  tcSplitDFunHead :: Type -> (Class, [Type])
  tcSplitDFunHead tau  
    = case tcSplitPredTy_maybe tau of 
         Just (ClassP clas tys) -> (clas, tys)
-       _ -> panic "tcSplitDFunHead"
+       _ -> pprPanic "tcSplitDFunHead" (ppr tau)
  
  tcInstHeadTyNotSynonym :: Type -> Bool
  -- Used in Haskell-98 mode, for the argument types of an instance head
  
  tcInstHeadTyNotSynonym :: Type -> Bool
  -- Used in Haskell-98 mode, for the argument types of an instance head
diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs

index a6ddc3c..b3d8dcc 100644 (file)
--- a/compiler/types/InstEnv.lhs
+++ b/compiler/types/InstEnv.lhs
@@ -116,7 +116,7 @@ setInstanceDFunId ispec dfun
         -- are ok; hence the assert
       ispec { is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys }
     where 
         -- are ok; hence the assert
       ispec { is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys }
     where 
-     (tvs, _, _, tys) = tcSplitDFunTy (idType dfun)
+     (tvs, _, tys) = tcSplitDFunTy (idType dfun)
  
  instanceRoughTcs :: Instance -> [Maybe Name]
  instanceRoughTcs = is_tcs
  
  instanceRoughTcs :: Instance -> [Maybe Name]
  instanceRoughTcs = is_tcs
@@ -140,16 +140,20 @@ pprInstanceHdr :: Instance -> SDoc
  -- Prints the Instance as an instance declaration
  pprInstanceHdr ispec@(Instance { is_flag = flag })
    = ptext (sLit "instance") <+> ppr flag
  -- Prints the Instance as an instance declaration
  pprInstanceHdr ispec@(Instance { is_flag = flag })
    = ptext (sLit "instance") <+> ppr flag
-    <+> sep [pprThetaArrow theta, pprClassPred clas tys]
+    <+> sep [pprThetaArrow theta, ppr res_ty]
    where
    where
-    (_, theta, clas, tys) = instanceHead ispec
+    (_, theta, res_ty) = tcSplitSigmaTy (idType (is_dfun ispec))
         -- Print without the for-all, which the programmer doesn't write
  
  pprInstances :: [Instance] -> SDoc
  pprInstances ispecs = vcat (map pprInstance ispecs)
  
         -- Print without the for-all, which the programmer doesn't write
  
  pprInstances :: [Instance] -> SDoc
  pprInstances ispecs = vcat (map pprInstance ispecs)
  
-instanceHead :: Instance -> ([TyVar], [PredType], Class, [Type])
-instanceHead ispec = tcSplitDFunTy (idType (is_dfun ispec))
+instanceHead :: Instance -> ([TyVar], ThetaType, Class, [Type])
+instanceHead ispec 
+   = (tvs, theta, cls, tys)
+   where
+     (tvs, theta, tau) = tcSplitSigmaTy (idType (is_dfun ispec))
+     (cls, tys) = tcSplitDFunHead tau
  
  mkLocalInstance :: DFunId -> OverlapFlag -> Instance
  -- Used for local instances, where we can safely pull on the DFunId
  
  mkLocalInstance :: DFunId -> OverlapFlag -> Instance
  -- Used for local instances, where we can safely pull on the DFunId
@@ -158,7 +162,7 @@ mkLocalInstance dfun oflag
                 is_tvs = mkVarSet tvs, is_tys = tys,
                 is_cls = className cls, is_tcs = roughMatchTcs tys }
    where
                 is_tvs = mkVarSet tvs, is_tys = tys,
                 is_cls = className cls, is_tcs = roughMatchTcs tys }
    where
-    (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
+    (tvs, cls, tys) = tcSplitDFunTy (idType dfun)
  
  mkImportedInstance :: Name -> [Maybe Name]
                    -> DFunId -> OverlapFlag -> Instance
  
  mkImportedInstance :: Name -> [Maybe Name]
                    -> DFunId -> OverlapFlag -> Instance
@@ -169,7 +173,7 @@ mkImportedInstance cls mb_tcs dfun oflag
                 is_tvs = mkVarSet tvs, is_tys = tys,
                 is_cls = cls, is_tcs = mb_tcs }
    where
                 is_tvs = mkVarSet tvs, is_tys = tys,
                 is_cls = cls, is_tcs = mb_tcs }
    where
-    (tvs, _, _, tys) = tcSplitDFunTy (idType dfun)
+    (tvs, _, tys) = tcSplitDFunTy (idType dfun)
  
  roughMatchTcs :: [Type] -> [Maybe Name]
  roughMatchTcs tys = map rough tys
  
  roughMatchTcs :: [Type] -> [Maybe Name]
  roughMatchTcs tys = map rough tys
diff --git a/compiler/vectorise/VectCore.hs b/compiler/vectorise/VectCore.hs

index c98c03c..d651526 100644 (file)
--- a/compiler/vectorise/VectCore.hs
+++ b/compiler/vectorise/VectCore.hs
@@ -16,9 +16,9 @@ module VectCore (
  #include "HsVersions.h"
  
  import CoreSyn
  #include "HsVersions.h"
  
  import CoreSyn
-import CoreUtils      ( mkInlineMe )
  import Type           ( Type )
  import Var
  import Type           ( Type )
  import Var
+import Outputable
  
  type Vect a = (a,a)
  type VVar   = Vect Var
  
  type Vect a = (a,a)
  type VVar   = Vect Var
@@ -86,3 +86,5 @@ vCaseDEFAULT (vscrut, lscrut) (vbndr, lbndr) vty lty (vbody, lbody)
  vInlineMe :: VExpr -> VExpr
  vInlineMe (vexpr, lexpr) = (mkInlineMe vexpr, mkInlineMe lexpr)
  
  vInlineMe :: VExpr -> VExpr
  vInlineMe (vexpr, lexpr) = (mkInlineMe vexpr, mkInlineMe lexpr)
  
+mkInlineMe :: CoreExpr -> CoreExpr
+mkInlineMe = pprTrace "VectCore.mkInlineMe" (text "Roman: need to replace mkInlineMe with an InlineRule somehow")
diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs

index 7540e1a..7b9ec50 100644 (file)
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -815,6 +815,13 @@ buildPADict vect_tc prepr_tc arr_tc repr
            var  <- newLocalVar name (exprType body)
            return (var, mkInlineMe body)
  
            var  <- newLocalVar name (exprType body)
            return (var, mkInlineMe body)
  
+-- The InlineMe note has gone away.  Instead, you need to use
+-- CoreUnfold.mkInlineRule to make an InlineRule for the thing, and
+-- attach *that* as the unfolding for the dictionary binder
+mkInlineMe :: CoreExpr -> CoreExpr
+mkInlineMe expr = pprTrace "VectType: Roman, you need to use the new InlineRule story" 
+                          (ppr expr) expr
+
  paMethods :: [(FastString, TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr)]
  paMethods = [(fsLit "dictPRepr",    buildPRDict),
               (fsLit "toPRepr",      buildToPRepr),
  paMethods :: [(FastString, TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr)]
  paMethods = [(fsLit "dictPRepr",    buildPRDict),
               (fsLit "toPRepr",      buildToPRepr),
author	simonpj@microsoft.com <unknown>
	Thu, 29 Oct 2009 14:30:51 +0000 (14:30 +0000)
committer	simonpj@microsoft.com <unknown>
	Thu, 29 Oct 2009 14:30:51 +0000 (14:30 +0000)
compiler/basicTypes/BasicTypes.lhs		patch \| blob \| history
compiler/basicTypes/Id.lhs		patch \| blob \| history
compiler/basicTypes/IdInfo.lhs		patch \| blob \| history
compiler/basicTypes/MkId.lhs		patch \| blob \| history
compiler/basicTypes/Name.lhs		patch \| blob \| history
compiler/basicTypes/OccName.lhs		patch \| blob \| history
compiler/coreSyn/CoreArity.lhs		patch \| blob \| history
compiler/coreSyn/CoreFVs.lhs		patch \| blob \| history
compiler/coreSyn/CoreLint.lhs		patch \| blob \| history
compiler/coreSyn/CorePrep.lhs		patch \| blob \| history
compiler/coreSyn/CoreSubst.lhs		patch \| blob \| history
compiler/coreSyn/CoreSyn.lhs		patch \| blob \| history
compiler/coreSyn/CoreTidy.lhs		patch \| blob \| history
compiler/coreSyn/CoreUnfold.lhs		patch \| blob \| history
compiler/coreSyn/CoreUtils.lhs		patch \| blob \| history
compiler/coreSyn/MkExternalCore.lhs		patch \| blob \| history
compiler/coreSyn/PprCore.lhs		patch \| blob \| history
compiler/cprAnalysis/CprAnalyse.lhs		patch \| blob \| history
compiler/deSugar/Desugar.lhs		patch \| blob \| history
compiler/deSugar/DsBinds.lhs		patch \| blob \| history
compiler/deSugar/DsExpr.lhs		patch \| blob \| history
compiler/deSugar/DsForeign.lhs		patch \| blob \| history
compiler/deSugar/DsMeta.hs		patch \| blob \| history
compiler/deSugar/DsMonad.lhs		patch \| blob \| history
compiler/deSugar/Match.lhs		patch \| blob \| history
compiler/hsSyn/Convert.lhs		patch \| blob \| history
compiler/hsSyn/HsBinds.lhs		patch \| blob \| history
compiler/hsSyn/HsUtils.lhs		patch \| blob \| history
compiler/iface/BinIface.hs		patch \| blob \| history
compiler/iface/IfaceSyn.lhs		patch \| blob \| history
compiler/iface/MkIface.lhs		patch \| blob \| history
compiler/iface/TcIface.lhs		patch \| blob \| history
compiler/main/TidyPgm.lhs		patch \| blob \| history
compiler/parser/Parser.y.pp		patch \| blob \| history
compiler/parser/ParserCore.y		patch \| blob \| history
compiler/parser/RdrHsSyn.lhs		patch \| blob \| history
compiler/prelude/PrelRules.lhs		patch \| blob \| history
compiler/simplCore/CSE.lhs		patch \| blob \| history
compiler/simplCore/CoreMonad.lhs		patch \| blob \| history
compiler/simplCore/FloatIn.lhs		patch \| blob \| history
compiler/simplCore/FloatOut.lhs		patch \| blob \| history
compiler/simplCore/OccurAnal.lhs		patch \| blob \| history
compiler/simplCore/SetLevels.lhs		patch \| blob \| history
compiler/simplCore/SimplCore.lhs		patch \| blob \| history
compiler/simplCore/SimplEnv.lhs		patch \| blob \| history
compiler/simplCore/SimplUtils.lhs		patch \| blob \| history
compiler/simplCore/Simplify.lhs		patch \| blob \| history
compiler/specialise/Rules.lhs		patch \| blob \| history
compiler/specialise/Specialise.lhs		patch \| blob \| history
compiler/stranal/DmdAnal.lhs		patch \| blob \| history
compiler/stranal/StrictAnal.lhs		patch \| blob \| history
compiler/stranal/WorkWrap.lhs		patch \| blob \| history
compiler/stranal/WwLib.lhs		patch \| blob \| history
compiler/typecheck/Inst.lhs		patch \| blob \| history
compiler/typecheck/TcBinds.lhs		patch \| blob \| history
compiler/typecheck/TcClassDcl.lhs		patch \| blob \| history
compiler/typecheck/TcDeriv.lhs		patch \| blob \| history
compiler/typecheck/TcForeign.lhs		patch \| blob \| history
compiler/typecheck/TcGenDeriv.lhs		patch \| blob \| history
compiler/typecheck/TcHsSyn.lhs		patch \| blob \| history
compiler/typecheck/TcInstDcls.lhs		patch \| blob \| history
compiler/typecheck/TcRnDriver.lhs		patch \| blob \| history
compiler/typecheck/TcSimplify.lhs		patch \| blob \| history
compiler/typecheck/TcType.lhs		patch \| blob \| history
compiler/types/InstEnv.lhs		patch \| blob \| history
compiler/vectorise/VectCore.hs		patch \| blob \| history
compiler/vectorise/VectType.hs		patch \| blob \| history