Commit 8160f42b authored by nkaretnikov's avatar nkaretnikov Committed by Ben Gamari

Add subWordC# on x86ish

This adds a subWordC# primop which implements subtraction with overflow
reporting.

Reviewers: tibbe, goldfire, rwbarton, bgamari, austin, hvr

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1334

GHC Trac Issues: #10962
parent 62f0fbc9
......@@ -549,6 +549,7 @@ data CallishMachOp
| MO_U_QuotRem Width
| MO_U_QuotRem2 Width
| MO_Add2 Width
| MO_SubWordC Width
| MO_AddIntC Width
| MO_SubIntC Width
| MO_U_Mul2 Width
......
......@@ -763,6 +763,7 @@ pprCallishMachOp_for_C mop
MO_U_QuotRem {} -> unsupported
MO_U_QuotRem2 {} -> unsupported
MO_Add2 {} -> unsupported
MO_SubWordC {} -> unsupported
MO_AddIntC {} -> unsupported
MO_SubIntC {} -> unsupported
MO_U_Mul2 {} -> unsupported
......
......@@ -824,6 +824,10 @@ callishPrimOpSupported dflags op
|| llvm -> Left (MO_Add2 (wordWidth dflags))
| otherwise -> Right genericWordAdd2Op
WordSubCOp | (ncg && x86ish)
|| llvm -> Left (MO_SubWordC (wordWidth dflags))
| otherwise -> Right genericWordSubCOp
IntAddCOp | (ncg && x86ish)
|| llvm -> Left (MO_AddIntC (wordWidth dflags))
| otherwise -> Right genericIntAddCOp
......@@ -940,6 +944,19 @@ genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]
(bottomHalf (CmmReg (CmmLocal r1))))]
genericWordAdd2Op _ _ = panic "genericWordAdd2Op"
genericWordSubCOp :: GenericOp
genericWordSubCOp [res_r, res_c] [aa, bb] = do
dflags <- getDynFlags
emit $ catAGraphs
[ -- Put the result into 'res_r'.
mkAssign (CmmLocal res_r) $
CmmMachOp (mo_wordSub dflags) [aa, bb]
-- Set 'res_c' to 1 if 'bb > aa' and to 0 otherwise.
, mkAssign (CmmLocal res_c) $
CmmMachOp (mo_wordUGt dflags) [bb, aa]
]
genericWordSubCOp _ _ = panic "genericWordSubCOp"
genericIntAddCOp :: GenericOp
genericIntAddCOp [res_r, res_c] [aa, bb]
{-
......
......@@ -366,6 +366,9 @@ genCall t@(PrimTarget (MO_SubIntC w)) [dstV, dstO] [lhs, rhs] =
genCall t@(PrimTarget (MO_Add2 w)) [dstO, dstV] [lhs, rhs] =
genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
genCall t@(PrimTarget (MO_SubWordC w)) [dstV, dstO] [lhs, rhs] =
genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
-- Handle all other foreign calls and prim ops.
genCall target res args = runStmtsDecls $ do
dflags <- lift $ getDynFlags
......@@ -472,8 +475,12 @@ genCall target res args = runStmtsDecls $ do
genCallWithOverflow
:: ForeignTarget -> Width -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData
genCallWithOverflow t@(PrimTarget op) w [dstV, dstO] [lhs, rhs] = do
-- So far this was only tested for the following three CallishMachOps.
MASSERT( (op `elem` [MO_Add2 w, MO_AddIntC w, MO_SubIntC w]) )
-- So far this was only tested for the following four CallishMachOps.
MASSERT( (op `elem` [ MO_Add2 w
, MO_AddIntC w
, MO_SubIntC w
, MO_SubWordC w
]) )
let width = widthToLlvmInt w
-- This will do most of the work of generating the call to the intrinsic and
-- extracting the values from the struct.
......@@ -728,6 +735,8 @@ cmmPrimOpFunctions mop = do
++ showSDoc dflags (ppr $ widthToLlvmInt w)
MO_Add2 w -> fsLit $ "llvm.uadd.with.overflow."
++ showSDoc dflags (ppr $ widthToLlvmInt w)
MO_SubWordC w -> fsLit $ "llvm.usub.with.overflow."
++ showSDoc dflags (ppr $ widthToLlvmInt w)
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
......
......@@ -1468,6 +1468,7 @@ genCCall' dflags gcp target dest_regs args
MO_U_QuotRem {} -> unsupported
MO_U_QuotRem2 {} -> unsupported
MO_Add2 {} -> unsupported
MO_SubWordC {} -> unsupported
MO_AddIntC {} -> unsupported
MO_SubIntC {} -> unsupported
MO_U_Mul2 {} -> unsupported
......
......@@ -660,6 +660,7 @@ outOfLineMachOp_table mop
MO_U_QuotRem {} -> unsupported
MO_U_QuotRem2 {} -> unsupported
MO_Add2 {} -> unsupported
MO_SubWordC {} -> unsupported
MO_AddIntC {} -> unsupported
MO_SubIntC {} -> unsupported
MO_U_Mul2 {} -> unsupported
......
......@@ -2065,10 +2065,12 @@ genCCall _ is32Bit target dest_regs args = do
ADC format (OpImm (ImmInteger 0)) (OpReg reg_h)
return code
_ -> panic "genCCall: Wrong number of arguments/results for add2"
(PrimTarget (MO_SubWordC width), [res_r, res_c]) ->
addSubIntC platform SUB_CC (const Nothing) CARRY width res_r res_c args
(PrimTarget (MO_AddIntC width), [res_r, res_c]) ->
addSubIntC platform ADD_CC (Just . ADD_CC) width res_r res_c args
addSubIntC platform ADD_CC (Just . ADD_CC) OFLO width res_r res_c args
(PrimTarget (MO_SubIntC width), [res_r, res_c]) ->
addSubIntC platform SUB_CC (const Nothing) width res_r res_c args
addSubIntC platform SUB_CC (const Nothing) OFLO width res_r res_c args
(PrimTarget (MO_U_Mul2 width), [res_h, res_l]) ->
case args of
[arg_x, arg_y] ->
......@@ -2122,7 +2124,8 @@ genCCall _ is32Bit target dest_regs args = do
divOp _ _ _ _ _ _ _
= panic "genCCall: Wrong number of results for divOp"
addSubIntC platform instr mrevinstr width res_r res_c [arg_x, arg_y]
addSubIntC platform instr mrevinstr cond width
res_r res_c [arg_x, arg_y]
= do let format = intFormat width
rCode <- anyReg =<< trivialCode width (instr format)
(mrevinstr format) arg_x arg_y
......@@ -2130,10 +2133,11 @@ genCCall _ is32Bit target dest_regs args = do
let reg_c = getRegisterReg platform True (CmmLocal res_c)
reg_r = getRegisterReg platform True (CmmLocal res_r)
code = rCode reg_r `snocOL`
SETCC OFLO (OpReg reg_tmp) `snocOL`
SETCC cond (OpReg reg_tmp) `snocOL`
MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)
return code
addSubIntC _ _ _ _ _ _ _
addSubIntC _ _ _ _ _ _ _ _
= panic "genCCall: Wrong number of arguments/results for addSubIntC"
genCCall32' :: DynFlags
......@@ -2576,6 +2580,7 @@ outOfLineCmmOp mop res args
MO_Add2 {} -> unsupported
MO_AddIntC {} -> unsupported
MO_SubIntC {} -> unsupported
MO_SubWordC {} -> unsupported
MO_U_Mul2 {} -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
......
......@@ -316,6 +316,11 @@ primtype Word#
primop WordAddOp "plusWord#" Dyadic Word# -> Word# -> Word#
with commutable = True
primop WordSubCOp "subWordC#" GenPrimOp Word# -> Word# -> (# Word#, Int# #)
{Subtract unsigned integers reporting overflow.
The first element of the pair is the result. The second element is
the carry flag, which is nonzero on overflow.}
-- Returns (# high, low #) (or equivalently, (# carry, low #))
primop WordAdd2Op "plusWord2#" GenPrimOp
Word# -> Word# -> (# Word#, Word# #)
......
......@@ -396,13 +396,6 @@ minusNaturalMaybe (NatJ# x) (NatJ# y)
where
res = minusBigNat x y
-- | Helper for 'minusNatural' and 'minusNaturalMaybe'
subWordC# :: Word# -> Word# -> (# Word#, Int# #)
subWordC# x# y# = (# d#, c# #)
where
d# = x# `minusWord#` y#
c# = d# `gtWord#` x#
-- | Convert 'BigNat' to 'Natural'.
-- Throws 'Underflow' if passed a 'nullBigNat'.
bigNatToNatural :: BigNat -> Natural
......
......@@ -1988,13 +1988,6 @@ cmpW# x# y#
| True = GT
{-# INLINE cmpW# #-}
subWordC# :: Word# -> Word# -> (# Word#, Int# #)
subWordC# x# y# = (# d#, c# #)
where
d# = x# `minusWord#` y#
c# = d# `gtWord#` x#
{-# INLINE subWordC# #-}
bitWord# :: Int# -> Word#
bitWord# = uncheckedShiftL# 1##
{-# INLINE bitWord# #-}
......
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
module Main where
import GHC.Base
main :: IO ()
main = do
-- Overflow.
let (# w1, i1 #) = subWordC# 1## 3##
print (W# w1, I# i1)
-- No overflow.
let (# w2, i2 #) = subWordC# 3## 1##
print (W# w2, I# i2)
......@@ -64,3 +64,4 @@ test('T8726', normal, compile_and_run, [''])
test('CarryOverflow', omit_ways(['ghci']), compile_and_run, [''])
test('T9810', normal, compile_and_run, [''])
test('T10011', normal, compile_and_run, [''])
test('T10962', omit_ways(['ghci']), compile_and_run, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment