[Git][ghc/ghc][wip/T24676] More wibbles... finally getting there

Simon Peyton Jones (@simonpj) gitlab at gitlab.haskell.org
Wed May 29 23:06:18 UTC 2024



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


Commits:
6eb79d1a by Simon Peyton Jones at 2024-05-30T00:03:14+01:00
More wibbles... finally getting there

- - - - -


3 changed files:

- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Utils/Unify.hs


Changes:

=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -161,7 +161,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 fun_ctxt tc_fun fun_sigma rn_args
-       ; _tc_args <- tcValArgs inst_args
+       ; mapM_ (tcValArg do_ql) inst_args
        ; return app_res_sigma }
 
 {- *********************************************************************
@@ -363,25 +363,25 @@ tcApp rn_expr exp_res_ty
 
        -- Typecheck the arguments
        ; ds_flag <- getDeepSubsumptionFlag
-       ; finishApp ds_flag rn_expr fun_ctxt tc_fun inst_args app_res_rho exp_res_ty }
+       ; finishApp do_ql ds_flag rn_expr fun_ctxt tc_fun inst_args app_res_rho exp_res_ty }
 
 setQLInstLevel :: QLFlag -> TcM a -> TcM a
 setQLInstLevel DoQL thing_inside = setTcLevel QLInstVar thing_inside
 setQLInstLevel NoQL thing_inside = thing_inside
 
-finishApp :: DeepSubsumptionFlag -> HsExpr GhcRn  -> AppCtxt
+finishApp :: QLFlag -> DeepSubsumptionFlag -> HsExpr GhcRn  -> AppCtxt
           -> HsExpr GhcTc -> [HsExprArg 'TcpInst]
           -> TcRhoType  -- Inferred type of the application;
                         --   zonked, but maybe not deeply instantiated
           -> ExpRhoType -- Expected type; this is deeply skolemised
           -> TcM (HsExpr GhcTc)
 -- At this point there are no more instantiation variables
-finishApp ds_flag rn_expr fun_ctxt tc_fun inst_args app_res_rho exp_res_ty
+finishApp do_ql ds_flag rn_expr fun_ctxt tc_fun inst_args app_res_rho exp_res_ty
   = do { res_wrap <- checkResTy ds_flag rn_expr fun_ctxt tc_fun inst_args
                                 app_res_rho exp_res_ty
 
        -- Typecheck the value arguments
-       ;  tc_args <- tcValArgs inst_args
+       ;  tc_args <- mapM (tcValArg do_ql) inst_args
 
        -- Horrible newtype check
        ; rejectRepPolyNewtypes tc_fun app_res_rho
@@ -393,7 +393,7 @@ finishApp ds_flag rn_expr fun_ctxt tc_fun inst_args app_res_rho exp_res_ty
 
        ; 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 pprHsExprArgTc inst_args)
+            ; 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
@@ -421,17 +421,18 @@ checkResTy ds_flag rn_expr fun_ctxt tc_fun inst_args app_res_rho (Check res_ty)
 -- Match up app_res_rho: the result type of rn_expr
 --     with res_ty:  the expected result type
  = perhaps_add_res_ty_ctxt $
-   do { traceTc "unifyResTy {" $
+   do { traceTc "checkResTy {" $
           vcat [ text "tc_fun:" <+> ppr tc_fun
                , text "app_res_rho:" <+> ppr app_res_rho
-               , text "res_ty:"  <+> ppr res_ty ]
+               , text "res_ty:"  <+> ppr res_ty
+               , text "ds_flag:" <+> ppr ds_flag ]
       ; case ds_flag of
           Shallow -> -- No deep subsumption
              -- app_res_rho and res_ty are both rho-types,
              -- so with simple subsumption we can just unify them
              -- No need to zonk; the unifier does that
              do { co <- unifyExprType rn_expr app_res_rho res_ty
-                ; traceTc "unifyResTy 1 }" (ppr co)
+                ; traceTc "checkResTy 1 }" (ppr co)
                 ; return (mkWpCastN co) }
 
           Deep ->   -- Deep subsumption
@@ -441,7 +442,7 @@ checkResTy ds_flag rn_expr fun_ctxt tc_fun inst_args app_res_rho (Check res_ty)
              -- Zonk app_res_rho first, because QL may have instantiated some
              -- delta variables to polytypes, and tcSubType doesn't expect that
              do { wrap <- tcSubTypeDS rn_expr app_res_rho res_ty
-                ; traceTc "unifyResTy 2 }" (ppr app_res_rho $$ ppr res_ty)
+                ; traceTc "checkResTy 2 }" (ppr app_res_rho $$ ppr res_ty)
                 ; return wrap } }
   where
     -- perhaps_add_res_ty_ctxt: Inside an expansion, the addFunResCtxt stuff is
@@ -471,28 +472,24 @@ quickLookKeys = [dollarIdKey, leftSectionKey, rightSectionKey]
 -- see what is going on.  For that reason, it is not a full zonk: add
 -- more if you need it.
 zonkArg :: HsExprArg 'TcpInst -> ZonkM (HsExprArg 'TcpInst)
