X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsCCall.lhs;h=5ee47807de1f6d089bcede6277afd771cd05cd4a;hb=979947f545d70c63edb7ca96f6e47008ac90e3bf;hp=51a22bae19dfc0af377e008354b4e488a02eafcc;hpb=861e836ed0cc1aa45932ecb3470967964440a0ef;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 51a22ba..5ee4780 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -6,7 +6,7 @@ \begin{code} module DsCCall ( dsCCall - , mkCCall + , mkFCall , unboxArg , boxResult , resultWrapper @@ -19,30 +19,40 @@ import CoreSyn import DsMonad import CoreUtils ( exprType, mkCoerce ) -import Id ( mkWildId ) -import MkId ( mkCCallOpId, realWorldPrimId ) +import Id ( Id, mkWildId, idType ) +import MkId ( mkFCallId, realWorldPrimId, mkPrimOpId ) import Maybes ( maybeToBool ) -import PrimOp ( CCall(..), CCallTarget(..) ) +import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, CCallConv(..) ) import DataCon ( splitProductType_maybe, dataConSourceArity, dataConWrapId ) -import CallConv -import Type ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys, - splitTyConApp_maybe, tyVarsOfType, mkForAllTys, - isNewType, repType, isUnLiftedType, mkFunTy, mkTyConApp, - Type +import ForeignCall ( ForeignCall, CCallTarget(..) ) + +import TcType ( tcSplitTyConApp_maybe ) +import Type ( Type, isUnLiftedType, mkFunTys, mkFunTy, + tyVarsOfType, mkForAllTys, mkTyConApp, + isPrimitiveType, eqType, + splitTyConApp_maybe, splitNewType_maybe ) + +import PrimOp ( PrimOp(..) ) import TysPrim ( realWorldStatePrimTy, - byteArrayPrimTyCon, mutableByteArrayPrimTyCon, intPrimTy + byteArrayPrimTyCon, mutableByteArrayPrimTyCon, + intPrimTy, foreignObjPrimTy ) +import TyCon ( TyCon, tyConDataCons ) import TysWiredIn ( unitDataConId, unboxedSingletonDataCon, unboxedPairDataCon, unboxedSingletonTyCon, unboxedPairTyCon, - boolTy, trueDataCon, falseDataCon, - trueDataConId, falseDataConId, unitTy + trueDataCon, falseDataCon, + trueDataConId, falseDataConId ) import Literal ( mkMachInt ) import CStrings ( CLabelString ) -import PrelNames ( Unique, hasKey, ioTyConKey ) +import PrelNames ( Unique, hasKey, ioTyConKey, boolTyConKey, unitTyConKey, + int8TyConKey, int16TyConKey, int32TyConKey, + word8TyConKey, word16TyConKey, word32TyConKey + ) import VarSet ( varSetElems ) +import Constants ( wORD_SIZE) import Outputable \end{code} @@ -84,22 +94,24 @@ follows: \begin{code} dsCCall :: CLabelString -- C routine to invoke -> [CoreExpr] -- Arguments (desugared) - -> Bool -- True <=> might cause Haskell GC + -> Safety -- Safety of the call -> Bool -- True <=> really a "_casm_" -> Type -- Type of the result: IO t -> DsM CoreExpr dsCCall lbl args may_gc is_asm result_ty = mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) -> - boxResult result_ty `thenDs` \ (ccall_result_ty, res_wrapper) -> + boxResult [] result_ty `thenDs` \ (ccall_result_ty, res_wrapper) -> getUniqueDs `thenDs` \ uniq -> let - the_ccall = CCall (StaticTarget lbl) is_asm may_gc cCallConv - the_prim_app = mkCCall uniq the_ccall unboxed_args ccall_result_ty + target | is_asm = CasmTarget lbl + | otherwise = StaticTarget lbl + the_fcall = CCall (CCallSpec target CCallConv may_gc) + the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty in returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers) -mkCCall :: Unique -> CCall +mkFCall :: Unique -> ForeignCall -> [CoreExpr] -- Args -> Type -- Result type -> CoreExpr @@ -112,14 +124,14 @@ mkCCall :: Unique -> CCall -- Here we build a ccall thus -- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr)) -- a b s x c -mkCCall uniq the_ccall val_args res_ty - = mkApps (mkVarApps (Var the_ccall_id) tyvars) val_args +mkFCall uniq the_fcall val_args res_ty + = mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args where arg_tys = map exprType val_args body_ty = (mkFunTys arg_tys res_ty) tyvars = varSetElems (tyVarsOfType body_ty) ty = mkForAllTys tyvars body_ty - the_ccall_id = mkCCallOpId uniq the_ccall ty + the_fcall_id = mkFCallId uniq the_fcall ty \end{code} \begin{code} @@ -132,16 +144,17 @@ unboxArg :: CoreExpr -- The supplied argument -- where W is a CoreExpr that probably mentions x# unboxArg arg - -- Unlifted types: nothing to unbox - | isUnLiftedType arg_ty + -- Primtive types: nothing to unbox + | isPrimitiveType arg_ty = returnDs (arg, \body -> body) - -- Newtypes - | isNewType arg_ty - = unboxArg (mkCoerce (repType arg_ty) arg_ty arg) + -- Recursive newtypes + | Just rep_ty <- splitNewType_maybe arg_ty + = unboxArg (mkCoerce rep_ty arg_ty arg) -- Booleans - | arg_ty == boolTy + | Just (tc,_) <- splitTyConApp_maybe arg_ty, + tc `hasKey` boolTyConKey = newSysLocalDs intPrimTy `thenDs` \ prim_arg -> returnDs (Var prim_arg, \ body -> Case (Case arg (mkWildId arg_ty) @@ -161,6 +174,9 @@ unboxArg arg ) -- Byte-arrays, both mutable and otherwise; hack warning + -- We're looking for values of type ByteArray, MutableByteArray + -- data ByteArray ix = ByteArray ix ix ByteArray# + -- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s) | is_product_type && data_con_arity == 3 && maybeToBool maybe_arg3_tycon && @@ -177,7 +193,7 @@ unboxArg arg = getSrcLocDs `thenDs` \ l -> pprPanic "unboxArg: " (ppr l <+> ppr arg_ty) where - arg_ty = exprType arg + arg_ty = exprType arg maybe_product_type = splitProductType_maybe arg_ty is_product_type = maybeToBool maybe_product_type Just (_, _, data_con, data_con_arg_tys) = maybe_product_type @@ -191,7 +207,7 @@ unboxArg arg \begin{code} -boxResult :: Type -> DsM (Type, CoreExpr -> CoreExpr) +boxResult :: [Id] -> Type -> DsM (Type, CoreExpr -> CoreExpr) -- Takes the result of the user-level ccall: -- either (IO t), @@ -204,20 +220,31 @@ boxResult :: Type -> DsM (Type, CoreExpr -> CoreExpr) -- the result type will be -- State# RealWorld -> (# State# RealWorld #) -boxResult result_ty - = case splitAlgTyConApp_maybe result_ty of +-- Here is where we arrange that ForeignPtrs which are passed to a 'safe' +-- foreign import don't get finalized until the call returns. For each +-- argument of type ForeignObj# we arrange to touch# the argument after +-- the call. The arg_ids passed in are the Ids passed to the actual ccall. + +boxResult arg_ids result_ty + = case tcSplitTyConApp_maybe result_ty of + -- This split absolutely has to be a tcSplit, because we must + -- see the IO type; and it's a newtype which is transparent to splitTyConApp. -- The result is IO t, so wrap the result in an IO constructor - Just (io_tycon, [io_res_ty], [io_data_con]) | io_tycon `hasKey` ioTyConKey + Just (io_tycon, [io_res_ty]) | io_tycon `hasKey` ioTyConKey -> mk_alt return_result (resultWrapper io_res_ty) `thenDs` \ (ccall_res_ty, the_alt) -> - newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id -> + newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id -> let - wrap = \ the_call -> mkApps (Var (dataConWrapId io_data_con)) - [Type io_res_ty, Lam state_id $ - Case (App the_call (Var state_id)) - (mkWildId ccall_res_ty) - [the_alt]] + io_data_con = head (tyConDataCons io_tycon) + wrap = \ the_call -> + mkApps (Var (dataConWrapId io_data_con)) + [ Type io_res_ty, + Lam state_id $ + Case (App the_call (Var state_id)) + (mkWildId ccall_res_ty) + [the_alt] + ] in returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) where @@ -228,7 +255,7 @@ boxResult result_ty -- It isn't, so do unsafePerformIO -- It's not conveniently available, so we inline it other -> mk_alt return_result - (resultWrapper result_ty) `thenDs` \ (ccall_res_ty, the_alt) -> + (resultWrapper result_ty) `thenDs` \ (ccall_res_ty, the_alt) -> let wrap = \ the_call -> Case (App the_call (Var realWorldPrimId)) (mkWildId ccall_res_ty) @@ -240,9 +267,13 @@ boxResult result_ty where mk_alt return_result (Nothing, wrap_result) = -- The ccall returns () + let + rhs_fun state_id = return_result (Var state_id) + (wrap_result (panic "boxResult")) + in newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id -> + mkTouches arg_ids state_id rhs_fun `thenDs` \ the_rhs -> let - the_rhs = return_result (Var state_id) (wrap_result (panic "boxResult")) ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy] the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs) in @@ -250,55 +281,86 @@ boxResult result_ty mk_alt return_result (Just prim_res_ty, wrap_result) = -- The ccall returns a non-() value - newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id -> newSysLocalDs prim_res_ty `thenDs` \ result_id -> let - the_rhs = return_result (Var state_id) (wrap_result (Var result_id)) + rhs_fun state_id = return_result (Var state_id) + (wrap_result (Var result_id)) + in + newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id -> + mkTouches arg_ids state_id rhs_fun `thenDs` \ the_rhs -> + let ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty] the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs) in returnDs (ccall_res_ty, the_alt) +touchzh = mkPrimOpId TouchOp + +mkTouches [] s cont = returnDs (cont s) +mkTouches (v:vs) s cont + | not (idType v `eqType` foreignObjPrimTy) = mkTouches vs s cont + | otherwise = newSysLocalDs realWorldStatePrimTy `thenDs` \s' -> + mkTouches vs s' cont `thenDs` \ rest -> + returnDs (Case (mkApps (Var touchzh) [Type foreignObjPrimTy, + Var v, Var s]) s' + [(DEFAULT, [], rest)]) resultWrapper :: Type -> (Maybe Type, -- Type of the expected result, if any CoreExpr -> CoreExpr) -- Wrapper for the result resultWrapper result_ty -- Base case 1: primitive types - | isUnLiftedType result_ty + | isPrimitiveType result_ty = (Just result_ty, \e -> e) - -- Base case 1: the unit type () - | result_ty == unitTy + -- Base case 2: the unit type () + | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey = (Nothing, \e -> Var unitDataConId) - | result_ty == boolTy + -- Base case 3: the boolean type + | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey = (Just intPrimTy, \e -> Case e (mkWildId intPrimTy) - [(LitAlt (mkMachInt 0),[],Var falseDataConId), - (DEFAULT ,[],Var trueDataConId )]) + [(DEFAULT ,[],Var trueDataConId ), + (LitAlt (mkMachInt 0),[],Var falseDataConId)]) + + -- Recursive newtypes + | Just rep_ty <- splitNewType_maybe result_ty + = let + (maybe_ty, wrapper) = resultWrapper rep_ty + in + (maybe_ty, \e -> mkCoerce result_ty rep_ty (wrapper e)) -- Data types with a single constructor, which has a single arg - | is_product_type && data_con_arity == 1 + | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty, + dataConSourceArity data_con == 1 = let (maybe_ty, wrapper) = resultWrapper unwrapped_res_ty (unwrapped_res_ty : _) = data_con_arg_tys + narrow_wrapper = maybeNarrow tycon in (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con)) - (map Type tycon_arg_tys ++ [wrapper e])) - - -- newtypes - | isNewType result_ty - = let - rep_ty = repType result_ty - (maybe_ty, wrapper) = resultWrapper rep_ty - in - (maybe_ty, \e -> mkCoerce result_ty rep_ty (wrapper e)) + (map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)])) | otherwise = pprPanic "resultWrapper" (ppr result_ty) where - maybe_product_type = splitProductType_maybe result_ty - is_product_type = maybeToBool maybe_product_type - Just (_, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type - data_con_arity = dataConSourceArity data_con + maybe_tc_app = splitTyConApp_maybe result_ty + +-- When the result of a foreign call is smaller than the word size, we +-- need to sign- or zero-extend the result up to the word size. The C +-- standard appears to say that this is the responsibility of the +-- caller, not the callee. + +maybeNarrow :: TyCon -> (CoreExpr -> CoreExpr) +maybeNarrow tycon + | tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e + | tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e + | tycon `hasKey` int32TyConKey + && wORD_SIZE > 4 = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e + + | tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e + | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e + | tycon `hasKey` word32TyConKey + && wORD_SIZE > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e + | otherwise = id \end{code}