tidyTopName,
nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule,
- isUserExportedName, nameSrcLoc,
+ isUserExportedName, isUserImportedExplicitlyName, nameSrcLoc,
isLocallyDefinedName,
isSystemName, isLocalName, isGlobalName, isExternallyVisibleName,
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
%************************************************************************
\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 &&
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,
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")
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")
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
[ numClassKey
, realClassKey
, integralClassKey
- , fractionalClassKey
+ ]
+ ++ fractionalClassKeys
+
+fractionalClassKeys =
+ [ fractionalClassKey
, floatingClassKey
, realFracClassKey
, realFloatClassKey
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"
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"
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}
%************************************************************************
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
= 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)
]
varQual = mkPreludeQual varName
-
-thinAirModules = [pREL_PACK_Name,pREL_BASE_Name] -- See notes with RnIfaces.findAndReadIface
\end{code}
\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
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}
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
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 )
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(..) )
import UniqFM ( lookupUFM )
import Util ( equivClasses )
import Maybes ( maybeToBool )
+import SrcLoc ( mkBuiltinSrcLoc )
import Outputable
\end{code}
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
\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
-- 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 = []
\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}
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 []
= 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)
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
-- 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
%************************************************************************
+
\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
-------------------------
+-- 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 ()
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 )
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)
= 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)
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}
= 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
= 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)
= vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
ptext SLIT("at ") <+> ppr loc1,
ptext SLIT("and") <+> ppr loc2]
-
\end{code}
import RnHsSyn ( RenamedHsDecl )
import TcMonad
-import TcEnv ( tcLookupClassByKey )
+import TcEnv ( tcLookupClassByKey_maybe )
import TcMonoType ( tcHsType )
import TcSimplify ( tcSimplifyCheckThetas )
\end{code}
\begin{code}
-default_default = [integerTy, doubleTy ]
+default_default = [integerTy, doubleTy]
tcDefaults :: [RenamedHsDecl]
-> TcM s [Type] -- defaulting types to heave
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 $
where
pp (DefaultDecl _ locn) = ptext SLIT("here was another default declaration") <+> ppr locn
\end{code}
+
tcLookupTy,
tcLookupTyCon, tcLookupTyConByKey,
- tcLookupClass, tcLookupClassByKey,
+ tcLookupClass, tcLookupClassByKey, tcLookupClassByKey_maybe,
tcExtendGlobalValEnv, tcExtendLocalValEnv,
tcGetValueEnv, tcSetValueEnv,
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) ->
\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)"))
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
<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>%
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).
-
-%----------------------------------------------------------------------
%************************************************************************
%* *
+<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)
<label id="options-optimise">
<p>
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"
,'-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"
/* -----------------------------------------------------------------------------
- * $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
*
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;
#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
\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}
%* *
%*********************************************************
-\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}
\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
(
#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}
#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}
import PrelShow
import PrelMaybe ( Either(..), Maybe(..) )
import PrelAddr ( Addr(..), nullAddr )
-import PrelArr ( ByteArray )
+import PrelByteArr ( ByteArray )
import PrelPack ( unpackNBytesAccST )
import PrelException ( ioError, catch )
import PrelEnum
import PrelShow
import PrelNum
+
+default()
\end{code}
%*********************************************************
\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
module Numeric
( fromRat -- :: (RealFloat a) => Rational -> a
-- 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
\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.
import PrelGHC
import PrelBase
-import PrelCCall
\end{code}
\begin{code}
Array implementation, @PrelArr@ exports the basic array
types and operations.
+For byte-arrays see @PrelByteArr@.
+
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
import PrelList (foldl)
import PrelST
import PrelBase
-import PrelCCall
import PrelAddr
import PrelGHC
+import PrelShow
infixl 9 !, //
+
+default ()
\end{code}
\begin{code}
{-# 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
{-# 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}
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)
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}
%*********************************************************
"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
%*********************************************************
%* *
+\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}
%* *
%*********************************************************
\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}
\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# ->
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# #) ->
import Ix
import PrelArr
+import PrelByteArr
import PrelST
import PrelBase
import PrelGHC
\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 #-}
infixr 2 ||
infixl 1 >>, >>=
infixr 0 $
+
+default () -- Double isn't available yet
\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}
%* *
%*********************************************************
%*********************************************************
%* *
+\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}
%* *
%*********************************************************
{-# 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
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}
--- /dev/null
+%
+% (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}
+++ /dev/null
-%
-% (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}
-
import PrelBase ( Int(..) )
import PrelException ( Exception(..), AsyncException(..) )
-infixr 0 `par`
+infixr 0 `par`, `seq`
\end{code}
%************************************************************************
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}
--- /dev/null
+%
+% (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}
import PrelIOBase
import PrelST
import PrelBase
-import PrelCCall
import PrelAddr
import PrelGHC
\end{code}
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 :: ? ;
1 zdfCCallableByteArrayzh :: {CCallable ByteArrayzh} ;
1 zdfCCallableMutableByteArrayzh :: __forall [s] => {CCallable (MutableByteArrayzh s)} ;
1 zdfCCallableForeignObjzh :: {CCallable ForeignObjzh} ;
+1 zdfCCallableStablePtrzh :: __forall [a] => {CCallable (StablePtrzh a)} ;
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
--- /dev/null
+---------------------------------------------------------------------------
+-- 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 ;
\section[PrelNum]{Module @PrelNum@}
+The class
+
+ Num
+
+and the type
+
+ Integer
+
+
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
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}
%* *
%*********************************************************
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@}
| 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 #) ->
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 #-}
#-}
\end{code}
+
%*********************************************************
%* *
-\subsection{Show code for Integers}
+\subsection{The @Integer@ instances for @Show@}
%* *
%*********************************************************
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}
import PrelST
import PrelNum
import PrelArr
+import PrelByteArr
import PrelAddr
\end{code}
import PrelErr ( error )
import PrelEnum ( Enum(..) )
import PrelNum
-import PrelNumExtra
+import PrelReal
+import PrelFloat
import PrelList
import PrelTup
import PrelMaybe
--- /dev/null
+%
+% (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}
import PrelBase
import PrelGHC
import PrelNum () -- So that we get the .hi file for system imports
+
+default ()
\end{code}
%*********************************************************
% -----------------------------------------------------------------------------
-% $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
%
data StablePtr a = StablePtr (StablePtr# a)
instance CCallable (StablePtr a)
-instance CCallable (StablePtr# a)
instance CReturnable (StablePtr a)
makeStablePtr :: a -> IO (StablePtr a)
import {-# SOURCE #-} PrelErr ( error )
import PrelBase
+
+default () -- Double isn't available yet
\end{code}
import PrelRead
import PrelEnum
import PrelNum
-import PrelNumExtra
+import PrelReal
+import PrelFloat
import PrelTup
import PrelMaybe
import PrelShow
\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.
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}
) 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}
Standard functions on rational numbers
\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
-
module Ratio
( Ratio
, Rational
-- 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
+
import PrelAddr
import PrelIOBase ( IOError(..), IOErrorType(..), constructErrorAndFailWithInfo, stToIO )
import PrelPack ( unpackCString, unpackCStringST, packString )
-import PrelArr ( ByteArray )
+import PrelByteArr ( ByteArray )
type PrimByteArray = ByteArray Int
#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
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
/* -----------------------------------------------------------------------------
- * $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
*
/* start the ticker */
install_vtalrm_handler();
+#if 0 /* tmp--SDM */
initialize_virtual_timer(TICK_MILLISECS);
+#endif
/* start our haskell execution tasks */
#ifdef SMP
projects / ghc-hetmet.git / commitdiff