December 2025 - ghc-commits

[Git][ghc/ghc] Pushed new branch wip/cleanup-ci-duplicate-keys
by Cheng Shao (＠TerrorJack) 19 Dec '25

19 Dec '25

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

1 0

[Git][ghc/ghc][master] compiler: remove unused OtherSection logic
by Marge Bot (＠marge-bot) 19 Dec '25

19 Dec '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 9a9c2f03 by Cheng Shao at 2025-12-18T13:24:39-05:00 compiler: remove unused OtherSection logic This patch removes the OtherSection logic in Cmm, given it's never actually used by any of our backends. - - - - - 9 changed files: - compiler/GHC/Cmm.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/CmmToAsm/AArch64/Ppr.hs - compiler/GHC/CmmToAsm/LA64/Ppr.hs - compiler/GHC/CmmToAsm/PPC/Ppr.hs - compiler/GHC/CmmToAsm/Ppr.hs - compiler/GHC/CmmToAsm/RV64/Ppr.hs - compiler/GHC/CmmToAsm/X86/Ppr.hs - compiler/GHC/CmmToLlvm/Data.hs Changes: ===================================== compiler/GHC/Cmm.hs ===================================== @@ -269,7 +269,6 @@ data SectionType | FiniArray -- .fini_array on ELF, .dtor on Windows | CString | IPE - | OtherSection String deriving (Show) data SectionProtection @@ -290,7 +289,6 @@ sectionProtection (Section t _) = case t of Data -> ReadWriteSection UninitialisedData -> ReadWriteSection IPE -> ReadWriteSection - (OtherSection _) -> ReadWriteSection {- Note [Relocatable Read-Only Data] @@ -550,4 +548,3 @@ pprSectionType s = doubleQuotes $ case s of FiniArray -> text "finiarray" CString -> text "cstring" IPE -> text "ipe" - OtherSection s' -> text s' ===================================== compiler/GHC/Cmm/Parser.y ===================================== @@ -978,7 +978,7 @@ section "data" = Data section "rodata" = ReadOnlyData section "relrodata" = RelocatableReadOnlyData section "bss" = UninitialisedData -section s = OtherSection s +section s = panic ("CmmParse: unknown section type: " ++ s) mkString :: String -> CmmStatic mkString s = CmmString (BS8.pack s) ===================================== compiler/GHC/CmmToAsm/AArch64/Ppr.hs ===================================== @@ -91,8 +91,6 @@ pprAlignForSection _platform _seg -- .balign 8 -- pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc -pprSectionAlign _config (Section (OtherSection _) _) = - panic "AArch64.Ppr.pprSectionAlign: unknown section" pprSectionAlign config sec@(Section seg _) = line (pprSectionHeader config sec) $$ pprAlignForSection (ncgPlatform config) seg ===================================== compiler/GHC/CmmToAsm/LA64/Ppr.hs ===================================== @@ -108,8 +108,6 @@ pprAlignForSection _seg = pprAlign . mkAlignment $ 8 -- .balign 8 -- pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc -pprSectionAlign _config (Section (OtherSection _) _) = - panic "LA64.Ppr.pprSectionAlign: unknown section" pprSectionAlign config sec@(Section seg _) = line (pprSectionHeader config sec) $$ pprAlignForSection seg ===================================== compiler/GHC/CmmToAsm/PPC/Ppr.hs ===================================== @@ -302,7 +302,6 @@ pprAlignForSection platform seg = line $ CString | ppc64 -> text ".align 3" | otherwise -> text ".align 2" - OtherSection _ -> panic "PprMach.pprSectionAlign: unknown section" pprDataItem :: IsDoc doc => Platform -> CmmLit -> doc pprDataItem platform lit ===================================== compiler/GHC/CmmToAsm/Ppr.hs ===================================== @@ -240,8 +240,6 @@ pprGNUSectionHeader config t suffix = | OSMinGW32 <- platformOS platform -> text ".rdata" | otherwise -> text ".ipe" - OtherSection _ -> - panic "PprBase.pprGNUSectionHeader: unknown section type" flags = case t of Text | OSMinGW32 <- platformOS platform, splitSections @@ -286,6 +284,5 @@ pprDarwinSectionHeader t = case t of FiniArray -> panic "pprDarwinSectionHeader: fini not supported" CString -> text ".section\t__TEXT,__cstring,cstring_literals" IPE -> text ".const" - OtherSection _ -> panic "pprDarwinSectionHeader: unknown section type" {-# SPECIALIZE pprDarwinSectionHeader :: SectionType -> SDoc #-} {-# SPECIALIZE pprDarwinSectionHeader :: SectionType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable ===================================== compiler/GHC/CmmToAsm/RV64/Ppr.hs ===================================== @@ -99,8 +99,6 @@ pprAlignForSection _seg = pprAlign . mkAlignment $ 8 -- .section .text -- .balign 8 pprSectionAlign :: (IsDoc doc) => NCGConfig -> Section -> doc -pprSectionAlign _config (Section (OtherSection _) _) = - panic "RV64.Ppr.pprSectionAlign: unknown section" pprSectionAlign config sec@(Section seg _) = line (pprSectionHeader config sec) $$ pprAlignForSection seg ===================================== compiler/GHC/CmmToAsm/X86/Ppr.hs ===================================== @@ -526,8 +526,6 @@ pprAddr platform (AddrBaseIndex base index displacement) -- | Print section header and appropriate alignment for that section. pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc -pprSectionAlign _config (Section (OtherSection _) _) = - panic "X86.Ppr.pprSectionAlign: unknown section" pprSectionAlign config sec@(Section seg _) = line (pprSectionHeader config sec) $$ pprAlignForSection (ncgPlatform config) seg ===================================== compiler/GHC/CmmToLlvm/Data.hs ===================================== @@ -148,7 +148,6 @@ llvmSectionType p t = case t of IPE -> fsLit ".ipe" InitArray -> panic "llvmSectionType: InitArray" FiniArray -> panic "llvmSectionType: FiniArray" - OtherSection _ -> panic "llvmSectionType: unknown section type" -- | Format a Cmm Section into a LLVM section name llvmSection :: Section -> LlvmM LMSection View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9a9c2f031abba5efdad19efc54e0e57… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9a9c2f031abba5efdad19efc54e0e57… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Remove outdated comment
by Marge Bot (＠marge-bot) 19 Dec '25

19 Dec '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: b3dd23b9 by Vilim Lendvaj at 2025-12-18T13:23:57-05:00 Remove outdated comment The Traversable instance for ZipList is no longer in GHC.Internal.Data.Traversable. In fact, it is right below this very comment. - - - - - 1 changed file: - libraries/ghc-internal/src/GHC/Internal/Functor/ZipList.hs Changes: ===================================== libraries/ghc-internal/src/GHC/Internal/Functor/ZipList.hs ===================================== @@ -46,7 +46,6 @@ newtype ZipList a = ZipList { getZipList :: [a] } , Generic -- ^ @since base-4.7.0.0 , Generic1 -- ^ @since base-4.7.0.0 ) --- See GHC.Internal.Data.Traversable for Traversable instance due to import loops -- | @since base-4.9.0.0 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b3dd23b9d6c40160f9b15df8ae80825… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b3dd23b9d6c40160f9b15df8ae80825… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] compiler/rts: fix ABI mismatch in barf() invocations
by Marge Bot (＠marge-bot) 19 Dec '25

19 Dec '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 1ca4b49a by Cheng Shao at 2025-12-18T13:23:11-05:00 compiler/rts: fix ABI mismatch in barf() invocations This patch fixes a long-standing issue of ABI mismatch in `barf()` invocations, both in compiler-emitted code and in hand written Cmm code: - In RTS, we have `barf()` which reports a fatal internal error message and exits the program. - `barf()` is a variadic C function! When used as a callee of a foreign call with `ccall` calling convention instead of `capi`, there is an ABI mismatch between the caller and the callee! - Unfortunately, both the compiler and the Cmm sources contain many places where we call `barf()` via `ccall` convention!! Like, when you write `foreign "C" barf("foo object (%p) entered!", R1)`, it totally doesn't do what you think it'll do at all!! The second argument `R1` is not properly passed in `va_list`, and the behavior is completely undefined!! - Even more unfortunately, this issue has been sitting around long enough because the ABI mismatch is subtle enough on normie platforms like x64 and arm64. - But there are platforms like wasm32 that are stricter about ABI, and the broken `barf()` invocations already causes trouble for wasm backend: we had to use ugly hacks like `barf(errmsg, NULL)` to make `wasm-ld` happy, and even with this band-aid, compiler-generated `barf()` invocations are still broken, resulting in regressions in certain debug-related functionality, e.g. `-dtag-inference-checks` is broken on wasm32 (#22882). This patch properly fixes the issue: - We add non-variadic `barf` wrappers in the RTS that can be used as `ccall` callees - Both the compiler `emitBarf` logic and the hand-written Cmm are changed to call these wrappers - `emitBarf` now also properly annotates the foreign call as `CmmNeverReturns` to indicate it's a noreturn call to enable more efficient code generation `-dtag-inference-checks` now works on wasm. Closes #22882. Co-authored-by: Codex <codex(a)openai.com> - - - - - 14 changed files: - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Utils.hs - rts/Apply.cmm - rts/Compact.cmm - rts/ContinuationOps.cmm - rts/Exception.cmm - rts/Jumps.h - rts/PrimOps.cmm - rts/RtsMessages.c - rts/StgMiscClosures.cmm - rts/StgStartup.cmm - rts/include/rts/Messages.h - testsuite/tests/simplStg/should_compile/all.T - utils/genapply/Main.hs Changes: ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -866,7 +866,7 @@ link_caf node = do ; let profile = stgToCmmProfile cfg ; let platform = profilePlatform profile ; bh <- newTemp (bWord platform) - ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl + ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl CmmMayReturn [ (baseExpr platform, AddrHint), (CmmReg (CmmLocal node), AddrHint) ] False ===================================== compiler/GHC/StgToCmm/Utils.hs ===================================== @@ -186,23 +186,27 @@ tagToClosure platform tycon tag emitBarf :: String -> FCode () emitBarf msg = do strLbl <- newStringCLit msg - emitRtsCall rtsUnitId (fsLit "barf") [(CmmLit strLbl,AddrHint)] False + emitRtsCallGen [] (mkCmmCodeLabel rtsUnitId (fsLit "sbarf")) + CmmNeverReturns + [(CmmLit strLbl, AddrHint)] False emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () -emitRtsCall pkg fun = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) +emitRtsCall pkg fun = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) CmmMayReturn emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () -emitRtsCallWithResult res hint pkg = emitRtsCallGen [(res,hint)] . mkCmmCodeLabel pkg +emitRtsCallWithResult res hint pkg = + \fun -> emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) CmmMayReturn -- Make a call to an RTS C procedure emitRtsCallGen :: [(LocalReg,ForeignHint)] -> CLabel + -> CmmReturnInfo -> [(CmmExpr,ForeignHint)] -> Bool -- True <=> CmmSafe call -> FCode () -emitRtsCallGen res lbl args safe +emitRtsCallGen res lbl ret_info args safe = do { platform <- getPlatform ; updfr_off <- getUpdFrameOff ; let (caller_save, caller_load) = callerSaveVolatileRegs platform @@ -214,7 +218,7 @@ emitRtsCallGen res lbl args safe if safe then emit =<< mkCmmCall fun_expr res' args' updfr_off else do - let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn + let conv = ForeignConvention CCallConv arg_hints res_hints ret_info emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args' (args', arg_hints) = unzip args (res', res_hints) = unzip res ===================================== rts/Apply.cmm ===================================== @@ -250,7 +250,7 @@ again: -------------------------------------------------------------------------- */ INFO_TABLE(stg_PAP,/*special layout*/0,0,PAP,"PAP","PAP") -{ ccall barf("PAP object (%p) entered!", R1) never returns; } +{ ccall pbarf("PAP object (%p) entered!", R1 "ptr") never returns; } stg_PAP_apply /* no args => explicit stack */ { ===================================== rts/Compact.cmm ===================================== @@ -282,7 +282,7 @@ eval: goto constructor; }} - ccall barf("stg_compactWorkerzh", NULL); + ccall sbarf("stg_compactWorkerzh") never returns; } // ===================================== rts/ContinuationOps.cmm ===================================== @@ -36,7 +36,7 @@ import CLOSURE ghc_hs_iface; -------------------------------------------------------------------------- */ INFO_TABLE(stg_PROMPT_TAG,0,0,PRIM,"PROMPT_TAG","PROMPT_TAG") -{ foreign "C" barf("PROMPT_TAG object (%p) entered!", R1) never returns; } +{ ccall pbarf("PROMPT_TAG object (%p) entered!", R1 "ptr") never returns; } stg_newPromptTagzh() { ===================================== rts/Exception.cmm ===================================== @@ -666,11 +666,11 @@ stg_raiseOverflowzh () */ stg_paniczh (W_ str) { - ccall barf(str, NULL) never returns; + ccall sbarf(str "ptr") never returns; } // See Note [Compiler error functions] in GHC.Prim.Panic stg_absentErrorzh (W_ str) { - ccall barf("Oops! Entered absent arg %s", str) never returns; + ccall ssbarf("Oops! Entered absent arg %s", str "ptr") never returns; } ===================================== rts/Jumps.h ===================================== @@ -70,7 +70,7 @@ INFO_TABLE_RET (MK_FUN_NM(stg_stack_underflow_frame), UNDERFLOW_FRAME, jump %ENTRY_CODE(Sp(ret_off)) ALL_ARG_REGS; #else - ccall barf("stg_stack_underflow_frame: unsupported register", NULL) never returns; + ccall sbarf("stg_stack_underflow_frame: unsupported register") never returns; #endif } @@ -96,6 +96,6 @@ INFO_TABLE_RET (MK_FUN_NM(stg_restore_cccs), RET_SMALL, W_ info_ptr, W_ cccs) jump %ENTRY_CODE(Sp(0)) ALL_ARG_REGS; #else - ccall barf("stg_restore_cccs: unsupported register", NULL) never returns; + ccall sbarf("stg_restore_cccs: unsupported register") never returns; #endif } ===================================== rts/PrimOps.cmm ===================================== @@ -2332,7 +2332,7 @@ stg_asyncReadzh ( W_ fd, W_ is_sock, W_ len, W_ buf ) CInt reqID; #if defined(THREADED_RTS) - ccall barf("asyncRead# on threaded RTS") never returns; + ccall sbarf("asyncRead# on threaded RTS") never returns; #else /* could probably allocate this on the heap instead */ @@ -2358,7 +2358,7 @@ stg_asyncWritezh ( W_ fd, W_ is_sock, W_ len, W_ buf ) CInt reqID; #if defined(THREADED_RTS) - ccall barf("asyncWrite# on threaded RTS") never returns; + ccall sbarf("asyncWrite# on threaded RTS") never returns; #else ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult, @@ -2384,7 +2384,7 @@ stg_asyncDoProczh ( W_ proc, W_ param ) CInt reqID; #if defined(THREADED_RTS) - ccall barf("asyncDoProc# on threaded RTS") never returns; + ccall sbarf("asyncDoProc# on threaded RTS") never returns; #else /* could probably allocate this on the heap instead */ ===================================== rts/RtsMessages.c ===================================== @@ -58,6 +58,24 @@ vbarf(const char*s, va_list ap) stg_exit(EXIT_INTERNAL_ERROR); // just in case fatalInternalErrorFn() returns } +void +sbarf(const char*s) +{ + barf("%s", s); +} + +void +pbarf(const char*fmt, void *p) +{ + barf(fmt, p); +} + +void +ssbarf(const char *fmt, const char *s) +{ + barf(fmt, s); +} + void _assertFail(const char*filename, unsigned int linenum) { ===================================== rts/StgMiscClosures.cmm ===================================== @@ -473,7 +473,7 @@ INFO_TABLE_RET( stg_dead_thread, RET_SMALL, W_ info_ptr, PROF_HDR_FIELDS(W_,p1,p2) P_ result ) -{ foreign "C" barf("stg_dead_thread entered!", NULL) never returns; } +{ ccall sbarf("stg_dead_thread entered!") never returns; } /* ---------------------------------------------------------------------------- Entry code for a BCO @@ -631,11 +631,11 @@ INFO_TABLE(__stg_EAGER_BLACKHOLE,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE") } INFO_TABLE(stg_BLOCKING_QUEUE_CLEAN,4,0,BLOCKING_QUEUE,"BLOCKING_QUEUE","BLOCKING_QUEUE") -{ foreign "C" barf("BLOCKING_QUEUE_CLEAN object (%p) entered!", R1) never returns; } +{ ccall pbarf("BLOCKING_QUEUE_CLEAN object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE(stg_BLOCKING_QUEUE_DIRTY,4,0,BLOCKING_QUEUE,"BLOCKING_QUEUE","BLOCKING_QUEUE") -{ foreign "C" barf("BLOCKING_QUEUE_DIRTY object (%p) entered!", R1) never returns; } +{ ccall pbarf("BLOCKING_QUEUE_DIRTY object (%p) entered!", R1 "ptr") never returns; } /* ---------------------------------------------------------------------------- @@ -673,7 +673,7 @@ loop: ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); jump %ENTRY_CODE(info) (node); #else - ccall barf("WHITEHOLE object (%p) entered!", R1) never returns; + ccall pbarf("WHITEHOLE object (%p) entered!", R1 "ptr") never returns; #endif } @@ -684,10 +684,10 @@ loop: ------------------------------------------------------------------------- */ INFO_TABLE(stg_TSO, 0,0,TSO, "TSO", "TSO") -{ foreign "C" barf("TSO object (%p) entered!", R1) never returns; } +{ ccall pbarf("TSO object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE(stg_STACK, 0,0, STACK, "STACK", "STACK") -{ foreign "C" barf("STACK object (%p) entered!", R1) never returns; } +{ ccall pbarf("STACK object (%p) entered!", R1 "ptr") never returns; } /* ---------------------------------------------------------------------------- Weak pointers @@ -698,7 +698,7 @@ INFO_TABLE(stg_STACK, 0,0, STACK, "STACK", "STACK") ------------------------------------------------------------------------- */ INFO_TABLE(stg_WEAK,1,4,WEAK,"WEAK","WEAK") -{ foreign "C" barf("WEAK object (%p) entered!", R1) never returns; } +{ ccall pbarf("WEAK object (%p) entered!", R1 "ptr") never returns; } /* * It's important when turning an existing WEAK into a DEAD_WEAK @@ -707,7 +707,7 @@ INFO_TABLE(stg_WEAK,1,4,WEAK,"WEAK","WEAK") * DEAD_WEAK 5 non-pointer fields. */ INFO_TABLE_CONSTR(stg_DEAD_WEAK,0,5,0,CONSTR,"DEAD_WEAK","DEAD_WEAK") -{ foreign "C" barf("DEAD_WEAK object (%p) entered!", R1) never returns; } +{ ccall pbarf("DEAD_WEAK object (%p) entered!", R1 "ptr") never returns; } /* ---------------------------------------------------------------------------- C finalizer lists @@ -716,7 +716,7 @@ INFO_TABLE_CONSTR(stg_DEAD_WEAK,0,5,0,CONSTR,"DEAD_WEAK","DEAD_WEAK") ------------------------------------------------------------------------- */ INFO_TABLE_CONSTR(stg_C_FINALIZER_LIST,1,4,0,CONSTR,"C_FINALIZER_LIST","C_FINALIZER_LIST") -{ foreign "C" barf("C_FINALIZER_LIST object (%p) entered!", R1) never returns; } +{ ccall pbarf("C_FINALIZER_LIST object (%p) entered!", R1 "ptr") never returns; } /* ---------------------------------------------------------------------------- NO_FINALIZER @@ -726,7 +726,7 @@ INFO_TABLE_CONSTR(stg_C_FINALIZER_LIST,1,4,0,CONSTR,"C_FINALIZER_LIST","C_FINALI ------------------------------------------------------------------------- */ INFO_TABLE_CONSTR(stg_NO_FINALIZER,0,0,0,CONSTR_NOCAF,"NO_FINALIZER","NO_FINALIZER") -{ foreign "C" barf("NO_FINALIZER object (%p) entered!", R1) never returns; } +{ ccall pbarf("NO_FINALIZER object (%p) entered!", R1 "ptr") never returns; } CLOSURE(stg_NO_FINALIZER_closure,stg_NO_FINALIZER); @@ -735,7 +735,7 @@ CLOSURE(stg_NO_FINALIZER_closure,stg_NO_FINALIZER); ------------------------------------------------------------------------- */ INFO_TABLE(stg_STABLE_NAME,0,1,PRIM,"STABLE_NAME","STABLE_NAME") -{ foreign "C" barf("STABLE_NAME object (%p) entered!", R1) never returns; } +{ ccall pbarf("STABLE_NAME object (%p) entered!", R1 "ptr") never returns; } /* ---------------------------------------------------------------------------- MVars @@ -745,38 +745,38 @@ INFO_TABLE(stg_STABLE_NAME,0,1,PRIM,"STABLE_NAME","STABLE_NAME") ------------------------------------------------------------------------- */ INFO_TABLE(stg_MVAR_CLEAN,3,0,MVAR_CLEAN,"MVAR","MVAR") -{ foreign "C" barf("MVAR object (%p) entered!", R1) never returns; } +{ ccall pbarf("MVAR object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE(stg_MVAR_DIRTY,3,0,MVAR_DIRTY,"MVAR","MVAR") -{ foreign "C" barf("MVAR object (%p) entered!", R1) never returns; } +{ ccall pbarf("MVAR object (%p) entered!", R1 "ptr") never returns; } /* ----------------------------------------------------------------------------- STM -------------------------------------------------------------------------- */ INFO_TABLE(stg_TVAR_CLEAN, 2, 1, TVAR, "TVAR", "TVAR") -{ foreign "C" barf("TVAR_CLEAN object (%p) entered!", R1) never returns; } +{ ccall pbarf("TVAR_CLEAN object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE(stg_TVAR_DIRTY, 2, 1, TVAR, "TVAR", "TVAR") -{ foreign "C" barf("TVAR_DIRTY object (%p) entered!", R1) never returns; } +{ ccall pbarf("TVAR_DIRTY object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE(stg_TVAR_WATCH_QUEUE, 3, 0, MUT_PRIM, "TVAR_WATCH_QUEUE", "TVAR_WATCH_QUEUE") -{ foreign "C" barf("TVAR_WATCH_QUEUE object (%p) entered!", R1) never returns; } +{ ccall pbarf("TVAR_WATCH_QUEUE object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE(stg_TREC_CHUNK, 0, 0, TREC_CHUNK, "TREC_CHUNK", "TREC_CHUNK") -{ foreign "C" barf("TREC_CHUNK object (%p) entered!", R1) never returns; } +{ ccall pbarf("TREC_CHUNK object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE(stg_TREC_HEADER, 2, 1, MUT_PRIM, "TREC_HEADER", "TREC_HEADER") -{ foreign "C" barf("TREC_HEADER object (%p) entered!", R1) never returns; } +{ ccall pbarf("TREC_HEADER object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_END_STM_WATCH_QUEUE,0,0,0,CONSTR_NOCAF,"END_STM_WATCH_QUEUE","END_STM_WATCH_QUEUE") -{ foreign "C" barf("END_STM_WATCH_QUEUE object (%p) entered!", R1) never returns; } +{ ccall pbarf("END_STM_WATCH_QUEUE object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_END_STM_CHUNK_LIST,0,0,0,CONSTR_NOCAF,"END_STM_CHUNK_LIST","END_STM_CHUNK_LIST") -{ foreign "C" barf("END_STM_CHUNK_LIST object (%p) entered!", R1) never returns; } +{ ccall pbarf("END_STM_CHUNK_LIST object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_NO_TREC,0,0,0,CONSTR_NOCAF,"NO_TREC","NO_TREC") -{ foreign "C" barf("NO_TREC object (%p) entered!", R1) never returns; } +{ ccall pbarf("NO_TREC object (%p) entered!", R1 "ptr") never returns; } CLOSURE(stg_END_STM_WATCH_QUEUE_closure,stg_END_STM_WATCH_QUEUE); @@ -791,52 +791,52 @@ CLOSURE(stg_NO_TREC_closure,stg_NO_TREC); ------------------------------------------------------------------------- */ INFO_TABLE_CONSTR(stg_SRT_1, 1, 0, 0, CONSTR_1_0, "SRT_1", "SRT_1") -{ foreign "C" barf("SRT_1 object (%p) entered!", R1) never returns; } +{ ccall pbarf("SRT_1 object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_SRT_2, 2, 0, 0, CONSTR_2_0, "SRT_2", "SRT_2") -{ foreign "C" barf("SRT_2 object (%p) entered!", R1) never returns; } +{ ccall pbarf("SRT_2 object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_SRT_3, 3, 0, 0, CONSTR, "SRT_3", "SRT_3") -{ foreign "C" barf("SRT_3 object (%p) entered!", R1) never returns; } +{ ccall pbarf("SRT_3 object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_SRT_4, 4, 0, 0, CONSTR, "SRT_4", "SRT_4") -{ foreign "C" barf("SRT_4 object (%p) entered!", R1) never returns; } +{ ccall pbarf("SRT_4 object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_SRT_5, 5, 0, 0, CONSTR, "SRT_5", "SRT_5") -{ foreign "C" barf("SRT_5 object (%p) entered!", R1) never returns; } +{ ccall pbarf("SRT_5 object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_SRT_6, 6, 0, 0, CONSTR, "SRT_6", "SRT_6") -{ foreign "C" barf("SRT_6 object (%p) entered!", R1) never returns; } +{ ccall pbarf("SRT_6 object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_SRT_7, 7, 0, 0, CONSTR, "SRT_7", "SRT_7") -{ foreign "C" barf("SRT_7 object (%p) entered!", R1) never returns; } +{ ccall pbarf("SRT_7 object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_SRT_8, 8, 0, 0, CONSTR, "SRT_8", "SRT_8") -{ foreign "C" barf("SRT_8 object (%p) entered!", R1) never returns; } +{ ccall pbarf("SRT_8 object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_SRT_9, 9, 0, 0, CONSTR, "SRT_9", "SRT_9") -{ foreign "C" barf("SRT_9 object (%p) entered!", R1) never returns; } +{ ccall pbarf("SRT_9 object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_SRT_10, 10, 0, 0, CONSTR, "SRT_10", "SRT_10") -{ foreign "C" barf("SRT_10 object (%p) entered!", R1) never returns; } +{ ccall pbarf("SRT_10 object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_SRT_11, 11, 0, 0, CONSTR, "SRT_11", "SRT_11") -{ foreign "C" barf("SRT_11 object (%p) entered!", R1) never returns; } +{ ccall pbarf("SRT_11 object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_SRT_12, 12, 0, 0, CONSTR, "SRT_12", "SRT_12") -{ foreign "C" barf("SRT_12 object (%p) entered!", R1) never returns; } +{ ccall pbarf("SRT_12 object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_SRT_13, 13, 0, 0, CONSTR, "SRT_13", "SRT_13") -{ foreign "C" barf("SRT_13 object (%p) entered!", R1) never returns; } +{ ccall pbarf("SRT_13 object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_SRT_14, 14, 0, 0, CONSTR, "SRT_14", "SRT_14") -{ foreign "C" barf("SRT_14 object (%p) entered!", R1) never returns; } +{ ccall pbarf("SRT_14 object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_SRT_15, 15, 0, 0, CONSTR, "SRT_15", "SRT_15") -{ foreign "C" barf("SRT_15 object (%p) entered!", R1) never returns; } +{ ccall pbarf("SRT_15 object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_SRT_16, 16, 0, 0, CONSTR, "SRT_16", "SRT_16") -{ foreign "C" barf("SRT_16 object (%p) entered!", R1) never returns; } +{ ccall pbarf("SRT_16 object (%p) entered!", R1 "ptr") never returns; } /* --------------------------------------------------------------------------- Messages ------------------------------------------------------------------------- */ @@ -844,20 +844,20 @@ INFO_TABLE_CONSTR(stg_SRT_16, 16, 0, 0, CONSTR, "SRT_16", "SRT_16") // PRIM rather than CONSTR, because PRIM objects cannot be duplicated by the GC. INFO_TABLE_CONSTR(stg_MSG_TRY_WAKEUP,2,0,0,PRIM,"MSG_TRY_WAKEUP","MSG_TRY_WAKEUP") -{ foreign "C" barf("MSG_TRY_WAKEUP object (%p) entered!", R1) never returns; } +{ ccall pbarf("MSG_TRY_WAKEUP object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_MSG_THROWTO,4,0,0,PRIM,"MSG_THROWTO","MSG_THROWTO") -{ foreign "C" barf("MSG_THROWTO object (%p) entered!", R1) never returns; } +{ ccall pbarf("MSG_THROWTO object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_MSG_BLACKHOLE,3,0,0,PRIM,"MSG_BLACKHOLE","MSG_BLACKHOLE") -{ foreign "C" barf("MSG_BLACKHOLE object (%p) entered!", R1) never returns; } +{ ccall pbarf("MSG_BLACKHOLE object (%p) entered!", R1 "ptr") never returns; } // used to overwrite a MSG_THROWTO when the message has been used/revoked INFO_TABLE_CONSTR(stg_MSG_NULL,1,0,0,PRIM,"MSG_NULL","MSG_NULL") -{ foreign "C" barf("MSG_NULL object (%p) entered!", R1) never returns; } +{ ccall pbarf("MSG_NULL object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_MSG_CLONE_STACK,3,0,0,PRIM,"MSG_CLONE_STACK","MSG_CLONE_STACK") -{ foreign "C" barf("stg_MSG_CLONE_STACK object (%p) entered!", R1) never returns; } +{ ccall pbarf("stg_MSG_CLONE_STACK object (%p) entered!", R1 "ptr") never returns; } /* ---------------------------------------------------------------------------- END_TSO_QUEUE @@ -867,7 +867,7 @@ INFO_TABLE_CONSTR(stg_MSG_CLONE_STACK,3,0,0,PRIM,"MSG_CLONE_STACK","MSG_CLONE_ST ------------------------------------------------------------------------- */ INFO_TABLE_CONSTR(stg_END_TSO_QUEUE,0,0,0,CONSTR_NOCAF,"END_TSO_QUEUE","END_TSO_QUEUE") -{ foreign "C" barf("END_TSO_QUEUE object (%p) entered!", R1) never returns; } +{ ccall pbarf("END_TSO_QUEUE object (%p) entered!", R1 "ptr") never returns; } CLOSURE(stg_END_TSO_QUEUE_closure,stg_END_TSO_QUEUE); @@ -876,7 +876,7 @@ CLOSURE(stg_END_TSO_QUEUE_closure,stg_END_TSO_QUEUE); ------------------------------------------------------------------------- */ INFO_TABLE_CONSTR(stg_GCD_CAF,0,0,0,CONSTR_NOCAF,"GCD_CAF","GCD_CAF") -{ foreign "C" barf("Evaluated a CAF (%p) that was GC'd!", R1) never returns; } +{ ccall pbarf("Evaluated a CAF (%p) that was GC'd!", R1 "ptr") never returns; } /* ---------------------------------------------------------------------------- STM_AWOKEN @@ -886,7 +886,7 @@ INFO_TABLE_CONSTR(stg_GCD_CAF,0,0,0,CONSTR_NOCAF,"GCD_CAF","GCD_CAF") ------------------------------------------------------------------------- */ INFO_TABLE_CONSTR(stg_STM_AWOKEN,0,0,0,CONSTR_NOCAF,"STM_AWOKEN","STM_AWOKEN") -{ foreign "C" barf("STM_AWOKEN object (%p) entered!", R1) never returns; } +{ ccall pbarf("STM_AWOKEN object (%p) entered!", R1 "ptr") never returns; } CLOSURE(stg_STM_AWOKEN_closure,stg_STM_AWOKEN); @@ -906,40 +906,40 @@ CLOSURE(stg_STM_AWOKEN_closure,stg_STM_AWOKEN); ------------------------------------------------------------------------- */ INFO_TABLE(stg_ARR_WORDS, 0, 0, ARR_WORDS, "ARR_WORDS", "ARR_WORDS") -{ foreign "C" barf("ARR_WORDS object (%p) entered!", R1) never returns; } +{ ccall pbarf("ARR_WORDS object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE(stg_MUT_ARR_PTRS_CLEAN, 0, 0, MUT_ARR_PTRS_CLEAN, "MUT_ARR_PTRS_CLEAN", "MUT_ARR_PTRS_CLEAN") -{ foreign "C" barf("MUT_ARR_PTRS_CLEAN object (%p) entered!", R1) never returns; } +{ ccall pbarf("MUT_ARR_PTRS_CLEAN object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE(stg_MUT_ARR_PTRS_DIRTY, 0, 0, MUT_ARR_PTRS_DIRTY, "MUT_ARR_PTRS_DIRTY", "MUT_ARR_PTRS_DIRTY") -{ foreign "C" barf("MUT_ARR_PTRS_DIRTY object (%p) entered!", R1) never returns; } +{ ccall pbarf("MUT_ARR_PTRS_DIRTY object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE(stg_MUT_ARR_PTRS_FROZEN_CLEAN, 0, 0, MUT_ARR_PTRS_FROZEN_CLEAN, "MUT_ARR_PTRS_FROZEN_CLEAN", "MUT_ARR_PTRS_FROZEN_CLEAN") -{ foreign "C" barf("MUT_ARR_PTRS_FROZEN_CLEAN object (%p) entered!", R1) never returns; } +{ ccall pbarf("MUT_ARR_PTRS_FROZEN_CLEAN object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE(stg_MUT_ARR_PTRS_FROZEN_DIRTY, 0, 0, MUT_ARR_PTRS_FROZEN_DIRTY, "MUT_ARR_PTRS_FROZEN_DIRTY", "MUT_ARR_PTRS_FROZEN_DIRTY") -{ foreign "C" barf("MUT_ARR_PTRS_FROZEN_DIRTY object (%p) entered!", R1) never returns; } +{ ccall pbarf("MUT_ARR_PTRS_FROZEN_DIRTY object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE(stg_SMALL_MUT_ARR_PTRS_CLEAN, 0, 0, SMALL_MUT_ARR_PTRS_CLEAN, "SMALL_MUT_ARR_PTRS_CLEAN", "SMALL_MUT_ARR_PTRS_CLEAN") -{ foreign "C" barf("SMALL_MUT_ARR_PTRS_CLEAN object (%p) entered!", R1) never returns; } +{ ccall pbarf("SMALL_MUT_ARR_PTRS_CLEAN object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE(stg_SMALL_MUT_ARR_PTRS_DIRTY, 0, 0, SMALL_MUT_ARR_PTRS_DIRTY, "SMALL_MUT_ARR_PTRS_DIRTY", "SMALL_MUT_ARR_PTRS_DIRTY") -{ foreign "C" barf("SMALL_MUT_ARR_PTRS_DIRTY object (%p) entered!", R1) never returns; } +{ ccall pbarf("SMALL_MUT_ARR_PTRS_DIRTY object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE(stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN, 0, 0, SMALL_MUT_ARR_PTRS_FROZEN_CLEAN, "SMALL_MUT_ARR_PTRS_FROZEN_CLEAN", "SMALL_MUT_ARR_PTRS_FROZEN_CLEAN") -{ foreign "C" barf("SMALL_MUT_ARR_PTRS_FROZEN_CLEAN object (%p) entered!", R1) never returns; } +{ ccall pbarf("SMALL_MUT_ARR_PTRS_FROZEN_CLEAN object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE(stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY, 0, 0, SMALL_MUT_ARR_PTRS_FROZEN_DIRTY, "SMALL_MUT_ARR_PTRS_FROZEN_DIRTY", "SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") -{ foreign "C" barf("SMALL_MUT_ARR_PTRS_FROZEN_DIRTY object (%p) entered!", R1) never returns; } +{ ccall pbarf("SMALL_MUT_ARR_PTRS_FROZEN_DIRTY object (%p) entered!", R1 "ptr") never returns; } /* ---------------------------------------------------------------------------- Mutable Variables ------------------------------------------------------------------------- */ INFO_TABLE(stg_MUT_VAR_CLEAN, 1, 0, MUT_VAR_CLEAN, "MUT_VAR_CLEAN", "MUT_VAR_CLEAN") -{ foreign "C" barf("MUT_VAR_CLEAN object (%p) entered!", R1) never returns; } +{ ccall pbarf("MUT_VAR_CLEAN object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE(stg_MUT_VAR_DIRTY, 1, 0, MUT_VAR_DIRTY, "MUT_VAR_DIRTY", "MUT_VAR_DIRTY") -{ foreign "C" barf("MUT_VAR_DIRTY object (%p) entered!", R1) never returns; } +{ ccall pbarf("MUT_VAR_DIRTY object (%p) entered!", R1 "ptr") never returns; } /* ---------------------------------------------------------------------------- Dummy return closure @@ -961,7 +961,7 @@ CLOSURE(stg_dummy_ret_closure,stg_dummy_ret); ------------------------------------------------------------------------- */ INFO_TABLE_CONSTR(stg_MVAR_TSO_QUEUE,2,0,0,PRIM,"MVAR_TSO_QUEUE","MVAR_TSO_QUEUE") -{ foreign "C" barf("MVAR_TSO_QUEUE object (%p) entered!", R1) never returns; } +{ ccall pbarf("MVAR_TSO_QUEUE object (%p) entered!", R1 "ptr") never returns; } /* ---------------------------------------------------------------------------- COMPACT_NFDATA (a blob of data in NF with no outgoing pointers) @@ -974,11 +974,11 @@ INFO_TABLE_CONSTR(stg_MVAR_TSO_QUEUE,2,0,0,PRIM,"MVAR_TSO_QUEUE","MVAR_TSO_QUEUE INFO_TABLE( stg_COMPACT_NFDATA_CLEAN, 0, 9, COMPACT_NFDATA, "COMPACT_NFDATA", "COMPACT_NFDATA") () -{ foreign "C" barf("COMPACT_NFDATA_CLEAN object (%p) entered!", R1) never returns; } +{ ccall pbarf("COMPACT_NFDATA_CLEAN object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE( stg_COMPACT_NFDATA_DIRTY, 0, 9, COMPACT_NFDATA, "COMPACT_NFDATA", "COMPACT_NFDATA") () -{ foreign "C" barf("COMPACT_NFDATA_DIRTY object (%p) entered!", R1) never returns; } +{ ccall pbarf("COMPACT_NFDATA_DIRTY object (%p) entered!", R1 "ptr") never returns; } /* ---------------------------------------------------------------------------- ClosureTable element null value @@ -988,7 +988,7 @@ INFO_TABLE( stg_COMPACT_NFDATA_DIRTY, 0, 9, COMPACT_NFDATA, "COMPACT_NFDATA", "C ------------------------------------------------------------------------- */ INFO_TABLE_CONSTR(stg_CLOSURE_TABLE_NULL,0,0,0,CONSTR_NOCAF,"CLOSURE_TABLE_NULL","CLOSURE_TABLE_NULL") -{ foreign "C" barf("CLOSURE_TABLE_NULL object (%p) entered!", R1) never returns; } +{ ccall pbarf("CLOSURE_TABLE_NULL object (%p) entered!", R1 "ptr") never returns; } CLOSURE(stg_CLOSURE_TABLE_NULL_closure,stg_CLOSURE_TABLE_NULL); @@ -1003,10 +1003,10 @@ INFO_TABLE_CONSTR(stg_TIMEOUT_QUEUE, stg_TIMEOUT_QUEUE_NUM_PTRS, stg_TIMEOUT_QUEUE_NUM_NONPTRS, 0,MUT_PRIM,"TIMEOUT_QUEUE","TIMEOUT_QUEUE") -{ foreign "C" barf("TIMEOUT_QUEUE object (%p) entered!", R1) never returns; } +{ ccall pbarf("TIMEOUT_QUEUE object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_TIMEOUT_QUEUE_EMPTY,0,0,0,CONSTR_NOCAF,"TIMEOUT_QUEUE_EMPTY","TIMEOUT_QUEUE_EMPTY") -{ foreign "C" barf("TIMEOUT_QUEUE_EMPTY object (%p) entered!", R1) never returns; } +{ ccall pbarf("TIMEOUT_QUEUE_EMPTY object (%p) entered!", R1 "ptr") never returns; } CLOSURE(stg_TIMEOUT_QUEUE_EMPTY_closure,stg_TIMEOUT_QUEUE_EMPTY); @@ -1022,9 +1022,9 @@ INFO_TABLE_CONSTR(stg_ASYNCIOOP, stg_ASYNCIOOP_NUM_PTRS, stg_ASYNCIOOP_NUM_NONPTRS, 0,PRIM,"ASYNCIOOP","ASYNCIOOP") -{ foreign "C" barf("ASYNCIOOP object (%p) entered!", R1) never returns; } +{ ccall pbarf("ASYNCIOOP object (%p) entered!", R1 "ptr") never returns; } INFO_TABLE_CONSTR(stg_ASYNCIO_LIVE0,0,0,0,CONSTR_NOCAF,"ASYNCIO_LIVE0","ASYNCIO_LIVE0") -{ foreign "C" barf("ASYNCIO_LIVE0 object (%p) entered!", R1) never returns; } +{ ccall pbarf("ASYNCIO_LIVE0 object (%p) entered!", R1 "ptr") never returns; } CLOSURE(stg_ASYNCIO_LIVE0_closure,stg_ASYNCIO_LIVE0); ===================================== rts/StgStartup.cmm ===================================== @@ -178,5 +178,5 @@ INFO_TABLE_RET(stg_forceIO, RET_SMALL, P_ info_ptr) /* Called when compiled with -falignment-sanitisation on alignment failure */ stg_badAlignment_entry { - foreign "C" barf("stg_badAlignment_entry", NULL); + ccall sbarf("stg_badAlignment_entry") never returns; } ===================================== rts/include/rts/Messages.h ===================================== @@ -37,6 +37,18 @@ void barf(const char *s, ...) void vbarf(const char *s, va_list ap) STG_NORETURN; +/* Non-variadic wrapper around barf(), used by the code generator. */ +void sbarf(const char *s) + STG_NORETURN; + +/* Non-variadic wrapper around barf() for a format string and one pointer. */ +void pbarf(const char *fmt, void *p) + STG_NORETURN; + +/* Non-variadic wrapper around barf() for a format string and one string. */ +void ssbarf(const char *fmt, const char *s) + STG_NORETURN; + // declared in Rts.h: // extern void _assertFail(const char *filename, unsigned int linenum) // STG_NORETURN; ===================================== testsuite/tests/simplStg/should_compile/all.T ===================================== @@ -19,8 +19,6 @@ test('T22840', [extra_files( [ 'T22840A.hs' , 'T22840B.hs' ]), - # barf signature mismatch on wasm32 due to -dtag-inference-checks - when(arch('wasm32'), skip), when(not(have_dynamic()),skip)], multimod_compile, ['T22840', '-dynamic-too -dtag-inference-checks']) test('inferTags003', [ only_ways(['optasm']), grep_errmsg(r'(call stg\_ap\_0)', [1]) ===================================== utils/genapply/Main.hs ===================================== @@ -79,7 +79,7 @@ in a conditional. For example, stg_stk_save_v32 looks like: V32_[Sp+WDS(3)] = YMM1; ... #else - foreign "C" barf("stg_stk_save_v32: unsupported vector register", NULL) never returns; + ccall sbarf("stg_stk_save_v32: unsupported vector register") never returns; #endif } @@ -344,7 +344,7 @@ vecsCpp fun regs code = , text "#if" <+> cond ] ++ code ++ [ text "#else //" <+> cond - , text "foreign \"C\" barf(\"" <> fun <> text ": unsupported vector register\", NULL) never returns;" + , text "ccall sbarf(\"" <> fun <> text ": unsupported vector register\") never returns;" , text "#endif //" <+> cond ] @@ -1049,7 +1049,7 @@ genApply targetInfo args = text "default: {", nest 4 ( - text "foreign \"C\" barf(\"" <> fun_ret_label <> text "\", NULL) never returns;" + text "ccall sbarf(\"" <> fun_ret_label <> text "\") never returns;" ), text "}" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1ca4b49a561447222072a44320fa9b0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1ca4b49a561447222072a44320fa9b0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] rts: use __builtin_mul_overflow for hs_mulIntMayOflo
by Marge Bot (＠marge-bot) 18 Dec '25

18 Dec '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 5729418c by Cheng Shao at 2025-12-18T13:22:29-05:00 rts: use __builtin_mul_overflow for hs_mulIntMayOflo This patch uses `__builtin_mul_overflow` to implement `hs_mulIntMayOflo`. This is a GNU C checked arithmetic builtin function supported by gcc/clang, is type-generic so works for both 32-bit/64-bit, and makes the code both more efficient and easier to read/maintain than the previous hand rolled logic. - - - - - 3 changed files: - compiler/GHC/CmmToC.hs - rts/include/Stg.h - rts/prim/mulIntMayOflo.c Changes: ===================================== compiler/GHC/CmmToC.hs ===================================== @@ -426,7 +426,7 @@ pprMachOpApp :: Platform -> MachOp -> [CmmExpr] -> SDoc pprMachOpApp platform op args | isMulMayOfloOp op - = text "mulIntMayOflo" <> parens (commafy (map (pprExpr platform) args)) + = text "hs_mulIntMayOflo" <> parens (commafy (map (pprExpr platform) args)) where isMulMayOfloOp (MO_S_MulMayOflo _) = True isMulMayOfloOp _ = False ===================================== rts/include/Stg.h ===================================== @@ -519,79 +519,3 @@ INLINE_HEADER StgInt64 PK_Int64(W_ p_src[]) } #endif /* SIZEOF_HSWORD == 4 */ - -/* ----------------------------------------------------------------------------- - Integer multiply with overflow - -------------------------------------------------------------------------- */ - -/* Multiply with overflow checking. - * - * This is tricky - the usual sign rules for add/subtract don't apply. - * - * On 32-bit machines we use gcc's 'long long' types, finding - * overflow with some careful bit-twiddling. - * - * On 64-bit machines where gcc's 'long long' type is also 64-bits, - * we use a crude approximation, testing whether either operand is - * larger than 32-bits; if neither is, then we go ahead with the - * multiplication. - * - * Return non-zero if there is any possibility that the signed multiply - * of a and b might overflow. Return zero only if you are absolutely sure - * that it won't overflow. If in doubt, return non-zero. - */ - -#if SIZEOF_VOID_P == 4 - -#if defined(WORDS_BIGENDIAN) -#define RTS_CARRY_IDX__ 0 -#define RTS_REM_IDX__ 1 -#else -#define RTS_CARRY_IDX__ 1 -#define RTS_REM_IDX__ 0 -#endif - -typedef union { - StgInt64 l; - StgInt32 i[2]; -} long_long_u ; - -#define mulIntMayOflo(a,b) \ -({ \ - StgInt32 r, c; \ - long_long_u z; \ - z.l = (StgInt64)a * (StgInt64)b; \ - r = z.i[RTS_REM_IDX__]; \ - c = z.i[RTS_CARRY_IDX__]; \ - if (c == 0 || c == -1) { \ - c = ((StgWord)((a^b) ^ r)) \ - >> (BITS_IN (I_) - 1); \ - } \ - c; \ -}) - -/* Careful: the carry calculation above is extremely delicate. Make sure - * you test it thoroughly after changing it. - */ - -#else - -/* Approximate version when we don't have long arithmetic (on 64-bit archs) */ - -/* If we have n-bit words then we have n-1 bits after accounting for the - * sign bit, so we can fit the result of multiplying 2 (n-1)/2-bit numbers */ -#define HALF_POS_INT (((I_)1) << ((BITS_IN (I_) - 1) / 2)) -#define HALF_NEG_INT (-HALF_POS_INT) - -#define mulIntMayOflo(a,b) \ -({ \ - I_ c; \ - if ((I_)a <= HALF_NEG_INT || a >= HALF_POS_INT \ - || (I_)b <= HALF_NEG_INT || b >= HALF_POS_INT) {\ - c = 1; \ - } else { \ - c = 0; \ - } \ - c; \ -}) -#endif ===================================== rts/prim/mulIntMayOflo.c ===================================== @@ -1,3 +1,6 @@ #include "Rts.h" -W_ hs_mulIntMayOflo(W_ a, W_ b) { return mulIntMayOflo(a, b); } +W_ hs_mulIntMayOflo(W_ a, W_ b) { + I_ r; + return (W_)__builtin_mul_overflow((I_)a, (I_)b, &r); +} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5729418c5b017cff5e722ec42c91e73… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5729418c5b017cff5e722ec42c91e73… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Doc: document -pgmi "" (#26634)
by Marge Bot (＠marge-bot) 18 Dec '25

18 Dec '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 3995187c by Sylvain Henry at 2025-12-18T13:21:45-05:00 Doc: document -pgmi "" (#26634) - - - - - 1 changed file: - docs/users_guide/phases.rst Changes: ===================================== docs/users_guide/phases.rst ===================================== @@ -155,6 +155,14 @@ given compilation phase: :ghc-flag:`-prof` is enabled, ``ghc-iserv-dyn`` if :ghc-flag:`-dynamic` is enabled, or ``ghc-iserv`` otherwise. + If <cmd> is the empty string then GHC will try to build an appropriate iserv + program for the target platform. It does this by looking for the installed + ``ghci`` unit and by building an executable program that uses + ``ghci:GHCi.Server.defaultServer`` as an entry point. Note that it doesn't + work when cross-compiling: the cross-compiled ``iserv`` program (if it can + be built) can't be run on the build platform. + + .. _forcing-options-through: Forcing options to a particular phase View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3995187c5d2d71984acd79d045aca7a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3995187c5d2d71984acd79d045aca7a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] testsuite: improve coverage of foundation test
by Marge Bot (＠marge-bot) 18 Dec '25

18 Dec '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: bd38b76c by Cheng Shao at 2025-12-18T13:20:31-05:00 testsuite: improve coverage of foundation test This patch refactors the `foundation` test a bit to improve coverage: - Instead of using a hard-coded seed, a random seed is now taken from the command line, and printed upon test failure. This improves test coverage over many future CI runs, and shall a failure occur, the seed is available in the CI log for local reproduction. - The iterations count is bumped to 1000 instead of 100, similar to the bump in `test-primops`. Runtime timeout is bumped 2x just to be safe. - Improve `newLCGGen` by using non-atomic loads/stores on a `MutableByteArray#` for storing mutable `Word64`, this test doesn't use parallelism in the first place - Fixed a few compiler warnings and removed redundant pragmas and imports Co-authored-by: Codex <codex(a)openai.com> - - - - - 3 changed files: - testsuite/tests/numeric/should_run/all.T - testsuite/tests/numeric/should_run/foundation.hs - testsuite/tests/numeric/should_run/foundation.stdout Changes: ===================================== testsuite/tests/numeric/should_run/all.T ===================================== @@ -3,6 +3,8 @@ # extra run flags # expected process return value, if not zero +import random + test('arith001', normal, compile_and_run, ['']) test('arith002', normal, compile_and_run, ['']) test('arith003', normal, compile_and_run, ['']) @@ -82,7 +84,7 @@ test('IntegerToFloat', normal, compile_and_run, ['']) test('T20291', normal, compile_and_run, ['']) test('T22282', normal, compile_and_run, ['']) test('T22671', js_fragile(24259), compile_and_run, ['']) -test('foundation', [when(js_arch(), run_timeout_multiplier(2)), js_fragile(24259), extra_ways(['optasm','ghci','ghci-opt'])], compile_and_run, ['-package transformers -fno-break-points']) +test('foundation', [run_timeout_multiplier(2), js_fragile(24259), extra_ways(['optasm','ghci','ghci-opt']), extra_run_opts(str(random.getrandbits(64)))], compile_and_run, ['-fno-break-points']) test('T24066', normal, compile_and_run, ['']) test('div01', normal, compile_and_run, ['']) test('T24245', normal, compile_and_run, ['']) ===================================== testsuite/tests/numeric/should_run/foundation.hs ===================================== @@ -10,9 +10,7 @@ compare the result of the primop wrappers with the results of interpretation. -} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeAbstractions #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DerivingStrategies #-} @@ -25,28 +23,23 @@ module Main ( main ) where +import Data.Array.Byte import Data.Bits (Bits((.&.), bit), FiniteBits, finiteBitSize) import Data.Word import Data.Int import GHC.Natural import Data.Typeable -import Data.Proxy import GHC.Int import GHC.Word -import GHC.Word import Data.Function import GHC.Prim import Control.Monad.Reader -import System.IO -import Foreign.Marshal.Alloc -import Foreign.Storable -import Foreign.Ptr import Data.List (intercalate) -import Data.IORef +import System.Environment (getArgs) +import Text.Read (readMaybe) import Unsafe.Coerce import GHC.Types import Data.Char -import Data.Semigroup import System.Exit import qualified GHC.Internal.PrimopWrappers as Wrapper @@ -194,11 +187,16 @@ newtype LCGGen = LCGGen { randomWord64 :: IO Word64 } data LCGParams = LCGParams { seed :: Word64, a :: Word64, c :: Word64, m :: Word64 } newLCGGen :: LCGParams -> IO LCGGen -newLCGGen LCGParams{..} = do - var <- newIORef (fromIntegral seed) - return $ LCGGen $ do - atomicModifyIORef' var (\old_v -> let new_val = (old_v * a + c) `mod` m in (new_val, new_val)) - +newLCGGen LCGParams {seed = W64# seed#, ..} = do + MutableByteArray mba# <- IO $ \s0 -> case newByteArray# 8# s0 of + (# s1, mba# #) -> case writeWord64Array# mba# 0# seed# s1 of + s2 -> (# s2, MutableByteArray mba# #) + pure $ LCGGen $ IO $ \s0 -> case readWord64Array# mba# 0# s0 of + (# s1, old_val# #) -> + let old_val = W64# old_val# + !new_val@(W64# new_val#) = (old_val * a + c) `mod` m + in case writeWord64Array# mba# 0# new_val# s1 of + s2 -> (# s2, new_val #) runPropertyCheck (PropertyBinaryOp res desc s1 s2) = if res then return Success @@ -211,7 +209,7 @@ runPropertyCheck (PropertyAnd a1 a2) = (<>) <$> runPropertyCheck a1 <*> runPrope runProperty :: Property -> ReaderT RunS IO Result runProperty (Prop p) = do - let iterations = 100 + let iterations = 1000 :: Int loop iterations iterations where loop iterations 0 = do @@ -257,14 +255,15 @@ runTestInternal (Property name p) = do nest label $ runProperty (property p) -runTests :: Test -> IO () -runTests t = do +runTests :: Word64 -> Test -> IO () +runTests seed t = do -- These params are the same ones as glibc uses. - h <- newLCGGen (LCGParams { seed = 1238123213, m = 2^31, a = 1103515245, c = 12345 }) + h <- newLCGGen (LCGParams { seed, m = 2 ^ (31 :: Int), a = 1103515245, c = 12345 }) res <- runReaderT (runTestInternal t) (RunS 0 h []) case res of Success -> return () Failure tests -> do + putStrLn $ "Seed: " ++ show seed putStrLn $ "These tests failed: \n" ++ intercalate " \n" (map (showStack 0 . reverse) tests) exitFailure @@ -455,7 +454,19 @@ instance TestPrimop LowerBitsAreDefined where twoNonZero :: (a -> a -> b) -> a -> NonZero a -> b twoNonZero f x (NonZero y) = f x y -main = runTests (Group "ALL" [testNumberRefs, testPrimops]) +getSeedFromArgs :: IO Word64 +getSeedFromArgs = do + args <- getArgs + case args of + [arg] -> case readMaybe arg of + Just seed -> pure seed + Nothing -> die $ "Invalid seed (expected Word64): " ++ show arg + _ -> die "Usage: foundation <seed>" + +main :: IO () +main = do + seed <- getSeedFromArgs + runTests seed (Group "ALL" [testNumberRefs, testPrimops]) -- Test an interpreted primop vs a compiled primop testPrimops = Group "primop" ===================================== testsuite/tests/numeric/should_run/foundation.stdout ===================================== @@ -3,1048 +3,1048 @@ Group ALL Group Int Group Integral Running FromIntegral(Integer(a)) == a - Passed 100 iterations + Passed 1000 iterations Group Property Running Eq - Passed 100 iterations + Passed 1000 iterations Running Show - Passed 100 iterations + Passed 1000 iterations Running Ord - Passed 100 iterations + Passed 1000 iterations Running < - Passed 100 iterations + Passed 1000 iterations Group Additive Running a + azero == a - Passed 100 iterations + Passed 1000 iterations Running azero + a == a - Passed 100 iterations + Passed 1000 iterations Running a + b == b + a - Passed 100 iterations + Passed 1000 iterations Group Multiplicative Running a * 1 == a - Passed 100 iterations + Passed 1000 iterations Running 1 * a == a - Passed 100 iterations + Passed 1000 iterations Running multiplication commutative - Passed 100 iterations + Passed 1000 iterations Running a * b == Integer(a) * Integer(b) - Passed 100 iterations + Passed 1000 iterations Group Divisible Running (x `div` y) * y + (x `mod` y) == x - Passed 100 iterations + Passed 1000 iterations Group Precedence Running + and - (1) - Passed 100 iterations + Passed 1000 iterations Running + and - (2) - Passed 100 iterations + Passed 1000 iterations Running + and * (1) - Passed 100 iterations + Passed 1000 iterations Running + and * (2) - Passed 100 iterations + Passed 1000 iterations Running - and * (1) - Passed 100 iterations + Passed 1000 iterations Running - and * (2) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (1) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (2) - Passed 100 iterations + Passed 1000 iterations Group Int8 Group Integral Running FromIntegral(Integer(a)) == a - Passed 100 iterations + Passed 1000 iterations Group Property Running Eq - Passed 100 iterations + Passed 1000 iterations Running Show - Passed 100 iterations + Passed 1000 iterations Running Ord - Passed 100 iterations + Passed 1000 iterations Running < - Passed 100 iterations + Passed 1000 iterations Group Additive Running a + azero == a - Passed 100 iterations + Passed 1000 iterations Running azero + a == a - Passed 100 iterations + Passed 1000 iterations Running a + b == b + a - Passed 100 iterations + Passed 1000 iterations Group Multiplicative Running a * 1 == a - Passed 100 iterations + Passed 1000 iterations Running 1 * a == a - Passed 100 iterations + Passed 1000 iterations Running multiplication commutative - Passed 100 iterations + Passed 1000 iterations Running a * b == Integer(a) * Integer(b) - Passed 100 iterations + Passed 1000 iterations Group Divisible Running (x `div` y) * y + (x `mod` y) == x - Passed 100 iterations + Passed 1000 iterations Group Precedence Running + and - (1) - Passed 100 iterations + Passed 1000 iterations Running + and - (2) - Passed 100 iterations + Passed 1000 iterations Running + and * (1) - Passed 100 iterations + Passed 1000 iterations Running + and * (2) - Passed 100 iterations + Passed 1000 iterations Running - and * (1) - Passed 100 iterations + Passed 1000 iterations Running - and * (2) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (1) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (2) - Passed 100 iterations + Passed 1000 iterations Group Int16 Group Integral Running FromIntegral(Integer(a)) == a - Passed 100 iterations + Passed 1000 iterations Group Property Running Eq - Passed 100 iterations + Passed 1000 iterations Running Show - Passed 100 iterations + Passed 1000 iterations Running Ord - Passed 100 iterations + Passed 1000 iterations Running < - Passed 100 iterations + Passed 1000 iterations Group Additive Running a + azero == a - Passed 100 iterations + Passed 1000 iterations Running azero + a == a - Passed 100 iterations + Passed 1000 iterations Running a + b == b + a - Passed 100 iterations + Passed 1000 iterations Group Multiplicative Running a * 1 == a - Passed 100 iterations + Passed 1000 iterations Running 1 * a == a - Passed 100 iterations + Passed 1000 iterations Running multiplication commutative - Passed 100 iterations + Passed 1000 iterations Running a * b == Integer(a) * Integer(b) - Passed 100 iterations + Passed 1000 iterations Group Divisible Running (x `div` y) * y + (x `mod` y) == x - Passed 100 iterations + Passed 1000 iterations Group Precedence Running + and - (1) - Passed 100 iterations + Passed 1000 iterations Running + and - (2) - Passed 100 iterations + Passed 1000 iterations Running + and * (1) - Passed 100 iterations + Passed 1000 iterations Running + and * (2) - Passed 100 iterations + Passed 1000 iterations Running - and * (1) - Passed 100 iterations + Passed 1000 iterations Running - and * (2) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (1) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (2) - Passed 100 iterations + Passed 1000 iterations Group Int32 Group Integral Running FromIntegral(Integer(a)) == a - Passed 100 iterations + Passed 1000 iterations Group Property Running Eq - Passed 100 iterations + Passed 1000 iterations Running Show - Passed 100 iterations + Passed 1000 iterations Running Ord - Passed 100 iterations + Passed 1000 iterations Running < - Passed 100 iterations + Passed 1000 iterations Group Additive Running a + azero == a - Passed 100 iterations + Passed 1000 iterations Running azero + a == a - Passed 100 iterations + Passed 1000 iterations Running a + b == b + a - Passed 100 iterations + Passed 1000 iterations Group Multiplicative Running a * 1 == a - Passed 100 iterations + Passed 1000 iterations Running 1 * a == a - Passed 100 iterations + Passed 1000 iterations Running multiplication commutative - Passed 100 iterations + Passed 1000 iterations Running a * b == Integer(a) * Integer(b) - Passed 100 iterations + Passed 1000 iterations Group Divisible Running (x `div` y) * y + (x `mod` y) == x - Passed 100 iterations + Passed 1000 iterations Group Precedence Running + and - (1) - Passed 100 iterations + Passed 1000 iterations Running + and - (2) - Passed 100 iterations + Passed 1000 iterations Running + and * (1) - Passed 100 iterations + Passed 1000 iterations Running + and * (2) - Passed 100 iterations + Passed 1000 iterations Running - and * (1) - Passed 100 iterations + Passed 1000 iterations Running - and * (2) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (1) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (2) - Passed 100 iterations + Passed 1000 iterations Group Int64 Group Integral Running FromIntegral(Integer(a)) == a - Passed 100 iterations + Passed 1000 iterations Group Property Running Eq - Passed 100 iterations + Passed 1000 iterations Running Show - Passed 100 iterations + Passed 1000 iterations Running Ord - Passed 100 iterations + Passed 1000 iterations Running < - Passed 100 iterations + Passed 1000 iterations Group Additive Running a + azero == a - Passed 100 iterations + Passed 1000 iterations Running azero + a == a - Passed 100 iterations + Passed 1000 iterations Running a + b == b + a - Passed 100 iterations + Passed 1000 iterations Group Multiplicative Running a * 1 == a - Passed 100 iterations + Passed 1000 iterations Running 1 * a == a - Passed 100 iterations + Passed 1000 iterations Running multiplication commutative - Passed 100 iterations + Passed 1000 iterations Running a * b == Integer(a) * Integer(b) - Passed 100 iterations + Passed 1000 iterations Group Divisible Running (x `div` y) * y + (x `mod` y) == x - Passed 100 iterations + Passed 1000 iterations Group Precedence Running + and - (1) - Passed 100 iterations + Passed 1000 iterations Running + and - (2) - Passed 100 iterations + Passed 1000 iterations Running + and * (1) - Passed 100 iterations + Passed 1000 iterations Running + and * (2) - Passed 100 iterations + Passed 1000 iterations Running - and * (1) - Passed 100 iterations + Passed 1000 iterations Running - and * (2) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (1) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (2) - Passed 100 iterations + Passed 1000 iterations Group Integer Group Integral Running FromIntegral(Integer(a)) == a - Passed 100 iterations + Passed 1000 iterations Group Property Running Eq - Passed 100 iterations + Passed 1000 iterations Running Show - Passed 100 iterations + Passed 1000 iterations Running Ord - Passed 100 iterations + Passed 1000 iterations Running < - Passed 100 iterations + Passed 1000 iterations Group Additive Running a + azero == a - Passed 100 iterations + Passed 1000 iterations Running azero + a == a - Passed 100 iterations + Passed 1000 iterations Running a + b == b + a - Passed 100 iterations + Passed 1000 iterations Group Multiplicative Running a * 1 == a - Passed 100 iterations + Passed 1000 iterations Running 1 * a == a - Passed 100 iterations + Passed 1000 iterations Running multiplication commutative - Passed 100 iterations + Passed 1000 iterations Running a * b == Integer(a) * Integer(b) - Passed 100 iterations + Passed 1000 iterations Group Divisible Running (x `div` y) * y + (x `mod` y) == x - Passed 100 iterations + Passed 1000 iterations Group Precedence Running + and - (1) - Passed 100 iterations + Passed 1000 iterations Running + and - (2) - Passed 100 iterations + Passed 1000 iterations Running + and * (1) - Passed 100 iterations + Passed 1000 iterations Running + and * (2) - Passed 100 iterations + Passed 1000 iterations Running - and * (1) - Passed 100 iterations + Passed 1000 iterations Running - and * (2) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (1) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (2) - Passed 100 iterations + Passed 1000 iterations Group Word Group Integral Running FromIntegral(Integer(a)) == a - Passed 100 iterations + Passed 1000 iterations Group Property Running Eq - Passed 100 iterations + Passed 1000 iterations Running Show - Passed 100 iterations + Passed 1000 iterations Running Ord - Passed 100 iterations + Passed 1000 iterations Running < - Passed 100 iterations + Passed 1000 iterations Group Additive Running a + azero == a - Passed 100 iterations + Passed 1000 iterations Running azero + a == a - Passed 100 iterations + Passed 1000 iterations Running a + b == b + a - Passed 100 iterations + Passed 1000 iterations Group Multiplicative Running a * 1 == a - Passed 100 iterations + Passed 1000 iterations Running 1 * a == a - Passed 100 iterations + Passed 1000 iterations Running multiplication commutative - Passed 100 iterations + Passed 1000 iterations Running a * b == Integer(a) * Integer(b) - Passed 100 iterations + Passed 1000 iterations Group Divisible Running (x `div` y) * y + (x `mod` y) == x - Passed 100 iterations + Passed 1000 iterations Group Precedence Running + and - (1) - Passed 100 iterations + Passed 1000 iterations Running + and - (2) - Passed 100 iterations + Passed 1000 iterations Running + and * (1) - Passed 100 iterations + Passed 1000 iterations Running + and * (2) - Passed 100 iterations + Passed 1000 iterations Running - and * (1) - Passed 100 iterations + Passed 1000 iterations Running - and * (2) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (1) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (2) - Passed 100 iterations + Passed 1000 iterations Group Word8 Group Integral Running FromIntegral(Integer(a)) == a - Passed 100 iterations + Passed 1000 iterations Group Property Running Eq - Passed 100 iterations + Passed 1000 iterations Running Show - Passed 100 iterations + Passed 1000 iterations Running Ord - Passed 100 iterations + Passed 1000 iterations Running < - Passed 100 iterations + Passed 1000 iterations Group Additive Running a + azero == a - Passed 100 iterations + Passed 1000 iterations Running azero + a == a - Passed 100 iterations + Passed 1000 iterations Running a + b == b + a - Passed 100 iterations + Passed 1000 iterations Group Multiplicative Running a * 1 == a - Passed 100 iterations + Passed 1000 iterations Running 1 * a == a - Passed 100 iterations + Passed 1000 iterations Running multiplication commutative - Passed 100 iterations + Passed 1000 iterations Running a * b == Integer(a) * Integer(b) - Passed 100 iterations + Passed 1000 iterations Group Divisible Running (x `div` y) * y + (x `mod` y) == x - Passed 100 iterations + Passed 1000 iterations Group Precedence Running + and - (1) - Passed 100 iterations + Passed 1000 iterations Running + and - (2) - Passed 100 iterations + Passed 1000 iterations Running + and * (1) - Passed 100 iterations + Passed 1000 iterations Running + and * (2) - Passed 100 iterations + Passed 1000 iterations Running - and * (1) - Passed 100 iterations + Passed 1000 iterations Running - and * (2) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (1) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (2) - Passed 100 iterations + Passed 1000 iterations Group Word16 Group Integral Running FromIntegral(Integer(a)) == a - Passed 100 iterations + Passed 1000 iterations Group Property Running Eq - Passed 100 iterations + Passed 1000 iterations Running Show - Passed 100 iterations + Passed 1000 iterations Running Ord - Passed 100 iterations + Passed 1000 iterations Running < - Passed 100 iterations + Passed 1000 iterations Group Additive Running a + azero == a - Passed 100 iterations + Passed 1000 iterations Running azero + a == a - Passed 100 iterations + Passed 1000 iterations Running a + b == b + a - Passed 100 iterations + Passed 1000 iterations Group Multiplicative Running a * 1 == a - Passed 100 iterations + Passed 1000 iterations Running 1 * a == a - Passed 100 iterations + Passed 1000 iterations Running multiplication commutative - Passed 100 iterations + Passed 1000 iterations Running a * b == Integer(a) * Integer(b) - Passed 100 iterations + Passed 1000 iterations Group Divisible Running (x `div` y) * y + (x `mod` y) == x - Passed 100 iterations + Passed 1000 iterations Group Precedence Running + and - (1) - Passed 100 iterations + Passed 1000 iterations Running + and - (2) - Passed 100 iterations + Passed 1000 iterations Running + and * (1) - Passed 100 iterations + Passed 1000 iterations Running + and * (2) - Passed 100 iterations + Passed 1000 iterations Running - and * (1) - Passed 100 iterations + Passed 1000 iterations Running - and * (2) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (1) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (2) - Passed 100 iterations + Passed 1000 iterations Group Word32 Group Integral Running FromIntegral(Integer(a)) == a - Passed 100 iterations + Passed 1000 iterations Group Property Running Eq - Passed 100 iterations + Passed 1000 iterations Running Show - Passed 100 iterations + Passed 1000 iterations Running Ord - Passed 100 iterations + Passed 1000 iterations Running < - Passed 100 iterations + Passed 1000 iterations Group Additive Running a + azero == a - Passed 100 iterations + Passed 1000 iterations Running azero + a == a - Passed 100 iterations + Passed 1000 iterations Running a + b == b + a - Passed 100 iterations + Passed 1000 iterations Group Multiplicative Running a * 1 == a - Passed 100 iterations + Passed 1000 iterations Running 1 * a == a - Passed 100 iterations + Passed 1000 iterations Running multiplication commutative - Passed 100 iterations + Passed 1000 iterations Running a * b == Integer(a) * Integer(b) - Passed 100 iterations + Passed 1000 iterations Group Divisible Running (x `div` y) * y + (x `mod` y) == x - Passed 100 iterations + Passed 1000 iterations Group Precedence Running + and - (1) - Passed 100 iterations + Passed 1000 iterations Running + and - (2) - Passed 100 iterations + Passed 1000 iterations Running + and * (1) - Passed 100 iterations + Passed 1000 iterations Running + and * (2) - Passed 100 iterations + Passed 1000 iterations Running - and * (1) - Passed 100 iterations + Passed 1000 iterations Running - and * (2) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (1) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (2) - Passed 100 iterations + Passed 1000 iterations Group Word64 Group Integral Running FromIntegral(Integer(a)) == a - Passed 100 iterations + Passed 1000 iterations Group Property Running Eq - Passed 100 iterations + Passed 1000 iterations Running Show - Passed 100 iterations + Passed 1000 iterations Running Ord - Passed 100 iterations + Passed 1000 iterations Running < - Passed 100 iterations + Passed 1000 iterations Group Additive Running a + azero == a - Passed 100 iterations + Passed 1000 iterations Running azero + a == a - Passed 100 iterations + Passed 1000 iterations Running a + b == b + a - Passed 100 iterations + Passed 1000 iterations Group Multiplicative Running a * 1 == a - Passed 100 iterations + Passed 1000 iterations Running 1 * a == a - Passed 100 iterations + Passed 1000 iterations Running multiplication commutative - Passed 100 iterations + Passed 1000 iterations Running a * b == Integer(a) * Integer(b) - Passed 100 iterations + Passed 1000 iterations Group Divisible Running (x `div` y) * y + (x `mod` y) == x - Passed 100 iterations + Passed 1000 iterations Group Precedence Running + and - (1) - Passed 100 iterations + Passed 1000 iterations Running + and - (2) - Passed 100 iterations + Passed 1000 iterations Running + and * (1) - Passed 100 iterations + Passed 1000 iterations Running + and * (2) - Passed 100 iterations + Passed 1000 iterations Running - and * (1) - Passed 100 iterations + Passed 1000 iterations Running - and * (2) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (1) - Passed 100 iterations + Passed 1000 iterations Running * and ^ (2) - Passed 100 iterations + Passed 1000 iterations Group primop Running gtChar# - Passed 100 iterations + Passed 1000 iterations Running geChar# - Passed 100 iterations + Passed 1000 iterations Running eqChar# - Passed 100 iterations + Passed 1000 iterations Running neChar# - Passed 100 iterations + Passed 1000 iterations Running ltChar# - Passed 100 iterations + Passed 1000 iterations Running leChar# - Passed 100 iterations + Passed 1000 iterations Running ord# - Passed 100 iterations + Passed 1000 iterations Running int8ToInt# - Passed 100 iterations + Passed 1000 iterations Running intToInt8# - Passed 100 iterations + Passed 1000 iterations Running negateInt8# - Passed 100 iterations + Passed 1000 iterations Running plusInt8# - Passed 100 iterations + Passed 1000 iterations Running subInt8# - Passed 100 iterations + Passed 1000 iterations Running timesInt8# - Passed 100 iterations + Passed 1000 iterations Running quotInt8# - Passed 100 iterations + Passed 1000 iterations Running remInt8# - Passed 100 iterations + Passed 1000 iterations Running quotRemInt8# - Passed 100 iterations + Passed 1000 iterations Running uncheckedShiftLInt8# - Passed 100 iterations + Passed 1000 iterations Running uncheckedShiftRAInt8# - Passed 100 iterations + Passed 1000 iterations Running uncheckedShiftRLInt8# - Passed 100 iterations + Passed 1000 iterations Running int8ToWord8# - Passed 100 iterations + Passed 1000 iterations Running eqInt8# - Passed 100 iterations + Passed 1000 iterations Running geInt8# - Passed 100 iterations + Passed 1000 iterations Running gtInt8# - Passed 100 iterations + Passed 1000 iterations Running leInt8# - Passed 100 iterations + Passed 1000 iterations Running ltInt8# - Passed 100 iterations + Passed 1000 iterations Running neInt8# - Passed 100 iterations + Passed 1000 iterations Running word8ToWord# - Passed 100 iterations + Passed 1000 iterations Running wordToWord8# - Passed 100 iterations + Passed 1000 iterations Running plusWord8# - Passed 100 iterations + Passed 1000 iterations Running subWord8# - Passed 100 iterations + Passed 1000 iterations Running timesWord8# - Passed 100 iterations + Passed 1000 iterations Running quotWord8# - Passed 100 iterations + Passed 1000 iterations Running remWord8# - Passed 100 iterations + Passed 1000 iterations Running quotRemWord8# - Passed 100 iterations + Passed 1000 iterations Running andWord8# - Passed 100 iterations + Passed 1000 iterations Running orWord8# - Passed 100 iterations + Passed 1000 iterations Running xorWord8# - Passed 100 iterations + Passed 1000 iterations Running notWord8# - Passed 100 iterations + Passed 1000 iterations Running uncheckedShiftLWord8# - Passed 100 iterations + Passed 1000 iterations Running uncheckedShiftRLWord8# - Passed 100 iterations + Passed 1000 iterations Running word8ToInt8# - Passed 100 iterations + Passed 1000 iterations Running eqWord8# - Passed 100 iterations + Passed 1000 iterations Running geWord8# - Passed 100 iterations + Passed 1000 iterations Running gtWord8# - Passed 100 iterations + Passed 1000 iterations Running leWord8# - Passed 100 iterations + Passed 1000 iterations Running ltWord8# - Passed 100 iterations + Passed 1000 iterations Running neWord8# - Passed 100 iterations + Passed 1000 iterations Running int16ToInt# - Passed 100 iterations + Passed 1000 iterations Running intToInt16# - Passed 100 iterations + Passed 1000 iterations Running negateInt16# - Passed 100 iterations + Passed 1000 iterations Running plusInt16# - Passed 100 iterations + Passed 1000 iterations Running subInt16# - Passed 100 iterations + Passed 1000 iterations Running timesInt16# - Passed 100 iterations + Passed 1000 iterations Running quotInt16# - Passed 100 iterations + Passed 1000 iterations Running remInt16# - Passed 100 iterations + Passed 1000 iterations Running quotRemInt16# - Passed 100 iterations + Passed 1000 iterations Running uncheckedShiftLInt16# - Passed 100 iterations + Passed 1000 iterations Running uncheckedShiftRAInt16# - Passed 100 iterations + Passed 1000 iterations Running uncheckedShiftRLInt16# - Passed 100 iterations + Passed 1000 iterations Running int16ToWord16# - Passed 100 iterations + Passed 1000 iterations Running eqInt16# - Passed 100 iterations + Passed 1000 iterations Running geInt16# - Passed 100 iterations + Passed 1000 iterations Running gtInt16# - Passed 100 iterations + Passed 1000 iterations Running leInt16# - Passed 100 iterations + Passed 1000 iterations Running ltInt16# - Passed 100 iterations + Passed 1000 iterations Running neInt16# - Passed 100 iterations + Passed 1000 iterations Running word16ToWord# - Passed 100 iterations + Passed 1000 iterations Running wordToWord16# - Passed 100 iterations + Passed 1000 iterations Running plusWord16# - Passed 100 iterations + Passed 1000 iterations Running subWord16# - Passed 100 iterations + Passed 1000 iterations Running timesWord16# - Passed 100 iterations + Passed 1000 iterations Running quotWord16# - Passed 100 iterations + Passed 1000 iterations Running remWord16# - Passed 100 iterations + Passed 1000 iterations Running quotRemWord16# - Passed 100 iterations + Passed 1000 iterations Running andWord16# - Passed 100 iterations + Passed 1000 iterations Running orWord16# - Passed 100 iterations + Passed 1000 iterations Running xorWord16# - Passed 100 iterations + Passed 1000 iterations Running notWord16# - Passed 100 iterations + Passed 1000 iterations Running uncheckedShiftLWord16# - Passed 100 iterations + Passed 1000 iterations Running uncheckedShiftRLWord16# - Passed 100 iterations + Passed 1000 iterations Running word16ToInt16# - Passed 100 iterations + Passed 1000 iterations Running eqWord16# - Passed 100 iterations + Passed 1000 iterations Running geWord16# - Passed 100 iterations + Passed 1000 iterations Running gtWord16# - Passed 100 iterations + Passed 1000 iterations Running leWord16# - Passed 100 iterations + Passed 1000 iterations Running ltWord16# - Passed 100 iterations + Passed 1000 iterations Running neWord16# - Passed 100 iterations + Passed 1000 iterations Running int32ToInt# - Passed 100 iterations + Passed 1000 iterations Running intToInt32# - Passed 100 iterations + Passed 1000 iterations Running negateInt32# - Passed 100 iterations + Passed 1000 iterations Running plusInt32# - Passed 100 iterations + Passed 1000 iterations Running subInt32# - Passed 100 iterations + Passed 1000 iterations Running timesInt32# - Passed 100 iterations + Passed 1000 iterations Running quotInt32# - Passed 100 iterations + Passed 1000 iterations Running remInt32# - Passed 100 iterations + Passed 1000 iterations Running quotRemInt32# - Passed 100 iterations + Passed 1000 iterations Running uncheckedShiftLInt32# - Passed 100 iterations + Passed 1000 iterations Running uncheckedShiftRAInt32# - Passed 100 iterations + Passed 1000 iterations Running uncheckedShiftRLInt32# - Passed 100 iterations + Passed 1000 iterations Running int32ToWord32# - Passed 100 iterations + Passed 1000 iterations Running eqInt32# - Passed 100 iterations + Passed 1000 iterations Running geInt32# - Passed 100 iterations + Passed 1000 iterations Running gtInt32# - Passed 100 iterations + Passed 1000 iterations Running leInt32# - Passed 100 iterations + Passed 1000 iterations Running ltInt32# - Passed 100 iterations + Passed 1000 iterations Running neInt32# - Passed 100 iterations + Passed 1000 iterations Running word32ToWord# - Passed 100 iterations + Passed 1000 iterations Running wordToWord32# - Passed 100 iterations + Passed 1000 iterations Running plusWord32# - Passed 100 iterations + Passed 1000 iterations Running subWord32# - Passed 100 iterations + Passed 1000 iterations Running timesWord32# - Passed 100 iterations + Passed 1000 iterations Running quotWord32# - Passed 100 iterations + Passed 1000 iterations Running remWord32# - Passed 100 iterations + Passed 1000 iterations Running quotRemWord32# - Passed 100 iterations + Passed 1000 iterations Running andWord32# - Passed 100 iterations + Passed 1000 iterations Running orWord32# - Passed 100 iterations + Passed 1000 iterations Running xorWord32# - Passed 100 iterations + Passed 1000 iterations Running notWord32# - Passed 100 iterations + Passed 1000 iterations Running uncheckedShiftLWord32# - Passed 100 iterations + Passed 1000 iterations Running uncheckedShiftRLWord32# - Passed 100 iterations + Passed 1000 iterations Running word32ToInt32# - Passed 100 iterations + Passed 1000 iterations Running eqWord32# - Passed 100 iterations + Passed 1000 iterations Running geWord32# - Passed 100 iterations + Passed 1000 iterations Running gtWord32# - Passed 100 iterations + Passed 1000 iterations Running leWord32# - Passed 100 iterations + Passed 1000 iterations Running ltWord32# - Passed 100 iterations + Passed 1000 iterations Running neWord32# - Passed 100 iterations + Passed 1000 iterations Running int64ToInt# - Passed 100 iterations + Passed 1000 iterations Running intToInt64# - Passed 100 iterations + Passed 1000 iterations Running negateInt64# - Passed 100 iterations + Passed 1000 iterations Running plusInt64# - Passed 100 iterations + Passed 1000 iterations Running subInt64# - Passed 100 iterations + Passed 1000 iterations Running timesInt64# - Passed 100 iterations + Passed 1000 iterations Running quotInt64# - Passed 100 iterations + Passed 1000 iterations Running remInt64# - Passed 100 iterations + Passed 1000 iterations Running uncheckedIShiftL64# - Passed 100 iterations + Passed 1000 iterations Running uncheckedIShiftRA64# - Passed 100 iterations + Passed 1000 iterations Running uncheckedIShiftRL64# - Passed 100 iterations + Passed 1000 iterations Running int64ToWord64# - Passed 100 iterations + Passed 1000 iterations Running eqInt64# - Passed 100 iterations + Passed 1000 iterations Running geInt64# - Passed 100 iterations + Passed 1000 iterations Running gtInt64# - Passed 100 iterations + Passed 1000 iterations Running leInt64# - Passed 100 iterations + Passed 1000 iterations Running ltInt64# - Passed 100 iterations + Passed 1000 iterations Running neInt64# - Passed 100 iterations + Passed 1000 iterations Running word64ToWord# - Passed 100 iterations + Passed 1000 iterations Running wordToWord64# - Passed 100 iterations + Passed 1000 iterations Running plusWord64# - Passed 100 iterations + Passed 1000 iterations Running subWord64# - Passed 100 iterations + Passed 1000 iterations Running timesWord64# - Passed 100 iterations + Passed 1000 iterations Running quotWord64# - Passed 100 iterations + Passed 1000 iterations Running remWord64# - Passed 100 iterations + Passed 1000 iterations Running and64# - Passed 100 iterations + Passed 1000 iterations Running or64# - Passed 100 iterations + Passed 1000 iterations Running xor64# - Passed 100 iterations + Passed 1000 iterations Running not64# - Passed 100 iterations + Passed 1000 iterations Running uncheckedShiftL64# - Passed 100 iterations + Passed 1000 iterations Running uncheckedShiftRL64# - Passed 100 iterations + Passed 1000 iterations Running word64ToInt64# - Passed 100 iterations + Passed 1000 iterations Running eqWord64# - Passed 100 iterations + Passed 1000 iterations Running geWord64# - Passed 100 iterations + Passed 1000 iterations Running gtWord64# - Passed 100 iterations + Passed 1000 iterations Running leWord64# - Passed 100 iterations + Passed 1000 iterations Running ltWord64# - Passed 100 iterations + Passed 1000 iterations Running neWord64# - Passed 100 iterations + Passed 1000 iterations Running +# - Passed 100 iterations + Passed 1000 iterations Running -# - Passed 100 iterations + Passed 1000 iterations Running *# - Passed 100 iterations + Passed 1000 iterations Running timesInt2# - Passed 100 iterations + Passed 1000 iterations Running mulIntMayOflo# - Passed 100 iterations + Passed 1000 iterations Running quotInt# - Passed 100 iterations + Passed 1000 iterations Running remInt# - Passed 100 iterations + Passed 1000 iterations Running quotRemInt# - Passed 100 iterations + Passed 1000 iterations Running andI# - Passed 100 iterations + Passed 1000 iterations Running orI# - Passed 100 iterations + Passed 1000 iterations Running xorI# - Passed 100 iterations + Passed 1000 iterations Running notI# - Passed 100 iterations + Passed 1000 iterations Running negateInt# - Passed 100 iterations + Passed 1000 iterations Running addIntC# - Passed 100 iterations + Passed 1000 iterations Running subIntC# - Passed 100 iterations + Passed 1000 iterations Running ># - Passed 100 iterations + Passed 1000 iterations Running >=# - Passed 100 iterations + Passed 1000 iterations Running ==# - Passed 100 iterations + Passed 1000 iterations Running /=# - Passed 100 iterations + Passed 1000 iterations Running <# - Passed 100 iterations + Passed 1000 iterations Running <=# - Passed 100 iterations + Passed 1000 iterations Running chr# - Passed 100 iterations + Passed 1000 iterations Running int2Word# - Passed 100 iterations + Passed 1000 iterations Running uncheckedIShiftL# - Passed 100 iterations + Passed 1000 iterations Running uncheckedIShiftRA# - Passed 100 iterations + Passed 1000 iterations Running uncheckedIShiftRL# - Passed 100 iterations + Passed 1000 iterations Running plusWord# - Passed 100 iterations + Passed 1000 iterations Running addWordC# - Passed 100 iterations + Passed 1000 iterations Running subWordC# - Passed 100 iterations + Passed 1000 iterations Running plusWord2# - Passed 100 iterations + Passed 1000 iterations Running minusWord# - Passed 100 iterations + Passed 1000 iterations Running timesWord# - Passed 100 iterations + Passed 1000 iterations Running timesWord2# - Passed 100 iterations + Passed 1000 iterations Running quotWord# - Passed 100 iterations + Passed 1000 iterations Running remWord# - Passed 100 iterations + Passed 1000 iterations Running quotRemWord# - Passed 100 iterations + Passed 1000 iterations Running and# - Passed 100 iterations + Passed 1000 iterations Running or# - Passed 100 iterations + Passed 1000 iterations Running xor# - Passed 100 iterations + Passed 1000 iterations Running not# - Passed 100 iterations + Passed 1000 iterations Running uncheckedShiftL# - Passed 100 iterations + Passed 1000 iterations Running uncheckedShiftRL# - Passed 100 iterations + Passed 1000 iterations Running word2Int# - Passed 100 iterations + Passed 1000 iterations Running gtWord# - Passed 100 iterations + Passed 1000 iterations Running geWord# - Passed 100 iterations + Passed 1000 iterations Running eqWord# - Passed 100 iterations + Passed 1000 iterations Running neWord# - Passed 100 iterations + Passed 1000 iterations Running ltWord# - Passed 100 iterations + Passed 1000 iterations Running leWord# - Passed 100 iterations + Passed 1000 iterations Running popCnt8# - Passed 100 iterations + Passed 1000 iterations Running popCnt16# - Passed 100 iterations + Passed 1000 iterations Running popCnt32# - Passed 100 iterations + Passed 1000 iterations Running popCnt64# - Passed 100 iterations + Passed 1000 iterations Running popCnt# - Passed 100 iterations + Passed 1000 iterations Running pdep8# - Passed 100 iterations + Passed 1000 iterations Running pdep16# - Passed 100 iterations + Passed 1000 iterations Running pdep32# - Passed 100 iterations + Passed 1000 iterations Running pdep64# - Passed 100 iterations + Passed 1000 iterations Running pdep# - Passed 100 iterations + Passed 1000 iterations Running pext8# - Passed 100 iterations + Passed 1000 iterations Running pext16# - Passed 100 iterations + Passed 1000 iterations Running pext32# - Passed 100 iterations + Passed 1000 iterations Running pext64# - Passed 100 iterations + Passed 1000 iterations Running pext# - Passed 100 iterations + Passed 1000 iterations Running clz8# - Passed 100 iterations + Passed 1000 iterations Running clz16# - Passed 100 iterations + Passed 1000 iterations Running clz32# - Passed 100 iterations + Passed 1000 iterations Running clz64# - Passed 100 iterations + Passed 1000 iterations Running clz# - Passed 100 iterations + Passed 1000 iterations Running ctz8# - Passed 100 iterations + Passed 1000 iterations Running ctz16# - Passed 100 iterations + Passed 1000 iterations Running ctz32# - Passed 100 iterations + Passed 1000 iterations Running ctz64# - Passed 100 iterations + Passed 1000 iterations Running ctz# - Passed 100 iterations + Passed 1000 iterations Running byteSwap16# - Passed 100 iterations + Passed 1000 iterations Running byteSwap32# - Passed 100 iterations + Passed 1000 iterations Running byteSwap64# - Passed 100 iterations + Passed 1000 iterations Running byteSwap# - Passed 100 iterations + Passed 1000 iterations Running bitReverse8# - Passed 100 iterations + Passed 1000 iterations Running bitReverse16# - Passed 100 iterations + Passed 1000 iterations Running bitReverse32# - Passed 100 iterations + Passed 1000 iterations Running bitReverse64# - Passed 100 iterations + Passed 1000 iterations Running bitReverse# - Passed 100 iterations + Passed 1000 iterations Running narrow8Int# - Passed 100 iterations + Passed 1000 iterations Running narrow16Int# - Passed 100 iterations + Passed 1000 iterations Running narrow32Int# - Passed 100 iterations + Passed 1000 iterations Running narrow8Word# - Passed 100 iterations + Passed 1000 iterations Running narrow16Word# - Passed 100 iterations + Passed 1000 iterations Running narrow32Word# - Passed 100 iterations + Passed 1000 iterations View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bd38b76cff47bcb27d737b15f8ad097… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bd38b76cff47bcb27d737b15f8ad097… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 2 commits: Removing the 'Data' instance for 'InstEnv'.
by Marge Bot (＠marge-bot) 18 Dec '25

18 Dec '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: eac418bb by Recursion Ninja at 2025-12-18T13:19:48-05:00 Removing the 'Data' instance for 'InstEnv'. The 'Data' instance is blocking work on Trees that Grow, and the 'Data' instance seem to have been added without a clear purpose. - - - - - e920e038 by Recursion Ninja at 2025-12-18T13:19:48-05:00 'Decouple Language.Haskell.Syntax.Decls' from 'GHC.Unit.Module.Warnings' - - - - - 23 changed files: - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Core/InstEnv.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Warnings.hs - compiler/GHC/Parser.y - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Types/DefaultEnv.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Unit/Module/Warnings.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Extension.hs - testsuite/tests/diagnostic-codes/codes.stdout - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs Changes: ===================================== compiler/GHC/Builtin/Utils.hs ===================================== @@ -79,6 +79,7 @@ import GHC.Utils.Panic import GHC.Utils.Constants (debugIsOn) import GHC.Parser.Annotation import GHC.Hs.Doc +import GHC.Hs.Extension (GhcPass) import GHC.Unit.Module.ModIface (IfaceExport) import GHC.Unit.Module.Warnings @@ -263,7 +264,7 @@ ghcPrimNames ] -- See Note [GHC.Prim Deprecations] -ghcPrimWarns :: Warnings a +ghcPrimWarns :: Warnings (GhcPass p) ghcPrimWarns = WarnSome -- declaration warnings (map mk_decl_dep primOpDeprecations) ===================================== compiler/GHC/Core/InstEnv.hs ===================================== @@ -7,7 +7,6 @@ The bits common to GHC.Tc.TyCl.Instance and GHC.Tc.Deriv. -} - module GHC.Core.InstEnv ( DFunId, InstMatch, ClsInstLookupResult, CanonicalEvidence(..), PotentialUnifiers(..), getCoherentUnifiers, nullUnifiers, @@ -54,7 +53,6 @@ import GHC.Types.Name.Set import GHC.Types.Basic import GHC.Types.Id import GHC.Generics (Generic) -import Data.Data ( Data ) import Data.List.NonEmpty ( NonEmpty (..), nonEmpty ) import qualified Data.List.NonEmpty as NE import Data.Maybe ( isJust ) @@ -113,7 +111,6 @@ data ClsInst -- See Note [Implementation of deprecated instances] -- in GHC.Tc.Solver.Dict } - deriving Data -- | A fuzzy comparison function for class instances, intended for sorting -- instances before displaying them to the user. ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -1384,7 +1384,6 @@ type instance XWarning (GhcPass _) = (NamespaceSpecifier, (EpToken "[", EpT type instance XXWarnDecl (GhcPass _) = DataConCantHappen - instance OutputableBndrId p => Outputable (WarnDecls (GhcPass p)) where ppr (Warnings ext decls) @@ -1404,7 +1403,7 @@ instance OutputableBndrId p <+> ppr txt where ppr_category = case txt of - WarningTxt (Just cat) _ _ -> ppr cat + WarningTxt _ (Just cat) _ -> ppr cat _ -> empty {- ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -31,6 +31,7 @@ import GHC.Hs.ImpExp import GHC.Parser.Annotation import GHC.Types.Name.Reader (WithUserRdr(..)) import GHC.Data.BooleanFormula (BooleanFormula(..)) +import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Extension (Anno) -- --------------------------------------------------------------------- @@ -272,6 +273,14 @@ deriving instance Data (WarnDecl GhcPs) deriving instance Data (WarnDecl GhcRn) deriving instance Data (WarnDecl GhcTc) +deriving instance Data (WarningTxt GhcPs) +deriving instance Data (WarningTxt GhcRn) +deriving instance Data (WarningTxt GhcTc) + +deriving instance Data (InWarningCategory GhcPs) +deriving instance Data (InWarningCategory GhcRn) +deriving instance Data (InWarningCategory GhcTc) + -- deriving instance (DataIdLR p p) => Data (AnnDecl p) deriving instance Data (AnnProvenance GhcPs) deriving instance Data (AnnProvenance GhcRn) ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -422,8 +422,8 @@ data IfaceWarnings [(IfExtName, IfaceWarningTxt)] data IfaceWarningTxt - = IfWarningTxt (Maybe WarningCategory) SourceText [(IfaceStringLiteral, [IfExtName])] - | IfDeprecatedTxt SourceText [(IfaceStringLiteral, [IfExtName])] + = IfWarningTxt SourceText (Maybe WarningCategory) [(IfaceStringLiteral, [IfExtName])] + | IfDeprecatedTxt SourceText [(IfaceStringLiteral, [IfExtName])] data IfaceStringLiteral = IfStringLiteral SourceText FastString @@ -662,7 +662,7 @@ fromIfaceWarnings = \case fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn fromIfaceWarningTxt = \case - IfWarningTxt mb_cat src strs -> WarningTxt (noLocA . fromWarningCategory <$> mb_cat) src (noLocA <$> map fromIfaceStringLiteralWithNames strs) + IfWarningTxt src mb_cat strs -> WarningTxt src (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs) IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs) fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers StringLiteral GhcRn ===================================== compiler/GHC/Iface/Warnings.hs ===================================== @@ -23,7 +23,7 @@ toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds' ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds] toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt -toIfaceWarningTxt (WarningTxt mb_cat src strs) = IfWarningTxt (unLoc . iwc_wc . unLoc <$> mb_cat) src (map (toIfaceStringLiteralWithNames . unLoc) strs) +toIfaceWarningTxt (WarningTxt src mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs) toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs) toIfaceStringLiteralWithNames :: WithHsDocIdentifiers StringLiteral GhcRn -> (IfaceStringLiteral, [IfExtName]) ===================================== compiler/GHC/Parser.y ===================================== @@ -2047,12 +2047,12 @@ maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) } {% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2)) (AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) } | '{-# WARNING' warning_category strings '#-}' - {% fmap Just $ amsr (sLL $1 $> $ WarningTxt $2 (getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $3)) + {% fmap Just $ amsr (sLL $1 $> $ WarningTxt (getWARNING_PRAGs $1) $2 (map stringLiteralToHsDocWst $ snd $ unLoc $3)) (AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)} | {- empty -} { Nothing } -warning_category :: { Maybe (LocatedE InWarningCategory) } - : 'in' STRING { Just (reLoc $ sLL $1 $> $ InWarningCategory (epTok $1) (getSTRINGs $2) +warning_category :: { Maybe (LocatedE (InWarningCategory GhcPs)) } + : 'in' STRING { Just (reLoc $ sLL $1 $> $ InWarningCategory (epTok $1, getSTRINGs $2) (reLoc $ sL1 $2 $ mkWarningCategory (getSTRING $2))) } | {- empty -} { Nothing } @@ -2077,7 +2077,7 @@ warning :: { OrdList (LWarnDecl GhcPs) } : warning_category namespace_spec namelist strings {% fmap unitOL $ amsA' (L (comb4 $1 $2 $3 $4) (Warning (unLoc $2, fst $ unLoc $4) (unLoc $3) - (WarningTxt $1 NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $4))) } + (WarningTxt NoSourceText $1 (map stringLiteralToHsDocWst $ snd $ unLoc $4)))) } namespace_spec :: { Located NamespaceSpecifier } : 'type' { sL1 $1 $ TypeNamespaceSpecifier (epTok $1) } ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -314,12 +314,16 @@ rnSrcWarnDecls bndr_set decls' rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn) -rnWarningTxt (WarningTxt mb_cat st wst) = do - forM_ mb_cat $ \(L _ (InWarningCategory _ _ (L loc cat))) -> - unless (validWarningCategory cat) $ - addErrAt (locA loc) (TcRnInvalidWarningCategory cat) +rnWarningTxt (WarningTxt st mb_cat wst) = do + mb_cat' <- case mb_cat of + Nothing -> pure Nothing + Just (L x (InWarningCategory y (L loc cat))) -> do + unless (validWarningCategory cat) $ + addErrAt (locA loc) (TcRnInvalidWarningCategory cat) + pure . Just $ L x (InWarningCategory y (L loc cat)) wst' <- traverse (traverse rnHsDoc) wst - pure (WarningTxt mb_cat st wst') + pure (WarningTxt st mb_cat' wst') + rnWarningTxt (DeprecatedTxt st wst) = do wst' <- traverse (traverse rnHsDoc) wst pure (DeprecatedTxt st wst') ===================================== compiler/GHC/Rename/Utils.hs ===================================== @@ -66,7 +66,6 @@ import GHC.Data.Bag ( mapBagM, headMaybe ) import Control.Monad import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) import GHC.Unit.Module -import GHC.Unit.Module.Warnings ( WarningTxt(..) ) import GHC.Iface.Load import qualified GHC.LanguageExtensions as LangExt ===================================== compiler/GHC/Tc/Deriv.hs ===================================== @@ -56,7 +56,6 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.SrcLoc -import GHC.Unit.Module.Warnings import GHC.Builtin.Names import GHC.Utils.Error ===================================== compiler/GHC/Tc/Deriv/Utils.hs ===================================== @@ -52,7 +52,6 @@ import GHC.Core.Type import GHC.Hs import GHC.Driver.Session import GHC.Unit.Module (getModule) -import GHC.Unit.Module.Warnings import GHC.Unit.Module.ModIface (mi_fix) import GHC.Iface.Load (loadInterfaceForName) ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -1835,7 +1835,7 @@ instance Diagnostic TcRnMessage where nest 2 (vcat (map (ppr . hsDocString . unLoc) msg)) ] where (extra, msg) = case txt of - WarningTxt _ _ msg -> ("", msg) + WarningTxt _ _ msg -> ("", msg) DeprecatedTxt _ msg -> (" is deprecated", msg) TcRnRedundantSourceImport mod_name -> mkSimpleDecorated $ ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -213,7 +213,6 @@ import GHC.Types.DefaultEnv (ClassDefaults) import GHC.Unit.Types (Module) import GHC.Unit.State (UnitState) -import GHC.Unit.Module.Warnings (WarningCategory, WarningTxt) import GHC.Unit.Module.ModIface (ModIface) import GHC.Utils.Outputable ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -60,7 +60,6 @@ import GHC.Core.PatSyn import GHC.Core.Multiplicity ( scaledThing ) import GHC.Unit.Module -import GHC.Unit.Module.Warnings import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Reader ===================================== compiler/GHC/Tc/Utils/Instantiate.hs ===================================== @@ -89,7 +89,6 @@ import GHC.Utils.Unique (sameUnique) import GHC.Unit.State import GHC.Unit.External -import GHC.Unit.Module.Warnings import Data.List ( mapAccumL ) import qualified Data.List.NonEmpty as NE ===================================== compiler/GHC/Types/DefaultEnv.hs ===================================== @@ -18,13 +18,12 @@ where import GHC.Core.Class (Class (className)) import GHC.Prelude -import GHC.Hs.Extension (GhcRn) +import GHC.Hs import GHC.Tc.Utils.TcType (Type) import GHC.Types.Name (Name, nameUnique, stableNameCmp) import GHC.Types.Name.Env import GHC.Types.Unique.FM (lookupUFM_Directly) import GHC.Types.SrcLoc (SrcSpan) -import GHC.Unit.Module.Warnings (WarningTxt) import GHC.Unit.Types (Module) import GHC.Utils.Outputable ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -761,6 +761,7 @@ type family GhcDiagnosticCode c = n | n -> c where -- TcRnPragmaWarning GhcDiagnosticCode "WarningTxt" = 63394 GhcDiagnosticCode "DeprecatedTxt" = 68441 + GhcDiagnosticCode "XWarningTxt" = 68077 -- TcRnRunSliceFailure/ConversionFail GhcDiagnosticCode "IllegalOccName" = 55017 ===================================== compiler/GHC/Unit/Module/Warnings.hs ===================================== @@ -1,6 +1,9 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} +-- Eq instances for WarningTxt, InWarningCategory +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | Warnings for a module module GHC.Unit.Module.Warnings ( WarningCategory(..) @@ -38,7 +41,7 @@ where import GHC.Prelude -import GHC.Data.FastString (FastString, mkFastString, unpackFS) +import GHC.Data.FastString (mkFastString, unpackFS) import GHC.Types.SourceText import GHC.Types.Name.Occurrence import GHC.Types.Name.Env @@ -55,77 +58,15 @@ import GHC.Utils.Binary import GHC.Unicode import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Decls -import Data.Data import Data.List (isPrefixOf) -import GHC.Generics ( Generic ) -import Control.DeepSeq - - -{- -Note [Warning categories] -~~~~~~~~~~~~~~~~~~~~~~~~~ -See GHC Proposal 541 for the design of the warning categories feature: -https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0541-warning-pragmas-with-categories.rst - -A WARNING pragma may be annotated with a category such as "x-partial" written -after the 'in' keyword, like this: - - {-# WARNING in "x-partial" head "This function is partial..." #-} - -This is represented by the 'Maybe (Located WarningCategory)' field in -'WarningTxt'. The parser will accept an arbitrary string as the category name, -then the renamer (in 'rnWarningTxt') will check it contains only valid -characters, so we can generate a nicer error message than a parse error. - -The corresponding warnings can then be controlled with the -Wx-partial, --Wno-x-partial, -Werror=x-partial and -Wwarn=x-partial flags. Such a flag is -distinguished from an 'unrecognisedWarning' by the flag parser testing -'validWarningCategory'. The 'x-' prefix means we can still usually report an -unrecognised warning where the user has made a mistake. - -A DEPRECATED pragma may not have a user-defined category, and is always treated -as belonging to the special category 'deprecations'. Similarly, a WARNING -pragma without a category belongs to the 'deprecations' category. -Thus the '-Wdeprecations' flag will enable all of the following: - - {-# WARNING in "deprecations" foo "This function is deprecated..." #-} - {-# WARNING foo "This function is deprecated..." #-} - {-# DEPRECATED foo "This function is deprecated..." #-} - -The '-Wwarnings-deprecations' flag is supported for backwards compatibility -purposes as being equivalent to '-Wdeprecations'. - -The '-Wextended-warnings' warning group collects together all warnings with -user-defined categories, so they can be enabled or disabled -collectively. Moreover they are treated as being part of other warning groups -such as '-Wdefault' (see 'warningGroupIncludesExtendedWarnings'). - -'DynFlags' and 'DiagOpts' each contain a set of enabled and a set of fatal -warning categories, just as they do for the finite enumeration of 'WarningFlag's -built in to GHC. These are represented as 'WarningCategorySet's to allow for -the possibility of them being infinite. - --} -data InWarningCategory - = InWarningCategory - { iwc_in :: !(EpToken "in"), - iwc_st :: !SourceText, - iwc_wc :: (LocatedE WarningCategory) - } deriving Data -fromWarningCategory :: WarningCategory -> InWarningCategory -fromWarningCategory wc = InWarningCategory noAnn NoSourceText (noLocA wc) - - --- See Note [Warning categories] -newtype WarningCategory = WarningCategory FastString - deriving stock Data - deriving newtype (Binary, Eq, Outputable, Show, Uniquable, NFData) - -mkWarningCategory :: FastString -> WarningCategory -mkWarningCategory = WarningCategory +fromWarningCategory :: + HasAnnotation (Anno WarningCategory) => + WarningCategory -> InWarningCategory (GhcPass p) +fromWarningCategory wc = InWarningCategory (noAnn, NoSourceText) (noLocA wc) -- | The @deprecations@ category is used for all DEPRECATED pragmas and for -- WARNING pragmas that do not specify a category. @@ -143,7 +84,6 @@ validWarningCategory cat@(WarningCategory c) = s = unpackFS c is_allowed c = isAlphaNum c || c == '\'' || c == '-' - -- | A finite or infinite set of warning categories. -- -- Unlike 'WarningFlag', there are (in principle) infinitely many warning @@ -188,66 +128,74 @@ deleteWarningCategorySet c (CofiniteWarningCategorySet s) = CofiniteWarningCateg type LWarningTxt pass = XRec pass (WarningTxt pass) --- | Warning Text --- --- reason/explanation from a WARNING or DEPRECATED pragma -data WarningTxt pass - = WarningTxt - (Maybe (LocatedE InWarningCategory)) - -- ^ Warning category attached to this WARNING pragma, if any; - -- see Note [Warning categories] - SourceText - [LocatedE (WithHsDocIdentifiers StringLiteral pass)] - | DeprecatedTxt - SourceText - [LocatedE (WithHsDocIdentifiers StringLiteral pass)] - deriving Generic - -- | To which warning category does this WARNING or DEPRECATED pragma belong? -- See Note [Warning categories]. -warningTxtCategory :: WarningTxt pass -> WarningCategory -warningTxtCategory (WarningTxt (Just (L _ (InWarningCategory _ _ (L _ cat)))) _ _) = cat +warningTxtCategory :: WarningTxt (GhcPass p) -> WarningCategory +warningTxtCategory (WarningTxt _ (Just (L _ (InWarningCategory _ (L _ cat)))) _) = cat warningTxtCategory _ = defaultWarningCategory + -- | The message that the WarningTxt was specified to output -warningTxtMessage :: WarningTxt p -> [LocatedE (WithHsDocIdentifiers StringLiteral p)] -warningTxtMessage (WarningTxt _ _ m) = m +warningTxtMessage :: WarningTxt (GhcPass p) -> [LocatedE (WithHsDocIdentifiers StringLiteral (GhcPass p))] +warningTxtMessage (WarningTxt _ _ m) = m warningTxtMessage (DeprecatedTxt _ m) = m -- | True if the 2 WarningTxts have the same category and messages -warningTxtSame :: WarningTxt p1 -> WarningTxt p2 -> Bool +warningTxtSame :: WarningTxt (GhcPass p) -> WarningTxt (GhcPass p) -> Bool warningTxtSame w1 w2 = warningTxtCategory w1 == warningTxtCategory w2 && literal_message w1 == literal_message w2 && same_type where - literal_message :: WarningTxt p -> [StringLiteral] + literal_message :: WarningTxt (GhcPass p) -> [StringLiteral] literal_message = map (hsDocString . unLoc) . warningTxtMessage same_type | DeprecatedTxt {} <- w1, DeprecatedTxt {} <- w2 = True - | WarningTxt {} <- w1, WarningTxt {} <- w2 = True + | WarningTxt {} <- w1, WarningTxt {} <- w2 = True | otherwise = False -deriving instance Eq InWarningCategory +instance Outputable (InWarningCategory (GhcPass pass)) where + ppr (InWarningCategory _ wt) = text "in" <+> doubleQuotes (ppr wt) -deriving instance (Eq (IdP pass)) => Eq (WarningTxt pass) -deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass) +type instance XDeprecatedTxt (GhcPass _) = SourceText +type instance XWarningTxt (GhcPass _) = SourceText +type instance XXWarningTxt (GhcPass _) = DataConCantHappen +type instance XInWarningCategory (GhcPass _) = (EpToken "in", SourceText) +type instance XXInWarningCategory (GhcPass _) = DataConCantHappen +type instance Anno (WithHsDocIdentifiers StringLiteral pass) = EpaLocation +type instance Anno (InWarningCategory (GhcPass pass)) = EpaLocation +type instance Anno (WarningCategory) = EpaLocation type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP -instance Outputable InWarningCategory where - ppr (InWarningCategory _ _ wt) = text "in" <+> doubleQuotes (ppr wt) +deriving stock instance Eq (WarningTxt GhcPs) +deriving stock instance Eq (WarningTxt GhcRn) +deriving stock instance Eq (WarningTxt GhcTc) + +deriving stock instance Eq (InWarningCategory GhcPs) +deriving stock instance Eq (InWarningCategory GhcRn) +deriving stock instance Eq (InWarningCategory GhcTc) + +-- TODO: Move to respecitive type-class definition modules after removing +-- the Language.Haskell.Syntax.Decls module's dependency on GHC.Hs.Doc. +-- Subsequently, create a Language.Haskell.Syntax.Decls.Warnings sub-module +-- with the "warning declaration" types and have Language.Haskell.Syntax.Decls +-- re-export Language.Haskell.Syntax.Decls.Warnings. This will prevent cyclic +-- import, but it will only work once GHC.Hs.Doc is no longer a GHC dependency. +deriving instance Binary WarningCategory +deriving instance Outputable WarningCategory -instance Outputable (WarningTxt pass) where - ppr (WarningTxt mcat lsrc ws) +deriving instance Uniquable WarningCategory + +instance Outputable (WarningTxt (GhcPass pass)) where + ppr (WarningTxt lsrc mcat ws) = case lsrc of NoSourceText -> pp_ws ws SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}" where ctg_doc = maybe empty (\ctg -> ppr ctg) mcat - - ppr (DeprecatedTxt lsrc ds) + ppr (DeprecatedTxt lsrc ds) = case lsrc of NoSourceText -> pp_ws ds SourceText src -> ftext src <+> pp_ws ds <+> text "#-}" @@ -260,7 +208,7 @@ pp_ws ws <+> text "]" -pprWarningTxtForMsg :: WarningTxt p -> SDoc +pprWarningTxtForMsg :: WarningTxt (GhcPass pass) -> SDoc pprWarningTxtForMsg (WarningTxt _ _ ws) = doubleQuotes (vcat (map (ftext . sl_fs . hsDocString . unLoc) ws)) pprWarningTxtForMsg (DeprecatedTxt _ ds) @@ -306,8 +254,6 @@ type DeclWarnOccNames pass = [(OccName, WarningTxt pass)] -- | Names that are deprecated as exports type ExportWarnNames pass = [(Name, WarningTxt pass)] -deriving instance Eq (IdP pass) => Eq (Warnings pass) - emptyWarn :: Warnings p emptyWarn = WarnSome [] [] ===================================== compiler/Language/Haskell/Syntax/Decls.hs ===================================== @@ -72,7 +72,18 @@ module Language.Haskell.Syntax.Decls ( FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn, -- * Grouping - HsGroup(..) + HsGroup(..), + + -- * Warnings + WarningTxt(..), + WarningCategory(..), + mkWarningCategory, + InWarningCategory(..), + -- ** Extension + XDeprecatedTxt, + XWarningTxt, + XXWarningTxt, + XInWarningCategory, ) where -- friends: @@ -90,12 +101,14 @@ import GHC.Types.Basic (TopLevelFlag, OverlapMode, RuleName, Activation ,TyConFlavour(..), TypeOrData(..), NewOrData(..)) import GHC.Types.ForeignCall (CType, CCallConv, Safety, Header, CLabelString, CCallTarget, CExportSpec) -import GHC.Unit.Module.Warnings (WarningTxt) - +import GHC.Data.FastString (FastString) import GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST +import GHC.Hs.Doc (WithHsDocIdentifiers) +import GHC.Types.SourceText (StringLiteral) -import Control.Monad +import Control.DeepSeq import Control.Exception (assert) +import Control.Monad import Data.Data hiding (TyCon, Fixity, Infix) import Data.Maybe import Data.String @@ -106,6 +119,8 @@ import Prelude (Show) import Data.Foldable import Data.Traversable import Data.List.NonEmpty (NonEmpty (..)) +import GHC.Generics ( Generic ) + {- ************************************************************************ @@ -1578,3 +1593,85 @@ data RoleAnnotDecl pass (LIdP pass) -- type constructor [XRec pass (Maybe Role)] -- optional annotations | XRoleAnnotDecl !(XXRoleAnnotDecl pass) + +{- +************************************************************************ +* * +\subsection[WarnAnnot]{Warning annotations} +* * +************************************************************************ +-} + +-- | Warning Text +-- +-- reason/explanation from a WARNING or DEPRECATED pragma +data WarningTxt pass + = DeprecatedTxt + (XDeprecatedTxt pass) + [XRec pass (WithHsDocIdentifiers StringLiteral pass)] + | WarningTxt + (XWarningTxt pass) + (Maybe (XRec pass (InWarningCategory pass))) + -- ^ Warning category attached to this WARNING pragma, if any; + -- see Note [Warning categories] + [XRec pass (WithHsDocIdentifiers StringLiteral pass)] + | XWarningTxt !(XXWarningTxt pass) + deriving Generic + +{- +Note [Warning categories] +~~~~~~~~~~~~~~~~~~~~~~~~~ +See GHC Proposal 541 for the design of the warning categories feature: +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0541-warning-pragmas-with-categories.rst + +A WARNING pragma may be annotated with a category such as "x-partial" written +after the 'in' keyword, like this: + + {-# WARNING in "x-partial" head "This function is partial..." #-} + +This is represented by the 'Maybe (Located WarningCategory)' field in +'WarningTxt'. The parser will accept an arbitrary string as the category name, +then the renamer (in 'rnWarningTxt') will check it contains only valid +characters, so we can generate a nicer error message than a parse error. + +The corresponding warnings can then be controlled with the -Wx-partial, +-Wno-x-partial, -Werror=x-partial and -Wwarn=x-partial flags. Such a flag is +distinguished from an 'unrecognisedWarning' by the flag parser testing +'validWarningCategory'. The 'x-' prefix means we can still usually report an +unrecognised warning where the user has made a mistake. + +A DEPRECATED pragma may not have a user-defined category, and is always treated +as belonging to the special category 'deprecations'. Similarly, a WARNING +pragma without a category belongs to the 'deprecations' category. +Thus the '-Wdeprecations' flag will enable all of the following: + + {-# WARNING in "deprecations" foo "This function is deprecated..." #-} + {-# WARNING foo "This function is deprecated..." #-} + {-# DEPRECATED foo "This function is deprecated..." #-} +The '-Wwarnings-deprecations' flag is supported for backwards compatibility +purposes as being equivalent to '-Wdeprecations'. + +The '-Wextended-warnings' warning group collects together all warnings with +user-defined categories, so they can be enabled or disabled +collectively. Moreover they are treated as being part of other warning groups +such as '-Wdefault' (see 'warningGroupIncludesExtendedWarnings'). + +'DynFlags' and 'DiagOpts' each contain a set of enabled and a set of fatal +warning categories, just as they do for the finite enumeration of 'WarningFlag's +built in to GHC. These are represented as 'WarningCategorySet's to allow for +the possibility of them being infinite. + +-} +data InWarningCategory pass + = InWarningCategory + { iwc_st :: (XInWarningCategory pass), + iwc_wc :: (XRec pass WarningCategory) + } + | XInWarningCategory !(XXInWarningCategory pass) + +newtype WarningCategory = WarningCategory FastString + deriving stock (Data) + deriving newtype (Eq, Show, NFData) + +mkWarningCategory :: FastString -> WarningCategory +mkWarningCategory = WarningCategory ===================================== compiler/Language/Haskell/Syntax/Extension.hs ===================================== @@ -410,6 +410,17 @@ type family XXWarnDecls x type family XWarning x type family XXWarnDecl x +-- ------------------------------------- +-- WarningTxt type families +type family XDeprecatedTxt x +type family XWarningTxt x +type family XXWarningTxt x + +-- ------------------------------------- +-- InWarningCategory type families +type family XInWarningCategory x +type family XXInWarningCategory x + -- ------------------------------------- -- AnnDecl type families type family XHsAnnotation x ===================================== testsuite/tests/diagnostic-codes/codes.stdout ===================================== @@ -70,6 +70,7 @@ [GHC-99991] is untested (constructor = TyVarMissingInEnv) [GHC-92834] is untested (constructor = BadCoercionRole) [GHC-93008] is untested (constructor = HsigShapeSortMismatch) +[GHC-68077] is untested (constructor = XWarningTxt) [GHC-68444] is untested (constructor = SumAltArityExceeded) [GHC-63966] is untested (constructor = IllegalSumAlt) [GHC-28709] is untested (constructor = MalformedType) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -53,7 +53,6 @@ import GHC.Types.PkgQual import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Types.Var -import GHC.Unit.Module.Warnings import GHC.Utils.Misc import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic @@ -1570,14 +1569,14 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where getAnnotationEntry = entryFromLocatedA setAnnotationAnchor = setAnchorAn - exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (WarningTxt mb_cat src ws)) = do + exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (WarningTxt src mb_cat ws)) = do o' <- markAnnOpen'' o src "{-# WARNING" mb_cat' <- markAnnotated mb_cat os' <- markEpToken os ws' <- markAnnotated ws cs' <- markEpToken cs c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (WarningTxt mb_cat' src ws')) + return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (WarningTxt src mb_cat' ws')) exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (DeprecatedTxt src ws)) = do o' <- markAnnOpen'' o src "{-# DEPRECATED" @@ -1587,14 +1586,14 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where c' <- markEpToken c return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (DeprecatedTxt src ws')) -instance ExactPrint InWarningCategory where +instance Typeable p => ExactPrint (InWarningCategory (GhcPass p)) where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (InWarningCategory tkIn source (L l wc)) = do + exact (InWarningCategory (tkIn, source) (L l wc)) = do tkIn' <- markEpToken tkIn L l' (_,wc') <- markAnnotated (L l (source, wc)) - return (InWarningCategory tkIn' source (L l' wc')) + return (InWarningCategory (tkIn', source) (L l' wc')) instance ExactPrint (SourceText, WarningCategory) where getAnnotationEntry _ = NoEntryVal @@ -1935,14 +1934,14 @@ instance ExactPrint (WarnDecl GhcPs) where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (Warning (ns_spec, (o,c)) lns (WarningTxt mb_cat src ls )) = do + exact (Warning (ns_spec, (o,c)) lns (WarningTxt src mb_cat ls )) = do mb_cat' <- markAnnotated mb_cat ns_spec' <- exactNsSpec ns_spec lns' <- markAnnotated lns o' <- markEpToken o ls' <- markAnnotated ls c' <- markEpToken c - return (Warning (ns_spec', (o',c')) lns' (WarningTxt mb_cat' src ls')) + return (Warning (ns_spec', (o',c')) lns' (WarningTxt src mb_cat' ls')) exact (Warning (ns_spec, (o,c)) lns (DeprecatedTxt src ls)) = do ns_spec' <- exactNsSpec ns_spec ===================================== utils/haddock/haddock-api/src/Haddock/Interface/Create.hs ===================================== @@ -354,7 +354,7 @@ parseWarning -> IfM m (Doc Name) parseWarning parserOpts sDocContext w = case w of IfDeprecatedTxt _ msg -> format "Deprecated: " (map dstToDoc msg) - IfWarningTxt _ _ msg -> format "Warning: " (map dstToDoc msg) + IfWarningTxt _ _ msg -> format "Warning: " (map dstToDoc msg) where dstToDoc :: (IfaceStringLiteral, [Name]) -> HsDoc GhcRn dstToDoc ((IfStringLiteral _ fs), ids) = WithHsDocIdentifiers (fsToDoc fs) (map noLoc ids) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/47d83d960e334ceed4ac59c7ebd1db… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/47d83d960e334ceed4ac59c7ebd1db… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 2 commits: Parser: improve mkModuleImpExp, remove checkImportSpec
by Marge Bot (＠marge-bot) 18 Dec '25

18 Dec '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 951402ed by Vladislav Zavialov at 2025-12-18T13:19:05-05:00 Parser: improve mkModuleImpExp, remove checkImportSpec 1. The `mkModuleImpExp` helper now knows whether it is processing an import or export list item, and uses this information to produce a more accurate error message for `import M (T(..,x))` with PatternSynonyms disabled. The old message incorrectly referred to this case as an export form. 2. The `checkImportSpec` helper is removed in favor of more comprehensive error checking in `mkModuleImpExp`. 3. Additionaly, the invariants of `ImpExpList` and `ImpExpAllWith` have been made more explicit in the comments and assertions (calls to 'panic'). Test case: import-syntax-no-ext - - - - - 47d83d96 by Vladislav Zavialov at 2025-12-18T13:19:06-05:00 Subordinate namespace-specified wildcards (#25901) Add support for subordinate namespace-specified wildcards `X(type ..)` and `X(data ..)` to import and export lists. Examples: import M (Cls(type ..)) -- imports Cls and all its associated types import M (Cls(data ..)) -- imports Cls and all its methods module M (R(data ..), C(type ..)) where -- exports R and all its data constructors and record fields; -- exports C and all its associated types, but not its methods The scope of this change is limited to the case where the wildcard is the only subordinate import/export item, whereas the more complex forms `X(type .., f)` or `X(type .., data ..)` are unsupported and raise the newly introduced PsErrUnsupportedExplicitNamespace error. This restriction may be lifted later. Summary of the changes: 1. Refactor IEThingAll to store its extension field XIEThingAll as a record IEThingAllExt instead of a tuple. 2. Extend the AST by adding a NamespaceSpecifier field to IEThingAllExt, representing an optional namespace specifier `type` or `data` in front of a subordinate wildcard `X(..)`. 3. Extend the grammar in Parser.y with productions for `type ..` and `data ..` in subordinate import/export items. 4. Introduce `filterByNamespaceGREs` to filter [GlobalRdrElt] by a NamespaceSpecifier; use it in `filterImports` and `exports_from_avail` to account for the namespace specifier in IEThingAll. 5. Improve diagnostics by storing more information in DodgyImportsEmptyParent and DodgyExportsEmptyParent. Test cases: T25901_sub_e T25901_sub_f T25901_sub_g T25901_sub_a T25901_sub_b T25901_sub_c T25901_sub_d T25901_sub_w DodgyImports02 DodgyImports03 DodgyImports04 - - - - - 50 changed files: - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Name/Reader.hs - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/patsyn/should_fail/all.T - + testsuite/tests/patsyn/should_fail/import-syntax-no-ext.hs - + testsuite/tests/patsyn/should_fail/import-syntax-no-ext.stderr - + testsuite/tests/rename/should_compile/T25901_sub_e.hs - + testsuite/tests/rename/should_compile/T25901_sub_f.hs - + testsuite/tests/rename/should_compile/T25901_sub_f.stderr - + testsuite/tests/rename/should_compile/T25901_sub_g.hs - + testsuite/tests/rename/should_compile/T25901_sub_g.stderr - + testsuite/tests/rename/should_compile/T25901_sub_g_helper.hs - testsuite/tests/rename/should_compile/all.T - testsuite/tests/rename/should_fail/T23570b.stderr - + testsuite/tests/rename/should_fail/T25901_sub_a.hs - + testsuite/tests/rename/should_fail/T25901_sub_a.stderr - + testsuite/tests/rename/should_fail/T25901_sub_b.hs - + testsuite/tests/rename/should_fail/T25901_sub_b.stderr - + testsuite/tests/rename/should_fail/T25901_sub_c.hs - + testsuite/tests/rename/should_fail/T25901_sub_c.stderr - + testsuite/tests/rename/should_fail/T25901_sub_c_helper.hs - + testsuite/tests/rename/should_fail/T25901_sub_d.hs - + testsuite/tests/rename/should_fail/T25901_sub_d.stderr - + testsuite/tests/rename/should_fail/T25901_sub_d_helper.hs - + testsuite/tests/rename/should_fail/T25901_sub_w.hs - + testsuite/tests/rename/should_fail/T25901_sub_w.stderr - testsuite/tests/rename/should_fail/all.T - testsuite/tests/warnings/should_compile/DodgyExports03.stderr - testsuite/tests/warnings/should_compile/DodgyImports.stderr - + testsuite/tests/warnings/should_compile/DodgyImports02.hs - + testsuite/tests/warnings/should_compile/DodgyImports02.stderr - + testsuite/tests/warnings/should_compile/DodgyImports03.hs - + testsuite/tests/warnings/should_compile/DodgyImports03.stderr - + testsuite/tests/warnings/should_compile/DodgyImports03_helper.hs - + testsuite/tests/warnings/should_compile/DodgyImports04.hs - + testsuite/tests/warnings/should_compile/DodgyImports04.stderr - testsuite/tests/warnings/should_compile/DodgyImports_hiding.stderr - testsuite/tests/warnings/should_compile/all.T - utils/check-exact/ExactPrint.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/55ab583b40ecdc1abc3307cea1d6a2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/55ab583b40ecdc1abc3307cea1d6a2… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 5 commits: X86 CodeGen: fix assign_eax_sse_regs
by Marge Bot (＠marge-bot) 18 Dec '25

18 Dec '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: fca9cd7c by sheaf at 2025-12-18T13:18:18-05:00 X86 CodeGen: fix assign_eax_sse_regs We must set %al to the number of SSE2 registers that contain arguments (in case we are dealing with a varargs function). The logic for counting how many arguments reside in SSE2 registers was incorrect, as it used 'isFloatFormat', which incorrectly ignores vector registers. We now instead do case analysis on the register class: is_sse_reg r = case targetClassOfReg platform r of RcFloatOrVector -> True RcInteger -> False This change is necessary to prevent segfaults in T20030_test1j, because subsequent commits change the format calculations, resulting in vector formats more often. - - - - - 53150617 by sheaf at 2025-12-18T13:18:19-05:00 X86 regUsageOfInstr: fix format for IMUL When used with 8-bit operands, the IMUL instruction returns the result in the lower 16 bits of %rax (also known as %ax). This is different than for the other sizes, where an input at 16, 32 or 64 bits will result in 16, 32 or 64 bits of output in both %rax and %rdx. This doesn't affect the behaviour of the compiler, because we don't allow partial writes at sub-word sizes. The rationale is explained in Wrinkle [Don't allow scalar partial writes] in Note [Register formats in liveness analysis], in GHC.CmmToAsm.Reg.Liveness. - - - - - c7a56dd1 by sheaf at 2025-12-18T13:18:19-05:00 Liveness analysis: consider register formats This commit updates the register allocator to be a bit more careful in situations in which a single register is used at multiple different formats, e.g. when xmm1 is used both to store a Double# and a DoubleX2#. This is done by introducing the 'Regs' newtype around 'UniqSet RegWithFormat', for which the combining operations take the larger of the two formats instead of overriding the format. Operations on 'Regs' are defined in 'GHC.CmmToAsm.Reg.Regs'. There is a modest compile-time cost for the additional overhead for tracking register formats, which causes the metric increases of this commit. The subtle aspects of the implementation are outlined in Note [Register formats in liveness analysis] in GHC.CmmToAsm.Reg.Liveness. Fixes #26411 #26611 ------------------------- Metric Increase: T12707 T26425 T3294 ------------------------- - - - - - c2e83339 by sheaf at 2025-12-18T13:18:19-05:00 Register allocator: reload at same format as spill This commit ensures that if we spill a register onto the stack at a given format, we then always reload the register at this same format. This ensures we don't end up in a situation where we spill F64x2 but end up only reloading the lower F64. This first reload would make us believe the whole data is in a register, thus silently losing the upper 64 bits of the spilled register's contents. Fixes #26526 - - - - - 55ab583b by sheaf at 2025-12-18T13:18:19-05:00 Register allocation: writes redefine format As explained in Note [Allocated register formats] in GHC.CmmToAsm.Reg.Linear, we consider all writes to redefine the format of the register. This ensures that in a situation such as movsd .Ln6m(%rip),%v1 shufpd $0,%v1,%v1 we properly consider the broadcast operation to change the format of %v1 from F64 to F64x2. This completes the fix to #26411 (test in T26411b). - - - - - 20 changed files: - compiler/GHC/CmmToAsm/Reg/Graph.hs - compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs - compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs - compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs - compiler/GHC/CmmToAsm/Reg/Linear.hs - compiler/GHC/CmmToAsm/Reg/Linear/Base.hs - compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs - compiler/GHC/CmmToAsm/Reg/Liveness.hs - + compiler/GHC/CmmToAsm/Reg/Regs.hs - compiler/GHC/CmmToAsm/Reg/Target.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToAsm/X86/Instr.hs - compiler/GHC/Types/Unique/FM.hs - compiler/GHC/Types/Unique/Set.hs - compiler/ghc.cabal.in - + testsuite/tests/simd/should_run/T26411.hs - + testsuite/tests/simd/should_run/T26411.stdout - + testsuite/tests/simd/should_run/T26411b.hs - + testsuite/tests/simd/should_run/T26411b.stdout - testsuite/tests/simd/should_run/all.T Changes: ===================================== compiler/GHC/CmmToAsm/Reg/Graph.hs ===================================== @@ -335,14 +335,14 @@ buildGraph platform code -- Conflicts between virtual and real regs are recorded as exclusions. graphAddConflictSet :: Platform - -> UniqSet RegWithFormat + -> Regs -> Color.Graph VirtualReg RegClass RealReg -> Color.Graph VirtualReg RegClass RealReg graphAddConflictSet platform regs graph = let arch = platformArch platform - virtuals = takeVirtualRegs regs - reals = takeRealRegs regs + virtuals = takeVirtualRegs $ getRegs regs + reals = takeRealRegs $ getRegs regs graph1 = Color.addConflicts virtuals (classOfVirtualReg arch) graph -- NB: we could add "arch" as argument to functions such as "addConflicts" ===================================== compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs ===================================== @@ -13,10 +13,8 @@ import GHC.Cmm import GHC.Data.Bag import GHC.Data.Graph.Directed import GHC.Platform (Platform) -import GHC.Types.Unique (getUnique) import GHC.Types.Unique.FM import GHC.Types.Unique.Supply -import GHC.Types.Unique.Set -- | Do register coalescing on this top level thing -- @@ -88,8 +86,8 @@ slurpJoinMovs platform live slurpLI rs (LiveInstr _ Nothing) = rs slurpLI rs (LiveInstr instr (Just live)) | Just (r1, r2) <- takeRegRegMoveInstr platform instr - , elemUniqSet_Directly (getUnique r1) $ liveDieRead live - , elemUniqSet_Directly (getUnique r2) $ liveBorn live + , r1 `elemRegs` liveDieRead live + , r2 `elemRegs` liveBorn live -- only coalesce movs between two virtuals for now, -- else we end up with allocatable regs in the live ===================================== compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs ===================================== @@ -144,7 +144,7 @@ regSpill_top platform regSlotMap cmm -- then record the fact that these slots are now live in those blocks -- in the given slotmap. patchLiveSlot - :: BlockMap IntSet -> BlockId -> UniqSet RegWithFormat-> BlockMap IntSet + :: BlockMap IntSet -> BlockId -> Regs -> BlockMap IntSet patchLiveSlot slotMap blockId regsLive = let @@ -154,7 +154,8 @@ regSpill_top platform regSlotMap cmm moreSlotsLive = IntSet.fromList $ mapMaybe (lookupUFM regSlotMap . regWithFormat_reg) - $ nonDetEltsUniqSet regsLive + $ nonDetEltsUniqSet + $ getRegs regsLive -- See Note [Unique Determinism and code generation] slotMap' ===================================== compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs ===================================== @@ -98,7 +98,7 @@ slurpSpillCostInfo platform cfg cmm countBlock info freqMap (BasicBlock blockId instrs) | LiveInfo _ _ blockLive _ <- info , Just rsLiveEntry <- mapLookup blockId blockLive - , rsLiveEntry_virt <- takeVirtualRegs rsLiveEntry + , rsLiveEntry_virt <- takeVirtualRegs $ getRegs rsLiveEntry = countLIs (ceiling $ blockFreq freqMap blockId) rsLiveEntry_virt instrs | otherwise @@ -132,9 +132,9 @@ slurpSpillCostInfo platform cfg cmm mapM_ (incDefs scale) $ nub $ mapMaybe (takeVirtualReg . regWithFormat_reg) written -- Compute liveness for entry to next instruction. - let liveDieRead_virt = takeVirtualRegs (liveDieRead live) - let liveDieWrite_virt = takeVirtualRegs (liveDieWrite live) - let liveBorn_virt = takeVirtualRegs (liveBorn live) + let liveDieRead_virt = takeVirtualRegs $ getRegs (liveDieRead live) + let liveDieWrite_virt = takeVirtualRegs $ getRegs (liveDieWrite live) + let liveBorn_virt = takeVirtualRegs $ getRegs (liveBorn live) let rsLiveAcross = rsLiveEntry `minusUniqSet` liveDieRead_virt ===================================== compiler/GHC/CmmToAsm/Reg/Linear.hs ===================================== @@ -207,7 +207,7 @@ linearRegAlloc :: forall instr. (Instruction instr) => NCGConfig -> [BlockId] -- ^ entry points - -> BlockMap (UniqSet RegWithFormat) + -> BlockMap Regs -- ^ live regs on entry to each basic block -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" @@ -246,7 +246,7 @@ linearRegAlloc' => NCGConfig -> freeRegs -> [BlockId] -- ^ entry points - -> BlockMap (UniqSet RegWithFormat) -- ^ live regs on entry to each basic block + -> BlockMap Regs -- ^ live regs on entry to each basic block -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int) @@ -260,7 +260,7 @@ linearRegAlloc' config initFreeRegs entry_ids block_live sccs linearRA_SCCs :: OutputableRegConstraint freeRegs instr => [BlockId] - -> BlockMap (UniqSet RegWithFormat) + -> BlockMap Regs -> [NatBasicBlock instr] -> [SCC (LiveBasicBlock instr)] -> RegM freeRegs [NatBasicBlock instr] @@ -295,7 +295,7 @@ linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs) process :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr) => [BlockId] - -> BlockMap (UniqSet RegWithFormat) + -> BlockMap Regs -> [GenBasicBlock (LiveInstr instr)] -> RegM freeRegs [[NatBasicBlock instr]] process entry_ids block_live = @@ -334,7 +334,7 @@ process entry_ids block_live = -- processBlock :: OutputableRegConstraint freeRegs instr - => BlockMap (UniqSet RegWithFormat) -- ^ live regs on entry to each basic block + => BlockMap Regs -- ^ live regs on entry to each basic block -> LiveBasicBlock instr -- ^ block to do register allocation on -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated @@ -351,7 +351,7 @@ processBlock block_live (BasicBlock id instrs) -- | Load the freeregs and current reg assignment into the RegM state -- for the basic block with this BlockId. initBlock :: FR freeRegs - => BlockId -> BlockMap (UniqSet RegWithFormat) -> RegM freeRegs () + => BlockId -> BlockMap Regs -> RegM freeRegs () initBlock id block_live = do platform <- getPlatform block_assig <- getBlockAssigR @@ -368,7 +368,7 @@ initBlock id block_live setFreeRegsR (frInitFreeRegs platform) Just live -> setFreeRegsR $ foldl' (flip $ frAllocateReg platform) (frInitFreeRegs platform) - (nonDetEltsUniqSet $ takeRealRegs live) + (nonDetEltsUniqSet $ takeRealRegs $ getRegs live) -- See Note [Unique Determinism and code generation] setAssigR emptyRegMap @@ -381,7 +381,7 @@ initBlock id block_live -- | Do allocation for a sequence of instructions. linearRA :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr) - => BlockMap (UniqSet RegWithFormat) -- ^ map of what vregs are live on entry to each block. + => BlockMap Regs -- ^ map of what vregs are live on entry to each block. -> BlockId -- ^ id of the current block, for debugging. -> [LiveInstr instr] -- ^ liveness annotated instructions in this block. -> RegM freeRegs @@ -406,7 +406,7 @@ linearRA block_live block_id = go [] [] -- | Do allocation for a single instruction. raInsn :: OutputableRegConstraint freeRegs instr - => BlockMap (UniqSet RegWithFormat) -- ^ map of what vregs are love on entry to each block. + => BlockMap Regs -- ^ map of what vregs are love on entry to each block. -> [instr] -- ^ accumulator for instructions already processed. -> BlockId -- ^ the id of the current block, for debugging -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info. @@ -427,7 +427,7 @@ raInsn _ new_instrs _ (LiveInstr ii@(Instr i) Nothing) raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) = do platform <- getPlatform - assig <- getAssigR :: RegM freeRegs (UniqFM Reg Loc) + assig <- getAssigR -- If we have a reg->reg move between virtual registers, where the -- src register is not live after this instruction, and the dst @@ -437,12 +437,12 @@ raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) -- (we can't eliminate it if the source register is on the stack, because -- we do not want to use one spill slot for different virtual registers) case takeRegRegMoveInstr platform instr of - Just (src,dst) | Just (RegWithFormat _ fmt) <- lookupUniqSet_Directly (liveDieRead live) (getUnique src), + Just (src,dst) | Just fmt <- lookupReg src (liveDieRead live), isVirtualReg dst, not (dst `elemUFM` assig), isRealReg src || isInReg src assig -> do case src of - RegReal rr -> setAssigR (addToUFM assig dst (InReg $ RealRegUsage rr fmt)) + RegReal rr -> setAssigR (addToUFM assig dst (Loc (InReg rr) fmt)) -- if src is a fixed reg, then we just map dest to this -- reg in the assignment. src must be an allocatable reg, -- otherwise it wouldn't be in r_dying. @@ -461,8 +461,8 @@ raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) return (new_instrs, []) _ -> genRaInsn block_live new_instrs id instr - (map regWithFormat_reg $ nonDetEltsUniqSet $ liveDieRead live) - (map regWithFormat_reg $ nonDetEltsUniqSet $ liveDieWrite live) + (map regWithFormat_reg $ nonDetEltsUniqSet $ getRegs $ liveDieRead live) + (map regWithFormat_reg $ nonDetEltsUniqSet $ getRegs $ liveDieWrite live) -- See Note [Unique Determinism and code generation] raInsn _ _ _ instr @@ -485,13 +485,16 @@ raInsn _ _ _ instr isInReg :: Reg -> RegMap Loc -> Bool -isInReg src assig | Just (InReg _) <- lookupUFM assig src = True - | otherwise = False +isInReg src assig + | Just (Loc (InReg _) _) <- lookupUFM assig src + = True + | otherwise + = False genRaInsn :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr) - => BlockMap (UniqSet RegWithFormat) + => BlockMap Regs -> [instr] -> BlockId -> instr @@ -643,14 +646,16 @@ releaseRegs regs = do loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs loop assig !free (r:rs) = case lookupUFM assig r of - Just (InBoth real _) -> loop (delFromUFM assig r) - (frReleaseReg platform (realReg real) free) rs - Just (InReg real) -> loop (delFromUFM assig r) - (frReleaseReg platform (realReg real) free) rs - _ -> loop (delFromUFM assig r) free rs + Just (Loc (InBoth real _) _) -> + loop (delFromUFM assig r) + (frReleaseReg platform real free) rs + Just (Loc (InReg real) _) -> + loop (delFromUFM assig r) + (frReleaseReg platform real free) rs + _ -> + loop (delFromUFM assig r) free rs loop assig free regs - -- ----------------------------------------------------------------------------- -- Clobber real registers @@ -668,17 +673,18 @@ releaseRegs regs = do saveClobberedTemps :: forall instr freeRegs. (Instruction instr, FR freeRegs) - => [RealReg] -- real registers clobbered by this instruction - -> [Reg] -- registers which are no longer live after this insn - -> RegM freeRegs [instr] -- return: instructions to spill any temps that will - -- be clobbered. + => [RealReg] -- ^ real registers clobbered by this instruction + -> [Reg] -- ^ registers which are no longer live after this instruction, + -- because read for the last time + -> RegM freeRegs [instr] -- return: instructions to spill any temps that will + -- be clobbered. saveClobberedTemps [] _ = return [] saveClobberedTemps clobbered dying = do - assig <- getAssigR :: RegM freeRegs (UniqFM Reg Loc) + assig <- getAssigR (assig',instrs) <- nonDetStrictFoldUFM_DirectlyM maybe_spill (assig,[]) assig setAssigR assig' return $ -- mkComment (text "<saveClobberedTemps>") ++ @@ -687,19 +693,21 @@ saveClobberedTemps clobbered dying where -- Unique represents the VirtualReg -- Here we separate the cases which we do want to spill from these we don't. - maybe_spill :: Unique -> (RegMap Loc,[instr]) -> (Loc) -> RegM freeRegs (RegMap Loc,[instr]) + maybe_spill :: Unique + -> (RegMap Loc,[instr]) + -> Loc + -> RegM freeRegs (RegMap Loc,[instr]) maybe_spill !temp !(assig,instrs) !loc = case loc of -- This is non-deterministic but we do not -- currently support deterministic code-generation. -- See Note [Unique Determinism and code generation] - InReg reg - | any (realRegsAlias $ realReg reg) clobbered + Loc (InReg reg) fmt + | any (realRegsAlias reg) clobbered , temp `notElem` map getUnique dying - -> clobber temp (assig,instrs) reg + -> clobber temp (assig,instrs) (RealRegUsage reg fmt) _ -> return (assig,instrs) - -- See Note [UniqFM and the register allocator] clobber :: Unique -> (RegMap Loc,[instr]) -> RealRegUsage -> RegM freeRegs (RegMap Loc,[instr]) clobber temp (assig,instrs) (RealRegUsage reg fmt) @@ -718,7 +726,7 @@ saveClobberedTemps clobbered dying (my_reg : _) -> do setFreeRegsR (frAllocateReg platform my_reg freeRegs) - let new_assign = addToUFM_Directly assig temp (InReg (RealRegUsage my_reg fmt)) + let new_assign = addToUFM_Directly assig temp (Loc (InReg my_reg) fmt) let instr = mkRegRegMoveInstr config fmt (RegReal reg) (RegReal my_reg) @@ -726,12 +734,13 @@ saveClobberedTemps clobbered dying -- (2) no free registers: spill the value [] -> do + (spill, slot) <- spillR (RegWithFormat (RegReal reg) fmt) temp -- record why this reg was spilled for profiling recordSpill (SpillClobber temp) - let new_assign = addToUFM_Directly assig temp (InBoth (RealRegUsage reg fmt) slot) + let new_assign = addToUFM_Directly assig temp (Loc (InBoth reg slot) fmt) return (new_assign, (spill ++ instrs)) @@ -779,9 +788,9 @@ clobberRegs clobbered clobber assig [] = assig - clobber assig ((temp, InBoth reg slot) : rest) - | any (realRegsAlias $ realReg reg) clobbered - = clobber (addToUFM_Directly assig temp (InMem slot)) rest + clobber assig ((temp, Loc (InBoth reg slot) regFmt) : rest) + | any (realRegsAlias reg) clobbered + = clobber (addToUFM_Directly assig temp (Loc (InMem slot) regFmt)) rest clobber assig (_:rest) = clobber assig rest @@ -790,9 +799,9 @@ clobberRegs clobbered -- allocateRegsAndSpill -- Why are we performing a spill? -data SpillLoc = ReadMem StackSlot -- reading from register only in memory - | WriteNew -- writing to a new variable - | WriteMem -- writing to register only in memory +data SpillLoc = ReadMem StackSlot Format -- reading from register only in memory + | WriteNew -- writing to a new variable + | WriteMem -- writing to register only in memory -- Note that ReadNew is not valid, since you don't want to be reading -- from an uninitialized register. We also don't need the location of -- the register in memory, since that will be invalidated by the write. @@ -818,28 +827,36 @@ allocateRegsAndSpill allocateRegsAndSpill _ _ spills alloc [] = return (spills, reverse alloc) -allocateRegsAndSpill reading keep spills alloc (r@(VirtualRegWithFormat vr _fmt):rs) +allocateRegsAndSpill reading keep spills alloc (r@(VirtualRegWithFormat vr vrFmt):rs) = do assig <- toVRegMap <$> getAssigR -- pprTraceM "allocateRegsAndSpill:assig" (ppr (r:rs) $$ ppr assig) -- See Note [UniqFM and the register allocator] let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig case lookupUFM assig vr of -- case (1a): already in a register - Just (InReg my_reg) -> - allocateRegsAndSpill reading keep spills (realReg my_reg:alloc) rs + Just (Loc (InReg my_reg) in_reg_fmt) -> do + -- (RF1) from Note [Allocated register formats]: + -- writes redefine the format the register is used at. + when (not reading && vrFmt /= in_reg_fmt) $ + setAssigR $ toRegMap $ + addToUFM assig vr (Loc (InReg my_reg) vrFmt) + allocateRegsAndSpill reading keep spills (my_reg:alloc) rs -- case (1b): already in a register (and memory) - -- NB1. if we're writing this register, update its assignment to be - -- InReg, because the memory value is no longer valid. - -- NB2. This is why we must process written registers here, even if they - -- are also read by the same instruction. - Just (InBoth my_reg _) - -> do when (not reading) (setAssigR $ toRegMap (addToUFM assig vr (InReg my_reg))) - allocateRegsAndSpill reading keep spills (realReg my_reg:alloc) rs + Just (Loc (InBoth my_reg _) _) -> do + -- NB1. if we're writing this register, update its assignment to be + -- InReg, because the memory value is no longer valid. + -- NB2. This is why we must process written registers here, even if they + -- are also read by the same instruction. + when (not reading) $ + setAssigR $ toRegMap $ + addToUFM assig vr (Loc (InReg my_reg) vrFmt) + allocateRegsAndSpill reading keep spills (my_reg:alloc) rs -- Not already in a register, so we need to find a free one... - Just (InMem slot) | reading -> doSpill (ReadMem slot) - | otherwise -> doSpill WriteMem + Just (Loc (InMem slot) memFmt) + | reading -> doSpill (ReadMem slot memFmt) + | otherwise -> doSpill WriteMem Nothing | reading -> pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr vr) -- NOTE: if the input to the NCG contains some @@ -875,7 +892,7 @@ allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr) -> UniqFM VirtualReg Loc -> SpillLoc -> RegM freeRegs ([instr], [RealReg]) -allocRegsAndSpill_spill reading keep spills alloc r@(VirtualRegWithFormat vr fmt) rs assig spill_loc +allocRegsAndSpill_spill reading keep spills alloc r@(VirtualRegWithFormat vr vrFmt) rs assig spill_loc = do platform <- getPlatform freeRegs <- getFreeRegsR let regclass = classOfVirtualReg (platformArch platform) vr @@ -897,7 +914,7 @@ allocRegsAndSpill_spill reading keep spills alloc r@(VirtualRegWithFormat vr fmt spills' <- loadTemp r spill_loc final_reg spills setAssigR $ toRegMap - $ (addToUFM assig vr $! newLocation spill_loc $ RealRegUsage final_reg fmt) + $ (addToUFM assig vr $! newLocation spill_loc $ RealRegUsage final_reg vrFmt) setFreeRegsR $ frAllocateReg platform final_reg freeRegs allocateRegsAndSpill reading keep spills' (final_reg : alloc) rs @@ -911,7 +928,7 @@ allocRegsAndSpill_spill reading keep spills alloc r@(VirtualRegWithFormat vr fmt let candidates' :: UniqFM VirtualReg Loc candidates' = flip delListFromUFM (fmap virtualRegWithFormat_reg keep) $ - filterUFM inRegOrBoth $ + filterUFM (inRegOrBoth . locWithFormat_loc) $ assig -- This is non-deterministic but we do not -- currently support deterministic code-generation. @@ -924,25 +941,25 @@ allocRegsAndSpill_spill reading keep spills alloc r@(VirtualRegWithFormat vr fmt == regclass candidates_inBoth :: [(Unique, RealRegUsage, StackSlot)] candidates_inBoth - = [ (temp, reg, mem) - | (temp, InBoth reg mem) <- candidates - , compat (realReg reg) ] + = [ (temp, RealRegUsage reg fmt, mem) + | (temp, Loc (InBoth reg mem) fmt) <- candidates + , compat reg ] -- the vregs we could kick out that are only in a reg -- this would require writing the reg to a new slot before using it. let candidates_inReg - = [ (temp, reg) - | (temp, InReg reg) <- candidates - , compat (realReg reg) ] + = [ (temp, RealRegUsage reg fmt) + | (temp, Loc (InReg reg) fmt) <- candidates + , compat reg ] let result -- we have a temporary that is in both register and mem, -- just free up its register for use. - | (temp, (RealRegUsage cand_reg _old_fmt), slot) : _ <- candidates_inBoth + | (temp, (RealRegUsage cand_reg old_fmt), slot) : _ <- candidates_inBoth = do spills' <- loadTemp r spill_loc cand_reg spills - let assig1 = addToUFM_Directly assig temp (InMem slot) - let assig2 = addToUFM assig1 vr $! newLocation spill_loc (RealRegUsage cand_reg fmt) + let assig1 = addToUFM_Directly assig temp $ Loc (InMem slot) old_fmt + let assig2 = addToUFM assig1 vr $! newLocation spill_loc (RealRegUsage cand_reg vrFmt) setAssigR $ toRegMap assig2 allocateRegsAndSpill reading keep spills' (cand_reg:alloc) rs @@ -962,8 +979,8 @@ allocRegsAndSpill_spill reading keep spills alloc r@(VirtualRegWithFormat vr fmt -- - the old data is now only in memory, -- - the new data is now allocated to this register; -- make sure to use the new format (#26542) - let assig1 = addToUFM_Directly assig temp_to_push_out (InMem slot) - let assig2 = addToUFM assig1 vr $! newLocation spill_loc (RealRegUsage cand_reg fmt) + let assig1 = addToUFM_Directly assig temp_to_push_out $ Loc (InMem slot) old_reg_fmt + let assig2 = addToUFM assig1 vr $! newLocation spill_loc (RealRegUsage cand_reg vrFmt) setAssigR $ toRegMap assig2 -- if need be, load up a spilled temp into the reg we've just freed up. @@ -980,7 +997,7 @@ allocRegsAndSpill_spill reading keep spills alloc r@(VirtualRegWithFormat vr fmt $ vcat [ text "allocating vreg: " <> text (show vr) , text "assignment: " <> ppr assig - , text "format: " <> ppr fmt + , text "format: " <> ppr vrFmt , text "freeRegs: " <> text (showRegs freeRegs) , text "initFreeRegs: " <> text (showRegs (frInitFreeRegs platform `asTypeOf` freeRegs)) ] @@ -992,9 +1009,12 @@ allocRegsAndSpill_spill reading keep spills alloc r@(VirtualRegWithFormat vr fmt -- | Calculate a new location after a register has been loaded. newLocation :: SpillLoc -> RealRegUsage -> Loc -- if the tmp was read from a slot, then now its in a reg as well -newLocation (ReadMem slot) my_reg = InBoth my_reg slot +newLocation (ReadMem slot memFmt) (RealRegUsage r _regFmt) = + -- See Note [Use spilled format when reloading] + Loc (InBoth r slot) memFmt + -- writes will always result in only the register being available -newLocation _ my_reg = InReg my_reg +newLocation _ (RealRegUsage r regFmt) = Loc (InReg r) regFmt -- | Load up a spilled temporary if we need to (read from memory). loadTemp @@ -1005,11 +1025,91 @@ loadTemp -> [instr] -> RegM freeRegs [instr] -loadTemp (VirtualRegWithFormat vreg fmt) (ReadMem slot) hreg spills +loadTemp (VirtualRegWithFormat vreg _fmt) (ReadMem slot memFmt) hreg spills = do - insn <- loadR (RegWithFormat (RegReal hreg) fmt) slot + -- See Note [Use spilled format when reloading] + insn <- loadR (RegWithFormat (RegReal hreg) memFmt) slot recordSpill (SpillLoad $ getUnique vreg) return $ {- mkComment (text "spill load") : -} insn ++ spills loadTemp _ _ _ spills = return spills + +{- Note [Allocated register formats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We uphold the following principle for the format at which we keep track of +alllocated registers: + + RF1. Writes redefine the format. + + When we write to a register 'r' at format 'fmt', we consider the register + to hold that format going forwards. + + (In cases where a partial write is desired, the move instruction should + specify that the destination format is the full register, even if, say, + the instruction only writes to the low 64 bits of the register. + See also Wrinkle [Don't allow scalar partial writes] in + Note [Register formats in liveness analysis] in GHC.CmmToAsm.Reg.Liveness.) + + RF2. Reads from a register do not redefine its format. + + Generally speaking, as explained in Note [Register formats in liveness analysis] + in GHC.CmmToAsm.Reg.Liveness, when computing the used format from a collection + of reads, we take a least upper bound. + +It is particularly important to get (RF1) correct, as otherwise we can end up in +the situation of T26411b, where code such as + + movsd .Ln6m(%rip),%v1 + shufpd $0,%v1,%v1 + +we start off with %v1 :: F64, but after shufpd (which broadcasts the low part +to the high part) we must consider that %v1 :: F64x2. If we fail to do that, +then we will silently discard the top bits in spill/reload operations. +-} + +{- Note [Use spilled format when reloading] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We always reload at the full format that a register was spilled at. The rationale +is as follows: + + 1. If later instructions only need the lower 64 bits of an XMM register, + then we should have only spilled the lower 64 bits in the first place. + (Whether this is true currently is another question.) + 2. If later instructions need say 128 bits, then we should immediately load + the entire 128 bits, as this avoids multiple load instructions. + +For (2), consider the situation of #26526, where we need to spill around a C +call (because we are using the System V ABI with no callee saved XMM registers). +Before register allocation, we have: + + vmovupd %v1 %v0 + call ... + movsd %v0 %v3 + movhlps %v0 %v4 + +The contents of %v0 need to be preserved across the call. We must spill %v0 at +format F64x2 (as later instructions need the entire 128 bits), and reload it +later. We thus expect something like: + + vmovupd %xmm1 %xmm0 + vmovupd %xmm0 72(%rsp) -- spill to preserve + call ... + vmovupd 72(%rsp) %xmm0 -- restore + movsd %xmm0 %xmm3 + movhlps %xmm0 %xmm4 + +This is certainly better than doing two loads from the stack, e.g. + + call ... + movsd 72(%rsp) %xmm0 -- restore only lower 64 bits + movsd %xmm0 %xmm3 + vmovupd 72(%rsp) %xmm0 -- restore the full 128 bits + movhlps %xmm0 %xmm4 + +The latter being especially risky because we don't want to believe %v0 is 'InBoth' +with format F64. The risk is that, when allocating registers for the 'VMOVUPD' +instruction, we think our data is already in a register and thus doesn't need to +be reloaded from memory, when in fact we have only loaded the lower 64 bits of +the data. +-} ===================================== compiler/GHC/CmmToAsm/Reg/Linear/Base.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} -- | Put common type definitions here to break recursive module dependencies. @@ -9,7 +10,7 @@ module GHC.CmmToAsm.Reg.Linear.Base ( emptyBlockAssignment, updateBlockAssignment, - Loc(..), + VLoc(..), Loc(..), IgnoreFormat(..), regsOfLoc, RealRegUsage(..), @@ -39,8 +40,6 @@ import GHC.Cmm.Dataflow.Label import GHC.CmmToAsm.Reg.Utils import GHC.CmmToAsm.Format -import Data.Function ( on ) - data ReadingOrWriting = Reading | Writing deriving (Eq,Ord) -- | Used to store the register assignment on entry to a basic block. @@ -70,8 +69,13 @@ updateBlockAssignment :: BlockId -> BlockAssignment freeRegs -> BlockAssignment freeRegs updateBlockAssignment dest (freeRegs, regMap) (BlockAssignment {..}) = - BlockAssignment (mapInsert dest (freeRegs, regMap) blockMap) - (mergeUFM combWithExisting id (mapMaybeUFM fromLoc) (firstUsed) (toVRegMap regMap)) + BlockAssignment + (mapInsert dest (freeRegs, regMap) blockMap) + (mergeUFM combWithExisting id + (mapMaybeUFM (fromVLoc . locWithFormat_loc)) + firstUsed + (toVRegMap regMap) + ) where -- The blocks are processed in dependency order, so if there's already an -- entry in the map then keep that assignment rather than writing the new @@ -79,13 +83,14 @@ updateBlockAssignment dest (freeRegs, regMap) (BlockAssignment {..}) = combWithExisting :: RealReg -> Loc -> Maybe RealReg combWithExisting old_reg _ = Just $ old_reg - fromLoc :: Loc -> Maybe RealReg - fromLoc (InReg rr) = Just $ realReg rr - fromLoc (InBoth rr _) = Just $ realReg rr - fromLoc _ = Nothing - + fromVLoc :: VLoc -> Maybe RealReg + fromVLoc (InReg rr) = Just rr + fromVLoc (InBoth rr _) = Just rr + fromVLoc _ = Nothing --- | Where a vreg is currently stored +-- | Where a vreg is currently stored. +-- +-- -- A temporary can be marked as living in both a register and memory -- (InBoth), for example if it was recently loaded from a spill location. -- This makes it cheap to spill (no save instruction required), but we @@ -96,22 +101,41 @@ updateBlockAssignment dest (freeRegs, regMap) (BlockAssignment {..}) = -- save it in a spill location, but mark it as InBoth because the current -- instruction might still want to read it. -- -data Loc +data VLoc -- | vreg is in a register - = InReg {-# UNPACK #-} !RealRegUsage + = InReg {-# UNPACK #-} !RealReg -- | vreg is held in stack slots - | InMem {-# UNPACK #-} !StackSlot - + | InMem {-# UNPACK #-} !StackSlot -- | vreg is held in both a register and stack slots - | InBoth {-# UNPACK #-} !RealRegUsage - {-# UNPACK #-} !StackSlot + | InBoth {-# UNPACK #-} !RealReg + {-# UNPACK #-} !StackSlot deriving (Eq, Ord, Show) -instance Outputable Loc where +-- | Where a virtual register is stored, together with the format it is stored at. +-- +-- See 'VLoc'. +data Loc + = Loc + { locWithFormat_loc :: {-# UNPACK #-} !VLoc + , locWithFormat_format :: Format + } + +-- | A newtype used to hang off 'Eq' and 'Ord' instances for 'Loc' which +-- ignore the format, as used in 'GHC.CmmToAsm.Reg.Linear.JoinToTargets'. +newtype IgnoreFormat a = IgnoreFormat a +instance Eq (IgnoreFormat Loc) where + IgnoreFormat (Loc l1 _) == IgnoreFormat (Loc l2 _) = l1 == l2 +instance Ord (IgnoreFormat Loc) where + compare (IgnoreFormat (Loc l1 _)) (IgnoreFormat (Loc l2 _)) = compare l1 l2 + +instance Outputable VLoc where ppr l = text (show l) +instance Outputable Loc where + ppr (Loc loc fmt) = parens (ppr loc <+> dcolon <+> ppr fmt) + -- | A 'RealReg', together with the specific 'Format' it is used at. data RealRegUsage = RealRegUsage @@ -122,22 +146,12 @@ data RealRegUsage instance Outputable RealRegUsage where ppr (RealRegUsage r fmt) = ppr r <> dcolon <+> ppr fmt --- NB: these instances only compare the underlying 'RealReg', as that is what --- is important for register allocation. --- --- (It would nonetheless be a good idea to remove these instances.) -instance Eq RealRegUsage where - (==) = (==) `on` realReg -instance Ord RealRegUsage where - compare = compare `on` realReg - -- | Get the reg numbers stored in this Loc. -regsOfLoc :: Loc -> [RealRegUsage] +regsOfLoc :: VLoc -> [RealReg] regsOfLoc (InReg r) = [r] regsOfLoc (InBoth r _) = [r] regsOfLoc (InMem _) = [] - -- | Reasons why instructions might be inserted by the spiller. -- Used when generating stats for -ddrop-asm-stats. -- ===================================== compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs ===================================== @@ -33,12 +33,14 @@ import GHC.Utils.Outputable import GHC.CmmToAsm.Format import GHC.Types.Unique.Set +import Data.Coerce (coerce) + -- | For a jump instruction at the end of a block, generate fixup code so its -- vregs are in the correct regs for its destination. -- joinToTargets :: (FR freeRegs, Instruction instr) - => BlockMap (UniqSet RegWithFormat) -- ^ maps the unique of the blockid to the set of vregs + => BlockMap Regs -- ^ maps the unique of the blockid to the set of vregs -- that are known to be live on the entry to each block. -> BlockId -- ^ id of the current block @@ -62,7 +64,7 @@ joinToTargets block_live id instr ----- joinToTargets' :: (FR freeRegs, Instruction instr) - => BlockMap (UniqSet RegWithFormat) -- ^ maps the unique of the blockid to the set of vregs + => BlockMap Regs -- ^ maps the unique of the blockid to the set of vregs -- that are known to be live on the entry to each block. -> [NatBasicBlock instr] -- ^ acc blocks of fixup code. @@ -90,23 +92,23 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests) -- adjust the current assignment to remove any vregs that are not live -- on entry to the destination block. let live_set = expectJust $ mapLookup dest block_live - let still_live uniq _ = uniq `elemUniqSet_Directly` live_set + let still_live uniq _ = uniq `elemUniqSet_Directly` getRegs live_set let adjusted_assig = filterUFM_Directly still_live assig -- and free up those registers which are now free. let to_free = - [ r | (reg, loc) <- nonDetUFMToList assig + [ r | (reg, Loc loc _locFmt) <- nonDetUFMToList assig -- This is non-deterministic but we do not -- currently support deterministic code-generation. -- See Note [Unique Determinism and code generation] - , not (elemUniqSet_Directly reg live_set) + , not (elemUniqSet_Directly reg $ getRegs live_set) , r <- regsOfLoc loc ] case lookupBlockAssignment dest block_assig of Nothing -> joinToTargets_first block_live new_blocks block_id instr dest dests - block_assig adjusted_assig $ map realReg to_free + block_assig adjusted_assig to_free Just (_, dest_assig) -> joinToTargets_again @@ -116,7 +118,7 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests) -- this is the first time we jumped to this block. joinToTargets_first :: (FR freeRegs, Instruction instr) - => BlockMap (UniqSet RegWithFormat) + => BlockMap Regs -> [NatBasicBlock instr] -> BlockId -> instr @@ -142,10 +144,9 @@ joinToTargets_first block_live new_blocks block_id instr dest dests joinToTargets' block_live new_blocks block_id instr dests - -- we've jumped to this block before joinToTargets_again :: (Instruction instr, FR freeRegs) - => BlockMap (UniqSet RegWithFormat) + => BlockMap Regs -> [NatBasicBlock instr] -> BlockId -> instr @@ -159,7 +160,9 @@ joinToTargets_again src_assig dest_assig -- the assignments already match, no problem. - | nonDetUFMToList dest_assig == nonDetUFMToList src_assig + | equalIgnoringFormats + (nonDetUFMToList dest_assig) + (nonDetUFMToList src_assig) -- This is non-deterministic but we do not -- currently support deterministic code-generation. -- See Note [Unique Determinism and code generation] @@ -183,7 +186,7 @@ joinToTargets_again -- -- We need to do the R2 -> R3 move before R1 -> R2. -- - let sccs = stronglyConnCompFromEdgedVerticesOrdR graph + let sccs = movementGraphSCCs graph -- debugging {- @@ -267,30 +270,36 @@ makeRegMovementGraph adjusted_assig dest_assig -- expandNode :: a - -> Loc -- ^ source of move - -> Loc -- ^ destination of move - -> [Node Loc a ] - -expandNode vreg loc@(InReg src) (InBoth dst mem) - | src == dst = [DigraphNode vreg loc [InMem mem]] - | otherwise = [DigraphNode vreg loc [InReg dst, InMem mem]] - -expandNode vreg loc@(InMem src) (InBoth dst mem) - | src == mem = [DigraphNode vreg loc [InReg dst]] - | otherwise = [DigraphNode vreg loc [InReg dst, InMem mem]] - -expandNode _ (InBoth _ src) (InMem dst) - | src == dst = [] -- guaranteed to be true - -expandNode _ (InBoth src _) (InReg dst) - | src == dst = [] - -expandNode vreg (InBoth src _) dst - = expandNode vreg (InReg src) dst - -expandNode vreg src dst - | src == dst = [] - | otherwise = [DigraphNode vreg src [dst]] + -> Loc -- ^ source of move + -> Loc -- ^ destination of move + -> [Node Loc a] +expandNode vreg src@(Loc srcLoc srcFmt) dst@(Loc dstLoc dstFmt) = + case (srcLoc, dstLoc) of + (InReg srcReg, InBoth dstReg dstMem) + | srcReg == dstReg + -> [DigraphNode vreg src [Loc (InMem dstMem) dstFmt]] + | otherwise + -> [DigraphNode vreg src [Loc (InReg dstReg) dstFmt + ,Loc (InMem dstMem) dstFmt]] + (InMem srcMem, InBoth dstReg dstMem) + | srcMem == dstMem + -> [DigraphNode vreg src [Loc (InReg dstReg) dstFmt]] + | otherwise + -> [DigraphNode vreg src [Loc (InReg dstReg) dstFmt + ,Loc (InMem dstMem) dstFmt]] + (InBoth _ srcMem, InMem dstMem) + | srcMem == dstMem + -> [] -- guaranteed to be true + (InBoth srcReg _, InReg dstReg) + | srcReg == dstReg + -> [] + (InBoth srcReg _, _) + -> expandNode vreg (Loc (InReg srcReg) srcFmt) dst + _ + | srcLoc == dstLoc + -> [] + | otherwise + -> [DigraphNode vreg src [dst]] -- | Generate fixup code for a particular component in the move graph @@ -327,7 +336,7 @@ handleComponent delta _ (AcyclicSCC (DigraphNode vreg src dsts)) -- require a fixup. -- handleComponent delta instr - (CyclicSCC ((DigraphNode vreg (InReg (RealRegUsage sreg scls)) ((InReg (RealRegUsage dreg dcls): _))) : rest)) + (CyclicSCC ((DigraphNode vreg (Loc (InReg sreg) scls) ((Loc (InReg dreg) dcls: _))) : rest)) -- dest list may have more than one element, if the reg is also InMem. = do -- spill the source into its slot @@ -338,7 +347,7 @@ handleComponent delta instr instrLoad <- loadR (RegWithFormat (RegReal dreg) dcls) slot remainingFixUps <- mapM (handleComponent delta instr) - (stronglyConnCompFromEdgedVerticesOrdR rest) + (movementGraphSCCs rest) -- make sure to do all the reloads after all the spills, -- so we don't end up clobbering the source values. @@ -347,29 +356,37 @@ handleComponent delta instr handleComponent _ _ (CyclicSCC _) = panic "Register Allocator: handleComponent cyclic" +-- Helper functions that use the @Ord (IgnoreFormat Loc)@ instance. + +equalIgnoringFormats :: [(Unique, Loc)] -> [(Unique, Loc)] -> Bool +equalIgnoringFormats = + coerce $ (==) @[(Unique, IgnoreFormat Loc)] +movementGraphSCCs :: [Node Loc Unique] -> [SCC (Node Loc Unique)] +movementGraphSCCs = + coerce $ stronglyConnCompFromEdgedVerticesOrdR @(IgnoreFormat Loc) @Unique -- | Move a vreg between these two locations. -- makeMove :: Instruction instr - => Int -- ^ current C stack delta. - -> Unique -- ^ unique of the vreg that we're moving. - -> Loc -- ^ source location. - -> Loc -- ^ destination location. - -> RegM freeRegs [instr] -- ^ move instruction. + => Int -- ^ current C stack delta + -> Unique -- ^ unique of the vreg that we're moving + -> Loc -- ^ source location + -> Loc -- ^ destination location + -> RegM freeRegs [instr] -- ^ move instruction -makeMove delta vreg src dst +makeMove delta vreg (Loc src _srcFmt) (Loc dst dstFmt) = do config <- getConfig case (src, dst) of - (InReg (RealRegUsage s _), InReg (RealRegUsage d fmt)) -> + (InReg s, InReg d) -> do recordSpill (SpillJoinRR vreg) - return $ [mkRegRegMoveInstr config fmt (RegReal s) (RegReal d)] - (InMem s, InReg (RealRegUsage d cls)) -> + return $ [mkRegRegMoveInstr config dstFmt (RegReal s) (RegReal d)] + (InMem s, InReg d) -> do recordSpill (SpillJoinRM vreg) - return $ mkLoadInstr config (RegWithFormat (RegReal d) cls) delta s - (InReg (RealRegUsage s cls), InMem d) -> + return $ mkLoadInstr config (RegWithFormat (RegReal d) dstFmt) delta s + (InReg s, InMem d) -> do recordSpill (SpillJoinRM vreg) - return $ mkSpillInstr config (RegWithFormat (RegReal s) cls) delta d + return $ mkSpillInstr config (RegWithFormat (RegReal s) dstFmt) delta d _ -> -- we don't handle memory to memory moves. -- they shouldn't happen because we don't share ===================================== compiler/GHC/CmmToAsm/Reg/Liveness.hs ===================================== @@ -30,7 +30,9 @@ module GHC.CmmToAsm.Reg.Liveness ( patchRegsLiveInstr, reverseBlocksInTops, regLiveness, - cmmTopLiveness + cmmTopLiveness, + + module GHC.CmmToAsm.Reg.Regs ) where import GHC.Prelude @@ -41,11 +43,11 @@ import GHC.CmmToAsm.Config import GHC.CmmToAsm.Format import GHC.CmmToAsm.Types import GHC.CmmToAsm.Utils +import GHC.CmmToAsm.Reg.Regs import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Label import GHC.Cmm -import GHC.CmmToAsm.Reg.Target import GHC.Data.Graph.Directed import GHC.Data.OrdList @@ -189,9 +191,9 @@ data LiveInstr instr data Liveness = Liveness - { liveBorn :: UniqSet RegWithFormat -- ^ registers born in this instruction (written to for first time). - , liveDieRead :: UniqSet RegWithFormat -- ^ registers that died because they were read for the last time. - , liveDieWrite :: UniqSet RegWithFormat} -- ^ registers that died because they were clobbered by something. + { liveBorn :: Regs -- ^ registers born in this instruction (written to for first time). + , liveDieRead :: Regs -- ^ registers that died because they were read for the last time. + , liveDieWrite :: Regs } -- ^ registers that died because they were clobbered by something. -- | Stash regs live on entry to each basic block in the info part of the cmm code. @@ -200,7 +202,7 @@ data LiveInfo (LabelMap RawCmmStatics) -- cmm info table static stuff [BlockId] -- entry points (first one is the -- entry point for the proc). - (BlockMap (UniqSet RegWithFormat)) -- argument locals live on entry to this block + (BlockMap Regs) -- argument locals live on entry to this block (BlockMap IntSet) -- stack slots live on entry to this block @@ -246,8 +248,8 @@ instance Outputable instr , pprRegs (text "# w_dying: ") (liveDieWrite live) ] $+$ space) - where pprRegs :: SDoc -> UniqSet RegWithFormat -> SDoc - pprRegs name regs + where pprRegs :: SDoc -> Regs -> SDoc + pprRegs name ( Regs regs ) | isEmptyUniqSet regs = empty | otherwise = name <> (pprUFM (getUniqSet regs) (hcat . punctuate space . map ppr)) @@ -330,7 +332,7 @@ slurpConflicts :: Instruction instr => Platform -> LiveCmmDecl statics instr - -> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg)) + -> (Bag Regs, Bag (Reg, Reg)) slurpConflicts platform live = slurpCmm (emptyBag, emptyBag) live @@ -364,23 +366,22 @@ slurpConflicts platform live = let -- regs that die because they are read for the last time at the start of an instruction -- are not live across it. - rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live) + rsLiveAcross = rsLiveEntry `minusRegs` (liveDieRead live) -- regs live on entry to the next instruction. -- be careful of orphans, make sure to delete dying regs _after_ unioning -- in the ones that are born here. - rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live)) - `minusUniqSet` (liveDieWrite live) + rsLiveNext = (rsLiveAcross `unionRegsMaxFmt` (liveBorn live)) + `minusCoveredRegs` (liveDieWrite live) -- orphan vregs are the ones that die in the same instruction they are born in. -- these are likely to be results that are never used, but we still -- need to assign a hreg to them.. - rsOrphans = intersectUniqSets + rsOrphans = intersectRegsMaxFmt (liveBorn live) - (unionUniqSets (liveDieWrite live) (liveDieRead live)) + (unionRegsMaxFmt (liveDieWrite live) (liveDieRead live)) - -- - rsConflicts = unionUniqSets rsLiveNext rsOrphans + rsConflicts = unionRegsMaxFmt rsLiveNext rsOrphans in case takeRegRegMoveInstr platform instr of Just rr -> slurpLIs rsLiveNext @@ -619,7 +620,7 @@ patchEraseLive platform patchF cmm | LiveInfo static id blockMap mLiveSlots <- info = let -- See Note [Unique Determinism and code generation] - blockMap' = mapMap (mapRegFormatSet patchF) blockMap + blockMap' = mapMap (mapRegs patchF) blockMap info' = LiveInfo static id blockMap' mLiveSlots in CmmProc info' label live $ map patchSCC sccs @@ -648,8 +649,8 @@ patchEraseLive platform patchF cmm | r1 == r2 = True -- destination reg is never used - | elemUniqSet_Directly (getUnique r2) (liveBorn live) - , elemUniqSet_Directly (getUnique r2) (liveDieRead live) || elemUniqSet_Directly (getUnique r2) (liveDieWrite live) + | r2 `elemRegs` liveBorn live + , r2 `elemRegs` liveDieRead live || r2 `elemRegs` liveDieWrite live = True | otherwise = False @@ -673,9 +674,9 @@ patchRegsLiveInstr platform patchF li (patchRegsOfInstr platform instr patchF) (Just live { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg - liveBorn = mapRegFormatSet patchF $ liveBorn live - , liveDieRead = mapRegFormatSet patchF $ liveDieRead live - , liveDieWrite = mapRegFormatSet patchF $ liveDieWrite live }) + liveBorn = mapRegs patchF $ liveBorn live + , liveDieRead = mapRegs patchF $ liveDieRead live + , liveDieWrite = mapRegs patchF $ liveDieWrite live }) -- See Note [Unique Determinism and code generation] -------------------------------------------------------------------------------- @@ -865,7 +866,7 @@ computeLiveness -> [SCC (LiveBasicBlock instr)] -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers -- which are "dead after this instruction". - BlockMap (UniqSet RegWithFormat)) -- blocks annotated with set of live registers + BlockMap Regs) -- blocks annotated with set of live registers -- on entry to the block. computeLiveness platform sccs @@ -880,11 +881,11 @@ computeLiveness platform sccs livenessSCCs :: Instruction instr => Platform - -> BlockMap (UniqSet RegWithFormat) + -> BlockMap Regs -> [SCC (LiveBasicBlock instr)] -- accum -> [SCC (LiveBasicBlock instr)] -> ( [SCC (LiveBasicBlock instr)] - , BlockMap (UniqSet RegWithFormat)) + , BlockMap Regs) livenessSCCs _ blockmap done [] = (done, blockmap) @@ -913,13 +914,14 @@ livenessSCCs platform blockmap done linearLiveness :: Instruction instr - => BlockMap (UniqSet RegWithFormat) -> [LiveBasicBlock instr] - -> (BlockMap (UniqSet RegWithFormat), [LiveBasicBlock instr]) + => BlockMap Regs -> [LiveBasicBlock instr] + -> (BlockMap Regs, [LiveBasicBlock instr]) linearLiveness = mapAccumL (livenessBlock platform) -- probably the least efficient way to compare two -- BlockMaps for equality. + equalBlockMaps :: BlockMap Regs -> BlockMap Regs -> Bool equalBlockMaps a b = a' == b' where a' = mapToList a @@ -933,14 +935,14 @@ livenessSCCs platform blockmap done livenessBlock :: Instruction instr => Platform - -> BlockMap (UniqSet RegWithFormat) + -> BlockMap Regs -> LiveBasicBlock instr - -> (BlockMap (UniqSet RegWithFormat), LiveBasicBlock instr) + -> (BlockMap Regs, LiveBasicBlock instr) livenessBlock platform blockmap (BasicBlock block_id instrs) = let (regsLiveOnEntry, instrs1) - = livenessBack platform emptyUniqSet blockmap [] (reverse instrs) + = livenessBack platform noRegs blockmap [] (reverse instrs) blockmap' = mapInsert block_id regsLiveOnEntry blockmap instrs2 = livenessForward platform regsLiveOnEntry instrs1 @@ -955,23 +957,26 @@ livenessBlock platform blockmap (BasicBlock block_id instrs) livenessForward :: Instruction instr => Platform - -> UniqSet RegWithFormat -- regs live on this instr + -> Regs -- regs live on this instr -> [LiveInstr instr] -> [LiveInstr instr] livenessForward _ _ [] = [] livenessForward platform rsLiveEntry (li@(LiveInstr instr mLive) : lis) | Just live <- mLive = let - RU _ written = regUsageOfInstr platform instr + RU _ rsWritten = regUsageOfInstr platform instr -- Regs that are written to but weren't live on entry to this instruction -- are recorded as being born here. - rsBorn = mkUniqSet - $ filter (\ r -> not $ elemUniqSet_Directly (getUnique r) rsLiveEntry) - $ written + rsBorn = mkRegsMaxFmt + [ reg + | reg@( RegWithFormat r _ ) <- rsWritten + , not $ r `elemRegs` rsLiveEntry + ] - rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn) - `minusUniqSet` (liveDieRead live) - `minusUniqSet` (liveDieWrite live) + -- See Note [Register formats in liveness analysis] + rsLiveNext = (rsLiveEntry `addRegsMaxFmt` rsWritten) + `minusRegs` (liveDieRead live) -- (FmtFwd1) + `minusRegs` (liveDieWrite live) -- (FmtFwd2) in LiveInstr instr (Just live { liveBorn = rsBorn }) : livenessForward platform rsLiveNext lis @@ -986,11 +991,11 @@ livenessForward platform rsLiveEntry (li@(LiveInstr instr mLive) : lis) livenessBack :: Instruction instr => Platform - -> UniqSet RegWithFormat -- regs live on this instr - -> BlockMap (UniqSet RegWithFormat) -- regs live on entry to other BBs - -> [LiveInstr instr] -- instructions (accum) - -> [LiveInstr instr] -- instructions - -> (UniqSet RegWithFormat, [LiveInstr instr]) + -> Regs -- ^ regs live on this instr + -> BlockMap Regs -- ^ regs live on entry to other BBs + -> [LiveInstr instr] -- ^ instructions (accum) + -> [LiveInstr instr] -- ^ instructions + -> (Regs, [LiveInstr instr]) livenessBack _ liveregs _ done [] = (liveregs, done) @@ -998,15 +1003,14 @@ livenessBack platform liveregs blockmap acc (instr : instrs) = let !(!liveregs', instr') = liveness1 platform liveregs blockmap instr in livenessBack platform liveregs' blockmap (instr' : acc) instrs - -- don't bother tagging comments or deltas with liveness liveness1 :: Instruction instr => Platform - -> UniqSet RegWithFormat - -> BlockMap (UniqSet RegWithFormat) + -> Regs + -> BlockMap Regs -> LiveInstr instr - -> (UniqSet RegWithFormat, LiveInstr instr) + -> (Regs, LiveInstr instr) liveness1 _ liveregs _ (LiveInstr instr _) | isMetaInstr instr @@ -1017,14 +1021,14 @@ liveness1 platform liveregs blockmap (LiveInstr instr _) | not_a_branch = (liveregs1, LiveInstr instr (Just $ Liveness - { liveBorn = emptyUniqSet + { liveBorn = noRegs , liveDieRead = r_dying , liveDieWrite = w_dying })) | otherwise = (liveregs_br, LiveInstr instr (Just $ Liveness - { liveBorn = emptyUniqSet + { liveBorn = noRegs , liveDieRead = r_dying_br , liveDieWrite = w_dying })) @@ -1033,21 +1037,22 @@ liveness1 platform liveregs blockmap (LiveInstr instr _) -- registers that were written here are dead going backwards. -- registers that were read here are live going backwards. - liveregs1 = (liveregs `delListFromUniqSet` written) - `addListToUniqSet` read + -- As for the formats, see Note [Register formats in liveness analysis] + liveregs1 = (liveregs `minusCoveredRegs` mkRegsMaxFmt written) -- (FmtBwd2) + `addRegsMaxFmt` read -- (FmtBwd1) - -- registers that are not live beyond this point, are recorded - -- as dying here. - r_dying = mkUniqSet + -- registers that are not live beyond this point are recorded + -- as dying here. + r_dying = mkRegsMaxFmt [ reg | reg@(RegWithFormat r _) <- read , not $ any (\ w -> getUnique w == getUnique r) written - , not (elementOfUniqSet reg liveregs) ] + , not $ r `elemRegs` liveregs ] - w_dying = mkUniqSet + w_dying = mkRegsMaxFmt [ reg - | reg <- written - , not (elementOfUniqSet reg liveregs) ] + | reg@(RegWithFormat r _) <- written + , not $ r `elemRegs` liveregs ] -- union in the live regs from all the jump destinations of this -- instruction. @@ -1057,14 +1062,91 @@ liveness1 platform liveregs blockmap (LiveInstr instr _) targetLiveRegs target = case mapLookup target blockmap of Just ra -> ra - Nothing -> emptyUniqSet - - live_from_branch = unionManyUniqSets (map targetLiveRegs targets) - - liveregs_br = liveregs1 `unionUniqSets` live_from_branch + Nothing -> noRegs -- registers that are live only in the branch targets should -- be listed as dying here. - live_branch_only = live_from_branch `minusUniqSet` liveregs - r_dying_br = (r_dying `unionUniqSets` live_branch_only) - -- See Note [Unique Determinism and code generation] + live_from_branch = unionManyRegsMaxFmt (map targetLiveRegs targets) + liveregs_br = liveregs1 `unionRegsMaxFmt` live_from_branch + live_branch_only = live_from_branch `minusRegs` liveregs + r_dying_br = r_dying `unionRegsMaxFmt` live_branch_only + -- NB: we treat registers live in branches similar to any other + -- registers read by the instruction, so the logic here matches + -- the logic in the definition of 'r_dying' above. + +{- Note [Register formats in liveness analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We keep track of which format each virtual register is live at, and make use +of this information during liveness analysis. + +First, we do backwards liveness analysis: + + (FmtBwd1) Take the larger format when computing registers live going backwards. + + Suppose for example that we have: + + <previous instructions> + movps %v0 %v1 + movupd %v0 %v2 + + Here we read %v0 both at format F64 and F64x2, so we must consider it live + at format F64x2, going backwards, in the previous instructions. + Not doing so caused #26411. + + (FmtBwd2) Only consider fully clobbered registers to be dead going backwards. + + Consider for example the liveness of %v0 going backwards in the following + instruction block: + + movlhps %v5 %v0 -- write the upper F64 of %v0 + movupd %v1 %v2 -- some unrelated instruction + movsd %v3 %v0 -- write the lower F64 of %v0 + movupd %v0 %v4 -- read %v0 at format F64x2 + + We must not consider %v0 to be dead going backwards from 'movsd %v3 %v0'. + If we do, that means we think %v0 is dead during 'movupd %v1 %v2', and thus + that we can assign both %v0 and %v2 to the same real register. However, this + would be catastrophic, as 'movupd %v1 %v2' would then clobber the data + written to '%v0' in 'movlhps %v5 %v0'. + + Wrinkle [Don't allow scalar partial writes] + + We don't allow partial writes within scalar registers, for many reasons: + + - partial writes can cause partial register stalls, which can have + disastrous performance implications (as seen in #20405) + - partial writes makes register allocation more difficult, as they can + require preserving the contents of a register across many instructions, + as in: + + mulw %v0 -- 32-bit write to %rax + <many instructions> + mulb %v1 -- 16-bit partial write to %rax + + The current register allocator is not equipped for spilling real + registers (only virtual registers), which means that e.g. on i386 we + end up with only 2 allocatable real GP registers for <many instructions>, + which is insufficient for instructions that require 3 registers. + + We could allow this to be customised depending on the architecture, but + currently we simply never allow scalar partial writes. + +The forwards analysis is a bit simpler: + + (FmtFwd1) Remove without considering format when dead going forwards. + + If a register is no longer read after an instruction, then it is dead + going forwards. The format doesn't matter. + + (FmtFwd2) Consider all writes as making a register dead going forwards. + + If we write to the lower 64 bits of a 128 bit register, we don't currently + have a way to say "the lower 64 bits are dead but the top 64 bits are still live". + We would need a notion of partial register, similar to 'VirtualRegHi' for + the top 32 bits of a I32x2 virtual register. + + As a result, the current approach is to consider the entire register to + be dead. This might cause us to unnecessarily spill/reload an entire vector + register to avoid its lower bits getting clobbered even though later + instructions might only care about its upper bits. +-} ===================================== compiler/GHC/CmmToAsm/Reg/Regs.hs ===================================== @@ -0,0 +1,119 @@ +{-# LANGUAGE DerivingStrategies #-} + +module GHC.CmmToAsm.Reg.Regs ( + Regs(..), + noRegs, + addRegMaxFmt, addRegsMaxFmt, + mkRegsMaxFmt, + minusCoveredRegs, + minusRegs, + unionRegsMaxFmt, + unionManyRegsMaxFmt, + intersectRegsMaxFmt, + shrinkingRegs, + mapRegs, + elemRegs, lookupReg, + + ) where + +import GHC.Prelude + +import GHC.Platform.Reg ( Reg ) +import GHC.CmmToAsm.Format ( Format, RegWithFormat(..), isVecFormat ) + +import GHC.Utils.Outputable ( Outputable ) +import GHC.Types.Unique ( Uniquable(..) ) +import GHC.Types.Unique.Set + +import Data.Coerce ( coerce ) + +----------------------------------------------------------------------------- + +-- | A set of registers, with their respective formats, mostly for use in +-- register liveness analysis. See Note [Register formats in liveness analysis] +-- in GHC.CmmToAsm.Reg.Liveness. +newtype Regs = Regs { getRegs :: UniqSet RegWithFormat } + deriving newtype (Eq, Outputable) + +maxRegWithFormat :: RegWithFormat -> RegWithFormat -> RegWithFormat +maxRegWithFormat r1@(RegWithFormat _ fmt1) r2@(RegWithFormat _ fmt2) + = if fmt1 >= fmt2 + then r1 + else r2 + -- Re-using one of the arguments avoids allocating a new 'RegWithFormat', + -- compared with returning 'RegWithFormat r1 (max fmt1 fmt2)'. + +noRegs :: Regs +noRegs = Regs emptyUniqSet + +addRegsMaxFmt :: Regs -> [RegWithFormat] -> Regs +addRegsMaxFmt = foldl' addRegMaxFmt + +mkRegsMaxFmt :: [RegWithFormat] -> Regs +mkRegsMaxFmt = addRegsMaxFmt noRegs + +addRegMaxFmt :: Regs -> RegWithFormat -> Regs +addRegMaxFmt = coerce $ strictAddOneToUniqSet_C maxRegWithFormat + -- Don't build up thunks when combining with 'maxRegWithFormat' + +-- | Remove 2nd argument registers from the 1st argument, but only +-- if the format in the second argument is at least as large as the format +-- in the first argument. +minusCoveredRegs :: Regs -> Regs -> Regs +minusCoveredRegs = coerce $ minusUniqSet_C f + where + f :: RegWithFormat -> RegWithFormat -> Maybe RegWithFormat + f r1@(RegWithFormat _ fmt1) (RegWithFormat _ fmt2) = + if fmt2 >= fmt1 + || + not ( isVecFormat fmt1 ) + -- See Wrinkle [Don't allow scalar partial writes] + -- in Note [Register formats in liveness analysis] in GHC.CmmToAsm.Reg.Liveness. + then Nothing + else Just r1 + +-- | Remove 2nd argument registers from the 1st argument, regardless of format. +-- +-- See also 'minusCoveredRegs', which looks at the formats. +minusRegs :: Regs -> Regs -> Regs +minusRegs = coerce $ minusUniqSet @RegWithFormat + +unionRegsMaxFmt :: Regs -> Regs -> Regs +unionRegsMaxFmt = coerce $ strictUnionUniqSets_C maxRegWithFormat + -- Don't build up thunks when combining with 'maxRegWithFormat' + +unionManyRegsMaxFmt :: [Regs] -> Regs +unionManyRegsMaxFmt = coerce $ strictUnionManyUniqSets_C maxRegWithFormat + -- Don't build up thunks when combining with 'maxRegWithFormat' + +intersectRegsMaxFmt :: Regs -> Regs -> Regs +intersectRegsMaxFmt = coerce $ strictIntersectUniqSets_C maxRegWithFormat + -- Don't build up thunks when combining with 'maxRegWithFormat' + +-- | Computes the set of registers in both arguments whose size is smaller in +-- the second argument than in the first. +shrinkingRegs :: Regs -> Regs -> Regs +shrinkingRegs = coerce $ minusUniqSet_C f + where + f :: RegWithFormat -> RegWithFormat -> Maybe RegWithFormat + f (RegWithFormat _ fmt1) r2@(RegWithFormat _ fmt2) + | fmt2 < fmt1 + = Just r2 + | otherwise + = Nothing + +-- | Map a function that may change the 'Unique' of the register, +-- which entails going via lists. +-- +-- See Note [UniqSet invariant] in GHC.Types.Unique.Set. +mapRegs :: (Reg -> Reg) -> Regs -> Regs +mapRegs f (Regs live) = + Regs $ + mapUniqSet (\ (RegWithFormat r fmt) -> RegWithFormat (f r) fmt) live + +elemRegs :: Reg -> Regs -> Bool +elemRegs r (Regs live) = elemUniqSet_Directly (getUnique r) live + +lookupReg :: Reg -> Regs -> Maybe Format +lookupReg r (Regs live) = + regWithFormat_format <$> lookupUniqSet_Directly live (getUnique r) ===================================== compiler/GHC/CmmToAsm/Reg/Target.hs ===================================== @@ -15,7 +15,6 @@ module GHC.CmmToAsm.Reg.Target ( targetMkVirtualReg, targetRegDotColor, targetClassOfReg, - mapRegFormatSet, ) where @@ -27,10 +26,8 @@ import GHC.Platform.Reg.Class import GHC.CmmToAsm.Format import GHC.Utils.Outputable -import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Types.Unique -import GHC.Types.Unique.Set import GHC.Platform import qualified GHC.CmmToAsm.X86.Regs as X86 @@ -142,6 +139,3 @@ targetClassOfReg platform reg = case reg of RegVirtual vr -> classOfVirtualReg (platformArch platform) vr RegReal rr -> targetClassOfRealReg platform rr - -mapRegFormatSet :: HasDebugCallStack => (Reg -> Reg) -> UniqSet RegWithFormat -> UniqSet RegWithFormat -mapRegFormatSet f = mapUniqSet (\ ( RegWithFormat r fmt ) -> RegWithFormat ( f r ) fmt) ===================================== compiler/GHC/CmmToAsm/X86/CodeGen.hs ===================================== @@ -54,7 +54,9 @@ import GHC.CmmToAsm.CFG import GHC.CmmToAsm.Format import GHC.CmmToAsm.Config import GHC.Platform.Reg +import GHC.CmmToAsm.Reg.Target (targetClassOfReg) import GHC.Platform +import GHC.Platform.Reg.Class.Unified (RegClass(..)) -- Our intermediate code: import GHC.Types.Basic @@ -4697,7 +4699,14 @@ genCCall64 addr conv dest_regs args = do -- It's not safe to omit this assignment, even if the number -- of SSE2 regs in use is zero. If %al is larger than 8 -- on entry to a varargs function, seg faults ensue. - nb_sse_regs_used = count (isFloatFormat . regWithFormat_format) arg_regs_used + is_sse_reg (RegWithFormat r _) = + -- NB: use 'targetClassOfRealReg' to compute whether this is an SSE + -- register or not, as we may have decided to e.g. store a 64-bit + -- integer in an xmm register. + case targetClassOfReg platform r of + RcFloatOrVector -> True + RcInteger -> False + nb_sse_regs_used = count is_sse_reg arg_regs_used assign_eax_sse_regs = unitOL (MOV II32 (OpImm (ImmInt nb_sse_regs_used)) (OpReg eax)) -- Note: we do this on Windows as well. It's not entirely clear why ===================================== compiler/GHC/CmmToAsm/X86/Instr.hs ===================================== @@ -114,9 +114,12 @@ data Instr -- | X86 scalar move instruction. -- - -- When used at a vector format, only moves the lower 64 bits of data; - -- the rest of the data in the destination may either be zeroed or - -- preserved, depending on the specific format and operands. + -- The format is the format the destination is written to. For an XMM + -- register, using a scalar format means that we don't care about the + -- upper bits, while using a vector format means that we care about the + -- upper bits, even though we are only writing to the lower bits. + -- + -- See also Note [Allocated register formats] in GHC.CmmToAsm.Reg.Linear. | MOV Format Operand Operand -- N.B. Due to AT&T assembler quirks, when used with 'II64' -- 'Format' immediate source and memory target operand, the source @@ -410,18 +413,27 @@ data FMAPermutation = FMA132 | FMA213 | FMA231 regUsageOfInstr :: Platform -> Instr -> RegUsage regUsageOfInstr platform instr = case instr of - MOV fmt src dst + + -- Recall that MOV is always a scalar move instruction, but when the destination + -- is an XMM register, we make the distinction between: + -- + -- - a scalar format, meaning that from now on we no longer care about the top bits + -- of the register, and + -- - a vector format, meaning that we still care about what's in the high bits. + -- + -- See Note [Allocated register formats] in GHC.CmmToAsm.Reg.Linear. + MOV dst_fmt src dst -- MOVSS/MOVSD preserve the upper half of vector registers, -- but only for reg-2-reg moves - | VecFormat _ sFmt <- fmt + | VecFormat _ sFmt <- dst_fmt , isFloatScalarFormat sFmt , OpReg {} <- src , OpReg {} <- dst - -> usageRM fmt src dst + -> usageRM dst_fmt src dst -- other MOV instructions zero any remaining upper part of the destination -- (largely to avoid partial register stalls) | otherwise - -> usageRW fmt src dst + -> usageRW dst_fmt src dst MOVD fmt1 fmt2 src dst -> -- NB: MOVD and MOVQ always zero any remaining upper part of destination, -- so the destination is "written" not "modified". @@ -437,7 +449,7 @@ regUsageOfInstr platform instr IMUL fmt src dst -> usageRM fmt src dst -- Result of IMULB will be in just in %ax - IMUL2 II8 src -> mkRU (mk II8 eax:use_R II8 src []) [mk II8 eax] + IMUL2 II8 src -> mkRU (mk II8 eax:use_R II8 src []) [mk II16 eax] -- Result of IMUL for wider values, will be split between %dx/%edx/%rdx and -- %ax/%eax/%rax. IMUL2 fmt src -> mkRU (mk fmt eax:use_R fmt src []) [mk fmt eax,mk fmt edx] ===================================== compiler/GHC/Types/Unique/FM.hs ===================================== @@ -38,6 +38,7 @@ module GHC.Types.Unique.FM ( listToUFM_C, listToIdentityUFM, addToUFM,addToUFM_C,addToUFM_Acc,addToUFM_L, + strictAddToUFM_C, addListToUFM,addListToUFM_C, addToUFM_Directly, addListToUFM_Directly, @@ -62,6 +63,7 @@ module GHC.Types.Unique.FM ( minusUFM_C, intersectUFM, intersectUFM_C, + strictIntersectUFM_C, disjointUFM, equalKeysUFM, diffUFM, @@ -178,6 +180,16 @@ addToUFM_C addToUFM_C f (UFM m) k v = UFM (M.insertWith (flip f) (getKey $ getUnique k) v m) +strictAddToUFM_C + :: Uniquable key + => (elt -> elt -> elt) -- ^ old -> new -> result + -> UniqFM key elt -- ^ old + -> key -> elt -- ^ new + -> UniqFM key elt -- ^ result +-- Arguments of combining function of MS.insertWith and strictAddToUFM_C are flipped. +strictAddToUFM_C f (UFM m) k v = + UFM (MS.insertWith (flip f) (getKey $ getUnique k) v m) + addToUFM_Acc :: Uniquable key => (elt -> elts -> elts) -- Add to existing @@ -391,6 +403,13 @@ intersectUFM_C -> UniqFM key elt3 intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y) +strictIntersectUFM_C + :: (elt1 -> elt2 -> elt3) + -> UniqFM key elt1 + -> UniqFM key elt2 + -> UniqFM key elt3 +strictIntersectUFM_C f (UFM x) (UFM y) = UFM (MS.intersectionWith f x y) + disjointUFM :: UniqFM key elt1 -> UniqFM key elt2 -> Bool disjointUFM (UFM x) (UFM y) = M.disjoint x y ===================================== compiler/GHC/Types/Unique/Set.hs ===================================== @@ -19,12 +19,14 @@ module GHC.Types.Unique.Set ( emptyUniqSet, unitUniqSet, mkUniqSet, - addOneToUniqSet, addListToUniqSet, + addOneToUniqSet, addListToUniqSet, strictAddOneToUniqSet_C, delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet, delListFromUniqSet_Directly, unionUniqSets, unionManyUniqSets, - minusUniqSet, uniqSetMinusUFM, uniqSetMinusUDFM, - intersectUniqSets, + strictUnionUniqSets_C, strictUnionManyUniqSets_C, + minusUniqSet, minusUniqSet_C, + uniqSetMinusUFM, uniqSetMinusUDFM, + intersectUniqSets, strictIntersectUniqSets_C, disjointUniqSets, restrictUniqSetToUFM, uniqSetAny, uniqSetAll, @@ -109,6 +111,10 @@ addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a addListToUniqSet = foldl' addOneToUniqSet {-# INLINEABLE addListToUniqSet #-} +strictAddOneToUniqSet_C :: Uniquable a => (a -> a -> a) -> UniqSet a -> a -> UniqSet a +strictAddOneToUniqSet_C f (UniqSet set) x = + UniqSet (strictAddToUFM_C f set x x) + delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a delOneFromUniqSet (UniqSet s) a = UniqSet (delFromUFM s a) @@ -127,15 +133,29 @@ delListFromUniqSet_Directly (UniqSet s) l = unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a unionUniqSets (UniqSet s) (UniqSet t) = UniqSet (plusUFM s t) +strictUnionUniqSets_C :: (a -> a -> a) -> UniqSet a -> UniqSet a -> UniqSet a +strictUnionUniqSets_C f (UniqSet s) (UniqSet t) = + UniqSet (strictPlusUFM_C f s t) + unionManyUniqSets :: [UniqSet a] -> UniqSet a unionManyUniqSets = foldl' (flip unionUniqSets) emptyUniqSet +strictUnionManyUniqSets_C :: (a -> a -> a) -> [UniqSet a] -> UniqSet a +strictUnionManyUniqSets_C f = foldl' (flip (strictUnionUniqSets_C f)) emptyUniqSet + minusUniqSet :: UniqSet a -> UniqSet a -> UniqSet a minusUniqSet (UniqSet s) (UniqSet t) = UniqSet (minusUFM s t) +minusUniqSet_C :: (a -> a -> Maybe a) -> UniqSet a -> UniqSet a -> UniqSet a +minusUniqSet_C f (UniqSet s) (UniqSet t) = UniqSet (minusUFM_C f s t) + intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a intersectUniqSets (UniqSet s) (UniqSet t) = UniqSet (intersectUFM s t) +strictIntersectUniqSets_C :: (a -> a -> a) -> UniqSet a -> UniqSet a -> UniqSet a +strictIntersectUniqSets_C f (UniqSet s) (UniqSet t) = + UniqSet (strictIntersectUFM_C f s t) + disjointUniqSets :: UniqSet a -> UniqSet a -> Bool disjointUniqSets (UniqSet s) (UniqSet t) = disjointUFM s t ===================================== compiler/ghc.cabal.in ===================================== @@ -310,6 +310,7 @@ Library GHC.CmmToAsm.Reg.Linear.X86 GHC.CmmToAsm.Reg.Linear.X86_64 GHC.CmmToAsm.Reg.Liveness + GHC.CmmToAsm.Reg.Regs GHC.CmmToAsm.Reg.Target GHC.CmmToAsm.Reg.Utils GHC.CmmToAsm.RV64 ===================================== testsuite/tests/simd/should_run/T26411.hs ===================================== @@ -0,0 +1,57 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import GHC.Exts + +data DoubleX32 = DoubleX32 + DoubleX2# DoubleX2# DoubleX2# DoubleX2# + DoubleX2# DoubleX2# DoubleX2# DoubleX2# + DoubleX2# DoubleX2# DoubleX2# DoubleX2# + DoubleX2# DoubleX2# DoubleX2# DoubleX2# + +doubleX32ToList :: DoubleX32 -> [Double] +doubleX32ToList (DoubleX32 v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15) + = a v0 . a v1 . a v2 . a v3 . a v4 . a v5 . a v6 . a v7 . a v8 . a v9 . a v10 . a v11 . a v12 . a v13 . a v14 . a v15 $ [] + where + a v xs = case unpackDoubleX2# v of + (# x0, x1 #) -> D# x0 : D# x1 : xs + +doubleX32FromList :: [Double] -> DoubleX32 +doubleX32FromList [D# x0, D# x1, D# x2, D# x3, D# x4, D# x5, D# x6, D# x7, D# x8, D# x9, D# x10, D# x11, D# x12, D# x13, D# x14, D# x15, D# x16, D# x17, D# x18, D# x19, D# x20, D# x21, D# x22, D# x23, D# x24, D# x25, D# x26, D# x27, D# x28, D# x29, D# x30, D# x31] + = DoubleX32 + (packDoubleX2# (# x0, x1 #)) (packDoubleX2# (# x2, x3 #)) (packDoubleX2# (# x4, x5 #)) (packDoubleX2# (# x6, x7 #)) + (packDoubleX2# (# x8, x9 #)) (packDoubleX2# (# x10, x11 #)) (packDoubleX2# (# x12, x13 #)) (packDoubleX2# (# x14, x15 #)) + (packDoubleX2# (# x16, x17 #)) (packDoubleX2# (# x18, x19 #)) (packDoubleX2# (# x20, x21 #)) (packDoubleX2# (# x22, x23 #)) + (packDoubleX2# (# x24, x25 #)) (packDoubleX2# (# x26, x27 #)) (packDoubleX2# (# x28, x29 #)) (packDoubleX2# (# x30, x31 #)) + +negateDoubleX32 :: DoubleX32 -> DoubleX32 +negateDoubleX32 (DoubleX32 v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15) + = DoubleX32 + (negateDoubleX2# v0) (negateDoubleX2# v1) (negateDoubleX2# v2) (negateDoubleX2# v3) + (negateDoubleX2# v4) (negateDoubleX2# v5) (negateDoubleX2# v6) (negateDoubleX2# v7) + (negateDoubleX2# v8) (negateDoubleX2# v9) (negateDoubleX2# v10) (negateDoubleX2# v11) + (negateDoubleX2# v12) (negateDoubleX2# v13) (negateDoubleX2# v14) (negateDoubleX2# v15) + +recipDoubleX2# :: DoubleX2# -> DoubleX2# +recipDoubleX2# v = divideDoubleX2# (broadcastDoubleX2# 1.0##) v +{-# INLINE recipDoubleX2# #-} + +recipDoubleX32 :: DoubleX32 -> DoubleX32 +recipDoubleX32 (DoubleX32 v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15) + = DoubleX32 + (recipDoubleX2# v0) (recipDoubleX2# v1) (recipDoubleX2# v2) (recipDoubleX2# v3) + (recipDoubleX2# v4) (recipDoubleX2# v5) (recipDoubleX2# v6) (recipDoubleX2# v7) + (recipDoubleX2# v8) (recipDoubleX2# v9) (recipDoubleX2# v10) (recipDoubleX2# v11) + (recipDoubleX2# v12) (recipDoubleX2# v13) (recipDoubleX2# v14) (recipDoubleX2# v15) + +main :: IO () +main = do + let a = doubleX32FromList [0..31] + b = negateDoubleX32 a + c = recipDoubleX32 a + print $ doubleX32ToList b + putStrLn $ if doubleX32ToList b == map negate [0..31] then "OK" else "Wrong" + print $ doubleX32ToList c + putStrLn $ if doubleX32ToList c == map recip [0..31] then "OK" else "Wrong" ===================================== testsuite/tests/simd/should_run/T26411.stdout ===================================== @@ -0,0 +1,4 @@ +[-0.0,-1.0,-2.0,-3.0,-4.0,-5.0,-6.0,-7.0,-8.0,-9.0,-10.0,-11.0,-12.0,-13.0,-14.0,-15.0,-16.0,-17.0,-18.0,-19.0,-20.0,-21.0,-22.0,-23.0,-24.0,-25.0,-26.0,-27.0,-28.0,-29.0,-30.0,-31.0] +OK +[Infinity,1.0,0.5,0.3333333333333333,0.25,0.2,0.16666666666666666,0.14285714285714285,0.125,0.1111111111111111,0.1,9.090909090909091e-2,8.333333333333333e-2,7.692307692307693e-2,7.142857142857142e-2,6.666666666666667e-2,6.25e-2,5.8823529411764705e-2,5.555555555555555e-2,5.263157894736842e-2,5.0e-2,4.7619047619047616e-2,4.5454545454545456e-2,4.3478260869565216e-2,4.1666666666666664e-2,4.0e-2,3.8461538461538464e-2,3.7037037037037035e-2,3.571428571428571e-2,3.4482758620689655e-2,3.333333333333333e-2,3.225806451612903e-2] +OK ===================================== testsuite/tests/simd/should_run/T26411b.hs ===================================== @@ -0,0 +1,73 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main (main) where + +import GHC.Exts + +data DoubleX32 = DoubleX32 + DoubleX2# DoubleX2# DoubleX2# DoubleX2# + DoubleX2# DoubleX2# DoubleX2# DoubleX2# + DoubleX2# DoubleX2# DoubleX2# DoubleX2# + DoubleX2# DoubleX2# DoubleX2# DoubleX2# + +doubleX32ToList :: DoubleX32 -> [Double] +doubleX32ToList (DoubleX32 v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15) + = a v0 . a v1 . a v2 . a v3 . a v4 . a v5 . a v6 . a v7 . a v8 . a v9 . a v10 . a v11 . a v12 . a v13 . a v14 . a v15 $ [] + where + a v xs = case unpackDoubleX2# v of + (# x0, x1 #) -> D# x0 : D# x1 : xs +{-# INLINE doubleX32ToList #-} + +doubleX32FromList :: [Double] -> DoubleX32 +doubleX32FromList [D# x0, D# x1, D# x2, D# x3, D# x4, D# x5, D# x6, D# x7, D# x8, D# x9, D# x10, D# x11, D# x12, D# x13, D# x14, D# x15, D# x16, D# x17, D# x18, D# x19, D# x20, D# x21, D# x22, D# x23, D# x24, D# x25, D# x26, D# x27, D# x28, D# x29, D# x30, D# x31] + = DoubleX32 + (packDoubleX2# (# x0, x1 #)) (packDoubleX2# (# x2, x3 #)) (packDoubleX2# (# x4, x5 #)) (packDoubleX2# (# x6, x7 #)) + (packDoubleX2# (# x8, x9 #)) (packDoubleX2# (# x10, x11 #)) (packDoubleX2# (# x12, x13 #)) (packDoubleX2# (# x14, x15 #)) + (packDoubleX2# (# x16, x17 #)) (packDoubleX2# (# x18, x19 #)) (packDoubleX2# (# x20, x21 #)) (packDoubleX2# (# x22, x23 #)) + (packDoubleX2# (# x24, x25 #)) (packDoubleX2# (# x26, x27 #)) (packDoubleX2# (# x28, x29 #)) (packDoubleX2# (# x30, x31 #)) +{-# NOINLINE doubleX32FromList #-} + +broadcastDoubleX32 :: Double -> DoubleX32 +broadcastDoubleX32 (D# x) + = let !v = broadcastDoubleX2# x + in DoubleX32 v v v v v v v v v v v v v v v v +{-# INLINE broadcastDoubleX32 #-} + +negateDoubleX32 :: DoubleX32 -> DoubleX32 +negateDoubleX32 (DoubleX32 v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15) + = DoubleX32 + (negateDoubleX2# v0) (negateDoubleX2# v1) (negateDoubleX2# v2) (negateDoubleX2# v3) + (negateDoubleX2# v4) (negateDoubleX2# v5) (negateDoubleX2# v6) (negateDoubleX2# v7) + (negateDoubleX2# v8) (negateDoubleX2# v9) (negateDoubleX2# v10) (negateDoubleX2# v11) + (negateDoubleX2# v12) (negateDoubleX2# v13) (negateDoubleX2# v14) (negateDoubleX2# v15) +{-# NOINLINE negateDoubleX32 #-} + +recipDoubleX2# :: DoubleX2# -> DoubleX2# +recipDoubleX2# v = divideDoubleX2# (broadcastDoubleX2# 1.0##) v +{-# NOINLINE recipDoubleX2# #-} + +recipDoubleX32 :: DoubleX32 -> DoubleX32 +recipDoubleX32 (DoubleX32 v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15) + = DoubleX32 + (recipDoubleX2# v0) (recipDoubleX2# v1) (recipDoubleX2# v2) (recipDoubleX2# v3) + (recipDoubleX2# v4) (recipDoubleX2# v5) (recipDoubleX2# v6) (recipDoubleX2# v7) + (recipDoubleX2# v8) (recipDoubleX2# v9) (recipDoubleX2# v10) (recipDoubleX2# v11) + (recipDoubleX2# v12) (recipDoubleX2# v13) (recipDoubleX2# v14) (recipDoubleX2# v15) +{-# NOINLINE recipDoubleX32 #-} + +divideDoubleX32 :: DoubleX32 -> DoubleX32 -> DoubleX32 +divideDoubleX32 (DoubleX32 u0 u1 u2 u3 u4 u5 u6 u7 u8 u9 u10 u11 u12 u13 u14 u15) (DoubleX32 v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15) + = DoubleX32 + (divideDoubleX2# u0 v0) (divideDoubleX2# u1 v1) (divideDoubleX2# u2 v2) (divideDoubleX2# u3 v3) + (divideDoubleX2# u4 v4) (divideDoubleX2# u5 v5) (divideDoubleX2# u6 v6) (divideDoubleX2# u7 v7) + (divideDoubleX2# u8 v8) (divideDoubleX2# u9 v9) (divideDoubleX2# u10 v10) (divideDoubleX2# u11 v11) + (divideDoubleX2# u12 v12) (divideDoubleX2# u13 v13) (divideDoubleX2# u14 v14) (divideDoubleX2# u15 v15) +{-# INLINE divideDoubleX32 #-} + +main :: IO () +main = do + let a = doubleX32FromList [0..31] + b = divideDoubleX32 (broadcastDoubleX32 1.0) a + print $ doubleX32ToList b + putStrLn $ if doubleX32ToList b == map recip [0..31] then "OK" else "Wrong" ===================================== testsuite/tests/simd/should_run/T26411b.stdout ===================================== @@ -0,0 +1,2 @@ +[Infinity,1.0,0.5,0.3333333333333333,0.25,0.2,0.16666666666666666,0.14285714285714285,0.125,0.1111111111111111,0.1,9.090909090909091e-2,8.333333333333333e-2,7.692307692307693e-2,7.142857142857142e-2,6.666666666666667e-2,6.25e-2,5.8823529411764705e-2,5.555555555555555e-2,5.263157894736842e-2,5.0e-2,4.7619047619047616e-2,4.5454545454545456e-2,4.3478260869565216e-2,4.1666666666666664e-2,4.0e-2,3.8461538461538464e-2,3.7037037037037035e-2,3.571428571428571e-2,3.4482758620689655e-2,3.333333333333333e-2,3.225806451612903e-2] +OK ===================================== testsuite/tests/simd/should_run/all.T ===================================== @@ -89,6 +89,7 @@ test('simd012', [], compile_and_run, ['']) test('simd013', [ req_c , unless(arch('x86_64'), skip) # because the C file uses Intel intrinsics + , extra_ways(["optasm"]) # #26526 demonstrated a bug in the optasm way ], compile_and_run, ['simd013C.c']) test('simd014', @@ -145,6 +146,8 @@ test('T22187_run', [],compile_and_run,['']) test('T25062_V16', [], compile_and_run, ['']) test('T25561', [], compile_and_run, ['']) test('T26542', [], compile_and_run, ['']) +test('T26411', [], compile_and_run, ['']) +test('T26411b', [], compile_and_run, ['-O']) # Even if the CPU we run on doesn't support *executing* those tests we should try to # compile them. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a2b43e3395902e88ec371c98cdb4a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a2b43e3395902e88ec371c98cdb4a… You're receiving this email because of your account on gitlab.haskell.org.

1 0