diff options
| -rw-r--r-- | compiler/GHC/Builtin/PrimOps.hs | 10 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Prim.hs | 23 |
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] |