Support "phase control" for SPECIALISE pragmas

This featurelet allows Trac #5237 to be fixed.
The idea is to allow SPECIALISE pragmas to specify
the phases in which the RULE is active, just as you can
do with RULES themselves.
  {-# SPECIALISE [1] foo :: Int -> Int #-}

This feature is so obvious that not having it is really a bug.
There are, needless to say, a few wrinkles.  See
   Note [Activation pragmas for SPECIALISE]
in DsBinds

compiler/deSugar/DsBinds.lhs

@@ -512,17 +512,31 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
        ; let spec_id  = mkLocalId spec_name spec_ty 
          	            `setInlinePragma` inl_prag
          	 	    `setIdUnfolding`  spec_unf
+             id_inl = idInlinePragma poly_id
+
+	     -- See Note [Activation pragmas for SPECIALISE]
              inl_prag | not (isDefaultInlinePragma spec_inl)    = spec_inl
          	      | not is_local_id  -- See Note [Specialising imported functions]
 		      	    		 -- in OccurAnal
                       , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
-		      | otherwise                               = idInlinePragma poly_id
+		      | otherwise                               = id_inl
        	      -- Get the INLINE pragma from SPECIALISE declaration, or,
               -- failing that, from the original Id
 
+             spec_prag_act = inlinePragmaActivation spec_inl
+
+	     -- See Note [Activation pragmas for SPECIALISE]
+	     -- no_act_spec is True if the user didn't write an explicit
+	     -- phase specification in the SPECIALISE pragma
+             no_act_spec = case inlinePragmaSpec spec_inl of
+                             NoInline -> isNeverActive  spec_prag_act
+                             _        -> isAlwaysActive spec_prag_act
+	     rule_act | no_act_spec = inlinePragmaActivation id_inl   -- Inherit
+                      | otherwise   = spec_prag_act                   -- Specified by user
+
              rule =  mkRule False {- Not auto -} is_local_id
                         (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
-       			AlwaysActive poly_name
+       			rule_act poly_name
        		        final_bndrs args
        			(mkVarApps (Var spec_id) bndrs)
 
@@ -557,6 +571,48 @@ specUnfolding _ _ _
   = return (noUnfolding, nilOL)
 \end{code}
 
+
+Note [Activation pragmas for SPECIALISE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+From a user SPECIALISE pragma for f, we generate
+  a) A top-level binding    spec_fn = rhs
+  b) A RULE                 f dOrd = spec_fn
+
+We need two pragma-like things:
+
+* spec_fn's inline pragma: inherited from f's inline pragma (ignoring 
+                           activation on SPEC), unless overriden by SPEC INLINE
+
+* Activation of RULE: from SPECIALISE pragma (if activation given)
+                      otherwise from f's inline pragma
+
+This is not obvious (see Trac #5237)!
+
+Examples      Rule activation   Inline prag on spec'd fn
+---------------------------------------------------------------------
+SPEC [n] f :: ty            [n]   Always, or NOINLINE [n]
+                                  copy f's prag
+
+NOINLINE f
+SPEC [n] f :: ty            [n]   NOINLINE
+                                  copy f's prag
+
+NOINLINE [k] f
+SPEC [n] f :: ty            [n]   NOINLINE [k]
+                                  copy f's prag
+
+INLINE [k] f
+SPEC [n] f :: ty            [n]   INLINE [k] 
+                                  copy f's prag
+
+SPEC INLINE [n] f :: ty     [n]   INLINE [n]
+                                  (ignore INLINE prag on f,
+                                  same activation for rule and spec'd fn)
+
+NOINLINE [k] f
+SPEC f :: ty                [n]   INLINE [k]
+
+
 %************************************************************************
 %*									*
 \subsection{Adding inline pragmas}

compiler/parser/Parser.y.pp

@@ -1320,14 +1320,15 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
                                 { LL $ toOL [ LL $ SigD (TypeSig ($1 : unLoc $3) $5) ] }
         | infix prec ops        { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
                                              | n <- unLoc $3 ] }
-        | '{-# INLINE'   activation qvar '#-}'        
+        | '{-# INLINE' activation qvar '#-}'        
                 { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) }
-        | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
-                { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlinePragma) 
-                                            | t <- $4] }
+        | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
+                { let inl_prag = mkInlinePragma (EmptyInlineSpec, FunLike) $2
+                  in LL $ toOL [ LL $ SigD (SpecSig $3 t inl_prag) 
+                               | t <- $5] }
         | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
                 { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma (getSPEC_INLINE $1) $2))
