[Git][ghc/ghc][wip/reduce-type-in-stg] Remove whitespace and work on extending note
by Jaro Reinders (＠jaro) 19 Jun '26
by Jaro Reinders (＠jaro) 19 Jun '26
19 Jun '26
Jaro Reinders pushed to branch wip/reduce-type-in-stg at Glasgow Haskell Compiler / GHC
Commits:
e577bcf9 by Jaro Reinders at 2026-06-19T13:05:53+02:00
Remove whitespace and work on extending note
- - - - -
1 changed file:
- compiler/GHC/Stg/Syntax.hs
Changes:
=====================================
compiler/GHC/Stg/Syntax.hs
=====================================
@@ -14,7 +14,7 @@ generation.
-}
module GHC.Stg.Syntax (
- StgKind(getStgKind), typeStgKind, stgKindPrimRep, stgKindPrimRep1,
+ StgKind(getStgKind), typeStgKind, stgKindPrimRep, stgKindPrimRep1,
stgKindPrimRepU, isUnboxedTupleStgKind, isLiftedTypeStgKind,
StgFArgType(..),
@@ -81,12 +81,12 @@ import GHC.Types.CostCentre ( CostCentreStack )
import GHC.Core ( AltCon )
import GHC.Core.DataCon
import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), TyCon )
-import GHC.Core.Type
- ( Type,
- tyConAppTyCon,
- typeKind,
- isUnboxedTupleKind,
- kindRep_maybe,
+import GHC.Core.Type
+ ( Type,
+ tyConAppTyCon,
+ typeKind,
+ isUnboxedTupleKind,
+ kindRep_maybe,
isLiftedRuntimeRep )
import GHC.Core.Ppr( {- instances -} )
@@ -95,11 +95,11 @@ import GHC.Types.Id
import GHC.Types.Tickish ( StgTickish )
import GHC.Types.Var.Set
import GHC.Types.Literal ( Literal, literalType )
-import GHC.Types.RepType
- ( typePrimRep,
- typePrimRep1,
- typePrimRepU,
- typePrimRep_maybe,
+import GHC.Types.RepType
+ ( typePrimRep,
+ typePrimRep1,
+ typePrimRepU,
+ typePrimRep_maybe,
kindPrimRep,
kindPrimRep1,
kindPrimRep_maybe,
@@ -169,7 +169,7 @@ There are two reasons for wanting a coarser type system:
another language might not be compatible with GHC's type system. In such a
case the kind system is often still compatible because it is so much coarser.
Examples of such projects are:
-
+
- agda2stg: https://github.com/noughtmare/agda2stg
- external-stg-interpreter: https://github.com/grin-compiler/ghc-whole-program-compiler-project/tree/ma…
@@ -189,7 +189,7 @@ There are two reasons for wanting a coarser type system:
Left _ -> r <------------- NB
Right _ -> error "urk"
- See Note [Case 2: CSEing case binders] for the full details of this
+ See Note [Case 2: CSEing case binders] for the full details of this
optimization.
This is not type-safe in Core, but it is kind-safe in STG. So, using
@@ -200,6 +200,23 @@ Note that the kinds do not always accurately reflect the final runtime
representation. For example, on the JS backend the kind 'TYPE Int64Rep'
might eventually be rewritten to 'TYPE (TupleRep [Int32Rep,Int32Rep])'
because there is no 64 bit integer type in JS.
+
+Consequences:
+
+* STG Lint checks for kind-correctness, not type-correctness.
+
+ - In an appplication, check that that kind of the argument matches the kind expected by the function
+ - In a let-binding check that the kind of the binder matches the kind of the RHS.
+ - etc
+
+ (It would be good to check these claims are true of STG Lint!)
+
+* In practice, each Id still contains its Type; but only the Kind of that type is used in STG onwards.
+ Some places still use DataCon which also still contains a reference to its type.
+
+* We define a newtype StgKind to distinguish it from Type which Kind is otherwise equal to.
+
+* What else?
-}
{-
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e577bcf96a81f8225b1936e162762e4…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e577bcf96a81f8225b1936e162762e4…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/reduce-type-in-stg] Clean up interface and expand note
by Jaro Reinders (＠jaro) 19 Jun '26
by Jaro Reinders (＠jaro) 19 Jun '26
19 Jun '26
Jaro Reinders pushed to branch wip/reduce-type-in-stg at Glasgow Haskell Compiler / GHC
Commits:
d400c2d8 by Jaro Reinders at 2026-06-19T12:47:45+02:00
Clean up interface and expand note
- - - - -
10 changed files:
- compiler/GHC/CoreToStg.hs
- compiler/GHC/Stg/BcPrep.hs
- compiler/GHC/Stg/Syntax.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm/Foreign.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToCmm/Utils.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/Utils.hs
Changes:
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -447,7 +447,7 @@ coreToStgExpr expr@(Lam {})
fun_ty = mkLamTypes val_bndrs body_ty
-- This type is a bit ill-formed but it doesn't matter
rhs = StgRhsClosure noExtFieldSilent currentCCS
- ReEntrant val_bndrs body' (MkStgKind (typeKind body_ty))
+ ReEntrant val_bndrs body' (typeStgKind body_ty)
tmp_fun = mkSysLocal (fsLit "pap") uniq ManyTy fun_ty
; return (StgLet noExtFieldSilent (StgNonRec tmp_fun rhs) $
StgApp tmp_fun []) }
@@ -607,7 +607,7 @@ mkStgApp f how_bound core_args stg_args res_ty
f_arity = stgArity f how_bound
n_val_args = length stg_args -- StgArgs are all value arguments
exactly_saturated = f_arity == n_val_args
- res_kind = MkStgKind (typeKind res_ty)
+ res_kind = typeStgKind res_ty
-- Given Core arguments to an unboxed sum datacon, return the 'PrimRep's
@@ -751,7 +751,7 @@ coreToMkStgRhs bndr expr = do
let mk_rhs = MkStgRhs
{ rhs_args = bndrs
, rhs_expr = body'
- , rhs_kind = MkStgKind (typeKind (exprType body))
+ , rhs_kind = typeStgKind (exprType body)
, rhs_is_join = isJoinId bndr
}
pure mk_rhs
=====================================
compiler/GHC/Stg/BcPrep.hs
=====================================
@@ -50,7 +50,7 @@ bcPrepRHS con@StgRhsCon{} = pure con
bcPrepExpr :: StgExpr -> BcPrepM StgExpr
-- explicitly match all constructors so we get a warning if we miss any
bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs)
- | isLiftedTypeKind tick_kind = do
+ | isLiftedTypeStgKind tick_kind = do
id <- newId tick_ty
rhs' <- bcPrepExpr rhs
let expr' = StgTick bp rhs'
@@ -59,7 +59,7 @@ bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs)
ReEntrant
[]
expr'
- (MkStgKind tick_kind)
+ tick_kind
)
letExp = StgLet noExtFieldSilent bnd (StgApp id [])
pure letExp
@@ -72,10 +72,10 @@ bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs)
ReEntrant
[voidArgId]
expr'
- (MkStgKind tick_kind)
+ tick_kind
)
pure $ StgLet noExtFieldSilent bnd (StgApp id [StgVarArg realWorldPrimId])
- where tick_kind = typeKind tick_ty
+ where tick_kind = typeStgKind tick_ty
bcPrepExpr (StgTick tick rhs) =
StgTick tick <$> bcPrepExpr rhs
bcPrepExpr (StgLet xlet bnds expr) =
=====================================
compiler/GHC/Stg/Syntax.hs
=====================================
@@ -14,7 +14,8 @@ generation.
-}
module GHC.Stg.Syntax (
- StgKind(..),
+ StgKind(getStgKind), typeStgKind, stgKindPrimRep, stgKindPrimRep1,
+ stgKindPrimRepU, isUnboxedTupleStgKind, isLiftedTypeStgKind,
StgFArgType(..),
collectStgFArgTypes,
@@ -80,7 +81,13 @@ import GHC.Types.CostCentre ( CostCentreStack )
import GHC.Core ( AltCon )
import GHC.Core.DataCon
import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), TyCon )
-import GHC.Core.Type ( Type, tyConAppTyCon )
+import GHC.Core.Type
+ ( Type,
+ tyConAppTyCon,
+ typeKind,
+ isUnboxedTupleKind,
+ kindRep_maybe,
+ isLiftedRuntimeRep )
import GHC.Core.Ppr( {- instances -} )
import GHC.Types.ForeignCall ( ForeignCall )
@@ -88,10 +95,19 @@ import GHC.Types.Id
import GHC.Types.Tickish ( StgTickish )
import GHC.Types.Var.Set
import GHC.Types.Literal ( Literal, literalType )
-import GHC.Types.RepType ( typePrimRep, typePrimRep1, typePrimRepU, typePrimRep_maybe, unwrapType )
+import GHC.Types.RepType
+ ( typePrimRep,
+ typePrimRep1,
+ typePrimRepU,
+ typePrimRep_maybe,
+ kindPrimRep,
+ kindPrimRep1,
+ kindPrimRep_maybe,
+ unwrapType )
import GHC.Utils.Outputable
import GHC.Utils.Panic.Plain
+import GHC.Utils.Panic ( pprPanic )
import GHC.Builtin.PrimOps ( PrimOp, PrimCall )
@@ -112,27 +128,54 @@ import GHC.Builtin.Types.Prim
-- Kind is otherwise equal to.
-- See Note [Kinds in STG]
newtype StgKind = MkStgKind { getStgKind :: Kind }
+-- getStgKind is only used to do some silly pretty printing in the JS backend.
+
+typeStgKind :: Type -> StgKind
+typeStgKind = MkStgKind . typeKind
+
+stgKindPrimRep1 :: StgKind -> PrimRep
+stgKindPrimRep1 = kindPrimRep1 . getStgKind
+
+stgKindPrimRepU :: StgKind -> PrimOrVoidRep
+stgKindPrimRepU (MkStgKind kind) = case kindPrimRep_maybe kind of
+ Just [] -> VoidRep
+ Just [r] -> NVRep r
+ r -> pprPanic "stgKindPrimRepU" (ppr r)
+
+stgKindPrimRep :: StgKind -> [PrimRep]
+stgKindPrimRep = kindPrimRep . getStgKind
+
+isUnboxedTupleStgKind :: StgKind -> Bool
+isUnboxedTupleStgKind = isUnboxedTupleKind . getStgKind
+
+isLiftedTypeStgKind :: StgKind -> Bool
+isLiftedTypeStgKind (MkStgKind kind)
+ = case kindRep_maybe kind of
+ Just rep -> isLiftedRuntimeRep rep
+ Nothing -> False
{-
Note [Kinds in STG]
~~~~~~~~~~~~~~~~~~~
-
-Whereas Core is type-annotated, STG is kind-annotated.
+Whereas Core is well-typed, STG is well-kinded.
Just as many different values may have a single type, so many different
types may have a single kind. So kinds are a "coarser approximation" to the
values being manipulated; and that is what we want in STG.
-There are two reasons for this:
+There are two reasons for wanting a coarser type system:
(1) It is easier for third party projects to compile to STG. The type system of
another language might not be compatible with GHC's type system. In such a
case the kind system is often still compatible because it is so much coarser.
- Example projects are Jaro Reinders' agda2stg and Csaba Hruska's external-stg.
+ Examples of such projects are:
+
+ - agda2stg: https://github.com/noughtmare/agda2stg
+ - external-stg-interpreter: https://github.com/grin-compiler/ghc-whole-program-compiler-project/tree/ma…
(2) It allows for more aggressive optimizations. In STG we may do
- type-incorrect things that are kind-correct. For example consider
- the following function:
+ type-incorrect things that are still kind-correct. For example
+ consider the following function:
f :: Either a b -> Either a c
f = \x -> case x of r
@@ -146,10 +189,12 @@ There are two reasons for this:
Left _ -> r <------------- NB
Right _ -> error "urk"
+ See Note [Case 2: CSEing case binders] for the full details of this
+ optimization.
+
This is not type-safe in Core, but it is kind-safe in STG. So, using
the coarser notion of kinds in STG allows us to do more aggressive
- optimizations. Note, however, that we do not implement any such
- optimizations yet.
+ optimizations.
Note that the kinds do not always accurately reflect the final runtime
representation. For example, on the JS backend the kind 'TYPE Int64Rep'
@@ -813,7 +858,6 @@ to move these around together, notably in StgOpApp and COpStmt.
Note [tagToEnum# in STG]
~~~~~~~~~~~~~~~~~~~~~~~~
-
STG is untyped, but 'tagToEnum#' needs type information, so we make it a special
STG operation which stores the type constructor information alongside it.
@@ -833,7 +877,6 @@ To preserve this information we desugar the 'tagToEnum#' primop into a special
'StgTagToEnumOp' which has an extra field to store the type constructor
information. This desugaring happens when converting Core to STG, which is the
last moment that we still have access to the type information.
-
-}
data StgOp
=====================================
compiler/GHC/Stg/Unarise.hs
=====================================
@@ -889,7 +889,7 @@ castArgRename ops in_arg rhs =
((op,ty,uq):rest_ops) ->
let out_id' = mkCastVar uq ty -- out_name `setIdUnique` uq `setIdType` ty
sub_cast = castArgRename rest_ops (StgVarArg out_id')
- in mkCast in_arg op out_id' (MkStgKind (typeKind ty)) $ sub_cast rhs
+ in mkCast in_arg op out_id' (typeStgKind ty) $ sub_cast rhs
-- Construct a case binder used when casting sums, of a given type and unique.
mkCastVar :: Unique -> Type -> Id
@@ -899,7 +899,7 @@ mkCast :: StgArg -> PrimOp -> OutId -> StgKind -> StgExpr -> StgExpr
mkCast arg_in cast_op out_id out_kind in_rhs =
let scrut = StgOpApp (StgPrimOp cast_op) [arg_in]
alt = GenStgAlt { alt_con = DEFAULT, alt_bndrs = [], alt_rhs = in_rhs}
- alt_ty = PrimAlt (kindPrimRep1 (getStgKind out_kind))
+ alt_ty = PrimAlt (stgKindPrimRep1 out_kind)
in (StgCase scrut out_id alt_ty [alt])
-- | Build a unboxed sum term from arguments of an alternative.
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -645,12 +645,6 @@ schemeE d s p (StgCase scrut _ _ []) = schemeE d s p scrut
schemeE d s p (StgCase scrut bndr _ alts)
= doCase d s p scrut bndr alts
-stgKindPrimRepU :: StgKind -> PrimOrVoidRep
-stgKindPrimRepU (MkStgKind kind) = case kindPrimRep_maybe kind of
- Just [] -> VoidRep
- Just [r] -> NVRep r
- r -> pprPanic "stgKindPrimRepU" (ppr r)
-
{-
Ticked Expressions
------------------
=====================================
compiler/GHC/StgToCmm/Foreign.hs
=====================================
@@ -72,7 +72,7 @@ cgForeignCall :: ForeignCall -- the op
cgForeignCall (CCall (CCallSpec target cconv safety)) arg_tys stg_args res_kind
= do { cmm_args <- getFCallArgs stg_args arg_tys
-- ; traceM $ show cmm_args
- ; (res_regs, res_hints) <- newUnboxedTupleRegs (getStgKind res_kind)
+ ; (res_regs, res_hints) <- newUnboxedTupleRegs res_kind
; let ((call_args, arg_hints), cmm_target)
= case target of
StaticTarget _ _ ForeignValue ->
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -36,7 +36,6 @@ import GHC.Cmm.Graph
import GHC.Stg.Syntax
import GHC.Cmm
import GHC.Unit ( rtsUnit )
-import GHC.Core.Type ( typeKind )
import GHC.Core.TyCon ( isEnumerationTyCon )
import GHC.Cmm.CLabel
import GHC.Cmm.Info ( closureInfoPtr )
@@ -105,7 +104,7 @@ cgOpApp (StgTagToEnumOp tyc) args = do
cmmPrimOpApp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> FCode ReturnKind
cmmPrimOpApp cfg primop cmm_args =
let PrimopCmmEmit _inline f = emitPrimOp cfg primop cmm_args
- in f (MkStgKind (typeKind (primOpResultType primop)))
+ in f (typeStgKind (primOpResultType primop))
externalPrimop :: PrimOp -> [CmmExpr] -> PrimopCmmEmit
externalPrimop primop args = outOfLinePrimop (callExternalPrimop primop args)
@@ -1919,7 +1918,7 @@ emitPrimOp cfg primop =
pure [reg]
ReturnsTuple
- -> do (regs, _hints) <- newUnboxedTupleRegs (getStgKind res_kind)
+ -> do (regs, _hints) <- newUnboxedTupleRegs res_kind
pure regs
f res_kind regs
emitReturn (map (CmmReg . CmmLocal) regs)
=====================================
compiler/GHC/StgToCmm/Utils.hs
=====================================
@@ -50,6 +50,7 @@ module GHC.StgToCmm.Utils (
import GHC.Prelude hiding ( head, init, last, tail )
import GHC.Platform
+import GHC.Stg.Syntax
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Lit (mkSimpleLit, newStringCLit)
@@ -65,7 +66,6 @@ import GHC.StgToCmm.CgUtils
import GHC.Types.ForeignCall
import GHC.Types.Id.Info
-import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Runtime.Heap.Layout
import GHC.Unit
@@ -76,7 +76,6 @@ import GHC.Types.Unique
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import GHC.Types.RepType
import GHC.Types.CostCentre
import GHC.Types.IPE
@@ -320,22 +319,20 @@ assignTemp e = do { platform <- getPlatform
; emitAssign (CmmLocal reg) e
; return reg }
-newUnboxedTupleRegs :: HasDebugCallStack => Kind -> FCode ([LocalReg], [ForeignHint])
+newUnboxedTupleRegs :: HasDebugCallStack => StgKind -> FCode ([LocalReg], [ForeignHint])
-- Choose suitable local regs to use for the components
-- of an unboxed tuple that we are about to return to
-- the Sequel. If the Sequel is a join point, using the
-- regs it wants will save later assignments.
newUnboxedTupleRegs res_kind
- = assert (isUnboxedTupleKind res_kind) $
- case kindPrimRep_maybe res_kind of
- Just reps ->
- do { platform <- getPlatform
- ; sequel <- getSequel
- ; regs <- case sequel of
- AssignTo regs _ -> regs <$ massert (regs `equalLength` reps)
- _ -> mapM (newTemp . primRepCmmType platform) reps
- ; return (regs, map primRepForeignHint reps) }
- Nothing -> pprPanic "newUnboxedTupleRegs applied to non-unboxed-tuple kind" (ppr res_kind)
+ = assert (isUnboxedTupleStgKind res_kind) $
+ let reps = stgKindPrimRep res_kind
+ in do { platform <- getPlatform
+ ; sequel <- getSequel
+ ; regs <- case sequel of
+ AssignTo regs _ -> regs <$ massert (regs `equalLength` reps)
+ _ -> mapM (newTemp . primRepCmmType platform) reps
+ ; return (regs, map primRepForeignHint reps) }
-------------------------------------------------------------------------
-- emitMultiAssign
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -366,7 +366,7 @@ resultSize kind = result
where
result = result_reps `zip` result_slots
result_slots = fmap (slotCount . primRepSize) result_reps
- result_reps = kindPrimRep (getStgKind kind)
+ result_reps = stgKindPrimRep kind
-- | Ensure that the set of identifiers has valid 'RuntimeRep's. This function
-- returns a no-op when 'csRuntimeAssert' in 'StgToJSConfig' is False.
=====================================
compiler/GHC/StgToJS/Utils.hs
=====================================
@@ -205,9 +205,7 @@ typeJSRep :: HasDebugCallStack => Type -> [JSRep]
typeJSRep t = map primRepToJSRep (typePrimRep t)
stgKindJSRep :: HasDebugCallStack => StgKind -> [JSRep]
-stgKindJSRep (MkStgKind k) = case kindPrimRep_maybe k of
- Just rs -> map primRepToJSRep rs
- Nothing -> pprPanic "kindJSRep" (ppr k)
+stgKindJSRep = map primRepToJSRep . stgKindPrimRep
-- only use if you know it's not an unboxed tuple
unaryTypeJSRep :: HasDebugCallStack => UnaryType -> JSRep
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d400c2d86603e9bece2d97e24286e23…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d400c2d86603e9bece2d97e24286e23…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/mangoiv/unused-type] compiler: rename ZonkAny to UnusedType and add pretty printing logic
by Magnus (＠MangoIV) 19 Jun '26
by Magnus (＠MangoIV) 19 Jun '26
19 Jun '26
Magnus pushed to branch wip/mangoiv/unused-type at Glasgow Haskell Compiler / GHC
Commits:
79037512 by mangoiv at 2026-06-19T12:45:00+02:00
compiler: rename ZonkAny to UnusedType and add pretty printing logic
ZonkAny is a hard to understand name for users who do not know how the
compiler works internally. Additionally, it is confusing that ZonkAny,
while being a concrete type *represents* a meta variable, espeically in
the compiler output.
This patch changes the name of ZonkAny to UnusedType which is closer to
its intended semantics and adds special pretty printing logic to display
this type in the same fashion the compiler displays meta variables in
other places, whenever they leak from the implementation to the user.
Fixes #27390
- - - - -
17 changed files:
- + changelog.d/unused-type
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Zonk/Type.hs
- libraries/ghc-internal/src/GHC/Internal/Types.hs
- testsuite/tests/perf/compiler/T11068.stdout
- testsuite/tests/pmcheck/should_compile/T12957.stderr
- testsuite/tests/profiling/should_run/staticcallstack002.stdout
- testsuite/tests/simplCore/should_compile/Makefile
- testsuite/tests/simplCore/should_compile/T13156.stdout
- testsuite/tests/simplCore/should_compile/T26615.stderr
- testsuite/tests/typecheck/should_fail/T13292.stderr
Changes:
=====================================
changelog.d/unused-type
=====================================
@@ -0,0 +1,14 @@
+section: compiler
+synopsis: Rename ZonkAny to UnusedType and add pretty printing logic for it.
+issues: #27390
+mrs: !16212
+
+description: {
+ After unification GHC fills in unused type variables with a fixed kind like in
+ ``(length :: [alpha] -> Int) ([] :: List alpha) :: Int`` with a fixed type.
+ This type was, confusingly to the user, called ``ZonkAny``.
+ We rename this type to ``UnusedType``, store naming information, and try hard to
+ pretty print it to something that is more resemblant of an unused in non-debugging
+ compiler output. We also export ``UnusedType`` from ``GHC.Internal.Types`` to make
+ it easier to discover without reading the GHC source code.
+}
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -1904,8 +1904,8 @@ unsatisfiableClassNameKey = mkPreludeTyConUnique 170
anyTyConKey :: Unique
anyTyConKey = mkPreludeTyConUnique 171
-zonkAnyTyConKey :: Unique
-zonkAnyTyConKey = mkPreludeTyConUnique 172
+unusedTypeTyConKey :: Unique
+unusedTypeTyConKey = mkPreludeTyConUnique 172
-- Custom user type-errors
errorMessageTypeErrorFamKey :: Unique
=====================================
compiler/GHC/Builtin/Types.hs
=====================================
@@ -93,7 +93,7 @@ module GHC.Builtin.Types (
cTupleSelId, cTupleSelIdName,
-- * Any
- anyTyCon, anyTy, anyTypeOfKind, zonkAnyTyCon,
+ anyTyCon, anyTy, anyTypeOfKind, unusedTypeTyCon,
-- * Recovery TyCon
makeRecoveryTyCon,
@@ -300,7 +300,7 @@ wiredInTyCons :: [TyCon]
wiredInTyCons = map (dataConTyCon . snd) boxingDataCons
++ [ anyTyCon
- , zonkAnyTyCon
+ , unusedTypeTyCon
, boolTyCon
, charTyCon
, stringTyCon
@@ -412,13 +412,13 @@ doubleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#")
{-
Note [Any types]
~~~~~~~~~~~~~~~~
-The type constructors `Any` and `ZonkAny` are closed type families declared thus:
+The type constructors `Any` and `UnusedType` are closed type families declared thus:
- type family Any :: forall k. k where { }
- type family ZonkAny :: forall k. Nat -> k where { }
+ type family Any :: forall k. k where { }
+ type family UnusedType :: forall k. Nat -> Symbol -> k where { }
They are used when we want a type of a particular kind, but we don't really care
-what that type is. The leading example is this: `ZonkAny` is used to instantiate
+what that type is. The leading example is this: `UnusedType` is used to instantiate
un-constrained type variables after type checking. For example, consider the
term (length [] :: Int), where
@@ -431,26 +431,26 @@ The typechecker will end up with
length @alpha ([] @alpha)
where `alpha` is an un-constrained unification variable. The "zonking" process zaps
-that unconstrained `alpha` to an arbitrary type (ZonkAny @Type 3), where the `3` is
-arbitrary (see wrinkle (Any5) below). This is done in `GHC.Tc.Zonk.Type.commitFlexi`.
-So we end up with
+that unconstrained `alpha` to an arbitrary type (UnusedType @Type 3 "a"), where the `3` is
+arbitrary (see wrinkle (Any5) below) and "a" is the name string of the meta variable.
+This is done in `GHC.Tc.Zonk.Type.commitFlexi`. So we end up with
- length @(ZonkAny @Type 3) ([] @(ZonkAny @Type 3))
+ length @(UnusedType @Type 3 "a") ([] @(UnusedType @Type 3 "a"))
-`Any` and `ZonkAny` differ only in the presence of the `Nat` argument; see
-wrinkle (Any4).
+`Any` and `UnusedType` differ only in the presence of the `Nat` and the `Symbol` arguments;
+see wrinkle (Any4).
Wrinkles:
-(Any1) `Any` and `ZonkAny` are kind polymorphic since in some program we may
- need to use `ZonkAny` to fill in a type variable of some kind other than *
+(Any1) `Any` and `UnusedType` are kind polymorphic since in some program we may
+ need to use `UnusedType` to fill in a type variable of some kind other than *
(see #959 for examples).
(Any2) They are /closed/ type families, with no instances. For example, suppose that
with alpha :: '(k1, k2) we add a given coercion
g :: alpha ~ (Fst alpha, Snd alpha)
- and we zonked alpha = ZonkAny @(k1,k2) n. Then, if `ZonkAny` was a /data/ type,
- we'd get inconsistency because we'd have a Given equality with `ZonkAny` on one
+ and we zonked alpha = UnusedType @(k1,k2) n. Then, if `UnusedType` was a /data/ type,
+ we'd get inconsistency because we'd have a Given equality with `UnusedType` on one
side and '(,) on the other. See also #9097 and #9636.
See #25244 for a suggestion that we instead use an /open/ type family for which
@@ -459,8 +459,11 @@ Wrinkles:
(Any3) They do not claim to be /data/ types, and that's important for
the code generator, because the code gen may /enter/ a data value
but never enters a function value.
+ This is the motivation for the primary use case of `Any` in userspace which is
+ implementing type safe interfaces with improved performance characteristics,
+ e.g. storing `Any` leaves as the values for a finite dependent Map.
-(Any4) `ZonkAny` takes a `Nat` argument so that we can readily make up /distinct/
+(Any4) `UnusedType` takes a `Nat` argument so that we can readily make up /distinct/
types (#24817). Consider
data SBool a where { STrue :: SBool True; SFalse :: SBool False }
@@ -475,25 +478,47 @@ Wrinkles:
Now, what are `alpha` and `beta`? If we zonk both of them to the same type
`Any @Type`, the pattern-match checker will (wrongly) report that the first
branch is inaccessible. So we zonk them to two /different/ types:
- alpha := ZonkAny @Type 4 and beta := ZonkAny @Type k 5
+ alpha := UnusedType @Type 4 "a" and beta := UnusedType @Type k 5 "b"
(The actual numbers are arbitrary; they just need to differ.)
The unique-name generation comes from field `tcg_zany_n` of `TcGblEnv`; and
- `GHC.Tc.Zonk.Type.commitFlexi` calls `GHC.Tc.Utils.Monad.newZonkAnyType` to
+ `GHC.Tc.Zonk.Type.commitFlexi` calls `GHC.Tc.Utils.Monad.newUnusedTypeType` to
make up a fresh type.
If this example seems unconvincing (e.g. in this case foo must be bottom)
see #24817 for larger but more compelling examples.
-(Any5) `Any` and `ZonkAny` are wired-in so we can easily refer to it where we
+(Any9)
+ `UnusedType` takes a `Symbol` argument, which we use to neatly display zonked unfilled
+ metavariables without leaking internal type families.
+
+ See T13292 for an example of this in action.
+
+ `UnusedType` is handled specially in the pretty-printer to avoid confusing compiler output.
+ For example, `UnusedType 3 "foo" :: Type` is displayed as `foo3`
+
+ That special handling is implemented in GHC.Iface.Type.pprTyTcApp and more specifically
+ ppr_iface_unused_ty_tycon.
+
+ Historical note: in the past, `UnusedType` was called `ZonkAny` (or `Any` before that).
+ We renamed it to `UnusedType` and added this special treatment in the pretty-printer to avoid
+ confusing mentions of zonking.
+
+(Any5) `Any` and `UnusedType` are wired-in so we can easily refer to it where we
don't have a name environment (e.g. see Rules.matchRule for one example)
-(Any6) `Any` is defined in library module ghc-prim:GHC.Types, and exported so that
- it is available to users. For this reason it's treated like any other
- wired-in type:
- - has a fixed unique, anyTyConKey,
+(Any6) `Any` is defined in library module ghc-internal:GHC.Internal.Types, and exported
+ and exported. `Any` should be available to users mainly because it is a useful type
+ in userspace and is thus re-exported from `GHC.Exts`.
+
+ `UnusedType` coudl be exported mainly for documentation in case a user stumbles over it
+ in debug output of GHC. However, since we do want to actually have the user use that type
+ and discoverability of internal modules is (and should be) low, and the fact that we
+ cannot depend on `Natural` in ghc-internal:GHC.Internal.Types, we do not export it.
+
+ `Any` is treated like any other wired-in types:
+ - it has a fixed unique, anyTyConKey
- lives in the global name cache
- Currently `ZonkAny` is not available to users; but it could easily be.
(Any7) Properties of `Any`:
* When `Any` is instantiated at a lifted type it is inhabited by at least one value,
@@ -512,7 +537,7 @@ Wrinkles:
See examples in ghc-prim:GHC.Types
-(Any8) Warning about unused bindings of type `Any` and `ZonkAny` are suppressed,
+(Any8) Warning about unused bindings of type `Any` and `UnusedType` are suppressed,
following the same rationale of supressing warning about the unit type.
For example, consider (#25895):
@@ -520,7 +545,7 @@ Wrinkles:
do { forever (return ()); blah }
where forever :: forall a b. IO a -> IO b
- Nothing constrains `b`, so it will be instantiates with `Any` or `ZonkAny`.
+ Nothing constrains `b`, so it will be instantiates with `Any` or `UnusedType`.
But we certainly don't want to complain about a discarded do-binding.
The Any tycon used to be quite magic, but we have since been able to
@@ -550,22 +575,23 @@ anyTy = mkTyConTy anyTyCon
anyTypeOfKind :: Kind -> Type
anyTypeOfKind kind = mkTyConApp anyTyCon [kind]
-zonkAnyTyConName :: Name
-zonkAnyTyConName =
- mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZonkAny") zonkAnyTyConKey zonkAnyTyCon
+unusedTypeTyConName :: Name
+unusedTypeTyConName =
+ mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnusedType") unusedTypeTyConKey unusedTypeTyCon
-zonkAnyTyCon :: TyCon
--- ZonkAnyTyCon :: forall k. Nat -> k
+unusedTypeTyCon :: TyCon
+-- unusedTypeTyCon :: forall k. Nat -> Symbol -> k
-- See Note [Any types]
-zonkAnyTyCon = mkFamilyTyCon zonkAnyTyConName kind bndrs 0 res_kind
+unusedTypeTyCon = mkFamilyTyCon unusedTypeTyConName kind bndrs 0 res_kind
Nothing
(ClosedSynFamilyTyCon Nothing)
Nothing
NotInjective
where
- [kv,nat_kv] = mkTemplateKindVars [liftedTypeKind, naturalTy]
+ [kv,nat_kv,sym_kv] = mkTemplateKindVars [liftedTypeKind, naturalTy, typeSymbolKind]
bndrs = [ mkNamedTyConBinder Specified kv
- , mkAnonTyConBinder nat_kv ]
+ , mkAnonTyConBinder nat_kv
+ , mkAnonTyConBinder sym_kv ]
res_kind = mkTyVarTy kv
kind = mkTyConKind bndrs res_kind
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -1281,11 +1281,11 @@ warnDiscardedDoBindings rhs@(L rhs_loc _) m_ty elt_ty
do { fam_inst_envs <- dsGetFamInstEnvs
; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
supressible_ty =
- isUnitTy norm_elt_ty || isAnyTy norm_elt_ty || isZonkAnyTy norm_elt_ty
+ isUnitTy norm_elt_ty || isAnyTy norm_elt_ty || isUnusedTypeTy norm_elt_ty
-- Warn about discarding things in 'monadic' binding,
-- however few types are excluded:
-- * Unit type `()`
- -- * `ZonkAny` or `Any` type see (Any8) of Note [Any types]
+ -- * `UnusedType` or `Any` type see (Any8) of Note [Any types]
; if warn_unused && not supressible_ty
then diagnosticDs (DsUnusedDoBind rhs elt_ty)
else
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -7,7 +7,7 @@ This module defines interface types and binders
-}
-{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE MultiWayIf, OverloadedRecordDot #-}
module GHC.Iface.Type (
IfExtName,
IfLclName(..), mkIfLclName, ifLclNameFS,
@@ -1740,6 +1740,7 @@ pprTyTcApp ctxt_prec tc tys =
sdocOption sdocPrintExplicitKinds $ \print_kinds ->
sdocOption sdocPrintTypeAbbreviations $ \print_type_abbreviations ->
getPprDebug $ \debug ->
+ getPprStyle $ \style ->
if | ifaceTyConName tc `hasKey` ipClassKey
, IA_Arg (IfaceLitTy (IfaceStrTyLit n))
@@ -1791,6 +1792,13 @@ pprTyTcApp ctxt_prec tc tys =
| Just doc <- ppr_equality ctxt_prec tc (appArgsIfaceTypes tys)
-> doc
+ -- See Note [Any types], specifically (Any4) and (Any9)
+ | ifaceTyConName tc `hasKey` unusedTypeTyConKey
+ , (arg_k : IfaceLitTy (IfaceNumTyLit arg_n) : IfaceLitTy (IfaceStrTyLit arg_nm) : _) <- appArgsIfaceTypes tys
+ -- if arg_k is a kind with more than 0 arguments, then _ might not be [] here
+ , userStyle style
+ -> ppr_iface_unused_ty_tycon ctxt_prec arg_k arg_n arg_nm
+
| otherwise
-> ppr_iface_tc_app ppr_app_arg ctxt_prec tc $
appArgsIfaceTypesForAllTyFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) tys
@@ -1802,6 +1810,19 @@ ppr_kind_type ctxt_prec = sdocOption sdocStarIsType $ \case
False -> pprPrefixOcc liftedTypeKindTyConName
True -> maybeParen ctxt_prec starPrec starLit
+-- | user-style printer that pretty-prints an 'UnusedType @k 3 "foo" to foo3.
+-- If -fprint-explicit-kinds or -fprint-explicit-runtime-reps are set, instead
+-- prints them to (foo3 :: k).
+-- See Note [Any types], specifically (Any4) and (Any9) for why this is useful.
+ppr_iface_unused_ty_tycon :: PprPrec -> IfaceType -> Integer -> LexicalFastString -> SDoc
+ppr_iface_unused_ty_tycon ctxt_prec arg_k arg_n arg_nm
+ = sdocOption sdocPrintExplicitKinds $ \print_kinds ->
+ sdocOption sdocPrintExplicitRuntimeReps $ \print_reps ->
+ if print_kinds || print_reps
+ then maybeParen ctxt_prec sigPrec $ prettyMeta <+> text "::" <+> pprIfaceType arg_k
+ else prettyMeta
+ where prettyMeta = ppr arg_nm <> ppr arg_n
+
-- | Pretty-print a type-level equality.
-- Returns (Just doc) if the argument is a /saturated/ application
-- of eqTyCon (~)
@@ -2190,7 +2211,8 @@ instance Binary IfaceTyConSort where
0 -> return IfaceNormalTyCon
1 -> IfaceTupleTyCon <$> get bh <*> get bh
2 -> IfaceSumTyCon <$> get bh
- _ -> return IfaceEqualityTyCon
+ 3 -> return IfaceEqualityTyCon
+ _ -> panic "get IfaceTyConSort"
instance Binary IfaceTyConInfo where
put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -582,7 +582,7 @@ data TcGblEnv
-- ^ Allows us to choose unique DFun names.
tcg_zany_n :: TcRef Integer,
- -- ^ A source of unique identities for ZonkAny instances
+ -- ^ A source of unique identities for UnusedType instances
-- See Note [Any types] in GHC.Builtin.Types, wrinkle (Any4)
tcg_merged :: [(Module, Fingerprint)],
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -154,7 +154,7 @@ module GHC.Tc.Utils.Monad(
getCCIndexM, getCCIndexTcM,
-- * Zonking
- liftZonkM, newZonkAnyType,
+ liftZonkM, newUnusedType,
-- * Complete matches
localAndImportedCompleteMatches, getCompleteMatchesTcM,
@@ -168,7 +168,7 @@ import GHC.Prelude
import GHC.Builtin.Names
-import GHC.Builtin.Types( zonkAnyTyCon )
+import GHC.Builtin.Types( unusedTypeTyCon )
import GHC.Tc.Errors.Types
import GHC.Tc.Errors.Hole.Plugin ( HoleFitPlugin, HoleFitPluginR (..) )
@@ -197,7 +197,7 @@ import GHC.Core.Coercion ( isReflCo )
import GHC.Core.Multiplicity
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
-import GHC.Core.Type( mkNumLitTy )
+import GHC.Core.Type( mkNumLitTy, mkStrLitTy )
import GHC.Core.TyCo.Rep( CoercionHole(..) )
import GHC.Core.TyCo.FVs( coVarsOfCo )
import GHC.Core.TyCon ( TyCon )
@@ -2258,17 +2258,17 @@ chooseUniqueOccTc fn =
; writeTcRef dfun_n_var (extendOccSet set occ)
; return occ }
-newZonkAnyType :: Kind -> TcM Type
--- Return a type (ZonkAny @k n), where n is fresh
--- Recall ZonkAny :: forall k. Natural -> k
+newUnusedType :: Name -> Kind -> TcM Type
+-- Return a type (UnusedType @k n sym), where n is fresh
+-- Recall UnusedType :: forall k. Natural -> Symbol -> k
-- See Note [Any types] in GHC.Builtin.Types, wrinkle (Any4)
-newZonkAnyType kind
+newUnusedType name kind
= do { env <- getGblEnv
; let zany_n_var = tcg_zany_n env
; i <- readTcRef zany_n_var
; let !i2 = i+1
; writeTcRef zany_n_var i2
- ; return (mkTyConApp zonkAnyTyCon [kind, mkNumLitTy i]) }
+ ; return (mkTyConApp unusedTypeTyCon [kind, mkNumLitTy i, mkStrLitTy $ getOccFS name ]) }
getConstraintVar :: TcM (TcRef WantedConstraints)
getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -85,7 +85,7 @@ module GHC.Tc.Utils.TcType (
isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy,
isFloatingPrimTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
isIntegerTy, isNaturalTy,
- isBoolTy, isUnitTy, isAnyTy, isZonkAnyTy, isCharTy,
+ isBoolTy, isUnitTy, isAnyTy, isUnusedTypeTy, isCharTy,
isTauTy, isTauTyCon, tcIsTyVarTy,
isPredTy, isSimplePredTy, isTyVarClassPred,
checkValidClsArgs, hasTyVarHead,
@@ -2057,7 +2057,7 @@ isFloatTy, isDoubleTy,
isFloatPrimTy, isDoublePrimTy,
isIntegerTy, isNaturalTy,
isIntTy, isWordTy, isBoolTy,
- isUnitTy, isAnyTy, isZonkAnyTy, isCharTy :: Type -> Bool
+ isUnitTy, isAnyTy, isUnusedTypeTy, isCharTy :: Type -> Bool
isFloatTy = is_tc floatTyConKey
isDoubleTy = is_tc doubleTyConKey
isFloatPrimTy = is_tc floatPrimTyConKey
@@ -2069,7 +2069,7 @@ isWordTy = is_tc wordTyConKey
isBoolTy = is_tc boolTyConKey
isUnitTy = is_tc unitTyConKey
isAnyTy = is_tc anyTyConKey
-isZonkAnyTy = is_tc zonkAnyTyConKey
+isUnusedTypeTy = is_tc unusedTypeTyConKey
isCharTy = is_tc charTyConKey
-- | Check whether the type is of the form @Any :: k@,
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedRecordDot #-}
{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1996-1998
@@ -43,7 +44,7 @@ import GHC.Tc.Types.TcRef
import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo )
import GHC.Tc.Utils.Env ( tcLookupGlobalOnly )
import GHC.Tc.Utils.TcType
-import GHC.Tc.Utils.Monad ( newZonkAnyType, setSrcSpanA, liftZonkM, traceTc, addErr )
+import GHC.Tc.Utils.Monad ( newUnusedType, setSrcSpanA, liftZonkM, traceTc, addErr )
import GHC.Tc.Types.Evidence
import GHC.Tc.Errors.Types
import GHC.Tc.Zonk.Env
@@ -470,11 +471,11 @@ commitFlexi DefaultFlexi tv zonked_kind
; return manyDataConTy }
| Just (ConcreteFRR origin) <- isConcreteTyVar_maybe tv
= do { addErr $ TcRnZonkerMessage (ZonkerCannotDefaultConcrete origin)
- ; newZonkAnyType zonked_kind }
+ ; newUnusedType tv.varName zonked_kind }
| otherwise
- = do { traceTc "Defaulting flexi tyvar to ZonkAny:" (pprTyVar tv)
+ = do { traceTc "Defaulting flexi tyvar to UnusedType:" (pprTyVar tv)
-- See Note [Any types] in GHC.Builtin.Types, esp wrinkle (Any4)
- ; newZonkAnyType zonked_kind }
+ ; newUnusedType tv.varName zonked_kind }
zonkCoVarOcc :: CoVar -> ZonkTcM Coercion
zonkCoVarOcc cv
=====================================
libraries/ghc-internal/src/GHC/Internal/Types.hs
=====================================
@@ -35,6 +35,7 @@ module GHC.Internal.Types (
SPEC(..),
Symbol,
Any,
+ UnusedType,
-- * Type equality
type (~), type (~~), Coercible,
@@ -284,43 +285,33 @@ data Symbol
* *
********************************************************************* -}
--- | The type constructor @Any :: forall k. k@ is a type to which you can unsafely coerce any type, and back.
+-- | The type constructor @Any :: forall k. k@ allows creating an arbitrary type
+-- of the given kind.
--
--- For @unsafeCoerce@ this means for all lifted types @t@ that
--- @unsafeCoerce (unsafeCoerce x :: Any) :: t@ is equivalent to @x@ and safe.
+-- It can be used to create a placeholder type when you only have a kind in hand.
--
--- The same is true for *all* types when using
--- @
--- unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
--- (a :: TYPE r1) (b :: TYPE r2).
--- a -> b
--- @
--- but /only/ if you instantiate @r1@ and @r2@ to the /same/ runtime representation.
--- For example using @(unsafeCoerce# :: forall (a :: TYPE IntRep) (b :: TYPE IntRep). a -> b) x@
--- is fine, but @(unsafeCoerce# :: forall (a :: TYPE IntRep) (b :: TYPE FloatRep). a -> b)@
--- will likely cause seg-faults or worse.
--- For this resason, users should always prefer unsafeCoerce over unsafeCoerce# when possible.
+-- You can use 'unsafeCoerce#' to unsafely coerce a value from @ty :: k@ to @Any \@k@
+-- and back. As per the documentation of 'unsafeCoerce#', this is only sound if both
+-- sides have the __exact same__runtime representation. Some examples:
--
--- Here are some more examples:
-- @
--- bad_a1 :: Any @(TYPE 'IntRep)
--- bad_a1 = unsafeCoerce# True
---
--- bad_a2 :: Any @(TYPE ('BoxedRep 'UnliftedRep))
--- bad_a2 = unsafeCoerce# True
+-- unsafeCoerce# True :: (Any :: Type) -- OK
+-- unsafeCoerce# (1# :: Int#) :: (Any :: TYPE IntRep) -- OK
+-- unsafeCoerce# True :: (Any :: Type IntRep) -- INVALID
+-- unsafeCoerce True :: (Any :: UnliftedType) -- INVALID
+-- unsafeCoerce (ba :: ByteArray#) :: (Any :: Type) -- INVALID
-- @
--- Here @bad_a1@ is bad because we started with @True :: (Bool :: Type)@, represented by a boxed heap pointer,
--- and coerced it to @a1 :: Any @(TYPE 'IntRep)@, whose representation is a non-pointer integer.
--- That's why we had to use `unsafeCoerce#`; it is really unsafe because it can change representations.
--- Similarly @bad_a2@ is bad because although both @True@ and @bad_a2@ are represented by a heap pointer,
--- @True@ is lifted but @bad_a2@ is not; bugs here may be rather subtle.
--
--- If you must use unsafeCoerce# to cast to `Any`, type annotations are recommended
--- to make sure that @Any@ has the correct kind. As casting between different runtimereps is
--- unsound. For example to cast a @ByteArray#@ to @Any@ you might use:
--- @
--- unsafeCoerce# b :: (Any :: TYPE ('BoxedRep 'Unlifted))
--- @
+-- To avoid accidentally unsafe-coercing between different representations,
+-- it is recommended to:
+-- - use explicit type annotations or type applications at every use-site
+-- of 'unsafeCoerce#'
+-- - use representation-monomorphic variants such as 'unsafeCoerce' or
+-- 'unsafeCoerceUnlifted'.
+--
+-- In particular, this also implies it is safe to round-trip unsafe-coercion via 'Any',
+-- as long as the kinds line up e.g. @unsafeCoerce (unsafeCoerce (val :: a) :: 'Any') :: a@
+-- is safe in that way.
type family Any :: k where { }
-- See Note [Any types] in GHC.Builtin.Types. Also, for a bit of history on Any see
-- #10886. Note that this must be a *closed* type family: we need to ensure
=====================================
testsuite/tests/perf/compiler/T11068.stdout
=====================================
@@ -23,137 +23,137 @@
`cast` (GHC.Internal.Generics.N:M1
`cast` (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
=====================================
testsuite/tests/pmcheck/should_compile/T12957.stderr
=====================================
@@ -1,7 +1,6 @@
T12957.hs:4:5: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
- Patterns of type ‘[GHC.Internal.Types.ZonkAny 0]’ not matched: []
+ In a case alternative: Patterns of type ‘[a0]’ not matched: []
T12957.hs:4:16: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)]
Pattern match is redundant
=====================================
testsuite/tests/profiling/should_run/staticcallstack002.stdout
=====================================
@@ -1,4 +1,4 @@
-Just (InfoProv {ipName = "sat_s1Rh_info", ipDesc = THUNK, ipTyDesc = "ZonkAny 0", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "10:23-39"})
-Just (InfoProv {ipName = "sat_s1RB_info", ipDesc = THUNK, ipTyDesc = "ZonkAny 1", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "11:23-42"})
-Just (InfoProv {ipName = "sat_s1RV_info", ipDesc = THUNK, ipTyDesc = "ZonkAny 2", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "12:23-46"})
-Just (InfoProv {ipName = "sat_s1Sf_info", ipDesc = THUNK, ipTyDesc = "ZonkAny 3", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "13:23-44"})
+Just (InfoProv {ipName = "main_sat_t2fs_info", ipDesc = THUNK, ipTyDesc = "UnusedType 0 \"a\"", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "10:23-39"})
+Just (InfoProv {ipName = "main_sat_t2fJ_info", ipDesc = THUNK, ipTyDesc = "UnusedType 1 \"a\"", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "11:23-42"})
+Just (InfoProv {ipName = "main_sat_t2g0_info", ipDesc = THUNK, ipTyDesc = "UnusedType 2 \"a\"", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "12:23-46"})
+Just (InfoProv {ipName = "main_sat_t2gh_info", ipDesc = THUNK, ipTyDesc = "UnusedType 3 \"a\"", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "13:23-44"})
=====================================
testsuite/tests/simplCore/should_compile/Makefile
=====================================
@@ -188,7 +188,7 @@ T13155:
T13156:
$(RM) -f T13156.hi T13156.o
- '$(TEST_HC)' $(TEST_HC_OPTS) -c T13156.hs -O -ddump-prep -dsuppress-uniques | grep "case.*Any"
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c T13156.hs -O -ddump-prep -dsuppress-uniques | grep "case.*UnusedType"
# There should be a single 'case r @ GHC.Types.Any'
.PHONY: T4138
=====================================
testsuite/tests/simplCore/should_compile/T13156.stdout
=====================================
@@ -1,2 +1,2 @@
- case r @(GHC.Internal.Types.ZonkAny 0) of { __DEFAULT ->
- case r @(GHC.Internal.Types.ZonkAny 1) of { __DEFAULT -> r @a }
+ case r @(GHC.Internal.Types.UnusedType 0 "a") of { __DEFAULT ->
+ case r @(GHC.Internal.Types.UnusedType 1 "a") of { __DEFAULT ->
=====================================
testsuite/tests/simplCore/should_compile/T26615.stderr
=====================================
@@ -2,7 +2,7 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 1,209, types: 1,139, coercions: 18, joins: 17/29}
+ = {terms: 1,209, types: 1,155, coercions: 18, joins: 17/29}
-- RHS size: {terms: 6, types: 8, coercions: 0, joins: 0/0}
unArray :: forall a. Array a -> SmallArray# a
@@ -15,45 +15,29 @@ unArray :: forall a. Array a -> SmallArray# a
unArray = \ (@a) (ds :: Array a) -> case ds of { Array ds1 -> ds1 }
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$trModule4 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 20 0}]
-T26615a.$trModule4 = "main"#
+$trModule1 :: Addr#
+[GblId, Unf=OtherCon []]
+$trModule1 = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$trModule3 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$trModule3 = GHC.Internal.Types.TrNameS T26615a.$trModule4
+$trModule2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$trModule2 = GHC.Internal.Types.TrNameS $trModule1
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$trModule2 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$trModule2 = "T26615a"#
+$trModule3 :: Addr#
+[GblId, Unf=OtherCon []]
+$trModule3 = "T26615a"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$trModule1 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$trModule1 = GHC.Internal.Types.TrNameS T26615a.$trModule2
+$trModule4 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$trModule4 = GHC.Internal.Types.TrNameS $trModule3
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$trModule :: GHC.Internal.Types.Module
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$trModule
- = GHC.Internal.Types.Module T26615a.$trModule3 T26615a.$trModule1
+T26615a.$trModule [InlPrag=[~]] :: GHC.Internal.Types.Module
+[GblId, Unf=OtherCon []]
+T26615a.$trModule = GHC.Internal.Types.Module $trModule2 $trModule4
-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
$krep :: GHC.Internal.Types.KindRep
@@ -104,33 +88,24 @@ $krep6
GHC.Internal.Types.$tcSmallArray# $krep5
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcLeaf2 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 20 0}]
-T26615a.$tcLeaf2 = "Leaf"#
+$tcLeaf1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tcLeaf1 = "Leaf"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcLeaf1 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tcLeaf1 = GHC.Internal.Types.TrNameS T26615a.$tcLeaf2
+$tcLeaf2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tcLeaf2 = GHC.Internal.Types.TrNameS $tcLeaf1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcLeaf :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tcLeaf [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tcLeaf
= GHC.Internal.Types.TyCon
13798714324392902582#Word64
3237499036029031497#Word64
T26615a.$trModule
- T26615a.$tcLeaf1
+ $tcLeaf2
0#
GHC.Internal.Types.krep$*->*->*
@@ -160,372 +135,284 @@ $krep10 :: GHC.Internal.Types.KindRep
$krep10 = GHC.Internal.Types.KindRepFun $krep2 $krep9
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'L1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep
+$krep11 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'L1 = GHC.Internal.Types.KindRepFun $krep3 $krep10
+$krep11 = GHC.Internal.Types.KindRepFun $krep3 $krep10
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'L3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 20 0}]
-T26615a.$tc'L3 = "'L"#
+$tc'L1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'L1 = "'L"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'L2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'L2 = GHC.Internal.Types.TrNameS T26615a.$tc'L3
+$tc'L2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'L2 = GHC.Internal.Types.TrNameS $tc'L1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'L :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'L [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'L
= GHC.Internal.Types.TyCon
8570419491837374712#Word64
2090006989092642392#Word64
T26615a.$trModule
- T26615a.$tc'L2
+ $tc'L2
2#
- T26615a.$tc'L1
+ $krep11
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcArray2 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$tcArray2 = "Array"#
+$tcArray1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tcArray1 = "Array"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcArray1 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tcArray1 = GHC.Internal.Types.TrNameS T26615a.$tcArray2
+$tcArray2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tcArray2 = GHC.Internal.Types.TrNameS $tcArray1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcArray :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tcArray [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tcArray
= GHC.Internal.Types.TyCon
10495761415291712389#Word64
7580086293698619153#Word64
T26615a.$trModule
- T26615a.$tcArray1
+ $tcArray2
0#
GHC.Internal.Types.krep$*Arr*
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-$krep11 :: GHC.Internal.Types.KindRep
+$krep12 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-$krep11
+$krep12
= GHC.Internal.Types.KindRepTyConApp T26615a.$tcArray $krep4
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Array1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep
+$krep13 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'Array1 = GHC.Internal.Types.KindRepFun $krep6 $krep11
+$krep13 = GHC.Internal.Types.KindRepFun $krep6 $krep12
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Array3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$tc'Array3 = "'Array"#
+$tc'Array1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'Array1 = "'Array"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Array2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'Array2 = GHC.Internal.Types.TrNameS T26615a.$tc'Array3
+$tc'Array2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'Array2 = GHC.Internal.Types.TrNameS $tc'Array1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Array :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'Array [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'Array
= GHC.Internal.Types.TyCon
12424115309881832159#Word64
15542868641947707803#Word64
T26615a.$trModule
- T26615a.$tc'Array2
+ $tc'Array2
1#
- T26615a.$tc'Array1
+ $krep13
-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
-$krep12 :: [GHC.Internal.Types.KindRep]
+$krep14 :: [GHC.Internal.Types.KindRep]
[GblId, Unf=OtherCon []]
-$krep12
+$krep14
= GHC.Internal.Types.:
@GHC.Internal.Types.KindRep
$krep9
(GHC.Internal.Types.[] @GHC.Internal.Types.KindRep)
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-$krep13 :: GHC.Internal.Types.KindRep
+$krep15 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-$krep13
- = GHC.Internal.Types.KindRepTyConApp T26615a.$tcArray $krep12
+$krep15
+ = GHC.Internal.Types.KindRepTyConApp T26615a.$tcArray $krep14
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcHashMap2 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$tcHashMap2 = "HashMap"#
+$tcHashMap1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tcHashMap1 = "HashMap"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcHashMap1 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tcHashMap1
- = GHC.Internal.Types.TrNameS T26615a.$tcHashMap2
+$tcHashMap2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tcHashMap2 = GHC.Internal.Types.TrNameS $tcHashMap1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcHashMap :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tcHashMap [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tcHashMap
= GHC.Internal.Types.TyCon
2021755758654901686#Word64
8209241086311595496#Word64
T26615a.$trModule
- T26615a.$tcHashMap1
+ $tcHashMap2
0#
GHC.Internal.Types.krep$*->*->*
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Empty1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep
+$krep16 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'Empty1
+$krep16
= GHC.Internal.Types.KindRepTyConApp T26615a.$tcHashMap $krep8
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Empty3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$tc'Empty3 = "'Empty"#
+$tc'Empty1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'Empty1 = "'Empty"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Empty2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'Empty2 = GHC.Internal.Types.TrNameS T26615a.$tc'Empty3
+$tc'Empty2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'Empty2 = GHC.Internal.Types.TrNameS $tc'Empty1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Empty :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'Empty [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'Empty
= GHC.Internal.Types.TyCon
2520556399233147460#Word64
17224648764450205443#Word64
T26615a.$trModule
- T26615a.$tc'Empty2
+ $tc'Empty2
2#
- T26615a.$tc'Empty1
+ $krep16
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-$krep14 :: GHC.Internal.Types.KindRep
+$krep17 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-$krep14 = GHC.Internal.Types.KindRepFun $krep9 T26615a.$tc'Empty1
+$krep17 = GHC.Internal.Types.KindRepFun $krep9 $krep16
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Leaf1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep
+$krep18 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'Leaf1 = GHC.Internal.Types.KindRepFun $krep1 $krep14
+$krep18 = GHC.Internal.Types.KindRepFun $krep1 $krep17
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Leaf3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$tc'Leaf3 = "'Leaf"#
+$tc'Leaf1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'Leaf1 = "'Leaf"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Leaf2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'Leaf2 = GHC.Internal.Types.TrNameS T26615a.$tc'Leaf3
+$tc'Leaf2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'Leaf2 = GHC.Internal.Types.TrNameS $tc'Leaf1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Leaf :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'Leaf [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'Leaf
= GHC.Internal.Types.TyCon
5773656560257991946#Word64
17028074687139582545#Word64
T26615a.$trModule
- T26615a.$tc'Leaf2
+ $tc'Leaf2
2#
- T26615a.$tc'Leaf1
+ $krep18
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-$krep15 :: GHC.Internal.Types.KindRep
+$krep19 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-$krep15 = GHC.Internal.Types.KindRepFun $krep13 T26615a.$tc'Empty1
+$krep19 = GHC.Internal.Types.KindRepFun $krep15 $krep16
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Collision1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep
+$krep20 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'Collision1
- = GHC.Internal.Types.KindRepFun $krep1 $krep15
+$krep20 = GHC.Internal.Types.KindRepFun $krep1 $krep19
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Collision3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 40 0}]
-T26615a.$tc'Collision3 = "'Collision"#
+$tc'Collision1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'Collision1 = "'Collision"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Collision2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'Collision2
- = GHC.Internal.Types.TrNameS T26615a.$tc'Collision3
+$tc'Collision2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'Collision2 = GHC.Internal.Types.TrNameS $tc'Collision1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Collision :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'Collision [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'Collision
= GHC.Internal.Types.TyCon
18175105753528304021#Word64
13986842878006680511#Word64
T26615a.$trModule
- T26615a.$tc'Collision2
+ $tc'Collision2
2#
- T26615a.$tc'Collision1
+ $krep20
-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
-$krep16 :: [GHC.Internal.Types.KindRep]
+$krep21 :: [GHC.Internal.Types.KindRep]
[GblId, Unf=OtherCon []]
-$krep16
+$krep21
= GHC.Internal.Types.:
@GHC.Internal.Types.KindRep
- T26615a.$tc'Empty1
+ $krep16
(GHC.Internal.Types.[] @GHC.Internal.Types.KindRep)
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-$krep17 :: GHC.Internal.Types.KindRep
+$krep22 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-$krep17
- = GHC.Internal.Types.KindRepTyConApp T26615a.$tcArray $krep16
+$krep22
+ = GHC.Internal.Types.KindRepTyConApp T26615a.$tcArray $krep21
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Full1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep
+$krep23 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'Full1
- = GHC.Internal.Types.KindRepFun $krep17 T26615a.$tc'Empty1
+$krep23 = GHC.Internal.Types.KindRepFun $krep22 $krep16
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Full3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$tc'Full3 = "'Full"#
+$tc'Full1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'Full1 = "'Full"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Full2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'Full2 = GHC.Internal.Types.TrNameS T26615a.$tc'Full3
+$tc'Full2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'Full2 = GHC.Internal.Types.TrNameS $tc'Full1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Full :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'Full [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'Full
= GHC.Internal.Types.TyCon
12008762105994325570#Word64
13514145886440831186#Word64
T26615a.$trModule
- T26615a.$tc'Full2
+ $tc'Full2
2#
- T26615a.$tc'Full1
+ $krep23
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'BitmapIndexed1 [InlPrag=[~]]
- :: GHC.Internal.Types.KindRep
+$krep24 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'BitmapIndexed1
- = GHC.Internal.Types.KindRepFun $krep1 T26615a.$tc'Full1
+$krep24 = GHC.Internal.Types.KindRepFun $krep1 $krep23
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'BitmapIndexed3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 50 0}]
-T26615a.$tc'BitmapIndexed3 = "'BitmapIndexed"#
+$tc'BitmapIndexed1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'BitmapIndexed1 = "'BitmapIndexed"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'BitmapIndexed2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'BitmapIndexed2
- = GHC.Internal.Types.TrNameS T26615a.$tc'BitmapIndexed3
+$tc'BitmapIndexed2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'BitmapIndexed2 = GHC.Internal.Types.TrNameS $tc'BitmapIndexed1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'BitmapIndexed :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'BitmapIndexed [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'BitmapIndexed
= GHC.Internal.Types.TyCon
15226751910432948177#Word64
957331387129868915#Word64
T26615a.$trModule
- T26615a.$tc'BitmapIndexed2
+ $tc'BitmapIndexed2
2#
- T26615a.$tc'BitmapIndexed1
+ $krep24
-- RHS size: {terms: 98, types: 109, coercions: 0, joins: 3/4}
T26615a.$wdisjointCollisions [InlPrag=INLINABLE[2]]
@@ -538,7 +425,7 @@ T26615a.$wdisjointCollisions [InlPrag=INLINABLE[2]]
Str=<LP(SC(S,C(1,L)),A)><L><1L><L><L>,
Unf=Unf{Src=StableUser, TopLvl=True,
Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [30 0 20 0 0] 406 10
+ Guidance=IF_ARGS [90 0 20 0 0] 406 10
Tmpl= \ (@k)
(@a)
(@b)
@@ -586,7 +473,7 @@ T26615a.$wdisjointCollisions [InlPrag=INLINABLE[2]]
Arity=5,
Str=<L><L><L><L><L>,
Unf=OtherCon []]
- lookupInArrayCont_ _ [Occ=Dead]
+ lookupInArrayCont_ ($dEq1 [Occ=Dead] :: Eq k)
(k1 [Occ=Once1] :: k)
(ary1 [Occ=Once1!] :: Array (Leaf k b))
(i1 [Occ=Once1!] :: Int)
@@ -654,24 +541,23 @@ T26615a.$wdisjointCollisions
$s$wfoldr_ [InlPrag=[2],
Occ=LoopBreaker,
Dmd=SC(S,C(1,C(1,C(1,L))))]
- :: Bool -> Int# -> Int# -> SmallArray# (Leaf k a) -> Bool
+ :: SmallArray# (Leaf k a) -> Int# -> Int# -> Bool -> Bool
[LclId[JoinId(4)(Nothing)],
Arity=4,
Str=<L><L><L><L>,
Unf=OtherCon []]
- $s$wfoldr_ (sc :: Bool)
+ $s$wfoldr_ (sc :: SmallArray# (Leaf k a))
(sc1 :: Int#)
(sc2 :: Int#)
- (sc3 :: SmallArray# (Leaf k a))
- = case >=# sc1 sc2 of {
+ (sc3 :: Bool)
+ = case >=# sc2 sc1 of {
__DEFAULT ->
- case indexSmallArray# @Lifted @(Leaf k a) sc3 sc1 of
- { (# ipv1 #) ->
+ case indexSmallArray# @Lifted @(Leaf k a) sc sc2 of { (# ipv1 #) ->
case ipv1 of { L kA ds1 ->
join {
$j :: Bool
[LclId[JoinId(0)(Nothing)]]
- $j = jump $s$wfoldr_ sc (+# sc1 1#) sc2 sc3 } in
+ $j = jump $s$wfoldr_ sc sc1 (+# sc2 1#) sc3 } in
joinrec {
$wlookupInArrayCont_ [InlPrag=[2],
Occ=LoopBreaker,
@@ -703,13 +589,13 @@ T26615a.$wdisjointCollisions
jump $wlookupInArrayCont_ kA ww2 0# lvl2
}
};
- 1# -> sc
+ 1# -> sc3
}; } in
jump $s$wfoldr_
- GHC.Internal.Types.True
- 0#
- (sizeofSmallArray# @Lifted @(Leaf k a) ipv)
ipv
+ (sizeofSmallArray# @Lifted @(Leaf k a) ipv)
+ 0#
+ GHC.Internal.Types.True
}
}
@@ -728,28 +614,28 @@ Rec {
-- RHS size: {terms: 133, types: 126, coercions: 0, joins: 1/2}
T26615a.disjointSubtrees_$s$wdisjointSubtrees [InlPrag=INLINABLE[2],
Occ=LoopBreaker]
- :: forall b a k.
- Word#
- -> SmallArray# (Leaf k a) -> Int# -> Eq k => HashMap k b -> Bool
+ :: forall k a b.
+ Eq k =>
+ Int# -> Word# -> SmallArray# (Leaf k a) -> HashMap k b -> Bool
[GblId[StrictWorker([~, ~, ~, ~, !])],
Arity=5,
- Str=<L><L><L><LP(SC(S,C(1,L)),A)><1L>,
+ Str=<LP(SC(S,C(1,L)),A)><L><L><L><1L>,
Unf=OtherCon []]
T26615a.disjointSubtrees_$s$wdisjointSubtrees
- = \ (@b)
+ = \ (@k)
(@a)
- (@k)
- (sc :: Word#)
- (sc1 :: SmallArray# (Leaf k a))
- (sc2 :: Int#)
- (sc3 :: Eq k)
+ (@b)
+ (sc :: Eq k)
+ (sc1 :: Int#)
+ (sc2 :: Word#)
+ (sc3 :: SmallArray# (Leaf k a))
(_b :: HashMap k b) ->
case _b of {
Empty -> GHC.Internal.Types.True;
Leaf bx ds ->
case ds of { L kB ds1 ->
case kB of k0 { __DEFAULT ->
- case eqWord# bx sc of {
+ case eqWord# bx sc2 of {
__DEFAULT -> GHC.Internal.Types.True;
1# ->
joinrec {
@@ -770,7 +656,7 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees
__DEFAULT ->
case indexSmallArray# @Lifted @(Leaf k a) ww ww1 of { (# ipv #) ->
case ipv of { L kx v ->
- case == @k sc3 k2 kx of {
+ case == @k sc k2 kx of {
False -> jump $wlookupInArrayCont_ k2 ww (+# ww1 1#) ww2;
True -> GHC.Internal.Types.False
}
@@ -780,19 +666,19 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees
}
}; } in
jump $wlookupInArrayCont_
- k0 sc1 0# (sizeofSmallArray# @Lifted @(Leaf k a) sc1)
+ k0 sc3 0# (sizeofSmallArray# @Lifted @(Leaf k a) sc3)
}
}
};
Collision bx bx1 ->
T26615a.$wdisjointCollisions
- @k @a @b sc3 sc (T26615a.Array @(Leaf k a) sc1) bx bx1;
+ @k @a @b sc sc2 (T26615a.Array @(Leaf k a) sc3) bx bx1;
BitmapIndexed bx bx1 ->
let {
m :: Word#
[LclId]
m = uncheckedShiftL#
- 1## (word2Int# (and# (uncheckedShiftRL# sc sc2) 31##)) } in
+ 1## (word2Int# (and# (uncheckedShiftRL# sc2 sc1) 31##)) } in
case and# m bx of {
__DEFAULT ->
case indexSmallArray#
@@ -803,7 +689,7 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees
of
{ (# ipv #) ->
T26615a.disjointSubtrees_$s$wdisjointSubtrees
- @b @a @k sc sc1 (+# sc2 5#) sc3 ipv
+ @k @a @b sc (+# sc1 5#) sc2 sc3 ipv
};
0## -> GHC.Internal.Types.True
};
@@ -812,17 +698,17 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees
@Lifted
@(HashMap k b)
bx
- (word2Int# (and# (uncheckedShiftRL# sc sc2) 31##))
+ (word2Int# (and# (uncheckedShiftRL# sc2 sc1) 31##))
of
{ (# ipv #) ->
T26615a.disjointSubtrees_$s$wdisjointSubtrees
- @b @a @k sc sc1 (+# sc2 5#) sc3 ipv
+ @k @a @b sc (+# sc1 5#) sc2 sc3 ipv
}
}
end Rec }
Rec {
--- RHS size: {terms: 705, types: 732, coercions: 18, joins: 13/23}
+-- RHS size: {terms: 705, types: 748, coercions: 18, joins: 13/23}
T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
:: forall k a b. Eq k => Int# -> HashMap k a -> HashMap k b -> Bool
[GblId[StrictWorker([~, ~, !])],
@@ -841,7 +727,7 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
join {
fail [Occ=Once3!T[1]] :: (# #) -> Bool
[LclId[JoinId(1)(Nothing)], Arity=1, Str=<L>, Unf=OtherCon []]
- fail _ [Occ=Dead, OS=OneShot]
+ fail (ds1 [Occ=Dead, OS=OneShot] :: (# #))
= case _b of wild [Occ=Once1] {
__DEFAULT ->
case GHC.Internal.Control.Exception.Base.patError
@@ -860,7 +746,7 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
Arity=5,
Str=<L><L><L><L><L>,
Unf=OtherCon []]
- lookupCont_ _ [Occ=Dead]
+ lookupCont_ ($dEq1 [Occ=Dead] :: Eq k)
(ds4 [Occ=Once1!] :: Word)
(ds5 [Occ=Once1] :: k)
(ds6 [Occ=Once1!] :: Int)
@@ -896,7 +782,7 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
Arity=5,
Str=<L><L><L><L><L>,
Unf=OtherCon []]
- lookupInArrayCont_ _ [Occ=Dead]
+ lookupInArrayCont_ ($dEq2 [Occ=Dead] :: Eq k)
(k1 [Occ=Once1] :: k)
(ary [Occ=Once1!] :: Array (Leaf k a))
(i [Occ=Once1!] :: Int)
@@ -1000,7 +886,7 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
Arity=5,
Str=<L><L><L><L><L>,
Unf=OtherCon []]
- lookupCont_ _ [Occ=Dead]
+ lookupCont_ ($dEq1 [Occ=Dead] :: Eq k)
(ds3 [Occ=Once1!] :: Word)
(ds4 [Occ=Once1] :: k)
(ds5 [Occ=Once1!] :: Int)
@@ -1034,7 +920,7 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
Arity=5,
Str=<L><L><L><L><L>,
Unf=OtherCon []]
- lookupInArrayCont_ _ [Occ=Dead]
+ lookupInArrayCont_ ($dEq2 [Occ=Dead] :: Eq k)
(k1 [Occ=Once1] :: k)
(ary [Occ=Once1!] :: Array (Leaf k b))
(i [Occ=Once1!] :: Int)
@@ -1179,23 +1065,23 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
@(*)
@(SmallArray# (HashMap k a)
-> SmallArray# (HashMap k b) -> Int#)
- @(GHC.Internal.Types.ZonkAny 0
- -> GHC.Internal.Types.ZonkAny 1 -> Int#)
+ @(GHC.Internal.Types.UnusedType 0 "a"
+ -> GHC.Internal.Types.UnusedType 1 "b" -> Int#)
of
{ GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 ->
case reallyUnsafePtrEquality#
@Lifted
@Lifted
- @(GHC.Internal.Types.ZonkAny 0)
- @(GHC.Internal.Types.ZonkAny 1)
+ @(GHC.Internal.Types.UnusedType 0 "a")
+ @(GHC.Internal.Types.UnusedType 1 "b")
(bx1
`cast` (SelCo:Fun(arg) (Sub (Sym v2))
:: SmallArray# (HashMap k a)
- ~R# GHC.Internal.Types.ZonkAny 0))
+ ~R# GHC.Internal.Types.UnusedType 0 "a"))
(bx3
`cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2)))
:: SmallArray# (HashMap k b)
- ~R# GHC.Internal.Types.ZonkAny 1))
+ ~R# GHC.Internal.Types.UnusedType 1 "b"))
of {
__DEFAULT ->
joinrec {
@@ -1324,51 +1210,49 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
}; } in
jump go (GHC.Internal.Types.W# (and# 4294967295## bx1));
Full bx1 ->
+ joinrec {
+ go [Occ=LoopBreakerT[1]] :: Int -> Bool
+ [LclId[JoinId(1)(Nothing)], Arity=1, Str=<L>, Unf=OtherCon []]
+ go (i :: Int)
+ = case GHC.Internal.Classes.ltInt i (GHC.Internal.Types.I# 0#) of {
+ False ->
+ case i of { I# i# ->
+ case indexSmallArray# @Lifted @(HashMap k a) bx i# of
+ { (# ipv [Occ=Once1] #) ->
+ case indexSmallArray# @Lifted @(HashMap k b) bx1 i# of
+ { (# ipv1 [Occ=Once1] #) ->
+ case T26615a.$wdisjointSubtrees @k @a @b $dEq (+# ww 5#) ipv ipv1
+ of {
+ False -> GHC.Internal.Types.False;
+ True -> jump go (GHC.Internal.Types.I# (-# i# 1#))
+ }
+ }
+ }
+ };
+ True -> GHC.Internal.Types.True
+ }; } in
case GHC.Internal.Unsafe.Coerce.unsafeEqualityProof
@(*)
@(SmallArray# (HashMap k a) -> SmallArray# (HashMap k b) -> Int#)
- @(GHC.Internal.Types.ZonkAny 0
- -> GHC.Internal.Types.ZonkAny 1 -> Int#)
+ @(GHC.Internal.Types.UnusedType 0 "a"
+ -> GHC.Internal.Types.UnusedType 1 "b" -> Int#)
of
{ GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 ->
case reallyUnsafePtrEquality#
@Lifted
@Lifted
- @(GHC.Internal.Types.ZonkAny 0)
- @(GHC.Internal.Types.ZonkAny 1)
+ @(GHC.Internal.Types.UnusedType 0 "a")
+ @(GHC.Internal.Types.UnusedType 1 "b")
(bx
`cast` (SelCo:Fun(arg) (Sub (Sym v2))
:: SmallArray# (HashMap k a)
- ~R# GHC.Internal.Types.ZonkAny 0))
+ ~R# GHC.Internal.Types.UnusedType 0 "a"))
(bx1
`cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2)))
:: SmallArray# (HashMap k b)
- ~R# GHC.Internal.Types.ZonkAny 1))
+ ~R# GHC.Internal.Types.UnusedType 1 "b"))
of {
- __DEFAULT ->
- joinrec {
- go [Occ=LoopBreakerT[1]] :: Int -> Bool
- [LclId[JoinId(1)(Nothing)], Arity=1, Str=<L>, Unf=OtherCon []]
- go (i :: Int)
- = case GHC.Internal.Classes.ltInt i (GHC.Internal.Types.I# 0#) of {
- False ->
- case i of { I# i# ->
- case indexSmallArray# @Lifted @(HashMap k a) bx i# of
- { (# ipv [Occ=Once1] #) ->
- case indexSmallArray# @Lifted @(HashMap k b) bx1 i# of
- { (# ipv1 [Occ=Once1] #) ->
- case T26615a.$wdisjointSubtrees
- @k @a @b $dEq (+# ww 5#) ipv ipv1
- of {
- False -> GHC.Internal.Types.False;
- True -> jump go (GHC.Internal.Types.I# (-# i# 1#))
- }
- }
- }
- };
- True -> GHC.Internal.Types.True
- }; } in
- jump go (GHC.Internal.Types.I# 31#);
+ __DEFAULT -> jump go (GHC.Internal.Types.I# 31#);
1# -> GHC.Internal.Types.False
}
}
@@ -1385,7 +1269,7 @@ T26615a.$wdisjointSubtrees
join {
fail [Dmd=MC(1,L)] :: (# #) -> Bool
[LclId[JoinId(1)(Nothing)], Arity=1, Str=<A>, Unf=OtherCon []]
- fail _ [Occ=Dead, OS=OneShot]
+ fail (ds1 [Occ=Dead, OS=OneShot] :: (# #))
= case _b of {
__DEFAULT -> case lvl1 of {};
Empty -> GHC.Internal.Types.True;
@@ -1508,7 +1392,7 @@ T26615a.$wdisjointSubtrees
};
Collision bx bx1 ->
T26615a.disjointSubtrees_$s$wdisjointSubtrees
- @a @b @k bx bx1 ww $dEq ds
+ @k @b @a $dEq ww bx bx1 ds
} } in
case ds of {
Empty -> GHC.Internal.Types.True;
@@ -1661,7 +1545,7 @@ T26615a.$wdisjointSubtrees
of
{ (# ipv #) ->
T26615a.disjointSubtrees_$s$wdisjointSubtrees
- @b @a @k bx bx1 (+# ww 5#) $dEq ipv
+ @k @a @b $dEq (+# ww 5#) bx bx1 ipv
};
0## -> GHC.Internal.Types.True
};
@@ -1674,7 +1558,7 @@ T26615a.$wdisjointSubtrees
of
{ (# ipv #) ->
T26615a.disjointSubtrees_$s$wdisjointSubtrees
- @b @a @k bx bx1 (+# ww 5#) $dEq ipv
+ @k @a @b $dEq (+# ww 5#) bx bx1 ipv
}
};
BitmapIndexed bx bx1 ->
@@ -1686,21 +1570,23 @@ T26615a.$wdisjointSubtrees
case GHC.Internal.Unsafe.Coerce.unsafeEqualityProof
@(*)
@(SmallArray# (HashMap k a) -> SmallArray# (HashMap k b) -> Int#)
- @(GHC.Internal.Types.ZonkAny 0
- -> GHC.Internal.Types.ZonkAny 1 -> Int#)
+ @(GHC.Internal.Types.UnusedType 0 "a"
+ -> GHC.Internal.Types.UnusedType 1 "b" -> Int#)
of
{ GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 ->
case reallyUnsafePtrEquality#
@Lifted
@Lifted
- @(GHC.Internal.Types.ZonkAny 0)
- @(GHC.Internal.Types.ZonkAny 1)
+ @(GHC.Internal.Types.UnusedType 0 "a")
+ @(GHC.Internal.Types.UnusedType 1 "b")
(bx1
`cast` (SelCo:Fun(arg) (Sub (Sym v2))
- :: SmallArray# (HashMap k a) ~R# GHC.Internal.Types.ZonkAny 0))
+ :: SmallArray# (HashMap k a)
+ ~R# GHC.Internal.Types.UnusedType 0 "a"))
(bx3
`cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2)))
- :: SmallArray# (HashMap k b) ~R# GHC.Internal.Types.ZonkAny 1))
+ :: SmallArray# (HashMap k b)
+ ~R# GHC.Internal.Types.UnusedType 1 "b"))
of {
__DEFAULT ->
let {
@@ -1829,21 +1715,23 @@ T26615a.$wdisjointSubtrees
case GHC.Internal.Unsafe.Coerce.unsafeEqualityProof
@(*)
@(SmallArray# (HashMap k a) -> SmallArray# (HashMap k b) -> Int#)
- @(GHC.Internal.Types.ZonkAny 0
- -> GHC.Internal.Types.ZonkAny 1 -> Int#)
+ @(GHC.Internal.Types.UnusedType 0 "a"
+ -> GHC.Internal.Types.UnusedType 1 "b" -> Int#)
of
{ GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 ->
case reallyUnsafePtrEquality#
@Lifted
@Lifted
- @(GHC.Internal.Types.ZonkAny 0)
- @(GHC.Internal.Types.ZonkAny 1)
+ @(GHC.Internal.Types.UnusedType 0 "a")
+ @(GHC.Internal.Types.UnusedType 1 "b")
(bx
`cast` (SelCo:Fun(arg) (Sub (Sym v2))
- :: SmallArray# (HashMap k a) ~R# GHC.Internal.Types.ZonkAny 0))
+ :: SmallArray# (HashMap k a)
+ ~R# GHC.Internal.Types.UnusedType 0 "a"))
(bx1
`cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2)))
- :: SmallArray# (HashMap k b) ~R# GHC.Internal.Types.ZonkAny 1))
+ :: SmallArray# (HashMap k b)
+ ~R# GHC.Internal.Types.UnusedType 1 "b"))
of {
__DEFAULT ->
let {
@@ -1910,88 +1798,72 @@ disjointSubtrees
------ Local rules for imported ids --------
"SC:$wdisjointSubtrees1" [1]
- forall (@a)
+ forall (@k)
(@b)
- (@k)
- (sc :: Word#)
- (sc1 :: SmallArray# (Leaf k a))
+ (@a)
+ (sc :: Eq k)
+ (sc1 :: Int#)
(sc2 :: Word#)
(sc3 :: SmallArray# (Leaf k b))
- (sc4 :: Int#)
- (sc5 :: Eq k).
+ (sc4 :: Word#)
+ (sc5 :: SmallArray# (Leaf k a)).
T26615a.$wdisjointSubtrees @k
@b
@a
- sc5
- sc4
+ sc
+ sc1
(T26615a.Collision @k @b sc2 sc3)
- (T26615a.Collision @k @a sc sc1)
+ (T26615a.Collision @k @a sc4 sc5)
= T26615a.$wdisjointCollisions
- @k @b @a sc5 sc2 (T26615a.Array @(Leaf k b) sc3) sc sc1
+ @k @b @a sc sc2 (T26615a.Array @(Leaf k b) sc3) sc4 sc5
"SC:$wdisjointSubtrees0" [1]
- forall (@b)
+ forall (@k)
(@a)
- (@k)
- (sc :: Word#)
- (sc1 :: SmallArray# (Leaf k a))
- (sc2 :: Int#)
- (sc3 :: Eq k).
+ (@b)
+ (sc :: Eq k)
+ (sc1 :: Int#)
+ (sc2 :: Word#)
+ (sc3 :: SmallArray# (Leaf k a)).
T26615a.$wdisjointSubtrees @k
@a
@b
- sc3
- sc2
- (T26615a.Collision @k @a sc sc1)
+ sc
+ sc1
+ (T26615a.Collision @k @a sc2 sc3)
= T26615a.disjointSubtrees_$s$wdisjointSubtrees
- @b @a @k sc sc1 sc2 sc3
+ @k @a @b sc sc1 sc2 sc3
[2 of 2] Compiling T26615 ( T26615.hs, T26615.o )
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 614, types: 666, coercions: 18, joins: 8/14}
+ = {terms: 614, types: 682, coercions: 18, joins: 8/14}
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615.$trModule2 :: GHC.Internal.Prim.Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615.$trModule2 = "T26615"#
+$trModule1 :: GHC.Internal.Prim.Addr#
+[GblId, Unf=OtherCon []]
+$trModule1 = "T26615"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615.$trModule1 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615.$trModule1 = GHC.Internal.Types.TrNameS T26615.$trModule2
+$trModule2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$trModule2 = GHC.Internal.Types.TrNameS $trModule1
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615.$trModule4 :: GHC.Internal.Prim.Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 20 0}]
-T26615.$trModule4 = "main"#
+$trModule3 :: GHC.Internal.Prim.Addr#
+[GblId, Unf=OtherCon []]
+$trModule3 = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615.$trModule3 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615.$trModule3 = GHC.Internal.Types.TrNameS T26615.$trModule4
+$trModule4 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$trModule4 = GHC.Internal.Types.TrNameS $trModule3
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615.$trModule :: GHC.Internal.Types.Module
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615.$trModule
- = GHC.Internal.Types.Module T26615.$trModule3 T26615.$trModule1
+T26615.$trModule [InlPrag=[~]] :: GHC.Internal.Types.Module
+[GblId, Unf=OtherCon []]
+T26615.$trModule = GHC.Internal.Types.Module $trModule4 $trModule2
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
lvl :: GHC.Internal.Prim.Addr#
@@ -2128,7 +2000,7 @@ $wpoly_lookupCont_
end Rec }
Rec {
--- RHS size: {terms: 448, types: 507, coercions: 18, joins: 8/13}
+-- RHS size: {terms: 448, types: 523, coercions: 18, joins: 8/13}
T26615.$s$wdisjointSubtrees [InlPrag=[~], Occ=LoopBreaker]
:: forall a b.
GHC.Internal.Prim.Int#
@@ -2143,7 +2015,7 @@ T26615.$s$wdisjointSubtrees
join {
fail [Dmd=MC(1,L)] :: (# #) -> Bool
[LclId[JoinId(1)(Nothing)], Arity=1, Str=<A>, Unf=OtherCon []]
- fail _ [Occ=Dead, OS=OneShot]
+ fail (ds1 [Occ=Dead, OS=OneShot] :: (# #))
= case _b of wild {
__DEFAULT -> case lvl1 of {};
T26615a.Empty -> GHC.Internal.Types.True;
@@ -2190,30 +2062,28 @@ T26615.$s$wdisjointSubtrees
$s$wfoldr_ [InlPrag=[2],
Occ=LoopBreaker,
Dmd=SC(S,C(1,C(1,C(1,L))))]
- :: Bool
- -> GHC.Internal.Prim.Int#
- -> GHC.Internal.Prim.Int#
- -> GHC.Internal.Prim.SmallArray# (T26615a.Leaf [Char] a)
- -> Bool
+ :: GHC.Internal.Prim.SmallArray# (T26615a.Leaf [Char] a)
+ -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> Bool -> Bool
[LclId[JoinId(4)(Nothing)],
Arity=4,
Str=<L><L><L><L>,
Unf=OtherCon []]
- $s$wfoldr_ (sc :: Bool)
+ $s$wfoldr_ (sc
+ :: GHC.Internal.Prim.SmallArray# (T26615a.Leaf [Char] a))
(sc1 :: GHC.Internal.Prim.Int#)
(sc2 :: GHC.Internal.Prim.Int#)
- (sc3 :: GHC.Internal.Prim.SmallArray# (T26615a.Leaf [Char] a))
- = case GHC.Internal.Prim.>=# sc1 sc2 of {
+ (sc3 :: Bool)
+ = case GHC.Internal.Prim.>=# sc2 sc1 of {
__DEFAULT ->
case GHC.Internal.Prim.indexSmallArray#
- @GHC.Internal.Types.Lifted @(T26615a.Leaf String a) sc3 sc1
+ @GHC.Internal.Types.Lifted @(T26615a.Leaf String a) sc sc2
of
{ (# ipv1 #) ->
case ipv1 of { T26615a.L kA ds2 ->
join {
$j :: Bool
[LclId[JoinId(0)(Nothing)]]
- $j = jump $s$wfoldr_ sc (GHC.Internal.Prim.+# sc1 1#) sc2 sc3 } in
+ $j = jump $s$wfoldr_ sc sc1 (GHC.Internal.Prim.+# sc2 1#) sc3 } in
joinrec {
$wlookupInArrayCont_ [InlPrag=[2],
Occ=LoopBreaker,
@@ -2258,14 +2128,14 @@ T26615.$s$wdisjointSubtrees
jump $wlookupInArrayCont_ kA bx3 0# lvl2
}
};
- 1# -> sc
+ 1# -> sc3
}; } in
jump $s$wfoldr_
- GHC.Internal.Types.True
- 0#
+ bx1
(GHC.Internal.Prim.sizeofSmallArray#
@GHC.Internal.Types.Lifted @(T26615a.Leaf String a) bx1)
- bx1
+ 0#
+ GHC.Internal.Types.True
};
T26615a.BitmapIndexed bx2 bx3 ->
let {
@@ -2317,23 +2187,23 @@ T26615.$s$wdisjointSubtrees
@(GHC.Internal.Prim.SmallArray# (HashMap String a)
-> GHC.Internal.Prim.SmallArray# (HashMap String b)
-> GHC.Internal.Prim.Int#)
- @(GHC.Internal.Types.ZonkAny 0
- -> GHC.Internal.Types.ZonkAny 1 -> GHC.Internal.Prim.Int#)
+ @(GHC.Internal.Types.UnusedType 0 "a"
+ -> GHC.Internal.Types.UnusedType 1 "b" -> GHC.Internal.Prim.Int#)
of
{ GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 ->
case GHC.Internal.Prim.reallyUnsafePtrEquality#
@GHC.Internal.Types.Lifted
@GHC.Internal.Types.Lifted
- @(GHC.Internal.Types.ZonkAny 0)
- @(GHC.Internal.Types.ZonkAny 1)
+ @(GHC.Internal.Types.UnusedType 0 "a")
+ @(GHC.Internal.Types.UnusedType 1 "b")
(bx1
`cast` (SelCo:Fun(arg) (Sub (Sym v2))
:: GHC.Internal.Prim.SmallArray# (HashMap String a)
- ~R# GHC.Internal.Types.ZonkAny 0))
+ ~R# GHC.Internal.Types.UnusedType 0 "a"))
(bx3
`cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2)))
:: GHC.Internal.Prim.SmallArray# (HashMap String b)
- ~R# GHC.Internal.Types.ZonkAny 1))
+ ~R# GHC.Internal.Types.UnusedType 1 "b"))
of {
__DEFAULT ->
joinrec {
@@ -2495,23 +2365,23 @@ T26615.$s$wdisjointSubtrees
@(GHC.Internal.Prim.SmallArray# (HashMap String a)
-> GHC.Internal.Prim.SmallArray# (HashMap String b)
-> GHC.Internal.Prim.Int#)
- @(GHC.Internal.Types.ZonkAny 0
- -> GHC.Internal.Types.ZonkAny 1 -> GHC.Internal.Prim.Int#)
+ @(GHC.Internal.Types.UnusedType 0 "a"
+ -> GHC.Internal.Types.UnusedType 1 "b" -> GHC.Internal.Prim.Int#)
of
{ GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 ->
case GHC.Internal.Prim.reallyUnsafePtrEquality#
@GHC.Internal.Types.Lifted
@GHC.Internal.Types.Lifted
- @(GHC.Internal.Types.ZonkAny 0)
- @(GHC.Internal.Types.ZonkAny 1)
+ @(GHC.Internal.Types.UnusedType 0 "a")
+ @(GHC.Internal.Types.UnusedType 1 "b")
(bx
`cast` (SelCo:Fun(arg) (Sub (Sym v2))
:: GHC.Internal.Prim.SmallArray# (HashMap String a)
- ~R# GHC.Internal.Types.ZonkAny 0))
+ ~R# GHC.Internal.Types.UnusedType 0 "a"))
(bx1
`cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2)))
:: GHC.Internal.Prim.SmallArray# (HashMap String b)
- ~R# GHC.Internal.Types.ZonkAny 1))
+ ~R# GHC.Internal.Types.UnusedType 1 "b"))
of {
__DEFAULT ->
joinrec {
@@ -2564,7 +2434,7 @@ f = \ (@a)
------ Local rules for imported ids --------
"SPEC/T26615 $wdisjointSubtrees @String @_ @_" [2]
- forall (@a) (@b) ($dEq :: Eq String).
+ forall (@a) (@b) ($dEq [Occ=Dead] :: Eq String).
T26615a.$wdisjointSubtrees @String @a @b $dEq
= T26615.$s$wdisjointSubtrees @a @b
=====================================
testsuite/tests/typecheck/should_fail/T13292.stderr
=====================================
@@ -14,15 +14,15 @@ T13292a.hs:4:12: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)]
In an equation for ‘someFunc’: someFunc = return ()
T13292.hs:6:1: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
- • Couldn't match type ‘GHC.Internal.Types.ZonkAny 0’ with ‘IO’
+ • Couldn't match type ‘m00’ with ‘IO’
Expected: IO ()
- Actual: GHC.Internal.Types.ZonkAny 0 ()
+ Actual: m00
• When checking the type of the IO action ‘main’
T13292.hs:6:1: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
- • Couldn't match type ‘GHC.Internal.Types.ZonkAny 0’ with ‘IO’
+ • Couldn't match type ‘m00’ with ‘IO’
Expected: IO ()
- Actual: GHC.Internal.Types.ZonkAny 0 ()
+ Actual: m00
• In the expression: main
When checking the type of the IO action ‘main’
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/79037512267b30e225dcc713d5d3728…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/79037512267b30e225dcc713d5d3728…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/davide/windows-dlls] WIP place SRT info tables into .rdata on windows
by David Eichmann (＠DavidEichmann) 19 Jun '26
by David Eichmann (＠DavidEichmann) 19 Jun '26
19 Jun '26
David Eichmann pushed to branch wip/davide/windows-dlls at Glasgow Haskell Compiler / GHC
Commits:
b8261917 by David Eichmann at 2026-06-19T10:52:13+01:00
WIP place SRT info tables into .rdata on windows
- - - - -
2 changed files:
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
Changes:
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -106,6 +106,7 @@ module GHC.Cmm.CLabel (
labelDynamic,
isLocalCLabel,
mayRedirectTo,
+ isSRTInfoLabel,
isInfoTableLabel,
isCmmInfoTableLabel,
isConInfoTableLabel,
@@ -730,6 +731,27 @@ mkOutOfBoundsAccessLabel = mkForeignLabel (fsLit "rtsOutOfBoundsAccess")
mkMemcpyRangeOverlapLabel = mkForeignLabel (fsLit "rtsMemcpyRangeOverlap") ForeignLabelInExternalPackage ForeignLabelIsFunction
mkMUT_VAR_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_VAR_CLEAN") CmmInfo
+isSRTInfoLabel :: CLabel -> Bool
+isSRTInfoLabel clbl = case clbl of
+ CmmLabel _ _ lbl CmmInfo ->
+ lbl == fsLit "stg_SRT_1"
+ || lbl == fsLit "stg_SRT_2"
+ || lbl == fsLit "stg_SRT_3"
+ || lbl == fsLit "stg_SRT_4"
+ || lbl == fsLit "stg_SRT_5"
+ || lbl == fsLit "stg_SRT_6"
+ || lbl == fsLit "stg_SRT_7"
+ || lbl == fsLit "stg_SRT_8"
+ || lbl == fsLit "stg_SRT_9"
+ || lbl == fsLit "stg_SRT_10"
+ || lbl == fsLit "stg_SRT_11"
+ || lbl == fsLit "stg_SRT_12"
+ || lbl == fsLit "stg_SRT_13"
+ || lbl == fsLit "stg_SRT_14"
+ || lbl == fsLit "stg_SRT_15"
+ || lbl == fsLit "stg_SRT_16"
+ _ -> False
+
mkSRTInfoLabel :: Int -> CLabel
mkSRTInfoLabel n = CmmLabel rtsUnitId (NeedExternDecl False) lbl CmmInfo
where
=====================================
compiler/GHC/CmmToAsm/X86/Ppr.hs
=====================================
@@ -33,7 +33,7 @@ import GHC.CmmToAsm.Ppr
import GHC.Cmm hiding (topInfoTable)
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.BlockId
-import GHC.Cmm.CLabel
+import GHC.Cmm.CLabel as CLabel
import GHC.Cmm.InitFini
import GHC.Cmm.DebugBlock (pprUnwindTable)
@@ -96,10 +96,16 @@ pprNatCmmDecl config proc@(CmmProc top_info entry_lbl _ (ListGraph blocks)) =
)
| otherwise = (empty,empty)
+ section = if platformOS platform == OSMinGW32
+ && externallyVisibleCLabel proc_lbl
+ && isSRTInfoLabel proc_lbl
+ then ReadOnlyData
+ else Text
+
in vcat
[ -- section directive. Requires proc_lbl when split-section is enabled to
-- use as a subsection name.
- pprSectionAlign config (Section Text proc_lbl)
+ pprSectionAlign config (Section section proc_lbl)
-- section alignment. Note that when there is an info table, we align the
-- info table and not the entry code!
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b82619177664a4ac33fc4174c0ea7f4…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b82619177664a4ac33fc4174c0ea7f4…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/mangoiv/unused-type] compiler: rename ZonkAny to UnusedType and add pretty printing logic
by Magnus (＠MangoIV) 19 Jun '26
by Magnus (＠MangoIV) 19 Jun '26
19 Jun '26
Magnus pushed to branch wip/mangoiv/unused-type at Glasgow Haskell Compiler / GHC
Commits:
eebd176c by mangoiv at 2026-06-19T11:31:43+02:00
compiler: rename ZonkAny to UnusedType and add pretty printing logic
ZonkAny is a hard to understand name for users who do not know how the
compiler works internally. Additionally, it is confusing that ZonkAny,
while being a concrete type *represents* a meta variable, espeically in
the compiler output.
This patch changes the name of ZonkAny to UnusedType which is closer to
its intended semantics and adds special pretty printing logic to display
this type in the same fashion the compiler displays meta variables in
other places, whenever they leak from the implementation to the user.
Fixes #27390
- - - - -
17 changed files:
- + changelog.d/unused-type
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Zonk/Type.hs
- libraries/ghc-internal/src/GHC/Internal/Types.hs
- testsuite/tests/perf/compiler/T11068.stdout
- testsuite/tests/pmcheck/should_compile/T12957.stderr
- testsuite/tests/profiling/should_run/staticcallstack002.stdout
- testsuite/tests/simplCore/should_compile/Makefile
- testsuite/tests/simplCore/should_compile/T13156.stdout
- testsuite/tests/simplCore/should_compile/T26615.stderr
- testsuite/tests/typecheck/should_fail/T13292.stderr
Changes:
=====================================
changelog.d/unused-type
=====================================
@@ -0,0 +1,14 @@
+section: compiler
+synopsis: Rename ZonkAny to UnusedType and add pretty printing logic for it.
+issues: #27390
+mrs: !16212
+
+description: {
+ After unification GHC fills in unused type variables with a fixed kind like in
+ ``(length :: [alpha] -> Int) ([] :: List alpha) :: Int`` with a fixed type.
+ This type was, confusingly to the user, called ``ZonkAny``.
+ We rename this type to ``UnusedType``, store naming information, and try hard to
+ pretty print it to something that is more resemblant of an unused in non-debugging
+ compiler output. We also export ``UnusedType`` from ``GHC.Internal.Types`` to make
+ it easier to discover without reading the GHC source code.
+}
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -1904,8 +1904,8 @@ unsatisfiableClassNameKey = mkPreludeTyConUnique 170
anyTyConKey :: Unique
anyTyConKey = mkPreludeTyConUnique 171
-zonkAnyTyConKey :: Unique
-zonkAnyTyConKey = mkPreludeTyConUnique 172
+unusedTypeTyConKey :: Unique
+unusedTypeTyConKey = mkPreludeTyConUnique 172
-- Custom user type-errors
errorMessageTypeErrorFamKey :: Unique
=====================================
compiler/GHC/Builtin/Types.hs
=====================================
@@ -93,7 +93,7 @@ module GHC.Builtin.Types (
cTupleSelId, cTupleSelIdName,
-- * Any
- anyTyCon, anyTy, anyTypeOfKind, zonkAnyTyCon,
+ anyTyCon, anyTy, anyTypeOfKind, unusedTypeTyCon,
-- * Recovery TyCon
makeRecoveryTyCon,
@@ -300,7 +300,7 @@ wiredInTyCons :: [TyCon]
wiredInTyCons = map (dataConTyCon . snd) boxingDataCons
++ [ anyTyCon
- , zonkAnyTyCon
+ , unusedTypeTyCon
, boolTyCon
, charTyCon
, stringTyCon
@@ -412,13 +412,13 @@ doubleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#")
{-
Note [Any types]
~~~~~~~~~~~~~~~~
-The type constructors `Any` and `ZonkAny` are closed type families declared thus:
+The type constructors `Any` and `UnusedType` are closed type families declared thus:
- type family Any :: forall k. k where { }
- type family ZonkAny :: forall k. Nat -> k where { }
+ type family Any :: forall k. k where { }
+ type family UnusedType :: forall k. Nat -> Symbol -> k where { }
They are used when we want a type of a particular kind, but we don't really care
-what that type is. The leading example is this: `ZonkAny` is used to instantiate
+what that type is. The leading example is this: `UnusedType` is used to instantiate
un-constrained type variables after type checking. For example, consider the
term (length [] :: Int), where
@@ -431,26 +431,26 @@ The typechecker will end up with
length @alpha ([] @alpha)
where `alpha` is an un-constrained unification variable. The "zonking" process zaps
-that unconstrained `alpha` to an arbitrary type (ZonkAny @Type 3), where the `3` is
-arbitrary (see wrinkle (Any5) below). This is done in `GHC.Tc.Zonk.Type.commitFlexi`.
-So we end up with
+that unconstrained `alpha` to an arbitrary type (UnusedType @Type 3 "a"), where the `3` is
+arbitrary (see wrinkle (Any5) below). and "a" is the original name, if we have one.
+This is done in `GHC.Tc.Zonk.Type.commitFlexi`. So we end up with
- length @(ZonkAny @Type 3) ([] @(ZonkAny @Type 3))
+ length @(UnusedType @Type 3 "a") ([] @(UnusedType @Type 3 "a"))
-`Any` and `ZonkAny` differ only in the presence of the `Nat` argument; see
-wrinkle (Any4).
+`Any` and `UnusedType` differ only in the presence of the `Nat` and the `Symbol` arguments;
+see wrinkle (Any4).
Wrinkles:
-(Any1) `Any` and `ZonkAny` are kind polymorphic since in some program we may
- need to use `ZonkAny` to fill in a type variable of some kind other than *
+(Any1) `Any` and `UnusedType` are kind polymorphic since in some program we may
+ need to use `UnusedType` to fill in a type variable of some kind other than *
(see #959 for examples).
(Any2) They are /closed/ type families, with no instances. For example, suppose that
with alpha :: '(k1, k2) we add a given coercion
g :: alpha ~ (Fst alpha, Snd alpha)
- and we zonked alpha = ZonkAny @(k1,k2) n. Then, if `ZonkAny` was a /data/ type,
- we'd get inconsistency because we'd have a Given equality with `ZonkAny` on one
+ and we zonked alpha = UnusedType @(k1,k2) n. Then, if `UnusedType` was a /data/ type,
+ we'd get inconsistency because we'd have a Given equality with `UnusedType` on one
side and '(,) on the other. See also #9097 and #9636.
See #25244 for a suggestion that we instead use an /open/ type family for which
@@ -459,8 +459,11 @@ Wrinkles:
(Any3) They do not claim to be /data/ types, and that's important for
the code generator, because the code gen may /enter/ a data value
but never enters a function value.
+ This is the motivation for the primary use case of `Any` in userspace which is
+ implementing type safe interfaces with improved performance characteristics,
+ e.g. storing `Any` leaves as the values for a finite dependent Map.
-(Any4) `ZonkAny` takes a `Nat` argument so that we can readily make up /distinct/
+(Any4) `UnusedType` takes a `Nat` argument so that we can readily make up /distinct/
types (#24817). Consider
data SBool a where { STrue :: SBool True; SFalse :: SBool False }
@@ -475,25 +478,43 @@ Wrinkles:
Now, what are `alpha` and `beta`? If we zonk both of them to the same type
`Any @Type`, the pattern-match checker will (wrongly) report that the first
branch is inaccessible. So we zonk them to two /different/ types:
- alpha := ZonkAny @Type 4 and beta := ZonkAny @Type k 5
+ alpha := UnusedType @Type 4 "a" and beta := UnusedType @Type k 5 "b"
(The actual numbers are arbitrary; they just need to differ.)
The unique-name generation comes from field `tcg_zany_n` of `TcGblEnv`; and
- `GHC.Tc.Zonk.Type.commitFlexi` calls `GHC.Tc.Utils.Monad.newZonkAnyType` to
+ `GHC.Tc.Zonk.Type.commitFlexi` calls `GHC.Tc.Utils.Monad.newUnusedTypeType` to
make up a fresh type.
If this example seems unconvincing (e.g. in this case foo must be bottom)
see #24817 for larger but more compelling examples.
-(Any5) `Any` and `ZonkAny` are wired-in so we can easily refer to it where we
+(Any9)
+ `UnusedType` takes a `Symbol` argument, which we use to neatly display zonked unfilled
+ metavariables without leaking internal type families.
+
+ See T13292 for an example of this in action.
+
+ `UnusedType` is handled specially in the pretty-printer to avoid confusing compiler output.
+ For example, `UnusedType 3 "foo" :: Type` is displayed as `foo3`
+
+ That special handling is implemented in GHC.Iface.Type.pprTyTcApp and more specifically
+ ppr_iface_unused_ty_tycon.
+
+ Historical note: in the past, `UnusedType` was called `ZonkAny` (or `Any` before that).
+ We renamed it to `UnusedType` and added this special treatment in the pretty-printer to avoid
+ confusing mentions of zonking.
+
+(Any5) `Any` and `UnusedType` are wired-in so we can easily refer to it where we
don't have a name environment (e.g. see Rules.matchRule for one example)
-(Any6) `Any` is defined in library module ghc-prim:GHC.Types, and exported so that
- it is available to users. For this reason it's treated like any other
- wired-in type:
- - has a fixed unique, anyTyConKey,
- - lives in the global name cache
- Currently `ZonkAny` is not available to users; but it could easily be.
+(Any6) `Any` and `UnusedType` are defined in library module ghc-prim:GHC.Types,
+ and exported. `Any` should be available to users mainly because it is a useful type
+ in userspace. `UnusedType` is exported mainly for documentation in case they stumble
+ over it in debug output: a user should not have to grep the compiler to know what
+ a given type in their program is there for. For this reason they're treated like any other
+ wired-in types:
+ - they have a fixed unique, anyTyConKey/unusedTypeTyConKey,
+ - live in the global name cache
(Any7) Properties of `Any`:
* When `Any` is instantiated at a lifted type it is inhabited by at least one value,
@@ -512,7 +533,7 @@ Wrinkles:
See examples in ghc-prim:GHC.Types
-(Any8) Warning about unused bindings of type `Any` and `ZonkAny` are suppressed,
+(Any8) Warning about unused bindings of type `Any` and `UnusedType` are suppressed,
following the same rationale of supressing warning about the unit type.
For example, consider (#25895):
@@ -520,7 +541,7 @@ Wrinkles:
do { forever (return ()); blah }
where forever :: forall a b. IO a -> IO b
- Nothing constrains `b`, so it will be instantiates with `Any` or `ZonkAny`.
+ Nothing constrains `b`, so it will be instantiates with `Any` or `UnusedType`.
But we certainly don't want to complain about a discarded do-binding.
The Any tycon used to be quite magic, but we have since been able to
@@ -550,22 +571,23 @@ anyTy = mkTyConTy anyTyCon
anyTypeOfKind :: Kind -> Type
anyTypeOfKind kind = mkTyConApp anyTyCon [kind]
-zonkAnyTyConName :: Name
-zonkAnyTyConName =
- mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZonkAny") zonkAnyTyConKey zonkAnyTyCon
+unusedTypeTyConName :: Name
+unusedTypeTyConName =
+ mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnusedType") unusedTypeTyConKey unusedTypeTyCon
-zonkAnyTyCon :: TyCon
--- ZonkAnyTyCon :: forall k. Nat -> k
+unusedTypeTyCon :: TyCon
+-- unusedTypeTyCon :: forall k. Nat -> Symbol -> k
-- See Note [Any types]
-zonkAnyTyCon = mkFamilyTyCon zonkAnyTyConName kind bndrs 0 res_kind
+unusedTypeTyCon = mkFamilyTyCon unusedTypeTyConName kind bndrs 0 res_kind
Nothing
(ClosedSynFamilyTyCon Nothing)
Nothing
NotInjective
where
- [kv,nat_kv] = mkTemplateKindVars [liftedTypeKind, naturalTy]
+ [kv,nat_kv,sym_kv] = mkTemplateKindVars [liftedTypeKind, naturalTy, typeSymbolKind]
bndrs = [ mkNamedTyConBinder Specified kv
- , mkAnonTyConBinder nat_kv ]
+ , mkAnonTyConBinder nat_kv
+ , mkAnonTyConBinder sym_kv ]
res_kind = mkTyVarTy kv
kind = mkTyConKind bndrs res_kind
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -1281,11 +1281,11 @@ warnDiscardedDoBindings rhs@(L rhs_loc _) m_ty elt_ty
do { fam_inst_envs <- dsGetFamInstEnvs
; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
supressible_ty =
- isUnitTy norm_elt_ty || isAnyTy norm_elt_ty || isZonkAnyTy norm_elt_ty
+ isUnitTy norm_elt_ty || isAnyTy norm_elt_ty || isUnusedTypeTy norm_elt_ty
-- Warn about discarding things in 'monadic' binding,
-- however few types are excluded:
-- * Unit type `()`
- -- * `ZonkAny` or `Any` type see (Any8) of Note [Any types]
+ -- * `UnusedType` or `Any` type see (Any8) of Note [Any types]
; if warn_unused && not supressible_ty
then diagnosticDs (DsUnusedDoBind rhs elt_ty)
else
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -7,7 +7,7 @@ This module defines interface types and binders
-}
-{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE MultiWayIf, OverloadedRecordDot #-}
module GHC.Iface.Type (
IfExtName,
IfLclName(..), mkIfLclName, ifLclNameFS,
@@ -1740,6 +1740,7 @@ pprTyTcApp ctxt_prec tc tys =
sdocOption sdocPrintExplicitKinds $ \print_kinds ->
sdocOption sdocPrintTypeAbbreviations $ \print_type_abbreviations ->
getPprDebug $ \debug ->
+ getPprStyle $ \style ->
if | ifaceTyConName tc `hasKey` ipClassKey
, IA_Arg (IfaceLitTy (IfaceStrTyLit n))
@@ -1791,6 +1792,13 @@ pprTyTcApp ctxt_prec tc tys =
| Just doc <- ppr_equality ctxt_prec tc (appArgsIfaceTypes tys)
-> doc
+ -- See Note [Any types], specifically (Any4) and (Any9)
+ | ifaceTyConName tc `hasKey` unusedTypeTyConKey
+ , (arg_k : IfaceLitTy (IfaceNumTyLit arg_n) : IfaceLitTy (IfaceStrTyLit arg_nm) : _) <- appArgsIfaceTypes tys
+ -- if arg_k is a kind with more than 0 arguments, then _ might not be [] here
+ , userStyle style
+ -> ppr_iface_unused_ty_tycon ctxt_prec arg_k arg_n arg_nm
+
| otherwise
-> ppr_iface_tc_app ppr_app_arg ctxt_prec tc $
appArgsIfaceTypesForAllTyFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) tys
@@ -1802,6 +1810,19 @@ ppr_kind_type ctxt_prec = sdocOption sdocStarIsType $ \case
False -> pprPrefixOcc liftedTypeKindTyConName
True -> maybeParen ctxt_prec starPrec starLit
+-- | user-style printer that pretty-prints an 'UnusedType @k 3 "foo" to foo3.
+-- If -fprint-explicit-kinds or -fprint-explicit-runtime-reps are set, instead
+-- prints them to (foo3 :: k).
+-- See Note [Any types], specifically (Any4) and (Any9) for why this is useful.
+ppr_iface_unused_ty_tycon :: PprPrec -> IfaceType -> Integer -> LexicalFastString -> SDoc
+ppr_iface_unused_ty_tycon ctxt_prec arg_k arg_n arg_nm
+ = sdocOption sdocPrintExplicitKinds $ \print_kinds ->
+ sdocOption sdocPrintExplicitRuntimeReps $ \print_reps ->
+ if print_kinds || print_reps
+ then maybeParen ctxt_prec sigPrec $ prettyMeta <+> text "::" <+> pprIfaceType arg_k
+ else prettyMeta
+ where prettyMeta = ppr arg_nm <> ppr arg_n
+
-- | Pretty-print a type-level equality.
-- Returns (Just doc) if the argument is a /saturated/ application
-- of eqTyCon (~)
@@ -2190,7 +2211,8 @@ instance Binary IfaceTyConSort where
0 -> return IfaceNormalTyCon
1 -> IfaceTupleTyCon <$> get bh <*> get bh
2 -> IfaceSumTyCon <$> get bh
- _ -> return IfaceEqualityTyCon
+ 3 -> return IfaceEqualityTyCon
+ _ -> panic "get IfaceTyConSort"
instance Binary IfaceTyConInfo where
put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -582,7 +582,7 @@ data TcGblEnv
-- ^ Allows us to choose unique DFun names.
tcg_zany_n :: TcRef Integer,
- -- ^ A source of unique identities for ZonkAny instances
+ -- ^ A source of unique identities for UnusedType instances
-- See Note [Any types] in GHC.Builtin.Types, wrinkle (Any4)
tcg_merged :: [(Module, Fingerprint)],
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -154,7 +154,7 @@ module GHC.Tc.Utils.Monad(
getCCIndexM, getCCIndexTcM,
-- * Zonking
- liftZonkM, newZonkAnyType,
+ liftZonkM, newUnusedType,
-- * Complete matches
localAndImportedCompleteMatches, getCompleteMatchesTcM,
@@ -168,7 +168,7 @@ import GHC.Prelude
import GHC.Builtin.Names
-import GHC.Builtin.Types( zonkAnyTyCon )
+import GHC.Builtin.Types( unusedTypeTyCon )
import GHC.Tc.Errors.Types
import GHC.Tc.Errors.Hole.Plugin ( HoleFitPlugin, HoleFitPluginR (..) )
@@ -197,7 +197,7 @@ import GHC.Core.Coercion ( isReflCo )
import GHC.Core.Multiplicity
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
-import GHC.Core.Type( mkNumLitTy )
+import GHC.Core.Type( mkNumLitTy, mkStrLitTy )
import GHC.Core.TyCo.Rep( CoercionHole(..) )
import GHC.Core.TyCo.FVs( coVarsOfCo )
import GHC.Core.TyCon ( TyCon )
@@ -2258,17 +2258,17 @@ chooseUniqueOccTc fn =
; writeTcRef dfun_n_var (extendOccSet set occ)
; return occ }
-newZonkAnyType :: Kind -> TcM Type
--- Return a type (ZonkAny @k n), where n is fresh
--- Recall ZonkAny :: forall k. Natural -> k
+newUnusedType :: Name -> Kind -> TcM Type
+-- Return a type (UnusedType @k n sym), where n is fresh
+-- Recall UnusedType :: forall k. Natural -> Symbol -> k
-- See Note [Any types] in GHC.Builtin.Types, wrinkle (Any4)
-newZonkAnyType kind
+newUnusedType name kind
= do { env <- getGblEnv
; let zany_n_var = tcg_zany_n env
; i <- readTcRef zany_n_var
; let !i2 = i+1
; writeTcRef zany_n_var i2
- ; return (mkTyConApp zonkAnyTyCon [kind, mkNumLitTy i]) }
+ ; return (mkTyConApp unusedTypeTyCon [kind, mkNumLitTy i, mkStrLitTy $ getOccFS name ]) }
getConstraintVar :: TcM (TcRef WantedConstraints)
getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -85,7 +85,7 @@ module GHC.Tc.Utils.TcType (
isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy,
isFloatingPrimTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
isIntegerTy, isNaturalTy,
- isBoolTy, isUnitTy, isAnyTy, isZonkAnyTy, isCharTy,
+ isBoolTy, isUnitTy, isAnyTy, isUnusedTypeTy, isCharTy,
isTauTy, isTauTyCon, tcIsTyVarTy,
isPredTy, isSimplePredTy, isTyVarClassPred,
checkValidClsArgs, hasTyVarHead,
@@ -2057,7 +2057,7 @@ isFloatTy, isDoubleTy,
isFloatPrimTy, isDoublePrimTy,
isIntegerTy, isNaturalTy,
isIntTy, isWordTy, isBoolTy,
- isUnitTy, isAnyTy, isZonkAnyTy, isCharTy :: Type -> Bool
+ isUnitTy, isAnyTy, isUnusedTypeTy, isCharTy :: Type -> Bool
isFloatTy = is_tc floatTyConKey
isDoubleTy = is_tc doubleTyConKey
isFloatPrimTy = is_tc floatPrimTyConKey
@@ -2069,7 +2069,7 @@ isWordTy = is_tc wordTyConKey
isBoolTy = is_tc boolTyConKey
isUnitTy = is_tc unitTyConKey
isAnyTy = is_tc anyTyConKey
-isZonkAnyTy = is_tc zonkAnyTyConKey
+isUnusedTypeTy = is_tc unusedTypeTyConKey
isCharTy = is_tc charTyConKey
-- | Check whether the type is of the form @Any :: k@,
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedRecordDot #-}
{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1996-1998
@@ -43,7 +44,7 @@ import GHC.Tc.Types.TcRef
import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo )
import GHC.Tc.Utils.Env ( tcLookupGlobalOnly )
import GHC.Tc.Utils.TcType
-import GHC.Tc.Utils.Monad ( newZonkAnyType, setSrcSpanA, liftZonkM, traceTc, addErr )
+import GHC.Tc.Utils.Monad ( newUnusedType, setSrcSpanA, liftZonkM, traceTc, addErr )
import GHC.Tc.Types.Evidence
import GHC.Tc.Errors.Types
import GHC.Tc.Zonk.Env
@@ -470,11 +471,11 @@ commitFlexi DefaultFlexi tv zonked_kind
; return manyDataConTy }
| Just (ConcreteFRR origin) <- isConcreteTyVar_maybe tv
= do { addErr $ TcRnZonkerMessage (ZonkerCannotDefaultConcrete origin)
- ; newZonkAnyType zonked_kind }
+ ; newUnusedType tv.varName zonked_kind }
| otherwise
- = do { traceTc "Defaulting flexi tyvar to ZonkAny:" (pprTyVar tv)
+ = do { traceTc "Defaulting flexi tyvar to UnusedType:" (pprTyVar tv)
-- See Note [Any types] in GHC.Builtin.Types, esp wrinkle (Any4)
- ; newZonkAnyType zonked_kind }
+ ; newUnusedType tv.varName zonked_kind }
zonkCoVarOcc :: CoVar -> ZonkTcM Coercion
zonkCoVarOcc cv
=====================================
libraries/ghc-internal/src/GHC/Internal/Types.hs
=====================================
@@ -35,6 +35,7 @@ module GHC.Internal.Types (
SPEC(..),
Symbol,
Any,
+ UnusedType,
-- * Type equality
type (~), type (~~), Coercible,
@@ -327,6 +328,17 @@ type family Any :: k where { }
-- that this can't reduce to a `data` type for the results discussed in
-- Note [Any types].
+-- | The type constructor 'UnusedType' is a type used by the compiler to fill in unused
+-- type variables after unification (more specifically the "zonking" step. It carries a
+-- number and a name to make pretty-printing possible. Under normal circumstances you
+-- should never see this type show up in compiler output if you don't explicitly ask for
+-- it by enabling debug output.
+-- 'UnusedType' is pretty-printed by the compiler to something that is more strongly resembling
+-- an unused type variable than a fixed type i.e. @'UnusedType' @k 3 "foo"@ is displayed as
+-- @foo3@ or @(foo3 :: k)@.
+type family UnusedType :: Nat -> Symbol -> k where { }
+-- See Note [Any types] in GHC.Builtin.Types, specifically (Any4) and (Any9).
+
{- *********************************************************************
* *
Lists
=====================================
testsuite/tests/perf/compiler/T11068.stdout
=====================================
@@ -23,137 +23,137 @@
`cast` (GHC.Internal.Generics.N:M1
`cast` (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
=====================================
testsuite/tests/pmcheck/should_compile/T12957.stderr
=====================================
@@ -1,7 +1,6 @@
T12957.hs:4:5: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
- Patterns of type ‘[GHC.Internal.Types.ZonkAny 0]’ not matched: []
+ In a case alternative: Patterns of type ‘[a0]’ not matched: []
T12957.hs:4:16: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)]
Pattern match is redundant
=====================================
testsuite/tests/profiling/should_run/staticcallstack002.stdout
=====================================
@@ -1,4 +1,4 @@
-Just (InfoProv {ipName = "sat_s1Rh_info", ipDesc = THUNK, ipTyDesc = "ZonkAny 0", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "10:23-39"})
-Just (InfoProv {ipName = "sat_s1RB_info", ipDesc = THUNK, ipTyDesc = "ZonkAny 1", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "11:23-42"})
-Just (InfoProv {ipName = "sat_s1RV_info", ipDesc = THUNK, ipTyDesc = "ZonkAny 2", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "12:23-46"})
-Just (InfoProv {ipName = "sat_s1Sf_info", ipDesc = THUNK, ipTyDesc = "ZonkAny 3", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "13:23-44"})
+Just (InfoProv {ipName = "main_sat_t2fs_info", ipDesc = THUNK, ipTyDesc = "UnusedType 0 \"a\"", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "10:23-39"})
+Just (InfoProv {ipName = "main_sat_t2fJ_info", ipDesc = THUNK, ipTyDesc = "UnusedType 1 \"a\"", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "11:23-42"})
+Just (InfoProv {ipName = "main_sat_t2g0_info", ipDesc = THUNK, ipTyDesc = "UnusedType 2 \"a\"", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "12:23-46"})
+Just (InfoProv {ipName = "main_sat_t2gh_info", ipDesc = THUNK, ipTyDesc = "UnusedType 3 \"a\"", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "13:23-44"})
=====================================
testsuite/tests/simplCore/should_compile/Makefile
=====================================
@@ -188,7 +188,7 @@ T13155:
T13156:
$(RM) -f T13156.hi T13156.o
- '$(TEST_HC)' $(TEST_HC_OPTS) -c T13156.hs -O -ddump-prep -dsuppress-uniques | grep "case.*Any"
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c T13156.hs -O -ddump-prep -dsuppress-uniques | grep "case.*UnusedType"
# There should be a single 'case r @ GHC.Types.Any'
.PHONY: T4138
=====================================
testsuite/tests/simplCore/should_compile/T13156.stdout
=====================================
@@ -1,2 +1,2 @@
- case r @(GHC.Internal.Types.ZonkAny 0) of { __DEFAULT ->
- case r @(GHC.Internal.Types.ZonkAny 1) of { __DEFAULT -> r @a }
+ case r @(GHC.Internal.Types.UnusedType 0 "a") of { __DEFAULT ->
+ case r @(GHC.Internal.Types.UnusedType 1 "a") of { __DEFAULT ->
=====================================
testsuite/tests/simplCore/should_compile/T26615.stderr
=====================================
@@ -2,7 +2,7 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 1,209, types: 1,139, coercions: 18, joins: 17/29}
+ = {terms: 1,209, types: 1,155, coercions: 18, joins: 17/29}
-- RHS size: {terms: 6, types: 8, coercions: 0, joins: 0/0}
unArray :: forall a. Array a -> SmallArray# a
@@ -15,45 +15,29 @@ unArray :: forall a. Array a -> SmallArray# a
unArray = \ (@a) (ds :: Array a) -> case ds of { Array ds1 -> ds1 }
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$trModule4 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 20 0}]
-T26615a.$trModule4 = "main"#
+$trModule1 :: Addr#
+[GblId, Unf=OtherCon []]
+$trModule1 = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$trModule3 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$trModule3 = GHC.Internal.Types.TrNameS T26615a.$trModule4
+$trModule2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$trModule2 = GHC.Internal.Types.TrNameS $trModule1
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$trModule2 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$trModule2 = "T26615a"#
+$trModule3 :: Addr#
+[GblId, Unf=OtherCon []]
+$trModule3 = "T26615a"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$trModule1 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$trModule1 = GHC.Internal.Types.TrNameS T26615a.$trModule2
+$trModule4 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$trModule4 = GHC.Internal.Types.TrNameS $trModule3
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$trModule :: GHC.Internal.Types.Module
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$trModule
- = GHC.Internal.Types.Module T26615a.$trModule3 T26615a.$trModule1
+T26615a.$trModule [InlPrag=[~]] :: GHC.Internal.Types.Module
+[GblId, Unf=OtherCon []]
+T26615a.$trModule = GHC.Internal.Types.Module $trModule2 $trModule4
-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
$krep :: GHC.Internal.Types.KindRep
@@ -104,33 +88,24 @@ $krep6
GHC.Internal.Types.$tcSmallArray# $krep5
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcLeaf2 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 20 0}]
-T26615a.$tcLeaf2 = "Leaf"#
+$tcLeaf1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tcLeaf1 = "Leaf"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcLeaf1 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tcLeaf1 = GHC.Internal.Types.TrNameS T26615a.$tcLeaf2
+$tcLeaf2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tcLeaf2 = GHC.Internal.Types.TrNameS $tcLeaf1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcLeaf :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tcLeaf [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tcLeaf
= GHC.Internal.Types.TyCon
13798714324392902582#Word64
3237499036029031497#Word64
T26615a.$trModule
- T26615a.$tcLeaf1
+ $tcLeaf2
0#
GHC.Internal.Types.krep$*->*->*
@@ -160,372 +135,284 @@ $krep10 :: GHC.Internal.Types.KindRep
$krep10 = GHC.Internal.Types.KindRepFun $krep2 $krep9
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'L1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep
+$krep11 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'L1 = GHC.Internal.Types.KindRepFun $krep3 $krep10
+$krep11 = GHC.Internal.Types.KindRepFun $krep3 $krep10
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'L3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 20 0}]
-T26615a.$tc'L3 = "'L"#
+$tc'L1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'L1 = "'L"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'L2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'L2 = GHC.Internal.Types.TrNameS T26615a.$tc'L3
+$tc'L2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'L2 = GHC.Internal.Types.TrNameS $tc'L1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'L :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'L [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'L
= GHC.Internal.Types.TyCon
8570419491837374712#Word64
2090006989092642392#Word64
T26615a.$trModule
- T26615a.$tc'L2
+ $tc'L2
2#
- T26615a.$tc'L1
+ $krep11
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcArray2 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$tcArray2 = "Array"#
+$tcArray1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tcArray1 = "Array"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcArray1 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tcArray1 = GHC.Internal.Types.TrNameS T26615a.$tcArray2
+$tcArray2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tcArray2 = GHC.Internal.Types.TrNameS $tcArray1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcArray :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tcArray [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tcArray
= GHC.Internal.Types.TyCon
10495761415291712389#Word64
7580086293698619153#Word64
T26615a.$trModule
- T26615a.$tcArray1
+ $tcArray2
0#
GHC.Internal.Types.krep$*Arr*
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-$krep11 :: GHC.Internal.Types.KindRep
+$krep12 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-$krep11
+$krep12
= GHC.Internal.Types.KindRepTyConApp T26615a.$tcArray $krep4
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Array1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep
+$krep13 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'Array1 = GHC.Internal.Types.KindRepFun $krep6 $krep11
+$krep13 = GHC.Internal.Types.KindRepFun $krep6 $krep12
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Array3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$tc'Array3 = "'Array"#
+$tc'Array1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'Array1 = "'Array"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Array2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'Array2 = GHC.Internal.Types.TrNameS T26615a.$tc'Array3
+$tc'Array2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'Array2 = GHC.Internal.Types.TrNameS $tc'Array1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Array :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'Array [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'Array
= GHC.Internal.Types.TyCon
12424115309881832159#Word64
15542868641947707803#Word64
T26615a.$trModule
- T26615a.$tc'Array2
+ $tc'Array2
1#
- T26615a.$tc'Array1
+ $krep13
-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
-$krep12 :: [GHC.Internal.Types.KindRep]
+$krep14 :: [GHC.Internal.Types.KindRep]
[GblId, Unf=OtherCon []]
-$krep12
+$krep14
= GHC.Internal.Types.:
@GHC.Internal.Types.KindRep
$krep9
(GHC.Internal.Types.[] @GHC.Internal.Types.KindRep)
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-$krep13 :: GHC.Internal.Types.KindRep
+$krep15 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-$krep13
- = GHC.Internal.Types.KindRepTyConApp T26615a.$tcArray $krep12
+$krep15
+ = GHC.Internal.Types.KindRepTyConApp T26615a.$tcArray $krep14
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcHashMap2 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$tcHashMap2 = "HashMap"#
+$tcHashMap1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tcHashMap1 = "HashMap"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcHashMap1 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tcHashMap1
- = GHC.Internal.Types.TrNameS T26615a.$tcHashMap2
+$tcHashMap2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tcHashMap2 = GHC.Internal.Types.TrNameS $tcHashMap1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcHashMap :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tcHashMap [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tcHashMap
= GHC.Internal.Types.TyCon
2021755758654901686#Word64
8209241086311595496#Word64
T26615a.$trModule
- T26615a.$tcHashMap1
+ $tcHashMap2
0#
GHC.Internal.Types.krep$*->*->*
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Empty1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep
+$krep16 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'Empty1
+$krep16
= GHC.Internal.Types.KindRepTyConApp T26615a.$tcHashMap $krep8
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Empty3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$tc'Empty3 = "'Empty"#
+$tc'Empty1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'Empty1 = "'Empty"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Empty2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'Empty2 = GHC.Internal.Types.TrNameS T26615a.$tc'Empty3
+$tc'Empty2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'Empty2 = GHC.Internal.Types.TrNameS $tc'Empty1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Empty :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'Empty [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'Empty
= GHC.Internal.Types.TyCon
2520556399233147460#Word64
17224648764450205443#Word64
T26615a.$trModule
- T26615a.$tc'Empty2
+ $tc'Empty2
2#
- T26615a.$tc'Empty1
+ $krep16
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-$krep14 :: GHC.Internal.Types.KindRep
+$krep17 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-$krep14 = GHC.Internal.Types.KindRepFun $krep9 T26615a.$tc'Empty1
+$krep17 = GHC.Internal.Types.KindRepFun $krep9 $krep16
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Leaf1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep
+$krep18 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'Leaf1 = GHC.Internal.Types.KindRepFun $krep1 $krep14
+$krep18 = GHC.Internal.Types.KindRepFun $krep1 $krep17
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Leaf3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$tc'Leaf3 = "'Leaf"#
+$tc'Leaf1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'Leaf1 = "'Leaf"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Leaf2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'Leaf2 = GHC.Internal.Types.TrNameS T26615a.$tc'Leaf3
+$tc'Leaf2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'Leaf2 = GHC.Internal.Types.TrNameS $tc'Leaf1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Leaf :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'Leaf [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'Leaf
= GHC.Internal.Types.TyCon
5773656560257991946#Word64
17028074687139582545#Word64
T26615a.$trModule
- T26615a.$tc'Leaf2
+ $tc'Leaf2
2#
- T26615a.$tc'Leaf1
+ $krep18
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-$krep15 :: GHC.Internal.Types.KindRep
+$krep19 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-$krep15 = GHC.Internal.Types.KindRepFun $krep13 T26615a.$tc'Empty1
+$krep19 = GHC.Internal.Types.KindRepFun $krep15 $krep16
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Collision1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep
+$krep20 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'Collision1
- = GHC.Internal.Types.KindRepFun $krep1 $krep15
+$krep20 = GHC.Internal.Types.KindRepFun $krep1 $krep19
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Collision3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 40 0}]
-T26615a.$tc'Collision3 = "'Collision"#
+$tc'Collision1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'Collision1 = "'Collision"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Collision2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'Collision2
- = GHC.Internal.Types.TrNameS T26615a.$tc'Collision3
+$tc'Collision2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'Collision2 = GHC.Internal.Types.TrNameS $tc'Collision1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Collision :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'Collision [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'Collision
= GHC.Internal.Types.TyCon
18175105753528304021#Word64
13986842878006680511#Word64
T26615a.$trModule
- T26615a.$tc'Collision2
+ $tc'Collision2
2#
- T26615a.$tc'Collision1
+ $krep20
-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
-$krep16 :: [GHC.Internal.Types.KindRep]
+$krep21 :: [GHC.Internal.Types.KindRep]
[GblId, Unf=OtherCon []]
-$krep16
+$krep21
= GHC.Internal.Types.:
@GHC.Internal.Types.KindRep
- T26615a.$tc'Empty1
+ $krep16
(GHC.Internal.Types.[] @GHC.Internal.Types.KindRep)
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-$krep17 :: GHC.Internal.Types.KindRep
+$krep22 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-$krep17
- = GHC.Internal.Types.KindRepTyConApp T26615a.$tcArray $krep16
+$krep22
+ = GHC.Internal.Types.KindRepTyConApp T26615a.$tcArray $krep21
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Full1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep
+$krep23 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'Full1
- = GHC.Internal.Types.KindRepFun $krep17 T26615a.$tc'Empty1
+$krep23 = GHC.Internal.Types.KindRepFun $krep22 $krep16
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Full3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$tc'Full3 = "'Full"#
+$tc'Full1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'Full1 = "'Full"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Full2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'Full2 = GHC.Internal.Types.TrNameS T26615a.$tc'Full3
+$tc'Full2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'Full2 = GHC.Internal.Types.TrNameS $tc'Full1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Full :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'Full [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'Full
= GHC.Internal.Types.TyCon
12008762105994325570#Word64
13514145886440831186#Word64
T26615a.$trModule
- T26615a.$tc'Full2
+ $tc'Full2
2#
- T26615a.$tc'Full1
+ $krep23
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'BitmapIndexed1 [InlPrag=[~]]
- :: GHC.Internal.Types.KindRep
+$krep24 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'BitmapIndexed1
- = GHC.Internal.Types.KindRepFun $krep1 T26615a.$tc'Full1
+$krep24 = GHC.Internal.Types.KindRepFun $krep1 $krep23
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'BitmapIndexed3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 50 0}]
-T26615a.$tc'BitmapIndexed3 = "'BitmapIndexed"#
+$tc'BitmapIndexed1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'BitmapIndexed1 = "'BitmapIndexed"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'BitmapIndexed2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'BitmapIndexed2
- = GHC.Internal.Types.TrNameS T26615a.$tc'BitmapIndexed3
+$tc'BitmapIndexed2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'BitmapIndexed2 = GHC.Internal.Types.TrNameS $tc'BitmapIndexed1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'BitmapIndexed :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'BitmapIndexed [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'BitmapIndexed
= GHC.Internal.Types.TyCon
15226751910432948177#Word64
957331387129868915#Word64
T26615a.$trModule
- T26615a.$tc'BitmapIndexed2
+ $tc'BitmapIndexed2
2#
- T26615a.$tc'BitmapIndexed1
+ $krep24
-- RHS size: {terms: 98, types: 109, coercions: 0, joins: 3/4}
T26615a.$wdisjointCollisions [InlPrag=INLINABLE[2]]
@@ -538,7 +425,7 @@ T26615a.$wdisjointCollisions [InlPrag=INLINABLE[2]]
Str=<LP(SC(S,C(1,L)),A)><L><1L><L><L>,
Unf=Unf{Src=StableUser, TopLvl=True,
Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [30 0 20 0 0] 406 10
+ Guidance=IF_ARGS [90 0 20 0 0] 406 10
Tmpl= \ (@k)
(@a)
(@b)
@@ -586,7 +473,7 @@ T26615a.$wdisjointCollisions [InlPrag=INLINABLE[2]]
Arity=5,
Str=<L><L><L><L><L>,
Unf=OtherCon []]
- lookupInArrayCont_ _ [Occ=Dead]
+ lookupInArrayCont_ ($dEq1 [Occ=Dead] :: Eq k)
(k1 [Occ=Once1] :: k)
(ary1 [Occ=Once1!] :: Array (Leaf k b))
(i1 [Occ=Once1!] :: Int)
@@ -654,24 +541,23 @@ T26615a.$wdisjointCollisions
$s$wfoldr_ [InlPrag=[2],
Occ=LoopBreaker,
Dmd=SC(S,C(1,C(1,C(1,L))))]
- :: Bool -> Int# -> Int# -> SmallArray# (Leaf k a) -> Bool
+ :: SmallArray# (Leaf k a) -> Int# -> Int# -> Bool -> Bool
[LclId[JoinId(4)(Nothing)],
Arity=4,
Str=<L><L><L><L>,
Unf=OtherCon []]
- $s$wfoldr_ (sc :: Bool)
+ $s$wfoldr_ (sc :: SmallArray# (Leaf k a))
(sc1 :: Int#)
(sc2 :: Int#)
- (sc3 :: SmallArray# (Leaf k a))
- = case >=# sc1 sc2 of {
+ (sc3 :: Bool)
+ = case >=# sc2 sc1 of {
__DEFAULT ->
- case indexSmallArray# @Lifted @(Leaf k a) sc3 sc1 of
- { (# ipv1 #) ->
+ case indexSmallArray# @Lifted @(Leaf k a) sc sc2 of { (# ipv1 #) ->
case ipv1 of { L kA ds1 ->
join {
$j :: Bool
[LclId[JoinId(0)(Nothing)]]
- $j = jump $s$wfoldr_ sc (+# sc1 1#) sc2 sc3 } in
+ $j = jump $s$wfoldr_ sc sc1 (+# sc2 1#) sc3 } in
joinrec {
$wlookupInArrayCont_ [InlPrag=[2],
Occ=LoopBreaker,
@@ -703,13 +589,13 @@ T26615a.$wdisjointCollisions
jump $wlookupInArrayCont_ kA ww2 0# lvl2
}
};
- 1# -> sc
+ 1# -> sc3
}; } in
jump $s$wfoldr_
- GHC.Internal.Types.True
- 0#
- (sizeofSmallArray# @Lifted @(Leaf k a) ipv)
ipv
+ (sizeofSmallArray# @Lifted @(Leaf k a) ipv)
+ 0#
+ GHC.Internal.Types.True
}
}
@@ -728,28 +614,28 @@ Rec {
-- RHS size: {terms: 133, types: 126, coercions: 0, joins: 1/2}
T26615a.disjointSubtrees_$s$wdisjointSubtrees [InlPrag=INLINABLE[2],
Occ=LoopBreaker]
- :: forall b a k.
- Word#
- -> SmallArray# (Leaf k a) -> Int# -> Eq k => HashMap k b -> Bool
+ :: forall k a b.
+ Eq k =>
+ Int# -> Word# -> SmallArray# (Leaf k a) -> HashMap k b -> Bool
[GblId[StrictWorker([~, ~, ~, ~, !])],
Arity=5,
- Str=<L><L><L><LP(SC(S,C(1,L)),A)><1L>,
+ Str=<LP(SC(S,C(1,L)),A)><L><L><L><1L>,
Unf=OtherCon []]
T26615a.disjointSubtrees_$s$wdisjointSubtrees
- = \ (@b)
+ = \ (@k)
(@a)
- (@k)
- (sc :: Word#)
- (sc1 :: SmallArray# (Leaf k a))
- (sc2 :: Int#)
- (sc3 :: Eq k)
+ (@b)
+ (sc :: Eq k)
+ (sc1 :: Int#)
+ (sc2 :: Word#)
+ (sc3 :: SmallArray# (Leaf k a))
(_b :: HashMap k b) ->
case _b of {
Empty -> GHC.Internal.Types.True;
Leaf bx ds ->
case ds of { L kB ds1 ->
case kB of k0 { __DEFAULT ->
- case eqWord# bx sc of {
+ case eqWord# bx sc2 of {
__DEFAULT -> GHC.Internal.Types.True;
1# ->
joinrec {
@@ -770,7 +656,7 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees
__DEFAULT ->
case indexSmallArray# @Lifted @(Leaf k a) ww ww1 of { (# ipv #) ->
case ipv of { L kx v ->
- case == @k sc3 k2 kx of {
+ case == @k sc k2 kx of {
False -> jump $wlookupInArrayCont_ k2 ww (+# ww1 1#) ww2;
True -> GHC.Internal.Types.False
}
@@ -780,19 +666,19 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees
}
}; } in
jump $wlookupInArrayCont_
- k0 sc1 0# (sizeofSmallArray# @Lifted @(Leaf k a) sc1)
+ k0 sc3 0# (sizeofSmallArray# @Lifted @(Leaf k a) sc3)
}
}
};
Collision bx bx1 ->
T26615a.$wdisjointCollisions
- @k @a @b sc3 sc (T26615a.Array @(Leaf k a) sc1) bx bx1;
+ @k @a @b sc sc2 (T26615a.Array @(Leaf k a) sc3) bx bx1;
BitmapIndexed bx bx1 ->
let {
m :: Word#
[LclId]
m = uncheckedShiftL#
- 1## (word2Int# (and# (uncheckedShiftRL# sc sc2) 31##)) } in
+ 1## (word2Int# (and# (uncheckedShiftRL# sc2 sc1) 31##)) } in
case and# m bx of {
__DEFAULT ->
case indexSmallArray#
@@ -803,7 +689,7 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees
of
{ (# ipv #) ->
T26615a.disjointSubtrees_$s$wdisjointSubtrees
- @b @a @k sc sc1 (+# sc2 5#) sc3 ipv
+ @k @a @b sc (+# sc1 5#) sc2 sc3 ipv
};
0## -> GHC.Internal.Types.True
};
@@ -812,17 +698,17 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees
@Lifted
@(HashMap k b)
bx
- (word2Int# (and# (uncheckedShiftRL# sc sc2) 31##))
+ (word2Int# (and# (uncheckedShiftRL# sc2 sc1) 31##))
of
{ (# ipv #) ->
T26615a.disjointSubtrees_$s$wdisjointSubtrees
- @b @a @k sc sc1 (+# sc2 5#) sc3 ipv
+ @k @a @b sc (+# sc1 5#) sc2 sc3 ipv
}
}
end Rec }
Rec {
--- RHS size: {terms: 705, types: 732, coercions: 18, joins: 13/23}
+-- RHS size: {terms: 705, types: 748, coercions: 18, joins: 13/23}
T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
:: forall k a b. Eq k => Int# -> HashMap k a -> HashMap k b -> Bool
[GblId[StrictWorker([~, ~, !])],
@@ -841,7 +727,7 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
join {
fail [Occ=Once3!T[1]] :: (# #) -> Bool
[LclId[JoinId(1)(Nothing)], Arity=1, Str=<L>, Unf=OtherCon []]
- fail _ [Occ=Dead, OS=OneShot]
+ fail (ds1 [Occ=Dead, OS=OneShot] :: (# #))
= case _b of wild [Occ=Once1] {
__DEFAULT ->
case GHC.Internal.Control.Exception.Base.patError
@@ -860,7 +746,7 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
Arity=5,
Str=<L><L><L><L><L>,
Unf=OtherCon []]
- lookupCont_ _ [Occ=Dead]
+ lookupCont_ ($dEq1 [Occ=Dead] :: Eq k)
(ds4 [Occ=Once1!] :: Word)
(ds5 [Occ=Once1] :: k)
(ds6 [Occ=Once1!] :: Int)
@@ -896,7 +782,7 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
Arity=5,
Str=<L><L><L><L><L>,
Unf=OtherCon []]
- lookupInArrayCont_ _ [Occ=Dead]
+ lookupInArrayCont_ ($dEq2 [Occ=Dead] :: Eq k)
(k1 [Occ=Once1] :: k)
(ary [Occ=Once1!] :: Array (Leaf k a))
(i [Occ=Once1!] :: Int)
@@ -1000,7 +886,7 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
Arity=5,
Str=<L><L><L><L><L>,
Unf=OtherCon []]
- lookupCont_ _ [Occ=Dead]
+ lookupCont_ ($dEq1 [Occ=Dead] :: Eq k)
(ds3 [Occ=Once1!] :: Word)
(ds4 [Occ=Once1] :: k)
(ds5 [Occ=Once1!] :: Int)
@@ -1034,7 +920,7 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
Arity=5,
Str=<L><L><L><L><L>,
Unf=OtherCon []]
- lookupInArrayCont_ _ [Occ=Dead]
+ lookupInArrayCont_ ($dEq2 [Occ=Dead] :: Eq k)
(k1 [Occ=Once1] :: k)
(ary [Occ=Once1!] :: Array (Leaf k b))
(i [Occ=Once1!] :: Int)
@@ -1179,23 +1065,23 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
@(*)
@(SmallArray# (HashMap k a)
-> SmallArray# (HashMap k b) -> Int#)
- @(GHC.Internal.Types.ZonkAny 0
- -> GHC.Internal.Types.ZonkAny 1 -> Int#)
+ @(GHC.Internal.Types.UnusedType 0 "a"
+ -> GHC.Internal.Types.UnusedType 1 "b" -> Int#)
of
{ GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 ->
case reallyUnsafePtrEquality#
@Lifted
@Lifted
- @(GHC.Internal.Types.ZonkAny 0)
- @(GHC.Internal.Types.ZonkAny 1)
+ @(GHC.Internal.Types.UnusedType 0 "a")
+ @(GHC.Internal.Types.UnusedType 1 "b")
(bx1
`cast` (SelCo:Fun(arg) (Sub (Sym v2))
:: SmallArray# (HashMap k a)
- ~R# GHC.Internal.Types.ZonkAny 0))
+ ~R# GHC.Internal.Types.UnusedType 0 "a"))
(bx3
`cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2)))
:: SmallArray# (HashMap k b)
- ~R# GHC.Internal.Types.ZonkAny 1))
+ ~R# GHC.Internal.Types.UnusedType 1 "b"))
of {
__DEFAULT ->
joinrec {
@@ -1324,51 +1210,49 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
}; } in
jump go (GHC.Internal.Types.W# (and# 4294967295## bx1));
Full bx1 ->
+ joinrec {
+ go [Occ=LoopBreakerT[1]] :: Int -> Bool
+ [LclId[JoinId(1)(Nothing)], Arity=1, Str=<L>, Unf=OtherCon []]
+ go (i :: Int)
+ = case GHC.Internal.Classes.ltInt i (GHC.Internal.Types.I# 0#) of {
+ False ->
+ case i of { I# i# ->
+ case indexSmallArray# @Lifted @(HashMap k a) bx i# of
+ { (# ipv [Occ=Once1] #) ->
+ case indexSmallArray# @Lifted @(HashMap k b) bx1 i# of
+ { (# ipv1 [Occ=Once1] #) ->
+ case T26615a.$wdisjointSubtrees @k @a @b $dEq (+# ww 5#) ipv ipv1
+ of {
+ False -> GHC.Internal.Types.False;
+ True -> jump go (GHC.Internal.Types.I# (-# i# 1#))
+ }
+ }
+ }
+ };
+ True -> GHC.Internal.Types.True
+ }; } in
case GHC.Internal.Unsafe.Coerce.unsafeEqualityProof
@(*)
@(SmallArray# (HashMap k a) -> SmallArray# (HashMap k b) -> Int#)
- @(GHC.Internal.Types.ZonkAny 0
- -> GHC.Internal.Types.ZonkAny 1 -> Int#)
+ @(GHC.Internal.Types.UnusedType 0 "a"
+ -> GHC.Internal.Types.UnusedType 1 "b" -> Int#)
of
{ GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 ->
case reallyUnsafePtrEquality#
@Lifted
@Lifted
- @(GHC.Internal.Types.ZonkAny 0)
- @(GHC.Internal.Types.ZonkAny 1)
+ @(GHC.Internal.Types.UnusedType 0 "a")
+ @(GHC.Internal.Types.UnusedType 1 "b")
(bx
`cast` (SelCo:Fun(arg) (Sub (Sym v2))
:: SmallArray# (HashMap k a)
- ~R# GHC.Internal.Types.ZonkAny 0))
+ ~R# GHC.Internal.Types.UnusedType 0 "a"))
(bx1
`cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2)))
:: SmallArray# (HashMap k b)
- ~R# GHC.Internal.Types.ZonkAny 1))
+ ~R# GHC.Internal.Types.UnusedType 1 "b"))
of {
- __DEFAULT ->
- joinrec {
- go [Occ=LoopBreakerT[1]] :: Int -> Bool
- [LclId[JoinId(1)(Nothing)], Arity=1, Str=<L>, Unf=OtherCon []]
- go (i :: Int)
- = case GHC.Internal.Classes.ltInt i (GHC.Internal.Types.I# 0#) of {
- False ->
- case i of { I# i# ->
- case indexSmallArray# @Lifted @(HashMap k a) bx i# of
- { (# ipv [Occ=Once1] #) ->
- case indexSmallArray# @Lifted @(HashMap k b) bx1 i# of
- { (# ipv1 [Occ=Once1] #) ->
- case T26615a.$wdisjointSubtrees
- @k @a @b $dEq (+# ww 5#) ipv ipv1
- of {
- False -> GHC.Internal.Types.False;
- True -> jump go (GHC.Internal.Types.I# (-# i# 1#))
- }
- }
- }
- };
- True -> GHC.Internal.Types.True
- }; } in
- jump go (GHC.Internal.Types.I# 31#);
+ __DEFAULT -> jump go (GHC.Internal.Types.I# 31#);
1# -> GHC.Internal.Types.False
}
}
@@ -1385,7 +1269,7 @@ T26615a.$wdisjointSubtrees
join {
fail [Dmd=MC(1,L)] :: (# #) -> Bool
[LclId[JoinId(1)(Nothing)], Arity=1, Str=<A>, Unf=OtherCon []]
- fail _ [Occ=Dead, OS=OneShot]
+ fail (ds1 [Occ=Dead, OS=OneShot] :: (# #))
= case _b of {
__DEFAULT -> case lvl1 of {};
Empty -> GHC.Internal.Types.True;
@@ -1508,7 +1392,7 @@ T26615a.$wdisjointSubtrees
};
Collision bx bx1 ->
T26615a.disjointSubtrees_$s$wdisjointSubtrees
- @a @b @k bx bx1 ww $dEq ds
+ @k @b @a $dEq ww bx bx1 ds
} } in
case ds of {
Empty -> GHC.Internal.Types.True;
@@ -1661,7 +1545,7 @@ T26615a.$wdisjointSubtrees
of
{ (# ipv #) ->
T26615a.disjointSubtrees_$s$wdisjointSubtrees
- @b @a @k bx bx1 (+# ww 5#) $dEq ipv
+ @k @a @b $dEq (+# ww 5#) bx bx1 ipv
};
0## -> GHC.Internal.Types.True
};
@@ -1674,7 +1558,7 @@ T26615a.$wdisjointSubtrees
of
{ (# ipv #) ->
T26615a.disjointSubtrees_$s$wdisjointSubtrees
- @b @a @k bx bx1 (+# ww 5#) $dEq ipv
+ @k @a @b $dEq (+# ww 5#) bx bx1 ipv
}
};
BitmapIndexed bx bx1 ->
@@ -1686,21 +1570,23 @@ T26615a.$wdisjointSubtrees
case GHC.Internal.Unsafe.Coerce.unsafeEqualityProof
@(*)
@(SmallArray# (HashMap k a) -> SmallArray# (HashMap k b) -> Int#)
- @(GHC.Internal.Types.ZonkAny 0
- -> GHC.Internal.Types.ZonkAny 1 -> Int#)
+ @(GHC.Internal.Types.UnusedType 0 "a"
+ -> GHC.Internal.Types.UnusedType 1 "b" -> Int#)
of
{ GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 ->
case reallyUnsafePtrEquality#
@Lifted
@Lifted
- @(GHC.Internal.Types.ZonkAny 0)
- @(GHC.Internal.Types.ZonkAny 1)
+ @(GHC.Internal.Types.UnusedType 0 "a")
+ @(GHC.Internal.Types.UnusedType 1 "b")
(bx1
`cast` (SelCo:Fun(arg) (Sub (Sym v2))
- :: SmallArray# (HashMap k a) ~R# GHC.Internal.Types.ZonkAny 0))
+ :: SmallArray# (HashMap k a)
+ ~R# GHC.Internal.Types.UnusedType 0 "a"))
(bx3
`cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2)))
- :: SmallArray# (HashMap k b) ~R# GHC.Internal.Types.ZonkAny 1))
+ :: SmallArray# (HashMap k b)
+ ~R# GHC.Internal.Types.UnusedType 1 "b"))
of {
__DEFAULT ->
let {
@@ -1829,21 +1715,23 @@ T26615a.$wdisjointSubtrees
case GHC.Internal.Unsafe.Coerce.unsafeEqualityProof
@(*)
@(SmallArray# (HashMap k a) -> SmallArray# (HashMap k b) -> Int#)
- @(GHC.Internal.Types.ZonkAny 0
- -> GHC.Internal.Types.ZonkAny 1 -> Int#)
+ @(GHC.Internal.Types.UnusedType 0 "a"
+ -> GHC.Internal.Types.UnusedType 1 "b" -> Int#)
of
{ GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 ->
case reallyUnsafePtrEquality#
@Lifted
@Lifted
- @(GHC.Internal.Types.ZonkAny 0)
- @(GHC.Internal.Types.ZonkAny 1)
+ @(GHC.Internal.Types.UnusedType 0 "a")
+ @(GHC.Internal.Types.UnusedType 1 "b")
(bx
`cast` (SelCo:Fun(arg) (Sub (Sym v2))
- :: SmallArray# (HashMap k a) ~R# GHC.Internal.Types.ZonkAny 0))
+ :: SmallArray# (HashMap k a)
+ ~R# GHC.Internal.Types.UnusedType 0 "a"))
(bx1
`cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2)))
- :: SmallArray# (HashMap k b) ~R# GHC.Internal.Types.ZonkAny 1))
+ :: SmallArray# (HashMap k b)
+ ~R# GHC.Internal.Types.UnusedType 1 "b"))
of {
__DEFAULT ->
let {
@@ -1910,88 +1798,72 @@ disjointSubtrees
------ Local rules for imported ids --------
"SC:$wdisjointSubtrees1" [1]
- forall (@a)
+ forall (@k)
(@b)
- (@k)
- (sc :: Word#)
- (sc1 :: SmallArray# (Leaf k a))
+ (@a)
+ (sc :: Eq k)
+ (sc1 :: Int#)
(sc2 :: Word#)
(sc3 :: SmallArray# (Leaf k b))
- (sc4 :: Int#)
- (sc5 :: Eq k).
+ (sc4 :: Word#)
+ (sc5 :: SmallArray# (Leaf k a)).
T26615a.$wdisjointSubtrees @k
@b
@a
- sc5
- sc4
+ sc
+ sc1
(T26615a.Collision @k @b sc2 sc3)
- (T26615a.Collision @k @a sc sc1)
+ (T26615a.Collision @k @a sc4 sc5)
= T26615a.$wdisjointCollisions
- @k @b @a sc5 sc2 (T26615a.Array @(Leaf k b) sc3) sc sc1
+ @k @b @a sc sc2 (T26615a.Array @(Leaf k b) sc3) sc4 sc5
"SC:$wdisjointSubtrees0" [1]
- forall (@b)
+ forall (@k)
(@a)
- (@k)
- (sc :: Word#)
- (sc1 :: SmallArray# (Leaf k a))
- (sc2 :: Int#)
- (sc3 :: Eq k).
+ (@b)
+ (sc :: Eq k)
+ (sc1 :: Int#)
+ (sc2 :: Word#)
+ (sc3 :: SmallArray# (Leaf k a)).
T26615a.$wdisjointSubtrees @k
@a
@b
- sc3
- sc2
- (T26615a.Collision @k @a sc sc1)
+ sc
+ sc1
+ (T26615a.Collision @k @a sc2 sc3)
= T26615a.disjointSubtrees_$s$wdisjointSubtrees
- @b @a @k sc sc1 sc2 sc3
+ @k @a @b sc sc1 sc2 sc3
[2 of 2] Compiling T26615 ( T26615.hs, T26615.o )
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 614, types: 666, coercions: 18, joins: 8/14}
+ = {terms: 614, types: 682, coercions: 18, joins: 8/14}
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615.$trModule2 :: GHC.Internal.Prim.Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615.$trModule2 = "T26615"#
+$trModule1 :: GHC.Internal.Prim.Addr#
+[GblId, Unf=OtherCon []]
+$trModule1 = "T26615"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615.$trModule1 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615.$trModule1 = GHC.Internal.Types.TrNameS T26615.$trModule2
+$trModule2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$trModule2 = GHC.Internal.Types.TrNameS $trModule1
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615.$trModule4 :: GHC.Internal.Prim.Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 20 0}]
-T26615.$trModule4 = "main"#
+$trModule3 :: GHC.Internal.Prim.Addr#
+[GblId, Unf=OtherCon []]
+$trModule3 = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615.$trModule3 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615.$trModule3 = GHC.Internal.Types.TrNameS T26615.$trModule4
+$trModule4 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$trModule4 = GHC.Internal.Types.TrNameS $trModule3
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615.$trModule :: GHC.Internal.Types.Module
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615.$trModule
- = GHC.Internal.Types.Module T26615.$trModule3 T26615.$trModule1
+T26615.$trModule [InlPrag=[~]] :: GHC.Internal.Types.Module
+[GblId, Unf=OtherCon []]
+T26615.$trModule = GHC.Internal.Types.Module $trModule4 $trModule2
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
lvl :: GHC.Internal.Prim.Addr#
@@ -2128,7 +2000,7 @@ $wpoly_lookupCont_
end Rec }
Rec {
--- RHS size: {terms: 448, types: 507, coercions: 18, joins: 8/13}
+-- RHS size: {terms: 448, types: 523, coercions: 18, joins: 8/13}
T26615.$s$wdisjointSubtrees [InlPrag=[~], Occ=LoopBreaker]
:: forall a b.
GHC.Internal.Prim.Int#
@@ -2143,7 +2015,7 @@ T26615.$s$wdisjointSubtrees
join {
fail [Dmd=MC(1,L)] :: (# #) -> Bool
[LclId[JoinId(1)(Nothing)], Arity=1, Str=<A>, Unf=OtherCon []]
- fail _ [Occ=Dead, OS=OneShot]
+ fail (ds1 [Occ=Dead, OS=OneShot] :: (# #))
= case _b of wild {
__DEFAULT -> case lvl1 of {};
T26615a.Empty -> GHC.Internal.Types.True;
@@ -2190,30 +2062,28 @@ T26615.$s$wdisjointSubtrees
$s$wfoldr_ [InlPrag=[2],
Occ=LoopBreaker,
Dmd=SC(S,C(1,C(1,C(1,L))))]
- :: Bool
- -> GHC.Internal.Prim.Int#
- -> GHC.Internal.Prim.Int#
- -> GHC.Internal.Prim.SmallArray# (T26615a.Leaf [Char] a)
- -> Bool
+ :: GHC.Internal.Prim.SmallArray# (T26615a.Leaf [Char] a)
+ -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> Bool -> Bool
[LclId[JoinId(4)(Nothing)],
Arity=4,
Str=<L><L><L><L>,
Unf=OtherCon []]
- $s$wfoldr_ (sc :: Bool)
+ $s$wfoldr_ (sc
+ :: GHC.Internal.Prim.SmallArray# (T26615a.Leaf [Char] a))
(sc1 :: GHC.Internal.Prim.Int#)
(sc2 :: GHC.Internal.Prim.Int#)
- (sc3 :: GHC.Internal.Prim.SmallArray# (T26615a.Leaf [Char] a))
- = case GHC.Internal.Prim.>=# sc1 sc2 of {
+ (sc3 :: Bool)
+ = case GHC.Internal.Prim.>=# sc2 sc1 of {
__DEFAULT ->
case GHC.Internal.Prim.indexSmallArray#
- @GHC.Internal.Types.Lifted @(T26615a.Leaf String a) sc3 sc1
+ @GHC.Internal.Types.Lifted @(T26615a.Leaf String a) sc sc2
of
{ (# ipv1 #) ->
case ipv1 of { T26615a.L kA ds2 ->
join {
$j :: Bool
[LclId[JoinId(0)(Nothing)]]
- $j = jump $s$wfoldr_ sc (GHC.Internal.Prim.+# sc1 1#) sc2 sc3 } in
+ $j = jump $s$wfoldr_ sc sc1 (GHC.Internal.Prim.+# sc2 1#) sc3 } in
joinrec {
$wlookupInArrayCont_ [InlPrag=[2],
Occ=LoopBreaker,
@@ -2258,14 +2128,14 @@ T26615.$s$wdisjointSubtrees
jump $wlookupInArrayCont_ kA bx3 0# lvl2
}
};
- 1# -> sc
+ 1# -> sc3
}; } in
jump $s$wfoldr_
- GHC.Internal.Types.True
- 0#
+ bx1
(GHC.Internal.Prim.sizeofSmallArray#
@GHC.Internal.Types.Lifted @(T26615a.Leaf String a) bx1)
- bx1
+ 0#
+ GHC.Internal.Types.True
};
T26615a.BitmapIndexed bx2 bx3 ->
let {
@@ -2317,23 +2187,23 @@ T26615.$s$wdisjointSubtrees
@(GHC.Internal.Prim.SmallArray# (HashMap String a)
-> GHC.Internal.Prim.SmallArray# (HashMap String b)
-> GHC.Internal.Prim.Int#)
- @(GHC.Internal.Types.ZonkAny 0
- -> GHC.Internal.Types.ZonkAny 1 -> GHC.Internal.Prim.Int#)
+ @(GHC.Internal.Types.UnusedType 0 "a"
+ -> GHC.Internal.Types.UnusedType 1 "b" -> GHC.Internal.Prim.Int#)
of
{ GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 ->
case GHC.Internal.Prim.reallyUnsafePtrEquality#
@GHC.Internal.Types.Lifted
@GHC.Internal.Types.Lifted
- @(GHC.Internal.Types.ZonkAny 0)
- @(GHC.Internal.Types.ZonkAny 1)
+ @(GHC.Internal.Types.UnusedType 0 "a")
+ @(GHC.Internal.Types.UnusedType 1 "b")
(bx1
`cast` (SelCo:Fun(arg) (Sub (Sym v2))
:: GHC.Internal.Prim.SmallArray# (HashMap String a)
- ~R# GHC.Internal.Types.ZonkAny 0))
+ ~R# GHC.Internal.Types.UnusedType 0 "a"))
(bx3
`cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2)))
:: GHC.Internal.Prim.SmallArray# (HashMap String b)
- ~R# GHC.Internal.Types.ZonkAny 1))
+ ~R# GHC.Internal.Types.UnusedType 1 "b"))
of {
__DEFAULT ->
joinrec {
@@ -2495,23 +2365,23 @@ T26615.$s$wdisjointSubtrees
@(GHC.Internal.Prim.SmallArray# (HashMap String a)
-> GHC.Internal.Prim.SmallArray# (HashMap String b)
-> GHC.Internal.Prim.Int#)
- @(GHC.Internal.Types.ZonkAny 0
- -> GHC.Internal.Types.ZonkAny 1 -> GHC.Internal.Prim.Int#)
+ @(GHC.Internal.Types.UnusedType 0 "a"
+ -> GHC.Internal.Types.UnusedType 1 "b" -> GHC.Internal.Prim.Int#)
of
{ GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 ->
case GHC.Internal.Prim.reallyUnsafePtrEquality#
@GHC.Internal.Types.Lifted
@GHC.Internal.Types.Lifted
- @(GHC.Internal.Types.ZonkAny 0)
- @(GHC.Internal.Types.ZonkAny 1)
+ @(GHC.Internal.Types.UnusedType 0 "a")
+ @(GHC.Internal.Types.UnusedType 1 "b")
(bx
`cast` (SelCo:Fun(arg) (Sub (Sym v2))
:: GHC.Internal.Prim.SmallArray# (HashMap String a)
- ~R# GHC.Internal.Types.ZonkAny 0))
+ ~R# GHC.Internal.Types.UnusedType 0 "a"))
(bx1
`cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2)))
:: GHC.Internal.Prim.SmallArray# (HashMap String b)
- ~R# GHC.Internal.Types.ZonkAny 1))
+ ~R# GHC.Internal.Types.UnusedType 1 "b"))
of {
__DEFAULT ->
joinrec {
@@ -2564,7 +2434,7 @@ f = \ (@a)
------ Local rules for imported ids --------
"SPEC/T26615 $wdisjointSubtrees @String @_ @_" [2]
- forall (@a) (@b) ($dEq :: Eq String).
+ forall (@a) (@b) ($dEq [Occ=Dead] :: Eq String).
T26615a.$wdisjointSubtrees @String @a @b $dEq
= T26615.$s$wdisjointSubtrees @a @b
=====================================
testsuite/tests/typecheck/should_fail/T13292.stderr
=====================================
@@ -14,15 +14,15 @@ T13292a.hs:4:12: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)]
In an equation for ‘someFunc’: someFunc = return ()
T13292.hs:6:1: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
- • Couldn't match type ‘GHC.Internal.Types.ZonkAny 0’ with ‘IO’
+ • Couldn't match type ‘m00’ with ‘IO’
Expected: IO ()
- Actual: GHC.Internal.Types.ZonkAny 0 ()
+ Actual: m00
• When checking the type of the IO action ‘main’
T13292.hs:6:1: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
- • Couldn't match type ‘GHC.Internal.Types.ZonkAny 0’ with ‘IO’
+ • Couldn't match type ‘m00’ with ‘IO’
Expected: IO ()
- Actual: GHC.Internal.Types.ZonkAny 0 ()
+ Actual: m00
• In the expression: main
When checking the type of the IO action ‘main’
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eebd176cebe89fae4a49cac47fba9d2…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eebd176cebe89fae4a49cac47fba9d2…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/mangoiv/unused-type] compiler: rename ZonkAny to UnusedType and add pretty printing logic
by Magnus (＠MangoIV) 19 Jun '26
by Magnus (＠MangoIV) 19 Jun '26
19 Jun '26
Magnus pushed to branch wip/mangoiv/unused-type at Glasgow Haskell Compiler / GHC
Commits:
65b92958 by mangoiv at 2026-06-19T11:31:25+02:00
compiler: rename ZonkAny to UnusedType and add pretty printing logic
ZonkAny is a hard to understand name for users who do not know how the
compiler works internally. Additionally, it is confusing that ZonkAny,
while being a concrete type *represents* a meta variable, espeically in
the compiler output.
This patch changes the name of ZonkAny to UnusedType which is closer to
its intended semantics and adds special pretty printing logic to display
this type in the same fashion the compiler displays meta variables in
other places, whenever they leak from the implementation to the user.
- - - - -
17 changed files:
- + changelog.d/unused-type
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Zonk/Type.hs
- libraries/ghc-internal/src/GHC/Internal/Types.hs
- testsuite/tests/perf/compiler/T11068.stdout
- testsuite/tests/pmcheck/should_compile/T12957.stderr
- testsuite/tests/profiling/should_run/staticcallstack002.stdout
- testsuite/tests/simplCore/should_compile/Makefile
- testsuite/tests/simplCore/should_compile/T13156.stdout
- testsuite/tests/simplCore/should_compile/T26615.stderr
- testsuite/tests/typecheck/should_fail/T13292.stderr
Changes:
=====================================
changelog.d/unused-type
=====================================
@@ -0,0 +1,14 @@
+section: compiler
+synopsis: Rename ZonkAny to UnusedType and add pretty printing logic for it.
+issues: #27390
+mrs: !16212
+
+description: {
+ After unification GHC fills in unused type variables with a fixed kind like in
+ ``(length :: [alpha] -> Int) ([] :: List alpha) :: Int`` with a fixed type.
+ This type was, confusingly to the user, called ``ZonkAny``.
+ We rename this type to ``UnusedType``, store naming information, and try hard to
+ pretty print it to something that is more resemblant of an unused in non-debugging
+ compiler output. We also export ``UnusedType`` from ``GHC.Internal.Types`` to make
+ it easier to discover without reading the GHC source code.
+}
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -1904,8 +1904,8 @@ unsatisfiableClassNameKey = mkPreludeTyConUnique 170
anyTyConKey :: Unique
anyTyConKey = mkPreludeTyConUnique 171
-zonkAnyTyConKey :: Unique
-zonkAnyTyConKey = mkPreludeTyConUnique 172
+unusedTypeTyConKey :: Unique
+unusedTypeTyConKey = mkPreludeTyConUnique 172
-- Custom user type-errors
errorMessageTypeErrorFamKey :: Unique
=====================================
compiler/GHC/Builtin/Types.hs
=====================================
@@ -93,7 +93,7 @@ module GHC.Builtin.Types (
cTupleSelId, cTupleSelIdName,
-- * Any
- anyTyCon, anyTy, anyTypeOfKind, zonkAnyTyCon,
+ anyTyCon, anyTy, anyTypeOfKind, unusedTypeTyCon,
-- * Recovery TyCon
makeRecoveryTyCon,
@@ -300,7 +300,7 @@ wiredInTyCons :: [TyCon]
wiredInTyCons = map (dataConTyCon . snd) boxingDataCons
++ [ anyTyCon
- , zonkAnyTyCon
+ , unusedTypeTyCon
, boolTyCon
, charTyCon
, stringTyCon
@@ -412,13 +412,13 @@ doubleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#")
{-
Note [Any types]
~~~~~~~~~~~~~~~~
-The type constructors `Any` and `ZonkAny` are closed type families declared thus:
+The type constructors `Any` and `UnusedType` are closed type families declared thus:
- type family Any :: forall k. k where { }
- type family ZonkAny :: forall k. Nat -> k where { }
+ type family Any :: forall k. k where { }
+ type family UnusedType :: forall k. Nat -> Symbol -> k where { }
They are used when we want a type of a particular kind, but we don't really care
-what that type is. The leading example is this: `ZonkAny` is used to instantiate
+what that type is. The leading example is this: `UnusedType` is used to instantiate
un-constrained type variables after type checking. For example, consider the
term (length [] :: Int), where
@@ -431,26 +431,26 @@ The typechecker will end up with
length @alpha ([] @alpha)
where `alpha` is an un-constrained unification variable. The "zonking" process zaps
-that unconstrained `alpha` to an arbitrary type (ZonkAny @Type 3), where the `3` is
-arbitrary (see wrinkle (Any5) below). This is done in `GHC.Tc.Zonk.Type.commitFlexi`.
-So we end up with
+that unconstrained `alpha` to an arbitrary type (UnusedType @Type 3 "a"), where the `3` is
+arbitrary (see wrinkle (Any5) below). and "a" is the original name, if we have one.
+This is done in `GHC.Tc.Zonk.Type.commitFlexi`. So we end up with
- length @(ZonkAny @Type 3) ([] @(ZonkAny @Type 3))
+ length @(UnusedType @Type 3 "a") ([] @(UnusedType @Type 3 "a"))
-`Any` and `ZonkAny` differ only in the presence of the `Nat` argument; see
-wrinkle (Any4).
+`Any` and `UnusedType` differ only in the presence of the `Nat` and the `Symbol` arguments;
+see wrinkle (Any4).
Wrinkles:
-(Any1) `Any` and `ZonkAny` are kind polymorphic since in some program we may
- need to use `ZonkAny` to fill in a type variable of some kind other than *
+(Any1) `Any` and `UnusedType` are kind polymorphic since in some program we may
+ need to use `UnusedType` to fill in a type variable of some kind other than *
(see #959 for examples).
(Any2) They are /closed/ type families, with no instances. For example, suppose that
with alpha :: '(k1, k2) we add a given coercion
g :: alpha ~ (Fst alpha, Snd alpha)
- and we zonked alpha = ZonkAny @(k1,k2) n. Then, if `ZonkAny` was a /data/ type,
- we'd get inconsistency because we'd have a Given equality with `ZonkAny` on one
+ and we zonked alpha = UnusedType @(k1,k2) n. Then, if `UnusedType` was a /data/ type,
+ we'd get inconsistency because we'd have a Given equality with `UnusedType` on one
side and '(,) on the other. See also #9097 and #9636.
See #25244 for a suggestion that we instead use an /open/ type family for which
@@ -459,8 +459,11 @@ Wrinkles:
(Any3) They do not claim to be /data/ types, and that's important for
the code generator, because the code gen may /enter/ a data value
but never enters a function value.
+ This is the motivation for the primary use case of `Any` in userspace which is
+ implementing type safe interfaces with improved performance characteristics,
+ e.g. storing `Any` leaves as the values for a finite dependent Map.
-(Any4) `ZonkAny` takes a `Nat` argument so that we can readily make up /distinct/
+(Any4) `UnusedType` takes a `Nat` argument so that we can readily make up /distinct/
types (#24817). Consider
data SBool a where { STrue :: SBool True; SFalse :: SBool False }
@@ -475,25 +478,43 @@ Wrinkles:
Now, what are `alpha` and `beta`? If we zonk both of them to the same type
`Any @Type`, the pattern-match checker will (wrongly) report that the first
branch is inaccessible. So we zonk them to two /different/ types:
- alpha := ZonkAny @Type 4 and beta := ZonkAny @Type k 5
+ alpha := UnusedType @Type 4 "a" and beta := UnusedType @Type k 5 "b"
(The actual numbers are arbitrary; they just need to differ.)
The unique-name generation comes from field `tcg_zany_n` of `TcGblEnv`; and
- `GHC.Tc.Zonk.Type.commitFlexi` calls `GHC.Tc.Utils.Monad.newZonkAnyType` to
+ `GHC.Tc.Zonk.Type.commitFlexi` calls `GHC.Tc.Utils.Monad.newUnusedTypeType` to
make up a fresh type.
If this example seems unconvincing (e.g. in this case foo must be bottom)
see #24817 for larger but more compelling examples.
-(Any5) `Any` and `ZonkAny` are wired-in so we can easily refer to it where we
+(Any9)
+ `UnusedType` takes a `Symbol` argument, which we use to neatly display zonked unfilled
+ metavariables without leaking internal type families.
+
+ See T13292 for an example of this in action.
+
+ `UnusedType` is handled specially in the pretty-printer to avoid confusing compiler output.
+ For example, `UnusedType 3 "foo" :: Type` is displayed as `foo3`
+
+ That special handling is implemented in GHC.Iface.Type.pprTyTcApp and more specifically
+ ppr_iface_unused_ty_tycon.
+
+ Historical note: in the past, `UnusedType` was called `ZonkAny` (or `Any` before that).
+ We renamed it to `UnusedType` and added this special treatment in the pretty-printer to avoid
+ confusing mentions of zonking.
+
+(Any5) `Any` and `UnusedType` are wired-in so we can easily refer to it where we
don't have a name environment (e.g. see Rules.matchRule for one example)
-(Any6) `Any` is defined in library module ghc-prim:GHC.Types, and exported so that
- it is available to users. For this reason it's treated like any other
- wired-in type:
- - has a fixed unique, anyTyConKey,
- - lives in the global name cache
- Currently `ZonkAny` is not available to users; but it could easily be.
+(Any6) `Any` and `UnusedType` are defined in library module ghc-prim:GHC.Types,
+ and exported. `Any` should be available to users mainly because it is a useful type
+ in userspace. `UnusedType` is exported mainly for documentation in case they stumble
+ over it in debug output: a user should not have to grep the compiler to know what
+ a given type in their program is there for. For this reason they're treated like any other
+ wired-in types:
+ - they have a fixed unique, anyTyConKey/unusedTypeTyConKey,
+ - live in the global name cache
(Any7) Properties of `Any`:
* When `Any` is instantiated at a lifted type it is inhabited by at least one value,
@@ -512,7 +533,7 @@ Wrinkles:
See examples in ghc-prim:GHC.Types
-(Any8) Warning about unused bindings of type `Any` and `ZonkAny` are suppressed,
+(Any8) Warning about unused bindings of type `Any` and `UnusedType` are suppressed,
following the same rationale of supressing warning about the unit type.
For example, consider (#25895):
@@ -520,7 +541,7 @@ Wrinkles:
do { forever (return ()); blah }
where forever :: forall a b. IO a -> IO b
- Nothing constrains `b`, so it will be instantiates with `Any` or `ZonkAny`.
+ Nothing constrains `b`, so it will be instantiates with `Any` or `UnusedType`.
But we certainly don't want to complain about a discarded do-binding.
The Any tycon used to be quite magic, but we have since been able to
@@ -550,22 +571,23 @@ anyTy = mkTyConTy anyTyCon
anyTypeOfKind :: Kind -> Type
anyTypeOfKind kind = mkTyConApp anyTyCon [kind]
-zonkAnyTyConName :: Name
-zonkAnyTyConName =
- mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZonkAny") zonkAnyTyConKey zonkAnyTyCon
+unusedTypeTyConName :: Name
+unusedTypeTyConName =
+ mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnusedType") unusedTypeTyConKey unusedTypeTyCon
-zonkAnyTyCon :: TyCon
--- ZonkAnyTyCon :: forall k. Nat -> k
+unusedTypeTyCon :: TyCon
+-- unusedTypeTyCon :: forall k. Nat -> Symbol -> k
-- See Note [Any types]
-zonkAnyTyCon = mkFamilyTyCon zonkAnyTyConName kind bndrs 0 res_kind
+unusedTypeTyCon = mkFamilyTyCon unusedTypeTyConName kind bndrs 0 res_kind
Nothing
(ClosedSynFamilyTyCon Nothing)
Nothing
NotInjective
where
- [kv,nat_kv] = mkTemplateKindVars [liftedTypeKind, naturalTy]
+ [kv,nat_kv,sym_kv] = mkTemplateKindVars [liftedTypeKind, naturalTy, typeSymbolKind]
bndrs = [ mkNamedTyConBinder Specified kv
- , mkAnonTyConBinder nat_kv ]
+ , mkAnonTyConBinder nat_kv
+ , mkAnonTyConBinder sym_kv ]
res_kind = mkTyVarTy kv
kind = mkTyConKind bndrs res_kind
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -1281,11 +1281,11 @@ warnDiscardedDoBindings rhs@(L rhs_loc _) m_ty elt_ty
do { fam_inst_envs <- dsGetFamInstEnvs
; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
supressible_ty =
- isUnitTy norm_elt_ty || isAnyTy norm_elt_ty || isZonkAnyTy norm_elt_ty
+ isUnitTy norm_elt_ty || isAnyTy norm_elt_ty || isUnusedTypeTy norm_elt_ty
-- Warn about discarding things in 'monadic' binding,
-- however few types are excluded:
-- * Unit type `()`
- -- * `ZonkAny` or `Any` type see (Any8) of Note [Any types]
+ -- * `UnusedType` or `Any` type see (Any8) of Note [Any types]
; if warn_unused && not supressible_ty
then diagnosticDs (DsUnusedDoBind rhs elt_ty)
else
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -7,7 +7,7 @@ This module defines interface types and binders
-}
-{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE MultiWayIf, OverloadedRecordDot #-}
module GHC.Iface.Type (
IfExtName,
IfLclName(..), mkIfLclName, ifLclNameFS,
@@ -1740,6 +1740,7 @@ pprTyTcApp ctxt_prec tc tys =
sdocOption sdocPrintExplicitKinds $ \print_kinds ->
sdocOption sdocPrintTypeAbbreviations $ \print_type_abbreviations ->
getPprDebug $ \debug ->
+ getPprStyle $ \style ->
if | ifaceTyConName tc `hasKey` ipClassKey
, IA_Arg (IfaceLitTy (IfaceStrTyLit n))
@@ -1791,6 +1792,13 @@ pprTyTcApp ctxt_prec tc tys =
| Just doc <- ppr_equality ctxt_prec tc (appArgsIfaceTypes tys)
-> doc
+ -- See Note [Any types], specifically (Any4) and (Any9)
+ | ifaceTyConName tc `hasKey` unusedTypeTyConKey
+ , (arg_k : IfaceLitTy (IfaceNumTyLit arg_n) : IfaceLitTy (IfaceStrTyLit arg_nm) : _) <- appArgsIfaceTypes tys
+ -- if arg_k is a kind with more than 0 arguments, then _ might not be [] here
+ , userStyle style
+ -> ppr_iface_unused_ty_tycon ctxt_prec arg_k arg_n arg_nm
+
| otherwise
-> ppr_iface_tc_app ppr_app_arg ctxt_prec tc $
appArgsIfaceTypesForAllTyFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) tys
@@ -1802,6 +1810,19 @@ ppr_kind_type ctxt_prec = sdocOption sdocStarIsType $ \case
False -> pprPrefixOcc liftedTypeKindTyConName
True -> maybeParen ctxt_prec starPrec starLit
+-- | user-style printer that pretty-prints an 'UnusedType @k 3 "foo" to foo3.
+-- If -fprint-explicit-kinds or -fprint-explicit-runtime-reps are set, instead
+-- prints them to (foo3 :: k).
+-- See Note [Any types], specifically (Any4) and (Any9) for why this is useful.
+ppr_iface_unused_ty_tycon :: PprPrec -> IfaceType -> Integer -> LexicalFastString -> SDoc
+ppr_iface_unused_ty_tycon ctxt_prec arg_k arg_n arg_nm
+ = sdocOption sdocPrintExplicitKinds $ \print_kinds ->
+ sdocOption sdocPrintExplicitRuntimeReps $ \print_reps ->
+ if print_kinds || print_reps
+ then maybeParen ctxt_prec sigPrec $ prettyMeta <+> text "::" <+> pprIfaceType arg_k
+ else prettyMeta
+ where prettyMeta = ppr arg_nm <> ppr arg_n
+
-- | Pretty-print a type-level equality.
-- Returns (Just doc) if the argument is a /saturated/ application
-- of eqTyCon (~)
@@ -2190,7 +2211,8 @@ instance Binary IfaceTyConSort where
0 -> return IfaceNormalTyCon
1 -> IfaceTupleTyCon <$> get bh <*> get bh
2 -> IfaceSumTyCon <$> get bh
- _ -> return IfaceEqualityTyCon
+ 3 -> return IfaceEqualityTyCon
+ _ -> panic "get IfaceTyConSort"
instance Binary IfaceTyConInfo where
put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -582,7 +582,7 @@ data TcGblEnv
-- ^ Allows us to choose unique DFun names.
tcg_zany_n :: TcRef Integer,
- -- ^ A source of unique identities for ZonkAny instances
+ -- ^ A source of unique identities for UnusedType instances
-- See Note [Any types] in GHC.Builtin.Types, wrinkle (Any4)
tcg_merged :: [(Module, Fingerprint)],
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -154,7 +154,7 @@ module GHC.Tc.Utils.Monad(
getCCIndexM, getCCIndexTcM,
-- * Zonking
- liftZonkM, newZonkAnyType,
+ liftZonkM, newUnusedType,
-- * Complete matches
localAndImportedCompleteMatches, getCompleteMatchesTcM,
@@ -168,7 +168,7 @@ import GHC.Prelude
import GHC.Builtin.Names
-import GHC.Builtin.Types( zonkAnyTyCon )
+import GHC.Builtin.Types( unusedTypeTyCon )
import GHC.Tc.Errors.Types
import GHC.Tc.Errors.Hole.Plugin ( HoleFitPlugin, HoleFitPluginR (..) )
@@ -197,7 +197,7 @@ import GHC.Core.Coercion ( isReflCo )
import GHC.Core.Multiplicity
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
-import GHC.Core.Type( mkNumLitTy )
+import GHC.Core.Type( mkNumLitTy, mkStrLitTy )
import GHC.Core.TyCo.Rep( CoercionHole(..) )
import GHC.Core.TyCo.FVs( coVarsOfCo )
import GHC.Core.TyCon ( TyCon )
@@ -2258,17 +2258,17 @@ chooseUniqueOccTc fn =
; writeTcRef dfun_n_var (extendOccSet set occ)
; return occ }
-newZonkAnyType :: Kind -> TcM Type
--- Return a type (ZonkAny @k n), where n is fresh
--- Recall ZonkAny :: forall k. Natural -> k
+newUnusedType :: Name -> Kind -> TcM Type
+-- Return a type (UnusedType @k n sym), where n is fresh
+-- Recall UnusedType :: forall k. Natural -> Symbol -> k
-- See Note [Any types] in GHC.Builtin.Types, wrinkle (Any4)
-newZonkAnyType kind
+newUnusedType name kind
= do { env <- getGblEnv
; let zany_n_var = tcg_zany_n env
; i <- readTcRef zany_n_var
; let !i2 = i+1
; writeTcRef zany_n_var i2
- ; return (mkTyConApp zonkAnyTyCon [kind, mkNumLitTy i]) }
+ ; return (mkTyConApp unusedTypeTyCon [kind, mkNumLitTy i, mkStrLitTy $ getOccFS name ]) }
getConstraintVar :: TcM (TcRef WantedConstraints)
getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -85,7 +85,7 @@ module GHC.Tc.Utils.TcType (
isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy,
isFloatingPrimTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
isIntegerTy, isNaturalTy,
- isBoolTy, isUnitTy, isAnyTy, isZonkAnyTy, isCharTy,
+ isBoolTy, isUnitTy, isAnyTy, isUnusedTypeTy, isCharTy,
isTauTy, isTauTyCon, tcIsTyVarTy,
isPredTy, isSimplePredTy, isTyVarClassPred,
checkValidClsArgs, hasTyVarHead,
@@ -2057,7 +2057,7 @@ isFloatTy, isDoubleTy,
isFloatPrimTy, isDoublePrimTy,
isIntegerTy, isNaturalTy,
isIntTy, isWordTy, isBoolTy,
- isUnitTy, isAnyTy, isZonkAnyTy, isCharTy :: Type -> Bool
+ isUnitTy, isAnyTy, isUnusedTypeTy, isCharTy :: Type -> Bool
isFloatTy = is_tc floatTyConKey
isDoubleTy = is_tc doubleTyConKey
isFloatPrimTy = is_tc floatPrimTyConKey
@@ -2069,7 +2069,7 @@ isWordTy = is_tc wordTyConKey
isBoolTy = is_tc boolTyConKey
isUnitTy = is_tc unitTyConKey
isAnyTy = is_tc anyTyConKey
-isZonkAnyTy = is_tc zonkAnyTyConKey
+isUnusedTypeTy = is_tc unusedTypeTyConKey
isCharTy = is_tc charTyConKey
-- | Check whether the type is of the form @Any :: k@,
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedRecordDot #-}
{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1996-1998
@@ -43,7 +44,7 @@ import GHC.Tc.Types.TcRef
import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo )
import GHC.Tc.Utils.Env ( tcLookupGlobalOnly )
import GHC.Tc.Utils.TcType
-import GHC.Tc.Utils.Monad ( newZonkAnyType, setSrcSpanA, liftZonkM, traceTc, addErr )
+import GHC.Tc.Utils.Monad ( newUnusedType, setSrcSpanA, liftZonkM, traceTc, addErr )
import GHC.Tc.Types.Evidence
import GHC.Tc.Errors.Types
import GHC.Tc.Zonk.Env
@@ -470,11 +471,11 @@ commitFlexi DefaultFlexi tv zonked_kind
; return manyDataConTy }
| Just (ConcreteFRR origin) <- isConcreteTyVar_maybe tv
= do { addErr $ TcRnZonkerMessage (ZonkerCannotDefaultConcrete origin)
- ; newZonkAnyType zonked_kind }
+ ; newUnusedType tv.varName zonked_kind }
| otherwise
- = do { traceTc "Defaulting flexi tyvar to ZonkAny:" (pprTyVar tv)
+ = do { traceTc "Defaulting flexi tyvar to UnusedType:" (pprTyVar tv)
-- See Note [Any types] in GHC.Builtin.Types, esp wrinkle (Any4)
- ; newZonkAnyType zonked_kind }
+ ; newUnusedType tv.varName zonked_kind }
zonkCoVarOcc :: CoVar -> ZonkTcM Coercion
zonkCoVarOcc cv
=====================================
libraries/ghc-internal/src/GHC/Internal/Types.hs
=====================================
@@ -35,6 +35,7 @@ module GHC.Internal.Types (
SPEC(..),
Symbol,
Any,
+ UnusedType,
-- * Type equality
type (~), type (~~), Coercible,
@@ -327,6 +328,17 @@ type family Any :: k where { }
-- that this can't reduce to a `data` type for the results discussed in
-- Note [Any types].
+-- | The type constructor 'UnusedType' is a type used by the compiler to fill in unused
+-- type variables after unification (more specifically the "zonking" step. It carries a
+-- number and a name to make pretty-printing possible. Under normal circumstances you
+-- should never see this type show up in compiler output if you don't explicitly ask for
+-- it by enabling debug output.
+-- 'UnusedType' is pretty-printed by the compiler to something that is more strongly resembling
+-- an unused type variable than a fixed type i.e. @'UnusedType' @k 3 "foo"@ is displayed as
+-- @foo3@ or @(foo3 :: k)@.
+type family UnusedType :: Nat -> Symbol -> k where { }
+-- See Note [Any types] in GHC.Builtin.Types, specifically (Any4) and (Any9).
+
{- *********************************************************************
* *
Lists
=====================================
testsuite/tests/perf/compiler/T11068.stdout
=====================================
@@ -23,137 +23,137 @@
`cast` (GHC.Internal.Generics.N:M1
`cast` (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.L1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
- ((GHC.Internal.Generics.U1 @(*) @(GHC.Internal.Types.ZonkAny 0))
+ ((GHC.Internal.Generics.U1
`cast` (Sym (GHC.Internal.Generics.N:M1
= GHC.Internal.Generics.R1
= GHC.Internal.Generics.R1
=====================================
testsuite/tests/pmcheck/should_compile/T12957.stderr
=====================================
@@ -1,7 +1,6 @@
T12957.hs:4:5: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
- In a case alternative:
- Patterns of type ‘[GHC.Internal.Types.ZonkAny 0]’ not matched: []
+ In a case alternative: Patterns of type ‘[a0]’ not matched: []
T12957.hs:4:16: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)]
Pattern match is redundant
=====================================
testsuite/tests/profiling/should_run/staticcallstack002.stdout
=====================================
@@ -1,4 +1,4 @@
-Just (InfoProv {ipName = "sat_s1Rh_info", ipDesc = THUNK, ipTyDesc = "ZonkAny 0", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "10:23-39"})
-Just (InfoProv {ipName = "sat_s1RB_info", ipDesc = THUNK, ipTyDesc = "ZonkAny 1", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "11:23-42"})
-Just (InfoProv {ipName = "sat_s1RV_info", ipDesc = THUNK, ipTyDesc = "ZonkAny 2", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "12:23-46"})
-Just (InfoProv {ipName = "sat_s1Sf_info", ipDesc = THUNK, ipTyDesc = "ZonkAny 3", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "13:23-44"})
+Just (InfoProv {ipName = "main_sat_t2fs_info", ipDesc = THUNK, ipTyDesc = "UnusedType 0 \"a\"", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "10:23-39"})
+Just (InfoProv {ipName = "main_sat_t2fJ_info", ipDesc = THUNK, ipTyDesc = "UnusedType 1 \"a\"", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "11:23-42"})
+Just (InfoProv {ipName = "main_sat_t2g0_info", ipDesc = THUNK, ipTyDesc = "UnusedType 2 \"a\"", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "12:23-46"})
+Just (InfoProv {ipName = "main_sat_t2gh_info", ipDesc = THUNK, ipTyDesc = "UnusedType 3 \"a\"", ipLabel = "main", ipUnitId = "main", ipMod = "Main", ipSrcFile = "staticcallstack002.hs", ipSrcSpan = "13:23-44"})
=====================================
testsuite/tests/simplCore/should_compile/Makefile
=====================================
@@ -188,7 +188,7 @@ T13155:
T13156:
$(RM) -f T13156.hi T13156.o
- '$(TEST_HC)' $(TEST_HC_OPTS) -c T13156.hs -O -ddump-prep -dsuppress-uniques | grep "case.*Any"
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c T13156.hs -O -ddump-prep -dsuppress-uniques | grep "case.*UnusedType"
# There should be a single 'case r @ GHC.Types.Any'
.PHONY: T4138
=====================================
testsuite/tests/simplCore/should_compile/T13156.stdout
=====================================
@@ -1,2 +1,2 @@
- case r @(GHC.Internal.Types.ZonkAny 0) of { __DEFAULT ->
- case r @(GHC.Internal.Types.ZonkAny 1) of { __DEFAULT -> r @a }
+ case r @(GHC.Internal.Types.UnusedType 0 "a") of { __DEFAULT ->
+ case r @(GHC.Internal.Types.UnusedType 1 "a") of { __DEFAULT ->
=====================================
testsuite/tests/simplCore/should_compile/T26615.stderr
=====================================
@@ -2,7 +2,7 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 1,209, types: 1,139, coercions: 18, joins: 17/29}
+ = {terms: 1,209, types: 1,155, coercions: 18, joins: 17/29}
-- RHS size: {terms: 6, types: 8, coercions: 0, joins: 0/0}
unArray :: forall a. Array a -> SmallArray# a
@@ -15,45 +15,29 @@ unArray :: forall a. Array a -> SmallArray# a
unArray = \ (@a) (ds :: Array a) -> case ds of { Array ds1 -> ds1 }
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$trModule4 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 20 0}]
-T26615a.$trModule4 = "main"#
+$trModule1 :: Addr#
+[GblId, Unf=OtherCon []]
+$trModule1 = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$trModule3 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$trModule3 = GHC.Internal.Types.TrNameS T26615a.$trModule4
+$trModule2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$trModule2 = GHC.Internal.Types.TrNameS $trModule1
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$trModule2 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$trModule2 = "T26615a"#
+$trModule3 :: Addr#
+[GblId, Unf=OtherCon []]
+$trModule3 = "T26615a"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$trModule1 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$trModule1 = GHC.Internal.Types.TrNameS T26615a.$trModule2
+$trModule4 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$trModule4 = GHC.Internal.Types.TrNameS $trModule3
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$trModule :: GHC.Internal.Types.Module
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$trModule
- = GHC.Internal.Types.Module T26615a.$trModule3 T26615a.$trModule1
+T26615a.$trModule [InlPrag=[~]] :: GHC.Internal.Types.Module
+[GblId, Unf=OtherCon []]
+T26615a.$trModule = GHC.Internal.Types.Module $trModule2 $trModule4
-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
$krep :: GHC.Internal.Types.KindRep
@@ -104,33 +88,24 @@ $krep6
GHC.Internal.Types.$tcSmallArray# $krep5
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcLeaf2 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 20 0}]
-T26615a.$tcLeaf2 = "Leaf"#
+$tcLeaf1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tcLeaf1 = "Leaf"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcLeaf1 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tcLeaf1 = GHC.Internal.Types.TrNameS T26615a.$tcLeaf2
+$tcLeaf2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tcLeaf2 = GHC.Internal.Types.TrNameS $tcLeaf1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcLeaf :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tcLeaf [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tcLeaf
= GHC.Internal.Types.TyCon
13798714324392902582#Word64
3237499036029031497#Word64
T26615a.$trModule
- T26615a.$tcLeaf1
+ $tcLeaf2
0#
GHC.Internal.Types.krep$*->*->*
@@ -160,372 +135,284 @@ $krep10 :: GHC.Internal.Types.KindRep
$krep10 = GHC.Internal.Types.KindRepFun $krep2 $krep9
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'L1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep
+$krep11 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'L1 = GHC.Internal.Types.KindRepFun $krep3 $krep10
+$krep11 = GHC.Internal.Types.KindRepFun $krep3 $krep10
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'L3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 20 0}]
-T26615a.$tc'L3 = "'L"#
+$tc'L1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'L1 = "'L"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'L2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'L2 = GHC.Internal.Types.TrNameS T26615a.$tc'L3
+$tc'L2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'L2 = GHC.Internal.Types.TrNameS $tc'L1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'L :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'L [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'L
= GHC.Internal.Types.TyCon
8570419491837374712#Word64
2090006989092642392#Word64
T26615a.$trModule
- T26615a.$tc'L2
+ $tc'L2
2#
- T26615a.$tc'L1
+ $krep11
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcArray2 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$tcArray2 = "Array"#
+$tcArray1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tcArray1 = "Array"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcArray1 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tcArray1 = GHC.Internal.Types.TrNameS T26615a.$tcArray2
+$tcArray2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tcArray2 = GHC.Internal.Types.TrNameS $tcArray1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcArray :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tcArray [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tcArray
= GHC.Internal.Types.TyCon
10495761415291712389#Word64
7580086293698619153#Word64
T26615a.$trModule
- T26615a.$tcArray1
+ $tcArray2
0#
GHC.Internal.Types.krep$*Arr*
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-$krep11 :: GHC.Internal.Types.KindRep
+$krep12 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-$krep11
+$krep12
= GHC.Internal.Types.KindRepTyConApp T26615a.$tcArray $krep4
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Array1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep
+$krep13 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'Array1 = GHC.Internal.Types.KindRepFun $krep6 $krep11
+$krep13 = GHC.Internal.Types.KindRepFun $krep6 $krep12
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Array3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$tc'Array3 = "'Array"#
+$tc'Array1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'Array1 = "'Array"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Array2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'Array2 = GHC.Internal.Types.TrNameS T26615a.$tc'Array3
+$tc'Array2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'Array2 = GHC.Internal.Types.TrNameS $tc'Array1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Array :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'Array [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'Array
= GHC.Internal.Types.TyCon
12424115309881832159#Word64
15542868641947707803#Word64
T26615a.$trModule
- T26615a.$tc'Array2
+ $tc'Array2
1#
- T26615a.$tc'Array1
+ $krep13
-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
-$krep12 :: [GHC.Internal.Types.KindRep]
+$krep14 :: [GHC.Internal.Types.KindRep]
[GblId, Unf=OtherCon []]
-$krep12
+$krep14
= GHC.Internal.Types.:
@GHC.Internal.Types.KindRep
$krep9
(GHC.Internal.Types.[] @GHC.Internal.Types.KindRep)
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-$krep13 :: GHC.Internal.Types.KindRep
+$krep15 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-$krep13
- = GHC.Internal.Types.KindRepTyConApp T26615a.$tcArray $krep12
+$krep15
+ = GHC.Internal.Types.KindRepTyConApp T26615a.$tcArray $krep14
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcHashMap2 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$tcHashMap2 = "HashMap"#
+$tcHashMap1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tcHashMap1 = "HashMap"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcHashMap1 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tcHashMap1
- = GHC.Internal.Types.TrNameS T26615a.$tcHashMap2
+$tcHashMap2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tcHashMap2 = GHC.Internal.Types.TrNameS $tcHashMap1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tcHashMap :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tcHashMap [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tcHashMap
= GHC.Internal.Types.TyCon
2021755758654901686#Word64
8209241086311595496#Word64
T26615a.$trModule
- T26615a.$tcHashMap1
+ $tcHashMap2
0#
GHC.Internal.Types.krep$*->*->*
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Empty1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep
+$krep16 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'Empty1
+$krep16
= GHC.Internal.Types.KindRepTyConApp T26615a.$tcHashMap $krep8
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Empty3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$tc'Empty3 = "'Empty"#
+$tc'Empty1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'Empty1 = "'Empty"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Empty2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'Empty2 = GHC.Internal.Types.TrNameS T26615a.$tc'Empty3
+$tc'Empty2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'Empty2 = GHC.Internal.Types.TrNameS $tc'Empty1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Empty :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'Empty [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'Empty
= GHC.Internal.Types.TyCon
2520556399233147460#Word64
17224648764450205443#Word64
T26615a.$trModule
- T26615a.$tc'Empty2
+ $tc'Empty2
2#
- T26615a.$tc'Empty1
+ $krep16
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-$krep14 :: GHC.Internal.Types.KindRep
+$krep17 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-$krep14 = GHC.Internal.Types.KindRepFun $krep9 T26615a.$tc'Empty1
+$krep17 = GHC.Internal.Types.KindRepFun $krep9 $krep16
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Leaf1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep
+$krep18 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'Leaf1 = GHC.Internal.Types.KindRepFun $krep1 $krep14
+$krep18 = GHC.Internal.Types.KindRepFun $krep1 $krep17
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Leaf3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$tc'Leaf3 = "'Leaf"#
+$tc'Leaf1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'Leaf1 = "'Leaf"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Leaf2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'Leaf2 = GHC.Internal.Types.TrNameS T26615a.$tc'Leaf3
+$tc'Leaf2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'Leaf2 = GHC.Internal.Types.TrNameS $tc'Leaf1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Leaf :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'Leaf [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'Leaf
= GHC.Internal.Types.TyCon
5773656560257991946#Word64
17028074687139582545#Word64
T26615a.$trModule
- T26615a.$tc'Leaf2
+ $tc'Leaf2
2#
- T26615a.$tc'Leaf1
+ $krep18
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-$krep15 :: GHC.Internal.Types.KindRep
+$krep19 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-$krep15 = GHC.Internal.Types.KindRepFun $krep13 T26615a.$tc'Empty1
+$krep19 = GHC.Internal.Types.KindRepFun $krep15 $krep16
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Collision1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep
+$krep20 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'Collision1
- = GHC.Internal.Types.KindRepFun $krep1 $krep15
+$krep20 = GHC.Internal.Types.KindRepFun $krep1 $krep19
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Collision3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 40 0}]
-T26615a.$tc'Collision3 = "'Collision"#
+$tc'Collision1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'Collision1 = "'Collision"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Collision2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'Collision2
- = GHC.Internal.Types.TrNameS T26615a.$tc'Collision3
+$tc'Collision2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'Collision2 = GHC.Internal.Types.TrNameS $tc'Collision1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Collision :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'Collision [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'Collision
= GHC.Internal.Types.TyCon
18175105753528304021#Word64
13986842878006680511#Word64
T26615a.$trModule
- T26615a.$tc'Collision2
+ $tc'Collision2
2#
- T26615a.$tc'Collision1
+ $krep20
-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
-$krep16 :: [GHC.Internal.Types.KindRep]
+$krep21 :: [GHC.Internal.Types.KindRep]
[GblId, Unf=OtherCon []]
-$krep16
+$krep21
= GHC.Internal.Types.:
@GHC.Internal.Types.KindRep
- T26615a.$tc'Empty1
+ $krep16
(GHC.Internal.Types.[] @GHC.Internal.Types.KindRep)
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-$krep17 :: GHC.Internal.Types.KindRep
+$krep22 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-$krep17
- = GHC.Internal.Types.KindRepTyConApp T26615a.$tcArray $krep16
+$krep22
+ = GHC.Internal.Types.KindRepTyConApp T26615a.$tcArray $krep21
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Full1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep
+$krep23 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'Full1
- = GHC.Internal.Types.KindRepFun $krep17 T26615a.$tc'Empty1
+$krep23 = GHC.Internal.Types.KindRepFun $krep22 $krep16
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Full3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615a.$tc'Full3 = "'Full"#
+$tc'Full1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'Full1 = "'Full"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Full2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'Full2 = GHC.Internal.Types.TrNameS T26615a.$tc'Full3
+$tc'Full2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'Full2 = GHC.Internal.Types.TrNameS $tc'Full1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'Full :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'Full [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'Full
= GHC.Internal.Types.TyCon
12008762105994325570#Word64
13514145886440831186#Word64
T26615a.$trModule
- T26615a.$tc'Full2
+ $tc'Full2
2#
- T26615a.$tc'Full1
+ $krep23
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'BitmapIndexed1 [InlPrag=[~]]
- :: GHC.Internal.Types.KindRep
+$krep24 :: GHC.Internal.Types.KindRep
[GblId, Unf=OtherCon []]
-T26615a.$tc'BitmapIndexed1
- = GHC.Internal.Types.KindRepFun $krep1 T26615a.$tc'Full1
+$krep24 = GHC.Internal.Types.KindRepFun $krep1 $krep23
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'BitmapIndexed3 :: Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 50 0}]
-T26615a.$tc'BitmapIndexed3 = "'BitmapIndexed"#
+$tc'BitmapIndexed1 :: Addr#
+[GblId, Unf=OtherCon []]
+$tc'BitmapIndexed1 = "'BitmapIndexed"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'BitmapIndexed2 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615a.$tc'BitmapIndexed2
- = GHC.Internal.Types.TrNameS T26615a.$tc'BitmapIndexed3
+$tc'BitmapIndexed2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$tc'BitmapIndexed2 = GHC.Internal.Types.TrNameS $tc'BitmapIndexed1
-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
-T26615a.$tc'BitmapIndexed :: GHC.Internal.Types.TyCon
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
+T26615a.$tc'BitmapIndexed [InlPrag=[~]] :: GHC.Internal.Types.TyCon
+[GblId, Unf=OtherCon []]
T26615a.$tc'BitmapIndexed
= GHC.Internal.Types.TyCon
15226751910432948177#Word64
957331387129868915#Word64
T26615a.$trModule
- T26615a.$tc'BitmapIndexed2
+ $tc'BitmapIndexed2
2#
- T26615a.$tc'BitmapIndexed1
+ $krep24
-- RHS size: {terms: 98, types: 109, coercions: 0, joins: 3/4}
T26615a.$wdisjointCollisions [InlPrag=INLINABLE[2]]
@@ -538,7 +425,7 @@ T26615a.$wdisjointCollisions [InlPrag=INLINABLE[2]]
Str=<LP(SC(S,C(1,L)),A)><L><1L><L><L>,
Unf=Unf{Src=StableUser, TopLvl=True,
Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [30 0 20 0 0] 406 10
+ Guidance=IF_ARGS [90 0 20 0 0] 406 10
Tmpl= \ (@k)
(@a)
(@b)
@@ -586,7 +473,7 @@ T26615a.$wdisjointCollisions [InlPrag=INLINABLE[2]]
Arity=5,
Str=<L><L><L><L><L>,
Unf=OtherCon []]
- lookupInArrayCont_ _ [Occ=Dead]
+ lookupInArrayCont_ ($dEq1 [Occ=Dead] :: Eq k)
(k1 [Occ=Once1] :: k)
(ary1 [Occ=Once1!] :: Array (Leaf k b))
(i1 [Occ=Once1!] :: Int)
@@ -654,24 +541,23 @@ T26615a.$wdisjointCollisions
$s$wfoldr_ [InlPrag=[2],
Occ=LoopBreaker,
Dmd=SC(S,C(1,C(1,C(1,L))))]
- :: Bool -> Int# -> Int# -> SmallArray# (Leaf k a) -> Bool
+ :: SmallArray# (Leaf k a) -> Int# -> Int# -> Bool -> Bool
[LclId[JoinId(4)(Nothing)],
Arity=4,
Str=<L><L><L><L>,
Unf=OtherCon []]
- $s$wfoldr_ (sc :: Bool)
+ $s$wfoldr_ (sc :: SmallArray# (Leaf k a))
(sc1 :: Int#)
(sc2 :: Int#)
- (sc3 :: SmallArray# (Leaf k a))
- = case >=# sc1 sc2 of {
+ (sc3 :: Bool)
+ = case >=# sc2 sc1 of {
__DEFAULT ->
- case indexSmallArray# @Lifted @(Leaf k a) sc3 sc1 of
- { (# ipv1 #) ->
+ case indexSmallArray# @Lifted @(Leaf k a) sc sc2 of { (# ipv1 #) ->
case ipv1 of { L kA ds1 ->
join {
$j :: Bool
[LclId[JoinId(0)(Nothing)]]
- $j = jump $s$wfoldr_ sc (+# sc1 1#) sc2 sc3 } in
+ $j = jump $s$wfoldr_ sc sc1 (+# sc2 1#) sc3 } in
joinrec {
$wlookupInArrayCont_ [InlPrag=[2],
Occ=LoopBreaker,
@@ -703,13 +589,13 @@ T26615a.$wdisjointCollisions
jump $wlookupInArrayCont_ kA ww2 0# lvl2
}
};
- 1# -> sc
+ 1# -> sc3
}; } in
jump $s$wfoldr_
- GHC.Internal.Types.True
- 0#
- (sizeofSmallArray# @Lifted @(Leaf k a) ipv)
ipv
+ (sizeofSmallArray# @Lifted @(Leaf k a) ipv)
+ 0#
+ GHC.Internal.Types.True
}
}
@@ -728,28 +614,28 @@ Rec {
-- RHS size: {terms: 133, types: 126, coercions: 0, joins: 1/2}
T26615a.disjointSubtrees_$s$wdisjointSubtrees [InlPrag=INLINABLE[2],
Occ=LoopBreaker]
- :: forall b a k.
- Word#
- -> SmallArray# (Leaf k a) -> Int# -> Eq k => HashMap k b -> Bool
+ :: forall k a b.
+ Eq k =>
+ Int# -> Word# -> SmallArray# (Leaf k a) -> HashMap k b -> Bool
[GblId[StrictWorker([~, ~, ~, ~, !])],
Arity=5,
- Str=<L><L><L><LP(SC(S,C(1,L)),A)><1L>,
+ Str=<LP(SC(S,C(1,L)),A)><L><L><L><1L>,
Unf=OtherCon []]
T26615a.disjointSubtrees_$s$wdisjointSubtrees
- = \ (@b)
+ = \ (@k)
(@a)
- (@k)
- (sc :: Word#)
- (sc1 :: SmallArray# (Leaf k a))
- (sc2 :: Int#)
- (sc3 :: Eq k)
+ (@b)
+ (sc :: Eq k)
+ (sc1 :: Int#)
+ (sc2 :: Word#)
+ (sc3 :: SmallArray# (Leaf k a))
(_b :: HashMap k b) ->
case _b of {
Empty -> GHC.Internal.Types.True;
Leaf bx ds ->
case ds of { L kB ds1 ->
case kB of k0 { __DEFAULT ->
- case eqWord# bx sc of {
+ case eqWord# bx sc2 of {
__DEFAULT -> GHC.Internal.Types.True;
1# ->
joinrec {
@@ -770,7 +656,7 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees
__DEFAULT ->
case indexSmallArray# @Lifted @(Leaf k a) ww ww1 of { (# ipv #) ->
case ipv of { L kx v ->
- case == @k sc3 k2 kx of {
+ case == @k sc k2 kx of {
False -> jump $wlookupInArrayCont_ k2 ww (+# ww1 1#) ww2;
True -> GHC.Internal.Types.False
}
@@ -780,19 +666,19 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees
}
}; } in
jump $wlookupInArrayCont_
- k0 sc1 0# (sizeofSmallArray# @Lifted @(Leaf k a) sc1)
+ k0 sc3 0# (sizeofSmallArray# @Lifted @(Leaf k a) sc3)
}
}
};
Collision bx bx1 ->
T26615a.$wdisjointCollisions
- @k @a @b sc3 sc (T26615a.Array @(Leaf k a) sc1) bx bx1;
+ @k @a @b sc sc2 (T26615a.Array @(Leaf k a) sc3) bx bx1;
BitmapIndexed bx bx1 ->
let {
m :: Word#
[LclId]
m = uncheckedShiftL#
- 1## (word2Int# (and# (uncheckedShiftRL# sc sc2) 31##)) } in
+ 1## (word2Int# (and# (uncheckedShiftRL# sc2 sc1) 31##)) } in
case and# m bx of {
__DEFAULT ->
case indexSmallArray#
@@ -803,7 +689,7 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees
of
{ (# ipv #) ->
T26615a.disjointSubtrees_$s$wdisjointSubtrees
- @b @a @k sc sc1 (+# sc2 5#) sc3 ipv
+ @k @a @b sc (+# sc1 5#) sc2 sc3 ipv
};
0## -> GHC.Internal.Types.True
};
@@ -812,17 +698,17 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees
@Lifted
@(HashMap k b)
bx
- (word2Int# (and# (uncheckedShiftRL# sc sc2) 31##))
+ (word2Int# (and# (uncheckedShiftRL# sc2 sc1) 31##))
of
{ (# ipv #) ->
T26615a.disjointSubtrees_$s$wdisjointSubtrees
- @b @a @k sc sc1 (+# sc2 5#) sc3 ipv
+ @k @a @b sc (+# sc1 5#) sc2 sc3 ipv
}
}
end Rec }
Rec {
--- RHS size: {terms: 705, types: 732, coercions: 18, joins: 13/23}
+-- RHS size: {terms: 705, types: 748, coercions: 18, joins: 13/23}
T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
:: forall k a b. Eq k => Int# -> HashMap k a -> HashMap k b -> Bool
[GblId[StrictWorker([~, ~, !])],
@@ -841,7 +727,7 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
join {
fail [Occ=Once3!T[1]] :: (# #) -> Bool
[LclId[JoinId(1)(Nothing)], Arity=1, Str=<L>, Unf=OtherCon []]
- fail _ [Occ=Dead, OS=OneShot]
+ fail (ds1 [Occ=Dead, OS=OneShot] :: (# #))
= case _b of wild [Occ=Once1] {
__DEFAULT ->
case GHC.Internal.Control.Exception.Base.patError
@@ -860,7 +746,7 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
Arity=5,
Str=<L><L><L><L><L>,
Unf=OtherCon []]
- lookupCont_ _ [Occ=Dead]
+ lookupCont_ ($dEq1 [Occ=Dead] :: Eq k)
(ds4 [Occ=Once1!] :: Word)
(ds5 [Occ=Once1] :: k)
(ds6 [Occ=Once1!] :: Int)
@@ -896,7 +782,7 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
Arity=5,
Str=<L><L><L><L><L>,
Unf=OtherCon []]
- lookupInArrayCont_ _ [Occ=Dead]
+ lookupInArrayCont_ ($dEq2 [Occ=Dead] :: Eq k)
(k1 [Occ=Once1] :: k)
(ary [Occ=Once1!] :: Array (Leaf k a))
(i [Occ=Once1!] :: Int)
@@ -1000,7 +886,7 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
Arity=5,
Str=<L><L><L><L><L>,
Unf=OtherCon []]
- lookupCont_ _ [Occ=Dead]
+ lookupCont_ ($dEq1 [Occ=Dead] :: Eq k)
(ds3 [Occ=Once1!] :: Word)
(ds4 [Occ=Once1] :: k)
(ds5 [Occ=Once1!] :: Int)
@@ -1034,7 +920,7 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
Arity=5,
Str=<L><L><L><L><L>,
Unf=OtherCon []]
- lookupInArrayCont_ _ [Occ=Dead]
+ lookupInArrayCont_ ($dEq2 [Occ=Dead] :: Eq k)
(k1 [Occ=Once1] :: k)
(ary [Occ=Once1!] :: Array (Leaf k b))
(i [Occ=Once1!] :: Int)
@@ -1179,23 +1065,23 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
@(*)
@(SmallArray# (HashMap k a)
-> SmallArray# (HashMap k b) -> Int#)
- @(GHC.Internal.Types.ZonkAny 0
- -> GHC.Internal.Types.ZonkAny 1 -> Int#)
+ @(GHC.Internal.Types.UnusedType 0 "a"
+ -> GHC.Internal.Types.UnusedType 1 "b" -> Int#)
of
{ GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 ->
case reallyUnsafePtrEquality#
@Lifted
@Lifted
- @(GHC.Internal.Types.ZonkAny 0)
- @(GHC.Internal.Types.ZonkAny 1)
+ @(GHC.Internal.Types.UnusedType 0 "a")
+ @(GHC.Internal.Types.UnusedType 1 "b")
(bx1
`cast` (SelCo:Fun(arg) (Sub (Sym v2))
:: SmallArray# (HashMap k a)
- ~R# GHC.Internal.Types.ZonkAny 0))
+ ~R# GHC.Internal.Types.UnusedType 0 "a"))
(bx3
`cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2)))
:: SmallArray# (HashMap k b)
- ~R# GHC.Internal.Types.ZonkAny 1))
+ ~R# GHC.Internal.Types.UnusedType 1 "b"))
of {
__DEFAULT ->
joinrec {
@@ -1324,51 +1210,49 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
}; } in
jump go (GHC.Internal.Types.W# (and# 4294967295## bx1));
Full bx1 ->
+ joinrec {
+ go [Occ=LoopBreakerT[1]] :: Int -> Bool
+ [LclId[JoinId(1)(Nothing)], Arity=1, Str=<L>, Unf=OtherCon []]
+ go (i :: Int)
+ = case GHC.Internal.Classes.ltInt i (GHC.Internal.Types.I# 0#) of {
+ False ->
+ case i of { I# i# ->
+ case indexSmallArray# @Lifted @(HashMap k a) bx i# of
+ { (# ipv [Occ=Once1] #) ->
+ case indexSmallArray# @Lifted @(HashMap k b) bx1 i# of
+ { (# ipv1 [Occ=Once1] #) ->
+ case T26615a.$wdisjointSubtrees @k @a @b $dEq (+# ww 5#) ipv ipv1
+ of {
+ False -> GHC.Internal.Types.False;
+ True -> jump go (GHC.Internal.Types.I# (-# i# 1#))
+ }
+ }
+ }
+ };
+ True -> GHC.Internal.Types.True
+ }; } in
case GHC.Internal.Unsafe.Coerce.unsafeEqualityProof
@(*)
@(SmallArray# (HashMap k a) -> SmallArray# (HashMap k b) -> Int#)
- @(GHC.Internal.Types.ZonkAny 0
- -> GHC.Internal.Types.ZonkAny 1 -> Int#)
+ @(GHC.Internal.Types.UnusedType 0 "a"
+ -> GHC.Internal.Types.UnusedType 1 "b" -> Int#)
of
{ GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 ->
case reallyUnsafePtrEquality#
@Lifted
@Lifted
- @(GHC.Internal.Types.ZonkAny 0)
- @(GHC.Internal.Types.ZonkAny 1)
+ @(GHC.Internal.Types.UnusedType 0 "a")
+ @(GHC.Internal.Types.UnusedType 1 "b")
(bx
`cast` (SelCo:Fun(arg) (Sub (Sym v2))
:: SmallArray# (HashMap k a)
- ~R# GHC.Internal.Types.ZonkAny 0))
+ ~R# GHC.Internal.Types.UnusedType 0 "a"))
(bx1
`cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2)))
:: SmallArray# (HashMap k b)
- ~R# GHC.Internal.Types.ZonkAny 1))
+ ~R# GHC.Internal.Types.UnusedType 1 "b"))
of {
- __DEFAULT ->
- joinrec {
- go [Occ=LoopBreakerT[1]] :: Int -> Bool
- [LclId[JoinId(1)(Nothing)], Arity=1, Str=<L>, Unf=OtherCon []]
- go (i :: Int)
- = case GHC.Internal.Classes.ltInt i (GHC.Internal.Types.I# 0#) of {
- False ->
- case i of { I# i# ->
- case indexSmallArray# @Lifted @(HashMap k a) bx i# of
- { (# ipv [Occ=Once1] #) ->
- case indexSmallArray# @Lifted @(HashMap k b) bx1 i# of
- { (# ipv1 [Occ=Once1] #) ->
- case T26615a.$wdisjointSubtrees
- @k @a @b $dEq (+# ww 5#) ipv ipv1
- of {
- False -> GHC.Internal.Types.False;
- True -> jump go (GHC.Internal.Types.I# (-# i# 1#))
- }
- }
- }
- };
- True -> GHC.Internal.Types.True
- }; } in
- jump go (GHC.Internal.Types.I# 31#);
+ __DEFAULT -> jump go (GHC.Internal.Types.I# 31#);
1# -> GHC.Internal.Types.False
}
}
@@ -1385,7 +1269,7 @@ T26615a.$wdisjointSubtrees
join {
fail [Dmd=MC(1,L)] :: (# #) -> Bool
[LclId[JoinId(1)(Nothing)], Arity=1, Str=<A>, Unf=OtherCon []]
- fail _ [Occ=Dead, OS=OneShot]
+ fail (ds1 [Occ=Dead, OS=OneShot] :: (# #))
= case _b of {
__DEFAULT -> case lvl1 of {};
Empty -> GHC.Internal.Types.True;
@@ -1508,7 +1392,7 @@ T26615a.$wdisjointSubtrees
};
Collision bx bx1 ->
T26615a.disjointSubtrees_$s$wdisjointSubtrees
- @a @b @k bx bx1 ww $dEq ds
+ @k @b @a $dEq ww bx bx1 ds
} } in
case ds of {
Empty -> GHC.Internal.Types.True;
@@ -1661,7 +1545,7 @@ T26615a.$wdisjointSubtrees
of
{ (# ipv #) ->
T26615a.disjointSubtrees_$s$wdisjointSubtrees
- @b @a @k bx bx1 (+# ww 5#) $dEq ipv
+ @k @a @b $dEq (+# ww 5#) bx bx1 ipv
};
0## -> GHC.Internal.Types.True
};
@@ -1674,7 +1558,7 @@ T26615a.$wdisjointSubtrees
of
{ (# ipv #) ->
T26615a.disjointSubtrees_$s$wdisjointSubtrees
- @b @a @k bx bx1 (+# ww 5#) $dEq ipv
+ @k @a @b $dEq (+# ww 5#) bx bx1 ipv
}
};
BitmapIndexed bx bx1 ->
@@ -1686,21 +1570,23 @@ T26615a.$wdisjointSubtrees
case GHC.Internal.Unsafe.Coerce.unsafeEqualityProof
@(*)
@(SmallArray# (HashMap k a) -> SmallArray# (HashMap k b) -> Int#)
- @(GHC.Internal.Types.ZonkAny 0
- -> GHC.Internal.Types.ZonkAny 1 -> Int#)
+ @(GHC.Internal.Types.UnusedType 0 "a"
+ -> GHC.Internal.Types.UnusedType 1 "b" -> Int#)
of
{ GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 ->
case reallyUnsafePtrEquality#
@Lifted
@Lifted
- @(GHC.Internal.Types.ZonkAny 0)
- @(GHC.Internal.Types.ZonkAny 1)
+ @(GHC.Internal.Types.UnusedType 0 "a")
+ @(GHC.Internal.Types.UnusedType 1 "b")
(bx1
`cast` (SelCo:Fun(arg) (Sub (Sym v2))
- :: SmallArray# (HashMap k a) ~R# GHC.Internal.Types.ZonkAny 0))
+ :: SmallArray# (HashMap k a)
+ ~R# GHC.Internal.Types.UnusedType 0 "a"))
(bx3
`cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2)))
- :: SmallArray# (HashMap k b) ~R# GHC.Internal.Types.ZonkAny 1))
+ :: SmallArray# (HashMap k b)
+ ~R# GHC.Internal.Types.UnusedType 1 "b"))
of {
__DEFAULT ->
let {
@@ -1829,21 +1715,23 @@ T26615a.$wdisjointSubtrees
case GHC.Internal.Unsafe.Coerce.unsafeEqualityProof
@(*)
@(SmallArray# (HashMap k a) -> SmallArray# (HashMap k b) -> Int#)
- @(GHC.Internal.Types.ZonkAny 0
- -> GHC.Internal.Types.ZonkAny 1 -> Int#)
+ @(GHC.Internal.Types.UnusedType 0 "a"
+ -> GHC.Internal.Types.UnusedType 1 "b" -> Int#)
of
{ GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 ->
case reallyUnsafePtrEquality#
@Lifted
@Lifted
- @(GHC.Internal.Types.ZonkAny 0)
- @(GHC.Internal.Types.ZonkAny 1)
+ @(GHC.Internal.Types.UnusedType 0 "a")
+ @(GHC.Internal.Types.UnusedType 1 "b")
(bx
`cast` (SelCo:Fun(arg) (Sub (Sym v2))
- :: SmallArray# (HashMap k a) ~R# GHC.Internal.Types.ZonkAny 0))
+ :: SmallArray# (HashMap k a)
+ ~R# GHC.Internal.Types.UnusedType 0 "a"))
(bx1
`cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2)))
- :: SmallArray# (HashMap k b) ~R# GHC.Internal.Types.ZonkAny 1))
+ :: SmallArray# (HashMap k b)
+ ~R# GHC.Internal.Types.UnusedType 1 "b"))
of {
__DEFAULT ->
let {
@@ -1910,88 +1798,72 @@ disjointSubtrees
------ Local rules for imported ids --------
"SC:$wdisjointSubtrees1" [1]
- forall (@a)
+ forall (@k)
(@b)
- (@k)
- (sc :: Word#)
- (sc1 :: SmallArray# (Leaf k a))
+ (@a)
+ (sc :: Eq k)
+ (sc1 :: Int#)
(sc2 :: Word#)
(sc3 :: SmallArray# (Leaf k b))
- (sc4 :: Int#)
- (sc5 :: Eq k).
+ (sc4 :: Word#)
+ (sc5 :: SmallArray# (Leaf k a)).
T26615a.$wdisjointSubtrees @k
@b
@a
- sc5
- sc4
+ sc
+ sc1
(T26615a.Collision @k @b sc2 sc3)
- (T26615a.Collision @k @a sc sc1)
+ (T26615a.Collision @k @a sc4 sc5)
= T26615a.$wdisjointCollisions
- @k @b @a sc5 sc2 (T26615a.Array @(Leaf k b) sc3) sc sc1
+ @k @b @a sc sc2 (T26615a.Array @(Leaf k b) sc3) sc4 sc5
"SC:$wdisjointSubtrees0" [1]
- forall (@b)
+ forall (@k)
(@a)
- (@k)
- (sc :: Word#)
- (sc1 :: SmallArray# (Leaf k a))
- (sc2 :: Int#)
- (sc3 :: Eq k).
+ (@b)
+ (sc :: Eq k)
+ (sc1 :: Int#)
+ (sc2 :: Word#)
+ (sc3 :: SmallArray# (Leaf k a)).
T26615a.$wdisjointSubtrees @k
@a
@b
- sc3
- sc2
- (T26615a.Collision @k @a sc sc1)
+ sc
+ sc1
+ (T26615a.Collision @k @a sc2 sc3)
= T26615a.disjointSubtrees_$s$wdisjointSubtrees
- @b @a @k sc sc1 sc2 sc3
+ @k @a @b sc sc1 sc2 sc3
[2 of 2] Compiling T26615 ( T26615.hs, T26615.o )
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 614, types: 666, coercions: 18, joins: 8/14}
+ = {terms: 614, types: 682, coercions: 18, joins: 8/14}
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615.$trModule2 :: GHC.Internal.Prim.Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 30 0}]
-T26615.$trModule2 = "T26615"#
+$trModule1 :: GHC.Internal.Prim.Addr#
+[GblId, Unf=OtherCon []]
+$trModule1 = "T26615"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615.$trModule1 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615.$trModule1 = GHC.Internal.Types.TrNameS T26615.$trModule2
+$trModule2 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$trModule2 = GHC.Internal.Types.TrNameS $trModule1
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T26615.$trModule4 :: GHC.Internal.Prim.Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 20 0}]
-T26615.$trModule4 = "main"#
+$trModule3 :: GHC.Internal.Prim.Addr#
+[GblId, Unf=OtherCon []]
+$trModule3 = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T26615.$trModule3 :: GHC.Internal.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615.$trModule3 = GHC.Internal.Types.TrNameS T26615.$trModule4
+$trModule4 :: GHC.Internal.Types.TrName
+[GblId, Unf=OtherCon []]
+$trModule4 = GHC.Internal.Types.TrNameS $trModule3
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T26615.$trModule :: GHC.Internal.Types.Module
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [] 10 10}]
-T26615.$trModule
- = GHC.Internal.Types.Module T26615.$trModule3 T26615.$trModule1
+T26615.$trModule [InlPrag=[~]] :: GHC.Internal.Types.Module
+[GblId, Unf=OtherCon []]
+T26615.$trModule = GHC.Internal.Types.Module $trModule4 $trModule2
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
lvl :: GHC.Internal.Prim.Addr#
@@ -2128,7 +2000,7 @@ $wpoly_lookupCont_
end Rec }
Rec {
--- RHS size: {terms: 448, types: 507, coercions: 18, joins: 8/13}
+-- RHS size: {terms: 448, types: 523, coercions: 18, joins: 8/13}
T26615.$s$wdisjointSubtrees [InlPrag=[~], Occ=LoopBreaker]
:: forall a b.
GHC.Internal.Prim.Int#
@@ -2143,7 +2015,7 @@ T26615.$s$wdisjointSubtrees
join {
fail [Dmd=MC(1,L)] :: (# #) -> Bool
[LclId[JoinId(1)(Nothing)], Arity=1, Str=<A>, Unf=OtherCon []]
- fail _ [Occ=Dead, OS=OneShot]
+ fail (ds1 [Occ=Dead, OS=OneShot] :: (# #))
= case _b of wild {
__DEFAULT -> case lvl1 of {};
T26615a.Empty -> GHC.Internal.Types.True;
@@ -2190,30 +2062,28 @@ T26615.$s$wdisjointSubtrees
$s$wfoldr_ [InlPrag=[2],
Occ=LoopBreaker,
Dmd=SC(S,C(1,C(1,C(1,L))))]
- :: Bool
- -> GHC.Internal.Prim.Int#
- -> GHC.Internal.Prim.Int#
- -> GHC.Internal.Prim.SmallArray# (T26615a.Leaf [Char] a)
- -> Bool
+ :: GHC.Internal.Prim.SmallArray# (T26615a.Leaf [Char] a)
+ -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> Bool -> Bool
[LclId[JoinId(4)(Nothing)],
Arity=4,
Str=<L><L><L><L>,
Unf=OtherCon []]
- $s$wfoldr_ (sc :: Bool)
+ $s$wfoldr_ (sc
+ :: GHC.Internal.Prim.SmallArray# (T26615a.Leaf [Char] a))
(sc1 :: GHC.Internal.Prim.Int#)
(sc2 :: GHC.Internal.Prim.Int#)
- (sc3 :: GHC.Internal.Prim.SmallArray# (T26615a.Leaf [Char] a))
- = case GHC.Internal.Prim.>=# sc1 sc2 of {
+ (sc3 :: Bool)
+ = case GHC.Internal.Prim.>=# sc2 sc1 of {
__DEFAULT ->
case GHC.Internal.Prim.indexSmallArray#
- @GHC.Internal.Types.Lifted @(T26615a.Leaf String a) sc3 sc1
+ @GHC.Internal.Types.Lifted @(T26615a.Leaf String a) sc sc2
of
{ (# ipv1 #) ->
case ipv1 of { T26615a.L kA ds2 ->
join {
$j :: Bool
[LclId[JoinId(0)(Nothing)]]
- $j = jump $s$wfoldr_ sc (GHC.Internal.Prim.+# sc1 1#) sc2 sc3 } in
+ $j = jump $s$wfoldr_ sc sc1 (GHC.Internal.Prim.+# sc2 1#) sc3 } in
joinrec {
$wlookupInArrayCont_ [InlPrag=[2],
Occ=LoopBreaker,
@@ -2258,14 +2128,14 @@ T26615.$s$wdisjointSubtrees
jump $wlookupInArrayCont_ kA bx3 0# lvl2
}
};
- 1# -> sc
+ 1# -> sc3
}; } in
jump $s$wfoldr_
- GHC.Internal.Types.True
- 0#
+ bx1
(GHC.Internal.Prim.sizeofSmallArray#
@GHC.Internal.Types.Lifted @(T26615a.Leaf String a) bx1)
- bx1
+ 0#
+ GHC.Internal.Types.True
};
T26615a.BitmapIndexed bx2 bx3 ->
let {
@@ -2317,23 +2187,23 @@ T26615.$s$wdisjointSubtrees
@(GHC.Internal.Prim.SmallArray# (HashMap String a)
-> GHC.Internal.Prim.SmallArray# (HashMap String b)
-> GHC.Internal.Prim.Int#)
- @(GHC.Internal.Types.ZonkAny 0
- -> GHC.Internal.Types.ZonkAny 1 -> GHC.Internal.Prim.Int#)
+ @(GHC.Internal.Types.UnusedType 0 "a"
+ -> GHC.Internal.Types.UnusedType 1 "b" -> GHC.Internal.Prim.Int#)
of
{ GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 ->
case GHC.Internal.Prim.reallyUnsafePtrEquality#
@GHC.Internal.Types.Lifted
@GHC.Internal.Types.Lifted
- @(GHC.Internal.Types.ZonkAny 0)
- @(GHC.Internal.Types.ZonkAny 1)
+ @(GHC.Internal.Types.UnusedType 0 "a")
+ @(GHC.Internal.Types.UnusedType 1 "b")
(bx1
`cast` (SelCo:Fun(arg) (Sub (Sym v2))
:: GHC.Internal.Prim.SmallArray# (HashMap String a)
- ~R# GHC.Internal.Types.ZonkAny 0))
+ ~R# GHC.Internal.Types.UnusedType 0 "a"))
(bx3
`cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2)))
:: GHC.Internal.Prim.SmallArray# (HashMap String b)
- ~R# GHC.Internal.Types.ZonkAny 1))
+ ~R# GHC.Internal.Types.UnusedType 1 "b"))
of {
__DEFAULT ->
joinrec {
@@ -2495,23 +2365,23 @@ T26615.$s$wdisjointSubtrees
@(GHC.Internal.Prim.SmallArray# (HashMap String a)
-> GHC.Internal.Prim.SmallArray# (HashMap String b)
-> GHC.Internal.Prim.Int#)
- @(GHC.Internal.Types.ZonkAny 0
- -> GHC.Internal.Types.ZonkAny 1 -> GHC.Internal.Prim.Int#)
+ @(GHC.Internal.Types.UnusedType 0 "a"
+ -> GHC.Internal.Types.UnusedType 1 "b" -> GHC.Internal.Prim.Int#)
of
{ GHC.Internal.Unsafe.Coerce.UnsafeRefl v2 ->
case GHC.Internal.Prim.reallyUnsafePtrEquality#
@GHC.Internal.Types.Lifted
@GHC.Internal.Types.Lifted
- @(GHC.Internal.Types.ZonkAny 0)
- @(GHC.Internal.Types.ZonkAny 1)
+ @(GHC.Internal.Types.UnusedType 0 "a")
+ @(GHC.Internal.Types.UnusedType 1 "b")
(bx
`cast` (SelCo:Fun(arg) (Sub (Sym v2))
:: GHC.Internal.Prim.SmallArray# (HashMap String a)
- ~R# GHC.Internal.Types.ZonkAny 0))
+ ~R# GHC.Internal.Types.UnusedType 0 "a"))
(bx1
`cast` (SelCo:Fun(arg) (SelCo:Fun(res) (Sub (Sym v2)))
:: GHC.Internal.Prim.SmallArray# (HashMap String b)
- ~R# GHC.Internal.Types.ZonkAny 1))
+ ~R# GHC.Internal.Types.UnusedType 1 "b"))
of {
__DEFAULT ->
joinrec {
@@ -2564,7 +2434,7 @@ f = \ (@a)
------ Local rules for imported ids --------
"SPEC/T26615 $wdisjointSubtrees @String @_ @_" [2]
- forall (@a) (@b) ($dEq :: Eq String).
+ forall (@a) (@b) ($dEq [Occ=Dead] :: Eq String).
T26615a.$wdisjointSubtrees @String @a @b $dEq
= T26615.$s$wdisjointSubtrees @a @b
=====================================
testsuite/tests/typecheck/should_fail/T13292.stderr
=====================================
@@ -14,15 +14,15 @@ T13292a.hs:4:12: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)]
In an equation for ‘someFunc’: someFunc = return ()
T13292.hs:6:1: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
- • Couldn't match type ‘GHC.Internal.Types.ZonkAny 0’ with ‘IO’
+ • Couldn't match type ‘m00’ with ‘IO’
Expected: IO ()
- Actual: GHC.Internal.Types.ZonkAny 0 ()
+ Actual: m00
• When checking the type of the IO action ‘main’
T13292.hs:6:1: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
- • Couldn't match type ‘GHC.Internal.Types.ZonkAny 0’ with ‘IO’
+ • Couldn't match type ‘m00’ with ‘IO’
Expected: IO ()
- Actual: GHC.Internal.Types.ZonkAny 0 ()
+ Actual: m00
• In the expression: main
When checking the type of the IO action ‘main’
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/65b92958a2e33121bce0482b6ff62f3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/65b92958a2e33121bce0482b6ff62f3…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/fix-prof-segv] Add test and changelog for #27123 fix.
by Andreas Klebinger (＠AndreasK) 19 Jun '26
by Andreas Klebinger (＠AndreasK) 19 Jun '26
19 Jun '26
Andreas Klebinger pushed to branch wip/andreask/fix-prof-segv at Glasgow Haskell Compiler / GHC
Commits:
eca76105 by Andreas Klebinger at 2026-06-19T09:11:46+00:00
Add test and changelog for #27123 fix.
- - - - -
3 changed files:
- + changelog.d/T27123.md
- + testsuite/tests/rts/T27123.hs
- testsuite/tests/rts/all.T
Changes:
=====================================
changelog.d/T27123.md
=====================================
@@ -0,0 +1,7 @@
+section: compiler
+synopsis: Fix two crashes that could happen in a multithreaded setting when profiling.
+description: There where two bugs that could cause occasional segfaults or crashes with
+an `PAP object entered` error when profiling. They only happened when two threads
+where racing to evaluate the same thunk, and specific GC timings.
+mrs: !16214
+issues: #27123
=====================================
testsuite/tests/rts/T27123.hs
=====================================
@@ -0,0 +1,65 @@
+{-# OPTIONS_GHC -fno-full-laziness -fno-worker-wrapper #-}
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+-- This test checks that the auto-apply code (stg_ap_0_fast, stg_ap_p) is robust
+-- against another thread or the GC evaluating a closure at the same time.
+
+module Main
+ -- (main)
+where
+
+import Control.Monad
+import Control.Concurrent
+import System.IO
+import GHC.Data.SmallArray
+import GHC.Exts
+import GHC.IO
+
+type Arr = SmallMutableArray RealWorld (Int->Int)
+
+io :: (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
+io f = IO f
+
+io_ :: (State# RealWorld -> State# RealWorld ) -> IO ()
+io_ f = IO (\s -> case f s of s2 -> (# s2, () #))
+
+{-# NOINLINE readSmallArray #-}
+readSmallArray (SmallMutableArray arr) (I# idx) = IO $ \s -> case readSmallArray# arr idx s of
+ (# s2, r #) -> (# s2, r #)
+
+-- Continually overwrites the array with unevaluated thunks that will evaluated to
+-- a PAP under profiling.
+{-# NOINLINE mkThunks #-}
+mkThunks :: Arr -> IO ()
+mkThunks arr = do
+ forever $ do
+ yield
+ forM_ [0..100] $ \_j -> do
+ forM_ [0..5 :: Int] $ \i -> do
+ -- With profiling results in a thunk that will evaluate to a PAP capturing the SCC
+ let g = {-# SCC g #-} succ
+ io_ (writeSmallArray arr i g)
+
+-- Evaluate the array repeatedly in the given order.
+{-# NOINLINE evaluateThunks #-}
+evaluateThunks :: Arr -> [Int] -> IO ()
+evaluateThunks arr idxs = do
+ forever $ do
+ yield
+ -- putStr "." >> hFlush stdout
+ forM [0..5000::Int] $ \j -> do
+ forM_ idxs $ \i -> do
+ !g <- readSmallArray arr i
+ seq (g i) (pure ())
+
+main :: IO ()
+main = do
+ -- We spawn three threads. Two are evaluating the thunks in the array in opposite directions
+ -- One thread is
+ arr <- io (newSmallArray 6 (id))
+ _ <- forkIO $ do
+ evaluateThunks arr [0..5]
+ _ <- forkIO $ do
+ evaluateThunks arr [5,4..0]
+ forkIO $ mkThunks arr
+ threadDelay 30_000_000
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -687,3 +687,5 @@ test('ClosureTable',
['-debug -O0 ClosureTable_c.c -I{top}/../rts -I{top}/../rts/include'])
test('resizeMutableByteArrayInPlace', [req_cmm, extra_ways(['optasm', 'sanity']), only_ways(['optasm', 'sanity'])], compile_and_run, [''])
+
+test('T27123', [extra_ways(['optasm']), when(have_profiling(), extra_ways['prof'])], compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eca761054db8f82d1b280bf40e54d7f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eca761054db8f82d1b280bf40e54d7f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Teo Camarasu pushed to branch wip/abstract-q at Glasgow Haskell Compiler / GHC
Commits:
60315570 by Teo Camarasu at 2026-06-19T10:01:07+01:00
Make Q abstract
This patch aims to clearly demarcate the internal and external interfaces
of Q.
In the past the `Quasi` typeclass was both part of the external,
public-facing interface, and was used to give the implementation of `Q`.
Now we separate out these two distinct roles. `Quasi` continues to exist
in the public interface, but we introduce a new `MetaHandlers` type,
which is equivalent to `Dict Quasi`.
`Q a` is now defined to be `MetaHandlers -> IO a`, and, crucially,
the constructor and the new `MetaHandlers` type are not exposed from the
public interface.
This gives us the ability to vary the interface on the GHC side without
forcing a breaking change on the `template-haskell` side.
Similarly `template-haskell` has more freedom to change the `Quasi`
typeclass without needing any changes in `lib:ghc`.
Implements https://github.com/ghc-proposals/ghc-proposals/pull/700
Resolves #27341
- - - - -
9 changed files:
- + changelog.d/AbstractQ
- compiler/GHC/Data/IOEnv.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Gen/Splice.hs-boot
- libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
- libraries/ghci/GHCi/TH.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- testsuite/tests/interface-stability/template-haskell-exports.stdout
Changes:
=====================================
changelog.d/AbstractQ
=====================================
@@ -0,0 +1,9 @@
+section: template-haskell
+synopsis: Hide the implementation of Q
+description: The constructor of Q is now hidden.
+ This is done to improve the stability of ``template-haskell``.
+ To minimize breakage, we have added a new ``qRunQ`` operation to ``Quasi``.
+ The ``Quasi TcM`` instance is no longer exposed from the ``ghc`` API.
+ See the `GHC proposal <https://github.com/ghc-proposals/ghc-proposals/pull/700>`_ for more details.
+mrs: !15696
+issues: #27341
=====================================
compiler/GHC/Data/IOEnv.hs
=====================================
@@ -22,7 +22,7 @@ module GHC.Data.IOEnv (
IOEnvFailure(..),
-- Getting at the environment
- getEnv, setEnv, updEnv, updEnvIO,
+ getEnv, setEnv, updEnv, updEnvIO, withRunInIO,
runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_,
tryM, tryAllM, tryMostM, fixM,
@@ -258,3 +258,12 @@ updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env))
updEnvIO :: (env -> IO env') -> IOEnv env' a -> IOEnv env a
{-# INLINE updEnvIO #-}
updEnvIO upd (IOEnv m) = IOEnv (\ env -> m =<< upd env)
+
+-- | 'withRunInIO' specialised to `IOEnv`.
+-- See https://hackage.haskell.org/package/unliftio-core/docs/Control-Monad-IO-Unl… for an explanation.
+withRunInIO:: forall env b. ((forall a. IOEnv env a -> IO a) -> IO b) -> IOEnv env b
+withRunInIO k = IOEnv $ \env ->
+ let
+ unlift :: forall a. IOEnv env a -> IO a
+ unlift (IOEnv m) = m env
+ in k unlift
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -25,7 +25,7 @@ module GHC.Tc.Gen.Splice(
tcTypedSplice, tcTypedBracket, tcUntypedBracket,
runAnnotation, getUntypedSpliceBody,
- runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,
+ runMetaE, runMetaP, runMetaT, runMetaD, runQinTcM,
tcTopSpliceExpr, lookupThName_maybe,
defaultRunMeta, runMeta', runRemoteModFinalizers,
finishTH, runTopSplice
@@ -138,6 +138,7 @@ import qualified GHC.LanguageExtensions as LangExt
-- THSyntax gives access to internal functions and data types
import qualified GHC.Boot.TH.Syntax as TH
import qualified GHC.Boot.TH.Monad as TH
+import GHC.Boot.TH.Monad (MetaHandlers(..))
import qualified GHC.Boot.TH.Ppr as TH
#if defined(HAVE_INTERNAL_INTERPRETER)
@@ -1138,8 +1139,8 @@ convertAnnotationWrapper fhv = do
************************************************************************
-}
-runQuasi :: TH.Q a -> TcM a
-runQuasi act = TH.runQ act
+runQinTcM :: TH.Q a -> TcM a
+runQinTcM (TH.Q act) = withRunInIO $ \runInIO -> act (metaHandlersTcM runInIO)
runRemoteModFinalizers :: ThModFinalizers -> TcM ()
runRemoteModFinalizers (ThModFinalizers finRefs) = do
@@ -1152,7 +1153,7 @@ runRemoteModFinalizers (ThModFinalizers finRefs) = do
#if defined(HAVE_INTERNAL_INTERPRETER)
InternalInterp -> do
qs <- liftIO (withForeignRefs finRefs $ mapM localRef)
- runQuasi $ sequence_ qs
+ runQinTcM $ sequence_ qs
#endif
ExternalInterp ext -> withExtInterp ext $ \inst -> do
@@ -1466,70 +1467,14 @@ when showing an error message.
To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
-}
-instance TH.Quasi TcM where
- qNewName s = do { u <- newUnique
- ; let i = toInteger (getKey u)
- ; return (TH.mkNameU s i) }
+-- 'msg' is forced to ensure exceptions don't escape,
+-- see Note [Exceptions in TH]
+report :: Bool -> [Char] -> TcM ()
+report True msg = seqList msg $ addErr $ TcRnTHError $ ReportCustomQuasiError True msg
+report False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg
- -- 'msg' is forced to ensure exceptions don't escape,
- -- see Note [Exceptions in TH]
- qReport True msg = seqList msg $ addErr $ TcRnTHError $ ReportCustomQuasiError True msg
- qReport False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg
-
- qLocation :: TcM TH.Loc
- qLocation = do { m <- getModule
- ; l <- getSrcSpanM
- ; r <- case l of
- RealSrcSpan s _ -> return s
- GeneratedSrcSpan{} -> pprPanic "qLocation: generatedSrcSpan"
- (pprGeneratedSrcSpanDetails)
- UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
- (ppr l)
- ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
- , TH.loc_module = moduleNameString (moduleName m)
- , TH.loc_package = unitString (moduleUnit m)
- , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
- , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
-
- qLookupName = lookupName
- qReify = reify
- qReifyFixity nm = lookupThName nm >>= reifyFixity
- qReifyType = reifyTypeOfThing
- qReifyInstances = reifyInstances
- qReifyRoles = reifyRoles
- qReifyAnnotations = reifyAnnotations
- qReifyModule = reifyModule
- qReifyConStrictness nm = do { nm' <- lookupThName nm
- ; dc <- tcLookupDataCon nm'
- ; let bangs = dataConImplBangs dc
- ; return (map reifyDecidedStrictness bangs) }
-
- -- For qRecover, discard error messages if
- -- the recovery action is chosen. Otherwise
- -- we'll only fail higher up.
- qRecover recover main = tryTcDiscardingErrs recover main
-
- qGetPackageRoot = do
- dflags <- getDynFlags
- return $ fromMaybe "." (workingDirectory dflags)
-
- qAddDependentFile fp = do
- ref <- fmap tcg_dependent_files getGblEnv
- dep_files <- readTcRef ref
- writeTcRef ref (fp:dep_files)
-
- qAddDependentDirectory dp = do
- ref <- fmap tcg_dependent_dirs getGblEnv
- dep_dirs <- readTcRef ref
- writeTcRef ref (dp:dep_dirs)
-
- qAddTempFile suffix = do
- dflags <- getDynFlags
- logger <- getLogger
- tmpfs <- hsc_tmpfs <$> getTopEnv
- liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix
-
- qAddTopDecls thds = do
+addTopDecls :: [TH.Dec] -> TcM ()
+addTopDecls thds = do
exts <- fmap extensionFlags getDynFlags
l <- getSrcSpanM
th_origin <- getThSpliceOrigin
@@ -1557,52 +1502,13 @@ instance TH.Quasi TcM where
bindName :: RdrName -> TcM ()
bindName (Exact n)
= do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
- ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)
- }
+ ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)
+ }
bindName name = addErr $ TcRnTHError $ THNameError $ NonExactName name
- qAddForeignFilePath lang fp = do
- var <- fmap tcg_th_foreign_files getGblEnv
- updTcRef var ((lang, fp) :)
-
- qAddModFinalizer fin = do
- r <- liftIO $ mkRemoteRef fin
- fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
- addModFinalizerRef fref
-
- qAddCorePlugin plugin = do
- hsc_env <- getTopEnv
- let fc = hsc_FC hsc_env
- let home_unit = hsc_home_unit hsc_env
- let dflags = hsc_dflags hsc_env
- let fopts = initFinderOpts dflags
- r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin)
- let err = TcRnTHError $ AddInvalidCorePlugin plugin
- case r of
- Found {} -> addErr err
- FoundMultiple {} -> addErr err
- _ -> return ()
- th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
- updTcRef th_coreplugins_var (plugin:)
-
- qGetQ :: forall a. Typeable a => TcM (Maybe a)
- qGetQ = do
- th_state_var <- fmap tcg_th_state getGblEnv
- th_state <- readTcRef th_state_var
- -- See #10596 for why we use a scoped type variable here.
- return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic)
-
- qPutQ x = do
- th_state_var <- fmap tcg_th_state getGblEnv
- updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
-
- qIsExtEnabled = xoptM
-
- qExtsEnabled =
- EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
-
- qPutDoc doc_loc s = do
+putDoc :: TH.DocLoc -> String -> TcM ()
+putDoc doc_loc s = do
th_doc_var <- tcg_th_docs <$> getGblEnv
resolved_doc_loc <- resolve_loc doc_loc
is_local <- checkLocalName resolved_doc_loc
@@ -1624,15 +1530,131 @@ instance TH.Quasi TcM where
checkLocalName (InstDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n
checkLocalName ModuleDoc = pure True
-
- qGetDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc
- qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc
- qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i
- qGetDoc TH.ModuleDoc = do
+getDoc :: TH.DocLoc -> TcM (Maybe String)
+getDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc
+getDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc
+getDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i
+getDoc TH.ModuleDoc = do
df <- getDynFlags
docs <- getGblEnv >>= extractDocs df
return (renderHsDocString . hsDocString <$> (docs_mod_hdr =<< docs))
+getQ :: forall a. Typeable a => TcM (Maybe a)
+getQ = do
+ th_state_var <- fmap tcg_th_state getGblEnv
+ th_state <- readTcRef th_state_var
+ -- See #10596 for why we use a scoped type variable here.
+ return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic)
+
+location :: TcM TH.Loc
+location = do { m <- getModule
+ ; l <- getSrcSpanM
+ ; r <- case l of
+ RealSrcSpan s _ -> return s
+ GeneratedSrcSpan{} -> pprPanic "qLocation: generatedSrcSpan"
+ (pprGeneratedSrcSpanDetails)
+ UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
+ (ppr l)
+ ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
+ , TH.loc_module = moduleNameString (moduleName m)
+ , TH.loc_package = unitString (moduleUnit m)
+ , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
+ , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
+
+metaHandlersTcM :: (forall x. TcM x -> IO x) -> TH.MetaHandlers
+metaHandlersTcM runInIO = TH.MetaHandlers {
+ mLiftIO = id
+ -- We are careful to use the TcM instance not the one for IO, since that would lead to a different error.
+ , mFail = \s -> runInIO $ fail @TcM s
+ , mNewName = \s -> runInIO $ do { u <- newUnique
+ ; let i = toInteger (getKey u)
+ ; return (TH.mkNameU s i) }
+
+ , mReport = fmap runInIO . report
+
+ , mLocation = runInIO location
+
+ , mLookupName = fmap runInIO . lookupName
+ , mReify = runInIO . reify
+ , mReifyFixity = \nm -> runInIO $ lookupThName nm >>= reifyFixity
+ , mReifyType = runInIO . reifyTypeOfThing
+ , mReifyInstances = fmap runInIO . reifyInstances
+ , mReifyRoles = runInIO . reifyRoles
+ , mReifyAnnotations = runInIO . reifyAnnotations
+ , mReifyModule = runInIO . reifyModule
+ , mReifyConStrictness = \nm -> runInIO $ do
+ { nm' <- lookupThName nm
+ ; dc <- tcLookupDataCon nm'
+ ; let bangs = dataConImplBangs dc
+ ; return (map reifyDecidedStrictness bangs) }
+
+ -- For qRecover, discard error messages if
+ -- the recovery action is chosen. Otherwise
+ -- we'll only fail higher up.
+ , mRecover = \recover main -> runInIO $ tryTcDiscardingErrs (runQinTcM recover) (runQinTcM main)
+
+ , mGetPackageRoot = runInIO $ do
+ dflags <- getDynFlags
+ return $ fromMaybe "." (workingDirectory dflags)
+
+ , mAddDependentFile = \fp -> runInIO $ do
+ ref <- fmap tcg_dependent_files getGblEnv
+ dep_files <- readTcRef ref
+ writeTcRef ref (fp:dep_files)
+
+ , mAddDependentDirectory = \dp -> runInIO $ do
+ ref <- fmap tcg_dependent_dirs getGblEnv
+ dep_dirs <- readTcRef ref
+ writeTcRef ref (dp:dep_dirs)
+
+ , mAddTempFile = \suffix -> runInIO $ do
+ dflags <- getDynFlags
+ logger <- getLogger
+ tmpfs <- hsc_tmpfs <$> getTopEnv
+ liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix
+
+ , mAddTopDecls = runInIO . addTopDecls
+
+ , mAddForeignFilePath = \lang fp -> runInIO $ do
+ var <- fmap tcg_th_foreign_files getGblEnv
+ updTcRef var ((lang, fp) :)
+
+ , mAddModFinalizer = \fin -> runInIO $ do
+ r <- liftIO $ mkRemoteRef fin
+ fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
+ addModFinalizerRef fref
+
+ , mAddCorePlugin = \plugin -> runInIO $ do
+ hsc_env <- getTopEnv
+ let fc = hsc_FC hsc_env
+ let home_unit = hsc_home_unit hsc_env
+ let dflags = hsc_dflags hsc_env
+ let fopts = initFinderOpts dflags
+ r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin)
+ let err = TcRnTHError $ AddInvalidCorePlugin plugin
+ case r of
+ Found {} -> addErr err
+ FoundMultiple {} -> addErr err
+ _ -> return ()
+ th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
+ updTcRef th_coreplugins_var (plugin:)
+
+ , mGetQ = runInIO getQ
+
+ , mPutQ = \x -> runInIO $ do
+ th_state_var <- fmap tcg_th_state getGblEnv
+ updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
+
+ , mIsExtEnabled = runInIO . xoptM
+
+ , mExtsEnabled = runInIO $
+ EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
+
+ , mPutDoc = fmap runInIO . putDoc
+
+ , mGetDoc = runInIO . getDoc
+ }
+
-- | Looks up documentation for a declaration in first the current module,
-- otherwise tries to find it in another module via 'hscGetModuleInterface'.
lookupDeclDoc :: Name -> TcM (Maybe String)
@@ -1788,7 +1810,7 @@ runTH ty fhv = do
InternalInterp -> do
-- Run it in the local TcM
hv <- liftIO $ wormhole interp fhv
- r <- runQuasi (unsafeCoerce hv :: TH.Q a)
+ r <- runQinTcM (unsafeCoerce hv :: TH.Q a)
return r
#endif
@@ -1797,7 +1819,7 @@ runTH ty fhv = do
-- Remote GHCi, see Note [Remote Template Haskell] in
-- libraries/ghci/GHCi/TH.hs.
rstate <- getTHState inst
- loc <- TH.qLocation
+ loc <- location
-- run a remote TH request
r <- liftIO $
withForeignRef rstate $ \state_hv ->
@@ -1913,32 +1935,32 @@ wrapTHResult tcm = do
handleTHMessage :: THMessage a -> TcM a
handleTHMessage msg = case msg of
- NewName a -> wrapTHResult $ TH.qNewName a
- Report b str -> wrapTHResult $ TH.qReport b str
- LookupName b str -> wrapTHResult $ TH.qLookupName b str
- Reify n -> wrapTHResult $ TH.qReify n
- ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n
- ReifyType n -> wrapTHResult $ TH.qReifyType n
- ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts
- ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n
+ NewName a -> wrapTHResult $ runQinTcM $ TH.newName a
+ Report b str -> wrapTHResult $ runQinTcM $ TH.report b str
+ LookupName b str -> wrapTHResult $ runQinTcM $ TH.lookupName b str
+ Reify n -> wrapTHResult $ runQinTcM $ TH.reify n
+ ReifyFixity n -> wrapTHResult $ runQinTcM $ TH.reifyFixity n
+ ReifyType n -> wrapTHResult $ runQinTcM $ TH.reifyType n
+ ReifyInstances n ts -> wrapTHResult $ runQinTcM $ TH.reifyInstances n ts
+ ReifyRoles n -> wrapTHResult $ runQinTcM $ TH.reifyRoles n
ReifyAnnotations lookup tyrep ->
wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)
- ReifyModule m -> wrapTHResult $ TH.qReifyModule m
- ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm
- GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot
- AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
- AddDependentDirectory d -> wrapTHResult $ TH.qAddDependentDirectory d
- AddTempFile s -> wrapTHResult $ TH.qAddTempFile s
+ ReifyModule m -> wrapTHResult $ runQinTcM $ TH.reifyModule m
+ ReifyConStrictness nm -> wrapTHResult $ runQinTcM $ TH.reifyConStrictness nm
+ GetPackageRoot -> wrapTHResult $ runQinTcM $ TH.getPackageRoot
+ AddDependentFile f -> wrapTHResult $ runQinTcM $ TH.addDependentFile f
+ AddDependentDirectory d -> wrapTHResult $ runQinTcM $ TH.addDependentDirectory d
+ AddTempFile s -> wrapTHResult $ runQinTcM $ TH.addTempFile s
AddModFinalizer r -> do
interp <- hscInterp <$> getTopEnv
wrapTHResult $ liftIO (mkFinalizedHValue interp r) >>= addModFinalizerRef
- AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str
- AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
- AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str
- IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
- ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
- PutDoc l s -> wrapTHResult $ TH.qPutDoc l s
- GetDoc l -> wrapTHResult $ TH.qGetDoc l
+ AddCorePlugin str -> wrapTHResult $ runQinTcM $ TH.addCorePlugin str
+ AddTopDecls decs -> wrapTHResult $ runQinTcM $ TH.addTopDecls decs
+ AddForeignFilePath lang str -> wrapTHResult $ runQinTcM $ TH.addForeignFilePath lang str
+ IsExtEnabled ext -> wrapTHResult $ runQinTcM $ TH.isExtEnabled ext
+ ExtsEnabled -> wrapTHResult $ runQinTcM $ TH.extsEnabled
+ PutDoc l s -> wrapTHResult $ runQinTcM $ TH.putDoc l s
+ GetDoc l -> wrapTHResult $ runQinTcM $ TH.getDoc l
FailIfErrs -> wrapTHResult failIfErrsM
_ -> panic ("handleTHMessage: unexpected message " ++ show msg)
=====================================
compiler/GHC/Tc/Gen/Splice.hs-boot
=====================================
@@ -42,6 +42,6 @@ runMetaT :: LHsExpr GhcTc -> TcM (LHsType GhcPs)
runMetaD :: LHsExpr GhcTc -> TcM [LHsDecl GhcPs]
lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
-runQuasi :: TH.Q a -> TcM a
+runQinTcM :: TH.Q a -> TcM a
runRemoteModFinalizers :: ThModFinalizers -> TcM ()
finishTH :: TcM ()
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
=====================================
@@ -1079,7 +1079,7 @@ withDecDoc :: String -> Q Dec -> Q Dec
withDecDoc doc dec = do
dec' <- dec
case doc_loc dec' of
- Just loc -> qAddModFinalizer $ qPutDoc loc doc
+ Just loc -> addModFinalizer $ putDoc loc doc
Nothing -> pure ()
pure dec'
where
@@ -1128,7 +1128,7 @@ funD_doc :: Name -> [Q Clause]
-> [Maybe String] -- ^ Documentation to attach to arguments
-> Q Dec
funD_doc nm cs mfun_doc arg_docs = do
- qAddModFinalizer $ sequence_
+ addModFinalizer $ sequence_
[putDoc (ArgDoc nm i) s | (i, Just s) <- zip [0..] arg_docs]
let dec = funD nm cs
case mfun_doc of
@@ -1145,7 +1145,7 @@ dataD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)
-- ^ Documentation to attach to the data declaration
-> Q Dec
dataD_doc ctxt tc tvs ksig cons_with_docs derivs mdoc = do
- qAddModFinalizer $ mapM_ docCons cons_with_docs
+ addModFinalizer $ mapM_ docCons cons_with_docs
let dec = dataD ctxt tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs) derivs
maybe dec (flip withDecDoc dec) mdoc
@@ -1159,7 +1159,7 @@ newtypeD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)
-- ^ Documentation to attach to the newtype declaration
-> Q Dec
newtypeD_doc ctxt tc tvs ksig con_with_docs@(con, _, _) derivs mdoc = do
- qAddModFinalizer $ docCons con_with_docs
+ addModFinalizer $ docCons con_with_docs
let dec = newtypeD ctxt tc tvs ksig con derivs
maybe dec (flip withDecDoc dec) mdoc
@@ -1172,7 +1172,7 @@ typeDataD_doc :: Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)
-- ^ Documentation to attach to the data declaration
-> Q Dec
typeDataD_doc tc tvs ksig cons_with_docs mdoc = do
- qAddModFinalizer $ mapM_ docCons cons_with_docs
+ addModFinalizer $ mapM_ docCons cons_with_docs
let dec = typeDataD tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs)
maybe dec (flip withDecDoc dec) mdoc
@@ -1186,7 +1186,7 @@ dataInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type -> Maybe (Q Kind)
-- ^ Documentation to attach to the instance declaration
-> Q Dec
dataInstD_doc ctxt mb_bndrs ty ksig cons_with_docs derivs mdoc = do
- qAddModFinalizer $ mapM_ docCons cons_with_docs
+ addModFinalizer $ mapM_ docCons cons_with_docs
let dec = dataInstD ctxt mb_bndrs ty ksig (map (\(con, _, _) -> con) cons_with_docs)
derivs
maybe dec (flip withDecDoc dec) mdoc
@@ -1202,7 +1202,7 @@ newtypeInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type
-- ^ Documentation to attach to the instance declaration
-> Q Dec
newtypeInstD_doc ctxt mb_bndrs ty ksig con_with_docs@(con, _, _) derivs mdoc = do
- qAddModFinalizer $ docCons con_with_docs
+ addModFinalizer $ docCons con_with_docs
let dec = newtypeInstD ctxt mb_bndrs ty ksig con derivs
maybe dec (flip withDecDoc dec) mdoc
@@ -1212,7 +1212,7 @@ patSynD_doc :: Name -> Q PatSynArgs -> Q PatSynDir -> Q Pat
-> [Maybe String] -- ^ Documentation to attach to the pattern arguments
-> Q Dec
patSynD_doc name args dir pat mdoc arg_docs = do
- qAddModFinalizer $ sequence_
+ addModFinalizer $ sequence_
[putDoc (ArgDoc name i) s | (i, Just s) <- zip [0..] arg_docs]
let dec = patSynD name args dir pat
maybe dec (flip withDecDoc dec) mdoc
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
=====================================
@@ -29,13 +29,13 @@ import Data.Data hiding (Fixity(..))
import Data.IORef
import System.IO.Unsafe (unsafePerformIO)
import Control.Monad.IO.Class (MonadIO (..))
-import System.IO (FilePath, hPutStrLn, stderr)
+import System.IO (hPutStrLn, stderr)
import qualified Data.Kind as Kind (Type)
import GHC.Types (TYPE, RuntimeRep(..))
#else
import GHC.Internal.Base (
Applicative(..), Functor(..), Monad(..), Monoid(..), Semigroup(..), String,
- flip, id, (.), (++),
+ flip, id, (.), (++), ($),
)
import GHC.Internal.Classes (not)
import GHC.Internal.Data.Data hiding (Fixity(..))
@@ -59,145 +59,150 @@ import GHC.Internal.ForeignSrcLang
import GHC.Internal.LanguageExtensions
import GHC.Internal.TH.Syntax
------------------------------------------------------
---
--- The Quasi class
---
------------------------------------------------------
-
-class (MonadIO m, MonadFail m) => Quasi m where
- -- | Fresh names. See 'newName'.
- qNewName :: String -> m Name
-
- ------- Error reporting and recovery -------
- -- | Report an error (True) or warning (False)
- -- ...but carry on; use 'fail' to stop. See 'report'.
- qReport :: Bool -> String -> m ()
-
- -- | See 'recover'.
- qRecover :: m a -- ^ the error handler
- -> m a -- ^ action which may fail
- -> m a -- ^ Recover from the monadic 'fail'
-
- ------- Inspect the type-checker's environment -------
- -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
- qLookupName :: Bool -> String -> m (Maybe Name)
- -- | See 'reify'.
- qReify :: Name -> m Info
- -- | See 'reifyFixity'.
- qReifyFixity :: Name -> m (Maybe Fixity)
- -- | See 'reifyType'.
- qReifyType :: Name -> m Type
- -- | Is (n tys) an instance? Returns list of matching instance Decs (with
- -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
- qReifyInstances :: Name -> [Type] -> m [Dec]
- -- | See 'reifyRoles'.
- qReifyRoles :: Name -> m [Role]
- -- | See 'reifyAnnotations'.
- qReifyAnnotations :: Data a => AnnLookup -> m [a]
- -- | See 'reifyModule'.
- qReifyModule :: Module -> m ModuleInfo
- -- | See 'reifyConStrictness'.
- qReifyConStrictness :: Name -> m [DecidedStrictness]
-
- -- | See 'location'.
- qLocation :: m Loc
-
- -- | Input/output (dangerous). See 'runIO'.
- qRunIO :: IO a -> m a
- qRunIO = liftIO
- -- | See 'getPackageRoot'.
- qGetPackageRoot :: m FilePath
-
- -- | See 'addDependentFile'.
- qAddDependentFile :: FilePath -> m ()
-
- -- | See 'addDependentDirectory'.
- qAddDependentDirectory :: FilePath -> m ()
-
- -- | See 'addTempFile'.
- qAddTempFile :: String -> m FilePath
-
- -- | See 'addTopDecls'.
- qAddTopDecls :: [Dec] -> m ()
-
- -- | See 'addForeignFilePath'.
- qAddForeignFilePath :: ForeignSrcLang -> String -> m ()
-
- -- | See 'addModFinalizer'.
- qAddModFinalizer :: Q () -> m ()
-
- -- | See 'addCorePlugin'.
- qAddCorePlugin :: String -> m ()
-
- -- | See 'getQ'.
- qGetQ :: Typeable a => m (Maybe a)
-
- -- | See 'putQ'.
- qPutQ :: Typeable a => a -> m ()
-
- -- | See 'isExtEnabled'.
- qIsExtEnabled :: Extension -> m Bool
- -- | See 'extsEnabled'.
- qExtsEnabled :: m [Extension]
-
- -- | See 'putDoc'.
- qPutDoc :: DocLoc -> String -> m ()
- -- | See 'getDoc'.
- qGetDoc :: DocLoc -> m (Maybe String)
+-- | 'MetaHandlers' defines the interface between GHC and TH splices.
+-- This is an internal interface between two parts of the compiler,
+-- and should never be directly exposed to users.
+--
+-- It mirrors the 'Quasi' typeclass, which is part of the public facing interface of TH.
+-- With time the two interfaces may drift apart.
+--
+-- This type is defined in `ghc-internal` rather than `lib:ghc` to avoid
+-- `template-haskell` having to depend on GHC, ie, it implements dependency inversion.
+--
+-- For more information about the historical design of this interface,
+-- see: https://github.com/ghc-proposals/ghc-proposals/pull/700
+data MetaHandlers = MetaHandlers {
+ -- | We have an explicit handler for liftIO to allow users to forbid lifting into 'IO'
+ mLiftIO :: forall a. IO a -> IO a
+ , mFail :: forall a. String -> IO a
+ -- | Fresh names. See 'newName'.
+ , mNewName :: String -> IO Name
+
+ ------- Error reporting and recovery -------
+ -- | Report an error (True) or warning (False)
+ -- ...but carry on; use 'fail' to stop. See 'report'.
+ , mReport :: Bool -> String -> IO ()
+
+ -- | See 'recover'.
+ , mRecover :: forall a. Q a -- ^ the error handler
+ -> Q a -- ^ action which may fail
+ -> IO a -- ^ Recover from the monadic 'fail'
+
+ ------- Inspect the type-checker's environment -------
+ -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
+ , mLookupName :: Bool -> String -> IO (Maybe Name)
+ -- | See 'reify'.
+ , mReify :: Name -> IO Info
+ -- | See 'reifyFixity'.
+ , mReifyFixity :: Name -> IO (Maybe Fixity)
+ -- | See 'reifyType'.
+ , mReifyType :: Name -> IO Type
+ -- | Is (n tys) an instance? Returns list of matching instance Decs (with
+ -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
+ , mReifyInstances :: Name -> [Type] -> IO [Dec]
+ -- | See 'reifyRoles'.
+ , mReifyRoles :: Name -> IO [Role]
+ -- | See 'reifyAnnotations'.
+ , mReifyAnnotations :: forall a. Data a => AnnLookup -> IO [a]
+ -- | See 'reifyModule'.
+ , mReifyModule :: Module -> IO ModuleInfo
+ -- | See 'reifyConStrictness'.
+ , mReifyConStrictness :: Name -> IO [DecidedStrictness]
+
+ -- | See 'location'.
+ , mLocation :: IO Loc
+
+ -- | See 'getPackageRoot'.
+ , mGetPackageRoot :: IO FilePath
+
+ -- | See 'addDependentFile'.
+ , mAddDependentFile :: FilePath -> IO ()
+
+ -- | See 'addDependentDirectory'.
+ , mAddDependentDirectory :: FilePath -> IO ()
+
+ -- | See 'addTempFile'.
+ , mAddTempFile :: String -> IO FilePath
+
+ -- | See 'addTopDecls'.
+ , mAddTopDecls :: [Dec] -> IO ()
+
+ -- | See 'addForeignFilePath'.
+ , mAddForeignFilePath :: ForeignSrcLang -> String -> IO ()
+
+ -- | See 'addModFinalizer'.
+ , mAddModFinalizer :: Q () -> IO ()
+
+ -- | See 'addCorePlugin'.
+ , mAddCorePlugin :: String -> IO ()
+
+ -- | See 'getQ'.
+ , mGetQ :: forall a. Typeable a => IO (Maybe a)
+
+ -- | See 'putQ'.
+ , mPutQ :: forall a. Typeable a => a -> IO ()
+
+ -- | See 'isExtEnabled'.
+ , mIsExtEnabled :: Extension -> IO Bool
+ -- | See 'extsEnabled'.
+ , mExtsEnabled :: IO [Extension]
+
+ -- | See 'putDoc'.
+ , mPutDoc :: DocLoc -> String -> IO ()
+ -- | See 'getDoc'.
+ , mGetDoc :: DocLoc -> IO (Maybe String)
+ }
------------------------------------------------------
--- The IO instance of Quasi
------------------------------------------------------
+badIO :: String -> IO a
+badIO op = do { hPutStrLn stderr ("Can't do `" ++ op ++ "' in the IO monad")
+ ; fail "Template Haskell failure" }
--- | This instance is used only when running a Q
--- computation in the IO monad, usually just to
--- print the result. There is no interesting
--- type environment, so reification isn't going to
--- work.
-instance Quasi IO where
- qNewName = newNameIO
-
- qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
- qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
-
- qLookupName _ _ = badIO "lookupName"
- qReify _ = badIO "reify"
- qReifyFixity _ = badIO "reifyFixity"
- qReifyType _ = badIO "reifyFixity"
- qReifyInstances _ _ = badIO "reifyInstances"
- qReifyRoles _ = badIO "reifyRoles"
- qReifyAnnotations _ = badIO "reifyAnnotations"
- qReifyModule _ = badIO "reifyModule"
- qReifyConStrictness _ = badIO "reifyConStrictness"
- qLocation = badIO "currentLocation"
- qRecover _ _ = badIO "recover" -- Maybe we could fix this?
- qGetPackageRoot = badIO "getProjectRoot"
- qAddDependentFile _ = badIO "addDependentFile"
- qAddTempFile _ = badIO "addTempFile"
- qAddTopDecls _ = badIO "addTopDecls"
- qAddForeignFilePath _ _ = badIO "addForeignFilePath"
- qAddModFinalizer _ = badIO "addModFinalizer"
- qAddCorePlugin _ = badIO "addCorePlugin"
- qGetQ = badIO "getQ"
- qPutQ _ = badIO "putQ"
- qIsExtEnabled _ = badIO "isExtEnabled"
- qExtsEnabled = badIO "extsEnabled"
- qPutDoc _ _ = badIO "putDoc"
- qGetDoc _ = badIO "getDoc"
- qAddDependentDirectory _ = badIO "AddDependentDirectory"
+metaHandlersIO :: MetaHandlers
+metaHandlersIO = MetaHandlers {
+ mLiftIO = id
+ , mFail = fail
+ , mNewName = newNameIO
+ , mReport = \b msg ->
+ if b then
+ hPutStrLn stderr ("Template Haskell error: " ++ msg)
+ else
+ hPutStrLn stderr ("Template Haskell error: " ++ msg) -- TODO: should this be different from above?
+ , mLookupName = \ _ _ -> badIO "lookupName"
+ , mReify = \_ -> badIO "reify"
+ , mReifyFixity = \_ -> badIO "reifyFixity"
+ , mReifyType = \_ -> badIO "reifyFixity"
+ , mReifyInstances = \_ _ -> badIO "reifyInstances"
+ , mReifyRoles = \_ -> badIO "reifyRoles"
+ , mReifyAnnotations = \_ -> badIO "reifyAnnotations"
+ , mReifyModule = \_ -> badIO "reifyModule"
+ , mReifyConStrictness = \_ -> badIO "reifyConStrictness"
+ , mLocation = badIO "currentLocation"
+ , mRecover = \_ _ -> badIO "recover" -- Maybe we could fix this?
+ , mGetPackageRoot = badIO "getProjectRoot"
+ , mAddDependentFile = \_ -> badIO "addDependentFile"
+ , mAddTempFile = \_ -> badIO "addTempFile"
+ , mAddTopDecls = \_ -> badIO "addTopDecls"
+ , mAddForeignFilePath = \_ _ -> badIO "addForeignFilePath"
+ , mAddModFinalizer = \_ -> badIO "addModFinalizer"
+ , mAddCorePlugin = \_ -> badIO "addCorePlugin"
+ , mGetQ = badIO "getQ"
+ , mPutQ = \_ -> badIO "putQ"
+ , mIsExtEnabled = \_ -> badIO "isExtEnabled"
+ , mExtsEnabled = badIO "extsEnabled"
+ , mPutDoc = \_ _ -> badIO "putDoc"
+ , mGetDoc = \_ -> badIO "getDoc"
+ , mAddDependentDirectory = \_ -> badIO "AddDependentDirectory"
+ }
instance Quote IO where
newName = newNameIO
+
+
newNameIO :: String -> IO Name
newNameIO s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x))
; pure (mkNameU s n) }
-badIO :: String -> IO a
-badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad")
- ; fail "Template Haskell failure" }
-
-- Global variable to generate unique symbols
counter :: IORef Uniq
{-# NOINLINE counter #-}
@@ -210,46 +215,24 @@ counter = unsafePerformIO (newIORef 0)
--
-----------------------------------------------------
--- | In short, 'Q' provides the 'Quasi' operations in one neat monad for the
--- user.
---
--- The longer story, is that 'Q' wraps an arbitrary 'Quasi'-able monad.
--- The perceptive reader notices that 'Quasi' has only two instances, 'Q'
--- itself and 'IO', neither of which have concrete implementations.'Q' plays
--- the trick of [dependency
--- inversion](https://en.wikipedia.org/wiki/Dependency_inversion_principle),
--- providing an abstract interface for the user which is later concretely
--- fufilled by an concrete 'Quasi' instance, internal to GHC.
-newtype Q a = Q { unQ :: forall m. Quasi m => m a }
-
--- | \"Runs\" the 'Q' monad. Normal users of Template Haskell
--- should not need this function, as the splice brackets @$( ... )@
--- are the usual way of running a 'Q' computation.
---
--- This function is primarily used in GHC internals, and for debugging
--- splices by running them in 'IO'.
---
--- Note that many functions in 'Q', such as 'reify' and other compiler
--- queries, are not supported when running 'Q' in 'IO'; these operations
--- simply fail at runtime. Indeed, the only operations guaranteed to succeed
--- are 'newName', 'runIO', 'reportError' and 'reportWarning'.
-runQ :: Quasi m => Q a -> m a
-runQ (Q m) = m
+-- | 'Q' is the base 'Monad' for TemplateHaskell splices,
+-- similar to how 'IO' is the base 'Monad' for normal Haskell programs.
+newtype Q a = Q { unQ :: MetaHandlers -> IO a }
instance Monad Q where
- Q m >>= k = Q (m >>= \x -> unQ (k x))
+ Q m >>= k = Q $ \h -> (m h >>= \x -> unQ (k x) h)
(>>) = (*>)
instance MonadFail Q where
- fail s = report True s >> Q (fail "Q monad failure")
+ fail s = report True s >> Q (\h -> mFail h "Q monad failure")
instance Functor Q where
- fmap f (Q x) = Q (fmap f x)
+ fmap f (Q x) = Q $ \h -> fmap f (x h)
instance Applicative Q where
- pure x = Q (pure x)
- Q f <*> Q x = Q (f <*> x)
- Q m *> Q n = Q (m *> n)
+ pure x = Q $ \_ -> pure x
+ Q f <*> Q x = Q $ \h -> (f h <*> x h)
+ Q m *> Q n = Q $ \h -> (m h *> n h)
-- | @since 2.17.0.0
instance Semigroup a => Semigroup (Q a) where
@@ -319,7 +302,7 @@ class Monad m => Quote m where
newName :: String -> m Name
instance Quote Q where
- newName s = Q (qNewName s)
+ newName s = Q $ \h -> mNewName h s
-----------------------------------------------------
--
@@ -517,35 +500,26 @@ joinCode = flip bindCode id
-- | Report an error (True) or warning (False),
-- but carry on; use 'fail' to stop.
report :: Bool -> String -> Q ()
-report b s = Q (qReport b s)
-{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6
-
--- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'.
-reportError :: String -> Q ()
-reportError = report True
-
--- | Report a warning to the user, and carry on.
-reportWarning :: String -> Q ()
-reportWarning = report False
+report b s = Q $ \h -> mReport h b s
-- | Recover from errors raised by 'reportError' or 'fail'.
recover :: Q a -- ^ handler to invoke on failure
-> Q a -- ^ computation to run
-> Q a
-recover (Q r) (Q m) = Q (qRecover r m)
+recover rec main = Q $ \h -> mRecover h rec main
-- We don't export lookupName; the Bool isn't a great API
-- Instead we export lookupTypeName, lookupValueName
lookupName :: Bool -> String -> Q (Maybe Name)
-lookupName ns s = Q (qLookupName ns s)
+lookupName ns s = Q $ \h -> mLookupName h ns s
-- | Look up the given name in the (type namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
lookupTypeName :: String -> Q (Maybe Name)
-lookupTypeName s = Q (qLookupName True s)
+lookupTypeName s = Q $ \h -> mLookupName h True s
-- | Look up the given name in the (value namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
lookupValueName :: String -> Q (Maybe Name)
-lookupValueName s = Q (qLookupName False s)
+lookupValueName s = Q $ \h -> mLookupName h False s
{-
Note [Name lookup]
@@ -620,7 +594,7 @@ To ensure we get information about @D@-the-value, use 'lookupValueName':
and to get information about @D@-the-type, use 'lookupTypeName'.
-}
reify :: Name -> Q Info
-reify v = Q (qReify v)
+reify v = Q $ \h -> mReify h v
{- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For
example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then
@@ -629,7 +603,7 @@ example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then
'Nothing', so you may assume @bar@ has 'defaultFixity'.
-}
reifyFixity :: Name -> Q (Maybe Fixity)
-reifyFixity nm = Q (qReifyFixity nm)
+reifyFixity nm = Q $ \h -> mReifyFixity h nm
{- | @reifyType nm@ attempts to find the type or kind of @nm@. For example,
@reifyType 'not@ returns @Bool -> Bool@, and
@@ -637,7 +611,7 @@ reifyFixity nm = Q (qReifyFixity nm)
This works even if there's no explicit signature and the type or kind is inferred.
-}
reifyType :: Name -> Q Type
-reifyType nm = Q (qReifyType nm)
+reifyType nm = Q $ \h -> mReifyType h nm
{- | Template Haskell is capable of reifying information about types and
terms defined in previous declaration groups. Top-level declaration splices break up
@@ -729,7 +703,7 @@ has some discussion around this.
-}
reifyInstances :: Name -> [Type] -> Q [InstanceDec]
-reifyInstances cls tys = Q (qReifyInstances cls tys)
+reifyInstances cls tys = Q $ \h -> mReifyInstances h cls tys
{- | @reifyRoles nm@ returns the list of roles associated with the parameters
(both visible and invisible) of
@@ -748,20 +722,20 @@ and @reifyRoles Proxy@, we will get @['NominalR', 'PhantomR']@. The 'NominalR' i
the role of the invisible @k@ parameter. Kind parameters are always nominal.
-}
reifyRoles :: Name -> Q [Role]
-reifyRoles nm = Q (qReifyRoles nm)
+reifyRoles nm = Q $ \h -> mReifyRoles h nm
-- | @reifyAnnotations target@ returns the list of annotations
-- associated with @target@. Only the annotations that are
-- appropriately typed is returned. So if you have @Int@ and @String@
-- annotations for the same target, you have to call this function twice.
reifyAnnotations :: Data a => AnnLookup -> Q [a]
-reifyAnnotations an = Q (qReifyAnnotations an)
+reifyAnnotations an = Q $ \h -> mReifyAnnotations h an
-- | @reifyModule mod@ looks up information about module @mod@. To
-- look up the current module, call this function with the return
-- value of 'Language.Haskell.TH.Lib.thisModule'.
reifyModule :: Module -> Q ModuleInfo
-reifyModule m = Q (qReifyModule m)
+reifyModule m = Q $ \h -> mReifyModule h m
-- | @reifyConStrictness nm@ looks up the strictness information for the fields
-- of the constructor with the name @nm@. Note that the strictness information
@@ -776,7 +750,7 @@ reifyModule m = Q (qReifyModule m)
-- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the
-- @-XStrictData@ language extension was enabled.
reifyConStrictness :: Name -> Q [DecidedStrictness]
-reifyConStrictness n = Q (qReifyConStrictness n)
+reifyConStrictness n = Q $ \h -> mReifyConStrictness h n
-- | Is the list of instances returned by 'reifyInstances' nonempty?
--
@@ -789,7 +763,7 @@ isInstance nm tys = do { decs <- reifyInstances nm tys
-- | The location at which this computation is spliced.
location :: Q Loc
-location = Q qLocation
+location = Q mLocation
-- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad.
-- Take care: you are guaranteed the ordering of calls to 'runIO' within
@@ -799,7 +773,7 @@ location = Q qLocation
-- necessarily flushed when the compiler finishes running, so you should
-- flush them yourself.
runIO :: IO a -> Q a
-runIO m = Q (qRunIO m)
+runIO m = Q $ \h -> mLiftIO h m
-- | Get the package root for the current package which is being compiled.
-- This can be set explicitly with the -package-root flag but is normally
@@ -811,7 +785,7 @@ runIO m = Q (qRunIO m)
-- change directory when compiling files but instead set the -package-root flag
-- appropriately.
getPackageRoot :: Q FilePath
-getPackageRoot = Q qGetPackageRoot
+getPackageRoot = Q mGetPackageRoot
-- | Record external directories that runIO is using (dependent upon).
-- The compiler can then recognize that it should re-compile the Haskell file
@@ -830,7 +804,7 @@ getPackageRoot = Q qGetPackageRoot
-- * The state of the directory is read at the interface generation time,
-- not at the time of the function call.
addDependentDirectory :: FilePath -> Q ()
-addDependentDirectory dp = Q (qAddDependentDirectory dp)
+addDependentDirectory dp = Q $ \h -> mAddDependentDirectory h dp
-- | Record external files that runIO is using (dependent upon).
-- The compiler can then recognize that it should re-compile the Haskell file
@@ -844,17 +818,17 @@ addDependentDirectory dp = Q (qAddDependentDirectory dp)
--
-- * The dependency is based on file content, not a modification time
addDependentFile :: FilePath -> Q ()
-addDependentFile fp = Q (qAddDependentFile fp)
+addDependentFile fp = Q $ \h -> mAddDependentFile h fp
-- | Obtain a temporary file path with the given suffix. The compiler will
-- delete this file after compilation.
addTempFile :: String -> Q FilePath
-addTempFile suffix = Q (qAddTempFile suffix)
+addTempFile suffix = Q $ \h -> mAddTempFile h suffix
-- | Add additional top-level declarations. The added declarations will be type
-- checked along with the current declaration group.
addTopDecls :: [Dec] -> Q ()
-addTopDecls ds = Q (qAddTopDecls ds)
+addTopDecls ds = Q $ \h -> mAddTopDecls h ds
-- | Same as 'addForeignSource', but expects to receive a path pointing to the
-- foreign file instead of a 'String' of its contents. Consider using this in
@@ -863,7 +837,7 @@ addTopDecls ds = Q (qAddTopDecls ds)
-- This is a good alternative to 'addForeignSource' when you are trying to
-- directly link in an object file.
addForeignFilePath :: ForeignSrcLang -> FilePath -> Q ()
-addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp)
+addForeignFilePath lang fp = Q $ \h -> mAddForeignFilePath h lang fp
-- | Add a finalizer that will run in the Q monad after the current module has
-- been type checked. This only makes sense when run within a top-level splice.
@@ -872,7 +846,7 @@ addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp)
-- 'reify' is able to find the local definitions when executed inside the
-- finalizer.
addModFinalizer :: Q () -> Q ()
-addModFinalizer act = Q (qAddModFinalizer (unQ act))
+addModFinalizer act = Q $ \h -> mAddModFinalizer h act
-- | Adds a core plugin to the compilation pipeline.
--
@@ -882,7 +856,7 @@ addModFinalizer act = Q (qAddModFinalizer (unQ act))
-- to tell the compiler that we needed to compile first a plugin module in the
-- current package.
addCorePlugin :: String -> Q ()
-addCorePlugin plugin = Q (qAddCorePlugin plugin)
+addCorePlugin plugin = Q $ \h -> mAddCorePlugin h plugin
-- | Get state from the 'Q' monad. The state maintained by 'Q' is isomorphic to
-- a type-indexed finite map. That is,
@@ -896,20 +870,20 @@ addCorePlugin plugin = Q (qAddCorePlugin plugin)
-- Note that the state is local to the Haskell module in which the Template
-- Haskell expression is executed.
getQ :: Typeable a => Q (Maybe a)
-getQ = Q qGetQ
+getQ = Q mGetQ
-- | Replace the state in the 'Q' monad. Note that the state is local to the
-- Haskell module in which the Template Haskell expression is executed.
putQ :: Typeable a => a -> Q ()
-putQ x = Q (qPutQ x)
+putQ x = Q $ \h -> mPutQ h x
-- | Determine whether the given language extension is enabled in the 'Q' monad.
isExtEnabled :: Extension -> Q Bool
-isExtEnabled ext = Q (qIsExtEnabled ext)
+isExtEnabled ext = Q $ \h -> mIsExtEnabled h ext
-- | List all enabled language extensions.
extsEnabled :: Q [Extension]
-extsEnabled = Q qExtsEnabled
+extsEnabled = Q mExtsEnabled
-- | Add Haddock documentation to the specified location. This will overwrite
-- any documentation at the location if it already exists. This will reify the
@@ -928,48 +902,18 @@ extsEnabled = Q qExtsEnabled
-- Adding documentation to anything outside of the current module will cause an
-- error.
putDoc :: DocLoc -> String -> Q ()
-putDoc t s = Q (qPutDoc t s)
+putDoc t s = Q $ \h -> mPutDoc h t s
-- | Retrieves the Haddock documentation at the specified location, if one
-- exists.
-- It can be used to read documentation on things defined outside of the current
-- module, provided that those modules were compiled with the @-haddock@ flag.
getDoc :: DocLoc -> Q (Maybe String)
-getDoc n = Q (qGetDoc n)
+getDoc n = Q $ \h -> mGetDoc h n
instance MonadIO Q where
liftIO = runIO
-instance Quasi Q where
- qNewName = newName
- qReport = report
- qRecover = recover
- qReify = reify
- qReifyFixity = reifyFixity
- qReifyType = reifyType
- qReifyInstances = reifyInstances
- qReifyRoles = reifyRoles
- qReifyAnnotations = reifyAnnotations
- qReifyModule = reifyModule
- qReifyConStrictness = reifyConStrictness
- qLookupName = lookupName
- qLocation = location
- qGetPackageRoot = getPackageRoot
- qAddDependentFile = addDependentFile
- qAddDependentDirectory = addDependentDirectory
- qAddTempFile = addTempFile
- qAddTopDecls = addTopDecls
- qAddForeignFilePath = addForeignFilePath
- qAddModFinalizer = addModFinalizer
- qAddCorePlugin = addCorePlugin
- qGetQ = getQ
- qPutQ = putQ
- qIsExtEnabled = isExtEnabled
- qExtsEnabled = extsEnabled
- qPutDoc = putDoc
- qGetDoc = getDoc
-
-
----------------------------------------------------
-- The following operations are used solely in GHC.HsToCore.Quote when
-- desugaring brackets. They are not necessary for the user, who can use
=====================================
libraries/ghci/GHCi/TH.hs
=====================================
@@ -1,5 +1,5 @@
{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric,
- TupleSections, RecordWildCards, InstanceSigs, CPP #-}
+ TupleSections, RecordWildCards, InstanceSigs, CPP, RankNTypes #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-- |
@@ -164,58 +164,70 @@ ghcCmd m = GHCiQ $ \sRef -> do
instance MonadIO GHCiQ where
liftIO m = GHCiQ $ \_ -> m
-instance TH.Quasi GHCiQ where
- qNewName str = ghcCmd (NewName str)
- qReport isError msg = ghcCmd (Report isError msg)
-
- -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice
- qRecover (GHCiQ h) a = GHCiQ $ \sRef -> mask $ \unmask -> do
- s <- readIORef sRef
- remoteTHCall (qsPipe s) StartRecover
- e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) sRef
- remoteTHCall (qsPipe s) (EndRecover (isLeft e))
- case e of
- Left GHCiQException{} -> h sRef
- Right r -> return r
- qLookupName isType occ = ghcCmd (LookupName isType occ)
- qReify name = ghcCmd (Reify name)
- qReifyFixity name = ghcCmd (ReifyFixity name)
- qReifyType name = ghcCmd (ReifyType name)
- qReifyInstances name tys = ghcCmd (ReifyInstances name tys)
- qReifyRoles name = ghcCmd (ReifyRoles name)
-
-- To reify annotations, we send GHC the AnnLookup and also the
-- TypeRep of the thing we're looking for, to avoid needing to
-- serialize irrelevant annotations.
- qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
- qReifyAnnotations lookup =
+reifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
+reifyAnnotations lookup =
map (deserializeWithData . B.unpack) <$>
ghcCmd (ReifyAnnotations lookup typerep)
where typerep = typeOf (undefined :: a)
- qReifyModule m = ghcCmd (ReifyModule m)
- qReifyConStrictness name = ghcCmd (ReifyConStrictness name)
- qLocation = fromMaybe noLoc . qsLocation <$> getState
- qGetPackageRoot = ghcCmd GetPackageRoot
- qAddDependentFile file = ghcCmd (AddDependentFile file)
- qAddDependentDirectory dir = ghcCmd (AddDependentDirectory dir)
- qAddTempFile suffix = ghcCmd (AddTempFile suffix)
- qAddTopDecls decls = ghcCmd (AddTopDecls decls)
- qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)
- qAddModFinalizer fin = GHCiQ (\_ -> mkRemoteRef fin) >>=
+runQinGHCiQ :: TH.Q a -> GHCiQ a
+runQinGHCiQ (TH.Q m) = GHCiQ $ \sRef -> m (metaHandlersGHCiQ (runInIO sRef))
+ where
+ runInIO :: IORef QState -> GHCiQ a -> IO a
+ runInIO sRef (GHCiQ m) = m sRef
+
+metaHandlersGHCiQ :: (forall x. GHCiQ x -> IO x) -> TH.MetaHandlers
+metaHandlersGHCiQ runInIO = TH.MetaHandlers {
+ mLiftIO = id
+ , mFail = runInIO . fail
+ , mNewName = \str -> runInIO $ ghcCmd (NewName str)
+ , mReport = \isError msg -> runInIO $ ghcCmd (Report isError msg)
+
+ -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice
+ , mRecover = \h a -> runInIO $ GHCiQ $ \sRef -> mask $ \unmask -> do
+ s <- readIORef sRef
+ remoteTHCall (qsPipe s) StartRecover
+ e <- try $ unmask $ runGHCiQ (runQinGHCiQ a <* ghcCmd FailIfErrs) sRef
+ remoteTHCall (qsPipe s) (EndRecover (isLeft e))
+ case e of
+ Left GHCiQException{} ->
+ runGHCiQ (runQinGHCiQ h) sRef
+ Right r -> return r
+ , mLookupName = \isType occ -> runInIO $ ghcCmd (LookupName isType occ)
+ , mReify = \name ->runInIO $ ghcCmd (Reify name)
+ , mReifyFixity = \name ->runInIO $ ghcCmd (ReifyFixity name)
+ , mReifyType = \name -> runInIO $ ghcCmd (ReifyType name)
+ , mReifyInstances = \name tys -> runInIO $ ghcCmd (ReifyInstances name tys)
+ , mReifyRoles = \name -> runInIO $ ghcCmd (ReifyRoles name)
+
+ , mReifyAnnotations = runInIO . reifyAnnotations
+ , mReifyModule = \m -> runInIO $ ghcCmd (ReifyModule m)
+ , mReifyConStrictness = \name -> runInIO $ ghcCmd (ReifyConStrictness name)
+ , mLocation = runInIO $ fromMaybe noLoc . qsLocation <$> getState
+ , mGetPackageRoot = runInIO $ ghcCmd GetPackageRoot
+ , mAddDependentFile = \file -> runInIO $ ghcCmd (AddDependentFile file)
+ , mAddDependentDirectory = \dir -> runInIO $ ghcCmd (AddDependentDirectory dir)
+ , mAddTempFile = \suffix -> runInIO $ ghcCmd (AddTempFile suffix)
+ , mAddTopDecls = \decls -> runInIO $ ghcCmd (AddTopDecls decls)
+ , mAddForeignFilePath = \lang fp -> runInIO $ ghcCmd (AddForeignFilePath lang fp)
+ , mAddModFinalizer = \fin -> runInIO $ GHCiQ (\_ -> mkRemoteRef fin) >>=
ghcCmd . AddModFinalizer
- qAddCorePlugin str = ghcCmd (AddCorePlugin str)
- qGetQ = do
+ , mAddCorePlugin = \str -> runInIO $ ghcCmd (AddCorePlugin str)
+ , mGetQ = runInIO $ do
s <- getState
let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
return $ lookup (qsMap s)
- qPutQ k = GHCiQ $ \sRef ->
- modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
- qIsExtEnabled x = ghcCmd (IsExtEnabled x)
- qExtsEnabled = ghcCmd ExtsEnabled
- qPutDoc l s = ghcCmd (PutDoc l s)
- qGetDoc l = ghcCmd (GetDoc l)
+ , mPutQ = \k -> runInIO $ GHCiQ $ \sRef ->
+ modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
+ , mIsExtEnabled = \x -> runInIO $ ghcCmd (IsExtEnabled x)
+ , mExtsEnabled = runInIO $ ghcCmd ExtsEnabled
+ , mPutDoc = \l s -> runInIO $ ghcCmd (PutDoc l s)
+ , mGetDoc = \l -> runInIO $ ghcCmd (GetDoc l)
+}
-- | The implementation of the 'StartTH' message: create
-- a new IORef QState, and return a RemoteRef to it.
@@ -235,7 +247,7 @@ runModFinalizerRefs pipe rstate qrefs = do
qstateref <- localRef rstate
qstate <- readIORef qstateref
qstate' <- newIORef $ qstate { qsPipe = pipe }
- _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate'
+ _ <- runGHCiQ (runQinGHCiQ $ sequence_ qs) qstate'
return ()
-- | The implementation of the 'RunTH' message
@@ -272,5 +284,5 @@ runTHQ
runTHQ pipe rstate mb_loc ghciq = do
qstateref <- localRef rstate
modifyIORef' qstateref (\qstate -> qstate { qsLocation = mb_loc, qsPipe = pipe })
- r <- runGHCiQ (TH.runQ ghciq) qstateref
+ r <- runGHCiQ (runQinGHCiQ ghciq) qstateref
return $! LB.toStrict (runPut (put r))
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -5,13 +5,17 @@
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE UnboxedTuples #-}
+-- Don't warn for using 'report' from ghc-internal
+{-# OPTIONS_GHC -Wno-warnings-deprecations #-}
module Language.Haskell.TH.Syntax (
Quote (..),
Exp (..),
Match (..),
Clause (..),
- Q (..),
+ Q,
+ -- backwards compatibility
+ Language.Haskell.TH.Syntax.unQ,
Pat (..),
Stmt (..),
Con (..),
@@ -202,11 +206,14 @@ where
import GHC.Boot.TH.Lift
import GHC.Boot.TH.Syntax
-import GHC.Boot.TH.Monad
+import GHC.Boot.TH.Monad hiding (report)
+import qualified GHC.Boot.TH.Monad as Internal
import System.FilePath
import Data.Data hiding (Fixity(..))
import Data.List.NonEmpty (NonEmpty(..))
import GHC.Lexeme ( startsVarSym, startsVarId )
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import System.IO (hPutStrLn, stderr)
-- This module completely re-exports 'GHC.Boot.TH.Syntax',
-- and exports additionally functions that depend on @filepath@ or @System.IO@.
@@ -499,3 +506,170 @@ reassociate the tree as necessary.
-- Subsumed by the more general 'SpecialiseEP' constructor.
pattern SpecialiseP :: Name -> Type -> (Maybe Inline) -> Phases -> Pragma
pattern SpecialiseP nm ty inl phases = SpecialiseEP Nothing [] (SigE (VarE nm) ty) inl phases
+
+unQ :: Q a -> (forall m. Quasi m => m a)
+unQ m = runQ m
+
+-----------------------------------------------------
+--
+-- The Quasi class
+--
+-----------------------------------------------------
+
+class (MonadIO m, MonadFail m) => Quasi m where
+ qRunQ :: Q a -> m a
+ -- | Fresh names. See 'newName'.
+ qNewName :: String -> m Name
+ qNewName = qRunQ . newName
+
+ ------- Error reporting and recovery -------
+ -- | Report an error (True) or warning (False)
+ -- ...but carry on; use 'fail' to stop. See 'report'.
+ qReport :: Bool -> String -> m ()
+ qReport b s = qRunQ $ report b s
+
+ -- | See 'recover'.
+ qRecover :: m a -- ^ the error handler
+ -> m a -- ^ action which may fail
+ -> m a -- ^ Recover from the monadic 'fail'
+
+ ------- Inspect the type-checker's environment -------
+ -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
+ qLookupName :: Bool -> String -> m (Maybe Name)
+ qLookupName ns s = qRunQ $ lookupName ns s
+ -- | See 'reify'.
+ qReify :: Name -> m Info
+ qReify v = qRunQ $ reify v
+ -- | See 'reifyFixity'.
+ qReifyFixity :: Name -> m (Maybe Fixity)
+ qReifyFixity v = qRunQ $ reifyFixity v
+ -- | See 'reifyType'.
+ qReifyType :: Name -> m Type
+ qReifyType v = qRunQ $ reifyType v
+ -- | Is (n tys) an instance? Returns list of matching instance Decs (with
+ -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
+ qReifyInstances :: Name -> [Type] -> m [Dec]
+ qReifyInstances cls tys = qRunQ $ reifyInstances cls tys
+ -- | See 'reifyRoles'.
+ qReifyRoles :: Name -> m [Role]
+ qReifyRoles nm = qRunQ $ reifyRoles nm
+ -- | See 'reifyAnnotations'.
+ qReifyAnnotations :: Data a => AnnLookup -> m [a]
+ qReifyAnnotations an = qRunQ $ reifyAnnotations an
+ -- | See 'reifyModule'.
+ qReifyModule :: Module -> m ModuleInfo
+ qReifyModule m = qRunQ $ reifyModule m
+ -- | See 'reifyConStrictness'.
+ qReifyConStrictness :: Name -> m [DecidedStrictness]
+ qReifyConStrictness nm = qRunQ $ reifyConStrictness nm
+
+ -- | See 'location'.
+ qLocation :: m Loc
+ qLocation = qRunQ location
+
+ -- | Input/output (dangerous). See 'runIO'.
+ qRunIO :: IO a -> m a
+ qRunIO = liftIO
+ -- | See 'getPackageRoot'.
+ qGetPackageRoot :: m FilePath
+ qGetPackageRoot = qRunQ getPackageRoot
+
+ -- | See 'addDependentFile'.
+ qAddDependentFile :: FilePath -> m ()
+ qAddDependentFile p = qRunQ $ addDependentFile p
+
+ -- | See 'addDependentDirectory'.
+ qAddDependentDirectory :: FilePath -> m ()
+ qAddDependentDirectory p = qRunQ $ addDependentDirectory p
+
+ -- | See 'addTempFile'.
+ qAddTempFile :: String -> m FilePath
+ qAddTempFile p = qRunQ $ addTempFile p
+
+ -- | See 'addTopDecls'.
+ qAddTopDecls :: [Dec] -> m ()
+ qAddTopDecls decls = qRunQ $ addTopDecls decls
+
+ -- | See 'addForeignFilePath'.
+ qAddForeignFilePath :: ForeignSrcLang -> String -> m ()
+ qAddForeignFilePath lang fp = qRunQ $ addForeignFilePath lang fp
+
+ -- | See 'addModFinalizer'.
+ qAddModFinalizer :: Q () -> m ()
+ qAddModFinalizer fin = qRunQ $ addModFinalizer fin
+
+ -- | See 'addCorePlugin'.
+ qAddCorePlugin :: String -> m ()
+ qAddCorePlugin nm = qRunQ $ addCorePlugin nm
+
+ -- | See 'getQ'.
+ qGetQ :: Typeable a => m (Maybe a)
+ qGetQ = qRunQ getQ
+
+ -- | See 'putQ'.
+ qPutQ :: Typeable a => a -> m ()
+ qPutQ x = qRunQ $ putQ x
+
+ -- | See 'isExtEnabled'.
+ qIsExtEnabled :: Extension -> m Bool
+ qIsExtEnabled ext = qRunQ $ isExtEnabled ext
+ -- | See 'extsEnabled'.
+ qExtsEnabled :: m [Extension]
+ qExtsEnabled = qRunQ extsEnabled
+
+ -- | See 'putDoc'.
+ qPutDoc :: DocLoc -> String -> m ()
+ qPutDoc l s = qRunQ $ putDoc l s
+ -- | See 'getDoc'.
+ qGetDoc :: DocLoc -> m (Maybe String)
+ qGetDoc l = qRunQ $ getDoc l
+
+-- | \"Runs\" the 'Q' monad. Normal users of Template Haskell
+-- should not need this function, as the splice brackets @$( ... )@
+-- are the usual way of running a 'Q' computation.
+--
+-- This function is primarily used in GHC internals, and for debugging
+-- splices by running them in 'IO'.
+--
+-- Note that many functions in 'Q', such as 'reify' and other compiler
+-- queries, are not supported when running 'Q' in 'IO'; these operations
+-- simply fail at runtime. Indeed, the only operations guaranteed to succeed
+-- are 'newName', 'runIO', 'reportError' and 'reportWarning'.
+runQ :: Quasi m => Q a -> m a
+runQ = qRunQ
+
+-----------------------------------------------------
+-- The IO instance of Quasi
+-----------------------------------------------------
+
+-- | This instance is used only when running a Q
+-- computation in the IO monad, usually just to
+-- print the result. There is no interesting
+-- type environment, so reification isn't going to
+-- work.
+instance Quasi IO where
+ qRunQ (Q m) = m metaHandlersIO
+ qNewName = newNameIO
+
+ qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
+ qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
+ qRecover _ _ = badIO "recover" -- Maybe we could fix this?
+
+instance Quasi Q where
+ qRunQ = id
+ qRecover = recover
+
+
+-- | Report an error (True) or warning (False),
+-- but carry on; use 'fail' to stop.
+report :: Bool -> String -> Q ()
+report = Internal.report
+{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6
+
+-- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'.
+reportError :: String -> Q ()
+reportError = report True
+
+-- | Report a warning to the user, and carry on.
+reportWarning :: String -> Q ()
+reportWarning = report False
=====================================
testsuite/tests/interface-stability/template-haskell-exports.stdout
=====================================
@@ -354,7 +354,6 @@ module Language.Haskell.TH where
type Pred = Type
type PredQ :: *
type PredQ = Q Pred
- type role Q nominal
type Q :: * -> *
newtype Q a = ...
type Quote :: (* -> *) -> Constraint
@@ -655,7 +654,7 @@ module Language.Haskell.TH where
roleAnnotD :: forall (m :: * -> *). Quote m => Name -> [GHC.Internal.TH.Lib.Role] -> m Dec
ruleVar :: forall (m :: * -> *). Quote m => Name -> m RuleBndr
runIO :: forall a. GHC.Internal.Types.IO a -> Q a
- runQ :: forall (m :: * -> *) a. GHC.Internal.TH.Monad.Quasi m => Q a -> m a
+ runQ :: forall (m :: * -> *) a. Language.Haskell.TH.Syntax.Quasi m => Q a -> m a
safe :: Safety
sectionL :: forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
sectionR :: forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
@@ -1703,11 +1702,11 @@ module Language.Haskell.TH.Syntax where
data Pragma = InlineP Name Inline RuleMatch Phases | OpaqueP Name | SpecialiseEP (GHC.Internal.Maybe.Maybe [TyVarBndr ()]) [RuleBndr] Exp (GHC.Internal.Maybe.Maybe Inline) Phases | SpecialiseInstP Type | RuleP GHC.Internal.Base.String (GHC.Internal.Maybe.Maybe [TyVarBndr ()]) [RuleBndr] Exp Exp Phases | AnnP AnnTarget Exp | LineP GHC.Internal.Types.Int GHC.Internal.Base.String | CompleteP [Name] (GHC.Internal.Maybe.Maybe Name) | SCCP Name (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String)
type Pred :: *
type Pred = Type
- type role Q nominal
type Q :: * -> *
- newtype Q a = Q {unQ :: forall (m :: * -> *). Quasi m => m a}
+ newtype Q a = ...
type Quasi :: (* -> *) -> Constraint
class (GHC.Internal.Control.Monad.IO.Class.MonadIO m, GHC.Internal.Control.Monad.Fail.MonadFail m) => Quasi m where
+ qRunQ :: forall a. Q a -> m a
qNewName :: GHC.Internal.Base.String -> m Name
qReport :: GHC.Internal.Types.Bool -> GHC.Internal.Base.String -> m ()
qRecover :: forall a. m a -> m a -> m a
@@ -1730,13 +1729,13 @@ module Language.Haskell.TH.Syntax where
qAddForeignFilePath :: ForeignSrcLang -> GHC.Internal.Base.String -> m ()
qAddModFinalizer :: Q () -> m ()
qAddCorePlugin :: GHC.Internal.Base.String -> m ()
- qGetQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a)
- qPutQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m ()
+ qGetQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a)
+ qPutQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m ()
qIsExtEnabled :: Extension -> m GHC.Internal.Types.Bool
qExtsEnabled :: m [Extension]
qPutDoc :: DocLoc -> GHC.Internal.Base.String -> m ()
qGetDoc :: DocLoc -> m (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String)
- {-# MINIMAL qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddDependentDirectory, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-}
+ {-# MINIMAL qRunQ, qRecover #-}
type Quote :: (* -> *) -> Constraint
class GHC.Internal.Base.Monad m => Quote m where
newName :: GHC.Internal.Base.String -> m Name
@@ -1814,7 +1813,7 @@ module Language.Haskell.TH.Syntax where
falseName :: Name
getDoc :: DocLoc -> Q (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String)
getPackageRoot :: Q GHC.Internal.IO.FilePath
- getQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a)
+ getQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a)
get_cons_names :: Con -> [Name]
hoistCode :: forall (m :: * -> *) (n :: * -> *) (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r). GHC.Internal.Base.Monad m => (forall x. m x -> n x) -> Code m a -> Code n a
isExtEnabled :: Extension -> Q GHC.Internal.Types.Bool
@@ -1861,7 +1860,7 @@ module Language.Haskell.TH.Syntax where
oneName :: Name
pkgString :: PkgName -> GHC.Internal.Base.String
putDoc :: DocLoc -> GHC.Internal.Base.String -> Q ()
- putQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q ()
+ putQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q ()
recover :: forall a. Q a -> Q a -> Q a
reify :: Name -> Q Info
reifyAnnotations :: forall a. GHC.Internal.Data.Data.Data a => AnnLookup -> Q [a]
@@ -1884,6 +1883,7 @@ module Language.Haskell.TH.Syntax where
trueName :: Name
tupleDataName :: GHC.Internal.Types.Int -> Name
tupleTypeName :: GHC.Internal.Types.Int -> Name
+ unQ :: forall a. Q a -> forall (m :: * -> *). Quasi m => m a
unTypeCode :: forall (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r) (m :: * -> *). Quote m => Code m a -> m Exp
unTypeQ :: forall (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r) (m :: * -> *). Quote m => m (TExp a) -> m Exp
unboxedSumDataName :: SumAlt -> SumArity -> Name
@@ -2289,10 +2289,10 @@ instance forall a b c d e f g. (GHC.Internal.TH.Lift.Lift a, GHC.Internal.TH.Lif
instance GHC.Internal.TH.Lift.Lift (# #) -- Defined in ‘GHC.Internal.TH.Lift’
instance GHC.Internal.TH.Lift.Lift GHC.Internal.Prim.Char# -- Defined in ‘GHC.Internal.TH.Lift’
instance GHC.Internal.TH.Lift.Lift GHC.Internal.Prim.Word# -- Defined in ‘GHC.Internal.TH.Lift’
-instance GHC.Internal.TH.Monad.Quasi GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.TH.Monad’
-instance GHC.Internal.TH.Monad.Quasi GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.TH.Monad’
instance GHC.Internal.TH.Monad.Quote GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.TH.Monad’
instance GHC.Internal.TH.Monad.Quote GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.TH.Monad’
instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag GHC.Internal.TH.Syntax.BndrVis -- Defined in ‘Language.Haskell.TH.Lib’
instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag GHC.Internal.TH.Syntax.Specificity -- Defined in ‘Language.Haskell.TH.Lib’
instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag () -- Defined in ‘Language.Haskell.TH.Lib’
+instance Language.Haskell.TH.Syntax.Quasi GHC.Internal.Types.IO -- Defined in ‘Language.Haskell.TH.Syntax’
+instance Language.Haskell.TH.Syntax.Quasi GHC.Internal.TH.Monad.Q -- Defined in ‘Language.Haskell.TH.Syntax’
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/60315570ab5f008d925098c1fff0f40…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/60315570ab5f008d925098c1fff0f40…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/fix-prof-segv] Add test and changelog for #27123 fix.
by Andreas Klebinger (＠AndreasK) 19 Jun '26
by Andreas Klebinger (＠AndreasK) 19 Jun '26
19 Jun '26
Andreas Klebinger pushed to branch wip/andreask/fix-prof-segv at Glasgow Haskell Compiler / GHC
Commits:
62717c0e by Andreas Klebinger at 2026-06-19T08:31:21+00:00
Add test and changelog for #27123 fix.
- - - - -
3 changed files:
- + changelog.d/T27123.md
- + testsuite/tests/rts/T27123.hs
- testsuite/tests/rts/all.T
Changes:
=====================================
changelog.d/T27123.md
=====================================
@@ -0,0 +1,7 @@
+section: compiler
+synopsis: Fix two crashes that could happen in a multithreaded setting when profiling.
+description: There where two bugs that could cause occasional segfaults or crashes with
+an `PAP object entered` error when profiling. They only happened when two threads
+where racing to evaluate the same thunk, and specific GC timings.
+mrs: !16214
+issues: #27123
=====================================
testsuite/tests/rts/T27123.hs
=====================================
@@ -0,0 +1,65 @@
+{-# OPTIONS_GHC -fno-full-laziness -fno-worker-wrapper #-}
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+-- This test checks that the auto-apply code (stg_ap_0_fast, stg_ap_p) is robust
+-- against another thread or the GC evaluating a closure at the same time.
+
+module Main
+ -- (main)
+where
+
+import Control.Monad
+import Control.Concurrent
+import System.IO
+import GHC.Data.SmallArray
+import GHC.Exts
+import GHC.IO
+
+type Arr = SmallMutableArray RealWorld (Int->Int)
+
+io :: (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
+io f = IO f
+
+io_ :: (State# RealWorld -> State# RealWorld ) -> IO ()
+io_ f = IO (\s -> case f s of s2 -> (# s2, () #))
+
+{-# NOINLINE readSmallArray #-}
+readSmallArray (SmallMutableArray arr) (I# idx) = IO $ \s -> case readSmallArray# arr idx s of
+ (# s2, r #) -> (# s2, r #)
+
+-- Continually overwrites the array with unevaluated thunks that will evaluated to
+-- a PAP under profiling.
+{-# NOINLINE mkThunks #-}
+mkThunks :: Arr -> IO ()
+mkThunks arr = do
+ forever $ do
+ yield
+ forM_ [0..100] $ \_j -> do
+ forM_ [0..5 :: Int] $ \i -> do
+ -- With profiling results in a thunk that will evaluate to a PAP capturing the SCC
+ let g = {-# SCC g #-} succ
+ io_ (writeSmallArray arr i g)
+
+-- Evaluate the array repeatedly in the given order.
+{-# NOINLINE evaluateThunks #-}
+evaluateThunks :: Arr -> [Int] -> IO ()
+evaluateThunks arr idxs = do
+ forever $ do
+ yield
+ -- putStr "." >> hFlush stdout
+ forM [0..5000::Int] $ \j -> do
+ forM_ idxs $ \i -> do
+ !g <- readSmallArray arr i
+ seq (g i) (pure ())
+
+main :: IO ()
+main = do
+ -- We spawn three threads. Two are evaluating the thunks in the array in opposite directions
+ -- One thread is
+ arr <- io (newSmallArray 6 (id))
+ _ <- forkIO $ do
+ evaluateThunks arr [0..5]
+ _ <- forkIO $ do
+ evaluateThunks arr [5,4..0]
+ forkIO $ mkThunks arr
+ threadDelay 30_000_000
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -687,3 +687,5 @@ test('ClosureTable',
['-debug -O0 ClosureTable_c.c -I{top}/../rts -I{top}/../rts/include'])
test('resizeMutableByteArrayInPlace', [req_cmm, extra_ways(['optasm', 'sanity']), only_ways(['optasm', 'sanity'])], compile_and_run, [''])
+
+test('T27123', [extra_ways(['optasm', 'prof'])], compile_and_run, [''])
\ No newline at end of file
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/62717c0ecf776c842a8be86a7a8b2a8…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/62717c0ecf776c842a8be86a7a8b2a8…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/25924] CorePrep: Don't speculatively evaluate bindings that we have already discovered to be absent
by Zubin (＠wz1000) 19 Jun '26
by Zubin (＠wz1000) 19 Jun '26
19 Jun '26
Zubin pushed to branch wip/25924 at Glasgow Haskell Compiler / GHC
Commits:
409a285a by Zubin Duggal at 2026-06-19T13:43:33+05:30
CorePrep: Don't speculatively evaluate bindings that we have already discovered to be absent
In #25924, we segfault because speculation forces a projection out of a RUBBISH dictionary
(which we generated because it absent).
Solution: Don't speculate on bindings we already know are absent.
Fixes 25924
- - - - -
8 changed files:
- + changelog.d/fix-absent-dict-projection
- compiler/GHC/CoreToStg/Prep.hs
- + testsuite/tests/core-to-stg/T25924/B.hs
- + testsuite/tests/core-to-stg/T25924/Main.hs
- + testsuite/tests/core-to-stg/T25924/all.T
- + testsuite/tests/core-to-stg/T25924a.hs
- + testsuite/tests/core-to-stg/T25924a.stdout
- testsuite/tests/core-to-stg/all.T
Changes:
=====================================
changelog.d/fix-absent-dict-projection
=====================================
@@ -0,0 +1,5 @@
+section: compiler
+synopsis: Fix a CorePrep miscompilation that could project a field out of an absent dictionary, resulting in a segfault.
+issues: #25924
+mrs: !16219
+description: We no longer speculatively evaluate bindings that we have already discovered are absent.
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -2253,12 +2253,18 @@ decideFloatInfo FIA{fia_levity=lev, fia_demand=dmd, fia_is_hnf=is_hnf,
| is_string = (CaseBound, TopLvlFloatable)
-- String literals are unboxed (so must be case-bound) and float to
-- the top-level
- | ok_for_spec = (CaseBound, case lev of Unlifted -> LazyContextFloatable
+ | ok_for_spec
+ , not (isAbsDmd dmd) = (CaseBound, case lev of Unlifted -> LazyContextFloatable
Lifted -> TopLvlFloatable)
-- See Note [Speculative evaluation]
-- Ok-for-spec-eval things will be case-bound, lifted or not.
-- But when it's lifted we are ok with floating it to top-level
-- (where it is actually bound lazily).
+ --
+ -- Don't speculate an absent binding. Its RHS may project a field out of
+ -- a dictionary that we filled with a rubbish literal because the
+ -- dictionary was absent (see Note [Absent fillers]). Speculating it
+ -- forces that projection and results in a segfault. See #25924.
| Unlifted <- lev = (CaseBound, StrictContextFloatable)
| isStrUsedDmd dmd = (CaseBound, StrictContextFloatable)
-- These will never be floated out of a lazy RHS context
=====================================
testsuite/tests/core-to-stg/T25924/B.hs
=====================================
@@ -0,0 +1,89 @@
+{-# LANGUAGE AllowAmbiguousTypes, TypeFamilies, QuantifiedConstraints, TypeAbstractions #-}
+module B where
+
+import Data.Kind
+
+class ABITypeable a where
+ abiTypeInfo :: String
+ abiTypeInfo = ""
+
+ unused :: a -> a
+ unused x = x
+
+data REF a
+
+instance ABITypeable () where
+instance ABITypeable a => ABITypeable (REF a) where
+
+class (ABITypeable a, ABITypeable a) => YulCatObj a where -- crash stops without duplicate constraint
+instance YulCatObj ()
+instance YulCatObj a => YulCatObj (REF a)
+
+type YulO1 a = YulCatObj a
+type YulO2 a b = (YulCatObj a, YulCatObj b)
+
+
+type YulCat :: Type -> Type -> Type
+data YulCat a b where
+ YulExtendType :: forall b. (YulO2 () b) => YulCat () b
+ YulComp :: forall a b c. YulCat c b -> YulCat a c -> YulCat a b
+ YulJmpB :: forall a b. (YulO2 a b) => YulCat a b
+
+data Trie a b where
+ Z :: Trie a a
+ (:.) :: (YulCatObj a, YulCatObj b) => YulCat a b -> Trie b c -> Trie a c
+
+type Cat a b = forall c. Trie b c -> Trie a c
+
+normalize :: forall a b unused ξ. (Int ~ unused, YulCatObj a, YulCatObj b)
+ => Trie a b -> (forall c. YulCatObj c => Trie a c -> YulCat c b -> ξ) -> ξ
+normalize t0 k = case t0 of
+ Z -> k Z undefined
+ φ :. f -> normalize f $ \f' s -> case f' of
+ Z -> k Z (s `YulComp` φ)
+ _ -> undefined
+
+
+toSMC :: forall a b . (YulCatObj a, YulCatObj b) => Cat a b -> YulCat a b
+toSMC t = normalize (t Z) $ \f g -> case f of
+ Z -> g
+ _ -> error "toSMC: normalisation process failed"
+
+
+encode :: (YulCatObj r, YulCatObj a, YulCatObj b) => (a `YulCat` b) -> (P r a -> P r b)
+encode φ (Y f) = Y (\x -> f (φ :. x))
+
+
+type P :: Type -> Type -> Type
+data P r a = Y (Cat r a)
+
+fromP :: P r a -> Cat r a
+fromP (Y f) = f
+
+
+decode :: (YulCatObj a, YulCatObj b) => (P a a -> P a b) -> YulCat a b
+decode f = toSMC (extract f)
+
+extract ::(YulCatObj a, YulCatObj b) => (P a a -> P a b) -> Cat a b
+extract f = fromP (f (Y id))
+
+
+yulShow :: YulCat a' b' -> String
+yulShow (YulExtendType @b) = "Te" <> abiTypeInfo @b
+yulShow (YulComp cb ac) = yulShow ac <> yulShow cb
+yulShow YulJmpB = "Jb"
+
+
+lfn' :: forall b unused.
+ ( YulO1 (REF b)
+ , () ~ unused
+ ) =>
+ (forall r. YulO1 r => P r () -> P r (REF b)) -> String
+lfn' f = yulShow (decode f)
+
+
+extendType'l :: forall a r. (YulO1 a, YulO1 r) => P r () -> P r a
+extendType'l = encode YulExtendType
+
+keccak256'l :: forall a r. YulO2 r a => P r a -> P r ()
+keccak256'l = encode YulJmpB
=====================================
testsuite/tests/core-to-stg/T25924/Main.hs
=====================================
@@ -0,0 +1,14 @@
+module Main where
+import B
+
+getCounterRef' :: forall b r.
+ ( YulO1 b
+ , YulO1 r
+ -- , YulO1 (REF b)
+ ) =>
+ P r () -> P r (REF b)
+getCounterRef' a = extendType'l (keccak256'l a)
+{-# NOINLINE getCounterRef' #-}
+
+main :: IO ()
+main = putStrLn $ lfn' @() getCounterRef'
=====================================
testsuite/tests/core-to-stg/T25924/all.T
=====================================
@@ -0,0 +1,4 @@
+test('T25924',
+ [exit_code(1), ignore_stderr, extra_files(['Main.hs', 'B.hs'])],
+ multimod_compile_and_run,
+ ['Main', '-O'])
=====================================
testsuite/tests/core-to-stg/T25924a.hs
=====================================
@@ -0,0 +1,31 @@
+{-# LANGUAGE GADTs, TypeApplications, ScopedTypeVariables, AllowAmbiguousTypes #-}
+module Main where
+
+class D a where
+ m :: a -> Int
+ m _ = 0
+ n :: a -> Int
+ n _ = 0
+
+class (D a, D a) => C a
+
+data T a
+
+instance D a => D (T a)
+instance C a => C (T a)
+
+instance D ()
+instance C ()
+
+data G where
+ MkG :: forall a. C (T a) => T a -> G
+
+sh :: G -> Int
+sh (MkG x) = m x
+
+f :: forall b. C b => G
+f = MkG (undefined :: T b)
+{-# NOINLINE f #-}
+
+main :: IO ()
+main = print (sh (f @()))
=====================================
testsuite/tests/core-to-stg/T25924a.stdout
=====================================
@@ -0,0 +1 @@
+0
=====================================
testsuite/tests/core-to-stg/all.T
=====================================
@@ -8,3 +8,4 @@ test('T24124', normal, compile, ['-O -ddump-stg-final -dno-typeable-binds -dsupp
test('T23865', normal, compile, ['-O -dlint'])
test('T24334', normal, compile_and_run, ['-O'])
test('T24463', normal, compile, ['-O'])
+test('T25924a', [ignore_stderr], compile_and_run, ['-O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/409a285ae0c05ddbf1f2c69812f7957…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/409a285ae0c05ddbf1f2c69812f7957…
You're receiving this email because of your account on gitlab.haskell.org.
1
0