From: partain Date: Tue, 11 Jun 1996 13:20:53 +0000 (+0000) Subject: [project @ 1996-06-11 13:18:54 by partain] X-Git-Tag: Approximately_1000_patches_recorded~909 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=ae45ff0e9831a0dc862a5d68d03e355d7e323c62 [project @ 1996-06-11 13:18:54 by partain] SLPJ changes to 960611 --- diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h index 23d67eb..f61a2a4 100644 --- a/ghc/compiler/HsVersions.h +++ b/ghc/compiler/HsVersions.h @@ -99,7 +99,7 @@ you will screw up the layout where they are used in case expressions! #endif {- ! __GLASGOW_HASKELL__ -} -#if __GLASGOW_HASKELL__ >= 23 && __GLASGOW_HASKELL__ < 200 +#if __GLASGOW_HASKELL__ >= 23 #define USE_FAST_STRINGS 1 #define FAST_STRING _PackedString #define SLIT(x) (_packCString (A# x#)) diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index 41ee1f3..53ce362 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -218,8 +218,6 @@ data CStmtMacro | UPD_BH_SINGLE_ENTRY | PUSH_STD_UPD_FRAME | POP_STD_UPD_FRAME - | SET_ARITY - | CHK_ARITY | SET_TAG | GRAN_FETCH -- for GrAnSim only -- HWL | GRAN_RESCHEDULE -- for GrAnSim only -- HWL @@ -502,34 +500,34 @@ We need magical @Eq@ because @VanillaReg@s come in multiple flavors. \begin{code} instance Eq MagicId where - reg1 == reg2 = tagOf_MagicId reg1 _EQ_ tagOf_MagicId reg2 - -tagOf_MagicId BaseReg = (ILIT(0) :: FAST_INT) -tagOf_MagicId StkOReg = ILIT(1) -tagOf_MagicId TagReg = ILIT(2) -tagOf_MagicId RetReg = ILIT(3) -tagOf_MagicId SpA = ILIT(4) -tagOf_MagicId SuA = ILIT(5) -tagOf_MagicId SpB = ILIT(6) -tagOf_MagicId SuB = ILIT(7) -tagOf_MagicId Hp = ILIT(8) -tagOf_MagicId HpLim = ILIT(9) -tagOf_MagicId LivenessReg = ILIT(10) -tagOf_MagicId StdUpdRetVecReg = ILIT(12) -tagOf_MagicId StkStubReg = ILIT(13) -tagOf_MagicId CurCostCentre = ILIT(14) -tagOf_MagicId VoidReg = ILIT(15) - -tagOf_MagicId (VanillaReg _ i) = ILIT(15) _ADD_ i - -tagOf_MagicId (FloatReg i) = ILIT(15) _ADD_ maxv _ADD_ i - where - maxv = case mAX_Vanilla_REG of { IBOX(x) -> x } - -tagOf_MagicId (DoubleReg i) = ILIT(15) _ADD_ maxv _ADD_ maxf _ADD_ i - where - maxv = case mAX_Vanilla_REG of { IBOX(x) -> x } - maxf = case mAX_Float_REG of { IBOX(x) -> x } + reg1 == reg2 = tag reg1 _EQ_ tag reg2 + where + tag BaseReg = (ILIT(0) :: FAST_INT) + tag StkOReg = ILIT(1) + tag TagReg = ILIT(2) + tag RetReg = ILIT(3) + tag SpA = ILIT(4) + tag SuA = ILIT(5) + tag SpB = ILIT(6) + tag SuB = ILIT(7) + tag Hp = ILIT(8) + tag HpLim = ILIT(9) + tag LivenessReg = ILIT(10) + tag StdUpdRetVecReg = ILIT(12) + tag StkStubReg = ILIT(13) + tag CurCostCentre = ILIT(14) + tag VoidReg = ILIT(15) + + tag (VanillaReg _ i) = ILIT(15) _ADD_ i + + tag (FloatReg i) = ILIT(15) _ADD_ maxv _ADD_ i + where + maxv = case mAX_Vanilla_REG of { IBOX(x) -> x } + + tag (DoubleReg i) = ILIT(15) _ADD_ maxv _ADD_ maxf _ADD_ i + where + maxv = case mAX_Vanilla_REG of { IBOX(x) -> x } + maxf = case mAX_Float_REG of { IBOX(x) -> x } \end{code} Returns True for any register that {\em potentially} dies across diff --git a/ghc/compiler/absCSyn/Costs.lhs b/ghc/compiler/absCSyn/Costs.lhs index bf68114..c32b010 100644 --- a/ghc/compiler/absCSyn/Costs.lhs +++ b/ghc/compiler/absCSyn/Costs.lhs @@ -363,8 +363,6 @@ stmtMacroCosts macro modes = UPD_BH_SINGLE_ENTRY -> Cost (3, 0, 0, 1, 0) {- SMupdate.lh -} PUSH_STD_UPD_FRAME -> Cost (3, 0, 0, 4, 0) {- SMupdate.lh -} POP_STD_UPD_FRAME -> Cost (1, 0, 3, 0, 0) {- SMupdate.lh -} - SET_ARITY -> nullCosts {- StgMacros.lh -} - CHK_ARITY -> nullCosts {- StgMacros.lh -} SET_TAG -> nullCosts {- COptRegs.lh -} GRAN_FETCH -> nullCosts {- GrAnSim bookkeeping -} GRAN_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -} diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 5704027..e379b95 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -17,7 +17,7 @@ module Id {- ( mkSpecId, mkSameSpecCon, selectIdInfoForSpecId, mkTemplateLocals, - mkImported, mkPreludeId, + mkImported, mkDataCon, mkTupleCon, mkIdWithNewUniq, mkMethodSelId, mkSuperDictSelId, mkDefaultMethodId, @@ -105,11 +105,11 @@ import CStrings ( identToC, cSEP ) import IdInfo import Maybes ( maybeToBool ) import Name ( appendRdr, nameUnique, mkLocalName, isLocalName, - isLocallyDefinedName, isPreludeDefinedName, + isLocallyDefinedName, mkTupleDataConName, mkCompoundName, mkCompoundName2, - isLexSym, isLexSpecialSym, getLocalName, - isLocallyDefined, isPreludeDefined, changeUnique, - getOccName, moduleNamePair, origName, nameOf, + isLexSym, isLexSpecialSym, + isLocallyDefined, changeUnique, + getOccName, origName, moduleOf, isExported, ExportFlag(..), RdrName(..), Name ) @@ -183,8 +183,6 @@ data IdDetails | ImportedId -- Global name (Imported or Implicit); Id imported from an interface - | PreludeId -- Global name (Builtin); Builtin prelude Ids - | TopLevId -- Global name (LocalDef); Top-level in the orig source pgm -- (not moved there by transformations). @@ -237,7 +235,7 @@ data IdDetails -- The "a" is irrelevant. As it is too painful to -- actually do comparisons that way, we kindly supply -- a Unique for that purpose. - (Maybe Module) -- module where instance came from; Nothing => Prelude + Module -- module where instance came from -- see below | ConstMethodId -- A method which depends only on the type of the @@ -245,7 +243,7 @@ data IdDetails Class -- Uniquely identified by: Type -- (class, type, classop) triple ClassOp - (Maybe Module) -- module where instance came from; Nothing => Prelude + Module -- module where instance came from | InstId -- An instance of a dictionary, class operation, -- or overloaded value (Local name) @@ -358,9 +356,6 @@ the infinite family of tuples. their @IdInfo@). %---------------------------------------------------------------------- -\item[@PreludeId@:] ToDo - -%---------------------------------------------------------------------- \item[@TopLevId@:] These are values defined at the top-level in this module; i.e., those which {\em might} be exported (hence, a @Name@). It does {\em not} include those which are moved to the @@ -499,7 +494,6 @@ toplevelishId (Id _ _ _ details _ _) chk (TupleConId _) = True chk (RecordSelId _) = True chk ImportedId = True - chk PreludeId = True chk TopLevId = True -- NB: see notes chk (SuperDictSelId _ _) = True chk (MethodSelId _ _) = True @@ -521,7 +515,6 @@ idHasNoFreeTyVars (Id _ _ _ details _ info) chk (TupleConId _) = True chk (RecordSelId _) = True chk ImportedId = True - chk PreludeId = True chk TopLevId = True chk (SuperDictSelId _ _) = True chk (MethodSelId _ _) = True @@ -608,7 +601,6 @@ pprIdInUnfolding in_scopes v case v_details of -- these ones must have been exported by their original module ImportedId -> pp_full_name - PreludeId -> pp_full_name -- these ones' exportedness checked later... TopLevId -> pp_full_name @@ -653,7 +645,7 @@ pprIdInUnfolding in_scopes v pp_full_name = let - (m_str, n_str) = moduleNamePair v + (OrigName m_str n_str) = origName "Id:ppr_Unfolding" v pp_n = if isLexSym n_str && not (isLexSpecialSym n_str) then @@ -877,7 +869,7 @@ unlocaliseId mod (Id u name ty info (InstId no_ftvs)) -- type might be wrong, but it hardly matters -- at this stage (just before printing C) ToDo where - name = getLocalName name + name = nameOf (origName "Id.unlocaliseId" name) full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc unlocaliseId mod other_id = Nothing @@ -1038,42 +1030,41 @@ getInstIdModule other = panic "Id:getInstIdModule" \begin{code} mkSuperDictSelId u c sc ty info - = Id u n ty (SuperDictSelId c sc) NoPragmaInfo info - where - cname = getName c -- we get other info out of here - - n = mkCompoundName u SLIT("sdsel") [origName cname, origName sc] cname + = mk_classy_id (SuperDictSelId c sc) SLIT("sdsel") (Left (origName "mkSuperDictSelId" sc)) u c ty info mkMethodSelId u rec_c op ty info - = Id u n ty (MethodSelId rec_c op) NoPragmaInfo info - where - cname = getName rec_c -- we get other info out of here - - n = mkCompoundName u SLIT("meth") [origName cname, Unqual (classOpString op)] cname + = mk_classy_id (MethodSelId rec_c op) SLIT("meth") (Right (classOpString op)) u rec_c ty info mkDefaultMethodId u rec_c op gen ty info - = Id u n ty (DefaultMethodId rec_c op gen) NoPragmaInfo info + = mk_classy_id (DefaultMethodId rec_c op gen) SLIT("defm") (Right (classOpString op)) u rec_c ty info + +mk_classy_id details str op_str u rec_c ty info + = Id u n ty details NoPragmaInfo info where cname = getName rec_c -- we get other info out of here + cname_orig = origName "mk_classy_id" cname + cmod = moduleOf cname_orig - n = mkCompoundName u SLIT("defm") [origName cname, Unqual (classOpString op)] cname + n = mkCompoundName u cmod str [Left cname_orig, op_str] cname mkDictFunId u c ity full_ty from_here locn mod info = Id u n full_ty (DictFunId c ity mod) NoPragmaInfo info where - n = mkCompoundName2 u SLIT("dfun") [origName c] (getTypeString ity) from_here locn + n = mkCompoundName2 u mod SLIT("dfun") (Left (origName "mkDictFunId" c) : map Right (getTypeString ity)) from_here locn mkConstMethodId u c op ity full_ty from_here locn mod info = Id u n full_ty (ConstMethodId c ity op mod) NoPragmaInfo info where - n = mkCompoundName2 u SLIT("const") [origName c, Unqual (classOpString op)] (getTypeString ity) from_here locn + n = mkCompoundName2 u mod SLIT("const") (Left (origName "mkConstMethodId" c) : Right (classOpString op) : map Right (getTypeString ity)) from_here locn mkWorkerId u unwrkr ty info = Id u n ty (WorkerId unwrkr) NoPragmaInfo info where unwrkr_name = getName unwrkr + unwrkr_orig = trace "mkWorkerId:origName:" $ origName "mkWorkerId" unwrkr_name + umod = moduleOf unwrkr_orig - n = mkCompoundName u SLIT("wrk") [origName unwrkr_name] unwrkr_name + n = mkCompoundName u umod SLIT("wrk") [Left unwrkr_orig] unwrkr_name mkInstId u ty name = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo @@ -1104,7 +1095,6 @@ getConstMethodId clas op ty \begin{code} mkImported n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info -mkPreludeId n ty info = Id (nameUnique n) n ty PreludeId NoPragmaInfo info {-LATER: updateIdType :: Id -> Type -> Id @@ -1642,23 +1632,6 @@ instance Outputable {-Id, i.e.:-}(GenId Type) where showId :: PprStyle -> Id -> String showId sty id = ppShow 80 (pprId sty id) - --- [used below] --- for DictFuns (instances) and const methods (instance code bits we --- can call directly): exported (a) if *either* the class or --- ***OUTERMOST*** tycon [arbitrary...] is exported; or (b) *both* --- class and tycon are from PreludeCore [non-std, but convenient] --- *and* the thing was defined in this module. - -instance_export_flag :: Class -> Type -> Bool -> ExportFlag - -instance_export_flag clas inst_ty from_here - = panic "Id:instance_export_flag" -{-LATER - = if instanceIsExported clas inst_ty from_here - then ExportAll - else NotExported --} \end{code} Default printing code (not used for interfaces): @@ -1677,53 +1650,6 @@ instance Uniquable (GenId ty) where instance NamedThing (GenId ty) where getName this_id@(Id u n _ details _ _) = n -{- OLD: - = get details - where - get (LocalId _) = n - get (SysLocalId _) = n - get (SpecPragmaId _ _) = n - get ImportedId = n - get PreludeId = n - get TopLevId = n - get (InstId n _) = n - get (DataConId _ _ _ _ _ _ _) = n - get (TupleConId _) = n - get (RecordSelId l) = getName l - get _ = mkCompoundName u (getIdNamePieces False{-no Uniques-} this_id) --} -{- LATER: - get (MethodSelId c op) = case (moduleOf (origName c)) of -- ToDo; better ??? - mod -> (mod, classOpString op) - - get (SpecId unspec ty_maybes _) - = case moduleNamePair unspec of { (mod, unspec_nm) -> - case specMaybeTysSuffix ty_maybes of { tys_suffix -> - (mod, - unspec_nm _APPEND_ - (if not (toplevelishId unspec) - then showUnique u - else tys_suffix) - ) }} - - get (WorkerId unwrkr) - = case moduleNamePair unwrkr of { (mod, unwrkr_nm) -> - (mod, - unwrkr_nm _APPEND_ - (if not (toplevelishId unwrkr) - then showUnique u - else SLIT(".wrk")) - ) } - - get other_details - -- the remaining internally-generated flavours of - -- Ids really do not have meaningful "original name" stuff, - -- but we need to make up something (usually for debugging output) - - = case (getIdNamePieces True this_id) of { (piece1:pieces) -> - case [ _CONS_ '.' p | p <- pieces ] of { dotted_pieces -> - (_NIL_, _CONCAT_ (piece1 : dotted_pieces)) }} --} \end{code} Note: The code generator doesn't carry a @UniqueSupply@, so it uses diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 6946df3..43c6b99 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -69,7 +69,7 @@ module IdInfo ( IMP_Ubiq() -IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and +IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and -- we break those loops by using IdLoop and -- *not* importing much of anything else, -- except from the very general "utils". @@ -77,7 +77,6 @@ IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and import CmdLineOpts ( opt_OmitInterfacePragmas ) import Maybes ( firstJust ) import MatchEnv ( nullMEnv, isEmptyMEnv, mEnvToList ) -import OccurAnal ( occurAnalyseGlobalExpr ) import Outputable ( ifPprInterface, Outputable(..){-instances-} ) import PprStyle ( PprStyle(..) ) import Pretty diff --git a/ghc/compiler/basicTypes/IdLoop.lhi b/ghc/compiler/basicTypes/IdLoop.lhi index deeae88..aea554a 100644 --- a/ghc/compiler/basicTypes/IdLoop.lhi +++ b/ghc/compiler/basicTypes/IdLoop.lhi @@ -18,6 +18,7 @@ import Id ( externallyVisibleId, isDataCon, isWorkerId, isWrapperId, import IdInfo ( IdInfo ) import Literal ( Literal ) import MagicUFs ( mkMagicUnfoldingFun, MagicUnfoldingFun ) +import OccurAnal ( occurAnalyseGlobalExpr ) import Outputable ( Outputable(..) ) import PprEnv ( NmbrEnv ) import PprStyle ( PprStyle ) @@ -31,6 +32,7 @@ import Usage ( GenUsage ) import Util ( Ord3(..) ) import WwLib ( mAX_WORKER_ARGS ) +occurAnalyseGlobalExpr :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique externallyVisibleId :: Id -> Bool isDataCon :: GenId ty -> Bool isWorkerId :: GenId ty -> Bool diff --git a/ghc/compiler/basicTypes/IdUtils.lhs b/ghc/compiler/basicTypes/IdUtils.lhs index afdc973..e17f17a 100644 --- a/ghc/compiler/basicTypes/IdUtils.lhs +++ b/ghc/compiler/basicTypes/IdUtils.lhs @@ -13,10 +13,10 @@ IMPORT_DELOOPER(PrelLoop) -- here for paranoia checking import CoreSyn import CoreUnfold ( UnfoldingGuidance(..) ) -import Id ( mkPreludeId, mkTemplateLocals ) +import Id ( mkImported, mkTemplateLocals ) import IdInfo -- quite a few things -import Name ( mkBuiltinName ) -import PrelMods ( pRELUDE_BUILTIN ) +import Name ( mkPrimitiveName, OrigName(..) ) +import PrelMods ( gHC_BUILTINS ) import PrimOp ( primOpInfo, tagOf_PrimOp, primOp_str, PrimOpInfo(..), PrimOpResultInfo(..) ) import RnHsSyn ( RnName(..) ) @@ -35,33 +35,33 @@ primOpNameInfo op = (primOp_str op, WiredInId (primOpId op)) primOpId op = case (primOpInfo op) of Dyadic str ty -> - mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (dyadic_fun_ty ty) 2 + mk_prim_Id op str [] [ty,ty] (dyadic_fun_ty ty) 2 Monadic str ty -> - mk_prim_Id op pRELUDE_BUILTIN str [] [ty] (monadic_fun_ty ty) 1 + mk_prim_Id op str [] [ty] (monadic_fun_ty ty) 1 Compare str ty -> - mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (compare_fun_ty ty) 2 + mk_prim_Id op str [] [ty,ty] (compare_fun_ty ty) 2 Coercing str ty1 ty2 -> - mk_prim_Id op pRELUDE_BUILTIN str [] [ty1] (mkFunTys [ty1] ty2) 1 + mk_prim_Id op str [] [ty1] (mkFunTys [ty1] ty2) 1 PrimResult str tyvars arg_tys prim_tycon kind res_tys -> - mk_prim_Id op pRELUDE_BUILTIN str + mk_prim_Id op str tyvars arg_tys (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys))) (length arg_tys) -- arity AlgResult str tyvars arg_tys tycon res_tys -> - mk_prim_Id op pRELUDE_BUILTIN str + mk_prim_Id op str tyvars arg_tys (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys))) (length arg_tys) -- arity where - mk_prim_Id prim_op mod name tyvar_tmpls arg_tys ty arity - = mkPreludeId (mkBuiltinName key mod name) ty + mk_prim_Id prim_op name tyvar_tmpls arg_tys ty arity + = mkImported (mkPrimitiveName key (OrigName gHC_BUILTINS name)) ty (noIdInfo `addInfo` (mkArityInfo arity) `addInfo_UF` (mkUnfolding EssentialUnfolding (mk_prim_unfold prim_op tyvar_tmpls arg_tys))) diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index b6b07af..7747daf 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -9,7 +9,12 @@ module Name ( Module(..), + OrigName(..), -- glorified pair + qualToOrigName, -- a Qual to an OrigName + RdrName(..), + preludeQual, + moduleNamePair, isUnqual, isQual, isRdrLexCon, isRdrLexConOrSpecial, @@ -20,9 +25,10 @@ module Name ( Name, Provenance, mkLocalName, isLocalName, - mkTopLevName, mkImportedName, + mkTopLevName, mkImportedName, oddlyImportedName, mkImplicitName, isImplicitName, - mkBuiltinName, mkCompoundName, mkCompoundName2, + mkPrimitiveName, mkWiredInName, + mkCompoundName, mkCompoundName2, mkFunTyConName, mkTupleDataConName, mkTupleTyConName, mkTupNameStr, @@ -33,19 +39,18 @@ module Name ( nameUnique, changeUnique, nameOccName, - nameOrigName, +-- nameOrigName, : not exported nameExportFlag, nameSrcLoc, nameImpLocs, nameImportFlag, - isLocallyDefinedName, - isPreludeDefinedName, + isLocallyDefinedName, isWiredInName, - origName, moduleOf, nameOf, moduleNamePair, + origName, moduleOf, nameOf, getOccName, getExportFlag, getSrcLoc, getImpLocs, - isLocallyDefined, isPreludeDefined, - getLocalName, ltLexical, + isLocallyDefined, + getLocalName, isSymLexeme, pprSym, pprNonSym, isLexCon, isLexVar, isLexId, isLexSym, isLexSpecialSym, @@ -54,10 +59,11 @@ module Name ( IMP_Ubiq() +import CmdLineOpts ( maybe_CompilingPrelude ) import CStrings ( identToC, cSEP ) import Outputable ( Outputable(..) ) import PprStyle ( PprStyle(..), codeStyle ) -import PrelMods ( pRELUDE, pRELUDE_BUILTIN, fromPrelude ) +import PrelMods ( pRELUDE ) import Pretty import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc ) import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique, @@ -79,10 +85,20 @@ ord = fromEnum :: Char -> Int \begin{code} type Module = FAST_STRING +data OrigName = OrigName Module FAST_STRING + +qualToOrigName (Qual m n) = OrigName m n + data RdrName = Unqual FAST_STRING | Qual Module FAST_STRING +preludeQual n = Qual pRELUDE n + +moduleNamePair (Qual m n) = (m, n) -- we make *no* claim whether this + -- constitutes an original name or + -- an occurrence name, or anything else + isUnqual (Unqual _) = True isUnqual (Qual _ _) = False @@ -96,13 +112,16 @@ isRdrLexConOrSpecial (Unqual n) = isLexCon n || isLexSpecialSym n isRdrLexConOrSpecial (Qual m n) = isLexCon n || isLexSpecialSym n appendRdr (Unqual n) str = Unqual (n _APPEND_ str) -appendRdr (Qual m n) str = ASSERT(not (fromPrelude m)) - Qual m (n _APPEND_ str) +appendRdr (Qual m n) str = Qual m (n _APPEND_ str) -cmpRdr (Unqual n1) (Unqual n2) = _CMP_STRING_ n1 n2 -cmpRdr (Unqual n1) (Qual m2 n2) = LT_ -cmpRdr (Qual m1 n1) (Unqual n2) = GT_ -cmpRdr (Qual m1 n1) (Qual m2 n2) = _CMP_STRING_ m1 m2 `thenCmp` _CMP_STRING_ n1 n2 +cmpRdr (Unqual n1) (Unqual n2) = _CMP_STRING_ n1 n2 +cmpRdr (Unqual n1) (Qual m2 n2) = LT_ +cmpRdr (Qual m1 n1) (Unqual n2) = GT_ +cmpRdr (Qual m1 n1) (Qual m2 n2) = _CMP_STRING_ n1 n2 `thenCmp` _CMP_STRING_ m1 m2 + -- always compare module-names *second* + +cmpOrig (OrigName m1 n1) (OrigName m2 n2) + = _CMP_STRING_ n1 n2 `thenCmp` _CMP_STRING_ m1 m2 -- again; module-names *second* instance Eq RdrName where a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } @@ -119,8 +138,14 @@ instance Ord3 RdrName where instance NamedThing RdrName where -- We're sorta faking it here - getName rdr_name - = Global u rdr_name prov ex [rdr_name] + getName (Unqual n) + = Local u n True locn + where + u = panic "NamedThing.RdrName:Unique1" + locn = panic "NamedThing.RdrName:locn" + + getName rdr_name@(Qual m n) + = Global u m n prov ex [rdr_name] where u = panic "NamedThing.RdrName:Unique" prov = panic "NamedThing.RdrName:Provenance" @@ -139,6 +164,26 @@ pp_name sty n | codeStyle sty = identToC n | otherwise = ppPStr n showRdr sty rdr = ppShow 100 (ppr sty rdr) + +------------------------- +instance Eq OrigName where + a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } + a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } + +instance Ord OrigName where + a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } + a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } + a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } + a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } + +instance Ord3 OrigName where + cmp = cmpOrig + +instance NamedThing OrigName where -- faking it + getName (OrigName m n) = getName (Qual m n) + +instance Outputable OrigName where -- ditto + ppr sty (OrigName m n) = ppr sty (Qual m n) \end{code} %************************************************************************ @@ -156,7 +201,8 @@ data Name SrcLoc | Global Unique - RdrName -- original name; Unqual => prelude + Module -- original name + FAST_STRING Provenance -- where it came from ExportFlag -- is it exported? [RdrName] -- ordered occurrence names (usually just one); @@ -170,57 +216,71 @@ data Provenance [SrcLoc] -- any import source location(s) | Implicit - | Builtin + | Primitive -- really and truly primitive thing (not + -- definable in Haskell) + | WiredIn Bool -- something defined in Haskell; True <=> + -- definition is in the module in question; + -- this probably comes from the -fcompiling-prelude=... + -- flag. \end{code} \begin{code} mkLocalName = Local -mkTopLevName u orig locn exp occs = Global u orig (LocalDef locn) exp occs -mkImportedName u orig imp locn imp_locs exp occs = Global u orig (Imported imp locn imp_locs) exp occs +mkTopLevName u (OrigName m n) locn exp occs = Global u m n (LocalDef locn) exp occs +mkImportedName u (OrigName m n) imp locn imp_locs exp occs = Global u m n (Imported imp locn imp_locs) exp occs -mkImplicitName :: Unique -> RdrName -> Name -mkImplicitName u o = Global u o Implicit NotExported [] +mkImplicitName :: Unique -> OrigName -> Name +mkImplicitName u (OrigName m n) = Global u m n Implicit NotExported [] -mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name -mkBuiltinName u m n - = Global u (if fromPrelude m then Unqual n else Qual m n) Builtin NotExported [] +mkPrimitiveName :: Unique -> OrigName -> Name +mkPrimitiveName u (OrigName m n) = Global u m n Primitive NotExported [] + +mkWiredInName :: Unique -> OrigName -> Name +mkWiredInName u (OrigName m n) + = Global u m n (WiredIn from_here) (if from_here then ExportAll else NotExported) [] + where + from_here + = case maybe_CompilingPrelude of + Nothing -> False + Just mod -> mod == _UNPK_ m mkCompoundName :: Unique + -> Module -> FAST_STRING -- indicates what kind of compound thing it is (e.g., "sdsel") - -> [RdrName] -- "dot" these names together + -> [Either OrigName FAST_STRING] -- "dot" these names together -> Name -- from which we get provenance, etc.... -> Name -- result! -mkCompoundName u str ns (Local _ _ _ _) = panic "mkCompoundName:Local?" -mkCompoundName u str ns (Global _ _ prov exp _) - = Global u (Unqual{-???-} (_CONCAT_ (glue ns [str]))) prov exp [] +mkCompoundName u m str ns (Local _ _ _ _) = panic "mkCompoundName:Local?" +mkCompoundName u m str ns (Global _ _ _ prov exp _) + = Global u m (_CONCAT_ (glue ns [str])) prov exp [] -glue [] acc = reverse acc -glue (Unqual n:ns) acc = glue ns (_CONS_ '.' n : acc) -glue (Qual m n:ns) acc = glue ns (_CONS_ '.' n : _CONS_ '.' m : acc) +glue [] acc = reverse acc +glue (Left (OrigName m n):ns) acc = glue ns (_CONS_ '.' n : _CONS_ '.' m : acc) +glue (Right n :ns) acc = glue ns (_CONS_ '.' n : acc) -- this ugly one is used for instance-y things mkCompoundName2 :: Unique - -> FAST_STRING -- indicates what kind of compound thing it is (e.g., "sdsel") - -> [RdrName] -- "dot" these names together - -> [FAST_STRING] -- type-name strings - -> Bool -- True <=> defined in this module - -> SrcLoc - -> Name -- result! - -mkCompoundName2 u str ns ty_strs from_here locn - = Global u (Unqual{-???-} ((_CONCAT_ (glue ns [str])) _APPEND_ (_CONS_ '.' (_CONCAT_ ty_strs)))) + -> Module + -> FAST_STRING -- indicates what kind of compound thing it is + -> [Either OrigName FAST_STRING] -- "dot" these names together + -> Bool -- True <=> defined in this module + -> SrcLoc + -> Name -- result! + +mkCompoundName2 u m str ns from_here locn + = Global u m (_CONCAT_ (glue ns [str])) (if from_here then LocalDef locn else Imported ExportAll locn []) ExportAll{-instances-} [] mkFunTyConName - = mkBuiltinName funTyConKey pRELUDE_BUILTIN SLIT("->") + = mkPrimitiveName funTyConKey (OrigName pRELUDE SLIT("->")) mkTupleDataConName arity - = mkBuiltinName (mkTupleDataConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity) + = mkWiredInName (mkTupleDataConUnique arity) (OrigName pRELUDE (mkTupNameStr arity)) mkTupleTyConName arity - = mkBuiltinName (mkTupleTyConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity) + = mkWiredInName (mkTupleTyConUnique arity) (OrigName pRELUDE (mkTupNameStr arity)) mkTupNameStr 0 = SLIT("()") mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???" @@ -236,15 +296,18 @@ mkTupNameStr n isLocalName (Local _ _ _ _) = True isLocalName _ = False -isImplicitName (Global _ _ Implicit _ _) = True -isImplicitName _ = False +-- things the compiler "knows about" are in some sense +-- "imported". When we are compiling the module where +-- the entities are defined, we need to be able to pick +-- them out, often in combination with isLocallyDefined. +oddlyImportedName (Global _ _ _ Primitive _ _) = True +oddlyImportedName (Global _ _ _ (WiredIn _) _ _) = True +oddlyImportedName _ = False -isBuiltinName (Global _ _ Builtin _ _) = True -isBuiltinName _ = False +isImplicitName (Global _ _ _ Implicit _ _) = True +isImplicitName _ = False \end{code} - - %************************************************************************ %* * \subsection[Name-instances]{Instance declarations} @@ -254,17 +317,10 @@ isBuiltinName _ = False \begin{code} cmpName n1 n2 = c n1 n2 where - c (Local u1 _ _ _) (Local u2 _ _ _) = cmp u1 u2 - c (Global u1 _ _ _ _) (Global u2 _ _ _ _) = cmp u1 u2 - - c other_1 other_2 -- the tags *must* be different - = let tag1 = tag_Name n1 - tag2 = tag_Name n2 - in - if tag1 _LT_ tag2 then LT_ else GT_ - - tag_Name (Local _ _ _ _) = (ILIT(1) :: FAST_INT) - tag_Name (Global _ _ _ _ _) = ILIT(2) + c (Local u1 _ _ _) (Local u2 _ _ _) = cmp u1 u2 + c (Local _ _ _ _) _ = LT_ + c (Global u1 _ _ _ _ _) (Global u2 _ _ _ _ _) = cmp u1 u2 + c (Global _ _ _ _ _ _) _ = GT_ \end{code} \begin{code} @@ -289,53 +345,53 @@ instance NamedThing Name where \end{code} \begin{code} -nameUnique (Local u _ _ _) = u -nameUnique (Global u _ _ _ _) = u +nameUnique (Local u _ _ _) = u +nameUnique (Global u _ _ _ _ _) = u -- when we renumber/rename things, we need to be -- able to change a Name's Unique to match the cached -- one in the thing it's the name of. If you know what I mean. changeUnique (Local _ n b l) u = Local u n b l -changeUnique n@(Global _ o p e os) u = ASSERT(not (isBuiltinName n)) - Global u o p e os +changeUnique (Global _ m n p e os) u = Global u m n p e os -nameOrigName (Local _ n _ _) = Unqual n -nameOrigName (Global _ orig _ _ _) = orig - -nameModuleNamePair (Local _ n _ _) = (panic "nameModuleNamePair", n) -nameModuleNamePair (Global _ (Unqual n) _ _ _) = (pRELUDE, n) -nameModuleNamePair (Global _ (Qual m n) _ _ _) = (m, n) +nameOrigName msg (Global _ m n _ _ _) = OrigName m n +#ifdef DEBUG +nameOrigName msg (Local _ n _ _) = panic ("nameOrigName:Local:"++msg++":"++ _UNPK_ n) +#endif nameOccName (Local _ n _ _) = Unqual n -nameOccName (Global _ orig _ _ [] ) = orig -nameOccName (Global _ orig _ _ occs) = head occs - -nameExportFlag (Local _ _ _ _) = NotExported -nameExportFlag (Global _ _ _ exp _) = exp - -nameSrcLoc (Local _ _ _ loc) = loc -nameSrcLoc (Global _ _ (LocalDef loc) _ _) = loc -nameSrcLoc (Global _ _ (Imported _ loc _) _ _) = loc -nameSrcLoc (Global _ _ Implicit _ _) = mkUnknownSrcLoc -nameSrcLoc (Global _ _ Builtin _ _) = mkBuiltinSrcLoc +nameOccName (Global _ m n _ _ [] ) = Qual m n +nameOccName (Global _ m n _ _ (o:_)) = o + +nameExportFlag (Local _ _ _ _) = NotExported +nameExportFlag (Global _ _ _ _ exp _) = exp + +nameSrcLoc (Local _ _ _ loc) = loc +nameSrcLoc (Global _ _ _ (LocalDef loc) _ _) = loc +nameSrcLoc (Global _ _ _ (Imported _ loc _) _ _) = loc +nameSrcLoc (Global _ _ _ Implicit _ _) = mkUnknownSrcLoc +nameSrcLoc (Global _ _ _ Primitive _ _) = mkBuiltinSrcLoc +nameSrcLoc (Global _ _ _ (WiredIn _) _ _) = mkBuiltinSrcLoc -nameImpLocs (Global _ _ (Imported _ _ locs) _ _) = locs -nameImpLocs _ = [] - -nameImportFlag (Local _ _ _ _) = NotExported -nameImportFlag (Global _ _ (LocalDef _) _ _) = ExportAll -nameImportFlag (Global _ _ (Imported exp _ _) _ _) = exp -nameImportFlag (Global _ _ Implicit _ _) = ExportAll -nameImportFlag (Global _ _ Builtin _ _) = ExportAll - -isLocallyDefinedName (Local _ _ _ _) = True -isLocallyDefinedName (Global _ _ (LocalDef _) _ _) = True -isLocallyDefinedName (Global _ _ (Imported _ _ _) _ _) = False -isLocallyDefinedName (Global _ _ Implicit _ _) = False -isLocallyDefinedName (Global _ _ Builtin _ _) = False - -isPreludeDefinedName (Local _ n _ _) = False -isPreludeDefinedName (Global _ orig _ _ _) = isUnqual orig +nameImpLocs (Global _ _ _ (Imported _ _ locs) _ _) = locs +nameImpLocs _ = [] + +nameImportFlag (Local _ _ _ _) = NotExported +nameImportFlag (Global _ _ _ (LocalDef _) _ _) = ExportAll +nameImportFlag (Global _ _ _ (Imported exp _ _) _ _) = exp +nameImportFlag (Global _ _ _ Implicit _ _) = ExportAll +nameImportFlag (Global _ _ _ Primitive _ _) = ExportAll +nameImportFlag (Global _ _ _ (WiredIn _) _ _) = ExportAll + +isLocallyDefinedName (Local _ _ _ _) = True +isLocallyDefinedName (Global _ _ _ (LocalDef _) _ _) = True +isLocallyDefinedName (Global _ _ _ (Imported _ _ _) _ _) = False +isLocallyDefinedName (Global _ _ _ Implicit _ _) = False +isLocallyDefinedName (Global _ _ _ Primitive _ _) = False +isLocallyDefinedName (Global _ _ _ (WiredIn from_here) _ _) = from_here + +isWiredInName (Global _ _ _ (WiredIn _) _ _) = True +isWiredInName _ = False \end{code} \begin{code} @@ -345,11 +401,11 @@ instance Outputable Name where | emph_uniq = ppBesides [pprUnique u, ppStr "{-", ppPStr n, ppStr "-}"] | otherwise = ppBesides [ppPStr n, ppStr "{-", pprUnique u, ppStr "-}"] - ppr PprDebug (Global u o _ _ _) = ppBesides [ppr PprDebug o, ppStr "{-", pprUnique u, ppStr "-}"] - ppr PprForUser (Global u o _ _ [] ) = ppr PprForUser o - ppr PprForUser (Global u o _ _ occs) = ppr PprForUser (head occs) - ppr PprShowAll (Global u o prov exp occs) = pp_all o prov exp occs - ppr sty (Global u o _ _ _) = ppr sty o + ppr PprDebug (Global u m n _ _ _) = ppBesides [ppr PprDebug (Qual m n), ppStr "{-", pprUnique u, ppStr "-}"] + ppr PprForUser (Global u m n _ _ [] ) = ppr PprForUser (Qual m n) + ppr PprForUser (Global u m n _ _ occs) = ppr PprForUser (head occs) + ppr PprShowAll (Global u m n prov exp occs) = pp_all (Qual m n) prov exp occs + ppr sty (Global u m n _ _ _) = ppr sty (Qual m n) pp_all orig prov exp occs = ppBesides [ppr PprShowAll orig, ppr PprShowAll occs, pp_prov prov, pp_exp exp] @@ -358,9 +414,10 @@ pp_exp NotExported = ppNil pp_exp ExportAll = ppPStr SLIT("/EXP(..)") pp_exp ExportAbs = ppPStr SLIT("/EXP") -pp_prov Implicit = ppPStr SLIT("/IMPLICIT") -pp_prov Builtin = ppPStr SLIT("/BUILTIN") -pp_prov _ = ppNil +pp_prov Implicit = ppPStr SLIT("/IMPLICIT") +pp_prov Primitive = ppPStr SLIT("/PRIMITIVE") +pp_prov (WiredIn _) = ppPStr SLIT("/WIREDIN") +pp_prov _ = ppNil \end{code} %************************************************************************ @@ -400,10 +457,9 @@ class NamedThing a where \end{code} \begin{code} -origName :: NamedThing a => a -> RdrName -moduleOf :: RdrName -> Module -nameOf :: RdrName -> FAST_STRING -moduleNamePair :: NamedThing a => a -> (Module, FAST_STRING) +origName :: NamedThing a => String -> a -> OrigName +moduleOf :: OrigName -> Module +nameOf :: OrigName -> FAST_STRING getOccName :: NamedThing a => a -> RdrName getLocalName :: NamedThing a => a -> FAST_STRING @@ -411,34 +467,22 @@ getExportFlag :: NamedThing a => a -> ExportFlag getSrcLoc :: NamedThing a => a -> SrcLoc getImpLocs :: NamedThing a => a -> [SrcLoc] isLocallyDefined :: NamedThing a => a -> Bool -isPreludeDefined :: NamedThing a => a -> Bool - --- ToDo: specialise for RdrNames? -origName = nameOrigName . getName -moduleNamePair = nameModuleNamePair . getName -moduleOf (Unqual n) = pRELUDE -moduleOf (Qual m n) = m +origName str n = nameOrigName str (getName n) -nameOf (Unqual n) = n -nameOf (Qual m n) = n +moduleOf (OrigName m n) = m +nameOf (OrigName m n) = n -getLocalName = nameOf . origName +getLocalName n + = case (getName n) of + Global _ m n _ _ _ -> n + Local _ n _ _ -> n getOccName = nameOccName . getName getExportFlag = nameExportFlag . getName getSrcLoc = nameSrcLoc . getName getImpLocs = nameImpLocs . getName isLocallyDefined = isLocallyDefinedName . getName -isPreludeDefined = isPreludeDefinedName . getName -\end{code} - -@ltLexical@ is used for sorting things into lexicographical order, so -as to canonicalize interfaces. [Regular @(<)@ should be used for fast -comparison.] - -\begin{code} -a `ltLexical` b = origName a < origName b \end{code} These functions test strings to see if they fit the lexical categories @@ -459,14 +503,12 @@ isLexSym cs = isLexConSym cs || isLexVarSym cs isLexConId cs | _NULL_ cs = False - | c == '_' = isLexConId (_TAIL_ cs) -- allow for leading _'s | otherwise = isUpper c || isUpperISO c where c = _HEAD_ cs isLexVarId cs | _NULL_ cs = False - | c == '_' = isLexVarId (_TAIL_ cs) -- allow for leading _'s | otherwise = isLower c || isLowerISO c where c = _HEAD_ cs @@ -509,14 +551,14 @@ And one ``higher-level'' interface to those: isSymLexeme :: NamedThing a => a -> Bool isSymLexeme v - = let str = nameOf (origName v) in isLexSym str + = let str = getLocalName v in isLexSym str -- print `vars`, (op) correctly pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty pprSym sty var = let - str = nameOf (origName var) + str = getLocalName var in if isLexSym str && not (isLexSpecialSym str) then ppr sty var diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 8edd5bd..92d6af2 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -44,7 +44,7 @@ import Id ( idPrimRep, toplevelishId, isDataCon, GenId{-instance NamedThing-} ) import Maybes ( catMaybes ) -import Name ( isLocallyDefined ) +import Name ( isLocallyDefined, oddlyImportedName, Name{-instance NamedThing-} ) #ifdef DEBUG import PprAbsC ( pprAmode ) #endif @@ -194,21 +194,22 @@ I {\em think} all looking-up is done through @getCAddrMode(s)@. \begin{code} getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo) -getCAddrModeAndInfo name - | not (isLocallyDefined name) - = returnFC (global_amode, mkLFImported name) +getCAddrModeAndInfo id + | not (isLocallyDefined name) || oddlyImportedName name + = returnFC (global_amode, mkLFImported id) - | isDataCon name - = returnFC (global_amode, mkConLFInfo name) + | isDataCon id + = returnFC (global_amode, mkConLFInfo id) | otherwise = -- *might* be a nested defn: in any case, it's something whose -- definition we will know about... - lookupBindC name `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) -> + lookupBindC id `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) -> idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode -> returnFC (amode, lf_info) where - global_amode = CLbl (mkClosureLabel name) kind - kind = idPrimRep name + name = getName id + global_amode = CLbl (mkClosureLabel id) kind + kind = idPrimRep id getCAddrMode :: Id -> FCode CAddrMode getCAddrMode name diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index 7745466..2083d8f 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -40,7 +40,7 @@ import Id ( dataConTag, dataConRawArgTys, emptyIdSet, GenId{-instance NamedThing-} ) -import Name ( getLocalName ) +import Name ( nameOf, origName ) import PrelInfo ( maybeIntLikeTyCon ) import PrimRep ( getPrimRepSize, PrimRep(..) ) import TyCon ( tyConDataCons, mkSpecTyCon ) @@ -209,7 +209,7 @@ genConInfo comp_info tycon data_con body_code)) entry_addr = CLbl entry_label CodePtrRep - con_descr = _UNPK_ (getLocalName data_con) + con_descr = _UNPK_ (nameOf (origName "con_descr" data_con)) closure_code = CClosureInfoAndCode closure_info body Nothing stdUpd con_descr @@ -337,7 +337,7 @@ genPhantomUpdInfo comp_info tycon data_con phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con) - con_descr = _UNPK_ (getLocalName data_con) + con_descr = _UNPK_ (nameOf (origName "con_descr2" data_con)) con_arity = dataConArity data_con diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 960e6a9..d24b55e 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -87,7 +87,7 @@ import Id ( idType, idPrimRep, getIdArity, ) import IdInfo ( arityMaybe ) import Maybes ( assocMaybe, maybeToBool ) -import Name ( isLocallyDefined, getLocalName ) +import Name ( isLocallyDefined, nameOf, origName ) import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-} ) import PrelInfo ( maybeCharLikeTyCon, maybeIntLikeTyCon ) @@ -1320,8 +1320,8 @@ closureKind (MkClosureInfo _ lf _) closureTypeDescr :: ClosureInfo -> String closureTypeDescr (MkClosureInfo id lf _) - = if (isDataCon id) then -- DataCon has function types - _UNPK_ (getLocalName (dataConTyCon id)) -- We want the TyCon not the -> + = if (isDataCon id) then -- DataCon has function types + _UNPK_ (nameOf (origName "closureTypeDescr" (dataConTyCon id))) -- We want the TyCon not the -> else getTyDescription (idType id) \end{code} diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 31e8ea5..d7f70ca 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -16,13 +16,15 @@ IMP_Ubiq() import CoreSyn import Bag -import Kind ( Kind{-instance-} ) +import Kind ( hasMoreBoxityInfo, Kind{-instance-} ) import Literal ( literalType, Literal{-instance-} ) import Id ( idType, isBottomingId, - dataConArgTys, GenId{-instances-} + dataConArgTys, GenId{-instances-}, + emptyIdSet, mkIdSet, intersectIdSets, + unionIdSets, elementOfIdSet, IdSet(..) ) import Maybes ( catMaybes ) -import Name ( isLocallyDefined, getSrcLoc ) +import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-} ) import Outputable ( Outputable(..){-instance * []-} ) import PprCore import PprStyle ( PprStyle(..) ) @@ -41,9 +43,6 @@ import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,mkForAllTys,getForAllTy_maybe, ) import TyCon ( isPrimTyCon ) import TyVar ( tyVarKind, GenTyVar{-instances-} ) -import UniqSet ( emptyUniqSet, mkUniqSet, intersectUniqSets, - unionUniqSets, elementOfUniqSet, UniqSet(..) - ) import Unique ( Unique ) import Usage ( GenUsage ) import Util ( zipEqual, pprTrace, pprPanic, assertPanic, panic ) @@ -188,8 +187,7 @@ lintCoreExpr (Var var) = checkInScope var `seqL` returnL (Just (idType var)) lintCoreExpr (Lit lit) = returnL (Just (literalType lit)) lintCoreExpr (SCC _ expr) = lintCoreExpr expr lintCoreExpr (Coerce _ ty expr) - = _trace "lintCoreExpr:Coerce" $ - lintCoreExpr expr `seqL` returnL (Just ty) + = lintCoreExpr expr `seqL` returnL (Just ty) lintCoreExpr (Let binds body) = lintCoreBinding binds `thenL` \binders -> @@ -294,9 +292,11 @@ lintCoreArg e ty a@(TyArg arg_ty) tyvar_kind = tyVarKind tyvar argty_kind = typeKind arg_ty in - if tyvar_kind == argty_kind --- SUSPICIOUS! (tyvar_kind `isSubKindOf` argty_kind --- || argty_kind `isSubKindOf` tyvar_kind) + if argty_kind `hasMoreBoxityInfo` tyvar_kind + -- Arg type might be boxed for a function with an uncommitted + -- tyvar; notably this is used so that we can give + -- error :: forall a:*. String -> a + -- and then apply it to both boxed and unboxed types. then returnL(Just(instantiateTy [(tyvar,arg_ty)] body)) else @@ -407,7 +407,7 @@ lintDeflt deflt@(BindDefault binder rhs) ty \begin{code} type LintM a = Bool -- True <=> specialisation has been done -> [LintLocInfo] -- Locations - -> UniqSet Id -- Local vars in scope + -> IdSet -- Local vars in scope -> Bag ErrMsg -- Error messages so far -> (a, Bag ErrMsg) -- Result and error messages (if any) @@ -444,7 +444,7 @@ pp_binder sty b = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)] \begin{code} initL :: LintM a -> Bool -> Maybe ErrMsg initL m spec_done - = case (m spec_done [] emptyUniqSet emptyBag) of { (_, errs) -> + = case (m spec_done [] emptyIdSet emptyBag) of { (_, errs) -> if isEmptyBag errs then Nothing else @@ -529,24 +529,27 @@ addInScopeVars ids m spec loc scope errs -- For now, it's just a "trace"; we may make -- a real error out of it... let - new_set = mkUniqSet ids + new_set = mkIdSet ids - shadowed = scope `intersectUniqSets` new_set +-- shadowed = scope `intersectIdSets` new_set in -- After adding -fliberate-case, Simon decided he likes shadowed -- names after all. WDP 94/07 -- (if isEmptyUniqSet shadowed -- then id -- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) ( - m spec loc (scope `unionUniqSets` new_set) errs + m spec loc (scope `unionIdSets` new_set) errs -- ) \end{code} \begin{code} checkInScope :: Id -> LintM () checkInScope id spec loc scope errs - = if isLocallyDefined id && not (id `elementOfUniqSet` scope) then - ((),addErr errs (\sty -> ppCat [ppr sty id,ppStr "is out of scope"]) loc) + = let + id_name = getName id + in + if isLocallyDefined id_name && not (id `elementOfIdSet` scope) then + ((),addErr errs (\sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc) else ((),errs) diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index bb73e01..80d0740 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -250,7 +250,7 @@ manifestlyWHNF (Var _) = True manifestlyWHNF (Lit _) = True manifestlyWHNF (Con _ _) = True manifestlyWHNF (SCC _ e) = manifestlyWHNF e -manifestlyWHNF (Coerce _ _ e) = _trace "manifestlyWHNF:Coerce" $ manifestlyWHNF e +manifestlyWHNF (Coerce _ _ e) = manifestlyWHNF e manifestlyWHNF (Let _ e) = False manifestlyWHNF (Case _ _) = False @@ -287,7 +287,7 @@ manifestlyBottom (Lit _) = False manifestlyBottom (Con _ _) = False manifestlyBottom (Prim _ _) = False manifestlyBottom (SCC _ e) = manifestlyBottom e -manifestlyBottom (Coerce _ _ e) = _trace "manifestlyBottom:Coerce" $ manifestlyBottom e +manifestlyBottom (Coerce _ _ e) = manifestlyBottom e manifestlyBottom (Let _ e) = manifestlyBottom e -- We do not assume \x.bottom == bottom: diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 47eb7c1..9ef9601 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -87,9 +87,7 @@ dsCCall label args may_gc is_asm result_ty (map coreExprType final_args) final_result_ty in - mkPrimDs the_ccall_op - [] -- ***NOTE*** no ty apps; the types are inside the_ccall_op. - final_args `thenDs` \ the_prim_app -> + mkPrimDs the_ccall_op (map VarArg final_args) `thenDs` \ the_prim_app -> let the_body = foldr apply (res_wrapper the_prim_app) arg_wrappers in @@ -115,7 +113,7 @@ unboxArg arg | arg_ty `eqTy` stringTy -- ToDo (ADR): - allow synonyms of Strings too? = newSysLocalDs byteArrayPrimTy `thenDs` \ prim_arg -> - mkAppDs (Var packStringForCId) [] [arg] `thenDs` \ pack_appn -> + mkAppDs (Var packStringForCId) [VarArg arg] `thenDs` \ pack_appn -> returnDs (Var prim_arg, \body -> Case pack_appn (PrimAlts [] (BindDefault prim_arg body)) @@ -189,15 +187,15 @@ boxResult result_ty not (null data_con_arg_tys) && null other_args_tys && -- Just one arg isPrimType the_prim_result_ty -- of primitive type = - newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id -> - newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id -> + newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id -> + newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id -> - mkConDs stateDataCon [realWorldTy] [Var prim_state_id] `thenDs` \ new_state -> - mkConDs the_data_con tycon_arg_tys [Var prim_result_id] `thenDs` \ the_result -> + mkConDs stateDataCon [TyArg realWorldTy, VarArg (Var prim_state_id)] `thenDs` \ new_state -> + mkConDs the_data_con (map TyArg tycon_arg_tys ++ [VarArg (Var prim_result_id)]) `thenDs` \ the_result -> mkConDs tuple_con_2 - [result_ty, realWorldStateTy] - [the_result, new_state] `thenDs` \ the_pair -> + [TyArg result_ty, TyArg realWorldStateTy, VarArg the_result, VarArg new_state] + `thenDs` \ the_pair -> let the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair) in @@ -210,13 +208,13 @@ boxResult result_ty (null other_data_cons) && -- Just one constr (null data_con_arg_tys) = - newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id -> - - mkConDs stateDataCon [realWorldTy] [Var prim_state_id] `thenDs` \ new_state -> + newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id -> + mkConDs stateDataCon [TyArg realWorldTy, VarArg (Var prim_state_id)] + `thenDs` \ new_state -> mkConDs tuple_con_2 - [result_ty, realWorldStateTy] - [covar_tuple_con_0, new_state] `thenDs` \ the_pair -> + [TyArg result_ty, TyArg realWorldStateTy, VarArg covar_tuple_con_0, VarArg new_state] + `thenDs` \ the_pair -> let the_alt = (stateDataCon, [prim_state_id], the_pair) diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index f679a78..d1de630 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -13,7 +13,7 @@ IMPORT_DELOOPER(DsLoop) -- partly to get dsBinds, partly to chk dsExpr import HsSyn ( failureFreePat, HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..), - Stmt(..), Match(..), Qual, HsBinds, PolyType, + Stmt(..), Match(..), Qualifier, HsBinds, PolyType, GRHSsAndBinds ) import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..), @@ -28,7 +28,7 @@ import DsHsSyn ( outPatType ) import DsListComp ( dsListComp ) import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom, mkErrorAppDs, showForErr, EquationInfo, - MatchResult + MatchResult, DsCoreArg(..) ) import Match ( matchWrapper ) @@ -54,7 +54,8 @@ import Type ( splitSigmaTy, splitFunTy, typePrimRep, getAppDataTyConExpandingDicts, getAppTyCon, applyTy, maybeBoxedPrimType ) -import TysWiredIn ( mkTupleTy, voidTy, nilDataCon, consDataCon, +import TysPrim ( voidTy ) +import TysWiredIn ( mkTupleTy, nilDataCon, consDataCon, charDataCon, charTy ) import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} ) @@ -111,7 +112,7 @@ dsExpr (HsLitOut (HsString s) _) the_char = mkCon charDataCon [] [] [LitArg (MachChar (_HEAD_ s))] the_nil = mk_nil_con charTy in - mkConDs consDataCon [charTy] [the_char, the_nil] + mkConDs consDataCon [TyArg charTy, VarArg the_char, VarArg the_nil] -- "_" => build (\ c n -> c 'c' n) -- LATER @@ -219,7 +220,7 @@ will sort it out. dsExpr (SectionL expr op) = dsExpr op `thenDs` \ core_op -> dsExpr expr `thenDs` \ core_expr -> - dsExprToAtom core_expr $ \ y_atom -> + dsExprToAtom (VarArg core_expr) $ \ y_atom -> -- for the type of x, we need the type of op's 2nd argument let @@ -235,7 +236,7 @@ dsExpr (SectionL expr op) dsExpr (SectionR op expr) = dsExpr op `thenDs` \ core_op -> dsExpr expr `thenDs` \ core_expr -> - dsExprToAtom core_expr $ \ y_atom -> + dsExprToAtom (VarArg core_expr) $ \ y_atom -> -- for the type of x, we need the type of op's 1st argument let @@ -305,19 +306,18 @@ dsExpr (ExplicitListOut ty xs) (y:ys) -> dsExpr y `thenDs` \ core_hd -> dsExpr (ExplicitListOut ty ys) `thenDs` \ core_tl -> - mkConDs consDataCon [ty] [core_hd, core_tl] + mkConDs consDataCon [TyArg ty, VarArg core_hd, VarArg core_tl] dsExpr (ExplicitTuple expr_list) = mapDs dsExpr expr_list `thenDs` \ core_exprs -> mkConDs (mkTupleCon (length expr_list)) - (map coreExprType core_exprs) - core_exprs + (map (TyArg . coreExprType) core_exprs ++ map VarArg core_exprs) -- Two cases, one for ordinary constructors and one for newtype constructors dsExpr (HsCon con tys args) | isDataTyCon tycon -- The usual datatype case = mapDs dsExpr args `thenDs` \ args_exprs -> - mkConDs con tys args_exprs + mkConDs con (map TyArg tys ++ map VarArg args_exprs) | otherwise -- The newtype case = ASSERT( isNewTyCon tycon ) @@ -333,26 +333,26 @@ dsExpr (HsCon con tys args) dsExpr (ArithSeqOut expr (From from)) = dsExpr expr `thenDs` \ expr2 -> dsExpr from `thenDs` \ from2 -> - mkAppDs expr2 [] [from2] + mkAppDs expr2 [VarArg from2] dsExpr (ArithSeqOut expr (FromTo from two)) = dsExpr expr `thenDs` \ expr2 -> dsExpr from `thenDs` \ from2 -> dsExpr two `thenDs` \ two2 -> - mkAppDs expr2 [] [from2, two2] + mkAppDs expr2 [VarArg from2, VarArg two2] dsExpr (ArithSeqOut expr (FromThen from thn)) = dsExpr expr `thenDs` \ expr2 -> dsExpr from `thenDs` \ from2 -> dsExpr thn `thenDs` \ thn2 -> - mkAppDs expr2 [] [from2, thn2] + mkAppDs expr2 [VarArg from2, VarArg thn2] dsExpr (ArithSeqOut expr (FromThenTo from thn two)) = dsExpr expr `thenDs` \ expr2 -> dsExpr from `thenDs` \ from2 -> dsExpr thn `thenDs` \ thn2 -> dsExpr two `thenDs` \ two2 -> - mkAppDs expr2 [] [from2, thn2, two2] + mkAppDs expr2 [VarArg from2, VarArg thn2, VarArg two2] \end{code} Record construction and update @@ -387,7 +387,7 @@ dsExpr (RecordCon con_expr rbinds) [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showForErr lbl) in mapDs mk_arg (zipEqual "dsExpr:RecordCon" arg_tys (dataConFieldLabels con_id)) `thenDs` \ con_args -> - mkAppDs con_expr' [] con_args + mkAppDs con_expr' (map VarArg con_args) where -- "con_expr'" is simply an application of the constructor Id -- to types and (perhaps) dictionaries. This gets the constructor... @@ -507,8 +507,7 @@ dsExpr (Dictionary dicts methods) _ -> -- tuple 'em up mkConDs (mkTupleCon num_of_d_and_ms) - (map coreExprType core_d_and_ms) - core_d_and_ms + (map (TyArg . coreExprType) core_d_and_ms ++ map VarArg core_d_and_ms) ) where dicts_and_methods = dicts ++ methods @@ -562,8 +561,6 @@ We're doing all this so we can saturate constructors (as painlessly as possible). \begin{code} -type DsCoreArg = GenCoreArg CoreExpr{-NB!-} TyVar UVar - dsApp :: TypecheckedHsExpr -- expr to desugar -> [DsCoreArg] -- accumulated ty/val args: NB: -> DsM CoreExpr -- final result @@ -591,36 +588,21 @@ dsApp (TyApp expr tys) args dsApp (HsVar v) args = lookupEnvDs v `thenDs` \ maybe_expr -> case maybe_expr of - Just expr -> apply_to_args expr args + Just expr -> mkAppDs expr args Nothing -> -- we're only saturating constructors and PrimOps case getIdUnfolding v of GenForm _ the_unfolding EssentialUnfolding -> do_unfold nullTyVarEnv nullIdEnv (unTagBinders the_unfolding) args - _ -> apply_to_args (Var v) args + _ -> mkAppDs (Var v) args dsApp anything_else args = dsExpr anything_else `thenDs` \ core_expr -> - apply_to_args core_expr args - --- a DsM version of mkGenApp: -apply_to_args :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr - -apply_to_args fun args - = let - (ty_args, val_args) = foldr sep ([],[]) args - in - mkAppDs fun ty_args val_args - where - sep a@(LitArg l) (tys,vals) = (tys, (Lit l):vals) - sep a@(VarArg e) (tys,vals) = (tys, e:vals) - sep a@(TyArg ty) (tys,vals) = (ty:tys, vals) - sep a@(UsageArg _) _ = panic "DsExpr:apply_to_args:UsageArg" + mkAppDs core_expr args \end{code} - \begin{code} dsRbinds :: TypecheckedRecordBinds -- The field bindings supplied -> ([(Id, CoreArg)] -> DsM CoreExpr) -- A continuation taking the field @@ -632,9 +614,9 @@ dsRbinds [] continue_with = continue_with [] dsRbinds ((sel_id, rhs, pun_flag) : rbinds) continue_with - = dsExpr rhs `thenDs` \ rhs' -> - dsExprToAtom rhs' $ \ rhs_atom -> - dsRbinds rbinds $ \ rbinds' -> + = dsExpr rhs `thenDs` \ rhs' -> + dsExprToAtom (VarArg rhs') $ \ rhs_atom -> + dsRbinds rbinds $ \ rbinds' -> continue_with ((sel_id, rhs_atom) : rbinds') \end{code} @@ -642,8 +624,8 @@ dsRbinds ((sel_id, rhs, pun_flag) : rbinds) continue_with do_unfold ty_env val_env (Lam (TyBinder tyvar) body) (TyArg ty : args) = do_unfold (addOneToTyVarEnv ty_env tyvar ty) val_env body args -do_unfold ty_env val_env (Lam (ValBinder binder) body) (VarArg expr : args) - = dsExprToAtom expr $ \ arg_atom -> +do_unfold ty_env val_env (Lam (ValBinder binder) body) (arg@(VarArg expr) : args) + = dsExprToAtom arg $ \ arg_atom -> do_unfold ty_env (addOneToIdEnv val_env binder (argToExpr arg_atom)) body args @@ -653,7 +635,7 @@ do_unfold ty_env val_env body args uniqSMtoDsM (substCoreExpr val_env ty_env body) `thenDs` \ body' -> -- Apply result to remaining arguments - apply_to_args body' args + mkAppDs body' args \end{code} Basically does the translation given in the Haskell~1.3 report: @@ -670,7 +652,9 @@ dsDo then_id zero_id (stmt:stmts) ExprStmtOut expr locn a b -> do_expr expr locn `thenDs` \ expr2 -> ds_rest `thenDs` \ rest -> - dsApp (HsVar then_id) [TyArg a, TyArg b, VarArg expr2, VarArg rest] + newSysLocalDs a `thenDs` \ ignored_result_id -> + dsApp (HsVar then_id) [TyArg a, TyArg b, VarArg expr2, + VarArg (mkValLam [ignored_result_id] rest)] LetStmt binds -> dsBinds binds `thenDs` \ binds2 -> diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index ac712c7..f0e388d 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -11,7 +11,7 @@ module DsListComp ( dsListComp ) where IMP_Ubiq() IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop -import HsSyn ( Qual(..), HsExpr, HsBinds ) +import HsSyn ( Qualifier(..), HsExpr, HsBinds ) import TcHsSyn ( TypecheckedQual(..), TypecheckedHsExpr(..) , TypecheckedHsBinds(..) ) import DsHsSyn ( outPatType ) import CoreSyn @@ -119,7 +119,7 @@ already desugared. @dsListComp@ does the top TE rule mentioned above. deListComp :: CoreExpr -> [TypecheckedQual] -> CoreExpr -> DsM CoreExpr deListComp expr [] list -- Figure 7.4, SLPJ, p 135, rule C above - = mkConDs consDataCon [coreExprType expr] [expr, list] + = mkConDs consDataCon [TyArg (coreExprType expr), VarArg expr, VarArg list] deListComp expr (FilterQual filt : quals) list -- rule B above = dsExpr filt `thenDs` \ core_filt -> @@ -154,13 +154,13 @@ deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above else h' in -- the "fail" value ... - mkAppDs (Var h) [] [Var u3] `thenDs` \ core_fail -> + mkAppDs (Var h) [VarArg (Var u3)] `thenDs` \ core_fail -> deListComp expr quals core_fail `thenDs` \ rest_expr -> matchSimply (Var u2) pat res_ty rest_expr core_fail `thenDs` \ core_match -> - mkAppDs (Var h) [] [core_list1] `thenDs` \ letrec_body -> + mkAppDs (Var h) [VarArg core_list1] `thenDs` \ letrec_body -> returnDs ( mkCoLetrecAny [ @@ -198,7 +198,7 @@ dfListComp :: CoreExpr -- the inside of the comp -> DsM CoreExpr dfListComp expr expr_ty c_ty c_id n_ty n_id [] - = mkAppDs (Var c_id) [] [expr, Var n_id] + = mkAppDs (Var c_id) [VarArg expr, VarArg (Var n_id)] dfListComp expr expr_ty c_ty c_id n_ty n_id (FilterQual filt : quals) = dsExpr filt `thenDs` \ core_filt -> diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 528607c..84e871f 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -13,7 +13,7 @@ module DsUtils ( combineGRHSMatchResults, combineMatchResults, - dsExprToAtom, + dsExprToAtom, DsCoreArg(..), mkCoAlgCaseMatchResult, mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs, mkCoLetsMatchResult, @@ -31,7 +31,7 @@ IMP_Ubiq() IMPORT_DELOOPER(DsLoop) ( match, matchSimply ) import HsSyn ( HsExpr(..), OutPat(..), HsLit(..), - Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo ) + Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo ) import TcHsSyn ( TypecheckedPat(..) ) import DsHsSyn ( outPatType ) import CoreSyn @@ -50,7 +50,7 @@ import TyCon ( mkTupleTyCon, isNewTyCon, tyConDataCons ) import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys, mkTheta, isUnboxedType, applyTyCon, getAppTyCon ) -import TysWiredIn ( voidTy ) +import TysPrim ( voidTy ) import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) ) import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} ) import PprCore{-ToDo:rm-} @@ -240,15 +240,19 @@ combineGRHSMatchResults match_result1 match_result2 %************************************************************************ \begin{code} -dsExprToAtom :: CoreExpr -- The argument expression +dsExprToAtom :: DsCoreArg -- The argument expression -> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*, -- and delivering an expression E -> DsM CoreExpr -- Either E or let x=arg-expr in E -dsExprToAtom (Var v) continue_with = continue_with (VarArg v) -dsExprToAtom (Lit v) continue_with = continue_with (LitArg v) +dsExprToAtom (UsageArg u) continue_with = continue_with (UsageArg u) +dsExprToAtom (TyArg t) continue_with = continue_with (TyArg t) +dsExprToAtom (LitArg l) continue_with = continue_with (LitArg l) -dsExprToAtom arg_expr continue_with +dsExprToAtom (VarArg (Var v)) continue_with = continue_with (VarArg v) +dsExprToAtom (VarArg (Lit v)) continue_with = continue_with (LitArg v) + +dsExprToAtom (VarArg arg_expr) continue_with = let ty = coreExprType arg_expr in @@ -260,12 +264,11 @@ dsExprToAtom arg_expr continue_with else Let (NonRec arg_id arg_expr) body ) -dsExprsToAtoms :: [CoreExpr] +dsExprsToAtoms :: [DsCoreArg] -> ([CoreArg] -> DsM CoreExpr) -> DsM CoreExpr -dsExprsToAtoms [] continue_with - = continue_with [] +dsExprsToAtoms [] continue_with = continue_with [] dsExprsToAtoms (arg:args) continue_with = dsExprToAtom arg $ \ arg_atom -> @@ -280,21 +283,23 @@ dsExprsToAtoms (arg:args) continue_with %************************************************************************ \begin{code} -mkAppDs :: CoreExpr -> [Type] -> [CoreExpr] -> DsM CoreExpr -mkConDs :: Id -> [Type] -> [CoreExpr] -> DsM CoreExpr -mkPrimDs :: PrimOp -> [Type] -> [CoreExpr] -> DsM CoreExpr +type DsCoreArg = GenCoreArg CoreExpr{-NB!-} TyVar UVar + +mkAppDs :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr +mkConDs :: Id -> [DsCoreArg] -> DsM CoreExpr +mkPrimDs :: PrimOp -> [DsCoreArg] -> DsM CoreExpr -mkAppDs fun tys arg_exprs - = dsExprsToAtoms arg_exprs $ \ vals -> - returnDs (mkApp fun [] tys vals) +mkAppDs fun args + = dsExprsToAtoms args $ \ atoms -> + returnDs (mkGenApp fun atoms) -mkConDs con tys arg_exprs - = dsExprsToAtoms arg_exprs $ \ vals -> - returnDs (mkCon con [] tys vals) +mkConDs con args + = dsExprsToAtoms args $ \ atoms -> + returnDs (Con con atoms) -mkPrimDs op tys arg_exprs - = dsExprsToAtoms arg_exprs $ \ vals -> - returnDs (mkPrim op [] tys vals) +mkPrimDs op args + = dsExprsToAtoms args $ \ atoms -> + returnDs (Prim op atoms) \end{code} \begin{code} diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index 010d471..8f34cfc 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -12,7 +12,7 @@ IMP_Ubiq() IMPORT_DELOOPER(DsLoop) -- break match-ish and dsExpr-ish loops import HsSyn ( HsLit(..), OutPat(..), HsExpr(..), - Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo ) + Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo ) import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..), TypecheckedPat(..) ) diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index b4356c7..7aa5f9f 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -247,8 +247,8 @@ data InstDecl tyvar uvar name pat -- module being compiled; False <=> It is from -- an imported interface. - (Maybe Module) -- The name of the module where the instance decl - -- originally came from; Nothing => Prelude + Module -- The name of the module where the instance decl + -- originally came from [Sig name] -- actually user-supplied pragmatic info (InstancePragmas name) -- interface-supplied pragmatic info diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 53bd672..b799db6 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -89,8 +89,8 @@ data HsExpr tyvar uvar id pat id -- id for zero, typed applied SrcLoc - | ListComp (HsExpr tyvar uvar id pat) -- list comprehension - [Qual tyvar uvar id pat] -- at least one Qual(ifier) + | ListComp (HsExpr tyvar uvar id pat) -- list comprehension + [Qualifier tyvar uvar id pat] -- at least one Qualifier | ExplicitList -- syntactic list [HsExpr tyvar uvar id pat] @@ -240,8 +240,8 @@ pprExpr sty (SectionL expr op) where pp_expr = pprParendExpr sty expr - pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op]) - 4 (ppCat [pp_expr, ppStr "_x )"]) + pp_prefixly = ppHang (ppCat [ppStr "( \\ x_ ->", ppr sty op]) + 4 (ppCat [pp_expr, ppStr "x_ )"]) pp_infixly v = ppSep [ ppBeside ppLparen pp_expr, ppBeside (pprSym sty v) ppRparen ] @@ -253,7 +253,7 @@ pprExpr sty (SectionR op expr) where pp_expr = pprParendExpr sty expr - pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op, ppPStr SLIT("_x")]) + pp_prefixly = ppHang (ppCat [ppStr "( \\ x_ ->", ppr sty op, ppPStr SLIT("x_")]) 4 (ppBeside pp_expr ppRparen) pp_infixly v = ppSep [ ppBeside ppLparen (pprSym sty v), @@ -477,7 +477,7 @@ pp_dotdot = ppPStr SLIT(" .. ") ``Qualifiers'' in list comprehensions: \begin{code} -data Qual tyvar uvar id pat +data Qualifier tyvar uvar id pat = GeneratorQual pat (HsExpr tyvar uvar id pat) | LetQual (HsBinds tyvar uvar id pat) @@ -487,7 +487,7 @@ data Qual tyvar uvar id pat \begin{code} instance (NamedThing id, Outputable id, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - Outputable (Qual tyvar uvar id pat) where + Outputable (Qualifier tyvar uvar id pat) where ppr sty (GeneratorQual pat expr) = ppCat [ppr sty pat, ppStr "<-", ppr sty expr] ppr sty (LetQual binds) diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index c2a2b43..d2ed9f7 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -161,7 +161,6 @@ opt_AllStrict = lookup SLIT("-fall-strict") opt_AutoSccsOnAllToplevs = lookup SLIT("-fauto-sccs-on-all-toplevs") opt_AutoSccsOnExportedToplevs = lookup SLIT("-fauto-sccs-on-exported-toplevs") opt_AutoSccsOnIndividualCafs = lookup SLIT("-fauto-sccs-on-individual-cafs") -opt_CompilingPrelude = lookup SLIT("-fcompiling-prelude") opt_D_dump_absC = lookup SLIT("-ddump-absC") opt_D_dump_asm = lookup SLIT("-ddump-asm") opt_D_dump_deforest = lookup SLIT("-ddump-deforest") @@ -216,6 +215,8 @@ opt_SpecialiseTrace = lookup SLIT("-ftrace-specialisation") opt_SpecialiseUnboxed = lookup SLIT("-fspecialise-unboxed") opt_StgDoLetNoEscapes = lookup SLIT("-flet-no-escape") opt_Verbose = lookup SLIT("-v") +opt_CompilingPrelude = maybeToBool maybe_CompilingPrelude +maybe_CompilingPrelude = lookup_str "-fcompiling-prelude=" opt_SccGroup = lookup_str "-G=" opt_ProduceC = lookup_str "-C=" opt_ProduceS = lookup_str "-S=" diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 8083b8d..a1cb9f7 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -30,17 +30,19 @@ import Id ( idType, dataConRawArgTys, dataConFieldLabels, dataConStrictMarks, StrictnessMark(..), GenId{-instance NamedThing/Outputable-} ) -import Name ( nameOrigName, origName, nameOf, +import Name ( origName, nameOf, moduleOf, exportFlagOn, nameExportFlag, ExportFlag(..), - ltLexical, isExported, getExportFlag, - isLexSym, isLocallyDefined, + isExported, getExportFlag, + isLexSym, isLocallyDefined, isWiredInName, RdrName(..){-instance Outputable-}, + OrigName(..){-instance Ord-}, Name{-instance NamedThing-} ) import ParseUtils ( UsagesMap(..), VersionsMap(..) ) import PprEnv -- not sure how much... import PprStyle ( PprStyle(..) ) import PprType -- most of it (??) +import PrelMods ( modulesWithBuiltins ) import Pretty ( prettyToUn ) import Unpretty -- ditto import RnHsSyn ( RenamedHsModule(..), RnName{-instance NamedThing-} ) @@ -54,21 +56,8 @@ uppSemid x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util ppr_ty ty = prettyToUn (pprType PprInterface ty) ppr_tyvar tv = prettyToUn (ppr PprInterface tv) ppr_name n - = let - on = origName n - s = nameOf on - pp = prettyToUn (ppr PprInterface on) - in - (if isLexSym s then uppParens else id) pp -{-OLD: -ppr_unq_name n - = let - on = origName n - s = nameOf on - pp = uppPStr s - in - (if isLexSym s then uppParens else id) pp --} + = case (origName "ppr_name" n) of { OrigName m s -> + uppBesides [uppPStr m, uppChar '.', uppPStr s] } \end{code} We have a function @startIface@ to open the output file and put @@ -139,14 +128,19 @@ ifaceUsages (Just if_hdl) usages = hPutStr if_hdl "\n__usages__\n" >> hPutStr if_hdl (uppShow 0 (uppAboves (map upp_uses usages_list))) where - usages_list = fmToList usages + usages_list = filter has_no_builtins (fmToList usages) + + has_no_builtins (m, _) + = m `notElem` modulesWithBuiltins + -- Don't *have* to do this; save gratuitous spillage in + -- every interface. Could be flag-controlled... upp_uses (m, (mv, versions)) = uppBesides [uppPStr m, uppSP, uppInt mv, uppPStr SLIT(" :: "), upp_versions (fmToList versions), uppSemi] upp_versions nvs - = uppIntersperse uppSP [ uppCat [(if isLexSym n then uppParens else id) (uppPStr n), uppInt v] | (n,v) <- nvs ] + = uppIntersperse uppSP [ uppCat [uppPStr n, uppInt v] | (n,v) <- nvs ] \end{code} \begin{code} @@ -158,11 +152,15 @@ ifaceVersions (Just if_hdl) version_info | otherwise = hPutStr if_hdl "\n__versions__\n" >> hPutStr if_hdl (uppShow 0 (upp_versions version_list)) + -- NB: when compiling Prelude.hs, this will spew out + -- stuff for [], (), (,), etc. [i.e., builtins], which + -- we'd rather it didn't. The version-mangling in + -- the driver will ignore them. where version_list = fmToList version_info upp_versions nvs - = uppAboves [ (if isLexSym n then uppParens else id) (uppPStr n) | (n,v) <- nvs ] + = uppAboves [ uppPStr n | (n,v) <- nvs ] \end{code} \begin{code} @@ -185,7 +183,7 @@ ifaceExportList Nothing{-no iface handle-} _ = return () ifaceExportList (Just if_hdl) (HsModule _ _ _ _ _ typedecls _ classdecls _ _ _ binds sigs _) = let - name_flag_pairs :: Bag (Name, ExportFlag) + name_flag_pairs :: Bag (OrigName, ExportFlag) name_flag_pairs = foldr from_ty (foldr from_cls @@ -212,10 +210,10 @@ ifaceExportList (Just if_hdl) from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs) -------------- - maybe_add :: Bag (Name, ExportFlag) -> RnName -> Bag (Name, ExportFlag) + maybe_add :: Bag (OrigName, ExportFlag) -> RnName -> Bag (OrigName, ExportFlag) maybe_add acc rn - | exportFlagOn ef = acc `snocBag` (n, ef) + | exportFlagOn ef = acc `snocBag` (origName "maybe_add" n, ef) | otherwise = acc where n = getName rn @@ -226,11 +224,11 @@ ifaceExportList (Just if_hdl) maybe_add_list acc (n:ns) = maybe_add (maybe_add_list acc ns) n -------------- - lexical_lt (n1,_) (n2,_) = nameOrigName n1 < nameOrigName n2 + lexical_lt (n1,_) (n2,_) = n1 < n2 -------------- - upp_pair (n, ef) - = uppBeside (ppr_name n) (upp_export ef) + upp_pair (OrigName m n, ef) + = uppBesides [uppPStr m, uppSP, uppPStr n, uppSP, upp_export ef] where upp_export ExportAll = uppPStr SLIT("(..)") upp_export ExportAbs = uppNil @@ -241,17 +239,20 @@ ifaceFixities Nothing{-no iface handle-} _ = return () ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _) = let - local_fixities = filter from_here fixities + pp_fixities = foldr go [] fixities in - if null local_fixities then + if null pp_fixities then return () else hPutStr if_hdl "\n__fixities__\n" >> - hPutStr if_hdl (uppShow 0 (uppAboves (map uppSemid local_fixities))) + hPutStr if_hdl (uppShow 0 (uppAboves pp_fixities)) where - from_here (InfixL v _) = isLocallyDefined v - from_here (InfixR v _) = isLocallyDefined v - from_here (InfixN v _) = isLocallyDefined v + go (InfixL v i) acc = (if isLocallyDefined v then (:) (print_fix "l" i v) else id) acc + go (InfixR v i) acc = (if isLocallyDefined v then (:) (print_fix "r" i v) else id) acc + go (InfixN v i) acc = (if isLocallyDefined v then (:) (print_fix "" i v) else id) acc + + print_fix suff prec var + = uppBesides [uppPStr SLIT("infix"), uppStr suff, uppSP, uppInt prec, uppSP, ppr_name var, uppSemi] \end{code} \begin{code} @@ -262,9 +263,17 @@ ifaceDecls (Just if_hdl) (vals, tycons, classes, _) ASSERT(all isLocallyDefined tycons) ASSERT(all isLocallyDefined classes) let - sorted_classes = sortLt ltLexical classes - sorted_tycons = sortLt ltLexical tycons - sorted_vals = sortLt ltLexical vals + non_wired x = not (isWiredInName (getName x)) + + nonwired_classes = filter non_wired classes + nonwired_tycons = filter non_wired tycons + nonwired_vals = filter non_wired vals + + lt_lexical a b = origName "lt_lexical" a < origName "lt_lexical" b + + sorted_classes = sortLt lt_lexical nonwired_classes + sorted_tycons = sortLt lt_lexical nonwired_tycons + sorted_vals = sortLt lt_lexical nonwired_vals in if (null sorted_classes && null sorted_tycons && null sorted_vals) then -- You could have a module with just instances in it @@ -302,10 +311,10 @@ ifaceInstances (Just if_hdl) (_, _, _, insts) tycon1 = fst (getAppTyCon ty1) tycon2 = fst (getAppTyCon ty2) in - case (origName clas1 `cmp` origName clas2) of + case (origName "lt_inst" clas1 `cmp` origName "lt_inst" clas2) of LT_ -> True GT_ -> False - EQ_ -> origName tycon1 < origName tycon2 + EQ_ -> origName "lt_inst2" tycon1 < origName "lt_inst2" tycon2 ------- pp_inst (InstInfo clas tvs ty theta _ _ _ _ _ _ _ _) @@ -330,25 +339,27 @@ ppr_class c case (initNmbr (nmbrClass c)) of { -- renumber it! Class _ n tyvar super_classes sdsels ops sels defms insts links -> - uppCat [uppPStr SLIT("class"), ppr_theta tyvar super_classes, + uppCat [uppPStr SLIT("class"), ppr_context tyvar super_classes, ppr_name n, ppr_tyvar tyvar, if null ops then uppSemi else uppCat [uppStr "where {", uppCat (map ppr_op ops), uppStr "};"]] } where - ppr_theta :: TyVar -> [Class] -> Unpretty + ppr_context :: TyVar -> [Class] -> Unpretty - ppr_theta tv [] = uppNil - ppr_theta tv [sc] = uppBeside (ppr_assert tv sc) (uppPStr SLIT(" =>")) - ppr_theta tv super_classes - = uppBesides [uppLparen, + ppr_context tv [] = uppNil +-- ppr_context tv [sc] = uppBeside (ppr_assert tv sc) (uppPStr SLIT(" =>")) + ppr_context tv super_classes + = uppBesides [uppStr "{{", uppIntersperse upp'SP{-'-} (map (ppr_assert tv) super_classes), - uppStr ") =>"] + uppStr "}} =>"] ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = uppCat [ppr_name n, ppr_tyvar tv] - ppr_op (ClassOp o _ ty) = pp_sig (Unqual o) ty + clas_mod = moduleOf (origName "ppr_class" c) + + ppr_op (ClassOp o _ ty) = pp_sig (Qual clas_mod o) ty \end{code} \begin{code} @@ -396,11 +407,11 @@ ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new) NewType -> uppPStr SLIT("newtype") ppr_context [] = uppNil - ppr_context [(c,t)] = uppCat [ppr_name c, ppr_ty t, uppPStr SLIT("=>")] +-- ppr_context [(c,t)] = uppCat [ppr_name c, ppr_ty t, uppPStr SLIT("=>")] ppr_context cs - = uppBesides[uppLparen, + = uppBesides[uppStr "{{", uppInterleave uppComma [uppCat [ppr_name c, ppr_ty t] | (c,t) <- cs], - uppRparen, uppPStr SLIT(" =>")] + uppStr "}}", uppPStr SLIT(" =>")] pp_condecls = let diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 62c5f97..c4b8e3d 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -258,13 +258,6 @@ macroCode POP_STD_UPD_FRAME args returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs) \end{code} -The @SET_ARITY@ and @CHK_ARITY@ macros are disabled for ``normal'' -compilation. -\begin{code} -macroCode SET_ARITY args = returnUs id -macroCode CHK_ARITY args = returnUs id -\end{code} - This one only applies if we have a machine register devoted to TagReg. \begin{code} macroCode SET_TAG [tag] diff --git a/ghc/compiler/parser/hslexer.flex b/ghc/compiler/parser/hslexer.flex index d5c187e..ab3300e 100644 --- a/ghc/compiler/parser/hslexer.flex +++ b/ghc/compiler/parser/hslexer.flex @@ -41,9 +41,6 @@ #define _O 0x8 #define _C 0x10 -#define _isconstr(s) (CharTable[*s]&(_C)) -BOOLEAN isconstr PROTO((char *)); /* fwd decl */ - static unsigned char CharTable[NCHARS] = { /* nul */ 0, 0, 0, 0, 0, 0, 0, 0, /* bs */ 0, _S, _S, _S, _S, 0, 0, 0, @@ -80,6 +77,12 @@ static unsigned char CharTable[NCHARS] = { /* */ 0, 0, 0, 0, 0, 0, 0, 0, }; +BOOLEAN +isconstr (char *s) +{ + return(CharTable[*s]&(_C)); +} + /********************************************************************** * * * * @@ -111,15 +114,15 @@ static BOOLEAN forgetindent = FALSE; /* Don't bother applying indentation rules static int nested_comments; /* For counting comment nesting depth */ -/* Hacky definition of yywrap: see flex doc. +/* OLD: Hacky definition of yywrap: see flex doc. If we don't do this, then we'll have to get the default yywrap from the flex library, which is often something we are not good at locating. This avoids that difficulty. (Besides which, this is the way old flexes (pre 2.4.x) did it.) WDP 94/09/05 -*/ #define yywrap() 1 +*/ /* Essential forward declarations */ @@ -193,26 +196,21 @@ static short indenttab[MAX_CONTEXTS] = {-1}; #endif /* Each time we enter a new start state, we push it onto the state stack. - Note that the rules do not allow us to underflow or overflow the stack. - (At least, they shouldn't.) The maximum expected depth is 4: - 0: Code -> 1: String -> 2: StringEsc -> 3: Comment */ -static int StateStack[5]; -static int StateDepth = -1; - -#ifdef HSP_DEBUG -#define PUSH_STATE(n) do {\ - fprintf(stderr,"Pushing %d (%d)\n", n, StateDepth + 1);\ - StateStack[++StateDepth] = (n); BEGIN(n);} while(0) -#define POP_STATE do {--StateDepth;\ - fprintf(stderr,"Popping %d (%d)\n", StateStack[StateDepth], StateDepth);\ - BEGIN(StateStack[StateDepth]);} while(0) -#else -#define PUSH_STATE(n) do {StateStack[++StateDepth] = (n); BEGIN(n);} while(0) -#define POP_STATE do {--StateDepth; BEGIN(StateStack[StateDepth]);} while(0) -#endif +#define PUSH_STATE(n) yy_push_state(n) +#define POP_STATE yy_pop_state() %} +/* Options: + 8bit (8-bit input) + noyywrap (do not call yywrap on end of file; avoid use of -lfl) + never-interactive (to go a bit faster) + stack (use a start-condition stack) +*/ +%option 8bit +%option noyywrap +%option never-interactive +%option stack /* The start states are: Code -- normal Haskell code (principal lexer) @@ -470,33 +468,23 @@ NL [\n\r] hsperror(errbuf); } hsnewid(yytext, yyleng); - RETURN(_isconstr(yytext) ? CONID : VARID); - } -_+{Id} { - if (! nonstandardFlag) { - char errbuf[ERR_BUF_SIZE]; - sprintf(errbuf, "Non-standard identifier (leading underscore): %s\n", yytext); - hsperror(errbuf); - } - hsnewid(yytext, yyleng); RETURN(isconstr(yytext) ? CONID : VARID); - /* NB: ^^^^^^^^ : not the macro! */ } {Id} { hsnewid(yytext, yyleng); - RETURN(_isconstr(yytext) ? CONID : VARID); + RETURN(isconstr(yytext) ? CONID : VARID); } {SId} { hsnewid(yytext, yyleng); - RETURN(_isconstr(yytext) ? CONSYM : VARSYM); + RETURN(isconstr(yytext) ? CONSYM : VARSYM); } {Mod}"."{Id} { - BOOLEAN isconstr = hsnewqid(yytext, yyleng); - RETURN(isconstr ? QCONID : QVARID); + BOOLEAN is_constr = hsnewqid(yytext, yyleng); + RETURN(is_constr ? QCONID : QVARID); } {Mod}"."{SId} { - BOOLEAN isconstr = hsnewqid(yytext, yyleng); - RETURN(isconstr ? QCONSYM : QVARSYM); + BOOLEAN is_constr = hsnewqid(yytext, yyleng); + RETURN(is_constr ? QCONSYM : QVARSYM); } %{ @@ -511,7 +499,7 @@ NL [\n\r] "`"{Id}"#`" { hsnewid(yytext + 1, yyleng - 2); - RETURN(_isconstr(yytext+1) ? CONSYM : VARSYM); + RETURN(isconstr(yytext+1) ? CONSYM : VARSYM); } %{ @@ -1297,15 +1285,5 @@ hsnewqid(char *name, int length) *dot = '.'; name[length] = save; - return _isconstr(dot+1); -} - -BOOLEAN -isconstr(char *s) /* walks past leading underscores before using the macro */ -{ - char *temp = s; - - for ( ; temp != NULL && *temp == '_' ; temp++ ); - - return _isconstr(temp); + return isconstr(dot+1); } diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index ccefcf3..466c140 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -34,7 +34,7 @@ import CmdLineOpts ( opt_HideBuiltinNames, import FiniteMap ( FiniteMap, emptyFM, listToFM ) import Id ( mkTupleCon, GenId, Id(..) ) import Maybes ( catMaybes ) -import Name ( moduleNamePair ) +import Name ( origName, OrigName(..) ) import RnHsSyn ( RnName(..) ) import TyCon ( tyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon ) import Type @@ -55,11 +55,11 @@ We have two ``builtin name funs,'' one to look up @TyCons@ and \begin{code} builtinNameInfo :: ( BuiltinNames, BuiltinKeys, BuiltinIdInfos ) -type BuiltinNames = (FiniteMap (FAST_STRING,Module) RnName, -- WiredIn Ids - FiniteMap (FAST_STRING,Module) RnName) -- WiredIn TyCons +type BuiltinNames = (FiniteMap OrigName RnName, -- WiredIn Ids + FiniteMap OrigName RnName) -- WiredIn TyCons -- Two maps because "[]" is in both... -type BuiltinKeys = FiniteMap (FAST_STRING,Module) (Unique, Name -> RnName) +type BuiltinKeys = FiniteMap OrigName (Unique, Name -> RnName) -- Names with known uniques type BuiltinIdInfos = UniqFM IdInfo -- Info for known unique Ids @@ -111,7 +111,6 @@ builtinNameInfo -- values map pcIdWiredInInfo wired_in_ids, - map pcIdWiredInInfo parallel_ids, primop_ids ] assoc_tc_wired @@ -214,6 +213,7 @@ data_tycons , stateAndSynchVarPrimTyCon , stateAndWordPrimTyCon , stateTyCon + , voidTyCon , wordTyCon ] \end{code} @@ -222,52 +222,56 @@ The WiredIn Ids ... ToDo: Some of these should be moved to id_keys_infos! \begin{code} wired_in_ids - = [ eRROR_ID - , pAT_ERROR_ID -- occurs in i/faces - , pAR_ERROR_ID -- ditto - , tRACE_ID - - , runSTId - , seqId - , realWorldPrimId - - -- foldr/build Ids have magic unfoldings - , buildId + = [ aBSENT_ERROR_ID , augmentId + , buildId + , copyableId + , eRROR_ID , foldlId , foldrId + , forkId + , iRREFUT_PAT_ERROR_ID + , integerMinusOneId + , integerPlusOneId + , integerPlusTwoId + , integerZeroId + , nON_EXHAUSTIVE_GUARDS_ERROR_ID + , nO_DEFAULT_METHOD_ERROR_ID + , nO_EXPLICIT_METHOD_ERROR_ID + , noFollowId + , pAR_ERROR_ID + , pAT_ERROR_ID + , packStringForCId + , parAtAbsId + , parAtForNowId + , parAtId + , parAtRelId + , parGlobalId + , parId + , parLocalId + , rEC_CON_ERROR_ID + , rEC_UPD_ERROR_ID + , realWorldPrimId + , runSTId + , seqId + , tRACE_ID + , tRACE_ID + , unpackCString2Id , unpackCStringAppendId , unpackCStringFoldrId + , unpackCStringId + , voidId ] -parallel_ids - = if not opt_ForConcurrent then - [] - else - [ parId - , forkId - , copyableId - , noFollowId - , parAtAbsId - , parAtForNowId - , parAtId - , parAtRelId - , parGlobalId - , parLocalId - ] - - -pcTyConWiredInInfo :: TyCon -> ((FAST_STRING,Module), RnName) -pcTyConWiredInInfo tc = (swap (moduleNamePair tc), WiredInTyCon tc) - -pcDataConWiredInInfo :: TyCon -> [((FAST_STRING,Module), RnName)] -pcDataConWiredInInfo tycon - = [ (swap (moduleNamePair con), WiredInId con) | con <- tyConDataCons tycon ] +pcTyConWiredInInfo :: TyCon -> (OrigName, RnName) +pcTyConWiredInInfo tc = (origName "pcTyConWiredInInfo" tc, WiredInTyCon tc) -pcIdWiredInInfo :: Id -> ((FAST_STRING,Module), RnName) -pcIdWiredInInfo id = (swap (moduleNamePair id), WiredInId id) +pcDataConWiredInInfo :: TyCon -> [(OrigName, RnName)] +pcDataConWiredInInfo tycon + = [ (origName "pcDataConWiredInInfo" con, WiredInId con) | con <- tyConDataCons tycon ] -swap (x,y) = (y,x) +pcIdWiredInInfo :: Id -> (OrigName, RnName) +pcIdWiredInInfo id = (origName "pcIdWiredInInfo" id, WiredInId id) \end{code} WiredIn primitive numeric operations ... @@ -275,8 +279,8 @@ WiredIn primitive numeric operations ... primop_ids = map prim_fn allThePrimOps ++ map funny_fn funny_name_primops where - prim_fn op = case (primOpNameInfo op) of (s,n) -> ((s,pRELUDE),n) - funny_fn (op,s) = case (primOpNameInfo op) of (_,n) -> ((s,pRELUDE),n) + prim_fn op = case (primOpNameInfo op) of (s,n) -> ((OrigName gHC_BUILTINS s),n) + funny_fn (op,s) = case (primOpNameInfo op) of (_,n) -> ((OrigName gHC_BUILTINS s),n) funny_name_primops = [ (IntAddOp, SLIT("+#")) @@ -306,30 +310,30 @@ funny_name_primops Ids, Synonyms, Classes and ClassOps with builtin keys. For the Ids we may also have some builtin IdInfo. \begin{code} -id_keys_infos :: [((FAST_STRING,Module), Unique, Maybe IdInfo)] +id_keys_infos :: [(OrigName, Unique, Maybe IdInfo)] id_keys_infos = [ -- here so we can check the type of main/mainPrimIO - ((SLIT("main"),SLIT("Main")), mainIdKey, Nothing) - , ((SLIT("mainPrimIO"),SLIT("Main")), mainPrimIOIdKey, Nothing) + (OrigName SLIT("Main") SLIT("main"), mainIdKey, Nothing) + , (OrigName SLIT("Main") SLIT("mainPrimIO"), mainPrimIOIdKey, Nothing) -- here because we use them in derived instances - , ((SLIT("&&"), pRELUDE), andandIdKey, Nothing) - , ((SLIT("."), pRELUDE), composeIdKey, Nothing) - , ((SLIT("lex"), pRELUDE), lexIdKey, Nothing) - , ((SLIT("not"), pRELUDE), notIdKey, Nothing) - , ((SLIT("readParen"), pRELUDE), readParenIdKey, Nothing) - , ((SLIT("showParen"), pRELUDE), showParenIdKey, Nothing) - , ((SLIT("showString"), pRELUDE), showStringIdKey,Nothing) - , ((SLIT("__readList"), pRELUDE), ureadListIdKey, Nothing) - , ((SLIT("__showList"), pRELUDE), ushowListIdKey, Nothing) - , ((SLIT("__showSpace"), pRELUDE), showSpaceIdKey, Nothing) + , (OrigName pRELUDE SLIT("&&"), andandIdKey, Nothing) + , (OrigName pRELUDE SLIT("."), composeIdKey, Nothing) + , (OrigName pRELUDE SLIT("lex"), lexIdKey, Nothing) + , (OrigName pRELUDE SLIT("not"), notIdKey, Nothing) + , (OrigName pRELUDE SLIT("readParen"), readParenIdKey, Nothing) + , (OrigName pRELUDE SLIT("showParen"), showParenIdKey, Nothing) + , (OrigName pRELUDE SLIT("showString"), showStringIdKey,Nothing) + , (OrigName gHC__ SLIT("readList__"), ureadListIdKey, Nothing) + , (OrigName gHC__ SLIT("showList__"), ushowListIdKey, Nothing) + , (OrigName gHC__ SLIT("showSpace"), showSpaceIdKey, Nothing) ] tysyn_keys - = [ ((SLIT("IO"),pRELUDE), (iOTyConKey, RnImplicitTyCon)) - , ((SLIT("Rational"),rATIO), (rationalTyConKey, RnImplicitTyCon)) - , ((SLIT("Ratio"),rATIO), (ratioTyConKey, RnImplicitTyCon)) - , ((SLIT("Ordering"),pRELUDE), (orderingTyConKey, RnImplicitTyCon)) + = [ (OrigName gHC__ SLIT("IO"), (iOTyConKey, RnImplicitTyCon)) + , (OrigName pRELUDE SLIT("Ordering"), (orderingTyConKey, RnImplicitTyCon)) + , (OrigName rATIO SLIT("Rational"), (rationalTyConKey, RnImplicitTyCon)) + , (OrigName rATIO SLIT("Ratio"), (ratioTyConKey, RnImplicitTyCon)) ] -- this "class_keys" list *must* include: @@ -338,41 +342,41 @@ tysyn_keys class_keys = [ (str_mod, (k, RnImplicitClass)) | (str_mod,k) <- - [ ((SLIT("Eq"),pRELUDE), eqClassKey) -- mentioned, derivable - , ((SLIT("Eval"),pRELUDE), evalClassKey) -- mentioned - , ((SLIT("Ord"),pRELUDE), ordClassKey) -- derivable - , ((SLIT("Num"),pRELUDE), numClassKey) -- mentioned, numeric - , ((SLIT("Real"),pRELUDE), realClassKey) -- numeric - , ((SLIT("Integral"),pRELUDE), integralClassKey) -- numeric - , ((SLIT("Fractional"),pRELUDE), fractionalClassKey) -- numeric - , ((SLIT("Floating"),pRELUDE), floatingClassKey) -- numeric - , ((SLIT("RealFrac"),pRELUDE), realFracClassKey) -- numeric - , ((SLIT("RealFloat"),pRELUDE), realFloatClassKey) -- numeric - , ((SLIT("Ix"),iX), ixClassKey) -- derivable (but it isn't Prelude.Ix; hmmm) - , ((SLIT("Bounded"),pRELUDE), boundedClassKey) -- derivable - , ((SLIT("Enum"),pRELUDE), enumClassKey) -- derivable - , ((SLIT("Show"),pRELUDE), showClassKey) -- derivable - , ((SLIT("Read"),pRELUDE), readClassKey) -- derivable - , ((SLIT("Monad"),pRELUDE), monadClassKey) - , ((SLIT("MonadZero"),pRELUDE), monadZeroClassKey) - , ((SLIT("MonadPlus"),pRELUDE), monadPlusClassKey) - , ((SLIT("Functor"),pRELUDE), functorClassKey) - , ((SLIT("_CCallable"),pRELUDE), cCallableClassKey) -- mentioned, ccallish - , ((SLIT("_CReturnable"),pRELUDE), cReturnableClassKey) -- mentioned, ccallish + [ (OrigName pRELUDE SLIT("Eq"), eqClassKey) -- mentioned, derivable + , (OrigName pRELUDE SLIT("Eval"), evalClassKey) -- mentioned + , (OrigName pRELUDE SLIT("Ord"), ordClassKey) -- derivable + , (OrigName pRELUDE SLIT("Num"), numClassKey) -- mentioned, numeric + , (OrigName pRELUDE SLIT("Real"), realClassKey) -- numeric + , (OrigName pRELUDE SLIT("Integral"), integralClassKey) -- numeric + , (OrigName pRELUDE SLIT("Fractional"), fractionalClassKey) -- numeric + , (OrigName pRELUDE SLIT("Floating"), floatingClassKey) -- numeric + , (OrigName pRELUDE SLIT("RealFrac"), realFracClassKey) -- numeric + , (OrigName pRELUDE SLIT("RealFloat"), realFloatClassKey) -- numeric + , (OrigName iX SLIT("Ix"), ixClassKey) -- derivable (but it isn't Prelude.Ix; hmmm) + , (OrigName pRELUDE SLIT("Bounded"), boundedClassKey) -- derivable + , (OrigName pRELUDE SLIT("Enum"), enumClassKey) -- derivable + , (OrigName pRELUDE SLIT("Show"), showClassKey) -- derivable + , (OrigName pRELUDE SLIT("Read"), readClassKey) -- derivable + , (OrigName pRELUDE SLIT("Monad"), monadClassKey) + , (OrigName pRELUDE SLIT("MonadZero"), monadZeroClassKey) + , (OrigName pRELUDE SLIT("MonadPlus"), monadPlusClassKey) + , (OrigName pRELUDE SLIT("Functor"), functorClassKey) + , (OrigName gHC__ SLIT("CCallable"), cCallableClassKey) -- mentioned, ccallish + , (OrigName gHC__ SLIT("CReturnable"), cReturnableClassKey) -- mentioned, ccallish ]] class_op_keys = [ (str_mod, (k, RnImplicit)) | (str_mod,k) <- - [ ((SLIT("fromInt"),pRELUDE), fromIntClassOpKey) - , ((SLIT("fromInteger"),pRELUDE), fromIntegerClassOpKey) - , ((SLIT("fromRational"),pRELUDE), fromRationalClassOpKey) - , ((SLIT("enumFrom"),pRELUDE), enumFromClassOpKey) - , ((SLIT("enumFromThen"),pRELUDE), enumFromThenClassOpKey) - , ((SLIT("enumFromTo"),pRELUDE), enumFromToClassOpKey) - , ((SLIT("enumFromThenTo"),pRELUDE),enumFromThenToClassOpKey) - , ((SLIT("=="),pRELUDE), eqClassOpKey) - , ((SLIT(">>="),pRELUDE), thenMClassOpKey) - , ((SLIT("zero"),pRELUDE), zeroClassOpKey) + [ (OrigName pRELUDE SLIT("fromInt"), fromIntClassOpKey) + , (OrigName pRELUDE SLIT("fromInteger"), fromIntegerClassOpKey) + , (OrigName pRELUDE SLIT("fromRational"), fromRationalClassOpKey) + , (OrigName pRELUDE SLIT("enumFrom"), enumFromClassOpKey) + , (OrigName pRELUDE SLIT("enumFromThen"), enumFromThenClassOpKey) + , (OrigName pRELUDE SLIT("enumFromTo"), enumFromToClassOpKey) + , (OrigName pRELUDE SLIT("enumFromThenTo"),enumFromThenToClassOpKey) + , (OrigName pRELUDE SLIT("=="), eqClassOpKey) + , (OrigName pRELUDE SLIT(">>="), thenMClassOpKey) + , (OrigName pRELUDE SLIT("zero"), zeroClassOpKey) ]] \end{code} diff --git a/ghc/compiler/prelude/PrelLoop.lhi b/ghc/compiler/prelude/PrelLoop.lhi index 9d17859..c016e48 100644 --- a/ghc/compiler/prelude/PrelLoop.lhi +++ b/ghc/compiler/prelude/PrelLoop.lhi @@ -8,7 +8,7 @@ import PreludePS ( _PackedString ) import Class ( GenClass ) import CoreUnfold ( mkMagicUnfolding, UnfoldingDetails ) import IdUtils ( primOpNameInfo ) -import Name ( Name, mkBuiltinName ) +import Name ( Name, OrigName, mkPrimitiveName, mkWiredInName ) import PrimOp ( PrimOp ) import RnHsSyn ( RnName ) import Type ( mkSigmaTy, mkFunTys, GenType ) @@ -17,7 +17,8 @@ import Unique ( Unique ) import Usage ( GenUsage ) mkMagicUnfolding :: Unique -> UnfoldingDetails -mkBuiltinName :: Unique -> _PackedString -> _PackedString -> Name +mkPrimitiveName :: Unique -> OrigName -> Name +mkWiredInName :: Unique -> OrigName -> Name mkSigmaTy :: [a] -> [(GenClass (GenTyVar (GenUsage Unique)) Unique, GenType a b)] -> GenType a b -> GenType a b mkFunTys :: [GenType a b] -> GenType a b -> GenType a b diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs index da5b711..1d73db7 100644 --- a/ghc/compiler/prelude/PrelMods.lhs +++ b/ghc/compiler/prelude/PrelMods.lhs @@ -9,14 +9,10 @@ defined here so as to avod #include "HsVersions.h" module PrelMods ( - pRELUDE, pRELUDE_BUILTIN, - pRELUDE_LIST, pRELUDE_TEXT, - pRELUDE_PRIMIO, pRELUDE_IO, pRELUDE_PS, - gLASGOW_ST, gLASGOW_MISC, - pRELUDE_FB, + gHC_BUILTINS, -- things that are really and truly primitive + pRELUDE, gHC__, rATIO, iX, - - fromPrelude + modulesWithBuiltins ) where CHK_Ubiq() -- debugging consistency check @@ -24,23 +20,12 @@ CHK_Ubiq() -- debugging consistency check \begin{code} -gLASGOW_MISC = SLIT("PreludeGlaMisc") -gLASGOW_ST = SLIT("PreludeGlaST") -pRELUDE = SLIT("Prelude") -pRELUDE_BUILTIN = SLIT("PreludeBuiltin") -pRELUDE_FB = SLIT("PreludeFoldrBuild") -pRELUDE_IO = SLIT("PreludeIO") -pRELUDE_LIST = SLIT("PreludeList") -pRELUDE_PRIMIO = SLIT("PreludePrimIO") -pRELUDE_PS = SLIT("PreludePS") -pRELUDE_TEXT = SLIT("PreludeText") +pRELUDE = SLIT("Prelude") +gHC_BUILTINS = SLIT("GHCbuiltins") -- the truly-primitive things +gHC__ = SLIT("GHCbase") -- all GHC basics, add-ons, extras, everything + -- (which can be defined in Haskell) +rATIO = SLIT("Ratio") +iX = SLIT("Ix") -rATIO = SLIT("Ratio") -iX = SLIT("Ix") - -fromPrelude :: FAST_STRING -> Bool -fromPrelude s = (_SUBSTR_ s 0 6 == SLIT("Prelude")) - where - substr str beg end - = take (end - beg + 1) (drop beg str) +modulesWithBuiltins = [ gHC_BUILTINS, gHC__, pRELUDE, rATIO, iX ] \end{code} diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index 9ae5300..30f24db 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -10,7 +10,7 @@ module PrelVals where IMP_Ubiq() IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..) ) -import Id ( Id(..), GenId, mkPreludeId, mkTemplateLocals ) +import Id ( Id(..), GenId, mkImported, mkUserId, mkTemplateLocals ) IMPORT_DELOOPER(PrelLoop) -- friends: @@ -19,11 +19,14 @@ import TysPrim import TysWiredIn -- others: +import CmdLineOpts ( maybe_CompilingPrelude ) import CoreSyn -- quite a bit import IdInfo -- quite a bit import Literal ( mkMachInt ) +import PragmaInfo import PrimOp ( PrimOp(..) ) import SpecEnv ( SpecEnv(..), nullSpecEnv ) +import Type ( mkTyVarTy ) import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar ) import Unique -- lots of *Keys import Util ( panic ) @@ -36,8 +39,25 @@ import Util ( panic ) -- only used herein: pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> Type -> IdInfo -> Id -pcMiscPrelId key mod name ty info - = mkPreludeId (mkBuiltinName key mod name) ty info +pcMiscPrelId key m n ty info + = let + name = mkWiredInName key (OrigName m n) + imp = mkImported name ty info -- the usual case... + in + imp + -- We lie and say the thing is imported; otherwise, we get into + -- a mess with dependency analysis; e.g., core2stg may heave in + -- random calls to GHCbase.unpackPS. If GHCbase is the module + -- being compiled, then it's just a matter of luck if the definition + -- will be in "the right place" to be in scope. +{- ??? + case maybe_CompilingPrelude of + Nothing -> imp + Just modname -> + if modname == _UNPK_ m -- we are compiling the module where this thing is defined... + then mkUserId name ty NoPragmaInfo + else imp +-} \end{code} %************************************************************************ @@ -48,15 +68,15 @@ pcMiscPrelId key mod name ty info GHC randomly injects these into the code. -@patError#@ is just a version of @error@ for pattern-matching +@patError@ is just a version of @error@ for pattern-matching failures. It knows various ``codes'' which expand to longer strings---this saves space! -@absent#@ is a thing we put in for ``absent'' arguments. They jolly +@absentErr@ is a thing we put in for ``absent'' arguments. They jolly well shouldn't be yanked on, but if one is, then you will get a -friendly message from @absent#@ (rather a totally random crash). +friendly message from @absentErr@ (rather a totally random crash). -@parError#@ is a special version of @error@ which the compiler does +@parError@ is a special version of @error@ which the compiler does not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@ templates, but we don't ever expect to generate code for it. @@ -68,36 +88,36 @@ pc_bottoming_Id key mod name ty -- these "bottom" out, no matter what their arguments eRROR_ID - = pc_bottoming_Id errorIdKey pRELUDE_BUILTIN SLIT("error") errorTy + = pc_bottoming_Id errorIdKey pRELUDE SLIT("error") errorTy generic_ERROR_ID u n - = pc_bottoming_Id u pRELUDE_BUILTIN n errorTy + = pc_bottoming_Id u gHC__ n errorTy pAT_ERROR_ID - = generic_ERROR_ID patErrorIdKey SLIT("patError#") + = generic_ERROR_ID patErrorIdKey SLIT("patError") rEC_CON_ERROR_ID - = generic_ERROR_ID recConErrorIdKey SLIT("recConError#") + = generic_ERROR_ID recConErrorIdKey SLIT("recConError") rEC_UPD_ERROR_ID - = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError#") + = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError") iRREFUT_PAT_ERROR_ID - = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError#") + = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError") nON_EXHAUSTIVE_GUARDS_ERROR_ID - = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError#") + = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError") nO_DEFAULT_METHOD_ERROR_ID - = generic_ERROR_ID noDefaultMethodErrorIdKey SLIT("noDefaultMethodError#") + = generic_ERROR_ID noDefaultMethodErrorIdKey SLIT("noDefaultMethodError") nO_EXPLICIT_METHOD_ERROR_ID - = generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError#") + = generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError") aBSENT_ERROR_ID - = pc_bottoming_Id absentErrorIdKey pRELUDE_BUILTIN SLIT("absent#") + = pc_bottoming_Id absentErrorIdKey gHC__ SLIT("absentErr") (mkSigmaTy [alphaTyVar] [] alphaTy) pAR_ERROR_ID - = pcMiscPrelId parErrorIdKey pRELUDE_BUILTIN SLIT("parError#") + = pcMiscPrelId parErrorIdKey gHC__ SLIT("parError") (mkSigmaTy [alphaTyVar] [] alphaTy) noIdInfo errorTy :: Type -errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] alphaTy) +errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] (mkTyVarTy openAlphaTyVar)) \end{code} We want \tr{_trace} (NB: name not in user namespace) to be wired in @@ -109,7 +129,7 @@ won't get an \tr{import} declaration in the interface file, so the importing-subsequently module needs to know it's magic. \begin{code} tRACE_ID - = pcMiscPrelId traceIdKey pRELUDE_BUILTIN SLIT("_trace") traceTy + = pcMiscPrelId traceIdKey gHC__ SLIT("trace") traceTy (noIdInfo `addInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy) where traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy) @@ -123,33 +143,33 @@ tRACE_ID \begin{code} packStringForCId - = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pRELUDE_PS SLIT("_packStringForC") + = pcMiscPrelId packCStringIdKey{-ToDo:rename-} gHC__ SLIT("packStringForC") (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo -------------------------------------------------------------------- unpackCStringId - = pcMiscPrelId unpackCStringIdKey pRELUDE_BUILTIN SLIT("unpackPS#") + = pcMiscPrelId unpackCStringIdKey gHC__ SLIT("unpackPS") (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo -- Andy says: -- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1) -- but I don't like wired-in IdInfos (WDP) unpackCString2Id -- for cases when a string has a NUL in it - = pcMiscPrelId unpackCString2IdKey pRELUDE_BUILTIN SLIT("unpackPS2#") + = pcMiscPrelId unpackCString2IdKey gHC__ SLIT("unpackPS2") (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy) noIdInfo -------------------------------------------------------------------- unpackCStringAppendId - = pcMiscPrelId unpackCStringAppendIdKey pRELUDE_BUILTIN SLIT("unpackAppendPS#") + = pcMiscPrelId unpackCStringAppendIdKey gHC__ SLIT("unpackAppendPS") (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy) ((noIdInfo {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey-}) `addInfo` mkArityInfo 2) unpackCStringFoldrId - = pcMiscPrelId unpackCStringFoldrIdKey pRELUDE_BUILTIN SLIT("unpackFoldrPS#") + = pcMiscPrelId unpackCStringFoldrIdKey gHC__ SLIT("unpackFoldrPS") (mkSigmaTy [alphaTyVar] [] (mkFunTys [addrPrimTy{-a "char *" pointer-}, mkFunTys [charTy, alphaTy] alphaTy, @@ -164,13 +184,13 @@ OK, this is Will's idea: we should have magic values for Integers 0, +1, +2, and -1 (go ahead, fire me): \begin{code} integerZeroId - = pcMiscPrelId integerZeroIdKey pRELUDE SLIT("__integer0") integerTy noIdInfo + = pcMiscPrelId integerZeroIdKey gHC__ SLIT("integer_0") integerTy noIdInfo integerPlusOneId - = pcMiscPrelId integerPlusOneIdKey pRELUDE SLIT("__integer1") integerTy noIdInfo + = pcMiscPrelId integerPlusOneIdKey gHC__ SLIT("integer_1") integerTy noIdInfo integerPlusTwoId - = pcMiscPrelId integerPlusTwoIdKey pRELUDE SLIT("__integer2") integerTy noIdInfo + = pcMiscPrelId integerPlusTwoIdKey gHC__ SLIT("integer_2") integerTy noIdInfo integerMinusOneId - = pcMiscPrelId integerMinusOneIdKey pRELUDE SLIT("__integerm1") integerTy noIdInfo + = pcMiscPrelId integerMinusOneIdKey gHC__ SLIT("integer_m1") integerTy noIdInfo \end{code} %************************************************************************ @@ -181,21 +201,21 @@ integerMinusOneId \begin{code} -------------------------------------------------------------------- --- seqId :: "_seq_", used w/ GRIP, etc., is really quite similar to +-- seqId :: "seq", used w/ GRIP, etc., is really quite similar to -- dangerousEval {- OLDER: - _seq_ = /\ a b -> \ x y -> case x of { _ -> y } + seq = /\ a b -> \ x y -> case x of { _ -> y } OLD: - _seq_ = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' } + seq = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' } NEW (95/05): - _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; } + seq = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; } -} -seqId = pcMiscPrelId seqIdKey pRELUDE_BUILTIN SLIT("_seq_") +seqId = pcMiscPrelId seqIdKey gHC__ SLIT("seq") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [alphaTy, betaTy] betaTy)) (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding seq_template)) @@ -215,7 +235,7 @@ seqId = pcMiscPrelId seqIdKey pRELUDE_BUILTIN SLIT("_seq_") (BindDefault z (Var y)))) -------------------------------------------------------------------- --- parId :: "_par_", also used w/ GRIP, etc. +-- parId :: "par", also used w/ GRIP, etc. {- OLDER: @@ -223,14 +243,14 @@ seqId = pcMiscPrelId seqIdKey pRELUDE_BUILTIN SLIT("_seq_") OLD: - _par_ = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' } + par = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' } NEW (95/05): - _par_ = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; } + par = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; } -} -parId = pcMiscPrelId parIdKey pRELUDE_BUILTIN SLIT("_par_") +parId = pcMiscPrelId parIdKey gHC__ SLIT("par") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [alphaTy, betaTy] betaTy)) (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding par_template)) @@ -249,11 +269,11 @@ parId = pcMiscPrelId parIdKey pRELUDE_BUILTIN SLIT("_par_") [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])] (BindDefault z (Var y)))) --- forkId :: "_fork_", for *required* concurrent threads +-- forkId :: "fork", for *required* concurrent threads {- _fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; } -} -forkId = pcMiscPrelId forkIdKey pRELUDE_BUILTIN SLIT("_fork_") +forkId = pcMiscPrelId forkIdKey gHC__ SLIT("fork") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [alphaTy, betaTy] betaTy)) (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding fork_template)) @@ -276,7 +296,7 @@ forkId = pcMiscPrelId forkIdKey pRELUDE_BUILTIN SLIT("_fork_") GranSim ones: \begin{code} -parLocalId = pcMiscPrelId parLocalIdKey pRELUDE_BUILTIN SLIT("_parLocal_") +parLocalId = pcMiscPrelId parLocalIdKey gHC__ SLIT("parLocal") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parLocal_template)) @@ -300,7 +320,7 @@ parLocalId = pcMiscPrelId parLocalIdKey pRELUDE_BUILTIN SLIT("_parLocal_") [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])] (BindDefault z (Var y)))) -parGlobalId = pcMiscPrelId parGlobalIdKey pRELUDE_BUILTIN SLIT("_parGlobal_") +parGlobalId = pcMiscPrelId parGlobalIdKey gHC__ SLIT("parGlobal") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parGlobal_template)) @@ -325,7 +345,7 @@ parGlobalId = pcMiscPrelId parGlobalIdKey pRELUDE_BUILTIN SLIT("_parGlobal_") (BindDefault z (Var y)))) -parAtId = pcMiscPrelId parAtIdKey pRELUDE_BUILTIN SLIT("_parAt_") +parAtId = pcMiscPrelId parAtIdKey gHC__ SLIT("parAt") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy, gammaTy] gammaTy)) @@ -351,7 +371,7 @@ parAtId = pcMiscPrelId parAtIdKey pRELUDE_BUILTIN SLIT("_parAt_") [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])] (BindDefault z (Var y)))) -parAtAbsId = pcMiscPrelId parAtAbsIdKey pRELUDE_BUILTIN SLIT("_parAtAbs_") +parAtAbsId = pcMiscPrelId parAtAbsIdKey gHC__ SLIT("parAtAbs") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtAbs_template)) @@ -376,7 +396,7 @@ parAtAbsId = pcMiscPrelId parAtAbsIdKey pRELUDE_BUILTIN SLIT("_parAtAbs_") [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])] (BindDefault z (Var y)))) -parAtRelId = pcMiscPrelId parAtRelIdKey pRELUDE_BUILTIN SLIT("_parAtRel_") +parAtRelId = pcMiscPrelId parAtRelIdKey gHC__ SLIT("parAtRel") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtRel_template)) @@ -401,7 +421,7 @@ parAtRelId = pcMiscPrelId parAtRelIdKey pRELUDE_BUILTIN SLIT("_parAtRel_") [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])] (BindDefault z (Var y)))) -parAtForNowId = pcMiscPrelId parAtForNowIdKey pRELUDE_BUILTIN SLIT("_parAtForNow_") +parAtForNowId = pcMiscPrelId parAtForNowIdKey gHC__ SLIT("parAtForNow") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy, gammaTy] gammaTy)) @@ -430,7 +450,7 @@ parAtForNowId = pcMiscPrelId parAtForNowIdKey pRELUDE_BUILTIN SLIT("_parAtForNow -- copyable and noFollow are currently merely hooks: they are translated into -- calls to the macros COPYABLE and NOFOLLOW -- HWL -copyableId = pcMiscPrelId copyableIdKey pRELUDE_BUILTIN SLIT("_copyable_") +copyableId = pcMiscPrelId copyableIdKey gHC__ SLIT("copyable") (mkSigmaTy [alphaTyVar] [] alphaTy) (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding copyable_template)) @@ -445,7 +465,7 @@ copyableId = pcMiscPrelId copyableIdKey pRELUDE_BUILTIN SLIT("_copyable_") copyable_template = mkLam [alphaTyVar] [x] ( Prim CopyableOp [TyArg alphaTy, VarArg x] ) -noFollowId = pcMiscPrelId noFollowIdKey pRELUDE_BUILTIN SLIT("_noFollow_") +noFollowId = pcMiscPrelId noFollowIdKey gHC__ SLIT("noFollow") (mkSigmaTy [alphaTyVar] [] alphaTy) (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding noFollow_template)) @@ -481,16 +501,6 @@ lex :: ReadS String %************************************************************************ %* * -\subsection[PrelVals-void]{@void@: Magic value of type @Void@} -%* * -%************************************************************************ - -\begin{code} -voidId = pcMiscPrelId voidIdKey pRELUDE_BUILTIN SLIT("_void") voidTy noIdInfo -\end{code} - -%************************************************************************ -%* * \subsection[PrelVals-runST]{@_runST@: Magic start-state-transformer function} %* * %************************************************************************ @@ -507,7 +517,7 @@ _runST a m = case m _RealWorld (S# _RealWorld realWorld#) of We unfold always, just for simplicity: \begin{code} runSTId - = pcMiscPrelId runSTIdKey pRELUDE_BUILTIN SLIT("_runST") run_ST_ty id_info + = pcMiscPrelId runSTIdKey gHC__ SLIT("runST") run_ST_ty id_info where s_tv = betaTyVar s = betaTy @@ -577,11 +587,15 @@ All calls to @f@ will share a {\em single} array! End SLPJ 95/04. nasty as-is, change it back to a literal (@Literal@). \begin{code} realWorldPrimId - = pcMiscPrelId realWorldPrimIdKey pRELUDE_BUILTIN SLIT("realWorld#") + = pcMiscPrelId realWorldPrimIdKey gHC_BUILTINS SLIT("realWorld#") realWorldStatePrimTy noIdInfo \end{code} +\begin{code} +voidId = pcMiscPrelId voidIdKey gHC_BUILTINS SLIT("void") voidTy noIdInfo +\end{code} + %************************************************************************ %* * \subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''} @@ -590,7 +604,7 @@ realWorldPrimId \begin{code} buildId - = pcMiscPrelId buildIdKey pRELUDE_BUILTIN SLIT("_build") buildTy + = pcMiscPrelId buildIdKey gHC__ SLIT("build") buildTy ((((noIdInfo {-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-}) `addInfo` mkStrictnessInfo [WwStrict] Nothing) @@ -635,7 +649,7 @@ mkBuild ty tv c n g expr \begin{code} augmentId - = pcMiscPrelId augmentIdKey pRELUDE_BUILTIN SLIT("_augment") augmentTy + = pcMiscPrelId augmentIdKey gHC__ SLIT("augment") augmentTy (((noIdInfo {-LATER:`addInfo_UF` mkMagicUnfolding augmentIdKey-}) `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing) @@ -652,7 +666,7 @@ augmentId \end{code} \begin{code} -foldrId = pcMiscPrelId foldrIdKey pRELUDE_FB{-not "List"-} SLIT("foldr") +foldrId = pcMiscPrelId foldrIdKey pRELUDE SLIT("foldr") foldrTy idInfo where foldrTy = @@ -666,7 +680,7 @@ foldrId = pcMiscPrelId foldrIdKey pRELUDE_FB{-not "List"-} SLIT("foldr") `addInfo` mkUpdateInfo [2,2,1]) `addInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy) -foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl") +foldlId = pcMiscPrelId foldlIdKey pRELUDE SLIT("foldl") foldlTy idInfo where foldlTy = @@ -693,7 +707,7 @@ foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl") -- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside -- the prelude. -- - +{- OLD: doesn't apply with 1.3 appendId = pcMiscPrelId appendIdKey pRELUDE_LIST SLIT("++") appendTy idInfo where @@ -704,6 +718,7 @@ appendId `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing) `addInfo` mkArityInfo 2) `addInfo` mkUpdateInfo [1,2]) +-} \end{code} %************************************************************************ diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 6527a7e..6556a87 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -1638,12 +1638,12 @@ primOpNeedsWrapper other_op = False \begin{code} primOp_str op = case (primOpInfo op) of - Dyadic str _ -> str - Monadic str _ -> str - Compare str _ -> str - Coercing str _ _ -> str + Dyadic str _ -> str + Monadic str _ -> str + Compare str _ -> str + Coercing str _ _ -> str PrimResult str _ _ _ _ _ -> str - AlgResult str _ _ _ _ -> str + AlgResult str _ _ _ _ -> str \end{code} @primOpType@ duplicates some work of @primOpId@, but since we diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index 876048f..08d49a8 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -14,10 +14,11 @@ module TysPrim where IMP_Ubiq(){-uitous-} import Kind ( mkUnboxedTypeKind, mkBoxedTypeKind, mkTypeKind, mkArrowKind ) -import Name ( mkBuiltinName ) -import PrelMods ( pRELUDE_BUILTIN ) +import Name ( mkPrimitiveName ) +import PrelMods ( gHC_BUILTINS ) import PrimRep ( PrimRep(..) ) -- getPrimRepInfo uses PrimRep repn import TyCon ( mkPrimTyCon, mkDataTyCon, NewOrData(..) ) +import Type ( mkTyConTy ) import TyVar ( GenTyVar(..), alphaTyVars ) import Type ( applyTyCon, mkTyVarTys ) import Usage ( usageOmega ) @@ -43,7 +44,7 @@ pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING -> Int -> PrimRep -> TyCon pcPrimTyCon key str arity primrep = mkPrimTyCon name (mk_kind arity) primrep where - name = mkBuiltinName key pRELUDE_BUILTIN str + name = mkPrimitiveName key (OrigName gHC_BUILTINS str) mk_kind 0 = mkUnboxedTypeKind mk_kind n = mkTypeKind `mkArrowKind` mk_kind (n-1) @@ -121,7 +122,7 @@ realWorldTyCon [{-no derivings-}] DataType where - name = mkBuiltinName realWorldTyConKey pRELUDE_BUILTIN SLIT("_RealWorld") + name = mkPrimitiveName realWorldTyConKey (OrigName gHC_BUILTINS SLIT("RealWorld")) realWorldStatePrimTy = mkStatePrimTy realWorldTy \end{code} @@ -129,6 +130,28 @@ realWorldStatePrimTy = mkStatePrimTy realWorldTy Note: the ``state-pairing'' types are not truly primitive, so they are defined in \tr{TysWiredIn.lhs}, not here. +\begin{code} +-- The Void type is represented as a data type with no constructors +-- It's a built in type (i.e. there's no way to define it in Haskell; +-- the nearest would be +-- +-- data Void = -- No constructors! +-- +-- ) It's boxed; there is only one value of this +-- type, namely "void", whose semantics is just bottom. +voidTy = mkTyConTy voidTyCon + +voidTyCon + = mkDataTyCon name mkBoxedTypeKind + [{-no tyvars-}] + [{-no context-}] + [{-no data cons!-}] + [{-no derivings-}] + DataType + where + name = mkPrimitiveName voidTyConKey (OrigName gHC_BUILTINS SLIT("Void")) +\end{code} + %************************************************************************ %* * \subsection[TysPrim-arrays]{The primitive array types} diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 04b3e49..27a16da 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -71,11 +71,9 @@ module TysWiredIn ( stringTy, trueDataCon, unitTy, - voidTy, voidTyCon, wordDataCon, wordTy, wordTyCon - ) where --ToDo:rm @@ -95,7 +93,7 @@ import TysPrim -- others: import SpecEnv ( SpecEnv(..) ) import Kind ( mkBoxedTypeKind, mkArrowKind ) -import Name ( mkBuiltinName ) +import Name ( mkWiredInName ) import SrcLoc ( mkBuiltinSrcLoc ) import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon, NewOrData(..), TyCon @@ -124,7 +122,7 @@ pcDataTyCon = pc_tycon DataType pcNewTyCon = pc_tycon NewType pc_tycon new_or_data key mod str tyvars cons - = mkDataTyCon (mkBuiltinName key mod str) tycon_kind + = mkDataTyCon (mkWiredInName key (OrigName mod str)) tycon_kind tyvars [{-no context-}] cons [{-no derivings-}] new_or_data where @@ -133,7 +131,7 @@ pc_tycon new_or_data key mod str tyvars cons pcDataCon :: Unique{-DataConKey-} -> Module -> FAST_STRING -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id pcDataCon key mod str tyvars context arg_tys tycon specenv - = mkDataCon (mkBuiltinName key mod str) + = mkDataCon (mkWiredInName key (OrigName mod str)) [ NotMarkedStrict | a <- arg_tys ] [ {- no labelled fields -} ] tyvars context arg_tys tycon @@ -153,88 +151,76 @@ pcGenerateDataSpecs ty %************************************************************************ \begin{code} --- The Void type is represented as a data type with no constructors --- It's a built in type (i.e. there's no way to define it in Haskell --- the nearest would be --- --- data Void = -- No constructors! --- --- It's boxed; there is only one value of this --- type, namely "void", whose semantics is just bottom. -voidTy = mkTyConTy voidTyCon - -voidTyCon = pcDataTyCon voidTyConKey pRELUDE_BUILTIN SLIT("Void") [] [] -\end{code} - -\begin{code} charTy = mkTyConTy charTyCon -charTyCon = pcDataTyCon charTyConKey pRELUDE_BUILTIN SLIT("Char") [] [charDataCon] -charDataCon = pcDataCon charDataConKey pRELUDE_BUILTIN SLIT("C#") [] [] [charPrimTy] charTyCon nullSpecEnv +charTyCon = pcDataTyCon charTyConKey pRELUDE SLIT("Char") [] [charDataCon] +charDataCon = pcDataCon charDataConKey pRELUDE SLIT("C#") [] [] [charPrimTy] charTyCon nullSpecEnv + +stringTy = mkListTy charTy -- convenience only \end{code} \begin{code} intTy = mkTyConTy intTyCon -intTyCon = pcDataTyCon intTyConKey pRELUDE_BUILTIN SLIT("Int") [] [intDataCon] -intDataCon = pcDataCon intDataConKey pRELUDE_BUILTIN SLIT("I#") [] [] [intPrimTy] intTyCon nullSpecEnv +intTyCon = pcDataTyCon intTyConKey pRELUDE SLIT("Int") [] [intDataCon] +intDataCon = pcDataCon intDataConKey pRELUDE SLIT("I#") [] [] [intPrimTy] intTyCon nullSpecEnv \end{code} \begin{code} wordTy = mkTyConTy wordTyCon -wordTyCon = pcDataTyCon wordTyConKey pRELUDE_BUILTIN SLIT("_Word") [] [wordDataCon] -wordDataCon = pcDataCon wordDataConKey pRELUDE_BUILTIN SLIT("W#") [] [] [wordPrimTy] wordTyCon nullSpecEnv +wordTyCon = pcDataTyCon wordTyConKey gHC__ SLIT("Word") [] [wordDataCon] +wordDataCon = pcDataCon wordDataConKey gHC__ SLIT("W#") [] [] [wordPrimTy] wordTyCon nullSpecEnv \end{code} \begin{code} addrTy = mkTyConTy addrTyCon -addrTyCon = pcDataTyCon addrTyConKey pRELUDE_BUILTIN SLIT("_Addr") [] [addrDataCon] -addrDataCon = pcDataCon addrDataConKey pRELUDE_BUILTIN SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv +addrTyCon = pcDataTyCon addrTyConKey gHC__ SLIT("Addr") [] [addrDataCon] +addrDataCon = pcDataCon addrDataConKey gHC__ SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv \end{code} \begin{code} floatTy = mkTyConTy floatTyCon -floatTyCon = pcDataTyCon floatTyConKey pRELUDE_BUILTIN SLIT("Float") [] [floatDataCon] -floatDataCon = pcDataCon floatDataConKey pRELUDE_BUILTIN SLIT("F#") [] [] [floatPrimTy] floatTyCon nullSpecEnv +floatTyCon = pcDataTyCon floatTyConKey pRELUDE SLIT("Float") [] [floatDataCon] +floatDataCon = pcDataCon floatDataConKey pRELUDE SLIT("F#") [] [] [floatPrimTy] floatTyCon nullSpecEnv \end{code} \begin{code} doubleTy = mkTyConTy doubleTyCon -doubleTyCon = pcDataTyCon doubleTyConKey pRELUDE_BUILTIN SLIT("Double") [] [doubleDataCon] -doubleDataCon = pcDataCon doubleDataConKey pRELUDE_BUILTIN SLIT("D#") [] [] [doublePrimTy] doubleTyCon nullSpecEnv +doubleTyCon = pcDataTyCon doubleTyConKey pRELUDE SLIT("Double") [] [doubleDataCon] +doubleDataCon = pcDataCon doubleDataConKey pRELUDE SLIT("D#") [] [] [doublePrimTy] doubleTyCon nullSpecEnv \end{code} \begin{code} mkStateTy ty = applyTyCon stateTyCon [ty] realWorldStateTy = mkStateTy realWorldTy -- a common use -stateTyCon = pcDataTyCon stateTyConKey pRELUDE_BUILTIN SLIT("_State") alpha_tyvar [stateDataCon] +stateTyCon = pcDataTyCon stateTyConKey gHC__ SLIT("State") alpha_tyvar [stateDataCon] stateDataCon - = pcDataCon stateDataConKey pRELUDE_BUILTIN SLIT("S#") + = pcDataCon stateDataConKey gHC__ SLIT("S#") alpha_tyvar [] [mkStatePrimTy alphaTy] stateTyCon nullSpecEnv \end{code} \begin{code} stablePtrTyCon - = pcDataTyCon stablePtrTyConKey gLASGOW_MISC SLIT("_StablePtr") + = pcDataTyCon stablePtrTyConKey gHC__ SLIT("StablePtr") alpha_tyvar [stablePtrDataCon] where stablePtrDataCon - = pcDataCon stablePtrDataConKey gLASGOW_MISC SLIT("_StablePtr") + = pcDataCon stablePtrDataConKey gHC__ SLIT("StablePtr") alpha_tyvar [] [mkStablePtrPrimTy alphaTy] stablePtrTyCon nullSpecEnv \end{code} \begin{code} foreignObjTyCon - = pcDataTyCon foreignObjTyConKey gLASGOW_MISC SLIT("_ForeignObj") + = pcDataTyCon foreignObjTyConKey gHC__ SLIT("ForeignObj") [] [foreignObjDataCon] where foreignObjDataCon - = pcDataCon foreignObjDataConKey gLASGOW_MISC SLIT("_ForeignObj") + = pcDataCon foreignObjDataConKey gHC__ SLIT("ForeignObj") [] [] [foreignObjPrimTy] foreignObjTyCon nullSpecEnv \end{code} @@ -249,27 +235,27 @@ foreignObjTyCon integerTy :: GenType t u integerTy = mkTyConTy integerTyCon -integerTyCon = pcDataTyCon integerTyConKey pRELUDE_BUILTIN SLIT("Integer") [] [integerDataCon] +integerTyCon = pcDataTyCon integerTyConKey pRELUDE SLIT("Integer") [] [integerDataCon] -integerDataCon = pcDataCon integerDataConKey pRELUDE_BUILTIN SLIT("J#") +integerDataCon = pcDataCon integerDataConKey pRELUDE SLIT("J#") [] [] [intPrimTy, intPrimTy, byteArrayPrimTy] integerTyCon nullSpecEnv \end{code} And the other pairing types: \begin{code} return2GMPsTyCon = pcDataTyCon return2GMPsTyConKey - pRELUDE_BUILTIN SLIT("_Return2GMPs") [] [return2GMPsDataCon] + gHC__ SLIT("Return2GMPs") [] [return2GMPsDataCon] return2GMPsDataCon - = pcDataCon return2GMPsDataConKey pRELUDE_BUILTIN SLIT("_Return2GMPs") [] [] + = pcDataCon return2GMPsDataConKey gHC__ SLIT("Return2GMPs") [] [] [intPrimTy, intPrimTy, byteArrayPrimTy, intPrimTy, intPrimTy, byteArrayPrimTy] return2GMPsTyCon nullSpecEnv returnIntAndGMPTyCon = pcDataTyCon returnIntAndGMPTyConKey - pRELUDE_BUILTIN SLIT("_ReturnIntAndGMP") [] [returnIntAndGMPDataCon] + gHC__ SLIT("ReturnIntAndGMP") [] [returnIntAndGMPDataCon] returnIntAndGMPDataCon - = pcDataCon returnIntAndGMPDataConKey pRELUDE_BUILTIN SLIT("_ReturnIntAndGMP") [] [] + = pcDataCon returnIntAndGMPDataConKey gHC__ SLIT("ReturnIntAndGMP") [] [] [intPrimTy, intPrimTy, intPrimTy, byteArrayPrimTy] returnIntAndGMPTyCon nullSpecEnv \end{code} @@ -288,118 +274,118 @@ We fish one of these \tr{StateAnd#} things with \begin{code} stateAndPtrPrimTyCon - = pcDataTyCon stateAndPtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndPtr#") + = pcDataTyCon stateAndPtrPrimTyConKey gHC__ SLIT("StateAndPtr#") alpha_beta_tyvars [stateAndPtrPrimDataCon] stateAndPtrPrimDataCon - = pcDataCon stateAndPtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndPtr#") + = pcDataCon stateAndPtrPrimDataConKey gHC__ SLIT("StateAndPtr#") alpha_beta_tyvars [] [mkStatePrimTy alphaTy, betaTy] stateAndPtrPrimTyCon nullSpecEnv stateAndCharPrimTyCon - = pcDataTyCon stateAndCharPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndChar#") + = pcDataTyCon stateAndCharPrimTyConKey gHC__ SLIT("StateAndChar#") alpha_tyvar [stateAndCharPrimDataCon] stateAndCharPrimDataCon - = pcDataCon stateAndCharPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndChar#") + = pcDataCon stateAndCharPrimDataConKey gHC__ SLIT("StateAndChar#") alpha_tyvar [] [mkStatePrimTy alphaTy, charPrimTy] stateAndCharPrimTyCon nullSpecEnv stateAndIntPrimTyCon - = pcDataTyCon stateAndIntPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndInt#") + = pcDataTyCon stateAndIntPrimTyConKey gHC__ SLIT("StateAndInt#") alpha_tyvar [stateAndIntPrimDataCon] stateAndIntPrimDataCon - = pcDataCon stateAndIntPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndInt#") + = pcDataCon stateAndIntPrimDataConKey gHC__ SLIT("StateAndInt#") alpha_tyvar [] [mkStatePrimTy alphaTy, intPrimTy] stateAndIntPrimTyCon nullSpecEnv stateAndWordPrimTyCon - = pcDataTyCon stateAndWordPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndWord#") + = pcDataTyCon stateAndWordPrimTyConKey gHC__ SLIT("StateAndWord#") alpha_tyvar [stateAndWordPrimDataCon] stateAndWordPrimDataCon - = pcDataCon stateAndWordPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndWord#") + = pcDataCon stateAndWordPrimDataConKey gHC__ SLIT("StateAndWord#") alpha_tyvar [] [mkStatePrimTy alphaTy, wordPrimTy] stateAndWordPrimTyCon nullSpecEnv stateAndAddrPrimTyCon - = pcDataTyCon stateAndAddrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndAddr#") + = pcDataTyCon stateAndAddrPrimTyConKey gHC__ SLIT("StateAndAddr#") alpha_tyvar [stateAndAddrPrimDataCon] stateAndAddrPrimDataCon - = pcDataCon stateAndAddrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndAddr#") + = pcDataCon stateAndAddrPrimDataConKey gHC__ SLIT("StateAndAddr#") alpha_tyvar [] [mkStatePrimTy alphaTy, addrPrimTy] stateAndAddrPrimTyCon nullSpecEnv stateAndStablePtrPrimTyCon - = pcDataTyCon stateAndStablePtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndStablePtr#") + = pcDataTyCon stateAndStablePtrPrimTyConKey gHC__ SLIT("StateAndStablePtr#") alpha_beta_tyvars [stateAndStablePtrPrimDataCon] stateAndStablePtrPrimDataCon - = pcDataCon stateAndStablePtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndStablePtr#") + = pcDataCon stateAndStablePtrPrimDataConKey gHC__ SLIT("StateAndStablePtr#") alpha_beta_tyvars [] [mkStatePrimTy alphaTy, applyTyCon stablePtrPrimTyCon [betaTy]] stateAndStablePtrPrimTyCon nullSpecEnv stateAndForeignObjPrimTyCon - = pcDataTyCon stateAndForeignObjPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndForeignObj#") + = pcDataTyCon stateAndForeignObjPrimTyConKey gHC__ SLIT("StateAndForeignObj#") alpha_tyvar [stateAndForeignObjPrimDataCon] stateAndForeignObjPrimDataCon - = pcDataCon stateAndForeignObjPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndForeignObj#") + = pcDataCon stateAndForeignObjPrimDataConKey gHC__ SLIT("StateAndForeignObj#") alpha_tyvar [] [mkStatePrimTy alphaTy, applyTyCon foreignObjPrimTyCon []] stateAndForeignObjPrimTyCon nullSpecEnv stateAndFloatPrimTyCon - = pcDataTyCon stateAndFloatPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndFloat#") + = pcDataTyCon stateAndFloatPrimTyConKey gHC__ SLIT("StateAndFloat#") alpha_tyvar [stateAndFloatPrimDataCon] stateAndFloatPrimDataCon - = pcDataCon stateAndFloatPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndFloat#") + = pcDataCon stateAndFloatPrimDataConKey gHC__ SLIT("StateAndFloat#") alpha_tyvar [] [mkStatePrimTy alphaTy, floatPrimTy] stateAndFloatPrimTyCon nullSpecEnv stateAndDoublePrimTyCon - = pcDataTyCon stateAndDoublePrimTyConKey pRELUDE_BUILTIN SLIT("StateAndDouble#") + = pcDataTyCon stateAndDoublePrimTyConKey gHC__ SLIT("StateAndDouble#") alpha_tyvar [stateAndDoublePrimDataCon] stateAndDoublePrimDataCon - = pcDataCon stateAndDoublePrimDataConKey pRELUDE_BUILTIN SLIT("StateAndDouble#") + = pcDataCon stateAndDoublePrimDataConKey gHC__ SLIT("StateAndDouble#") alpha_tyvar [] [mkStatePrimTy alphaTy, doublePrimTy] stateAndDoublePrimTyCon nullSpecEnv \end{code} \begin{code} stateAndArrayPrimTyCon - = pcDataTyCon stateAndArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndArray#") + = pcDataTyCon stateAndArrayPrimTyConKey gHC__ SLIT("StateAndArray#") alpha_beta_tyvars [stateAndArrayPrimDataCon] stateAndArrayPrimDataCon - = pcDataCon stateAndArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndArray#") + = pcDataCon stateAndArrayPrimDataConKey gHC__ SLIT("StateAndArray#") alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkArrayPrimTy betaTy] stateAndArrayPrimTyCon nullSpecEnv stateAndMutableArrayPrimTyCon - = pcDataTyCon stateAndMutableArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMutableArray#") + = pcDataTyCon stateAndMutableArrayPrimTyConKey gHC__ SLIT("StateAndMutableArray#") alpha_beta_tyvars [stateAndMutableArrayPrimDataCon] stateAndMutableArrayPrimDataCon - = pcDataCon stateAndMutableArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMutableArray#") + = pcDataCon stateAndMutableArrayPrimDataConKey gHC__ SLIT("StateAndMutableArray#") alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkMutableArrayPrimTy alphaTy betaTy] stateAndMutableArrayPrimTyCon nullSpecEnv stateAndByteArrayPrimTyCon - = pcDataTyCon stateAndByteArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndByteArray#") + = pcDataTyCon stateAndByteArrayPrimTyConKey gHC__ SLIT("StateAndByteArray#") alpha_tyvar [stateAndByteArrayPrimDataCon] stateAndByteArrayPrimDataCon - = pcDataCon stateAndByteArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndByteArray#") + = pcDataCon stateAndByteArrayPrimDataConKey gHC__ SLIT("StateAndByteArray#") alpha_tyvar [] [mkStatePrimTy alphaTy, byteArrayPrimTy] stateAndByteArrayPrimTyCon nullSpecEnv stateAndMutableByteArrayPrimTyCon - = pcDataTyCon stateAndMutableByteArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMutableByteArray#") + = pcDataTyCon stateAndMutableByteArrayPrimTyConKey gHC__ SLIT("StateAndMutableByteArray#") alpha_tyvar [stateAndMutableByteArrayPrimDataCon] stateAndMutableByteArrayPrimDataCon - = pcDataCon stateAndMutableByteArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMutableByteArray#") + = pcDataCon stateAndMutableByteArrayPrimDataConKey gHC__ SLIT("StateAndMutableByteArray#") alpha_tyvar [] [mkStatePrimTy alphaTy, applyTyCon mutableByteArrayPrimTyCon alpha_ty] stateAndMutableByteArrayPrimTyCon nullSpecEnv stateAndSynchVarPrimTyCon - = pcDataTyCon stateAndSynchVarPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndSynchVar#") + = pcDataTyCon stateAndSynchVarPrimTyConKey gHC__ SLIT("StateAndSynchVar#") alpha_beta_tyvars [stateAndSynchVarPrimDataCon] stateAndSynchVarPrimDataCon - = pcDataCon stateAndSynchVarPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndSynchVar#") + = pcDataCon stateAndSynchVarPrimDataConKey gHC__ SLIT("StateAndSynchVar#") alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkSynchVarPrimTy alphaTy betaTy] stateAndSynchVarPrimTyCon nullSpecEnv \end{code} @@ -453,11 +439,11 @@ This is really just an ordinary synonym, except it is ABSTRACT. \begin{code} mkStateTransformerTy s a = applyTyCon stTyCon [s, a] -stTyCon = pcNewTyCon stTyConKey pRELUDE SLIT("_ST") alpha_beta_tyvars [stDataCon] +stTyCon = pcNewTyCon stTyConKey gHC__ SLIT("ST") alpha_beta_tyvars [stDataCon] where ty = mkFunTys [mkStateTy alphaTy] (mkTupleTy 2 [betaTy, mkStateTy alphaTy]) - stDataCon = pcDataCon stDataConKey pRELUDE SLIT("_ST") + stDataCon = pcDataCon stDataConKey gHC__ SLIT("ST") alpha_beta_tyvars [] [ty] stTyCon nullSpecEnv \end{code} @@ -472,11 +458,11 @@ stTyCon = pcNewTyCon stTyConKey pRELUDE SLIT("_ST") alpha_beta_tyvars [stDataCon \begin{code} mkPrimIoTy a = applyTyCon primIoTyCon [a] -primIoTyCon = pcNewTyCon primIoTyConKey pRELUDE SLIT("_PrimIO") alpha_tyvar [primIoDataCon] +primIoTyCon = pcNewTyCon primIoTyConKey gHC__ SLIT("PrimIO") alpha_tyvar [primIoDataCon] where ty = mkFunTys [mkStateTy realWorldTy] (mkTupleTy 2 [alphaTy, mkStateTy realWorldTy]) - primIoDataCon = pcDataCon primIoDataConKey pRELUDE SLIT("_PrimIO") + primIoDataCon = pcDataCon primIoDataConKey gHC__ SLIT("PrimIO") alpha_tyvar [] [ty] primIoTyCon nullSpecEnv \end{code} @@ -558,12 +544,12 @@ mkListTy ty = applyTyCon listTyCon [ty] alphaListTy = mkSigmaTy alpha_tyvar [] (applyTyCon listTyCon alpha_ty) -listTyCon = pcDataTyCon listTyConKey pRELUDE_BUILTIN SLIT("[]") +listTyCon = pcDataTyCon listTyConKey pRELUDE SLIT("[]") alpha_tyvar [nilDataCon, consDataCon] -nilDataCon = pcDataCon nilDataConKey pRELUDE_BUILTIN SLIT("[]") alpha_tyvar [] [] listTyCon +nilDataCon = pcDataCon nilDataConKey pRELUDE SLIT("[]") alpha_tyvar [] [] listTyCon (pcGenerateDataSpecs alphaListTy) -consDataCon = pcDataCon consDataConKey pRELUDE_BUILTIN SLIT(":") +consDataCon = pcDataCon consDataConKey pRELUDE SLIT(":") alpha_tyvar [] [alphaTy, applyTyCon listTyCon alpha_ty] listTyCon (pcGenerateDataSpecs alphaListTy) -- Interesting: polymorphic recursion would help here. @@ -654,24 +640,13 @@ isLiftTy ty alphaLiftTy = mkSigmaTy alpha_tyvar [] (applyTyCon liftTyCon alpha_ty) liftTyCon - = pcDataTyCon liftTyConKey pRELUDE_BUILTIN SLIT("_Lift") alpha_tyvar [liftDataCon] + = pcDataTyCon liftTyConKey gHC__ SLIT("Lift") alpha_tyvar [liftDataCon] liftDataCon - = pcDataCon liftDataConKey pRELUDE_BUILTIN SLIT("_Lift") + = pcDataCon liftDataConKey gHC__ SLIT("Lift") alpha_tyvar [] alpha_ty liftTyCon ((pcGenerateDataSpecs alphaLiftTy) `addOneToSpecEnv` (mkSpecInfo [Just realWorldStatePrimTy] 0 bottom)) where bottom = panic "liftDataCon:State# _RealWorld" \end{code} - - -%************************************************************************ -%* * -\subsection[TysWiredIn-for-convenience]{Types wired in for convenience (e.g., @String@)} -%* * -%************************************************************************ - -\begin{code} -stringTy = mkListTy charTy -\end{code} diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs index cd0ae20..cb5aa2b 100644 --- a/ghc/compiler/reader/RdrHsSyn.lhs +++ b/ghc/compiler/reader/RdrHsSyn.lhs @@ -80,7 +80,7 @@ type RdrNameMonoBinds = MonoBinds Fake Fake RdrName RdrNamePat type RdrNameMonoType = MonoType RdrName type RdrNamePat = InPat RdrName type RdrNamePolyType = PolyType RdrName -type RdrNameQual = Qual Fake Fake RdrName RdrNamePat +type RdrNameQual = Qualifier Fake Fake RdrName RdrNamePat type RdrNameSig = Sig RdrName type RdrNameSpecInstSig = SpecInstSig RdrName type RdrNameStmt = Stmt Fake Fake RdrName RdrNamePat diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index 88ddda0..9353e87 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -17,12 +17,11 @@ import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas ) import RdrHsSyn import PrefixToHs -import CmdLineOpts ( opt_CompilingPrelude ) import ErrUtils ( addErrLoc, ghcExit ) import FiniteMap ( elemFM, FiniteMap ) -import Name ( RdrName(..), isRdrLexConOrSpecial ) +import Name ( RdrName(..), isRdrLexConOrSpecial, preludeQual ) import PprStyle ( PprStyle(..) ) -import PrelMods ( fromPrelude, pRELUDE ) +import PrelMods ( pRELUDE ) import Pretty import SrcLoc ( SrcLoc ) import Util ( nOfThem, pprError, panic ) @@ -62,12 +61,9 @@ wlkQid :: U_qid -> UgnM RdrName wlkQid (U_noqual name) = returnUgn (Unqual name) wlkQid (U_aqual mod name) - | fromPrelude mod - = returnUgn (Unqual name) - | otherwise = returnUgn (Qual mod name) wlkQid (U_gid n name) - = returnUgn (Unqual name) + = returnUgn (preludeQual name) cvFlag :: U_long -> Bool cvFlag 0 = False @@ -307,10 +303,7 @@ wlkExpr expr wlkExpr nexp `thenUgn` \ expr -> -- this is a hack let - neg = SLIT("negate") - rdr = if opt_CompilingPrelude - then Unqual neg - else Qual pRELUDE neg + rdr = preludeQual SLIT("negate") in returnUgn (NegApp expr (HsVar rdr)) @@ -570,12 +563,9 @@ wlkBinding binding binds = cvMonoBinds sf bs uprags = concat (map cvInstDeclSig ss) ctxt_inst_ty = HsPreForAllTy ctxt inst_ty - maybe_mod = if opt_CompilingPrelude - then Nothing - else Just modname in returnUgn (RdrInstDecl - (InstDecl clas ctxt_inst_ty binds True maybe_mod uprags noInstancePragmas src_loc)) + (InstDecl clas ctxt_inst_ty binds True modname uprags noInstancePragmas src_loc)) -- "default" declaration U_dbind dbindts srcline -> diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 86c4675..bc4137d 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -13,7 +13,7 @@ import HsPragmas ( noGenPragmas ) import Bag ( emptyBag, unitBag, snocBag ) import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM ) -import Name ( ExportFlag(..), mkTupNameStr, +import Name ( ExportFlag(..), mkTupNameStr, preludeQual, RdrName(..){-instance Outputable:ToDo:rm-} ) import Outputable -- ToDo:rm @@ -43,9 +43,9 @@ parseIface = parseIToks . lexIface DECLARATIONS_PART { ITdeclarations } PRAGMAS_PART { ITpragmas } BANG { ITbang } - BQUOTE { ITbquote } CBRACK { ITcbrack } CCURLY { ITccurly } + DCCURLY { ITdccurly } CLASS { ITclass } COMMA { ITcomma } CPAREN { ITcparen } @@ -61,6 +61,7 @@ parseIface = parseIToks . lexIface NEWTYPE { ITnewtype } OBRACK { ITobrack } OCURLY { ITocurly } + DOCURLY { ITdocurly } OPAREN { IToparen } RARROW { ITrarrow } SEMI { ITsemi } @@ -123,7 +124,7 @@ name_version_pairs : name_version_pair { $1 `snocBag` $2 } name_version_pair :: { (FAST_STRING, Int) } -name_version_pair : iname INTEGER +name_version_pair : name INTEGER { ($1, fromInteger $2) -------------------------------------------------------------------------- } @@ -132,12 +133,12 @@ exports_part :: { ExportsMap } exports_part : EXPORTS_PART export_items { bagToFM $2 } | { emptyFM } -export_items :: { Bag (FAST_STRING, (RdrName, ExportFlag)) } +export_items :: { Bag (FAST_STRING, (OrigName, ExportFlag)) } export_items : export_item { unitBag $1 } | export_items export_item { $1 `snocBag` $2 } -export_item :: { (FAST_STRING, (RdrName, ExportFlag)) } -export_item : qiname maybe_dotdot { (de_qual $1, ($1, $2)) } +export_item :: { (FAST_STRING, (OrigName, ExportFlag)) } +export_item : CONID name maybe_dotdot { ($2, (OrigName $1 $2, $3)) } maybe_dotdot :: { ExportFlag } maybe_dotdot : DOTDOT { ExportAll } @@ -164,9 +165,9 @@ fixes : fix { case $1 of (k,v) -> unitFM k v } | fixes fix { case $2 of (k,v) -> addToFM $1 k v } fix :: { (FAST_STRING, RdrNameFixityDecl) } -fix : INFIXL INTEGER qop SEMI { (de_qual $3, InfixL $3 (fromInteger $2)) } - | INFIXR INTEGER qop SEMI { (de_qual $3, InfixR $3 (fromInteger $2)) } - | INFIX INTEGER qop SEMI { (de_qual $3, InfixN $3 (fromInteger $2)) +fix : INFIXL INTEGER qname SEMI { (de_qual $3, InfixL $3 (fromInteger $2)) } + | INFIXR INTEGER qname SEMI { (de_qual $3, InfixR $3 (fromInteger $2)) } + | INFIX INTEGER qname SEMI { (de_qual $3, InfixN $3 (fromInteger $2)) -------------------------------------------------------------------------- } @@ -217,8 +218,7 @@ decl :: { (FAST_STRING, RdrNameSig) } decl : var DCOLON ctype SEMI { (de_qual $1, Sig $1 $3 noGenPragmas mkIfaceSrcLoc) } context :: { RdrNameContext } -context : OPAREN context_list CPAREN { reverse $2 } - | class { [$1] } +context : DOCURLY context_list DCCURLY { reverse $2 } context_list :: { RdrNameContext{-reversed-} } context_list : class { [$1] } @@ -228,8 +228,8 @@ class :: { (RdrName, RdrName) } class : gtycon VARID { ($1, Unqual $2) } ctype :: { RdrNamePolyType } -ctype : type DARROW type { HsPreForAllTy (type2context $1) $3 } - | type { HsPreForAllTy [] $1 } +ctype : context DARROW type { HsPreForAllTy $1 $3 } + | type { HsPreForAllTy [] $1 } type :: { RdrNameMonoType } type : btype { $1 } @@ -248,9 +248,9 @@ btype : gtyconapp { case $1 of (tc, tys) -> MonoTyApp tc tys } case ty1 of { MonoTyVar tv -> MonoTyApp tv tys; MonoTyApp tc ts -> MonoTyApp tc (ts++tys); - MonoFunTy t1 t2 -> MonoTyApp (Unqual SLIT("->")) (t1:t2:tys); - MonoListTy ty -> MonoTyApp (Unqual SLIT("[]")) (ty:tys); - MonoTupleTy ts -> MonoTyApp (Unqual (mkTupNameStr (length ts))) + MonoFunTy t1 t2 -> MonoTyApp (preludeQual SLIT("->")) (t1:t2:tys); + MonoListTy ty -> MonoTyApp (preludeQual SLIT("[]")) (ty:tys); + MonoTupleTy ts -> MonoTyApp (preludeQual (mkTupNameStr (length ts))) (ts++tys); _ -> pprPanic "test:" (ppr PprDebug $1) }} @@ -280,11 +280,10 @@ ntycon : VARID { MonoTyVar (Unqual $1) } gtycon :: { RdrName } gtycon : QCONID { $1 } - | CONID { Unqual $1 } - | OPAREN RARROW CPAREN { Unqual SLIT("->") } - | OBRACK CBRACK { Unqual SLIT("[]") } - | OPAREN CPAREN { Unqual SLIT("()") } - | OPAREN commas CPAREN { Unqual (mkTupNameStr $2) } + | OPAREN RARROW CPAREN { preludeQual SLIT("->") } + | OBRACK CBRACK { preludeQual SLIT("[]") } + | OPAREN CPAREN { preludeQual SLIT("()") } + | OPAREN commas CPAREN { preludeQual (mkTupNameStr $2) } commas :: { Int } commas : COMMA { 2{-1 comma => arity 2-} } @@ -305,10 +304,8 @@ constrs : constr { [$1] } constr :: { (RdrName, RdrNameConDecl) } constr : btyconapp { case $1 of (con, tys) -> (con, ConDecl con tys mkIfaceSrcLoc) } - | OPAREN QCONSYM CPAREN { ($2, ConDecl $2 [] mkIfaceSrcLoc) } - | OPAREN QCONSYM CPAREN batypes { ($2, ConDecl $2 $4 mkIfaceSrcLoc) } - | OPAREN CONSYM CPAREN { (Unqual $2, ConDecl (Unqual $2) [] mkIfaceSrcLoc) } - | OPAREN CONSYM CPAREN batypes { (Unqual $2, ConDecl (Unqual $2) $4 mkIfaceSrcLoc) } + | QCONSYM { ($1, ConDecl $1 [] mkIfaceSrcLoc) } + | QCONSYM batypes { ($1, ConDecl $1 $2 mkIfaceSrcLoc) } | gtycon OCURLY fields CCURLY { ($1, RecConDecl $1 $3 mkIfaceSrcLoc) } @@ -340,37 +337,21 @@ constr1 :: { (RdrName, RdrNameMonoType) } constr1 : gtycon atype { ($1, $2) } var :: { RdrName } -var : QVARID { $1 } - | OPAREN QVARSYM CPAREN { $2 } - | VARID { Unqual $1 } - | OPAREN VARSYM CPAREN { Unqual $2 } - -op :: { FAST_STRING } -op : BQUOTE VARID BQUOTE { $2 } - | BQUOTE CONID BQUOTE { $2 } - | VARSYM { $1 } - | CONSYM { $1 } - -qop :: { RdrName } -qop : BQUOTE QVARID BQUOTE { $2 } - | BQUOTE QCONID BQUOTE { $2 } +var : QVARID { $1 } + | QVARSYM { $1 } + +qname :: { RdrName } +qname : QVARID { $1 } + | QCONID { $1 } | QVARSYM { $1 } | QCONSYM { $1 } - | op { Unqual $1 } - -iname :: { FAST_STRING } -iname : VARID { $1 } - | CONID { $1 } - | OPAREN VARSYM CPAREN { $2 } - | OPAREN BANG CPAREN { SLIT("!"){-sigh, double-sigh-} } - | OPAREN CONSYM CPAREN { $2 } - -qiname :: { RdrName } -qiname : QVARID { $1 } - | QCONID { $1 } - | OPAREN QVARSYM CPAREN { $2 } - | OPAREN QCONSYM CPAREN { $2 } - | iname { Unqual $1 } + +name :: { FAST_STRING } +name : VARID { $1 } + | CONID { $1 } + | VARSYM { $1 } + | BANG { SLIT("!"){-sigh, double-sigh-} } + | CONSYM { $1 } instances_part :: { Bag RdrIfaceInst } instances_part : INSTANCES_PART instdecls { $2 } diff --git a/ghc/compiler/rename/ParseUtils.lhs b/ghc/compiler/rename/ParseUtils.lhs index e3fde6b..e71614f 100644 --- a/ghc/compiler/rename/ParseUtils.lhs +++ b/ghc/compiler/rename/ParseUtils.lhs @@ -20,11 +20,11 @@ import ErrUtils ( Error(..) ) import FiniteMap ( unitFM, listToFM, lookupFM, plusFM, FiniteMap ) import Maybes ( maybeToBool, MaybeErr(..) ) import Name ( isLexConId, isLexVarId, isLexConSym, - mkTupNameStr, + mkTupNameStr, preludeQual, isRdrLexCon, RdrName(..){-instance Outputable:ToDo:rm-} ) import PprStyle ( PprStyle(..) ) -- ToDo: rm debugging -import PrelMods ( fromPrelude ) +import PrelMods ( pRELUDE ) import Pretty ( ppCat, ppPStr, ppInt, ppShow, ppStr ) import SrcLoc ( mkIfaceSrcLoc ) import Util ( startsWith, isIn, panic, assertPanic ) @@ -37,7 +37,7 @@ type UsagesMap = FiniteMap Module (Version, VersionsMap) -- representing all the instances def'd in that module type VersionsMap = FiniteMap FAST_STRING Version -- Versions for things def'd in this module -type ExportsMap = FiniteMap FAST_STRING (RdrName, ExportFlag) +type ExportsMap = FiniteMap FAST_STRING (OrigName, ExportFlag) type FixitiesMap = FiniteMap FAST_STRING RdrNameFixityDecl type LocalTyDefsMap = FiniteMap FAST_STRING RdrIfaceDecl -- for TyCon/Class type LocalValDefsMap = FiniteMap FAST_STRING RdrIfaceDecl -- for values incl DataCon @@ -65,13 +65,14 @@ data ParsedIface data RdrIfaceDecl = TypeSig RdrName SrcLoc RdrNameTyDecl - | NewTypeSig RdrName RdrName SrcLoc RdrNameTyDecl + | NewTypeSig RdrName RdrName SrcLoc RdrNameTyDecl | DataSig RdrName [RdrName] [RdrName] SrcLoc RdrNameTyDecl | ClassSig RdrName [RdrName] SrcLoc RdrNameClassDecl | ValSig RdrName SrcLoc RdrNamePolyType data RdrIfaceInst - = InstSig RdrName RdrName SrcLoc RdrNameInstDecl + = InstSig RdrName RdrName SrcLoc (Module -> RdrNameInstDecl) + -- InstDecl minus a Module name \end{code} \begin{code} @@ -97,13 +98,14 @@ data IfaceToken | ITinfix | ITbang -- magic symbols | ITvbar - | ITbquote | ITdcolon | ITcomma | ITdarrow | ITdotdot | ITequal | ITocurly + | ITdccurly + | ITdocurly | ITobrack | IToparen | ITrarrow @@ -132,60 +134,56 @@ de_qual (Qual _ n) = n en_mono :: FAST_STRING -> RdrNameMonoType en_mono tv = MonoTyVar (Unqual tv) +{-OLD: type2context (MonoTupleTy tys) = map type2class_assertion tys type2context other_ty = [ type2class_assertion other_ty ] type2class_assertion (MonoTyApp clas [MonoTyVar tyvar]) = (clas, tyvar) type2class_assertion _ = panic "type2class_assertion: bad format" +-} ----------------------------------------------------------------- mk_type :: (RdrName, [FAST_STRING]) -> RdrNameMonoType -> LocalTyDefsMap -mk_type (qtycon, tyvars) ty +mk_type (qtycon@(Qual mod tycon), tyvars) ty = let - tycon = de_qual qtycon qtyvars = map Unqual tyvars in - unitFM tycon (TypeSig qtycon mkIfaceSrcLoc ( - TySynonym qtycon qtyvars ty mkIfaceSrcLoc)) + unitFM tycon (TypeSig qtycon mkIfaceSrcLoc $ + TySynonym qtycon qtyvars ty mkIfaceSrcLoc) mk_data :: RdrNameContext -> (RdrName, [FAST_STRING]) -> [(RdrName, RdrNameConDecl)] -> (LocalTyDefsMap, LocalValDefsMap) -mk_data ctxt (qtycon, tyvars) names_and_constrs +mk_data ctxt (qtycon@(Qual mod tycon), tyvars) names_and_constrs = let - (qconnames, constrs) = unzip names_and_constrs - qfieldnames = [] -- ToDo ... - tycon = de_qual qtycon - connames = map de_qual qconnames - fieldnames = map de_qual qfieldnames + (qthingnames, constrs) = unzip names_and_constrs + (qconnames, qfieldnames) = partition isRdrLexCon qthingnames + thingnames = [ t | (Qual _ t) <- qthingnames] qtyvars = map Unqual tyvars - decl = DataSig qtycon qconnames qfieldnames mkIfaceSrcLoc ( - TyData ctxt qtycon qtyvars constrs Nothing noDataPragmas mkIfaceSrcLoc) + decl = DataSig qtycon qconnames qfieldnames mkIfaceSrcLoc $ + TyData ctxt qtycon qtyvars constrs Nothing noDataPragmas mkIfaceSrcLoc in - (unitFM tycon decl, listToFM [(c,decl) | c <- connames] - `plusFM` - listToFM [(f,decl) | f <- fieldnames]) + (unitFM tycon decl, listToFM [(t,decl) | t <- thingnames]) mk_new :: RdrNameContext -> (RdrName, [FAST_STRING]) -> (RdrName, RdrNameMonoType) -> (LocalTyDefsMap, LocalValDefsMap) -mk_new ctxt (qtycon, tyvars) (qconname, ty) - = let - tycon = de_qual qtycon - conname = de_qual qconname +mk_new ctxt (qtycon@(Qual mod1 tycon), tyvars) (qconname@(Qual mod2 conname), ty) + = ASSERT(mod1 == mod2) + let qtyvars = map Unqual tyvars constr = NewConDecl qconname ty mkIfaceSrcLoc - decl = NewTypeSig qtycon qconname mkIfaceSrcLoc ( - TyNew ctxt qtycon qtyvars [constr] Nothing noDataPragmas mkIfaceSrcLoc) + decl = NewTypeSig qtycon qconname mkIfaceSrcLoc $ + TyNew ctxt qtycon qtyvars [constr] Nothing noDataPragmas mkIfaceSrcLoc in (unitFM tycon decl, unitFM conname decl) @@ -194,15 +192,14 @@ mk_class :: RdrNameContext -> [(FAST_STRING, RdrNameSig)] -> (LocalTyDefsMap, LocalValDefsMap) -mk_class ctxt (qclas, tyvar) ops_and_sigs +mk_class ctxt (qclas@(Qual mod clas), tyvar) ops_and_sigs = case (unzip ops_and_sigs) of { (opnames, sigs) -> let - qopnames = map Unqual opnames - clas = de_qual qclas + qopnames = map (Qual mod) opnames op_sigs = map opify sigs - decl = ClassSig qclas qopnames mkIfaceSrcLoc ( - ClassDecl ctxt qclas tyvar op_sigs EmptyMonoBinds noClassPragmas mkIfaceSrcLoc) + decl = ClassSig qclas qopnames mkIfaceSrcLoc $ + ClassDecl ctxt qclas tyvar op_sigs EmptyMonoBinds noClassPragmas mkIfaceSrcLoc in (unitFM clas decl, listToFM [(o,decl) | o <- opnames]) } where @@ -213,23 +210,23 @@ mk_inst :: RdrNameContext -> RdrNameMonoType -- fish the tycon out yourself... -> RdrIfaceInst -mk_inst ctxt clas mono_ty - = InstSig clas (tycon_name mono_ty) mkIfaceSrcLoc ( - InstDecl clas (HsPreForAllTy ctxt mono_ty) - EmptyMonoBinds False Nothing{-lying-} [{-sigs-}] - noInstancePragmas mkIfaceSrcLoc) +mk_inst ctxt qclas@(Qual cmod cname) mono_ty + = InstSig qclas (tycon_name mono_ty) mkIfaceSrcLoc $ \ mod -> + InstDecl qclas (HsPreForAllTy ctxt mono_ty) + EmptyMonoBinds False mod [{-sigs-}] + noInstancePragmas mkIfaceSrcLoc where tycon_name (MonoTyApp tc _) = tc - tycon_name (MonoListTy _) = Unqual SLIT("[]") - tycon_name (MonoFunTy _ _) = Unqual SLIT("->") - tycon_name (MonoTupleTy ts) = Unqual (mkTupNameStr (length ts)) + tycon_name (MonoListTy _) = preludeQual SLIT("[]") + tycon_name (MonoFunTy _ _) = preludeQual SLIT("->") + tycon_name (MonoTupleTy ts) = preludeQual (mkTupNameStr (length ts)) ----------------------------------------------------------------- lexIface :: String -> [IfaceToken] -lexIface str +lexIface input = _scc_ "Lexer" - case str of + case input of [] -> [] -- whitespace and comments @@ -240,21 +237,23 @@ lexIface str '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs '(' : '.' : '.' : ')' : cs -> ITdotdot : lexIface cs + '{' : '{' : cs -> ITdocurly : lexIface cs + '}' : '}' : cs -> ITdccurly : lexIface cs + '{' : cs -> ITocurly : lexIface cs + '}' : cs -> ITccurly : lexIface cs '(' : cs -> IToparen : lexIface cs ')' : cs -> ITcparen : lexIface cs '[' : cs -> ITobrack : lexIface cs ']' : cs -> ITcbrack : lexIface cs - '{' : cs -> ITocurly : lexIface cs - '}' : cs -> ITccurly : lexIface cs ',' : cs -> ITcomma : lexIface cs ';' : cs -> ITsemi : lexIface cs - '`' : cs -> ITbquote : lexIface cs - '_' : cs -> lex_name Nothing is_var_sym str - c : cs | isUpper c -> lex_word str -- don't know if "Module." on front or not - | isDigit c -> lex_num str - | isAlpha c -> lex_name Nothing is_var_sym str - | is_sym_sym c -> lex_name Nothing is_sym_sym str + '_' : '_' : cs -> lex_keyword cs + + c : cs | isUpper c -> lex_word input -- don't know if "Module." on front or not + | isDigit c -> lex_num input + | isAlpha c -> lex_name Nothing is_var_sym input + | is_sym_sym c -> lex_name Nothing is_sym_sym input other -> error ("lexing:"++other) where @@ -285,6 +284,7 @@ lexIface str is_var_sym1 '\'' = False is_var_sym1 '#' = False + is_var_sym1 '_' = False is_var_sym1 c = is_var_sym c is_sym_sym c = c `elem` ":!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic @@ -297,10 +297,9 @@ lexIface str Just (m,rest) -> lex_name (Just m) (in_the_club rest) rest where in_the_club [] = panic "lex_word:in_the_club" - in_the_club (c:_) | isAlpha c = is_var_sym - | c == '_' = is_var_sym - | is_sym_sym c = is_sym_sym - | otherwise = panic ("lex_word:in_the_club="++[c]) + in_the_club (x:_) | isAlpha x = is_var_sym + | is_sym_sym x = is_sym_sym + | otherwise = panic ("lex_word:in_the_club="++[x]) module_dot (c:cs) = if not (isUpper c) || c == '\'' then @@ -313,6 +312,13 @@ lexIface str _ -> Nothing } + lex_keyword str + = case (span is_var_sym str) of { (kw, rest) -> + case (lookupFM keywordsFM kw) of + Nothing -> panic ("lex_keyword:"++str) + Just xx -> xx : lexIface rest + } + lex_name module_dot in_the_club str = case (span in_the_club str) of { (word, rest) -> case (lookupFM keywordsFM word) of @@ -335,7 +341,7 @@ lexIface str categ n (ITconid n) (ITvarid n) (ITconsym n) (ITvarsym n) Just m -> let - q = if fromPrelude m then Unqual n else Qual m n + q = Qual m n in categ n (ITqconid q) (ITqvarid q) (ITqconsym q) (ITqvarsym q) @@ -353,14 +359,14 @@ lexIface str keywordsFM = listToFM [ ("interface", ITinterface) - ,("__usages__", ITusages) - ,("__versions__", ITversions) - ,("__exports__", ITexports) - ,("__instance_modules__",ITinstance_modules) - ,("__instances__", ITinstances) - ,("__fixities__", ITfixities) - ,("__declarations__", ITdeclarations) - ,("__pragmas__", ITpragmas) + ,("usages__", ITusages) + ,("versions__", ITversions) + ,("exports__", ITexports) + ,("instance_modules__", ITinstance_modules) + ,("instances__", ITinstances) + ,("fixities__", ITfixities) + ,("declarations__", ITdeclarations) + ,("pragmas__", ITpragmas) ,("data", ITdata) ,("type", ITtype) diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index ac41996..d1b2fbc 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -40,9 +40,8 @@ import CmdLineOpts ( opt_HiMap, opt_NoImplicitPrelude ) import ErrUtils ( Error(..), Warning(..) ) import FiniteMap ( emptyFM, eltsFM, fmToList, lookupFM{-ToDo:rm-} ) import Maybes ( catMaybes ) -import Name ( isLocallyDefined, mkBuiltinName, Name, RdrName(..) ) +import Name ( isLocallyDefined, mkWiredInName, Name, RdrName(..) ) import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) ) -import PrelMods ( pRELUDE ) import Unique ( ixClassKey ) import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM ) import UniqSupply ( splitUniqSupply ) @@ -69,7 +68,7 @@ ToDo: May want to arrange to return old interface for this module! ToDo: Deal with instances (instance version, this module on instance list ???) \begin{code} -renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) +renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _) = let (b_names, b_keys, _) = builtinNameInfo @@ -103,7 +102,7 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) else -- No top-level name errors so rename source ... - case initRn True mod occ_env us2 + case initRn True modname occ_env us2 (rnSource imp_mods unqual_imps imp_fixes input) of { ((rn_module, export_fn, src_occs), src_errs, src_warns) -> @@ -158,20 +157,32 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) -- including those for which we have definitions (orig_def_env, orig_def_dups) - = extendGlobalRnEnv emptyRnEnv (map pair_orig def_vals) - (map pair_orig def_tcs) + = extendGlobalRnEnv emptyRnEnv (map pairify_rn def_vals) + (map pairify_rn def_tcs) (orig_occ_env, orig_occ_dups) - = extendGlobalRnEnv emptyRnEnv (map pair_orig occ_vals) - (map pair_orig occ_tcs) - - pair_orig rn = (origName rn, rn) + = extendGlobalRnEnv emptyRnEnv (map pairify_rn occ_vals) + (map pairify_rn occ_tcs) + + -- This stuff is pretty dodgy right now: I think original + -- names and occurrence names may be getting entangled + -- when they shouldn't be... WDP 96/06 + + pairify_rn rn -- ToDo: move to Name? + = let + name = getName rn + in + (if isLocalName name + then Unqual (getLocalName name) + else case (origName "pairify_rn" name) of { OrigName m n -> + Qual m n } + , rn) must_haves | opt_NoImplicitPrelude = [{-no Prelude.hi, no point looking-}] | otherwise - = [ name_fn (mkBuiltinName u mod str) - | ((str, mod), (u, name_fn)) <- fmToList b_keys, + = [ name_fn (mkWiredInName u orig) + | (orig@(OrigName mod str), (u, name_fn)) <- fmToList b_keys, str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ] in -- ASSERT (isEmptyBag orig_occ_dups) @@ -226,68 +237,3 @@ multipleOccWarn (name, occs) sty = ppBesides [ppStr "warning:multiple names used to refer to `", ppr sty name, ppStr "': ", ppInterleave ppComma (map (ppr sty) occs)] \end{code} - -\begin{code} -{- TESTING: -pprPIface (ParsedIface m ms v mv usgs lcm exm ims lfx ltdm lvdm lids ldp) - = ppAboves [ - ppCat [ppPStr SLIT("interface"), ppPStr m, ppInt v, - case mv of { Nothing -> ppNil; Just n -> ppInt n }], - - ppPStr SLIT("__versions__"), - ppAboves [ ppCat[ppPStr n, ppInt v] | (n,v) <- fmToList lcm ], - - ppPStr SLIT("__exports__"), - ppAboves [ ppBesides[ppPStr n, ppSP, ppr PprDebug rn, - case ex of {ExportAll -> ppStr "(..)"; _ -> ppNil}] - | (n,(rn,ex)) <- fmToList exm ], - - pp_ims (bagToList ims), - pp_fixities lfx, - pp_decls ltdm lvdm, - pp_insts (bagToList lids), - pp_pragmas ldp - ] - where - pp_ims [] = ppNil - pp_ims ms = ppAbove (ppPStr SLIT("__instance_modules__")) - (ppCat (map ppPStr ms)) - - pp_fixities fx - | isEmptyFM fx = ppNil - | otherwise = ppAboves (ppPStr SLIT("__fixities__") - : [ ppr PprDebug fix | (n, fix) <- fmToList fx]) - - pp_decls tds vds = ppAboves (ppPStr SLIT("__declarations__") - : [ pprRdrIfaceDecl d | (n, d) <- fmToList tds ++ fmToList vds]) - - pp_insts [] = ppNil - pp_insts is = ppAboves (ppPStr SLIT("__instances__") - : [ pprRdrInstDecl i | i <- is]) - - pp_pragmas ps | isEmptyFM ps = ppNil - | otherwise = panic "Rename.pp_pragmas" - -pprRdrIfaceDecl (TypeSig tc _ decl) - = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; ", ppr PprDebug decl] - -pprRdrIfaceDecl (NewTypeSig tc dc _ decl) - = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacon=", ppr PprDebug dc, - ppStr "; ", ppr PprDebug decl] - -pprRdrIfaceDecl (DataSig tc dcs dfs _ decl) - = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacons=", ppr PprDebug dcs, - ppStr "; fields=", ppr PprDebug dfs, ppStr "; ", ppr PprDebug decl] - -pprRdrIfaceDecl (ClassSig c ops _ decl) - = ppBesides [ppStr "class=", ppr PprDebug c, ppStr "; ops=", ppr PprDebug ops, - ppStr "; ", ppr PprDebug decl] - -pprRdrIfaceDecl (ValSig f _ ty) - = ppBesides [ppr PprDebug f, ppStr " :: ", ppr PprDebug ty] - -pprRdrInstDecl (InstSig c t _ decl) - = ppBesides [ppStr "class=", ppr PprDebug c, ppStr " type=", ppr PprDebug t, ppStr "; ", - ppr PprDebug decl] --} -\end{code} diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index a96d3ee..ab0e9ee 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -34,11 +34,12 @@ import Digraph ( stronglyConnComp ) import ErrUtils ( addErrLoc, addShortErrLocLine ) import Name ( RdrName ) import Maybes ( catMaybes ) +import PprStyle--ToDo:rm import Pretty import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet, unionUniqSets, unionManyUniqSets, elementOfUniqSet, uniqSetToList, UniqSet(..) ) -import Util ( thenCmp, isIn, removeDups, panic, panic#, assertPanic ) +import Util ( thenCmp, isIn, removeDups, panic, panic#, assertPanic, pprTrace{-ToDo:rm-} ) \end{code} -- ToDo: Put the annotations into the monad, so that they arrive in the proper @@ -261,7 +262,7 @@ rnMonoBinds mbinds siglist -- Do the SCC analysis let vertices = mkVertices mbinds_info - edges = mkEdges vertices mbinds_info + edges = mkEdges mbinds_info scc_result = stronglyConnComp (==) edges vertices @@ -316,9 +317,9 @@ flattenMonoBinds :: Int -- Next free vertex tag flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn (uniq, []) -flattenMonoBinds uniq sigs (AndMonoBinds mB1 mB2) - = flattenMonoBinds uniq sigs mB1 `thenRn` \ (uniq1, flat1) -> - flattenMonoBinds uniq1 sigs mB2 `thenRn` \ (uniq2, flat2) -> +flattenMonoBinds uniq sigs (AndMonoBinds bs1 bs2) + = flattenMonoBinds uniq sigs bs1 `thenRn` \ (uniq1, flat1) -> + flattenMonoBinds uniq1 sigs bs2 `thenRn` \ (uniq2, flat2) -> returnRn (uniq2, flat1 ++ flat2) flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn) @@ -471,27 +472,28 @@ type FlatMonoBindsInfo ] mkVertices :: FlatMonoBindsInfo -> [VertexTag] -mkVertices info = [ vertex | (vertex,_,_,_,_) <- info] +mkEdges :: FlatMonoBindsInfo -> [Edge] -mkEdges :: [VertexTag] -> FlatMonoBindsInfo -> [Edge] +mkVertices info = [ vertex | (vertex,_,_,_,_) <- info] -mkEdges vertices flat_info +mkEdges flat_info -- An edge (v,v') indicates that v depends on v' - = [ (source_vertex, target_vertex) - | (source_vertex, _, used_names, _, _) <- flat_info, - target_name <- uniqSetToList used_names, - target_vertex <- vertices_defining target_name flat_info - ] - where - -- If each name only has one binding in this group, then - -- vertices_defining will always return the empty list, or a - -- singleton. The case when there is more than one binding (an - -- error) needs more thought. - - vertices_defining name flat_info2 - = [ vertex | (vertex, names_defined, _, _, _) <- flat_info2, - name `elementOfUniqSet` names_defined - ] + = -- pprTrace "mkEdges:" (ppAboves [ppAboves[ppInt v, ppCat [ppr PprDebug d|d <- uniqSetToList defd], ppCat [ppr PprDebug u|u <- uniqSetToList used]] | (v,defd,used,_,_) <- flat_info]) $ + [ (source_vertex, target_vertex) + | (source_vertex, _, used_names, _, _) <- flat_info, + target_name <- uniqSetToList used_names, + target_vertex <- vertices_defining target_name flat_info + ] + where + -- If each name only has one binding in this group, then + -- vertices_defining will always return the empty list, or a + -- singleton. The case when there is more than one binding (an + -- error) needs more thought. + + vertices_defining name flat_info2 + = [ vertex | (vertex, names_defined, _, _, _) <- flat_info2, + name `elementOfUniqSet` names_defined + ] \end{code} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 10aef2e..9e2697f 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -5,7 +5,7 @@ Basically dependency analysis. -Handles @Match@, @GRHSsAndBinds@, @HsExpr@, and @Qual@ datatypes. In +Handles @Match@, @GRHSsAndBinds@, @HsExpr@, and @Qualifier@ datatypes. In general, all of these functions return a renamed thing, and a set of free variables. @@ -369,7 +369,7 @@ rnRpats rpats %************************************************************************ %* * -\subsubsection{@Qual@s: in list comprehensions} +\subsubsection{@Qualifier@s: in list comprehensions} %* * %************************************************************************ diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index d8cfa12..596ed5f 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -163,7 +163,7 @@ type RenamedMonoType = MonoType RnName type RenamedPat = InPat RnName type RenamedPolyType = PolyType RnName type RenamedRecordBinds = HsRecordBinds Fake Fake RnName RenamedPat -type RenamedQual = Qual Fake Fake RnName RenamedPat +type RenamedQual = Qualifier Fake Fake RnName RenamedPat type RenamedSig = Sig RnName type RenamedSpecInstSig = SpecInstSig RnName type RenamedStmt = Stmt Fake Fake RnName RenamedPat diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 6b0b75c..3db7db8 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -7,17 +7,14 @@ #include "HsVersions.h" module RnIfaces ( --- findHiFiles, cachedIface, cachedDecl, - readIface, rnIfaces, IfaceCache(..) ) where IMP_Ubiq() -import LibDirectory import PreludeGlaST ( thenPrimIO, seqPrimIO, readVar, writeVar, MutableVar(..) ) import HsSyn @@ -41,11 +38,11 @@ import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM, plusFM_C, addListToFM, keysFM{-ToDo:rm-} ) import Maybes ( maybeToBool ) -import Name ( moduleNamePair, origName, isRdrLexCon, RdrName(..), Name{-instance NamedThing-} ) +import Name ( origName, moduleOf, nameOf, qualToOrigName, OrigName(..), + isLexCon, RdrName(..), Name{-instance NamedThing-} ) import PprStyle -- ToDo:rm import Outputable -- ToDo:rm import PrelInfo ( builtinNameInfo ) -import PrelMods ( pRELUDE ) import Pretty import Maybes ( MaybeErr(..) ) import UniqFM ( emptyUFM ) @@ -68,80 +65,6 @@ type IfaceCache ********************************************************* * * -\subsection{Looking for interface files} -* * -********************************************************* - -Return a mapping from module-name to -absolute-filename-for-that-interface. -\begin{code} -{- OLD: -findHiFiles :: [FilePath] -> [FilePath] -> IO (FiniteMap Module FilePath) - -findHiFiles dirs sysdirs - = --hPutStr stderr " findHiFiles " >> - do_dirs emptyFM (dirs ++ sysdirs) >>= \ result -> - --hPutStr stderr " done\n" >> - return result - where - do_dirs env [] = return env - do_dirs env (dir:dirs) - = do_dir env dir >>= \ new_env -> - do_dirs new_env dirs - ------- - do_dir env dir - = --hPutStr stderr "D" >> - getDirectoryContents dir >>= \ entries -> - do_entries env entries - where - do_entries env [] = return env - do_entries env (e:es) - = do_entry env e >>= \ new_env -> - do_entries new_env es - ------- - do_entry env e - = case (acceptable_hi (reverse e)) of - Nothing -> --trace ("Deemed uncool:"++e) $ - --hPutStr stderr "." >> - return env - Just mod -> - let - pmod = _PK_ mod - in - case (lookupFM env pmod) of - Nothing -> --trace ("Adding "++mod++" -> "++e) $ - --hPutStr stderr "!" >> - return (addToFM env pmod (dir ++ '/':e)) - -- ToDo: use DIR_SEP, not / - - Just xx -> ( if de_dot xx /= e then trace ("Already mapped!! "++mod++" -> "++xx++"; ignoring:"++e) else id) $ - --hPutStr stderr "." >> - return env - ------- - acceptable_hi rev_e -- looking at pathname *backwards* - = case (startsWith (reverse opt_HiSuffix) rev_e) of - Nothing -> Nothing - Just xs -> plausible_modname xs{-reversed-} - - ------- - de_dot ('.' : '/' : xs) = xs - de_dot xs = xs - - ------- - plausible_modname rev_e - = let - cand = reverse (takeWhile is_modname_char rev_e) - in - if null cand || not (isUpper (head cand)) - then Nothing - else Just cand - where - is_modname_char c = isAlphanum c || c == '_' --} -\end{code} - -********************************************************* -* * \subsection{Reading interface files} * * ********************************************************* @@ -174,22 +97,22 @@ cachedIface :: Bool -- True => want merged interface for original name -> Module -> IO (MaybeErr ParsedIface Error) -cachedIface want_orig_iface iface_cache mod +cachedIface want_orig_iface iface_cache modname = readVar iface_cache `thenPrimIO` \ (iface_fm, orig_fm, file_fm) -> - case (lookupFM iface_fm mod) of + case (lookupFM iface_fm modname) of Just iface -> return (want_iface iface orig_fm) Nothing -> - case (lookupFM file_fm mod) of - Nothing -> return (Failed (noIfaceErr mod)) + case (lookupFM file_fm modname) of + Nothing -> return (Failed (noIfaceErr modname)) Just file -> - readIface file mod >>= \ read_iface -> + readIface file modname >>= \ read_iface -> case read_iface of Failed err -> -- pprTrace "module-file map:\n" (ppAboves [ppCat [ppPStr m, ppStr f] | (m,f) <- fmToList file_fm]) $ return (Failed err) Succeeded iface -> let - iface_fm' = addToFM iface_fm mod iface + iface_fm' = addToFM iface_fm modname iface orig_fm' = addToFM_C mergeIfaces orig_fm (iface_mod iface) iface in writeVar iface_cache (iface_fm', orig_fm', file_fm) `seqPrimIO` @@ -197,8 +120,8 @@ cachedIface want_orig_iface iface_cache mod where want_iface iface orig_fm | want_orig_iface - = case lookupFM orig_fm mod of - Nothing -> Failed (noOrigIfaceErr mod) + = case lookupFM orig_fm modname of + Nothing -> Failed (noOrigIfaceErr modname) Just orig_iface -> Succeeded orig_iface | otherwise = Succeeded iface @@ -240,11 +163,11 @@ mergeIfaces (ParsedIface mod1 (_, files1) _ _ _ _ _ _ fixes1 tdefs1 vdefs1 idefs ---------- cachedDecl :: IfaceCache -> Bool -- True <=> tycon or class name - -> RdrName + -> OrigName -> IO (MaybeErr RdrIfaceDecl Error) -cachedDecl iface_cache class_or_tycon orig - = -- pprTrace "cachedDecl:" (ppr PprDebug orig) $ +cachedDecl iface_cache class_or_tycon name@(OrigName mod str) + = -- pprTrace "cachedDecl:" (ppr PprDebug name) $ cachedIface True iface_cache mod >>= \ maybe_iface -> case maybe_iface of Failed err -> --pprTrace "cachedDecl:fail:" (ppr PprDebug orig) $ @@ -253,8 +176,6 @@ cachedDecl iface_cache class_or_tycon orig case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of Just decl -> return (Succeeded decl) Nothing -> return (Failed (noDeclInIfaceErr mod str)) - where - (mod, str) = moduleNamePair orig ---------- cachedDeclByType :: IfaceCache @@ -265,7 +186,7 @@ cachedDeclByType iface_cache rn -- the idea is: check that, e.g., if we're given an -- RnClass, then we really get back a ClassDecl from -- the cache (not an RnData, or something silly) - = cachedDecl iface_cache (isRnTyConOrClass rn) (origName rn) >>= \ maybe_decl -> + = cachedDecl iface_cache (isRnTyConOrClass rn) (origName "cachedDeclByType" rn) >>= \ maybe_decl -> let return_maybe_decl = return maybe_decl return_failed msg = return (Failed msg) @@ -313,10 +234,9 @@ cachedDeclByType iface_cache rn \end{code} \begin{code} -readIface :: FilePath -> Module - -> IO (MaybeErr ParsedIface Error) +readIface :: FilePath -> Module -> IO (MaybeErr ParsedIface Error) -readIface file mod +readIface file modname = hPutStr stderr (" reading "++file) >> readFile file `thenPrimIO` \ read_result -> case read_result of @@ -327,7 +247,7 @@ readIface file mod return ( case parsed of Failed _ -> parsed - Succeeded p -> Succeeded (init_merge mod p) + Succeeded p -> Succeeded (init_merge modname p) ) where init_merge this (ParsedIface mod _ v sv us vs exps insts fixes tdefs vdefs idefs prags) @@ -399,7 +319,10 @@ rnIfaces iface_cache imp_mods us if_errs_warns) where decls_and_insts todo def_env occ_env to_return us - = do_decls todo -- initial batch of names to process + = let + (us1,us2) = splitUniqSupply us + in + do_decls todo -- initial batch of names to process (def_env, occ_env, us1) -- init stuff down to_return -- acc results >>= \ (decls_return, @@ -410,9 +333,8 @@ rnIfaces iface_cache imp_mods us do_insts decls_def_env decls_occ_env emptyRnEnv emptyFM (add_errs errs decls_return) us2 - where - (us1,us2) = splitUniqSupply us + -------- do_insts def_env occ_env prev_env done_insts to_return us | size_tc_env occ_env == size_tc_env prev_env = return (to_return, occ_env) @@ -460,7 +382,7 @@ rnIfaces iface_cache imp_mods us do_decls ns down to_return Nothing - | fst (moduleNamePair n) == modname -> + | moduleOf (origName "do_decls" n) == modname -> -- avoid looking in interface for the module being compiled --pprTrace "do_decls:this module error:" (ppr PprDebug n) $ do_decls ns down (add_warn (thisModImplicitWarn modname n) to_return) @@ -516,10 +438,9 @@ type Go_Down = (RnEnv, -- stuff we already have defns for; ) lookup_defd (def_env, _, _) n - | isRnTyConOrClass n - = lookupTcRnEnv def_env (origName n) - | otherwise - = lookupRnEnv def_env (origName n) + = (if isRnTyConOrClass n then lookupTcRnEnv else lookupRnEnv) def_env + (case (origName "lookup_defd" n) of { OrigName m s -> Qual m s }) + -- this is hack because we are reusing the RnEnv technology defenv (def_env, _, _) = def_env occenv (_, occ_env, _) = occ_env @@ -532,8 +453,11 @@ add_occs (val_defds, tc_defds) (val_imps, tc_imps) (def_env, occ_env, us) (if isEmptyBag def_dups then \x->x else pprTrace "add_occs:" (ppCat [ppr PprDebug n | (n,_,_) <- bagToList def_dups])) $ -- ASSERT(isEmptyBag def_dups) let - val_occs = val_defds ++ fmToList val_imps - tc_occs = tc_defds ++ fmToList tc_imps + de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ] + -- again, this hackery because we are reusing the RnEnv technology + + val_occs = val_defds ++ de_orig val_imps + tc_occs = tc_defds ++ de_orig tc_imps in case (extendGlobalRnEnv occ_env val_occs tc_occs) of { (new_occ_env, occ_dups) -> @@ -561,7 +485,7 @@ add_insts is ((tydecls, classdecls, instdecls, sigs), implicit, msgs) = ((tydecls, classdecls, is ++ instdecls, sigs), implicit, msgs) add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs) - = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM` tc_imps), msgs) + = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM` tc_imps), msgs) add_err err (decls,implicit,(errs,warns)) = (decls,implicit,(errs `snocBag` err,warns)) add_errs ers (decls,implicit,(errs,warns)) = (decls,implicit,(errs `unionBags` ers,warns)) @@ -645,8 +569,8 @@ rnIfaceDecl (ValSig f src_loc ty) sub :: ImplicitEnv -> ([(RdrName,RnName)], [(RdrName,RnName)]) -> ImplicitEnv sub (val_ment, tc_ment) (val_defds, tc_defds) - = (delListFromFM val_ment (map fst val_defds), - delListFromFM tc_ment (map fst tc_defds)) + = (delListFromFM val_ment (map (qualToOrigName . fst) val_defds), + delListFromFM tc_ment (map (qualToOrigName . fst) tc_defds)) \end{code} % ------------------------------ @@ -687,7 +611,7 @@ cacheInstModules iface_cache imp_mods @rnIfaceInstStuff@: Deal with instance declarations from interface files. \begin{code} -type InstanceEnv = FiniteMap (RdrName, RdrName) Int +type InstanceEnv = FiniteMap (OrigName, OrigName) Int rnIfaceInstStuff :: IfaceCache -- all about ifaces we've read @@ -727,8 +651,8 @@ rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return case (initRn False{-iface-} modname occ_env us ( setExtraRn emptyUFM{-no fixities-} $ - mapRn rnIfaceInst interesting_insts `thenRn` \ insts -> - getImplicitUpRn `thenRn` \ implicits -> + mapRn (rnIfaceInst modname) interesting_insts `thenRn` \ insts -> + getImplicitUpRn `thenRn` \ implicits -> returnRn (insts, implicits))) of { ((if_insts, if_implicits), if_errs, if_warns) -> @@ -743,16 +667,21 @@ rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return where get_insts (ParsedIface _ _ _ _ _ _ _ _ _ _ _ insts _) = insts + tycon_class clas tycon = (qualToOrigName clas, qualToOrigName tycon) + add_done_inst (InstSig clas tycon _ _) inst_env - = addToFM_C (+) inst_env (tycon,clas) 1 + = addToFM_C (+) inst_env (tycon_class clas tycon) 1 is_done_inst (InstSig clas tycon _ _) - = maybeToBool (lookupFM done_inst_env (tycon,clas)) + = maybeToBool (lookupFM done_inst_env (tycon_class clas tycon)) add_imp_occs (val_imps, tc_imps) occ_env - = case extendGlobalRnEnv occ_env (fmToList val_imps) (fmToList tc_imps) of + = case (extendGlobalRnEnv occ_env (de_orig val_imps) (de_orig tc_imps)) of (ext_occ_env, occ_dups) -> ASSERT(isEmptyBag occ_dups) ext_occ_env + where + de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ] + -- again, this hackery because we are reusing the RnEnv technology want_inst i@(InstSig clas tycon _ _) = -- it's a "good instance" (one to hang onto) if we have a @@ -764,25 +693,26 @@ rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return = case lookupTcRnEnv occ_env nm of Just _ -> True Nothing -> -- maybe it's builtin - let str_mod = case nm of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) } - in case (lookupFM b_tc_names str_mod) of - Just _ -> True - Nothing -> maybeToBool (lookupFM b_keys str_mod) + let orig = qualToOrigName nm in + case (lookupFM b_tc_names orig) of + Just _ -> True + Nothing -> maybeToBool (lookupFM b_keys orig) (b_tc_names, b_keys) -- pretty UGLY ... = case builtinNameInfo of ((_,builtin_tcs),b_keys,_) -> (builtin_tcs,b_keys) - +{- ppr_insts insts = ppAboves (map ppr_inst insts) where ppr_inst (InstSig c t _ inst_decl) = ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug inst_decl] +-} \end{code} \begin{code} -rnIfaceInst :: RdrIfaceInst -> RnM_Fixes _RealWorld RenamedInstDecl +rnIfaceInst :: Module -> RdrIfaceInst -> RnM_Fixes _RealWorld RenamedInstDecl -rnIfaceInst (InstSig _ _ _ inst_decl) = rnInstDecl inst_decl +rnIfaceInst mod (InstSig _ _ _ inst_decl) = rnInstDecl (inst_decl mod) \end{code} \begin{code} @@ -867,7 +797,7 @@ finalIfaceInfo iface_cache modname if_final_env@((qual, unqual, tc_qual, tc_unqu irrelevant (RnConstr _ _) = True -- We don't report these in their irrelevant (RnField _ _) = True -- own right in usages/etc. irrelevant (RnClassOp _ _) = True - irrelevant (RnImplicit n) = isRdrLexCon (origName n) -- really a RnConstr + irrelevant (RnImplicit n) = isLexCon (nameOf (origName "irrelevant" n)) -- really a RnConstr irrelevant _ = False \end{code} @@ -875,7 +805,7 @@ finalIfaceInfo iface_cache modname if_final_env@((qual, unqual, tc_qual, tc_unqu \begin{code} thisModImplicitWarn mod n sty - = ppBesides [ppPStr SLIT("An interface has an implicit need of "), ppPStr mod, ppChar '.', ppr sty n, ppPStr SLIT("; assuming this module will provide it.")] + = ppBesides [ppPStr SLIT("An interface has an implicit need of "), ppr sty n, ppPStr SLIT("; assuming this module will provide it.")] noIfaceErr mod sty = ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod] diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 3b36cf7..1d7cc96 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -53,7 +53,7 @@ import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine, import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, fmToList{-ToDo:rm-} ) import Maybes ( assocMaybe ) import Name ( Module(..), RdrName(..), isQual, - Name, mkLocalName, mkImplicitName, + OrigName(..), Name, mkLocalName, mkImplicitName, getOccName, pprNonSym ) import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) ) @@ -97,7 +97,7 @@ data RnMode s -- Renaming interface; creating and returning implicit names -- ImplicitEnv: one map for Values and one for TyCons/Classes. -type ImplicitEnv = (FiniteMap RdrName RnName, FiniteMap RdrName RnName) +type ImplicitEnv = (FiniteMap OrigName RnName, FiniteMap OrigName RnName) emptyImplicitEnv :: ImplicitEnv emptyImplicitEnv = (emptyFM, emptyFM) @@ -368,28 +368,29 @@ lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnSource occ_var) env lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _) = case lookup env rdr of - Just name -> returnSST name - Nothing -> lookup_nonexisting_val b_names b_key imp_var us_var rdr - -lookup_nonexisting_val (b_names,_) b_key imp_var us_var rdr - = let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) } - in case (lookupFM b_names str_mod) of - Nothing -> lookup_or_create_implicit_val b_key imp_var us_var rdr - Just xx -> returnSST xx + Just name -> returnSST name + Nothing -> case rdr of + Unqual n -> panic ("lookup_val:"++ _UNPK_ n) + Qual m n -> + lookup_nonexisting_val b_names b_key imp_var us_var (OrigName m n) + +lookup_nonexisting_val (b_names,_) b_key imp_var us_var orig + = case (lookupFM b_names orig) of + Just xx -> returnSST xx + Nothing -> lookup_or_create_implicit_val b_key imp_var us_var orig -lookup_or_create_implicit_val b_key imp_var us_var rdr +lookup_or_create_implicit_val b_key imp_var us_var orig = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) -> - case lookupFM implicit_val_fm rdr of + case (lookupFM implicit_val_fm orig) of Just implicit -> returnSST implicit Nothing -> - (let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) } - in case (lookupFM b_key str_mod) of + (case (lookupFM b_key orig) of Just (u,_) -> returnSST u _ -> get_unique us_var ) `thenSST` \ uniq -> let - implicit = mkRnImplicit (mkImplicitName uniq rdr) - new_val_fm = addToFM implicit_val_fm rdr implicit + implicit = mkRnImplicit (mkImplicitName uniq orig) + new_val_fm = addToFM implicit_val_fm orig implicit in writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_` returnSST implicit @@ -420,37 +421,33 @@ lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) returnSST name fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down -lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _) +lookup_tc rdr@(Qual m n) check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _) = case lookupTcRnEnv env rdr of Just name | check name -> returnSST name | otherwise -> fail - Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var rdr + Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var (OrigName m n) where fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down -lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var rdr - = let - str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) } - in - --pprTrace "lookup:" (ppAboves [case str_mod of {(n,m)->ppCat [ppPStr n, ppPStr m]}, ppAboves [ ppCat [ppPStr n, ppPStr m] | ((n,m), _) <- fmToList b_names]]) $ - case (lookupFM b_names str_mod) of - Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr +lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var orig--@(OrigName m n) + = --pprTrace "lookup:" (ppAboves [case str_mod of {(n,m)->ppCat [ppPStr n, ppPStr m]}, ppAboves [ ppCat [ppPStr n, ppPStr m] | ((n,m), _) <- fmToList b_names]]) $ + case (lookupFM b_names orig) of Just xx -> returnSST xx + Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig -lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr +lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) -> - case lookupFM implicit_tc_fm rdr of + case (lookupFM implicit_tc_fm orig) of Just implicit | check implicit -> returnSST implicit | otherwise -> fail Nothing -> - (let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) } - in case (lookupFM b_key str_mod) of + (case (lookupFM b_key orig) of Just (u,_) -> returnSST u _ -> get_unique us_var ) `thenSST` \ uniq -> let - implicit = mk_implicit (mkImplicitName uniq rdr) - new_tc_fm = addToFM implicit_tc_fm rdr implicit + implicit = mk_implicit (mkImplicitName uniq orig) + new_tc_fm = addToFM implicit_tc_fm orig implicit in writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_` returnSST implicit diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 59594f2..cd256b9 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -24,39 +24,43 @@ import RnIfaces ( IfaceCache(..), cachedIface, cachedDecl ) import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv, lubExportFlag, qualNameErr, dupNamesErr ) -import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst ) +import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), ExportsMap(..), RdrIfaceInst ) import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags, unionManyBags, mapBag, filterBag, listToBag, bagToList ) import CmdLineOpts ( opt_NoImplicitPrelude, opt_CompilingPrelude ) import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine, addShortWarnLocLine ) -import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, keysFM{-ToDo:rm-} ) +import FiniteMap ( emptyFM, addToFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, keysFM{-ToDo:rm-} ) import Id ( GenId ) import Maybes ( maybeToBool, catMaybes, MaybeErr(..) ) -import Name ( RdrName(..), Name, isQual, mkTopLevName, origName, - mkImportedName, nameExportFlag, nameImportFlag, - getLocalName, getSrcLoc, getImpLocs, moduleNamePair, - pprNonSym, isLexCon, isRdrLexCon, ExportFlag(..) +import Name ( RdrName(..), Name, isQual, mkTopLevName, mkWiredInName, origName, + nameOf, qualToOrigName, mkImportedName, + nameExportFlag, nameImportFlag, + getLocalName, getSrcLoc, getImpLocs, + moduleNamePair, pprNonSym, + isLexCon, ExportFlag(..), OrigName(..) ) import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) ) -import PrelMods ( fromPrelude, pRELUDE_BUILTIN, pRELUDE, rATIO, iX ) +import PrelMods ( pRELUDE, gHC_BUILTINS, modulesWithBuiltins ) import Pretty import SrcLoc ( SrcLoc, mkBuiltinSrcLoc ) import TyCon ( tyConDataCons ) import UniqFM ( emptyUFM, addListToUFM_C, lookupUFM ) import UniqSupply ( splitUniqSupply ) import Util ( isIn, assoc, cmpPString, sortLt, removeDups, - equivClasses, panic, assertPanic, pprTrace{-ToDo:rm-} + equivClasses, panic, assertPanic, pprPanic{-ToDo:rm-}, pprTrace{-ToDo:rm-} ) +import PprStyle --ToDo:rm \end{code} - \begin{code} type GlobalNameInfo = (BuiltinNames, BuiltinKeys, Name -> ExportFlag, -- export flag - Name -> [RdrName]) -- occurence names + Name -> [RdrName]) -- occurrence names + -- NB: both of the functions are in a *knot* and + -- must be tugged on oh-so-gently... type RnM_Info s r = RnMonad GlobalNameInfo s r @@ -74,7 +78,10 @@ getGlobalNames :: getGlobalNames iface_cache info us (HsModule mod _ _ imports _ ty_decls _ cls_decls _ _ _ binds _ _) - = case initRn True mod emptyRnEnv us1 + = let + (us1, us2) = splitUniqSupply us + in + case initRn True mod emptyRnEnv us1 (setExtraRn info $ getSourceNames ty_decls cls_decls binds) of { ((src_vals, src_tcs), src_errs, src_warns) -> @@ -91,7 +98,7 @@ getGlobalNames iface_cache info us -- remove dups of the same imported thing diff_imp_dups = filterBag diff_orig imp_dups - diff_orig (_,rn1,rn2) = origName rn1 /= origName rn2 + diff_orig (_,rn1,rn2) = origName "diff_orig" rn1 /= origName "diff_orig" rn2 all_dups = bagToList (src_dups `unionBags` diff_imp_dups) dup_errs = map dup_err (equivClasses cmp_rdr all_dups) @@ -101,10 +108,7 @@ getGlobalNames iface_cache info us all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs all_warns = src_warns `unionBags` imp_warns in - return (all_env, imp_mods, unqual_imps, imp_fixes, all_errs, all_warns) - } - where - (us1, us2) = splitUniqSupply us + return (all_env, imp_mods, unqual_imps, imp_fixes, all_errs, all_warns) } \end{code} ********************************************************* @@ -130,12 +134,16 @@ getSourceNames ty_decls cls_decls binds unionManyBags cls_ops_s `unionBags` bind_names, listToBag tycon_s `unionBags` listToBag cls_s) - +-------------- getTyDeclNames :: RdrNameTyDecl -> RnM_Info s (RnName, Bag RnName, Bag RnName) -- tycon, constrs and fields getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc) - = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name -> + = --getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) -> + --pprTrace "getTyDeclNames:" (ppr PprDebug tycon) $ + --pprTrace "getTDN1:" (ppAboves [ ppCat [ppPStr m, ppPStr n] | ((OrigName m n), _) <- fmToList b_tc_names]) $ + + newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name -> getConFieldNames (Just (nameExportFlag tycon_name)) emptyBag emptyBag emptyFM condecls `thenRn` \ (con_names, field_names) -> let @@ -157,6 +165,12 @@ getTyDeclNames (TySynonym tycon _ _ src_loc) = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name -> returnRn (RnSyn tycon_name, emptyBag, emptyBag) +---------------- +getConFieldNames :: Maybe ExportFlag + -> Bag Name -> Bag Name + -> FiniteMap RdrName () + -> [RdrNameConDecl] + -> RnM_Info s ([Name], [Name]) getConFieldNames exp constrs fields have [] = returnRn (bagToList constrs, bagToList fields) @@ -183,6 +197,7 @@ getConFieldNames exp constrs fields have (RecConDecl con fielddecls src_loc : re new_fields = filter (not . maybeToBool . lookupFM have) uniq_fields new_have = addListToFM have (zip new_fields (repeat ())) +------------- getClassNames :: RdrNameClassDecl -> RnM_Info s (RnName, Bag RnName) -- class and class ops @@ -193,8 +208,13 @@ getClassNames (ClassDecl _ cname _ sigs _ _ src_loc) returnRn (RnClass class_name op_names, listToBag (map (\ n -> RnClassOp n class_name) op_names)) -getClassOpNames exp [] - = returnRn [] +--------------- +getClassOpNames :: Maybe ExportFlag + -> [RdrNameSig] + -> RnM_Info s [Name] + +getClassOpNames exp [] = returnRn [] + getClassOpNames exp (ClassOpSig op _ _ src_loc : sigs) = newGlobalName src_loc exp True{-val-} op `thenRn` \ op_name -> getClassOpNames exp sigs `thenRn` \ op_names -> @@ -266,45 +286,65 @@ doName locn rdr ********************************************************* \begin{code} -newGlobalName :: SrcLoc -> Maybe ExportFlag -> Bool{-True<=>value name,False<=>tycon/class-} - -> RdrName -> RnM_Info s Name +newGlobalName :: SrcLoc + -> Maybe ExportFlag + -> Bool{-True<=>value name,False<=>tycon/class-} + -> RdrName + -> RnM_Info s Name + +newGlobalName locn maybe_exp is_val_name (Unqual name) + = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) -> + getModuleRn `thenRn` \ mod -> + rnGetUnique `thenRn` \ u -> + let + orig = OrigName mod name + + (uniq, is_toplev) + = case (lookupFM b_keys orig) of + Just (key,_) -> (key, True) + Nothing -> if not opt_CompilingPrelude then (u,True) else -- really here just to save gratuitous lookup + case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of + Nothing -> (u, True) + Just xx -> (uniqueOf xx, False{-builtin!-}) --- ToDo: b_names and b_keys being defined in this module !!! + exp = case maybe_exp of + Just flag -> flag + Nothing -> rec_exp_fn n -newGlobalName locn maybe_exp is_val_name rdr - = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,exp_fn,occ_fn) -> - getModuleRn `thenRn` \ mod -> - rnGetUnique `thenRn` \ u -> + n = if is_toplev + then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s + else mkWiredInName uniq orig + in + returnRn n + +newGlobalName locn maybe_exp is_val_name rdr@(Qual mod name) + | opt_CompilingPrelude + -- we are actually defining something that compiler knows about (e.g., Bool) + + = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) -> let - unqual = case rdr of { Qual m n -> n; Unqual n -> n } - - orig = if fromPrelude mod - then (Unqual unqual) - else (Qual mod unqual) - - uniq - = let - str_mod = case orig of { Qual m n -> (n, m); Unqual n -> (n, pRELUDE) } - n = fst str_mod - m = snd str_mod - in - --pprTrace "newGlobalName:" (ppAboves ((ppCat [ppPStr n, ppPStr m]) : [ ppCat [ppPStr x, ppPStr y] | (x,y) <- keysFM b_keys])) $ - case (lookupFM b_keys str_mod) of - Just (key,_) -> key - Nothing -> if not opt_CompilingPrelude then u else - case (lookupFM (if is_val_name then b_val_names else b_tc_names) str_mod) of - Nothing -> u - Just xx -> --pprTrace "Using Unique for:" (ppCat [ppPStr n, ppPStr m]) $ - uniqueOf xx + orig = OrigName mod name + + (uniq, is_toplev) + = case (lookupFM b_keys orig) of + Just (key,_) -> (key, True) + Nothing -> case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of + Nothing -> (pprPanic "newGlobalName:Qual:uniq:" (ppr PprDebug rdr), True) + Just xx -> (uniqueOf xx, False{-builtin!-}) exp = case maybe_exp of - Just exp -> exp - Nothing -> exp_fn n + Just flag -> flag + Nothing -> rec_exp_fn n - n = mkTopLevName uniq orig locn exp (occ_fn n) -- NB: two "n"s + n = if is_toplev + then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s + else mkWiredInName uniq orig in - addErrIfRn (isQual rdr) (qualNameErr "name in definition" (rdr, locn)) `thenRn_` returnRn n + + | otherwise + = addErrRn (qualNameErr "name in definition" (rdr, locn)) `thenRn_` + returnRn (pprPanic "newGlobalName:Qual:" (ppr PprDebug rdr)) \end{code} ********************************************************* @@ -314,23 +354,27 @@ newGlobalName locn maybe_exp is_val_name rdr ********************************************************* \begin{code} -type ImportNameInfo = (GlobalNameInfo, - FiniteMap (Module,FAST_STRING) RnName, -- values imported so far - FiniteMap (Module,FAST_STRING) RnName, -- tycons/classes imported so far - Name -> (ExportFlag, [SrcLoc])) -- import flag and src locns - +type ImportNameInfo + = (GlobalNameInfo, + FiniteMap OrigName RnName, -- values imported so far + FiniteMap OrigName RnName, -- tycons/classes imported so far + Name -> (ExportFlag, [SrcLoc])) -- import flag and src locns; + -- NB: this last field is in a knot + -- and mustn't be tugged on! + type RnM_IInfo s r = RnMonad ImportNameInfo s r +------------------------------------------------------------------ doImportDecls :: IfaceCache - -> GlobalNameInfo -- builtin and knot name info + -> GlobalNameInfo -- builtin and knot name info -> UniqSupply - -> [RdrNameImportDecl] -- import declarations - -> IO (Bag (RdrName,RnName), -- imported values in scope - Bag (RdrName,RnName), -- imported tycons/classes in scope - [Module], -- directly imported modules - Bag (Module,RnName), -- unqualified import from module - Bag RenamedFixityDecl, -- fixity info for imported names + -> [RdrNameImportDecl] -- import declarations + -> IO (Bag (RdrName,RnName), -- imported values in scope + Bag (RdrName,RnName), -- imported tycons/classes in scope + [Module], -- directly imported modules + Bag (Module,RnName), -- unqualified import from module + Bag RenamedFixityDecl, -- fixity info for imported names Bag Error, Bag Warning) @@ -362,23 +406,21 @@ doImportDecls iface_cache g_info us src_imps imp_errs `unionBags` errs, imp_warns `unionBags` warns) where - the_imps = implicit_prel ++ src_imps + the_imps = implicit_prel ++ src_imps all_imps = implicit_qprel ++ the_imps - implicit_qprel = if opt_NoImplicitPrelude - then [{- no "import qualified Prelude" -} - ImportDecl pRELUDE_BUILTIN True Nothing Nothing prel_loc - ] - else [ImportDecl pRELUDE True Nothing Nothing prel_loc] + implicit_qprel = ImportDecl gHC_BUILTINS True Nothing Nothing prel_loc + : (if opt_NoImplicitPrelude + then [{- no "import qualified Prelude" -}] + else [ImportDecl pRELUDE True Nothing Nothing prel_loc]) explicit_prelude_imp = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps, mod == pRELUDE ]) - implicit_prel = if explicit_prelude_imp || opt_NoImplicitPrelude - then [{- no "import Prelude" -} - ImportDecl pRELUDE_BUILTIN False Nothing Nothing prel_loc - ] - else [ImportDecl pRELUDE False Nothing Nothing prel_loc] + implicit_prel = ImportDecl gHC_BUILTINS False Nothing Nothing prel_loc + : (if explicit_prelude_imp || opt_NoImplicitPrelude + then [{- no "import Prelude" -}] + else [ImportDecl pRELUDE False Nothing Nothing prel_loc]) prel_loc = mkBuiltinSrcLoc @@ -386,7 +428,7 @@ doImportDecls iface_cache g_info us src_imps cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2 qprel_imps = [ imp | imp@(ImportDecl mod True Nothing _ _) <- src_imps, - fromPrelude mod ] + mod == pRELUDE ] qual_mods = [ (qual_name mod as_mod, imp) | imp@(ImportDecl mod True as_mod _ _) <- src_imps ] qual_name mod (Just as_mod) = as_mod @@ -399,10 +441,9 @@ doImportDecls iface_cache g_info us src_imps all_same_mod ((q,ImportDecl mod _ _ _ _):rest) = all has_same_mod rest where - has_same_mod (q,ImportDecl mod2 _ _ _ _) = mod == mod2 - + has_same_mod (_,ImportDecl mod2 _ _ _ _) = mod == mod2 - imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps, mod /= pRELUDE_BUILTIN ] + imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps, mod /= gHC_BUILTINS ] imp_warns = listToBag (map dupImportWarn imp_dups) `unionBags` @@ -410,22 +451,33 @@ doImportDecls iface_cache g_info us src_imps imp_errs = listToBag (map dupQualImportErr bad_qual_dups) +----------------------- +doImports :: IfaceCache + -> ImportNameInfo + -> UniqSupply + -> [RdrNameImportDecl] -- import declarations + -> IO (Bag (RdrName,RnName), -- imported values in scope + Bag (RdrName,RnName), -- imported tycons/classes in scope + Bag (Module, RnName), -- unqualified import from module + Bag RenamedFixityDecl, -- fixity info for imported names + Bag Error, + Bag Warning, + Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs + doImports iface_cache i_info us [] = return (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag) -doImports iface_cache i_info@(g_info,done_vals,done_tcs,imp_fn) us (imp:imps) - = doImport iface_cache i_info us1 imp + +doImports iface_cache i_info@(g_info,done_vals,done_tcs,rec_imp_fn) us (imp:imps) + = let + (us1, us2) = splitUniqSupply us + in + doImport iface_cache i_info us1 imp >>= \ (vals1, tcs1, unquals1, fixes1, errs1, warns1, imps1) -> let - new_vals = [ (moduleNamePair rn, rn) | (_,rn) <- bagToList vals1, - not (maybeToBool (lookupFM done_vals (moduleNamePair rn))) ] - -- moduleNamePair computed twice - ext_vals = addListToFM done_vals new_vals - - new_tcs = [ (moduleNamePair rn, rn) | (_,rn) <- bagToList tcs1, - not (maybeToBool (lookupFM done_tcs (moduleNamePair rn))) ] - ext_tcs = addListToFM done_tcs new_tcs + ext_vals = foldl add_new_one done_vals (bagToList vals1) + ext_tcs = foldl add_new_one done_tcs (bagToList tcs1) in - doImports iface_cache (g_info,ext_vals,ext_tcs,imp_fn) us2 imps + doImports iface_cache (g_info,ext_vals,ext_tcs,rec_imp_fn) us2 imps >>= \ (vals2, tcs2, unquals2, fixes2, errs2, warns2, imps2) -> return (vals1 `unionBags` vals2, tcs1 `unionBags` tcs2, @@ -435,9 +487,19 @@ doImports iface_cache i_info@(g_info,done_vals,done_tcs,imp_fn) us (imp:imps) warns1 `unionBags` warns2, imps1 `unionBags` imps2) where - (us1, us2) = splitUniqSupply us + add_new_one :: FiniteMap OrigName RnName -- ones done so far + -> (dont_care, RnName) + -> FiniteMap OrigName RnName -- extended + add_new_one fm (_, rn) + = let + orig = origName "add_new_one" rn + in + case (lookupFM fm orig) of + Just _ -> fm -- already there: no change + Nothing -> addToFM fm orig rn +---------------------- doImport :: IfaceCache -> ImportNameInfo -> UniqSupply @@ -454,9 +516,9 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc) = let (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec in - (if mod == pRELUDE_BUILTIN then - return (Succeeded (panic "doImport:PreludeBuiltin"), - \ iface -> ([], [], emptyBag)) + (if mod == gHC_BUILTINS then + return (Succeeded (panic "doImport:GHC fake import!"), + \ iface -> ([], [], emptyBag)) else --pprTrace "doImport:" (ppPStr mod) $ cachedIface False iface_cache mod >>= \ maybe_iface -> @@ -480,16 +542,17 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc) final_tcs = mapBag fst_occ b_tcs `unionBags` mapBag pair_occ ie_tcs final_vals_list = bagToList final_vals in - (if mod == pRELUDE_BUILTIN then + (if mod == gHC_BUILTINS then return [ (Nothing, emptyBag) | _ <- final_vals_list ] else - accumulate (map (getFixityDecl iface_cache) final_vals_list) + accumulate (map (getFixityDecl iface_cache . snd) final_vals_list) ) >>= \ fix_maybes_errs -> let (chk_errs, chk_warns) = unzip chk_errs_warns (fix_maybes, fix_errs) = unzip fix_maybes_errs - unquals = if qual then emptyBag + unquals = if qual{-ified import-} + then emptyBag else mapBag pair_as (ie_vals `unionBags` ie_tcs) final_fixes = listToBag (catMaybes fix_maybes) @@ -503,24 +566,40 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc) return (final_vals, final_tcs, unquals, final_fixes, final_errs, final_warns, imp_stuff) where + as_mod :: Module as_mod = case maybe_as of {Nothing -> mod; Just as_this -> as_this} + + mk_occ :: FAST_STRING -> RdrName mk_occ str = if qual then Qual as_mod str else Unqual str + fst_occ :: (FAST_STRING, RnName) -> (RdrName, RnName) fst_occ (str, rn) = (mk_occ str, rn) - pair_occ rn = (mk_occ (getLocalName rn), rn) - pair_as rn = (as_mod, rn) + pair_occ :: RnName -> (RdrName, RnName) + pair_occ rn = (mk_occ (getLocalName rn), rn) + + pair_as :: RnName -> (Module, RnName) + pair_as rn = (as_mod, rn) -getBuiltins _ mod maybe_spec - | not (fromPrelude mod || mod == iX || mod == rATIO) +----------------------------- +getBuiltins :: ImportNameInfo + -> Module + -> Maybe (Bool, [RdrNameIE]) + -> (Bag (FAST_STRING, RnName), + Bag (FAST_STRING, RnName), + Maybe (Bool, [RdrNameIE]) -- return IEs that had no effect + ) + +getBuiltins _ modname maybe_spec + | modname `notElem` modulesWithBuiltins = (emptyBag, emptyBag, maybe_spec) -getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec +getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) modname maybe_spec = case maybe_spec of Nothing -> (all_vals, all_tcs, Nothing) Just (True, ies) -> -- hiding does not work for builtin names - trace "getBuiltins: import Prelude hiding ( ... )" $ + trace "NOTE: `import Prelude hiding ...' does not hide built-in names" $ (all_vals, all_tcs, maybe_spec) Just (False, ies) -> let @@ -531,20 +610,21 @@ getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec all_vals = do_all_builtin (fmToList b_val_names) all_tcs = do_all_builtin (fmToList b_tc_names) - filter_mod = if fromPrelude mod then pRELUDE else mod - do_all_builtin [] = emptyBag - do_all_builtin (((str,mod),rn):rest) - | mod == filter_mod - = (str, rn) `consBag` do_all_builtin rest - | otherwise - = do_all_builtin rest + do_all_builtin (((OrigName mod str),rn):rest) + = --pprTrace "do_all_builtin:" (ppCat [ppPStr modname, ppPStr mod, ppPStr str]) $ + (if mod == modname then consBag (str, rn) else id) (do_all_builtin rest) do_builtin [] = (emptyBag,emptyBag,[]) do_builtin (ie:ies) - = let str = unqual_str (ie_name ie) + = let + (str, orig) + = case (ie_name ie) of + Unqual s -> (s, OrigName modname s) + Qual m s -> pprTrace "do_builtin:surprising qual!" (ppCat [ppPStr m, ppPStr s]) $ + (s, OrigName modname s) in - case (lookupFM b_tc_names (str,mod)) of -- NB: we favour the tycon/class FM... + case (lookupFM b_tc_names orig) of -- NB: we favour the tycon/class FM... Just rn -> case (ie,rn) of (IEThingAbs _, WiredInTyCon tc) -> (vals, (str, rn) `consBag` tcs, ies_left) @@ -554,14 +634,14 @@ getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec `unionBags` vals, (str,rn) `consBag` tcs, ies_left) (IEThingWith _ _, WiredInTyCon tc) -- No checking of With... - -> (listToBag (map (\ id -> (getLocalName id, WiredInId id)) + -> (listToBag (map (\ id -> (nameOf (origName "IEThingWith" id), WiredInId id)) (tyConDataCons tc)) `unionBags` vals, (str,rn) `consBag` tcs, ies_left) _ -> panic "importing builtin names (1)" Nothing -> - case (lookupFM b_val_names (str,mod)) of + case (lookupFM b_val_names orig) of Nothing -> (vals, tcs, ie:ies_left) Just rn -> case (ie,rn) of (IEVar _, WiredInId _) @@ -570,6 +650,12 @@ getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec where (vals, tcs, ies_left) = do_builtin ies +------------------------- +getOrigIEs :: ParsedIface + -> Maybe (Bool, [RdrNameIE]) -- "hiding" or not, blah, blah, blah + -> ([IE OrigName], + [(IE OrigName, ExportFlag)], + Bag (Module -> SrcLoc -> Error)) getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all = (map mkAllIE (eltsFM exps), [], emptyBag) @@ -585,42 +671,59 @@ getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- imp where (found_ies, errs) = lookupIEs exps ies +------------------------------------------------ +mkAllIE :: (OrigName, ExportFlag) -> IE OrigName mkAllIE (orig,ExportAbs) - = ASSERT(isLexCon (getLocalName orig)) + = ASSERT(isLexCon (nameOf orig)) IEThingAbs orig mkAllIE (orig, ExportAll) - | isLexCon (getLocalName orig) + | isLexCon (nameOf orig) = IEThingAll orig | otherwise = IEVar orig +------------ +lookupIEs :: ExportsMap + -> [RdrNameIE] + -> ([(IE OrigName, ExportFlag)], -- IEs we found, orig-ified + Bag (Module -> SrcLoc -> Error)) -lookupIEs exps [] - = ([], emptyBag) -lookupIEs exps (ie:ies) - = case lookupFM exps (unqual_str (ie_name ie)) of - Nothing -> - (orig_ies, unknownImpSpecErr ie `consBag` errs) - Just (orig,flag) -> - (orig_ie orig flag ie ++ orig_ies, - adderr_if (seen_ie orig orig_ies) (duplicateImpSpecErr ie) errs) +lookupIEs exps ies + = foldr go ([], emptyBag) ies where - (orig_ies, errs) = lookupIEs exps ies - - orig_ie orig flag (IEVar n) = [(IEVar orig, flag)] - orig_ie orig flag (IEThingAbs n) = [(IEThingAbs orig, flag)] - orig_ie orig flag (IEThingAll n) = [(IEThingAll orig, flag)] - orig_ie orig flag (IEThingWith n ns) = [(IEThingWith orig ns, flag)] + go ie (already, errs) + = let + str = case (ie_name ie) of + Unqual s -> s + Qual m s -> s + in + case (lookupFM exps str) of + Nothing -> + (already, unknownImpSpecErr ie `consBag` errs) + Just (orig, flag) -> + ((orig_ie orig ie, flag) : already, + adderr_if (seen_ie orig already) (duplicateImpSpecErr ie) errs) + + orig_ie orig (IEVar n) = IEVar orig + orig_ie orig (IEThingAbs n) = IEThingAbs orig + orig_ie orig (IEThingAll n) = IEThingAll orig + orig_ie orig (IEThingWith n ns) = IEThingWith orig (map re_orig ns) + where + (OrigName mod _) = orig + re_orig (Unqual s) = OrigName mod s seen_ie orig seen_ies = any (\ (ie,_) -> orig == ie_name ie) seen_ies - +-------------------------------------------- doOrigIEs iface_cache info mod src_loc us [] = return (emptyBag,emptyBag,emptyBag,emptyBag,emptyBag) doOrigIEs iface_cache info mod src_loc us (ie:ies) - = doOrigIE iface_cache info mod src_loc us1 ie + = let + (us1, us2) = splitUniqSupply us + in + doOrigIE iface_cache info mod src_loc us1 ie >>= \ (vals1, tcs1, imps1, errs1, warns1) -> doOrigIEs iface_cache info mod src_loc us2 ies >>= \ (vals2, tcs2, imps2, errs2, warns2) -> @@ -629,8 +732,19 @@ doOrigIEs iface_cache info mod src_loc us (ie:ies) imps1 `unionBags` imps2, errs1 `unionBags` errs2, warns1 `unionBags` warns2) - where - (us1, us2) = splitUniqSupply us + +---------------------- +doOrigIE :: IfaceCache + -> ImportNameInfo + -> Module + -> SrcLoc + -> UniqSupply + -> IE OrigName + -> IO (Bag RnName, -- values + Bag RnName, -- tycons/classes + Bag (RnName,ExportFlag), -- import flags + Bag Error, + Bag Warning) doOrigIE iface_cache info mod src_loc us ie = with_decl iface_cache (ie_name ie) @@ -642,6 +756,11 @@ doOrigIE iface_cache info mod src_loc us ie of ((vals, tcs, imps), errs, warns) -> (vals, tcs, imps, errs, warns)) +------------------------- +checkOrigIE :: IfaceCache + -> (IE OrigName, ExportFlag) + -> IO (Bag (Module -> SrcLoc -> Error), Bag (Module -> SrcLoc -> Warning)) + checkOrigIE iface_cache (IEThingAll n, ExportAbs) = with_decl iface_cache n (\ err -> (unitBag (\ mod locn -> err), emptyBag)) @@ -660,26 +779,36 @@ checkOrigIE iface_cache (IEThingWith n ns, ExportAll) DataSig _ cons fields _ _ -> (check_with "constructors (and fields)" (cons++fields) ns, emptyBag) ClassSig _ ops _ _ -> (check_with "class ops" ops ns, emptyBag)) where - check_with str has rdrs - | sortLt (<) (map getLocalName has) == sortLt (<) (map unqual_str rdrs) + check_with str has origs + | sortLt (<) (map getLocalName has) == sortLt (<) (map nameOf origs) = emptyBag | otherwise - = unitBag (withImpSpecErr str n has rdrs) + = unitBag (withImpSpecErr str n has origs) checkOrigIE iface_cache other = return (emptyBag, emptyBag) +----------------------- +with_decl :: IfaceCache + -> OrigName + -> (Error -> something) -- if an error... + -> (RdrIfaceDecl -> something) -- if OK... + -> IO something with_decl iface_cache n do_err do_decl - = cachedDecl iface_cache (isRdrLexCon n) n >>= \ maybe_decl -> + = cachedDecl iface_cache (isLexCon (nameOf n)) n >>= \ maybe_decl -> case maybe_decl of - Failed err -> return (do_err err) + Failed err -> return (do_err err) Succeeded decl -> return (do_decl decl) +------------- +getFixityDecl :: IfaceCache + -> RnName + -> IO (Maybe RenamedFixityDecl, Bag Error) -getFixityDecl iface_cache (_,rn) +getFixityDecl iface_cache rn = let - (mod, str) = moduleNamePair rn + (OrigName mod str) = origName "getFixityDecl" rn succeeded infx i = return (Just (infx rn i), emptyBag) in @@ -699,10 +828,7 @@ ie_name (IEThingAbs n) = n ie_name (IEThingAll n) = n ie_name (IEThingWith n _) = n -unqual_str (Unqual str) = str -unqual_str q@(Qual _ _) = panic "unqual_str" - -adderr_if True err errs = err `consBag` errs +adderr_if True err errs = err `consBag` errs adderr_if False err errs = errs \end{code} @@ -713,7 +839,7 @@ adderr_if False err errs = errs ********************************************************* \begin{code} -getIfaceDeclNames :: RdrNameIE -> RdrIfaceDecl +getIfaceDeclNames :: IE OrigName -> RdrIfaceDecl -> RnM_IInfo s (Bag RnName, -- values Bag RnName, -- tycons/classes Bag (RnName,ExportFlag)) -- import flags @@ -799,32 +925,33 @@ newImportedName :: Bool -- True => tycon or class -> RnM_IInfo s Name newImportedName tycon_or_class locn maybe_exp maybe_imp rdr - = getExtraRn `thenRn` \ ((_,b_keys,exp_fn,occ_fn),done_vals,done_tcs,imp_fn) -> - case if tycon_or_class - then lookupFM done_tcs (moduleNamePair rdr) - else lookupFM done_vals (moduleNamePair rdr) - of - Just rn -> returnRn (getName rn) - Nothing -> + = let + orig = qualToOrigName rdr + in + getExtraRn `thenRn` \ ((_,b_keys,rec_exp_fn,rec_occ_fn),done_vals,done_tcs,rec_imp_fn) -> + case ((if tycon_or_class + then lookupFM done_tcs + else lookupFM done_vals) orig) of + + Just rn -> returnRn (getName rn) + Nothing -> rnGetUnique `thenRn` \ u -> let - str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n,pRELUDE) } - - uniq = case lookupFM b_keys str_mod of + uniq = case lookupFM b_keys orig of Nothing -> u Just (key,_) -> key exp = case maybe_exp of - Just exp -> exp - Nothing -> exp_fn n + Just xx -> xx + Nothing -> rec_exp_fn n imp = case maybe_imp of - Just imp -> imp - Nothing -> imp_flag + Just xx -> xx + Nothing -> imp_flag - (imp_flag, imp_locs) = imp_fn n + (imp_flag, imp_locs) = rec_imp_fn n - n = mkImportedName uniq rdr imp locn imp_locs exp (occ_fn n) -- NB: two "n"s + n = mkImportedName uniq orig imp locn imp_locs exp (rec_occ_fn n) -- NB: two "n"s in returnRn n \end{code} diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 64f64c5..3831ec0 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -21,12 +21,13 @@ import RnUtils ( lookupGlobalRnEnv, lubExportFlag ) import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList ) import Class ( derivableClassKeys ) +import CmdLineOpts ( opt_CompilingPrelude ) import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine ) import FiniteMap ( emptyFM, lookupFM, addListToFM_C ) import ListSetOps ( unionLists, minusList ) import Maybes ( maybeToBool, catMaybes ) -import Name ( Name, isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..), - nameImportFlag, RdrName, pprNonSym ) +import Name ( isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..), + nameImportFlag, RdrName, pprNonSym, Name ) import Outputable -- ToDo:rm import PprStyle -- ToDo:rm import Pretty @@ -589,7 +590,10 @@ rnFixes fixities rn_fixity_pieces mk_fixity name i fix = getRnEnv `thenRn` \ env -> case lookupGlobalRnEnv env name of - Just res | isLocallyDefined res + Just res | isLocallyDefined res || opt_CompilingPrelude + -- the opt_CompilingPrelude thing is a *HACK* to get (:)'s + -- fixity decl to go through. It has a builtin name, which + -- doesn't respond to isLocallyDefined... sigh. -> returnRn (Just (mk_fixity res i)) _ -> failButContinueRn Nothing (undefinedFixityDeclErr src_loc fix) in diff --git a/ghc/compiler/rename/RnUtils.lhs b/ghc/compiler/rename/RnUtils.lhs index 7205e91..7e50792 100644 --- a/ghc/compiler/rename/RnUtils.lhs +++ b/ghc/compiler/rename/RnUtils.lhs @@ -21,6 +21,7 @@ module RnUtils ( IMP_Ubiq(){-uitous-} import Bag ( Bag, emptyBag, snocBag, unionBags ) +import CmdLineOpts ( opt_CompilingPrelude ) import ErrUtils ( addShortErrLocLine ) import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, lookupFM, addListToFM, addToFM ) @@ -38,7 +39,7 @@ import Util ( assertPanic ) * * ********************************************************* -Seperate FiniteMaps are kept for lookup up Qual names, +Separate FiniteMaps are kept for lookup up Qual names, Unqual names and Local names. \begin{code} @@ -127,7 +128,10 @@ extendLocalRnEnv report_shadows (global, stack) new_local lookupRnEnv ((qual, unqual, _, _), stack) rdr = case rdr of Unqual str -> lookup stack str (lookup unqual str Nothing) - Qual mod str -> lookup qual (str,mod) Nothing + Qual mod str -> lookup qual (str,mod) + (if not opt_CompilingPrelude -- see below + then Nothing + else lookup unqual str Nothing) where lookup fm thing do_on_fail = case lookupFM fm thing of @@ -137,12 +141,25 @@ lookupRnEnv ((qual, unqual, _, _), stack) rdr lookupGlobalRnEnv ((qual, unqual, _, _), _) rdr = case rdr of Unqual str -> lookupFM unqual str - Qual mod str -> lookupFM qual (str,mod) + Qual mod str -> case (lookupFM qual (str,mod)) of + Just xx -> Just xx + Nothing -> if not opt_CompilingPrelude then + Nothing + else -- "[]" may have turned into "Prelude.[]" and + -- we are actually compiling "data [] a = ..."; + -- maybe the right thing is to get "Prelude.[]" + -- into the "qual" table... + lookupFM unqual str lookupTcRnEnv ((_, _, tc_qual, tc_unqual), _) rdr = case rdr of Unqual str -> lookupFM tc_unqual str - Qual mod str -> lookupFM tc_qual (str,mod) + Qual mod str -> case (lookupFM tc_qual (str,mod)) of -- as above + Just xx -> Just xx + Nothing -> if not opt_CompilingPrelude then + Nothing + else + lookupFM tc_unqual str \end{code} ********************************************************* diff --git a/ghc/compiler/simplCore/FoldrBuildWW.lhs b/ghc/compiler/simplCore/FoldrBuildWW.lhs index e5903cb..40fbba2 100644 --- a/ghc/compiler/simplCore/FoldrBuildWW.lhs +++ b/ghc/compiler/simplCore/FoldrBuildWW.lhs @@ -157,8 +157,8 @@ try_split_bind id expr = -- right function to use .. -- Now the bodies - c_id = mkSysLocal SLIT("_fbww") c_new_uq c_ty mkUnknownSrcLoc - n_id = mkSysLocal SLIT("_fbww") n_new_uq n_ty mkUnknownSrcLoc + c_id = mkSysLocal SLIT("fbww") c_new_uq c_ty mkUnknownSrcLoc + n_id = mkSysLocal SLIT("fbww") n_new_uq n_ty mkUnknownSrcLoc worker_rhs = mkTyLam [] (big_args ++ [alphaTyVar]) (args++[c_id,n_id]) worker_body diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index cdb26cb..4d36323 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -18,6 +18,7 @@ module OccurAnal ( ) where IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(IdLoop) -- paranoia import BinderInfo import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) ) diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs index 58574cd..8e7656b 100644 --- a/ghc/compiler/simplCore/SimplCase.lhs +++ b/ghc/compiler/simplCore/SimplCase.lhs @@ -35,7 +35,7 @@ import SimplEnv import SimplMonad import SimplUtils ( mkValLamTryingEta ) import Type ( isPrimType, maybeAppDataTyConExpandingDicts, mkFunTys, eqTy ) -import TysWiredIn ( voidTy ) +import TysPrim ( voidTy ) import Unique ( Unique{-instance Eq-} ) import Usage ( GenUsage{-instance Eq-} ) import Util ( isIn, isSingleton, zipEqual, panic, assertPanic ) diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs index 68d6816..62d9a01 100644 --- a/ghc/compiler/specialise/SpecUtils.lhs +++ b/ghc/compiler/specialise/SpecUtils.lhs @@ -33,12 +33,11 @@ import Id ( idType, isDictFunId, isConstMethodId_maybe, GenId {-instance NamedThing -} ) import Maybes ( maybeToBool, catMaybes, firstJust ) -import Name ( isLexVarSym, isLexSpecialSym, pprNonSym, moduleNamePair ) +import Name ( origName, isLexVarSym, isLexSpecialSym, pprNonSym ) import PprStyle ( PprStyle(..) ) import PprType ( pprGenType, pprParendGenType, pprMaybeTy, TyCon{-ditto-}, GenType{-ditto-}, GenTyVar ) -import PrelMods ( fromPrelude, pRELUDE ) import Pretty -- plenty of it import TyCon ( tyConTyVars, TyCon{-instance NamedThing-} ) import Type ( splitSigmaTy, mkTyVarTy, mkForAllTys, @@ -235,18 +234,16 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs | isDictFunId id || maybeToBool (isConstMethodId_maybe id) = let get_mod = getInstIdModule id - use_mod = if fromPrelude get_mod - then pRELUDE - else get_mod + use_mod = get_mod in (use_mod, _NIL_) | otherwise - = moduleNamePair id + = case (origName "get_id_name" id) of { OrigName m n -> (m, n) } get_ty_data (ty, tys) = (mod_name, [(ty_name, ty, tys)]) where - (mod_name,ty_name) = moduleNamePair ty + (OrigName mod_name ty_name) = origName "get_ty_data" ty module_names = concat [keysFM idspecs_fm, keysFM tyspecs_fm] mods = map head (equivClasses _CMP_STRING_ module_names) @@ -257,8 +254,7 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs EQ_ -> ([_NIL_], tail mods) other -> ([], mods) - (prels, others) = partition fromPrelude known - use_modules = unks ++ prels ++ others + use_modules = unks ++ known pp_module_specs :: FAST_STRING -> Pretty pp_module_specs mod @@ -313,7 +309,7 @@ pp_idspec sty pp_mod (_, id, tys, is_err) | is_const_method_id = let Just (cls, clsty, clsop) = const_method_maybe - (_, cls_str) = moduleNamePair cls + (OrigName _ cls_str) = origName "pp_idspec" cls clsop_str = classOpString clsop in ppCat [pp_mod, @@ -327,7 +323,7 @@ pp_idspec sty pp_mod (_, id, tys, is_err) | is_default_method_id = let Just (cls, clsop, _) = default_method_maybe - (_, cls_str) = moduleNamePair cls + (OrigName _ cls_str) = origName "pp_idspec2" cls clsop_str = classOpString clsop in ppCat [pp_mod, diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index a707068..59e1c40 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -202,6 +202,7 @@ coreBindToStg env (NonRec binder rhs) else [] -- Discard it in + -- pprTrace "coreBindToStg:" (ppCat [ppr PprDebug binder, ppr PprDebug (isExported binder)]) $ case stg_rhs of StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) -> -- Trivial RHS, so augment envt, and ditch the binding diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 2aacbfe..562cd6c 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -31,7 +31,7 @@ module Inst ( IMP_Ubiq() import HsSyn ( HsLit(..), HsExpr(..), HsBinds, - InPat, OutPat, Stmt, Qual, Match, + InPat, OutPat, Stmt, Qualifier, Match, ArithSeqInfo, PolyType, Fake ) import RnHsSyn ( RenamedArithSeqInfo(..), RenamedHsExpr(..) ) import TcHsSyn ( TcIdOcc(..), TcExpr(..), TcIdBndr(..), diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 0393618..90a5af4 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -15,7 +15,7 @@ IMP_Ubiq() import HsSyn ( ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..), HsLit(..), OutPat(..), Sig(..), PolyType(..), MonoType, - Stmt, Qual, ArithSeqInfo, InPat, Fake ) + Stmt, Qualifier, ArithSeqInfo, InPat, Fake ) import HsPragmas ( ClassPragmas(..) ) import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..), RenamedClassOpSig(..), RenamedMonoBinds(..), @@ -43,7 +43,7 @@ import Class ( GenClass, mkClass, mkClassOp, classBigSig, import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId, idType ) import IdInfo ( noIdInfo ) -import Name ( isLocallyDefined, moduleNamePair, getLocalName ) +import Name ( isLocallyDefined, origName, getLocalName ) import PrelVals ( nO_DEFAULT_METHOD_ERROR_ID ) import PprStyle import Pretty @@ -615,7 +615,7 @@ makeClassDeclDefaultMethodRhs clas method_ids tag -} where - (clas_mod, clas_name) = moduleNamePair clas + (OrigName clas_mod clas_name) = origName "makeClassDeclDefaultMethodRhs" clas method_id = method_ids !! (tag-1) class_op = (classOps clas) !! (tag-1) diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 7304d60..e699cc0 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -33,13 +33,12 @@ import RnBinds ( rnMethodBinds, rnTopBinds ) import Bag ( emptyBag{-ToDo:rm-}, Bag, isEmptyBag, unionBags, listToBag ) import Class ( classKey, needsDataDeclCtxtClassKeys, GenClass ) -import CmdLineOpts ( opt_CompilingPrelude ) import ErrUtils ( pprBagOfErrors, addErrLoc, Error(..) ) import Id ( dataConArgTys, isNullaryDataCon, mkDictFunId ) import Maybes ( maybeToBool, Maybe(..) ) -import Name ( moduleNamePair, isLocallyDefined, getSrcLoc, +import Name ( isLocallyDefined, getSrcLoc, mkTopLevName, origName, mkImplicitName, ExportFlag(..), - RdrName{-instance Outputable-}, Name{--O only-} + RdrName(..), Name{--O only-} ) import Outputable ( Outputable(..){-instances e.g., (,)-} ) import PprType ( GenType, GenTyVar, GenClass, TyCon ) @@ -56,7 +55,7 @@ import Type ( GenType(..), TauType(..), mkTyVarTys, applyTyCon, mkSigmaTy, mkDictTy, isPrimType, instantiateTy, getAppDataTyCon, getAppTyCon ) -import TysWiredIn ( voidTy ) +import TysPrim ( voidTy ) import TyVar ( GenTyVar ) import UniqFM ( emptyUFM ) import Unique -- Keys stuff @@ -223,7 +222,7 @@ tcDeriving modname rn_env inst_decl_infos_in fixities gen_tag_n_con_binds rn_env nm_alist_etc `thenTc` \ (extra_binds, deriver_rn_env) -> - mapTc (gen_inst_info maybe_mod fixities deriver_rn_env) new_inst_infos + mapTc (gen_inst_info modname fixities deriver_rn_env) new_inst_infos `thenTc` \ really_new_inst_infos -> let ddump_deriv = ddump_deriving really_new_inst_infos extra_binds @@ -234,8 +233,6 @@ tcDeriving modname rn_env inst_decl_infos_in fixities extra_binds, ddump_deriv) where - maybe_mod = if opt_CompilingPrelude then Nothing else Just modname - ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty) ddump_deriving inst_infos extra_binds sty @@ -558,7 +555,7 @@ the renamer. What a great hack! \end{itemize} \begin{code} -gen_inst_info :: Maybe Module -- Module name; Nothing => Prelude +gen_inst_info :: Module -- Module name -> [RenamedFixityDecl] -- all known fixities; -- may be needed for Text -> RnEnv -- lookup stuff for names we may use @@ -626,7 +623,7 @@ gen_inst_info modname fixities deriver_rn_env from_here modname locn []) where clas_key = classKey clas - clas_Name = RnImplicitClass (mkImplicitName clas_key (origName clas)) + clas_Name = RnImplicitClass (mkImplicitName clas_key (origName "gen_inst_info" clas)) \end{code} %************************************************************************ @@ -660,7 +657,8 @@ gen_tag_n_con_binds rn_env nm_alist_etc in tcGetUniques (length names_to_add) `thenNF_Tc` \ uniqs -> let - pairs_to_add = [ (pn, mkRnName (mkTopLevName u pn mkGeneratedSrcLoc ExportAll [])) + pairs_to_add = [ case pn of { Qual pnm pnn -> + (pn, mkRnName (mkTopLevName u (OrigName pnm pnn) mkGeneratedSrcLoc ExportAll [])) } | (pn,u) <- zipEqual "gen_tag..." names_to_add uniqs ] deriver_rn_env diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index a45dc27..11f6365 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -10,7 +10,7 @@ module TcExpr ( tcExpr ) where IMP_Ubiq() -import HsSyn ( HsExpr(..), Qual(..), Stmt(..), +import HsSyn ( HsExpr(..), Qualifier(..), Stmt(..), HsBinds(..), Bind(..), MonoBinds(..), ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds, Match, Fake, InPat, OutPat, PolyType, diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 7438517..d79ca49 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -65,7 +65,7 @@ module TcGenDeriv ( IMP_Ubiq() import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..), - GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qual(..), Stmt, + GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qualifier(..), Stmt, ArithSeqInfo, Sig, PolyType, FixityDecl, Fake ) import RdrHsSyn ( RdrNameMonoBinds(..), RdrNameHsExpr(..), RdrNamePat(..) ) import RnHsSyn ( RenamedFixityDecl(..) ) @@ -76,8 +76,8 @@ import Id ( GenId, dataConArity, isNullaryDataCon, dataConTag, isDataCon, DataCon(..), ConTag(..) ) import IdUtils ( primOpId ) import Maybes ( maybeToBool ) -import Name ( moduleNamePair, origName, RdrName(..) ) -import PrelMods ( fromPrelude, pRELUDE, pRELUDE_BUILTIN, pRELUDE_LIST, pRELUDE_TEXT ) +import Name ( origName, preludeQual, nameOf, RdrName(..), OrigName(..) ) +import PrelMods ( pRELUDE, gHC__, iX ) import PrelVals ( eRROR_ID ) import PrimOp ( PrimOp(..) ) @@ -199,7 +199,7 @@ gen_Eq_binds tycon con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed) con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed) - data_con_PN = origName data_con + data_con_PN = qual_orig_name data_con con_arity = dataConArity data_con as_needed = take con_arity as_PNs bs_needed = take con_arity bs_PNs @@ -359,7 +359,7 @@ gen_Ord_binds tycon con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed) con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed) - data_con_PN = origName data_con + data_con_PN = qual_orig_name data_con con_arity = dataConArity data_con as_needed = take con_arity as_PNs bs_needed = take con_arity bs_PNs @@ -487,8 +487,8 @@ gen_Bounded_binds tycon data_con_1 = head data_cons data_con_N = last data_cons - data_con_1_PN = origName data_con_1 - data_con_N_PN = origName data_con_N + data_con_1_PN = qual_orig_name data_con_1 + data_con_N_PN = qual_orig_name data_con_N ----- single-constructor-flavored: ------------- arity = dataConArity data_con_1 @@ -565,7 +565,7 @@ gen_Ix_binds tycon then enum_ixes else single_con_ixes where - tycon_str = _UNPK_ (snd (moduleNamePair tycon)) + tycon_str = _UNPK_ (nameOf (origName "gen_Ix_binds" tycon)) -------------------------------------------------------------- enum_ixes = enum_range `AndMonoBinds` @@ -623,7 +623,7 @@ gen_Ix_binds tycon dc con_arity = dataConArity data_con - data_con_PN = origName data_con + data_con_PN = qual_orig_name data_con con_pat xs = ConPatIn data_con_PN (map VarPatIn xs) con_expr xs = mk_easy_App data_con_PN xs @@ -697,8 +697,8 @@ gen_Read_binds fixities tycon where read_con data_con -- note: "b" is the string being "read" = let - data_con_PN = origName data_con - data_con_str= snd (moduleNamePair data_con) + data_con_PN = qual_orig_name data_con + data_con_str= nameOf (origName "gen_Read_binds" data_con) con_arity = dataConArity data_con as_needed = take con_arity as_PNs bs_needed = take con_arity bs_PNs @@ -756,14 +756,14 @@ gen_Show_binds fixities tycon where pats_etc data_con = let - data_con_PN = origName data_con + data_con_PN = qual_orig_name data_con con_arity = dataConArity data_con bs_needed = take con_arity bs_PNs con_pat = ConPatIn data_con_PN (map VarPatIn bs_needed) nullary_con = isNullaryDataCon data_con show_con - = let (mod, nm) = moduleNamePair data_con + = let (OrigName mod nm) = origName "gen_Show_binds" data_con space_maybe = if nullary_con then _NIL_ else SLIT(" ") in HsApp (HsVar showString_PN) (HsLit (HsString (nm _APPEND_ space_maybe))) @@ -824,7 +824,7 @@ gen_tag_n_con_monobind (pn, tycon, GenCon2Tag) ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))) where pat = ConPatIn var_PN (nOfThem (dataConArity var) WildPatIn) - var_PN = origName var + var_PN = qual_orig_name var gen_tag_n_con_monobind (pn, tycon, GenTag2Con) = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon)) @@ -836,7 +836,7 @@ gen_tag_n_con_monobind (pn, tycon, GenTag2Con) ([lit_pat], HsVar var_PN) where lit_pat = ConPatIn mkInt_PN [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))] - var_PN = origName var + var_PN = qual_orig_name var gen_tag_n_con_monobind (pn, tycon, GenMaxTag) = mk_easy_FunMonoBind pn [] [] (HsApp (HsVar mkInt_PN) (HsLit (HsIntPrim max_tag))) @@ -1040,6 +1040,8 @@ parenify e = HsPar e \end{code} \begin{code} +qual_orig_name n = case (origName "qual_orig_name" n) of { OrigName m n -> Qual m n } + a_PN = Unqual SLIT("a") b_PN = Unqual SLIT("b") c_PN = Unqual SLIT("c") @@ -1049,42 +1051,40 @@ bh_PN = Unqual SLIT("b#") ch_PN = Unqual SLIT("c#") dh_PN = Unqual SLIT("d#") cmp_eq_PN = Unqual SLIT("cmp_eq") -rangeSize_PN = Unqual SLIT("rangeSize") +rangeSize_PN = Qual iX SLIT("rangeSize") as_PNs = [ Unqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ] bs_PNs = [ Unqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ] cs_PNs = [ Unqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ] -eq_PN = prelude_method SLIT("Eq") SLIT("==") -ne_PN = prelude_method SLIT("Eq") SLIT("/=") -le_PN = prelude_method SLIT("Ord") SLIT("<=") -lt_PN = prelude_method SLIT("Ord") SLIT("<") -ge_PN = prelude_method SLIT("Ord") SLIT(">=") -gt_PN = prelude_method SLIT("Ord") SLIT(">") -max_PN = prelude_method SLIT("Ord") SLIT("max") -min_PN = prelude_method SLIT("Ord") SLIT("min") -compare_PN = prelude_method SLIT("Ord") SLIT("compare") -minBound_PN = prelude_method SLIT("Bounded") SLIT("minBound") -maxBound_PN = prelude_method SLIT("Bounded") SLIT("maxBound") -ltTag_PN = Unqual SLIT("LT") -eqTag_PN = Unqual SLIT("EQ") -gtTag_PN = Unqual SLIT("GT") -enumFrom_PN = prelude_method SLIT("Enum") SLIT("enumFrom") -enumFromTo_PN = prelude_method SLIT("Enum") SLIT("enumFromTo") -enumFromThen_PN = prelude_method SLIT("Enum") SLIT("enumFromThen") -enumFromThenTo_PN= prelude_method SLIT("Enum") SLIT("enumFromThenTo") -range_PN = prelude_method SLIT("Ix") SLIT("range") -index_PN = prelude_method SLIT("Ix") SLIT("index") -inRange_PN = prelude_method SLIT("Ix") SLIT("inRange") -readsPrec_PN = prelude_method SLIT("Read") SLIT("readsPrec") -readList_PN = prelude_method SLIT("Read") SLIT("readList") -showsPrec_PN = prelude_method SLIT("Show") SLIT("showsPrec") -showList_PN = prelude_method SLIT("Show") SLIT("showList") -plus_PN = prelude_method SLIT("Num") SLIT("+") -times_PN = prelude_method SLIT("Num") SLIT("*") - -false_PN = prelude_val pRELUDE SLIT("False") -true_PN = prelude_val pRELUDE SLIT("True") +eq_PN = preludeQual {-SLIT("Eq")-} SLIT("==") +ne_PN = preludeQual {-SLIT("Eq")-} SLIT("/=") +le_PN = preludeQual {-SLIT("Ord")-} SLIT("<=") +lt_PN = preludeQual {-SLIT("Ord")-} SLIT("<") +ge_PN = preludeQual {-SLIT("Ord")-} SLIT(">=") +gt_PN = preludeQual {-SLIT("Ord")-} SLIT(">") +max_PN = preludeQual {-SLIT("Ord")-} SLIT("max") +min_PN = preludeQual {-SLIT("Ord")-} SLIT("min") +compare_PN = preludeQual {-SLIT("Ord")-} SLIT("compare") +minBound_PN = preludeQual {-SLIT("Bounded")-} SLIT("minBound") +maxBound_PN = preludeQual {-SLIT("Bounded")-} SLIT("maxBound") +enumFrom_PN = preludeQual {-SLIT("Enum")-} SLIT("enumFrom") +enumFromTo_PN = preludeQual {-SLIT("Enum")-} SLIT("enumFromTo") +enumFromThen_PN = preludeQual {-SLIT("Enum")-} SLIT("enumFromThen") +enumFromThenTo_PN= preludeQual {-SLIT("Enum")-} SLIT("enumFromThenTo") +range_PN = Qual iX SLIT("range") +index_PN = Qual iX SLIT("index") +inRange_PN = Qual iX SLIT("inRange") +readsPrec_PN = preludeQual {-SLIT("Read")-} SLIT("readsPrec") +readList_PN = preludeQual {-SLIT("Read")-} SLIT("readList") +showsPrec_PN = preludeQual {-SLIT("Show")-} SLIT("showsPrec") +showList_PN = preludeQual {-SLIT("Show")-} SLIT("showList") +plus_PN = preludeQual {-SLIT("Num")-} SLIT("+") +times_PN = preludeQual {-SLIT("Num")-} SLIT("*") +ltTag_PN = preludeQual SLIT("LT") +eqTag_PN = preludeQual SLIT("EQ") +gtTag_PN = preludeQual SLIT("GT") + eqH_Char_PN = prelude_primop CharEqOp ltH_Char_PN = prelude_primop CharLtOp eqH_Word_PN = prelude_primop WordEqOp @@ -1100,24 +1100,25 @@ ltH_Int_PN = prelude_primop IntLtOp geH_PN = prelude_primop IntGeOp leH_PN = prelude_primop IntLeOp minusH_PN = prelude_primop IntSubOp -and_PN = prelude_val pRELUDE SLIT("&&") -not_PN = prelude_val pRELUDE SLIT("not") -append_PN = prelude_val pRELUDE_LIST SLIT("++") -map_PN = prelude_val pRELUDE_LIST SLIT("map") -compose_PN = prelude_val pRELUDE SLIT(".") -mkInt_PN = prelude_val pRELUDE_BUILTIN SLIT("I#") -error_PN = prelude_val pRELUDE SLIT("error") -showString_PN = prelude_val pRELUDE_TEXT SLIT("showString") -showParen_PN = prelude_val pRELUDE_TEXT SLIT("showParen") -readParen_PN = prelude_val pRELUDE_TEXT SLIT("readParen") -lex_PN = prelude_val pRELUDE_TEXT SLIT("lex") -showSpace_PN = prelude_val pRELUDE_TEXT SLIT("__showSpace") -_showList_PN = prelude_val pRELUDE SLIT("__showList") -_readList_PN = prelude_val pRELUDE SLIT("__readList") - -prelude_val m s = Unqual s -prelude_method c o = Unqual o -prelude_primop o = origName (primOpId o) + +prelude_primop o = case (origName "prelude_primop" (primOpId o)) of { OrigName m n -> Qual m n } + +false_PN = preludeQual SLIT("False") +true_PN = preludeQual SLIT("True") +and_PN = preludeQual SLIT("&&") +not_PN = preludeQual SLIT("not") +append_PN = preludeQual SLIT("++") +map_PN = preludeQual SLIT("map") +compose_PN = preludeQual SLIT(".") +mkInt_PN = preludeQual SLIT("I#") +error_PN = preludeQual SLIT("error") +showString_PN = preludeQual SLIT("showString") +showParen_PN = preludeQual SLIT("showParen") +readParen_PN = preludeQual SLIT("readParen") +lex_PN = preludeQual SLIT("lex") +showSpace_PN = Qual gHC__ SLIT("showSpace") +_showList_PN = Qual gHC__ SLIT("showList__") +_readList_PN = Qual gHC__ SLIT("readList__") a_Expr = HsVar a_PN b_Expr = HsVar b_PN @@ -1139,20 +1140,20 @@ d_Pat = VarPatIn d_PN con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> RdrName con2tag_PN tycon - = let (mod, nm) = moduleNamePair tycon + = let (OrigName mod nm) = origName "con2tag_PN" tycon con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#") in - (if fromPrelude mod then Unqual else Qual mod) con2tag + Qual mod con2tag tag2con_PN tycon - = let (mod, nm) = moduleNamePair tycon + = let (OrigName mod nm) = origName "tag2con_PN" tycon tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#") in - (if fromPrelude mod then Unqual else Qual mod) tag2con + Qual mod tag2con maxtag_PN tycon - = let (mod, nm) = moduleNamePair tycon + = let (OrigName mod nm) = origName "maxtag_PN" tycon maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#") in - (if fromPrelude mod then Unqual else Qual mod) maxtag + Qual mod maxtag \end{code} diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 54d2b7a..93149e4 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -55,7 +55,7 @@ import PprType ( GenType, GenTyVar ) -- instances import Type ( mkTyVarTy, tyVarsOfType ) import TyVar ( GenTyVar {- instances -}, TyVarEnv(..), growTyVarEnvList, emptyTyVarSet ) -import TysWiredIn ( voidTy ) +import TysPrim ( voidTy ) import Unique ( Unique ) -- instances import UniqFM import PprStyle @@ -86,7 +86,7 @@ type TcExpr s = HsExpr (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TcGRHSsAndBinds s = GRHSsAndBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TcGRHS s = GRHS (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TcMatch s = Match (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcQual s = Qual (TcTyVar s) UVar (TcIdOcc s) (TcPat s) +type TcQual s = Qualifier (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TcStmt s = Stmt (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TcArithSeqInfo s = ArithSeqInfo (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TcRecordBinds s = HsRecordBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) @@ -98,7 +98,7 @@ type TypecheckedHsBinds = HsBinds TyVar UVar Id TypecheckedPat type TypecheckedBind = Bind TyVar UVar Id TypecheckedPat type TypecheckedHsExpr = HsExpr TyVar UVar Id TypecheckedPat type TypecheckedArithSeqInfo = ArithSeqInfo TyVar UVar Id TypecheckedPat -type TypecheckedQual = Qual TyVar UVar Id TypecheckedPat +type TypecheckedQual = Qualifier TyVar UVar Id TypecheckedPat type TypecheckedStmt = Stmt TyVar UVar Id TypecheckedPat type TypecheckedMatch = Match TyVar UVar Id TypecheckedPat type TypecheckedGRHSsAndBinds = GRHSsAndBinds TyVar UVar Id TypecheckedPat diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 80238ff..aa8590a 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -20,7 +20,7 @@ import HsSyn ( InstDecl(..), FixityDecl, Sig(..), SpecInstSig(..), HsBinds(..), Bind(..), MonoBinds(..), GRHSsAndBinds, Match, InPat(..), OutPat(..), HsExpr(..), HsLit(..), - Stmt, Qual, ArithSeqInfo, Fake, + Stmt, Qualifier, ArithSeqInfo, Fake, PolyType(..), MonoType ) import RnHsSyn ( RenamedHsBinds(..), RenamedMonoBinds(..), RenamedInstDecl(..), RenamedFixityDecl(..), @@ -54,9 +54,10 @@ import Unify ( unifyTauTy, unifyTauTyLists ) import Bag ( emptyBag, unitBag, unionBags, unionManyBags, concatBag, foldBag, bagToList ) -import CmdLineOpts ( opt_GlasgowExts, opt_CompilingPrelude, +import CmdLineOpts ( opt_GlasgowExts, opt_OmitDefaultInstanceMethods, - opt_SpecialiseOverloaded ) + opt_SpecialiseOverloaded + ) import Class ( GenClass, GenClassOp, isCcallishClass, classBigSig, classOps, classOpLocalType, @@ -232,8 +233,7 @@ tcInstDecl1 mod_name if (not from_here && (clas `derivedFor` inst_tycon) && all isTyVarTy arg_tys) then - if not opt_CompilingPrelude && maybeToBool inst_mod && - mod_name == expectJust "inst_mod" inst_mod + if mod_name == inst_mod then -- Imported instance came from this module; -- discard and derive fresh instance @@ -534,7 +534,7 @@ makeInstanceDeclNoDefaultExpr -> [Id] -> TcType s -> Class - -> Maybe Module + -> Module -> Int -> NF_TcM s (TcExpr s) @@ -555,13 +555,11 @@ makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id - mod_str = case inst_mod of { Nothing -> pRELUDE; Just m -> m } - - error_msg = _UNPK_ mod_str ++ "." ++ _UNPK_ clas_name ++ "." + error_msg = _UNPK_ inst_mod ++ "." ++ _UNPK_ clas_name ++ "." ++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "." ++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\"" - clas_name = nameOf (origName clas) + clas_name = nameOf (origName "makeInstanceDeclNoDefaultExpr" clas) \end{code} @@ -930,7 +928,6 @@ scrutiniseInstanceType from_here clas inst_tau -- A user declaration of a CCallable/CReturnable instance -- must be for a "boxed primitive" type. isCcallishClass clas --- && not opt_CompilingPrelude -- which allows anything && not (maybeToBool (maybeBoxedPrimType inst_tau)) = failTc (nonBoxedPrimCCallErr clas inst_tau) @@ -961,9 +958,7 @@ derivingWhenInstanceImportedErr inst_mod clas tycon sty = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"]) 4 (ppBesides [ppStr "when an instance declared in module `", pp_mod, ppStr "' has been imported"]) where - pp_mod = case inst_mod of - Nothing -> ppPStr SLIT("the standard Prelude") - Just m -> ppBesides [ppStr "module `", ppPStr m, ppStr "'"] + pp_mod = ppBesides [ppStr "module `", ppPStr inst_mod, ppStr "'"] nonBoxedPrimCCallErr clas inst_ty sty = ppHang (ppStr "Instance isn't for a `boxed-primitive' type") diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index 04717e3..fde76aa 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -63,7 +63,7 @@ data InstInfo [Id] -- Constant methods (either all or none) RenamedMonoBinds -- Bindings, b Bool -- True <=> local instance decl - (Maybe Module) -- Name of module where this instance defined; Nothing => Prelude + Module -- Name of module where this instance defined SrcLoc -- Source location assoc'd with this instance's defn [RenamedSig] -- User pragmas recorded for generating specialised instances \end{code} @@ -77,7 +77,7 @@ data InstInfo \begin{code} mkInstanceRelatedIds :: Bool -> SrcLoc - -> Maybe Module + -> Module -> RenamedInstancePragmas -> Class -> [TyVar] diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index b857bb0..45aaa5d 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -11,7 +11,7 @@ module TcPat ( tcPat ) where IMP_Ubiq(){-uitous-} import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..), - Match, HsBinds, Qual, PolyType, + Match, HsBinds, Qualifier, PolyType, ArithSeqInfo, Stmt, Fake ) import RnHsSyn ( RenamedPat(..) ) import TcHsSyn ( TcPat(..), TcIdOcc(..) ) diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 21f4547..c6089d0 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -15,7 +15,7 @@ module TcSimplify ( IMP_Ubiq() import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit, - Match, HsBinds, Qual, PolyType, ArithSeqInfo, + Match, HsBinds, Qualifier, PolyType, ArithSeqInfo, GRHSsAndBinds, Stmt, Fake ) import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcExpr(..), TcMonoBinds(..) ) diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 680753e..8ee07e5 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -24,7 +24,6 @@ import TcMonad hiding ( rnMtoTcM ) import Inst ( InstanceMapper(..) ) import TcClassDcl ( tcClassDecl1 ) import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv, - tcExtendGlobalValEnv, tcTyVarScope, tcGetEnv ) import TcKind ( TcKind, newKindVars ) import TcTyDecls ( tcTyDecl, mkDataBinds ) diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 47649c7..0191ba6 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -16,7 +16,7 @@ IMP_Ubiq(){-uitous-} import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..), Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..), - HsBinds(..), HsLit, Stmt, Qual, ArithSeqInfo, + HsBinds(..), HsLit, Stmt, Qualifier, ArithSeqInfo, PolyType, Fake, InPat, Bind(..), MonoBinds(..), Sig, MonoType ) diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index b386d1a..a237dc6 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -55,7 +55,7 @@ import TcKind ( TcKind ) import TcMonad hiding ( rnMtoTcM ) import Usage ( Usage(..), GenUsage, UVar(..), duffUsage ) -import TysWiredIn ( voidTy ) +import TysPrim ( voidTy ) IMP_Ubiq() import Unique ( Unique ) diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index eb6ed43..a4c6d2c 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -43,8 +43,8 @@ import Usage ( GenUsage(..) ) import CStrings ( identToC ) import CmdLineOpts ( opt_OmitInterfacePragmas ) import Maybes ( maybeToBool ) -import Name ( isLexVarSym, isLexSpecialSym, isPreludeDefined, origName, moduleOf, - nameOrigName, nameOf, Name{-instance Outputable-} +import Name ( isLexVarSym, isLexSpecialSym, origName, moduleOf, + getLocalName, Name{-instance Outputable-} ) import Outputable ( ifPprShowAll, interpp'SP ) import PprEnv @@ -52,7 +52,7 @@ import PprStyle ( PprStyle(..), codeStyle, showUserishTypes ) import Pretty import TysWiredIn ( listTyCon ) import UniqFM ( addToUFM_Directly, lookupUFM_Directly, ufmToList{-ToDo:rm-} ) -import Unique ( pprUnique10, pprUnique, incrUnique ) +import Unique ( pprUnique10, pprUnique, incrUnique, listTyConKey ) import Usage ( UVar(..), pprUVar ) import Util \end{code} @@ -147,8 +147,12 @@ ppr_ty sty env ctxt_prec ty@(FunTy (DictTy _ _ _) _ _) where (theta, body_ty) = splitRhoTy ty - ppr_theta [ct] = ppr_dict sty env tOP_PREC ct - ppr_theta cts = ppParens (ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts)) + ppr_theta = case sty of { PprInterface -> ppr_theta_2 ; _ -> ppr_theta_1 } + + ppr_theta_1 [ct] = ppr_dict sty env tOP_PREC ct + ppr_theta_1 cts = ppParens (ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts)) + + ppr_theta_2 cts = ppBesides [ppStr "{{", ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts), ppStr "}}"] ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage) -- We fiddle the precedences passed to left/right branches, @@ -163,9 +167,11 @@ ppr_ty sty env ctxt_prec ty@(AppTy _ _) where (fun_ty, arg_tys) = splitAppTy ty +{- OLD: ppr_ty PprInterface env ctxt_prec (SynTy tycon tys expansion) -- always expand types in an interface = ppr_ty PprInterface env ctxt_prec expansion +-} ppr_ty sty env ctxt_prec (SynTy tycon tys expansion) = ppBeside @@ -267,7 +273,7 @@ pprGenTyVar sty (TyVar uniq kind name usage) where pp_u = pprUnique uniq pp_name = case name of - Just n -> ppPStr (nameOf (nameOrigName n)) + Just n -> ppPStr (getLocalName n) Nothing -> case kind of TypeKind -> ppChar 'o' BoxedTypeKind -> ppChar 't' @@ -287,13 +293,25 @@ ToDo; all this is suspiciously like getOccName! showTyCon :: PprStyle -> TyCon -> String showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon) +maybe_code sty = if codeStyle sty then identToC else ppPStr + pprTyCon :: PprStyle -> TyCon -> Pretty -pprTyCon sty FunTyCon = ppStr "(->)" -pprTyCon sty (TupleTyCon _ name _) = ppr sty name pprTyCon sty (PrimTyCon _ name _ _) = ppr sty name +pprTyCon sty FunTyCon = maybe_code sty SLIT("(->)") +pprTyCon sty (TupleTyCon _ _ arity) = case arity of + 0 -> maybe_code sty SLIT("()") + 2 -> maybe_code sty SLIT("(,)") + 3 -> maybe_code sty SLIT("(,,)") + 4 -> maybe_code sty SLIT("(,,,)") + 5 -> maybe_code sty SLIT("(,,,,)") + n -> maybe_code sty (_PK_ ( "(" ++ nOfThem (n-1) ',' ++ ")")) + pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd) + | uniq == listTyConKey + = maybe_code sty SLIT("[]") + | otherwise = ppr sty name pprTyCon sty (SpecTyCon tc ty_maybes) @@ -352,23 +370,16 @@ ppr_class_op sty tyvars (ClassOp op_name i ty) -- vaguely close to what can be used in C identifier. -- Don't forget to include the module name!!! getTypeString :: Type -> [FAST_STRING] -getTypeString ty - | is_prelude_ty = [string] - | otherwise = [mod, string] +getTypeString ty = [mod, string] where string = _PK_ (tidy (ppShow 1000 ppr_t)) ppr_t = pprGenType PprForC ty -- PprForC expands type synonyms as it goes - (is_prelude_ty, mod) + mod = case (maybeAppTyCon ty) of - Nothing -> true_bottom - Just (tycon,_) -> - if isPreludeDefined tycon - then true_bottom - else (False, moduleOf (origName tycon)) - - true_bottom = (True, panic "getTypeString") + Nothing -> panic "getTypeString" + Just (tycon,_) -> moduleOf (origName "getTypeString" tycon) -------------------------------------------------- -- tidy: very ad-hoc diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index be4eccd..02a7dd3 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -331,7 +331,7 @@ instance NamedThing TyCon where getName tc = panic "TyCon.getName" {- LATER: - getName (SpecTyCon tc tys) = let (m,n) = moduleNamePair tc in + getName (SpecTyCon tc tys) = let (OrigName m n) = origName "????" tc in (m, n _APPEND_ specMaybeTysSuffix tys) getName other_tc = moduleNamePair (expectJust "tycon1" (getName other_tc)) getName other = Nothing diff --git a/ghc/compiler/types/TyLoop.lhi b/ghc/compiler/types/TyLoop.lhi index 2491f4c..9fb866f 100644 --- a/ghc/compiler/types/TyLoop.lhi +++ b/ghc/compiler/types/TyLoop.lhi @@ -17,7 +17,7 @@ import TyVar ( GenTyVar, TyVar ) import Type ( GenType, Type ) import Usage ( GenUsage ) import Class ( Class, GenClass ) -import TysWiredIn ( voidTy ) +import TysPrim ( voidTy ) data GenId ty data GenType tyvar uvar diff --git a/ghc/compiler/utils/Bag.lhs b/ghc/compiler/utils/Bag.lhs index 6085e37..36fe314 100644 --- a/ghc/compiler/utils/Bag.lhs +++ b/ghc/compiler/utils/Bag.lhs @@ -10,10 +10,10 @@ module Bag ( Bag, -- abstract type emptyBag, unitBag, unionBags, unionManyBags, - elemBag, mapBag, + mapBag, -- UNUSED: elemBag, filterBag, partitionBag, concatBag, foldBag, isEmptyBag, consBag, snocBag, - listToBag, bagToList, bagToList_append + listToBag, bagToList ) where #ifdef COMPILING_GHC @@ -35,6 +35,7 @@ data Bag a emptyBag = EmptyBag unitBag = UnitBag +{- UNUSED: elemBag :: Eq a => a -> Bag a -> Bool elemBag x EmptyBag = False @@ -42,6 +43,7 @@ elemBag x (UnitBag y) = x==y elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2 elemBag x (ListBag ys) = any (x ==) ys elemBag x (ListOfBags bs) = any (x `elemBag`) bs +-} unionManyBags [] = EmptyBag unionManyBags xs = ListOfBags xs @@ -139,6 +141,7 @@ bagToList (ListBag vs) = vs bagToList b = bagToList_append b [] -- (bagToList_append b xs) flattens b and puts xs on the end. + -- (not exported) bagToList_append EmptyBag xs = xs bagToList_append (UnitBag x) xs = x:xs bagToList_append (TwoBags b1 b2) xs = bagToList_append b1 (bagToList_append b2 xs) diff --git a/ghc/compiler/utils/Ubiq.lhi b/ghc/compiler/utils/Ubiq.lhi index 82e31b4..1632c4b 100644 --- a/ghc/compiler/utils/Ubiq.lhi +++ b/ghc/compiler/utils/Ubiq.lhi @@ -31,7 +31,7 @@ import Literal ( Literal ) import MachRegs ( Reg ) import Maybes ( MaybeErr ) import MatchEnv ( MatchEnv ) -import Name ( Module(..), RdrName, Name, ExportFlag, NamedThing(..) ) +import Name ( Module(..), OrigName, RdrName, Name, ExportFlag, NamedThing(..) ) import Outputable ( Outputable(..) ) import PprStyle ( PprStyle ) import PragmaInfo ( PragmaInfo ) @@ -111,6 +111,7 @@ data Literal data MaybeErr a b data MatchEnv a b data Name +data OrigName = OrigName _PackedString _PackedString data RdrName = Unqual _PackedString | Qual _PackedString _PackedString data Reg data OutPat a b c diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 8ae4b4b..37cb8c0 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -211,6 +211,7 @@ startsWith, endsWith :: String -> String -> Maybe String startsWith [] str = Just str startsWith (c:cs) (s:ss) = if c /= s then Nothing else startsWith cs ss +startWith _ [] = Nothing endsWith cs ss = case (startsWith (reverse cs) (reverse ss)) of