Support the 2-result primops in the new code generator

6 files changed, 176 insertions, 7 deletions

diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs
index 204f26e24b..2fa8c6a13f 100644
--- a/compiler/cmm/CmmCvt.hs
+++ b/compiler/cmm/CmmCvt.hs
@@ -12,7 +12,7 @@ import CmmUtils
 import qualified OldCmm as Old
 import OldPprCmm ()
 
-import Hoopl hiding ((<*>), mkLabel, mkBranch)
+import Hoopl
 import Data.Maybe
 import Maybes
 import Outputable
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 3ee06215bc..47239caeb8 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -16,7 +16,7 @@ import ForeignCall
 import CmmLive
 import CmmProcPoint
 import SMRep
-import Hoopl hiding ((<*>), mkLast, mkMiddle)
+import Hoopl
 import Constants
 import UniqSupply
 import Maybes
diff --git a/compiler/cmm/CmmRewriteAssignments.hs b/compiler/cmm/CmmRewriteAssignments.hs
index 2f13997771..2a6091d46f 100644
--- a/compiler/cmm/CmmRewriteAssignments.hs
+++ b/compiler/cmm/CmmRewriteAssignments.hs
@@ -27,6 +27,7 @@ import Unique
 import BlockId
 
 import Hoopl
+import Compiler.Hoopl ((<*>), mkMiddle, mkLast)
 import Data.Maybe
 import Control.Monad
 import Prelude hiding (succ, zip)
diff --git a/compiler/cmm/Hoopl.hs b/compiler/cmm/Hoopl.hs
index 0eca85cb8a..08d95b5073 100644
--- a/compiler/cmm/Hoopl.hs
+++ b/compiler/cmm/Hoopl.hs
@@ -7,7 +7,8 @@ module Hoopl (
   ) where
 
 import Compiler.Hoopl hiding
