From cfbedcecad9f9c4241fa1313e73468fd95db76b3 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 7 Apr 2000 13:45:48 +0000 Subject: [PATCH] [project @ 2000-04-07 13:45:46 by simonpj] * Fix 'foreign export' and 'foreign export dynamic' so that we can export pure (non-IO) functions as well as IO-ish ones NB: There's a change to PrelIOBase, so you'll need to recompile the Prelude * Add Type.mkDictTys and call it in various places. --- ghc/compiler/basicTypes/DataCon.lhs | 4 +- ghc/compiler/basicTypes/MkId.lhs | 6 +- ghc/compiler/basicTypes/Unique.lhs | 8 +- ghc/compiler/deSugar/DsForeign.lhs | 217 ++++++++++++++----------------- ghc/compiler/prelude/PrelInfo.lhs | 5 +- ghc/compiler/rename/RnIfaces.lhs | 7 +- ghc/compiler/rename/RnMonad.lhs | 1 - ghc/compiler/rename/RnSource.lhs | 4 +- ghc/compiler/simplCore/SimplCore.lhs | 4 +- ghc/compiler/stranal/SaAbsInt.lhs | 3 +- ghc/compiler/typecheck/Inst.lhs | 4 +- ghc/compiler/typecheck/TcClassDcl.lhs | 4 +- ghc/compiler/typecheck/TcForeign.lhs | 33 +++-- ghc/compiler/typecheck/TcTyClsDecls.lhs | 2 +- ghc/compiler/types/Type.lhs | 22 +--- ghc/compiler/types/Variance.lhs | 1 - ghc/lib/std/PrelIOBase.lhs | 6 +- 17 files changed, 151 insertions(+), 180 deletions(-) diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index e849e73..b998ef2 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -31,7 +31,7 @@ import CmdLineOpts ( opt_DictsStrict ) import TysPrim import Type ( Type, ThetaType, TauType, ClassContext, mkForAllTys, mkFunTys, mkTyConApp, - mkTyVarTys, mkDictTy, + mkTyVarTys, mkDictTys, splitAlgTyConApp_maybe, classesToPreds ) import TyCon ( TyCon, tyConDataCons, isDataTyCon, isProductTyCon, @@ -262,7 +262,7 @@ mkDataCon name arg_stricts fields (real_arg_stricts, strict_arg_tyss) = unzip (zipWith (unbox_strict_arg_ty tycon) arg_stricts orig_arg_tys) - rep_arg_tys = [mkDictTy cls tys | (cls,tys) <- ex_theta] ++ concat strict_arg_tyss + rep_arg_tys = mkDictTys ex_theta ++ concat strict_arg_tyss ex_dict_stricts = map mk_dict_strict_mark ex_theta -- Add a strictness flag for the existential dictionary arguments diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index c83a230..661e3f5 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -40,7 +40,7 @@ import TysWiredIn ( boolTy, charTy, mkListTy ) import PrelMods ( pREL_ERR, pREL_GHC ) import PrelRules ( primOpRule ) import Rules ( addRule ) -import Type ( Type, ClassContext, mkDictTy, mkTyConApp, mkTyVarTys, +import Type ( Type, ClassContext, mkDictTy, mkDictTys, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy, classesToPreds, isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, tyVarsOfTypes, splitSigmaTy, splitFunTy_maybe, @@ -286,8 +286,8 @@ mkDataConWrapId data_con (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con all_tyvars = tyvars ++ ex_tyvars - dict_tys = [mkDictTy clas tys | (clas,tys) <- theta] - ex_dict_tys = [mkDictTy clas tys | (clas,tys) <- ex_theta] + dict_tys = mkDictTys theta + ex_dict_tys = mkDictTys ex_theta all_arg_tys = dict_tys ++ ex_dict_tys ++ orig_arg_tys result_ty = mkTyConApp tycon (mkTyVarTys tyvars) diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 3b7c614..868fe76 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -154,6 +154,7 @@ module Unique ( recConErrorIdKey, recSelErrIdKey, recUpdErrorIdKey, + returnIOIdKey, returnMClassOpKey, runSTRepIdKey, showClassKey, @@ -635,9 +636,10 @@ concatIdKey = mkPreludeMiscIdUnique 33 filterIdKey = mkPreludeMiscIdUnique 34 zipIdKey = mkPreludeMiscIdUnique 35 bindIOIdKey = mkPreludeMiscIdUnique 36 -deRefStablePtrIdKey = mkPreludeMiscIdUnique 37 -makeStablePtrIdKey = mkPreludeMiscIdUnique 38 -getTagIdKey = mkPreludeMiscIdUnique 39 +returnIOIdKey = mkPreludeMiscIdUnique 37 +deRefStablePtrIdKey = mkPreludeMiscIdUnique 38 +makeStablePtrIdKey = mkPreludeMiscIdUnique 39 +getTagIdKey = mkPreludeMiscIdUnique 40 \end{code} Certain class operations from Prelude classes. They get their own diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index c1fb6fe..f946acb 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -20,7 +20,7 @@ import HsSyn ( ExtName(..), ForeignDecl(..), isDynamicExtName, ForKind(..) ) import HsDecls ( extNameStatic ) import CallConv import TcHsSyn ( TypecheckedForeignDecl ) -import CoreUtils ( exprType, mkInlineMe, bindNonRec ) +import CoreUtils ( exprType, mkInlineMe ) import DataCon ( DataCon, dataConWrapId ) import Id ( Id, idType, idName, mkWildId, mkVanillaId ) import MkId ( mkWorkerId ) @@ -30,16 +30,16 @@ import Name ( mkGlobalName, nameModule, nameOccName, getOccString, mkForeignExportOcc, isLocalName, NamedThing(..), Provenance(..), ExportFlag(..) ) -import PrelInfo ( deRefStablePtr_NAME, bindIO_NAME, makeStablePtr_NAME ) +import PrelInfo ( deRefStablePtr_NAME, returnIO_NAME, bindIO_NAME, makeStablePtr_NAME ) import Type ( unUsgTy, splitTyConApp_maybe, splitFunTys, splitForAllTys, Type, mkFunTys, mkForAllTys, mkTyConApp, - mkTyVarTy, mkFunTy, splitAppTy + mkTyVarTy, mkFunTy, splitAppTy, applyTy, funResultTy ) import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) import Var ( TyVar ) import TysPrim ( realWorldStatePrimTy, addrPrimTy ) -import TysWiredIn ( unitTyCon, addrTy, stablePtrTyCon, +import TysWiredIn ( unitTy, addrTy, stablePtrTyCon, unboxedTupleCon, addrDataCon ) import Unique @@ -193,22 +193,30 @@ dsFExport :: Id , SDoc , SDoc ) -dsFExport i ty mod_name ext_name cconv isDyn = - getUniqueDs `thenDs` \ uniq -> - getSrcLocDs `thenDs` \ src_loc -> - let - f_helper_glob = mkVanillaId helper_name helper_ty - where - name = idName i - mod - | isLocalName name = mod_name - | otherwise = nameModule name - - occ = mkForeignExportOcc (nameOccName name) - prov = LocalDef src_loc Exported - helper_name = mkGlobalName uniq mod occ prov - in - newSysLocalsDs fe_arg_tys `thenDs` \ fe_args -> +dsFExport i ty mod_name ext_name cconv isDyn + = -- BUILD THE returnIO WRAPPER, if necessary + -- Look at the result type of the exported function, orig_res_ty + -- If it's IO t, return (\x.x, IO t, t) + -- If it's plain t, return (\x.returnIO x, IO t, t) + (case splitTyConApp_maybe orig_res_ty of + Just (ioTyCon, [res_ty]) + -> ASSERT( getUnique ioTyCon == ioTyConKey ) + -- The function already returns IO t + returnDs (\body -> body, orig_res_ty, res_ty) + + other -> -- The function returns t, so wrap the call in returnIO + dsLookupGlobalValue returnIO_NAME `thenDs` \ retIOId -> + returnDs (\body -> mkApps (Var retIOId) [Type orig_res_ty, body], + funResultTy (applyTy (idType retIOId) orig_res_ty), + -- We don't have ioTyCon conveniently to hand + orig_res_ty) + + ) `thenDs` \ (return_io_wrapper, -- Either identity or returnIO + io_res_ty, -- IO t + res_ty) -> -- t + + + -- BUILD THE deRefStablePtr WRAPPER, if necessary (if isDyn then newSysLocalDs stbl_ptr_ty `thenDs` \ stbl_ptr -> newSysLocalDs stbl_ptr_to_ty `thenDs` \ stbl_value -> @@ -217,19 +225,13 @@ dsFExport i ty mod_name ext_name cconv isDyn = the_deref_app = mkApps (Var deRefStablePtrId) [ Type stbl_ptr_to_ty, Var stbl_ptr ] in - newSysLocalDs (exprType the_deref_app) `thenDs` \ x_deref_app -> dsLookupGlobalValue bindIO_NAME `thenDs` \ bindIOId -> - newSysLocalDs (mkFunTy stbl_ptr_to_ty - (mkTyConApp ioTyCon [res_ty])) `thenDs` \ x_cont -> let - stbl_app = \ cont -> - bindNonRec x_cont (mkLams [stbl_value] cont) $ - bindNonRec x_deref_app the_deref_app - (mkApps (Var bindIOId) - [ Type stbl_ptr_to_ty - , Type res_ty - , Var x_deref_app - , Var x_cont]) + stbl_app cont = mkApps (Var bindIOId) + [ Type stbl_ptr_to_ty + , Type res_ty + , the_deref_app + , mkLams [stbl_value] cont] in returnDs (stbl_value, stbl_app, stbl_ptr) else @@ -237,67 +239,56 @@ dsFExport i ty mod_name ext_name cconv isDyn = \ body -> body, panic "stbl_ptr" -- should never be touched. )) `thenDs` \ (i, getFun_wrapper, stbl_ptr) -> - let - wrapper_args - | isDyn = stbl_ptr:fe_args - | otherwise = fe_args - wrapper_arg_tys - | isDyn = stbl_ptr_ty:helper_arg_tys - | otherwise = helper_arg_tys - the_app = - getFun_wrapper $ - mkApps (Var i) (map (Type . mkTyVarTy) tvs ++ map Var fe_args) - in + -- BUILD THE HELPER getModuleDs `thenDs` \ mod -> getUniqueDs `thenDs` \ uniq -> + getSrcLocDs `thenDs` \ src_loc -> + newSysLocalsDs fe_arg_tys `thenDs` \ fe_args -> let - the_body = mkLams (tvs ++ wrapper_args) the_app - c_nm = extNameStatic ext_name + wrapper_args | isDyn = stbl_ptr:fe_args + | otherwise = fe_args - (h_stub, c_stub) = fexportEntry (moduleUserString mod) + wrapper_arg_tys | isDyn = stbl_ptr_ty:fe_arg_tys + | otherwise = fe_arg_tys + + helper_ty = mkForAllTys tvs $ + mkFunTys wrapper_arg_tys io_res_ty + + f_helper_glob = mkVanillaId helper_name helper_ty + where + name = idName i + mod + | isLocalName name = mod_name + | otherwise = nameModule name + + occ = mkForeignExportOcc (nameOccName name) + prov = LocalDef src_loc Exported + helper_name = mkGlobalName uniq mod occ prov + + the_app = getFun_wrapper (return_io_wrapper (mkVarApps (Var i) (tvs ++ fe_args))) + the_body = mkLams (tvs ++ wrapper_args) the_app + c_nm = extNameStatic ext_name + + (h_stub, c_stub) = fexportEntry (moduleUserString mod) c_nm f_helper_glob - wrapper_arg_tys the_result_ty cconv isDyn + wrapper_arg_tys res_ty cconv isDyn in returnDs (NonRec f_helper_glob the_body, h_stub, c_stub) where - (tvs,sans_foralls) = splitForAllTys ty - (fe_arg_tys', io_res) = splitFunTys sans_foralls - - - Just (ioTyCon, [res_ty]) = splitTyConApp_maybe io_res + (fe_arg_tys', orig_res_ty) = splitFunTys sans_foralls (_, stbl_ptr_ty') = splitForAllTys stbl_ptr_ty (_, stbl_ptr_to_ty) = splitAppTy stbl_ptr_ty' - fe_arg_tys - | isDyn = tail fe_arg_tys' - | otherwise = fe_arg_tys' - - (stbl_ptr_ty, helper_arg_tys) = - case fe_arg_tys' of - (x:xs) | isDyn -> (x,xs) - ls -> (error "stbl_ptr_ty", ls) - - helper_ty = - mkForAllTys tvs $ - mkFunTys arg_tys io_res - where - arg_tys - | isDyn = stbl_ptr_ty : helper_arg_tys - | otherwise = helper_arg_tys - - the_result_ty = - case splitTyConApp_maybe io_res of - Just (_,[res_ty]) -> - case splitTyConApp_maybe res_ty of - Just (tc,_) | getUnique tc /= getUnique unitTyCon -> Just res_ty - _ -> Nothing - _ -> Nothing - + 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" \end{code} @foreign export dynamic@ lets you dress up Haskell IO actions @@ -345,25 +336,21 @@ dsFExportDynamic i ty mod_name ext_name cconv = in dsFExport i export_ty mod_name fe_ext_name cconv True `thenDs` \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) -> - newSysLocalDs arg_ty `thenDs` \ cback -> - dsLookupGlobalValue makeStablePtr_NAME `thenDs` \ makeStablePtrId -> + newSysLocalDs arg_ty `thenDs` \ cback -> + dsLookupGlobalValue makeStablePtr_NAME `thenDs` \ makeStablePtrId -> let mk_stbl_ptr_app = mkApps (Var makeStablePtrId) [ Type arg_ty, Var cback ] - mk_stbl_ptr_app_ty = exprType mk_stbl_ptr_app in - newSysLocalDs mk_stbl_ptr_app_ty `thenDs` \ x_mk_stbl_ptr_app -> dsLookupGlobalValue bindIO_NAME `thenDs` \ bindIOId -> newSysLocalDs (mkTyConApp stablePtrTyCon [arg_ty]) `thenDs` \ stbl_value -> let - stbl_app = \ x_cont cont ret_ty -> - bindNonRec x_cont cont $ - bindNonRec x_mk_stbl_ptr_app mk_stbl_ptr_app $ - (mkApps (Var bindIOId) - [ Type (mkTyConApp stablePtrTyCon [arg_ty]) - , Type ret_ty - , Var x_mk_stbl_ptr_app - , Var x_cont - ]) + stbl_app cont ret_ty + = mkApps (Var bindIOId) + [ Type (mkTyConApp stablePtrTyCon [arg_ty]) + , Type ret_ty + , mk_stbl_ptr_app + , cont + ] {- The arguments to the external function which will @@ -380,34 +367,31 @@ dsFExportDynamic i ty mod_name ext_name cconv = -- (probably in the RTS.) adjustor = SLIT("createAdjustor") in - dsCCall adjustor adj_args False False addrTy `thenDs` \ ccall_adj -> + dsCCall adjustor adj_args False False ioAddrTy `thenDs` \ ccall_adj -> let ccall_adj_ty = exprType ccall_adj + ccall_io_adj = mkLams [stbl_value] $ + Note (Coerce io_res_ty (unUsgTy ccall_adj_ty)) + ccall_adj in - newSysLocalDs ccall_adj_ty `thenDs` \ x_ccall_adj -> - let ccall_io_adj = - mkLams [stbl_value] $ - bindNonRec x_ccall_adj ccall_adj $ - Note (Coerce (mkTyConApp ioTyCon [res_ty]) (unUsgTy ccall_adj_ty)) - (Var x_ccall_adj) - in - newSysLocalDs (exprType ccall_io_adj) `thenDs` \ x_ccall_io_adj -> let io_app = mkLams tvs $ mkLams [cback] $ - stbl_app x_ccall_io_adj ccall_io_adj addrTy + stbl_app ccall_io_adj addrTy in returnDs (NonRec i io_app, fe, h_code, c_code) where (tvs,sans_foralls) = splitForAllTys ty - ([arg_ty], io_res) = splitFunTys sans_foralls + ([arg_ty], io_res_ty) = splitFunTys sans_foralls - Just (ioTyCon, [res_ty]) = splitTyConApp_maybe io_res + Just (ioTyCon, [res_ty]) = splitTyConApp_maybe io_res_ty export_ty = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty + ioAddrTy :: Type -- IO Addr + ioAddrTy = mkTyConApp ioTyCon [addrTy] + toCName :: Id -> String toCName i = showSDoc (pprCode CStyle (ppr (idName i))) - \end{code} %* @@ -425,11 +409,11 @@ fexportEntry :: String -> FAST_STRING -> Id -> [Type] - -> Maybe Type + -> Type -> CallConv -> Bool -> (SDoc, SDoc) -fexportEntry mod_nm c_nm helper args res cc isDyn = (header_bits, c_bits) +fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits) where -- name of the (Haskell) helper function generated by the desugarer. h_nm = ppr helper <> text "_closure" @@ -449,7 +433,9 @@ fexportEntry mod_nm c_nm helper args res cc isDyn = (header_bits, c_bits) -- create the application + perform it. , text "rc=rts_evalIO" <> parens (foldl appArg (text "(StgClosure*)&" <> h_nm) (zip args c_args) <> comma <> text "&ret") <> semi - , returnResult + , text "rts_checkSchedStatus" <> parens (doubleQuotes (text mod_nm <> char '.' <> ptext c_nm) + <> comma <> text "rc") <> semi + , text "return" <> return_what <> semi , rbrace ] @@ -458,10 +444,10 @@ fexportEntry mod_nm c_nm helper args res cc isDyn = (header_bits, c_bits) cParamTypes = map showStgType real_args - cResType = - case res of - Nothing -> text "void" - Just t -> showStgType t + res_ty_is_unit = res_ty == unitTy + + cResType | res_ty_is_unit = text "void" + | otherwise = showStgType res_ty pprCconv | cc == cCallConv = empty @@ -473,17 +459,8 @@ fexportEntry mod_nm c_nm helper args res cc isDyn = (header_bits, c_bits) mkExtern ty nm = text "extern" <+> ty <+> nm <> semi - returnResult = - text "rts_checkSchedStatus" <> - parens (doubleQuotes (text mod_nm <> char '.' <> ptext c_nm) <> comma <> text "rc") <> semi $$ - (case res of - Nothing -> text "return" - Just _ -> text "return" <> parens (res_name)) <> semi - - res_name = - case res of - Nothing -> empty - Just t -> unpackHObj t <> parens (text "ret") + return_what | res_ty_is_unit = empty + | otherwise = parens (unpackHObj res_ty <> parens (text "ret")) c_args = mkCArgNames 0 args diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index f049e0e..4c94443 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -21,7 +21,7 @@ module PrelInfo ( -- Random other things main_NAME, ioTyCon_NAME, deRefStablePtr_NAME, makeStablePtr_NAME, - bindIO_NAME, + bindIO_NAME, returnIO_NAME, maybeCharLikeCon, maybeIntLikeCon, needsDataDeclCtxtClassKeys, cCallishClassKeys, cCallishTyKeys, @@ -203,6 +203,7 @@ main_NAME = mkKnownKeyGlobal (main_RDR, mainKey) -- Operations needed when compiling FFI decls bindIO_NAME = mkKnownKeyGlobal (bindIO_RDR, bindIOIdKey) +returnIO_NAME = mkKnownKeyGlobal (returnIO_RDR, returnIOIdKey) deRefStablePtr_NAME = mkKnownKeyGlobal (deRefStablePtr_RDR, deRefStablePtrIdKey) makeStablePtr_NAME = mkKnownKeyGlobal (makeStablePtr_RDR, makeStablePtrIdKey) @@ -266,6 +267,7 @@ knownKeyNames , (deRefStablePtr_RDR, deRefStablePtrIdKey) , (makeStablePtr_RDR, makeStablePtrIdKey) , (bindIO_RDR, bindIOIdKey) + , (returnIO_RDR, returnIOIdKey) , (map_RDR, mapIdKey) , (append_RDR, appendIdKey) @@ -320,6 +322,7 @@ intTyCon_RDR = nameRdrName (getName intTyCon) ioTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("IO") ioDataCon_RDR = dataQual pREL_IO_BASE_Name SLIT("IO") bindIO_RDR = varQual pREL_IO_BASE_Name SLIT("bindIO") +returnIO_RDR = varQual pREL_IO_BASE_Name SLIT("returnIO") orderingTyCon_RDR = tcQual pREL_BASE_Name SLIT("Ordering") diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index ff3f51c..8ff191f 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -123,8 +123,7 @@ loadInterface doc_str mod_name from mod_map_result -> -- READ THE MODULE IN - findAndReadIface doc_str mod_name from below_me - `thenRn` \ (hi_boot_read, read_result) -> + findAndReadIface doc_str mod_name from below_me `thenRn` \ (hi_boot_read, read_result) -> case read_result of { Nothing -> -- Not found, so add an empty export env to the Ifaces map -- so that we don't look again @@ -1049,7 +1048,9 @@ cannaeReadFile file err text (show err)] getDeclErr name - = ptext SLIT("Failed to find interface decl for") <+> quotes (ppr name) + = vcat [ptext SLIT("Failed to find interface decl for") <+> quotes (ppr name), + ptext SLIT("from module") <+> quotes (ppr (nameModule name)) + ] getDeclWarn name loc = sep [ptext SLIT("Failed to find (optional) interface decl for") <+> quotes (ppr name), diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 95a248e..197f6ae 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -760,5 +760,4 @@ lookupModuleRn x = case lookupFM himap x of Nothing -> returnRn (mkVanillaModule x) Just (_,x) -> returnRn x - \end{code} diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 9897fd8..40be2b7 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -43,7 +43,7 @@ import OccName ( mkDefaultMethodOcc ) import BasicTypes ( TopLevelFlag(..) ) import FiniteMap ( elemFM ) import PrelInfo ( derivableClassKeys, - deRefStablePtr_NAME, makeStablePtr_NAME, bindIO_NAME + deRefStablePtr_NAME, makeStablePtr_NAME, bindIO_NAME, returnIO_NAME ) import Bag ( bagToList ) import List ( partition, nub ) @@ -358,7 +358,7 @@ rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc)) FoLabel -> emptyFVs FoExport | isDyn -> mkNameSet [makeStablePtr_NAME, deRefStablePtr_NAME, - bindIO_NAME] + bindIO_NAME, returnIO_NAME] | otherwise -> mkNameSet [name'] _ -> emptyFVs in diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index f3a5d14..dc8ffb8 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -59,9 +59,7 @@ import StrictAnal ( saBinds ) import WorkWrap ( wwTopBinds ) import CprAnalyse ( cprAnalyse ) -import Unique ( Unique, Uniquable(..), - ratioTyConKey - ) +import Unique ( Unique, Uniquable(..) ) import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply ) import Util ( mapAccumL ) import SrcLoc ( noSrcLoc ) diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index 3c7dfb5..bec1d11 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -571,7 +571,8 @@ absApply AbsAnal (AbsApproxFun (d:ds) val) arg other -> AbsApproxFun ds val #ifdef DEBUG -absApply anal f@(AbsProd _) arg = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr f) <+> (ppr arg)) +absApply anal f@(AbsProd _) arg + = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr f) <+> (ppr arg)) #endif \end{code} diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index aa65498..55a1a4f4 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -476,8 +476,8 @@ instToId :: Inst -> TcId instToId inst = instToIdBndr inst instToIdBndr :: Inst -> TcId -instToIdBndr (Dict u (Class clas ty) (_,loc,_)) - = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas ty) loc +instToIdBndr (Dict u (Class clas tys) (_,loc,_)) + = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas tys) loc instToIdBndr (Dict u (IParam n ty) (_,loc,_)) = ipToId n ty loc diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index f0eb0be..a5aee6b 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -54,7 +54,7 @@ import Name ( Name, nameOccName, isLocallyDefined, NamedThing(..) ) import NameSet ( emptyNameSet ) import Outputable import Type ( Type, ThetaType, ClassContext, - mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, + mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, mkDictTys, mkSigmaTy, mkForAllTys, mkClassPred, classesOfPreds, boxedTypeKind, mkArrowKind ) @@ -241,7 +241,7 @@ tcClassContext class_name rec_class rec_tyvars context sc_sel_names let sc_theta' = classesOfPreds sc_theta - sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta'] + sc_tys = mkDictTys sc_theta' sc_sel_ids = zipWithEqual "tcClassContext" mk_super_id sc_sel_names sc_tys in -- Done diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 58c73ab..1a7b6e9 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -177,53 +177,53 @@ checkForeignImport is_dynamic is_safe ty args res (x:xs) -> check (isAddrTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_` mapTc (checkForeignArg (isFFIArgumentTy is_safe)) xs `thenTc_` - checkForeignRes (isFFIResultTy) res + checkForeignRes True {-NonIO ok-} isFFIResultTy res | otherwise = mapTc (checkForeignArg (isFFIArgumentTy is_safe)) args `thenTc_` - checkForeignRes (isFFIResultTy) res + checkForeignRes True {-NonIO ok-} isFFIResultTy res checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM s () checkForeignExport is_dynamic ty args res | is_dynamic = -- * the first (and only!) arg has got to be a function type - -- * result type is an Addr + -- and it must return IO t + -- * result type is an Addr or IO Addr case args of [arg] -> case splitFunTys arg of (arg_tys, res_ty) -> - mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_` - checkForeignRes (isFFIResultTy) res_ty `thenTc_` - checkForeignRes (isAddrTy) res + mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_` + checkForeignRes True {-NonIO ok-} isFFIResultTy res_ty `thenTc_` + checkForeignRes False {-Must be IO-} isAddrTy res _ -> check False (illegalForeignTyErr True{-Arg-} ty) | otherwise = mapTc (checkForeignArg isFFIExternalTy) args `thenTc_` - checkForeignRes (isFFIResultTy) res + checkForeignRes True {-NonIO ok-} isFFIResultTy res -check :: Bool -> Message -> TcM s () -check True _ = returnTc () -check _ the_err = addErrTc the_err `thenNF_Tc_` returnTc () - checkForeignArg :: (Type -> Bool) -> Type -> TcM s () checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty) -- Check that the type has the form -- (IO t) or (t) , and that t satisfies the given predicate. -- -checkForeignRes :: (Type -> Bool) -> Type -> TcM s () -checkForeignRes pred_res_ty ty = +checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM s () +checkForeignRes non_io_result_ok pred_res_ty ty = case (splitTyConApp_maybe ty) of Just (io, [res_ty]) | (getUnique io) == ioTyConKey && pred_res_ty res_ty -> returnTc () _ - | pred_res_ty ty -> returnTc () - | otherwise -> check False (illegalForeignTyErr False{-Res-} ty) - + -> check (non_io_result_ok && pred_res_ty ty) + (illegalForeignTyErr False{-Res-} ty) \end{code} Warnings \begin{code} +check :: Bool -> Message -> TcM s () +check True _ = returnTc () +check _ the_err = addErrTc the_err `thenNF_Tc_` returnTc () + illegalForeignTyErr isArg ty = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration:")]) 4 (hsep [ppr ty]) @@ -235,5 +235,4 @@ illegalForeignTyErr isArg ty foreignDeclCtxt fo = hang (ptext SLIT("When checking declaration:")) 4 (ppr fo) - \end{code} diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 88b7428..701c15c 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -29,7 +29,7 @@ import TcTyDecls ( tcTyDecl, kcTyDecl ) import TcMonoType ( kcHsTyVar ) import TcType ( TcKind, newKindVar, newKindVars, kindToTcKind, zonkTcKindToKind ) -import Type ( mkArrowKind, boxedTypeKind, mkDictTy ) +import Type ( mkArrowKind, boxedTypeKind ) import Class ( Class ) import Var ( TyVar, tyVarKind ) diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 1aaf17a..6ec5e2d 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -34,7 +34,7 @@ module Type ( mkTyConApp, mkTyConTy, splitTyConApp_maybe, splitAlgTyConApp_maybe, splitAlgTyConApp, - mkDictTy, mkPredTy, splitPredTy_maybe, splitDictTy_maybe, isDictTy, + mkDictTy, mkDictTys, mkPredTy, splitPredTy_maybe, splitDictTy_maybe, isDictTy, mkSynTy, isSynTy, deNoteType, @@ -335,23 +335,13 @@ tell from the type constructor whether it's a dictionary or not. mkDictTy :: Class -> [Type] -> Type mkDictTy clas tys = TyConApp (classTyCon clas) tys +mkDictTys :: ClassContext -> [Type] +mkDictTys cxt = [mkDictTy cls tys | (cls,tys) <- cxt] + mkPredTy :: PredType -> Type mkPredTy (Class clas tys) = TyConApp (classTyCon clas) tys mkPredTy (IParam n ty) = NoteTy (IPNote n) ty -{- -splitDictTy_maybe :: Type -> Maybe (Class, [Type]) -splitDictTy_maybe (TyConApp tc tys) - | maybeToBool maybe_class - && tyConArity tc == length tys = Just (clas, tys) - where - maybe_class = tyConClass_maybe tc - Just clas = maybe_class - -splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty -splitDictTy_maybe other = Nothing --} - splitPredTy_maybe :: Type -> Maybe PredType splitPredTy_maybe (TyConApp tc tys) | maybeToBool maybe_class @@ -368,7 +358,7 @@ splitPredTy_maybe other = Nothing splitDictTy_maybe :: Type -> Maybe (Class, [Type]) splitDictTy_maybe ty = case splitPredTy_maybe ty of - Just p -> getClassTys_maybe p + Just p -> getClassTys_maybe p Nothing -> Nothing isDictTy :: Type -> Bool @@ -712,7 +702,7 @@ mkClassPred clas tys = Class clas tys getClassTys_maybe :: PredType -> Maybe ClassPred getClassTys_maybe (Class clas tys) = Just (clas, tys) -getClassTys_maybe _ = Nothing +getClassTys_maybe _ = Nothing ipName_maybe :: PredType -> Maybe Name ipName_maybe (IParam n _) = Just n diff --git a/ghc/compiler/types/Variance.lhs b/ghc/compiler/types/Variance.lhs index 52f5d08..dfab7a8 100644 --- a/ghc/compiler/types/Variance.lhs +++ b/ghc/compiler/types/Variance.lhs @@ -12,7 +12,6 @@ module Variance( #include "HsVersions.h" import TypeRep ( Type(..), TyNote(..) ) -- friend -import Type ( mkDictTy ) import TyCon ( TyCon, ArgVrcs, tyConKind, tyConArity, tyConDataCons, tyConTyVars, tyConArgVrcs_maybe, getSynTyConDefn, isSynTyCon, isAlgTyCon ) import DataCon ( dataConRepArgTys ) diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs index ebcea05..3d4714c 100644 --- a/ghc/lib/std/PrelIOBase.lhs +++ b/ghc/lib/std/PrelIOBase.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelIOBase.lhs,v 1.19 2000/03/28 08:51:09 simonmar Exp $ +% $Id: PrelIOBase.lhs,v 1.20 2000/04/07 13:45:48 simonpj Exp $ % % (c) The AQUA Project, Glasgow University, 1994-1998 % @@ -87,7 +87,7 @@ instance Monad IO where {-# INLINE (>>) #-} {-# INLINE (>>=) #-} m >> k = m >>= \ _ -> k - return x = IO $ \ s -> (# s, x #) + return x = returnIO x m >>= k = bindIO m k fail s = error s -- not ioError? @@ -101,6 +101,8 @@ bindIO (IO m) k = IO ( \ s -> (# new_s, a #) -> unIO (k a) new_s ) +returnIO :: a -> IO a +returnIO x = IO (\ s -> (# s, x #)) #endif \end{code} -- 1.7.10.4