summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/GHC/Builtin/PrimOps.hs10
-rw-r--r--compiler/GHC/StgToCmm/Prim.hs23
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]