From: simonpj Date: Mon, 16 Jul 2001 09:41:26 +0000 (+0000) Subject: [project @ 2001-07-16 09:41:26 by simonpj] X-Git-Tag: Approximately_9120_patches~1545 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=47451553f2775977be9e09966425f5c44b6582bd;p=ghc-hetmet.git [project @ 2001-07-16 09:41:26 by simonpj] Tidy up Type/TcType stuff in DsCCall/DsForeign --- diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index eca07f7..a103864 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -31,7 +31,7 @@ import TcType ( Type, isUnLiftedType, mkFunTys, mkFunTy, isBoolTy, isUnitTy, isPrimitiveType, tcSplitTyConApp_maybe ) -import Type ( splitTyConApp_maybe, repType, eqType ) -- Sees the representation type +import Type ( repType, eqType ) -- Sees the representation type import PrimOp ( PrimOp(TouchOp) ) import TysPrim ( realWorldStatePrimTy, byteArrayPrimTyCon, mutableByteArrayPrimTyCon, @@ -153,7 +153,6 @@ unboxArg arg prim_arg [(DEFAULT,[],body)]) - -- Newtypes -- Data types with a single constructor, which has a single, primitive-typed arg -- This deals with Int, Float etc | is_product_type && data_con_arity == 1 @@ -165,6 +164,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 && @@ -183,7 +185,9 @@ unboxArg arg where arg_ty = repType (exprType arg) -- The repType looks through any newtype or - -- implicit-parameter wrappings on the argument. + -- implicit-parameter wrappings on the argument; + -- this is necessary, because isBoolTy (in particular) does not. + maybe_product_type = splitProductType_maybe arg_ty is_product_type = maybeToBool maybe_product_type Just (_, _, data_con, data_con_arg_tys) = maybe_product_type @@ -217,6 +221,8 @@ boxResult :: [Id] -> Type -> DsM (Type, CoreExpr -> CoreExpr) 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_tycon `hasKey` ioTyConKey @@ -324,6 +330,5 @@ resultWrapper result_ty | otherwise = pprPanic "resultWrapper" (ppr result_ty) where - result_ty_rep = repType result_ty - + result_ty_rep = repType result_ty -- Look through any newtypes/implicit parameters \end{code} diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 9c979a3..133e1d6 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -28,14 +28,10 @@ import Name ( mkGlobalName, nameModule, nameOccName, getOccString, NamedThing(..), ) - -- Import Type not TcType; in this module we are generating code - -- to marshal representation types across to C -import Type ( splitTyConApp_maybe, funResultTy, - splitFunTys, splitForAllTys, splitAppTy, - Type, mkFunTys, mkForAllTys, mkTyConApp, - mkFunTy, applyTy, eqType, repType - ) -import TcType ( tcSplitForAllTys, tcSplitFunTys, +import Type ( repType, eqType ) +import TcType ( Type, mkFunTys, mkForAllTys, mkTyConApp, + mkFunTy, applyTy, + tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs, tcSplitTyConApp_maybe, tcSplitAppTy, tcFunResultTy ) @@ -151,6 +147,8 @@ dsFCall mod_Name fn_id fcall ty = idType fn_id (tvs, fun_ty) = tcSplitForAllTys ty (arg_tys, io_res_ty) = tcSplitFunTys fun_ty + -- Must use tcSplit* functions because we want to + -- see that (IO t) in the corner in newSysLocalsDs arg_tys `thenDs` \ args -> mapAndUnzipDs unboxArg (map Var args) `thenDs` \ (val_args, arg_wrappers) -> @@ -225,6 +223,9 @@ dsFExport mod_name fn_id ty ext_name cconv isDyn -- If it's IO t, return (\x.x, IO t, t) -- If it's plain t, return (\x.returnIO x, IO t, t) (case tcSplitTyConApp_maybe orig_res_ty of + -- We must use tcSplit here so that we see the (IO t) in + -- the type. [IO t is transparent to plain splitTyConApp.] + Just (ioTyCon, [res_ty]) -> ASSERT( ioTyCon `hasKey` ioTyConKey ) -- The function already returns IO t @@ -303,15 +304,19 @@ dsFExport mod_name fn_id ty ext_name cconv isDyn where (tvs,sans_foralls) = tcSplitForAllTys ty (fe_arg_tys', orig_res_ty) = tcSplitFunTys sans_foralls - - (_, stbl_ptr_ty') = tcSplitForAllTys stbl_ptr_ty - (_, stbl_ptr_to_ty) = tcSplitAppTy stbl_ptr_ty' + -- We must use tcSplits here, because we want to see + -- the (IO t) in the corner of the type! fe_arg_tys | isDyn = tail fe_arg_tys' | otherwise = fe_arg_tys' stbl_ptr_ty | isDyn = head fe_arg_tys' | otherwise = error "stbl_ptr_ty" + + (_, stbl_ptr_ty') = tcSplitForAllTys stbl_ptr_ty + (_, stbl_ptr_to_ty) = tcSplitAppTy stbl_ptr_ty' + -- Again, stable pointers are just newtypes, + -- so we must see them! Hence tcSplit* \end{code} @foreign export dynamic@ lets you dress up Haskell IO actions @@ -395,11 +400,12 @@ dsFExportDynamic mod_name id cconv returnDs ([fed, fe], h_code, c_code) where - ty = idType id - (tvs,sans_foralls) = tcSplitForAllTys ty - ([arg_ty], io_res_ty) = tcSplitFunTys sans_foralls - Just (ioTyCon, [res_ty]) = tcSplitTyConApp_maybe io_res_ty - export_ty = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty + ty = idType id + (tvs,sans_foralls) = tcSplitForAllTys ty + ([arg_ty], io_res_ty) = tcSplitFunTys sans_foralls + [res_ty] = tcTyConAppArgs io_res_ty + -- Must use tcSplit* to see the (IO t), which is a newtype + export_ty = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty toCName :: Id -> String toCName i = showSDoc (pprCode CStyle (ppr (idName i))) @@ -455,7 +461,7 @@ fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits) cParamTypes = map showStgType real_args - res_ty_is_unit = res_ty `eqType` unitTy + res_ty_is_unit = res_ty `eqType` unitTy -- Look through any newtypes cResType | res_ty_is_unit = text "void" | otherwise = showStgType res_ty @@ -503,7 +509,7 @@ showStgType t = text "Hs" <> text (showFFIType t) showFFIType :: Type -> String showFFIType t = getOccString (getName tc) where - tc = case splitTyConApp_maybe (repType t) of + tc = case tcSplitTyConApp_maybe (repType t) of Just (tc,_) -> tc Nothing -> pprPanic "showFFIType" (ppr t) \end{code}