-                                            | t <- $5] }
+                            | t <- $5] }
         | '{-# SPECIALISE' 'instance' inst_type '#-}'
                 { LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
 

compiler/parser/RdrHsSyn.lhs

@@ -885,7 +885,8 @@ 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) }
 
 mkInlinePragma :: (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma
--- The Maybe is because the user can omit the activation spec (and usually does)
+-- The (Maybe Activation) is because the user can omit 
+-- the activation spec (and usually does)
 mkInlinePragma (inl, match_info) mb_act
   = InlinePragma { inl_inline = inl
                  , inl_sat    = Nothing

docs/users_guide/glasgow_exts.xml

@@ -8302,12 +8302,16 @@ happen.
   {-# SPECIALIZE hammeredLookup :: [(Widget, value)] -> Widget -> value #-}
 </programlisting>
 
+<itemizedlist>
+<listitem>
       <para>A <literal>SPECIALIZE</literal> pragma for a function can
       be put anywhere its type signature could be put.  Moreover, you 
       can also <literal>SPECIALIZE</literal> an <emphasis>imported</emphasis>
 		function provided it was given an <literal>INLINABLE</literal> pragma at
 		its definition site (<xref linkend="inlinable-pragma"/>).</para>
+</listitem>
 
+<listitem>
       <para>A <literal>SPECIALIZE</literal> has the effect of generating
       (a) a specialised version of the function and (b) a rewrite rule
       (see <xref linkend="rewrite-rules"/>) that rewrites a call to
@@ -8318,7 +8322,36 @@ happen.
       by <literal>f</literal>, if they are in the same module as
       the <literal>SPECIALIZE</literal> pragma, or if they are
       <literal>INLINABLE</literal>; and so on, transitively.</para>
+</listitem>
 
+<listitem>
+   <para>You can add phase control (<xref linkend="phase-control"/>) 
+   to the RULE generated by a <literal>SPECIALIZE</literal> pragma,
+   just as you can if you writ a RULE directly. For exxample:
+<programlisting>
+  {-# SPECIALIZE [0] hammeredLookup :: [(Widget, value)] -> Widget -> value #-}
+</programlisting>
+   generates a specialisation rule that only fires in Phase 0 (the final phase).
+   If you do not specify any phase control in the <literal>SPECIALIZE</literal> pragma,
+   the phase control is inherited from the inline pragma (if any) of the function.
+   For example:
+<programlisting>
+  foo :: Num a => a -> a
+  foo = ...blah...
+  {-# NOINLINE [0] foo #-}
+  {-# SPECIALIZE foo :: Int -> Int #-}
+</programlisting>
+  The <literal>NOINLINE</literal> pragma tells GHC not to inline <literal>foo</literal>
+  until Phase 0; and this property is inherited by the specialiation RULE, which will
+  therefore only fire in Phase 0.</para>
+  <para>The main reason for using phase control on specialisations is so that you can 
+  write optimisation RULES that fire early in the compilation pipeline, and only 
+   <emphasis>then</emphasis> specialise the calls to the function. If specialisation is
+   done too early, the optimsation rules might fail to fire.
+  </para>
+</listitem>
+
+<listitem>
       <para>The type in a SPECIALIZE pragma can be any type that is less
 	polymorphic than the type of the original function.  In concrete terms,
 	if the original function is <literal>f</literal> then the pragma
@@ -8346,6 +8379,8 @@ The last of these examples will generate a
 RULE with a somewhat-complex left-hand side (try it yourself), so it might not fire very
 well.  If you use this kind of specialisation, let us know how well it works.
 </para>
+</listitem>
+</itemizedlist>
 
     <sect3 id="specialize-inline">
       <title>SPECIALIZE INLINE</title>
@@ -8376,6 +8411,11 @@ the specialised function will be inlined.  It has two calls to
 both at type <literal>Int</literal>.  Both these calls fire the first
 specialisation, whose body is also inlined.  The result is a type-based
 unrolling of the indexing function.</para>
+<para>You can add explicit phase control (<xref linkend="phase-control"/>) 
+to <literal>SPECIALISE INLINE</literal> pragma,
+just like on an <literal>INLINE</literal> pragma; if you do so, the same phase 
+is used for the rewrite rule and the INLINE control of the specialised function.
+
 <para>Warning: you can make GHC diverge by using <literal>SPECIALISE INLINE</literal>
 on an ordinarily-recursive function.</para>
 </sect3>