summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/cmm/CmmMachOp.hs3
-rw-r--r--compiler/cmm/PprC.hs1
-rw-r--r--compiler/codeGen/CgPrimOp.hs48
-rw-r--r--compiler/llvmGen/LlvmCodeGen/CodeGen.hs1
-rw-r--r--compiler/nativeGen/PPC/CodeGen.hs1
-rw-r--r--compiler/nativeGen/SPARC/CodeGen.hs1
-rw-r--r--compiler/nativeGen/X86/CodeGen.hs1
-rw-r--r--compiler/prelude/primops.txt.pp4
8 files changed, 59 insertions, 1 deletions
diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs
index 3deb4feb99..d9484a6644 100644
--- a/compiler/cmm/CmmMachOp.hs
+++ b/compiler/cmm/CmmMachOp.hs
@@ -442,7 +442,8 @@ data CallishMachOp
| MO_S_QuotRem Width
| MO_U_QuotRem Width
- | MO_Add2 Width
+ | MO_Add2 Width
+ | MO_U_Mul2 Width
| MO_WriteBarrier
| MO_Touch -- Keep variables live (when using interior pointers)
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index fc4a2dec9e..3e28484c94 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -664,6 +664,7 @@ pprCallishMachOp_for_C mop
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_Add2 {} -> unsupported
+ MO_U_Mul2 {} -> unsupported
MO_Touch -> unsupported
where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop
++ " not supported!")
diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs
index 0b0b82cc29..c23608de36 100644
--- a/compiler/codeGen/CgPrimOp.hs
+++ b/compiler/codeGen/CgPrimOp.hs
@@ -33,6 +33,8 @@ import Outputable
import FastString
import StaticFlags
+import Control.Monad
+
-- ---------------------------------------------------------------------------
-- Code generation for PrimOps
@@ -503,6 +505,52 @@ emitPrimOp [res_h, res_l] WordAdd2Op [arg_x, arg_y] _
CmmHinted arg_y NoHint]
CmmMayReturn
stmtC stmt
+emitPrimOp [res_h, res_l] WordMul2Op [arg_x, arg_y] _
+ = do let t = cmmExprType arg_x
+ xlyl <- liftM CmmLocal $ newLocalReg t
+ xlyh <- liftM CmmLocal $ newLocalReg t
+ xhyl <- liftM CmmLocal $ newLocalReg t
+ r <- liftM CmmLocal $ newLocalReg t
+ -- This generic implementation is very simple and slow. We might
+ -- well be able to do better, but for now this at least works.
+ let genericImpl [CmmHinted res_h _, CmmHinted res_l _]
+ [CmmHinted arg_x _, CmmHinted arg_y _]
+ = [CmmAssign xlyl
+ (mul (bottomHalf arg_x) (bottomHalf arg_y)),
+ CmmAssign xlyh
+ (mul (bottomHalf arg_x) (topHalf arg_y)),
+ CmmAssign xhyl
+ (mul (topHalf arg_x) (bottomHalf arg_y)),
+ CmmAssign r
+ (sum [topHalf (CmmReg xlyl),
+ bottomHalf (CmmReg xhyl),
+ bottomHalf (CmmReg xlyh)]),
+ CmmAssign (CmmLocal res_l)
+ (or (bottomHalf (CmmReg xlyl))
+ (toTopHalf (CmmReg r))),
+ CmmAssign (CmmLocal res_h)
+ (sum [mul (topHalf arg_x) (topHalf arg_y),
+ bottomHalf (CmmReg xhyl),
+ bottomHalf (CmmReg xlyh),
+ topHalf (CmmReg r)])]
+ where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww]
+ toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww]
+ bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm]
+ add x y = CmmMachOp (MO_Add wordWidth) [x, y]
+ sum = foldl1 add
+ mul x y = CmmMachOp (MO_Mul wordWidth) [x, y]
+ or x y = CmmMachOp (MO_Or wordWidth) [x, y]
+ hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth))
+ wordWidth)
+ hwm = CmmLit (CmmInt halfWordMask wordWidth)
+ genericImpl _ _ = panic "emitPrimOp WordMul2Op generic: bad lengths"
+ stmt = CmmCall (CmmPrim (MO_U_Mul2 wordWidth) (Just genericImpl))
+ [CmmHinted res_h NoHint,
+ CmmHinted res_l NoHint]
+ [CmmHinted arg_x NoHint,
+ CmmHinted arg_y NoHint]
+ CmmMayReturn
+ stmtC stmt
emitPrimOp _ op _ _
= pprPanic "emitPrimOp: can't translate PrimOp" (ppr op)
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 0df0fe3c5b..cfd0ac22b6 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -475,6 +475,7 @@ cmmPrimOpFunctions env mop
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_Add2 {} -> unsupported
+ MO_U_Mul2 {} -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index 9974fb582b..9fff25b789 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -1148,6 +1148,7 @@ genCCall' gcp target dest_regs argsAndHints
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_Add2 {} -> unsupported
+ MO_U_Mul2 {} -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
unsupported = panic ("outOfLineCmmOp: " ++ show mop
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index f5ee02204f..66461551a9 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -643,6 +643,7 @@ outOfLineMachOp_table mop
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_Add2 {} -> unsupported
+ MO_U_Mul2 {} -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
where unsupported = panic ("outOfLineCmmOp: " ++ show mop
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index 41628eeb28..5f582774c2 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -2102,6 +2102,7 @@ outOfLineCmmOp mop res args
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_Add2 {} -> unsupported
+ MO_U_Mul2 {} -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
unsupported = panic ("outOfLineCmmOp: " ++ show mop
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 69503b1188..4d452c02ea 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -278,6 +278,10 @@ primop WordSubOp "minusWord#" Dyadic Word# -> Word# -> Word#
primop WordMulOp "timesWord#" Dyadic Word# -> Word# -> Word#
with commutable = True
+primop WordMul2Op "timesWord2#" GenPrimOp
+ Word# -> Word# -> (# Word#, Word# #)
+ with commutable = True
+
primop WordQuotOp "quotWord#" Dyadic Word# -> Word# -> Word#
with can_fail = True
View Lorry Controller Status