From e921b2e307532e0f30eefa88b11a124be592bde4 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Mon, 20 Dec 1999 10:34:37 +0000
Subject: [PATCH] [project @ 1999-12-20 10:34:27 by simonpj] This commit
implements a substantial re-organisation of the Prelude It also fixes a
couple of small renamer bugs that were reported recently (notably, Sven
pointed out that we weren't reporting unused imports properly)
My original goal was to get rid of all "orphan" modules (i.e. ones
with instance decls that don't belong either to a tycon or a class
defined in the same module). This should reduce the number of
interface files that have to be read when compiling small Haskell
modules.
But like most expeditions into the Prelude Swamp, it spiraled out
of control. The result is quite satisfactory, though.
GONE AWAY: PrelCCall, PrelNumExtra
NEW: PrelReal, PrelFloat, PrelByteArr, PrelNum.hi-boot
(The extra PrelNum.hi-boot is because of a tiresome thin-air Id, addr2Integer,
which used to be in PrelBase.)
Quite a lot of types have moved from one module to another,
which entails some changes to part of the compiler (PrelInfo, PrelMods) etc,
and there are a few places in the RTS includes and even in the driver
that know about these home modules (alas).
So the rough structure is as follows, in (linearised) dependency order
[this list now appears in PrelBase.lhs]
PrelGHC Has no implementation. It defines built-in things, and
by importing it you bring them into scope.
The source file is PrelGHC.hi-boot, which is just
copied to make PrelGHC.hi
Classes: CCallable, CReturnable
PrelBase Classes: Eq, Ord, Functor, Monad
Types: list, (), Int, Bool, Ordering, Char, String
PrelTup Types: tuples, plus instances for PrelBase classes
PrelShow Class: Show, plus instances for PrelBase/PrelTup types
PrelEnum Class: Enum, plus instances for PrelBase/PrelTup types
PrelMaybe Type: Maybe, plus instances for PrelBase classes
PrelNum Class: Num, plus instances for Int
Type: Integer, plus instances for all classes so far (Eq, Ord, Num, Show)
Integer is needed here because it is mentioned in the signature
of 'fromInteger' in class Num
PrelReal Classes: Real, Integral, Fractional, RealFrac
plus instances for Int, Integer
Types: Ratio, Rational
plus intances for classes so far
Rational is needed here because it is mentioned in the signature
of 'toRational' in class Real
Ix Classes: Ix, plus instances for Int, Bool, Char, Integer, Ordering, tuples
PrelArr Types: Array, MutableArray, MutableVar
Does *not* contain any ByteArray stuff (see PrelByteArr)
Arrays are used by a function in PrelFloat
PrelFloat Classes: Floating, RealFloat
Types: Float, Double, plus instances of all classes so far
This module contains everything to do with floating point.
It is a big module (900 lines)
With a bit of luck, many modules can be compiled without ever reading PrelFloat.hi
PrelByteArr Types: ByteArray, MutableByteArray
We want this one to be after PrelFloat, because it defines arrays
of unboxed floats.
Other Prelude modules are much easier with fewer complex dependencies.
---
ghc/compiler/basicTypes/Name.lhs | 5 +-
ghc/compiler/main/MkIface.lhs | 2 +-
ghc/compiler/prelude/PrelInfo.lhs | 35 +-
ghc/compiler/prelude/PrelMods.lhs | 13 +-
ghc/compiler/prelude/ThinAir.lhs | 6 +-
ghc/compiler/prelude/TysWiredIn.lhs | 14 +-
ghc/compiler/rename/Rename.lhs | 70 +-
ghc/compiler/rename/RnEnv.lhs | 24 +-
ghc/compiler/rename/RnIfaces.lhs | 10 +-
ghc/compiler/rename/RnNames.lhs | 41 +-
ghc/compiler/typecheck/TcDefaults.lhs | 34 +-
ghc/compiler/typecheck/TcEnv.lhs | 9 +-
ghc/compiler/typecheck/TcInstDcls.lhs | 2 +-
ghc/docs/users_guide/debugging.vsgml | 46 +-
ghc/docs/users_guide/using.vsgml | 37 ++
ghc/driver/ghc.lprl | 8 +-
ghc/includes/Prelude.h | 18 +-
ghc/lib/std/Array.lhs | 48 +-
ghc/lib/std/CPUTime.lhs | 18 +-
ghc/lib/std/Directory.lhs | 18 +-
ghc/lib/std/IO.lhs | 2 +-
ghc/lib/std/Ix.lhs | 2 +
ghc/lib/std/Numeric.lhs | 35 +-
ghc/lib/std/PrelAddr.lhs | 1 -
ghc/lib/std/PrelArr.lhs | 374 ++---------
ghc/lib/std/PrelArrExtra.lhs | 1 +
ghc/lib/std/PrelBase.lhs | 185 +++---
ghc/lib/std/PrelByteArr.lhs | 377 +++++++++++
ghc/lib/std/PrelCCall.lhs | 43 --
ghc/lib/std/PrelConc.lhs | 2 +-
ghc/lib/std/PrelEnum.lhs | 2 +
ghc/lib/std/PrelFloat.lhs | 892 ++++++++++++++++++++++++++
ghc/lib/std/PrelForeign.lhs | 1 -
ghc/lib/std/PrelGHC.hi-boot | 3 +-
ghc/lib/std/PrelHandle.lhs | 7 +-
ghc/lib/std/PrelNum.hi-boot | 14 +
ghc/lib/std/PrelNum.lhs | 590 +++++++----------
ghc/lib/std/PrelPack.lhs | 1 +
ghc/lib/std/PrelRead.lhs | 3 +-
ghc/lib/std/PrelReal.lhs | 299 +++++++++
ghc/lib/std/PrelST.lhs | 2 +
ghc/lib/std/PrelStable.lhs | 3 +-
ghc/lib/std/PrelTup.lhs | 2 +
ghc/lib/std/Prelude.lhs | 45 +-
ghc/lib/std/Random.lhs | 21 +-
ghc/lib/std/Ratio.lhs | 58 +-
ghc/lib/std/System.lhs | 2 +-
ghc/lib/std/Time.lhs | 24 +-
ghc/rts/HSprel.def | 8 +-
ghc/rts/RtsStartup.c | 4 +-
50 files changed, 2398 insertions(+), 1063 deletions(-)
create mode 100644 ghc/lib/std/PrelByteArr.lhs
delete mode 100644 ghc/lib/std/PrelCCall.lhs
create mode 100644 ghc/lib/std/PrelFloat.lhs
create mode 100644 ghc/lib/std/PrelNum.hi-boot
create mode 100644 ghc/lib/std/PrelReal.lhs
diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index 4a3bfaa3980b..46e0a0193994 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -21,7 +21,7 @@ module Name (
tidyTopName,
nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule,
- isUserExportedName, nameSrcLoc,
+ isUserExportedName, isUserImportedExplicitlyName, nameSrcLoc,
isLocallyDefinedName,
isSystemName, isLocalName, isGlobalName, isExternallyVisibleName,
@@ -398,6 +398,9 @@ nameRdrName (Name { n_sort = sort, n_occ = occ }) = mkRdrQual (moduleName (name
isUserExportedName (Name { n_prov = LocalDef _ Exported }) = True
isUserExportedName other = False
+isUserImportedExplicitlyName (Name { n_prov = NonLocalDef (UserImport _ _ explicit) _ }) = explicit
+isUserImportedExplicitlyName other = False
+
nameSrcLoc name = provSrcLoc (n_prov name)
provSrcLoc (LocalDef loc _) = loc
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 224e31ee4da4..81aff83df2c3 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -466,7 +466,7 @@ ifaceBinds hdl needed_ids final_ids binds
%************************************************************************
\begin{code}
-ifaceTyCons hdl tycons = hPutCol hdl upp_tycon (sortLt (<) (filter (for_iface_name . getName) tycons ))
+ifaceTyCons hdl tycons = hPutCol hdl upp_tycon (sortLt (<) (filter (for_iface_name . getName) tycons))
ifaceClasses hdl classes = hPutCol hdl upp_class (sortLt (<) (filter (for_iface_name . getName) classes))
for_iface_name name = isLocallyDefined name &&
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index b52682f21e96..58a3d8fe2e9e 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -26,7 +26,7 @@ module PrelInfo (
maybeCharLikeCon, maybeIntLikeCon,
needsDataDeclCtxtClassKeys, cCallishClassKeys, cCallishTyKeys,
isNoDictClass, isNumericClass, isStandardClass, isCcallishClass,
- isCreturnableClass, numericTyKeys,
+ isCreturnableClass, numericTyKeys, fractionalClassKeys,
-- RdrNames for lots of things, mainly used in derivings
eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR,
@@ -319,12 +319,13 @@ ioDataCon_RDR = dataQual pREL_IO_BASE_Name SLIT("IO")
bindIO_RDR = varQual pREL_IO_BASE_Name SLIT("bindIO")
orderingTyCon_RDR = tcQual pREL_BASE_Name SLIT("Ordering")
-rationalTyCon_RDR = tcQual pREL_NUM_Name SLIT("Rational")
-ratioTyCon_RDR = tcQual pREL_NUM_Name SLIT("Ratio")
-ratioDataCon_RDR = dataQual pREL_NUM_Name SLIT(":%")
-byteArrayTyCon_RDR = tcQual pREL_ARR_Name SLIT("ByteArray")
-mutableByteArrayTyCon_RDR = tcQual pREL_ARR_Name SLIT("MutableByteArray")
+rationalTyCon_RDR = tcQual pREL_REAL_Name SLIT("Rational")
+ratioTyCon_RDR = tcQual pREL_REAL_Name SLIT("Ratio")
+ratioDataCon_RDR = dataQual pREL_REAL_Name SLIT(":%")
+
+byteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("ByteArray")
+mutableByteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray")
foreignObjTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("ForeignObj")
stablePtrTyCon_RDR = tcQual pREL_STABLE_Name SLIT("StablePtr")
@@ -401,13 +402,14 @@ plus_RDR = varQual pREL_NUM_Name SLIT("+")
times_RDR = varQual pREL_NUM_Name SLIT("*")
-- Other numberic classes
-realClass_RDR = clsQual pREL_NUM_Name SLIT("Real")
-integralClass_RDR = clsQual pREL_NUM_Name SLIT("Integral")
-fractionalClass_RDR = clsQual pREL_NUM_Name SLIT("Fractional")
-floatingClass_RDR = clsQual pREL_NUM_Name SLIT("Floating")
-realFracClass_RDR = clsQual pREL_NUM_Name SLIT("RealFrac")
-realFloatClass_RDR = clsQual pREL_NUM_Name SLIT("RealFloat")
-fromRational_RDR = varQual pREL_NUM_Name SLIT("fromRational")
+realClass_RDR = clsQual pREL_REAL_Name SLIT("Real")
+integralClass_RDR = clsQual pREL_REAL_Name SLIT("Integral")
+realFracClass_RDR = clsQual pREL_REAL_Name SLIT("RealFrac")
+fractionalClass_RDR = clsQual pREL_REAL_Name SLIT("Fractional")
+fromRational_RDR = varQual pREL_REAL_Name SLIT("fromRational")
+
+floatingClass_RDR = clsQual pREL_FLOAT_Name SLIT("Floating")
+realFloatClass_RDR = clsQual pREL_FLOAT_Name SLIT("RealFloat")
-- Class Ix
ixClass_RDR = clsQual iX_Name SLIT("Ix")
@@ -549,6 +551,7 @@ because the list of ambiguous dictionaries hasn't been simplified.
isCcallishClass, isCreturnableClass, isNoDictClass,
isNumericClass, isStandardClass :: Class -> Bool
+isFractionalClass clas = classKey clas `is_elem` fractionalClassKeys
isNumericClass clas = classKey clas `is_elem` numericClassKeys
isStandardClass clas = classKey clas `is_elem` standardClassKeys
isCcallishClass clas = classKey clas `is_elem` cCallishClassKeys
@@ -560,7 +563,11 @@ numericClassKeys =
[ numClassKey
, realClassKey
, integralClassKey
- , fractionalClassKey
+ ]
+ ++ fractionalClassKeys
+
+fractionalClassKeys =
+ [ fractionalClassKey
, floatingClassKey
, realFracClassKey
, realFloatClassKey
diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs
index 5e77ba97524b..bb9943dbebd9 100644
--- a/ghc/compiler/prelude/PrelMods.lhs
+++ b/ghc/compiler/prelude/PrelMods.lhs
@@ -15,15 +15,16 @@ module PrelMods
mkTupNameStr, mkUbxTupNameStr,
pREL_GHC, pREL_BASE, pREL_ADDR, pREL_STABLE,
- pREL_IO_BASE, pREL_PACK, pREL_ERR,
+ pREL_IO_BASE, pREL_PACK, pREL_ERR, pREL_NUM, pREL_FLOAT, pREL_REAL,
pREL_GHC_Name, pRELUDE_Name, mONAD_Name, rATIO_Name,
iX_Name, mAIN_Name, pREL_MAIN_Name, pREL_ERR_Name,
pREL_BASE_Name, pREL_NUM_Name, pREL_LIST_Name,
pREL_TUP_Name, pREL_ADDR_Name, pREL_READ_Name,
pREL_PACK_Name, pREL_CONC_Name, pREL_IO_BASE_Name,
- pREL_ST_Name, pREL_ARR_Name, pREL_FOREIGN_Name,
- pREL_STABLE_Name, pREL_SHOW_Name, pREL_ENUM_Name, iNT_Name, wORD_Name
+ pREL_ST_Name, pREL_ARR_Name, pREL_BYTEARR_Name, pREL_FOREIGN_Name,
+ pREL_STABLE_Name, pREL_SHOW_Name, pREL_ENUM_Name, iNT_Name, wORD_Name,
+ pREL_REAL_Name, pREL_FLOAT_Name
) where
#include "HsVersions.h"
@@ -48,10 +49,13 @@ pREL_CONC_Name = mkSrcModule "PrelConc"
pREL_IO_BASE_Name = mkSrcModule "PrelIOBase"
pREL_ST_Name = mkSrcModule "PrelST"
pREL_ARR_Name = mkSrcModule "PrelArr"
+pREL_BYTEARR_Name = mkSrcModule "PrelByteArr"
pREL_FOREIGN_Name = mkSrcModule "PrelForeign"
pREL_STABLE_Name = mkSrcModule "PrelStable"
pREL_ADDR_Name = mkSrcModule "PrelAddr"
pREL_ERR_Name = mkSrcModule "PrelErr"
+pREL_REAL_Name = mkSrcModule "PrelReal"
+pREL_FLOAT_Name = mkSrcModule "PrelFloat"
mONAD_Name = mkSrcModule "Monad"
rATIO_Name = mkSrcModule "Ratio"
@@ -68,6 +72,9 @@ pREL_STABLE = mkPrelModule pREL_STABLE_Name
pREL_IO_BASE = mkPrelModule pREL_IO_BASE_Name
pREL_PACK = mkPrelModule pREL_PACK_Name
pREL_ERR = mkPrelModule pREL_ERR_Name
+pREL_NUM = mkPrelModule pREL_NUM_Name
+pREL_REAL = mkPrelModule pREL_REAL_Name
+pREL_FLOAT = mkPrelModule pREL_FLOAT_Name
\end{code}
%************************************************************************
diff --git a/ghc/compiler/prelude/ThinAir.lhs b/ghc/compiler/prelude/ThinAir.lhs
index af616fbf0b97..147dde222f1e 100644
--- a/ghc/compiler/prelude/ThinAir.lhs
+++ b/ghc/compiler/prelude/ThinAir.lhs
@@ -7,7 +7,7 @@
module ThinAir (
thinAirIdNames, -- Names of non-wired-in Ids that may be used out of
setThinAirIds, -- thin air in any compilation. If they are not wired in
- thinAirModules, -- we must be sure to import them from some Prelude
+ -- we must be sure to import them from some Prelude
-- interface file even if they are not overtly
-- mentioned. Subset of builtinNames.
-- Here are the thin-air Ids themselves
@@ -55,7 +55,7 @@ thinAirIdNames
= map mkKnownKeyGlobal
[
-- Needed for converting literals to Integers (used in tidyCoreExpr)
- (varQual pREL_BASE_Name SLIT("addr2Integer"), addr2IntegerIdKey)
+ (varQual pREL_NUM_Name SLIT("addr2Integer"), addr2IntegerIdKey)
-- String literals
, (varQual pREL_PACK_Name SLIT("packCString#"), packCStringIdKey)
@@ -70,8 +70,6 @@ thinAirIdNames
]
varQual = mkPreludeQual varName
-
-thinAirModules = [pREL_PACK_Name,pREL_BASE_Name] -- See notes with RnIfaces.findAndReadIface
\end{code}
diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index 894fd7d3ba48..8f6e76bfbe15 100644
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -317,8 +317,8 @@ isAddrTy ty
\begin{code}
floatTy = mkTyConTy floatTyCon
-floatTyCon = pcNonRecDataTyCon floatTyConKey pREL_BASE SLIT("Float") [] [] [floatDataCon]
-floatDataCon = pcDataCon floatDataConKey pREL_BASE SLIT("F#") [] [] [floatPrimTy] floatTyCon
+floatTyCon = pcNonRecDataTyCon floatTyConKey pREL_FLOAT SLIT("Float") [] [] [floatDataCon]
+floatDataCon = pcDataCon floatDataConKey pREL_FLOAT SLIT("F#") [] [] [floatPrimTy] floatTyCon
isFloatTy :: Type -> Bool
isFloatTy ty
@@ -337,8 +337,8 @@ isDoubleTy ty
Just (tycon, [], _) -> getUnique tycon == doubleTyConKey
_ -> False
-doubleTyCon = pcNonRecDataTyCon doubleTyConKey pREL_BASE SLIT("Double") [] [] [doubleDataCon]
-doubleDataCon = pcDataCon doubleDataConKey pREL_BASE SLIT("D#") [] [] [doublePrimTy] doubleTyCon
+doubleTyCon = pcNonRecDataTyCon doubleTyConKey pREL_FLOAT SLIT("Double") [] [] [doubleDataCon]
+doubleDataCon = pcDataCon doubleDataConKey pREL_FLOAT SLIT("D#") [] [] [doublePrimTy] doubleTyCon
\end{code}
\begin{code}
@@ -372,12 +372,12 @@ foreignObjTyCon
integerTy :: Type
integerTy = mkTyConTy integerTyCon
-integerTyCon = pcNonRecDataTyCon integerTyConKey pREL_BASE SLIT("Integer")
+integerTyCon = pcNonRecDataTyCon integerTyConKey pREL_NUM SLIT("Integer")
[] [] [smallIntegerDataCon, largeIntegerDataCon]
-smallIntegerDataCon = pcDataCon smallIntegerDataConKey pREL_BASE SLIT("S#")
+smallIntegerDataCon = pcDataCon smallIntegerDataConKey pREL_NUM SLIT("S#")
[] [] [intPrimTy] integerTyCon
-largeIntegerDataCon = pcDataCon largeIntegerDataConKey pREL_BASE SLIT("J#")
+largeIntegerDataCon = pcDataCon largeIntegerDataConKey pREL_NUM SLIT("J#")
[] [] [intPrimTy, byteArrayPrimTy] integerTyCon
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index e1381ba88d98..f95b22203109 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -25,14 +25,14 @@ import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions,
getImportedRules, loadHomeInterface, getSlurped, removeContext
)
import RnEnv ( availName, availNames, availsToNameSet,
- warnUnusedTopNames, mapFvRn, lookupImplicitOccRn,
+ warnUnusedImports, warnUnusedLocalBinds, mapFvRn, lookupImplicitOccRn,
FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs
)
import Module ( Module, ModuleName, pprModule, mkSearchPath, mkThisModule )
import Name ( Name, isLocallyDefined,
NamedThing(..), ImportReason(..), Provenance(..),
- pprOccName, nameOccName,
- getNameProvenance,
+ pprOccName, nameOccName, nameUnique,
+ getNameProvenance, isUserImportedExplicitlyName,
maybeWiredInTyConName, maybeWiredInIdName, isWiredInName
)
import Id ( idType )
@@ -42,7 +42,7 @@ import RdrName ( RdrName )
import NameSet
import PrelMods ( mAIN_Name, pREL_MAIN_Name )
import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon )
-import PrelInfo ( ioTyCon_NAME, numClass_RDR, thinAirIdNames, derivingOccurrences )
+import PrelInfo ( ioTyCon_NAME, thinAirIdNames, fractionalClassKeys, derivingOccurrences )
import Type ( namesOfType, funTyCon )
import ErrUtils ( printErrorsAndWarnings, dumpIfSet, ghcExit )
import BasicTypes ( NewOrData(..) )
@@ -52,6 +52,7 @@ import UniqSupply ( UniqSupply )
import UniqFM ( lookupUFM )
import Util ( equivClasses )
import Maybes ( maybeToBool )
+import SrcLoc ( mkBuiltinSrcLoc )
import Outputable
\end{code}
@@ -118,7 +119,7 @@ rename this_mod@(HsModule mod_name vers _ imports local_decls loc)
in
slurpImpDecls real_source_fvs `thenRn` \ rn_imp_decls ->
let
- rn_all_decls = rn_imp_decls ++ rn_local_decls
+ rn_all_decls = rn_local_decls ++ rn_imp_decls
in
-- EXIT IF ERRORS FOUND
@@ -164,21 +165,20 @@ mentioned explicitly, but which might be needed by the type checker.
\begin{code}
implicitFVs mod_name decls
= mapRn lookupImplicitOccRn implicit_occs `thenRn` \ implicit_names ->
- returnRn (implicit_main `plusFV`
- mkNameSet default_tys `plusFV`
- mkNameSet thinAirIdNames `plusFV`
+ returnRn (implicit_main `plusFV`
+ mkNameSet (map getName default_tycons) `plusFV`
+ mkNameSet thinAirIdNames `plusFV`
mkNameSet implicit_names)
-
where
- -- Add occurrences for Int, Double, and (), because they
+ -- Add occurrences for Int, and (), because they
-- are the types to which ambigious type variables may be defaulted by
-- the type checker; so they won't always appear explicitly.
-- [The () one is a GHC extension for defaulting CCall results.]
-- ALSO: funTyCon, since it occurs implicitly everywhere!
-- (we don't want to be bothered with making funTyCon a
-- free var at every function application!)
- default_tys = [getName intTyCon, getName doubleTyCon,
- getName unitTyCon, getName funTyCon, getName boolTyCon]
+ -- Double is dealt with separately in getGates
+ default_tycons = [unitTyCon, funTyCon, boolTyCon, intTyCon]
-- Add occurrences for IO or PrimIO
implicit_main | mod_name == mAIN_Name
@@ -190,7 +190,6 @@ implicitFVs mod_name decls
-- generate code
implicit_occs = foldr ((++) . get) [] decls
- get (DefD _) = [numClass_RDR]
get (TyClD (TyData _ _ _ _ _ (Just deriv_classes) _ _))
= concat (map get_deriv deriv_classes)
get other = []
@@ -229,6 +228,17 @@ isOrphanDecl other = False
\end{code}
+\begin{code}
+dupDefaultDeclErrRn (DefaultDecl _ locn1 : dup_things)
+ = pushSrcLocRn locn1 $
+ addErrRn msg
+ where
+ msg = hang (ptext SLIT("Multiple default declarations"))
+ 4 (vcat (map pp dup_things))
+ pp (DefaultDecl _ locn) = ptext SLIT("here was another default declaration") <+> ppr locn
+\end{code}
+
+
%*********************************************************
%* *
\subsection{Slurping declarations}
@@ -285,7 +295,7 @@ slurpSourceRefs source_binders source_fvs
rnInstDecls decls1 fvs1 gates1 inst_decls `thenRn` \ (decls2, fvs2, gates2) ->
go_outer decls2 fvs2 (all_gates `plusFV` gates2)
(nameSetToList (gates2 `minusNameSet` all_gates))
- -- Knock out the all_gates because even ifwe don't slurp any new
+ -- Knock out the all_gates because even if we don't slurp any new
-- decls we can get some apparently-new gates from wired-in names
go_inner decls fvs gates []
@@ -408,14 +418,25 @@ getGates source_fvs (SigD (IfaceSig _ ty _ _))
= extractHsTyNames ty
getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ _ _))
- = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
+ = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
(map getTyVarName tvs)
- `addOneToNameSet` cls
+ `addOneToNameSet` cls)
+ `plusFV` maybe_double
where
get (ClassOpSig n _ _ ty _)
| n `elemNameSet` source_fvs = extractHsTyNames ty
| otherwise = emptyFVs
+ -- If we load any numeric class that doesn't have
+ -- Int as an instance, add Double to the gates.
+ -- This takes account of the fact that Double might be needed for
+ -- defaulting, but we don't want to load Double (and all its baggage)
+ -- if the more exotic classes aren't used at all.
+ maybe_double | nameUnique cls `elem` fractionalClassKeys
+ = unitFV (getName doubleTyCon)
+ | otherwise
+ = emptyFVs
+
getGates source_fvs (TyClD (TySynonym tycon tvs ty _))
= delListFromNameSet (extractHsTyNames ty)
(map getTyVarName tvs)
@@ -510,20 +531,11 @@ reportUnusedNames gbl_env avail_env (ExportEnv export_avails _ _) mentioned_name
nameSetToList (defined_names `minusNameSet` really_used_names)
-- Filter out the ones only defined implicitly
- bad_guys = filter reportableUnusedName defined_but_not_used
+ bad_locals = [n | n <- defined_but_not_used, isLocallyDefined n]
+ bad_imps = [n | n <- defined_but_not_used, isUserImportedExplicitlyName n]
in
- warnUnusedTopNames bad_guys
-
-reportableUnusedName :: Name -> Bool
-reportableUnusedName name
- = explicitlyImported (getNameProvenance name)
- where
- explicitlyImported (LocalDef _ _) = True
- -- Report unused defns of local vars
- explicitlyImported (NonLocalDef (UserImport _ _ expl) _) = expl
- -- Report unused explicit imports
- explicitlyImported other = False
- -- Don't report others
+ warnUnusedLocalBinds bad_locals `thenRn_`
+ warnUnusedImports bad_imps
rnDump :: [RenamedHsDecl] -- Renamed imported decls
-> [RenamedHsDecl] -- Renamed local decls
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index a4fad13d9c27..62312174be2d 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -631,7 +631,10 @@ filterAvail (IEVar v) avail@(AvailTC n ns) = Just (AvailTC n (filter wanted
-- import A( op )
-- where op is a class operation
-filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail
+filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail
+ -- We don't complain even if the IE says T(..), but
+ -- no constrs/class ops of T are available
+ -- Instead that's caught with a warning by the caller
filterAvail ie avail = Nothing
@@ -694,18 +697,19 @@ mapFvRn f xs = mapRn f xs `thenRn` \ stuff ->
%************************************************************************
+
\begin{code}
-warnUnusedLocalBinds, warnUnusedTopNames, warnUnusedMatches :: [Name] -> RnM d ()
+warnUnusedLocalBinds, warnUnusedImports, warnUnusedMatches :: [Name] -> RnM d ()
-warnUnusedTopNames names
- | not opt_WarnUnusedBinds && not opt_WarnUnusedImports
- = returnRn () -- Don't force ns unless necessary
+warnUnusedImports names
+ | not opt_WarnUnusedImports
+ = returnRn () -- Don't force names unless necessary
| otherwise
- = warnUnusedBinds (\ is_local -> not is_local) names
+ = warnUnusedBinds (const True) names
warnUnusedLocalBinds ns
| not opt_WarnUnusedBinds = returnRn ()
- | otherwise = warnUnusedBinds (\ is_local -> is_local) ns
+ | otherwise = warnUnusedBinds (const True) ns
warnUnusedMatches names
| opt_WarnUnusedMatches = warnUnusedGroup (const True) names
@@ -731,6 +735,12 @@ warnUnusedBinds warn_when_local names
-------------------------
+-- NOTE: the function passed to warnUnusedGroup is
+-- now always (const True) so we should be able to
+-- simplify the code slightly. I'm leaving it there
+-- for now just in case I havn't realised why it was there.
+-- Looks highly bogus to me. SLPJ Dec 99
+
warnUnusedGroup :: (Bool -> Bool) -> [Name] -> RnM d ()
warnUnusedGroup emit_warning names
| null filtered_names = returnRn ()
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index ceb91aa3d1da..a46eb5b33aca 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -58,7 +58,7 @@ import NameSet
import Var ( Id )
import SrcLoc ( mkSrcLoc, SrcLoc )
import PrelMods ( pREL_GHC )
-import PrelInfo ( cCallishTyKeys, thinAirModules )
+import PrelInfo ( cCallishTyKeys )
import Bag
import Maybes ( MaybeErr(..), maybeToBool, orElse )
import ListSetOps ( unionLists )
@@ -973,12 +973,18 @@ readIface the_mod file_path
context = [],
glasgow_exts = 1#,
loc = mkSrcLoc (mkFastString file_path) 1 } of
- PFailed err -> failWithRn Nothing err
POk _ (PIface mod_nm iface) ->
warnCheckRn (mod_nm == moduleName the_mod)
(hiModuleNameMismatchWarn the_mod mod_nm) `thenRn_`
returnRn (Just (the_mod, iface))
+ PFailed err -> failWithRn Nothing err
+ other -> failWithRn Nothing (ptext SLIT("Unrecognisable interface file"))
+ -- This last case can happen if the interface file is (say) empty
+ -- in which case the parser thinks it looks like an IdInfo or
+ -- something like that. Just an artefact of the fact that the
+ -- parser is used for several purposes at once.
+
Left err
| isDoesNotExistError err -> returnRn Nothing
| otherwise -> failWithRn Nothing (cannaeReadFile file_path err)
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index d98dc2aca9d1..176eca3b3e34 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -413,10 +413,9 @@ filterImports mod (Just (want_hiding, import_items)) avails
= addErrRn (badImportItemErr mod item) `thenRn_`
returnRn Nothing
- | dodgy_import = addWarnRn (dodgyImportWarn mod item) `thenRn_`
- returnRn (Just (filtered_avail, explicits))
-
- | otherwise = returnRn (Just (filtered_avail, explicits))
+ | otherwise
+ = warnCheckRn (okItem item avail) (dodgyImportWarn mod item) `thenRn_`
+ returnRn (Just (filtered_avail, explicits))
where
wanted_occ = rdrNameOcc (ieName item)
@@ -432,13 +431,12 @@ filterImports mod (Just (want_hiding, import_items)) avails
IEThingAll _ -> True
other -> False
- dodgy_import = case (item, avail) of
- (IEThingAll _, AvailTC _ [n]) -> True
- -- This occurs when you import T(..), but
- -- only export T abstractly. The single [n]
- -- in the AvailTC is the type or class itself
-
- other -> False
+
+okItem (IEThingAll _) (AvailTC _ [n]) = False
+ -- This occurs when you import T(..), but
+ -- only export T abstractly. The single [n]
+ -- in the AvailTC is the type or class itself
+okItem _ _ = True
\end{code}
@@ -608,7 +606,10 @@ exportsFromAvail this_mod (Just export_items)
= failWithRn acc (exportItemErr ie)
| otherwise -- Phew! It's OK! Now to check the occurrence stuff!
- = check_occs ie occs export_avail `thenRn` \ occs' ->
+
+
+ = warnCheckRn (okItem ie avail) (dodgyExportWarn ie) `thenRn_`
+ check_occs ie occs export_avail `thenRn` \ occs' ->
returnRn (mods, occs', add_avail avails export_avail)
where
@@ -659,17 +660,20 @@ badImportItemErr mod ie
= sep [ptext SLIT("Module"), quotes (pprModuleName mod),
ptext SLIT("does not export"), quotes (ppr ie)]
-dodgyImportWarn mod (IEThingAll tc)
- = sep [ptext SLIT("Module") <+> quotes (pprModuleName mod)
- <+> ptext SLIT("exports") <+> quotes (ppr tc),
- ptext SLIT("with no constructors/class operations;"),
- ptext SLIT("yet it is imported with a (..)")]
+dodgyImportWarn mod item = dodgyMsg (ptext SLIT("import")) item
+dodgyExportWarn item = dodgyMsg (ptext SLIT("export")) item
+dodgyMsg kind item@(IEThingAll tc)
+ = sep [ ptext SLIT("The") <+> kind <+> ptext SLIT("item") <+> quotes (ppr item),
+ ptext SLIT("suggests that") <+> quotes (ppr tc) <+> ptext SLIT("has constructor or class methods"),
+ ptext SLIT("but it has none; it is a type synonym or abstract type or class") ]
+
modExportErr mod
= hsep [ ptext SLIT("Unknown module in export list: module"), quotes (pprModuleName mod)]
exportItemErr export_item
- = sep [ ptext SLIT("Bad export item"), quotes (ppr export_item)]
+ = sep [ ptext SLIT("The export item") <+> quotes (ppr export_item),
+ ptext SLIT("attempts to export constructors or class methods that are not visible here") ]
exportClashErr occ_name ie1 ie2
= hsep [ptext SLIT("The export items"), quotes (ppr ie1)
@@ -703,5 +707,4 @@ dupFixityDecl rdr_name loc1 loc2
= vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
ptext SLIT("at ") <+> ppr loc1,
ptext SLIT("and") <+> ppr loc2]
-
\end{code}
diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs
index 6fe697ba590b..a3c292b82368 100644
--- a/ghc/compiler/typecheck/TcDefaults.lhs
+++ b/ghc/compiler/typecheck/TcDefaults.lhs
@@ -12,7 +12,7 @@ import HsSyn ( HsDecl(..), DefaultDecl(..) )
import RnHsSyn ( RenamedHsDecl )
import TcMonad
-import TcEnv ( tcLookupClassByKey )
+import TcEnv ( tcLookupClassByKey_maybe )
import TcMonoType ( tcHsType )
import TcSimplify ( tcSimplifyCheckThetas )
@@ -25,7 +25,7 @@ import Util
\end{code}
\begin{code}
-default_default = [integerTy, doubleTy ]
+default_default = [integerTy, doubleTy]
tcDefaults :: [RenamedHsDecl]
-> TcM s [Type] -- defaulting types to heave
@@ -35,24 +35,33 @@ tcDefaults decls = tc_defaults [default_decl | DefD default_decl <- decls]
tc_defaults [] = returnTc default_default
+tc_defaults [DefaultDecl [] locn]
+ = returnTc [] -- no defaults
+
tc_defaults [DefaultDecl mono_tys locn]
- = tcAddSrcLoc locn $
+ = tcLookupClassByKey_maybe numClassKey `thenNF_Tc` \ maybe_num ->
+ case maybe_num of {
+ Nothing -> -- Num has not been sucked in, so the defaults will
+ -- never be used; so simply discard the default decl.
+ -- This slightly benefits modules that don't use any
+ -- numeric stuff at all, by avoid the necessity of
+ -- always sucking in Num
+ returnTc [] ;
+
+ Just num -> -- The common case
+
+ tcAddSrcLoc locn $
mapTc tcHsType mono_tys `thenTc` \ tau_tys ->
- case tau_tys of
- [] -> returnTc [] -- no defaults
-
- _ ->
-- Check that all the types are instances of Num
-- We only care about whether it worked or not
-
- tcAddErrCtxt defaultDeclCtxt $
- tcLookupClassByKey numClassKey `thenNF_Tc` \ num ->
- tcSimplifyCheckThetas
+ tcAddErrCtxt defaultDeclCtxt $
+ tcSimplifyCheckThetas
[{- Nothing given -}]
[ (num, [ty]) | ty <- tau_tys ] `thenTc_`
- returnTc tau_tys
+ returnTc tau_tys
+ }
tc_defaults decls@(DefaultDecl _ loc : _) =
tcAddSrcLoc loc $
@@ -69,3 +78,4 @@ dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things)
where
pp (DefaultDecl _ locn) = ptext SLIT("here was another default declaration") <+> ppr locn
\end{code}
+
diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 49da0db77b87..6b13551a600c 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -13,7 +13,7 @@ module TcEnv(
tcLookupTy,
tcLookupTyCon, tcLookupTyConByKey,
- tcLookupClass, tcLookupClassByKey,
+ tcLookupClass, tcLookupClassByKey, tcLookupClassByKey_maybe,
tcExtendGlobalValEnv, tcExtendLocalValEnv,
tcGetValueEnv, tcSetValueEnv,
@@ -332,6 +332,13 @@ tcLookupClassByKey key
Just (_, _, AClass cl) -> returnNF_Tc cl
other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key)
+tcLookupClassByKey_maybe :: Unique -> NF_TcM s (Maybe Class)
+tcLookupClassByKey_maybe key
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
+ case lookupUFM_Directly te key of
+ Just (_, _, AClass cl) -> returnNF_Tc (Just cl)
+ other -> returnNF_Tc Nothing
+
tcLookupTyConByKey :: Unique -> NF_TcM s TyCon
tcLookupTyConByKey key
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 5bd347192edb..fb74078e63ee 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -585,7 +585,7 @@ creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
\begin{code}
instConstraintErr clas tys
- = hang (ptext SLIT("Illegal constaint") <+>
+ = hang (ptext SLIT("Illegal constraint") <+>
quotes (pprConstraint clas tys) <+>
ptext SLIT("in instance context"))
4 (ptext SLIT("(Instance contexts must constrain only type variables)"))
diff --git a/ghc/docs/users_guide/debugging.vsgml b/ghc/docs/users_guide/debugging.vsgml
index 2d99076ec79e..f3fed156e436 100644
--- a/ghc/docs/users_guide/debugging.vsgml
+++ b/ghc/docs/users_guide/debugging.vsgml
@@ -104,7 +104,7 @@ output) by using @-ddump-all@, or most of them with @-ddump-most@.
Some of the most useful ones are:
<descrip>
-<tag>@-ddump-parsed@:</tag> oarser output
+<tag>@-ddump-parsed@:</tag> parser output
<tag>@-ddump-rn@:</tag> renamer output
<tag>@-ddump-tc@:</tag> typechecker output
<tag>@-ddump-deriv@:</tag> derived instances
@@ -122,6 +122,10 @@ Some of the most useful ones are:
<tag>@-ddump-flatC@:</tag> <em>flattened</em> Abstract~C
<tag>@-ddump-realC@:</tag> same as what goes to the C compiler
<tag>@-ddump-asm@:</tag> assembly language from the native-code generator
+<tag>@-ddump-most@:</tag> most of the above, plus @-dshow-passes@, @-dsource-stats@, @-ddump-simpl-stats@,
+<tag>@-ddump-all@:</tag> all the above, plus @-ddump-inlinings@,
+@-ddump-simpl-iterations@, @-ddump-rn-trace@,
+@-ddump-verbose-simpl@, @-ddump-verbose-stg@.
</descrip>
<nidx>-ddump-all option</nidx>%
@@ -331,43 +335,3 @@ Main.skip2{-r1L6-} =
trademark of Peyton Jones Enterprises, plc.)
%----------------------------------------------------------------------
-<sect2>Command line options in source files
-<label id="source-file-options">
-<p>
-<nidx>source-file options</nidx>
-
-Sometimes it is useful to make the connection between a source file
-and the command-line options it requires quite tight. For instance,
-if a (Glasgow) Haskell source file uses @casm@s, the C back-end
-often needs to be told about which header files to include. Rather than
-maintaining the list of files the source depends on in a
-@Makefile@ (using the @-#include@ command-line option), it is
-possible to do this directly in the source file using the @OPTIONS@
-pragma <nidx>OPTIONS pragma</nidx>:
-
-<tscreen><verb>
-{-# OPTIONS -#include "foo.h" #-}
-module X where
-
-...
-</verb></tscreen>
-
-@OPTIONS@ pragmas are only looked for at the top of your source
-files, upto the first (non-literate,non-empty) line not containing
-@OPTIONS@. Multiple @OPTIONS@ pragmas are recognised. Note
-that your command shell does not get to the source file options, they
-are just included literally in the array of command-line arguments
-the compiler driver maintains internally, so you'll be desperately
-disappointed if you try to glob etc. inside @OPTIONS@.
-
-NOTE: the contents of OPTIONS are prepended to the command-line
-options, so you *do* have the ability to override OPTIONS settings
-via the command line.
-
-It is not recommended to move all the contents of your Makefiles into
-your source files, but in some circumstances, the @OPTIONS@ pragma
-is the Right Thing. (If you use @-keep-hc-file-too@ and have OPTION
-flags in your module, the OPTIONS will get put into the generated .hc
-file).
-
-%----------------------------------------------------------------------
diff --git a/ghc/docs/users_guide/using.vsgml b/ghc/docs/users_guide/using.vsgml
index 5de6c1a5612e..450771203487 100644
--- a/ghc/docs/users_guide/using.vsgml
+++ b/ghc/docs/users_guide/using.vsgml
@@ -889,6 +889,43 @@ __export A TA;
compiler that handles mutually recursive properly without the manual
construction of interface files, is (allegedly) in the works.
+%************************************************************************
+%* *
+<sect1>Command line options in source files
+<label id="source-file-options">
+<p>
+<nidx>source-file options</nidx>
+%* *
+%************************************************************************
+
+GHC expects its flags on the command line, but it is also possible
+to embed them in the Haskell module itself, using the @OPTIONS@
+pragma <nidx>OPTIONS pragma</nidx>:
+<tscreen><verb>
+ {-# OPTIONS -fglasgow-exts -fno-cpr-analyse #-}
+ module X where
+
+ ...
+</verb></tscreen>
+@OPTIONS@ pragmas are only looked for at the top of your source
+files, upto the first (non-literate,non-empty) line not containing
+@OPTIONS@. Multiple @OPTIONS@ pragmas are recognised. Note
+that your command shell does not get to the source file options, they
+are just included literally in the array of command-line arguments
+the compiler driver maintains internally, so you'll be desperately
+disappointed if you try to @glob@ etc. inside @OPTIONS@.
+
+The contents of @OPTIONS@ are prepended to the command-line
+options, so you *do* have the ability to override @OPTIONS@ settings
+via the command line.
+
+It is not recommended to move all the contents of your Makefiles into
+your source files, but in some circumstances, the @OPTIONS@ pragma
+is the Right Thing. (If you use @-keep-hc-file-too@ and have @OPTIONS@
+flags in your module, the @OPTIONS@ will get put into the generated .hc
+file).
+
+
%************************************************************************
%* *
<sect1>Optimisation (code improvement)
diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl
index ec4952580c4a..f07b251738ac 100644
--- a/ghc/driver/ghc.lprl
+++ b/ghc/driver/ghc.lprl
@@ -1077,8 +1077,8 @@ sub setupLinkOpts {
unshift(@Ld_flags,
( '-u', "${uscore}PrelBase_Izh_static_info"
,'-u', "${uscore}PrelBase_Czh_static_info"
- ,'-u', "${uscore}PrelBase_Fzh_static_info"
- ,'-u', "${uscore}PrelBase_Dzh_static_info"
+ ,'-u', "${uscore}PrelFloat_Fzh_static_info"
+ ,'-u', "${uscore}PrelFloat_Dzh_static_info"
,'-u', "${uscore}PrelAddr_Azh_static_info"
,'-u', "${uscore}PrelAddr_Wzh_static_info"
,'-u', "${uscore}PrelAddr_I64zh_static_info"
@@ -1086,8 +1086,8 @@ sub setupLinkOpts {
,'-u', "${uscore}PrelStable_StablePtr_static_info"
,'-u', "${uscore}PrelBase_Izh_con_info"
,'-u', "${uscore}PrelBase_Czh_con_info"
- ,'-u', "${uscore}PrelBase_Fzh_con_info"
- ,'-u', "${uscore}PrelBase_Dzh_con_info"
+ ,'-u', "${uscore}PrelFloat_Fzh_con_info"
+ ,'-u', "${uscore}PrelFloat_Dzh_con_info"
,'-u', "${uscore}PrelAddr_Azh_con_info"
,'-u', "${uscore}PrelAddr_Wzh_con_info"
,'-u', "${uscore}PrelAddr_I64zh_con_info"
diff --git a/ghc/includes/Prelude.h b/ghc/includes/Prelude.h
index 33015c5f2356..2f8d93d20233 100644
--- a/ghc/includes/Prelude.h
+++ b/ghc/includes/Prelude.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: Prelude.h,v 1.9 1999/07/14 11:15:09 simonmar Exp $
+ * $Id: Prelude.h,v 1.10 1999/12/20 10:34:33 simonpj Exp $
*
* (c) The GHC Team, 1998-1999
*
@@ -25,14 +25,14 @@ extern const StgClosure PrelMain_mainIO_closure;
extern DLL_IMPORT const StgInfoTable PrelBase_Czh_static_info;
extern DLL_IMPORT const StgInfoTable PrelBase_Izh_static_info;
-extern DLL_IMPORT const StgInfoTable PrelBase_Fzh_static_info;
-extern DLL_IMPORT const StgInfoTable PrelBase_Dzh_static_info;
+extern DLL_IMPORT const StgInfoTable PrelFloat_Fzh_static_info;
+extern DLL_IMPORT const StgInfoTable PrelFloat_Dzh_static_info;
extern DLL_IMPORT const StgInfoTable PrelAddr_Azh_static_info;
extern DLL_IMPORT const StgInfoTable PrelAddr_Wzh_static_info;
extern DLL_IMPORT const StgInfoTable PrelBase_Czh_con_info;
extern DLL_IMPORT const StgInfoTable PrelBase_Izh_con_info;
-extern DLL_IMPORT const StgInfoTable PrelBase_Fzh_con_info;
-extern DLL_IMPORT const StgInfoTable PrelBase_Dzh_con_info;
+extern DLL_IMPORT const StgInfoTable PrelFloat_Fzh_con_info;
+extern DLL_IMPORT const StgInfoTable PrelFloat_Dzh_con_info;
extern DLL_IMPORT const StgInfoTable PrelAddr_Azh_con_info;
extern DLL_IMPORT const StgInfoTable PrelAddr_Wzh_con_info;
extern DLL_IMPORT const StgInfoTable PrelAddr_I64zh_con_info;
@@ -53,14 +53,14 @@ extern DLL_IMPORT const StgInfoTable PrelStable_StablePtr_con_info;
#define NonTermination_closure PrelException_NonTermination_static_closure
#define Czh_static_info PrelBase_Czh_static_info
#define Izh_static_info PrelBase_Izh_static_info
-#define Fzh_static_info PrelBase_Fzh_static_info
-#define Dzh_static_info PrelBase_Dzh_static_info
+#define Fzh_static_info PrelFloat_Fzh_static_info
+#define Dzh_static_info PrelFloat_Dzh_static_info
#define Azh_static_info PrelAddr_Azh_static_info
#define Wzh_static_info PrelAddr_Wzh_static_info
#define Czh_con_info PrelBase_Czh_con_info
#define Izh_con_info PrelBase_Izh_con_info
-#define Fzh_con_info PrelBase_Fzh_con_info
-#define Dzh_con_info PrelBase_Dzh_con_info
+#define Fzh_con_info PrelFloat_Fzh_con_info
+#define Dzh_con_info PrelFloat_Dzh_con_info
#define Azh_con_info PrelAddr_Azh_con_info
#define Wzh_con_info PrelAddr_Wzh_con_info
#define W64zh_con_info PrelAddr_W64zh_con_info
diff --git a/ghc/lib/std/Array.lhs b/ghc/lib/std/Array.lhs
index e703494642c6..5ff36c9748ab 100644
--- a/ghc/lib/std/Array.lhs
+++ b/ghc/lib/std/Array.lhs
@@ -63,33 +63,15 @@ infixl 9 !, //
\begin{code}
-#ifdef USE_FOLDR_BUILD
-{-# INLINE indices #-}
-{-# INLINE elems #-}
-{-# INLINE assocs #-}
-#endif
{-# SPECIALISE listArray :: (Int,Int) -> [b] -> Array Int b #-}
listArray :: (Ix a) => (a,a) -> [b] -> Array a b
listArray b vs = array b (zip (range b) vs)
-{-# SPECIALISE indices :: Array Int b -> [Int] #-}
-indices :: (Ix a) => Array a b -> [a]
-indices = range . bounds
-
-{-# SPECIALISE elems :: Array Int b -> [b] #-}
+{-# INLINE elems #-}
elems :: (Ix a) => Array a b -> [b]
elems a = [a!i | i <- indices a]
-{-# SPECIALISE assocs :: Array Int b -> [(Int,b)] #-}
-assocs :: (Ix a) => Array a b -> [(a,b)]
-assocs a = [(i, a!i) | i <- indices a]
-
-{-# SPECIALISE amap :: (b -> c) -> Array Int b -> Array Int c #-}
-amap :: (Ix a) => (b -> c) -> Array a b -> Array a c
-amap f a = array b [(i, f (a!i)) | i <- range b]
- where b = bounds a
-
ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a c
ixmap b f a = array b [(i, a ! f i) | i <- range b]
\end{code}
@@ -101,34 +83,6 @@ ixmap b f a = array b [(i, a ! f i) | i <- range b]
%* *
%*********************************************************
-\begin{code}
-instance Ix a => Functor (Array a) where
- fmap = amap
-
-instance (Ix a, Eq b) => Eq (Array a b) where
- a == a' = assocs a == assocs a'
- a /= a' = assocs a /= assocs a'
-
-instance (Ix a, Ord b) => Ord (Array a b) where
- compare a b = compare (assocs a) (assocs b)
-
-instance (Ix a, Show a, Show b) => Show (Array a b) where
- showsPrec p a = showParen (p > 9) (
- showString "array " .
- shows (bounds a) . showChar ' ' .
- shows (assocs a) )
- showList = showList__ (showsPrec 0)
-
-{-
-instance (Ix a, Read a, Read b) => Read (Array a b) where
- readsPrec p = readParen (p > 9)
- (\r -> [(array b as, u) | ("array",s) <- lex r,
- (b,t) <- reads s,
- (as,u) <- reads t ])
- readList = readList__ (readsPrec 0)
--}
-\end{code}
-
#else
\begin{code}
diff --git a/ghc/lib/std/CPUTime.lhs b/ghc/lib/std/CPUTime.lhs
index e808b2a0d58a..9d7e6a7c7942 100644
--- a/ghc/lib/std/CPUTime.lhs
+++ b/ghc/lib/std/CPUTime.lhs
@@ -4,7 +4,7 @@
\section[CPUTime]{Haskell 1.4 CPU Time Library}
\begin{code}
-{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
+{-# OPTIONS -#include "cbits/stgio.h" #-}
module CPUTime
(
@@ -17,15 +17,13 @@ module CPUTime
#ifndef __HUGS__
\begin{code}
-import PrelBase
-import PrelArr ( ByteArray(..), newIntArray, unsafeFreezeByteArray )
-import PrelMaybe
-import PrelNum
-import PrelNumExtra
-import PrelIOBase
-import PrelST
-import IO ( ioError )
-import PrelNum ( Num(..), Integral(..) ) -- To get fromInt/toInt
+import Prelude -- To generate the dependency
+import PrelGHC ( indexIntArray# )
+import PrelBase ( Int(..) )
+import PrelByteArr ( ByteArray(..), newIntArray, unsafeFreezeByteArray )
+import PrelNum ( fromInt )
+import PrelIOBase ( IOError(..), IOErrorType( UnsupportedOperation ),
+ unsafePerformIO, stToIO )
import Ratio
\end{code}
diff --git a/ghc/lib/std/Directory.lhs b/ghc/lib/std/Directory.lhs
index 81331191f79f..6ca00295fd4f 100644
--- a/ghc/lib/std/Directory.lhs
+++ b/ghc/lib/std/Directory.lhs
@@ -53,14 +53,20 @@ module Directory
#ifdef __HUGS__
--import PreludeBuiltin
#else
-import PrelBase
-import PrelIOBase
-import PrelHandle
-import PrelST
-import PrelArr
+
+import Prelude -- Just to get it in the dependencies
+
+import PrelGHC ( RealWorld, int2Word#, or#, and# )
+import PrelByteArr ( ByteArray, MutableByteArray,
+ newWordArray, readWordArray, newCharArray,
+ unsafeFreezeByteArray
+ )
import PrelPack ( unpackNBytesST, packString, unpackCStringST )
-import PrelAddr
+import PrelIOBase ( stToIO,
+ constructErrorAndFail, constructErrorAndFailWithInfo,
+ IOError(IOError), IOErrorType(SystemError) )
import Time ( ClockTime(..) )
+import PrelAddr ( Addr, nullAddr, Word(..), wordToInt )
#endif
\end{code}
diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs
index f72b817545e2..1a8d4b338ca9 100644
--- a/ghc/lib/std/IO.lhs
+++ b/ghc/lib/std/IO.lhs
@@ -107,7 +107,7 @@ import PrelRead ( readParen, Read(..), reads, lex,
import PrelShow
import PrelMaybe ( Either(..), Maybe(..) )
import PrelAddr ( Addr(..), nullAddr )
-import PrelArr ( ByteArray )
+import PrelByteArr ( ByteArray )
import PrelPack ( unpackNBytesAccST )
import PrelException ( ioError, catch )
diff --git a/ghc/lib/std/Ix.lhs b/ghc/lib/std/Ix.lhs
index e7ee2042f7fb..ab733ee3ee6c 100644
--- a/ghc/lib/std/Ix.lhs
+++ b/ghc/lib/std/Ix.lhs
@@ -37,6 +37,8 @@ import PrelList( null )
import PrelEnum
import PrelShow
import PrelNum
+
+default()
\end{code}
%*********************************************************
diff --git a/ghc/lib/std/Numeric.lhs b/ghc/lib/std/Numeric.lhs
index fa56105a824e..ac2a037402ea 100644
--- a/ghc/lib/std/Numeric.lhs
+++ b/ghc/lib/std/Numeric.lhs
@@ -8,7 +8,6 @@ Odds and ends, mostly functions for reading and showing
\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
module Numeric
( fromRat -- :: (RealFloat a) => Rational -> a
@@ -34,23 +33,27 @@ module Numeric
-- Implementation checked wrt. Haskell 98 lib report, 1/99.
) where
+import Char
+
#ifndef __HUGS__
-import PrelBase
-import PrelMaybe
-import PrelShow
-import PrelArr
-import PrelNum
-import PrelNumExtra
-import PrelRead
-import PrelErr ( error )
+ -- GHC imports
+import Prelude -- For dependencies
+import PrelBase ( Char(..) )
+import PrelRead -- Lots of things
+import PrelReal ( showSigned )
+import PrelFloat ( fromRat, FFFormat(..),
+ formatRealFloat, floatToDigits, showFloat
+ )
+import PrelNum ( ord_0 )
#else
-import Char
+ -- Hugs imports
import Array
#endif
-\end{code}
#ifndef __HUGS__
+\end{code}
+
\begin{code}
showInt :: Integral a => a -> ShowS
showInt i rs
@@ -82,7 +85,15 @@ showGFloat d x = showString (formatRealFloat FFGeneric d x)
\end{code}
-#else
+#else
+
+%*********************************************************
+%* *
+ All of this code is for Hugs only
+ GHC gets it from PrelFloat!
+%* *
+%*********************************************************
+
\begin{code}
-- This converts a rational to a floating. This should be used in the
-- Fractional instances of Float and Double.
diff --git a/ghc/lib/std/PrelAddr.lhs b/ghc/lib/std/PrelAddr.lhs
index 70f4a7c0686f..1f61cec4ad0e 100644
--- a/ghc/lib/std/PrelAddr.lhs
+++ b/ghc/lib/std/PrelAddr.lhs
@@ -22,7 +22,6 @@ module PrelAddr (
import PrelGHC
import PrelBase
-import PrelCCall
\end{code}
\begin{code}
diff --git a/ghc/lib/std/PrelArr.lhs b/ghc/lib/std/PrelArr.lhs
index e1d1f2b7ce7c..03873d6165d6 100644
--- a/ghc/lib/std/PrelArr.lhs
+++ b/ghc/lib/std/PrelArr.lhs
@@ -6,6 +6,8 @@
Array implementation, @PrelArr@ exports the basic array
types and operations.
+For byte-arrays see @PrelByteArr@.
+
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
@@ -16,11 +18,13 @@ import Ix
import PrelList (foldl)
import PrelST
import PrelBase
-import PrelCCall
import PrelAddr
import PrelGHC
+import PrelShow
infixl 9 !, //
+
+default ()
\end{code}
\begin{code}
@@ -30,9 +34,6 @@ array :: (Ix a) => (a,a) -> [(a,b)] -> Array a b
{-# SPECIALISE (!) :: Array Int b -> Int -> b #-}
(!) :: (Ix a) => Array a b -> a -> b
-{-# SPECIALISE bounds :: Array Int b -> (Int,Int) #-}
-bounds :: (Ix a) => Array a b -> (a,a)
-
{-# SPECIALISE (//) :: Array Int b -> [(Int,b)] -> Array Int b #-}
(//) :: (Ix a) => Array a b -> [(a,b)] -> Array a b
@@ -41,6 +42,10 @@ accum :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b
{-# SPECIALISE accumArray :: (b -> c -> b) -> b -> (Int,Int) -> [(Int,c)] -> Array Int b #-}
accumArray :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b
+
+bounds :: (Ix a) => Array a b -> (a,a)
+assocs :: (Ix a) => Array a b -> [(a,b)]
+indices :: (Ix a) => Array a b -> [a]
\end{code}
@@ -54,12 +59,8 @@ accumArray :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a
type IPr = (Int, Int)
data Ix ix => Array ix elt = Array ix ix (Array# elt)
-data Ix ix => ByteArray ix = ByteArray ix ix ByteArray#
data Ix ix => MutableArray s ix elt = MutableArray ix ix (MutableArray# s elt)
-data Ix ix => MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
-instance CCallable (MutableByteArray s ix)
-instance CCallable (ByteArray ix)
data MutableVar s a = MutableVar (MutVar# s a)
@@ -71,10 +72,6 @@ instance Eq (MutableVar s a) where
instance Eq (MutableArray s ix elt) where
MutableArray _ _ arr1# == MutableArray _ _ arr2#
= sameMutableArray# arr1# arr2#
-
-instance Eq (MutableByteArray s ix) where
- MutableByteArray _ _ arr1# == MutableByteArray _ _ arr2#
- = sameMutableByteArray# arr1# arr2#
\end{code}
%*********************************************************
@@ -108,8 +105,20 @@ writeVar (MutableVar var#) val = ST $ \ s# ->
"array", "!" and "bounds" are basic; the rest can be defined in terms of them
\begin{code}
+{-# INLINE bounds #-}
bounds (Array l u _) = (l,u)
+{-# INLINE assocs #-} -- Want to fuse the list comprehension
+assocs a = [(i, a!i) | i <- indices a]
+
+{-# INLINE indices #-}
+indices = range . bounds
+
+{-# SPECIALISE amap :: (b -> c) -> Array Int b -> Array Int c #-}
+amap :: (Ix a) => (b -> c) -> Array a b -> Array a c
+amap f a = array b [(i, f (a!i)) | i <- range b]
+ where b = bounds a
+
(Array l u arr#) ! i
= let n# = case (index (l,u) i) of { I# x -> x } -- index fails if out of range
in
@@ -195,6 +204,42 @@ accumArray f zero ixs ivs
\end{code}
+%*********************************************************
+%* *
+\subsection{Array instances}
+%* *
+%*********************************************************
+
+
+\begin{code}
+instance Ix a => Functor (Array a) where
+ fmap = amap
+
+instance (Ix a, Eq b) => Eq (Array a b) where
+ a == a' = assocs a == assocs a'
+ a /= a' = assocs a /= assocs a'
+
+instance (Ix a, Ord b) => Ord (Array a b) where
+ compare a b = compare (assocs a) (assocs b)
+
+instance (Ix a, Show a, Show b) => Show (Array a b) where
+ showsPrec p a = showParen (p > 9) (
+ showString "array " .
+ shows (bounds a) . showChar ' ' .
+ shows (assocs a) )
+ showList = showList__ (showsPrec 0)
+
+{-
+instance (Ix a, Read a, Read b) => Read (Array a b) where
+ readsPrec p = readParen (p > 9)
+ (\r -> [(array b as, u) | ("array",s) <- lex r,
+ (b,t) <- reads s,
+ (as,u) <- reads t ])
+ readList = readList__ (readsPrec 0)
+-}
+\end{code}
+
+
%*********************************************************
%* *
\subsection{Operations on mutable arrays}
@@ -216,208 +261,40 @@ might be different, though.
\begin{code}
newArray :: Ix ix => (ix,ix) -> elt -> ST s (MutableArray s ix elt)
-newCharArray, newIntArray, newWordArray, newAddrArray, newFloatArray, newDoubleArray
- :: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix)
{-# SPECIALIZE newArray :: IPr -> elt -> ST s (MutableArray s Int elt),
(IPr,IPr) -> elt -> ST s (MutableArray s IPr elt)
#-}
-{-# SPECIALIZE newCharArray :: IPr -> ST s (MutableByteArray s Int) #-}
-{-# SPECIALIZE newIntArray :: IPr -> ST s (MutableByteArray s Int) #-}
-{-# SPECIALIZE newWordArray :: IPr -> ST s (MutableByteArray s Int) #-}
-{-# SPECIALIZE newAddrArray :: IPr -> ST s (MutableByteArray s Int) #-}
-{-# SPECIALIZE newFloatArray :: IPr -> ST s (MutableByteArray s Int) #-}
-{-# SPECIALIZE newDoubleArray :: IPr -> ST s (MutableByteArray s Int) #-}
-
newArray (l,u) init = ST $ \ s# ->
case rangeSize (l,u) of { I# n# ->
case (newArray# n# init s#) of { (# s2#, arr# #) ->
(# s2#, MutableArray l u arr# #) }}
-newCharArray (l,u) = ST $ \ s# ->
- case rangeSize (l,u) of { I# n# ->
- case (newCharArray# n# s#) of { (# s2#, barr# #) ->
- (# s2#, MutableByteArray l u barr# #) }}
-
-newIntArray (l,u) = ST $ \ s# ->
- case rangeSize (l,u) of { I# n# ->
- case (newIntArray# n# s#) of { (# s2#, barr# #) ->
- (# s2#, MutableByteArray l u barr# #) }}
-
-newWordArray (l,u) = ST $ \ s# ->
- case rangeSize (l,u) of { I# n# ->
- case (newWordArray# n# s#) of { (# s2#, barr# #) ->
- (# s2#, MutableByteArray l u barr# #) }}
-
-newAddrArray (l,u) = ST $ \ s# ->
- case rangeSize (l,u) of { I# n# ->
- case (newAddrArray# n# s#) of { (# s2#, barr# #) ->
- (# s2#, MutableByteArray l u barr# #) }}
-
-newFloatArray (l,u) = ST $ \ s# ->
- case rangeSize (l,u) of { I# n# ->
- case (newFloatArray# n# s#) of { (# s2#, barr# #) ->
- (# s2#, MutableByteArray l u barr# #) }}
-newDoubleArray (l,u) = ST $ \ s# ->
- case rangeSize (l,u) of { I# n# ->
- case (newDoubleArray# n# s#) of { (# s2#, barr# #) ->
- (# s2#, MutableByteArray l u barr# #) }}
boundsOfArray :: Ix ix => MutableArray s ix elt -> (ix, ix)
-
{-# SPECIALIZE boundsOfArray :: MutableArray s Int elt -> IPr #-}
-
boundsOfArray (MutableArray l u _) = (l,u)
readArray :: Ix ix => MutableArray s ix elt -> ix -> ST s elt
-
-readCharArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Char
-readIntArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Int
-readWordArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Word
-readAddrArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Addr
-readFloatArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Float
-readDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Double
-
{-# SPECIALIZE readArray :: MutableArray s Int elt -> Int -> ST s elt,
MutableArray s IPr elt -> IPr -> ST s elt
#-}
-{-# SPECIALIZE readCharArray :: MutableByteArray s Int -> Int -> ST s Char #-}
-{-# SPECIALIZE readIntArray :: MutableByteArray s Int -> Int -> ST s Int #-}
-{-# SPECIALIZE readAddrArray :: MutableByteArray s Int -> Int -> ST s Addr #-}
---NO:{-# SPECIALIZE readFloatArray :: MutableByteArray s Int -> Int -> ST s Float #-}
-{-# SPECIALIZE readDoubleArray :: MutableByteArray s Int -> Int -> ST s Double #-}
readArray (MutableArray l u arr#) n = ST $ \ s# ->
case (index (l,u) n) of { I# n# ->
case readArray# arr# n# s# of { (# s2#, r #) ->
(# s2#, r #) }}
-readCharArray (MutableByteArray l u barr#) n = ST $ \ s# ->
- case (index (l,u) n) of { I# n# ->
- case readCharArray# barr# n# s# of { (# s2#, r# #) ->
- (# s2#, C# r# #) }}
-
-readIntArray (MutableByteArray l u barr#) n = ST $ \ s# ->
- case (index (l,u) n) of { I# n# ->
- case readIntArray# barr# n# s# of { (# s2#, r# #) ->
- (# s2#, I# r# #) }}
-
-readWordArray (MutableByteArray l u barr#) n = ST $ \ s# ->
- case (index (l,u) n) of { I# n# ->
- case readWordArray# barr# n# s# of { (# s2#, r# #) ->
- (# s2#, W# r# #) }}
-
-readAddrArray (MutableByteArray l u barr#) n = ST $ \ s# ->
- case (index (l,u) n) of { I# n# ->
- case readAddrArray# barr# n# s# of { (# s2#, r# #) ->
- (# s2#, A# r# #) }}
-
-readFloatArray (MutableByteArray l u barr#) n = ST $ \ s# ->
- case (index (l,u) n) of { I# n# ->
- case readFloatArray# barr# n# s# of { (# s2#, r# #) ->
- (# s2#, F# r# #) }}
-
-readDoubleArray (MutableByteArray l u barr#) n = ST $ \ s# ->
- case (index (l,u) n) of { I# n# ->
- case readDoubleArray# barr# n# s# of { (# s2#, r# #) ->
- (# s2#, D# r# #) }}
-
---Indexing of ordinary @Arrays@ is standard Haskell and isn't defined here.
-indexCharArray :: Ix ix => ByteArray ix -> ix -> Char
-indexIntArray :: Ix ix => ByteArray ix -> ix -> Int
-indexWordArray :: Ix ix => ByteArray ix -> ix -> Word
-indexAddrArray :: Ix ix => ByteArray ix -> ix -> Addr
-indexFloatArray :: Ix ix => ByteArray ix -> ix -> Float
-indexDoubleArray :: Ix ix => ByteArray ix -> ix -> Double
-
-{-# SPECIALIZE indexCharArray :: ByteArray Int -> Int -> Char #-}
-{-# SPECIALIZE indexIntArray :: ByteArray Int -> Int -> Int #-}
-{-# SPECIALIZE indexAddrArray :: ByteArray Int -> Int -> Addr #-}
---NO:{-# SPECIALIZE indexFloatArray :: ByteArray Int -> Int -> Float #-}
-{-# SPECIALIZE indexDoubleArray :: ByteArray Int -> Int -> Double #-}
-
-indexCharArray (ByteArray l u barr#) n
- = case (index (l,u) n) of { I# n# ->
- case indexCharArray# barr# n# of { r# ->
- (C# r#)}}
-
-indexIntArray (ByteArray l u barr#) n
- = case (index (l,u) n) of { I# n# ->
- case indexIntArray# barr# n# of { r# ->
- (I# r#)}}
-
-indexWordArray (ByteArray l u barr#) n
- = case (index (l,u) n) of { I# n# ->
- case indexWordArray# barr# n# of { r# ->
- (W# r#)}}
-
-indexAddrArray (ByteArray l u barr#) n
- = case (index (l,u) n) of { I# n# ->
- case indexAddrArray# barr# n# of { r# ->
- (A# r#)}}
-
-indexFloatArray (ByteArray l u barr#) n
- = case (index (l,u) n) of { I# n# ->
- case indexFloatArray# barr# n# of { r# ->
- (F# r#)}}
-
-indexDoubleArray (ByteArray l u barr#) n
- = case (index (l,u) n) of { I# n# ->
- case indexDoubleArray# barr# n# of { r# ->
- (D# r#)}}
-
writeArray :: Ix ix => MutableArray s ix elt -> ix -> elt -> ST s ()
-writeCharArray :: Ix ix => MutableByteArray s ix -> ix -> Char -> ST s ()
-writeIntArray :: Ix ix => MutableByteArray s ix -> ix -> Int -> ST s ()
-writeWordArray :: Ix ix => MutableByteArray s ix -> ix -> Word -> ST s ()
-writeAddrArray :: Ix ix => MutableByteArray s ix -> ix -> Addr -> ST s ()
-writeFloatArray :: Ix ix => MutableByteArray s ix -> ix -> Float -> ST s ()
-writeDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> Double -> ST s ()
-
{-# SPECIALIZE writeArray :: MutableArray s Int elt -> Int -> elt -> ST s (),
MutableArray s IPr elt -> IPr -> elt -> ST s ()
#-}
-{-# SPECIALIZE writeCharArray :: MutableByteArray s Int -> Int -> Char -> ST s () #-}
-{-# SPECIALIZE writeIntArray :: MutableByteArray s Int -> Int -> Int -> ST s () #-}
-{-# SPECIALIZE writeAddrArray :: MutableByteArray s Int -> Int -> Addr -> ST s () #-}
---NO:{-# SPECIALIZE writeFloatArray :: MutableByteArray s Int -> Int -> Float -> ST s () #-}
-{-# SPECIALIZE writeDoubleArray :: MutableByteArray s Int -> Int -> Double -> ST s () #-}
writeArray (MutableArray l u arr#) n ele = ST $ \ s# ->
case index (l,u) n of { I# n# ->
case writeArray# arr# n# ele s# of { s2# ->
(# s2#, () #) }}
-
-writeCharArray (MutableByteArray l u barr#) n (C# ele) = ST $ \ s# ->
- case index (l,u) n of { I# n# ->
- case writeCharArray# barr# n# ele s# of { s2# ->
- (# s2#, () #) }}
-
-writeIntArray (MutableByteArray l u barr#) n (I# ele) = ST $ \ s# ->
- case index (l,u) n of { I# n# ->
- case writeIntArray# barr# n# ele s# of { s2# ->
- (# s2#, () #) }}
-
-writeWordArray (MutableByteArray l u barr#) n (W# ele) = ST $ \ s# ->
- case index (l,u) n of { I# n# ->
- case writeWordArray# barr# n# ele s# of { s2# ->
- (# s2#, () #) }}
-
-writeAddrArray (MutableByteArray l u barr#) n (A# ele) = ST $ \ s# ->
- case index (l,u) n of { I# n# ->
- case writeAddrArray# barr# n# ele s# of { s2# ->
- (# s2#, () #) }}
-
-writeFloatArray (MutableByteArray l u barr#) n (F# ele) = ST $ \ s# ->
- case index (l,u) n of { I# n# ->
- case writeFloatArray# barr# n# ele s# of { s2# ->
- (# s2#, () #) }}
-
-writeDoubleArray (MutableByteArray l u barr#) n (D# ele) = ST $ \ s# ->
- case index (l,u) n of { I# n# ->
- case writeDoubleArray# barr# n# ele s# of { s2# ->
- (# s2#, () #) }}
\end{code}
@@ -429,15 +306,9 @@ writeDoubleArray (MutableByteArray l u barr#) n (D# ele) = ST $ \ s# ->
\begin{code}
freezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt)
-freezeCharArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
-freezeIntArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
-freezeWordArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
-freezeAddrArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
-
{-# SPECIALISE freezeArray :: MutableArray s Int elt -> ST s (Array Int elt),
MutableArray s IPr elt -> ST s (Array IPr elt)
#-}
-{-# SPECIALISE freezeCharArray :: MutableByteArray s Int -> ST s (ByteArray Int) #-}
freezeArray (MutableArray l u arr#) = ST $ \ s# ->
case rangeSize (l,u) of { I# n# ->
@@ -471,148 +342,19 @@ freezeArray (MutableArray l u arr#) = ST $ \ s# ->
copy (cur# +# 1#) end# from# to# s2#
}}
-freezeCharArray (MutableByteArray l u arr#) = ST $ \ s# ->
- case rangeSize (l,u) of { I# n# ->
- case freeze arr# n# s# of { (# s2#, frozen# #) ->
- (# s2#, ByteArray l u frozen# #) }}
- where
- freeze :: MutableByteArray# s -- the thing
- -> Int# -- size of thing to be frozen
- -> State# s -- the Universe and everything
- -> (# State# s, ByteArray# #)
-
- freeze arr1# n# s1#
- = case (newCharArray# n# s1#) of { (# s2#, newarr1# #) ->
- case copy 0# n# arr1# newarr1# s2# of { (# s3#, newarr2# #) ->
- unsafeFreezeByteArray# newarr2# s3#
- }}
- where
- copy :: Int# -> Int#
- -> MutableByteArray# s -> MutableByteArray# s
- -> State# s
- -> (# State# s, MutableByteArray# s #)
-
- copy cur# end# from# to# st#
- | cur# ==# end#
- = (# st#, to# #)
- | otherwise
- = case (readCharArray# from# cur# st#) of { (# s2#, ele #) ->
- case (writeCharArray# to# cur# ele s2#) of { s3# ->
- copy (cur# +# 1#) end# from# to# s3#
- }}
-
-freezeIntArray (MutableByteArray l u arr#) = ST $ \ s# ->
- case rangeSize (l,u) of { I# n# ->
- case freeze arr# n# s# of { (# s2#, frozen# #) ->
- (# s2#, ByteArray l u frozen# #) }}
- where
- freeze :: MutableByteArray# s -- the thing
- -> Int# -- size of thing to be frozen
- -> State# s -- the Universe and everything
- -> (# State# s, ByteArray# #)
-
- freeze m_arr# n# s#
- = case (newIntArray# n# s#) of { (# s2#, newarr1# #) ->
- case copy 0# n# m_arr# newarr1# s2# of { (# s3#, newarr2# #) ->
- unsafeFreezeByteArray# newarr2# s3#
- }}
- where
- copy :: Int# -> Int#
- -> MutableByteArray# s -> MutableByteArray# s
- -> State# s
- -> (# State# s, MutableByteArray# s #)
-
- copy cur# end# from# to# s1#
- | cur# ==# end#
- = (# s1#, to# #)
- | otherwise
- = case (readIntArray# from# cur# s1#) of { (# s2#, ele #) ->
- case (writeIntArray# to# cur# ele s2#) of { s3# ->
- copy (cur# +# 1#) end# from# to# s3#
- }}
-
-freezeWordArray (MutableByteArray l u arr#) = ST $ \ s# ->
- case rangeSize (l,u) of { I# n# ->
- case freeze arr# n# s# of { (# s2#, frozen# #) ->
- (# s2#, ByteArray l u frozen# #) }}
- where
- freeze :: MutableByteArray# s -- the thing
- -> Int# -- size of thing to be frozen
- -> State# s -- the Universe and everything
- -> (# State# s, ByteArray# #)
-
- freeze m_arr# n# s1#
- = case (newWordArray# n# s1#) of { (# s2#, newarr1# #) ->
- case copy 0# n# m_arr# newarr1# s2# of { (# s3#, newarr2# #) ->
- unsafeFreezeByteArray# newarr2# s3#
- }}
- where
- copy :: Int# -> Int#
- -> MutableByteArray# s -> MutableByteArray# s
- -> State# s
- -> (# State# s, MutableByteArray# s #)
-
- copy cur# end# from# to# st#
- | cur# ==# end# = (# st#, to# #)
- | otherwise =
- case (readWordArray# from# cur# st#) of { (# s2#, ele #) ->
- case (writeWordArray# to# cur# ele s2#) of { s3# ->
- copy (cur# +# 1#) end# from# to# s3#
- }}
-
-freezeAddrArray (MutableByteArray l u arr#) = ST $ \ s# ->
- case rangeSize (l,u) of { I# n# ->
- case freeze arr# n# s# of { (# s2#, frozen# #) ->
- (# s2#, ByteArray l u frozen# #) }}
- where
- freeze :: MutableByteArray# s -- the thing
- -> Int# -- size of thing to be frozen
- -> State# s -- the Universe and everything
- -> (# State# s, ByteArray# #)
-
- freeze m_arr# n# s1#
- = case (newAddrArray# n# s1#) of { (# s2#, newarr1# #) ->
- case copy 0# n# m_arr# newarr1# s2# of { (# s3#, newarr2# #) ->
- unsafeFreezeByteArray# newarr2# s3#
- }}
- where
- copy :: Int# -> Int#
- -> MutableByteArray# s -> MutableByteArray# s
- -> State# s
- -> (# State# s, MutableByteArray# s #)
-
- copy cur# end# from# to# st#
- | cur# ==# end#
- = (# st#, to# #)
- | otherwise
- = case (readAddrArray# from# cur# st#) of { (# st1#, ele #) ->
- case (writeAddrArray# to# cur# ele st1#) of { st2# ->
- copy (cur# +# 1#) end# from# to# st2#
- }}
-
unsafeFreezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt)
-unsafeFreezeByteArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
-
-{-# SPECIALIZE unsafeFreezeByteArray :: MutableByteArray s Int -> ST s (ByteArray Int)
- #-}
-
unsafeFreezeArray (MutableArray l u arr#) = ST $ \ s# ->
case unsafeFreezeArray# arr# s# of { (# s2#, frozen# #) ->
(# s2#, Array l u frozen# #) }
-unsafeFreezeByteArray (MutableByteArray l u arr#) = ST $ \ s# ->
- case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
- (# s2#, ByteArray l u frozen# #) }
-
-
--This takes a immutable array, and copies it into a mutable array, in a
--hurry.
+thawArray :: Ix ix => Array ix elt -> ST s (MutableArray s ix elt)
{-# SPECIALISE thawArray :: Array Int elt -> ST s (MutableArray s Int elt),
Array IPr elt -> ST s (MutableArray s IPr elt)
#-}
-thawArray :: Ix ix => Array ix elt -> ST s (MutableArray s ix elt)
thawArray (Array l u arr#) = ST $ \ s# ->
case rangeSize (l,u) of { I# n# ->
case thaw arr# n# s# of { (# s2#, thawed# #) ->
diff --git a/ghc/lib/std/PrelArrExtra.lhs b/ghc/lib/std/PrelArrExtra.lhs
index 7c267fccc4c3..840e9dd7c890 100644
--- a/ghc/lib/std/PrelArrExtra.lhs
+++ b/ghc/lib/std/PrelArrExtra.lhs
@@ -15,6 +15,7 @@ module PrelArrExtra where
import Ix
import PrelArr
+import PrelByteArr
import PrelST
import PrelBase
import PrelGHC
diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs
index 89b069444830..dcf8f31058e4 100644
--- a/ghc/lib/std/PrelBase.lhs
+++ b/ghc/lib/std/PrelBase.lhs
@@ -4,6 +4,72 @@
\section[PrelBase]{Module @PrelBase@}
+The overall structure of the GHC Prelude is a bit tricky.
+
+ a) We want to avoid "orphan modules", i.e. ones with instance
+ decls that don't belong either to a tycon or a class
+ defined in the same module
+
+ b) We want to avoid giant modules
+
+So the rough structure is as follows, in (linearised) dependency order
+
+
+PrelGHC Has no implementation. It defines built-in things, and
+ by importing it you bring them into scope.
+ The source file is PrelGHC.hi-boot, which is just
+ copied to make PrelGHC.hi
+
+ Classes: CCallable, CReturnable
+
+PrelBase Classes: Eq, Ord, Functor, Monad
+ Types: list, (), Int, Bool, Ordering, Char, String
+
+PrelTup Types: tuples, plus instances for PrelBase classes
+
+PrelShow Class: Show, plus instances for PrelBase/PrelTup types
+
+PrelEnum Class: Enum, plus instances for PrelBase/PrelTup types
+
+PrelMaybe Type: Maybe, plus instances for PrelBase classes
+
+PrelNum Class: Num, plus instances for Int
+ Type: Integer, plus instances for all classes so far (Eq, Ord, Num, Show)
+
+ Integer is needed here because it is mentioned in the signature
+ of 'fromInteger' in class Num
+
+PrelReal Classes: Real, Integral, Fractional, RealFrac
+ plus instances for Int, Integer
+ Types: Ratio, Rational
+ plus intances for classes so far
+
+ Rational is needed here because it is mentioned in the signature
+ of 'toRational' in class Real
+
+Ix Classes: Ix, plus instances for Int, Bool, Char, Integer, Ordering, tuples
+
+PrelArr Types: Array, MutableArray, MutableVar
+
+ Does *not* contain any ByteArray stuff (see PrelByteArr)
+ Arrays are used by a function in PrelFloat
+
+PrelFloat Classes: Floating, RealFloat
+ Types: Float, Double, plus instances of all classes so far
+
+ This module contains everything to do with floating point.
+ It is a big module (900 lines)
+ With a bit of luck, many modules can be compiled without ever reading PrelFloat.hi
+
+PrelByteArr Types: ByteArray, MutableByteArray
+
+ We want this one to be after PrelFloat, because it defines arrays
+ of unboxed floats.
+
+
+Other Prelude modules are much easier with fewer complex dependencies.
+
+
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
@@ -25,6 +91,8 @@ infixr 3 &&
infixr 2 ||
infixl 1 >>, >>=
infixr 0 $
+
+default () -- Double isn't available yet
\end{code}
@@ -358,74 +426,6 @@ compareInt :: Int -> Int -> Ordering
\end{code}
-%*********************************************************
-%* *
-\subsection{Type @Integer@, @Float@, @Double@}
-%* *
-%*********************************************************
-
-\begin{code}
-data Float = F# Float#
-data Double = D# Double#
-
-data Integer
- = S# Int# -- small integers
- | J# Int# ByteArray# -- large integers
-
-instance Eq Integer where
- (S# i) == (S# j) = i ==# j
- (S# i) == (J# s d) = cmpIntegerInt# s d i ==# 0#
- (J# s d) == (S# i) = cmpIntegerInt# s d i ==# 0#
- (J# s1 d1) == (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) ==# 0#
-
- (S# i) /= (S# j) = i /=# j
- (S# i) /= (J# s d) = cmpIntegerInt# s d i /=# 0#
- (J# s d) /= (S# i) = cmpIntegerInt# s d i /=# 0#
- (J# s1 d1) /= (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) /=# 0#
-
-instance Ord Integer where
- (S# i) <= (S# j) = i <=# j
- (J# s d) <= (S# i) = cmpIntegerInt# s d i <=# 0#
- (S# i) <= (J# s d) = cmpIntegerInt# s d i >=# 0#
- (J# s1 d1) <= (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) <=# 0#
-
- (S# i) > (S# j) = i ># j
- (J# s d) > (S# i) = cmpIntegerInt# s d i ># 0#
- (S# i) > (J# s d) = cmpIntegerInt# s d i <# 0#
- (J# s1 d1) > (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) ># 0#
-
- (S# i) < (S# j) = i <# j
- (J# s d) < (S# i) = cmpIntegerInt# s d i <# 0#
- (S# i) < (J# s d) = cmpIntegerInt# s d i ># 0#
- (J# s1 d1) < (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) <# 0#
-
- (S# i) >= (S# j) = i >=# j
- (J# s d) >= (S# i) = cmpIntegerInt# s d i >=# 0#
- (S# i) >= (J# s d) = cmpIntegerInt# s d i <=# 0#
- (J# s1 d1) >= (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) >=# 0#
-
- compare (S# i) (S# j)
- | i ==# j = EQ
- | i <=# j = LT
- | otherwise = GT
- compare (J# s d) (S# i)
- = case cmpIntegerInt# s d i of { res# ->
- if res# <# 0# then LT else
- if res# ># 0# then GT else EQ
- }
- compare (S# i) (J# s d)
- = case cmpIntegerInt# s d i of { res# ->
- if res# ># 0# then LT else
- if res# <# 0# then GT else EQ
- }
- compare (J# s1 d1) (J# s2 d2)
- = case cmpInteger# s1 d1 s2 d2 of { res# ->
- if res# <# 0# then LT else
- if res# ># 0# then GT else EQ
- }
-\end{code}
-
-
%*********************************************************
%* *
\subsection{The function type}
@@ -467,6 +467,28 @@ asTypeOf :: a -> a -> a
asTypeOf = const
\end{code}
+%*********************************************************
+%* *
+\subsection{CCallable instances}
+%* *
+%*********************************************************
+
+Defined here to avoid orphans
+
+\begin{code}
+instance CCallable Char
+instance CReturnable Char
+
+instance CCallable Int
+instance CReturnable Int
+
+-- DsCCall knows how to pass strings...
+instance CCallable [Char]
+
+instance CReturnable () -- Why, exactly?
+\end{code}
+
+
%*********************************************************
%* *
\subsection{Numeric primops}
@@ -490,16 +512,30 @@ used in the case of partial applications, etc.
{-# INLINE remInt #-}
{-# INLINE negateInt #-}
-plusInt, minusInt, timesInt, quotInt, remInt :: Int -> Int -> Int
+plusInt, minusInt, timesInt, quotInt, remInt, gcdInt :: Int -> Int -> Int
plusInt (I# x) (I# y) = I# (x +# y)
minusInt(I# x) (I# y) = I# (x -# y)
timesInt(I# x) (I# y) = I# (x *# y)
quotInt (I# x) (I# y) = I# (quotInt# x y)
remInt (I# x) (I# y) = I# (remInt# x y)
+gcdInt (I# a) (I# b) = I# (gcdInt# a b)
negateInt :: Int -> Int
negateInt (I# x) = I# (negateInt# x)
+divInt, modInt :: Int -> Int -> Int
+x `divInt` y
+ | x > zeroInt && y < zeroInt = quotInt ((x `minusInt` y) `minusInt` oneInt) y
+ | x < zeroInt && y > zeroInt = quotInt ((x `minusInt` y) `plusInt` oneInt) y
+ | otherwise = quotInt x y
+
+x `modInt` y
+ | x > zeroInt && y < zeroInt ||
+ x < zeroInt && y > zeroInt = if r/=zeroInt then r `plusInt` y else zeroInt
+ | otherwise = r
+ where
+ r = remInt x y
+
gtInt, geInt, eqInt, neInt, ltInt, leInt :: Int -> Int -> Bool
gtInt (I# x) (I# y) = x ># y
geInt (I# x) (I# y) = x >=# y
@@ -509,14 +545,3 @@ ltInt (I# x) (I# y) = x <# y
leInt (I# x) (I# y) = x <=# y
\end{code}
-Convenient boxed Integer PrimOps. These are 'thin-air' Ids, so
-it's nice to have them in PrelBase.
-
-\begin{code}
-{-# INLINE int2Integer #-}
-{-# INLINE addr2Integer #-}
-int2Integer :: Int# -> Integer
-int2Integer i = S# i
-addr2Integer :: Addr# -> Integer
-addr2Integer x = case addr2Integer# x of (# s, d #) -> J# s d
-\end{code}
diff --git a/ghc/lib/std/PrelByteArr.lhs b/ghc/lib/std/PrelByteArr.lhs
new file mode 100644
index 000000000000..3973c741c1be
--- /dev/null
+++ b/ghc/lib/std/PrelByteArr.lhs
@@ -0,0 +1,377 @@
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+\section[PrelByteArr]{Module @PrelByteArr@}
+
+Byte-arrays are flat arrays of non-pointers only.
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+module PrelByteArr where
+
+import {-# SOURCE #-} PrelErr ( error )
+import PrelArr
+import PrelFloat
+import Ix
+import PrelList (foldl)
+import PrelST
+import PrelBase
+import PrelAddr
+import PrelGHC
+
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{The @Array@ types}
+%* *
+%*********************************************************
+
+\begin{code}
+data Ix ix => ByteArray ix = ByteArray ix ix ByteArray#
+data Ix ix => MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
+
+instance CCallable (MutableByteArray s ix)
+instance CCallable (ByteArray ix)
+
+instance Eq (MutableByteArray s ix) where
+ MutableByteArray _ _ arr1# == MutableByteArray _ _ arr2#
+ = sameMutableByteArray# arr1# arr2#
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Operations on mutable arrays}
+%* *
+%*********************************************************
+
+Idle ADR question: What's the tradeoff here between flattening these
+datatypes into @MutableArray ix ix (MutableArray# s elt)@ and using
+it as is? As I see it, the former uses slightly less heap and
+provides faster access to the individual parts of the bounds while the
+code used has the benefit of providing a ready-made @(lo, hi)@ pair as
+required by many array-related functions. Which wins? Is the
+difference significant (probably not).
+
+Idle AJG answer: When I looked at the outputted code (though it was 2
+years ago) it seems like you often needed the tuple, and we build
+it frequently. Now we've got the overloading specialiser things
+might be different, though.
+
+\begin{code}
+newCharArray, newIntArray, newWordArray, newAddrArray, newFloatArray, newDoubleArray
+ :: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix)
+
+{-# SPECIALIZE newCharArray :: IPr -> ST s (MutableByteArray s Int) #-}
+{-# SPECIALIZE newIntArray :: IPr -> ST s (MutableByteArray s Int) #-}
+{-# SPECIALIZE newWordArray :: IPr -> ST s (MutableByteArray s Int) #-}
+{-# SPECIALIZE newAddrArray :: IPr -> ST s (MutableByteArray s Int) #-}
+{-# SPECIALIZE newFloatArray :: IPr -> ST s (MutableByteArray s Int) #-}
+{-# SPECIALIZE newDoubleArray :: IPr -> ST s (MutableByteArray s Int) #-}
+
+newCharArray (l,u) = ST $ \ s# ->
+ case rangeSize (l,u) of { I# n# ->
+ case (newCharArray# n# s#) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray l u barr# #) }}
+
+newIntArray (l,u) = ST $ \ s# ->
+ case rangeSize (l,u) of { I# n# ->
+ case (newIntArray# n# s#) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray l u barr# #) }}
+
+newWordArray (l,u) = ST $ \ s# ->
+ case rangeSize (l,u) of { I# n# ->
+ case (newWordArray# n# s#) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray l u barr# #) }}
+
+newAddrArray (l,u) = ST $ \ s# ->
+ case rangeSize (l,u) of { I# n# ->
+ case (newAddrArray# n# s#) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray l u barr# #) }}
+
+newFloatArray (l,u) = ST $ \ s# ->
+ case rangeSize (l,u) of { I# n# ->
+ case (newFloatArray# n# s#) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray l u barr# #) }}
+
+newDoubleArray (l,u) = ST $ \ s# ->
+ case rangeSize (l,u) of { I# n# ->
+ case (newDoubleArray# n# s#) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray l u barr# #) }}
+
+
+readCharArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Char
+readIntArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Int
+readWordArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Word
+readAddrArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Addr
+readFloatArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Float
+readDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Double
+
+{-# SPECIALIZE readCharArray :: MutableByteArray s Int -> Int -> ST s Char #-}
+{-# SPECIALIZE readIntArray :: MutableByteArray s Int -> Int -> ST s Int #-}
+{-# SPECIALIZE readAddrArray :: MutableByteArray s Int -> Int -> ST s Addr #-}
+--NO:{-# SPECIALIZE readFloatArray :: MutableByteArray s Int -> Int -> ST s Float #-}
+{-# SPECIALIZE readDoubleArray :: MutableByteArray s Int -> Int -> ST s Double #-}
+
+readCharArray (MutableByteArray l u barr#) n = ST $ \ s# ->
+ case (index (l,u) n) of { I# n# ->
+ case readCharArray# barr# n# s# of { (# s2#, r# #) ->
+ (# s2#, C# r# #) }}
+
+readIntArray (MutableByteArray l u barr#) n = ST $ \ s# ->
+ case (index (l,u) n) of { I# n# ->
+ case readIntArray# barr# n# s# of { (# s2#, r# #) ->
+ (# s2#, I# r# #) }}
+
+readWordArray (MutableByteArray l u barr#) n = ST $ \ s# ->
+ case (index (l,u) n) of { I# n# ->
+ case readWordArray# barr# n# s# of { (# s2#, r# #) ->
+ (# s2#, W# r# #) }}
+
+readAddrArray (MutableByteArray l u barr#) n = ST $ \ s# ->
+ case (index (l,u) n) of { I# n# ->
+ case readAddrArray# barr# n# s# of { (# s2#, r# #) ->
+ (# s2#, A# r# #) }}
+
+readFloatArray (MutableByteArray l u barr#) n = ST $ \ s# ->
+ case (index (l,u) n) of { I# n# ->
+ case readFloatArray# barr# n# s# of { (# s2#, r# #) ->
+ (# s2#, F# r# #) }}
+
+readDoubleArray (MutableByteArray l u barr#) n = ST $ \ s# ->
+ case (index (l,u) n) of { I# n# ->
+ case readDoubleArray# barr# n# s# of { (# s2#, r# #) ->
+ (# s2#, D# r# #) }}
+
+--Indexing of ordinary @Arrays@ is standard Haskell and isn't defined here.
+indexCharArray :: Ix ix => ByteArray ix -> ix -> Char
+indexIntArray :: Ix ix => ByteArray ix -> ix -> Int
+indexWordArray :: Ix ix => ByteArray ix -> ix -> Word
+indexAddrArray :: Ix ix => ByteArray ix -> ix -> Addr
+indexFloatArray :: Ix ix => ByteArray ix -> ix -> Float
+indexDoubleArray :: Ix ix => ByteArray ix -> ix -> Double
+
+{-# SPECIALIZE indexCharArray :: ByteArray Int -> Int -> Char #-}
+{-# SPECIALIZE indexIntArray :: ByteArray Int -> Int -> Int #-}
+{-# SPECIALIZE indexAddrArray :: ByteArray Int -> Int -> Addr #-}
+--NO:{-# SPECIALIZE indexFloatArray :: ByteArray Int -> Int -> Float #-}
+{-# SPECIALIZE indexDoubleArray :: ByteArray Int -> Int -> Double #-}
+
+indexCharArray (ByteArray l u barr#) n
+ = case (index (l,u) n) of { I# n# ->
+ case indexCharArray# barr# n# of { r# ->
+ (C# r#)}}
+
+indexIntArray (ByteArray l u barr#) n
+ = case (index (l,u) n) of { I# n# ->
+ case indexIntArray# barr# n# of { r# ->
+ (I# r#)}}
+
+indexWordArray (ByteArray l u barr#) n
+ = case (index (l,u) n) of { I# n# ->
+ case indexWordArray# barr# n# of { r# ->
+ (W# r#)}}
+
+indexAddrArray (ByteArray l u barr#) n
+ = case (index (l,u) n) of { I# n# ->
+ case indexAddrArray# barr# n# of { r# ->
+ (A# r#)}}
+
+indexFloatArray (ByteArray l u barr#) n
+ = case (index (l,u) n) of { I# n# ->
+ case indexFloatArray# barr# n# of { r# ->
+ (F# r#)}}
+
+indexDoubleArray (ByteArray l u barr#) n
+ = case (index (l,u) n) of { I# n# ->
+ case indexDoubleArray# barr# n# of { r# ->
+ (D# r#)}}
+
+writeCharArray :: Ix ix => MutableByteArray s ix -> ix -> Char -> ST s ()
+writeIntArray :: Ix ix => MutableByteArray s ix -> ix -> Int -> ST s ()
+writeWordArray :: Ix ix => MutableByteArray s ix -> ix -> Word -> ST s ()
+writeAddrArray :: Ix ix => MutableByteArray s ix -> ix -> Addr -> ST s ()
+writeFloatArray :: Ix ix => MutableByteArray s ix -> ix -> Float -> ST s ()
+writeDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> Double -> ST s ()
+
+{-# SPECIALIZE writeCharArray :: MutableByteArray s Int -> Int -> Char -> ST s () #-}
+{-# SPECIALIZE writeIntArray :: MutableByteArray s Int -> Int -> Int -> ST s () #-}
+{-# SPECIALIZE writeAddrArray :: MutableByteArray s Int -> Int -> Addr -> ST s () #-}
+--NO:{-# SPECIALIZE writeFloatArray :: MutableByteArray s Int -> Int -> Float -> ST s () #-}
+{-# SPECIALIZE writeDoubleArray :: MutableByteArray s Int -> Int -> Double -> ST s () #-}
+
+writeCharArray (MutableByteArray l u barr#) n (C# ele) = ST $ \ s# ->
+ case index (l,u) n of { I# n# ->
+ case writeCharArray# barr# n# ele s# of { s2# ->
+ (# s2#, () #) }}
+
+writeIntArray (MutableByteArray l u barr#) n (I# ele) = ST $ \ s# ->
+ case index (l,u) n of { I# n# ->
+ case writeIntArray# barr# n# ele s# of { s2# ->
+ (# s2#, () #) }}
+
+writeWordArray (MutableByteArray l u barr#) n (W# ele) = ST $ \ s# ->
+ case index (l,u) n of { I# n# ->
+ case writeWordArray# barr# n# ele s# of { s2# ->
+ (# s2#, () #) }}
+
+writeAddrArray (MutableByteArray l u barr#) n (A# ele) = ST $ \ s# ->
+ case index (l,u) n of { I# n# ->
+ case writeAddrArray# barr# n# ele s# of { s2# ->
+ (# s2#, () #) }}
+
+writeFloatArray (MutableByteArray l u barr#) n (F# ele) = ST $ \ s# ->
+ case index (l,u) n of { I# n# ->
+ case writeFloatArray# barr# n# ele s# of { s2# ->
+ (# s2#, () #) }}
+
+writeDoubleArray (MutableByteArray l u barr#) n (D# ele) = ST $ \ s# ->
+ case index (l,u) n of { I# n# ->
+ case writeDoubleArray# barr# n# ele s# of { s2# ->
+ (# s2#, () #) }}
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Moving between mutable and immutable}
+%* *
+%*********************************************************
+
+\begin{code}
+freezeCharArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
+freezeIntArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
+freezeWordArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
+freezeAddrArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
+
+{-# SPECIALISE freezeCharArray :: MutableByteArray s Int -> ST s (ByteArray Int) #-}
+
+freezeCharArray (MutableByteArray l u arr#) = ST $ \ s# ->
+ case rangeSize (l,u) of { I# n# ->
+ case freeze arr# n# s# of { (# s2#, frozen# #) ->
+ (# s2#, ByteArray l u frozen# #) }}
+ where
+ freeze :: MutableByteArray# s -- the thing
+ -> Int# -- size of thing to be frozen
+ -> State# s -- the Universe and everything
+ -> (# State# s, ByteArray# #)
+
+ freeze arr1# n# s1#
+ = case (newCharArray# n# s1#) of { (# s2#, newarr1# #) ->
+ case copy 0# n# arr1# newarr1# s2# of { (# s3#, newarr2# #) ->
+ unsafeFreezeByteArray# newarr2# s3#
+ }}
+ where
+ copy :: Int# -> Int#
+ -> MutableByteArray# s -> MutableByteArray# s
+ -> State# s
+ -> (# State# s, MutableByteArray# s #)
+
+ copy cur# end# from# to# st#
+ | cur# ==# end#
+ = (# st#, to# #)
+ | otherwise
+ = case (readCharArray# from# cur# st#) of { (# s2#, ele #) ->
+ case (writeCharArray# to# cur# ele s2#) of { s3# ->
+ copy (cur# +# 1#) end# from# to# s3#
+ }}
+
+freezeIntArray (MutableByteArray l u arr#) = ST $ \ s# ->
+ case rangeSize (l,u) of { I# n# ->
+ case freeze arr# n# s# of { (# s2#, frozen# #) ->
+ (# s2#, ByteArray l u frozen# #) }}
+ where
+ freeze :: MutableByteArray# s -- the thing
+ -> Int# -- size of thing to be frozen
+ -> State# s -- the Universe and everything
+ -> (# State# s, ByteArray# #)
+
+ freeze m_arr# n# s#
+ = case (newIntArray# n# s#) of { (# s2#, newarr1# #) ->
+ case copy 0# n# m_arr# newarr1# s2# of { (# s3#, newarr2# #) ->
+ unsafeFreezeByteArray# newarr2# s3#
+ }}
+ where
+ copy :: Int# -> Int#
+ -> MutableByteArray# s -> MutableByteArray# s
+ -> State# s
+ -> (# State# s, MutableByteArray# s #)
+
+ copy cur# end# from# to# s1#
+ | cur# ==# end#
+ = (# s1#, to# #)
+ | otherwise
+ = case (readIntArray# from# cur# s1#) of { (# s2#, ele #) ->
+ case (writeIntArray# to# cur# ele s2#) of { s3# ->
+ copy (cur# +# 1#) end# from# to# s3#
+ }}
+
+freezeWordArray (MutableByteArray l u arr#) = ST $ \ s# ->
+ case rangeSize (l,u) of { I# n# ->
+ case freeze arr# n# s# of { (# s2#, frozen# #) ->
+ (# s2#, ByteArray l u frozen# #) }}
+ where
+ freeze :: MutableByteArray# s -- the thing
+ -> Int# -- size of thing to be frozen
+ -> State# s -- the Universe and everything
+ -> (# State# s, ByteArray# #)
+
+ freeze m_arr# n# s1#
+ = case (newWordArray# n# s1#) of { (# s2#, newarr1# #) ->
+ case copy 0# n# m_arr# newarr1# s2# of { (# s3#, newarr2# #) ->
+ unsafeFreezeByteArray# newarr2# s3#
+ }}
+ where
+ copy :: Int# -> Int#
+ -> MutableByteArray# s -> MutableByteArray# s
+ -> State# s
+ -> (# State# s, MutableByteArray# s #)
+
+ copy cur# end# from# to# st#
+ | cur# ==# end# = (# st#, to# #)
+ | otherwise =
+ case (readWordArray# from# cur# st#) of { (# s2#, ele #) ->
+ case (writeWordArray# to# cur# ele s2#) of { s3# ->
+ copy (cur# +# 1#) end# from# to# s3#
+ }}
+
+freezeAddrArray (MutableByteArray l u arr#) = ST $ \ s# ->
+ case rangeSize (l,u) of { I# n# ->
+ case freeze arr# n# s# of { (# s2#, frozen# #) ->
+ (# s2#, ByteArray l u frozen# #) }}
+ where
+ freeze :: MutableByteArray# s -- the thing
+ -> Int# -- size of thing to be frozen
+ -> State# s -- the Universe and everything
+ -> (# State# s, ByteArray# #)
+
+ freeze m_arr# n# s1#
+ = case (newAddrArray# n# s1#) of { (# s2#, newarr1# #) ->
+ case copy 0# n# m_arr# newarr1# s2# of { (# s3#, newarr2# #) ->
+ unsafeFreezeByteArray# newarr2# s3#
+ }}
+ where
+ copy :: Int# -> Int#
+ -> MutableByteArray# s -> MutableByteArray# s
+ -> State# s
+ -> (# State# s, MutableByteArray# s #)
+
+ copy cur# end# from# to# st#
+ | cur# ==# end#
+ = (# st#, to# #)
+ | otherwise
+ = case (readAddrArray# from# cur# st#) of { (# st1#, ele #) ->
+ case (writeAddrArray# to# cur# ele st1#) of { st2# ->
+ copy (cur# +# 1#) end# from# to# st2#
+ }}
+
+unsafeFreezeByteArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
+
+{-# SPECIALIZE unsafeFreezeByteArray :: MutableByteArray s Int -> ST s (ByteArray Int)
+ #-}
+
+unsafeFreezeByteArray (MutableByteArray l u arr#) = ST $ \ s# ->
+ case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
+ (# s2#, ByteArray l u frozen# #) }
+\end{code}
diff --git a/ghc/lib/std/PrelCCall.lhs b/ghc/lib/std/PrelCCall.lhs
deleted file mode 100644
index d8c1eb4f4b48..000000000000
--- a/ghc/lib/std/PrelCCall.lhs
+++ /dev/null
@@ -1,43 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1994-1996
-%
-
-\section[PrelCCall]{Module @PrelCCall@}
-
-\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
-
-module PrelCCall (
- CCallable(..),
- CReturnable(..)
- ) where
-
-import PrelBase
-import PrelGHC
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Classes @CCallable@ and @CReturnable@}
-%* *
-%*********************************************************
-
-\begin{code}
-instance CCallable Char
-instance CReturnable Char
-
-instance CCallable Int
-instance CReturnable Int
-
--- DsCCall knows how to pass strings...
-instance CCallable [Char]
-
-instance CCallable Float
-instance CReturnable Float
-
-instance CCallable Double
-instance CReturnable Double
-
-instance CReturnable () -- Why, exactly?
-\end{code}
-
diff --git a/ghc/lib/std/PrelConc.lhs b/ghc/lib/std/PrelConc.lhs
index e327827f48c3..f2b7b0180fd4 100644
--- a/ghc/lib/std/PrelConc.lhs
+++ b/ghc/lib/std/PrelConc.lhs
@@ -44,7 +44,7 @@ import PrelIOBase ( IO(..), MVar(..), unsafePerformIO )
import PrelBase ( Int(..) )
import PrelException ( Exception(..), AsyncException(..) )
-infixr 0 `par`
+infixr 0 `par`, `seq`
\end{code}
%************************************************************************
diff --git a/ghc/lib/std/PrelEnum.lhs b/ghc/lib/std/PrelEnum.lhs
index 2ace283077a8..2b0f5bd5af0e 100644
--- a/ghc/lib/std/PrelEnum.lhs
+++ b/ghc/lib/std/PrelEnum.lhs
@@ -19,6 +19,8 @@ module PrelEnum(
import {-# SOURCE #-} PrelErr ( error )
import PrelBase
import PrelTup () -- To make sure we look for the .hi file
+
+default () -- Double isn't available yet
\end{code}
diff --git a/ghc/lib/std/PrelFloat.lhs b/ghc/lib/std/PrelFloat.lhs
new file mode 100644
index 000000000000..bb85dcc7beb1
--- /dev/null
+++ b/ghc/lib/std/PrelFloat.lhs
@@ -0,0 +1,892 @@
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[PrelNum]{Module @PrelNum@}
+
+The types
+
+ Float
+ Double
+
+and the classes
+
+ Floating
+ RealFloat
+
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+#include "../includes/ieee-flpt.h"
+
+module PrelFloat where
+
+import {-# SOURCE #-} PrelErr
+import PrelBase
+import PrelList
+import PrelEnum
+import PrelShow
+import PrelNum
+import PrelReal
+import PrelArr
+import PrelMaybe
+
+infixr 8 **
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Standard numeric classes}
+%* *
+%*********************************************************
+
+\begin{code}
+class (Fractional a) => Floating a where
+ pi :: a
+ exp, log, sqrt :: a -> a
+ (**), logBase :: a -> a -> a
+ sin, cos, tan :: a -> a
+ asin, acos, atan :: a -> a
+ sinh, cosh, tanh :: a -> a
+ asinh, acosh, atanh :: a -> a
+
+ x ** y = exp (log x * y)
+ logBase x y = log y / log x
+ sqrt x = x ** 0.5
+ tan x = sin x / cos x
+ tanh x = sinh x / cosh x
+
+class (RealFrac a, Floating a) => RealFloat a where
+ floatRadix :: a -> Integer
+ floatDigits :: a -> Int
+ floatRange :: a -> (Int,Int)
+ decodeFloat :: a -> (Integer,Int)
+ encodeFloat :: Integer -> Int -> a
+ exponent :: a -> Int
+ significand :: a -> a
+ scaleFloat :: Int -> a -> a
+ isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
+ :: a -> Bool
+ atan2 :: a -> a -> a
+
+
+ exponent x = if m == 0 then 0 else n + floatDigits x
+ where (m,n) = decodeFloat x
+
+ significand x = encodeFloat m (negate (floatDigits x))
+ where (m,_) = decodeFloat x
+
+ scaleFloat k x = encodeFloat m (n+k)
+ where (m,n) = decodeFloat x
+
+ atan2 y x
+ | x > 0 = atan (y/x)
+ | x == 0 && y > 0 = pi/2
+ | x < 0 && y > 0 = pi + atan (y/x)
+ |(x <= 0 && y < 0) ||
+ (x < 0 && isNegativeZero y) ||
+ (isNegativeZero x && isNegativeZero y)
+ = -atan2 (-y) x
+ | y == 0 && (x < 0 || isNegativeZero x)
+ = pi -- must be after the previous test on zero y
+ | x==0 && y==0 = y -- must be after the other double zero tests
+ | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Type @Integer@, @Float@, @Double@}
+%* *
+%*********************************************************
+
+\begin{code}
+data Float = F# Float#
+data Double = D# Double#
+
+instance CCallable Float
+instance CReturnable Float
+
+instance CCallable Double
+instance CReturnable Double
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Type @Float@}
+%* *
+%*********************************************************
+
+\begin{code}
+instance Eq Float where
+ (F# x) == (F# y) = x `eqFloat#` y
+
+instance Ord Float where
+ (F# x) `compare` (F# y) | x `ltFloat#` y = LT
+ | x `eqFloat#` y = EQ
+ | otherwise = GT
+
+ (F# x) < (F# y) = x `ltFloat#` y
+ (F# x) <= (F# y) = x `leFloat#` y
+ (F# x) >= (F# y) = x `geFloat#` y
+ (F# x) > (F# y) = x `gtFloat#` y
+
+instance Num Float where
+ (+) x y = plusFloat x y
+ (-) x y = minusFloat x y
+ negate x = negateFloat x
+ (*) x y = timesFloat x y
+ abs x | x >= 0.0 = x
+ | otherwise = negateFloat x
+ signum x | x == 0.0 = 0
+ | x > 0.0 = 1
+ | otherwise = negate 1
+
+ {-# INLINE fromInteger #-}
+ fromInteger n = encodeFloat n 0
+ -- It's important that encodeFloat inlines here, and that
+ -- fromInteger in turn inlines,
+ -- so that if fromInteger is applied to an (S# i) the right thing happens
+
+ {-# INLINE fromInt #-}
+ fromInt i = int2Float i
+
+instance Real Float where
+ toRational x = (m%1)*(b%1)^^n
+ where (m,n) = decodeFloat x
+ b = floatRadix x
+
+instance Fractional Float where
+ (/) x y = divideFloat x y
+ fromRational x = fromRat x
+ recip x = 1.0 / x
+
+instance RealFrac Float where
+
+ {-# SPECIALIZE properFraction :: Float -> (Int, Float) #-}
+ {-# SPECIALIZE truncate :: Float -> Int #-}
+ {-# SPECIALIZE round :: Float -> Int #-}
+ {-# SPECIALIZE ceiling :: Float -> Int #-}
+ {-# SPECIALIZE floor :: Float -> Int #-}
+
+ {-# SPECIALIZE properFraction :: Float -> (Integer, Float) #-}
+ {-# SPECIALIZE truncate :: Float -> Integer #-}
+ {-# SPECIALIZE round :: Float -> Integer #-}
+ {-# SPECIALIZE ceiling :: Float -> Integer #-}
+ {-# SPECIALIZE floor :: Float -> Integer #-}
+
+ properFraction x
+ = case (decodeFloat x) of { (m,n) ->
+ let b = floatRadix x in
+ if n >= 0 then
+ (fromInteger m * fromInteger b ^ n, 0.0)
+ else
+ case (quotRem m (b^(negate n))) of { (w,r) ->
+ (fromInteger w, encodeFloat r n)
+ }
+ }
+
+ truncate x = case properFraction x of
+ (n,_) -> n
+
+ round x = case properFraction x of
+ (n,r) -> let
+ m = if r < 0.0 then n - 1 else n + 1
+ half_down = abs r - 0.5
+ in
+ case (compare half_down 0.0) of
+ LT -> n
+ EQ -> if even n then n else m
+ GT -> m
+
+ ceiling x = case properFraction x of
+ (n,r) -> if r > 0.0 then n + 1 else n
+
+ floor x = case properFraction x of
+ (n,r) -> if r < 0.0 then n - 1 else n
+
+instance Floating Float where
+ pi = 3.141592653589793238
+ exp x = expFloat x
+ log x = logFloat x
+ sqrt x = sqrtFloat x
+ sin x = sinFloat x
+ cos x = cosFloat x
+ tan x = tanFloat x
+ asin x = asinFloat x
+ acos x = acosFloat x
+ atan x = atanFloat x
+ sinh x = sinhFloat x
+ cosh x = coshFloat x
+ tanh x = tanhFloat x
+ (**) x y = powerFloat x y
+ logBase x y = log y / log x
+
+ asinh x = log (x + sqrt (1.0+x*x))
+ acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))
+ atanh x = log ((x+1.0) / sqrt (1.0-x*x))
+
+instance RealFloat Float where
+ floatRadix _ = FLT_RADIX -- from float.h
+ floatDigits _ = FLT_MANT_DIG -- ditto
+ floatRange _ = (FLT_MIN_EXP, FLT_MAX_EXP) -- ditto
+
+ decodeFloat (F# f#)
+ = case decodeFloat# f# of
+ (# exp#, s#, d# #) -> (J# s# d#, I# exp#)
+
+ encodeFloat (S# i) j = int_encodeFloat# i j
+ encodeFloat (J# s# d#) e = encodeFloat# s# d# e
+
+ exponent x = case decodeFloat x of
+ (m,n) -> if m == 0 then 0 else n + floatDigits x
+
+ significand x = case decodeFloat x of
+ (m,_) -> encodeFloat m (negate (floatDigits x))
+
+ scaleFloat k x = case decodeFloat x of
+ (m,n) -> encodeFloat m (n+k)
+ isNaN x = 0 /= isFloatNaN x
+ isInfinite x = 0 /= isFloatInfinite x
+ isDenormalized x = 0 /= isFloatDenormalized x
+ isNegativeZero x = 0 /= isFloatNegativeZero x
+ isIEEE _ = True
+
+instance Show Float where
+ showsPrec x = showSigned showFloat x
+ showList = showList__ (showsPrec 0)
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Type @Double@}
+%* *
+%*********************************************************
+
+\begin{code}
+instance Eq Double where
+ (D# x) == (D# y) = x ==## y
+
+instance Ord Double where
+ (D# x) `compare` (D# y) | x <## y = LT
+ | x ==## y = EQ
+ | otherwise = GT
+
+ (D# x) < (D# y) = x <## y
+ (D# x) <= (D# y) = x <=## y
+ (D# x) >= (D# y) = x >=## y
+ (D# x) > (D# y) = x >## y
+
+instance Num Double where
+ (+) x y = plusDouble x y
+ (-) x y = minusDouble x y
+ negate x = negateDouble x
+ (*) x y = timesDouble x y
+ abs x | x >= 0.0 = x
+ | otherwise = negateDouble x
+ signum x | x == 0.0 = 0
+ | x > 0.0 = 1
+ | otherwise = negate 1
+
+ {-# INLINE fromInteger #-}
+ -- See comments with Num Float
+ fromInteger n = encodeFloat n 0
+ fromInt (I# n#) = case (int2Double# n#) of { d# -> D# d# }
+
+instance Real Double where
+ toRational x = (m%1)*(b%1)^^n
+ where (m,n) = decodeFloat x
+ b = floatRadix x
+
+instance Fractional Double where
+ (/) x y = divideDouble x y
+ fromRational x = fromRat x
+ recip x = 1.0 / x
+
+instance Floating Double where
+ pi = 3.141592653589793238
+ exp x = expDouble x
+ log x = logDouble x
+ sqrt x = sqrtDouble x
+ sin x = sinDouble x
+ cos x = cosDouble x
+ tan x = tanDouble x
+ asin x = asinDouble x
+ acos x = acosDouble x
+ atan x = atanDouble x
+ sinh x = sinhDouble x
+ cosh x = coshDouble x
+ tanh x = tanhDouble x
+ (**) x y = powerDouble x y
+ logBase x y = log y / log x
+
+ asinh x = log (x + sqrt (1.0+x*x))
+ acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))
+ atanh x = log ((x+1.0) / sqrt (1.0-x*x))
+
+instance RealFrac Double where
+
+ {-# SPECIALIZE properFraction :: Double -> (Int, Double) #-}
+ {-# SPECIALIZE truncate :: Double -> Int #-}
+ {-# SPECIALIZE round :: Double -> Int #-}
+ {-# SPECIALIZE ceiling :: Double -> Int #-}
+ {-# SPECIALIZE floor :: Double -> Int #-}
+
+ {-# SPECIALIZE properFraction :: Double -> (Integer, Double) #-}
+ {-# SPECIALIZE truncate :: Double -> Integer #-}
+ {-# SPECIALIZE round :: Double -> Integer #-}
+ {-# SPECIALIZE ceiling :: Double -> Integer #-}
+ {-# SPECIALIZE floor :: Double -> Integer #-}
+
+ properFraction x
+ = case (decodeFloat x) of { (m,n) ->
+ let b = floatRadix x in
+ if n >= 0 then
+ (fromInteger m * fromInteger b ^ n, 0.0)
+ else
+ case (quotRem m (b^(negate n))) of { (w,r) ->
+ (fromInteger w, encodeFloat r n)
+ }
+ }
+
+ truncate x = case properFraction x of
+ (n,_) -> n
+
+ round x = case properFraction x of
+ (n,r) -> let
+ m = if r < 0.0 then n - 1 else n + 1
+ half_down = abs r - 0.5
+ in
+ case (compare half_down 0.0) of
+ LT -> n
+ EQ -> if even n then n else m
+ GT -> m
+
+ ceiling x = case properFraction x of
+ (n,r) -> if r > 0.0 then n + 1 else n
+
+ floor x = case properFraction x of
+ (n,r) -> if r < 0.0 then n - 1 else n
+
+instance RealFloat Double where
+ floatRadix _ = FLT_RADIX -- from float.h
+ floatDigits _ = DBL_MANT_DIG -- ditto
+ floatRange _ = (DBL_MIN_EXP, DBL_MAX_EXP) -- ditto
+
+ decodeFloat (D# x#)
+ = case decodeDouble# x# of
+ (# exp#, s#, d# #) -> (J# s# d#, I# exp#)
+
+ encodeFloat (S# i) j = int_encodeDouble# i j
+ encodeFloat (J# s# d#) e = encodeDouble# s# d# e
+
+ exponent x = case decodeFloat x of
+ (m,n) -> if m == 0 then 0 else n + floatDigits x
+
+ significand x = case decodeFloat x of
+ (m,_) -> encodeFloat m (negate (floatDigits x))
+
+ scaleFloat k x = case decodeFloat x of
+ (m,n) -> encodeFloat m (n+k)
+
+ isNaN x = 0 /= isDoubleNaN x
+ isInfinite x = 0 /= isDoubleInfinite x
+ isDenormalized x = 0 /= isDoubleDenormalized x
+ isNegativeZero x = 0 /= isDoubleNegativeZero x
+ isIEEE _ = True
+
+instance Show Double where
+ showsPrec x = showSigned showFloat x
+ showList = showList__ (showsPrec 0)
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{@Enum@ instances}
+%* *
+%*********************************************************
+
+The @Enum@ instances for Floats and Doubles are slightly unusual.
+The @toEnum@ function truncates numbers to Int. The definitions
+of @enumFrom@ and @enumFromThen@ allow floats to be used in arithmetic
+series: [0,0.1 .. 1.0]. However, roundoff errors make these somewhat
+dubious. This example may have either 10 or 11 elements, depending on
+how 0.1 is represented.
+
+NOTE: The instances for Float and Double do not make use of the default
+methods for @enumFromTo@ and @enumFromThenTo@, as these rely on there being
+a `non-lossy' conversion to and from Ints. Instead we make use of the
+1.2 default methods (back in the days when Enum had Ord as a superclass)
+for these (@numericEnumFromTo@ and @numericEnumFromThenTo@ below.)
+
+\begin{code}
+instance Enum Float where
+ succ x = x + 1
+ pred x = x - 1
+ toEnum = fromInt
+ fromEnum = fromInteger . truncate -- may overflow
+ enumFrom = numericEnumFrom
+ enumFromTo = numericEnumFromTo
+ enumFromThen = numericEnumFromThen
+ enumFromThenTo = numericEnumFromThenTo
+
+instance Enum Double where
+ succ x = x + 1
+ pred x = x - 1
+ toEnum = fromInt
+ fromEnum = fromInteger . truncate -- may overflow
+ enumFrom = numericEnumFrom
+ enumFromTo = numericEnumFromTo
+ enumFromThen = numericEnumFromThen
+ enumFromThenTo = numericEnumFromThenTo
+
+numericEnumFrom :: (Fractional a) => a -> [a]
+numericEnumFrom = iterate (+1)
+
+numericEnumFromThen :: (Fractional a) => a -> a -> [a]
+numericEnumFromThen n m = iterate (+(m-n)) n
+
+numericEnumFromTo :: (Ord a, Fractional a) => a -> a -> [a]
+numericEnumFromTo n m = takeWhile (<= m + 1/2) (numericEnumFrom n)
+
+numericEnumFromThenTo :: (Ord a, Fractional a) => a -> a -> a -> [a]
+numericEnumFromThenTo e1 e2 e3 = takeWhile pred (numericEnumFromThen e1 e2)
+ where
+ mid = (e2 - e1) / 2
+ pred | e2 > e1 = (<= e3 + mid)
+ | otherwise = (>= e3 + mid)
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Printing floating point}
+%* *
+%*********************************************************
+
+
+\begin{code}
+showFloat :: (RealFloat a) => a -> ShowS
+showFloat x = showString (formatRealFloat FFGeneric Nothing x)
+
+-- These are the format types. This type is not exported.
+
+data FFFormat = FFExponent | FFFixed | FFGeneric
+
+formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
+formatRealFloat fmt decs x
+ | isNaN x = "NaN"
+ | isInfinite x = if x < 0 then "-Infinity" else "Infinity"
+ | x < 0 || isNegativeZero x = '-':doFmt fmt (floatToDigits (toInteger base) (-x))
+ | otherwise = doFmt fmt (floatToDigits (toInteger base) x)
+ where
+ base = 10
+
+ doFmt format (is, e) =
+ let ds = map intToDigit is in
+ case format of
+ FFGeneric ->
+ doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
+ (is,e)
+ FFExponent ->
+ case decs of
+ Nothing ->
+ let show_e' = show (e-1) in
+ case ds of
+ "0" -> "0.0e0"
+ [d] -> d : ".0e" ++ show_e'
+ (d:ds') -> d : '.' : ds' ++ "e" ++ show_e'
+ Just dec ->
+ let dec' = max dec 1 in
+ case is of
+ [0] -> '0' :'.' : take dec' (repeat '0') ++ "e0"
+ _ ->
+ let
+ (ei,is') = roundTo base (dec'+1) is
+ (d:ds') = map intToDigit (if ei > 0 then init is' else is')
+ in
+ d:'.':ds' ++ 'e':show (e-1+ei)
+ FFFixed ->
+ let
+ mk0 ls = case ls of { "" -> "0" ; _ -> ls}
+ in
+ case decs of
+ Nothing ->
+ let
+ f 0 s rs = mk0 (reverse s) ++ '.':mk0 rs
+ f n s "" = f (n-1) ('0':s) ""
+ f n s (r:rs) = f (n-1) (r:s) rs
+ in
+ f e "" ds
+ Just dec ->
+ let dec' = max dec 0 in
+ if e >= 0 then
+ let
+ (ei,is') = roundTo base (dec' + e) is
+ (ls,rs) = splitAt (e+ei) (map intToDigit is')
+ in
+ mk0 ls ++ (if null rs then "" else '.':rs)
+ else
+ let
+ (ei,is') = roundTo base dec' (replicate (-e) 0 ++ is)
+ d:ds' = map intToDigit (if ei > 0 then is' else 0:is')
+ in
+ d : '.' : ds'
+
+
+roundTo :: Int -> Int -> [Int] -> (Int,[Int])
+roundTo base d is =
+ case f d is of
+ x@(0,_) -> x
+ (1,xs) -> (1, 1:xs)
+ where
+ b2 = base `div` 2
+
+ f n [] = (0, replicate n 0)
+ f 0 (x:_) = (if x >= b2 then 1 else 0, [])
+ f n (i:xs)
+ | i' == base = (1,0:ds)
+ | otherwise = (0,i':ds)
+ where
+ (c,ds) = f (n-1) xs
+ i' = c + i
+
+--
+-- Based on "Printing Floating-Point Numbers Quickly and Accurately"
+-- by R.G. Burger and R.K. Dybvig in PLDI 96.
+-- This version uses a much slower logarithm estimator. It should be improved.
+
+-- This function returns a list of digits (Ints in [0..base-1]) and an
+-- exponent.
+
+floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
+floatToDigits _ 0 = ([0], 0)
+floatToDigits base x =
+ let
+ (f0, e0) = decodeFloat x
+ (minExp0, _) = floatRange x
+ p = floatDigits x
+ b = floatRadix x
+ minExp = minExp0 - p -- the real minimum exponent
+ -- Haskell requires that f be adjusted so denormalized numbers
+ -- will have an impossibly low exponent. Adjust for this.
+ (f, e) =
+ let n = minExp - e0 in
+ if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
+ (r, s, mUp, mDn) =
+ if e >= 0 then
+ let be = b^ e in
+ if f == b^(p-1) then
+ (f*be*b*2, 2*b, be*b, b)
+ else
+ (f*be*2, 2, be, be)
+ else
+ if e > minExp && f == b^(p-1) then
+ (f*b*2, b^(-e+1)*2, b, 1)
+ else
+ (f*2, b^(-e)*2, 1, 1)
+ k =
+ let
+ k0 =
+ if b == 2 && base == 10 then
+ -- logBase 10 2 is slightly bigger than 3/10 so
+ -- the following will err on the low side. Ignoring
+ -- the fraction will make it err even more.
+ -- Haskell promises that p-1 <= logBase b f < p.
+ (p - 1 + e0) * 3 `div` 10
+ else
+ ceiling ((log (fromInteger (f+1)) +
+ fromInt e * log (fromInteger b)) /
+ log (fromInteger base))
+--WAS: fromInt e * log (fromInteger b))
+
+ fixup n =
+ if n >= 0 then
+ if r + mUp <= expt base n * s then n else fixup (n+1)
+ else
+ if expt base (-n) * (r + mUp) <= s then n else fixup (n+1)
+ in
+ fixup k0
+
+ gen ds rn sN mUpN mDnN =
+ let
+ (dn, rn') = (rn * base) `divMod` sN
+ mUpN' = mUpN * base
+ mDnN' = mDnN * base
+ in
+ case (rn' < mDnN', rn' + mUpN' > sN) of
+ (True, False) -> dn : ds
+ (False, True) -> dn+1 : ds
+ (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
+ (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
+
+ rds =
+ if k >= 0 then
+ gen [] r (s * expt base k) mUp mDn
+ else
+ let bk = expt base (-k) in
+ gen [] (r * bk) s (mUp * bk) (mDn * bk)
+ in
+ (map toInt (reverse rds), k)
+
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Converting from a Rational to a RealFloat
+%* *
+%*********************************************************
+
+[In response to a request for documentation of how fromRational works,
+Joe Fasel writes:] A quite reasonable request! This code was added to
+the Prelude just before the 1.2 release, when Lennart, working with an
+early version of hbi, noticed that (read . show) was not the identity
+for floating-point numbers. (There was a one-bit error about half the
+time.) The original version of the conversion function was in fact
+simply a floating-point divide, as you suggest above. The new version
+is, I grant you, somewhat denser.
+
+Unfortunately, Joe's code doesn't work! Here's an example:
+
+main = putStr (shows (1.82173691287639817263897126389712638972163e-300::Double) "\n")
+
+This program prints
+ 0.0000000000000000
+instead of
+ 1.8217369128763981e-300
+
+Here's Joe's code:
+
+\begin{pseudocode}
+fromRat :: (RealFloat a) => Rational -> a
+fromRat x = x'
+ where x' = f e
+
+-- If the exponent of the nearest floating-point number to x
+-- is e, then the significand is the integer nearest xb^(-e),
+-- where b is the floating-point radix. We start with a good
+-- guess for e, and if it is correct, the exponent of the
+-- floating-point number we construct will again be e. If
+-- not, one more iteration is needed.
+
+ f e = if e' == e then y else f e'
+ where y = encodeFloat (round (x * (1 % b)^^e)) e
+ (_,e') = decodeFloat y
+ b = floatRadix x'
+
+-- We obtain a trial exponent by doing a floating-point
+-- division of x's numerator by its denominator. The
+-- result of this division may not itself be the ultimate
+-- result, because of an accumulation of three rounding
+-- errors.
+
+ (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
+ / fromInteger (denominator x))
+\end{pseudocode}
+
+Now, here's Lennart's code (which works)
+
+\begin{code}
+{-# SPECIALISE fromRat ::
+ Rational -> Double,
+ Rational -> Float #-}
+fromRat :: (RealFloat a) => Rational -> a
+fromRat x
+ | x == 0 = encodeFloat 0 0 -- Handle exceptional cases
+ | x < 0 = - fromRat' (-x) -- first.
+ | otherwise = fromRat' x
+
+-- Conversion process:
+-- Scale the rational number by the RealFloat base until
+-- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat).
+-- Then round the rational to an Integer and encode it with the exponent
+-- that we got from the scaling.
+-- To speed up the scaling process we compute the log2 of the number to get
+-- a first guess of the exponent.
+
+fromRat' :: (RealFloat a) => Rational -> a
+fromRat' x = r
+ where b = floatRadix r
+ p = floatDigits r
+ (minExp0, _) = floatRange r
+ minExp = minExp0 - p -- the real minimum exponent
+ xMin = toRational (expt b (p-1))
+ xMax = toRational (expt b p)
+ p0 = (integerLogBase b (numerator x) - integerLogBase b (denominator x) - p) `max` minExp
+ f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1
+ (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)
+ r = encodeFloat (round x') p'
+
+-- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.
+scaleRat :: Rational -> Int -> Rational -> Rational -> Int -> Rational -> (Rational, Int)
+scaleRat b minExp xMin xMax p x
+ | p <= minExp = (x, p)
+ | x >= xMax = scaleRat b minExp xMin xMax (p+1) (x/b)
+ | x < xMin = scaleRat b minExp xMin xMax (p-1) (x*b)
+ | otherwise = (x, p)
+
+-- Exponentiation with a cache for the most common numbers.
+minExpt, maxExpt :: Int
+minExpt = 0
+maxExpt = 1100
+
+expt :: Integer -> Int -> Integer
+expt base n =
+ if base == 2 && n >= minExpt && n <= maxExpt then
+ expts!n
+ else
+ base^n
+
+expts :: Array Int Integer
+expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]
+
+-- Compute the (floor of the) log of i in base b.
+-- Simplest way would be just divide i by b until it's smaller then b, but that would
+-- be very slow! We are just slightly more clever.
+integerLogBase :: Integer -> Integer -> Int
+integerLogBase b i
+ | i < b = 0
+ | otherwise = doDiv (i `div` (b^l)) l
+ where
+ -- Try squaring the base first to cut down the number of divisions.
+ l = 2 * integerLogBase (b*b) i
+
+ doDiv :: Integer -> Int -> Int
+ doDiv x y
+ | x < b = y
+ | otherwise = doDiv (x `div` b) (y+1)
+
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Floating point numeric primops}
+%* *
+%*********************************************************
+
+Definitions of the boxed PrimOps; these will be
+used in the case of partial applications, etc.
+
+\begin{code}
+plusFloat, minusFloat, timesFloat, divideFloat :: Float -> Float -> Float
+plusFloat (F# x) (F# y) = F# (plusFloat# x y)
+minusFloat (F# x) (F# y) = F# (minusFloat# x y)
+timesFloat (F# x) (F# y) = F# (timesFloat# x y)
+divideFloat (F# x) (F# y) = F# (divideFloat# x y)
+
+negateFloat :: Float -> Float
+negateFloat (F# x) = F# (negateFloat# x)
+
+gtFloat, geFloat, eqFloat, neFloat, ltFloat, leFloat :: Float -> Float -> Bool
+gtFloat (F# x) (F# y) = gtFloat# x y
+geFloat (F# x) (F# y) = geFloat# x y
+eqFloat (F# x) (F# y) = eqFloat# x y
+neFloat (F# x) (F# y) = neFloat# x y
+ltFloat (F# x) (F# y) = ltFloat# x y
+leFloat (F# x) (F# y) = leFloat# x y
+
+float2Int :: Float -> Int
+float2Int (F# x) = I# (float2Int# x)
+
+int2Float :: Int -> Float
+int2Float (I# x) = F# (int2Float# x)
+
+expFloat, logFloat, sqrtFloat :: Float -> Float
+sinFloat, cosFloat, tanFloat :: Float -> Float
+asinFloat, acosFloat, atanFloat :: Float -> Float
+sinhFloat, coshFloat, tanhFloat :: Float -> Float
+expFloat (F# x) = F# (expFloat# x)
+logFloat (F# x) = F# (logFloat# x)
+sqrtFloat (F# x) = F# (sqrtFloat# x)
+sinFloat (F# x) = F# (sinFloat# x)
+cosFloat (F# x) = F# (cosFloat# x)
+tanFloat (F# x) = F# (tanFloat# x)
+asinFloat (F# x) = F# (asinFloat# x)
+acosFloat (F# x) = F# (acosFloat# x)
+atanFloat (F# x) = F# (atanFloat# x)
+sinhFloat (F# x) = F# (sinhFloat# x)
+coshFloat (F# x) = F# (coshFloat# x)
+tanhFloat (F# x) = F# (tanhFloat# x)
+
+powerFloat :: Float -> Float -> Float
+powerFloat (F# x) (F# y) = F# (powerFloat# x y)
+
+-- definitions of the boxed PrimOps; these will be
+-- used in the case of partial applications, etc.
+
+plusDouble, minusDouble, timesDouble, divideDouble :: Double -> Double -> Double
+plusDouble (D# x) (D# y) = D# (x +## y)
+minusDouble (D# x) (D# y) = D# (x -## y)
+timesDouble (D# x) (D# y) = D# (x *## y)
+divideDouble (D# x) (D# y) = D# (x /## y)
+
+negateDouble :: Double -> Double
+negateDouble (D# x) = D# (negateDouble# x)
+
+gtDouble, geDouble, eqDouble, neDouble, leDouble, ltDouble :: Double -> Double -> Bool
+gtDouble (D# x) (D# y) = x >## y
+geDouble (D# x) (D# y) = x >=## y
+eqDouble (D# x) (D# y) = x ==## y
+neDouble (D# x) (D# y) = x /=## y
+ltDouble (D# x) (D# y) = x <## y
+leDouble (D# x) (D# y) = x <=## y
+
+double2Int :: Double -> Int
+double2Int (D# x) = I# (double2Int# x)
+
+int2Double :: Int -> Double
+int2Double (I# x) = D# (int2Double# x)
+
+double2Float :: Double -> Float
+double2Float (D# x) = F# (double2Float# x)
+float2Double :: Float -> Double
+float2Double (F# x) = D# (float2Double# x)
+
+expDouble, logDouble, sqrtDouble :: Double -> Double
+sinDouble, cosDouble, tanDouble :: Double -> Double
+asinDouble, acosDouble, atanDouble :: Double -> Double
+sinhDouble, coshDouble, tanhDouble :: Double -> Double
+expDouble (D# x) = D# (expDouble# x)
+logDouble (D# x) = D# (logDouble# x)
+sqrtDouble (D# x) = D# (sqrtDouble# x)
+sinDouble (D# x) = D# (sinDouble# x)
+cosDouble (D# x) = D# (cosDouble# x)
+tanDouble (D# x) = D# (tanDouble# x)
+asinDouble (D# x) = D# (asinDouble# x)
+acosDouble (D# x) = D# (acosDouble# x)
+atanDouble (D# x) = D# (atanDouble# x)
+sinhDouble (D# x) = D# (sinhDouble# x)
+coshDouble (D# x) = D# (coshDouble# x)
+tanhDouble (D# x) = D# (tanhDouble# x)
+
+powerDouble :: Double -> Double -> Double
+powerDouble (D# x) (D# y) = D# (x **## y)
+\end{code}
+
+\begin{code}
+foreign import ccall "__encodeFloat" unsafe
+ encodeFloat# :: Int# -> ByteArray# -> Int -> Float
+foreign import ccall "__int_encodeFloat" unsafe
+ int_encodeFloat# :: Int# -> Int -> Float
+
+
+foreign import ccall "isFloatNaN" unsafe isFloatNaN :: Float -> Int
+foreign import ccall "isFloatInfinite" unsafe isFloatInfinite :: Float -> Int
+foreign import ccall "isFloatDenormalized" unsafe isFloatDenormalized :: Float -> Int
+foreign import ccall "isFloatNegativeZero" unsafe isFloatNegativeZero :: Float -> Int
+
+
+foreign import ccall "__encodeDouble" unsafe
+ encodeDouble# :: Int# -> ByteArray# -> Int -> Double
+foreign import ccall "__int_encodeDouble" unsafe
+ int_encodeDouble# :: Int# -> Int -> Double
+
+foreign import ccall "isDoubleNaN" unsafe isDoubleNaN :: Double -> Int
+foreign import ccall "isDoubleInfinite" unsafe isDoubleInfinite :: Double -> Int
+foreign import ccall "isDoubleDenormalized" unsafe isDoubleDenormalized :: Double -> Int
+foreign import ccall "isDoubleNegativeZero" unsafe isDoubleNegativeZero :: Double -> Int
+\end{code}
diff --git a/ghc/lib/std/PrelForeign.lhs b/ghc/lib/std/PrelForeign.lhs
index 4dc8f3f5ecd8..859dc18b079f 100644
--- a/ghc/lib/std/PrelForeign.lhs
+++ b/ghc/lib/std/PrelForeign.lhs
@@ -19,7 +19,6 @@ module PrelForeign (
import PrelIOBase
import PrelST
import PrelBase
-import PrelCCall
import PrelAddr
import PrelGHC
\end{code}
diff --git a/ghc/lib/std/PrelGHC.hi-boot b/ghc/lib/std/PrelGHC.hi-boot
index dba3e67e6c52..6d86963e59d6 100644
--- a/ghc/lib/std/PrelGHC.hi-boot
+++ b/ghc/lib/std/PrelGHC.hi-boot
@@ -344,7 +344,7 @@ instance {CCallable Wordzh} = zdfCCallableWordzh;
instance {CCallable ByteArrayzh} = zdfCCallableByteArrayzh;
instance __forall [s] => {CCallable (MutableByteArrayzh s)} = zdfCCallableMutableByteArrayzh;
instance {CCallable ForeignObjzh} = zdfCCallableForeignObjzh;
-
+instance __forall [s] => {CCallable (StablePtrzh s)} = zdfCCallableStablePtrzh;
-- CCallable and CReturnable have kind (Type AnyBox) so that
-- things like Int# can be instances of CCallable.
1 class CCallable a :: ? ;
@@ -365,3 +365,4 @@ instance {CCallable ForeignObjzh} = zdfCCallableForeignObjzh;
1 zdfCCallableByteArrayzh :: {CCallable ByteArrayzh} ;
1 zdfCCallableMutableByteArrayzh :: __forall [s] => {CCallable (MutableByteArrayzh s)} ;
1 zdfCCallableForeignObjzh :: {CCallable ForeignObjzh} ;
+1 zdfCCallableStablePtrzh :: __forall [a] => {CCallable (StablePtrzh a)} ;
diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs
index 41feadc08b09..85289ad87351 100644
--- a/ghc/lib/std/PrelHandle.lhs
+++ b/ghc/lib/std/PrelHandle.lhs
@@ -16,17 +16,18 @@ module PrelHandle where
import PrelBase
import PrelAddr ( Addr, nullAddr )
-import PrelArr ( newVar, readVar, writeVar, ByteArray(..) )
+import PrelArr ( newVar, readVar, writeVar )
+import PrelByteArr ( ByteArray(..) )
import PrelRead ( Read )
import PrelList ( span )
import PrelIOBase
import PrelException
import PrelMaybe ( Maybe(..) )
import PrelEnum
-import PrelNum
+import PrelNum ( toBig, Integer(..), Num(..) )
import PrelShow
import PrelAddr ( Addr, nullAddr )
-import PrelNum ( toInteger, toBig )
+import PrelReal ( toInteger )
import PrelPack ( packString )
import PrelWeak ( addForeignFinalizer )
import Ix
diff --git a/ghc/lib/std/PrelNum.hi-boot b/ghc/lib/std/PrelNum.hi-boot
new file mode 100644
index 000000000000..7c47b0a4245f
--- /dev/null
+++ b/ghc/lib/std/PrelNum.hi-boot
@@ -0,0 +1,14 @@
+---------------------------------------------------------------------------
+-- PrelNum.hi-boot
+--
+-- This hand-written interface file is the
+-- initial bootstrap version for PrelNum.hi.
+-- It's needed for the 'thin-air' Id addr2Integer, when compiling
+-- PrelBase, and other Prelude files that precede PrelNum
+---------------------------------------------------------------------------
+
+__interface PrelNum 1 where
+__export PrelNum Integer addr2Integer ;
+
+1 data Integer ;
+1 addr2Integer :: PrelGHC.Addrzh -> Integer ;
diff --git a/ghc/lib/std/PrelNum.lhs b/ghc/lib/std/PrelNum.lhs
index f70f7269ec0f..48ed0d956373 100644
--- a/ghc/lib/std/PrelNum.lhs
+++ b/ghc/lib/std/PrelNum.lhs
@@ -4,6 +4,15 @@
\section[PrelNum]{Module @PrelNum@}
+The class
+
+ Num
+
+and the type
+
+ Integer
+
+
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
@@ -15,16 +24,16 @@ import PrelList
import PrelEnum
import PrelShow
-infixr 8 ^, ^^, **
-infixl 7 %, /, `quot`, `rem`, `div`, `mod`
infixl 7 *
infixl 6 +, -
+default () -- Double isn't available yet,
+ -- and we shouldn't be using defaults anyway
\end{code}
%*********************************************************
%* *
-\subsection{Standard numeric classes}
+\subsection{Standard numeric class}
%* *
%*********************************************************
@@ -41,104 +50,20 @@ class (Eq a, Show a) => Num a where
fromInt (I# i#) = fromInteger (S# i#)
-- Go via the standard class-op if the
-- non-standard one ain't provided
+\end{code}
-class (Num a, Ord a) => Real a where
- toRational :: a -> Rational
-
-class (Real a, Enum a) => Integral a where
- quot, rem, div, mod :: a -> a -> a
- quotRem, divMod :: a -> a -> (a,a)
- toInteger :: a -> Integer
- toInt :: a -> Int -- partain: Glasgow extension
-
- n `quot` d = q where (q,_) = quotRem n d
- n `rem` d = r where (_,r) = quotRem n d
- n `div` d = q where (q,_) = divMod n d
- n `mod` d = r where (_,r) = divMod n d
- divMod n d = if signum r == negate (signum d) then (q-1, r+d) else qr
- where qr@(q,r) = quotRem n d
-
-class (Num a) => Fractional a where
- (/) :: a -> a -> a
- recip :: a -> a
- fromRational :: Rational -> a
-
- recip x = 1 / x
- x / y = x * recip y
-
-class (Fractional a) => Floating a where
- pi :: a
- exp, log, sqrt :: a -> a
- (**), logBase :: a -> a -> a
- sin, cos, tan :: a -> a
- asin, acos, atan :: a -> a
- sinh, cosh, tanh :: a -> a
- asinh, acosh, atanh :: a -> a
-
- x ** y = exp (log x * y)
- logBase x y = log y / log x
- sqrt x = x ** 0.5
- tan x = sin x / cos x
- tanh x = sinh x / cosh x
-
-class (Real a, Fractional a) => RealFrac a where
- properFraction :: (Integral b) => a -> (b,a)
- truncate, round :: (Integral b) => a -> b
- ceiling, floor :: (Integral b) => a -> b
-
- truncate x = m where (m,_) = properFraction x
-
- round x = let (n,r) = properFraction x
- m = if r < 0 then n - 1 else n + 1
- in case signum (abs r - 0.5) of
- -1 -> n
- 0 -> if even n then n else m
- 1 -> m
-
- ceiling x = if r > 0 then n + 1 else n
- where (n,r) = properFraction x
-
- floor x = if r < 0 then n - 1 else n
- where (n,r) = properFraction x
-
-class (RealFrac a, Floating a) => RealFloat a where
- floatRadix :: a -> Integer
- floatDigits :: a -> Int
- floatRange :: a -> (Int,Int)
- decodeFloat :: a -> (Integer,Int)
- encodeFloat :: Integer -> Int -> a
- exponent :: a -> Int
- significand :: a -> a
- scaleFloat :: Int -> a -> a
- isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
- :: a -> Bool
- atan2 :: a -> a -> a
-
-
- exponent x = if m == 0 then 0 else n + floatDigits x
- where (m,n) = decodeFloat x
-
- significand x = encodeFloat m (negate (floatDigits x))
- where (m,_) = decodeFloat x
-
- scaleFloat k x = encodeFloat m (n+k)
- where (m,n) = decodeFloat x
-
- atan2 y x
- | x > 0 = atan (y/x)
- | x == 0 && y > 0 = pi/2
- | x < 0 && y > 0 = pi + atan (y/x)
- |(x <= 0 && y < 0) ||
- (x < 0 && isNegativeZero y) ||
- (isNegativeZero x && isNegativeZero y)
- = -atan2 (-y) x
- | y == 0 && (x < 0 || isNegativeZero x)
- = pi -- must be after the previous test on zero y
- | x==0 && y==0 = y -- must be after the other double zero tests
- | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
+A few small numeric functions
+\begin{code}
+subtract :: (Num a) => a -> a -> a
+{-# INLINE subtract #-}
+subtract x y = y - x
+
+ord_0 :: Num a => a
+ord_0 = fromInt (ord '0')
\end{code}
+
%*********************************************************
%* *
\subsection{Instances for @Int@}
@@ -157,57 +82,228 @@ instance Num Int where
| n `eqInt` 0 = 0
| otherwise = 1
- fromInteger (S# i#) = I# i#
- fromInteger (J# s# d#)
- = case (integer2Int# s# d#) of { i# -> I# i# }
+ fromInteger n = integer2Int n
+ fromInt n = n
+\end{code}
- fromInt n = n
-instance Real Int where
- toRational x = toInteger x % 1
+\begin{code}
+-- These can't go in PrelBase with the defn of Int, because
+-- we don't have pairs defined at that time!
-instance Integral Int where
- a@(I# _) `quotRem` b@(I# _) = (a `quotInt` b, a `remInt` b)
+quotRemInt :: Int -> Int -> (Int, Int)
+a@(I# _) `quotRemInt` b@(I# _) = (a `quotInt` b, a `remInt` b)
-- OK, so I made it a little stricter. Shoot me. (WDP 94/10)
- -- Following chks for zero divisor are non-standard (WDP)
- a `quot` b = if b /= 0
- then a `quotInt` b
- else error "Prelude.Integral.quot{Int}: divide by 0"
- a `rem` b = if b /= 0
- then a `remInt` b
- else error "Prelude.Integral.rem{Int}: divide by 0"
-
- x `div` y = if x > 0 && y < 0 then quotInt (x-y-1) y
- else if x < 0 && y > 0 then quotInt (x-y+1) y
- else quotInt x y
- x `mod` y = if x > 0 && y < 0 || x < 0 && y > 0 then
- if r/=0 then r+y else 0
- else
- r
- where r = remInt x y
-
- divMod x@(I# _) y@(I# _) = (x `div` y, x `mod` y)
+divModInt :: Int -> Int -> (Int, Int)
+divModInt x@(I# _) y@(I# _) = (x `divInt` y, x `modInt` y)
-- Stricter. Sorry if you don't like it. (WDP 94/10)
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{The @Integer@ type}
+%* *
+%*********************************************************
+
+\begin{code}
+data Integer
+ = S# Int# -- small integers
+ | J# Int# ByteArray# -- large integers
+\end{code}
+
+Convenient boxed Integer PrimOps.
+
+\begin{code}
+zeroInteger :: Integer
+zeroInteger = S# 0#
---OLD: even x = eqInt (x `mod` 2) 0
---OLD: odd x = neInt (x `mod` 2) 0
+int2Integer :: Int -> Integer
+{-# INLINE int2Integer #-}
+int2Integer (I# i) = S# i
- toInteger (I# i) = int2Integer i -- give back a full-blown Integer
- toInt x = x
+integer2Int :: Integer -> Int
+integer2Int (S# i) = I# i
+integer2Int (J# s d) = case (integer2Int# s d) of { n# -> I# n# }
+addr2Integer :: Addr# -> Integer
+{-# INLINE addr2Integer #-}
+addr2Integer x = case addr2Integer# x of (# s, d #) -> J# s d
+
+toBig (S# i) = case int2Integer# i of { (# s, d #) -> J# s d }
+toBig i@(J# _ _) = i
\end{code}
+
%*********************************************************
%* *
-\subsection{Instances for @Integer@}
+\subsection{Dividing @Integers@}
%* *
%*********************************************************
\begin{code}
-toBig (S# i) = case int2Integer# i of { (# s, d #) -> J# s d }
-toBig i@(J# _ _) = i
+quotRemInteger :: Integer -> Integer -> (Integer, Integer)
+quotRemInteger (S# i) (S# j)
+ = case quotRemInt (I# i) (I# j) of ( I# i, I# j ) -> ( S# i, S# j )
+quotRemInteger i1@(J# _ _) i2@(S# _) = quotRemInteger i1 (toBig i2)
+quotRemInteger i1@(S# _) i2@(J# _ _) = quotRemInteger (toBig i1) i2
+quotRemInteger (J# s1 d1) (J# s2 d2)
+ = case (quotRemInteger# s1 d1 s2 d2) of
+ (# s3, d3, s4, d4 #)
+ -> (J# s3 d3, J# s4 d4)
+
+divModInteger (S# i) (S# j)
+ = case divModInt (I# i) (I# j) of ( I# i, I# j ) -> ( S# i, S# j)
+divModInteger i1@(J# _ _) i2@(S# _) = divModInteger i1 (toBig i2)
+divModInteger i1@(S# _) i2@(J# _ _) = divModInteger (toBig i1) i2
+divModInteger (J# s1 d1) (J# s2 d2)
+ = case (divModInteger# s1 d1 s2 d2) of
+ (# s3, d3, s4, d4 #)
+ -> (J# s3 d3, J# s4 d4)
+
+remInteger :: Integer -> Integer -> Integer
+remInteger ia 0
+ = error "Prelude.Integral.rem{Integer}: divide by 0"
+remInteger (S# a) (S# b)
+ = S# (remInt# a b)
+remInteger ia@(S# a) (J# sb b)
+ | sb ==# 1# = S# (remInt# a (word2Int# (integer2Word# sb b)))
+ | sb ==# -1# = S# (remInt# a (0# -# (word2Int# (integer2Word# sb b))))
+ | 0# <# sb = ia
+ | otherwise = S# (0# -# a)
+remInteger (J# sa a) (S# b)
+ = case int2Integer# b of { (# sb, b #) ->
+ case remInteger# sa a sb b of { (# sr, r #) ->
+ S# (sr *# (word2Int# (integer2Word# sr r))) }}
+remInteger (J# sa a) (J# sb b)
+ = case remInteger# sa a sb b of (# sr, r #) -> J# sr r
+
+quotInteger :: Integer -> Integer -> Integer
+quotInteger ia 0
+ = error "Prelude.Integral.quot{Integer}: divide by 0"
+quotInteger (S# a) (S# b)
+ = S# (quotInt# a b)
+quotInteger (S# a) (J# sb b)
+ | sb ==# 1# = S# (quotInt# a (word2Int# (integer2Word# sb b)))
+ | sb ==# -1# = S# (quotInt# a (0# -# (word2Int# (integer2Word# sb b))))
+ | otherwise = zeroInteger
+quotInteger (J# sa a) (S# b)
+ = case int2Integer# b of { (# sb, b #) ->
+ case quotInteger# sa a sb b of (# sq, q #) -> J# sq q }
+quotInteger (J# sa a) (J# sb b)
+ = case quotInteger# sa a sb b of (# sg, g #) -> J# sg g
+\end{code}
+
+
+
+\begin{code}
+gcdInteger :: Integer -> Integer -> Integer
+gcdInteger (S# a) (S# b)
+ = case gcdInt# a b of g -> S# g
+gcdInteger ia@(S# a) ib@(J# sb b)
+ | a ==# 0# = abs ib
+ | sb ==# 0# = abs ia
+ | otherwise = case gcdIntegerInt# sb b a of g -> S# g
+gcdInteger ia@(J# sa a) ib@(S# b)
+ | sa ==# 0# = abs ib
+ | b ==# 0# = abs ia
+ | otherwise = case gcdIntegerInt# sa a b of g -> S# g
+gcdInteger (J# sa a) (J# sb b)
+ = case gcdInteger# sa a sb b of (# sg, g #) -> J# sg g
+
+lcmInteger :: Integer -> Integer -> Integer
+lcmInteger a 0
+ = zeroInteger
+lcmInteger 0 b
+ = zeroInteger
+lcmInteger a b
+ = (divExact aa (gcdInteger aa ab)) * ab
+ where aa = abs a
+ ab = abs b
+
+divExact :: Integer -> Integer -> Integer
+divExact (S# a) (S# b)
+ = S# (quotInt# a b)
+divExact (S# a) (J# sb b)
+ = S# (quotInt# a (sb *# (word2Int# (integer2Word# sb b))))
+divExact (J# sa a) (S# b)
+ = case int2Integer# b of
+ (# sb, b #) -> case divExactInteger# sa a sb b of (# sd, d #) -> J# sd d
+divExact (J# sa a) (J# sb b)
+ = case divExactInteger# sa a sb b of (# sd, d #) -> J# sd d
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{The @Integer@ instances for @Eq@, @Ord@}
+%* *
+%*********************************************************
+
+\begin{code}
+instance Eq Integer where
+ (S# i) == (S# j) = i ==# j
+ (S# i) == (J# s d) = cmpIntegerInt# s d i ==# 0#
+ (J# s d) == (S# i) = cmpIntegerInt# s d i ==# 0#
+ (J# s1 d1) == (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) ==# 0#
+
+ (S# i) /= (S# j) = i /=# j
+ (S# i) /= (J# s d) = cmpIntegerInt# s d i /=# 0#
+ (J# s d) /= (S# i) = cmpIntegerInt# s d i /=# 0#
+ (J# s1 d1) /= (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) /=# 0#
+
+------------------------------------------------------------------------
+instance Ord Integer where
+ (S# i) <= (S# j) = i <=# j
+ (J# s d) <= (S# i) = cmpIntegerInt# s d i <=# 0#
+ (S# i) <= (J# s d) = cmpIntegerInt# s d i >=# 0#
+ (J# s1 d1) <= (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) <=# 0#
+
+ (S# i) > (S# j) = i ># j
+ (J# s d) > (S# i) = cmpIntegerInt# s d i ># 0#
+ (S# i) > (J# s d) = cmpIntegerInt# s d i <# 0#
+ (J# s1 d1) > (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) ># 0#
+
+ (S# i) < (S# j) = i <# j
+ (J# s d) < (S# i) = cmpIntegerInt# s d i <# 0#
+ (S# i) < (J# s d) = cmpIntegerInt# s d i ># 0#
+ (J# s1 d1) < (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) <# 0#
+
+ (S# i) >= (S# j) = i >=# j
+ (J# s d) >= (S# i) = cmpIntegerInt# s d i >=# 0#
+ (S# i) >= (J# s d) = cmpIntegerInt# s d i <=# 0#
+ (J# s1 d1) >= (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) >=# 0#
+
+ compare (S# i) (S# j)
+ | i ==# j = EQ
+ | i <=# j = LT
+ | otherwise = GT
+ compare (J# s d) (S# i)
+ = case cmpIntegerInt# s d i of { res# ->
+ if res# <# 0# then LT else
+ if res# ># 0# then GT else EQ
+ }
+ compare (S# i) (J# s d)
+ = case cmpIntegerInt# s d i of { res# ->
+ if res# ># 0# then LT else
+ if res# <# 0# then GT else EQ
+ }
+ compare (J# s1 d1) (J# s2 d2)
+ = case cmpInteger# s1 d1 s2 d2 of { res# ->
+ if res# <# 0# then LT else
+ if res# ># 0# then GT else EQ
+ }
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{The @Integer@ instances for @Num@}
+%* *
+%*********************************************************
+\begin{code}
instance Num Integer where
(+) i1@(S# i) i2@(S# j)
= case addIntC# i j of { (# r, c #) ->
@@ -258,90 +354,21 @@ instance Num Integer where
fromInteger x = x
fromInt (I# i) = S# i
+\end{code}
-instance Real Integer where
- toRational x = x % 1
-
-instance Integral Integer where
- -- ToDo: a `rem` b returns a small integer if b is small,
- -- a `quot` b returns a small integer if a is small.
- quotRem (S# i) (S# j)
- = case quotRem (I# i) (I# j) of ( I# i, I# j ) -> ( S# i, S# j)
- quotRem i1@(J# _ _) i2@(S# _) = quotRem i1 (toBig i2)
- quotRem i1@(S# _) i2@(J# _ _) = quotRem (toBig i1) i2
- quotRem (J# s1 d1) (J# s2 d2)
- = case (quotRemInteger# s1 d1 s2 d2) of
- (# s3, d3, s4, d4 #)
- -> (J# s3 d3, J# s4 d4)
-
- toInteger n = n
- toInt (S# i) = I# i
- toInt (J# s d) = case (integer2Int# s d) of { n# -> I# n# }
-
- -- we've got specialised quot/rem methods for Integer (see below)
- n `quot` d = n `quotInteger` d
- n `rem` d = n `remInteger` d
-
- n `div` d = q where (q,_) = divMod n d
- n `mod` d = r where (_,r) = divMod n d
-
- divMod (S# i) (S# j)
- = case divMod (I# i) (I# j) of ( I# i, I# j ) -> ( S# i, S# j)
- divMod i1@(J# _ _) i2@(S# _) = divMod i1 (toBig i2)
- divMod i1@(S# _) i2@(J# _ _) = divMod (toBig i1) i2
- divMod (J# s1 d1) (J# s2 d2)
- = case (divModInteger# s1 d1 s2 d2) of
- (# s3, d3, s4, d4 #)
- -> (J# s3 d3, J# s4 d4)
-
-remInteger :: Integer -> Integer -> Integer
-remInteger ia 0
- = error "Prelude.Integral.rem{Integer}: divide by 0"
-remInteger (S# a) (S# b) = S# (remInt# a b)
-remInteger ia@(S# a) (J# sb b)
- = if sb ==# 1#
- then
- S# (remInt# a (word2Int# (integer2Word# sb b)))
- else if sb ==# -1# then
- S# (remInt# a (0# -# (word2Int# (integer2Word# sb b))))
- else if 0# <# sb then
- ia
- else
- S# (0# -# a)
-remInteger (J# sa a) (S# b)
- = case int2Integer# b of { (# sb, b #) ->
- case remInteger# sa a sb b of { (# sr, r #) ->
- S# (sr *# (word2Int# (integer2Word# sr r))) }}
-remInteger (J# sa a) (J# sb b)
- = case remInteger# sa a sb b of (# sr, r #) -> J# sr r
-
-quotInteger :: Integer -> Integer -> Integer
-quotInteger ia 0
- = error "Prelude.Integral.quot{Integer}: divide by 0"
-quotInteger (S# a) (S# b) = S# (quotInt# a b)
-quotInteger (S# a) (J# sb b)
- = if sb ==# 1#
- then
- S# (quotInt# a (word2Int# (integer2Word# sb b)))
- else if sb ==# -1# then
- S# (quotInt# a (0# -# (word2Int# (integer2Word# sb b))))
- else
- zeroInteger
-quotInteger (J# sa a) (S# b)
- = case int2Integer# b of { (# sb, b #) ->
- case quotInteger# sa a sb b of (# sq, q #) -> J# sq q }
-quotInteger (J# sa a) (J# sb b)
- = case quotInteger# sa a sb b of (# sg, g #) -> J# sg g
-zeroInteger :: Integer
-zeroInteger = S# 0#
+%*********************************************************
+%* *
+\subsection{The @Integer@ instance for @Enum@}
+%* *
+%*********************************************************
-------------------------------------------------------------------------
+\begin{code}
instance Enum Integer where
succ x = x + 1
pred x = x - 1
- toEnum n = toInteger n
- fromEnum n = toInt n
+ toEnum n = int2Integer n
+ fromEnum n = integer2Int n
{-# INLINE enumFrom #-}
{-# INLINE enumFromThen #-}
@@ -390,9 +417,10 @@ dn_list x delta lim = go (x::Integer)
#-}
\end{code}
+
%*********************************************************
%* *
-\subsection{Show code for Integers}
+\subsection{The @Integer@ instances for @Show@}
%* *
%*********************************************************
@@ -414,147 +442,7 @@ jtos i rs
jtos' :: Integer -> String -> String
jtos' n cs
| n < 10 = chr (fromInteger n + (ord_0::Int)) : cs
- | otherwise = jtos' q (chr (toInt r + (ord_0::Int)) : cs)
+ | otherwise = jtos' q (chr (integer2Int r + (ord_0::Int)) : cs)
where
- (q,r) = n `quotRem` 10
-
-ord_0 :: Num a => a
-ord_0 = fromInt (ord '0')
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{The @Ratio@ and @Rational@ types}
-%* *
-%*********************************************************
-
-\begin{code}
-data (Integral a) => Ratio a = !a :% !a deriving (Eq)
-type Rational = Ratio Integer
-
-{-# SPECIALISE (%) :: Integer -> Integer -> Rational #-}
-(%) :: (Integral a) => a -> a -> Ratio a
-numerator, denominator :: (Integral a) => Ratio a -> a
-\end{code}
-
-\tr{reduce} is a subsidiary function used only in this module .
-It normalises a ratio by dividing both numerator and denominator by
-their greatest common divisor.
-
-\begin{code}
-reduce :: (Integral a) => a -> a -> Ratio a
-reduce _ 0 = error "Ratio.%: zero denominator"
-reduce x y = (x `quot` d) :% (y `quot` d)
- where d = gcd x y
-\end{code}
-
-\begin{code}
-x % y = reduce (x * signum y) (abs y)
-
-numerator (x :% _) = x
-denominator (_ :% y) = y
-
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Overloaded numeric functions}
-%* *
-%*********************************************************
-
-\begin{code}
-
-{-# SPECIALISE subtract :: Int -> Int -> Int #-}
-subtract :: (Num a) => a -> a -> a
-subtract x y = y - x
-
-even, odd :: (Integral a) => a -> Bool
-even n = n `rem` 2 == 0
-odd = not . even
-
-gcd :: (Integral a) => a -> a -> a
-gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
-gcd x y = gcd' (abs x) (abs y)
- where gcd' a 0 = a
- gcd' a b = gcd' b (a `rem` b)
-
-{-# SPECIALISE lcm ::
- Int -> Int -> Int,
- Integer -> Integer -> Integer #-}
-lcm :: (Integral a) => a -> a -> a
-lcm _ 0 = 0
-lcm 0 _ = 0
-lcm x y = abs ((x `quot` (gcd x y)) * y)
-
-{-# SPECIALISE (^) ::
- Integer -> Integer -> Integer,
- Integer -> Int -> Integer,
- Int -> Int -> Int #-}
-(^) :: (Num a, Integral b) => a -> b -> a
-_ ^ 0 = 1
-x ^ n | n > 0 = f x (n-1) x
- where f _ 0 y = y
- f a d y = g a d where
- g b i | even i = g (b*b) (i `quot` 2)
- | otherwise = f b (i-1) (b*y)
-_ ^ _ = error "Prelude.^: negative exponent"
-
-{- SPECIALISE (^^) ::
- Double -> Int -> Double,
- Rational -> Int -> Rational #-}
-(^^) :: (Fractional a, Integral b) => a -> b -> a
-x ^^ n = if n >= 0 then x^n else recip (x^(negate n))
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Specialized versions of gcd/lcm for Int/Integer}
-%* *
-%*********************************************************
-
-\begin{code}
-{-# RULES
-"Int.gcd" forall a b . gcd a b = gcdInt a b
-"Integer.gcd" forall a b . gcd a b = gcdInteger a b
-"Integer.lcm" forall a b . lcm a b = lcmInteger a b
- #-}
-
-gcdInt :: Int -> Int -> Int
-gcdInt (I# a) (I# b)
- = I# (gcdInt# a b)
-
-gcdInteger :: Integer -> Integer -> Integer
-gcdInteger (S# a) (S# b)
- = case gcdInt# a b of g -> S# g
-gcdInteger ia@(S# a) ib@(J# sb b)
- | a ==# 0# = abs ib
- | sb ==# 0# = abs ia
- | otherwise = case gcdIntegerInt# sb b a of g -> S# g
-gcdInteger ia@(J# sa a) ib@(S# b)
- | sa ==# 0# = abs ib
- | b ==# 0# = abs ia
- | otherwise = case gcdIntegerInt# sa a b of g -> S# g
-gcdInteger (J# sa a) (J# sb b)
- = case gcdInteger# sa a sb b of (# sg, g #) -> J# sg g
-
-lcmInteger :: Integer -> Integer -> Integer
-lcmInteger a 0
- = zeroInteger
-lcmInteger 0 b
- = zeroInteger
-lcmInteger a b
- = (divExact aa (gcdInteger aa ab)) * ab
- where aa = abs a
- ab = abs b
-
-divExact :: Integer -> Integer -> Integer
-divExact (S# a) (S# b)
- = S# (quotInt# a b)
-divExact (S# a) (J# sb b)
- = S# (quotInt# a (sb *# (word2Int# (integer2Word# sb b))))
-divExact (J# sa a) (S# b)
- = case int2Integer# b of
- (# sb, b #) -> case divExactInteger# sa a sb b of (# sd, d #) -> J# sd d
-divExact (J# sa a) (J# sb b)
- = case divExactInteger# sa a sb b of (# sd, d #) -> J# sd d
+ (q,r) = n `quotRemInteger` 10
\end{code}
diff --git a/ghc/lib/std/PrelPack.lhs b/ghc/lib/std/PrelPack.lhs
index 6351fca9b697..187d2a7bce99 100644
--- a/ghc/lib/std/PrelPack.lhs
+++ b/ghc/lib/std/PrelPack.lhs
@@ -53,6 +53,7 @@ import PrelList ( length )
import PrelST
import PrelNum
import PrelArr
+import PrelByteArr
import PrelAddr
\end{code}
diff --git a/ghc/lib/std/PrelRead.lhs b/ghc/lib/std/PrelRead.lhs
index 6c8da898ffe3..ad3fe8161c57 100644
--- a/ghc/lib/std/PrelRead.lhs
+++ b/ghc/lib/std/PrelRead.lhs
@@ -14,7 +14,8 @@ module PrelRead where
import PrelErr ( error )
import PrelEnum ( Enum(..) )
import PrelNum
-import PrelNumExtra
+import PrelReal
+import PrelFloat
import PrelList
import PrelTup
import PrelMaybe
diff --git a/ghc/lib/std/PrelReal.lhs b/ghc/lib/std/PrelReal.lhs
new file mode 100644
index 000000000000..530f12306c5f
--- /dev/null
+++ b/ghc/lib/std/PrelReal.lhs
@@ -0,0 +1,299 @@
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[PrelReal]{Module @PrelReal@}
+
+The types
+
+ Ratio, Rational
+
+and the classes
+
+ Real
+ Integral
+ Fractional
+ RealFrac
+
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+module PrelReal where
+
+import {-# SOURCE #-} PrelErr
+import PrelBase
+import PrelNum
+import PrelList
+import PrelEnum
+import PrelShow
+
+infixr 8 ^, ^^
+infixl 7 /, `quot`, `rem`, `div`, `mod`
+
+default () -- Double isn't available yet,
+ -- and we shouldn't be using defaults anyway
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{The @Ratio@ and @Rational@ types}
+%* *
+%*********************************************************
+
+\begin{code}
+data (Integral a) => Ratio a = !a :% !a deriving (Eq)
+type Rational = Ratio Integer
+\end{code}
+
+
+\begin{code}
+{-# SPECIALISE (%) :: Integer -> Integer -> Rational #-}
+(%) :: (Integral a) => a -> a -> Ratio a
+numerator, denominator :: (Integral a) => Ratio a -> a
+\end{code}
+
+\tr{reduce} is a subsidiary function used only in this module .
+It normalises a ratio by dividing both numerator and denominator by
+their greatest common divisor.
+
+\begin{code}
+reduce :: (Integral a) => a -> a -> Ratio a
+reduce _ 0 = error "Ratio.%: zero denominator"
+reduce x y = (x `quot` d) :% (y `quot` d)
+ where d = gcd x y
+\end{code}
+
+\begin{code}
+x % y = reduce (x * signum y) (abs y)
+
+numerator (x :% _) = x
+denominator (_ :% y) = y
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Standard numeric classes}
+%* *
+%*********************************************************
+
+\begin{code}
+class (Num a, Ord a) => Real a where
+ toRational :: a -> Rational
+
+class (Real a, Enum a) => Integral a where
+ quot, rem, div, mod :: a -> a -> a
+ quotRem, divMod :: a -> a -> (a,a)
+ toInteger :: a -> Integer
+ toInt :: a -> Int -- partain: Glasgow extension
+
+ n `quot` d = q where (q,_) = quotRem n d
+ n `rem` d = r where (_,r) = quotRem n d
+ n `div` d = q where (q,_) = divMod n d
+ n `mod` d = r where (_,r) = divMod n d
+ divMod n d = if signum r == negate (signum d) then (q-1, r+d) else qr
+ where qr@(q,r) = quotRem n d
+
+class (Num a) => Fractional a where
+ (/) :: a -> a -> a
+ recip :: a -> a
+ fromRational :: Rational -> a
+
+ recip x = 1 / x
+ x / y = x * recip y
+
+class (Real a, Fractional a) => RealFrac a where
+ properFraction :: (Integral b) => a -> (b,a)
+ truncate, round :: (Integral b) => a -> b
+ ceiling, floor :: (Integral b) => a -> b
+
+ truncate x = m where (m,_) = properFraction x
+
+ round x = let (n,r) = properFraction x
+ m = if r < 0 then n - 1 else n + 1
+ in case signum (abs r - 0.5) of
+ -1 -> n
+ 0 -> if even n then n else m
+ 1 -> m
+
+ ceiling x = if r > 0 then n + 1 else n
+ where (n,r) = properFraction x
+
+ floor x = if r < 0 then n - 1 else n
+ where (n,r) = properFraction x
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Instances for @Int@}
+%* *
+%*********************************************************
+
+\begin{code}
+instance Real Int where
+ toRational x = toInteger x % 1
+
+instance Integral Int where
+ toInteger i = int2Integer i -- give back a full-blown Integer
+ toInt x = x
+
+ -- Following chks for zero divisor are non-standard (WDP)
+ a `quot` b = if b /= 0
+ then a `quotInt` b
+ else error "Prelude.Integral.quot{Int}: divide by 0"
+ a `rem` b = if b /= 0
+ then a `remInt` b
+ else error "Prelude.Integral.rem{Int}: divide by 0"
+
+ x `div` y = x `divInt` y
+ x `mod` y = x `modInt` y
+
+ a `quotRem` b = a `quotRemInt` b
+ a `divMod` b = a `divModInt` b
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Instances for @Integer@}
+%* *
+%*********************************************************
+
+\begin{code}
+instance Real Integer where
+ toRational x = x % 1
+
+instance Integral Integer where
+ toInteger n = n
+ toInt n = integer2Int n
+
+ n `quot` d = n `quotInteger` d
+ n `rem` d = n `remInteger` d
+
+ n `div` d = q where (q,_) = divMod n d
+ n `mod` d = r where (_,r) = divMod n d
+
+ a `divMod` b = a `divModInteger` b
+ a `quotRem` b = a `quotRemInteger` b
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Instances for @Ratio@}
+%* *
+%*********************************************************
+
+\begin{code}
+instance (Integral a) => Ord (Ratio a) where
+ (x:%y) <= (x':%y') = x * y' <= x' * y
+ (x:%y) < (x':%y') = x * y' < x' * y
+
+instance (Integral a) => Num (Ratio a) where
+ (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
+ (x:%y) - (x':%y') = reduce (x*y' - x'*y) (y*y')
+ (x:%y) * (x':%y') = reduce (x * x') (y * y')
+ negate (x:%y) = (-x) :% y
+ abs (x:%y) = abs x :% y
+ signum (x:%_) = signum x :% 1
+ fromInteger x = fromInteger x :% 1
+
+instance (Integral a) => Fractional (Ratio a) where
+ (x:%y) / (x':%y') = (x*y') % (y*x')
+ recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x
+ fromRational (x:%y) = fromInteger x :% fromInteger y
+
+instance (Integral a) => Real (Ratio a) where
+ toRational (x:%y) = toInteger x :% toInteger y
+
+instance (Integral a) => RealFrac (Ratio a) where
+ properFraction (x:%y) = (fromInteger (toInteger q), r:%y)
+ where (q,r) = quotRem x y
+
+instance (Integral a) => Show (Ratio a) where
+ showsPrec p (x:%y) = showParen (p > ratio_prec)
+ (shows x . showString " % " . shows y)
+
+ratio_prec :: Int
+ratio_prec = 7
+
+instance (Integral a) => Enum (Ratio a) where
+ succ x = x + 1
+ pred x = x - 1
+
+ toEnum n = fromInt n :% 1
+ fromEnum = fromInteger . truncate
+
+ enumFrom = bounded_iterator True (1)
+ enumFromThen n m = bounded_iterator (diff >= 0) diff n
+ where diff = m - n
+
+bounded_iterator :: (Ord a, Num a) => Bool -> a -> a -> [a]
+bounded_iterator inc step v
+ | inc && v > new_v = [v] -- oflow
+ | not inc && v < new_v = [v] -- uflow
+ | otherwise = v : bounded_iterator inc step new_v
+ where
+ new_v = v + step
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Overloaded numeric functions}
+%* *
+%*********************************************************
+
+\begin{code}
+showSigned :: (Real a) => (a -> ShowS) -> Int -> a -> ShowS
+showSigned showPos p x
+ | x < 0 = showParen (p > 6) (showChar '-' . showPos (-x))
+ | otherwise = showPos x
+
+even, odd :: (Integral a) => a -> Bool
+even n = n `rem` 2 == 0
+odd = not . even
+
+-------------------------------------------------------
+{-# SPECIALISE (^) ::
+ Integer -> Integer -> Integer,
+ Integer -> Int -> Integer,
+ Int -> Int -> Int #-}
+(^) :: (Num a, Integral b) => a -> b -> a
+_ ^ 0 = 1
+x ^ n | n > 0 = f x (n-1) x
+ where f _ 0 y = y
+ f a d y = g a d where
+ g b i | even i = g (b*b) (i `quot` 2)
+ | otherwise = f b (i-1) (b*y)
+_ ^ _ = error "Prelude.^: negative exponent"
+
+{- SPECIALISE (^^) ::
+ Rational -> Int -> Rational #-}
+(^^) :: (Fractional a, Integral b) => a -> b -> a
+x ^^ n = if n >= 0 then x^n else recip (x^(negate n))
+
+
+-------------------------------------------------------
+gcd :: (Integral a) => a -> a -> a
+gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
+gcd x y = gcd' (abs x) (abs y)
+ where gcd' a 0 = a
+ gcd' a b = gcd' b (a `rem` b)
+
+lcm :: (Integral a) => a -> a -> a
+{-# SPECIALISE lcm :: Int -> Int -> Int #-}
+lcm _ 0 = 0
+lcm 0 _ = 0
+lcm x y = abs ((x `quot` (gcd x y)) * y)
+
+
+{-# RULES
+"Int.gcd" forall a b . gcd a b = gcdInt a b
+"Integer.gcd" forall a b . gcd a b = gcdInteger a b
+"Integer.lcm" forall a b . lcm a b = lcmInteger a b
+ #-}
+\end{code}
diff --git a/ghc/lib/std/PrelST.lhs b/ghc/lib/std/PrelST.lhs
index 1aca5bcbab5d..b41c0795e133 100644
--- a/ghc/lib/std/PrelST.lhs
+++ b/ghc/lib/std/PrelST.lhs
@@ -13,6 +13,8 @@ import PrelShow
import PrelBase
import PrelGHC
import PrelNum () -- So that we get the .hi file for system imports
+
+default ()
\end{code}
%*********************************************************
diff --git a/ghc/lib/std/PrelStable.lhs b/ghc/lib/std/PrelStable.lhs
index fb121584d5fd..faefb0395bfd 100644
--- a/ghc/lib/std/PrelStable.lhs
+++ b/ghc/lib/std/PrelStable.lhs
@@ -1,5 +1,5 @@
% -----------------------------------------------------------------------------
-% $Id: PrelStable.lhs,v 1.2 1999/09/19 19:12:42 sof Exp $
+% $Id: PrelStable.lhs,v 1.3 1999/12/20 10:34:35 simonpj Exp $
%
% (c) The GHC Team, 1992-1999
%
@@ -23,7 +23,6 @@ import PrelIOBase
data StablePtr a = StablePtr (StablePtr# a)
instance CCallable (StablePtr a)
-instance CCallable (StablePtr# a)
instance CReturnable (StablePtr a)
makeStablePtr :: a -> IO (StablePtr a)
diff --git a/ghc/lib/std/PrelTup.lhs b/ghc/lib/std/PrelTup.lhs
index 34dbfa88f12a..b1f143a39432 100644
--- a/ghc/lib/std/PrelTup.lhs
+++ b/ghc/lib/std/PrelTup.lhs
@@ -13,6 +13,8 @@ module PrelTup where
import {-# SOURCE #-} PrelErr ( error )
import PrelBase
+
+default () -- Double isn't available yet
\end{code}
diff --git a/ghc/lib/std/Prelude.lhs b/ghc/lib/std/Prelude.lhs
index 0b9f102379cf..01e82b3ae4d9 100644
--- a/ghc/lib/std/Prelude.lhs
+++ b/ghc/lib/std/Prelude.lhs
@@ -77,7 +77,8 @@ import PrelList
import PrelRead
import PrelEnum
import PrelNum
-import PrelNumExtra
+import PrelReal
+import PrelFloat
import PrelTup
import PrelMaybe
import PrelShow
@@ -101,6 +102,12 @@ undefined = error "Prelude.undefined"
\end{code}
+%*********************************************************
+%* *
+\subsection{List sum and product}
+%* *
+%*********************************************************
+
List sum and product are defined here because PrelList is too far
down the compilation chain to "see" the Num class.
@@ -125,3 +132,39 @@ product l = prod l 1
prod (x:xs) a = prod xs (a*x)
#endif
\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Coercions}
+%* *
+%*********************************************************
+
+\begin{code}
+{-# SPECIALIZE fromIntegral ::
+ Int -> Rational,
+ Integer -> Rational,
+ Int -> Int,
+ Int -> Integer,
+ Int -> Float,
+ Int -> Double,
+ Integer -> Int,
+ Integer -> Integer,
+ Integer -> Float,
+ Integer -> Double #-}
+fromIntegral :: (Integral a, Num b) => a -> b
+fromIntegral = fromInteger . toInteger
+
+{-# SPECIALIZE realToFrac ::
+ Double -> Rational,
+ Rational -> Double,
+ Float -> Rational,
+ Rational -> Float,
+ Rational -> Rational,
+ Double -> Double,
+ Double -> Float,
+ Float -> Float,
+ Float -> Double #-}
+realToFrac :: (Real a, Fractional b) => a -> b
+realToFrac = fromRational . toRational
+\end{code}
diff --git a/ghc/lib/std/Random.lhs b/ghc/lib/std/Random.lhs
index 9bf845e0bce1..09ba145892d4 100644
--- a/ghc/lib/std/Random.lhs
+++ b/ghc/lib/std/Random.lhs
@@ -29,17 +29,18 @@ module Random
) where
#ifndef __HUGS__
-import CPUTime (getCPUTime)
-import PrelST
-import PrelRead
-import PrelShow
-import PrelNum -- So we get fromInt, toInt
-import PrelIOBase
-import PrelNumExtra ( float2Double, double2Float )
-import PrelBase
-import PrelArr
-import Time (getClockTime, ClockTime(..))
+import PrelGHC ( RealWorld )
+import PrelNum ( fromInt )
+import PrelShow ( showSignedInt, showSpace )
+import PrelRead ( readDec )
+import PrelIOBase ( unsafePerformIO, stToIO )
+import PrelArr ( MutableVar, newVar, readVar, writeVar )
+import PrelReal ( toInt )
+import CPUTime ( getCPUTime )
+import PrelFloat ( float2Double, double2Float )
+import Time ( getClockTime, ClockTime(..) )
#endif
+
import Char ( isSpace, chr, ord )
\end{code}
diff --git a/ghc/lib/std/Ratio.lhs b/ghc/lib/std/Ratio.lhs
index a002888ab198..f7593ab7756f 100644
--- a/ghc/lib/std/Ratio.lhs
+++ b/ghc/lib/std/Ratio.lhs
@@ -7,8 +7,6 @@
Standard functions on rational numbers
\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
-
module Ratio
( Ratio
, Rational
@@ -31,9 +29,59 @@ module Ratio
-- Implementation checked wrt. Haskell 98 lib report, 1/99.
) where
+\end{code}
+
#ifndef __HUGS__
-import PrelNum
-import PrelNumExtra
-#endif
+
+\begin{code}
+import Prelude -- To generate the dependencies
+import PrelReal -- The basic defns for Ratio
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{approxRational}
+%* *
+%*********************************************************
+
+@approxRational@, applied to two real fractional numbers x and epsilon,
+returns the simplest rational number within epsilon of x. A rational
+number n%d in reduced form is said to be simpler than another n'%d' if
+abs n <= abs n' && d <= d'. Any real interval contains a unique
+simplest rational; here, for simplicity, we assume a closed rational
+interval. If such an interval includes at least one whole number, then
+the simplest rational is the absolutely least whole number. Otherwise,
+the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d
+and abs r' < d', and the simplest rational is q%1 + the reciprocal of
+the simplest rational between d'%r' and d%r.
+
+\begin{code}
+approxRational :: (RealFrac a) => a -> a -> Rational
+approxRational rat eps = simplest (rat-eps) (rat+eps)
+ where simplest x y | y < x = simplest y x
+ | x == y = xr
+ | x > 0 = simplest' n d n' d'
+ | y < 0 = - simplest' (-n') d' (-n) d
+ | otherwise = 0 :% 1
+ where xr = toRational x
+ n = numerator xr
+ d = denominator xr
+ nd' = toRational y
+ n' = numerator nd'
+ d' = denominator nd'
+
+ simplest' n d n' d' -- assumes 0 < n%d < n'%d'
+ | r == 0 = q :% 1
+ | q /= q' = (q+1) :% 1
+ | otherwise = (q*n''+d'') :% n''
+ where (q,r) = quotRem n d
+ (q',r') = quotRem n' d'
+ nd'' = simplest' d' r' d r
+ n'' = numerator nd''
+ d'' = denominator nd''
\end{code}
+
+
+#endif
+
diff --git a/ghc/lib/std/System.lhs b/ghc/lib/std/System.lhs
index e62b7d4311c2..41373d193440 100644
--- a/ghc/lib/std/System.lhs
+++ b/ghc/lib/std/System.lhs
@@ -25,7 +25,7 @@ import Prelude
import PrelAddr
import PrelIOBase ( IOError(..), IOErrorType(..), constructErrorAndFailWithInfo, stToIO )
import PrelPack ( unpackCString, unpackCStringST, packString )
-import PrelArr ( ByteArray )
+import PrelByteArr ( ByteArray )
type PrimByteArray = ByteArray Int
diff --git a/ghc/lib/std/Time.lhs b/ghc/lib/std/Time.lhs
index d9a336f4ae97..ff8556a08589 100644
--- a/ghc/lib/std/Time.lhs
+++ b/ghc/lib/std/Time.lhs
@@ -38,17 +38,21 @@ module Time
#ifdef __HUGS__
import PreludeBuiltin
#else
-import PrelBase
-import PrelShow
-import PrelIOBase
-import PrelHandle
-import PrelArr
-import PrelST
-import PrelAddr
-import PrelNum
-import PrelPack ( unpackCString, new_ps_array,
- freeze_ps_array, unpackCStringBA
+import PrelGHC ( RealWorld, (>#), (<#), (==#),
+ newIntArray#, readIntArray#,
+ unsafeFreezeByteArray#,
+ int2Integer#, negateInt# )
+import PrelBase ( Int(..) )
+import PrelNum ( Integer(..), fromInt )
+import PrelIOBase ( IO(..), unsafePerformIO, stToIO, constructErrorAndFail )
+import PrelShow ( showList__ )
+import PrelPack ( unpackCString, unpackCStringBA,
+ new_ps_array, freeze_ps_array
)
+import PrelByteArr ( MutableByteArray(..) )
+import PrelHandle ( Bytes )
+import PrelAddr ( Addr )
+
#endif
import Ix
diff --git a/ghc/rts/HSprel.def b/ghc/rts/HSprel.def
index 634cd9876e33..eeb707903951 100644
--- a/ghc/rts/HSprel.def
+++ b/ghc/rts/HSprel.def
@@ -11,10 +11,10 @@ PrelAddr_I64zh_con_info DATA
PrelAddr_W64zh_con_info DATA
PrelAddr_Azh_con_info DATA
PrelAddr_Azh_static_info DATA
-PrelBase_Fzh_con_info DATA
-PrelBase_Fzh_static_info DATA
-PrelBase_Dzh_con_info DATA
-PrelBase_Dzh_static_info DATA
+PrelFloat_Fzh_con_info DATA
+PrelFloat_Fzh_static_info DATA
+PrelFloat_Dzh_con_info DATA
+PrelFloat_Dzh_static_info DATA
PrelAddr_Wzh_con_info DATA
PrelAddr_Wzh_static_info DATA
PrelStable_StablePtr_con_info DATA
diff --git a/ghc/rts/RtsStartup.c b/ghc/rts/RtsStartup.c
index bb387bf6b64c..0996ba037c6e 100644
--- a/ghc/rts/RtsStartup.c
+++ b/ghc/rts/RtsStartup.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: RtsStartup.c,v 1.24 1999/11/09 10:46:26 simonmar Exp $
+ * $Id: RtsStartup.c,v 1.25 1999/12/20 10:34:37 simonpj Exp $
*
* (c) The GHC Team, 1998-1999
*
@@ -118,7 +118,9 @@ startupHaskell(int argc, char *argv[])
/* start the ticker */
install_vtalrm_handler();
+#if 0 /* tmp--SDM */
initialize_virtual_timer(TICK_MILLISECS);
+#endif
/* start our haskell execution tasks */
#ifdef SMP
--
GitLab