Commit 7caedc52 authored by sof's avatar sof
Browse files

[project @ 1998-11-13 19:35:42 by sof]

Relax restriction that 'foreign import' has got to be an IO action
parent 9a0dbd72
......@@ -10,6 +10,7 @@ module DsCCall
, getIoOkDataCon
, unboxArg
, boxResult
, wrapUnboxedValue
, can'tSeeDataConsPanic
) where
......@@ -205,10 +206,8 @@ boxResult ioOkDataCon result_ty
isUnpointedType the_prim_result_ty -- of primitive type
=
newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
mkConDs the_data_con (map TyArg tycon_arg_tys ++ [VarArg (Var prim_result_id)]) `thenDs` \ the_result ->
wrapUnboxedValue result_ty `thenDs` \ (state_and_prim_datacon,
state_and_prim_ty, prim_result_id, the_result) ->
mkConDs ioOkDataCon
[TyArg result_ty, VarArg (Var prim_state_id), VarArg the_result]
`thenDs` \ the_pair ->
......@@ -239,7 +238,6 @@ boxResult ioOkDataCon result_ty
| otherwise
= pprPanic "boxResult: " (ppr result_ty)
where
maybe_data_type = splitAlgTyConApp_maybe result_ty
Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
......@@ -248,7 +246,43 @@ boxResult ioOkDataCon result_ty
data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
(the_prim_result_ty : other_args_tys) = data_con_arg_tys
(state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
-- (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
-- wrap up an unboxed value.
wrapUnboxedValue :: Type -> DsM (Id, Type, Id, CoreExpr)
wrapUnboxedValue ty
| null data_cons
-- oops! can't see the data constructors
= can'tSeeDataConsPanic "result" ty
-- Data types with a single constructor, which has a single, primitive-typed arg
| (maybeToBool maybe_data_type) && -- Data type
(null other_data_cons) && -- Just one constr
not (null data_con_arg_tys) && null other_args_tys && -- Just one arg
isUnpointedType the_prim_result_ty -- of primitive type
=
newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
mkConDs the_data_con (map TyArg tycon_arg_tys ++
[VarArg (Var prim_result_id)]) `thenDs` \ the_result ->
returnDs (state_and_prim_datacon, state_and_prim_ty, prim_result_id, the_result)
-- Data types with a single nullary constructor
| (maybeToBool maybe_data_type) && -- Data type
(null other_data_cons) && -- Just one constr
(null data_con_arg_tys)
=
let unit = unitDataCon in
returnDs (stateDataCon, realWorldStateTy, unit, Var unit)
| otherwise
= pprPanic "boxResult: " (ppr ty)
where
maybe_data_type = splitAlgTyConApp_maybe ty
Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
(the_data_con : other_data_cons) = data_cons
data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
(the_prim_result_ty : other_args_tys) = data_con_arg_tys
(state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
\end{code}
This grimy bit of code is for digging out the IOok constructor from an
......
......@@ -14,7 +14,7 @@ module DsForeign ( dsForeigns ) where
import CoreSyn
import DsCCall ( getIoOkDataCon, boxResult, unboxArg,
can'tSeeDataConsPanic
can'tSeeDataConsPanic, wrapUnboxedValue
)
import DsMonad
import DsUtils
......@@ -31,7 +31,7 @@ import IdInfo ( noIdInfo )
import Literal ( Literal(..), mkMachInt )
import Maybes ( maybeToBool )
import Name ( nameString, occNameString, nameOccName, nameUnique )
import PrelVals ( packStringForCId, eRROR_ID )
import PrelVals ( packStringForCId, eRROR_ID, realWorldPrimId )
import PrimOp ( PrimOp(..) )
import Type ( isUnpointedType, splitAlgTyConApp_maybe,
splitTyConApp_maybe, splitFunTys, splitForAllTys,
......@@ -54,6 +54,7 @@ import TysWiredIn ( getStatePairingConInfo,
stateAndPtrPrimDataCon,
addrDataCon
)
import Unique
import Outputable
\end{code}
......@@ -125,13 +126,29 @@ dsFImport nm ty may_not_gc ext_name cconv =
mkArgs ty `thenDs` \ (tvs, args, io_res_ty) ->
mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
let
final_args = Var old_s : unboxed_args
the_state_arg
| is_io_action = old_s
| otherwise = realWorldPrimId
final_args = Var the_state_arg : unboxed_args
(ioOkDataCon, ioDataCon, result_ty) = getIoOkDataCon io_res_ty
is_io_action =
case (splitTyConApp_maybe io_res_ty) of
Just (iot,[_]) -> (uniqueOf iot) == ioTyConKey
_ -> False
in
boxResult ioOkDataCon result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
(if not is_io_action then
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_tok ->
wrapUnboxedValue io_res_ty `thenDs` \ (state_and_foo, state_and_foo_ty, v, res_v) ->
let the_alt = (state_and_foo, [state_tok,v], res_v) in
returnDs (state_and_foo_ty, \ prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault))
else
boxResult ioOkDataCon result_ty) `thenDs` \ (final_result_ty, res_wrapper) ->
(case ext_name of
Dynamic -> getUniqueDs `thenDs` \ u -> returnDs (Right u)
ExtName fs _ -> returnDs (Left fs)) `thenDs` \ label ->
Dynamic -> getUniqueDs `thenDs` \ u ->
returnDs (Right u)
ExtName fs _ -> returnDs (Left fs)) `thenDs` \ label ->
let
the_ccall_op = CCallOp label False (not may_not_gc) cconv
(map coreExprType final_args)
......@@ -139,12 +156,18 @@ dsFImport nm ty may_not_gc ext_name cconv =
in
mkPrimDs the_ccall_op (map VarArg final_args) `thenDs` \ the_prim_app ->
let
the_body = mkValLam [old_s]
(foldr ($) (res_wrapper the_prim_app) arg_wrappers)
body = foldr ($) (res_wrapper the_prim_app) arg_wrappers
the_body
| not is_io_action = body
| otherwise = mkValLam [old_s] body
in
newSysLocalDs (coreExprType the_body) `thenDs` \ ds ->
let
io_app = mkValApp (mkTyApp (Var ioDataCon) [result_ty]) [VarArg ds]
io_app
| is_io_action = mkValApp (mkTyApp (Var ioDataCon) [result_ty]) [VarArg ds]
| otherwise = Var ds
fo_rhs = mkTyLam tvs $
mkValLam (map (\ (Var x) -> x) args)
(mkCoLetAny (NonRec ds the_body) io_app)
......
......@@ -222,7 +222,8 @@ checkForeignRes pred_res_ty ty =
| (uniqueOf io) == ioTyConKey &&
pred_res_ty res_ty
-> returnTc ()
_ -> check False (illegalForeignTyErr False{-Res-} ty)
_ | pred_res_ty ty -> returnTc ()
| otherwise -> check False (illegalForeignTyErr False{-Res-} ty)
\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