- ghc-commits - Haskell.org

[Git][ghc/ghc] Pushed new branch wip/aidylns/RecConWildE
by Adriaan Leijnse (＠aidylns) 09 Jun '25

09 Jun '25

Adriaan Leijnse pushed new branch wip/aidylns/RecConWildE at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/aidylns/RecConWildE You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: haddock: Parse math even after ordinary characters
by Marge Bot (＠marge-bot) 09 Jun '25

09 Jun '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 6558467c by Ryan Hendrickson at 2025-06-06T05:46:58-04:00 haddock: Parse math even after ordinary characters Fixes a bug where math sections were not recognized if preceded by a character that isn't special (like space or a markup character). - - - - - 265d0024 by ARATA Mizuki at 2025-06-06T05:47:48-04:00 AArch64 NCG: Fix sub-word arithmetic right shift As noted in Note [Signed arithmetic on AArch64], we should zero-extend sub-word values. Fixes #26061 - - - - - 05e9be18 by Simon Hengel at 2025-06-06T05:48:35-04:00 Allow Unicode in "message" and "hints" with -fdiagnostics-as-json (fixes #26075) - - - - - bfa6b70f by ARATA Mizuki at 2025-06-06T05:49:24-04:00 x86 NCG: Fix code generation of bswap64 on i386 Co-authored-by: sheaf <sam.derbyshire(a)gmail.com> Fix #25601 - - - - - 35826d8b by Matthew Pickering at 2025-06-08T22:00:41+01:00 Hadrian: Add option to generate .hie files for stage1 libraries The +hie_files flavour transformer can be enabled to produce hie files for stage1 libraries. The hie files are produced in the "extra-compilation-artifacts" folder and copied into the resulting bindist. At the moment the hie files are not produced for the release flavour, they add about 170M to the final bindist. Towards #16901 - - - - - 70cdcb7b by Ryan Hendrickson at 2025-06-09T08:16:00-04:00 Fix various failures to -fprint-unicode-syntax - - - - - 36 changed files: - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Types/Error.hs - hadrian/doc/flavours.md - hadrian/doc/user-settings.md - hadrian/src/Context.hs - hadrian/src/Context/Path.hs - hadrian/src/Flavour.hs - hadrian/src/Flavour/Type.hs - hadrian/src/Settings/Builders/Ghc.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Flavours/Release.hs - + testsuite/tests/cmm/should_run/T25601.hs - + testsuite/tests/cmm/should_run/T25601.stdout - + testsuite/tests/cmm/should_run/T25601a.cmm - testsuite/tests/cmm/should_run/all.T - + testsuite/tests/codeGen/should_run/T26061.hs - + testsuite/tests/codeGen/should_run/T26061.stdout - testsuite/tests/codeGen/should_run/all.T - testsuite/tests/driver/json.stderr - testsuite/tests/driver/json_warn.stderr - testsuite/tests/ghci/scripts/T12550.stdout - testsuite/tests/ghci/scripts/T8959b.stderr - testsuite/tests/ghci/scripts/all.T - + testsuite/tests/ghci/scripts/print-unicode-syntax.script - + testsuite/tests/ghci/scripts/print-unicode-syntax.stderr - + testsuite/tests/ghci/scripts/print-unicode-syntax.stdout - testsuite/tests/ghci/should_run/T11825.stdout - utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs - utils/haddock/haddock-library/test/Documentation/Haddock/ParserSpec.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eec6dd1bca51e5cec11a1f2f740dfb… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eec6dd1bca51e5cec11a1f2f740dfb… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26107] Fix EPT enforcement when mixing unboxed tuples and non-tuples
by Krzysztof Gogolewski (＠monoidal) 09 Jun '25

09 Jun '25

Krzysztof Gogolewski pushed to branch wip/T26107 at Glasgow Haskell Compiler / GHC Commits: 4187c2e3 by Krzysztof Gogolewski at 2025-06-09T13:00:25+02:00 Fix EPT enforcement when mixing unboxed tuples and non-tuples The code was assuming that an alternative cannot be returning a normal datacon and an unboxed tuple at the same time. However, as seen in #26107, this can happen when using a GADT to refine the representation type. The solution is just to conservatively return TagDunno. - - - - - 3 changed files: - compiler/GHC/Stg/EnforceEpt/Types.hs - + testsuite/tests/rep-poly/T26107.hs - testsuite/tests/rep-poly/all.T Changes: ===================================== compiler/GHC/Stg/EnforceEpt/Types.hs ===================================== @@ -39,8 +39,8 @@ type InferStgAlt = GenStgAlt 'InferTaggedBinders combineAltInfo :: TagInfo -> TagInfo -> TagInfo combineAltInfo TagDunno _ = TagDunno combineAltInfo _ TagDunno = TagDunno -combineAltInfo (TagTuple {}) TagProper = panic "Combining unboxed tuple with non-tuple result" -combineAltInfo TagProper (TagTuple {}) = panic "Combining unboxed tuple with non-tuple result" +combineAltInfo (TagTuple {}) TagProper = TagDunno -- This can happen with rep-polymorphic result, see #26107 +combineAltInfo TagProper (TagTuple {}) = TagDunno -- This can happen with rep-polymorphic result, see #26107 combineAltInfo TagProper TagProper = TagProper combineAltInfo (TagTuple is1) (TagTuple is2) = TagTuple (zipWithEqual combineAltInfo is1 is2) combineAltInfo (TagTagged) ti = ti ===================================== testsuite/tests/rep-poly/T26107.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE GADTs, UnboxedTuples #-} +module T26107 where + +import Data.Kind +import GHC.Exts + +type T :: TYPE rep -> Type +data T a where + A :: T Bool + B :: T (# #) + +f :: forall rep (a :: TYPE rep). T a -> a +f A = True +f B = (# #) ===================================== testsuite/tests/rep-poly/all.T ===================================== @@ -41,6 +41,7 @@ test('T23883a', normal, compile_fail, ['']) test('T23883b', normal, compile_fail, ['']) test('T23883c', normal, compile_fail, ['']) test('T23903', normal, compile_fail, ['']) +test('T26107', normal, compile, ['-O']) test('EtaExpandDataCon', normal, compile, ['-O']) test('EtaExpandStupid1', normal, compile, ['-Wno-deprecated-flags']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4187c2e389759c1b1393e8d24d68f7d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4187c2e389759c1b1393e8d24d68f7d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T26107
by Krzysztof Gogolewski (＠monoidal) 09 Jun '25

09 Jun '25

Krzysztof Gogolewski pushed new branch wip/T26107 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T26107 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/amg/castz] WIP: introduce cast zapping as an alternative to coercion zapping
by Adam Gundry (＠adamgundry) 09 Jun '25

09 Jun '25

Adam Gundry pushed to branch wip/amg/castz at Glasgow Haskell Compiler / GHC Commits: c1cfc9c4 by Adam Gundry at 2025-06-09T12:09:38+02:00 WIP: introduce cast zapping as an alternative to coercion zapping - - - - - 51 changed files: - compiler/GHC/Core.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/LateCC/OverloadedCalls.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Map/Expr.hs - compiler/GHC/Core/Map/Type.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/CSE.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/Seq.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Stats.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/Tidy.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Ppr.hs - compiler/GHC/Core/TyCo/Ppr.hs-boot - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCo/Rep.hs-boot - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/TyCo/Tidy.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/HsToCore/Foreign/Prim.hs - compiler/GHC/HsToCore/Foreign/Wasm.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Rename.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Types/EvTerm.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/Types/Id/Make.hs - docs/core-spec/CoreLint.ott - docs/core-spec/CoreSyn.ott - docs/core-spec/OpSem.ott The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c1cfc9c438a263d8ee536675e41440c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c1cfc9c438a263d8ee536675e41440c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/wasm-bytearray-marshall] wasm: Add JSUint8Array to ByteArray conversion functions
by Matthew Pickering (＠mpickering) 09 Jun '25

09 Jun '25

Matthew Pickering pushed to branch wip/wasm-bytearray-marshall at Glasgow Haskell Compiler / GHC Commits: 96d12714 by Matthew Pickering at 2025-06-09T09:58:59+01:00 wasm: Add JSUint8Array to ByteArray conversion functions With these functions you can more directly pass ByteArray#-like objects to functions compiled using the wasm backend. For example, a foreign export can expect a JSUint8Array ``` foreign export javascript "hs_round" roundTrip :: JSUint8Array -> JSUint8Array ``` and then the function can be called from javascript and passed a Uint8Array. ``` var uint8Array = new Uint8Array(arrayBuffer); wasi.instance.exports.hs_round(uint8Array); ``` - - - - - 3 changed files: - libraries/ghc-experimental/ghc-experimental.cabal.in - + libraries/ghc-experimental/src/GHC/Wasm/Uint8Array.hs - testsuite/tests/jsffi/textconv.hs Changes: ===================================== libraries/ghc-experimental/ghc-experimental.cabal.in ===================================== @@ -40,6 +40,7 @@ library Prelude.Experimental if arch(wasm32) exposed-modules: GHC.Wasm.Prim + GHC.Wasm.Uint8Array other-extensions: build-depends: base >=4.20 && < 4.22, ghc-internal == @ProjectVersionForLib@.* ===================================== libraries/ghc-experimental/src/GHC/Wasm/Uint8Array.hs ===================================== @@ -0,0 +1,48 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +-- | Utilities to marshall a javascript 'Uint8Array' to a 'ByteArray' +module GHC.Wasm.Uint8Array + ( toJSUint8Array, fromJSUint8Array, JSUint8Array(..), byteLength + ) where + +import Data.Array.Byte +import GHC.Wasm.Prim +import GHC.Ptr +import GHC.Exts +import System.IO.Unsafe +import GHC.IO + +newtype JSUint8Array = JSUint8Array { unJSUint8Array :: JSVal } + +foreign import javascript unsafe + "$1.byteLength" + byteLength :: JSUint8Array -> Int + +withByteArrayContents :: ByteArray -> (Ptr () -> Int -> IO a) -> IO a +withByteArrayContents (ByteArray arr#) f = IO $ \s0 -> + keepAlive# arr# s0 (unIO $ f (Ptr (byteArrayContents# arr#)) (I# (sizeofByteArray# arr#) )) + +fromJSUint8ArrayLen :: Int -> JSUint8Array -> ByteArray +fromJSUint8ArrayLen (I# len) arr = unsafePerformIO $ IO $ + \s -> case newByteArray# len s of + (# s', mb #) -> + let a = mutableByteArrayContents# mb + in case unIO (memorySetUint8Array (Ptr a) (I# len) arr) s' of + (# s'', () #) -> case unsafeFreezeByteArray# mb s'' of + (# s''', arr' #) -> (# s''', ByteArray arr' #) + +toJSUint8Array :: ByteArray -> JSUint8Array +toJSUint8Array ba = + unsafePerformIO $ withByteArrayContents ba uint8ArrayFromMemory + +fromJSUint8Array :: JSUint8Array -> ByteArray +fromJSUint8Array src_buf = fromJSUint8ArrayLen (byteLength src_buf) src_buf + +foreign import javascript unsafe + "(new Uint8Array(__exports.memory.buffer, $1, $2)).set($3)" + memorySetUint8Array :: Ptr a -> Int -> JSUint8Array -> IO () + +foreign import javascript unsafe + "new Uint8Array(new Uint8Array(__exports.memory.buffer, $1, $2))" + uint8ArrayFromMemory :: Ptr a -> Int -> IO JSUint8Array + ===================================== testsuite/tests/jsffi/textconv.hs ===================================== @@ -14,36 +14,24 @@ import qualified Data.Text.IO.Utf8 as T import GHC.Exts import GHC.IO import GHC.Wasm.Prim - -newtype JSUint8Array = JSUint8Array JSVal +import GHC.Wasm.Uint8Array foreign import javascript unsafe "(new TextEncoder()).encode($1)" - js_str_encode :: JSString -> IO JSUint8Array - -foreign import javascript unsafe "$1.byteLength" - js_buf_len :: JSUint8Array -> IO Int - -foreign import javascript unsafe "(new Uint8Array(__exports.memory.buffer, $2, $1.byteLength)).set($1)" - js_from_buf :: JSUint8Array -> Ptr a -> IO () + js_str_encode :: JSString -> JSUint8Array -foreign import javascript unsafe "(new TextDecoder('utf-8', {fatal: true})).decode(new Uint8Array(__exports.memory.buffer, $1, $2))" - js_to_str :: Ptr a -> Int -> IO JSString +foreign import javascript unsafe "(new TextDecoder('utf-8', {fatal: true})).decode($1)" + js_to_str :: JSUint8Array -> JSString textFromJSString :: JSString -> Text -textFromJSString str = unsafeDupablePerformIO $ do - buf <- js_str_encode str - I# len# <- js_buf_len buf - IO $ \s0 -> case newByteArray# len# s0 of - (# s1, mba# #) -> case unIO (js_from_buf buf (Ptr (mutableByteArrayContents# mba#))) s1 of - (# s2, _ #) -> case unIO (freeJSVal (coerce buf)) s2 of - (# s3, _ #) -> case unsafeFreezeByteArray# mba# s3 of - (# s4, ba# #) -> (# s4, Text (ByteArray ba#) 0 (I# len#) #) +textFromJSString str = + let buf = js_str_encode str + in Text (fromJSUint8Array buf) 0 (byteLength buf) +-- NOTE: Do not copy this into your program, you need to take into account the +-- offset to do this converson properly textToJSString :: Text -> JSString -textToJSString (Text (ByteArray ba#) (I# off#) (I# len#)) = unsafeDupablePerformIO $ - IO $ \s0 -> case newPinnedByteArray# len# s0 of - (# s1, mba# #) -> case copyByteArray# ba# off# mba# 0# len# s1 of - s2 -> keepAlive# mba# s2 $ unIO $ js_to_str (Ptr (mutableByteArrayContents# mba#)) $ I# len# +textToJSString (Text ba 0 len) = js_to_str (toJSUint8Array ba) +textToJSString _ = error "non-zero offset not supported" foreign export javascript "main sync" main :: IO () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/96d12714484b1d93b564fc046f0e1a2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/96d12714484b1d93b564fc046f0e1a2… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/libffi-3.5.0
by Cheng Shao (＠TerrorJack) 09 Jun '25

