[Git][ghc/ghc][wip/T24676] More wibbles

Simon Peyton Jones (@simonpj) gitlab at gitlab.haskell.org
Mon Jun 3 21:25:41 UTC 2024



Simon Peyton Jones pushed to branch wip/T24676 at Glasgow Haskell Compiler / GHC


Commits:
801075df by Simon Peyton Jones at 2024-06-03T22:25:02+01:00
More wibbles

- - - - -


3 changed files:

- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Zonk/TcType.hs


Changes:

=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -51,7 +51,6 @@ import GHC.Core.Coercion
 import GHC.Builtin.Types ( multiplicityTy )
 import GHC.Builtin.PrimOps( tagToEnumKey )
 import GHC.Builtin.Names
-import GHC.Driver.DynFlags
 
 import GHC.Types.Var
 import GHC.Types.Name
@@ -167,7 +166,7 @@ tcInferSigma inst (L loc rn_expr)
        ; do_ql <- wantQuickLook rn_fun
        ; (tc_fun, fun_sigma) <- tcInferAppHead fun
        ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst (tc_fun, fun_ctxt) fun_sigma rn_args
-       ; mapM_ (tcValArg do_ql) inst_args
+       ; _ <- tcValArgs do_ql inst_args
        ; return app_res_sigma }
 
 {- *********************************************************************
@@ -275,24 +274,41 @@ tcApp works like this:
    /its/ argument(s), in this case (h x).  And so on recursively.  Key
    point: all these instantiations make instantiation variables.
 
-4. Use quickLookResultType to take a quick look at the result type,
-   when in checking mode.  This is the shaded part of APP-Downarrow
-   in Fig 5.
+Now we split into two cases:
 
-5. Then we call finishApp to finish the job
+4. Case NoQL: no Quick Look
 
-6. finishApp uses qlZonkTcType to expose what we have learned from
-   Quick Look (if Quick Look is being used for this application)
+   4.1 Use checkResultTy to connect the the result type.
+       Do this /before/ checking the arguments; see
+       Note [Unify with expected type before typechecking arguments]
 
-7. Then call checkResultTy to match up the result type of the call
-   with that expected by the context.  See Note [Unify with
-   expected type before typechecking arguments]
+   4.2 Check the arguments with `tcValArgs`.
 
-8. Use tcValArgs to typecheck the value arguments
+   4.3 Use `finishApp` to wrap up.
 
-9. Horrible newtype check
+5. Case DoQL: use Quick Look
+
+   5.1 Use `quickLookResultType` to take a quick look at the result type,
+       when in checking mode.  This is the shaded part of APP-Downarrow
+       in Fig 5.  It also implements the key part of
+       Note [Unify with expected type before typechecking arguments]
+
+   5.2 Check the arguments with `tcValArgs`. Importantly, this will monomorphise
+       all the instantiation variables of the call.  See Note [qlMonoTcType]
+
+   5.3 Use `zonkTcType` to expose the polymophism hidden under instantiation
+       variables in `app_res_rho`, and the monomorphic versions of any
+       un-unified instantiation variables.
+
+   5.4 Use `checkResTy` to do the subsumption check as usual
+
+   5.4 Use `finishApp` to wrap up
+
+The funcion `finishApp` mainly calls `rebuildHsApps` to rebuild the
+application; but it also does a couple of gruesome final checks:
+  * Horrible newtype check
+  * Special case for tagToEnum
 
-10. After a gruesome special case for tagToEnum, rebuild the result.
 
 Some cases that /won't/ work:
 
@@ -373,65 +389,56 @@ tcApp rn_expr exp_res_ty
                                          -- Note [tcApp: typechecking applications]
                  tcInstFun do_ql True tc_head fun_sigma rn_args
 
-       -- Step 3: Take a quick look at the result type
-       ; quickLookResultType do_ql app_res_rho exp_res_ty
-
-       -- Finish up
-       ; finishApp do_ql rn_expr tc_head inst_args app_res_rho exp_res_ty }
+       ; case do_ql of
+            NoQL -> do { -- Step 4.1: subsumption check against expecte result type
+                         -- See Note [Unify with expected type before typechecking arguments]
+                         res_wrap <- checkResultTy rn_expr tc_head inst_args
+                                                   app_res_rho exp_res_ty
+                         -- Step 4.2: typecheck the  arguments
+                       ; tc_args <- tcValArgs NoQL inst_args
+                         -- Step 4.3: wrap up
+                       ; finishApp tc_head tc_args app_res_rho res_wrap }
+
+            DoQL -> do { -- Step 5.1: Take a quick look at the result type
+                         quickLookResultType app_res_rho exp_res_ty
+                         -- Step 5.2: typecheck the arguments, and monomorphise
+                         --           any un-unified instantiation variables
+                       ; tc_args <- tcValArgs DoQL inst_args
+                         -- Step 5.3: typecheck the arguments
+                       ; app_res_rho <- liftZonkM $ zonkTcType app_res_rho
+                         -- Step 5.4: subsumption check against the expected type
+                       ; res_wrap <- checkResultTy rn_expr tc_head inst_args
+                                                   app_res_rho exp_res_ty
+                         -- Step 5.5: wrap up
+                       ; finishApp tc_head tc_args app_res_rho res_wrap } }
 
 setQLInstLevel :: QLFlag -> TcM a -> TcM a
 setQLInstLevel DoQL thing_inside = setTcLevel QLInstVar thing_inside
 setQLInstLevel NoQL thing_inside = thing_inside
 