-  ( Unique,
+  ( (<*>), mkLabel, mkBranch, mkMiddle, mkLast, -- clashes with our MkGraph
+    Unique,
     FwdTransfer(..), FwdRewrite(..), FwdPass(..),
     BwdTransfer(..), BwdRewrite(..), BwdPass(..),
     noFwdRewrite, noBwdRewrite,
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index f64d203ee3..2151f84353 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -33,7 +33,7 @@ import StgCmmEnv
 
 import MkGraph
 
-import Hoopl hiding ((<*>), mkBranch)
+import Hoopl
 import SMRep
 import Cmm
 import CmmUtils
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index bd783a3b30..15020ccf7b 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -30,6 +30,8 @@ import StgCmmTicky
 import StgCmmHeap
 import StgCmmProf
 
+import DynFlags
+import Platform
 import BasicTypes
 import MkGraph
 import StgSyn
@@ -47,6 +49,8 @@ import Outputable
 import StaticFlags
 import Util
 
+import Control.Monad (liftM)
+
 ------------------------------------------------------------------------
 --	Primitive operations and foreign calls
 ------------------------------------------------------------------------
@@ -508,9 +512,172 @@ emitPrimOp r@[res] op args
    = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in
      emit stmt
 
-emitPrimOp _ op _
- = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op)
-
+emitPrimOp results op args
+   = do dflags <- getDynFlags
+        case callishPrimOpSupported dflags op of
+          Left op   -> emit $ mkUnsafeCall (PrimTarget op) results args
+          Right gen -> gen results args
+
+type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()
+
+callishPrimOpSupported :: DynFlags -> PrimOp -> Either CallishMachOp GenericOp
+callishPrimOpSupported dflags op
+  = case op of
+      IntQuotRemOp   | ncg && x86ish  -> Left (MO_S_QuotRem  wordWidth)
+                     | otherwise      -> Right genericIntQuotRemOp
+
+      WordQuotRemOp  | ncg && x86ish  -> Left (MO_U_QuotRem  wordWidth)
+                     | otherwise      -> Right genericWordQuotRemOp
+
+      WordQuotRem2Op | ncg && x86ish  -> Left (MO_U_QuotRem2 wordWidth)
+                     | otherwise      -> Right genericWordQuotRem2Op
+
+      WordAdd2Op     | ncg && x86ish  -> Left (MO_Add2       wordWidth)
+                     | otherwise      -> Right genericWordAdd2Op
+
+      WordMul2Op     | ncg && x86ish  -> Left (MO_U_Mul2     wordWidth)
+                     | otherwise      -> Right genericWordMul2Op
+
+      _ -> panic "emitPrimOp: can't translate PrimOp" (ppr op)
+ where
+  ncg = case hscTarget dflags of
+           HscAsm -> True
+           _      -> False
+
+  x86ish = case platformArch (targetPlatform dflags) of
+             ArchX86    -> True
+             ArchX86_64 -> True
+             _          -> False
+
+genericIntQuotRemOp :: GenericOp
+genericIntQuotRemOp [res_q, res_r] [arg_x, arg_y]
+   = emit $ mkAssign (CmmLocal res_q)
+              (CmmMachOp (MO_S_Quot wordWidth) [arg_x, arg_y]) <*>
+            mkAssign (CmmLocal res_r)
+              (CmmMachOp (MO_S_Rem  wordWidth) [arg_x, arg_y])
+genericIntQuotRemOp _ _ = panic "genericIntQuotRemOp"
+
+genericWordQuotRemOp :: GenericOp
+genericWordQuotRemOp [res_q, res_r] [arg_x, arg_y]
+    = emit $ mkAssign (CmmLocal res_q)
+               (CmmMachOp (MO_U_Quot wordWidth) [arg_x, arg_y]) <*>
+             mkAssign (CmmLocal res_r)
+               (CmmMachOp (MO_U_Rem  wordWidth) [arg_x, arg_y])
+genericWordQuotRemOp _ _ = panic "genericWordQuotRemOp"
+
+genericWordQuotRem2Op :: GenericOp
+genericWordQuotRem2Op [res_q, res_r] [arg_x_high, arg_x_low, arg_y]
+    = emit =<< f (widthInBits wordWidth) zero arg_x_high arg_x_low
+    where    ty = cmmExprType arg_x_high
+             shl   x i = CmmMachOp (MO_Shl   wordWidth) [x, i]
+             shr   x i = CmmMachOp (MO_U_Shr wordWidth) [x, i]
+             or    x y = CmmMachOp (MO_Or    wordWidth) [x, y]
+             ge    x y = CmmMachOp (MO_U_Ge  wordWidth) [x, y]
+             ne    x y = CmmMachOp (MO_Ne    wordWidth) [x, y]
+             minus x y = CmmMachOp (MO_Sub   wordWidth) [x, y]
+             times x y = CmmMachOp (MO_Mul   wordWidth) [x, y]
+             zero   = lit 0
+             one    = lit 1
+             negone = lit (fromIntegral (widthInBits wordWidth) - 1)
+             lit i = CmmLit (CmmInt i wordWidth)
+
+             f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph
+             f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>
+                                      mkAssign (CmmLocal res_r) high)
+             f i acc high low =
+                 do roverflowedBit <- newTemp ty
+                    rhigh'         <- newTemp ty
+                    rhigh''        <- newTemp ty
+                    rlow'          <- newTemp ty
+                    risge          <- newTemp ty
+                    racc'          <- newTemp ty
+                    let high'         = CmmReg (CmmLocal rhigh')
+                        isge          = CmmReg (CmmLocal risge)
+                        overflowedBit = CmmReg (CmmLocal roverflowedBit)
+                    let this = catAGraphs
+                               [mkAssign (CmmLocal roverflowedBit)
+                                          (shr high negone),
+                                mkAssign (CmmLocal rhigh')
+                                          (or (shl high one) (shr low negone)),
+                                mkAssign (CmmLocal rlow')
+                                          (shl low one),
+                                mkAssign (CmmLocal risge)
+                                          (or (overflowedBit `ne` zero)
+                                              (high' `ge` arg_y)),
+                                mkAssign (CmmLocal rhigh'')
+                                          (high' `minus` (arg_y `times` isge)),
+                                mkAssign (CmmLocal racc')
+                                          (or (shl acc one) isge)]
+                    rest <- f (i - 1) (CmmReg (CmmLocal racc'))
+                                      (CmmReg (CmmLocal rhigh''))
+                                      (CmmReg (CmmLocal rlow'))
+                    return (this <*> rest)
+genericWordQuotRem2Op _ _ = panic "genericWordQuotRem2Op"
+
+genericWordAdd2Op :: GenericOp
+genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]
+  = do r1 <- newTemp (cmmExprType arg_x)
+       r2 <- newTemp (cmmExprType arg_x)
+       emit $ catAGraphs
+          [mkAssign (CmmLocal r1)
+               (add (bottomHalf arg_x) (bottomHalf arg_y)),
+           mkAssign (CmmLocal r2)
+               (add (topHalf (CmmReg (CmmLocal r1)))
+                    (add (topHalf arg_x) (topHalf arg_y))),
+           mkAssign (CmmLocal res_h)
+               (topHalf (CmmReg (CmmLocal r2))),
+           mkAssign (CmmLocal res_l)
+               (or (toTopHalf (CmmReg (CmmLocal r2)))
+                   (bottomHalf (CmmReg (CmmLocal r1))))]
+   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]
+         or x y = CmmMachOp (MO_Or wordWidth) [x, y]
+         hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth))
+                              wordWidth)
+         hwm = CmmLit (CmmInt halfWordMask wordWidth)
+genericWordAdd2Op _ _ = panic "genericWordAdd2Op"
+
+genericWordMul2Op :: GenericOp
+genericWordMul2Op [res_h, res_l] [arg_x, arg_y]
+ = do let t = cmmExprType arg_x
+      xlyl <- liftM CmmLocal $ newTemp t
+      xlyh <- liftM CmmLocal $ newTemp t
+      xhyl <- liftM CmmLocal $ newTemp t
+      r    <- liftM CmmLocal $ newTemp t
+      -- This generic implementation is very simple and slow. We might
+      -- well be able to do better, but for now this at least works.
+      emit $ catAGraphs
+             [mkAssign xlyl
+                  (mul (bottomHalf arg_x) (bottomHalf arg_y)),
+              mkAssign xlyh
+                  (mul (bottomHalf arg_x) (topHalf arg_y)),
+              mkAssign xhyl
+                  (mul (topHalf arg_x) (bottomHalf arg_y)),
+              mkAssign r
+                  (sum [topHalf    (CmmReg xlyl),
+                        bottomHalf (CmmReg xhyl),
+                        bottomHalf (CmmReg xlyh)]),
+              mkAssign (CmmLocal res_l)
+                  (or (bottomHalf (CmmReg xlyl))
+                      (toTopHalf (CmmReg r))),
+              mkAssign (CmmLocal res_h)
+                  (sum [mul (topHalf arg_x) (topHalf arg_y),
+                        topHalf (CmmReg xhyl),
+                        topHalf (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)
+genericWordMul2Op _ _ = panic "genericWordMul2Op"
 
 -- These PrimOps are NOPs in Cmm