-zonkArg eva@(EValArg { ea_arg_ty = (do_zonk, Scaled m ty) })
+zonkArg eva@(EValArg { ea_arg_ty = Scaled m ty })
   = do { ty' <- zonkTcType ty
-       ; return (eva { ea_arg_ty = (do_zonk, Scaled m ty') }) }
+       ; return (eva { ea_arg_ty = Scaled m ty' }) }
 zonkArg arg = return arg
 
 
 
 ----------------
 
-tcValArgs :: [HsExprArg 'TcpInst]    -- Actual argument
-          -> TcM [HsExprArg 'TcpTc]  -- Resulting argument
-tcValArgs  args = mapM tcValArg 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 :: 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 (EValArg { ea_ctxt   = ctxt
-                  , ea_arg    = larg@(L arg_loc arg)
-                  , ea_arg_ty = (do_zonk, Scaled mult exp_arg_ty) })
+tcValArg do_ql (EValArg { ea_ctxt   = ctxt
+                        , ea_arg    = larg@(L arg_loc arg)
+                        , ea_arg_ty = Scaled mult exp_arg_ty })
   = addArgCtxt ctxt larg $
     do { traceTc "tcValArg" $
          vcat [ ppr ctxt
@@ -508,7 +505,7 @@ tcValArg (EValArg { ea_ctxt   = ctxt
          -- Then Theta = [p :-> forall a. a->a], and we want
          -- to check 'e' with expected type (forall a. a->a)
          -- See Note [Instantiation variables are short lived]
-       ; exp_arg_ty <- case do_zonk of
+       ; exp_arg_ty <- case do_ql of
               DoQL -> liftZonkM $ zonkTcType exp_arg_ty
               NoQL -> return exp_arg_ty
 
@@ -520,21 +517,21 @@ tcValArg (EValArg { ea_ctxt   = ctxt
                          , ea_arg = L arg_loc arg'
                          , ea_arg_ty = noExtField }) }
 
-tcValArg (EValArgQL { eaql_status  = ql_status
-                    , eaql_ctxt    = ctxt
-                    , eaql_arg_ty  = Scaled mult exp_arg_ty
-                    , eaql_larg    = larg@(L arg_loc rn_expr)
-                    , eaql_head    = rn_head
-                    , eaql_tc_fun  = tc_fun
-                    , eaql_args    = inst_args
-                    , eaql_res_rho = app_res_rho })
+tcValArg _ (EValArgQL { eaql_status  = ql_status
+                      , eaql_ctxt    = ctxt
+                      , eaql_arg_ty  = Scaled mult exp_arg_ty
+                      , eaql_larg    = larg@(L arg_loc rn_expr)
+                      , eaql_head    = rn_head
+                      , eaql_tc_fun  = tc_fun
+                      , eaql_args    = inst_args
+                      , eaql_res_rho = app_res_rho })
   = addArgCtxt ctxt larg $
     tcScalingUsage mult  $
     case ql_status of
       QLUnified  -- We have decided to unify (no generalisation or deep subsumption)
         ->       -- So pass Shallow to finishAPp
-           do { tc_app <- finishApp Shallow rn_expr ctxt tc_fun inst_args app_res_rho
-                                    (mkCheckExpType exp_arg_ty)
+           do { tc_app <- finishApp DoQL Shallow rn_expr ctxt tc_fun inst_args
+                                    app_res_rho (mkCheckExpType exp_arg_ty)
               ; return (EValArg { ea_ctxt   = ctxt
                                 , ea_arg    = L arg_loc tc_app
                                 , ea_arg_ty = noExtField }) }
@@ -556,8 +553,8 @@ tcValArg (EValArgQL { eaql_status  = ql_status
                          ; qlUnify app_res_rho exp_arg_rho
                          ; monomorphiseQLInstVars inst_args app_res_rho
                          ; app_res_rho <- liftZonkM $ zonkTcType app_res_rho
-                         ; finishApp ds_flag rn_expr ctxt tc_fun inst_args app_res_rho
-                                             (mkCheckExpType exp_arg_rho) }
+                         ; finishApp DoQL ds_flag rn_expr ctxt tc_fun inst_args
+                                     app_res_rho (mkCheckExpType exp_arg_rho) }
 
               ; traceTc "tcEValArgQL }" $
                   vcat [ text "rn_head:" <+> ppr rn_head
@@ -1658,20 +1655,20 @@ quickLookArg :: QLFlag -> AppCtxt
 --   (a) the call itself
 --   (b) the arguments of the call
 quickLookArg NoQL ctxt larg orig_arg_ty
-  = skipQuickLook NoQL ctxt larg orig_arg_ty
+  = skipQuickLook ctxt larg orig_arg_ty
 quickLookArg DoQL ctxt larg orig_arg_ty
   = do { is_rho <- tcIsDeepRho (scaledThing orig_arg_ty)
        ; traceTc "qla" (ppr orig_arg_ty $$ ppr is_rho)
        ; if not is_rho
-         then skipQuickLook DoQL ctxt larg orig_arg_ty
+         then skipQuickLook ctxt larg orig_arg_ty
          else quickLookArg1 ctxt larg orig_arg_ty }
 
-skipQuickLook :: QLFlag -> AppCtxt -> LHsExpr GhcRn -> Scaled TcRhoType
+skipQuickLook :: AppCtxt -> LHsExpr GhcRn -> Scaled TcRhoType
               -> TcM (HsExprArg 'TcpInst)
-skipQuickLook do_ql ctxt larg arg_ty
+skipQuickLook ctxt larg arg_ty
   = return (EValArg { ea_ctxt   = ctxt
                     , ea_arg    = larg
-                    , ea_arg_ty = (do_ql, arg_ty)  })
+                    , ea_arg_ty = arg_ty })
     -- do_ql <=> remember to zonk this argument in tcValArg
 
 tcIsDeepRho :: TcType -> TcM Bool
@@ -1722,7 +1719,7 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
               , text "args:" <+> ppr rn_args ]
 
        ; case mb_fun_ty of {
-           Nothing -> skipQuickLook DoQL ctxt larg sc_arg_ty ;    -- fun is too complicated
+           Nothing -> skipQuickLook ctxt larg sc_arg_ty ;    -- fun is too complicated
            Just (tc_fun, fun_sigma) ->
 
        -- Step 2: use |-inst to instantiate the head applied to the arguments
@@ -1804,10 +1801,13 @@ monomorphiseQLInstVars inst_args res_rho
     go_val_arg_ql inst_args rho = do { mapM_ go_arg inst_args; go_ty rho }
 
     go_arg :: HsExprArg 'TcpInst -> TcM ()
-    go_arg (EValArg { ea_arg_ty = (_, arg_ty) })   -- Ignore the DoQL part; f $ (g x) with -XNoImpredicativeTypes
+    go_arg (EValArg { ea_arg_ty = arg_ty })
+      = go_ty (scaledThing arg_ty)
+    go_arg (EValArgQL { eaql_status = QLUnified {}, eaql_args = args
+                      , eaql_res_rho = rho, eaql_arg_ty = arg_ty })
+      = do { go_ty (scaledThing arg_ty); go_val_arg_ql args rho }
+    go_arg (EValArgQL { eaql_status = QLIndependent {}, eaql_arg_ty = arg_ty })
       = go_ty (scaledThing arg_ty)
-    go_arg (EValArgQL { eaql_status = QLUnified {}, eaql_args = args, eaql_res_rho = rho })
-      = go_val_arg_ql args rho
     go_arg _ = return ()
 
     go_ty :: TcType -> TcM ()


=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -20,7 +20,7 @@ module GHC.Tc.Gen.Head
        , AppCtxt(..), appCtxtLoc, insideExpansion
        , splitHsApps, rebuildHsApps
        , addArgWrap, isHsValArg
-       , leadingValArgs, isVisibleArg, pprHsExprArgTc
+       , leadingValArgs, isVisibleArg
 
        , tcInferAppHead, tcInferAppHead_maybe
        , tcInferId, tcCheckId, obviousSig
@@ -198,12 +198,7 @@ type family XETAType (p :: TcPass) where  -- Type arguments
   XETAType _      = Type
 
 type family XEVAType (p :: TcPass) where   -- Value arguments
-  XEVAType 'TcpInst = (QLFlag, Scaled TcSigmaType)
-     -- QLFlag = DoQL => we /are/ doing Quick Look,
-     --   but this particular arg did not contribute; in this case
-     --   we must zonk the type to expose the foralls from other args
-     --   (If it did contribute, we'd be in EValArgQL.)
-
+  XEVAType 'TcpInst = Scaled TcSigmaType
   XEVAType _        = NoExtField
 
 data QLFlag = DoQL | NoQL
@@ -433,20 +428,23 @@ isVisibleArg (ETypeArg {}) = True
 isVisibleArg _             = False
 
 instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where
-  ppr (EValArg { ea_arg = arg })      = text "EValArg" <+> ppr arg
   ppr (EPrag _ p)                     = text "EPrag" <+> ppr p
   ppr (ETypeArg { ea_hs_ty = hs_ty }) = char '@' <> ppr hs_ty
   ppr (EWrap wrap)                    = ppr wrap
+  ppr (EValArg { ea_arg = arg })
+    = text "EValArg" <+> ppr arg
   ppr (EValArgQL { eaql_head = fun, eaql_args = args, eaql_res_rho = ty})
     = hang (text "EValArgQL" <+> ppr fun)
          2 (vcat [ ppr args, text "ea_ql_ty:" <+> ppr ty ])
 
 pprArgInst :: HsExprArg 'TcpInst -> SDoc
-pprArgInst (EValArg { ea_arg = arg, ea_arg_ty = ty }) = hang (text "EValArg" <+> ppr arg)
-                                                           2 (text "arg_ty" <+> ppr ty)
-pprArgInst (EPrag _ p)                      = text "EPrag" <+> ppr p
+-- Ugh!  A special version for 'TcpInst, se we can print the arg_ty of EValArg
+pprArgInst (EPrag _ p)                     = text "EPrag" <+> ppr p
 pprArgInst (ETypeArg { ea_hs_ty = hs_ty }) = char '@' <> ppr hs_ty
-pprArgInst (EWrap wrap)                     = ppr wrap
+pprArgInst (EWrap wrap)                    = ppr wrap
+pprArgInst (EValArg { ea_arg = arg, ea_arg_ty = ty })
+  = hang (text "EValArg" <+> ppr arg)
+       2 (text "arg_ty" <+> ppr ty)
 pprArgInst (EValArgQL { eaql_head = fun, eaql_args = args, eaql_res_rho = ty})
   = hang (text "EValArgQL" <+> ppr fun)
        2 (vcat [ vcat (map pprArgInst args), text "ea_ql_ty:" <+> ppr ty ])
@@ -461,11 +459,6 @@ instance Outputable EWrap where
   ppr (EHsWrap w)    = text "EHsWrap" <+> ppr w
   ppr (EExpand orig) = text "EExpand" <+> ppr orig
 
-pprHsExprArgTc :: HsExprArg 'TcpInst -> SDoc
-pprHsExprArgTc (EValArg { ea_arg = tm, ea_arg_ty = ty })
-  = text "EValArg" <+> hang (ppr tm) 2 (dcolon <+> ppr ty)
-pprHsExprArgTc arg = ppr arg
-
 {- Note [Desugar OpApp in the typechecker]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Operator sections are desugared in the renamer; see GHC.Rename.Expr


=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -1790,6 +1790,10 @@ doesn't do it yet, awaiting credible user demand.  See #24696.
 
 data DeepSubsumptionFlag = Deep | Shallow
 
+instance Outputable DeepSubsumptionFlag where
+    ppr Deep    = text "Deep"
+    ppr Shallow = text "Shallow"
+
 getDeepSubsumptionFlag :: TcM DeepSubsumptionFlag
 getDeepSubsumptionFlag = do { ds <- xoptM LangExt.DeepSubsumption
                             ; if ds then return Deep else return Shallow }



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6eb79d1a433b220c4a5d78c954c0c8148c9c5a7a

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6eb79d1a433b220c4a5d78c954c0c8148c9c5a7a
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/20240529/aa9733df/attachment-0001.html>


More information about the ghc-commits mailing list