diff options
Diffstat (limited to 'compiler/GHC/HsToCore/Expr.hs')
| -rw-r--r-- | compiler/GHC/HsToCore/Expr.hs | 125 |
1 files changed, 78 insertions, 47 deletions
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 88dc4f7d45..6b8ced95ad 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -1140,15 +1140,26 @@ ds_withDict wrapped_ty -- `meth_tvs = a_1 ... a_n` and `co` is a newtype coercion between -- `C` and `meth_ty`. , Just (inst_meth_ty, co) <- instNewTyCon_maybe dict_tc dict_args + -- co :: C t1 ..tn ~R# st -- Check that `st` is equal to `meth_ty[t_i/a_i]`. , st `eqType` inst_meth_ty - = do { sv <- newSysLocalDs mult1 st + = do { sv <- newSysLocalDs mult1 st ; k <- newSysLocalDs mult2 dt_to_r - ; pure $ mkLams [sv, k] $ Var k `App` Cast (Var sv) (mkSymCo co) } + ; let wd_rhs = mkLams [sv, k] $ Var k `App` Cast (Var sv) (mkSymCo co) + ; wd_id <- newSysLocalDs Many (exprType wd_rhs) + ; let wd_id' = wd_id `setInlinePragma` inlineAfterSpecialiser + ; pure $ Let (NonRec wd_id' wd_rhs) (Var wd_id') } + -- Why a Let? See (WD8) in Note [withDict] | otherwise = errDsCoreExpr (DsInvalidInstantiationDictAtType wrapped_ty) +inlineAfterSpecialiser :: InlinePragma +-- Do not inline before the specialiser; but do so afterwards +-- See (WD8) in Note [withDict] +inlineAfterSpecialiser = alwaysInlinePragma `setInlinePragmaActivation` + ActiveAfter NoSourceText 2 + {- Note [withDict] ~~~~~~~~~~~~~~~~~~ The identifier `withDict` is just a place-holder, which is used to @@ -1202,7 +1213,7 @@ Where: That is, C must be a class with exactly one method and no superclasses. * The `mtype` argument to withDict must be equal to `meth_type[t_i/a_i]`, - which is instantied type of C's method. + which is instantiated type of C's method. * `co` is a newtype coercion that, when applied to `t_1 ... t_n`, coerces from `C t_1 ... t_n` to `mtype`. This coercion is guaranteed to exist by virtue of @@ -1213,66 +1224,86 @@ These requirements are implemented in the guards in ds_withDict's definition. Some further observations about `withDict`: -* Every use of `withDict` must be instantiated at a /particular/ class C. - It's a bit like representation polymorphism: we don't allow class-polymorphic - calls of `withDict`. We check this in the desugarer -- and then we - can immediately replace this invocation of `withDict` with appropriate - class-specific Core code. +(WD1) Every use of `withDict` must be instantiated at a /particular/ class C. + It's a bit like representation polymorphism: we don't allow class-polymorphic + calls of `withDict`. We check this in the desugarer -- and then we + can immediately replace this invocation of `withDict` with appropriate + class-specific Core code. + +(WD2) The `dt` in the type of withDict must be explicitly instantiated with + visible type application, as invoking `withDict` would be ambiguous + otherwise. + + For examples of how `withDict` is used in the `base` library, see `withSNat` + in GHC.TypeNats, as well as `withSChar` and `withSSymbol` in GHC.TypeLits. + +(WD3) The `r` is representation-polymorphic, to support things like + `withTypeable` in `Data.Typeable.Internal`. -* The `dt` in the type of withDict must be explicitly instantiated with - visible type application, as invoking `withDict` would be ambiguous - otherwise. +(WD4) As an alternative to `withDict`, one could define functions like `withT` + above in terms of `unsafeCoerce`. This is more error-prone, however. -* For examples of how `withDict` is used in the `base` library, see `withSNat` - in GHC.TypeNats, as well as `withSChar` and `withSSymbol` in GHC.TypeLits. +(WD5) In order to define things like `reifySymbol` below: -* The `r` is representation-polymorphic, - to support things like `withTypeable` in `Data.Typeable.Internal`. + reifySymbol :: forall r. String -> (forall (n :: Symbol). KnownSymbol n => r) -> r -* As an alternative to `withDict`, one could define functions like `withT` - above in terms of `unsafeCoerce`. This is more error-prone, however. + `withDict` needs to be instantiated with `Any`, like so: -* In order to define things like `reifySymbol` below: + reifySymbol n k = withDict @String @(KnownSymbol Any) @r n (k @Any) - reifySymbol :: forall r. String -> (forall (n :: Symbol). KnownSymbol n => r) -> r + The use of `Any` is explained in Note [NOINLINE someNatVal] in + base:GHC.TypeNats. - `withDict` needs to be instantiated with `Any`, like so: +(WD6) The only valid way to apply `withDict` is as described above. Applying + `withDict` in any other way will result in a non-recoverable error during + desugaring. In other words, GHC will never execute the `withDict` function + in compiled code. - reifySymbol n k = withDict @String @(KnownSymbol Any) @r n (k @Any) + In theory, this means that we don't need to define a binding for `withDict` + in GHC.Magic.Dict. In practice, we define a binding anyway, for two reasons: - The use of `Any` is explained in Note [NOINLINE someNatVal] in - base:GHC.TypeNats. + - To give it Haddocks, and + - To define the type of `withDict`, which GHC can find in + GHC.Magic.Dict.hi. -* The only valid way to apply `withDict` is as described above. Applying - `withDict` in any other way will result in a non-recoverable error during - desugaring. In other words, GHC will never execute the `withDict` function - in compiled code. + Because we define a binding for `withDict`, we have to provide a right-hand + side for its definition. We somewhat arbitrarily choose: - In theory, this means that we don't need to define a binding for `withDict` - in GHC.Magic.Dict. In practice, we define a binding anyway, for two reasons: + withDict = panicError "Non rewritten withDict"# - - To give it Haddocks, and - - To define the type of `withDict`, which GHC can find in - GHC.Magic.Dict.hi. + This should never be reachable anyway, but just in case ds_withDict fails + to rewrite away `withDict`, this ensures that the program won't get very far. - Because we define a binding for `withDict`, we have to provide a right-hand - side for its definition. We somewhat arbitrarily choose: +(WD7) One could conceivably implement this special case for `withDict` as a + constant-folding rule instead of during desugaring. We choose not to do so + for the following reasons: - withDict = panicError "Non rewritten withDict"# + - Having a constant-folding rule would require that `withDict`'s definition + be wired in to the compiler so as to prevent `withDict` from inlining too + early. Implementing the special case in the desugarer, on the other hand, + only requires that `withDict` be known-key. - This should never be reachable anyway, but just in case ds_withDict fails - to rewrite away `withDict`, this ensures that the program won't get very far. + - If the constant-folding rule were to fail, we want to throw a compile-time + error, which is trickier to do with the way that GHC.Core.Opt.ConstantFold + is set up. -* One could conceivably implement this special case for `withDict` as a - constant-folding rule instead of during desugaring. We choose not to do so - for the following reasons: +(WD8) In fact we desugar `withDict @{rr} @mtype @(C t_1 ... t_n) @r` to + let wd = \sv k -> k (sv |> co) + {-# INLINE [2] #-} + in wd - - Having a constant-folding rule would require that `withDict`'s definition - be wired in to the compiler so as to prevent `withDict` from inlining too - early. Implementing the special case in the desugarer, on the other hand, - only requires that `withDict` be known-key. + The local `let` and INLINE pragma delays inlining `wd` until after the + type-class Specialiser has run. This is super important. Suppose we + have calls + withDict A k + withDict B k + where k1, k2 :: C T -> blah. If we inline those withDict calls we'll get + k (A |> co1) + k (B |> co2) + and the Specialiser will assume that those arguments (of type `C T`) are + the same, will specialise `k` for that type, and will call the same, + specialised function from both call sites. #21575 is a concrete case in point. - - If the constant-folding rule were to fail, we want to throw a compile-time - error, which is trickier to do with the way that GHC.Core.Opt.ConstantFold - is set up. + Solution: delay inlining `withDict` until after the specialiser; that is, + until Phase 2. This is not a Final Solution -- seee #21575 "Alas..". -} |