Optimise genericIntMul2Op

We shouldn't directly call 'genericWordMul2Op' in genericIntMul2Op
because a target may provide a faster primop for 'WordMul2Op': we'd
better use it!

2 files changed, 26 insertions, 7 deletions

diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs
index 9ee4834bf6..77dc9ca1c0 100644
--- a/compiler/GHC/Builtin/PrimOps.hs
+++ b/compiler/GHC/Builtin/PrimOps.hs
@@ -8,7 +8,7 @@
 
 module GHC.Builtin.PrimOps (
         PrimOp(..), PrimOpVecCat(..), allThePrimOps,
-        primOpType, primOpSig,
+        primOpType, primOpSig, primOpResultType,
         primOpTag, maxPrimOpTag, primOpOcc,
         primOpWrapperId,
 
@@ -581,6 +581,14 @@ primOpType op
     GenPrimOp _occ tyvars arg_tys res_ty ->
         mkSpecForAllTys tyvars (mkVisFunTysMany arg_tys res_ty)
 
+primOpResultType :: PrimOp -> Type
+primOpResultType op
+  = case primOpInfo op of
+    Dyadic  _occ ty  -> ty
+    Monadic _occ ty  -> ty
+    Compare _occ _ty -> intPrimTy
+    GenPrimOp _occ _tyvars _arg_tys res_ty -> res_ty
+
 primOpOcc :: PrimOp -> OccName
 primOpOcc op = case primOpInfo op of
                Dyadic    occ _     -> occ
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index d311249cd6..ef5e376be8 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -86,17 +86,27 @@ cgOpApp (StgFCallOp fcall ty) stg_args res_ty
 cgOpApp (StgPrimOp primop) args res_ty = do
     dflags <- getDynFlags
     cmm_args <- getNonVoidArgAmodes args
-    case emitPrimOp dflags primop cmm_args of
-        PrimopCmmEmit_Internal f -> emitReturn =<< f res_ty
-        PrimopCmmEmit_External -> do
-          let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
-          emitCall (NativeNodeCall, NativeReturn) fun cmm_args
+    cmmPrimOpApp dflags primop cmm_args (Just res_ty)
 
 cgOpApp (StgPrimCallOp primcall) args _res_ty
   = do  { cmm_args <- getNonVoidArgAmodes args
         ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))
         ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }
 
+cmmPrimOpApp :: DynFlags -> PrimOp -> [CmmExpr] -> Maybe Type -> FCode ReturnKind
+cmmPrimOpApp dflags primop cmm_args mres_ty =
+  case emitPrimOp dflags primop cmm_args of
+    PrimopCmmEmit_Internal f ->
+      let
+         -- if the result type isn't explicitly given, we directly use the
+         -- result type of the primop.
+         res_ty = fromMaybe (primOpResultType primop) mres_ty
+      in emitReturn =<< f res_ty
+    PrimopCmmEmit_External -> do
+      let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
+      emitCall (NativeNodeCall, NativeReturn) fun cmm_args
+
+
 -- | Interpret the argument as an unsigned value, assuming the value
 -- is given in two-complement form in the given width.
 --
@@ -1866,7 +1876,8 @@ genericIntMul2Op [res_c, res_h, res_l] both_args@[arg_x, arg_y]
       let t = cmmExprType platform arg_x
       p   <- newTemp t
       -- 1) compute the multiplication as if numbers were unsigned
-      genericWordMul2Op [p, res_l] both_args
+      _ <- withSequel (AssignTo [p, res_l] False) $
+             cmmPrimOpApp dflags WordMul2Op both_args Nothing
       -- 2) correct the high bits of the unsigned result
       let carryFill x = CmmMachOp (MO_S_Shr ww) [x, wwm1]
           sub x y     = CmmMachOp (MO_Sub   ww) [x, y]