functorClassKey,
geClassOpKey,
gtDataConKey,
- iOTyConKey,
intDataConKey,
intPrimTyConKey,
intTyConKey,
liftTyConKey,
listTyConKey,
ltDataConKey,
- mainKey, mainPrimIoKey,
+ mainKey,
minusClassOpKey,
monadClassKey,
monadPlusClassKey,
parErrorIdKey,
parIdKey,
patErrorIdKey,
- primIoTyConKey,
ratioDataConKey,
ratioTyConKey,
rationalTyConKey,
showStringIdKey,
stTyConKey,
stDataConKey,
+ ioTyConKey,
+ ioDataConKey,
+ ioResultTyConKey,
+ ioOkDataConKey,
+ ioFailDataConKey,
stablePtrDataConKey,
stablePtrPrimTyConKey,
stablePtrTyConKey,
floatPrimTyConKey = mkPreludeTyConUnique 11
floatTyConKey = mkPreludeTyConUnique 12
funTyConKey = mkPreludeTyConUnique 13
-iOTyConKey = mkPreludeTyConUnique 14
-intPrimTyConKey = mkPreludeTyConUnique 15
-intTyConKey = mkPreludeTyConUnique 16
-integerTyConKey = mkPreludeTyConUnique 17
-liftTyConKey = mkPreludeTyConUnique 18
-listTyConKey = mkPreludeTyConUnique 19
-foreignObjPrimTyConKey = mkPreludeTyConUnique 20
-foreignObjTyConKey = mkPreludeTyConUnique 21
-mutableArrayPrimTyConKey = mkPreludeTyConUnique 22
-mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 23
-orderingTyConKey = mkPreludeTyConUnique 24
-synchVarPrimTyConKey = mkPreludeTyConUnique 25
-ratioTyConKey = mkPreludeTyConUnique 26
-rationalTyConKey = mkPreludeTyConUnique 27
-realWorldTyConKey = mkPreludeTyConUnique 28
-return2GMPsTyConKey = mkPreludeTyConUnique 29
-returnIntAndGMPTyConKey = mkPreludeTyConUnique 30
-stablePtrPrimTyConKey = mkPreludeTyConUnique 31
-stablePtrTyConKey = mkPreludeTyConUnique 32
-stateAndAddrPrimTyConKey = mkPreludeTyConUnique 33
-stateAndArrayPrimTyConKey = mkPreludeTyConUnique 34
-stateAndByteArrayPrimTyConKey = mkPreludeTyConUnique 35
-stateAndCharPrimTyConKey = mkPreludeTyConUnique 36
-stateAndDoublePrimTyConKey = mkPreludeTyConUnique 37
-stateAndFloatPrimTyConKey = mkPreludeTyConUnique 38
-stateAndIntPrimTyConKey = mkPreludeTyConUnique 39
-stateAndForeignObjPrimTyConKey = mkPreludeTyConUnique 40
-stateAndMutableArrayPrimTyConKey = mkPreludeTyConUnique 41
-stateAndMutableByteArrayPrimTyConKey = mkPreludeTyConUnique 42
-stateAndSynchVarPrimTyConKey = mkPreludeTyConUnique 43
-stateAndPtrPrimTyConKey = mkPreludeTyConUnique 44
-stateAndStablePtrPrimTyConKey = mkPreludeTyConUnique 45
-stateAndWordPrimTyConKey = mkPreludeTyConUnique 46
-statePrimTyConKey = mkPreludeTyConUnique 47
-stateTyConKey = mkPreludeTyConUnique 48
-mutableByteArrayTyConKey = mkPreludeTyConUnique 49
-stTyConKey = mkPreludeTyConUnique 50
-primIoTyConKey = mkPreludeTyConUnique 51
-byteArrayTyConKey = mkPreludeTyConUnique 52
-wordPrimTyConKey = mkPreludeTyConUnique 53
-wordTyConKey = mkPreludeTyConUnique 54
-voidTyConKey = mkPreludeTyConUnique 55
-stRetTyConKey = mkPreludeTyConUnique 56
+intPrimTyConKey = mkPreludeTyConUnique 14
+intTyConKey = mkPreludeTyConUnique 15
+integerTyConKey = mkPreludeTyConUnique 16
+liftTyConKey = mkPreludeTyConUnique 17
+listTyConKey = mkPreludeTyConUnique 18
+foreignObjPrimTyConKey = mkPreludeTyConUnique 19
+foreignObjTyConKey = mkPreludeTyConUnique 20
+mutableArrayPrimTyConKey = mkPreludeTyConUnique 21
+mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 22
+orderingTyConKey = mkPreludeTyConUnique 23
+synchVarPrimTyConKey = mkPreludeTyConUnique 24
+ratioTyConKey = mkPreludeTyConUnique 25
+rationalTyConKey = mkPreludeTyConUnique 26
+realWorldTyConKey = mkPreludeTyConUnique 27
+return2GMPsTyConKey = mkPreludeTyConUnique 28
+returnIntAndGMPTyConKey = mkPreludeTyConUnique 29
+stablePtrPrimTyConKey = mkPreludeTyConUnique 30
+stablePtrTyConKey = mkPreludeTyConUnique 31
+stateAndAddrPrimTyConKey = mkPreludeTyConUnique 32
+stateAndArrayPrimTyConKey = mkPreludeTyConUnique 33
+stateAndByteArrayPrimTyConKey = mkPreludeTyConUnique 34
+stateAndCharPrimTyConKey = mkPreludeTyConUnique 35
+stateAndDoublePrimTyConKey = mkPreludeTyConUnique 36
+stateAndFloatPrimTyConKey = mkPreludeTyConUnique 37
+stateAndIntPrimTyConKey = mkPreludeTyConUnique 38
+stateAndForeignObjPrimTyConKey = mkPreludeTyConUnique 39
+stateAndMutableArrayPrimTyConKey = mkPreludeTyConUnique 40
+stateAndMutableByteArrayPrimTyConKey = mkPreludeTyConUnique 41
+stateAndSynchVarPrimTyConKey = mkPreludeTyConUnique 42
+stateAndPtrPrimTyConKey = mkPreludeTyConUnique 43
+stateAndStablePtrPrimTyConKey = mkPreludeTyConUnique 44
+stateAndWordPrimTyConKey = mkPreludeTyConUnique 45
+statePrimTyConKey = mkPreludeTyConUnique 46
+stateTyConKey = mkPreludeTyConUnique 47
+mutableByteArrayTyConKey = mkPreludeTyConUnique 48
+stTyConKey = mkPreludeTyConUnique 49
+stRetTyConKey = mkPreludeTyConUnique 50
+ioTyConKey = mkPreludeTyConUnique 51
+ioResultTyConKey = mkPreludeTyConUnique 52
+byteArrayTyConKey = mkPreludeTyConUnique 53
+wordPrimTyConKey = mkPreludeTyConUnique 54
+wordTyConKey = mkPreludeTyConUnique 55
+voidTyConKey = mkPreludeTyConUnique 56
\end{code}
%************************************************************************
wordDataConKey = mkPreludeDataConUnique 41
stDataConKey = mkPreludeDataConUnique 42
stRetDataConKey = mkPreludeDataConUnique 43
+ioDataConKey = mkPreludeDataConUnique 44
+ioOkDataConKey = mkPreludeDataConUnique 45
+ioFailDataConKey = mkPreludeDataConUnique 46
\end{code}
%************************************************************************
\begin{code}
fromIntClassOpKey = mkPreludeMiscIdUnique 53
fromIntegerClassOpKey = mkPreludeMiscIdUnique 54
-minusClassOpKey = mkPreludeMiscIdUnique 69
-fromRationalClassOpKey = mkPreludeMiscIdUnique 55
-enumFromClassOpKey = mkPreludeMiscIdUnique 56
-enumFromThenClassOpKey = mkPreludeMiscIdUnique 57
-enumFromToClassOpKey = mkPreludeMiscIdUnique 58
-enumFromThenToClassOpKey= mkPreludeMiscIdUnique 59
-eqClassOpKey = mkPreludeMiscIdUnique 60
-geClassOpKey = mkPreludeMiscIdUnique 61
-zeroClassOpKey = mkPreludeMiscIdUnique 62
-thenMClassOpKey = mkPreludeMiscIdUnique 63 -- (>>=)
-unboundKey = mkPreludeMiscIdUnique 64 -- Just a place holder for unbound
+minusClassOpKey = mkPreludeMiscIdUnique 55
+fromRationalClassOpKey = mkPreludeMiscIdUnique 56
+enumFromClassOpKey = mkPreludeMiscIdUnique 57
+enumFromThenClassOpKey = mkPreludeMiscIdUnique 58
+enumFromToClassOpKey = mkPreludeMiscIdUnique 59
+enumFromThenToClassOpKey= mkPreludeMiscIdUnique 60
+eqClassOpKey = mkPreludeMiscIdUnique 61
+geClassOpKey = mkPreludeMiscIdUnique 62
+zeroClassOpKey = mkPreludeMiscIdUnique 63
+thenMClassOpKey = mkPreludeMiscIdUnique 64 -- (>>=)
+unboundKey = mkPreludeMiscIdUnique 65 -- Just a place holder for unbound
-- variables produced by the renamer
-fromEnumClassOpKey = mkPreludeMiscIdUnique 65
+fromEnumClassOpKey = mkPreludeMiscIdUnique 66
-mainKey = mkPreludeMiscIdUnique 66
-mainPrimIoKey = mkPreludeMiscIdUnique 67
+mainKey = mkPreludeMiscIdUnique 67
returnMClassOpKey = mkPreludeMiscIdUnique 68
--- Used for minusClassOp 69
-otherwiseIdKey = mkPreludeMiscIdUnique 70
-toEnumClassOpKey = mkPreludeMiscIdUnique 71
+otherwiseIdKey = mkPreludeMiscIdUnique 69
+toEnumClassOpKey = mkPreludeMiscIdUnique 70
\end{code}
import DsUtils
import CoreUtils ( coreExprType )
-import Id ( dataConArgTys )
+import Id ( dataConArgTys, dataConTyCon, idType )
import Maybes ( maybeToBool )
import Outputable ( PprStyle(..), Outputable(..) )
import PprType ( GenType{-instances-} )
import PrelVals ( packStringForCId )
import PrimOp ( PrimOp(..) )
import Type ( isPrimType, maybeAppDataTyConExpandingDicts, maybeAppTyCon,
- eqTy, maybeBoxedPrimType, SYN_IE(Type) )
+ eqTy, maybeBoxedPrimType, SYN_IE(Type), GenType(..),
+ splitFunTy, splitForAllTy, splitAppTys )
+import TyCon ( tyConDataCons )
import TysPrim ( byteArrayPrimTy, realWorldTy, realWorldStatePrimTy,
byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
import TysWiredIn ( getStatePairingConInfo,
- stRetDataCon, pairDataCon, unitDataCon,
- stringTy,
+ unitDataCon, stringTy,
realWorldStateTy, stateDataCon
)
import Util ( pprPanic, pprError, panic )
-> [CoreExpr] -- Arguments (desugared)
-> Bool -- True <=> might cause Haskell GC
-> Bool -- True <=> really a "_casm_"
- -> Type -- Type of the result (a boxed-prim type)
+ -> Type -- Type of the result (a boxed-prim IO type)
-> DsM CoreExpr
-dsCCall label args may_gc is_asm result_ty
+dsCCall label args may_gc is_asm io_result_ty
= newSysLocalDs realWorldStatePrimTy `thenDs` \ old_s ->
mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
let
final_args = Var old_s : unboxed_args
+ (ioOkDataCon, result_ty) = getIoOkDataCon io_result_ty
in
- boxResult result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
+ boxResult ioOkDataCon result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
let
the_ccall_op = CCallOp label is_asm may_gc
\begin{code}
-boxResult :: Type -- Type of desired result
+boxResult :: Id -- IOok constructor
+ -> Type -- Type of desired result
-> DsM (Type, -- Type of the result of the ccall itself
CoreExpr -> CoreExpr) -- Wrapper for the ccall
-- to box the result
-boxResult result_ty
+boxResult ioOkDataCon result_ty
| null data_cons
-- oops! can't see the data constructors
= can't_see_datacons_error "result" result_ty
mkConDs the_data_con (map TyArg tycon_arg_tys ++ [VarArg (Var prim_result_id)]) `thenDs` \ the_result ->
- mkConDs stRetDataCon
- [TyArg realWorldTy, TyArg result_ty, VarArg (Var prim_state_id), VarArg the_result]
+ mkConDs ioOkDataCon
+ [TyArg result_ty, VarArg (Var prim_state_id), VarArg the_result]
`thenDs` \ the_pair ->
let
the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
=
newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
- mkConDs stRetDataCon
- [TyArg realWorldTy, TyArg result_ty, VarArg (Var prim_state_id), VarArg (Var unitDataCon)]
+ mkConDs ioOkDataCon
+ [TyArg result_ty, VarArg (Var prim_state_id), VarArg (Var unitDataCon)]
`thenDs` \ the_pair ->
let
(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
+application of the the IO type. The constructor is needed for
+wrapping the result of a _ccall_. The alternative is to wire-in IO,
+which brings a whole heap of junk with it.
+
+If the representation of IO changes, this will probably have to be
+brought in line with the new definition.
+
+newtype IO a = IO (State# RealWorld -> IOResult a)
+
+the constructor IO has type (State# RealWorld -> IOResult a) -> IO a
+
+\begin{code}
+getIoOkDataCon :: Type -> (Id,Type)
+getIoOkDataCon io_result_ty =
+ let
+ AppTy (TyConTy ioTyCon _) result_ty = io_result_ty
+ [ioDataCon] = tyConDataCons ioTyCon
+ ioDataConTy = idType ioDataCon
+ (_,ioDataConTy') = splitForAllTy ioDataConTy
+ ([arg],_) = splitFunTy ioDataConTy'
+ (_,AppTy (TyConTy ioResultTyCon _) _) = splitFunTy arg
+ [ioOkDataCon,ioFailDataCon] = tyConDataCons ioResultTyCon
+ in
+ (ioOkDataCon, result_ty)
+
+\end{code}
+
+Another way to do it, more sensitive:
+
+ case ioDataConTy of
+ ForAll _ (FunTy (FunTy _ (AppTy (TyConTy ioResultTyCon _) _)) _) ->
+ let [ioOkDataCon,ioFailDataCon] = tyConDataCons ioResultTyCon
+ in
+ (ioOkDataCon, result_ty)
+ _ -> pprPanic "getIoOkDataCon: " (ppr PprDebug ioDataConTy)
maybeCharLikeTyCon, maybeIntLikeTyCon,
- eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR, compare_RDR,
- minBound_RDR, maxBound_RDR, enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR,
- enumFromThenTo_RDR, fromEnum_RDR, toEnum_RDR, ratioDataCon_RDR,
- range_RDR, index_RDR, inRange_RDR, readsPrec_RDR, readList_RDR,
- showsPrec_RDR, showList_RDR, plus_RDR, times_RDR, ltTag_RDR, eqTag_RDR, gtTag_RDR,
- eqH_Char_RDR, ltH_Char_RDR, eqH_Word_RDR, ltH_Word_RDR, eqH_Addr_RDR, ltH_Addr_RDR,
- eqH_Float_RDR, ltH_Float_RDR, eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR, ltH_Int_RDR,
- geH_RDR, leH_RDR, minusH_RDR, false_RDR, true_RDR, and_RDR, not_RDR, append_RDR,
- map_RDR, compose_RDR, mkInt_RDR, error_RDR, showString_RDR, showParen_RDR, readParen_RDR,
- lex_RDR, showSpace_RDR, showList___RDR, readList___RDR, negate_RDR,
-
- numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, creturnableClass_RDR,
+ eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR,
+ compare_RDR, minBound_RDR, maxBound_RDR, enumFrom_RDR, enumFromTo_RDR,
+ enumFromThen_RDR, enumFromThenTo_RDR, fromEnum_RDR, toEnum_RDR,
+ ratioDataCon_RDR, range_RDR, index_RDR, inRange_RDR, readsPrec_RDR,
+ readList_RDR, showsPrec_RDR, showList_RDR, plus_RDR, times_RDR,
+ ltTag_RDR, eqTag_RDR, gtTag_RDR, eqH_Char_RDR, ltH_Char_RDR,
+ eqH_Word_RDR, ltH_Word_RDR, eqH_Addr_RDR, ltH_Addr_RDR, eqH_Float_RDR,
+ ltH_Float_RDR, eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR,
+ ltH_Int_RDR, geH_RDR, leH_RDR, minusH_RDR, false_RDR, true_RDR,
+ and_RDR, not_RDR, append_RDR, map_RDR, compose_RDR, mkInt_RDR,
+ error_RDR, showString_RDR, showParen_RDR, readParen_RDR, lex_RDR,
+ showSpace_RDR, showList___RDR, readList___RDR, negate_RDR,
+
+ numClass_RDR, fractionalClass_RDR, eqClass_RDR,
+ ccallableClass_RDR, creturnableClass_RDR,
monadZeroClass_RDR, enumClass_RDR, evalClass_RDR, ordClass_RDR,
+ ioDataCon_RDR, ioOkDataCon_RDR,
- main_NAME, mainPrimIO_NAME, ioTyCon_NAME, primIoTyCon_NAME, allClass_NAME,
+ main_NAME, allClass_NAME, ioTyCon_NAME,
needsDataDeclCtxtClassKeys, cCallishClassKeys, cCallishTyKeys, isNoDictClass,
isNumericClass, isStandardClass, isCcallishClass
, intTyCon
, integerTyCon
, liftTyCon
- , primIoTyCon
, return2GMPsTyCon
, returnIntAndGMPTyCon
, stTyCon
+ , stRetTyCon
, stablePtrTyCon
, stateAndAddrPrimTyCon
, stateAndArrayPrimTyCon
, stateAndStablePtrPrimTyCon
, stateAndSynchVarPrimTyCon
, stateAndWordPrimTyCon
- , stRetTyCon
, voidTyCon
, wordTyCon
]
= mkGlobalName uniq mod occ (Implicit hif)
allClass_NAME = mkKnownKeyGlobal (allClass_RDR, allClassKey)
+ioTyCon_NAME = mkKnownKeyGlobal (ioTyCon_RDR, ioTyConKey)
main_NAME = mkKnownKeyGlobal (main_RDR, mainKey)
-mainPrimIO_NAME = mkKnownKeyGlobal (mainPrimIO_RDR, mainPrimIoKey)
-ioTyCon_NAME = mkKnownKeyGlobal (ioTyCon_RDR, iOTyConKey)
-primIoTyCon_NAME = getName primIoTyCon
knownKeyNames :: [Name]
knownKeyNames
- = [main_NAME, mainPrimIO_NAME, ioTyCon_NAME, allClass_NAME]
+ = [main_NAME, allClass_NAME, ioTyCon_NAME]
++
map mkKnownKeyGlobal
[
-- Type constructors (synonyms especially)
- (orderingTyCon_RDR, orderingTyConKey)
+ (ioOkDataCon_RDR, ioOkDataConKey)
+ , (orderingTyCon_RDR, orderingTyConKey)
, (rationalTyCon_RDR, rationalTyConKey)
, (ratioDataCon_RDR, ratioDataConKey)
, (ratioTyCon_RDR, ratioTyConKey)
intTyCon_RDR = qual (modAndOcc intTyCon)
ioTyCon_RDR = tcQual (iO_BASE, SLIT("IO"))
+ioDataCon_RDR = varQual (iO_BASE, SLIT("IO"))
+ioOkDataCon_RDR = varQual (iO_BASE, SLIT("IOok"))
orderingTyCon_RDR = tcQual (pREL_BASE, SLIT("Ordering"))
rationalTyCon_RDR = tcQual (pREL_NUM, SLIT("Rational"))
ratioTyCon_RDR = tcQual (pREL_NUM, SLIT("Ratio"))
realFloatClass_RDR = tcQual (pREL_NUM, SLIT("RealFloat"))
readClass_RDR = tcQual (pREL_READ, SLIT("Read"))
ixClass_RDR = tcQual (iX, SLIT("Ix"))
-ccallableClass_RDR = tcQual (fOREIGN, SLIT("CCallable"))
-creturnableClass_RDR = tcQual (fOREIGN, SLIT("CReturnable"))
+ccallableClass_RDR = tcQual (cCALL, SLIT("CCallable"))
+creturnableClass_RDR = tcQual (cCALL, SLIT("CReturnable"))
fromInt_RDR = varQual (pREL_BASE, SLIT("fromInt"))
fromInteger_RDR = varQual (pREL_BASE, SLIT("fromInteger"))
times_RDR = varQual (pREL_BASE, SLIT("*"))
mkInt_RDR = varQual (pREL_BASE, SLIT("I#"))
-error_RDR = varQual (iO_BASE, SLIT("error"))
+error_RDR = varQual (eRROR, SLIT("error"))
eqH_Char_RDR = prelude_primop CharEqOp
ltH_Char_RDR = prelude_primop CharLtOp
minusH_RDR = prelude_primop IntSubOp
main_RDR = varQual (mAIN, SLIT("main"))
-mainPrimIO_RDR = varQual (gHC_MAIN, SLIT("mainPrimIO"))
otherwiseId_RDR = varQual (pREL_BASE, SLIT("otherwise"))
\end{code}
projects / ghc-hetmet.git / commitdiff