From d51f7ef704de2c33db43a9f384e83eac8605bb61 Mon Sep 17 00:00:00 2001
From: simonm <unknown>
Date: Tue, 11 Nov 1997 14:28:30 +0000
Subject: [PATCH] [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).
---
ghc/compiler/prelude/PrelMods.lhs | 8 +++-
ghc/compiler/prelude/PrelVals.lhs | 2 +-
ghc/compiler/prelude/PrimOp.lhs | 10 ++---
ghc/compiler/prelude/TysWiredIn.lhs | 63 ++++++++++++-----------------
ghc/compiler/rename/Rename.lhs | 10 +----
ghc/compiler/rename/RnExpr.lhs | 10 +++--
ghc/compiler/typecheck/TcExpr.lhs | 30 +++++++++-----
ghc/compiler/typecheck/TcModule.lhs | 52 +++++++++---------------
8 files changed, 85 insertions(+), 100 deletions(-)
diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs
index 52347938ba20..4e20de102de5 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 6af3ca255032..dbed539f4f8e 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 cf63b3412c82..fd1a66651eb3 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 e689b5333d16..2c391683347c 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}
@@ -286,18 +290,6 @@ stateDataCon
alpha_tyvar [] [mkStatePrimTy alphaTy] stateTyCon nullSpecEnv
\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")
@@ -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 c3c8e4cd6cc1..789a06b46b26 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 f7a25f6239c7..62d0b9a7ff84 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 dbf3e6b5f6dc..baaa137b7df1 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 97c53c538a6c..8c57967449dd 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]
--
GitLab