From 7caedc52dde9fb7f773fb3a1d5fc0f7b2d8de848 Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Fri, 13 Nov 1998 19:35:44 +0000
Subject: [PATCH] [project @ 1998-11-13 19:35:42 by sof] Relax restriction that
'foreign import' has got to be an IO action
---
ghc/compiler/deSugar/DsCCall.lhs | 46 ++++++++++++++++++++++++----
ghc/compiler/deSugar/DsForeign.lhs | 41 +++++++++++++++++++------
ghc/compiler/typecheck/TcForeign.lhs | 3 +-
3 files changed, 74 insertions(+), 16 deletions(-)
diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index 511c2882b8e1..c50050508013 100644
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -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
diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index 52b177b4708a..878ac17f35a2 100644
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -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)
diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs
index 638247200344..2b689acaa992 100644
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -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}
--
GitLab