The bootstrapping compiler is now required to be > 609

[ghc-hetmet.git] / compiler / specialise / Specialise.lhs

diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index ad641d4..849b600 100644 (file)
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -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      ( isNeverActive, inlinePragmaActivation )

 import Bag
 import Util
 import Outputable
 import Bag
 import Util
 import Outputable

@@ -587,7 +588,7 @@ specProgram us binds = initSM us $
 
 \begin{code}
 specVar :: Subst -> Id -> CoreExpr
 
 \begin{code}
 specVar :: Subst -> Id -> CoreExpr

-specVar subst v = lookupIdSubst subst v
+specVar subst v = lookupIdSubst (text "specVar") subst v

 
 specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
 -- We carry a substitution down:
 
 specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
 -- We carry a substitution down:

@@ -773,6 +774,9 @@ specDefn subst body_uds fn rhs
   |  rhs_tyvars `lengthIs`     n_tyvars -- Rhs of fn's defn has right number of big lambdas
   && rhs_ids    `lengthAtLeast` n_dicts        -- and enough dict args
   && notNull calls_for_me              -- And there are some calls to specialise
   |  rhs_tyvars `lengthIs`     n_tyvars -- Rhs of fn's defn has right number of big lambdas
   && rhs_ids    `lengthAtLeast` n_dicts        -- and enough dict args
   && notNull calls_for_me              -- And there are some calls to specialise

+  && not (isNeverActive (idInlineActivation fn))
+       -- Don't specialise NOINLINE things
+       -- See Note [Auto-specialisation and RULES]

 
 --   && not (certainlyWillInline (idUnfolding fn))     -- And it's not small
 --     See Note [Inline specialisation] for why we do not 
 
 --   && not (certainlyWillInline (idUnfolding fn))     -- And it's not small
 --     See Note [Inline specialisation] for why we do not 

@@ -804,7 +808,7 @@ specDefn subst body_uds fn rhs
     (tyvars, theta, _) = tcSplitSigmaTy fn_type
     n_tyvars          = length tyvars
     n_dicts           = length theta
     (tyvars, theta, _) = tcSplitSigmaTy fn_type
     n_tyvars          = length tyvars
     n_dicts           = length theta

-    inline_act         = idInlineActivation fn
+    inl_act            = inlinePragmaActivation (idInlinePragma fn)

 
        -- Figure out whether the function has an INLINE pragma
        -- See Note [Inline specialisations]
 
        -- Figure out whether the function has an INLINE pragma
        -- See Note [Inline specialisations]

@@ -867,7 +871,7 @@ specDefn subst body_uds fn rhs
                ty_args       = mk_ty_args call_ts
                rhs_subst     = CoreSubst.extendTvSubstList subst spec_tv_binds
 
                ty_args       = mk_ty_args call_ts
                rhs_subst     = CoreSubst.extendTvSubstList subst spec_tv_binds
 

-          ; (rhs_subst1, inst_dict_ids) <- cloneDictBndrs rhs_subst rhs_dict_ids
+          ; (rhs_subst1, inst_dict_ids) <- newDictBndrs rhs_subst rhs_dict_ids

                          -- Clone rhs_dicts, including instantiating their types
 
           ; let (rhs_subst2, dx_binds) = bindAuxiliaryDicts rhs_subst1 $
                          -- Clone rhs_dicts, including instantiating their types
 
           ; let (rhs_subst2, dx_binds) = bindAuxiliaryDicts rhs_subst1 $

@@ -886,10 +890,6 @@ specDefn subst body_uds fn rhs
                 spec_id_ty = mkPiTypes lam_args body_ty
        
            ; spec_f <- newSpecIdSM fn spec_id_ty
                 spec_id_ty = mkPiTypes lam_args body_ty
        
            ; spec_f <- newSpecIdSM fn spec_id_ty

-          ; let spec_f_w_arity = setIdArity spec_f (max 0 (fn_arity - n_dicts))
-               -- Adding arity information just propagates it a bit faster
-               -- See Note [Arity decrease] in Simplify
-

            ; (spec_rhs, rhs_uds) <- specExpr rhs_subst2 (mkLams lam_args body)
           ; let
                -- The rule to put in the function's specialisation is:
            ; (spec_rhs, rhs_uds) <- specExpr rhs_subst2 (mkLams lam_args body)
           ; let
                -- The rule to put in the function's specialisation is:

