From: simonpj Date: Thu, 13 Apr 2000 11:56:37 +0000 (+0000) Subject: [project @ 2000-04-13 11:56:35 by simonpj] X-Git-Tag: Approximately_9120_patches~4717 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=9579283cadf4ac68a6f4252244041b5127e16811;p=ghc-hetmet.git [project @ 2000-04-13 11:56:35 by simonpj] Add support for 'packages'. * A package is a group of modules. * A package has a name (e.g. std) * A package is built into a single library (Unix; e.g. libHSstd.a) or a single DLL (Windows; e.g. HSstd.dll) * The '-package-name foo' flag tells GHC that the module being compiled is destined for package foo. * The '-package foo' flag tells GHC to make available modules from package 'foo'. It replaces '-syslib foo' which is now deprecated. * Cross-package references cost an extra indirection in Windows, but not Unix * GHC does not maintain detailed cross-package dependency information. It does remember which modules in other packages the current module depends on, but not which things within those imported things. All of this tidies up the Prelude enormously. The Prelude and Standard Libraries are built into a singl package called 'std'. (This is a change; the library is now called libHSstd.a instead of libHS.a) --- diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 4215354..523fc09 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CLabel.lhs,v 1.32 2000/03/23 17:45:17 simonpj Exp $ +% $Id: CLabel.lhs,v 1.33 2000/04/13 11:56:35 simonpj Exp $ % \section[CLabel]{@CLabel@: Information to make C Labels} @@ -70,8 +70,8 @@ import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl ) import CmdLineOpts ( opt_Static, opt_DoTickyProfiling ) import CStrings ( pp_cSEP ) import DataCon ( ConTag, DataCon ) -import Module ( isDynamicModule, ModuleName, moduleNameString ) -import Name ( Name, getName, isExternallyVisibleName, nameModule, isLocallyDefinedName ) +import Module ( ModuleName ) +import Name ( Name, getName, isDllName, isExternallyVisibleName ) import TyCon ( TyCon ) import Unique ( pprUnique, Unique ) import PrimOp ( PrimOp, pprPrimOp ) @@ -337,12 +337,11 @@ in a DLL, be it a data reference or not. labelDynamic :: CLabel -> Bool labelDynamic lbl = case lbl of - RtsLabel _ -> not opt_Static -- i.e., is the RTS in a DLL or not? - IdLabel n k | not (isLocallyDefinedName n) -> isDynamicModule (nameModule n) - DataConLabel n k | not (isLocallyDefinedName n) -> isDynamicModule (nameModule n) - TyConLabel tc | not (isLocallyDefinedName (getName tc)) -> isDynamicModule (nameModule (getName tc)) - _ -> False - + RtsLabel _ -> not opt_Static -- i.e., is the RTS in a DLL or not? + IdLabel n k -> isDllName n + DataConLabel n k -> isDllName n + TyConLabel tc -> isDllName (getName tc) + _ -> False \end{code} diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index e2210b2..60aca39 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -599,16 +599,14 @@ ppLocalnessMacro include_dyn_prefix clabel = where is_visible = externallyVisibleCLabel clabel label_type = labelType clabel - is_dynamic = labelDynamic clabel visiblity_prefix | is_visible = char 'E' | otherwise = char 'I' dyn_prefix - | not include_dyn_prefix = empty - | is_dynamic = char 'D' - | otherwise = empty + | include_dyn_prefix && labelDynamic clabel = char 'D' + | otherwise = empty \end{code} diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index b998ef2..a9aac4c 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -14,7 +14,7 @@ module DataCon ( dataConFieldLabels, dataConStrictMarks, dataConSourceArity, dataConRepArity, dataConNumInstArgs, dataConId, dataConWrapId, dataConRepStrictness, - isNullaryDataCon, isTupleCon, isUnboxedTupleCon, isDynDataCon, + isNullaryDataCon, isTupleCon, isUnboxedTupleCon, isExistentialDataCon, splitProductType_maybe, splitProductType, @@ -37,7 +37,7 @@ import Type ( Type, ThetaType, TauType, ClassContext, import TyCon ( TyCon, tyConDataCons, isDataTyCon, isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon ) import Class ( classTyCon ) -import Name ( Name, NamedThing(..), nameUnique, isDynName, isLocallyDefined ) +import Name ( Name, NamedThing(..), nameUnique, isLocallyDefined ) import Var ( TyVar, Id ) import FieldLabel ( FieldLabel ) import BasicTypes ( Arity ) @@ -386,9 +386,6 @@ isUnboxedTupleCon (MkData {dcTyCon = tc}) = isUnboxedTupleTyCon tc isExistentialDataCon :: DataCon -> Bool isExistentialDataCon (MkData {dcExTyVars = tvs}) = not (null tvs) - -isDynDataCon :: DataCon -> Bool -isDynDataCon con = isDynName (dataConName con) \end{code} diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index 24b4750..e098db4 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -21,9 +21,9 @@ module Module , mkVanillaModule -- :: ModuleName -> Module , mkThisModule -- :: ModuleName -> Module , mkPrelModule -- :: UserString -> Module + , mkModule -- :: ModuleName -> PackageName -> Module - , isDynamicModule -- :: Module -> Bool - , isPrelModule + , isLocalModule -- :: Module -> Bool , mkSrcModule @@ -32,11 +32,7 @@ module Module , pprModule, pprModuleName - -- DllFlavour - , DllFlavour, dll, notDll - - -- ModFlavour - , ModFlavour, + , PackageName -- Where to find a .hi file , WhereFrom(..), SearchPath, mkSearchPath @@ -48,7 +44,7 @@ module Module import OccName import Outputable import FiniteMap -import CmdLineOpts ( opt_Static, opt_CompilingPrelude, opt_WarnHiShadows, opt_HiMapSep ) +import CmdLineOpts ( opt_Static, opt_InPackage, opt_WarnHiShadows, opt_HiMapSep ) import Constants ( interfaceFileFormatVersion ) import Maybes ( seqMaybe ) import Maybe ( fromMaybe ) @@ -57,6 +53,7 @@ import DirUtils ( getDirectoryContents ) import List ( intersperse ) import Monad ( foldM ) import IO ( hPutStrLn, stderr, isDoesNotExistError ) +import FastString ( FastString ) \end{code} @@ -78,16 +75,18 @@ The logic for how an interface file is marked as corresponding to a module that' hiding in a DLL is explained elsewhere (ToDo: give renamer href here.) \begin{code} -data DllFlavour = NotDll -- Ordinary module - | Dll -- The module's object code lives in a DLL. - deriving( Eq ) +data PackageInfo = ThisPackage -- A module from the same package + -- as the one being compiled + | AnotherPackage PackageName -- A module from a different package + +type PackageName = FastString -- No encoding at all -dll = Dll -notDll = NotDll +preludePackage :: PackageName +preludePackage = SLIT("prelude") -instance Show DllFlavour where -- Just used in debug prints of lex tokens - showsPrec n NotDll s = s - showsPrec n Dll s = "dll " ++ s +instance Show PackageInfo where -- Just used in debug prints of lex tokens + showsPrec n ThisPackage s = s + showsPrec n (AnotherPackage p) s = (_UNPK_ p) ++ s \end{code} @@ -145,19 +144,6 @@ type ModuleName = EncodedFS -- Haskell module names can include the quote character ', -- so the module names have the z-encoding applied to them - -- True for names of prelude modules -isPrelModuleName :: ModuleName -> Bool - -- HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK - -- HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK - -- HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK - -- HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK -isPrelModuleName m = take 4 m_str == "Prel" && m_str /= "PrelInfo" - where m_str = _UNPK_ m - -- HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK - -- HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK - -- HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK - -- HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK - pprModuleName :: ModuleName -> SDoc pprModuleName nm = pprEncodedFS nm @@ -178,10 +164,7 @@ mkSysModuleFS s = s \end{code} \begin{code} -data Module = Module - ModuleName - ModFlavour - DllFlavour +data Module = Module ModuleName PackageInfo \end{code} \begin{code} @@ -189,80 +172,59 @@ instance Outputable Module where ppr = pprModule instance Eq Module where - (Module m1 _ _) == (Module m2 _ _) = m1 == m2 + (Module m1 _) == (Module m2 _) = m1 == m2 instance Ord Module where - (Module m1 _ _) `compare` (Module m2 _ _) = m1 `compare` m2 + (Module m1 _) `compare` (Module m2 _) = m1 `compare` m2 \end{code} \begin{code} pprModule :: Module -> SDoc -pprModule (Module mod _ _) = getPprStyle $ \ sty -> - if userStyle sty then +pprModule (Module mod _) = getPprStyle $ \ sty -> + if userStyle sty then text (moduleNameUserString mod) - else + else pprModuleName mod \end{code} \begin{code} -mkModule :: FilePath -- Directory in which this module is - -> ModuleName -- Name of the module - -> DllFlavour +mkModule :: ModuleName -- Name of the module + -> PackageName -> Module -mkModule dir_path mod_nm is_dll - | isPrelModuleName mod_nm = mkPrelModule mod_nm - | otherwise = Module mod_nm UserMod is_dll - -- Make every module into a 'user module' - -- except those constructed by mkPrelModule - +mkModule mod_nm pack_name + = Module mod_nm pack_info + where + pack_info | pack_name == opt_InPackage = ThisPackage + | otherwise = AnotherPackage pack_name mkVanillaModule :: ModuleName -> Module -mkVanillaModule name = Module name UserMod dell - where - main_mod = mkSrcModuleFS SLIT("Main") - - -- Main can never be in a DLL - need this - -- special case in order to correctly - -- compile PrelMain - dell | opt_Static || opt_CompilingPrelude || - name == main_mod = NotDll - | otherwise = Dll - +mkVanillaModule name = Module name (pprTrace "mkVanillaModule" (ppr name) ThisPackage) + -- Used temporarily when we first come across Foo.x in an interface + -- file, but before we've opened Foo.hi. + -- (Until we've opened Foo.hi we don't know what the PackageInfo is.) mkThisModule :: ModuleName -> Module -- The module being comiled -mkThisModule name = - Module name UserMod NotDll -- This is fine, a Dll flag is only - -- pinned on imported modules. +mkThisModule name = Module name ThisPackage mkPrelModule :: ModuleName -> Module -mkPrelModule name = Module name sys dll - where - sys | opt_CompilingPrelude = UserMod - | otherwise = PrelMod - - dll | opt_Static || opt_CompilingPrelude = NotDll - | otherwise = Dll +mkPrelModule name = mkModule name preludePackage moduleString :: Module -> EncodedString -moduleString (Module mod _ _) = _UNPK_ mod +moduleString (Module mod _) = _UNPK_ mod moduleName :: Module -> ModuleName -moduleName (Module mod _ _) = mod +moduleName (Module mod _) = mod moduleUserString :: Module -> UserString -moduleUserString (Module mod _ _) = moduleNameUserString mod +moduleUserString (Module mod _) = moduleNameUserString mod \end{code} \begin{code} -isDynamicModule :: Module -> Bool -isDynamicModule (Module _ _ Dll) = True -isDynamicModule _ = False - -isPrelModule :: Module -> Bool -isPrelModule (Module _ PrelMod _) = True -isPrelModule _ = False +isLocalModule :: Module -> Bool +isLocalModule (Module _ ThisPackage) = True +isLocalModule _ = False \end{code} @@ -273,10 +235,10 @@ isPrelModule _ = False %************************************************************************ \begin{code} -type ModuleHiMap = FiniteMap ModuleName (String, Module) +type ModuleHiMap = FiniteMap ModuleName String -- Mapping from module name to -- * the file path of its corresponding interface file, - -- * the Module, decorated with it's properties + -- * the ModuleName \end{code} (We allege that) it is quicker to build up a mapping from module names @@ -293,17 +255,6 @@ mkModuleHiMaps dirs = foldM (getAllFilesMatching dirs) (env,env) dirs where env = emptyFM -{- A pseudo file, currently "dLL_ifs.hi", - signals that the interface files - contained in a particular directory have got their - corresponding object codes stashed away in a DLL - - This stuff is only needed to deal with Win32 DLLs, - and conceivably we conditionally compile in support - for handling it. (ToDo?) --} -dir_contain_dll_his = "dLL_ifs.hi" - getAllFilesMatching :: SearchPath -> (ModuleHiMap, ModuleHiMap) -> (FilePath, String) @@ -311,15 +262,7 @@ getAllFilesMatching :: SearchPath getAllFilesMatching dirs hims (dir_path, suffix) = ( do -- fpaths entries do not have dir_path prepended fpaths <- getDirectoryContents dir_path - is_dll <- catch - (if opt_Static || dir_path == "." then - return NotDll - else - do exists <- doesFileExist (dir_path ++ '/': dir_contain_dll_his) - return (if exists then Dll else NotDll) - ) - (\ _ {-don't care-} -> return NotDll) - return (foldl (addModules is_dll) hims fpaths)) + return (foldl addModules hims fpaths)) -- soft failure `catch` (\ err -> do @@ -343,7 +286,7 @@ getAllFilesMatching dirs hims (dir_path, suffix) = ( do reverse (show interfaceFileFormatVersion) ++ '-':hi_boot_xiffus hi_boot_xiffus = "toob-ih." -- .hi-boot reversed! - addModules is_dll his@(hi_env, hib_env) filename = fromMaybe his $ + addModules his@(hi_env, hib_env) filename = fromMaybe his $ FMAP add_hi (go xiffus rev_fname) `seqMaybe` FMAP add_vhib (go hi_boot_version_xiffus rev_fname) `seqMaybe` @@ -363,7 +306,7 @@ getAllFilesMatching dirs hims (dir_path, suffix) = ( do add_hib file_nm = (hi_env, add_to_map addNewOne hib_env file_nm) add_to_map combiner env file_nm - = addToFM_C combiner env mod_nm (path, mkModule dir_path mod_nm is_dll) + = addToFM_C combiner env mod_nm path where mod_nm = mkSrcModuleFS file_nm @@ -379,15 +322,15 @@ getAllFilesMatching dirs hims (dir_path, suffix) = ( do stickWithOld old new = old overrideNew old new = new - conflict (old_path,mod) (new_path,_) + conflict old_path new_path | old_path /= new_path = pprTrace "Warning: " (text "Identically named interface files present on the import path, " $$ text (show old_path) <+> text "shadows" $$ text (show new_path) $$ text "on the import path: " <+> text (concat (intersperse ":" (map fst dirs)))) - (old_path,mod) - | otherwise = (old_path,mod) -- don't warn about innocous shadowings. + old_path + | otherwise = old_path -- don't warn about innocous shadowings. \end{code} diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index c8a382b..ddc7fec 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -25,7 +25,7 @@ module Name ( isUserExportedName, isUserImportedName, isUserImportedExplicitlyName, maybeUserImportedFrom, - nameSrcLoc, isLocallyDefinedName, isDynName, + nameSrcLoc, isLocallyDefinedName, isDllName, isSystemName, isLocalName, isGlobalName, isExternallyVisibleName, @@ -46,9 +46,9 @@ import {-# SOURCE #-} Var ( Id, setIdName ) import {-# SOURCE #-} TyCon ( TyCon, setTyConName ) import OccName -- All of it -import Module ( Module, moduleName, pprModule, mkVanillaModule, isDynamicModule ) +import Module ( Module, moduleName, pprModule, mkVanillaModule, isLocalModule ) import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule ) -import CmdLineOpts ( opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) +import CmdLineOpts ( opt_Static, opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc ) import Unique ( pprUnique, Unique, Uniquable(..), unboundKey, u2i ) @@ -435,10 +435,11 @@ isUserImportedName other = False maybeUserImportedFrom (Name { n_prov = NonLocalDef (UserImport m _ _) _ }) = Just m maybeUserImportedFrom other = Nothing -isDynName :: Name -> Bool - -- Does this name come from a DLL? -isDynName nm = not (isLocallyDefinedName nm) && - isDynamicModule (nameModule nm) +isDllName :: Name -> Bool + -- Does this name refer to something in a different DLL? +isDllName nm = not opt_Static && + not (isLocallyDefinedName nm) && + not (isLocalModule (nameModule nm)) nameSrcLoc name = provSrcLoc (n_prov name) diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index f771fdb..8aeda98 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -45,11 +45,10 @@ import ClosureInfo ( mkClosureLFInfo, mkConLFInfo, mkLFArgument, import CostCentre ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack, currentCCS ) import DataCon ( DataCon, dataConName, dataConTag, dataConTyCon, - isUnboxedTupleCon, isNullaryDataCon, isDynDataCon, dataConId, dataConWrapId + isUnboxedTupleCon, isNullaryDataCon, dataConId, dataConWrapId ) import Id ( Id, idName, idType, idPrimRep ) import Name ( nameModule, isLocallyDefinedName ) -import Module ( isDynamicModule ) import Literal ( Literal(..) ) import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon ) import PrimRep ( PrimRep(..), isFollowableRep ) @@ -100,7 +99,7 @@ cgTopRhsCon id con args top_ccc = mkCCostCentreStack dontCareCCS -- because it's static data -- stuff needed by the assert pred only. - dynamic_con_or_args = isDynDataCon con || any isDynArg args + dynamic_con_or_args = isDllConApp con args \end{code} %************************************************************************ diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 17b23a7..620f060 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -405,7 +405,7 @@ pp_rbinds :: (Outputable id, Outputable pat) pp_rbinds thing rbinds = hang thing - 4 (braces (hsep (punctuate comma (map (pp_rbind) rbinds)))) + 4 (braces (sep (punctuate comma (map (pp_rbind) rbinds)))) where pp_rbind (v, e, pun_flag) = getPprStyle $ \ sty -> diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 3d2bf13..cf2655c 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -119,7 +119,7 @@ module CmdLineOpts ( opt_UF_DearOp, -- misc opts - opt_CompilingPrelude, + opt_InPackage, opt_EmitCExternDecls, opt_EnsureSplittableC, opt_GranMacros, @@ -390,14 +390,15 @@ opt_UnfoldCasms = lookUp SLIT("-funfold-casms-in-hi-file") opt_UsageSPOn = lookUp SLIT("-fusagesp-on") opt_UnboxStrictFields = lookUp SLIT("-funbox-strict-fields") - {- - It's a bit unfortunate to have to re-introduce this chap, but on Win32 - platforms we do need a way of distinguishing between the case when we're - compiling a static version of the Prelude and one that's going to be - put into a DLL. Why? Because the compiler's wired in modules need to - be attributed as either coming from a DLL or not. - -} -opt_CompilingPrelude = lookUp SLIT("-fcompiling-prelude") +{- + The optional '-inpackage=P' flag tells what package + we are compiling this module for. + The Prelude, for example is compiled with '-package prelude' +-} +opt_InPackage = case lookup_str "-inpackage=" of + Just p -> _PK_ p + Nothing -> SLIT("Main") -- The package name if none is specified + opt_EmitCExternDecls = lookUp SLIT("-femit-extern-decls") opt_EnsureSplittableC = lookUp SLIT("-fglobalise-toplev-names") opt_GranMacros = lookUp SLIT("-fgransim") diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 6851765..b540092 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -103,8 +103,9 @@ startIface mod (InterfaceDetails has_orphans import_usages (ExportEnv avails fix Just fn -> do if_hdl <- openFile fn WriteMode - hPutStr if_hdl ("__interface " ++ moduleString mod) - hPutStr if_hdl (' ' : show (opt_HiVersion :: Int) ++ orphan_indicator) + hPutStr if_hdl ("__interface \"" ++ show opt_InPackage ++ "\" " ++ moduleString mod) + hPutStr if_hdl (' ' : show (opt_HiVersion :: Int)) + hPutStr if_hdl (' ' : orphan_indicator) hPutStrLn if_hdl " where" ifaceExports if_hdl avails ifaceImports if_hdl import_usages diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index ad12190..4062b55 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -31,9 +31,10 @@ import OccName ( mkSysOccFS, tcName, varName, ipName, dataName, clsName, tvName, uvName, EncodedFS ) -import Module ( ModuleName, mkSysModuleFS ) +import Module ( ModuleName, PackageName, mkSysModuleFS, mkModule ) import PrelInfo ( mkTupConRdrName, mkUbxTupConRdrName ) import SrcLoc ( SrcLoc ) +import CmdLineOpts ( opt_InPackage ) import Maybes import Outputable @@ -75,7 +76,6 @@ import Ratio ( (%) ) 'then' { ITthen } 'type' { ITtype } 'where' { ITwhere } ---???? 'scc' { ITscc } 'forall' { ITforall } -- GHC extension keywords 'foreign' { ITforeign } @@ -176,31 +176,31 @@ import Ratio ( (%) ) -- (c) the IdInfo part of a signature (same reason) iface_stuff :: { IfaceStuff } -iface_stuff : iface { let (nm, iff) = $1 in PIface nm iff } +iface_stuff : iface { PIface $1 } | type { PType $1 } | id_info { PIdInfo $1 } | '__R' rules { PRules $2 } | '__D' deprecs { PDeprecs $2 } -iface :: { (ModuleName, ParsedIface) } -iface : '__interface' mod_fs INTEGER orphans checkVersion 'where' +iface :: { ParsedIface } +iface : '__interface' package mod_name INTEGER orphans checkVersion 'where' exports_part import_part instance_decl_part decls_part rules_and_deprecs - { ( $2 -- Module name - , ParsedIface { - pi_mod = fromInteger $3, -- Module version - pi_orphan = $4, - pi_exports = $7, -- Exports - pi_usages = $8, -- Usages - pi_insts = $9, -- Local instances - pi_decls = $10, -- Decls - pi_rules = fst $11, -- Rules - pi_deprecs = snd $11 -- Deprecations - } ) } + { ParsedIface { + pi_mod = mkModule $3 $2, -- Module itself + pi_vers = fromInteger $4, -- Module version + pi_orphan = $5, + pi_exports = $8, -- Exports + pi_usages = $9, -- Usages + pi_insts = $10, -- Local instances + pi_decls = $11, -- Decls + pi_rules = fst $12, -- Rules + pi_deprecs = snd $12 -- Deprecations + } } -------------------------------------------------------------------------- @@ -209,12 +209,11 @@ import_part : { [] } | import_part import_decl { $2 : $1 } import_decl :: { ImportVersion OccName } -import_decl : 'import' mod_fs INTEGER orphans is_boot whats_imported ';' +import_decl : 'import' mod_name INTEGER orphans is_boot whats_imported ';' { (mkSysModuleFS $2, fromInteger $3, $4, $5, $6) } -- import Foo 3 :: a 1 b 3 c 7 ; means import a,b,c from Foo -- import Foo 3 ; means import all of Foo - -- import Foo 3 ! @ :: ...stuff... ; the ! means that Foo contains orphans - -- and @ that Foo is a boot interface + -- import Foo 3 ! :: ...stuff... ; the ! means that Foo contains orphans orphans :: { WhetherHasOrphans } orphans : { False } @@ -242,7 +241,7 @@ name_version_pair : var_occ INTEGER { ($1, fromInteger $2) } exports_part :: { [ExportItem] } exports_part : { [] } | exports_part '__export' - mod_fs entities ';' { (mkSysModuleFS $3, $4) : $1 } + mod_name entities ';' { (mkSysModuleFS $3, $4) : $1 } entities :: { [RdrAvailInfo] } entities : { [] } @@ -506,11 +505,14 @@ atypes :: { [RdrNameHsType] {- Zero or more -} } atypes : { [] } | atype atypes { $1 : $2 } --------------------------------------------------------------------- -mod_fs :: { EncodedFS } - : CONID { $1 } +package :: { PackageName } + : STRING { $1 } + | {- empty -} { opt_InPackage } -- Useful for .hi-boot files, + -- which can omit the package Id + -- Module loops are always within a package mod_name :: { ModuleName } - : mod_fs { mkSysModuleFS $1 } + : CONID { mkSysModuleFS $1 } --------------------------------------------------- @@ -868,7 +870,7 @@ checkVersion :: { () } happyError :: P a happyError buf PState{ loc = loc } = PFailed (ifaceParseErr buf loc) -data IfaceStuff = PIface EncodedFS{-.hi module name-} ParsedIface +data IfaceStuff = PIface ParsedIface | PIdInfo [HsIdInfo RdrName] | PType RdrNameHsType | PRules [RdrNameRuleDecl] diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 5a563a0..3f27194 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -344,8 +344,8 @@ slurpSourceRefs source_binders source_fvs -- the free variables returned are simply 'listTyCon_Name', -- with a system provenance. We could look them up every time -- but that seems a waste. - | otherwise = loadHomeInterface doc name `thenRn_` - returnRn () + | otherwise = loadHomeInterface doc name `thenRn_` + returnRn () where doc = ptext SLIT("need home module for wired in thing") <+> ppr name diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index b47ecdb..1ab1482 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -35,7 +35,7 @@ import OccName ( OccName, ) import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon ) import Type ( funTyCon ) -import Module ( ModuleName, mkThisModule, moduleName ) +import Module ( ModuleName, mkThisModule, moduleName, mkVanillaModule ) import TyCon ( TyCon ) import FiniteMap import Unique ( Unique, Uniquable(..) ) @@ -92,8 +92,7 @@ newImportedBinder mod rdr_name -- Make an imported global name, checking first to see if it's in the cache mkImportedGlobalName :: ModuleName -> OccName -> RnM d Name mkImportedGlobalName mod_name occ - = lookupModuleRn mod_name `thenRn` \ mod -> - newImportedGlobalName mod_name occ mod + = newImportedGlobalName mod_name occ (mkVanillaModule mod_name) mkImportedGlobalFromRdrName :: RdrName -> RnM d Name mkImportedGlobalFromRdrName rdr_name diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 7368d34..7a27d29 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -50,7 +50,7 @@ import Name ( Name {-instance NamedThing-}, ) import Module ( Module, moduleString, pprModule, mkVanillaModule, pprModuleName, - moduleUserString, moduleName, isPrelModule, + moduleUserString, moduleName, isLocalModule, ModuleName, WhereFrom(..), ) import RdrName ( RdrName, rdrNameOcc ) @@ -102,41 +102,54 @@ loadInterface doc_str mod_name from let mod_map = iImpModInfo ifaces mod_info = lookupFM mod_map mod_name - below_me = case mod_info of - Nothing -> False - Just (_, _, is_boot, _) -> not is_boot - in - - -- Issue a warning for a redundant {- SOURCE -} import - -- It's redundant if the moduld is in the iImpModInfo at all, - -- because we arrange to read all the ordinary imports before - -- any of the {- SOURCE -} imports - warnCheckRn (not (below_me && case from of {ImportByUserSource -> True; other -> False})) - (warnRedundantSourceImport mod_name) `thenRn_` + hi_boot_file = case from of { + ImportByUser -> False ; -- Not hi-boot + ImportByUserSource -> True ; -- hi-boot + ImportBySystem -> + case mod_info of + Just (_, _, is_boot, _) -> is_boot + + Nothing -> False + -- We're importing a module we know absolutely + -- nothing about, so we assume it's from + -- another package, where we aren't doing + -- dependency tracking. So it won't be a hi-boot file. + } + redundant_source_import + = case (from, mod_info) of + (ImportByUserSource, Just (_,_,False,_)) -> True + other -> False + in -- CHECK WHETHER WE HAVE IT ALREADY case mod_info of { - Just (_, _, _, Just (load_mod, _)) + Just (_, _, _, Just (load_mod, _, _)) -> -- We're read it already so don't re-read it returnRn (load_mod, ifaces) ; - mod_map_result -> + _ -> + + -- Issue a warning for a redundant {- SOURCE -} import + -- NB that we arrange to read all the ordinary imports before + -- any of the {- SOURCE -} imports + warnCheckRn (not redundant_source_import) + (warnRedundantSourceImport mod_name) `thenRn_` -- READ THE MODULE IN - findAndReadIface doc_str mod_name from below_me `thenRn` \ (hi_boot_read, read_result) -> + findAndReadIface doc_str mod_name hi_boot_file `thenRn` \ read_result -> case read_result of { Nothing -> -- Not found, so add an empty export env to the Ifaces map -- so that we don't look again let mod = mkVanillaModule mod_name - new_mod_map = addToFM mod_map mod_name (0, False, False, Just (mod, [])) + new_mod_map = addToFM mod_map mod_name (0, False, False, Just (mod, from, [])) new_ifaces = ifaces { iImpModInfo = new_mod_map } in setIfacesRn new_ifaces `thenRn_` - failWithRn (mod, new_ifaces) (noIfaceErr mod hi_boot_read) ; + failWithRn (mod, new_ifaces) (noIfaceErr mod hi_boot_file) ; -- Found and parsed! - Just (mod, iface) -> + Just iface -> -- LOAD IT INTO Ifaces @@ -148,7 +161,14 @@ loadInterface doc_str mod_name from getModuleRn `thenRn` \ this_mod_nm -> let rd_decls = pi_decls iface + mod = pi_mod iface in + -- Sanity check. If we're system-importing a module we know nothing at all + -- about, it should be from a different package to this one + WARN( not (maybeToBool mod_info) && + case from of { ImportBySystem -> True; other -> False } && + isLocalModule mod, + ppr mod ) foldlRn (loadDecl mod) (iDecls ifaces) rd_decls `thenRn` \ new_decls -> foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts -> (if opt_IgnoreIfacePragmas @@ -164,12 +184,13 @@ loadInterface doc_str mod_name from -- the things the imported module depends on, extracted -- from its usage info. mod_map1 = case from of - ImportByUser -> addModDeps mod mod_map (pi_usages iface) + ImportByUser -> addModDeps mod (pi_usages iface) mod_map other -> mod_map -- Now add info about this module mod_map2 = addToFM mod_map1 mod_name mod_details - mod_details = (pi_mod iface, pi_orphan iface, hi_boot_read, Just (mod, concat avails_s)) + cts = (pi_mod iface, from, concat avails_s) + mod_details = (pi_vers iface, pi_orphan iface, hi_boot_file, Just cts) new_ifaces = ifaces { iImpModInfo = mod_map2, iDecls = new_decls, @@ -182,18 +203,25 @@ loadInterface doc_str mod_name from returnRn (mod, new_ifaces) }} -addModDeps :: Module -> ImportedModuleInfo - -> [ImportVersion a] -> ImportedModuleInfo -addModDeps mod mod_deps new_deps - = foldr add mod_deps new_deps +addModDeps :: Module -> [ImportVersion a] + -> ImportedModuleInfo -> ImportedModuleInfo +-- (addModDeps M ivs deps) +-- We are importing module M, and M.hi contains 'import' decls given by ivs +addModDeps mod new_deps mod_deps + = foldr add mod_deps filtered_new_deps where - is_lib = isPrelModule mod -- Don't record dependencies when importing a prelude module - add (imp_mod, version, has_orphans, is_boot, _) deps - | is_lib && not has_orphans = deps - | otherwise = addToFM_C combine deps imp_mod (version, has_orphans, is_boot, Nothing) - -- Record dependencies for modules that are - -- either are dependent via a non-library module - -- or contain orphan rules or instance decls + -- Don't record dependencies when importing a module from another package + -- Except for its descendents which contain orphans, + -- and in that case, forget about the boot indicator + filtered_new_deps + | isLocalModule mod = [ (imp_mod, (version, has_orphans, is_boot, Nothing)) + | (imp_mod, version, has_orphans, is_boot, _) <- new_deps + ] + | otherwise = [ (imp_mod, (version, True, False, Nothing)) + | (imp_mod, version, has_orphans, _, _) <- new_deps, + has_orphans + ] + add (imp_mod, dep) deps = addToFM_C combine deps imp_mod dep combine old@(_, _, old_is_boot, cts) new | maybeToBool cts || not old_is_boot = old -- Keep the old info if it's already loaded @@ -375,28 +403,32 @@ namesFromIE (IEModuleContents _ ) = [] %******************************************************** \begin{code} -checkUpToDate :: ModuleName -> RnMG Bool -- True <=> no need to recompile +upToDate = True +outOfDate = False + +checkUpToDate :: ModuleName -> RnMG Bool -- True <=> no need to recompile + -- When this guy is called, we already know that the + -- source code is unchanged from last time checkUpToDate mod_name = getIfacesRn `thenRn` \ ifaces -> findAndReadIface doc_str mod_name - ImportByUser - (error "checkUpToDate") `thenRn` \ (_, read_result) -> + False {- Not hi-boot -} `thenRn` \ read_result -> -- CHECK WHETHER WE HAVE IT ALREADY case read_result of Nothing -> -- Old interface file not found, so we'd better bail out traceRn (sep [ptext SLIT("Didnt find old iface"), pprModuleName mod_name]) `thenRn_` - returnRn False + returnRn outOfDate - Just (_, iface) + Just iface -> -- Found it, so now check it checkModUsage (pi_usages iface) where -- Only look in current directory, with suffix .hi doc_str = sep [ptext SLIT("need usage info from"), pprModuleName mod_name] -checkModUsage [] = returnRn True -- Yes! Everything is up to date! +checkModUsage [] = returnRn upToDate -- Yes! Everything is up to date! checkModUsage ((mod_name, old_mod_vers, _, _, Specifically []) : rest) -- If CurrentModule.hi contains @@ -407,19 +439,19 @@ checkModUsage ((mod_name, old_mod_vers, _, _, Specifically []) : rest) = traceRn (ptext SLIT("Nothing used from:") <+> ppr mod_name) `thenRn_` checkModUsage rest -- This one's ok, so check the rest -checkModUsage ((mod_name, old_mod_vers, _, _, whats_imported) : rest) +checkModUsage ((mod_name, old_mod_vers, _, _, whats_imported) : rest) = loadInterface doc_str mod_name ImportBySystem `thenRn` \ (mod, ifaces) -> let maybe_mod_vers = case lookupFM (iImpModInfo ifaces) mod_name of - Just (version, _, _, Just (_, _)) -> Just version - other -> Nothing + Just (version, _, _, Just (_, _, _)) -> Just version + other -> Nothing in case maybe_mod_vers of { Nothing -> -- If we can't find a version number for the old module then -- bail out saying things aren't up to date traceRn (sep [ptext SLIT("Can't find version number for module"), pprModuleName mod_name]) - `thenRn_` returnRn False ; + `thenRn_` returnRn outOfDate ; Just new_mod_vers -> @@ -437,7 +469,7 @@ checkModUsage ((mod_name, old_mod_vers, _, _, whats_imported) : rest) -- In that case, we must recompile case whats_imported of { Everything -> traceRn (ptext SLIT("...and I needed the whole module")) `thenRn_` - returnRn False; -- Bale out + returnRn outOfDate; -- Bale out Specifically old_local_vers -> @@ -447,14 +479,14 @@ checkModUsage ((mod_name, old_mod_vers, _, _, whats_imported) : rest) traceRn (ptext SLIT("...but the bits I use haven't.")) `thenRn_` checkModUsage rest -- This one's ok, so check the rest else - returnRn False -- This one failed, so just bail out now + returnRn outOfDate -- This one failed, so just bail out now }} where doc_str = sep [ptext SLIT("need version info for"), pprModuleName mod_name] checkEntityUsage mod decls [] - = returnRn True -- Yes! All up to date! + = returnRn upToDate -- Yes! All up to date! checkEntityUsage mod decls ((occ_name,old_vers) : rest) = mkImportedGlobalName mod occ_name `thenRn` \ name -> @@ -462,7 +494,7 @@ checkEntityUsage mod decls ((occ_name,old_vers) : rest) Nothing -> -- We used it before, but it ain't there now traceRn (sep [ptext SLIT("No longer exported:"), ppr name]) - `thenRn_` returnRn False + `thenRn_` returnRn outOfDate Just (new_vers,_,_,_) -- It's there, but is it up to date? | new_vers == old_vers @@ -472,7 +504,7 @@ checkEntityUsage mod decls ((occ_name,old_vers) : rest) | otherwise -- Out of date, so bale out -> traceRn (sep [ptext SLIT("Out of date:"), ppr name]) `thenRn_` - returnRn False + returnRn outOfDate \end{code} @@ -564,7 +596,7 @@ getInterfaceExports mod_name from -- anyway, but this does no harm.) returnRn (mod, []) - Just (_, _, _, Just (mod, avails)) -> returnRn (mod, avails) + Just (_, _, _, Just (mod, _, avails)) -> returnRn (mod, avails) where doc_str = sep [pprModuleName mod_name, ptext SLIT("is directly imported")] \end{code} @@ -605,12 +637,6 @@ getImportedInstDecls gates where gate_list = nameSetToList gates - load_home gate | isLocallyDefined gate - = returnRn () - | otherwise - = loadHomeInterface (ppr gate <+> text "is an instance gate") gate `thenRn_` - returnRn () - ppr_brief_inst_decl (mod, InstD (InstDecl inst_ty _ _ _ _)) = case inst_ty of HsForAllTy _ _ tau -> ppr tau @@ -776,10 +802,11 @@ getImportVersions this_mod (ExportEnv _ _ export_all_mods) -- Foo in the module dependency hierarchy. We want to propagate this -- information. The Nothing says that we didn't even open the interface -- file but we must still propagate the dependeny info. + -- The module in question must be a local module (in the same package) go_for_it (Specifically []) - Just (mod, _) -- We did open the interface - | is_lib_module && not has_orphans + Just (mod, how_imported, _) + | is_sys_import && is_lib_module && not has_orphans -> so_far | is_lib_module -- Record the module but not detailed @@ -795,7 +822,10 @@ getImportVersions this_mod (ExportEnv _ _ export_all_mods) -- but don't actually *use* anything from Foo -- In which case record an empty dependency list where - is_lib_module = isPrelModule mod + is_lib_module = not (isLocalModule mod) + is_sys_import = case how_imported of + ImportBySystem -> True + other -> False in @@ -945,51 +975,35 @@ getDeclSysBinders new_name other_decl %********************************************************* \begin{code} -findAndReadIface :: SDoc -> ModuleName -> WhereFrom - -> Bool -- Only relevant for SystemImport - -- True <=> Look for a .hi file - -- False <=> Look for .hi-boot file unless there's - -- a library .hi file - -> RnM d (Bool, Maybe (Module, ParsedIface)) - -- Bool is True if the interface actually read was a .hi-boot one +findAndReadIface :: SDoc -> ModuleName + -> IsBootInterface -- True <=> Look for a .hi-boot file + -- False <=> Look for .hi file + -> RnM d (Maybe ParsedIface) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed -findAndReadIface doc_str mod_name from hi_file +findAndReadIface doc_str mod_name hi_boot_file = traceRn trace_msg `thenRn_` -- we keep two maps for interface files, -- one for 'normal' ones, the other for .hi-boot files, -- hence the need to signal which kind we're interested. - getHiMaps `thenRn` \ hi_maps -> + getHiMaps `thenRn` \ (hi_map, hiboot_map) -> + let + relevant_map | hi_boot_file = hiboot_map + | otherwise = hi_map + in + case lookupFM relevant_map mod_name of + -- Found the file + Just fpath -> traceRn (ptext SLIT("...reading from") <+> text fpath) `thenRn_` + readIface mod_name fpath - case find_path from hi_maps of - -- Found the file - (hi_boot, Just (fpath, mod)) -> traceRn (ptext SLIT("...reading from") <+> text fpath) - `thenRn_` - readIface mod fpath `thenRn` \ result -> - returnRn (hi_boot, result) - (hi_boot, Nothing) -> traceRn (ptext SLIT("...not found")) `thenRn_` - returnRn (hi_boot, Nothing) + -- Can't find it + Nothing -> traceRn (ptext SLIT("...not found")) `thenRn_` + returnRn Nothing where - find_path ImportByUser (hi_map, _) = (False, lookupFM hi_map mod_name) - find_path ImportByUserSource (_, hiboot_map) = (True, lookupFM hiboot_map mod_name) - - find_path ImportBySystem (hi_map, hiboot_map) - | hi_file - = -- If the module we seek is in our dependent set, - -- Look for a .hi file - (False, lookupFM hi_map mod_name) - - | otherwise - -- Check if there's a prelude module of that name - -- If not, look for an hi-boot file - = case lookupFM hi_map mod_name of - stuff@(Just (_, mod)) | isPrelModule mod -> (False, stuff) - other -> (True, lookupFM hiboot_map mod_name) - trace_msg = sep [hsep [ptext SLIT("Reading"), - ppr from, + if hi_boot_file then ptext SLIT("[boot]") else empty, ptext SLIT("interface for"), pprModuleName mod_name <> semi], nest 4 (ptext SLIT("reason:") <+> doc_str)] @@ -998,10 +1012,10 @@ findAndReadIface doc_str mod_name from hi_file @readIface@ tries just the one file. \begin{code} -readIface :: Module -> String -> RnM d (Maybe (Module, ParsedIface)) +readIface :: ModuleName -> String -> RnM d (Maybe ParsedIface) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed -readIface the_mod file_path +readIface wanted_mod file_path = ioToRnM (hGetStringBuffer False file_path) `thenRn` \ read_result -> case read_result of Right contents -> @@ -1010,10 +1024,12 @@ readIface the_mod file_path context = [], glasgow_exts = 1#, loc = mkSrcLoc (mkFastString file_path) 1 } of - POk _ (PIface mod_nm iface) -> - warnCheckRn (mod_nm == moduleName the_mod) - (hiModuleNameMismatchWarn the_mod mod_nm) `thenRn_` - returnRn (Just (the_mod, iface)) + POk _ (PIface iface) -> + warnCheckRn (read_mod == wanted_mod) + (hiModuleNameMismatchWarn wanted_mod read_mod) `thenRn_` + returnRn (Just iface) + where + read_mod = moduleName (pi_mod iface) PFailed err -> failWithRn Nothing err other -> failWithRn Nothing (ptext SLIT("Unrecognisable interface file")) @@ -1068,12 +1084,12 @@ warnRedundantSourceImport mod_name = ptext SLIT("Unnecessary {- SOURCE -} in the import of module") <+> quotes (pprModuleName mod_name) -hiModuleNameMismatchWarn :: Module -> ModuleName -> Message -hiModuleNameMismatchWarn requested_mod mod_nm = +hiModuleNameMismatchWarn :: ModuleName -> ModuleName -> Message +hiModuleNameMismatchWarn requested_mod read_mod = hsep [ ptext SLIT("Something is amiss; requested module name") - , pprModule requested_mod - , ptext SLIT("differs from name found in the interface file ") - , pprModuleName mod_nm + , pprModuleName requested_mod + , ptext SLIT("differs from name found in the interface file") + , pprModuleName read_mod ] \end{code} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 197f6ae..ca2ac10 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -287,7 +287,8 @@ type LocalVersion name = (name, Version) data ParsedIface = ParsedIface { - pi_mod :: Version, -- Module version number + pi_mod :: Module, -- Complete with package info + pi_vers :: Version, -- Module version number pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans pi_usages :: [ImportVersion OccName], -- Usages pi_exports :: [ExportItem], -- Exports @@ -349,7 +350,8 @@ data Ifaces = Ifaces { type GatedDecl = (NameSet, (Module, RdrNameHsDecl)) type ImportedModuleInfo - = FiniteMap ModuleName (Version, WhetherHasOrphans, IsBootInterface, Maybe (Module, Avails)) + = FiniteMap ModuleName (Version, WhetherHasOrphans, IsBootInterface, + Maybe (Module, WhereFrom, Avails)) -- Suppose the domain element is module 'A' -- -- The first Bool is True if A contains @@ -752,12 +754,4 @@ getHiMaps :: RnM d (ModuleHiMap, ModuleHiMap) getHiMaps (RnDown {rn_hi_maps = himaps}) _ = return himaps \end{code} - -\begin{code} -lookupModuleRn :: ModuleName -> RnM d Module -lookupModuleRn x = - getHiMaps `thenRn` \ (himap, _) -> - case lookupFM himap x of - Nothing -> returnRn (mkVanillaModule x) - Just (_,x) -> returnRn x \end{code} diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 6e2d065..481c6f5 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -27,10 +27,9 @@ import Id ( Id, mkSysLocal, idType, idStrictness, idUnique, isExportedId, mkVan import Var ( Var, varType, modifyIdInfo ) import IdInfo ( setDemandInfo, StrictnessInfo(..), IdFlavour(..) ) import UsageSPUtils ( primOpUsgTys ) -import DataCon ( DataCon, dataConName, isDynDataCon, dataConWrapId ) +import DataCon ( DataCon, dataConName, dataConWrapId ) import Demand ( Demand, isStrict, wwStrict, wwLazy ) import Name ( Name, nameModule, isLocallyDefinedName, setNameUnique ) -import Module ( isDynamicModule ) import Literal ( Literal(..) ) import VarEnv import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..), primOpUsg ) @@ -302,12 +301,9 @@ exprToRhs dem _ (StgLam _ bndrs body) then be run at load time to fix up static closures. -} exprToRhs dem toplev (StgConApp con args) - | isNotTopLevel toplev || - (not is_dynamic && - all (not . isLitLitArg) args) + | isNotTopLevel toplev || not (isDllConApp con args) + -- isDllConApp checks for LitLit args too = StgRhsCon noCCS con args - where - is_dynamic = isDynDataCon con || any (isDynArg) args exprToRhs dem _ expr = upd `seq` diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 759c174..aacde30 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -33,7 +33,7 @@ module StgSyn ( pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs, getArgPrimRep, - isLitLitArg, isDynArg, isStgTypeArg, + isLitLitArg, isDllConApp, isStgTypeArg, stgArity, stgArgType, collectFinalStgBinders @@ -46,9 +46,9 @@ module StgSyn ( import CostCentre ( CostCentreStack, CostCentre ) import Id ( Id, idName, idPrimRep, idType ) -import Name ( isDynName ) +import Name ( isDllName ) import Literal ( Literal, literalType, isLitLitLit, literalPrimRep ) -import DataCon ( DataCon, isDynDataCon, isNullaryDataCon ) +import DataCon ( DataCon, dataConName, isNullaryDataCon ) import PrimOp ( PrimOp ) import PrimRep ( PrimRep(..) ) import Outputable @@ -96,10 +96,16 @@ isLitLitArg _ = False isStgTypeArg (StgTypeArg _) = True isStgTypeArg other = False -isDynArg :: StgArg -> Bool - -- Does this argument refer to something in a DLL? -isDynArg (StgVarArg v) = isDynName (idName v) -isDynArg (StgLitArg lit) = isLitLitLit lit +isDllArg :: StgArg -> Bool + -- Does this argument refer to something in a different DLL? +isDllArg (StgVarArg v) = isDllName (idName v) +isDllArg (StgLitArg lit) = isLitLitLit lit + +isDllConApp :: DataCon -> [StgArg] -> Bool + -- Does this constructor application refer to + -- anything in a different DLL? + -- If so, we can't allocate it statically +isDllConApp con args = isDllName (dataConName con) || any isDllArg args stgArgType :: StgArg -> Type -- Very half baked becase we have lost the type arguments diff --git a/ghc/driver/ghc-iface.lprl b/ghc/driver/ghc-iface.lprl index 80ce281..90424c5 100644 --- a/ghc/driver/ghc-iface.lprl +++ b/ghc/driver/ghc-iface.lprl @@ -153,7 +153,7 @@ sub constructNewHiFile { } local($new_module_version) = &calcNewModuleVersion(@decl_names); - print NEWHI "__interface ", $ModuleName{'new'}, " $new_module_version $Orphan{'new'} $ProjectVersionInt where\n"; + print NEWHI "__interface ", $PackageName{'new'}, $ModuleName{'new'}, " $new_module_version $Orphan{'new'} $ProjectVersionInt where\n"; print NEWHI $Stuff{'new:exports'}; print NEWHI $Stuff{'new:usages'} unless $Stuff{'new:usages'} eq ''; print NEWHI $Stuff{'new:instances'} unless $Stuff{'new:instances'} eq ''; @@ -211,14 +211,15 @@ sub readHiFile { hi_line: while () { next if /^ *$/; # blank line - if ( /^__interface ([A-Z]\S*) (\d+)( \!)?/ ) { + if ( /^__interface ("[A-Za-z]*"\s*)([A-Z]\S*) (\d+) (\!)?/ ) { if ( $mod ne 'new' ) { # Reading old .hi file - $ModuleVersion{$mod} = $2; + $ModuleVersion{$mod} = $3; } - $ModuleName{$mod} = $1; # used to decide name of iface file. - $Orphan{$mod} = $3; + $PackageName{$mod} = $1; + $ModuleName{$mod} = $2; # used to decide name of iface file. + $Orphan{$mod} = $4; # optional "!" indicates that the # module contains orphan rules or instance decls diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl index a8af730..8e4b16f 100644 --- a/ghc/driver/ghc.lprl +++ b/ghc/driver/ghc.lprl @@ -1147,7 +1147,7 @@ sub setupIncPaths { \begin{code} sub setupSyslibs { - push(@SysLibrary, ( '-lHS', '-lHS_cbits' )); # basic I/O and prelude stuff + push(@SysLibrary, ( '-lHSstd', '-lHSstd_cbits' )); # basic I/O and prelude stuff local($f); foreach $f (@SysLibrary) { @@ -2789,7 +2789,7 @@ sub splitCmdLine { arg: while($_ = $args[0]) { shift(@args); # sigh, we have to deal with these -option arg specially here. - /^-(tmpdir|odir|ohi|o|isuf|osuf|hisuf|odump|syslib)$/ && + /^-(tmpdir|odir|ohi|o|isuf|osuf|hisuf|odump|syslib|package|package-name)$/ && do { push(@Cmd_opts, $_); push(@Cmd_opts,$args[0]); shift(@args); next arg; }; /^--?./ && do { push(@Cmd_opts, $_); next arg; }; @@ -3082,10 +3082,21 @@ arg: while($_ = $Args[0]) { /^-L(.*)/ && do { push(@UserLibrary_dir, &grab_arg_arg(*Args,'-L', $1)); next arg; }; /^-l(.*)/ && do { push(@UserLibrary,'-l'.&grab_arg_arg(*Args,'-l', $1)); next arg; }; + # DEPRECATED: use -package instead /^-syslib(.*)/ && do { local($syslib) = &grab_arg_arg(*Args,'-syslib',$1); &add_syslib($syslib); next arg; }; + /^-package-name(.*)/ && do + { local($package) = &grab_arg_arg(*Args,'-package-name',$1); + push(@HsC_flags,"-inpackage=$package"); + next arg; + }; + + /^-package(.*)/ && do { local($package) = &grab_arg_arg(*Args,'-package',$1); + &add_syslib($package); + next arg; }; + #======================================================================= # various flags that we can harmlessly send to one program or another # (we will later "reclaim" some of the compiler ones now sent to gcc) diff --git a/ghc/lib/std/Makefile b/ghc/lib/std/Makefile index 96400f9..a41492a 100644 --- a/ghc/lib/std/Makefile +++ b/ghc/lib/std/Makefile @@ -25,7 +25,9 @@ endif HC = $(GHC_INPLACE) MKDEPENDHS = $(GHC_INPLACE) -LIBRARY = libHS$(_way).a +PACKAGE = std +LIBRARY = libHS$(PACKAGE)$(_way).a + LIBOBJS = $(HS_OBJS) ifeq "$(TARGETPLATFORM)" "i386-unknown-mingw32" LIBOBJS = $(filter-out PrelHugs.$(way_)o,$(HS_OBJS)) @@ -34,7 +36,7 @@ endif #----------------------------------------------------------------------------- # Setting the GHC compile options -SRC_HC_OPTS += -recomp -cpp -fglasgow-exts -fvia-C -Rghc-timing $(GhcLibHcOpts) +SRC_HC_OPTS += -recomp -cpp -fglasgow-exts -fvia-C -Rghc-timing $(GhcLibHcOpts) -package-name $(PACKAGE) ifneq "$(way)" "dll" SRC_HC_OPTS += -static endif @@ -82,9 +84,9 @@ boot :: PrelGHC.hi $(foreach way, $(WAYS), PrelGHC.$(way)_hi) DLL_NAME = HSprel.dll DLL_DESCRIPTION="GHC-compiled Haskell Prelude" -DLL_IMPLIB_NAME = libHS_imp.a +DLL_IMPLIB_NAME = libHSstd_imp.a SRC_BLD_DLL_OPTS += --export-all --output-def=HSprel.def DllVersionInfo.o -SRC_BLD_DLL_OPTS += -lwinmm -lHSrts_imp -lHS_cbits_imp -lgmp -L. -L../../rts/gmp -L../../rts -Lcbits +SRC_BLD_DLL_OPTS += -lwinmm -lHSrts_imp -lHSstd_cbits_imp -lgmp -L. -L../../rts/gmp -L../../rts -Lcbits ifeq "$(way)" "dll" HS_SRCS := $(filter-out PrelMain.lhs PrelHugs.lhs, $(HS_SRCS)) @@ -127,11 +129,11 @@ endif # which hugs can load as an auxiliary object file when loading the Prelude. # ifeq "$(way)" "u" -all :: libHS_cbits.u_o -CLEAN_FILES += libHS_cbits.u_o -libHS_cbits.u_o: - $(RM) libHS_cbits.u_o - ld -r -o libHS_cbits.u_o cbits/*.o +all :: libHSstd_cbits.u_o +CLEAN_FILES += libHSstd_cbits.u_o +libHSstd_cbits.u_o: + $(RM) libHSstd_cbits.u_o + ld -r -o libHSstd_cbits.u_o cbits/*.o endif #----------------------------------------------------------------------------- diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs index e9160ea..7ed127c 100644 --- a/ghc/lib/std/PrelBase.lhs +++ b/ghc/lib/std/PrelBase.lhs @@ -82,6 +82,9 @@ module PrelBase where import {-# SOURCE #-} PrelErr ( error ) +import {-# SOURCE #-} PrelNum ( addr2Integer ) + -- Otherwise the system import of addr2Integer looks for PrelNum.hi + import PrelGHC infixr 9 . diff --git a/ghc/lib/std/PrelGHC.hi-boot b/ghc/lib/std/PrelGHC.hi-boot index 374de3c..ccd2499 100644 --- a/ghc/lib/std/PrelGHC.hi-boot +++ b/ghc/lib/std/PrelGHC.hi-boot @@ -5,7 +5,7 @@ -- primitive operations and types that GHC knows about. --------------------------------------------------------------------------- -__interface PrelGHC 2 0 where +__interface "std" PrelGHC 2 0 where __export PrelGHC