09 Jun '25

Cheng Shao pushed new branch wip/libffi-3.5.0 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/libffi-3.5.0 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/amg/castz] WIP: switch from CastZ to Cast + CastCoercion
by Adam Gundry (＠adamgundry) 09 Jun '25

09 Jun '25

Adam Gundry pushed to branch wip/amg/castz at Glasgow Haskell Compiler / GHC Commits: dcd2ea0e by Adam Gundry at 2025-06-09T08:50:31+02:00 WIP: switch from CastZ to Cast + CastCoercion - - - - - 64 changed files: - compiler/GHC/Core.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/LateCC/OverloadedCalls.hs - compiler/GHC/Core/LateCC/TopLevelBinds.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Map/Expr.hs - compiler/GHC/Core/Map/Type.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/CSE.hs - compiler/GHC/Core/Opt/CallArity.hs - compiler/GHC/Core/Opt/CallerCC.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/Exitify.hs - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/FloatOut.hs - compiler/GHC/Core/Opt/LiberateCase.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/StaticArgs.hs - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/Seq.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Stats.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/Tidy.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Ppr.hs - compiler/GHC/Core/TyCo/Ppr.hs-boot - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCo/Rep.hs-boot - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/TyCo/Tidy.hs - compiler/GHC/Core/Unfold.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/HsToCore/Foreign/Prim.hs - compiler/GHC/HsToCore/Foreign/Wasm.hs - compiler/GHC/HsToCore/Pmc/Solver.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Rename.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Types/EvTerm.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/Types/Id/Make.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dcd2ea0e7965d6bfd6ebf49822896ee… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dcd2ea0e7965d6bfd6ebf49822896ee… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-apporv-Oct24] remove addHeadCtxt
by Apoorv Ingle (＠ani) 09 Jun '25