@@ -897,22 +897,33 @@ specDefn subst body_uds fn rhs
                rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args))
                spec_env_rule = mkLocalRule
                                  rule_name
                rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args))
                spec_env_rule = mkLocalRule
                                  rule_name

-                                 inline_act    -- Note [Auto-specialisation and RULES]
+                                 inl_act       -- Note [Auto-specialisation and RULES]

                                  (idName fn)
                                  (poly_tyvars ++ inst_dict_ids)
                                  inst_args 
                                  (idName fn)
                                  (poly_tyvars ++ inst_dict_ids)
                                  inst_args 

-                                 (mkVarApps (Var spec_f_w_arity) app_args)
+                                 (mkVarApps (Var spec_f) app_args)

 
                -- 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
 

+               -- Adding arity information just propagates it a bit faster
+               --      See Note [Arity decrease] in Simplify
+               -- Copy InlinePragma information from the parent Id.
+               -- So if f has INLINE[1] so does spec_f
+               spec_f_w_arity = spec_f `setIdArity`          max 0 (fn_arity - n_dicts)
+                                        `setInlineActivation` inl_act
+
+               -- Add an InlineRule if the parent has one

                -- See Note [Inline specialisations]
                -- See Note [Inline specialisations]

-               final_spec_f | Just sat <- fn_has_inline_rule
-                            = spec_f_w_arity `setInlineActivation` inline_act
-                                             `setIdUnfolding` mkInlineRule sat spec_rhs spec_arity
-                                               -- I'm not sure this should be unconditionally InlSat
-                            | otherwise 
-                            = spec_f_w_arity
+               final_spec_f 
+                  | Just sat <- fn_has_inline_rule
+                 = let 
+                       mb_spec_arity = if sat then Just spec_arity else Nothing
+                    in 
+                    spec_f_w_arity `setIdUnfolding` mkInlineRule spec_rhs mb_spec_arity
+                 | otherwise 
+                 = spec_f_w_arity
+

           ; return (Just ((final_spec_f, spec_rhs), final_uds, spec_env_rule)) } }
       where
        my_zipEqual xs ys zs
           ; return (Just ((final_spec_f, spec_rhs), final_uds, spec_env_rule)) } }
       where
        my_zipEqual xs ys zs

@@ -937,6 +948,9 @@ bindAuxiliaryDicts subst triples = go subst [] triples
     go subst binds ((d, dx_id, dx) : pairs)
       | exprIsTrivial dx = go (extendIdSubst subst d dx) binds pairs
              -- No auxiliary binding necessary
     go subst binds ((d, dx_id, dx) : pairs)
       | exprIsTrivial dx = go (extendIdSubst subst d dx) binds pairs
              -- No auxiliary binding necessary

+            -- Note that we bind the *original* dict in the substitution,
+            -- overriding any d->dx_id binding put there by substBndrs
+

       | otherwise        = go subst_w_unf (NonRec dx_id dx : binds) pairs
       where
         dx_id1 = dx_id `setIdUnfolding` mkUnfolding False False dx
       | otherwise        = go subst_w_unf (NonRec dx_id dx : binds) pairs
       where
         dx_id1 = dx_id `setIdUnfolding` mkUnfolding False False dx

