From: simonpj Date: Tue, 23 May 2000 11:35:38 +0000 (+0000) Subject: [project @ 2000-05-23 11:35:36 by simonpj] X-Git-Tag: Approximately_9120_patches~4407 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=bb91427f27c940e4dd0fc6c7360e7ef61264b240;p=ghc-hetmet.git [project @ 2000-05-23 11:35:36 by simonpj] *** MERGE WITH 4.07 (once I've checked it works) *** * Fix result type signatures. Note that a consequential change is that an ordinary binding with a variable on the left f = e is now treated as a FunMonoBind, not a PatMonoBind. This makes a few things a bit simpler (eg rnMethodBinds) * Fix warnings for unused imports. This meant moving where provenances are improved in RnNames. Move mkExportAvails from RnEnv to RnNames. * Print module names right (small change in Module.lhs and Rename.lhs) * Remove a few unused bindings * Add a little hack to let us print info about join points that turn out not to be let-no-escaped. The idea is to call them "$j" and report any such variables that are not let-no-escaped. * Some small things aiming towards -ddump-types (harmless but incomplete) --- diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index cbec03c..2650e2e 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -183,9 +183,7 @@ instance Ord Module where \begin{code} pprModule :: Module -> SDoc pprModule (Module mod p) = getPprStyle $ \ sty -> - if userStyle sty then - text (moduleNameUserString mod) - else if debugStyle sty then + if debugStyle sty then -- Print the package too text (show p) <> dot <> pprModuleName mod else diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index ddc7fec..83508b5 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -37,7 +37,7 @@ module Name ( -- Class NamedThing and overloaded friends NamedThing(..), - getSrcLoc, isLocallyDefined, getOccString + getSrcLoc, isLocallyDefined, getOccString, toRdrName ) where #include "HsVersions.h" @@ -423,6 +423,12 @@ nameRdrName :: Name -> RdrName nameRdrName (Name { n_sort = Local, n_occ = occ }) = mkRdrUnqual occ nameRdrName (Name { n_sort = sort, n_occ = occ }) = mkRdrQual (moduleName (nameSortModule sort)) occ +ifaceNameRdrName :: Name -> RdrName +-- Makes a qualified naem for imported things, +-- and an unqualified one for local things +ifaceNameRdrName n | isLocallyDefined n = mkRdrUnqual (nameOccName n) + | otherwise = mkRdrQual (moduleName (nameModule n)) (nameOccName n) + isUserExportedName (Name { n_prov = LocalDef _ Exported }) = True isUserExportedName other = False @@ -622,10 +628,12 @@ class NamedThing a where getSrcLoc :: NamedThing a => a -> SrcLoc isLocallyDefined :: NamedThing a => a -> Bool getOccString :: NamedThing a => a -> String +toRdrName :: NamedThing a => a -> RdrName getSrcLoc = nameSrcLoc . getName isLocallyDefined = isLocallyDefinedName . getName getOccString x = occNameString (getOccName x) +toRdrName = ifaceNameRdrName . getName \end{code} \begin{code} diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index 8de9aae..d52773b 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -19,7 +19,7 @@ module OccName ( mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc, - isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, isValOcc, + isSysOcc, isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, isValOcc, occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour, setOccNameSpace, @@ -310,6 +310,13 @@ mkSpecOcc = mk_simple_deriv varName "$s" mkForeignExportOcc = mk_simple_deriv varName "$f" mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ) + + +isSysOcc :: OccName -> Bool -- True for all these '$' things +isSysOcc occ = case occNameUserString occ of + ('$' : _ ) -> True + other -> False -- We don't care about the ':' ones + -- isSysOcc is only called for Ids anyway \end{code} \begin{code} diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index ea1eeeb..5eefa47 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -373,8 +373,6 @@ dsExpr (TyApp expr tys) dsExpr (ExplicitListOut ty xs) = go xs where - list_ty = mkListTy ty - go [] = returnDs (mkNilExpr ty) go (x:xs) = dsExpr x `thenDs` \ core_x -> go xs `thenDs` \ core_xs -> @@ -490,10 +488,10 @@ dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds) -- necessary so that we don't lose sharing let - record_in_ty = exprType record_expr' - (tycon, in_inst_tys, cons) = splitAlgTyConApp record_in_ty - (_, out_inst_tys, _) = splitAlgTyConApp record_out_ty - cons_to_upd = filter has_all_fields cons + record_in_ty = exprType record_expr' + (_, in_inst_tys, cons) = splitAlgTyConApp record_in_ty + (_, out_inst_tys, _) = splitAlgTyConApp record_out_ty + cons_to_upd = filter has_all_fields cons mk_val_arg field old_arg_id = case [rhs | (sel_id, rhs, _) <- rbinds, diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 3c95d90..181beeb 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -288,14 +288,15 @@ mkCoAlgCaseMatchResult var match_alts where -- Common stuff scrut_ty = idType var - (tycon, tycon_arg_tys, _) = splitAlgTyConApp scrut_ty + (tycon, _, _) = splitAlgTyConApp scrut_ty -- Stuff for newtype - (con_id, arg_ids, match_result) = head match_alts - arg_id = head arg_ids - coercion_bind = NonRec arg_id - (Note (Coerce (unUsgTy (idType arg_id)) (unUsgTy scrut_ty)) (Var var)) - newtype_sanity = null (tail match_alts) && null (tail arg_ids) + (_, arg_ids, match_result) = head match_alts + arg_id = head arg_ids + coercion_bind = NonRec arg_id (Note (Coerce (unUsgTy (idType arg_id)) + (unUsgTy scrut_ty)) + (Var var)) + newtype_sanity = null (tail match_alts) && null (tail arg_ids) -- Stuff for data types data_cons = tyConDataCons tycon diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 16f135f..4e2f98b 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -103,15 +103,19 @@ data MonoBinds id pat | AndMonoBinds (MonoBinds id pat) (MonoBinds id pat) - | PatMonoBind pat - (GRHSs id pat) - SrcLoc - - | FunMonoBind id + | FunMonoBind id -- Used for both functions f x = e + -- and variables f = \x -> e + -- Reason: the Match stuff lets us have an optional + -- result type sig f :: a->a = ...mentions a... Bool -- True => infix declaration [Match id pat] SrcLoc + | PatMonoBind pat -- The pattern is never a simple variable; + -- That case is done by FunMonoBind + (GRHSs id pat) + SrcLoc + | VarMonoBind id -- TRANSLATION (HsExpr id pat) diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index ccaeac8..ca1b58d 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -38,6 +38,7 @@ module CmdLineOpts ( opt_D_dump_stg, opt_D_dump_stranal, opt_D_dump_tc, + opt_D_dump_types, opt_D_dump_usagesp, opt_D_dump_worker_wrapper, opt_D_show_passes, @@ -324,6 +325,7 @@ opt_D_dump_spec = opt_D_dump_most || lookUp SLIT("-ddump-spec") opt_D_dump_stg = opt_D_dump_most || lookUp SLIT("-ddump-stg") opt_D_dump_stranal = opt_D_dump_most || lookUp SLIT("-ddump-stranal") opt_D_dump_tc = opt_D_dump_most || lookUp SLIT("-ddump-tc") +opt_D_dump_types = opt_D_dump_most || lookUp SLIT("-ddump-types") opt_D_dump_rules = opt_D_dump_most || lookUp SLIT("-ddump-rules") opt_D_dump_usagesp = opt_D_dump_most || lookUp SLIT("-ddump-usagesp") opt_D_dump_cse = opt_D_dump_most || lookUp SLIT("-ddump-cse") diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 21991ea..6ed5e4c 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -548,7 +548,7 @@ ifaceTyCon tycon braces $ hsep $ punctuate comma (map ppr_field (strict_marks `zip` field_labels)) ] where - (tyvars1, theta1, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con + (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con field_labels = dataConFieldLabels data_con strict_marks = dataConStrictMarks data_con name = getName data_con diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 2372e4a..93aa715 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -340,11 +340,12 @@ checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc)) checkValSig other ty loc = parseError "Type signature given for an expression" --- A variable binding is parsed as an RdrNamePatBind. +-- A variable binding is parsed as an RdrNameFunMonoBind. +-- See comments with HsBinds.MonoBinds isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op) = Just (op, True, (l:r:es)) -isFunLhs (HsVar f) es@(_:_) | not (isRdrDataCon f) +isFunLhs (HsVar f) es | not (isRdrDataCon f) = Just (f,False,es) isFunLhs (HsApp f e) es = isFunLhs f (e:es) isFunLhs (HsPar e) es = isFunLhs e es diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index b705f89..d5521bf 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.29 2000/03/24 17:49:30 simonpj Exp $ +$Id: Parser.y,v 1.30 2000/05/23 11:35:37 simonpj Exp $ Haskell grammar. @@ -397,10 +397,6 @@ opt_phase :: { Maybe Int } : INTEGER { Just (fromInteger $1) } | {- empty -} { Nothing } -sigtypes :: { [RdrNameHsType] } - : sigtype { [ $1 ] } - | sigtypes ',' sigtype { $3 : $1 } - wherebinds :: { RdrNameHsBinds } : where { cvBinds cvValSig (groupBindings $1) } @@ -421,13 +417,6 @@ fixdecl :: { RdrBinding } (Fixity $3 $2) $1)) | n <- $4 ] } -sigtype :: { RdrNameHsType } - : ctype { mkHsForAllTy Nothing [] $1 } - -sig_vars :: { [RdrName] } - : sig_vars ',' var { $3 : $1 } - | var { [ $1 ] } - ----------------------------------------------------------------------------- -- Transformation Rules @@ -485,6 +474,29 @@ ext_name :: { Maybe ExtName } | STRING STRING { Just (ExtName $2 (Just $1)) } | {- empty -} { Nothing } + +----------------------------------------------------------------------------- +-- Type signatures + +opt_sig :: { Maybe RdrNameHsType } + : {- empty -} { Nothing } + | '::' sigtype { Just $2 } + +opt_asig :: { Maybe RdrNameHsType } + : {- empty -} { Nothing } + | '::' atype { Just $2 } + +sigtypes :: { [RdrNameHsType] } + : sigtype { [ $1 ] } + | sigtypes ',' sigtype { $3 : $1 } + +sigtype :: { RdrNameHsType } + : ctype { mkHsForAllTy Nothing [] $1 } + +sig_vars :: { [RdrName] } + : sig_vars ',' var { $3 : $1 } + | var { [ $1 ] } + ----------------------------------------------------------------------------- -- Types @@ -797,14 +809,6 @@ alt :: { RdrNameMatch } returnP (Match [] [p] $2 (GRHSs $3 $4 Nothing)) } -opt_sig :: { Maybe RdrNameHsType } - : {- empty -} { Nothing } - | '::' sigtype { Just $2 } - -opt_asig :: { Maybe RdrNameHsType } - : {- empty -} { Nothing } - | '::' atype { Just $2 } - ralt :: { [RdrNameGRHS] } : '->' srcloc exp { [GRHS [ExprStmt $3 $2] $2] } | gdpats { (reverse $1) } diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index abd60a0..ff10456 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -379,12 +379,6 @@ rnMethodBinds (FunMonoBind name inf matches locn) mapRn_ (checkPrecMatch inf sel_name) new_matches `thenRn_` returnRn (FunMonoBind sel_name inf new_matches locn, fvs `addOneFV` sel_name) -rnMethodBinds (PatMonoBind (VarPatIn name) grhss locn) - = pushSrcLocRn locn $ - lookupGlobalOccRn name `thenRn` \ sel_name -> - rnGRHSs grhss `thenRn` \ (grhss', fvs) -> - returnRn (PatMonoBind (VarPatIn sel_name) grhss' locn, fvs `addOneFV` sel_name) - -- Can't handle method pattern-bindings which bind multiple methods. rnMethodBinds mbind@(PatMonoBind other_pat _ locn) = pushSrcLocRn locn $ diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 7cef968..8c81f2e 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -35,17 +35,15 @@ import OccName ( OccName, ) import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon ) import Type ( funTyCon ) -import Module ( ModuleName, mkThisModule, moduleName, mkVanillaModule ) +import Module ( ModuleName, mkThisModule, moduleName, mkVanillaModule, pprModuleName ) import TyCon ( TyCon ) import FiniteMap import Unique ( Unique, Uniquable(..) ) -import UniqFM ( emptyUFM, listToUFM, plusUFM_C ) import UniqSupply import SrcLoc ( SrcLoc, noSrcLoc ) import Outputable import Util ( removeDups, equivClasses, thenCmp ) import List ( nub ) -import Maybes ( mapMaybe ) \end{code} @@ -595,46 +593,6 @@ will still have different provenances. -\subsubsection{ExportAvails}% ================ - -\begin{code} -mkEmptyExportAvails :: ModuleName -> ExportAvails -mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM) - -mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails -mkExportAvails mod_name unqual_imp name_env avails - = (mod_avail_env, entity_avail_env) - where - mod_avail_env = unitFM mod_name unqual_avails - - -- unqual_avails is the Avails that are visible in *unqualfied* form - -- (1.4 Report, Section 5.1.1) - -- For example, in - -- import T hiding( f ) - -- we delete f from avails - - unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports - | otherwise = mapMaybe prune avails - - prune (Avail n) | unqual_in_scope n = Just (Avail n) - prune (Avail n) | otherwise = Nothing - prune (AvailTC n ns) | null uqs = Nothing - | otherwise = Just (AvailTC n uqs) - where - uqs = filter unqual_in_scope ns - - unqual_in_scope n = unQualInScope name_env n - - entity_avail_env = listToUFM [ (name,avail) | avail <- avails, - name <- availNames avail] - -plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails -plusExportAvails (m1, e1) (m2, e2) - = (plusFM_C (++) m1 m2, plusAvailEnv e1 e2) - -- ToDo: wasteful: we do this once for each constructor! -\end{code} - - \subsubsection{AvailInfo}% ================ \begin{code} @@ -768,7 +726,7 @@ warnUnusedModules mods | not opt_WarnUnusedImports = returnRn () | otherwise = mapRn_ (addWarnRn . unused_mod) mods where - unused_mod m = ptext SLIT("Module") <+> quotes (ppr m) <+> + unused_mod m = ptext SLIT("Module") <+> quotes (pprModuleName m) <+> ptext SLIT("is imported, but nothing from it is used") warnUnusedLocalBinds, warnUnusedImports, warnUnusedMatches :: [Name] -> RnM d () diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 65bf0f8..8669ca6 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -174,7 +174,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) tyvars_in_sigs = rhs_sig_tyvars `unionLists` tyvars_in_pats rhs_sig_tyvars = case maybe_rhs_sig of Nothing -> [] - Just ty -> extractHsTyRdrNames ty + Just ty -> extractHsTyRdrTyVars ty tyvars_in_pats = extractPatsTyVars pats forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs doc_sig = text "a pattern type-signature" @@ -191,7 +191,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) -> (case maybe_rhs_sig of Nothing -> returnRn (Nothing, emptyFVs) - Just ty | opt_GlasgowExts -> rnHsType doc_sig ty `thenRn` \ (ty', ty_fvs) -> + Just ty | opt_GlasgowExts -> rnHsPolyType doc_sig ty `thenRn` \ (ty', ty_fvs) -> returnRn (Just ty', ty_fvs) | otherwise -> addErrRn (patSigErr ty) `thenRn_` returnRn (Nothing, emptyFVs) @@ -638,7 +638,7 @@ mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg neg_op) -- NegApp can occur on the righ = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_` returnRn (OpApp e1 op1 fix1 e2) where - (nofix_err, associate_right) = compareFixity fix1 negateFixity + (_, associate_right) = compareFixity fix1 negateFixity --------------------------- -- Default case diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 788440b..275f830 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -34,7 +34,6 @@ import PrelMods import PrelInfo ( main_RDR ) import UniqFM ( lookupUFM ) import Bag ( bagToList ) -import Maybes ( maybeToBool, catMaybes ) import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) ) import NameSet import Name ( Name, ExportFlag(..), ImportReason(..), Provenance(..), @@ -46,6 +45,8 @@ import OccName ( setOccNameSpace, dataName ) import SrcLoc ( SrcLoc ) import NameSet ( elemNameSet, emptyNameSet ) import Outputable +import Maybes ( maybeToBool, catMaybes, mapMaybe ) +import UniqFM ( emptyUFM, listToUFM, plusUFM_C ) import Unique ( getUnique ) import Util ( removeDups, equivClassesByUniq, sortLt ) import List ( partition ) @@ -241,27 +242,29 @@ importsFromImportDecl is_unqual (ImportDecl imp_mod_name from qual_only as_mod i returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod_name) else - filterImports imp_mod_name import_spec avails - `thenRn` \ (filtered_avails, hides, explicits) -> + filterImports imp_mod_name import_spec avails `thenRn` \ (filtered_avails, hides, explicits) -> + qualifyImports imp_mod_name + (not qual_only) -- Maybe want unqualified names + as_mod hides + (improveAvails imp_mod iloc explicits + is_unqual filtered_avails) + + +improveAvails imp_mod iloc explicits is_unqual avails -- We 'improve' the provenance by setting -- (a) the import-reason field, so that the Name says how it came into scope -- including whether it's explicitly imported -- (b) the print-unqualified field - -- But don't fiddle with wired-in things or we get in a twist - let - improve_prov name = - setNameProvenance name (NonLocalDef (UserImport imp_mod iloc (is_explicit name)) - (is_unqual name)) - is_explicit name = name `elemNameSet` explicits - in - qualifyImports imp_mod_name - (not qual_only) -- Maybe want unqualified names - as_mod hides - filtered_avails improve_prov - `thenRn` \ (rdr_name_env, mod_avails) -> + = map improve_avail avails + where + improve_avail (Avail n) = Avail (improve n) + improve_avail (AvailTC n ns) = AvailTC n (map improve ns) -- n doesn't matter - returnRn (rdr_name_env, mod_avails) + improve name = setNameProvenance name + (NonLocalDef (UserImport imp_mod iloc (is_explicit name)) + (is_unqual name)) + is_explicit name = name `elemNameSet` explicits \end{code} @@ -290,7 +293,6 @@ importsFromLocalDecls mod_name rec_exp_fn decls Nothing -- no 'as M' [] -- Hide nothing avails - (\n -> n) where mod = mkThisModule mod_name @@ -437,9 +439,6 @@ filterImports mod (Just (want_hiding, import_items)) avails Nothing -> bale_out item Just avail -> returnRn [(avail, availNames avail)] - ok_dotdot_item (AvailTC _ [n]) = False - ok_dotdot_item other = True - check_item item | not (maybeToBool maybe_in_import_avails) || not (maybeToBool maybe_filtered_avail) @@ -476,14 +475,9 @@ qualifyImports :: ModuleName -- Imported module -> Maybe ModuleName -- Optional "as M" part -> [AvailInfo] -- What's to be hidden -> Avails -- Whats imported and how - -> (Name -> Name) -- Improves the provenance on imported things -> RnMG (GlobalRdrEnv, ExportAvails) - -- NB: the Names in ExportAvails don't have the improve-provenance - -- function applied to them - -- We could fix that, but I don't think it matters -qualifyImports this_mod unqual_imp as_mod hides - avails improve_prov +qualifyImports this_mod unqual_imp as_mod hides avails = -- Make the name environment. We're talking about a -- single module here, so there must be no name clashes. @@ -513,14 +507,49 @@ qualifyImports this_mod unqual_imp as_mod hides | unqual_imp = env2 | otherwise = env1 where - env1 = addOneToGlobalRdrEnv env (mkRdrQual qual_mod occ) better_name - env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) better_name - occ = nameOccName name - better_name = improve_prov name + env1 = addOneToGlobalRdrEnv env (mkRdrQual qual_mod occ) name + env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) name + occ = nameOccName name del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names where rdr_names = map (mkRdrUnqual . nameOccName) (availNames avail) + + +mkEmptyExportAvails :: ModuleName -> ExportAvails +mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM) + +mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails +mkExportAvails mod_name unqual_imp name_env avails + = (mod_avail_env, entity_avail_env) + where + mod_avail_env = unitFM mod_name unqual_avails + + -- unqual_avails is the Avails that are visible in *unqualfied* form + -- (1.4 Report, Section 5.1.1) + -- For example, in + -- import T hiding( f ) + -- we delete f from avails + + unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports + | otherwise = mapMaybe prune avails + + prune (Avail n) | unqual_in_scope n = Just (Avail n) + prune (Avail n) | otherwise = Nothing + prune (AvailTC n ns) | null uqs = Nothing + | otherwise = Just (AvailTC n uqs) + where + uqs = filter unqual_in_scope ns + + unqual_in_scope n = unQualInScope name_env n + + entity_avail_env = listToUFM [ (name,avail) | avail <- avails, + name <- availNames avail] + +plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails +plusExportAvails (m1, e1) (m2, e2) + = (plusFM_C (++) m1 m2, plusAvailEnv e1 e2) + -- ToDo: wasteful: we do this once for each constructor! \end{code} diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index ad08f3a..97dee5c 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -54,6 +54,7 @@ import PprCore () -- Instances import Rules ( RuleBase ) import CostCentre ( CostCentreStack, subsumedCCS ) import Name ( isLocallyDefined ) +import OccName ( UserFS ) import Var ( TyVar ) import VarEnv import VarSet @@ -674,20 +675,19 @@ setSimplBinderStuff (subst, us) m env _ sc \begin{code} -newId :: Type -> (Id -> SimplM a) -> SimplM a +newId :: UserFS -> Type -> (Id -> SimplM a) -> SimplM a -- Extends the in-scope-env too -newId ty m env@(SimplEnv {seSubst = subst}) us sc +newId fs ty m env@(SimplEnv {seSubst = subst}) us sc = case splitUniqSupply us of (us1, us2) -> m v (env {seSubst = Subst.extendInScope subst v}) us2 sc where - v = mkSysLocal SLIT("s") (uniqFromSupply us1) ty + v = mkSysLocal fs (uniqFromSupply us1) ty -newIds :: [Type] -> ([Id] -> SimplM a) -> SimplM a -newIds tys m env@(SimplEnv {seSubst = subst}) us sc +newIds :: UserFS -> [Type] -> ([Id] -> SimplM a) -> SimplM a +newIds fs tys m env@(SimplEnv {seSubst = subst}) us sc = case splitUniqSupply us of (us1, us2) -> m vs (env {seSubst = Subst.extendInScopes subst vs}) us2 sc where - vs = zipWithEqual "newIds" (mkSysLocal SLIT("s")) + vs = zipWithEqual "newIds" (mkSysLocal fs) (uniqsFromSupply (length tys) us1) tys - \end{code} diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index fd5f21e..f09d6ae 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -567,7 +567,7 @@ tryEtaExpansion rhs = returnSmpl rhs | otherwise -- Consider eta expansion - = newIds y_tys $ ( \ y_bndrs -> + = newIds SLIT("y") y_tys $ ( \ y_bndrs -> tick (EtaExpansion (head y_bndrs)) `thenSmpl_` mapAndUnzipSmpl bind_z_arg (args `zip` trivial_args) `thenSmpl` (\ (maybe_z_binds, z_args) -> returnSmpl (mkLams x_bndrs $ @@ -582,7 +582,7 @@ tryEtaExpansion rhs bind_z_arg (arg, trivial_arg) | trivial_arg = returnSmpl (Nothing, arg) - | otherwise = newId (exprType arg) $ \ z -> + | otherwise = newId SLIT("z") (exprType arg) $ \ z -> returnSmpl (Just (NonRec z arg), Var z) -- Note: I used to try to avoid the exprType call by using diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 6cacbdb..caaa51e 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -898,7 +898,7 @@ prepareArgs no_case_of_case fun orig_cont thing_inside = simplValArg arg_ty dem val_arg se (contResultType cont) $ \ new_arg -> -- A data constructor whose argument is now non-trivial; -- so let/case bind it. - newId arg_ty $ \ arg_id -> + newId SLIT("a") arg_ty $ \ arg_id -> addNonRecBind arg_id new_arg $ go (Var arg_id : acc) ds' res_ty cont @@ -1345,10 +1345,10 @@ prepareCaseAlts bndr (Just (tycon, inst_tys)) scrut_cons alts let ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars mk uniq tv = mkSysTyVar uniq (tyVarKind tv) + arg_tys = dataConArgTys data_con + (inst_tys ++ mkTyVarTys ex_tyvars') in - newIds (dataConArgTys - data_con - (inst_tys ++ mkTyVarTys ex_tyvars')) $ \ bndrs -> + newIds SLIT("a") arg_tys $ \ bndrs -> returnSmpl ((DataAlt data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt) other -> returnSmpl filtered_alts @@ -1452,13 +1452,15 @@ mkDupableCont ty (InlinePlease cont) thing_inside mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside = -- Build the RHS of the join point - newId join_arg_ty ( \ arg_id -> + newId SLIT("a") join_arg_ty ( \ arg_id -> cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) -> returnSmpl (Lam (setOneShotLambda arg_id) (mkLets binds rhs)) ) `thenSmpl` \ join_rhs -> -- Build the join Id and continuation - newId (exprType join_rhs) $ \ join_id -> + -- We give it a "$j" name just so that for later amusement + -- we can identify any join points that don't end up as let-no-escapes + newId SLIT("$j") (exprType join_rhs) $ \ join_id -> let new_cont = ArgOf OkToDup cont_ty (\arg' -> rebuild_done (App (Var join_id) arg')) @@ -1476,9 +1478,9 @@ mkDupableCont ty (ApplyTo _ arg se cont) thing_inside if exprIsDupable arg' then thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont') else - newId (exprType arg') $ \ bndr -> + newId SLIT("a") (exprType arg') $ \ bndr -> - tick (CaseOfCase bndr) `thenSmpl_` + tick (CaseOfCase bndr) `thenSmpl_` -- Want to tick here so that we go round again, -- and maybe copy or inline the code; -- not strictly CaseOf Case @@ -1574,14 +1576,15 @@ mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs) -- then 78 -- else 5 - then newId realWorldStatePrimTy $ \ rw_id -> + then newId SLIT("w") realWorldStatePrimTy $ \ rw_id -> returnSmpl ([rw_id], [Var realWorldPrimId]) else returnSmpl (used_bndrs', map varToCoreExpr used_bndrs) ) `thenSmpl` \ (final_bndrs', final_args) -> - newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr -> + -- See comment about "$j" name above + newId SLIT("$j") (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr -> -- Notice that we make the lambdas into one-shot-lambdas. The -- join point is sure to be applied at most once, and doing so diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs index 350ef60..6b3f65f 100644 --- a/ghc/compiler/simplStg/StgVarInfo.lhs +++ b/ghc/compiler/simplStg/StgVarInfo.lhs @@ -22,7 +22,8 @@ import IdInfo ( ArityInfo(..), OccInfo(..), import PrimOp ( PrimOp(..), ccallMayGC ) import TysWiredIn ( isForeignObjTy ) import Maybes ( maybeToBool, orElse ) -import Name ( isLocallyDefined ) +import Name ( isLocallyDefined, getOccName ) +import OccName ( occNameUserString ) import BasicTypes ( Arity ) import Outputable @@ -543,12 +544,8 @@ vars_let let_no_escape bind body -- Compute the new let-expression let - new_let = if let_no_escape then - -- trace "StgLetNoEscape!" ( - StgLetNoEscape live_in_whole_let bind_lvs bind2 body2 - -- ) - else - StgLet bind2 body2 + new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2 + | otherwise = StgLet bind2 body2 free_in_whole_let = (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders @@ -568,6 +565,18 @@ vars_let let_no_escape bind body -- this let(rec) no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs) + +#ifdef DEBUG + -- Debugging code as requested by Andrew Kennedy + checked_no_binder_escapes + | not no_binder_escapes && any is_join_var binders + = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders) + False + | otherwise = no_binder_escapes +#else + checked_no_binder_escapes = no_binder_escapes +#endif + -- Mustn't depend on the passed-in let_no_escape flag, since -- no_binder_escapes is used by the caller to derive the flag! in @@ -575,7 +584,7 @@ vars_let let_no_escape bind body new_let, free_in_whole_let, let_escs, - no_binder_escapes + checked_no_binder_escapes )) where set_of_binders = mkVarSet binders @@ -626,6 +635,11 @@ vars_let let_no_escape bind body in returnLne (StgRec (binders' `zip` rhss2), fvs, escs, env_ext) )) + +is_join_var :: Id -> Bool +-- A hack (used only for compiler debuggging) to tell if +-- a variable started life as a join point ($j) +is_join_var j = occNameUserString (getOccName j) == "$j" \end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index b252aca..342529c 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -13,7 +13,7 @@ import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcExpr ) import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), StmtCtxt(..), - collectMonoBinders, andMonoBindList, andMonoBinds + Match(..), collectMonoBinders, andMonoBindList, andMonoBinds ) import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds ) import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet ) @@ -573,13 +573,16 @@ isUnRestrictedGroup :: [Name] -- Signatures given for these is_elem v vs = isIn "isUnResMono" v vs -isUnRestrictedGroup sigs (PatMonoBind (VarPatIn v) _ _) = v `is_elem` sigs isUnRestrictedGroup sigs (PatMonoBind other _ _) = False isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs -isUnRestrictedGroup sigs (FunMonoBind _ _ _ _) = True +isUnRestrictedGroup sigs (FunMonoBind v _ matches _) = any isUnRestrictedMatch matches || + v `is_elem` sigs isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 && isUnRestrictedGroup sigs mb2 isUnRestrictedGroup sigs EmptyMonoBinds = True + +isUnRestrictedMatch (Match _ [] Nothing _) = False -- No args, no signature +isUnRestrictedMatch other = True -- Some args or a signature \end{code} diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index efc05e1..a046545 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -13,8 +13,8 @@ module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2, mkImplicitClassBin import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..), InPat(..), HsBinds(..), GRHSs(..), HsExpr(..), HsLit(..), HsType(..), HsPred(..), - pprHsClassAssertion, unguardedRHS, - andMonoBinds, andMonoBindList, getTyVarName, + pprHsClassAssertion, mkSimpleMatch, + andMonoBinds, andMonoBindList, getTyVarName, isClassDecl, isClassOpSig, isPragSig, collectMonoBinders ) import HsPragmas ( ClassPragmas(..) ) @@ -248,8 +248,6 @@ tcClassContext class_name rec_class rec_tyvars context sc_sel_names returnTc (sc_theta', sc_tys, sc_sel_ids) where - rec_tyvar_tys = mkTyVarTys rec_tyvars - check_constraint (HsPClass c tys) = checkTc (all is_tyvar tys) (superClassErr class_name (c, tys)) @@ -605,8 +603,6 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta -- but we must use the method name; so we substitute it here. Crude but simple. find_bind meth_name (FunMonoBind op_name fix matches loc) | op_name == sel_name = Just (FunMonoBind meth_name fix matches loc) - find_bind meth_name (PatMonoBind (VarPatIn op_name) grhss loc) - | op_name == sel_name = Just (PatMonoBind (VarPatIn meth_name) grhss loc) find_bind meth_name (AndMonoBinds b1 b2) = find_bind meth_name b1 `seqMaybe` find_bind meth_name b2 find_bind meth_name other = Nothing -- Default case @@ -624,8 +620,9 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta find_prags meth_name (prag:prags) = find_prags meth_name prags mk_default_bind local_meth_name loc - = PatMonoBind (VarPatIn local_meth_name) - (GRHSs (unguardedRHS (default_expr loc) loc) EmptyBinds Nothing) + = FunMonoBind local_meth_name + False -- Not infix decl + [mkSimpleMatch [] (default_expr loc) Nothing loc] loc default_expr loc diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 81b468f..d940d97 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -384,7 +384,6 @@ tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty newTyVarTy boxedTypeKind `thenNF_Tc` \ result_ty -> let io_result_ty = mkTyConApp ioTyCon [result_ty] - [ioDataCon] = tyConDataCons ioTyCon in unifyTauTy res_ty io_result_ty `thenTc_` @@ -568,8 +567,8 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty splitSigmaTy (idType sel_id) -- Selectors can be overloaded -- when the data type has a context Just (data_ty, _) = splitFunTy_maybe tau -- Must succeed since sel_id is a selector - (tycon, _, data_cons) = splitAlgTyConApp data_ty - (con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons) + (tycon, _, data_cons) = splitAlgTyConApp data_ty + (con_tyvars, _, _, _, _, _) = dataConSig (head data_cons) in tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) -> diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index de9c9b0..cd5d05c 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -341,11 +341,11 @@ tcCoreAlt scrut_ty (UfDataAlt con_name, names, rhs) (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con - (tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty - ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars] - ex_tys' = mkTyVarTys ex_tyvars' - arg_tys = dataConArgTys con (inst_tys ++ ex_tys') - id_names = drop (length ex_tyvars) names + (_, inst_tys, cons) = splitAlgTyConApp scrut_ty + ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars] + ex_tys' = mkTyVarTys ex_tyvars' + arg_tys = dataConArgTys con (inst_tys ++ ex_tys') + id_names = drop (length ex_tyvars) names arg_ids #ifdef DEBUG | length id_names /= length arg_tys diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index b50818d..882123f 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -538,12 +538,9 @@ scrutiniseInstanceHead clas inst_taus Just (tycon, arg_tys) = maybe_tycon_app -- Stuff for an *algebraic* data type - alg_tycon_app_maybe = splitAlgTyConApp_maybe first_inst_tau - -- The "Alg" part looks through synonyms - is_alg_tycon_app = maybeToBool alg_tycon_app_maybe - Just (alg_tycon, _, data_cons) = alg_tycon_app_maybe - - constructors_visible = not (null data_cons) + alg_tycon_app_maybe = splitAlgTyConApp_maybe first_inst_tau + -- The "Alg" part looks through synonyms + Just (alg_tycon, _, _) = alg_tycon_app_maybe ccallable_type ty = isFFIArgumentTy False {- Not safe call -} ty creturnable_type ty = isFFIResultTy ty diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 4fc3937..14adb46 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -11,7 +11,7 @@ module TcModule ( #include "HsVersions.h" -import CmdLineOpts ( opt_D_dump_tc ) +import CmdLineOpts ( opt_D_dump_tc, opt_D_dump_types, opt_PprStyle_Debug ) import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) ) import RnHsSyn ( RenamedHsModule ) import TcHsSyn ( TcMonoBinds, TypecheckedMonoBinds, @@ -27,7 +27,7 @@ import TcDefaults ( tcDefaults ) import TcEnv ( tcExtendGlobalValEnv, tcExtendTypeEnv, getEnvTyCons, getEnvClasses, tcLookupValueMaybe, explicitLookupValueByKey, tcSetValueEnv, - tcLookupTyCon, initEnv, + tcLookupTyCon, initEnv, valueEnvIds, ValueEnv, TcTyThing(..) ) import TcExpr ( tcId ) @@ -49,7 +49,10 @@ import Bag ( isEmptyBag ) import ErrUtils ( Message, printErrorsAndWarnings, dumpIfSet ) import Id ( Id, idType ) import Module ( pprModuleName ) -import Name ( Name, nameUnique, isLocallyDefined, NamedThing(..) ) +import OccName ( isSysOcc ) +import Name ( Name, nameUnique, nameOccName, isLocallyDefined, + toRdrName, NamedThing(..) + ) import TyCon ( TyCon, tyConKind ) import Class ( Class, classSelIds, classTyCon ) import Type ( mkTyConApp, mkForAllTy, @@ -104,18 +107,19 @@ typecheckModule us rn_name_supply iface_det mod Nothing -> return () ) >> - dumpIfSet opt_D_dump_tc "Typechecked" - (case maybe_result of - Just results -> ppr (tc_binds results) - $$ - pp_rules (tc_rules results) - Nothing -> text "Typecheck failed") >> - + (case maybe_result of + Nothing -> return () + Just results -> dumpIfSet opt_D_dump_tc "Typechecked" (dump_tc results) + ) >> + return (if isEmptyBag errs then maybe_result else Nothing) +dump_tc results + = ppr (tc_binds results) $$ pp_rules (tc_rules results) + pp_rules [] = empty pp_rules rs = vcat [ptext SLIT("{-# RULES"), nest 4 (vcat (map ppr rs)), diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index b036e39..e193c7e 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -476,7 +476,7 @@ badFieldCon con field polyPatSig :: TcType -> SDoc polyPatSig sig_ty - = hang (ptext SLIT("Polymorphic type signature in pattern")) + = hang (ptext SLIT("Illegal polymorphic type signature in pattern:")) 4 (ppr sig_ty) \end{code} diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 1be4d68..b24673a 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -134,18 +134,12 @@ tcDecl :: RecFlag -- True => recursive group tcDecl is_rec_group unf_env inst_mapper vrcs_env decl = tcAddDeclCtxt decl $ --- traceTc (text "Starting" <+> ppr name) `thenTc_` if isClassDecl decl then tcClassDecl1 unf_env inst_mapper vrcs_env decl `thenTc` \ clas -> --- traceTc (text "Finished" <+> ppr name) `thenTc_` returnTc (getName clas, AClass clas) else tcTyDecl is_rec_group vrcs_env decl `thenTc` \ tycon -> --- traceTc (text "Finished" <+> ppr name) `thenTc_` returnTc (getName tycon, ATyCon tycon) - - where - name = tyClDeclName decl tcAddDeclCtxt decl thing_inside @@ -257,7 +251,6 @@ sortByDependency decls edges = map mk_edges tycl_decls is_syn_decl (d, _, _) = isSynDecl d - is_cls_decl (d, _, _) = isClassDecl d \end{code} Edges in Type/Class decls