From: simonpj Date: Thu, 2 Dec 2004 17:18:32 +0000 (+0000) Subject: [project @ 2004-12-02 17:18:15 by simonpj] X-Git-Tag: Initial_conversion_from_CVS_complete~1369 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=759739c69f9cd540f03c3c69aa1990d5d58a5dd6;p=ghc-hetmet.git [project @ 2004-12-02 17:18:15 by simonpj] Sorry for the fact that there are overlapping three commits in here... 1. Make -fno-monomorphism-restriction and -fno-implicit-prelude reversible, like other flags 2. Fix a wibble in the new ImportAvails story, in RnNames.mkExportAvails 3. Fix a Template Haskell bug that meant that top-level names created with newName were not made properly unique. --- diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index dbfc12a..4c93676 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -18,7 +18,7 @@ Haskell). module Unique ( Unique, Uniquable(..), hasKey, - pprUnique, + pprUnique, mkUnique, -- Used in UniqSupply mkUniqueGrimily, -- Used in UniqSupply only! @@ -202,7 +202,7 @@ We do sometimes make strings with @Uniques@ in them: pprUnique :: Unique -> SDoc pprUnique uniq = case unpkUnique uniq of - (tag, u) -> finish_ppr tag u (iToBase62 u) + (tag, u) -> finish_ppr tag u (text (iToBase62 u)) #ifdef UNUSED pprUnique10 :: Unique -> SDoc @@ -235,19 +235,18 @@ The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints. Code stolen from Lennart. \begin{code} -iToBase62 :: Int -> SDoc - -iToBase62 n@(I# n#) - = ASSERT(n >= 0) - if n# <# 62# then - case (indexCharOffAddr# chars62# n#) of { c -> - char (C# c) } - else - case (quotRem n 62) of { (q, I# r#) -> - case (indexCharOffAddr# chars62# r#) of { c -> - (<>) (iToBase62 q) (char (C# c)) }} +iToBase62 :: Int -> String +iToBase62 n@(I# n#) + = ASSERT(n >= 0) go n# "" where - chars62# = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"# + go n# cs | n# <# 62# + = case (indexCharOffAddr# chars62# n#) of { c# -> C# c# : cs } + | otherwise + = case (quotRem (I# n#) 62) of { (I# q#, I# r#) -> + case (indexCharOffAddr# chars62# r#) of { c# -> + go q# (C# c# : cs) }} + + chars62# = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"# \end{code} %************************************************************************ diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index a57fd76..9a7d0b6 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -15,27 +15,24 @@ import Language.Haskell.TH.Syntax as TH import HsSyn as Hs import qualified Class (FunDep) -import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, nameRdrName, getRdrName ) +import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, getRdrName ) import Module ( Module, mkModule ) -import RdrHsSyn ( mkHsIntegral, mkHsFractional, mkClassDecl, mkTyData ) -import Name ( mkInternalName ) +import RdrHsSyn ( mkClassDecl, mkTyData ) import qualified OccName -import SrcLoc ( SrcLoc, generatedSrcLoc, noLoc, unLoc, Located(..), - noSrcSpan, SrcSpan, srcLocSpan, noSrcLoc ) +import SrcLoc ( generatedSrcLoc, noLoc, unLoc, Located(..), + SrcSpan, srcLocSpan ) import Type ( Type ) -import TysWiredIn ( unitTyCon, tupleTyCon, trueDataCon, falseDataCon ) +import TysWiredIn ( unitTyCon, tupleTyCon, trueDataCon ) import BasicTypes( Boxity(..), RecFlag(Recursive) ) import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..), CExportSpec(..)) -import HsDecls ( CImportSpec(..), ForeignImport(..), ForeignExport(..), - ForeignDecl(..) ) -import FastString( FastString, mkFastString, nilFS ) -import Char ( ord, isAscii, isAlphaNum, isAlpha ) +import Char ( isAscii, isAlphaNum, isAlpha ) import List ( partition ) -import Unique ( Unique, mkUniqueGrimily ) +import Unique ( mkUniqueGrimily ) import ErrUtils (Message) -import GLAEXTS ( Int#, Int(..) ) +import GLAEXTS ( Int(..) ) import Bag ( emptyBag, consBag ) +import FastString import Outputable @@ -371,7 +368,6 @@ cvtPanic herald thing -- some useful things truePat = nlConPat (getRdrName trueDataCon) [] -falsePat = nlConPat (getRdrName falseDataCon) [] overloadedLit :: Lit -> Bool -- True for literals that Haskell treats as overloaded @@ -406,17 +402,21 @@ tconName = thRdrName OccName.tcName thRdrName :: OccName.NameSpace -> TH.Name -> RdrName -- This turns a Name into a RdrName --- The last case is slightly interesting. It constructs a --- unique name from the unique in the TH thingy, so that the renamer --- won't mess about. I hope. (Another possiblity would be to generate --- "x_77" etc, but that could conceivably clash.) -thRdrName ns (TH.Name occ (TH.NameG ns' mod)) = mkOrig (mk_mod mod) (mk_occ ns occ) -thRdrName ns (TH.Name occ TH.NameS) = mkDynName ns occ -thRdrName ns (TH.Name occ (TH.NameU uniq)) = nameRdrName (mkInternalName (mk_uniq uniq) (mk_occ ns occ) noSrcLoc) - -mk_uniq :: Int# -> Unique -mk_uniq u = mkUniqueGrimily (I# u) +thRdrName ns (TH.Name occ (TH.NameG ns' mod)) = mkOrig (mk_mod mod) (mk_occ ns occ) +thRdrName ns (TH.Name occ TH.NameS) = mkDynName ns occ +thRdrName ns (TH.Name occ (TH.NameU uniq)) + = mkRdrUnqual (OccName.mkOccName ns uniq_str) + where + uniq_str = TH.occString occ ++ '[' : shows (mkUniqueGrimily (I# uniq)) "]" + -- The idea here is to make a name that + -- a) the user could not possibly write, and + -- b) cannot clash with another NameU + -- Previously I generated an Exact RdrName with mkInternalName. + -- This works fine for local binders, but does not work at all for + -- top-level binders, which must have External Names, since they are + -- rapidly baked into data constructors and the like. Baling out + -- and generating an unqualified RdrName here is the simple solution -- The packing and unpacking is rather turgid :-( mk_occ :: OccName.NameSpace -> TH.OccName -> OccName.OccName diff --git a/ghc/compiler/iface/IfaceEnv.lhs b/ghc/compiler/iface/IfaceEnv.lhs index 3a3842f..ef729b1 100644 --- a/ghc/compiler/iface/IfaceEnv.lhs +++ b/ghc/compiler/iface/IfaceEnv.lhs @@ -10,7 +10,7 @@ module IfaceEnv ( tcIfaceLclId, tcIfaceTyVar, -- Name-cache stuff - allocateGlobalBinder, initNameCache + allocateGlobalBinder, initNameCache, ) where #include "HsVersions.h" @@ -23,10 +23,11 @@ import TyCon ( TyCon, tyConName ) import DataCon ( dataConWorkId, dataConName ) import Var ( TyVar, Id, varName ) import Name ( Name, nameUnique, nameModule, - nameOccName, nameSrcLoc, + nameOccName, nameSrcLoc, getOccName, nameParent_maybe, isWiredInName, mkIPName, mkExternalName, mkInternalName ) + import OccName ( OccName, isTupleOcc_maybe, tcName, dataName, lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList ) import PrelNames ( gHC_PRIM, pREL_TUP ) diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index 57ba589..ea571d1 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -251,9 +251,9 @@ mkIface :: HscEnv -> Maybe ModIface -- The old interface, if we have it -> ModGuts -- The compiled, tidied module -> IO ModIface -- The new one, complete with decls and versions --- mkFinalIface --- a) completes the interface --- b) writes it out to a file if necessary +-- mkIface +-- a) Builds the ModIface +-- b) Writes it out to a file if necessary mkIface hsc_env location maybe_old_iface guts@ModGuts{ mg_module = this_mod, @@ -774,8 +774,8 @@ mkIfaceExports exports avail_fs = occNameFS (availName avail) add_avail avail_fm _ = addToFM_C add_item avail_fm avail_fs avail - add_item (AvailTC p occs) _ = AvailTC p (insert occ occs) - add_item (Avail n) _ = pprPanic "MkIface.addAvail" (ppr n <+> ppr name) + add_item (AvailTC p occs) _ = AvailTC p (List.insert occ occs) + add_item (Avail n) _ = pprPanic "MkIface.addAvail" (ppr n <+> ppr name) \end{code} diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 6942408..1e282a0 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -265,7 +265,7 @@ data DynFlag | Opt_AllowOverlappingInstances | Opt_AllowUndecidableInstances | Opt_AllowIncoherentInstances - | Opt_NoMonomorphismRestriction + | Opt_MonomorphismRestriction | Opt_GlasgowExts | Opt_FFI | Opt_PArr -- syntactic support for parallel arrays @@ -273,7 +273,7 @@ data DynFlag | Opt_TH | Opt_ImplicitParams | Opt_Generics - | Opt_NoImplicitPrelude + | Opt_ImplicitPrelude -- optimisation opts | Opt_Strictness @@ -391,6 +391,8 @@ defaultDynFlags = DynFlags { pkgState = error "pkgState", flags = [ + Opt_ImplicitPrelude, + Opt_MonomorphismRestriction, Opt_Generics, -- Generating the helper-functions for -- generics is now on by default diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 0aa9563..9f9749d 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -437,11 +437,6 @@ dynamic_flags = [ , ( "fglasgow-exts", NoArg (mapM_ setDynFlag glasgowExtsFlags) ) , ( "fno-glasgow-exts", NoArg (mapM_ unSetDynFlag glasgowExtsFlags) ) - -- "active negatives" - , ( "fno-implicit-prelude", NoArg (setDynFlag Opt_NoImplicitPrelude) ) - , ( "fno-monomorphism-restriction", - NoArg (setDynFlag Opt_NoMonomorphismRestriction) ) - -- the rest of the -f* and -fno-* flags , ( "fno-", PrefixPred (\f -> isFFlag f) (\f -> unSetDynFlag (getFFlag f)) ) , ( "f", PrefixPred (\f -> isFFlag f) (\f -> setDynFlag (getFFlag f)) ) @@ -470,6 +465,8 @@ fFlags = [ ( "arrows", Opt_Arrows ), -- arrow syntax ( "parr", Opt_PArr ), ( "th", Opt_TH ), + ( "implicit-prelude", Opt_ImplicitPrelude ), + ( "monomorphism-restriction", Opt_MonomorphismRestriction ), ( "implicit-params", Opt_ImplicitParams ), ( "allow-overlapping-instances", Opt_AllowOverlappingInstances ), ( "allow-undecidable-instances", Opt_AllowUndecidableInstances ), diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index f695526..dac2df7 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -46,7 +46,7 @@ import HsTypes ( replaceTyVarName ) import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity ) import TcRnMonad import Name ( Name, nameIsLocalOrFrom, mkInternalName, isInternalName, - nameSrcLoc, nameOccName, nameModule, nameParent ) + nameSrcLoc, nameOccName, nameModule, nameParent, isExternalName ) import NameSet import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused ) import Module ( Module ) @@ -73,19 +73,16 @@ import FastString ( FastString ) newTopSrcBinder :: Module -> Maybe Name -> Located RdrName -> RnM Name newTopSrcBinder this_mod mb_parent (L loc rdr_name) | Just name <- isExact_maybe rdr_name - -- This is here to catch + = -- This is here to catch -- (a) Exact-name binders created by Template Haskell -- (b) The PrelBase defn of (say) [] and similar, for which -- the parser reads the special syntax and returns an Exact RdrName - -- - -- We are at a binding site for the name, so check first that it + -- We are at a binding site for the name, so check first that it -- the current module is the correct one; otherwise GHC can get - -- very confused indeed. This test rejects code like - -- data T = (,) Int Int - -- unless we are in GHC.Tup - = do checkErr (isInternalName name || this_mod == nameModule name) - (badOrigBinding rdr_name) - returnM name + -- very confused indeed. + ASSERT2( isExternalName name, ppr name ) + ASSERT2( this_mod == nameModule name, ppr name ) + returnM name | isOrig rdr_name = do checkErr (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) @@ -493,8 +490,8 @@ checks the type of the user thing against the type of the standard thing. lookupSyntaxName :: Name -- The standard name -> RnM (Name, FreeVars) -- Possibly a non-standard name lookupSyntaxName std_name - = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> - if not no_prelude then normal_case + = doptM Opt_ImplicitPrelude `thenM` \ implicit_prelude -> + if implicit_prelude then normal_case else -- Get the similarly named thing from the local environment lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name -> @@ -505,8 +502,8 @@ lookupSyntaxName std_name lookupSyntaxNames :: [Name] -- Standard names -> RnM (ReboundNames Name, FreeVars) -- See comments with HsExpr.ReboundNames lookupSyntaxNames std_names - = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> - if not no_prelude then normal_case + = doptM Opt_ImplicitPrelude `thenM` \ implicit_prelude -> + if implicit_prelude then normal_case else -- Get the similarly named thing from the local environment mappM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names -> diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index e043ab0..5b426fe 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -75,9 +75,9 @@ rnImports imports -- Do the non {- SOURCE -} ones first, so that we get a helpful -- warning for {- SOURCE -} ones that are unnecessary this_mod <- getModule - ; opt_no_prelude <- doptM Opt_NoImplicitPrelude + ; implicit_prelude <- doptM Opt_ImplicitPrelude ; let - all_imports = mk_prel_imports this_mod opt_no_prelude ++ imports + all_imports = mk_prel_imports this_mod implicit_prelude ++ imports (source, ordinary) = partition is_source_import all_imports is_source_import (L _ (ImportDecl _ is_boot _ _ _)) = is_boot @@ -101,10 +101,10 @@ rnImports imports -- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); -- because the former doesn't even look at Prelude.hi for instance -- declarations, whereas the latter does. - mk_prel_imports this_mod no_prelude + mk_prel_imports this_mod implicit_prelude | this_mod == pRELUDE || explicit_prelude_import - || no_prelude + || not implicit_prelude = [] | otherwise = [preludeImportDecl] @@ -251,18 +251,29 @@ exportsToAvails :: [IfaceExport] -> TcRnIf gbl lcl NameSet exportsToAvails exports = foldlM do_one emptyNameSet exports where - do_one acc (mod, exports) = foldlM (do_avail mod) acc exports - do_avail mod acc (Avail n) = do { n' <- lookupOrig mod n; - ; return (addOneToNameSet acc n') } - do_avail mod acc (AvailTC n ns) = do { n' <- lookupOrig mod n - ; ns' <- mappM (lookup_sub n') ns - ; return (addListToNameSet acc (n':ns')) } + do_one acc (mod, exports) = foldlM (do_avail mod) acc exports + do_avail mod acc (Avail n) = do { n' <- lookupOrig mod n; + ; return (addOneToNameSet acc n') } + do_avail mod acc (AvailTC p_occ occs) + = do { p_name <- lookupOrig mod p_occ + ; ns <- mappM (lookup_sub p_name) occs + ; return (addListToNameSet acc ns) } + -- Remember that 'occs' is all the exported things, including + -- the parent. It's possible to export just class ops without + -- the class, via C( op ). If the class was exported too we'd + -- have C( C, op ) where - lookup_sub parent occ = newGlobalBinder mod occ (Just parent) noSrcLoc - -- Hack alert! Notice the newGlobalBinder. It ensures that the subordinate - -- names record their parent; and that in turn ensures that the GlobalRdrEnv - -- has the correct parent for all the names in its range. - -- For imported things, we only suck in the binding site later, if ever. + lookup_sub parent occ + = newGlobalBinder mod occ mb_parent noSrcLoc + where + mb_parent | occ == p_occ = Nothing + | otherwise = Just parent + + -- The use of newGlobalBinder here (rather than lookupOrig) + -- ensures that the subordinate names record their parent; + -- and that in turn ensures that the GlobalRdrEnv + -- has the correct parent for all the names in its range. + -- For imported things, we only suck in the binding site later, if ever. -- Reason for all this: -- Suppose module M exports type A.T, and constructor A.MkT -- Then, we know that A.MkT is a subordinate name of A.T, @@ -309,7 +320,7 @@ importsFromLocalDecls group -- printer returns False. It seems awkward to fix, unfortunately. mappM_ addDupDeclErr dups `thenM_` - doptM Opt_NoImplicitPrelude `thenM` \ implicit_prelude -> + doptM Opt_ImplicitPrelude `thenM` \ implicit_prelude -> let prov = LocalDef this_mod gbl_env = mkGlobalRdrEnv gres @@ -335,8 +346,8 @@ importsFromLocalDecls group -- Sigh. It doesn't matter because it only affects the Data.Tuple really. -- The important thing is to trim down the exports. filtered_names - | implicit_prelude = filter (not . isBuiltInSyntax) all_names - | otherwise = all_names + | implicit_prelude = all_names + | otherwise = filter (not . isBuiltInSyntax) all_names imports = emptyImportAvails { imp_env = unitModuleEnv this_mod $ diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 297ce7e..9db0b3a 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -11,7 +11,7 @@ module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcCheckSigma, tcCheckRho ) -import CmdLineOpts ( DynFlag(Opt_NoMonomorphismRestriction) ) +import CmdLineOpts ( DynFlag(Opt_MonomorphismRestriction) ) import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, Sig(..), LSig, Match(..), HsBindGroup(..), IPBind(..), LPat, GRHSs, MatchGroup(..), emptyLHsBinds, isEmptyLHsBinds, @@ -720,8 +720,8 @@ find which tyvars are constrained. \begin{code} isUnRestrictedGroup :: LHsBinds Name -> [TcSigInfo] -> TcM Bool isUnRestrictedGroup binds sigs - = do { no_MR <- doptM Opt_NoMonomorphismRestriction - ; return (no_MR || all_unrestricted) } + = do { mono_restriction <- doptM Opt_MonomorphismRestriction + ; return (not mono_restriction || all_unrestricted) } where all_unrestricted = all (unrestricted . unLoc) (bagToList binds) tysig_names = map (idName . sig_id) sigs