diff options
| -rw-r--r-- | compiler/basicTypes/Module.lhs | 7 | ||||
| -rw-r--r-- | compiler/coreSyn/ExternalCore.lhs | 2 | ||||
| -rw-r--r-- | compiler/deSugar/DsUtils.lhs | 12 | ||||
| -rw-r--r-- | compiler/main/Packages.lhs | 10 | ||||
| -rw-r--r-- | compiler/prelude/PrelNames.lhs | 39 | ||||
| -rw-r--r-- | compiler/prelude/TysWiredIn.lhs | 6 | ||||
| -rw-r--r-- | compiler/utils/Binary.hs | 9 | ||||
| -rw-r--r-- | libraries/Makefile | 5 | ||||
| -rw-r--r-- | libraries/boot-packages | 4 | ||||
| -rw-r--r-- | libraries/installPackage.hs | 6 | ||||
| -rw-r--r-- | rts/Exception.cmm | 6 | ||||
| -rw-r--r-- | rts/Prelude.h | 8 | ||||
| -rw-r--r-- | rts/package.conf.in | 8 |
13 files changed, 74 insertions, 48 deletions
diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index 22941a2d91..fcfcbb1156 100644 --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@ -28,6 +28,8 @@ module Module packageIdString, -- * Wired-in PackageIds + primPackageId, + integerPackageId, basePackageId, rtsPackageId, haskell98PackageId, @@ -277,8 +279,11 @@ packageIdString = unpackFS . packageIdFS -- package that depends directly or indirectly on it (much as if you -- had used -ignore-package). -basePackageId, rtsPackageId, haskell98PackageId, +integerPackageId, primPackageId, + basePackageId, rtsPackageId, haskell98PackageId, thPackageId, ndpPackageId, mainPackageId :: PackageId +primPackageId = fsToPackageId FSLIT("ghc-prim") +integerPackageId = fsToPackageId FSLIT("integer") basePackageId = fsToPackageId FSLIT("base") rtsPackageId = fsToPackageId FSLIT("rts") haskell98PackageId = fsToPackageId FSLIT("haskell98") diff --git a/compiler/coreSyn/ExternalCore.lhs b/compiler/coreSyn/ExternalCore.lhs index 49a77530f4..576e03ebbb 100644 --- a/compiler/coreSyn/ExternalCore.lhs +++ b/compiler/coreSyn/ExternalCore.lhs @@ -81,7 +81,7 @@ type Qual t = (Mname,t) type Id = String primMname :: Mname -primMname = "base:GHC.Prim" +primMname = "ghc-prim:GHC.Prim" tcArrow :: Qual Tcon tcArrow = (primMname, "(->)") diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 5eb33c8f97..cf670cdf37 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -515,8 +515,8 @@ mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)] mkIntegerExpr i | inIntRange i -- Small enough, so start from an Int - = do integer_dc <- dsLookupDataCon smallIntegerDataConName - return (mkSmallIntegerLit integer_dc i) + = do integer_id <- dsLookupGlobalId smallIntegerName + return (mkSmallIntegerLit integer_id i) -- Special case for integral literals with a large magnitude: -- They are transformed into an expression involving only smaller @@ -525,9 +525,9 @@ mkIntegerExpr i | otherwise = do -- Big, so start from a string plus_id <- dsLookupGlobalId plusIntegerName times_id <- dsLookupGlobalId timesIntegerName - integer_dc <- dsLookupDataCon smallIntegerDataConName + integer_id <- dsLookupGlobalId smallIntegerName let - lit i = mkSmallIntegerLit integer_dc i + lit i = mkSmallIntegerLit integer_id i plus a b = Var plus_id `App` a `App` b times a b = Var times_id `App` a `App` b @@ -543,8 +543,8 @@ mkIntegerExpr i return (horner tARGET_MAX_INT i) -mkSmallIntegerLit :: DataCon -> Integer -> CoreExpr -mkSmallIntegerLit small_integer_data_con i = mkConApp small_integer_data_con [mkIntLit i] +mkSmallIntegerLit :: Id -> Integer -> CoreExpr +mkSmallIntegerLit small_integer i = mkApps (Var small_integer) [mkIntLit i] mkStringExpr str = mkStringExprFS (mkFastString str) diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 2647a5fab0..bd421bd799 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -380,10 +380,12 @@ findWiredInPackages dflags pkgs preload this_package = do -- their canonical names (eg. base-1.0 ==> base). -- let - wired_in_pkgids = [ basePackageId, - rtsPackageId, - haskell98PackageId, - thPackageId, + wired_in_pkgids = [ primPackageId, + integerPackageId, + basePackageId, + rtsPackageId, + haskell98PackageId, + thPackageId, ndpPackageId ] wired_in_names = map packageIdString wired_in_pkgids diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 21e352088c..c324e95151 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -118,7 +118,7 @@ basicKnownKeyNames stringTyConName, ratioDataConName, ratioTyConName, - integerTyConName, smallIntegerDataConName, largeIntegerDataConName, + integerTyConName, smallIntegerName, -- Classes. *Must* include: -- classes that are grabbed by key (e.g., eqClassKey) @@ -236,12 +236,15 @@ genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName] --MetaHaskell Extension Add a new module here \begin{code} pRELUDE = mkBaseModule_ pRELUDE_NAME -gHC_PRIM = mkBaseModule FSLIT("GHC.Prim") -- Primitive types and values +gHC_PRIM = mkPrimModule FSLIT("GHC.Prim") -- Primitive types and values +gHC_BOOL = mkPrimModule FSLIT("GHC.Bool") +gHC_GENERICS = mkPrimModule FSLIT("GHC.Generics") gHC_BASE = mkBaseModule FSLIT("GHC.Base") gHC_ENUM = mkBaseModule FSLIT("GHC.Enum") gHC_SHOW = mkBaseModule FSLIT("GHC.Show") gHC_READ = mkBaseModule FSLIT("GHC.Read") gHC_NUM = mkBaseModule FSLIT("GHC.Num") +gHC_INTEGER = mkIntegerModule FSLIT("GHC.Integer") gHC_LIST = mkBaseModule FSLIT("GHC.List") gHC_PARR = mkBaseModule FSLIT("GHC.PArr") dATA_TUP = mkBaseModule FSLIT("Data.Tuple") @@ -288,6 +291,12 @@ thFAKE = mkMainModule FSLIT(":THFake") pRELUDE_NAME = mkModuleNameFS FSLIT("Prelude") mAIN_NAME = mkModuleNameFS FSLIT("Main") +mkPrimModule :: FastString -> Module +mkPrimModule m = mkModule primPackageId (mkModuleNameFS m) + +mkIntegerModule :: FastString -> Module +mkIntegerModule m = mkModule integerPackageId (mkModuleNameFS m) + mkBaseModule :: FastString -> Module mkBaseModule m = mkModule basePackageId (mkModuleNameFS m) @@ -439,10 +448,10 @@ mkTyConRep_RDR = varQual_RDR tYPEABLE FSLIT("mkTyCon") undefined_RDR = varQual_RDR gHC_ERR FSLIT("undefined") -crossDataCon_RDR = dataQual_RDR gHC_BASE FSLIT(":*:") -inlDataCon_RDR = dataQual_RDR gHC_BASE FSLIT("Inl") -inrDataCon_RDR = dataQual_RDR gHC_BASE FSLIT("Inr") -genUnitDataCon_RDR = dataQual_RDR gHC_BASE FSLIT("Unit") +crossDataCon_RDR = dataQual_RDR gHC_GENERICS FSLIT(":*:") +inlDataCon_RDR = dataQual_RDR gHC_GENERICS FSLIT("Inl") +inrDataCon_RDR = dataQual_RDR gHC_GENERICS FSLIT("Inr") +genUnitDataCon_RDR = dataQual_RDR gHC_GENERICS FSLIT("Unit") ---------------------- varQual_RDR mod str = mkOrig mod (mkOccNameFS varName str) @@ -475,9 +484,9 @@ leftDataConName = conName dATA_EITHER FSLIT("Left") leftDataConKey rightDataConName = conName dATA_EITHER FSLIT("Right") rightDataConKey -- Generics -crossTyConName = tcQual gHC_BASE FSLIT(":*:") crossTyConKey -plusTyConName = tcQual gHC_BASE FSLIT(":+:") plusTyConKey -genUnitTyConName = tcQual gHC_BASE FSLIT("Unit") genUnitTyConKey +crossTyConName = tcQual gHC_GENERICS FSLIT(":*:") crossTyConKey +plusTyConName = tcQual gHC_GENERICS FSLIT(":+:") plusTyConKey +genUnitTyConName = tcQual gHC_GENERICS FSLIT("Unit") genUnitTyConKey -- Base strings Strings unpackCStringName = varQual gHC_BASE FSLIT("unpackCString#") unpackCStringIdKey @@ -548,11 +557,10 @@ numClassName = clsQual gHC_NUM FSLIT("Num") numClassKey fromIntegerName = methName gHC_NUM FSLIT("fromInteger") fromIntegerClassOpKey minusName = methName gHC_NUM FSLIT("-") minusClassOpKey negateName = methName gHC_NUM FSLIT("negate") negateClassOpKey -plusIntegerName = varQual gHC_NUM FSLIT("plusInteger") plusIntegerIdKey -timesIntegerName = varQual gHC_NUM FSLIT("timesInteger") timesIntegerIdKey -integerTyConName = tcQual gHC_NUM FSLIT("Integer") integerTyConKey -smallIntegerDataConName = conName gHC_NUM FSLIT("S#") smallIntegerDataConKey -largeIntegerDataConName = conName gHC_NUM FSLIT("J#") largeIntegerDataConKey +plusIntegerName = varQual gHC_INTEGER FSLIT("plusInteger") plusIntegerIdKey +timesIntegerName = varQual gHC_INTEGER FSLIT("timesInteger") timesIntegerIdKey +integerTyConName = tcQual gHC_INTEGER FSLIT("Integer") integerTyConKey +smallIntegerName = varQual gHC_INTEGER FSLIT("smallInteger") smallIntegerIdKey -- PrelReal types and classes rationalTyConName = tcQual gHC_REAL FSLIT("Rational") rationalTyConKey @@ -889,8 +897,6 @@ doubleDataConKey = mkPreludeDataConUnique 3 falseDataConKey = mkPreludeDataConUnique 4 floatDataConKey = mkPreludeDataConUnique 5 intDataConKey = mkPreludeDataConUnique 6 -smallIntegerDataConKey = mkPreludeDataConUnique 7 -largeIntegerDataConKey = mkPreludeDataConUnique 8 nilDataConKey = mkPreludeDataConUnique 11 ratioDataConKey = mkPreludeDataConUnique 12 stableNameDataConKey = mkPreludeDataConUnique 14 @@ -957,6 +963,7 @@ bindIOIdKey = mkPreludeMiscIdUnique 36 returnIOIdKey = mkPreludeMiscIdUnique 37 deRefStablePtrIdKey = mkPreludeMiscIdUnique 38 newStablePtrIdKey = mkPreludeMiscIdUnique 39 +smallIntegerIdKey = mkPreludeMiscIdUnique 40 plusIntegerIdKey = mkPreludeMiscIdUnique 41 timesIntegerIdKey = mkPreludeMiscIdUnique 42 printIdKey = mkPreludeMiscIdUnique 43 diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 78d3583ed1..ce9988bb4a 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -155,9 +155,9 @@ charDataConName = mkWiredInDataConName UserSyntax gHC_BASE FSLIT("C#") charDat intTyConName = mkWiredInTyConName UserSyntax gHC_BASE FSLIT("Int") intTyConKey intTyCon intDataConName = mkWiredInDataConName UserSyntax gHC_BASE FSLIT("I#") intDataConKey intDataCon -boolTyConName = mkWiredInTyConName UserSyntax gHC_BASE FSLIT("Bool") boolTyConKey boolTyCon -falseDataConName = mkWiredInDataConName UserSyntax gHC_BASE FSLIT("False") falseDataConKey falseDataCon -trueDataConName = mkWiredInDataConName UserSyntax gHC_BASE FSLIT("True") trueDataConKey trueDataCon +boolTyConName = mkWiredInTyConName UserSyntax gHC_BOOL FSLIT("Bool") boolTyConKey boolTyCon +falseDataConName = mkWiredInDataConName UserSyntax gHC_BOOL FSLIT("False") falseDataConKey falseDataCon +trueDataConName = mkWiredInDataConName UserSyntax gHC_BOOL FSLIT("True") trueDataConKey trueDataCon listTyConName = mkWiredInTyConName BuiltInSyntax gHC_BASE FSLIT("[]") listTyConKey listTyCon nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_BASE FSLIT("[]") nilDataConKey nilDataCon consDataConName = mkWiredInDataConName BuiltInSyntax gHC_BASE FSLIT(":") consDataConKey consDataCon diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index ad048b6674..466a515dfc 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -467,6 +467,14 @@ instance (Binary a, Binary b) => Binary (Either a b) where -- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.lhs instance Binary Integer where + -- XXX This is hideous + put_ bh i = put_ bh (show i) + get bh = do str <- get bh + case reads str of + [(i, "")] -> return i + _ -> fail ("Binary Integer: got " ++ show str) + + {- put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) put_ bh (J# s# a#) = do putByte bh 1 @@ -484,6 +492,7 @@ instance Binary Integer where sz <- get bh (BA a#) <- getByteArray bh sz return (J# s# a#) +-} -- As for the rest of this code, even though this module -- exports it, it doesn't seem to be used anywhere else diff --git a/libraries/Makefile b/libraries/Makefile index c854108a18..9617dd4e08 100644 --- a/libraries/Makefile +++ b/libraries/Makefile @@ -38,7 +38,7 @@ show: TOP=.. include $(TOP)/mk/boilerplate.mk -SUBDIRS = base array packedstring containers bytestring +SUBDIRS = ghc-prim integer-gmp base array packedstring containers bytestring SUBDIRS += old-locale old-time filepath directory ifeq "$(GhcLibsWithUnix)" "YES" SUBDIRS += unix @@ -322,7 +322,8 @@ doc.library.%: stamp/configure.library.build$(CONFIGURE_STAMP_EXTRAS).% \ $(CABAL_HADDOCK_FLAGS); \ fi ifneq "$(HSCOLOUR)" "" - if ifBuildable/ifBuildable $*; then cp hscolour.css $*/dist/doc/html/$*/src/; fi +# We use */src rather than $*/src due to the integer-gmp/integer mismatch + if ifBuildable/ifBuildable $*; then cp hscolour.css $*/dist/doc/html/*/src/; fi endif .PHONY: distclean clean clean.library.% diff --git a/libraries/boot-packages b/libraries/boot-packages index 940683d004..6ffb54eb34 100644 --- a/libraries/boot-packages +++ b/libraries/boot-packages @@ -6,7 +6,10 @@ containers directory editline filepath +ghc-prim haskell98 +hpc +integer-gmp old-locale old-time packedstring @@ -16,4 +19,3 @@ random template-haskell unix Win32 -hpc diff --git a/libraries/installPackage.hs b/libraries/installPackage.hs index df2a9e20d3..4615429560 100644 --- a/libraries/installPackage.hs +++ b/libraries/installPackage.hs @@ -40,7 +40,7 @@ doRegisterInplace verbosity = do lbi <- getConfig verbosity let registerFlags = defaultRegisterFlags { regInPlace = toFlag True } pd = localPkgDescr lbi - pd_reg = if pkgName (package pd) == "base" + pd_reg = if pkgName (package pd) == "ghc-prim" then case library pd of Just lib -> let ems = "GHC.Prim" : exposedModules lib @@ -75,9 +75,9 @@ doInstall verbosity ghcpkg ghcpkgconf destdir topdir let pd = localPkgDescr lbi i = installDirTemplates lbi -- This is an almighty hack. We need to register - -- base:GHC.Prim, but it doesn't exist, get built, get + -- ghc-prim:GHC.Prim, but it doesn't exist, get built, get -- haddocked, get copied, etc. - pd_reg = if pkgName (package pd) == "base" + pd_reg = if pkgName (package pd) == "ghc-prim" then case library pd of Just lib -> let ems = "GHC.Prim" : exposedModules lib diff --git a/rts/Exception.cmm b/rts/Exception.cmm index 39a2abad9a..c2f0dde675 100644 --- a/rts/Exception.cmm +++ b/rts/Exception.cmm @@ -14,7 +14,7 @@ #include "RaiseAsync.h" #ifdef __PIC__ -import base_GHCziBase_True_closure; +import ghczmprim_GHCziBool_True_closure; #endif /* ----------------------------------------------------------------------------- @@ -440,8 +440,8 @@ retry_pop_stack: Sp(5) = stg_raise_ret_info; Sp(4) = stg_noforceIO_info; // required for unregisterised Sp(3) = exception; // the AP_STACK - Sp(2) = base_GHCziBase_True_closure; // dummy breakpoint info - Sp(1) = base_GHCziBase_True_closure; // True <=> a breakpoint + Sp(2) = ghczmprim_GHCziBool_True_closure; // dummy breakpoint info + Sp(1) = ghczmprim_GHCziBool_True_closure; // True <=> a breakpoint R1 = ioAction; jump RET_LBL(stg_ap_pppv); } diff --git a/rts/Prelude.h b/rts/Prelude.h index 31fe136d36..f237e59bea 100644 --- a/rts/Prelude.h +++ b/rts/Prelude.h @@ -24,8 +24,8 @@ * modules these names are defined in. */ -PRELUDE_CLOSURE(base_GHCziBase_True_closure); -PRELUDE_CLOSURE(base_GHCziBase_False_closure); +PRELUDE_CLOSURE(ghczmprim_GHCziBool_True_closure); +PRELUDE_CLOSURE(ghczmprim_GHCziBool_False_closure); PRELUDE_CLOSURE(base_GHCziPack_unpackCString_closure); PRELUDE_CLOSURE(base_GHCziWeak_runFinalizzerBatch_closure); @@ -79,8 +79,8 @@ PRELUDE_INFO(base_GHCziWord_W64zh_con_info); PRELUDE_INFO(base_GHCziStable_StablePtr_static_info); PRELUDE_INFO(base_GHCziStable_StablePtr_con_info); -#define True_closure DLL_IMPORT_DATA_REF(base_GHCziBase_True_closure) -#define False_closure DLL_IMPORT_DATA_REF(base_GHCziBase_False_closure) +#define True_closure DLL_IMPORT_DATA_REF(ghczmprim_GHCziBool_True_closure) +#define False_closure DLL_IMPORT_DATA_REF(ghczmprim_GHCziBool_False_closure) #define unpackCString_closure DLL_IMPORT_DATA_REF(base_GHCziPack_unpackCString_closure) #define runFinalizerBatch_closure DLL_IMPORT_DATA_REF(base_GHCziWeak_runFinalizzerBatch_closure) #define mainIO_closure (&ZCMain_main_closure) diff --git a/rts/package.conf.in b/rts/package.conf.in index f73e6b1421..1642101ba0 100644 --- a/rts/package.conf.in +++ b/rts/package.conf.in @@ -101,8 +101,8 @@ ld-options: , "-u", "_base_GHCziPtr_Ptr_con_info" , "-u", "_base_GHCziPtr_FunPtr_con_info" , "-u", "_base_GHCziStable_StablePtr_con_info" - , "-u", "_base_GHCziBase_False_closure" - , "-u", "_base_GHCziBase_True_closure" + , "-u", "_ghczmprim_GHCziBool_False_closure" + , "-u", "_ghczmprim_GHCziBool_True_closure" , "-u", "_base_GHCziPack_unpackCString_closure" , "-u", "_base_GHCziIOBase_stackOverflow_closure" , "-u", "_base_GHCziIOBase_heapOverflow_closure" @@ -135,8 +135,8 @@ ld-options: , "-u", "base_GHCziPtr_Ptr_con_info" , "-u", "base_GHCziPtr_FunPtr_con_info" , "-u", "base_GHCziStable_StablePtr_con_info" - , "-u", "base_GHCziBase_False_closure" - , "-u", "base_GHCziBase_True_closure" + , "-u", "ghczmprim_GHCziBool_False_closure" + , "-u", "ghczmprim_GHCziBool_True_closure" , "-u", "base_GHCziPack_unpackCString_closure" , "-u", "base_GHCziIOBase_stackOverflow_closure" , "-u", "base_GHCziIOBase_heapOverflow_closure" |