[commit: ghc] master: Add a 2-word-multiply operator (45eb0a4)
Ian Lynagh
igloo at earth.li
Fri Feb 24 03:46:29 CET 2012
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : master
http://hackage.haskell.org/trac/ghc/changeset/45eb0a425bb134d41e47a90e73ec5279c23bbc27
>---------------------------------------------------------------
commit 45eb0a425bb134d41e47a90e73ec5279c23bbc27
Author: Ian Lynagh <igloo at earth.li>
Date: Fri Feb 24 00:34:46 2012 +0000
Add a 2-word-multiply operator
Currently no NCGs support it
>---------------------------------------------------------------
compiler/cmm/CmmMachOp.hs | 3 +-
compiler/cmm/PprC.hs | 1 +
compiler/codeGen/CgPrimOp.hs | 48 +++++++++++++++++++++++++++++++
compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 1 +
compiler/nativeGen/PPC/CodeGen.hs | 1 +
compiler/nativeGen/SPARC/CodeGen.hs | 1 +
compiler/nativeGen/X86/CodeGen.hs | 1 +
compiler/prelude/primops.txt.pp | 4 ++
8 files changed, 59 insertions(+), 1 deletions(-)
diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs
index 3deb4fe..d9484a6 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 fc4a2de..3e28484 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 0b0b82c..c23608d 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 0df0fe3..cfd0ac2 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 9974fb5..9fff25b 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 f5ee022..6646155 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 41628ee..5f58277 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 69503b1..4d452c0 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
More information about the Cvs-ghc
mailing list