From: simonpj Date: Thu, 7 Jan 1999 12:48:23 +0000 (+0000) Subject: [project @ 1999-01-07 12:48:13 by simonpj] X-Git-Tag: Approx_2487_patches~148 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=982006447ff7b8aa264bc018568e891313916d4d;p=ghc-hetmet.git [project @ 1999-01-07 12:48:13 by simonpj] Small changes to make the compiler boot itself --- diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index b90208a..f458c32 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.47 1998/12/10 08:54:18 simonpj Exp $ +# $Id: Makefile,v 1.48 1999/01/07 12:48:13 simonpj Exp $ TOP = .. include $(TOP)/mk/boilerplate.mk @@ -178,7 +178,7 @@ reader/Lex_HC_OPTS = -K2m -H16m -fvia-C # Heap was 6m with 2.10 reader/ReadPrefix_HC_OPTS = -fvia-C '-\#include"hspincl.h"' -H10m -rename/ParseIface_HC_OPTS += -Onot -H30m -fno-warn-incomplete-patterns +rename/ParseIface_HC_OPTS += -Onot -H45m -fno-warn-incomplete-patterns rename/ParseIface_HAPPY_OPTS += -g ifeq "$(TARGETPLATFORM)" "hppa1.1-hp-hpux9" diff --git a/ghc/compiler/hsSyn/HsExpr.hi-boot-5 b/ghc/compiler/hsSyn/HsExpr.hi-boot-5 index ecc7ae4..ed46c09 100644 --- a/ghc/compiler/hsSyn/HsExpr.hi-boot-5 +++ b/ghc/compiler/hsSyn/HsExpr.hi-boot-5 @@ -1,4 +1,4 @@ __interface HsExpr 1 0 where __export HsExpr HsExpr pprExpr; -1 data HsExpr f i p ; -1 pprExpr :: __forall [_i _p _f] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => HsExpr.HsExpr _f _i _p -> Outputable.SDoc ; +1 data HsExpr i p ; +1 pprExpr :: __forall [_i _p] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => HsExpr.HsExpr _i _p -> Outputable.SDoc ; diff --git a/ghc/compiler/hsSyn/HsMatches.hi-boot-5 b/ghc/compiler/hsSyn/HsMatches.hi-boot-5 index 2d6ac87..37d55ed 100644 --- a/ghc/compiler/hsSyn/HsMatches.hi-boot-5 +++ b/ghc/compiler/hsSyn/HsMatches.hi-boot-5 @@ -1,7 +1,7 @@ __interface HsMatches 1 0 where -__export HsMatches Match GRHSsAndBinds pprMatch pprMatches pprGRHSsAndBinds ; -1 data Match a b c ; -1 data GRHSsAndBinds a b c ; -1 pprGRHSsAndBinds :: __forall [_i _p _f] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => PrelBase.Bool -> HsMatches.GRHSsAndBinds _f _i _p -> Outputable.SDoc ; -1 pprMatch :: __forall [_i _p _f] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => PrelBase.Bool -> HsMatches.Match _f _i _p -> Outputable.SDoc ; -1 pprMatches :: __forall [_i _p _f] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => (PrelBase.Bool, Outputable.SDoc) -> [HsMatches.Match _f _i _p] -> Outputable.SDoc ; +__export HsMatches Match GRHSs pprMatch pprMatches pprGRHSs ; +1 data Match a b ; +1 data GRHSs a b ; +1 pprGRHSs :: __forall [i p] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsMatches.GRHSs i p -> Outputable.SDoc ; +1 pprMatch :: __forall [_i _p] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => (PrelBase.Bool, Outputable.SDoc) -> HsMatches.Match _i _p -> Outputable.SDoc ; +1 pprMatches :: __forall [_i _p] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => (PrelBase.Bool, Outputable.SDoc) -> [HsMatches.Match _i _p] -> Outputable.SDoc ; diff --git a/ghc/compiler/rename/RnBinds.hi-boot-5 b/ghc/compiler/rename/RnBinds.hi-boot-5 index 74669bd..4bf277f 100644 --- a/ghc/compiler/rename/RnBinds.hi-boot-5 +++ b/ghc/compiler/rename/RnBinds.hi-boot-5 @@ -1,3 +1,3 @@ __interface RnBinds 1 0 where __export RnBinds rnBinds; -1 rnBinds :: __forall [_a _b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS _a (_b, RnMonad.FreeVars)) -> RnMonad.RnMS _a (_b, RnMonad.FreeVars) ; +1 rnBinds :: __forall [_a _b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS _a (_b, RnEnv.FreeVars)) -> RnMonad.RnMS _a (_b, RnEnv.FreeVars) ; diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 205c2c7..2e406b8 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -499,13 +499,16 @@ combine_globals ns_old ns_new -- ns_new is often short choose n' | n==n' && better_provenance n n' = n | otherwise = n' --- Choose a user-imported thing over a non-user-imported thing --- and an explicitly-imported thing over an implicitly imported thing +-- Choose +-- a local thing over an imported thing +-- a user-imported thing over a non-user-imported thing +-- an explicitly-imported thing over an implicitly imported thing better_provenance n1 n2 = case (getNameProvenance n1, getNameProvenance n2) of + (LocalDef _ _, _ ) -> True (NonLocalDef (UserImport _ _ True) _ _, _ ) -> True (NonLocalDef (UserImport _ _ _ ) _ _, NonLocalDef ImplicitImport _ _) -> True - other -> False + other -> False no_conflict :: Name -> Name -> Bool no_conflict n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 7d7520a..20f8817 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -270,7 +270,7 @@ loadDecl mod as_source decls_map (version, decl) [ (name, (version,avail,decl',name==main_name)) | name <- sys_bndrs ++ availNames avail] add_decl decls_map (name, stuff) - = ASSERT2( not (name `elemNameEnv` decls_map), ppr name ) + = WARN( name `elemNameEnv` decls_map, ppr name ) addToNameEnv decls_map name stuff in returnRn new_decls_map diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 9471b3c..29c6bab 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -78,7 +78,7 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc) importsFromLocalDecls this_mod rec_exp_fn decls `thenRn` \ (local_gbl_env, local_mod_avails) -> -- PROCESS IMPORT DECLS - mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) + mapAndUnzipRn (importsFromImportDecl this_mod rec_unqual_fn) all_imports `thenRn` \ (imp_gbl_envs, imp_avails_s) -> -- COMBINE RESULTS @@ -181,22 +181,23 @@ checkEarlyExit mod \end{code} \begin{code} -importsFromImportDecl :: (Name -> Bool) -- True => print unqualified +importsFromImportDecl :: Module -- The module being compiled + -> (Name -> Bool) -- True => print unqualified -> RdrNameImportDecl -> RnMG (GlobalRdrEnv, ExportAvails) -importsFromImportDecl rec_unqual_fn (ImportDecl mod qual_only as_source as_mod import_spec iloc) +importsFromImportDecl this_mod rec_unqual_fn (ImportDecl imp_mod qual_only as_source as_mod import_spec iloc) = pushSrcLocRn iloc $ - getInterfaceExports mod as_source `thenRn` \ avails -> + getInterfaceExports imp_mod as_source `thenRn` \ avails -> if null avails then -- If there's an error in getInterfaceExports, (e.g. interface -- file not found) we get lots of spurious errors from 'filterImports' - returnRn (emptyRdrEnv, mkEmptyExportAvails mod) + returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod) else - filterImports mod import_spec avails `thenRn` \ (filtered_avails, hides, explicits) -> + filterImports imp_mod import_spec avails `thenRn` \ (filtered_avails, hides, explicits) -> -- Load all the home modules for the things being -- bought into scope. This makes sure their fixities @@ -212,12 +213,10 @@ importsFromImportDecl rec_unqual_fn (ImportDecl mod qual_only as_source as_mod i other -> True, let name = availName avail, - nameModule (availName avail) /= mod - -- This nameModule predicate is a bit of a hack. - -- PrelBase imports error from PrelErr.hi-boot; but error is - -- wired in, so its provenance doesn't say it's from an hi-boot - -- file. Result: disaster when PrelErr.hi doesn't exist. - -- [Jan 99: I now can't see how the predicate achieves the goal!] + not (isLocallyDefined name || nameModule name == imp_mod) + -- Don't try to load the module being compiled + -- (this can happen in mutual-recursion situations) + -- or from the module being imported (it's already loaded) ] same_module n1 n2 = nameModule n1 == nameModule n2 @@ -236,11 +235,11 @@ importsFromImportDecl rec_unqual_fn (ImportDecl mod qual_only as_source as_mod i | otherwise = setNameProvenance name (mk_new_prov name) is_explicit name = name `elemNameSet` explicits - mk_new_prov name = NonLocalDef (UserImport mod iloc (is_explicit name)) + mk_new_prov name = NonLocalDef (UserImport imp_mod iloc (is_explicit name)) as_source (rec_unqual_fn name) in - qualifyImports mod + qualifyImports imp_mod (not qual_only) -- Maybe want unqualified names as_mod hides filtered_avails improve_prov `thenRn` \ (rdr_name_env, mod_avails) -> @@ -354,7 +353,7 @@ fixitiesFromLocalDecls gbl_env decls available, and filters it through the import spec (if any). \begin{code} -filterImports :: Module +filterImports :: Module -- The module being imported -> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hiding -> [AvailInfo] -- What's available -> RnMG ([AvailInfo], -- What's actually imported diff --git a/ghc/compiler/rename/RnSource.hi-boot-5 b/ghc/compiler/rename/RnSource.hi-boot-5 index dbb4b1c..aeca07e 100644 --- a/ghc/compiler/rename/RnSource.hi-boot-5 +++ b/ghc/compiler/rename/RnSource.hi-boot-5 @@ -1,5 +1,8 @@ __interface RnSource 1 0 where -__export RnSource rnHsSigType; -1 rnHsSigType :: __forall [_a] => (Outputable.SDoc) +__export RnSource rnHsSigType rnHsType; +1 rnHsSigType :: __forall [_a] => Outputable.SDoc -> RdrHsSyn.RdrNameHsType - -> RnMonad.RnMS _a RnHsSyn.RenamedHsType ; + -> RnMonad.RnMS _a (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ; +1 rnHsType :: __forall [_a] => Outputable.SDoc + -> RdrHsSyn.RdrNameHsType + -> RnMonad.RnMS _a (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ; diff --git a/ghc/compiler/typecheck/TcEnv.hi-boot-5 b/ghc/compiler/typecheck/TcEnv.hi-boot-5 index b28fac9..4c3e1fd 100644 --- a/ghc/compiler/typecheck/TcEnv.hi-boot-5 +++ b/ghc/compiler/typecheck/TcEnv.hi-boot-5 @@ -1,3 +1,3 @@ __interface TcEnv 1 0 where __export TcEnv TcEnv; -1 data TcEnv a; +1 data TcEnv ; diff --git a/ghc/compiler/typecheck/TcExpr.hi-boot-5 b/ghc/compiler/typecheck/TcExpr.hi-boot-5 index 13c267a..25c9e5a 100644 --- a/ghc/compiler/typecheck/TcExpr.hi-boot-5 +++ b/ghc/compiler/typecheck/TcExpr.hi-boot-5 @@ -2,5 +2,5 @@ __interface TcExpr 1 0 where __export TcExpr tcExpr ; 1 tcExpr :: __forall [_s] => RnHsSyn.RenamedHsExpr - -> TcMonad.TcType _s - -> TcMonad.TcM _s (TcHsSyn.TcExpr _s, Inst.LIE _s) ; + -> TcMonad.TcType + -> TcMonad.TcM _s (TcHsSyn.TcExpr, Inst.LIE) ; diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 84fc1d9..466a699 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -504,18 +504,29 @@ tcMonoExpr (RecordCon con_name rbinds) res_ty tcMonoExpr (RecordUpd record_expr rbinds) res_ty = tcAddErrCtxt recordUpdCtxt $ - -- STEP 1 - -- Figure out the tycon and data cons from the first field name + -- STEP 0 + -- Check that the field names are really field names ASSERT( not (null rbinds) ) let - ((first_field_name, _, _) : rest) = rbinds + field_names = [field_name | (field_name, _, _) <- rbinds] + in + mapNF_Tc tcLookupValueMaybe field_names `thenNF_Tc` \ maybe_sel_ids -> + let + bad_guys = [field_name | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids, + case maybe_sel_id of + Nothing -> True + Just sel_id -> not (isRecordSelector sel_id) + ] in - tcLookupValueMaybe first_field_name `thenNF_Tc` \ maybe_sel_id -> - (case maybe_sel_id of - Just sel_id | isRecordSelector sel_id -> returnTc sel_id - other -> failWithTc (notSelector first_field_name) - ) `thenTc` \ sel_id -> + mapNF_Tc (addErrTc . notSelector) bad_guys `thenTc_` + if not (null bad_guys) then + failTc + else + + -- STEP 1 + -- Figure out the tycon and data cons from the first field name let + (Just sel_id : _) = maybe_sel_ids (_, tau) = splitForAllTys (idType sel_id) Just (data_ty, _) = splitFunTy_maybe tau -- Must succeed since sel_id is a selector (tycon, _, data_cons) = splitAlgTyConApp data_ty @@ -524,9 +535,11 @@ tcMonoExpr (RecordUpd record_expr rbinds) res_ty tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) -> -- STEP 2 - -- Check for bad fields + -- Check that at least one constructor has all the named fields + -- i.e. has an empty set of bad fields returned by badFields checkTc (any (null . badFields rbinds) data_cons) (badFieldsUpd rbinds) `thenTc_` + -- STEP 3 -- Typecheck the update bindings. -- (Do this after checking for bad fields in case there's a field that diff --git a/ghc/compiler/typecheck/TcMatches.hi-boot-5 b/ghc/compiler/typecheck/TcMatches.hi-boot-5 new file mode 100644 index 0000000..4be7cbb --- /dev/null +++ b/ghc/compiler/typecheck/TcMatches.hi-boot-5 @@ -0,0 +1,14 @@ +__interface TcMatches 1 0 where +__export TcMatches tcGRHSs tcMatchesFun; +1 tcGRHSs :: __forall [s] => + RnHsSyn.RenamedGRHSs + -> TcMonad.TcType + -> HsExpr.StmtCtxt + -> TcMonad.TcM s (TcHsSyn.TcGRHSs, Inst.LIE) ; +1 tcMatchesFun :: __forall [s] => + [(Name.Name,Var.Id)] + -> Name.Name + -> TcMonad.TcType + -> [RnHsSyn.RenamedMatch] + -> TcMonad.TcM s ([TcHsSyn.TcMatch], Inst.LIE) ; + diff --git a/ghc/compiler/types/Type.hi-boot-5 b/ghc/compiler/types/Type.hi-boot-5 index 971c926..43c7bf3 100644 --- a/ghc/compiler/types/Type.hi-boot-5 +++ b/ghc/compiler/types/Type.hi-boot-5 @@ -4,3 +4,4 @@ __export Type Type Kind SuperKind ; 1 type Kind = Type ; 1 type SuperKind = Type ; +