@@ -949,6 +963,9 @@ bindAuxiliaryDicts subst triples = go subst [] triples
             -- a consequent call (g d') with an auxiliary definition
             --     d' = df dNumInt
             -- We want that consequent call to look interesting
             -- a consequent call (g d') with an auxiliary definition
             --     d' = df dNumInt
             -- We want that consequent call to look interesting

+            --
+            -- Again, note that we bind the *original* dict in the substitution,
+            -- overriding any d->dx_id binding put there by substBndrs

 \end{code}
 
 Note [From non-recursive to recursive]
 \end{code}
 
 Note [From non-recursive to recursive]

@@ -1112,10 +1129,14 @@ also add
        RULE f g_spec = 0
 
 But that's a bit complicated.  For now we ask the programmer's help,
        RULE f g_spec = 0
 
 But that's a bit complicated.  For now we ask the programmer's help,

-by *copying the INLINE activation pragma* to the auto-specialised rule.
-So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule will also
-not be active until phase 2.  
+by *copying the INLINE activation pragma* to the auto-specialised
+rule.  So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule
+will also not be active until phase 2.  And that's what programmers
+should jolly well do anyway, even aside from specialisation, to ensure
+that g doesn't inline too early.

 
 

+This in turn means that the RULE would never fire for a NOINLINE
+thing so not much point in generating a specialisation at all.

 
 Note [Specialisation shape]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 Note [Specialisation shape]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -1141,13 +1162,12 @@ It's a silly exapmle, but we get
 where choose doesn't have any dict arguments.  Thus far I have not
 tried to fix this (wait till there's a real example).
 
 where choose doesn't have any dict arguments.  Thus far I have not
 tried to fix this (wait till there's a real example).
 

-

 Note [Inline specialisations]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We transfer to the specialised function any INLINE stuff from the
 Note [Inline specialisations]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We transfer to the specialised function any INLINE stuff from the

-original.  This means (a) the Activation in the IdInfo, and (b) any
-InlineMe on the RHS.  We do not, however, transfer the RuleMatchInfo
-since we do not expect the specialisation to occur in rewrite rules.
+original.  This means 
+   (a) the Activation for its inlining (from its InlinePragma)
+   (b) any InlineRule

 
 This is a change (Jun06).  Previously the idea is that the point of
 inlining was precisely to specialise the function at its call site,
 
 This is a change (Jun06).  Previously the idea is that the point of
 inlining was precisely to specialise the function at its call site,

@@ -1166,9 +1186,6 @@ arguments alone are enough to specialise (even though the args are too
 boring to trigger inlining), and it's certainly better to call the 
 specialised version.
 
 boring to trigger inlining), and it's certainly better to call the 
 specialised version.
 

-A case in point is dictionary functions, which are current marked
-INLINE, but which are worth specialising.
-

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

@@ -1500,19 +1517,27 @@ cloneBindSM subst (Rec pairs) = do
     let (subst', bndrs') = cloneRecIdBndrs subst us (map fst pairs)
     return (subst', subst', Rec (bndrs' `zip` map snd pairs))
 
     let (subst', bndrs') = cloneRecIdBndrs subst us (map fst pairs)
     return (subst', subst', Rec (bndrs' `zip` map snd pairs))
 

-cloneDictBndrs :: Subst -> [CoreBndr] -> SpecM (Subst, [CoreBndr])
-cloneDictBndrs subst bndrs 
-  = do { us <- getUniqueSupplyM
-       ; return (cloneIdBndrs subst us bndrs) }
+newDictBndrs :: Subst -> [CoreBndr] -> SpecM (Subst, [CoreBndr])
+-- Make up completely fresh binders for the dictionaries
+-- Their bindings are going to float outwards
+newDictBndrs subst bndrs 
+  = do { bndrs' <- mapM new bndrs
+       ; let subst' = extendIdSubstList subst 
+                        [(d, Var d') | (d,d') <- bndrs `zip` bndrs']
+       ; return (subst', bndrs' ) }
+  where
+    new b = do { uniq <- getUniqueM
+              ; let n   = idName b
+                     ty' = CoreSubst.substTy subst (idType b)
+               ; return (mkUserLocal (nameOccName n) uniq ty' (getSrcSpan n)) }

 
 newSpecIdSM :: Id -> Type -> SpecM Id
     -- Give the new Id a similar occurrence name to the old one
 newSpecIdSM old_id new_ty
   = do { uniq <- getUniqueM
 
 newSpecIdSM :: Id -> Type -> SpecM Id
     -- Give the new Id a similar occurrence name to the old one
 newSpecIdSM old_id new_ty
   = do { uniq <- getUniqueM

-       ; let 
-           name    = idName old_id
-           new_occ = mkSpecOcc (nameOccName name)
-           new_id  = mkUserLocal new_occ uniq new_ty (getSrcSpan name)
+       ; let name    = idName old_id
+             new_occ = mkSpecOcc (nameOccName name)
+             new_id  = mkUserLocal new_occ uniq new_ty (getSrcSpan name)

         ; return new_id }
 \end{code}
 
         ; return new_id }
 \end{code}