Rework Template Haskell's handling of strictness

Currently, Template Haskell's treatment of strictness is not enough to
cover all possible combinations of unpackedness and strictness. In
addition, it isn't equipped to deal with new features (such as
`-XStrictData`) which can change a datatype's fields' strictness during
compilation.

To address this, I replaced TH's `Strict` datatype with
`SourceUnpackedness` and `SourceStrictness` (which give the programmer a
more complete toolkit to configure a datatype field's strictness than
just `IsStrict`, `IsLazy`, and `Unpack`). I also added the ability to
reify a constructor fields' strictness post-compilation through the
`reifyConStrictness` function.

Fixes #10697.

Test Plan: ./validate

Reviewers: simonpj, goldfire, bgamari, austin

Reviewed By: goldfire, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1603

GHC Trac Issues: #10697

1 files changed, 61 insertions, 37 deletions

diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs
index d683b1a9b4..392aeda1ff 100644
--- a/compiler/prelude/THNames.hs
+++ b/compiler/prelude/THNames.hs
@@ -73,14 +73,18 @@ templateHaskellNames = [
     roleAnnotDName,
     -- Cxt
     cxtName,
-    -- Strict
-    isStrictName, notStrictName, unpackedName,
+    -- SourceUnpackedness
+    noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName,
+    -- SourceStrictness
+    noSourceStrictnessName, sourceLazyName, sourceStrictName,
     -- Con
     normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName,
-    -- StrictType
-    strictTypeName,
-    -- VarStrictType
-    varStrictTypeName,
+    -- Bang
+    bangName,
+    -- BangType
+    bangTypeName,
+    -- VarBangType
+    varBangTypeName,
     -- Type
     forallTName, varTName, conTName, appTName, equalityTName,
     tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName,
@@ -130,8 +134,8 @@ templateHaskellNames = [
     -- And the tycons
     qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
     clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
-    stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,
-    varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
+    stmtQTyConName, decQTyConName, conQTyConName, bangTypeQTyConName,
+    varBangTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
     typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
     patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
     predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,
@@ -349,11 +353,17 @@ roleAnnotDName       = libFun (fsLit "roleAnnotD")        roleAnnotDIdKey
 cxtName :: Name
 cxtName = libFun (fsLit "cxt") cxtIdKey
 
--- data Strict = ...
-isStrictName, notStrictName, unpackedName :: Name
-isStrictName      = libFun  (fsLit "isStrict")      isStrictKey
-notStrictName     = libFun  (fsLit "notStrict")     notStrictKey
-unpackedName      = libFun  (fsLit "unpacked")      unpackedKey
+-- data SourceUnpackedness = ...
+noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName :: Name
+noSourceUnpackednessName = libFun (fsLit "noSourceUnpackedness") noSourceUnpackednessKey
+sourceNoUnpackName       = libFun (fsLit "sourceNoUnpack")       sourceNoUnpackKey
+sourceUnpackName         = libFun (fsLit "sourceUnpack")         sourceUnpackKey
+
+-- data SourceStrictness = ...
+noSourceStrictnessName, sourceLazyName, sourceStrictName :: Name
+noSourceStrictnessName = libFun (fsLit "noSourceStrictness") noSourceStrictnessKey
+sourceLazyName         = libFun (fsLit "sourceLazy")         sourceLazyKey
+sourceStrictName       = libFun (fsLit "sourceStrict")       sourceStrictKey
 
 -- data Con = ...
 normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName :: Name
@@ -364,13 +374,17 @@ forallCName  = libFun (fsLit "forallC" ) forallCIdKey
 gadtCName    = libFun (fsLit "gadtC"   ) gadtCIdKey
 recGadtCName = libFun (fsLit "recGadtC") recGadtCIdKey
 
--- type StrictType = ...
-strictTypeName :: Name
-strictTypeName    = libFun  (fsLit "strictType")    strictTKey
+-- data Bang = ...
+bangName :: Name
+bangName = libFun (fsLit "bang") bangIdKey
+
+-- type BangType = ...
+bangTypeName :: Name
+bangTypeName = libFun (fsLit "bangType") bangTKey
 
--- type VarStrictType = ...
-varStrictTypeName :: Name
-varStrictTypeName = libFun  (fsLit "varStrictType") varStrictTKey
+-- type VarBangType = ...
+varBangTypeName :: Name
+varBangTypeName = libFun (fsLit "varBangType") varBangTKey
 
 -- data Type = ...
 forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName,
@@ -479,8 +493,8 @@ typeAnnotationName   = libFun (fsLit "typeAnnotation")   typeAnnotationIdKey
 moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey
 
 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
-    decQTyConName, conQTyConName, strictTypeQTyConName,
-    varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
+    decQTyConName, conQTyConName, bangTypeQTyConName,
+    varBangTypeQTyConName, typeQTyConName, fieldExpQTyConName,
     patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,
     ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName :: Name
 matchQTyConName         = libTc (fsLit "MatchQ")         matchQTyConKey
@@ -490,8 +504,8 @@ stmtQTyConName          = libTc (fsLit "StmtQ")          stmtQTyConKey
 decQTyConName           = libTc (fsLit "DecQ")           decQTyConKey
 decsQTyConName          = libTc (fsLit "DecsQ")          decsQTyConKey  -- Q [Dec]
 conQTyConName           = libTc (fsLit "ConQ")           conQTyConKey
-strictTypeQTyConName    = libTc (fsLit "StrictTypeQ")    strictTypeQTyConKey
-varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey
+bangTypeQTyConName      = libTc (fsLit "BangTypeQ")      bangTypeQTyConKey
+varBangTypeQTyConName   = libTc (fsLit "VarBangTypeQ")   varBangTypeQTyConKey
 typeQTyConName          = libTc (fsLit "TypeQ")          typeQTyConKey
 fieldExpQTyConName      = libTc (fsLit "FieldExpQ")      fieldExpQTyConKey
 patQTyConName           = libTc (fsLit "PatQ")           patQTyConKey
@@ -550,7 +564,7 @@ liftClassKey = mkPreludeClassUnique 200
 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
     decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
     stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,
-    decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
+    decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey,
     fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
     fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
     predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,
@@ -569,8 +583,8 @@ conQTyConKey            = mkPreludeTyConUnique 210
 typeQTyConKey           = mkPreludeTyConUnique 211
 typeTyConKey            = mkPreludeTyConUnique 212
 decTyConKey             = mkPreludeTyConUnique 213
-varStrictTypeQTyConKey  = mkPreludeTyConUnique 214
-strictTypeQTyConKey     = mkPreludeTyConUnique 215
+bangTypeQTyConKey       = mkPreludeTyConUnique 214
+varBangTypeQTyConKey    = mkPreludeTyConUnique 215
 fieldExpTyConKey        = mkPreludeTyConUnique 216
 fieldPatTyConKey        = mkPreludeTyConUnique 217
 nameTyConKey            = mkPreludeTyConUnique 218
@@ -796,11 +810,17 @@ defaultSigDIdKey       = mkPreludeMiscIdUnique 357
 cxtIdKey :: Unique
 cxtIdKey            = mkPreludeMiscIdUnique 360
 
--- data Strict = ...
-isStrictKey, notStrictKey, unpackedKey :: Unique
-isStrictKey         = mkPreludeMiscIdUnique 363
-notStrictKey        = mkPreludeMiscIdUnique 364
-unpackedKey         = mkPreludeMiscIdUnique 365
+-- data SourceUnpackedness = ...
+noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique
+noSourceUnpackednessKey = mkPreludeMiscIdUnique 361
+sourceNoUnpackKey       = mkPreludeMiscIdUnique 362
+sourceUnpackKey         = mkPreludeMiscIdUnique 363
+
+-- data SourceStrictness = ...
+noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique
+noSourceStrictnessKey   = mkPreludeMiscIdUnique 364
+sourceLazyKey           = mkPreludeMiscIdUnique 365
+sourceStrictKey         = mkPreludeMiscIdUnique 366
 
 -- data Con = ...
 normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey,
@@ -812,13 +832,17 @@ forallCIdKey      = mkPreludeMiscIdUnique 373
 gadtCIdKey        = mkPreludeMiscIdUnique 374
 recGadtCIdKey     = mkPreludeMiscIdUnique 375
 
--- type StrictType = ...
-strictTKey :: Unique
-strictTKey        = mkPreludeMiscIdUnique 376
+-- data Bang = ...
+bangIdKey :: Unique
+bangIdKey         = mkPreludeMiscIdUnique 376
+
+-- type BangType = ...
+bangTKey :: Unique
+bangTKey          = mkPreludeMiscIdUnique 377
 
--- type VarStrictType = ...
-varStrictTKey :: Unique
-varStrictTKey     = mkPreludeMiscIdUnique 377
+-- type VarBangType = ...
+varBangTKey :: Unique
+varBangTKey       = mkPreludeMiscIdUnique 378
 
 -- data Type = ...
 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey,