diff options
Diffstat (limited to 'compiler/deSugar/DsCCall.hs')
| -rw-r--r-- | compiler/deSugar/DsCCall.hs | 32 |
1 files changed, 16 insertions, 16 deletions
diff --git a/compiler/deSugar/DsCCall.hs b/compiler/deSugar/DsCCall.hs index f7bfa7b581..9a3fe5a220 100644 --- a/compiler/deSugar/DsCCall.hs +++ b/compiler/deSugar/DsCCall.hs @@ -21,16 +21,16 @@ module DsCCall import CoreSyn import DsMonad -import DsUtils( mkCastDs ) import CoreUtils import MkCore -import Var import MkId import ForeignCall import DataCon +import DsUtils import TcType import Type +import Id ( Id ) import Coercion import PrimOp import TysPrim @@ -101,8 +101,8 @@ dsCCall lbl args may_gc result_ty return (foldr ($) (res_wrapper the_prim_app) arg_wrappers) mkFCall :: DynFlags -> Unique -> ForeignCall - -> [CoreExpr] -- Args - -> Type -- Result type + -> [CoreExpr] -- Args + -> Type -- Result type -> CoreExpr -- Construct the ccall. The only tricky bit is that the ccall Id should have -- no free vars, so if any of the arg tys do we must give it a polymorphic type. @@ -114,12 +114,13 @@ mkFCall :: DynFlags -> Unique -> ForeignCall -- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr)) -- a b s x c mkFCall dflags uniq the_fcall val_args res_ty - = mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args + = ASSERT( all isTyVar tyvars ) -- this must be true because the type is top-level + mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args where arg_tys = map exprType val_args body_ty = (mkFunTys arg_tys res_ty) - tyvars = tyVarsOfTypeList body_ty - ty = mkForAllTys tyvars body_ty + tyvars = tyCoVarsOfTypeWellScoped body_ty + ty = mkInvForAllTys tyvars body_ty the_fcall_id = mkFCallId dflags uniq the_fcall ty unboxArg :: CoreExpr -- The supplied argument @@ -226,9 +227,9 @@ boxResult result_ty _ -> [] return_result state anss - = mkCoreConApps (tupleDataCon Unboxed (2 + length extra_result_tys)) - (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys) - ++ (state : anss)) + = mkCoreUbxTup + (realWorldStatePrimTy : io_res_ty : extra_result_tys) + (state : anss) ; (ccall_res_ty, the_alt) <- mk_alt return_result res @@ -274,8 +275,8 @@ mk_alt return_result (Nothing, wrap_result) 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) + ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy] + the_alt = (DataAlt (tupleDataCon Unboxed 1), [state_id], the_rhs) return (ccall_res_ty, the_alt) @@ -290,8 +291,7 @@ mk_alt return_result (Just prim_res_ty, wrap_result) let the_rhs = return_result (Var state_id) (wrap_result (Var result_id) : map Var as) - ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity) - (realWorldStatePrimTy : ls) + ccall_res_ty = mkTupleTy Unboxed (realWorldStatePrimTy : ls) the_alt = ( DataAlt (tupleDataCon Unboxed arity) , (state_id : args_ids) , the_rhs @@ -304,8 +304,8 @@ mk_alt return_result (Just prim_res_ty, wrap_result) let the_rhs = return_result (Var state_id) [wrap_result (Var result_id)] - ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty] - the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs) + ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty] + the_alt = (DataAlt (tupleDataCon Unboxed 2), [state_id, result_id], the_rhs) return (ccall_res_ty, the_alt) |