Andreas Klebinger pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC Commits: 71681e41 by Andreas Klebinger at 2026-07-25T11:51:29+00:00 CmmLint: Check for unsupported MachOp widths - - - - - 1523beef by Andreas Klebinger at 2026-07-25T11:52:30+00:00 Add tests - - - - - 7 changed files: - compiler/GHC/Cmm/Lint.hs - compiler/GHC/Cmm/MachOp.hs - + testsuite/tests/codeGen/should_run/T27537.hs - + testsuite/tests/codeGen/should_run/T27537.stdout - + testsuite/tests/codeGen/should_run/T27538.hs - + testsuite/tests/codeGen/should_run/T27538.stdout - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/Cmm/Lint.hs ===================================== @@ -99,11 +99,11 @@ lintCmmExpr expr@(CmmMachOp op args) = do platform <- getPlatform tys <- mapM lintCmmExpr args lintShiftOp op (zip args tys) - let machop_arg_widths = machOpArgReps platform op + let machop_arg_widths_m = machOpArgReps platform op arg_tys = map (cmmExprType platform) args - if map typeWidth arg_tys == machop_arg_widths + if maybe False (\machop_arg_widths -> map typeWidth arg_tys == machop_arg_widths) machop_arg_widths_m then cmmCheckMachOp op args tys - else cmmLintMachOpErr expr arg_tys machop_arg_widths + else cmmLintMachOpErr expr arg_tys machop_arg_widths_m lintCmmExpr (CmmRegOff reg offset) = do let rep = typeWidth (cmmRegType reg) lintCmmExpr (CmmMachOp (MO_Add rep) @@ -279,8 +279,16 @@ addLintInfo info thing = CmmLint $ \platform -> Left err -> Left (hang info 2 err) Right a -> Right a -cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a -cmmLintMachOpErr expr argsRep opExpectsRep +cmmLintMachOpErr :: CmmExpr -> [CmmType] -> Maybe [Width] -> CmmLint a +cmmLintMachOpErr expr argsRep Nothing + = do + platform <- getPlatform + cmmLintErr (text "in MachOp application: " $$ + nest 2 (pdoc platform expr) $$ + text "op is using unsupported width" $$ + (text "arguments provide: " <+> ppr argsRep)) + +cmmLintMachOpErr expr argsRep (Just opExpectsRep) = do platform <- getPlatform cmmLintErr (text "in MachOp application: " $$ ===================================== compiler/GHC/Cmm/MachOp.hs ===================================== @@ -565,111 +565,118 @@ comparisonResultRep = bWord -- is it? -- application of a MachOp is "type-correct" by checking that the MachReps of -- its arguments are the same as the MachOp expects. This is used when -- linting a CmmExpr. +-- We also check if the given width is supported at all. But there might be +-- false positives. -machOpArgReps :: Platform -> MachOp -> [Width] +machOpArgReps :: Platform -> MachOp -> Maybe [Width] machOpArgReps platform op = case op of - MO_Add w -> [w,w] - MO_Sub w -> [w,w] - MO_Eq w -> [w,w] - MO_Ne w -> [w,w] - MO_Mul w -> [w,w] - MO_S_MulMayOflo w -> [w,w] - MO_S_Quot w -> [w,w] - MO_S_Rem w -> [w,w] - MO_S_Neg w -> [w] - MO_U_Quot w -> [w,w] - MO_U_Rem w -> [w,w] - - MO_S_Ge w -> [w,w] - MO_S_Le w -> [w,w] - MO_S_Gt w -> [w,w] - MO_S_Lt w -> [w,w] - - MO_U_Ge w -> [w,w] - MO_U_Le w -> [w,w] - MO_U_Gt w -> [w,w] - MO_U_Lt w -> [w,w] - - MO_F_Add w -> [w,w] - MO_F_Sub w -> [w,w] - MO_F_Mul w -> [w,w] - MO_F_Quot w -> [w,w] - MO_F_Neg w -> [w] - MO_F_Min w -> [w,w] - MO_F_Max w -> [w,w] - - MO_FMA _ l w -> [vecwidth l w, vecwidth l w, vecwidth l w] - - MO_F_Eq w -> [w,w] - MO_F_Ne w -> [w,w] - MO_F_Ge w -> [w,w] - MO_F_Le w -> [w,w] - MO_F_Gt w -> [w,w] - MO_F_Lt w -> [w,w] - - MO_And w -> [w,w] - MO_Or w -> [w,w] - MO_Xor w -> [w,w] - MO_Not w -> [w] - MO_Shl w -> [w, wordWidth platform] - MO_U_Shr w -> [w, wordWidth platform] - MO_S_Shr w -> [w, wordWidth platform] - - MO_SS_Conv from _ -> [from] - MO_UU_Conv from _ -> [from] - MO_XX_Conv from _ -> [from] - MO_SF_Round from _ -> [from] - MO_FS_Truncate from _ -> [from] - MO_FF_Conv from _ -> [from] - MO_WF_Bitcast w -> [w] - MO_FW_Bitcast w -> [w] - - MO_V_Shuffle l w _ -> [vecwidth l w, vecwidth l w] - MO_VF_Shuffle l w _ -> [vecwidth l w, vecwidth l w] - - MO_V_Broadcast _ w -> [w] - MO_V_Insert l w -> [vecwidth l w, w, W32] - MO_V_Extract l w -> [vecwidth l w, W32] - MO_VF_Broadcast _ w -> [w] - MO_VF_Insert l w -> [vecwidth l w, w, W32] - MO_VF_Extract l w -> [vecwidth l w, W32] + MO_Add w -> Just [w,w] + MO_Sub w -> Just [w,w] + MO_Eq w -> Just [w,w] + MO_Ne w -> Just [w,w] + MO_Mul w -> Just [w,w] + MO_S_MulMayOflo w -> Just [w,w] + MO_S_Quot w -> Just [w,w] + MO_S_Rem w -> Just [w,w] + MO_S_Neg w -> Just [w] + MO_U_Quot w -> Just [w,w] + MO_U_Rem w -> Just [w,w] + + MO_S_Ge w -> Just [w,w] + MO_S_Le w -> Just [w,w] + MO_S_Gt w -> Just [w,w] + MO_S_Lt w -> Just [w,w] + + MO_U_Ge w -> Just [w,w] + MO_U_Le w -> Just [w,w] + MO_U_Gt w -> Just [w,w] + MO_U_Lt w -> Just [w,w] + + MO_F_Add w -> Just [w,w] + MO_F_Sub w -> Just [w,w] + MO_F_Mul w -> Just [w,w] + MO_F_Quot w -> Just [w,w] + MO_F_Neg w -> Just [w] + MO_F_Min w -> Just [w,w] + MO_F_Max w -> Just [w,w] + + MO_FMA _ l w -> Just [vecwidth l w, vecwidth l w, vecwidth l w] + + MO_F_Eq w -> Just [w,w] + MO_F_Ne w -> Just [w,w] + MO_F_Ge w -> Just [w,w] + MO_F_Le w -> Just [w,w] + MO_F_Gt w -> Just [w,w] + MO_F_Lt w -> Just [w,w] + + MO_And w -> Just [w,w] + MO_Or w -> Just [w,w] + MO_Xor w -> Just [w,w] + MO_Not w -> Just [w] + MO_Shl w -> Just [w, wordWidth platform] + MO_U_Shr w -> Just [w, wordWidth platform] + MO_S_Shr w -> Just [w, wordWidth platform] + + MO_SS_Conv from _ -> Just [from] + MO_UU_Conv from _ -> Just [from] + MO_XX_Conv from _ -> Just [from] + -- Only supports W32/W64 + MO_SF_Round from _w -> onlyW32W64 from + MO_FS_Truncate from _ -> onlyW32W64 from + MO_FF_Conv from _ -> onlyW32W64 from + MO_WF_Bitcast w -> onlyW32W64 w + MO_FW_Bitcast w -> onlyW32W64 w + + MO_V_Shuffle l w _ -> Just [vecwidth l w, vecwidth l w] + MO_VF_Shuffle l w _ -> Just [vecwidth l w, vecwidth l w] + + MO_V_Broadcast _ w -> Just [w] + MO_V_Insert l w -> Just [vecwidth l w, w, W32] + MO_V_Extract l w -> Just [vecwidth l w, W32] + MO_VF_Broadcast _ w -> Just [w] + MO_VF_Insert l w -> Just [vecwidth l w, w, W32] + MO_VF_Extract l w -> Just [vecwidth l w, W32] -- SIMD vector indices are always 32 bit - MO_V_Add l w -> [vecwidth l w, vecwidth l w] - MO_V_Sub l w -> [vecwidth l w, vecwidth l w] - MO_V_Mul l w -> [vecwidth l w, vecwidth l w] + MO_V_Add l w -> Just [vecwidth l w, vecwidth l w] + MO_V_Sub l w -> Just [vecwidth l w, vecwidth l w] + MO_V_Mul l w -> Just [vecwidth l w, vecwidth l w] - MO_VS_Neg l w -> [vecwidth l w] - MO_VS_Abs l w -> [vecwidth l w] - MO_VS_Min l w -> [vecwidth l w, vecwidth l w] - MO_VS_Max l w -> [vecwidth l w, vecwidth l w] + MO_VS_Neg l w -> Just [vecwidth l w] + MO_VS_Abs l w -> Just [vecwidth l w] + MO_VS_Min l w -> Just [vecwidth l w, vecwidth l w] + MO_VS_Max l w -> Just [vecwidth l w, vecwidth l w] - MO_VU_Min l w -> [vecwidth l w, vecwidth l w] - MO_VU_Max l w -> [vecwidth l w, vecwidth l w] + MO_VU_Min l w -> Just [vecwidth l w, vecwidth l w] + MO_VU_Max l w -> Just [vecwidth l w, vecwidth l w] -- NOTE: The below is owing to the fact that floats use the SSE registers - MO_VF_Add l w -> [vecwidth l w, vecwidth l w] - MO_VF_Sub l w -> [vecwidth l w, vecwidth l w] - MO_VF_Mul l w -> [vecwidth l w, vecwidth l w] - MO_VF_Quot l w -> [vecwidth l w, vecwidth l w] - MO_VF_Neg l w -> [vecwidth l w] - MO_VF_Abs l w -> [vecwidth l w] - MO_VF_Sqrt l w -> [vecwidth l w] - MO_VF_Min l w -> [vecwidth l w, vecwidth l w] - MO_VF_Max l w -> [vecwidth l w, vecwidth l w] - - MO_V_And l w -> [vecwidth l w, vecwidth l w] - MO_V_Or l w -> [vecwidth l w, vecwidth l w] - MO_V_Xor l w -> [vecwidth l w, vecwidth l w] - MO_VF_And l w -> [vecwidth l w, vecwidth l w] - MO_VF_Or l w -> [vecwidth l w, vecwidth l w] - MO_VF_Xor l w -> [vecwidth l w, vecwidth l w] - - MO_RelaxedRead _ -> [wordWidth platform] - MO_AlignmentCheck _ w -> [w] + MO_VF_Add l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Sub l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Mul l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Quot l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Neg l w -> Just [vecwidth l w] + MO_VF_Abs l w -> Just [vecwidth l w] + MO_VF_Sqrt l w -> Just [vecwidth l w] + MO_VF_Min l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Max l w -> Just [vecwidth l w, vecwidth l w] + + MO_V_And l w -> Just [vecwidth l w, vecwidth l w] + MO_V_Or l w -> Just [vecwidth l w, vecwidth l w] + MO_V_Xor l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_And l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Or l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Xor l w -> Just [vecwidth l w, vecwidth l w] + + MO_RelaxedRead _ -> Just [wordWidth platform] + MO_AlignmentCheck _ w -> Just [w] where vecwidth l w = widthFromBytes (l * widthInBytes w) + onlyW32W64 w + | w == W64 = Just [w] + | w == W32 = Just [w] + | otherwise = Nothing ----------------------------------------------------------------------------- -- CallishMachOp ===================================== testsuite/tests/codeGen/should_run/T27537.hs ===================================== @@ -0,0 +1,26 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Exts + +{-# NOINLINE lt8 #-} +lt8 :: Int -> Word -> Int -- ltWord8# 254 255: must be 1 +lt8 (I# m) (W# n) = I# (ltWord8# (int8ToWord8# (intToInt8# m)) (wordToWord8# n)) + +{-# NOINLINE eq8 #-} +eq8 :: Int -> Word -> Int -- eqWord8# 254 254: must be 1 +eq8 (I# m) (W# n) = I# (eqWord8# (int8ToWord8# (intToInt8# m)) (wordToWord8# n)) + +{-# NOINLINE eqi16 #-} +eqi16 :: Int -> Int -> Int -- eqInt16# (-2) (-2): must be 1 +eqi16 (I# m) (I# n) = I# (eqInt16# (intToInt16# m) (word16ToInt16# (wordToWord16# (int2Word# n)))) + +{-# NOINLINE rem8 #-} +rem8 :: Int -> Word -> Word -- remWord8# 254 100: must be 54 +rem8 (I# m) (W# n) = W# (word8ToWord# (remWord8# (int8ToWord8# (intToInt8# m)) (wordToWord8# n))) + +main :: IO () +main = do + print (lt8 (-2) 255) + print (eq8 (-2) 254) + print (eqi16 (-2) 65534) + print (rem8 (-2) 100) ===================================== testsuite/tests/codeGen/should_run/T27537.stdout ===================================== @@ -0,0 +1,4 @@ +1 +1 +1 +54 ===================================== testsuite/tests/codeGen/should_run/T27538.hs ===================================== @@ -0,0 +1,19 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Exts + +{-# NOINLINE ix #-} +ix :: Int +ix = 0 + +{-# NOINLINE f #-} +f :: Int8# -> Int# +f x = if isTrue# (x `ltInt8#` intToInt8# 0#) + then (int8ToWord8# x) `gtWord8#` wordToWord8# 200## + else 1# + +main :: IO () +main = do + let !(I# i) = ix + x = indexInt8OffAddr# "\x80"# i + putStrLn ("f(0x80) = " ++ show (I# (f x))) ===================================== testsuite/tests/codeGen/should_run/T27538.stdout ===================================== @@ -0,0 +1 @@ +f(0x80) = 0 ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -297,3 +297,7 @@ test('aarch64-sxtw-run', ['aarch64-sxtw-run', [('aarch64-sxtw-cmm.cmm', '')], '-O']) test('T27430', [req_c, extra_ways(['optasm'])], compile_and_run, ['T27430_c.c']) + +test('T27537', normal, compile_and_run, ['-O']) + +test('T27538', normal, compile_and_run, ['-O']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7fefaf5f34da5c723b8dce977710a58... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7fefaf5f34da5c723b8dce977710a58... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help