Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
-
8fed9248
by Apoorv Ingle at 2025-11-26T23:31:45-06:00
-
5e9b41d5
by Apoorv Ingle at 2025-11-27T01:14:17-06:00
5 changed files:
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/Unify.hs
Changes:
| ... | ... | @@ -296,7 +296,11 @@ dsExpr e@(XExpr ext_expr_tc) |
| 296 | 296 | WrapExpr {} -> dsApp e
|
| 297 | 297 | ConLikeTc {} -> dsApp e
|
| 298 | 298 | |
| 299 | - ExpandedThingTc _ e -> dsExpr e
|
|
| 299 | + ExpandedThingTc o e
|
|
| 300 | + | OrigStmt (L loc _) _ <- o -- c.f. T14546d. We have lost the location of the first statement in the GhcRn -> GhcTc
|
|
| 301 | + -> putSrcSpanDsA loc $ dsExpr e
|
|
| 302 | + | otherwise -> dsExpr e
|
|
| 303 | + |
|
| 300 | 304 | -- Hpc Support
|
| 301 | 305 | HsTick tickish e -> do
|
| 302 | 306 | e' <- dsLExpr e
|
| ... | ... | @@ -1997,10 +1997,12 @@ quickLookArg1 :: Int -> SrcSpan -> (HsExpr GhcRn, SrcSpan) -> LHsExpr GhcRn |
| 1997 | 1997 | -> Scaled TcRhoType -- Deeply skolemised
|
| 1998 | 1998 | -> TcM (HsExprArg 'TcpInst)
|
| 1999 | 1999 | -- quickLookArg1 implements the "QL Argument" judgement in Fig 5 of the paper
|
| 2000 | -quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
|
|
| 2000 | +quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L arg_loc arg) sc_arg_ty@(Scaled _ orig_arg_rho)
|
|
| 2001 | 2001 | = addArgCtxt pos (fun, fun_lspan) larg $ -- Context needed for constraints
|
| 2002 | 2002 | -- generated by calls in arg
|
| 2003 | - do { ((rn_fun_arg, fun_lspan_arg), rn_args) <- splitHsApps arg
|
|
| 2003 | + do { ((rn_fun_arg, fun_lspan_arg'), rn_args) <- splitHsApps arg
|
|
| 2004 | + ; let fun_lspan_arg | null rn_args = locA arg_loc -- arg is an id (or an XExpr) so use the arg_loc in tcInstFun
|
|
| 2005 | + | otherwise = fun_lspan_arg'
|
|
| 2004 | 2006 | |
| 2005 | 2007 | -- Step 1: get the type of the head of the argument
|
| 2006 | 2008 | ; (fun_ue, mb_fun_ty) <- tcCollectingUsage $ tcInferAppHead_maybe rn_fun_arg
|
| ... | ... | @@ -2027,13 +2029,14 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _ |
| 2027 | 2029 | ; ds_flag_arg <- getDeepSubsumptionFlag_DataConHead tc_fun_arg_head
|
| 2028 | 2030 | ; ((inst_args, app_res_rho), wanted)
|
| 2029 | 2031 | <- captureConstraints $
|
| 2030 | - tcInstFun do_ql True ds_flag_arg (arg_orig, rn_fun_arg, fun_lspan_arg) tc_fun_arg_head fun_sigma_arg_head rn_args
|
|
| 2032 | + tcInstFun do_ql True ds_flag_arg (arg_orig, rn_fun_arg, fun_lspan_arg) tc_fun_arg_head fun_sigma_arg_head rn_args
|
|
| 2031 | 2033 | -- We must capture type-class and equality constraints here, but
|
| 2032 | 2034 | -- not equality constraints. See (QLA6) in Note [Quick Look at
|
| 2033 | 2035 | -- value arguments]
|
| 2034 | 2036 | |
| 2035 | 2037 | ; traceTc "quickLookArg 2" $
|
| 2036 | 2038 | vcat [ text "arg:" <+> ppr arg
|
| 2039 | + , text "orig:" <+> ppr arg_orig
|
|
| 2037 | 2040 | , text "orig_arg_rho:" <+> ppr orig_arg_rho
|
| 2038 | 2041 | , text "app_res_rho:" <+> ppr app_res_rho ]
|
| 2039 | 2042 |
| ... | ... | @@ -404,11 +404,13 @@ tcDoStmts doExpr@(DoExpr _) ss@(L l stmts) res_ty |
| 404 | 404 | then do { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
|
| 405 | 405 | ; res_ty <- readExpType res_ty
|
| 406 | 406 | ; return (HsDo res_ty doExpr (L l stmts')) }
|
| 407 | - else do { expanded_expr <- expandDoStmts doExpr stmts -- Do expansion on the fly
|
|
| 407 | + else do { (L expr_lspan expanded_expr) <- expandDoStmts doExpr stmts -- Do expansion on the fly
|
|
| 408 | + ; traceTc "tcDoStmts" (vcat [ppr expr_lspan, ppr expanded_expr])
|
|
| 408 | 409 | ; let orig = HsDo noExtField doExpr ss
|
| 409 | - ; addExpansionErrCtxt (OrigExpr orig) (srcCodeOriginErrCtxMsg (OrigExpr orig)) $
|
|
| 410 | - do { e' <- tcMonoLExpr expanded_expr res_ty
|
|
| 411 | - ; return (mkExpandedExprTc orig (unLoc e'))}
|
|
| 410 | + ; mkExpandedExprTc orig <$> (
|
|
| 411 | + setSrcSpanA expr_lspan $ -- We lose this expr_lspan location in GhcTc :(
|
|
| 412 | + addExpansionErrCtxt (OrigExpr orig) (srcCodeOriginErrCtxMsg (OrigExpr orig)) $
|
|
| 413 | + tcExpr expanded_expr res_ty )
|
|
| 412 | 414 | }
|
| 413 | 415 | }
|
| 414 | 416 |
| ... | ... | @@ -1328,7 +1328,6 @@ setErrCtxt ctxt = updLclEnv (setLclEnvErrCtxt ctxt) |
| 1328 | 1328 | |
| 1329 | 1329 | -- | Add a fixed message to the error context. This message should not
|
| 1330 | 1330 | -- do any tidying.
|
| 1331 | --- NB. No op in generated code
|
|
| 1332 | 1331 | -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr
|
| 1333 | 1332 | addErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a
|
| 1334 | 1333 | {-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt]
|
| ... | ... | @@ -1339,7 +1338,6 @@ addExpansionErrCtxt :: SrcCodeOrigin -> ErrCtxtMsg -> TcM a -> TcM a |
| 1339 | 1338 | addExpansionErrCtxt o msg = addExpansionErrCtxtM o (\env -> return (env, msg))
|
| 1340 | 1339 | |
| 1341 | 1340 | -- | Add a message to the error context. This message may do tidying.
|
| 1342 | --- NB. No op in generated code
|
|
| 1343 | 1341 | -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr
|
| 1344 | 1342 | addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a
|
| 1345 | 1343 | {-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt]
|
| ... | ... | @@ -1363,16 +1361,10 @@ addLandmarkErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM |
| 1363 | 1361 | {-# INLINE addLandmarkErrCtxtM #-} -- Note [Inlining addErrCtxt]
|
| 1364 | 1362 | addLandmarkErrCtxtM ctxt = pushCtxt (MkErrCtxt LandmarkUserSrcCode ctxt)
|
| 1365 | 1363 | |
| 1366 | --- | NB. no op in generated code
|
|
| 1367 | 1364 | -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr
|
| 1368 | 1365 | pushCtxt :: ErrCtxt -> TcM a -> TcM a
|
| 1369 | 1366 | {-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt]
|
| 1370 | -pushCtxt ctxt = updLclEnv (updCtxt ctxt)
|
|
| 1371 | - |
|
| 1372 | -updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv
|
|
| 1373 | --- Do not update the context if we are in generated code
|
|
| 1374 | --- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr
|
|
| 1375 | -updCtxt ctxt env = addLclEnvErrCtxt ctxt env
|
|
| 1367 | +pushCtxt ctxt = updLclEnv (addLclEnvErrCtxt ctxt)
|
|
| 1376 | 1368 | |
| 1377 | 1369 | popErrCtxt :: TcM a -> TcM a
|
| 1378 | 1370 | popErrCtxt thing_inside = updLclEnv (\env -> setLclEnvErrCtxt (pop $ getLclEnvErrCtxt env) env) $
|
| ... | ... | @@ -2460,7 +2460,7 @@ unifyTypeAndEmit t_or_k orig ty1 ty2 |
| 2460 | 2460 | , u_given_eq_lvl = cur_lvl
|
| 2461 | 2461 | , u_rewriters = emptyCoHoleSet -- ToDo: check this
|
| 2462 | 2462 | , u_defer = ref, u_what = WU_None }
|
| 2463 | - |
|
| 2463 | + ; traceTc "unifyTypeAndEmit" (ppr t_or_k)
|
|
| 2464 | 2464 | -- The hard work happens here
|
| 2465 | 2465 | ; co <- uType env ty1 ty2
|
| 2466 | 2466 |