-quickLookResultType :: QLFlag -> TcRhoType -> ExpRhoType -> TcM ()
+quickLookResultType :: TcRhoType -> ExpRhoType -> TcM ()
 -- This function implements the shaded bit of rule APP-Downarrow in
 -- Fig 5 of the QL paper: "A quick look at impredicativity" (ICFP'20).
-quickLookResultType DoQL app_res_rho (Check exp_rho) = qlUnify app_res_rho exp_rho
-quickLookResultType _    _           _               = return ()
-
-finishApp :: QLFlag -> HsExpr GhcRn
-          -> (HsExpr GhcTc, AppCtxt)   -- Head of the application
-          -> [HsExprArg 'TcpInst]      -- Args of the application
-          -> TcRhoType  -- Inferred type of the application
-          -> ExpRhoType -- Expected type; this is deeply skolemised
+quickLookResultType app_res_rho (Check exp_rho) = qlUnify app_res_rho exp_rho
+quickLookResultType  _           _              = return ()
+
+finishApp :: (HsExpr GhcTc, AppCtxt) -> [HsExprArg 'TcpTc]
+          -> TcRhoType -> HsWrapper
           -> TcM (HsExpr GhcTc)
-finishApp do_ql rn_expr tc_head@(tc_fun,_) inst_args app_res_rho exp_res_ty
-  = do { -- Step 6: qlZonk the type of the result of the call
-         -- See Note [QuickLook zonking] in GHC.Tc.Zonk.TcType
-         traceTc "finishApp" $ vcat [ ppr app_res_rho, ppr exp_res_ty ]
-       ; app_res_rho <- case do_ql of
-            DoQL -> liftZonkM $ qlZonkTcType app_res_rho
-            NoQL -> return app_res_rho
-
-       -- Step 7: check the result type
-       ; res_wrap <- checkResultTy rn_expr tc_head inst_args
-                                   app_res_rho exp_res_ty
-
-       -- step 8: Typecheck the value arguments
-       ;  tc_args <- mapM (tcValArg do_ql) inst_args
-
-       -- Step 9: Horrible newtype check
+-- Do final checks and wrap up the result
+finishApp tc_head@(tc_fun,_) tc_args app_res_rho res_wrap
+  = do { -- Horrible newtype check
        ; rejectRepPolyNewtypes tc_head app_res_rho
 
-       -- Step 10: econstruct, with a special case for tagToEnum#.
-       ; tc_expr <- if isTagToEnum tc_fun
-                    then tcTagToEnum tc_head tc_args app_res_rho
-                    else return (rebuildHsApps tc_head tc_args)
-
-       ; whenDOptM Opt_D_dump_tc_trace $
-         do { inst_args <- liftZonkM $ mapM zonkArg inst_args  -- Only when tracing
-            ; traceTc "tcApp }" (vcat [ text "inst_args"    <+> brackets (pprWithCommas pprArgInst inst_args)
-                                      , text "app_res_rho:" <+> ppr app_res_rho
-                                      , text "tc_fun:"      <+> ppr tc_fun
-                                      , text "tc_args:"     <+> ppr tc_args
-                                      , text "tc_expr:"     <+> ppr tc_expr ]) }
-
-       ; return (mkHsWrap res_wrap tc_expr) }
-
+       -- Reconstruct, with a horrible special case for tagToEnum#.
+       ; res_expr <- if isTagToEnum tc_fun
+                     then tcTagToEnum tc_head tc_args app_res_rho
+                     else return (rebuildHsApps tc_head tc_args)
+       ; return (mkHsWrap res_wrap res_expr) }
 
 checkResultTy :: HsExpr GhcRn
               -> (HsExpr GhcTc, AppCtxt)  -- Head
-              -> [HsExprArg p]            -- Arguments
+              -> [HsExprArg p]            -- Arguments, just error messages
               -> TcRhoType  -- Inferred type of the application; zonked to
                             --   expose foralls, but maybe not deeply instantiated
               -> ExpRhoType -- Expected type; this is deeply skolemised
@@ -486,11 +493,20 @@ checkResultTy rn_expr (tc_fun, fun_ctxt) inst_args app_res_rho (Check res_ty)
         thing_inside
 
 ----------------
+tcValArgs :: QLFlag -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc]
+-- Importantly, tcValArgs works left-to-right, so that by the time we
+-- encounter an argument, we have monomorphised all the instantiation
+-- variables that its type contains.  All that is left to do is an ordinary
+-- zonkTcType.  See Note [Monomorphise instantiation variables].
+tcValArgs do_ql args = mapM (tcValArg do_ql) args
+
 tcValArg :: QLFlag -> HsExprArg 'TcpInst    -- Actual argument
          -> TcM (HsExprArg 'TcpTc)          -- Resulting argument
-tcValArg _ (EPrag l p)           = return (EPrag l (tcExprPrag p))
-tcValArg _ (EWrap w)             = return (EWrap w)
-tcValArg _ (ETypeArg l hs_ty ty) = return (ETypeArg l hs_ty ty)
+tcValArg _     (EPrag l p)         = return (EPrag l (tcExprPrag p))
+tcValArg _     (ETypeArg l hty ty) = return (ETypeArg l hty ty)
+tcValArg do_ql (EWrap (EHsWrap w)) = do { whenQL do_ql $ qlMonoHsWrapper w
+                                        ; return (EWrap (EHsWrap w)) }
+tcValArg _     (EWrap ew)          = return (EWrap ew)
 
 tcValArg do_ql (EValArg { ea_ctxt   = ctxt
                         , ea_arg    = larg@(L arg_loc arg)
@@ -512,7 +528,7 @@ tcValArg do_ql (EValArg { ea_ctxt   = ctxt
          -- See Note [Instantiation variables are short lived]
          -- and Note [QuickLook zonking] in GHC.Tc.Zonk.TcType
        ; Scaled mult exp_arg_ty <- case do_ql of
-              DoQL -> liftZonkM $ qlZonkScaledTcType sc_arg_ty
+              DoQL -> liftZonkM $ zonkScaledTcType sc_arg_ty
               NoQL -> return sc_arg_ty
 
          -- Now check the argument
@@ -533,7 +549,7 @@ tcValArg _ (EValArgQL { eaql_wanted  = wanted
                       , eaql_res_rho = app_res_rho })
   = addArgCtxt ctxt larg $
     do { -- Expose QL results to tcSkolemise, as in EValArg case
-         Scaled mult exp_arg_ty <- liftZonkM $ qlZonkScaledTcType sc_arg_ty
+         Scaled mult exp_arg_ty <- liftZonkM $ zonkScaledTcType sc_arg_ty
 
        ; traceTc "tcEValArgQL {" (vcat [ text "app_res_rho:" <+> ppr app_res_rho
                                        , text "exp_arg_ty:" <+> ppr exp_arg_ty
@@ -547,13 +563,16 @@ tcValArg _ (EValArgQL { eaql_wanted  = wanted
                     -- See (QLA4) in Note [Quick Look at value arguments]
                     emitConstraints wanted
 
-                    -- Unify with context if we have no already done so
+                    -- Unify with context if we have not already done so
                     -- See (QLA4) in Note [Quick Look at value arguments]
                   ; unless arg_influences_enclosing_call $  -- Don't repeat
                     qlUnify app_res_rho exp_arg_rho         -- the qlUnify
 
-                  ; finishApp DoQL rn_expr tc_head inst_args
-                              app_res_rho (mkCheckExpType exp_arg_rho) }
+                  ; tc_args <- tcValArgs DoQL inst_args
+                  ; app_res_rho <- liftZonkM $ zonkTcType app_res_rho
+                  ; res_wrap <- checkResultTy rn_expr tc_head inst_args
+                                              app_res_rho (mkCheckExpType exp_arg_rho)
+                  ; finishApp tc_head tc_args app_res_rho res_wrap }
 
        ; traceTc "tcEValArgQL }" $
            vcat [ text "app_res_rho:" <+> ppr app_res_rho ]
@@ -574,6 +593,7 @@ quickLookKeys :: [Unique]
 -- See Note [Quick Look for particular Ids]
 quickLookKeys = [dollarIdKey, leftSectionKey, rightSectionKey]
 
+{-
 -- zonkArg is used *only* during debug-tracing, to make it easier to
 -- see what is going on.  For that reason, it is not a full zonk: add
 -- more if you need it.
@@ -582,6 +602,7 @@ zonkArg eva@(EValArg { ea_arg_ty = Scaled m ty })
   = do { ty' <- zonkTcType ty
        ; return (eva { ea_arg_ty = Scaled m ty' }) }
 zonkArg arg = return arg
+-}
 
 {- *********************************************************************
 *                                                                      *
@@ -1530,19 +1551,17 @@ at its arguments.  This is quadratic in the nesting depth of the arguments.
 Instead, after the quick look, we /save/ the work we have done in an EValArgQL
 record, and /resume/ it later.  The way to think of it is this:
 
-  * `tcApp` typechecks an application.  It is strutured into two:
-      - the "initial" part, especially `tcInstFun`
-      - the "finish" part, `finishApp`, which completes the job
+  * `tcApp` typechecks an application.  It uses `tcInstFun`, which in turn
+    calls `quickLookArg` on each value argument.
 
-  * quickLookArg (which takes a quick look at the argument)
+  * `quickLookArg` (which takes a quick look at the argument)
 
       - Does the "initial" part of `tcApp`, especially `tcInstFun`
 
       - Captures the result in an EValArgQL record
 
       - Later, `tcValArg` starts from the EValArgQL record, and
-        completes the job of tpyechecking the appication by calling
-        `finishApp`
+        completes the job of typechecking the application
 
 This turned out to be more subtle than I expected.  Wrinkles:
 
@@ -1609,7 +1628,10 @@ skipQuickLook ctxt larg arg_ty
   = return (EValArg { ea_ctxt   = ctxt
                     , ea_arg    = larg
                     , ea_arg_ty = arg_ty })
-    -- do_ql <=> remember to zonk this argument in tcValArg
+
+whenQL :: QLFlag -> ZonkM () -> TcM ()
+whenQL DoQL thing_inside = liftZonkM thing_inside
+whenQL NoQL _            = return ()
 
 tcIsDeepRho :: TcType -> TcM Bool
 -- This top-level zonk step, which is the reason we need a local 'go' loop,
@@ -1711,6 +1733,87 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
 *                                                                      *
 ********************************************************************* -}
 
+{- Note [Monomorphise instantiation variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we are done with Quick Look on a call, we must turn any un-unified
+/instantiation/ variables into regular /unification/ variables.  This is the
+lower-case 'theta' (a mono-substitution) in the APP-DOWN rule of Fig 5 of the
+Quick Look paper.
+
+We so this by look at the arguments, left to right, monomorphising the free
+instantiation variables of the /type/ arguments of the call.  Those type
+arguments appear (only) in
+  * the `WpTyApp` components of
+  * the `HsWrapper` of
+  * a `EWrap` argument
+See `qlMonoHsWrapper`.
+
+By going left to right, we are sure to monomorphise instantiation variables
+before we encounter them in an argument type (in `tcValArg`).
+
+To monomorphise the free QL instantiation variables of a type, we use
+`foldQLInstVars`.
+
+Wrinkles:
+
+(MIV1) When monomorphising an instantiation variable, don't forget to
+   monomorphise its kind. It might have type (a :: TYPE k), where both
+  `a` and `k` are instantiation variables.
+
+(MIV2) In `qlUnify`, `make_kinds_ok` may unify
+    a :: k1  ~  b :: k2
+  making a cast
+    a := b |> (co :: k1 ~ k2)
+  But now suppose k1 is an instantiation variable.  Then that coercion hole
+  `co` is the only place that `k1` will show up in the traversal, and yet
+  we want to monomrphise it.  Hence the do_hole in `foldQLInstTyVars`
+-}
+
+qlMonoHsWrapper :: HsWrapper -> ZonkM ()
+qlMonoHsWrapper (WpCompose w1 w2) = qlMonoHsWrapper w1 >> qlMonoHsWrapper w2
+qlMonoHsWrapper (WpTyApp ty)      = qlMonoTcType ty
+qlMonoHsWrapper _                 = return ()
+
+qlMonoTcType :: TcType -> ZonkM ()
+qlMonoTcType ty
+  = do { traceZonk "monomorphiseQLInstVars {" (ppr ty)
+       ; go_ty ty
+       ; traceZonk "monomorphiseQLInstVars }" empty }
+  where
+    go_ty :: TcType -> ZonkM ()
+    go_ty ty = unTcMUnit (foldQLInstVars go_tv ty)
+
+    go_tv :: TcTyVar -> TcMUnit
+    -- Precondition: tv is a QL instantiation variable
+    -- If it is already unified, look through it and carry on
+    -- If not, monomorphise it, by making a fresh unification variable,
+    -- at the ambient level
+    go_tv tv
+      | MetaTv { mtv_ref = ref, mtv_tclvl = lvl, mtv_info = info } <- tcTyVarDetails tv
+      = assertPpr (case lvl of QLInstVar -> True; _ -> False) (ppr tv) $
+        TCMU $ do { traceZonk "qlMonoTcType" (ppr tv)
+                  ; flex <- readTcRef ref
+                  ; case flex of {
+                      Indirect ty -> go_ty ty ;
+                      Flexi       ->
+               do { let kind = tyVarKind tv
+                  ; go_ty kind  -- See (MIV1) in Note [Monomorphise instantiation variables]
+                  ; ref2  <- newTcRef Flexi
+                  ; lvl2  <- getZonkTcLevel
+                  ; let details = MetaTv { mtv_info  = info
+                                         , mtv_ref   = ref2
+                                         , mtv_tclvl = lvl2 }
+                        tv2  = mkTcTyVar (tyVarName tv) kind details
+                 ; writeTcRef ref (Indirect (mkTyVarTy tv2)) }}}
+      | otherwise
+      = pprPanic "qlMonoTcType" (ppr tv)
+
+newtype TcMUnit = TCMU { unTcMUnit :: ZonkM () }
+instance Semigroup TcMUnit where
+  TCMU ml <> TCMU mr = TCMU (ml >> mr)
+instance Monoid TcMUnit where
+  mempty = TCMU (return ())
+
 {- Note [The fiv test in quickLookArg]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In rule APP-lightning-bolt in Fig 5 of the paper, we have to test rho_r


=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -16,7 +16,7 @@
 -}
 
 module GHC.Tc.Gen.Head
-       ( HsExprArg(..), TcPass(..), QLFlag(..)
+       ( HsExprArg(..), TcPass(..), QLFlag(..), EWrap(..)
        , AppCtxt(..), appCtxtLoc, insideExpansion
        , splitHsApps, rebuildHsApps
        , addArgWrap, isHsValArg


=====================================
compiler/GHC/Tc/Zonk/TcType.hs
=====================================
@@ -15,15 +15,12 @@ module GHC.Tc.Zonk.TcType
     module GHC.Tc.Zonk.Monad
 
     -- ** Zonking types
-  , zonkTcType, zonkTcTypes
+  , zonkTcType, zonkTcTypes, zonkScaledTcType
   , zonkTcTyVar, zonkTcTyVars
   , zonkTcTyVarToTcTyVar, zonkTcTyVarsToTcTyVars
   , zonkInvisTVBinder
   , zonkCo
 
-    -- ** Quick-look zonking
-  , qlZonkTcType, qlZonkScaledTcType
-
     -- ** Zonking 'TyCon's
   , zonkTcTyCon
 
@@ -196,103 +193,6 @@ These functions just wrap writeTcRef, with some extra tracing
 See for example test T5631, which regresses without this change.
 -}
 
-{-
-************************************************************************
-*                                                                      *
-       QuickLook zonking
-*                                                                      *
-************************************************************************
--}
-
-{- Note [QuickLook zonking]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we are done with the QuickLook, we must
-* Expose the polytypes hidden inside now-unified instantiation
-  variables, by zonking the types involved.
-* Turn any still-un-unified QL instantiation variables into regular
-  unification variables, with a now-known level.
-
-These tasks are performed simultaneously by `qlZonkTcType`. It behaves very
-similarly to the regular `zonkTcType`, except that /in addition/ it turns any
-un-filled-in instantiation variable kappa into a monotype, using
-`monomorphiseQLInstVar`.  The latter creates a fresh unification variable, say
-alpha[lvl], and unifiying kappa := alpha.
-
-It is very simple and satisfying that the two tasks can be done as one.
--}
-
-qlZonkScaledTcType :: Scaled TcType -> ZonkM (Scaled TcType)
-qlZonkScaledTcType (Scaled m ty)
-  = Scaled <$> qlZonkTcType m <*> qlZonkTcType ty
-
-qlZonkTcType :: TcType   -> ZonkM TcType
-qlZonkCo     :: Coercion -> ZonkM Coercion
--- See Note [QuickLook zonking]
-(qlZonkTcType, _, qlZonkCo, _)
-  = mapTyCo mapper
-  where
-    mapper :: TyCoMapper () ZonkM
-    mapper = TyCoMapper
-      { tcm_tyvar      = const qlzonk_tc_tyvar
-      , tcm_covar      = const (\cv -> mkCoVarCo <$> qlzonk_tcv cv)
-      , tcm_hole       = qlzonk_hole
-      , tcm_tycobinder = \ _env tcv _vis k -> qlzonk_tcv tcv >>= k ()
-      , tcm_tycon      = return }
-
-    qlzonk_hole :: () -> CoercionHole -> ZonkM Coercion
-    qlzonk_hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })
-      = do { contents <- readTcRef ref
-           ; case contents of
-               Just co -> qlZonkCo co
-               Nothing -> do { cv' <- qlzonk_tcv cv
-                             ; return $ HoleCo (hole { ch_co_var = cv' }) } }
-
-    qlzonk_tcv :: TyCoVar -> ZonkM TyCoVar
-    qlzonk_tcv tcv = do { kind' <- qlZonkTcType (varType tcv)
-                        ; return (setVarType tcv kind') }
-
-    qlzonk_tc_tyvar :: TcTyVar -> ZonkM TcType
-    qlzonk_tc_tyvar tv
-      | isTcTyVar tv
-      = case tcTyVarDetails tv of
-          SkolemTv {}   -> qlzonk_kind_and_return tv
-          RuntimeUnk {} -> qlzonk_kind_and_return tv
-          MetaTv { mtv_ref = ref, mtv_tclvl = lvl, mtv_info = info }
-             -> do { cts <- readTcRef ref
-                   ; case cts of
-                        Indirect ty -> do { ty' <- qlZonkTcType ty
-                                          ; writeTcRef ref (Indirect ty')
-                                            -- See Note [Sharing in zonking]
-                                          ; return ty' }
-                        Flexi | QLInstVar <- lvl
-                              -> do { ty' <- monomorphiseQLInstTyVar tv info
-                                    ; writeTcRef ref (Indirect ty')
-                                    ; return ty' }
-                              | otherwise
-                              -> qlzonk_kind_and_return tv }
-
-      | otherwise -- coercion variable
-      = qlzonk_kind_and_return tv
-      where
-
-    qlzonk_kind_and_return :: TcTyVar -> ZonkM TcType
-    qlzonk_kind_and_return tv
-      = do { tv' <- qlzonk_tcv tv
-           ; return (mkTyVarTy tv') }
-
-monomorphiseQLInstTyVar :: TcTyVar -> MetaInfo -> ZonkM TcType
--- Make a fresh ordinary unification variable, with the same
--- Name and MetaInfo as the current one
--- Precondition: the MetaInfo argument is that of the TcTyVar
-monomorphiseQLInstTyVar tv info
-  = do { ref  <- newTcRef Flexi
-       ; lvl  <- getZonkTcLevel
-       ; kind <- qlZonkTcType (tyVarKind tv)
-       ; let details = MetaTv  {mtv_info = info, mtv_ref = ref, mtv_tclvl = lvl }
-             new_tv  = mkTcTyVar (tyVarName tv) kind details
-       ; return (mkTyVarTy new_tv) }
-
-
 {-
 ************************************************************************
 *                                                                      *
@@ -301,6 +201,10 @@ monomorphiseQLInstTyVar tv info
 ************************************************************************
 -}
 
+zonkScaledTcType :: Scaled TcType -> ZonkM (Scaled TcType)
+zonkScaledTcType (Scaled m ty)
+  = Scaled <$> zonkTcType m <*> zonkTcType ty
+
 -- For unbound, mutable tyvars, zonkType uses the function given to it
 -- For tyvars bound at a for-all, zonkType zonks them to an immutable
 --      type variable and zonks the kind too



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/801075dff6202767a9f300ec0b0a5af587afd49c

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/801075dff6202767a9f300ec0b0a5af587afd49c
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240603/3956a336/attachment-0001.html>


More information about the ghc-commits mailing list