Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 706d33e3 by Recursion Ninja at 2025-08-15T04:12:12-04:00 Resolving issues #20645 and #26109 Correctly sign extending and casting smaller bit width types for LLVM operations: - bitReverse8# - bitReverse16# - bitReverse32# - byteSwap16# - byteSwap32# - pdep8# - pdep16# - pext8# - pext16# - - - - - 1cdc6f46 by Cheng Shao at 2025-08-15T04:12:56-04:00 hadrian: enforce have_llvm=False for wasm32/js This patch fixes hadrian to always pass have_llvm=False to the testsuite driver for wasm32/js targets. These targets don't really support the LLVM backend, and the optllvm test way doesn't work. We used to special-case wasm32/js to avoid auto-adding optllvm way in testsuite/config/ghc, but this is still problematic if someone writes a new LLVM-related test and uses something like when(have_llvm(), extra_ways(["optllvm"])). So better just enforce have_llvm=False for these targets here. - - - - - 5df0d908 by Cheng Shao at 2025-08-18T12:00:36-04:00 compiler: use `UniqMap` instead of `Map` for `BCEnv` in bytecode compiler The bytecode compiler maintains a `BCEnv` which was previously `Map Id StackDepth`. Given `Id` is `Uniquable`, we might as well use `UniqMap` here as a more efficient data structure, hence this patch. Co-authored-by: Codex - - - - - c5ff5591 by Cheng Shao at 2025-08-18T12:00:37-04:00 libffi: update to 3.5.2 Bumps libffi submodule. - - - - - 17 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/CmmToLlvm/CodeGen.hs - compiler/GHC/StgToByteCode.hs - hadrian/src/Settings/Builders/RunTest.hs - libffi-tarballs - libraries/ghc-internal/cbits/pdep.c - libraries/ghc-internal/cbits/pext.c - testsuite/config/ghc - + testsuite/tests/llvm/should_run/T20645.hs - + testsuite/tests/llvm/should_run/T20645.stdout - testsuite/tests/llvm/should_run/all.T - testsuite/tests/numeric/should_run/foundation.hs - utils/genprimopcode/Lexer.x - utils/genprimopcode/Main.hs - utils/genprimopcode/Parser.y - utils/genprimopcode/ParserM.hs - utils/genprimopcode/Syntax.hs Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -148,6 +148,7 @@ defaults vector = [] deprecated_msg = {} -- A non-empty message indicates deprecation div_like = False -- Second argument expected to be non zero - used for tests + defined_bits = Nothing -- The number of bits the operation is defined for (if not all bits) -- Note [When do out-of-line primops go in primops.txt.pp] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1065,8 +1066,10 @@ primop CtzOp "ctz#" GenPrimOp Word# -> Word# primop BSwap16Op "byteSwap16#" GenPrimOp Word# -> Word# {Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. } + with defined_bits = 16 primop BSwap32Op "byteSwap32#" GenPrimOp Word# -> Word# {Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. } + with defined_bits = 32 primop BSwap64Op "byteSwap64#" GenPrimOp Word64# -> Word64# {Swap bytes in a 64 bits of a word.} primop BSwapOp "byteSwap#" GenPrimOp Word# -> Word# @@ -1074,10 +1077,13 @@ primop BSwapOp "byteSwap#" GenPrimOp Word# -> Word# primop BRev8Op "bitReverse8#" GenPrimOp Word# -> Word# {Reverse the order of the bits in a 8-bit word.} + with defined_bits = 8 primop BRev16Op "bitReverse16#" GenPrimOp Word# -> Word# {Reverse the order of the bits in a 16-bit word.} + with defined_bits = 16 primop BRev32Op "bitReverse32#" GenPrimOp Word# -> Word# {Reverse the order of the bits in a 32-bit word.} + with defined_bits = 32 primop BRev64Op "bitReverse64#" GenPrimOp Word64# -> Word64# {Reverse the order of the bits in a 64-bit word.} primop BRevOp "bitReverse#" GenPrimOp Word# -> Word# ===================================== compiler/GHC/CmmToLlvm/CodeGen.hs ===================================== @@ -230,23 +230,22 @@ genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) [] | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt) --- Handle PopCnt, Clz, Ctz, and BSwap that need to only convert arg --- and return types -genCall t@(PrimTarget (MO_PopCnt w)) dsts args = - genCallSimpleCast w t dsts args - -genCall t@(PrimTarget (MO_Pdep w)) dsts args = - genCallSimpleCast2 w t dsts args -genCall t@(PrimTarget (MO_Pext w)) dsts args = - genCallSimpleCast2 w t dsts args -genCall t@(PrimTarget (MO_Clz w)) dsts args = - genCallSimpleCast w t dsts args -genCall t@(PrimTarget (MO_Ctz w)) dsts args = - genCallSimpleCast w t dsts args -genCall t@(PrimTarget (MO_BSwap w)) dsts args = - genCallSimpleCast w t dsts args -genCall t@(PrimTarget (MO_BRev w)) dsts args = - genCallSimpleCast w t dsts args +-- Handle Clz, Ctz, BRev, BSwap, Pdep, Pext, and PopCnt that need to only +-- convert arg and return types +genCall (PrimTarget op@(MO_Clz w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_Ctz w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_BRev w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_BSwap w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_Pdep w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_Pext w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_PopCnt w)) [dst] args = + genCallSimpleCast w op dst args genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $ do addrVar <- exprToVarW addr @@ -640,63 +639,28 @@ genCallExtract _ _ _ _ = -- since GHC only really has i32 and i64 types and things like Word8 are backed -- by an i32 and just present a logical i8 range. So we must handle conversions -- from i32 to i8 explicitly as LLVM is strict about types. -genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual] - -> LlvmM StmtData -genCallSimpleCast w t@(PrimTarget op) [dst] args = do - let width = widthToLlvmInt w - dstTy = cmmToLlvmType $ localRegType dst - - fname <- cmmPrimOpFunctions op - (fptr, _, top3) <- getInstrinct fname width [width] - - (dstV, _dst_ty) <- getCmmReg (CmmLocal dst) - - let (_, arg_hints) = foreignTargetHints t - let args_hints = zip args arg_hints - (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) - (argsV', stmts4) <- castVars Signed $ zip argsV [width] - (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] - (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)] - let retV' = singletonPanic "genCallSimpleCast" retVs' - let s2 = Store retV' dstV Nothing [] - - let stmts = stmts2 `appOL` stmts4 `snocOL` - s1 `appOL` stmts5 `snocOL` s2 - return (stmts, top2 ++ top3) -genCallSimpleCast _ _ dsts _ = - panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts") - --- Handle simple function call that only need simple type casting, of the form: --- truncate arg >>= \a -> call(a) >>= zext --- --- since GHC only really has i32 and i64 types and things like Word8 are backed --- by an i32 and just present a logical i8 range. So we must handle conversions --- from i32 to i8 explicitly as LLVM is strict about types. -genCallSimpleCast2 :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual] - -> LlvmM StmtData -genCallSimpleCast2 w t@(PrimTarget op) [dst] args = do - let width = widthToLlvmInt w - dstTy = cmmToLlvmType $ localRegType dst - - fname <- cmmPrimOpFunctions op - (fptr, _, top3) <- getInstrinct fname width (const width <$> args) - - (dstV, _dst_ty) <- getCmmReg (CmmLocal dst) - - let (_, arg_hints) = foreignTargetHints t - let args_hints = zip args arg_hints - (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) - (argsV', stmts4) <- castVars Signed $ zip argsV (const width <$> argsV) - (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] - (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)] - let retV' = singletonPanic "genCallSimpleCast2" retVs' - let s2 = Store retV' dstV Nothing [] +genCallSimpleCast :: Width -> CallishMachOp -> CmmFormal -> [CmmActual] + -> LlvmM StmtData +genCallSimpleCast specW op dst args = do + let width = widthToLlvmInt specW + argsW = const width <$> args + dstType = cmmToLlvmType $ localRegType dst + signage = cmmPrimOpRetValSignage op + + fname <- cmmPrimOpFunctions op + (fptr, _, top3) <- getInstrinct fname width argsW + (dstV, _dst_ty) <- getCmmReg (CmmLocal dst) + let (_, arg_hints) = foreignTargetHints $ PrimTarget op + let args_hints = zip args arg_hints + (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) + (argsV', stmts4) <- castVars signage $ zip argsV argsW + (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] + (retV', stmts5) <- castVar signage retV dstType + let s2 = Store retV' dstV Nothing [] let stmts = stmts2 `appOL` stmts4 `snocOL` - s1 `appOL` stmts5 `snocOL` s2 + s1 `snocOL` stmts5 `snocOL` s2 return (stmts, top2 ++ top3) -genCallSimpleCast2 _ _ dsts _ = - panic ("genCallSimpleCast2: " ++ show (length dsts) ++ " dsts") -- | Create a function pointer from a target. getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget @@ -811,11 +775,47 @@ castVar signage v t | getVarType v == t Signed -> LM_Sext Unsigned -> LM_Zext - cmmPrimOpRetValSignage :: CallishMachOp -> Signage cmmPrimOpRetValSignage mop = case mop of - MO_Pdep _ -> Unsigned - MO_Pext _ -> Unsigned + -- Some bit-wise operations /must/ always treat the input and output values + -- as 'Unsigned' in order to return the expected result values when pre/post- + -- operation bit-width truncation and/or extension occur. For example, + -- consider the Bit-Reverse operation: + -- + -- If the result of a Bit-Reverse is treated as signed, + -- an positive input can result in an negative output, i.e.: + -- + -- identity(0x03) = 0x03 = 00000011 + -- breverse(0x03) = 0xC0 = 11000000 + -- + -- Now if an extension is performed after the operation to + -- promote a smaller bit-width value into a larger bit-width + -- type, it is expected that the /bit-wise/ operations will + -- not be treated /numerically/ as signed. + -- + -- To illustrate the difference, consider how a signed extension + -- for the type i16 to i32 differs for out values above: + -- ext_zeroed(i32, breverse(0x03)) = 0x00C0 = 0000000011000000 + -- ext_signed(i32, breverse(0x03)) = 0xFFC0 = 1111111111000000 + -- + -- Here we can see that the former output is the expected result + -- of a bit-wise operation which needs to be promoted to a larger + -- bit-width type. The latter output is not desirable when we must + -- constraining a value into a range of i16 within an i32 type. + -- + -- Hence we always treat the "signage" as unsigned for Bit-Reverse! + -- + -- The same reasoning applied to Bit-Reverse above applies to the other + -- bit-wise operations; do not sign extend a possibly negated number! + MO_BRev _ -> Unsigned + MO_BSwap _ -> Unsigned + MO_Clz _ -> Unsigned + MO_Ctz _ -> Unsigned + MO_Pdep _ -> Unsigned + MO_Pext _ -> Unsigned + MO_PopCnt _ -> Unsigned + + -- All other cases, default to preserving the numeric sign when extending. _ -> Signed -- | Decide what C function to use to implement a CallishMachOp ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -84,11 +84,11 @@ import Data.Coerce (coerce) #if MIN_VERSION_rts(1,0,3) import qualified Data.ByteString.Char8 as BS #endif -import Data.Map (Map) import Data.IntMap (IntMap) import qualified Data.Map as Map import qualified Data.IntMap as IntMap -import qualified GHC.Data.FiniteMap as Map +import GHC.Types.Unique.Map (UniqMap) +import qualified GHC.Types.Unique.Map as UniqMap import Data.Ord import Data.Either ( partitionEithers ) @@ -209,7 +209,7 @@ type StackDepth = ByteOff -- | Maps Ids to their stack depth. This allows us to avoid having to mess with -- it after each push/pop. -type BCEnv = Map Id StackDepth -- To find vars on the stack +type BCEnv = UniqMap Id StackDepth -- To find vars on the stack {- ppBCEnv :: BCEnv -> SDoc @@ -379,7 +379,7 @@ schemeR_wrk fvs nm original_body (args, body) sum_szsb_args = sum szsb_args -- Make a stack offset for each argument or free var -- they should -- appear contiguous in the stack, in order. - p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args)) + p_init = UniqMap.listToUniqMap (zip all_args (mkStackOffsets 0 szsb_args)) -- make the arg bitmap bits = argBits platform (reverse (map (idArgRep platform) all_args)) @@ -442,7 +442,7 @@ fvsToEnv :: BCEnv -> CgStgRhs -> [Id] -- it, have to agree about this layout fvsToEnv p rhs = [v | v <- dVarSetElems $ freeVarsOfRhs rhs, - v `Map.member` p] + v `UniqMap.elemUniqMap` p] -- ----------------------------------------------------------------------------- -- schemeE @@ -533,7 +533,7 @@ schemeE d s p (StgLet _xlet alloc_code <- mkConAppCode d s p data_con args platform <- targetPlatform <$> getDynFlags let !d2 = d + wordSize platform - body_code <- schemeE d2 s (Map.insert x d2 p) body + body_code <- schemeE d2 s (UniqMap.addToUniqMap p x d2) body return (alloc_code `appOL` body_code) -- General case for let. Generates correct, if inefficient, code in -- all situations. @@ -557,7 +557,7 @@ schemeE d s p (StgLet _ext binds body) = do -- after the closures have been allocated in the heap (but not -- filled in), and pointers to them parked on the stack. offsets = mkStackOffsets d (genericReplicate n_binds (wordSize platform)) - p' = Map.insertList (zipEqual xs offsets) p + p' = UniqMap.addListToUniqMap p $ zipEqual xs offsets d' = d + wordsToBytes platform n_binds -- ToDo: don't build thunks for things with no free variables @@ -1180,7 +1180,7 @@ doCase d s p scrut bndr alts -- Env in which to compile the alts, not including -- any vars bound by the alts themselves - p_alts = Map.insert bndr d_bndr p + p_alts = UniqMap.addToUniqMap p bndr d_bndr bndr_ty = idType bndr isAlgCase = isAlgType bndr_ty @@ -1208,12 +1208,11 @@ doCase d s p scrut bndr alts stack_bot = d_alts - p' = Map.insertList + p' = UniqMap.addListToUniqMap p_alts [ (arg, tuple_start - wordsToBytes platform (nativeCallSize call_info) + offset) | (NonVoid arg, offset) <- args_offsets] - p_alts in do rhs_code <- schemeE stack_bot s p' rhs return (NoDiscr, rhs_code) @@ -1227,10 +1226,9 @@ doCase d s p scrut bndr alts stack_bot = d_alts + wordsToBytes platform size -- convert offsets from Sp into offsets into the virtual stack - p' = Map.insertList + p' = UniqMap.addListToUniqMap p_alts [ (arg, stack_bot - ByteOff offset) | (NonVoid arg, offset) <- args_offsets ] - p_alts in do massert isAlgCase @@ -1312,12 +1310,13 @@ doCase d s p scrut bndr alts -- NB: unboxed tuple cases bind the scrut binder to the same offset -- as one of the alt binders, so we have to remove any duplicates here: -- 'toAscList' takes care of sorting the result, which was previously done after the application of 'filter'. - rel_slots = IntSet.toAscList $ IntSet.fromList $ Map.elems $ Map.mapMaybeWithKey spread p - spread id offset | isUnboxedTupleType (idType id) || - isUnboxedSumType (idType id) = Nothing - | isFollowableArg (idArgRep platform id) = Just (fromIntegral rel_offset) - | otherwise = Nothing - where rel_offset = bytesToWords platform (d - offset) + rel_slots = IntSet.toAscList $ UniqMap.nonDetFoldUniqMap go IntSet.empty p + go (var, offset) !acc + | isUnboxedTupleType (idType var) || isUnboxedSumType (idType var) + = acc + | isFollowableArg (idArgRep platform var) + = fromIntegral (bytesToWords platform (d - offset)) `IntSet.insert` acc + | otherwise = acc bitmap = intsToReverseBitmap platform bitmap_size' pointers @@ -2546,7 +2545,7 @@ instance Outputable Discr where lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff -lookupBCEnv_maybe = Map.lookup +lookupBCEnv_maybe v env = UniqMap.lookupUniqMap env v idSizeW :: Platform -> Id -> WordOff idSizeW platform = WordOff . argRepSizeW platform . idArgRep platform ===================================== hadrian/src/Settings/Builders/RunTest.hs ===================================== @@ -86,6 +86,16 @@ data TestCompilerArgs = TestCompilerArgs{ , pkgConfCacheFile :: FilePath } deriving (Eq, Show) +-- | Some archs like wasm32/js used to report have_llvm=True because +-- they are based on LLVM related toolchains like wasi-sdk/emscripten, +-- but these targets don't really support the LLVM backend, and the +-- optllvm test way doesn't work. We used to special-case wasm32/js to +-- avoid auto-adding optllvm way in testsuite/config/ghc, but this is +-- still problematic if someone writes a new LLVM-related test and +-- uses something like when(have_llvm(), extra_ways(["optllvm"])). So +-- better just enforce have_llvm=False for these targets here. +allowHaveLLVM :: String -> Bool +allowHaveLLVM = not . (`elem` ["wasm32", "javascript"]) -- | If the tree is in-compiler then we already know how we will build it so -- don't build anything in order to work out what we will build. @@ -129,7 +139,7 @@ inTreeCompilerArgs stg = do llc_cmd <- queryTargetTarget tgtLlc llvm_as_cmd <- queryTargetTarget tgtLlvmAs - let have_llvm = all isJust [llc_cmd, llvm_as_cmd] + let have_llvm = allowHaveLLVM arch && all isJust [llc_cmd, llvm_as_cmd] top <- topDirectory @@ -176,7 +186,7 @@ outOfTreeCompilerArgs = do let debugged = "debug" `isInfixOf` rtsWay llc_cmd <- getTestSetting TestLLC - have_llvm <- liftIO (isJust <$> findExecutable llc_cmd) + have_llvm <- (allowHaveLLVM arch &&) <$> liftIO (isJust <$> findExecutable llc_cmd) profiled <- getBooleanSetting TestGhcProfiled pkgConfCacheFile <- getTestSetting TestGhcPackageDb <&> ( "package.cache") ===================================== libffi-tarballs ===================================== @@ -1 +1 @@ -Subproject commit a5480d7e7f86a9bb5b44dd1156a92f69f7c185ec +Subproject commit 7c51059557b68d29820a0a87cebfa6fe73c8adf5 ===================================== libraries/ghc-internal/cbits/pdep.c ===================================== @@ -24,20 +24,23 @@ hs_pdep64(StgWord64 src, StgWord64 mask) return result; } +// When dealing with values of bit-width shorter than uint64_t, ensure to +// cast the return value to correctly truncate the undefined upper bits. +// This is *VERY* important when GHC is using the LLVM backend! StgWord hs_pdep32(StgWord src, StgWord mask) { - return hs_pdep64(src, mask); + return (StgWord) ((StgWord32) hs_pdep64(src, mask)); } StgWord hs_pdep16(StgWord src, StgWord mask) { - return hs_pdep64(src, mask); + return (StgWord) ((StgWord16) hs_pdep64(src, mask)); } StgWord hs_pdep8(StgWord src, StgWord mask) { - return hs_pdep64(src, mask); + return (StgWord) ((StgWord8) hs_pdep64(src, mask)); } ===================================== libraries/ghc-internal/cbits/pext.c ===================================== @@ -1,13 +1,13 @@ #include "Rts.h" #include "MachDeps.h" -StgWord64 -hs_pext64(StgWord64 src, StgWord64 mask) +static StgWord64 +hs_pext(const unsigned char bit_width, const StgWord64 src, const StgWord64 mask) { uint64_t result = 0; int offset = 0; - for (int bit = 0; bit != sizeof(uint64_t) * 8; ++bit) { + for (int bit = 0; bit != bit_width; ++bit) { const uint64_t src_bit = (src >> bit) & 1; const uint64_t mask_bit = (mask >> bit) & 1; @@ -20,20 +20,29 @@ hs_pext64(StgWord64 src, StgWord64 mask) return result; } +StgWord64 +hs_pext64(const StgWord64 src, const StgWord64 mask) +{ + return hs_pext(64, src, mask); +} + +// When dealing with values of bit-width shorter than uint64_t, ensure to +// cast the return value to correctly truncate the undefined upper bits. +// This is *VERY* important when GHC is using the LLVM backend! StgWord -hs_pext32(StgWord src, StgWord mask) +hs_pext32(const StgWord src, const StgWord mask) { - return hs_pext64(src, mask); + return (StgWord) ((StgWord32) hs_pext(32, src, mask)); } StgWord -hs_pext16(StgWord src, StgWord mask) +hs_pext16(const StgWord src, const StgWord mask) { - return hs_pext64(src, mask); + return (StgWord) ((StgWord16) hs_pext(16, src, mask)); } StgWord -hs_pext8(StgWord src, StgWord mask) +hs_pext8(const StgWord src, const StgWord mask) { - return hs_pext64(src, mask); + return (StgWord) ((StgWord8) hs_pext(8, src, mask)); } ===================================== testsuite/config/ghc ===================================== @@ -70,7 +70,7 @@ if windows: config.other_ways += winio_ways # LLVM -if not config.unregisterised and not config.arch in {"wasm32", "javascript"} and config.have_llvm: +if not config.unregisterised and config.have_llvm: config.compile_ways.append('optllvm') config.run_ways.append('optllvm') ===================================== testsuite/tests/llvm/should_run/T20645.hs ===================================== @@ -0,0 +1,18 @@ +-- Minimal reproducer for https://gitlab.haskell.org/ghc/ghc/-/issues/20645 +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ExtendedLiterals #-} +import GHC.Exts +import GHC.Word +import Numeric (showHex) + +opaqueInt8# :: Int8# -> Int8# +opaqueInt8# x = x +{-# OPAQUE opaqueInt8# #-} + +main :: IO () +main = let !x = opaqueInt8# 109#Int8 + !y = opaqueInt8# 1#Int8 + in putStrLn $ flip showHex "" (W# ( pext8# + (word8ToWord# (int8ToWord8# (0#Int8 `subInt8#` x ))) + (word8ToWord# (int8ToWord8# (y `subInt8#` 4#Int8))) + )) ===================================== testsuite/tests/llvm/should_run/T20645.stdout ===================================== @@ -0,0 +1 @@ +49 ===================================== testsuite/tests/llvm/should_run/all.T ===================================== @@ -17,3 +17,4 @@ test('T22487', [normal, normalise_errmsg_fun(ignore_llvm_and_vortex)], compile_a test('T22033', [normal, normalise_errmsg_fun(ignore_llvm_and_vortex)], compile_and_run, ['']) test('T25730', [req_c, unless(arch('x86_64'), skip), normalise_errmsg_fun(ignore_llvm_and_vortex)], compile_and_run, ['T25730C.c']) # T25730C.c contains Intel instrinsics, so only run this test on x86 +test('T20645', [normal, normalise_errmsg_fun(ignore_llvm_and_vortex), when(have_llvm(), extra_ways(["optllvm"]))], compile_and_run, ['']) ===================================== testsuite/tests/numeric/should_run/foundation.hs ===================================== @@ -24,6 +24,7 @@ module Main ( main ) where +import Data.Bits (Bits((.&.), bit)) import Data.Word import Data.Int import GHC.Natural @@ -408,6 +409,33 @@ instance TestPrimop (Word# -> Int# -> Word#) where testPrimop s l r = Property s $ \(uWord -> a1) (uInt -> a2) -> (wWord (l a1 a2)) === wWord (r a1 a2) -} +-- | A special data-type for representing functions where, +-- since only some number of the lower bits are defined, +-- testing for strict equality in the undefined upper bits is not appropriate! +-- Without using this data-type, false-positive failures will be reported +-- when the undefined bit regions do not match, even though the equality of bits +-- in this undefined region has no bearing on correctness. +data LowerBitsAreDefined = + LowerBitsAreDefined + { definedLowerWidth :: Word + -- ^ The (strictly-non-negative) number of least-significant bits + -- for which the attached function is defined. + , undefinedBehavior :: (Word# -> Word#) + -- ^ Function with undefined behavior for some of its most significant bits. + } + +instance TestPrimop LowerBitsAreDefined where + testPrimop s l r = Property s $ \ (uWord#-> x0) -> + let -- Create a mask to unset all bits in the undefined area, + -- leaving set bits only in the area of defined behavior. + -- Since the upper bits are undefined, + -- if the function defines behavior for the lower N bits, + -- then /only/ the lower N bits are preserved, + -- and the upper WORDSIZE - N bits are discarded. + mask = bit (fromEnum (definedLowerWidth r)) - 1 + valL = wWord# (undefinedBehavior l x0) .&. mask + valR = wWord# (undefinedBehavior r x0) .&. mask + in valL === valR twoNonZero :: (a -> a -> b) -> a -> NonZero a -> b twoNonZero f x (NonZero y) = f x y @@ -655,13 +683,13 @@ testPrimops = Group "primop" , testPrimop "ctz32#" Primop.ctz32# Wrapper.ctz32# , testPrimop "ctz64#" Primop.ctz64# Wrapper.ctz64# , testPrimop "ctz#" Primop.ctz# Wrapper.ctz# - , testPrimop "byteSwap16#" Primop.byteSwap16# Wrapper.byteSwap16# - , testPrimop "byteSwap32#" Primop.byteSwap32# Wrapper.byteSwap32# + , testPrimop "byteSwap16#" (16 `LowerBitsAreDefined` Primop.byteSwap16#) (16 `LowerBitsAreDefined` Wrapper.byteSwap16#) + , testPrimop "byteSwap32#" (32 `LowerBitsAreDefined` Primop.byteSwap32#) (32 `LowerBitsAreDefined` Wrapper.byteSwap32#) , testPrimop "byteSwap64#" Primop.byteSwap64# Wrapper.byteSwap64# , testPrimop "byteSwap#" Primop.byteSwap# Wrapper.byteSwap# - , testPrimop "bitReverse8#" Primop.bitReverse8# Wrapper.bitReverse8# - , testPrimop "bitReverse16#" Primop.bitReverse16# Wrapper.bitReverse16# - , testPrimop "bitReverse32#" Primop.bitReverse32# Wrapper.bitReverse32# + , testPrimop "bitReverse8#" (8 `LowerBitsAreDefined` Primop.bitReverse8#) (8 `LowerBitsAreDefined` Wrapper.bitReverse8#) + , testPrimop "bitReverse16#" (16 `LowerBitsAreDefined` Primop.bitReverse16#) (16 `LowerBitsAreDefined` Wrapper.bitReverse16#) + , testPrimop "bitReverse32#" (32 `LowerBitsAreDefined` Primop.bitReverse32#) (32 `LowerBitsAreDefined` Wrapper.bitReverse32#) , testPrimop "bitReverse64#" Primop.bitReverse64# Wrapper.bitReverse64# , testPrimop "bitReverse#" Primop.bitReverse# Wrapper.bitReverse# , testPrimop "narrow8Int#" Primop.narrow8Int# Wrapper.narrow8Int# ===================================== utils/genprimopcode/Lexer.x ===================================== @@ -56,6 +56,7 @@ words :- <0> "CanFail" { mkT TCanFail } <0> "ThrowsException" { mkT TThrowsException } <0> "ReadWriteEffect" { mkT TReadWriteEffect } + <0> "defined_bits" { mkT TDefinedBits } <0> "can_fail_warning" { mkT TCanFailWarnFlag } <0> "DoNotWarnCanFail" { mkT TDoNotWarnCanFail } <0> "WarnIfEffectIsCanFail" { mkT TWarnIfEffectIsCanFail } ===================================== utils/genprimopcode/Main.hs ===================================== @@ -10,6 +10,7 @@ module Main where import Parser import Syntax +import Control.Applicative (asum) import Data.Char import Data.List (union, intersperse, intercalate, nub, sort) import Data.Maybe ( catMaybes, mapMaybe ) @@ -116,9 +117,15 @@ desugarVectorSpec i = case vecOptions i of main :: IO () main = getArgs >>= \args -> if length args /= 1 || head args `notElem` known_args - then error ("usage: genprimopcode command < primops.txt > ...\n" + then error ("Usage: genprimopcode command < primops.txt > ...\n" ++ " where command is one of\n" ++ unlines (map (" "++) known_args) + ++ unlines + [ "" + , "Nota Bene: Be sure to manually run primops.txt through the C Pre-Processor" + , " before sending the input stream to STDIN, i.e:" + , "" + , " cpp -P -w primops.txt | genprimopcode command" ] ) else do hSetEncoding stdin utf8 -- The input file is in UTF-8. Set the encoding explicitly. @@ -312,6 +319,7 @@ gen_hs_source (Info defaults entries) = opt (OptionVector _) = "" opt (OptionFixity mf) = "fixity = " ++ show mf opt (OptionEffect eff) = "effect = " ++ show eff + opt (OptionDefinedBits bc) = "defined_bits = " ++ show bc opt (OptionCanFailWarnFlag wf) = "can_fail_warning = " ++ show wf hdr s@(Section {}) = sec s @@ -638,6 +646,7 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults entries) getAltRhs (OptionVector _) = "True" getAltRhs (OptionFixity mf) = show mf getAltRhs (OptionEffect eff) = show eff + getAltRhs (OptionDefinedBits bc) = show bc getAltRhs (OptionCanFailWarnFlag wf) = show wf mkAlt po @@ -753,7 +762,12 @@ gen_foundation_tests (Info _ entries) = let testPrimOpHow = if is_divLikeOp po then "testPrimopDivLike" else "testPrimop" - in Just $ intercalate " " [testPrimOpHow, "\"" ++ poName ++ "\"", wrap "Primop" poName, wrap "Wrapper" poName] + qualOp qualification = + let qName = wrap qualification poName + in case mb_defined_bits po of + Nothing -> qName + Just bs -> concat ["(", show bs, " `LowerBitsAreDefined` ", qName, ")"] + in Just $ intercalate " " [testPrimOpHow, "\"" ++ poName ++ "\"", qualOp "Primop", qualOp "Wrapper"] | otherwise = Nothing @@ -771,6 +785,16 @@ gen_foundation_tests (Info _ entries) divableTyCons = ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#" ,"Int8#", "Int16#", "Int32#", "Int64#"] + mb_defined_bits :: Entry -> Maybe Word + mb_defined_bits op@(PrimOpSpec{}) = + let opOpts = opts op + getDefBits :: Option -> Maybe Word + getDefBits (OptionDefinedBits x) = x + getDefBits _ = Nothing + in asum $ getDefBits <$> opOpts + mb_defined_bits _ = Nothing + + ------------------------------------------------------------------ -- Create PrimOpInfo text from PrimOpSpecs ----------------------- ------------------------------------------------------------------ ===================================== utils/genprimopcode/Parser.y ===================================== @@ -50,6 +50,7 @@ import AccessOps CanFail { TCanFail } ThrowsException { TThrowsException } ReadWriteEffect { TReadWriteEffect } + defined_bits { TDefinedBits } can_fail_warning { TCanFailWarnFlag } DoNotWarnCanFail { TDoNotWarnCanFail } WarnIfEffectIsCanFail { TWarnIfEffectIsCanFail } @@ -81,13 +82,14 @@ pOptions : pOption pOptions { $1 : $2 } | {- empty -} { [] } pOption :: { Option } -pOption : lowerName '=' false { OptionFalse $1 } - | lowerName '=' true { OptionTrue $1 } - | lowerName '=' pStuffBetweenBraces { OptionString $1 $3 } - | lowerName '=' integer { OptionInteger $1 $3 } - | vector '=' pVectorTemplate { OptionVector $3 } - | fixity '=' pInfix { OptionFixity $3 } - | effect '=' pEffect { OptionEffect $3 } +pOption : lowerName '=' false { OptionFalse $1 } + | lowerName '=' true { OptionTrue $1 } + | lowerName '=' pStuffBetweenBraces { OptionString $1 $3 } + | lowerName '=' integer { OptionInteger $1 $3 } + | vector '=' pVectorTemplate { OptionVector $3 } + | fixity '=' pInfix { OptionFixity $3 } + | effect '=' pEffect { OptionEffect $3 } + | defined_bits '=' pGoodBits { OptionDefinedBits $3 } | can_fail_warning '=' pPrimOpCanFailWarnFlag { OptionCanFailWarnFlag $3 } pInfix :: { Maybe Fixity } @@ -102,6 +104,10 @@ pEffect : NoEffect { NoEffect } | ThrowsException { ThrowsException } | ReadWriteEffect { ReadWriteEffect } +pGoodBits :: { Maybe Word } +pGoodBits : integer { Just $ toEnum $1 } + | nothing { Nothing } + pPrimOpCanFailWarnFlag :: { PrimOpCanFailWarnFlag } pPrimOpCanFailWarnFlag : DoNotWarnCanFail { DoNotWarnCanFail } | WarnIfEffectIsCanFail { WarnIfEffectIsCanFail } ===================================== utils/genprimopcode/ParserM.hs ===================================== @@ -116,6 +116,7 @@ data Token = TEOF | TCanFail | TThrowsException | TReadWriteEffect + | TDefinedBits | TCanFailWarnFlag | TDoNotWarnCanFail | TWarnIfEffectIsCanFail ===================================== utils/genprimopcode/Syntax.hs ===================================== @@ -76,6 +76,7 @@ data Option | OptionFixity (Maybe Fixity) -- fixity = infix{,l,r} <int> | Nothing | OptionEffect PrimOpEffect -- effect = NoEffect | DoNotSpeculate | CanFail | ThrowsException | ReadWriteEffect | FallibleReadWriteEffect | OptionCanFailWarnFlag PrimOpCanFailWarnFlag -- can_fail_warning = DoNotWarnCanFail | WarnIfEffectIsCanFail | YesWarnCanFail + | OptionDefinedBits (Maybe Word) -- defined_bits = Just 16 | Nothing deriving Show -- categorises primops @@ -196,6 +197,7 @@ get_attrib_name (OptionVector _) = "vector" get_attrib_name (OptionFixity _) = "fixity" get_attrib_name (OptionEffect _) = "effect" get_attrib_name (OptionCanFailWarnFlag _) = "can_fail_warning" +get_attrib_name (OptionDefinedBits _) = "defined_bits" lookup_attrib :: String -> [Option] -> Maybe Option lookup_attrib _ [] = Nothing View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0982b7bbe6912b8673ece2b676b16aa... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0982b7bbe6912b8673ece2b676b16aa... You're receiving this email because of your account on gitlab.haskell.org.