Andreas Klebinger pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC

Commits:

26 changed files:

Changes:

  • changelog.d/arm_ncg_fixes_T27430
    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.

  • compiler/GHC/Cmm/Expr.hs
    ... ... @@ -445,8 +445,8 @@ pprExpr platform e
    445 445
    446 446 
     -- | `op` usually, but `(op[width])` with -dppr-debug
    447 447 
     withDebugWidth :: Width -> SDoc -> SDoc
    448 
    -withDebugWidth w exp =
    449 
    -  ifPprDebug (parens (exp <> brackets (ppr w))) exp
    448 
    +withDebugWidth w doc =
    449 
    +  ifPprDebug (parens (doc <> brackets (ppr w))) doc
    450 450
    451 451 
     -- Here's the precedence table from GHC.Cmm.Parser:
    452 452 
     -- %nonassoc '>=' '>' '<=' '<' '!=' '=='

  • compiler/GHC/Cmm/Lint.hs
    ... ... @@ -113,7 +113,7 @@ lintCmmExpr expr =
    113 113 
       do platform <- getPlatform
    114 114 
          return (cmmExprType platform expr)
    115 115
    116 
    --- We require every address to refer to be word-width since we don't support 32
    116 
    +-- We require every address value to be word-sized since we don't support 32
    117 117 
     -- bit pointers on 64bit platforms.
    118 118 
     lintAddrTy :: CmmExpr -> CmmType -> CmmLint ()
    119 119 
     lintAddrTy e addr_ty = do

  • compiler/GHC/Cmm/MachOp.hs
    ... ... @@ -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
    ... ... @@ -623,7 +623,9 @@ machOpArgReps platform op =
    623 623 
         MO_XX_Conv from _     -> Just [from]
    624 624 
         -- Only supports W32/W64
    625 625 
         MO_SF_Round from _w   -> onlyW32W64 from
    626 
    -    MO_FS_Truncate from _ -> onlyW32W64 from
    626 
    +    MO_FS_Truncate from to
    627 
    +      | to `notElem` [W32, W64] -> Nothing
    628 
    +      | otherwise -> onlyW32W64 from
    627 629 
         MO_FF_Conv from _     -> onlyW32W64 from
    628 630 
         MO_WF_Bitcast w       -> onlyW32W64 w
    629 631 
         MO_FW_Bitcast w       -> onlyW32W64 w

  • compiler/GHC/Cmm/Parser.y
    ... ... @@ -746,7 +746,7 @@ stmt :: { CmmParse () }
    746 746 
             | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';'
    747 747 
                     { doCall $6 $2 $8 }
    748 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 checkCond, #27543).
    749 
    +        -- We don't allow arbitrary expressions as conditions (See GHC.Cmm.Lint.checkCond:checkCond, #27543).
    750 750 
             | 'if' bool_expr cond_likely 'goto' NAME
    751 751 
                     { do l <- lookupLabel $5; cmmRawIf $2 l $3 }
    752 752 
             | 'if' bool_expr cond_likely '{' body '}' else

  • compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
    ... ... @@ -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 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

  • compiler/GHC/CmmToAsm/AArch64/Instr.hs
    ... ... @@ -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

  • compiler/GHC/CmmToAsm/AArch64/Ppr.hs
    ... ... @@ -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

  • testsuite/tests/cmm/should_compile/Makefile
    ... ... @@ -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]*$$||'

  • testsuite/tests/cmm/should_compile/T27368-ppr-debug.stderr
    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 
    +

  • testsuite/tests/cmm/should_compile/T27368-ppr-debug.stdout deleted
    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 (>[W64]) 0) goto _lbl_; else goto _lbl_;
    10 
    -       _lbl_:
    11 
    -           goto _lbl_;
    12 
    -       _lbl_:
    13 
    -           __locVar_::I64 = __locVar_::I64 (-[W64]) 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 (+[W64]) 42;
    24 
    -             R1 = __locVar_::I64;
    25 
    -             call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
    26 
    -     }
    27 
    - }]

  • testsuite/tests/cmm/should_compile/all.T
    ... ... @@ -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 '

  • testsuite/tests/codeGen/should_run/T27430.hs
    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))

  • testsuite/tests/codeGen/should_run/T27430.stdout
    1 
    +1
    2 
    +1
    3 
    +1
    4 
    +1
    5 
    +1
    6 
    +1

  • testsuite/tests/codeGen/should_run/T27430_c.c
    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; }

  • testsuite/tests/codeGen/should_run/T27533.hs
    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

  • testsuite/tests/codeGen/should_run/T27533.stdout
    1 
    +after 1-byte release-store: 43 ff ff ff ff ff ff ff
    2 
    +acquire byte load at p+1:   0xff

  • testsuite/tests/codeGen/should_run/T27533_cmm.cmm
    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 
    +}

  • testsuite/tests/codeGen/should_run/T27537.hs
    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)

  • testsuite/tests/codeGen/should_run/T27537.stdout
    1 
    +1
    2 
    +1
    3 
    +1
    4 
    +54

  • testsuite/tests/codeGen/should_run/T27538.hs
    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)))

  • testsuite/tests/codeGen/should_run/T27538.stdout
    1 
    +f(0x80) = 0

  • testsuite/tests/codeGen/should_run/all.T
    ... ... @@ -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'])

  • testsuite/tests/simd/should_run/T27565.hs
    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 ]

  • testsuite/tests/simd/should_run/T27565.stdout
    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]

  • testsuite/tests/simd/should_run/all.T
    ... ... @@ -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, [''])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/compare/92a88f55d52a4e729b32d9c355fb452ea2340de3...746a43e303beefb2e1f83219e949845cad07089e at 1787579203