X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsCCall.lhs;h=f46d99e504c111c7e6e73ed2c2c43db8646c4a5c;hp=0ceb44379b128dbf7026e4e6e04b653441c43da0;hb=6e9c0431a7cf2bf1a48f01db48c6a1d41fe15a09;hpb=b601e528ba870ee5ec68b3aba894a77ae008390a diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index 0ceb443..f46d99e 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.lhs @@ -6,13 +6,6 @@ Desugaring foreign calls \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module DsCCall ( dsCCall , mkFCall @@ -29,7 +22,8 @@ import CoreSyn import DsMonad import CoreUtils -import Id +import MkCore +import Var import MkId import Maybes import ForeignCall @@ -48,11 +42,6 @@ import PrelNames import VarSet import Constants import Outputable - -#ifdef DEBUG -import TypeRep -#endif - \end{code} Desugaring of @ccall@s consists of adding some state manipulation, @@ -99,10 +88,10 @@ dsCCall :: CLabelString -- C routine to invoke dsCCall lbl args may_gc result_ty = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args - (ccall_result_ty, res_wrapper) <- boxResult id Nothing result_ty + (ccall_result_ty, res_wrapper) <- boxResult result_ty uniq <- newUnique let - target = StaticTarget lbl + target = StaticTarget lbl Nothing the_fcall = CCall (CCallSpec target CCallConv may_gc) the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty return (foldr ($) (res_wrapper the_prim_app) arg_wrappers) @@ -145,7 +134,7 @@ unboxArg arg = return (arg, \body -> body) -- Recursive newtypes - | Just(rep_ty, co) <- splitNewTypeRepCo_maybe arg_ty + | Just(_rep_ty, co) <- splitNewTypeRepCo_maybe arg_ty = unboxArg (mkCoerce co arg) -- Booleans @@ -153,7 +142,7 @@ unboxArg arg tc `hasKey` boolTyConKey = do prim_arg <- newSysLocalDs intPrimTy return (Var prim_arg, - \ body -> Case (Case arg (mkWildId arg_ty) intPrimTy + \ body -> Case (mkWildCase arg arg_ty intPrimTy [(DataAlt falseDataCon,[],mkIntLit 0), (DataAlt trueDataCon, [],mkIntLit 1)]) -- In increasing tag order! @@ -182,7 +171,7 @@ unboxArg arg (arg3_tycon == byteArrayPrimTyCon || arg3_tycon == mutableByteArrayPrimTyCon) = do case_bndr <- newSysLocalDs arg_ty - vars@[l_var, r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys + vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys return (Var arr_cts_var, \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)] ) @@ -206,7 +195,7 @@ unboxArg arg , arg , Lam prim_string body ]) - | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty, + | Just (tc, [_]) <- splitTyConApp_maybe arg_ty, tyConName tc == objectTyConName -- Object; dotnet only = do unpack_id <- dsLookupGlobalId marshalObjectName @@ -242,10 +231,7 @@ unboxArg arg \begin{code} -boxResult :: ((Maybe Type, CoreExpr -> CoreExpr) - -> (Maybe Type, CoreExpr -> CoreExpr)) - -> Maybe Id - -> Type +boxResult :: Type -> DsM (Type, CoreExpr -> CoreExpr) -- Takes the result of the user-level ccall: @@ -258,11 +244,8 @@ boxResult :: ((Maybe Type, CoreExpr -> CoreExpr) -- where t' is the unwrapped form of t. If t is simply (), then -- the result type will be -- State# RealWorld -> (# State# RealWorld #) --- --- The gruesome 'augment' and 'mbTopCon' are to do with .NET foreign calls --- It looks a mess: I wonder if it could be refactored. -boxResult augment mbTopCon result_ty +boxResult result_ty | Just (io_tycon, io_res_ty, co) <- tcSplitIOType_maybe result_ty -- isIOType_maybe handles the case where the type is a -- simple wrapping of IO. E.g. @@ -272,9 +255,8 @@ boxResult augment mbTopCon result_ty -- another case, and a coercion.) -- The result is IO t, so wrap the result in an IO constructor = do { res <- resultWrapper io_res_ty - ; let aug_res = augment res - extra_result_tys - = case aug_res of + ; let extra_result_tys + = case res of (Just ty,_) | isUnboxedTupleType ty -> let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls @@ -285,40 +267,43 @@ boxResult augment mbTopCon result_ty (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys) ++ (state : anss)) - ; (ccall_res_ty, the_alt) <- mk_alt return_result aug_res + ; (ccall_res_ty, the_alt) <- mk_alt return_result res ; state_id <- newSysLocalDs realWorldStatePrimTy ; let io_data_con = head (tyConDataCons io_tycon) - toIOCon = mbTopCon `orElse` dataConWrapId io_data_con + toIOCon = dataConWrapId io_data_con wrap the_call = mkCoerceI (mkSymCoI co) $ mkApps (Var toIOCon) [ Type io_res_ty, Lam state_id $ - Case (App the_call (Var state_id)) - (mkWildId ccall_res_ty) + mkWildCase (App the_call (Var state_id)) + ccall_res_ty (coreAltType the_alt) [the_alt] ] ; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) } -boxResult augment mbTopCon result_ty +boxResult result_ty = do -- It isn't IO, so do unsafePerformIO -- It's not conveniently available, so we inline it res <- resultWrapper result_ty - (ccall_res_ty, the_alt) <- mk_alt return_result (augment res) + (ccall_res_ty, the_alt) <- mk_alt return_result res let - wrap = \ the_call -> Case (App the_call (Var realWorldPrimId)) - (mkWildId ccall_res_ty) - (coreAltType the_alt) - [the_alt] + wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId)) + ccall_res_ty + (coreAltType the_alt) + [the_alt] return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) where - return_result state [ans] = ans - return_result _ _ = panic "return_result: expected single result" + return_result _ [ans] = ans + return_result _ _ = panic "return_result: expected single result" +mk_alt :: (Expr Var -> [Expr Var] -> Expr Var) + -> (Maybe Type, Expr Var -> Expr Var) + -> DsM (Type, (AltCon, [Id], Expr Var)) mk_alt return_result (Nothing, wrap_result) = do -- The ccall returns () state_id <- newSysLocalDs realWorldStatePrimTy @@ -374,12 +359,12 @@ resultWrapper result_ty -- Base case 2: the unit type () | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey - = return (Nothing, \e -> Var unitDataConId) + = return (Nothing, \_ -> Var unitDataConId) -- Base case 3: the boolean type | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey = return - (Just intPrimTy, \e -> Case e (mkWildId intPrimTy) + (Just intPrimTy, \e -> mkWildCase e intPrimTy boolTy [(DEFAULT ,[],Var trueDataConId ), (LitAlt (mkMachInt 0),[],Var falseDataConId)]) @@ -415,7 +400,7 @@ resultWrapper result_ty \ e -> App (Var pack_id) e) -- Objects; 'dotnet' only. - | Just (tc, [arg_ty]) <- maybe_tc_app, + | Just (tc, [_]) <- maybe_tc_app, tyConName tc == objectTyConName = do pack_id <- dsLookupGlobalId unmarshalObjectName return (Just addrPrimTy,