09 Jun '25

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: c5cd0302 by Apoorv Ingle at 2025-06-08T22:45:10-05:00 remove addHeadCtxt - - - - - 2 changed files: - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Head.hs Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -408,6 +408,7 @@ tcApp fun_orig rn_expr exp_res_ty vcat [ text "rn_expr:" <+> ppr rn_expr , text "rn_fun:" <+> ppr rn_fun , text "fun_ctxt:" <+> ppr fun_ctxt + , text "orig:" <+> ppr fun_orig , text "rn_args:" <+> ppr rn_args ] -- Step 2: Infer the type of `fun`, the head of the application @@ -769,7 +770,7 @@ tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args = do { (_inst_tvs, wrap, fun_rho) <- -- addHeadCtxt: important for the class constraints -- that may be emitted from instantiating fun_sigma - addHeadCtxt fun_ctxt $ + setSrcSpan fun_ctxt $ instantiateSigma fun_orig fun_conc_tvs tvs theta body2 -- See Note [Representation-polymorphism checking built-ins] -- in GHC.Tc.Utils.Concrete. ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -26,7 +26,7 @@ module GHC.Tc.Gen.Head , nonBidirectionalErr , pprArgInst - , addHeadCtxt, addExprCtxt, addFunResCtxt ) where + , addExprCtxt, addFunResCtxt ) where import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig ) import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody ) @@ -458,8 +458,8 @@ tcInferAppHead :: (HsExpr GhcRn, SrcSpan) -- cases are dealt with by splitHsApps. -- -- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App -tcInferAppHead (fun,ctxt) - = addHeadCtxt ctxt $ +tcInferAppHead (fun,fun_loc) + = setSrcSpan fun_loc $ do { mb_tc_fun <- tcInferAppHead_maybe fun ; case mb_tc_fun of Just (fun', fun_sigma) -> return (fun', fun_sigma) @@ -480,13 +480,6 @@ tcInferAppHead_maybe fun = HsOverLit _ lit -> Just <$> tcInferOverLit lit _ -> return Nothing -addHeadCtxt :: SrcSpan -> TcM a -> TcM a --TODO ANI: Why not just setSrcSpan? -addHeadCtxt fun_loc thing_inside - | not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments - = thing_inside -- => context is already set - | otherwise - = setSrcSpan fun_loc thing_inside - {- ********************************************************************* * * View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c5cd030283615b7c070e376433c4ed6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c5cd030283615b7c070e376433c4ed6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-apporv-Oct24] 2 commits: kill VACall
by Apoorv Ingle (＠ani) 09 Jun '25

09 Jun '25

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 9bf56452 by Apoorv Ingle at 2025-06-08T19:23:41-05:00 kill VACall - - - - - 38dbe018 by Apoorv Ingle at 2025-06-08T19:23:58-05:00 kill AppCtxt - - - - - 5 changed files: - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -5328,6 +5328,7 @@ pprArising :: CtLoc -> SDoc -- We've done special processing for TypeEq, KindEq, givens pprArising ct_loc | suppress_origin = empty + | in_generated_code = pprCtOrigin orig -- TODO ANI: maybe should go way | otherwise = pprCtOrigin orig where orig = ctLocOrigin ct_loc ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -1,4 +1,3 @@ - {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -189,8 +188,8 @@ tcExprSigma inst fun_orig rn_expr = do { (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps rn_expr ; do_ql <- wantQuickLook rn_fun ; (tc_fun, fun_sigma) <- tcInferAppHead fun - ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst fun_orig (tc_fun, fun_ctxt) fun_sigma rn_args - ; tc_args <- tcValArgs do_ql inst_args + ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args + ; tc_args <- tcValArgs do_ql rn_fun inst_args ; let tc_expr = rebuildHsApps (tc_fun, fun_ctxt) tc_args ; return (tc_expr, app_res_sigma) } @@ -422,7 +421,7 @@ tcApp fun_orig rn_expr exp_res_ty , text "do_ql:" <+> ppr do_ql] ; (inst_args, app_res_rho) - <- tcInstFun do_ql True fun_orig (tc_fun, fun_ctxt) fun_sigma rn_args + <- tcInstFun do_ql True fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args ; case do_ql of NoQL -> do { traceTc "tcApp:NoQL" (ppr rn_fun $$ ppr app_res_rho) @@ -433,7 +432,7 @@ tcApp fun_orig rn_expr exp_res_ty app_res_rho exp_res_ty -- Step 4.2: typecheck the arguments - ; tc_args <- tcValArgs NoQL inst_args + ; tc_args <- tcValArgs NoQL rn_fun inst_args -- Step 4.3: wrap up ; finishApp tc_head tc_args app_res_rho res_wrap } @@ -443,7 +442,7 @@ tcApp fun_orig rn_expr exp_res_ty ; 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 + ; tc_args <- tcValArgs DoQL rn_fun 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 @@ -458,7 +457,7 @@ quickLookResultType :: TcRhoType -> ExpRhoType -> TcM () quickLookResultType app_res_rho (Check exp_rho) = qlUnify app_res_rho exp_rho quickLookResultType _ _ = return () -finishApp :: (HsExpr GhcTc, AppCtxt) -> [HsExprArg 'TcpTc] +finishApp :: (HsExpr GhcTc, SrcSpan) -> [HsExprArg 'TcpTc] -> TcRhoType -> HsWrapper -> TcM (HsExpr GhcTc) -- Do final checks and wrap up the result @@ -473,7 +472,7 @@ finishApp tc_head@(tc_fun,_) tc_args app_res_rho res_wrap ; return (mkHsWrap res_wrap res_expr) } checkResultTy :: HsExpr GhcRn - -> (HsExpr GhcTc, AppCtxt) -- Head + -> (HsExpr GhcTc, SrcSpan) -- Head -> [HsExprArg p] -- Arguments, just error messages -> TcRhoType -- Inferred type of the application; zonked to -- expose foralls, but maybe not deeply instantiated @@ -522,33 +521,50 @@ checkResultTy rn_expr (tc_fun, fun_ctxt) inst_args app_res_rho (Check res_ty) -- the source program; it was added by the renamer. See -- Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr perhaps_add_res_ty_ctxt thing_inside - | insideExpansion fun_ctxt + | isGeneratedSrcSpan fun_ctxt = thing_inside | otherwise = addFunResCtxt tc_fun inst_args app_res_rho (mkCheckExpType res_ty) $ thing_inside ---------------- -tcValArgs :: QLFlag -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc] +tcValArgs :: QLFlag -> HsExpr GhcRn -> [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 +tcValArgs do_ql fun args = go do_ql 0 args + where + go _ _ [] = return [] + go do_ql pos (arg : args) = + do { arg' <- tcValArg do_ql pos' fun arg + ; args' <- go do_ql pos' args + ; return (arg' : args') + } + where + -- increment position if the argument is user written type or value argument + pos' | EValArg{} <- arg + = pos + 1 + | EValArgQL{} <- arg + = pos + 1 + | ETypeArg{ ea_ctxt = l } <- arg + , not (isGeneratedSrcSpan l) = pos + 1 + | otherwise = pos -tcValArg :: QLFlag -> HsExprArg 'TcpInst -- Actual argument + +tcValArg :: QLFlag -> Int -> HsExpr GhcRn -> HsExprArg 'TcpInst -- Actual argument -> TcM (HsExprArg 'TcpTc) -- Resulting argument -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 _ _ _ (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)) } -- qlMonoHsWrapper: see Note [Monomorphise instantiation variables] -tcValArg _ (EWrap ew) = return (EWrap ew) +tcValArg _ _ _ (EWrap ew) = return (EWrap ew) -tcValArg do_ql (EValArg { ea_ctxt = ctxt - , ea_arg = larg@(L arg_loc arg) - , ea_arg_ty = sc_arg_ty }) - = addArgCtxt ctxt larg $ +tcValArg do_ql pos fun (EValArg { ea_ctxt = ctxt + , ea_arg = larg@(L arg_loc arg) + , ea_arg_ty = sc_arg_ty }) + = addArgCtxt pos fun larg $ do { -- Crucial step: expose QL results before checking exp_arg_ty -- So far as the paper is concerned, this step applies -- the poly-substitution Theta, learned by QL, so that we @@ -577,23 +593,26 @@ tcValArg do_ql (EValArg { ea_ctxt = ctxt , ea_arg = L arg_loc arg' , ea_arg_ty = noExtField }) } -tcValArg _ (EValArgQL { eaql_wanted = wanted +tcValArg _ pos fun (EValArgQL { eaql_wanted = wanted , eaql_ctxt = ctxt , eaql_arg_ty = sc_arg_ty , eaql_larg = larg@(L arg_loc rn_expr) , eaql_tc_fun = tc_head + , eaql_rn_fun = rn_fun , eaql_fun_ue = head_ue , eaql_args = inst_args , eaql_encl = arg_influences_enclosing_call , eaql_res_rho = app_res_rho }) - = addArgCtxt ctxt larg $ + = addArgCtxt pos fun larg $ do { -- Expose QL results to tcSkolemise, as in EValArg case 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 , text "args:" <+> ppr inst_args - , text "mult:" <+> ppr mult]) + , text "mult:" <+> ppr mult + , text "fun" <+> ppr fun + , text "tc_head" <+> ppr tc_head]) ; ds_flag <- getDeepSubsumptionFlag ; (wrap, arg') @@ -611,7 +630,7 @@ tcValArg _ (EValArgQL { eaql_wanted = wanted ; unless arg_influences_enclosing_call $ -- Don't repeat qlUnify app_res_rho exp_arg_rho -- the qlUnify - ; tc_args <- tcValArgs DoQL inst_args + ; tc_args <- tcValArgs DoQL rn_fun 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) @@ -656,14 +675,14 @@ tcInstFun :: QLFlag -- Otherwise we do eager instantiation; in Fig 5 of the paper -- |-inst returns a rho-type -> CtOrigin - -> (HsExpr GhcTc, AppCtxt) + -> (HsExpr GhcTc, HsExpr GhcRn, SrcSpan) -> TcSigmaType -> [HsExprArg 'TcpRn] -> TcM ( [HsExprArg 'TcpInst] , TcSigmaType ) -- This crucial function implements the |-inst judgement in Fig 4, plus the -- modification in Fig 5, of the QL paper: -- "A quick look at impredicativity" (ICFP'20). -tcInstFun do_ql inst_final fun_orig (tc_fun, fun_ctxt) fun_sigma rn_args +tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args = do { traceTc "tcInstFun" (vcat [ text "origin" <+> ppr fun_orig , text "tc_fun" <+> ppr tc_fun , text "fun_sigma" <+> ppr fun_sigma @@ -845,7 +864,7 @@ tcInstFun do_ql inst_final fun_orig (tc_fun, fun_ctxt) fun_sigma rn_args (Just $ HsExprTcThing tc_fun) (n_val_args, fun_sigma) fun_ty - ; arg' <- quickLookArg do_ql ctxt arg arg_ty + ; arg' <- quickLookArg do_ql pos ctxt rn_fun arg arg_ty ; let acc' = arg' : addArgWrap wrap acc ; go (pos+1) acc' res_ty rest_args } @@ -889,7 +908,7 @@ looks_like_type_arg EValArg{ ea_arg = L _ e } = _ -> False looks_like_type_arg _ = False -addArgCtxt :: AppCtxt -> LHsExpr GhcRn +addArgCtxt :: Int -> HsExpr GhcRn -> LHsExpr GhcRn -> TcM a -> TcM a -- There are 2 cases: -- 1. In the normal case, we add an informative context @@ -901,20 +920,18 @@ addArgCtxt :: AppCtxt -> LHsExpr GhcRn -- Unless the arg is also a generated thing, in which case do nothing. -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr -- See Note [Expanding HsDo with XXExprGhcRn] in GHC.Tc.Gen.Do -addArgCtxt ctxt (L arg_loc arg) thing_inside +addArgCtxt arg_no fun (L arg_loc arg) thing_inside = do { in_generated_code <- inGeneratedCode ; traceTc "addArgCtxt" (vcat [ text "generated:" <+> ppr in_generated_code , text "arg: " <+> ppr arg , text "arg_loc" <+> ppr arg_loc]) - ; case ctxt of - VACall fun arg_no _ | not in_generated_code - -> do setSrcSpanA arg_loc $ - addErrCtxt (FunAppCtxt (FunAppCtxtExpr fun arg) arg_no) $ - thing_inside - - _ -> setSrcSpanA arg_loc $ - addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated - thing_inside } + ; if in_generated_code + then do setSrcSpanA arg_loc $ + addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated + thing_inside + else do setSrcSpanA arg_loc $ + addErrCtxt (FunAppCtxt (FunAppCtxtExpr fun arg) arg_no) $ + thing_inside } {- ********************************************************************* * * @@ -1690,21 +1707,21 @@ This turned out to be more subtle than I expected. Wrinkles: -} -quickLookArg :: QLFlag -> AppCtxt +quickLookArg :: QLFlag -> Int -> SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn -- ^ Argument -> Scaled TcSigmaTypeFRR -- ^ Type expected by the function -> TcM (HsExprArg 'TcpInst) -- See Note [Quick Look at value arguments] -quickLookArg NoQL ctxt larg orig_arg_ty +quickLookArg NoQL _ ctxt _ larg orig_arg_ty = skipQuickLook ctxt larg orig_arg_ty -quickLookArg DoQL ctxt larg orig_arg_ty +quickLookArg DoQL pos ctxt fun 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 ctxt larg orig_arg_ty - else quickLookArg1 ctxt larg orig_arg_ty } + else quickLookArg1 pos ctxt fun larg orig_arg_ty } -skipQuickLook :: AppCtxt -> LHsExpr GhcRn -> Scaled TcRhoType +skipQuickLook :: SrcSpan -> LHsExpr GhcRn -> Scaled TcRhoType -> TcM (HsExprArg 'TcpInst) skipQuickLook ctxt larg arg_ty = return (EValArg { ea_ctxt = ctxt @@ -1745,12 +1762,12 @@ isGuardedTy ty | Just {} <- tcSplitAppTy_maybe ty = True | otherwise = False -quickLookArg1 :: AppCtxt -> LHsExpr GhcRn +quickLookArg1 :: Int -> SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn -> Scaled TcRhoType -- Deeply skolemised -> TcM (HsExprArg 'TcpInst) -- quickLookArg1 implements the "QL Argument" judgement in Fig 5 of the paper -quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) - = addArgCtxt ctxt larg $ -- Context needed for constraints +quickLookArg1 pos ctxt fun larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) + = addArgCtxt pos fun larg $ -- Context needed for constraints -- generated by calls in arg do { ((rn_fun, fun_ctxt), rn_args) <- splitHsApps arg @@ -1776,7 +1793,7 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) ; do_ql <- wantQuickLook rn_fun ; ((inst_args, app_res_rho), wanted) <- captureConstraints $ - tcInstFun do_ql True (exprCtOrigin arg) (tc_fun, fun_ctxt) fun_sigma rn_args + tcInstFun do_ql True (exprCtOrigin arg) (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args -- We must capture type-class and equality constraints here, but -- not equality constraints. See (QLA6) in Note [Quick Look at -- value arguments] @@ -1812,6 +1829,7 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) , eaql_arg_ty = sc_arg_ty , eaql_larg = larg , eaql_tc_fun = tc_head + , eaql_rn_fun = rn_fun , eaql_fun_ue = fun_ue , eaql_args = inst_args , eaql_wanted = wanted @@ -2187,7 +2205,7 @@ isTagToEnum :: HsExpr GhcTc -> Bool isTagToEnum (HsVar _ (L _ fun_id)) = fun_id `hasKey` tagToEnumKey isTagToEnum _ = False -tcTagToEnum :: (HsExpr GhcTc, AppCtxt) -> [HsExprArg 'TcpTc] +tcTagToEnum :: (HsExpr GhcTc, SrcSpan) -> [HsExprArg 'TcpTc] -> TcRhoType -> TcM (HsExpr GhcTc) -- tagToEnum# :: forall a. Int# -> a @@ -2314,7 +2332,7 @@ Wrinkle [Representation-polymorphic lambdas] in Note [Typechecking data construc -- if the representation of its argument isn't known. -- -- See Note [Eta-expanding rep-poly unlifted newtypes]. -rejectRepPolyNewtypes :: (HsExpr GhcTc, AppCtxt) +rejectRepPolyNewtypes :: (HsExpr GhcTc, SrcSpan) -> TcRhoType -> TcM () rejectRepPolyNewtypes (fun,_) app_res_rho = case fun of ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -1,4 +1,3 @@ - {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -905,7 +904,7 @@ tcSyntaxOpGen :: CtOrigin -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -> TcM (a, SyntaxExprTc) tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside - = do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan) + = do { (expr, sigma) <- tcInferAppHead (op, noSrcSpan) -- Ugh!! But all this code is scheduled for demolition anyway ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma) ; (result, expr_wrap, arg_wraps, res_wrap) ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -1,4 +1,3 @@ - {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -17,7 +16,6 @@ module GHC.Tc.Gen.Head ( HsExprArg(..), TcPass(..), QLFlag(..), EWrap(..) - , AppCtxt(..), appCtxtLoc, insideExpansion, appCtxtExpr , splitHsApps, rebuildHsApps , addArgWrap, isHsValArg , leadingValArgs, isVisibleArg @@ -167,18 +165,19 @@ data TcPass = TcpRn -- Arguments decomposed data HsExprArg (p :: TcPass) where -- See Note [HsExprArg] -- Data constructor EValArg represents a value argument - EValArg :: { ea_ctxt :: AppCtxt + EValArg :: { ea_ctxt :: SrcSpan , ea_arg_ty :: !(XEVAType p) , ea_arg :: LHsExpr (GhcPass (XPass p)) } -> HsExprArg p -- Data constructor EValArgQL represents an argument that has been -- partly-type-checked by Quick Look; see Note [EValArgQL] - EValArgQL :: { eaql_ctxt :: AppCtxt + EValArgQL :: { eaql_ctxt :: SrcSpan , eaql_arg_ty :: Scaled TcSigmaType -- Argument type expected by function , eaql_larg :: LHsExpr GhcRn -- Original application, for -- location and error msgs - , eaql_tc_fun :: (HsExpr GhcTc, AppCtxt) -- Typechecked head + , eaql_rn_fun :: HsExpr GhcRn -- Head of the argument if it is an application + , eaql_tc_fun :: (HsExpr GhcTc, SrcSpan) -- Typechecked head , eaql_fun_ue :: UsageEnv -- Usage environment of the typechecked head (QLA5) , eaql_args :: [HsExprArg 'TcpInst] -- Args: instantiated, not typechecked , eaql_wanted :: WantedConstraints @@ -187,12 +186,12 @@ data HsExprArg (p :: TcPass) where -- See Note [HsExprArg] , eaql_res_rho :: TcRhoType } -- Result type of the application -> HsExprArg 'TcpInst -- Only exists in TcpInst phase - ETypeArg :: { ea_ctxt :: AppCtxt + ETypeArg :: { ea_ctxt :: SrcSpan , ea_hs_ty :: LHsWcType GhcRn -- The type arg , ea_ty_arg :: !(XETAType p) } -- Kind-checked type arg -> HsExprArg p - EPrag :: AppCtxt -> (HsPragE (GhcPass (XPass p))) -> HsExprArg p + EPrag :: SrcSpan -> (HsPragE (GhcPass (XPass p))) -> HsExprArg p EWrap :: EWrap -> HsExprArg p type family XETAType (p :: TcPass) where -- Type arguments @@ -205,70 +204,25 @@ type family XEVAType (p :: TcPass) where -- Value arguments data QLFlag = DoQL | NoQL -data EWrap = EPar AppCtxt +data EWrap = EPar SrcSpan | EExpand (HsExpr GhcRn) | EHsWrap HsWrapper -data AppCtxt = - VACall - (HsExpr GhcRn) Int -- In the third argument of function f - SrcSpan -- The SrcSpan of the application (f e1 e2 e3) - -- noSrcSpan if outermost; see Note [AppCtxt] - - -{- Note [AppCtxt] -~~~~~~~~~~~~~~~~~ -In a call (f e1 ... en), we pair up each argument with an AppCtxt. For -example, the AppCtxt for e3 allows us to say - "In the third argument of `f`" -See splitHsApps. - -To do this we must take a quick look into the expression to find the -function at the head (`f` in this case) and how many arguments it -has. That is what the funcion top_ctxt does. - -If the function part is an expansion, we don't want to look further. -For example, with rebindable syntax the expression - (if e1 then e2 else e3) e4 e5 -might expand to - (ifThenElse e1 e2 e3) e4 e5 -For e4 we an AppCtxt that says "In the first argument of (if ...)", -not "In the fourth argument of ifThenElse". So top_ctxt stops -at expansions. - -The SrcSpan in an AppCtxt describes the whole call. We initialise -it to noSrcSpan, because splitHsApps deals in HsExpr not LHsExpr, so -we don't have a span for the whole call; and we use that noSrcSpan in -GHC.Tc.Gen.App.tcInstFun (set_fun_ctxt) to avoid pushing "In the expression `f`" -a second time. --} - -appCtxtLoc :: AppCtxt -> SrcSpan -appCtxtLoc (VACall _ _ l) = l - -insideExpansion :: AppCtxt -> Bool -insideExpansion ctxt = isGeneratedSrcSpan (appCtxtLoc ctxt) - -appCtxtExpr :: AppCtxt -> HsExpr GhcRn -appCtxtExpr (VACall e _ _) = e instance Outputable QLFlag where ppr DoQL = text "DoQL" ppr NoQL = text "NoQL" -instance Outputable AppCtxt where - ppr (VACall f n l) = text "VACall" <+> int n <+> ppr f <+> ppr l - type family XPass (p :: TcPass) where XPass 'TcpRn = 'Renamed XPass 'TcpInst = 'Renamed XPass 'TcpTc = 'Typechecked -mkEValArg :: AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn +mkEValArg :: SrcSpan -> LHsExpr GhcRn -> HsExprArg 'TcpRn mkEValArg ctxt e = EValArg { ea_arg = e, ea_ctxt = ctxt , ea_arg_ty = noExtField } -mkETypeArg :: AppCtxt -> LHsWcType GhcRn -> HsExprArg 'TcpRn +mkETypeArg :: SrcSpan -> LHsWcType GhcRn -> HsExprArg 'TcpRn mkETypeArg ctxt hs_ty = ETypeArg { ea_ctxt = ctxt , ea_hs_ty = hs_ty @@ -281,52 +235,38 @@ addArgWrap wrap args splitHsApps :: HsExpr GhcRn - -> TcM ( (HsExpr GhcRn, AppCtxt) -- Head + -> TcM ( (HsExpr GhcRn, SrcSpan) -- Head , [HsExprArg 'TcpRn]) -- Args -- See Note [splitHsApps]. -- -- This uses the TcM monad solely because we must run modFinalizers when looking -- through HsUntypedSplices -- (see Note [Looking through Template Haskell splices in splitHsApps]). -splitHsApps e = go e (top_ctxt 0 e) [] +splitHsApps e = go e noSrcSpan [] where - top_ctxt :: Int -> HsExpr GhcRn -> AppCtxt - -- Always returns VACall fun n_val_args noSrcSpan - -- to initialise the argument splitting in 'go' - -- See Note [AppCtxt] - top_ctxt n (HsPar _ fun) = top_lctxt n fun - top_ctxt n (HsPragE _ _ fun) = top_lctxt n fun - top_ctxt n (HsAppType _ fun _) = top_lctxt (n+1) fun - top_ctxt n (HsApp _ fun _) = top_lctxt (n+1) fun - top_ctxt n (XExpr (PopErrCtxt fun)) = top_ctxt n fun - top_ctxt n other_fun = VACall other_fun n noSrcSpan - - top_lctxt :: Int -> LHsExpr GhcRn -> AppCtxt - top_lctxt n (L _ fun) = top_ctxt n fun - - go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn] - -> TcM ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn]) - -- Modify the AppCtxt as we walk inwards, so it describes the next argument - go (HsPar _ (L l fun)) ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt) : args) - go (HsPragE _ p (L l fun)) ctxt args = go fun (set l ctxt) (EPrag ctxt p : args) - go (HsAppType _ (L l fun) ty) ctxt args = go fun (dec l ctxt) (mkETypeArg ctxt ty : args) - go (HsApp _ (L l fun) arg) ctxt args = go fun (dec l ctxt) (mkEValArg ctxt arg : args) + go :: HsExpr GhcRn -> SrcSpan -> [HsExprArg 'TcpRn] + -> TcM ((HsExpr GhcRn, SrcSpan), [HsExprArg 'TcpRn]) + -- Modify the SrcSpan as we walk inwards, so it describes the next argument + go (HsPar _ (L l fun)) ctxt args = go fun (locA l) (EWrap (EPar ctxt) : args) + go (HsPragE _ p (L l fun)) ctxt args = go fun (locA l) (EPrag ctxt p : args) + go (HsAppType _ (L l fun) ty) ctxt args = go fun (locA l) (mkETypeArg ctxt ty : args) + go (HsApp _ (L l fun) arg) ctxt args = go fun (locA l) (mkEValArg ctxt arg : args) -- See Note [Looking through Template Haskell splices in splitHsApps] - go e@(HsUntypedSplice splice_res splice) ctxt args + go e@(HsUntypedSplice splice_res splice) _ args = do { fun <- getUntypedSpliceBody splice_res ; go fun ctxt' (EWrap (EExpand e) : args) } where - ctxt' :: AppCtxt + ctxt' :: SrcSpan ctxt' = case splice of - HsUntypedSpliceExpr _ (L l _) -> set l ctxt -- l :: SrcAnn AnnListItem - HsQuasiQuote _ _ (L l _) -> set l ctxt -- l :: SrcAnn NoEpAnns + HsUntypedSpliceExpr _ (L l _) -> locA l -- l :: SrcAnn AnnListItem + HsQuasiQuote _ _ (L l _) -> locA l -- l :: SrcAnn NoEpAnns -- See Note [Desugar OpApp in the typechecker] go e@(OpApp _ arg1 (L l op) arg2) _ args - = pure ( (op, VACall op 0 (locA l)) - , mkEValArg (VACall op 1 generatedSrcSpan) arg1 - : mkEValArg (VACall op 2 generatedSrcSpan) arg2 + = pure ( (op, locA l) + , mkEValArg generatedSrcSpan arg1 + : mkEValArg generatedSrcSpan arg2 -- generatedSrcSpan because this the span of the call, -- and its hard to say exactly what that is : EWrap (EExpand e) @@ -337,11 +277,6 @@ splitHsApps e = go e (top_ctxt 0 e) [] go e ctxt args = pure ((e,ctxt), args) - set :: EpAnn ann -> AppCtxt -> AppCtxt - set l (VACall f n _) = VACall f n (locA l) - - dec :: EpAnn ann -> AppCtxt -> AppCtxt - dec l (VACall f n _) = VACall f (n-1) (locA l) -- | Rebuild an application: takes a type-checked application head -- expression together with arguments in the form of typechecked 'HsExprArg's @@ -351,7 +286,7 @@ splitHsApps e = go e (top_ctxt 0 e) [] -- representation-polymorphic unlifted newtypes have been eta-expanded. -- -- See Note [Eta-expanding rep-poly unlifted newtypes]. -rebuildHsApps :: (HsExpr GhcTc, AppCtxt) +rebuildHsApps :: (HsExpr GhcTc, SrcSpan) -- ^ the function being applied -> [HsExprArg 'TcpTc] -- ^ the arguments to the function @@ -372,7 +307,7 @@ rebuildHsApps (fun, ctxt) (arg : args) EWrap (EHsWrap wrap) -> rebuildHsApps (mkHsWrap wrap fun, ctxt) args where - lfun = L (noAnnSrcSpan $ appCtxtLoc ctxt) fun + lfun = L (noAnnSrcSpan ctxt) fun isHsValArg :: HsExprArg id -> Bool isHsValArg (EValArg {}) = True @@ -505,7 +440,7 @@ Wrinkle (UTS1): * * ********************************************************************* -} -tcInferAppHead :: (HsExpr GhcRn, AppCtxt) +tcInferAppHead :: (HsExpr GhcRn, SrcSpan) -> TcM (HsExpr GhcTc, TcSigmaType) -- Infer type of the head of an application -- i.e. the 'f' in (f e1 ... en) @@ -545,13 +480,12 @@ tcInferAppHead_maybe fun = HsOverLit _ lit -> Just <$> tcInferOverLit lit _ -> return Nothing -addHeadCtxt :: AppCtxt -> TcM a -> TcM a -addHeadCtxt fun_ctxt thing_inside +addHeadCtxt :: SrcSpan -> TcM a -> TcM a --TODO ANI: Why not just setSrcSpan? +addHeadCtxt fun_loc thing_inside | not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments = thing_inside -- => context is already set | otherwise = setSrcSpan fun_loc thing_inside - where fun_loc = appCtxtLoc fun_ctxt {- ********************************************************************* ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -1730,6 +1730,7 @@ mkErrCtxt env ctxts -- else go dbg 0 env ctxts = go False 0 env ctxts -- regular error ctx where + go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg] go _ _ _ [] = return [] go dbg n env ((is_landmark, ctxt) : ctxts) | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2d9928289c1aeb1f7f0c0334034b22… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2d9928289c1aeb1f7f0c0334034b22… You're receiving this email because of your account on gitlab.haskell.org.

1 0