From: simonm Date: Tue, 11 Nov 1997 14:28:30 +0000 (+0000) Subject: [project @ 1997-11-11 14:28:12 by simonm] X-Git-Tag: Approx_2487_patches~1310 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=d51f7ef704de2c33db43a9f384e83eac8605bb61;p=ghc-hetmet.git [project @ 1997-11-11 14:28:12 by simonm] Compiler changes to: * remove PrimIO * change type of _ccall_ to IO. (includes commits to basicTypes/Unique.lhs, deSugar/DsCCall.lhs, and prelude/PrelInfo.lhs, but the commit script messed up). --- diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs index 5234793..4e20de1 100644 --- a/ghc/compiler/prelude/PrelMods.lhs +++ b/ghc/compiler/prelude/PrelMods.lhs @@ -17,9 +17,10 @@ module PrelMods gHC__, pRELUDE, pREL_BASE, pREL_READ , pREL_NUM, pREL_LIST, pREL_TUP , pACKED_STRING, cONC_BASE, - iO_BASE , mONAD, rATIO, iX, + iO_BASE , eRROR, mONAD, rATIO, iX, sT_BASE , aRR_BASE, fOREIGN, mAIN, - gHC_MAIN , gHC_ERR + gHC_MAIN , gHC_ERR, + cCALL , aDDR ) where CHK_Ubiq() -- debugging consistency check @@ -43,12 +44,15 @@ pREL_TUP = SLIT("PrelTup") pACKED_STRING= SLIT("PackBase") cONC_BASE = SLIT("ConcBase") iO_BASE = SLIT("IOBase") +eRROR = SLIT("Error") mONAD = SLIT("Monad") rATIO = SLIT("Ratio") iX = SLIT("Ix") sT_BASE = SLIT("STBase") aRR_BASE = SLIT("ArrBase") fOREIGN = SLIT("Foreign") +cCALL = SLIT("CCall") +aDDR = SLIT("Addr") mAIN = SLIT("Main") gHC_MAIN = SLIT("GHCmain") diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index 6af3ca2..dbed539 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -93,7 +93,7 @@ pc_bottoming_Id key mod name ty -- these "bottom" out, no matter what their arguments eRROR_ID - = pc_bottoming_Id errorIdKey iO_BASE SLIT("error") errorTy + = pc_bottoming_Id errorIdKey eRROR SLIT("error") errorTy generic_ERROR_ID u n = pc_bottoming_Id u gHC_ERR n errorTy diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index cf63b34..fd1a666 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -1380,13 +1380,11 @@ primOpInfo NoFollowOp -- noFollow# :: a -> a %************************************************************************ \begin{code} -primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld# - = PrimResult SLIT("errorIO#") [] - [primio_ish_ty unitTy] +-- errorIO# :: (State# RealWorld# -> a) -> State# RealWorld# +primOpInfo ErrorIOPrimOp + = PrimResult SLIT("errorIO#") [alphaTyVar] + [mkFunTy realWorldStatePrimTy alphaTy] statePrimTyCon VoidRep [realWorldTy] - where - primio_ish_ty result - = mkFunTy (mkStatePrimTy realWorldTy) (mkSTretTy realWorldTy result) \end{code} %************************************************************************ diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index e689b53..2c39168 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -46,21 +46,26 @@ module TysWiredIn ( liftTyCon, listTyCon, foreignObjTyCon, + mkLiftTy, mkListTy, - mkPrimIoTy, - mkStateTy, - mkStateTransformerTy, - tupleTyCon, tupleCon, unitTyCon, unitDataCon, pairTyCon, pairDataCon, mkTupleTy, + tupleTyCon, tupleCon, unitTyCon, unitDataCon, pairTyCon, pairDataCon, nilDataCon, - primIoTyCon, realWorldStateTy, return2GMPsTyCon, returnIntAndGMPTyCon, + + -- ST and STret types + mkStateTy, + mkStateTransformerTy, + mkSTretTy, stTyCon, stDataCon, - stablePtrTyCon, + stRetDataCon, + stRetTyCon, + + -- CCall result types stateAndAddrPrimTyCon, stateAndArrayPrimTyCon, stateAndByteArrayPrimTyCon, @@ -77,9 +82,8 @@ module TysWiredIn ( stateAndWordPrimTyCon, stateDataCon, stateTyCon, - stRetDataCon, - stRetTyCon, - mkSTretTy, + + stablePtrTyCon, stringTy, trueDataCon, unitTy, @@ -258,8 +262,8 @@ wordDataCon = pcDataCon wordDataConKey fOREIGN SLIT("W#") [] [] [wordPrimTy] wor \begin{code} addrTy = mkTyConTy addrTyCon -addrTyCon = pcDataTyCon addrTyConKey fOREIGN SLIT("Addr") [] [addrDataCon] -addrDataCon = pcDataCon addrDataConKey fOREIGN SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv +addrTyCon = pcDataTyCon addrTyConKey aDDR SLIT("Addr") [] [addrDataCon] +addrDataCon = pcDataCon addrDataConKey aDDR SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv \end{code} \begin{code} @@ -287,18 +291,6 @@ stateDataCon \end{code} \begin{code} -mkSTretTy alpha beta = applyTyCon stRetTyCon [alpha,beta] - -stRetTyCon - = pcDataTyCon stRetTyConKey sT_BASE SLIT("STret") - alpha_beta_tyvars [stRetDataCon] -stRetDataCon - = pcDataCon stRetDataConKey sT_BASE SLIT("STret") - alpha_beta_tyvars [] [mkStatePrimTy alphaTy, betaTy] - stRetTyCon nullSpecEnv -\end{code} - -\begin{code} stablePtrTyCon = pcDataTyCon stablePtrTyConKey fOREIGN SLIT("StablePtr") alpha_tyvar [stablePtrDataCon] @@ -534,7 +526,8 @@ getStatePairingConInfo prim_ty %* * %************************************************************************ -This is really just an ordinary synonym, except it is ABSTRACT. +The only reason this is wired in is because we have to represent the +type of runST. \begin{code} mkStateTransformerTy s a = applyTyCon stTyCon [s, a] @@ -545,22 +538,16 @@ stDataCon = pcDataCon stDataConKey sT_BASE SLIT("ST") alpha_beta_tyvars [] [ty] stTyCon nullSpecEnv where ty = mkFunTy (mkStatePrimTy alphaTy) (mkSTretTy alphaTy betaTy) -\end{code} - -%************************************************************************ -%* * -\subsection[TysWiredIn-IO]{The @PrimIO@ monadic-I/O type} -%* * -%************************************************************************ -\begin{code} -mkPrimIoTy a = mkStateTransformerTy realWorldTy a +mkSTretTy alpha beta = applyTyCon stRetTyCon [alpha,beta] -primIoTyCon - = pcSynTyCon - primIoTyConKey sT_BASE SLIT("PrimIO") - (mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind) - 1 alpha_tyvar (mkPrimIoTy alphaTy) +stRetTyCon + = pcDataTyCon stRetTyConKey sT_BASE SLIT("STret") + alpha_beta_tyvars [stRetDataCon] +stRetDataCon + = pcDataCon stRetDataConKey sT_BASE SLIT("STret") + alpha_beta_tyvars [] [mkStatePrimTy alphaTy, betaTy] + stRetTyCon nullSpecEnv \end{code} %************************************************************************ diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index c3c8e4c..789a06b 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -42,7 +42,6 @@ import Name ( Name, Provenance, ExportFlag(..), isLocallyDefined, nameModule, pprModule, pprOccName, nameOccName ) import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon ) -import PrelInfo ( ioTyCon_NAME, primIoTyCon_NAME ) import TyCon ( TyCon ) import PrelMods ( mAIN, gHC_MAIN ) import ErrUtils ( SYN_IE(Error), SYN_IE(Warning), pprBagOfErrors, @@ -172,18 +171,13 @@ mentioned explicitly, but which might be needed by the type checker. \begin{code} addImplicits mod_name - = addImplicitOccsRn (implicit_main ++ default_tys) + = addImplicitOccsRn default_tys where -- Add occurrences for Int, Double, and (), because they -- are the types to which ambigious type variables may be defaulted by -- the type checker; so they won't every appear explicitly. -- [The () one is a GHC extension for defaulting CCall results.] - default_tys = [getName intTyCon, getName doubleTyCon, getName unitTyCon] - - -- Add occurrences for IO or PrimIO - implicit_main | mod_name == mAIN = [ioTyCon_NAME] - | mod_name == gHC_MAIN = [primIoTyCon_NAME] - | otherwise = [] + default_tys = [getName intTyCon, getName doubleTyCon, getName unitTyCon ] \end{code} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index f7a25f6..62d0b9a 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -32,9 +32,11 @@ import RnMonad import RnEnv import CmdLineOpts ( opt_GlasgowExts ) import BasicTypes ( Fixity(..), FixityDirection(..) ) -import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, - creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, ordClass_RDR, - ratioDataCon_RDR, negate_RDR +import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, + ccallableClass_RDR, creturnableClass_RDR, + monadZeroClass_RDR, enumClass_RDR, ordClass_RDR, + ratioDataCon_RDR, negate_RDR, + ioDataCon_RDR, ioOkDataCon_RDR ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon @@ -315,6 +317,8 @@ rnExpr (SectionR op expr) rnExpr (CCall fun args may_gc is_casm fake_result_ty) = lookupImplicitOccRn ccallableClass_RDR `thenRn_` lookupImplicitOccRn creturnableClass_RDR `thenRn_` + lookupImplicitOccRn ioDataCon_RDR `thenRn_` + lookupImplicitOccRn ioOkDataCon_RDR `thenRn_` rnExprs args `thenRn` \ (args', fvs_args) -> returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index dbf3e6b..baaa137 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -31,7 +31,8 @@ import Inst ( Inst, InstOrigin(..), OverloadedLit(..), import TcBinds ( tcBindsAndThen, checkSigTyVars ) import TcEnv ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey, tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars, - tcExtendGlobalTyVars, tcLookupGlobalValueMaybe + tcExtendGlobalTyVars, tcLookupGlobalValueMaybe, + tcLookupTyCon ) import SpecEnv ( SpecEnv ) import TcMatches ( tcMatchesCase, tcMatchExpected ) @@ -59,13 +60,14 @@ import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy, getAppDataTyCon, maybeAppDataTyCon ) import TyVar ( GenTyVar, SYN_IE(TyVarSet), unionTyVarSets, elementOfTyVarSet, mkTyVarSet ) +import TyCon ( tyConDataCons ) import TysPrim ( intPrimTy, charPrimTy, doublePrimTy, floatPrimTy, addrPrimTy, realWorldTy ) -import TysWiredIn ( addrTy, - boolTy, charTy, stringTy, mkListTy, - mkTupleTy, mkPrimIoTy, stDataCon +import TysWiredIn ( addrTy, mkTupleTy, + boolTy, charTy, stringTy, mkListTy ) +import PrelInfo ( ioTyCon_NAME ) import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy, unifyListTy, unifyTupleTy ) @@ -251,6 +253,7 @@ tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty = -- Get the callable and returnable classes. tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass -> tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass -> + tcLookupTyCon ioTyCon_NAME `thenTc` \ (_,_,ioTyCon) -> let new_arg_dict (arg, arg_ty) @@ -266,20 +269,27 @@ tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty tcExprs args ty_vars `thenTc` \ (args', args_lie) -> -- The argument types can be unboxed or boxed; the result - -- type must, however, be boxed since it's an argument to the PrimIO + -- type must, however, be boxed since it's an argument to the IO -- type constructor. newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ result_ty -> - unifyTauTy (mkPrimIoTy result_ty) res_ty `thenTc_` + let + io_result_ty = applyTyCon ioTyCon [result_ty] + in + case tyConDataCons ioTyCon of { [ioDataCon] -> + unifyTauTy io_result_ty res_ty `thenTc_` -- Construct the extra insts, which encode the -- constraints on the argument and result types. - mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args ty_vars) `thenNF_Tc` \ ccarg_dicts_s -> - newDicts result_origin [(cReturnableClass, result_ty)] `thenNF_Tc` \ (ccres_dict, _) -> + mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args ty_vars) + `thenNF_Tc` \ ccarg_dicts_s -> + newDicts result_origin [(cReturnableClass, result_ty)] + `thenNF_Tc` \ (ccres_dict, _) -> - returnTc (HsApp (HsVar (RealId stDataCon) `TyApp` [realWorldTy, result_ty]) - (CCall lbl args' may_gc is_asm result_ty), + returnTc (HsApp (HsVar (RealId ioDataCon) `TyApp` [result_ty]) + (CCall lbl args' may_gc is_asm io_result_ty), -- do the wrapping in the newtype constructor here foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie) + } \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 97c53c5..8c57967 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -63,7 +63,7 @@ import Type ( applyTyCon, mkSynTy, SYN_IE(Type) ) import PprType ( GenType, GenTyVar ) import TysWiredIn ( unitTy ) import PrelMods ( gHC_MAIN, mAIN ) -import PrelInfo ( main_NAME, mainPrimIO_NAME, ioTyCon_NAME, primIoTyCon_NAME ) +import PrelInfo ( main_NAME, ioTyCon_NAME ) import TyVar ( GenTyVar, SYN_IE(TyVarEnv), nullTyVarEnv ) import Unify ( unifyTauTy ) import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly, @@ -284,50 +284,38 @@ get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls] \begin{code} tcCheckMainSig mod_name - | not is_main && not is_ghc_main + | mod_name /= mAIN = returnTc () -- A non-main module | otherwise = -- Check that main is defined - tcLookupTyCon tycon_name `thenTc` \ (_,_,tycon) -> - tcLookupLocalValue main_name `thenNF_Tc` \ maybe_main_id -> + tcLookupTyCon ioTyCon_NAME `thenTc` \ (_,_,ioTyCon) -> + tcLookupLocalValue main_NAME `thenNF_Tc` \ maybe_main_id -> case maybe_main_id of { - Nothing -> failTc (noMainErr mod_name main_name); + Nothing -> failTc noMainErr; Just main_id -> -- Check that it has the right type (or a more general one) - let - expected_ty | isSynTyCon tycon = mkSynTy tycon [unitTy] - | otherwise = applyTyCon tycon [unitTy] - -- This is bizarre. There ought to be a suitable function in Type.lhs! - in - tcInstType [] expected_ty `thenNF_Tc` \ expected_tau -> - tcId main_name `thenNF_Tc` \ (_, lie, main_tau) -> - tcSetErrCtxt (mainTyCheckCtxt main_name) $ + let expected_ty = applyTyCon ioTyCon [unitTy] in + tcInstType [] expected_ty `thenNF_Tc` \ expected_tau -> + tcId main_NAME `thenNF_Tc` \ (_, lie, main_tau) -> + tcSetErrCtxt mainTyCheckCtxt $ unifyTauTy expected_tau - main_tau `thenTc_` - checkTc (isEmptyBag lie) (mainTyMisMatch main_name expected_ty (idType main_id)) + main_tau `thenTc_` + checkTc (isEmptyBag lie) (mainTyMisMatch expected_ty (idType main_id)) } - where - is_main = mod_name == mAIN - is_ghc_main = mod_name == gHC_MAIN - - main_name | is_main = main_NAME - | otherwise = mainPrimIO_NAME - - tycon_name | is_main = ioTyCon_NAME - | otherwise = primIoTyCon_NAME -mainTyCheckCtxt main_name sty - = hsep [ptext SLIT("When checking that"), ppr sty main_name, ptext SLIT("has the required type")] +mainTyCheckCtxt sty + = hsep [ptext SLIT("When checking that"), ppr sty main_NAME, + ptext SLIT("has the required type")] -noMainErr mod_name main_name sty - = hsep [ptext SLIT("Module"), pprModule sty mod_name, - ptext SLIT("must include a definition for"), ppr sty main_name] +noMainErr sty + = hsep [ptext SLIT("Module"), pprModule sty mAIN, + ptext SLIT("must include a definition for"), ppr sty main_NAME] -mainTyMisMatch :: Name -> Type -> TcType s -> Error -mainTyMisMatch main_name expected actual sty - = hang (hsep [ppr sty main_name, ptext SLIT("has the wrong type")]) +mainTyMisMatch :: Type -> TcType s -> Error +mainTyMisMatch expected actual sty + = hang (hsep [ppr sty main_NAME, ptext SLIT("has the wrong type")]) 4 (vcat [ hsep [ptext SLIT("Expected:"), ppr sty expected], hsep [ptext SLIT("Inferred:"), ppr sty actual]