Revert "Remove SpecConstrAnnotation (#13681)" (#19168)

This reverts commit 7bc3a65b467c4286377b9bded277d5a2f69160b3.

NoSpecConstr is used in the wild (see #19168)

7 files changed, 118 insertions, 31 deletions

diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index 1abe9f7ab3..02c1c3cf2e 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -1,18 +1,23 @@
 {-
+ToDo [Oct 2013]
+~~~~~~~~~~~~~~~
+1. Nuke ForceSpecConstr for good (it is subsumed by GHC.Types.SPEC in ghc-prim)
+2. Nuke NoSpecConstr
+
 
 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 
+\section[SpecConstr]{Specialise over constructors}
 -}
 
 {-# LANGUAGE CPP #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
--- | Specialise over constructors
-module GHC.Core.Opt.SpecConstr
-   ( specConstrProgram
-   )
-where
+module GHC.Core.Opt.SpecConstr(
+        specConstrProgram,
+        SpecConstrAnnotation(..)
+    ) where
 
 #include "HsVersions.h"
 
@@ -31,7 +36,7 @@ import GHC.Core.DataCon
 import GHC.Core.Coercion hiding( substCo )
 import GHC.Core.Rules
 import GHC.Core.Type     hiding ( substTy )
-import GHC.Core.TyCon   ( tyConUnique )
+import GHC.Core.TyCon   ( tyConUnique, tyConName )
 import GHC.Core.Multiplicity
 import GHC.Types.Id
 import GHC.Core.Ppr     ( pprParendExpr )
@@ -46,6 +51,7 @@ import GHC.Driver.Ppr
 import GHC.Data.Maybe     ( orElse, catMaybes, isJust, isNothing )
 import GHC.Types.Demand
 import GHC.Types.Cpr
+import GHC.Serialized   ( deserializeWithData )
 import GHC.Utils.Misc
 import GHC.Data.Pair
 import GHC.Types.Unique.Supply
@@ -58,6 +64,8 @@ import Control.Monad    ( zipWithM )
 import Data.List
 import GHC.Builtin.Names ( specTyConKey )
 import GHC.Unit.Module
+import GHC.Core.TyCon ( TyCon )
+import GHC.Exts( SpecConstrAnnotation(..) )
 import Data.Ord( comparing )
 
 {-
@@ -449,19 +457,32 @@ With stream fusion and in other similar cases, we want to fully
 specialise some (but not necessarily all!) loops regardless of their
 size and the number of specialisations.
 
-We allow a library to force the specialisation by adding a parameter of type
-GHC.Types.SPEC (from ghc-prim) to the loop body.
+We allow a library to do this, in one of two ways (one which is
+deprecated):
+
+  1) Add a parameter of type GHC.Types.SPEC (from ghc-prim) to the loop body.
+
+  2) (Deprecated) Annotate a type with ForceSpecConstr from GHC.Exts,
+     and then add *that* type as a parameter to the loop body
 
-   Historical note: in the past any datatype could be used in place of
-   GHC.Types.SPEC as long as it was annotated with GHC.Exts.ForceSpecConstr. It
-   has been deprecated because it required GHCi, which isn't available for
-   things like a cross compiler using stage1.
+The reason #2 is deprecated is because it requires GHCi, which isn't
+available for things like a cross compiler using stage1.
 
 Here's a (simplified) example from the `vector` package. You may bring
 the special 'force specialization' type into scope by saying:
 
   import GHC.Types (SPEC(..))
 
+or by defining your own type (again, deprecated):
+
+  data SPEC = SPEC | SPEC2
+  {-# ANN type SPEC ForceSpecConstr #-}
+
+(Note this is the exact same definition of GHC.Types.SPEC, just
+without the annotation.)
+
+After that, you say:
+
   foldl :: (a -> b -> a) -> a -> Stream b -> a
   {-# INLINE foldl #-}
   foldl f z (Stream step s _) = foldl_loop SPEC z s
@@ -483,7 +504,7 @@ foldl_loop. Note that
 
 This is all quite ugly; we ought to come up with a better design.
 
-SPEC arguments are spotted in scExpr' and scTopBinds which then set
+ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set
 sc_force to True when calling specLoop. This flag does four things:
 
   * Ignore specConstrThreshold, to specialise functions of arbitrary size
@@ -526,8 +547,8 @@ What alternatives did I consider?
   user (e.g., the accumulator here) but we still want to specialise as
   much as possible.
 
-Alternatives to SPEC
-~~~~~~~~~~~~~~~~~~~~
+Alternatives to ForceSpecConstr
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Instead of giving the loop an extra argument of type SPEC, we
 also considered *wrapping* arguments in SPEC, thus
   data SPEC a = SPEC a | SPEC2
@@ -551,13 +572,13 @@ this doesn't look like a specialisable call.
 
 Note [Limit recursive specialisation]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It is possible for SPEC to cause an infinite loop of specialisation.
+It is possible for ForceSpecConstr to cause an infinite loop of specialisation.
 Because there is no limit on the number of specialisations, a recursive call with
 a recursive constructor as an argument (for example, list cons) will generate
 a specialisation for that constructor. If the resulting specialisation also
 contains a recursive call with the constructor, this could proceed indefinitely.
 
-For example, if SPEC is on:
+For example, if ForceSpecConstr is on:
   loop :: [Int] -> [Int] -> [Int]
   loop z []         = z
   loop z (x:xs)     = loop (x:z) xs
@@ -587,6 +608,16 @@ more than N times (controlled by -fspec-constr-recursive=N) we check
 See #5550.   Also #13623, where this test had become over-aggressive,
 and we lost a wonderful specialisation that we really wanted!
 
+Note [NoSpecConstr]
+~~~~~~~~~~~~~~~~~~~
+The ignoreDataCon stuff allows you to say
+    {-# ANN type T NoSpecConstr #-}
+to mean "don't specialise on arguments of this type".  It was added
+before we had ForceSpecConstr.  Lacking ForceSpecConstr we specialised
+regardless of size; and then we needed a way to turn that *off*.  Now
+that we have ForceSpecConstr, this NoSpecConstr is probably redundant.
+(Used only for PArray, TODO: remove?)
+
 -----------------------------------------------------
                 Stuff not yet handled
 -----------------------------------------------------
@@ -674,10 +705,11 @@ specConstrProgram guts
   = do
       dflags <- getDynFlags
       us     <- getUniqueSupplyM
+      (_, annos) <- getFirstAnnotations deserializeWithData guts
       this_mod <- getModule
       let binds' = reverse $ fst $ initUs us $ do
                     -- Note [Top-level recursive groups]
-                    (env, binds) <- goEnv (initScEnv dflags this_mod)
+                    (env, binds) <- goEnv (initScEnv dflags this_mod annos)
                                           (mg_binds guts)
                         -- binds is identical to (mg_binds guts), except that the
                         -- binders on the LHS have been replaced by extendBndr
@@ -793,7 +825,7 @@ data ScEnv = SCE { sc_dflags    :: DynFlags,
                                                 -- See Note [Avoiding exponential blowup]
 
                    sc_recursive :: Int,         -- Max # of specialisations over recursive type.
-                                                -- Stops SPEC from diverging.
+                                                -- Stops ForceSpecConstr from diverging.
 
                    sc_keen     :: Bool,         -- Specialise on arguments that are known
                                                 -- constructors, even if they are not
@@ -810,13 +842,15 @@ data ScEnv = SCE { sc_dflags    :: DynFlags,
                         -- Binds interesting non-top-level variables
                         -- Domain is OutVars (*after* applying the substitution)
 
-                   sc_vals      :: ValueEnv
+                   sc_vals      :: ValueEnv,
                         -- Domain is OutIds (*after* applying the substitution)
                         -- Used even for top-level bindings (but not imported ones)
                         -- The range of the ValueEnv is *work-free* values
                         -- such as (\x. blah), or (Just v)
                         -- but NOT (Just (expensive v))
                         -- See Note [Work-free values only in environment]
+
+                   sc_annotations :: UniqFM Name SpecConstrAnnotation
              }
 
 ---------------------
@@ -833,8 +867,8 @@ instance Outputable Value where
    ppr LambdaVal         = text "<Lambda>"
 
 ---------------------
-initScEnv :: DynFlags -> Module -> ScEnv
-initScEnv dflags this_mod
+initScEnv :: DynFlags -> Module -> UniqFM Name SpecConstrAnnotation -> ScEnv
+initScEnv dflags this_mod anns
   = SCE { sc_dflags      = dflags,
           sc_uf_opts     = unfoldingOpts dflags,
           sc_module      = this_mod,
@@ -845,7 +879,8 @@ initScEnv dflags this_mod
           sc_force       = False,
           sc_subst       = emptySubst,
           sc_how_bound   = emptyVarEnv,
-          sc_vals        = emptyVarEnv }
+          sc_vals        = emptyVarEnv,
+          sc_annotations = anns }
 
 data HowBound = RecFun  -- These are the recursive functions for which
                         -- we seek interesting call patterns
@@ -970,7 +1005,21 @@ decreaseSpecCount env n_specs
 
 ---------------------------------------------------
 -- See Note [Forcing specialisation]
+ignoreType    :: ScEnv -> Type   -> Bool
+ignoreDataCon  :: ScEnv -> DataCon -> Bool
 forceSpecBndr :: ScEnv -> Var    -> Bool
+
+ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc)
+
+ignoreType env ty
+  = case tyConAppTyCon_maybe ty of
+      Just tycon -> ignoreTyCon env tycon
+      _          -> False
+
+ignoreTyCon :: ScEnv -> TyCon -> Bool
+ignoreTyCon env tycon
+  = lookupUFM (sc_annotations env) (tyConName tycon) == Just NoSpecConstr
+
 forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTyCoVars . varType $ var
 
 forceSpecFunTy :: ScEnv -> Type -> Bool
@@ -984,6 +1033,7 @@ forceSpecArgTy env ty
   | Just (tycon, tys) <- splitTyConApp_maybe ty
   , tycon /= funTyCon
       = tyConUnique tycon == specTyConKey
+        || lookupUFM (sc_annotations env) (tyConName tycon) == Just ForceSpecConstr
         || any (forceSpecArgTy env) tys
 
 forceSpecArgTy _ _ = False
@@ -1846,9 +1896,9 @@ by trim_pats.
   of specialisations for a given function to N.
 
 * -fno-spec-constr-count sets the sc_count field to Nothing,
-  which switches off the limit.
+  which switches of the limit.
 
-* The ghastly SPEC trick also switches off the limit
+* The ghastly ForceSpecConstr trick also switches of the limit
   for a particular function
 
 * Otherwise we sort the patterns to choose the most general
@@ -2121,6 +2171,7 @@ argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
 -}
 
 argToPat env in_scope val_env (Cast arg co) arg_occ
+  | not (ignoreType env ty2)
   = do  { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
         ; if not interesting then
                 wildCardPat ty2
@@ -2151,6 +2202,7 @@ argToPat in_scope val_env arg arg_occ
   -- NB: this *precedes* the Var case, so that we catch nullary constrs
 argToPat env in_scope val_env arg arg_occ
   | Just (ConVal (DataAlt dc) args) <- isValue val_env arg
+  , not (ignoreDataCon env dc)        -- See Note [NoSpecConstr]
   , Just arg_occs <- mb_scrut dc
   = do  { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args
         ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs
@@ -2171,10 +2223,11 @@ argToPat env in_scope val_env arg arg_occ
   -- In that case it counts as "interesting"
 argToPat env in_scope val_env (Var v) arg_occ
   | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
-    is_value                                                             -- (b)
+    is_value,                                                            -- (b)
        -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing]
        -- So sc_keen focused just on f (I# x), where we have freshly-allocated
        -- box that we can eliminate in the caller
+    not (ignoreType env (varType v))
   = return (True, Var v)
   where
     is_value
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 109d854526..8e92fc974f 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -466,7 +466,7 @@ data DynFlags = DynFlags {
   specConstrThreshold   :: Maybe Int,   -- ^ Threshold for SpecConstr
   specConstrCount       :: Maybe Int,   -- ^ Max number of specialisations for any one function
   specConstrRecursive   :: Int,         -- ^ Max number of specialisations for recursive types
-                                        --   Not optional; otherwise SPEC can diverge.
+                                        --   Not optional; otherwise ForceSpecConstr can diverge.
   binBlobThreshold      :: Word,        -- ^ Binary literals (e.g. strings) whose size is above
                                         --   this threshold will be dumped in a binary file
                                         --   by the assembler code generator (0 to disable)
diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs
index 31788c24c0..d1ca1cfff8 100755
--- a/libraries/base/GHC/Exts.hs
+++ b/libraries/base/GHC/Exts.hs
@@ -5,8 +5,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UnboxedTuples #-}
 {-# LANGUAGE Unsafe #-}
-
-{-# OPTIONS_HADDOCK not-home #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -99,6 +98,9 @@ module GHC.Exts
         -- * Event logging
         traceEvent,
 
+        -- * SpecConstr annotations
+        SpecConstrAnnotation(..),
+
         -- * The call stack
         currentCallStack,
 
@@ -124,6 +126,7 @@ import GHC.Stack
 import qualified Data.Coerce
 import Data.String
 import Data.OldList
+import Data.Data
 import Data.Ord
 import Data.Version ( Version(..), makeVersion )
 import qualified Debug.Trace
@@ -173,6 +176,25 @@ traceEvent = Debug.Trace.traceEventIO
 
 {- **********************************************************************
 *                                                                       *
+*              SpecConstr annotation                                    *
+*                                                                       *
+********************************************************************** -}
+
+-- Annotating a type with NoSpecConstr will make SpecConstr
+-- not specialise for arguments of that type.
+
+-- This data type is defined here, rather than in the SpecConstr module
+-- itself, so that importing it doesn't force stupidly linking the
+-- entire ghc package at runtime
+
+data SpecConstrAnnotation = NoSpecConstr | ForceSpecConstr
+                deriving ( Data -- ^ @since 4.3.0.0
+                         , Eq   -- ^ @since 4.3.0.0
+                         )
+
+
+{- **********************************************************************
+*                                                                       *
 *              The IsList class                                         *
 *                                                                       *
 ********************************************************************** -}
diff --git a/testsuite/tests/simplCore/should_compile/T19168.hs b/testsuite/tests/simplCore/should_compile/T19168.hs
new file mode 100644
index 0000000000..7e271a2c61
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T19168.hs
@@ -0,0 +1,6 @@
+module T19168 where
+
+import GHC.Exts (SpecConstrAnnotation(..))
+
+{-# ANN type List NoSpecConstr #-}
+newtype List a = List { unList :: [a] }
diff --git a/testsuite/tests/simplCore/should_compile/T5550.hs b/testsuite/tests/simplCore/should_compile/T5550.hs
index 25788c09e3..025da505f3 100644
--- a/testsuite/tests/simplCore/should_compile/T5550.hs
+++ b/testsuite/tests/simplCore/should_compile/T5550.hs
@@ -1,6 +1,9 @@
 module T5550 where
 
-import GHC.Types
+import GHC.Exts ( SpecConstrAnnotation(..) )
+
+data SPEC = SPEC | SPEC2
+{-# ANN type SPEC ForceSpecConstr #-}
 
 loop :: SPEC -> [Int] -> [Int] -> [Int]
 loop SPEC z [] = z
diff --git a/testsuite/tests/simplCore/should_compile/T7944.hs b/testsuite/tests/simplCore/should_compile/T7944.hs
index 7f9acbf0c7..7fa0e2d279 100644
--- a/testsuite/tests/simplCore/should_compile/T7944.hs
+++ b/testsuite/tests/simplCore/should_compile/T7944.hs
@@ -1,6 +1,8 @@
 module T7944 where
 
-import GHC.Types
+import GHC.Exts
+
+-- Force specialisation of "go"
 
 -- This is more or less just an ordinary fold
 go :: SPEC -> [a] -> IntMap a -> IntMap a
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 51d35322d1..d62a7ce0e6 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -343,3 +343,4 @@ test('T18747B', normal, compile, [''])
 test('T18815', only_ways(['optasm']), makefile_test, ['T18815'])
 test('T18668', normal, compile, ['-dsuppress-uniques'])
 test('T18995', [ grep_errmsg(r'print') ], compile, ['-O -ddump-simpl -dsuppress-uniques'])
+test('T19168', normal, compile, [''])