Commit 47451553 authored by simonpj's avatar simonpj

[project @ 2001-07-16 09:41:26 by simonpj]

Tidy up Type/TcType stuff in DsCCall/DsForeign
parent 4c3a6486
......@@ -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}
......@@ -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}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment