Andreas Klebinger pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC
Commits:
-
3bf3cfc3
by Andreas Klebinger at 2026-08-13T18:17:46+00:00
-
1a01ed86
by Andreas Klebinger at 2026-08-13T19:35:35+00:00
-
193487c6
by Andreas Klebinger at 2026-08-13T19:35:43+00:00
-
bda8a8c6
by Andreas Klebinger at 2026-08-13T19:35:43+00:00
-
45bf8b75
by Andreas Klebinger at 2026-08-13T19:35:43+00:00
-
5b91f817
by Andreas Klebinger at 2026-08-13T19:35:43+00:00
-
ef7c872c
by Andreas Klebinger at 2026-08-13T19:35:43+00:00
-
92a88f55
by Andreas Klebinger at 2026-08-13T19:37:05+00:00
26 changed files:
- + changelog.d/arm_ncg_fixes_T27430
- compiler/GHC/Cmm/Expr.hs
- compiler/GHC/Cmm/Lint.hs
- compiler/GHC/Cmm/MachOp.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/AArch64/Instr.hs
- compiler/GHC/CmmToAsm/AArch64/Ppr.hs
- testsuite/tests/cmm/should_compile/Makefile
- + testsuite/tests/cmm/should_compile/T27368-ppr-debug.stderr
- − testsuite/tests/cmm/should_compile/T27368-ppr-debug.stdout
- testsuite/tests/cmm/should_compile/all.T
- + testsuite/tests/codeGen/should_run/T27430.hs
- + testsuite/tests/codeGen/should_run/T27430.stdout
- + testsuite/tests/codeGen/should_run/T27430_c.c
- + testsuite/tests/codeGen/should_run/T27533.hs
- + testsuite/tests/codeGen/should_run/T27533.stdout
- + testsuite/tests/codeGen/should_run/T27533_cmm.cmm
- + 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
- + testsuite/tests/simd/should_run/T27565.hs
- + testsuite/tests/simd/should_run/T27565.stdout
- testsuite/tests/simd/should_run/all.T
Changes:
| 1 | +section: compiler
|
|
| 2 | +issues: #27430 #27539 #27538 #27537 #27550 #27565 #27533
|
|
| 3 | +mrs: !16255
|
|
| 4 | +synopsis:
|
|
| 5 | + A series of fixes to the ARM64 ncg, related to handling of primitive
|
|
| 6 | + 8/16bit types and simd.
|
|
| 7 | +description:
|
|
| 8 | + A series of related fixes to the ncg fixing:
|
|
| 9 | + |
|
| 10 | + Fixed sign extension for subword values returned from unsafe ffi calls.
|
|
| 11 | + Clarify and lint for invalid conversions of int8/int16 -> float/double conversions.
|
|
| 12 | + Fix incorrect clobbering of local variables when comparing signed subword values.
|
|
| 13 | + Fix incorrect use of 32bit reads/stores for 8/16bit wide reads/stores.
|
|
| 14 | + Fix zero extension on function entry if arguments are passed at word-width
|
|
| 15 | + but used at subword-widths.
|
|
| 16 | + Fix broadcast# for non-literal arguments (arm64 only).
|
|
| 17 | + Fix rare assembler errors caused by overflowing literals, by properly checking
|
|
| 18 | + whether a constant is a viable immediate argument. |
| ... | ... | @@ -443,6 +443,11 @@ pprExpr platform e |
| 443 | 443 | CmmLit lit -> pprLit platform lit
|
| 444 | 444 | _other -> pprExpr1 platform e
|
| 445 | 445 | |
| 446 | +-- | `op` usually, but `(op[width])` with -dppr-debug
|
|
| 447 | +withDebugWidth :: Width -> SDoc -> SDoc
|
|
| 448 | +withDebugWidth w doc =
|
|
| 449 | + ifPprDebug (parens (doc <> brackets (ppr w))) doc
|
|
| 450 | + |
|
| 446 | 451 | -- Here's the precedence table from GHC.Cmm.Parser:
|
| 447 | 452 | -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
|
| 448 | 453 | -- %left '|'
|
| ... | ... | @@ -465,15 +470,17 @@ pprExpr1 platform e = pprExpr7 platform e |
| 465 | 470 | |
| 466 | 471 | infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
|
| 467 | 472 | |
| 468 | -infixMachOp1 (MO_Eq _) = Just (text "==")
|
|
| 469 | -infixMachOp1 (MO_Ne _) = Just (text "!=")
|
|
| 470 | -infixMachOp1 (MO_Shl _) = Just (text "<<")
|
|
| 471 | -infixMachOp1 (MO_U_Shr _) = Just (text ">>")
|
|
| 472 | -infixMachOp1 (MO_U_Ge _) = Just (text ">=")
|
|
| 473 | -infixMachOp1 (MO_U_Le _) = Just (text "<=")
|
|
| 474 | -infixMachOp1 (MO_U_Gt _) = Just (char '>')
|
|
| 475 | -infixMachOp1 (MO_U_Lt _) = Just (char '<')
|
|
| 476 | -infixMachOp1 _ = Nothing
|
|
| 473 | +infixMachOp1 mop = case mop of
|
|
| 474 | + (MO_Eq w) -> Just $ withDebugWidth w (text "==")
|
|
| 475 | + (MO_Ne w) -> Just $ withDebugWidth w (text "!=")
|
|
| 476 | + (MO_Shl w) -> Just $ withDebugWidth w (text "<<")
|
|
| 477 | + (MO_U_Shr w) -> Just $ withDebugWidth w (text ">>")
|
|
| 478 | + (MO_U_Ge w) -> Just $ withDebugWidth w (text ">=")
|
|
| 479 | + (MO_U_Le w) -> Just $ withDebugWidth w (text "<=")
|
|
| 480 | + (MO_U_Gt w) -> Just $ withDebugWidth w (char '>')
|
|
| 481 | + (MO_U_Lt w) -> Just $ withDebugWidth w (char '<')
|
|
| 482 | + _ -> Nothing
|
|
| 483 | + where
|
|
| 477 | 484 | |
| 478 | 485 | -- %left '-' '+'
|
| 479 | 486 | pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
|
| ... | ... | @@ -483,8 +490,8 @@ pprExpr7 platform (CmmMachOp op [x,y]) |
| 483 | 490 | = pprExpr7 platform x <+> doc <+> pprExpr8 platform y
|
| 484 | 491 | pprExpr7 platform e = pprExpr8 platform e
|
| 485 | 492 | |
| 486 | -infixMachOp7 (MO_Add _) = Just (char '+')
|
|
| 487 | -infixMachOp7 (MO_Sub _) = Just (char '-')
|
|
| 493 | +infixMachOp7 (MO_Add w) = Just $ withDebugWidth w (char '+')
|
|
| 494 | +infixMachOp7 (MO_Sub w) = Just $ withDebugWidth w (char '-')
|
|
| 488 | 495 | infixMachOp7 _ = Nothing
|
| 489 | 496 | |
| 490 | 497 | -- %left '/' '*' '%'
|
| ... | ... | @@ -493,9 +500,9 @@ pprExpr8 platform (CmmMachOp op [x,y]) |
| 493 | 500 | = pprExpr8 platform x <+> doc <+> pprExpr9 platform y
|
| 494 | 501 | pprExpr8 platform e = pprExpr9 platform e
|
| 495 | 502 | |
| 496 | -infixMachOp8 (MO_U_Quot _) = Just (char '/')
|
|
| 497 | -infixMachOp8 (MO_Mul _) = Just (char '*')
|
|
| 498 | -infixMachOp8 (MO_U_Rem _) = Just (char '%')
|
|
| 503 | +infixMachOp8 (MO_U_Quot w) = Just $ withDebugWidth w (char '/')
|
|
| 504 | +infixMachOp8 (MO_Mul w) = Just $ withDebugWidth w (char '*')
|
|
| 505 | +infixMachOp8 (MO_U_Rem w) = Just $ withDebugWidth w (char '%')
|
|
| 499 | 506 | infixMachOp8 _ = Nothing
|
| 500 | 507 | |
| 501 | 508 | pprExpr9 :: Platform -> CmmExpr -> SDoc
|
| ... | ... | @@ -545,11 +552,11 @@ genMachOp platform mop args |
| 545 | 552 | infixMachOp :: MachOp -> Maybe SDoc
|
| 546 | 553 | infixMachOp mop
|
| 547 | 554 | = case mop of
|
| 548 | - MO_And _ -> Just $ char '&'
|
|
| 549 | - MO_Or _ -> Just $ char '|'
|
|
| 550 | - MO_Xor _ -> Just $ char '^'
|
|
| 551 | - MO_Not _ -> Just $ char '~'
|
|
| 552 | - MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :)
|
|
| 555 | + MO_And w -> Just $ withDebugWidth w $ char '&'
|
|
| 556 | + MO_Or w -> Just $ withDebugWidth w $ char '|'
|
|
| 557 | + MO_Xor w -> Just $ withDebugWidth w $ char '^'
|
|
| 558 | + MO_Not w -> Just $ withDebugWidth w $ char '~'
|
|
| 559 | + MO_S_Neg w -> Just $ withDebugWidth w $ char '-' -- there is no unsigned neg :)
|
|
| 553 | 560 | _ -> Nothing
|
| 554 | 561 | |
| 555 | 562 | -- --------------------------------------------------------------------------
|
| ... | ... | @@ -88,8 +88,9 @@ lintCmmBlock labels block |
| 88 | 88 | -- byte/word mismatches.
|
| 89 | 89 | |
| 90 | 90 | lintCmmExpr :: CmmExpr -> CmmLint CmmType
|
| 91 | -lintCmmExpr (CmmLoad expr rep _alignment) = do
|
|
| 92 | - _ <- lintCmmExpr expr
|
|
| 91 | +lintCmmExpr e@(CmmLoad expr rep _alignment) = do
|
|
| 92 | + ty <- lintCmmExpr expr
|
|
| 93 | + lintAddrTy e ty
|
|
| 93 | 94 | -- Disabled, if we have the inlining phase before the lint phase,
|
| 94 | 95 | -- we can have funny offsets due to pointer tagging. -- EZY
|
| 95 | 96 | -- when (widthInBytes (typeWidth rep) >= platformWordSizeInBytes platform) $
|
| ... | ... | @@ -99,11 +100,11 @@ lintCmmExpr expr@(CmmMachOp op args) = do |
| 99 | 100 | platform <- getPlatform
|
| 100 | 101 | tys <- mapM lintCmmExpr args
|
| 101 | 102 | lintShiftOp op (zip args tys)
|
| 102 | - let machop_arg_widths = machOpArgReps platform op
|
|
| 103 | + let machop_arg_widths_m = machOpArgReps platform op
|
|
| 103 | 104 | arg_tys = map (cmmExprType platform) args
|
| 104 | - if map typeWidth arg_tys == machop_arg_widths
|
|
| 105 | + if maybe False (\machop_arg_widths -> map typeWidth arg_tys == machop_arg_widths) machop_arg_widths_m
|
|
| 105 | 106 | then cmmCheckMachOp op args tys
|
| 106 | - else cmmLintMachOpErr expr arg_tys machop_arg_widths
|
|
| 107 | + else cmmLintMachOpErr expr arg_tys machop_arg_widths_m
|
|
| 107 | 108 | lintCmmExpr (CmmRegOff reg offset)
|
| 108 | 109 | = do let rep = typeWidth (cmmRegType reg)
|
| 109 | 110 | lintCmmExpr (CmmMachOp (MO_Add rep)
|
| ... | ... | @@ -112,6 +113,15 @@ lintCmmExpr expr = |
| 112 | 113 | do platform <- getPlatform
|
| 113 | 114 | return (cmmExprType platform expr)
|
| 114 | 115 | |
| 116 | +-- We require every address value to be word-sized since we don't support 32
|
|
| 117 | +-- bit pointers on 64bit platforms.
|
|
| 118 | +lintAddrTy :: CmmExpr -> CmmType -> CmmLint ()
|
|
| 119 | +lintAddrTy e addr_ty = do
|
|
| 120 | + p <- getPlatform
|
|
| 121 | + -- We don't support any platforms where wordwidth /= ptrWidth currently.
|
|
| 122 | + unless (addr_ty `cmmCompatType` bWord p) $ cmmLintErr (text "Non word-width address found in:" <+> pdoc p e)
|
|
| 123 | + |
|
| 124 | + |
|
| 115 | 125 | -- | Check for obviously out-of-bounds shift operations
|
| 116 | 126 | lintShiftOp :: MachOp -> [(CmmExpr, CmmType)] -> CmmLint ()
|
| 117 | 127 | lintShiftOp op [(_, arg_ty), (CmmLit (CmmInt n _), _)]
|
| ... | ... | @@ -173,10 +183,10 @@ lintCmmMiddle node = case node of |
| 173 | 183 | unless (erep `cmmCompatType` reg_ty) $
|
| 174 | 184 | cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
|
| 175 | 185 | |
| 176 | - CmmStore l r _alignment -> do
|
|
| 177 | - _ <- lintCmmExpr l
|
|
| 178 | - _ <- lintCmmExpr r
|
|
| 179 | - return ()
|
|
| 186 | + CmmStore addr rhs _alignment -> do
|
|
| 187 | + addr_ty <- lintCmmExpr addr
|
|
| 188 | + _ <- lintCmmExpr rhs
|
|
| 189 | + lintAddrTy addr addr_ty
|
|
| 180 | 190 | |
| 181 | 191 | CmmUnsafeForeignCall target _formals actuals -> do
|
| 182 | 192 | let lintArg expr = do
|
| ... | ... | @@ -279,8 +289,16 @@ addLintInfo info thing = CmmLint $ \platform -> |
| 279 | 289 | Left err -> Left (hang info 2 err)
|
| 280 | 290 | Right a -> Right a
|
| 281 | 291 | |
| 282 | -cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
|
|
| 283 | -cmmLintMachOpErr expr argsRep opExpectsRep
|
|
| 292 | +cmmLintMachOpErr :: CmmExpr -> [CmmType] -> Maybe [Width] -> CmmLint a
|
|
| 293 | +cmmLintMachOpErr expr argsRep Nothing
|
|
| 294 | + = do
|
|
| 295 | + platform <- getPlatform
|
|
| 296 | + cmmLintErr (text "in MachOp application: " $$
|
|
| 297 | + nest 2 (pdoc platform expr) $$
|
|
| 298 | + text "op is using unsupported width" $$
|
|
| 299 | + (text "arguments provide: " <+> ppr argsRep))
|
|
| 300 | + |
|
| 301 | +cmmLintMachOpErr expr argsRep (Just opExpectsRep)
|
|
| 284 | 302 | = do
|
| 285 | 303 | platform <- getPlatform
|
| 286 | 304 | cmmLintErr (text "in MachOp application: " $$
|
| ... | ... | @@ -142,8 +142,8 @@ data MachOp |
| 142 | 142 | |
| 143 | 143 | -- Conversions. Some of these will be NOPs.
|
| 144 | 144 | -- Floating-point conversions use the signed variant.
|
| 145 | - | MO_SF_Round Width Width -- Signed int -> Float
|
|
| 146 | - | MO_FS_Truncate Width Width -- Float -> Signed int
|
|
| 145 | + | MO_SF_Round Width Width -- Signed int -> Float, but only W32/W64 inputs
|
|
| 146 | + | MO_FS_Truncate Width Width -- Float -> Signed int, only W32/W64 on the int side.
|
|
| 147 | 147 | | MO_SS_Conv Width Width -- Signed int -> Signed int
|
| 148 | 148 | | MO_UU_Conv Width Width -- unsigned int -> unsigned int
|
| 149 | 149 | | MO_XX_Conv Width Width -- int -> int; puts no requirements on the
|
| ... | ... | @@ -565,111 +565,120 @@ comparisonResultRep = bWord -- is it? |
| 565 | 565 | -- application of a MachOp is "type-correct" by checking that the MachReps of
|
| 566 | 566 | -- its arguments are the same as the MachOp expects. This is used when
|
| 567 | 567 | -- linting a CmmExpr.
|
| 568 | +-- We also check if the given width is supported at all. But there might be
|
|
| 569 | +-- false positives.
|
|
| 568 | 570 | |
| 569 | -machOpArgReps :: Platform -> MachOp -> [Width]
|
|
| 571 | +machOpArgReps :: Platform -> MachOp -> Maybe [Width]
|
|
| 570 | 572 | machOpArgReps platform op =
|
| 571 | 573 | case op of
|
| 572 | - MO_Add w -> [w,w]
|
|
| 573 | - MO_Sub w -> [w,w]
|
|
| 574 | - MO_Eq w -> [w,w]
|
|
| 575 | - MO_Ne w -> [w,w]
|
|
| 576 | - MO_Mul w -> [w,w]
|
|
| 577 | - MO_S_MulMayOflo w -> [w,w]
|
|
| 578 | - MO_S_Quot w -> [w,w]
|
|
| 579 | - MO_S_Rem w -> [w,w]
|
|
| 580 | - MO_S_Neg w -> [w]
|
|
| 581 | - MO_U_Quot w -> [w,w]
|
|
| 582 | - MO_U_Rem w -> [w,w]
|
|
| 583 | - |
|
| 584 | - MO_S_Ge w -> [w,w]
|
|
| 585 | - MO_S_Le w -> [w,w]
|
|
| 586 | - MO_S_Gt w -> [w,w]
|
|
| 587 | - MO_S_Lt w -> [w,w]
|
|
| 588 | - |
|
| 589 | - MO_U_Ge w -> [w,w]
|
|
| 590 | - MO_U_Le w -> [w,w]
|
|
| 591 | - MO_U_Gt w -> [w,w]
|
|
| 592 | - MO_U_Lt w -> [w,w]
|
|
| 593 | - |
|
| 594 | - MO_F_Add w -> [w,w]
|
|
| 595 | - MO_F_Sub w -> [w,w]
|
|
| 596 | - MO_F_Mul w -> [w,w]
|
|
| 597 | - MO_F_Quot w -> [w,w]
|
|
| 598 | - MO_F_Neg w -> [w]
|
|
| 599 | - MO_F_Min w -> [w,w]
|
|
| 600 | - MO_F_Max w -> [w,w]
|
|
| 601 | - |
|
| 602 | - MO_FMA _ l w -> [vecwidth l w, vecwidth l w, vecwidth l w]
|
|
| 603 | - |
|
| 604 | - MO_F_Eq w -> [w,w]
|
|
| 605 | - MO_F_Ne w -> [w,w]
|
|
| 606 | - MO_F_Ge w -> [w,w]
|
|
| 607 | - MO_F_Le w -> [w,w]
|
|
| 608 | - MO_F_Gt w -> [w,w]
|
|
| 609 | - MO_F_Lt w -> [w,w]
|
|
| 610 | - |
|
| 611 | - MO_And w -> [w,w]
|
|
| 612 | - MO_Or w -> [w,w]
|
|
| 613 | - MO_Xor w -> [w,w]
|
|
| 614 | - MO_Not w -> [w]
|
|
| 615 | - MO_Shl w -> [w, wordWidth platform]
|
|
| 616 | - MO_U_Shr w -> [w, wordWidth platform]
|
|
| 617 | - MO_S_Shr w -> [w, wordWidth platform]
|
|
| 618 | - |
|
| 619 | - MO_SS_Conv from _ -> [from]
|
|
| 620 | - MO_UU_Conv from _ -> [from]
|
|
| 621 | - MO_XX_Conv from _ -> [from]
|
|
| 622 | - MO_SF_Round from _ -> [from]
|
|
| 623 | - MO_FS_Truncate from _ -> [from]
|
|
| 624 | - MO_FF_Conv from _ -> [from]
|
|
| 625 | - MO_WF_Bitcast w -> [w]
|
|
| 626 | - MO_FW_Bitcast w -> [w]
|
|
| 627 | - |
|
| 628 | - MO_V_Shuffle l w _ -> [vecwidth l w, vecwidth l w]
|
|
| 629 | - MO_VF_Shuffle l w _ -> [vecwidth l w, vecwidth l w]
|
|
| 630 | - |
|
| 631 | - MO_V_Broadcast _ w -> [w]
|
|
| 632 | - MO_V_Insert l w -> [vecwidth l w, w, W32]
|
|
| 633 | - MO_V_Extract l w -> [vecwidth l w, W32]
|
|
| 634 | - MO_VF_Broadcast _ w -> [w]
|
|
| 635 | - MO_VF_Insert l w -> [vecwidth l w, w, W32]
|
|
| 636 | - MO_VF_Extract l w -> [vecwidth l w, W32]
|
|
| 574 | + MO_Add w -> Just [w,w]
|
|
| 575 | + MO_Sub w -> Just [w,w]
|
|
| 576 | + MO_Eq w -> Just [w,w]
|
|
| 577 | + MO_Ne w -> Just [w,w]
|
|
| 578 | + MO_Mul w -> Just [w,w]
|
|
| 579 | + MO_S_MulMayOflo w -> Just [w,w]
|
|
| 580 | + MO_S_Quot w -> Just [w,w]
|
|
| 581 | + MO_S_Rem w -> Just [w,w]
|
|
| 582 | + MO_S_Neg w -> Just [w]
|
|
| 583 | + MO_U_Quot w -> Just [w,w]
|
|
| 584 | + MO_U_Rem w -> Just [w,w]
|
|
| 585 | + |
|
| 586 | + MO_S_Ge w -> Just [w,w]
|
|
| 587 | + MO_S_Le w -> Just [w,w]
|
|
| 588 | + MO_S_Gt w -> Just [w,w]
|
|
| 589 | + MO_S_Lt w -> Just [w,w]
|
|
| 590 | + |
|
| 591 | + MO_U_Ge w -> Just [w,w]
|
|
| 592 | + MO_U_Le w -> Just [w,w]
|
|
| 593 | + MO_U_Gt w -> Just [w,w]
|
|
| 594 | + MO_U_Lt w -> Just [w,w]
|
|
| 595 | + |
|
| 596 | + MO_F_Add w -> Just [w,w]
|
|
| 597 | + MO_F_Sub w -> Just [w,w]
|
|
| 598 | + MO_F_Mul w -> Just [w,w]
|
|
| 599 | + MO_F_Quot w -> Just [w,w]
|
|
| 600 | + MO_F_Neg w -> Just [w]
|
|
| 601 | + MO_F_Min w -> Just [w,w]
|
|
| 602 | + MO_F_Max w -> Just [w,w]
|
|
| 603 | + |
|
| 604 | + MO_FMA _ l w -> Just [vecwidth l w, vecwidth l w, vecwidth l w]
|
|
| 605 | + |
|
| 606 | + MO_F_Eq w -> Just [w,w]
|
|
| 607 | + MO_F_Ne w -> Just [w,w]
|
|
| 608 | + MO_F_Ge w -> Just [w,w]
|
|
| 609 | + MO_F_Le w -> Just [w,w]
|
|
| 610 | + MO_F_Gt w -> Just [w,w]
|
|
| 611 | + MO_F_Lt w -> Just [w,w]
|
|
| 612 | + |
|
| 613 | + MO_And w -> Just [w,w]
|
|
| 614 | + MO_Or w -> Just [w,w]
|
|
| 615 | + MO_Xor w -> Just [w,w]
|
|
| 616 | + MO_Not w -> Just [w]
|
|
| 617 | + MO_Shl w -> Just [w, wordWidth platform]
|
|
| 618 | + MO_U_Shr w -> Just [w, wordWidth platform]
|
|
| 619 | + MO_S_Shr w -> Just [w, wordWidth platform]
|
|
| 620 | + |
|
| 621 | + MO_SS_Conv from _ -> Just [from]
|
|
| 622 | + MO_UU_Conv from _ -> Just [from]
|
|
| 623 | + MO_XX_Conv from _ -> Just [from]
|
|
| 624 | + -- Only supports W32/W64
|
|
| 625 | + MO_SF_Round from _w -> onlyW32W64 from
|
|
| 626 | + MO_FS_Truncate from to
|
|
| 627 | + | to `notElem` [W32, W64] -> Nothing
|
|
| 628 | + | otherwise -> onlyW32W64 from
|
|
| 629 | + MO_FF_Conv from _ -> onlyW32W64 from
|
|
| 630 | + MO_WF_Bitcast w -> onlyW32W64 w
|
|
| 631 | + MO_FW_Bitcast w -> onlyW32W64 w
|
|
| 632 | + |
|
| 633 | + MO_V_Shuffle l w _ -> Just [vecwidth l w, vecwidth l w]
|
|
| 634 | + MO_VF_Shuffle l w _ -> Just [vecwidth l w, vecwidth l w]
|
|
| 635 | + |
|
| 636 | + MO_V_Broadcast _ w -> Just [w]
|
|
| 637 | + MO_V_Insert l w -> Just [vecwidth l w, w, W32]
|
|
| 638 | + MO_V_Extract l w -> Just [vecwidth l w, W32]
|
|
| 639 | + MO_VF_Broadcast _ w -> Just [w]
|
|
| 640 | + MO_VF_Insert l w -> Just [vecwidth l w, w, W32]
|
|
| 641 | + MO_VF_Extract l w -> Just [vecwidth l w, W32]
|
|
| 637 | 642 | -- SIMD vector indices are always 32 bit
|
| 638 | 643 | |
| 639 | - MO_V_Add l w -> [vecwidth l w, vecwidth l w]
|
|
| 640 | - MO_V_Sub l w -> [vecwidth l w, vecwidth l w]
|
|
| 641 | - MO_V_Mul l w -> [vecwidth l w, vecwidth l w]
|
|
| 644 | + MO_V_Add l w -> Just [vecwidth l w, vecwidth l w]
|
|
| 645 | + MO_V_Sub l w -> Just [vecwidth l w, vecwidth l w]
|
|
| 646 | + MO_V_Mul l w -> Just [vecwidth l w, vecwidth l w]
|
|
| 642 | 647 | |
| 643 | - MO_VS_Neg l w -> [vecwidth l w]
|
|
| 644 | - MO_VS_Abs l w -> [vecwidth l w]
|
|
| 645 | - MO_VS_Min l w -> [vecwidth l w, vecwidth l w]
|
|
| 646 | - MO_VS_Max l w -> [vecwidth l w, vecwidth l w]
|
|
| 648 | + MO_VS_Neg l w -> Just [vecwidth l w]
|
|
| 649 | + MO_VS_Abs l w -> Just [vecwidth l w]
|
|
| 650 | + MO_VS_Min l w -> Just [vecwidth l w, vecwidth l w]
|
|
| 651 | + MO_VS_Max l w -> Just [vecwidth l w, vecwidth l w]
|
|
| 647 | 652 | |
| 648 | - MO_VU_Min l w -> [vecwidth l w, vecwidth l w]
|
|
| 649 | - MO_VU_Max l w -> [vecwidth l w, vecwidth l w]
|
|
| 653 | + MO_VU_Min l w -> Just [vecwidth l w, vecwidth l w]
|
|
| 654 | + MO_VU_Max l w -> Just [vecwidth l w, vecwidth l w]
|
|
| 650 | 655 | |
| 651 | 656 | -- NOTE: The below is owing to the fact that floats use the SSE registers
|
| 652 | - MO_VF_Add l w -> [vecwidth l w, vecwidth l w]
|
|
| 653 | - MO_VF_Sub l w -> [vecwidth l w, vecwidth l w]
|
|
| 654 | - MO_VF_Mul l w -> [vecwidth l w, vecwidth l w]
|
|
| 655 | - MO_VF_Quot l w -> [vecwidth l w, vecwidth l w]
|
|
| 656 | - MO_VF_Neg l w -> [vecwidth l w]
|
|
| 657 | - MO_VF_Abs l w -> [vecwidth l w]
|
|
| 658 | - MO_VF_Sqrt l w -> [vecwidth l w]
|
|
| 659 | - MO_VF_Min l w -> [vecwidth l w, vecwidth l w]
|
|
| 660 | - MO_VF_Max l w -> [vecwidth l w, vecwidth l w]
|
|
| 661 | - |
|
| 662 | - MO_V_And l w -> [vecwidth l w, vecwidth l w]
|
|
| 663 | - MO_V_Or l w -> [vecwidth l w, vecwidth l w]
|
|
| 664 | - MO_V_Xor l w -> [vecwidth l w, vecwidth l w]
|
|
| 665 | - MO_VF_And l w -> [vecwidth l w, vecwidth l w]
|
|
| 666 | - MO_VF_Or l w -> [vecwidth l w, vecwidth l w]
|
|
| 667 | - MO_VF_Xor l w -> [vecwidth l w, vecwidth l w]
|
|
| 668 | - |
|
| 669 | - MO_RelaxedRead _ -> [wordWidth platform]
|
|
| 670 | - MO_AlignmentCheck _ w -> [w]
|
|
| 657 | + MO_VF_Add l w -> Just [vecwidth l w, vecwidth l w]
|
|
| 658 | + MO_VF_Sub l w -> Just [vecwidth l w, vecwidth l w]
|
|
| 659 | + MO_VF_Mul l w -> Just [vecwidth l w, vecwidth l w]
|
|
| 660 | + MO_VF_Quot l w -> Just [vecwidth l w, vecwidth l w]
|
|
| 661 | + MO_VF_Neg l w -> Just [vecwidth l w]
|
|
| 662 | + MO_VF_Abs l w -> Just [vecwidth l w]
|
|
| 663 | + MO_VF_Sqrt l w -> Just [vecwidth l w]
|
|
| 664 | + MO_VF_Min l w -> Just [vecwidth l w, vecwidth l w]
|
|
| 665 | + MO_VF_Max l w -> Just [vecwidth l w, vecwidth l w]
|
|
| 666 | + |
|
| 667 | + MO_V_And l w -> Just [vecwidth l w, vecwidth l w]
|
|
| 668 | + MO_V_Or l w -> Just [vecwidth l w, vecwidth l w]
|
|
| 669 | + MO_V_Xor l w -> Just [vecwidth l w, vecwidth l w]
|
|
| 670 | + MO_VF_And l w -> Just [vecwidth l w, vecwidth l w]
|
|
| 671 | + MO_VF_Or l w -> Just [vecwidth l w, vecwidth l w]
|
|
| 672 | + MO_VF_Xor l w -> Just [vecwidth l w, vecwidth l w]
|
|
| 673 | + |
|
| 674 | + MO_RelaxedRead _ -> Just [wordWidth platform]
|
|
| 675 | + MO_AlignmentCheck _ w -> Just [w]
|
|
| 671 | 676 | where
|
| 672 | 677 | vecwidth l w = widthFromBytes (l * widthInBytes w)
|
| 678 | + onlyW32W64 w
|
|
| 679 | + | w == W64 = Just [w]
|
|
| 680 | + | w == W32 = Just [w]
|
|
| 681 | + | otherwise = Nothing
|
|
| 673 | 682 | |
| 674 | 683 | -----------------------------------------------------------------------------
|
| 675 | 684 | -- CallishMachOp
|
| ... | ... | @@ -745,6 +745,8 @@ stmt :: { CmmParse () } |
| 745 | 745 | { doCall $2 [] $4 }
|
| 746 | 746 | | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';'
|
| 747 | 747 | { doCall $6 $2 $8 }
|
| 748 | + -- NB: bool_expr most be a *boolean* expression: A comparison machOp or 1/0 word literals.
|
|
| 749 | + -- We don't allow arbitrary expressions as conditions (See GHC.Cmm.Lint.checkCond:checkCond, #27543).
|
|
| 748 | 750 | | 'if' bool_expr cond_likely 'goto' NAME
|
| 749 | 751 | { do l <- lookupLabel $5; cmmRawIf $2 l $3 }
|
| 750 | 752 | | 'if' bool_expr cond_likely '{' body '}' else
|
| ... | ... | @@ -356,13 +356,10 @@ type InstrBlock |
| 356 | 356 | --
|
| 357 | 357 | data Register
|
| 358 | 358 | = Fixed Format Reg InstrBlock
|
| 359 | + -- ^ It can be unsafe to clobber the result reg, as it might map to a
|
|
| 360 | + -- local variable.
|
|
| 359 | 361 | | Any Format (Reg -> InstrBlock)
|
| 360 | - |
|
| 361 | --- | Sometimes we need to change the Format of a register. Primarily during
|
|
| 362 | --- conversion.
|
|
| 363 | -swizzleRegisterRep :: Format -> Register -> Register
|
|
| 364 | -swizzleRegisterRep format (Fixed _ reg code) = Fixed format reg code
|
|
| 365 | -swizzleRegisterRep format (Any _ codefn) = Any format codefn
|
|
| 362 | + -- ^ A destination the caller decides, prevents redundant moves
|
|
| 366 | 363 | |
| 367 | 364 | -- | Grab the Reg for a CmmReg
|
| 368 | 365 | getRegisterReg :: Platform -> CmmReg -> Reg
|
| ... | ... | @@ -370,8 +367,9 @@ getRegisterReg :: Platform -> CmmReg -> Reg |
| 370 | 367 | getRegisterReg _ (CmmLocal (LocalReg u pk))
|
| 371 | 368 | = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)
|
| 372 | 369 | |
| 373 | -getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _))
|
|
| 374 | - = case globalRegMaybe platform mid of
|
|
| 370 | +getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid ty))
|
|
| 371 | + = assert (formatInBytes (cmmTypeFormat ty) >= 4) $
|
|
| 372 | + case globalRegMaybe platform mid of
|
|
| 375 | 373 | Just reg -> RegReal reg
|
| 376 | 374 | Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal reg)
|
| 377 | 375 | -- By this stage, the only MagicIds remaining should be the
|
| ... | ... | @@ -382,11 +380,17 @@ getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _)) |
| 382 | 380 | -- -----------------------------------------------------------------------------
|
| 383 | 381 | -- General things for putting together code sequences
|
| 384 | 382 | |
| 385 | --- | The dual to getAnyReg: compute an expression into a register, but
|
|
| 386 | --- we don't mind which one it is.
|
|
| 383 | +-- | Computes the `Register` value into a concrete register, but we can't pick which one.
|
|
| 384 | +-- This means the register might be mapped to a global or local variable and
|
|
| 385 | +-- we can only mutate the result reg in place if we know the Cmm expression can't
|
|
| 386 | +-- refer to local or global variables.
|
|
| 387 | 387 | getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock)
|
| 388 | 388 | getSomeReg expr = do
|
| 389 | 389 | r <- getRegister expr
|
| 390 | + someReg r
|
|
| 391 | + |
|
| 392 | +someReg :: Register -> NatM (Reg, Format, InstrBlock)
|
|
| 393 | +someReg r =
|
|
| 390 | 394 | case r of
|
| 391 | 395 | Any rep code -> do
|
| 392 | 396 | tmp <- getNewRegNat rep
|
| ... | ... | @@ -647,28 +651,38 @@ opRegWidth W16 = W32 -- w |
| 647 | 651 | opRegWidth W8 = W32 -- w
|
| 648 | 652 | opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w)
|
| 649 | 653 | |
| 650 | --- Note [Signed arithmetic on AArch64]
|
|
| 651 | --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
| 652 | --- Handling signed arithmetic on sub-word-size values on AArch64 is a bit
|
|
| 653 | --- tricky as Cmm's type system does not capture signedness. While 32-bit values
|
|
| 654 | --- are fairly easy to handle due to AArch64's 32-bit instruction variants
|
|
| 655 | --- (denoted by use of %wN registers), 16- and 8-bit values require quite some
|
|
| 656 | --- care.
|
|
| 654 | +-- Note [Subword operations on AArch64]
|
|
| 655 | +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
| 656 | +-- Handling subword operations on AArch64 is a bit tricky. 32-bit values are fairly
|
|
| 657 | +-- easy to handle due to AArch64's 32-bit instruction variants. 16- and 8-bit
|
|
| 658 | +-- values require quite some care. The platform doesn't provide operations at
|
|
| 659 | +-- widths below 32bit. Which means we have to simulate them using wider operations.
|
|
| 660 | +-- Signed arithmetic on sub-word-size values on AArch64 is a bit tricky as Cmm's
|
|
| 661 | +-- type system does not capture signedness. If we have a 8 bit value the high
|
|
| 662 | +-- bits could be sign or zero extended with no easy way to tell.
|
|
| 657 | 663 | --
|
| 658 | --- We handle 16-and 8-bit values by using the 32-bit operations and
|
|
| 664 | +-- To work around this handle 16-and 8-bit values by using the 32-bit operations and
|
|
| 659 | 665 | -- sign-/zero-extending operands and truncate results as necessary. For
|
| 660 | 666 | -- simplicity we maintain the invariant that a register containing a
|
| 661 | 667 | -- sub-word-size value always contains the zero-extended form of that value
|
| 662 | 668 | -- in between operations.
|
| 663 | 669 | --
|
| 664 | --- IMPORTANT: this invariant only holds within a single expression tree as
|
|
| 665 | --- generated by the NCG (via truncateReg after each sub-word operation). It
|
|
| 666 | --- does NOT hold at function entry points or across basic block boundaries,
|
|
| 667 | --- because the GHC calling convention does not guarantee that callers
|
|
| 668 | --- zero-extend sub-word arguments. Therefore, any operation that is sensitive
|
|
| 669 | --- to the upper bits of its input (e.g. unsigned right shift, unsigned
|
|
| 670 | --- division) must explicitly zero- or sign-extend its operands rather than
|
|
| 671 | --- assuming they are already extended.
|
|
| 670 | +-- Concretely we establish this invariant on every input into the function for which
|
|
| 671 | +-- we generate code for in the NCG. This means:
|
|
| 672 | +-- * Global STG register access
|
|
| 673 | +-- * memory reads
|
|
| 674 | +-- * function arguments
|
|
| 675 | +-- * ffi results
|
|
| 676 | +-- * function call results
|
|
| 677 | +-- * results from any subexpression
|
|
| 678 | +--
|
|
| 679 | +-- This means we can assume the invariant when generated code for expression trees
|
|
| 680 | +-- or machops reading local variables, avoiding (some) redundant extensions. But
|
|
| 681 | +-- we have to take great care to uphold the invariant when computing new values.
|
|
| 682 | +--
|
|
| 683 | +-- We used to do the inverse. Re-establish the invariant for any operation that
|
|
| 684 | +-- is sensitive to values in the high bits. But that turned out to produce worse
|
|
| 685 | +-- code and wasn't any less likely to result in new bugs in practice.
|
|
| 672 | 686 | --
|
| 673 | 687 | -- For instance, consider the program,
|
| 674 | 688 | --
|
| ... | ... | @@ -688,7 +702,10 @@ opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w) |
| 688 | 702 | -- Next we compute `c`: The `%not` requires no extension of its operands, but
|
| 689 | 703 | -- we must still truncate the result back down to 8-bits. Finally the `%shrl`
|
| 690 | 704 | -- requires no extension and no truncate since we can assume that
|
| 691 | --- `c` is zero-extended (it was produced by a truncateReg in the same block).
|
|
| 705 | +-- `c` is zero-extended.
|
|
| 706 | +--
|
|
| 707 | +-- Down the line I think the right way to approach this is to operate more over
|
|
| 708 | +-- the `Register` type and store sign extension information inside it.
|
|
| 692 | 709 | --
|
| 693 | 710 | -- TODO:
|
| 694 | 711 | -- Don't use Width in Operands
|
| ... | ... | @@ -925,20 +942,36 @@ getRegister' config plat expr |
| 925 | 942 | getRegister (CmmLoad e (cmmBits w) NaturallyAligned)
|
| 926 | 943 | |
| 927 | 944 | CmmMachOp op [e] -> do
|
| 928 | - (reg, _format, code) <- getSomeReg e
|
|
| 945 | + register <- getRegister e
|
|
| 946 | + (reg, _format, code) <- someReg register
|
|
| 929 | 947 | case op of
|
| 930 | - MO_Not w -> return $ Any (intFormat w) $ \dst ->
|
|
| 948 | + -- XX Conversion
|
|
| 949 | + -- truncateSubwordRegister: See Note [Subword operations on AArch64].
|
|
| 950 | + MO_XX_Conv from to
|
|
| 951 | + | to >= from -> pure $ swizzleRegisterRep register (intFormat to)
|
|
| 952 | + | otherwise -> pure $ truncateSubwordRegister to register
|
|
| 953 | + |
|
| 954 | + -- truncateSubwordRegister: See Note [Subword operations on AArch64].
|
|
| 955 | + MO_Not w -> return $ truncateSubwordRegister w $ Any (intFormat w) $ \dst ->
|
|
| 931 | 956 | let w' = opRegWidth w
|
| 932 | 957 | in code `snocOL`
|
| 933 | - MVN (OpReg w' dst) (OpReg w' reg) `appOL`
|
|
| 934 | - truncateReg w' w dst -- See Note [Signed arithmetic on AArch64]
|
|
| 958 | + MVN (OpReg w' dst) (OpReg w' reg)
|
|
| 959 | + |
|
| 960 | + -- truncateSubwordRegister: See Note [Subword operations on AArch64].
|
|
| 961 | + MO_S_Neg w -> truncateSubwordRegister w <$> do
|
|
| 962 | + let op_w = opRegWidth w
|
|
| 963 | + (src, _fmt, reg_code) <- someReg $ signExtendRegister w op_w register
|
|
| 964 | + pure $ Any (intFormat w) $ \dst -> reg_code `snocOL` (NEG (intFormat w) (OpReg op_w dst) (OpReg op_w src))
|
|
| 935 | 965 | |
| 936 | - MO_S_Neg w -> negate code w reg
|
|
| 937 | 966 | MO_F_Neg w -> return $ Any fmt (\dst -> code `snocOL` NEG fmt (OpReg w dst) (OpReg w reg))
|
| 938 | 967 | where fmt = floatFormat w
|
| 939 | 968 | |
| 940 | - MO_SF_Round from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg)) -- (Signed ConVerT Float)
|
|
| 941 | - MO_FS_Truncate from to -> return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from reg)) -- (float convert (-> zero) signed)
|
|
| 969 | + MO_SF_Round from to ->
|
|
| 970 | + massert (from >= W32) >>
|
|
| 971 | + return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg)) -- (Signed ConVerT Float)
|
|
| 972 | + MO_FS_Truncate from to ->
|
|
| 973 | + massert (to >= W32) >>
|
|
| 974 | + return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from reg)) -- (float convert (-> zero) signed)
|
|
| 942 | 975 | |
| 943 | 976 | -- TODO this is very hacky
|
| 944 | 977 | -- Note, UBFM and SBFM expect source and target register to be of the same size, so we'll use @max from to@
|
| ... | ... | @@ -951,11 +984,8 @@ getRegister' config plat expr |
| 951 | 984 | MO_FW_Bitcast w -> return $ Any fmt (\dst -> code `snocOL` FMOV fmt (OpReg w dst) (OpReg w reg))
|
| 952 | 985 | where fmt = intFormat w
|
| 953 | 986 | |
| 954 | - -- Conversions
|
|
| 955 | - MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e
|
|
| 956 | - |
|
| 957 | 987 | -- Vector
|
| 958 | - MO_V_Broadcast l w -> return $ Any fmt (\dst -> code `snocOL` DUP fmt (OpReg vw dst) (OpScalarAsVec w reg))
|
|
| 988 | + MO_V_Broadcast l w -> return $ Any fmt (\dst -> code `snocOL` DUP fmt (OpReg vw dst) (OpReg w reg))
|
|
| 959 | 989 | where fmt = VecFormat l (intScalarFormat w)
|
| 960 | 990 | vw = formatToWidth fmt
|
| 961 | 991 | MO_VF_Broadcast l w -> return $ Any fmt (\dst -> code `snocOL` DUP fmt (OpReg vw dst) (OpScalarAsVec w reg))
|
| ... | ... | @@ -1054,26 +1084,13 @@ getRegister' config plat expr |
| 1054 | 1084 | toImm W256 = (OpImm (ImmInt 255))
|
| 1055 | 1085 | toImm W512 = (OpImm (ImmInt 511))
|
| 1056 | 1086 | |
| 1057 | - -- In the case of 16- or 8-bit values we need to sign-extend to 32-bits
|
|
| 1058 | - -- See Note [Signed arithmetic on AArch64].
|
|
| 1059 | - negate code w reg = do
|
|
| 1060 | - let w' = opRegWidth w
|
|
| 1061 | - fmt = intFormat w
|
|
| 1062 | - (reg', code_sx) <- signExtendReg w w' reg
|
|
| 1063 | - return $ Any fmt $ \dst ->
|
|
| 1064 | - code `appOL`
|
|
| 1065 | - code_sx `snocOL`
|
|
| 1066 | - NEG fmt (OpReg w' dst) (OpReg w' reg') `appOL`
|
|
| 1067 | - truncateReg w' w dst
|
|
| 1068 | - |
|
| 1069 | 1087 | ss_conv from to reg code =
|
| 1070 | 1088 | let w' = opRegWidth (max from to)
|
| 1071 | - in return $ Any (intFormat to) $ \dst ->
|
|
| 1072 | - code `snocOL`
|
|
| 1073 | - SBFM (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt 0)) (toImm (min from to)) `appOL`
|
|
| 1074 | - -- At this point an 8- or 16-bit value would be sign-extended
|
|
| 1089 | + in return $ truncateSubwordRegister to $ Any (intFormat to) $ \dst ->
|
|
| 1090 | + code `snocOL`
|
|
| 1091 | + SBFM (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt 0)) (toImm (min from to))
|
|
| 1092 | + -- At this point an 8- or 16-bit value is sign-extended
|
|
| 1075 | 1093 | -- to 32-bits. Truncate back down the final width.
|
| 1076 | - truncateReg w' to dst
|
|
| 1077 | 1094 | |
| 1078 | 1095 | -- Dyadic machops:
|
| 1079 | 1096 | --
|
| ... | ... | @@ -1090,26 +1107,14 @@ getRegister' config plat expr |
| 1090 | 1107 | CmmMachOp (MO_Sub _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'
|
| 1091 | 1108 | -- Immediates are handled via `getArithImm` in the generic code path.
|
| 1092 | 1109 | |
| 1093 | - CmmMachOp (MO_U_Quot w) [x, y] | w == W8 -> do
|
|
| 1110 | + CmmMachOp (MO_U_Quot w) [x, y] | w == W8 || w == W16-> do
|
|
| 1094 | 1111 | (reg_x, _format_x, code_x) <- getSomeReg x
|
| 1095 | 1112 | (reg_y, _format_y, code_y) <- getSomeReg y
|
| 1096 | - tmp_x <- getNewRegNat (intFormat w)
|
|
| 1097 | - tmp_y <- getNewRegNat (intFormat w)
|
|
| 1098 | - return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w tmp_x) (OpReg w reg_x)) `snocOL`
|
|
| 1099 | - (UXTB (OpReg w tmp_y) (OpReg w reg_y)) `snocOL`
|
|
| 1100 | - (UDIV (OpReg w dst) (OpReg w tmp_x) (OpReg w tmp_y)))
|
|
| 1101 | - CmmMachOp (MO_U_Quot w) [x, y] | w == W16 -> do
|
|
| 1102 | - (reg_x, _format_x, code_x) <- getSomeReg x
|
|
| 1103 | - (reg_y, _format_y, code_y) <- getSomeReg y
|
|
| 1104 | - tmp_x <- getNewRegNat (intFormat w)
|
|
| 1105 | - tmp_y <- getNewRegNat (intFormat w)
|
|
| 1106 | - return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w tmp_x) (OpReg w reg_x)) `snocOL`
|
|
| 1107 | - (UXTH (OpReg w tmp_y) (OpReg w reg_y)) `snocOL`
|
|
| 1108 | - (UDIV (OpReg w dst) (OpReg w tmp_x) (OpReg w tmp_y)))
|
|
| 1113 | + return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))
|
|
| 1109 | 1114 | |
| 1110 | 1115 | -- 2. Shifts. x << n, x >> n.
|
| 1111 | 1116 | -- Sub-word left shifts by a constant: use UBFM (UBFIZ alias) to shift
|
| 1112 | - -- and mask in a single instruction. See Note [Signed arithmetic on AArch64].
|
|
| 1117 | + -- and mask in a single instruction. See Note [Subword operations on AArch64].
|
|
| 1113 | 1118 | CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do
|
| 1114 | 1119 | (reg_x, _format_x, code_x) <- getSomeReg x
|
| 1115 | 1120 | return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (UBFM (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger ((32 - n) `mod` 32))) (OpImm (ImmInteger (7 - n)))))
|
| ... | ... | @@ -1126,7 +1131,7 @@ getRegister' config plat expr |
| 1126 | 1131 | CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do
|
| 1127 | 1132 | (reg_x, _format_x, code_x) <- getSomeReg x
|
| 1128 | 1133 | return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n))))
|
| 1129 | - `snocOL` (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]
|
|
| 1134 | + `snocOL` (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Subword operations on AArch64]
|
|
| 1130 | 1135 | CmmMachOp (MO_S_Shr w) [x, y] | w == W8 -> do
|
| 1131 | 1136 | (reg_x, _format_x, code_x) <- getSomeReg x
|
| 1132 | 1137 | (reg_y, _format_y, code_y) <- getSomeReg y
|
| ... | ... | @@ -1135,12 +1140,12 @@ getRegister' config plat expr |
| 1135 | 1140 | tmp <- getNewRegNat (intFormat w)
|
| 1136 | 1141 | return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTB (OpReg w tmp) (OpReg w reg_x)) `snocOL`
|
| 1137 | 1142 | (ASR (OpReg w dst) (OpReg w tmp) (OpReg w reg_y)) `snocOL`
|
| 1138 | - (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]
|
|
| 1143 | + (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Subword operations on AArch64]
|
|
| 1139 | 1144 | |
| 1140 | 1145 | CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do
|
| 1141 | 1146 | (reg_x, _format_x, code_x) <- getSomeReg x
|
| 1142 | 1147 | return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n))))
|
| 1143 | - `snocOL` (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]
|
|
| 1148 | + `snocOL` (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Subword operations on AArch64]
|
|
| 1144 | 1149 | CmmMachOp (MO_S_Shr w) [x, y] | w == W16 -> do
|
| 1145 | 1150 | (reg_x, _format_x, code_x) <- getSomeReg x
|
| 1146 | 1151 | (reg_y, _format_y, code_y) <- getSomeReg y
|
| ... | ... | @@ -1149,7 +1154,7 @@ getRegister' config plat expr |
| 1149 | 1154 | tmp <- getNewRegNat (intFormat w)
|
| 1150 | 1155 | return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTH (OpReg w tmp) (OpReg w reg_x)) `snocOL`
|
| 1151 | 1156 | (ASR (OpReg w dst) (OpReg w tmp) (OpReg w reg_y)) `snocOL`
|
| 1152 | - (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]
|
|
| 1157 | + (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Subword operations on AArch64]
|
|
| 1153 | 1158 | |
| 1154 | 1159 | CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))]
|
| 1155 | 1160 | | w == W32 || w == W64
|
| ... | ... | @@ -1182,14 +1187,14 @@ getRegister' config plat expr |
| 1182 | 1187 | return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))
|
| 1183 | 1188 | |
| 1184 | 1189 | -- 3. Logic &&, ||
|
| 1185 | - CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (opRegWidth w') (fromIntegral n) ->
|
|
| 1186 | - return $ Any fmt (\d -> unitOL $ annExpr expr (AND fmt (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))
|
|
| 1190 | + CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | Just op_bitmask <- getBitmaskImm n w ->
|
|
| 1191 | + return $ Any fmt (\d -> unitOL $ annExpr expr (AND fmt (OpReg w d) (OpReg w' r') op_bitmask))
|
|
| 1187 | 1192 | where fmt = intFormat w
|
| 1188 | 1193 | w' = formatToWidth (cmmTypeFormat (cmmRegType reg))
|
| 1189 | 1194 | r' = getRegisterReg plat reg
|
| 1190 | 1195 | |
| 1191 | - CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (opRegWidth w') (fromIntegral n) ->
|
|
| 1192 | - return $ Any fmt (\d -> unitOL $ annExpr expr (ORR fmt (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))
|
|
| 1196 | + CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | Just op_bitmask <- getBitmaskImm n w ->
|
|
| 1197 | + return $ Any fmt (\d -> unitOL $ annExpr expr (ORR fmt (OpReg w d) (OpReg w' r') op_bitmask))
|
|
| 1193 | 1198 | where fmt = intFormat w
|
| 1194 | 1199 | w' = formatToWidth (cmmTypeFormat (cmmRegType reg))
|
| 1195 | 1200 | r' = getRegisterReg plat reg
|
| ... | ... | @@ -1220,16 +1225,17 @@ getRegister' config plat expr |
| 1220 | 1225 | code_y `appOL`
|
| 1221 | 1226 | op (OpReg w dst) (OpReg w reg_x) op_y)
|
| 1222 | 1227 | |
| 1223 | - -- A (potentially signed) integer operation.
|
|
| 1228 | + -- A (potentially signed) integer operation that can have immediate arguments.
|
|
| 1224 | 1229 | -- In the case of 8- and 16-bit signed arithmetic we must first
|
| 1225 | 1230 | -- sign-extend both arguments to 32-bits.
|
| 1226 | - -- See Note [Signed arithmetic on AArch64].
|
|
| 1227 | - intOpImm :: Bool -> Width -> (Operand -> Operand -> Operand -> OrdList Instr) -> (Integer -> Width -> Maybe Operand) -> NatM (Register)
|
|
| 1228 | - intOpImm {- is signed -} True w op _encode_imm = intOp True w op
|
|
| 1229 | - intOpImm False w op encode_imm = do
|
|
| 1231 | + -- See Note [Subword operations on AArch64].
|
|
| 1232 | + intOpImm :: Bool -> SetsHighBits -> Width -> (Operand -> Operand -> Operand -> OrdList Instr) -> (Integer -> Width -> Maybe Operand) -> NatM (Register)
|
|
| 1233 | + intOpImm {- is signed -} True trunc w op _encode_imm = intOp True trunc w op
|
|
| 1234 | + intOpImm False trunc w op encode_imm = maintainHighBits trunc w <$> do
|
|
| 1230 | 1235 | -- compute x<m> <- x
|
| 1231 | 1236 | -- compute x<o> <- y
|
| 1232 | 1237 | -- <OP> x<n>, x<m>, x<o>
|
| 1238 | + let w' = opRegWidth w
|
|
| 1233 | 1239 | (reg_x, format_x, code_x) <- getSomeReg x
|
| 1234 | 1240 | (op_y, format_y, code_y) <- case y of
|
| 1235 | 1241 | CmmLit (CmmInt n w)
|
| ... | ... | @@ -1241,40 +1247,29 @@ getRegister' config plat expr |
| 1241 | 1247 | massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int"
|
| 1242 | 1248 | -- This is the width of the registers on which the operation
|
| 1243 | 1249 | -- should be performed.
|
| 1244 | - let w' = opRegWidth w
|
|
| 1245 | 1250 | return $ Any (intFormat w) $ \dst ->
|
| 1246 | 1251 | code_x `appOL`
|
| 1247 | 1252 | code_y `appOL`
|
| 1248 | - op (OpReg w' dst) (OpReg w' reg_x) (op_y) `appOL`
|
|
| 1249 | - truncateReg w' w dst -- truncate back to the operand's original width
|
|
| 1253 | + op (OpReg w' dst) (OpReg w' reg_x) (op_y)
|
|
| 1250 | 1254 | |
| 1251 | 1255 | -- A (potentially signed) integer operation.
|
| 1252 | 1256 | -- In the case of 8- and 16-bit signed arithmetic we must first
|
| 1253 | 1257 | -- sign-extend both arguments to 32-bits.
|
| 1254 | - -- See Note [Signed arithmetic on AArch64].
|
|
| 1255 | - intOp is_signed w op = do
|
|
| 1258 | + -- See Note [Subword operations on AArch64].
|
|
| 1259 | + intOp is_signed clean_highbits w op = maintainHighBits clean_highbits w <$> do
|
|
| 1256 | 1260 | -- compute x<m> <- x
|
| 1257 | 1261 | -- compute x<o> <- y
|
| 1258 | 1262 | -- <OP> x<n>, x<m>, x<o>
|
| 1259 | - (reg_x, format_x, code_x) <- getSomeReg x
|
|
| 1260 | - (reg_y, format_y, code_y) <- getSomeReg y
|
|
| 1263 | + let op_w = opRegWidth w
|
|
| 1264 | + let setHighBits = if is_signed then signExtendRegister w (opRegWidth w) else id
|
|
| 1265 | + (reg_x_sx, format_x, code_x) <- someReg =<< setHighBits <$> getRegister x
|
|
| 1266 | + (reg_y_sx, format_y, code_y) <- someReg =<< setHighBits <$> getRegister y
|
|
| 1261 | 1267 | massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int"
|
| 1262 | - -- This is the width of the registers on which the operation
|
|
| 1263 | - -- should be performed.
|
|
| 1264 | - let w' = opRegWidth w
|
|
| 1265 | - signExt r
|
|
| 1266 | - | not is_signed = return (r, nilOL)
|
|
| 1267 | - | otherwise = signExtendReg w w' r
|
|
| 1268 | - (reg_x_sx, code_x_sx) <- signExt reg_x
|
|
| 1269 | - (reg_y_sx, code_y_sx) <- signExt reg_y
|
|
| 1268 | + |
|
| 1270 | 1269 | return $ Any (intFormat w) $ \dst ->
|
| 1271 | 1270 | code_x `appOL`
|
| 1272 | 1271 | code_y `appOL`
|
| 1273 | - -- sign-extend both operands
|
|
| 1274 | - code_x_sx `appOL`
|
|
| 1275 | - code_y_sx `appOL`
|
|
| 1276 | - op (OpReg w' dst) (OpReg w' reg_x_sx) (OpReg w' reg_y_sx) `appOL`
|
|
| 1277 | - truncateReg w' w dst -- truncate back to the operand's original width
|
|
| 1272 | + op (OpReg op_w dst) (OpReg op_w reg_x_sx) (OpReg op_w reg_y_sx)
|
|
| 1278 | 1273 | |
| 1279 | 1274 | floatOp w op = do
|
| 1280 | 1275 | (reg_fx, format_x, code_fx) <- getFloatReg x
|
| ... | ... | @@ -1465,9 +1460,9 @@ getRegister' config plat expr |
| 1465 | 1460 | case op of
|
| 1466 | 1461 | -- Integer operations
|
| 1467 | 1462 | -- Add/Sub should only be Integer Options.
|
| 1468 | - MO_Add w -> intOpImm False w (\d x y -> unitOL $ annExpr expr (ADD (intFormat w) d x y)) getArithImm
|
|
| 1463 | + MO_Add w -> intOpImm False UnknownHighBits w (\d x y -> unitOL $ annExpr expr (ADD (intFormat w) d x y)) getArithImm
|
|
| 1469 | 1464 | -- TODO: Handle sub-word case
|
| 1470 | - MO_Sub w -> intOpImm False w (\d x y -> unitOL $ annExpr expr (SUB (intFormat w) d x y)) getArithImm
|
|
| 1465 | + MO_Sub w -> intOpImm False UnknownHighBits w (\d x y -> unitOL $ annExpr expr (SUB (intFormat w) d x y)) getArithImm
|
|
| 1471 | 1466 | |
| 1472 | 1467 | -- Note [CSET]
|
| 1473 | 1468 | -- ~~~~~~~~~~~
|
| ... | ... | @@ -1513,9 +1508,9 @@ getRegister' config plat expr |
| 1513 | 1508 | MO_Ne w -> bitOpImm w (\d x y -> toOL [ CMP x y, CSET d NE ]) getArithImm
|
| 1514 | 1509 | |
| 1515 | 1510 | -- Signed multiply/divide
|
| 1516 | - MO_Mul w -> intOp True w (\d x y -> unitOL $ MUL (intFormat w) d x y)
|
|
| 1511 | + MO_Mul w -> intOp True UnknownHighBits w (\d x y -> unitOL $ MUL (intFormat w) d x y)
|
|
| 1517 | 1512 | MO_S_MulMayOflo w -> do_mul_may_oflo w x y
|
| 1518 | - MO_S_Quot w -> intOp True w (\d x y -> unitOL $ SDIV (intFormat w) d x y)
|
|
| 1513 | + MO_S_Quot w -> intOp True UnknownHighBits w (\d x y -> unitOL $ SDIV (intFormat w) d x y)
|
|
| 1519 | 1514 | |
| 1520 | 1515 | -- No native rem instruction. So we'll compute the following
|
| 1521 | 1516 | -- Rd <- Rx / Ry | 2 <- 7 / 3 -- SDIV Rd Rx Ry
|
| ... | ... | @@ -1525,24 +1520,24 @@ getRegister' config plat expr |
| 1525 | 1520 | -- '--------------------------'
|
| 1526 | 1521 | -- Note the swap in Rx and Ry.
|
| 1527 | 1522 | MO_S_Rem w -> withTempIntReg w $ \t ->
|
| 1528 | - intOp True w (\d x y -> toOL [ SDIV (intFormat w) t x y, MSUB d t y x ])
|
|
| 1523 | + intOp True UnknownHighBits w (\d x y -> toOL [ SDIV (intFormat w) t x y, MSUB d t y x ])
|
|
| 1529 | 1524 | |
| 1530 | 1525 | -- Unsigned multiply/divide
|
| 1531 | - MO_U_Quot w -> intOp False w (\d x y -> unitOL $ UDIV d x y)
|
|
| 1526 | + MO_U_Quot w -> intOp False CleanHighBits w (\d x y -> unitOL $ UDIV d x y)
|
|
| 1532 | 1527 | MO_U_Rem w -> withTempIntReg w $ \t ->
|
| 1533 | - intOp False w (\d x y -> toOL [ UDIV t x y, MSUB d t y x ])
|
|
| 1528 | + intOp False CleanHighBits w (\d x y -> toOL [ UDIV t x y, MSUB d t y x ])
|
|
| 1534 | 1529 | |
| 1535 | 1530 | -- Signed comparisons -- see Note [CSET]
|
| 1536 | - MO_S_Ge w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SGE ])
|
|
| 1537 | - MO_S_Le w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SLE ])
|
|
| 1538 | - MO_S_Gt w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SGT ])
|
|
| 1539 | - MO_S_Lt w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SLT ])
|
|
| 1531 | + MO_S_Ge w -> intOp True CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d SGE ])
|
|
| 1532 | + MO_S_Le w -> intOp True CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d SLE ])
|
|
| 1533 | + MO_S_Gt w -> intOp True CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d SGT ])
|
|
| 1534 | + MO_S_Lt w -> intOp True CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d SLT ])
|
|
| 1540 | 1535 | |
| 1541 | 1536 | -- Unsigned comparisons
|
| 1542 | - MO_U_Ge w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d UGE ]) getArithImm
|
|
| 1543 | - MO_U_Le w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d ULE ]) getArithImm
|
|
| 1544 | - MO_U_Gt w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d UGT ]) getArithImm
|
|
| 1545 | - MO_U_Lt w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d ULT ]) getArithImm
|
|
| 1537 | + MO_U_Ge w -> intOpImm False CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d UGE ]) getArithImm
|
|
| 1538 | + MO_U_Le w -> intOpImm False CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d ULE ]) getArithImm
|
|
| 1539 | + MO_U_Gt w -> intOpImm False CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d UGT ]) getArithImm
|
|
| 1540 | + MO_U_Lt w -> intOpImm False CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d ULT ]) getArithImm
|
|
| 1546 | 1541 | |
| 1547 | 1542 | -- Floating point arithmetic
|
| 1548 | 1543 | MO_F_Add w -> floatOp w (\d x y -> unitOL $ ADD (floatFormat w) d x y)
|
| ... | ... | @@ -1570,9 +1565,9 @@ getRegister' config plat expr |
| 1570 | 1565 | MO_And w -> bitOpImm w (\d x y -> unitOL $ AND (intFormat w) d x y) getBitmaskImm
|
| 1571 | 1566 | MO_Or w -> bitOpImm w (\d x y -> unitOL $ ORR (intFormat w) d x y) getBitmaskImm
|
| 1572 | 1567 | MO_Xor w -> bitOpImm w (\d x y -> unitOL $ EOR (intFormat w) d x y) getBitmaskImm
|
| 1573 | - MO_Shl w -> intOp False w (\d x y -> unitOL $ LSL d x y)
|
|
| 1574 | - MO_U_Shr w -> intOp False w (\d x y -> unitOL $ LSR d x y)
|
|
| 1575 | - MO_S_Shr w -> intOp True w (\d x y -> unitOL $ ASR d x y)
|
|
| 1568 | + MO_Shl w -> intOp False UnknownHighBits w (\d x y -> unitOL $ LSL d x y)
|
|
| 1569 | + MO_U_Shr w -> intOp False CleanHighBits w (\d x y -> unitOL $ LSR d x y)
|
|
| 1570 | + MO_S_Shr w -> intOp True UnknownHighBits w (\d x y -> unitOL $ ASR d x y)
|
|
| 1576 | 1571 | |
| 1577 | 1572 | -- Vector operations
|
| 1578 | 1573 | MO_V_Add l w -> intVecOp l w (\fmt d x y -> unitOL $ ADD fmt d x y)
|
| ... | ... | @@ -1630,7 +1625,7 @@ getRegister' config plat expr |
| 1630 | 1625 | _ -> pprPanic "Unsupported offset" (pdoc platform y)
|
| 1631 | 1626 | (reg_x, format_x, code_x) <- getSomeReg x
|
| 1632 | 1627 | massertPpr (isVecFormat format_x) $ text "MO_V_Extract: non-vector"
|
| 1633 | - -- Always use UMOV. See Note [Signed arithmetic on AArch64]
|
|
| 1628 | + -- Always use UMOV. See Note [Subword operations on AArch64]
|
|
| 1634 | 1629 | return $ Any format (\dst -> code_x `snocOL` UMOV (OpReg w dst) (OpVecLane w reg_x index))
|
| 1635 | 1630 | |
| 1636 | 1631 | MO_VF_Extract l w -> do
|
| ... | ... | @@ -1759,7 +1754,7 @@ getRegister' config plat expr |
| 1759 | 1754 | tmp <- getNewRegNat format
|
| 1760 | 1755 | return $ Any format $ \dst ->
|
| 1761 | 1756 | code_x `appOL` code_y `appOL`
|
| 1762 | - if dst == reg_y
|
|
| 1757 | + if dst == reg_y --unlike MO_V_Insert here y/dst can overlap.
|
|
| 1763 | 1758 | then toOL [ MOV (OpReg W128 tmp) (OpReg W128 reg_x)
|
| 1764 | 1759 | , INS format (OpVecLane w tmp index) (OpScalarAsVec w reg_y)
|
| 1765 | 1760 | , MOV (OpReg W128 dst) (OpReg W128 tmp)
|
| ... | ... | @@ -1886,36 +1881,87 @@ isAArch64Bitmask width n = |
| 1886 | 1881 | hasOneRun m =
|
| 1887 | 1882 | 64 == popCount m + countLeadingZeros m + countTrailingZeros m
|
| 1888 | 1883 | |
| 1884 | +--------------------------------------------------------------------------------
|
|
| 1885 | +-- Helpers to help enforcing Note [Subword operations on AArch64]
|
|
| 1886 | +--------------------------------------------------------------------------------
|
|
| 1887 | + |
|
| 1889 | 1888 | -- | Instructions to sign-extend the value in the given register from width @w@
|
| 1890 | 1889 | -- up to width @w'@.
|
| 1891 | -signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr)
|
|
| 1892 | -signExtendReg w w' r =
|
|
| 1893 | - case w of
|
|
| 1894 | - W64 -> noop
|
|
| 1895 | - W32
|
|
| 1896 | - | w' == W32 -> noop
|
|
| 1897 | - | otherwise -> extend SXTW
|
|
| 1898 | - W16 -> extend SXTH
|
|
| 1899 | - W8 -> extend SXTB
|
|
| 1900 | - _ -> panic "intOp"
|
|
| 1890 | +signExtendInstr :: Width -> Width -> Reg -> Maybe (Reg -> Instr)
|
|
| 1891 | +signExtendInstr w w' r =
|
|
| 1892 | + case (w,w') of
|
|
| 1893 | + (W64,_) -> Nothing
|
|
| 1894 | + (W32,W32) -> Nothing
|
|
| 1895 | + (W32,_) -> extend SXTW
|
|
| 1896 | + (W16,_) -> extend SXTH
|
|
| 1897 | + (W8 ,_) -> extend SXTB
|
|
| 1898 | + _ -> panic "signExtendInstr:unexpectedWidth"
|
|
| 1899 | + where
|
|
| 1900 | + extend instr = Just $ \r' -> instr (OpReg w' r') (OpReg w r)
|
|
| 1901 | + |
|
| 1902 | +-- | Sign extend the register if needed, otherwise use register as-is
|
|
| 1903 | +signExtendRegister :: Width -> Width -> Register -> Register
|
|
| 1904 | +signExtendRegister w w' register = case register of
|
|
| 1905 | + Fixed _fmt reg code ->
|
|
| 1906 | + maybe register
|
|
| 1907 | + (\instr_ext -> Any (intFormat w') (\dst -> code `snocOL` instr_ext dst) )
|
|
| 1908 | + (signExtendInstr w w' reg)
|
|
| 1909 | + Any _fmt code ->
|
|
| 1910 | + Any (intFormat w') $ \dst ->
|
|
| 1911 | + maybe (code dst)
|
|
| 1912 | + (\instr_ext -> code dst `snocOL` instr_ext dst)
|
|
| 1913 | + (signExtendInstr w w' dst)
|
|
| 1914 | + |
|
| 1915 | +truncSubwordRegInstr :: Width -> Reg -> Maybe (Reg -> Instr)
|
|
| 1916 | +truncSubwordRegInstr w_to r =
|
|
| 1917 | + case w_to of
|
|
| 1918 | + -- Asserted false, but be defensive for non-debug builds.
|
|
| 1919 | + W64 -> Nothing
|
|
| 1920 | + W32 -> Nothing
|
|
| 1921 | + |
|
| 1922 | + -- Actual truncation
|
|
| 1923 | + W16 -> trunc W32 UXTH
|
|
| 1924 | + W8 -> trunc W32 UXTB
|
|
| 1925 | + _ -> panic "truncateSubwordReg:unexpectedWidth"
|
|
| 1901 | 1926 | where
|
| 1902 | - noop = return (r, nilOL)
|
|
| 1903 | - extend instr = do
|
|
| 1904 | - r' <- getNewRegNat (intFormat w')
|
|
| 1905 | - return (r', unitOL $ instr (OpReg w' r') (OpReg w r))
|
|
| 1906 | - |
|
| 1907 | --- | Instructions to truncate the value in the given register from width @w@
|
|
| 1908 | --- down to width @w'@.
|
|
| 1909 | -truncateReg :: Width -> Width -> Reg -> OrdList Instr
|
|
| 1910 | -truncateReg w w' r =
|
|
| 1911 | - case w of
|
|
| 1927 | + trunc w instr = do
|
|
| 1928 | + Just $ \r' -> instr (OpReg w r') (OpReg w r)
|
|
| 1929 | + |
|
| 1930 | +-- | Like @truncateSubwordRegister@, but modifes the given argument register in place if we
|
|
| 1931 | +-- need to truncate.
|
|
| 1932 | +truncateSubwordRegInplace :: Width -> Reg -> OrdList Instr
|
|
| 1933 | +truncateSubwordRegInplace w_to r = do
|
|
| 1934 | + case w_to of
|
|
| 1912 | 1935 | W64 -> nilOL
|
| 1913 | - W32
|
|
| 1914 | - | w' == W32 -> nilOL
|
|
| 1915 | - _ -> unitOL $ UBFM (OpReg w r)
|
|
| 1916 | - (OpReg w r)
|
|
| 1917 | - (OpImm (ImmInt 0))
|
|
| 1918 | - (OpImm $ ImmInt $ widthInBits w' - 1)
|
|
| 1936 | + W32 -> nilOL
|
|
| 1937 | + W16 -> trunc UXTH
|
|
| 1938 | + W8 -> trunc UXTB
|
|
| 1939 | + _ -> panic "truncateSubwordRegInplace:unexpectedWidth"
|
|
| 1940 | + where
|
|
| 1941 | + trunc instr = do
|
|
| 1942 | + unitOL $ instr (OpReg W32 r) (OpReg W32 r)
|
|
| 1943 | + |
|
| 1944 | +-- | Zeros the high words of the value represented by Register if needed according to
|
|
| 1945 | +-- Note [Subword operations on AArch64]
|
|
| 1946 | +truncateSubwordRegister :: Width -> Register -> Register
|
|
| 1947 | +truncateSubwordRegister w register = case register of
|
|
| 1948 | + Fixed _fmt reg code ->
|
|
| 1949 | + maybe (swizzleRegisterRep register (intFormat w))
|
|
| 1950 | + (\r_instr -> Any (intFormat w) (\dst -> code `snocOL` r_instr dst))
|
|
| 1951 | + (truncSubwordRegInstr w reg)
|
|
| 1952 | + Any _fmt code -> Any (intFormat w) $ \dst ->
|
|
| 1953 | + maybe (code dst) (\r_inst -> code dst `snocOL` r_inst dst) (truncSubwordRegInstr w dst)
|
|
| 1954 | + |
|
| 1955 | +data SetsHighBits = UnknownHighBits | CleanHighBits
|
|
| 1956 | + |
|
| 1957 | +maintainHighBits :: SetsHighBits -> Width -> Register -> Register
|
|
| 1958 | +maintainHighBits CleanHighBits _w x = x
|
|
| 1959 | +maintainHighBits UnknownHighBits w x = truncateSubwordRegister w x
|
|
| 1960 | + |
|
| 1961 | +-- Reinterpret the value in the register as different format.
|
|
| 1962 | +swizzleRegisterRep :: Register -> Format -> Register
|
|
| 1963 | +swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code
|
|
| 1964 | +swizzleRegisterRep (Any _ codefn) format = Any format codefn
|
|
| 1919 | 1965 | |
| 1920 | 1966 | -- -----------------------------------------------------------------------------
|
| 1921 | 1967 | -- The 'Amode' type: Memory addressing modes passed up the tree.
|
| ... | ... | @@ -2038,27 +2084,24 @@ genCondJump bid expr = do |
| 2038 | 2084 | -- Generic case.
|
| 2039 | 2085 | CmmMachOp mop [x, y] -> do
|
| 2040 | 2086 | |
| 2041 | - let ubcond w cmp = do
|
|
| 2042 | - -- compute both sides.
|
|
| 2043 | - (reg_x, _format_x, code_x) <- getSomeReg x
|
|
| 2044 | - (reg_y, _format_y, code_y) <- getSomeReg y
|
|
| 2045 | - let x' = OpReg w reg_x
|
|
| 2046 | - y' = OpReg w reg_y
|
|
| 2047 | - return $ case w of
|
|
| 2048 | - W8 -> code_x `appOL` code_y `appOL` toOL [ UXTB x' x', UXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
|
|
| 2049 | - W16 -> code_x `appOL` code_y `appOL` toOL [ UXTH x' x', UXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
|
|
| 2050 | - _ -> code_x `appOL` code_y `appOL` toOL [ CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
|
|
| 2051 | - |
|
| 2052 | - sbcond w cmp = do
|
|
| 2053 | - -- compute both sides.
|
|
| 2054 | - (reg_x, _format_x, code_x) <- getSomeReg x
|
|
| 2055 | - (reg_y, _format_y, code_y) <- getSomeReg y
|
|
| 2087 | + let icond is_signed w cmp = do
|
|
| 2088 | + -- zero or sign extend the argument register(s)
|
|
| 2089 | + let extend reg =
|
|
| 2090 | + if is_signed
|
|
| 2091 | + then someReg $ signExtendRegister w (opRegWidth w) reg
|
|
| 2092 | + else someReg $ truncateSubwordRegister w reg
|
|
| 2093 | + |
|
| 2094 | + (reg_x, _format_x, code_x) <- extend =<< getRegister x
|
|
| 2095 | + (reg_y, _format_y, code_y) <- extend =<< getRegister y
|
|
| 2096 | + |
|
| 2056 | 2097 | let x' = OpReg w reg_x
|
| 2057 | 2098 | y' = OpReg w reg_y
|
| 2058 | - return $ case w of
|
|
| 2059 | - W8 -> code_x `appOL` code_y `appOL` toOL [ SXTB x' x', SXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
|
|
| 2060 | - W16 -> code_x `appOL` code_y `appOL` toOL [ SXTH x' x', SXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
|
|
| 2061 | - _ -> code_x `appOL` code_y `appOL` toOL [ CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
|
|
| 2099 | + |
|
| 2100 | + return $ concatOL [code_x, code_y,
|
|
| 2101 | + toOL [CMP x' y', (annExpr expr (BCOND cmp (TBlock bid)))]]
|
|
| 2102 | + |
|
| 2103 | + let ubcond w cmp = icond False w cmp
|
|
| 2104 | + sbcond w cmp = icond True w cmp
|
|
| 2062 | 2105 | |
| 2063 | 2106 | fbcond w cmp = do
|
| 2064 | 2107 | -- ensure we get float regs
|
| ... | ... | @@ -2327,32 +2370,27 @@ genCCall target dest_regs arg_regs = do |
| 2327 | 2370 | , [src_a, src_b] <- arg_regs
|
| 2328 | 2371 | , [dst_needed, dst_hi, dst_lo] <- dest_regs
|
| 2329 | 2372 | -> do
|
| 2330 | - (reg_a', _format_x, code_a) <- getSomeReg src_a
|
|
| 2331 | - (reg_b', _format_y, code_b) <- getSomeReg src_b
|
|
| 2373 | + -- Sign-extend inputs to W32 for SMULL (Xd = Wn * Wm).
|
|
| 2374 | + -- sign extension always allocates a fresh temp for w < W32,
|
|
| 2375 | + -- and is a noop for W32 (safe: SMULL reads both sources
|
|
| 2376 | + -- atomically before writing the destination).
|
|
| 2377 | + (reg_a, _format_x, code_a) <- someReg =<< signExtendRegister w W32 <$> getRegister src_a
|
|
| 2378 | + (reg_b, _format_y, code_b) <- someReg =<< signExtendRegister w W32 <$> getRegister src_b
|
|
| 2332 | 2379 | |
| 2333 | 2380 | let lo = getRegisterReg platform (CmmLocal dst_lo)
|
| 2334 | 2381 | hi = getRegisterReg platform (CmmLocal dst_hi)
|
| 2335 | 2382 | nd = getRegisterReg platform (CmmLocal dst_needed)
|
| 2336 | 2383 | w' = platformWordWidth platform
|
| 2337 | 2384 | |
| 2338 | - -- Sign-extend inputs to W32 for SMULL (Xd = Wn * Wm).
|
|
| 2339 | - -- signExtendReg always allocates a fresh temp for w < W32,
|
|
| 2340 | - -- and is a noop for W32 (safe: SMULL reads both sources
|
|
| 2341 | - -- atomically before writing the destination).
|
|
| 2342 | - (reg_a, code_a') <- signExtendReg w W32 reg_a'
|
|
| 2343 | - (reg_b, code_b') <- signExtendReg w W32 reg_b'
|
|
| 2344 | - |
|
| 2345 | 2385 | return $
|
| 2346 | 2386 | code_a `appOL`
|
| 2347 | - code_b `appOL`
|
|
| 2348 | - code_a' `appOL`
|
|
| 2349 | - code_b' `snocOL`
|
|
| 2387 | + code_b `snocOL`
|
|
| 2350 | 2388 | -- SMULL Xd, Wn, Wm: multiply two W32 values producing a
|
| 2351 | 2389 | -- 64-bit result. The low w bits of lo contain the truncated
|
| 2352 | 2390 | -- product, and hi gets the overflow (sign extension bits).
|
| 2353 | 2391 | SMULL (OpReg w' lo) (OpReg W32 reg_a) (OpReg W32 reg_b) `snocOL`
|
| 2354 | 2392 | ASR (OpReg w' hi) (OpReg w' lo) (OpImm (ImmInt $ widthInBits w)) `appOL`
|
| 2355 | - truncateReg w' w lo `snocOL`
|
|
| 2393 | + truncateSubwordRegInplace w lo `snocOL`
|
|
| 2356 | 2394 | -- CMN (compare negative) tests hi + lo' == 0, i.e. hi == -lo'.
|
| 2357 | 2395 | -- lo' = LSR(lo, w-1) gives 1 if lo is negative, 0 if positive.
|
| 2358 | 2396 | -- No overflow iff hi is the sign extension of lo:
|
| ... | ... | @@ -2362,7 +2400,7 @@ genCCall target dest_regs arg_regs = do |
| 2362 | 2400 | -- NE to set nd = 1 when overflow occurred.
|
| 2363 | 2401 | CMN (OpReg w' hi) (OpRegShift w' lo SLSR (widthInBits w - 1)) `snocOL`
|
| 2364 | 2402 | CSET (OpReg w' nd) NE `appOL`
|
| 2365 | - truncateReg w' w hi
|
|
| 2403 | + truncateSubwordRegInplace w hi
|
|
| 2366 | 2404 | -- Can't handle > 64 bit operands
|
| 2367 | 2405 | | otherwise -> unsupported (MO_S_Mul2 w)
|
| 2368 | 2406 | PrimTarget (MO_U_Mul2 w)
|
| ... | ... | @@ -2385,7 +2423,7 @@ genCCall target dest_regs arg_regs = do |
| 2385 | 2423 | )
|
| 2386 | 2424 | -- For sizes < platform width, we can just perform a multiply and shift
|
| 2387 | 2425 | -- Need to be careful to truncate the low half, but the upper half should be
|
| 2388 | - -- be ok if the invariant in [Signed arithmetic on AArch64] is maintained.
|
|
| 2426 | + -- be ok if the invariant in Note [Subword operations on AArch64] is maintained.
|
|
| 2389 | 2427 | -- Currently this case can't be produced by the compiler since
|
| 2390 | 2428 | -- timesWord2# :: Word# -> Word# -> (# Word#, Word# #)
|
| 2391 | 2429 | -- TODO: Remove? Or would the extra primop be useful for avoiding the extra
|
| ... | ... | @@ -2412,7 +2450,7 @@ genCCall target dest_regs arg_regs = do |
| 2412 | 2450 | (OpImm (ImmInt $ widthInBits w)) -- lsb
|
| 2413 | 2451 | (OpImm (ImmInt $ widthInBits w)) -- width to extract
|
| 2414 | 2452 | `appOL`
|
| 2415 | - truncateReg W64 w lo
|
|
| 2453 | + truncateSubwordRegInplace w lo
|
|
| 2416 | 2454 | )
|
| 2417 | 2455 | | otherwise -> unsupported (MO_U_Mul2 w)
|
| 2418 | 2456 | PrimTarget (MO_Clz w)
|
| ... | ... | @@ -2730,6 +2768,7 @@ genCCall target dest_regs arg_regs = do |
| 2730 | 2768 | | [p_reg, val_reg] <- arg_regs -> do
|
| 2731 | 2769 | (p, _fmt_p, code_p) <- getSomeReg p_reg
|
| 2732 | 2770 | (val, fmt_val, code_val) <- getSomeReg val_reg
|
| 2771 | + massert (fmt_val == intFormat w)
|
|
| 2733 | 2772 | let instr = case ord of
|
| 2734 | 2773 | MemOrderRelaxed -> STR
|
| 2735 | 2774 | _ -> STLR
|
| ... | ... | @@ -2845,6 +2884,7 @@ genCCall target dest_regs arg_regs = do |
| 2845 | 2884 | W16 -> SXTH (OpReg W64 gpReg) (OpReg w r)
|
| 2846 | 2885 | _ -> panic "impossible"
|
| 2847 | 2886 | | otherwise
|
| 2887 | + -- Relies on Note [Subword operations on AArch64]
|
|
| 2848 | 2888 | = MOV (OpReg w gpReg) (OpReg w r)
|
| 2849 | 2889 | accumCode' = accumCode `appOL`
|
| 2850 | 2890 | code_r `snocOL`
|
| ... | ... | @@ -2898,6 +2938,7 @@ genCCall target dest_regs arg_regs = do |
| 2898 | 2938 | |
| 2899 | 2939 | passArguments _ _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state")
|
| 2900 | 2940 | |
| 2941 | + -- readResults gpArgs fpArgs dest_regs reg_acc code_acc
|
|
| 2901 | 2942 | readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM (InstrBlock)
|
| 2902 | 2943 | readResults _ _ [] _ accumCode = return accumCode
|
| 2903 | 2944 | readResults [] _ _ _ _ = do
|
| ... | ... | @@ -2915,7 +2956,14 @@ genCCall target dest_regs arg_regs = do |
| 2915 | 2956 | r_dst = getRegisterReg platform (CmmLocal dst)
|
| 2916 | 2957 | if isFloatFormat format || isVecFormat format
|
| 2917 | 2958 | then readResults (gpReg:gpRegs) fpRegs dsts (fpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg))
|
| 2918 | - else readResults gpRegs (fpReg:fpRegs) dsts (gpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w gpReg))
|
|
| 2959 | + else do
|
|
| 2960 | + -- Needed, ffi calls can return garbage in high bits.
|
|
| 2961 | + -- See Note [Subword operations on AArch64]
|
|
| 2962 | + let !mov_instr = case w of
|
|
| 2963 | + W8 -> UXTB
|
|
| 2964 | + W16 -> UXTH
|
|
| 2965 | + _ -> MOV
|
|
| 2966 | + readResults gpRegs (fpReg:fpRegs) dsts (gpReg:accumRegs) (accumCode `snocOL` mov_instr (OpReg w r_dst) (OpReg w gpReg))
|
|
| 2919 | 2967 | |
| 2920 | 2968 | unaryFloatOp w op arg_reg dest_reg = do
|
| 2921 | 2969 | platform <- getPlatform
|
| ... | ... | @@ -771,7 +771,8 @@ data Instr |
| 771 | 771 | | MOVZ Operand Operand
|
| 772 | 772 | | MVN Operand Operand -- rd = ~rn
|
| 773 | 773 | | ORR Format Operand Operand Operand -- rd = rn | op2
|
| 774 | - -- Load and stores.
|
|
| 774 | + -- Load and stores, we support subwords by picking the subword variant
|
|
| 775 | + -- based on the format.
|
|
| 775 | 776 | -- TODO STR/LDR might want to change to STP/LDP with XZR for the second register.
|
| 776 | 777 | | STR Format Operand Operand -- str Xn, address-mode // Xn -> *addr
|
| 777 | 778 | | STLR Format Operand Operand -- stlr Xn, address-mode // Xn -> *addr
|
| ... | ... | @@ -569,12 +569,8 @@ pprInstr platform instr = case instr of |
| 569 | 569 | -- NOTE: GHC may do whacky things where it only load the lower part of an
|
| 570 | 570 | -- address. Not observing the correct size when loading will lead
|
| 571 | 571 | -- inevitably to crashes.
|
| 572 | - STR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 ->
|
|
| 573 | - op2 (text "\tstrb") o1 o2
|
|
| 574 | - STR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 ->
|
|
| 575 | - op2 (text "\tstrh") o1 o2
|
|
| 576 | - STR _f o1 o2 -> op2 (text "\tstr") o1 o2
|
|
| 577 | - STLR _f o1 o2 -> op2 (text "\tstlr") o1 o2
|
|
| 572 | + STR f o1 o2 -> op2 (subword_suffix f $ text "\tstr") o1 o2
|
|
| 573 | + STLR f o1 o2 -> op2 (subword_suffix f $ text "\tstlr") o1 o2
|
|
| 578 | 574 | |
| 579 | 575 | LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->
|
| 580 | 576 | let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in
|
| ... | ... | @@ -622,12 +618,8 @@ pprInstr platform instr = case instr of |
| 622 | 618 | op_adrp o1 adrp' $$
|
| 623 | 619 | op_add o1 ldr'
|
| 624 | 620 | |
| 625 | - LDR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 ->
|
|
| 626 | - op2 (text "\tldrb") o1 o2
|
|
| 627 | - LDR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 ->
|
|
| 628 | - op2 (text "\tldrh") o1 o2
|
|
| 629 | - LDR _f o1 o2 -> op2 (text "\tldr") o1 o2
|
|
| 630 | - LDAR _f o1 o2 -> op2 (text "\tldar") o1 o2
|
|
| 621 | + LDR f o1 o2 -> op2 (subword_suffix f $ text "\tldr") o1 o2
|
|
| 622 | + LDAR f o1 o2 -> op2 (subword_suffix f $ text "\tldar") o1 o2
|
|
| 631 | 623 | |
| 632 | 624 | -- 8. Synchronization Instructions -------------------------------------------
|
| 633 | 625 | DMBISH DmbLoadStore -> line $ text "\tdmb ish"
|
| ... | ... | @@ -698,6 +690,12 @@ pprInstr platform instr = case instr of |
| 698 | 690 | check_off off = if off >= 0 && off <= 4095 then char '#' <> int off else
|
| 699 | 691 | pgmError $ "GHC.CmmToAsm.AArch64.Ppr.check_off : " ++ show off ++ " is out of 12 bit"
|
| 700 | 692 | |
| 693 | + -- Some instructions encode subword ops via b/h suffix on the instruction.
|
|
| 694 | + -- We handle this here relying on the format rather than the operands.
|
|
| 695 | + subword_suffix II8 t = t <> char 'b'
|
|
| 696 | + subword_suffix II16 t = t <> char 'h'
|
|
| 697 | + subword_suffix _ t = t
|
|
| 698 | + |
|
| 701 | 699 | pprBcond :: IsLine doc => Cond -> doc
|
| 702 | 700 | pprBcond c = text "b." <> pprCond c
|
| 703 | 701 |
| ... | ... | @@ -16,16 +16,3 @@ T16930: |
| 16 | 16 | |
| 17 | 17 | T23610:
|
| 18 | 18 | '$(TEST_HC)' $(TEST_HC_OPTS) T23610.cmm -S |
| 19 | - |
|
| 20 | -# The three seds below, in order:
|
|
| 21 | -# 1. Keep only the "Parsed Cmm" dump, since that is the one stage where the
|
|
| 22 | -# unreachable block still exists.
|
|
| 23 | -# 2. Rewrite goto targets: their label uniques survive -dsuppress-uniques
|
|
| 24 | -# (#21310).
|
|
| 25 | -# 3. Drop the "// CmmAssign"-style node annotations, which pprNode emits
|
|
| 26 | -# only on DEBUG compilers.
|
|
| 27 | -T27368-ppr-debug:
|
|
| 28 | - '$(TEST_HC)' $(TEST_HC_OPTS) -c -no-hs-main -ddump-cmm-verbose-by-proc -dppr-debug -dsuppress-uniques -dsuppress-ticks T27368-ppr-debug.cmm 2>&1 \
|
|
| 29 | - | sed -n '/^==* Parsed Cmm/,/^ \}\]/p' \
|
|
| 30 | - | sed 's/goto c[0-9A-Za-z]*/goto _lbl_/g' \
|
|
| 31 | - | sed 's| *// Cmm[A-Za-z]*$$||' |
| 1 | + |
|
| 2 | +==================== Parsed Cmm ====================
|
|
| 3 | +[testUnreachable() { // [R1]
|
|
| 4 | + { info_tbls: []
|
|
| 5 | + stack_info: arg_space: 8
|
|
| 6 | + }
|
|
| 7 | + {offset
|
|
| 8 | + c7: // global
|
|
| 9 | + _c1::I64 = R1;
|
|
| 10 | + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)>
|
|
| 11 | + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4;
|
|
| 12 | + c2: // global
|
|
| 13 | + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)>
|
|
| 14 | + goto c6;
|
|
| 15 | + c6: // global
|
|
| 16 | + //tick src<T27368-ppr-debug.cmm:17:5-12>
|
|
| 17 | + _c1::I64 = _c1::I64 (-[W64]) 1;
|
|
| 18 | + R1 = _c1::I64;
|
|
| 19 | + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
|
|
| 20 | + c4: // global
|
|
| 21 | + goto c3;
|
|
| 22 | + c3: // global
|
|
| 23 | + R1 = _c1::I64;
|
|
| 24 | + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
|
|
| 25 | + // unreachable blocks:
|
|
| 26 | + c5: // global
|
|
| 27 | + //tick src<T27368-ppr-debug.cmm:13:5-13>
|
|
| 28 | + _c1::I64 = _c1::I64 (+[W64]) 42;
|
|
| 29 | + R1 = _c1::I64;
|
|
| 30 | + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
|
|
| 31 | + }
|
|
| 32 | + }]
|
|
| 33 | + |
|
| 34 | + |
|
| 35 | + |
|
| 36 | +==================== Post control-flow optimisations (1) ====================
|
|
| 37 | +testUnreachable
|
|
| 38 | +{offset
|
|
| 39 | + c7: // global
|
|
| 40 | + _c1::I64 = R1;
|
|
| 41 | + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)>
|
|
| 42 | + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4;
|
|
| 43 | + c2: // global
|
|
| 44 | + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)>
|
|
| 45 | + //tick src<T27368-ppr-debug.cmm:17:5-12>
|
|
| 46 | + _c1::I64 = _c1::I64 (-[W64]) 1;
|
|
| 47 | + R1 = _c1::I64;
|
|
| 48 | + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
|
|
| 49 | + c4: // global
|
|
| 50 | + R1 = _c1::I64;
|
|
| 51 | + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
|
|
| 52 | +}
|
|
| 53 | + |
|
| 54 | + |
|
| 55 | + |
|
| 56 | +==================== Post switch plan ====================
|
|
| 57 | +testUnreachable
|
|
| 58 | +{offset
|
|
| 59 | + c7: // global
|
|
| 60 | + _c1::I64 = R1;
|
|
| 61 | + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)>
|
|
| 62 | + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4;
|
|
| 63 | + c2: // global
|
|
| 64 | + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)>
|
|
| 65 | + //tick src<T27368-ppr-debug.cmm:17:5-12>
|
|
| 66 | + _c1::I64 = _c1::I64 (-[W64]) 1;
|
|
| 67 | + R1 = _c1::I64;
|
|
| 68 | + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
|
|
| 69 | + c4: // global
|
|
| 70 | + R1 = _c1::I64;
|
|
| 71 | + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
|
|
| 72 | +}
|
|
| 73 | + |
|
| 74 | + |
|
| 75 | + |
|
| 76 | +==================== ThreadSanitizer instrumentation ====================
|
|
| 77 | +testUnreachable
|
|
| 78 | +{offset
|
|
| 79 | + c7: // global
|
|
| 80 | + _c1::I64 = R1;
|
|
| 81 | + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)>
|
|
| 82 | + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4;
|
|
| 83 | + c2: // global
|
|
| 84 | + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)>
|
|
| 85 | + //tick src<T27368-ppr-debug.cmm:17:5-12>
|
|
| 86 | + _c1::I64 = _c1::I64 (-[W64]) 1;
|
|
| 87 | + R1 = _c1::I64;
|
|
| 88 | + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
|
|
| 89 | + c4: // global
|
|
| 90 | + R1 = _c1::I64;
|
|
| 91 | + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
|
|
| 92 | +}
|
|
| 93 | + |
|
| 94 | + |
|
| 95 | + |
|
| 96 | +==================== Layout Stack ====================
|
|
| 97 | +testUnreachable
|
|
| 98 | +{offset
|
|
| 99 | + c7: // global
|
|
| 100 | + _c1::I64 = R1;
|
|
| 101 | + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)>
|
|
| 102 | + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4;
|
|
| 103 | + c2: // global
|
|
| 104 | + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)>
|
|
| 105 | + //tick src<T27368-ppr-debug.cmm:17:5-12>
|
|
| 106 | + _c1::I64 = _c1::I64 (-[W64]) 1;
|
|
| 107 | + R1 = _c1::I64;
|
|
| 108 | + call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
|
|
| 109 | + c4: // global
|
|
| 110 | + R1 = _c1::I64;
|
|
| 111 | + call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
|
|
| 112 | +}
|
|
| 113 | + |
|
| 114 | + |
|
| 115 | + |
|
| 116 | +==================== CAFEnv ====================
|
|
| 117 | +[(c2, {}), (c4, {}), (c7, {})]
|
|
| 118 | + |
|
| 119 | + |
|
| 120 | + |
|
| 121 | +==================== after setInfoTableStackMap ====================
|
|
| 122 | +testUnreachable() { // [R1]
|
|
| 123 | + { info_tbls: []
|
|
| 124 | + stack_info: arg_space: 8
|
|
| 125 | + }
|
|
| 126 | + {offset
|
|
| 127 | + c7: // global
|
|
| 128 | + _c1::I64 = R1;
|
|
| 129 | + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)>
|
|
| 130 | + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4;
|
|
| 131 | + c2: // global
|
|
| 132 | + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)>
|
|
| 133 | + //tick src<T27368-ppr-debug.cmm:17:5-12>
|
|
| 134 | + _c1::I64 = _c1::I64 (-[W64]) 1;
|
|
| 135 | + R1 = _c1::I64;
|
|
| 136 | + call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
|
|
| 137 | + c4: // global
|
|
| 138 | + R1 = _c1::I64;
|
|
| 139 | + call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
|
|
| 140 | + }
|
|
| 141 | +}
|
|
| 142 | + |
|
| 143 | + |
|
| 144 | + |
|
| 145 | +==================== Post control-flow optimisations (2) ====================
|
|
| 146 | +testUnreachable() { // [R1]
|
|
| 147 | + { info_tbls: []
|
|
| 148 | + stack_info: arg_space: 8
|
|
| 149 | + }
|
|
| 150 | + {offset
|
|
| 151 | + c7: // global
|
|
| 152 | + _c1::I64 = R1;
|
|
| 153 | + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)>
|
|
| 154 | + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4;
|
|
| 155 | + c2: // global
|
|
| 156 | + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)>
|
|
| 157 | + //tick src<T27368-ppr-debug.cmm:17:5-12>
|
|
| 158 | + _c1::I64 = _c1::I64 (-[W64]) 1;
|
|
| 159 | + R1 = _c1::I64;
|
|
| 160 | + call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
|
|
| 161 | + c4: // global
|
|
| 162 | + R1 = _c1::I64;
|
|
| 163 | + call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
|
|
| 164 | + }
|
|
| 165 | +}
|
|
| 166 | + |
|
| 167 | + |
|
| 168 | + |
|
| 169 | +==================== Post CPS Cmm ====================
|
|
| 170 | +[testUnreachable() { // [R1]
|
|
| 171 | + { info_tbls: []
|
|
| 172 | + stack_info: arg_space: 8
|
|
| 173 | + }
|
|
| 174 | + {offset
|
|
| 175 | + c7: // global
|
|
| 176 | + _c1::I64 = R1;
|
|
| 177 | + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)>
|
|
| 178 | + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4;
|
|
| 179 | + c2: // global
|
|
| 180 | + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)>
|
|
| 181 | + //tick src<T27368-ppr-debug.cmm:17:5-12>
|
|
| 182 | + _c1::I64 = _c1::I64 (-[W64]) 1;
|
|
| 183 | + R1 = _c1::I64;
|
|
| 184 | + call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
|
|
| 185 | + c4: // global
|
|
| 186 | + R1 = _c1::I64;
|
|
| 187 | + call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
|
|
| 188 | + }
|
|
| 189 | + }]
|
|
| 190 | + |
|
| 191 | + |
| 1 | -==================== Parsed Cmm ====================
|
|
| 2 | -[testUnreachable() { // [R1]
|
|
| 3 | - { info_tbls: []
|
|
| 4 | - stack_info: arg_space: 8
|
|
| 5 | - }
|
|
| 6 | - {offset
|
|
| 7 | - _lbl_:
|
|
| 8 | - __locVar_::I64 = R1;
|
|
| 9 | - if (__locVar_::I64 > 0) goto _lbl_; else goto _lbl_;
|
|
| 10 | - _lbl_:
|
|
| 11 | - goto _lbl_;
|
|
| 12 | - _lbl_:
|
|
| 13 | - __locVar_::I64 = __locVar_::I64 - 1;
|
|
| 14 | - R1 = __locVar_::I64;
|
|
| 15 | - call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
|
|
| 16 | - _lbl_:
|
|
| 17 | - goto _lbl_;
|
|
| 18 | - _lbl_:
|
|
| 19 | - R1 = __locVar_::I64;
|
|
| 20 | - call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
|
|
| 21 | - // unreachable blocks:
|
|
| 22 | - _lbl_:
|
|
| 23 | - __locVar_::I64 = __locVar_::I64 + 42;
|
|
| 24 | - R1 = __locVar_::I64;
|
|
| 25 | - call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
|
|
| 26 | - }
|
|
| 27 | - }] |
| ... | ... | @@ -13,11 +13,9 @@ test('T20725', normal, compile, ['-package ghc']) |
| 13 | 13 | test('T23610', normal, makefile_test, ['T23610'])
|
| 14 | 14 | test('T24224', [cmm_src, grep_errmsg(r'(F64.*);', [1]), only_ways(['normal'])], compile, ['-no-hs-main -ddump-cmm -dsuppress-all -dsuppress-uniques'])
|
| 15 | 15 | test('T24474', cmm_src, compile, ['-optc-g3'])
|
| 16 | -# -dppr-debug makes stored-but-unreachable blocks visible in Cmm dumps (#27368).
|
|
| 17 | -# Skipped on wordsize(32) targets, where the dump would say I32/P32, and on
|
|
| 18 | -# unregisterised builds, which print call targets with an extra load.
|
|
| 19 | -test('T27368-ppr-debug', [when(wordsize(32), skip), when(unregisterised(), skip)],
|
|
| 20 | - makefile_test, ['T27368-ppr-debug'])
|
|
| 16 | +# Grep for a `... = + .. 42 ..;` occurence from within the dead code block in the cmm dump output.
|
|
| 17 | +test('T27368-ppr-debug', [cmm_src, only_ways(['normal']), grep_errmsg(r'\=.*\+.*(42;)', [1])],
|
|
| 18 | + compile, ['-no-hs-main -ddump-cmm-verbose-by-proc -dppr-debug'])
|
|
| 21 | 19 | test('T24474-cmm-gets-c-opts', cmm_src, compile, ['-optc-DFOO'])
|
| 22 | 20 | test('T24474-cmm-opt-order', cmm_src, compile, ['-optc-DFOO '
|
| 23 | 21 | '-optCmmP-UFOO '
|
| 1 | +{-# LANGUAGE MagicHash #-}
|
|
| 2 | + |
|
| 3 | +import GHC.Exts
|
|
| 4 | +import Data.Bits
|
|
| 5 | +import GHC.Word
|
|
| 6 | + |
|
| 7 | +foreign import ccall unsafe "u64_to_u8" u64_to_u8 :: Word64 -> Word8
|
|
| 8 | +foreign import ccall unsafe "u64_to_u16" u64_to_u16 :: Word64 -> Word16
|
|
| 9 | +foreign import ccall unsafe "u64_to_u32" u64_to_u32 :: Word64 -> Word32
|
|
| 10 | + |
|
| 11 | +x :: Word64
|
|
| 12 | +x = 5
|
|
| 13 | + |
|
| 14 | +-- Those should give just x when truncated.
|
|
| 15 | +y8,y16,y32 :: Word64
|
|
| 16 | +y8 = setBit x 8
|
|
| 17 | +y16 = setBit x 16
|
|
| 18 | +y32 = setBit x 32
|
|
| 19 | + |
|
| 20 | +eq8 :: Word8 -> Word8 -> Int
|
|
| 21 | +eq8 (W8# a) (W8# b) = I# (eqWord8# a b)
|
|
| 22 | + |
|
| 23 | +eq16 :: Word16 -> Word16 -> Int
|
|
| 24 | +eq16 (W16# a) (W16# b) = I# (eqWord16# a b)
|
|
| 25 | + |
|
| 26 | +eq32 :: Word32 -> Word32 -> Int
|
|
| 27 | +eq32 (W32# a) (W32# b) = I# (eqWord32# a b)
|
|
| 28 | + |
|
| 29 | +{-# NOINLINE outline_eq8 #-}
|
|
| 30 | +outline_eq8 = eq8
|
|
| 31 | +{-# NOINLINE outline_eq16 #-}
|
|
| 32 | +outline_eq16 = eq16
|
|
| 33 | +{-# NOINLINE outline_eq32 #-}
|
|
| 34 | +outline_eq32 = eq32
|
|
| 35 | + |
|
| 36 | +main :: IO ()
|
|
| 37 | +main = do
|
|
| 38 | + print (eq8 (u64_to_u8 x) (u64_to_u8 y8))
|
|
| 39 | + print (eq16 (u64_to_u16 x) (u64_to_u16 y16))
|
|
| 40 | + print (eq32 (u64_to_u32 x) (u64_to_u32 y32))
|
|
| 41 | + |
|
| 42 | + print (outline_eq8 (u64_to_u8 x) (u64_to_u8 y8))
|
|
| 43 | + print (outline_eq16 (u64_to_u16 x) (u64_to_u16 y16))
|
|
| 44 | + print (outline_eq32 (u64_to_u32 x) (u64_to_u32 y32)) |
| 1 | +1
|
|
| 2 | +1
|
|
| 3 | +1
|
|
| 4 | +1
|
|
| 5 | +1
|
|
| 6 | +1 |
| 1 | +#include <stdint.h>
|
|
| 2 | + |
|
| 3 | +uint8_t u64_to_u8(uint64_t v) { return (uint8_t)v; }
|
|
| 4 | +uint16_t u64_to_u16(uint64_t v) { return (uint16_t)v; }
|
|
| 5 | +uint32_t u64_to_u32(uint64_t v) { return (uint32_t)v; } |
| 1 | +{-# LANGUAGE MagicHash, UnboxedTuples, GHCForeignImportPrim, UnliftedFFITypes #-}
|
|
| 2 | + |
|
| 3 | +import GHC.Exts
|
|
| 4 | +import GHC.IO (IO(..))
|
|
| 5 | +import Foreign.Marshal.Alloc (allocaBytes)
|
|
| 6 | +import Foreign.Marshal.Utils (fillBytes)
|
|
| 7 | +import Foreign.Ptr (Ptr(..))
|
|
| 8 | +import Data.Word (Word8)
|
|
| 9 | +import Numeric (showHex)
|
|
| 10 | +import System.IO
|
|
| 11 | + |
|
| 12 | +foreign import prim "store8" store8# :: Addr# -> Word#
|
|
| 13 | +foreign import prim "load8" load8# :: Addr# -> Word#
|
|
| 14 | + |
|
| 15 | +-- Read one byte at a given byte offset. Working a byte at a time keeps the
|
|
| 16 | +-- test independent of both endianness and word size: the buffer contents are
|
|
| 17 | +-- a fixed sequence of bytes in address order, whereas a word-sized read of
|
|
| 18 | +-- the same buffer would give 0x..43 on little-endian and 0x43.. on big-endian.
|
|
| 19 | +readByte :: Addr# -> Int -> IO Word
|
|
| 20 | +readByte a (I# i) =
|
|
| 21 | + IO (\s -> case readWord8OffAddr# a i s of
|
|
| 22 | + (# s', v #) -> (# s', W# (word8ToWord# v) #))
|
|
| 23 | + |
|
| 24 | +main :: IO ()
|
|
| 25 | +main = do
|
|
| 26 | + hSetBuffering stdout NoBuffering
|
|
| 27 | + allocaBytes 8 $ \p@(Ptr a) -> do
|
|
| 28 | + -- 1. Silent corruption: release-store of 1 byte into an all-ones buffer.
|
|
| 29 | + -- The store must touch byte 0 and leave bytes 1..7 alone; a buggy NCG
|
|
| 30 | + -- widens it to a 4-byte store and zeroes bytes 1..3.
|
|
| 31 | + fillBytes p (0xFF :: Word8) 8
|
|
| 32 | + case store8# a of _ -> return () -- case on unlifted Word# forces the call
|
|
| 33 | + bs <- mapM (readByte a) [0 .. 7]
|
|
| 34 | + putStrLn ("after 1-byte release-store: " ++ unwords (map (\b -> showHex b "") bs))
|
|
| 35 | + -- expected 43 ff ff ff ff ff ff ff
|
|
| 36 | + -- buggy NCG gives 43 0 0 0 ff ff ff ff
|
|
| 37 | + |
|
| 38 | + -- 2. SIGBUS: acquire-load of 1 byte at an odd address (well-defined).
|
|
| 39 | + r <- IO (\s -> (# s, W# (load8# (a `plusAddr#` 1#)) #))
|
|
| 40 | + putStrLn ("acquire byte load at p+1: 0x" ++ showHex r "")
|
|
| 41 | + -- expected 0xff; buggy NCG dies with SIGBUS before printing |
| 1 | +after 1-byte release-store: 43 ff ff ff ff ff ff ff
|
|
| 2 | +acquire byte load at p+1: 0xff |
| 1 | +#include "Cmm.h"
|
|
| 2 | + |
|
| 3 | +// Release-store one byte at p. Must touch exactly 1 byte.
|
|
| 4 | +store8 (W_ p) {
|
|
| 5 | + %release I8[p] = 67 :: I8;
|
|
| 6 | + return (0);
|
|
| 7 | +}
|
|
| 8 | + |
|
| 9 | +// Acquire-load one byte from p.
|
|
| 10 | +load8 (W_ p) {
|
|
| 11 | + I8 v;
|
|
| 12 | + v = %acquire I8[p];
|
|
| 13 | + return (%zx64(v));
|
|
| 14 | +} |
| 1 | +{-# LANGUAGE MagicHash #-}
|
|
| 2 | + |
|
| 3 | +import GHC.Exts
|
|
| 4 | + |
|
| 5 | +{-# NOINLINE lt8 #-}
|
|
| 6 | +lt8 :: Int -> Word -> Int -- ltWord8# 254 255: must be 1
|
|
| 7 | +lt8 (I# m) (W# n) = I# (ltWord8# (int8ToWord8# (intToInt8# m)) (wordToWord8# n))
|
|
| 8 | + |
|
| 9 | +{-# NOINLINE eq8 #-}
|
|
| 10 | +eq8 :: Int -> Word -> Int -- eqWord8# 254 254: must be 1
|
|
| 11 | +eq8 (I# m) (W# n) = I# (eqWord8# (int8ToWord8# (intToInt8# m)) (wordToWord8# n))
|
|
| 12 | + |
|
| 13 | +{-# NOINLINE eqi16 #-}
|
|
| 14 | +eqi16 :: Int -> Int -> Int -- eqInt16# (-2) (-2): must be 1
|
|
| 15 | +eqi16 (I# m) (I# n) = I# (eqInt16# (intToInt16# m) (word16ToInt16# (wordToWord16# (int2Word# n))))
|
|
| 16 | + |
|
| 17 | +{-# NOINLINE rem8 #-}
|
|
| 18 | +rem8 :: Int -> Word -> Word -- remWord8# 254 100: must be 54
|
|
| 19 | +rem8 (I# m) (W# n) = W# (word8ToWord# (remWord8# (int8ToWord8# (intToInt8# m)) (wordToWord8# n)))
|
|
| 20 | + |
|
| 21 | +main :: IO ()
|
|
| 22 | +main = do
|
|
| 23 | + print (lt8 (-2) 255)
|
|
| 24 | + print (eq8 (-2) 254)
|
|
| 25 | + print (eqi16 (-2) 65534)
|
|
| 26 | + print (rem8 (-2) 100) |
| 1 | +1
|
|
| 2 | +1
|
|
| 3 | +1
|
|
| 4 | +54 |
| 1 | +{-# LANGUAGE MagicHash #-}
|
|
| 2 | + |
|
| 3 | +import GHC.Exts
|
|
| 4 | + |
|
| 5 | +{-# NOINLINE ix #-}
|
|
| 6 | +ix :: Int
|
|
| 7 | +ix = 0
|
|
| 8 | + |
|
| 9 | +{-# NOINLINE f #-}
|
|
| 10 | +f :: Int8# -> Int#
|
|
| 11 | +f x = if isTrue# (x `ltInt8#` intToInt8# 0#)
|
|
| 12 | + then (int8ToWord8# x) `gtWord8#` wordToWord8# 200##
|
|
| 13 | + else 1#
|
|
| 14 | + |
|
| 15 | +main :: IO ()
|
|
| 16 | +main = do
|
|
| 17 | + -- Test for use of byte-width read.
|
|
| 18 | + let !(I# i) = ix
|
|
| 19 | + x = indexInt8OffAddr# "\x80"# i
|
|
| 20 | + putStrLn ("f(0x80) = " ++ show (I# (f x))) |
| 1 | +f(0x80) = 0 |
| ... | ... | @@ -295,3 +295,12 @@ test('aarch64-sxtw-run', |
| 295 | 295 | when(unregisterised(), skip)],
|
| 296 | 296 | multi_compile_and_run,
|
| 297 | 297 | ['aarch64-sxtw-run', [('aarch64-sxtw-cmm.cmm', '')], '-O'])
|
| 298 | + |
|
| 299 | +test('T27430', [req_c, extra_ways(['optasm'])], compile_and_run, ['T27430_c.c'])
|
|
| 300 | + |
|
| 301 | +test('T27533', [req_cmm, extra_ways(['optasm'])], multi_compile_and_run,
|
|
| 302 | + ['T27533', [('T27533_cmm.cmm', '')], '-O'])
|
|
| 303 | + |
|
| 304 | +test('T27537', normal, compile_and_run, ['-O'])
|
|
| 305 | + |
|
| 306 | +test('T27538', normal, compile_and_run, ['-O']) |
| 1 | +{-# LANGUAGE MagicHash, UnboxedTuples #-}
|
|
| 2 | +module Main (main) where
|
|
| 3 | +import GHC.Exts
|
|
| 4 | +import GHC.Int (Int8(..), Int16(..), Int32(..), Int64(..))
|
|
| 5 | + |
|
| 6 | +{-# OPAQUE broadcast_i8 #-}
|
|
| 7 | +broadcast_i8 :: Int8# -> Int8X16#
|
|
| 8 | +broadcast_i8 x = broadcastInt8X16# x
|
|
| 9 | + |
|
| 10 | +{-# OPAQUE broadcast_i16 #-}
|
|
| 11 | +broadcast_i16 :: Int16# -> Int16X8#
|
|
| 12 | +broadcast_i16 x = broadcastInt16X8# x
|
|
| 13 | + |
|
| 14 | +{-# OPAQUE broadcast_i32 #-}
|
|
| 15 | +broadcast_i32 :: Int32# -> Int32X4#
|
|
| 16 | +broadcast_i32 x = broadcastInt32X4# x
|
|
| 17 | + |
|
| 18 | +{-# OPAQUE broadcast_i64 #-}
|
|
| 19 | +broadcast_i64 :: Int64# -> Int64X2#
|
|
| 20 | +broadcast_i64 x = broadcastInt64X2# x
|
|
| 21 | + |
|
| 22 | +main :: IO ()
|
|
| 23 | +main = do
|
|
| 24 | + case unpackInt8X16# (broadcast_i8 (intToInt8# 32#)) of
|
|
| 25 | + (# a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15 #) ->
|
|
| 26 | + print [ I8# a0, I8# a1, I8# a2, I8# a3, I8# a4, I8# a5, I8# a6, I8# a7
|
|
| 27 | + , I8# a8, I8# a9, I8# a10, I8# a11, I8# a12, I8# a13, I8# a14, I8# a15 ]
|
|
| 28 | + case unpackInt16X8# (broadcast_i16 (intToInt16# 32#)) of
|
|
| 29 | + (# b0,b1,b2,b3,b4,b5,b6,b7 #) ->
|
|
| 30 | + print [ I16# b0, I16# b1, I16# b2, I16# b3, I16# b4, I16# b5, I16# b6, I16# b7 ]
|
|
| 31 | + case unpackInt32X4# (broadcast_i32 (intToInt32# 32#)) of
|
|
| 32 | + (# c0,c1,c2,c3 #) ->
|
|
| 33 | + print [ I32# c0, I32# c1, I32# c2, I32# c3 ]
|
|
| 34 | + case unpackInt64X2# (broadcast_i64 (intToInt64# 32#)) of
|
|
| 35 | + (# d0,d1 #) ->
|
|
| 36 | + print [ I64# d0, I64# d1 ] |
| 1 | +[32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32]
|
|
| 2 | +[32,32,32,32,32,32,32,32]
|
|
| 3 | +[32,32,32,32]
|
|
| 4 | +[32,32] |
| ... | ... | @@ -217,3 +217,5 @@ test('StackAlignment64' |
| 217 | 217 | , compile_and_run if have_cpu_feature('avx512f') else compile
|
| 218 | 218 | , ['StackAlignment64_main.c']
|
| 219 | 219 | )
|
| 220 | + |
|
| 221 | +test('T27565', [], compile_and_run, ['']) |