X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FBase.lhs;h=0a2bcc70f788015cb5256a48d60e30e5142b70aa;hb=092841be56472fe1dae12f745df6a72abbf44c40;hp=f616b0e150bc060c01804433c43bf789297ab3a4;hpb=3a8b769484788cb3874e9c695543712eb3330b7f;p=ghc-base.git diff --git a/GHC/Base.lhs b/GHC/Base.lhs index f616b0e..0a2bcc7 100644 --- a/GHC/Base.lhs +++ b/GHC/Base.lhs @@ -62,11 +62,20 @@ GHC.Float Classes: Floating, RealFloat Other Prelude modules are much easier with fewer complex dependencies. \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , BangPatterns + , ExplicitForAll + , MagicHash + , UnboxedTuples + , ExistentialQuantification + , Rank2Types + #-} -- -fno-warn-orphans is needed for things like: -- Orphan rule: "x# -# x#" ALWAYS forall x# :: Int# -# x# x# = 0 {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Base @@ -87,9 +96,10 @@ Other Prelude modules are much easier with fewer complex dependencies. module GHC.Base ( module GHC.Base, - module GHC.Bool, module GHC.Classes, - module GHC.Generics, + module GHC.CString, + --module GHC.Generics, -- JPM: We no longer export GHC.Generics + -- by default to avoid name clashes module GHC.Ordering, module GHC.Types, module GHC.Prim, -- Re-export GHC.Prim and GHC.Err, to avoid lots @@ -98,9 +108,10 @@ module GHC.Base where import GHC.Types -import GHC.Bool import GHC.Classes -import GHC.Generics +import GHC.CString +-- JPM: Since we don't export it, we don't need to import GHC.Generics +--import GHC.Generics import GHC.Ordering import GHC.Prim import {-# SOURCE #-} GHC.Show @@ -146,15 +157,6 @@ otherwise = True build = error "urk" foldr = error "urk" - -unpackCString# :: Addr# -> [Char] -unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a -unpackAppendCString# :: Addr# -> [Char] -> [Char] -unpackCStringUtf8# :: Addr# -> [Char] -unpackCString# a = error "urk" -unpackFoldrCString# a = error "urk" -unpackAppendCString# a = error "urk" -unpackCStringUtf8# a = error "urk" -} \end{code} @@ -173,7 +175,7 @@ Instances of 'Functor' should satisfy the following laws: > fmap (f . g) == fmap f . fmap g The instances of 'Functor' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO' -defined in the "Prelude" satisfy these laws. +satisfy these laws. -} class Functor f where @@ -500,26 +502,6 @@ maxInt = I# 0x7FFFFFFF# minInt = I# (-0x8000000000000000#) maxInt = I# 0x7FFFFFFFFFFFFFFF# #endif - -instance Eq Int where - (==) = eqInt - (/=) = neInt - -instance Ord Int where - compare = compareInt - (<) = ltInt - (<=) = leInt - (>=) = geInt - (>) = gtInt - -compareInt :: Int -> Int -> Ordering -(I# x#) `compareInt` (I# y#) = compareInt# x# y# - -compareInt# :: Int# -> Int# -> Ordering -compareInt# x# y# - | x# <# y# = LT - | x# ==# y# = EQ - | otherwise = GT \end{code} @@ -701,12 +683,6 @@ Definitions of the boxed PrimOps; these will be used in the case of partial applications, etc. \begin{code} -{-# INLINE eqInt #-} -{-# INLINE neInt #-} -{-# INLINE gtInt #-} -{-# INLINE geInt #-} -{-# INLINE ltInt #-} -{-# INLINE leInt #-} {-# INLINE plusInt #-} {-# INLINE minusInt #-} {-# INLINE timesInt #-} @@ -737,14 +713,6 @@ plusInt, minusInt, timesInt, quotInt, remInt, divInt, modInt :: Int -> Int -> In negateInt :: Int -> Int negateInt (I# x) = I# (negateInt# x) -gtInt, geInt, eqInt, neInt, ltInt, leInt :: Int -> Int -> Bool -(I# x) `gtInt` (I# y) = x ># y -(I# x) `geInt` (I# y) = x >=# y -(I# x) `eqInt` (I# y) = x ==# y -(I# x) `neInt` (I# y) = x /=# y -(I# x) `ltInt` (I# y) = x <# y -(I# x) `leInt` (I# y) = x <=# y - {-# RULES "x# ># x#" forall x#. x# ># x# = False "x# >=# x#" forall x#. x# >=# x# = True @@ -839,106 +807,9 @@ a `iShiftRL#` b | b >=# WORD_SIZE_IN_BITS# = 0# "int2Word2Int" forall x#. int2Word# (word2Int# x#) = x# "word2Int2Word" forall x#. word2Int# (int2Word# x#) = x# #-} -\end{code} -%******************************************************** -%* * -\subsection{Unpacking C strings} -%* * -%******************************************************** - -This code is needed for virtually all programs, since it's used for -unpacking the strings of error messages. - -\begin{code} -unpackCString# :: Addr# -> [Char] -{-# NOINLINE unpackCString# #-} - -- There's really no point in inlining this, ever, cos - -- the loop doesn't specialise in an interesting - -- But it's pretty small, so there's a danger that - -- it'll be inlined at every literal, which is a waste -unpackCString# addr - = unpack 0# - where - unpack nh - | ch `eqChar#` '\0'# = [] - | otherwise = C# ch : unpack (nh +# 1#) - where - !ch = indexCharOffAddr# addr nh - -unpackAppendCString# :: Addr# -> [Char] -> [Char] -{-# NOINLINE unpackAppendCString# #-} - -- See the NOINLINE note on unpackCString# -unpackAppendCString# addr rest - = unpack 0# - where - unpack nh - | ch `eqChar#` '\0'# = rest - | otherwise = C# ch : unpack (nh +# 1#) - where - !ch = indexCharOffAddr# addr nh - -unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a - --- Usually the unpack-list rule turns unpackFoldrCString# into unpackCString# - --- It also has a BuiltInRule in PrelRules.lhs: --- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) --- = unpackFoldrCString# "foobaz" c n - -{-# NOINLINE unpackFoldrCString# #-} --- At one stage I had NOINLINE [0] on the grounds that, unlike --- unpackCString#, there *is* some point in inlining --- unpackFoldrCString#, because we get better code for the --- higher-order function call. BUT there may be a lot of --- literal strings, and making a separate 'unpack' loop for --- each is highly gratuitous. See nofib/real/anna/PrettyPrint. - -unpackFoldrCString# addr f z - = unpack 0# - where - unpack nh - | ch `eqChar#` '\0'# = z - | otherwise = C# ch `f` unpack (nh +# 1#) - where - !ch = indexCharOffAddr# addr nh - -unpackCStringUtf8# :: Addr# -> [Char] -unpackCStringUtf8# addr - = unpack 0# - where - unpack nh - | ch `eqChar#` '\0'# = [] - | ch `leChar#` '\x7F'# = C# ch : unpack (nh +# 1#) - | ch `leChar#` '\xDF'# = - C# (chr# (((ord# ch -# 0xC0#) `uncheckedIShiftL#` 6#) +# - (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#))) : - unpack (nh +# 2#) - | ch `leChar#` '\xEF'# = - C# (chr# (((ord# ch -# 0xE0#) `uncheckedIShiftL#` 12#) +# - ((ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 6#) +# - (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#))) : - unpack (nh +# 3#) - | otherwise = - C# (chr# (((ord# ch -# 0xF0#) `uncheckedIShiftL#` 18#) +# - ((ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 12#) +# - ((ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `uncheckedIShiftL#` 6#) +# - (ord# (indexCharOffAddr# addr (nh +# 3#)) -# 0x80#))) : - unpack (nh +# 4#) - where - !ch = indexCharOffAddr# addr nh - -unpackNBytes# :: Addr# -> Int# -> [Char] -unpackNBytes# _addr 0# = [] -unpackNBytes# addr len# = unpack [] (len# -# 1#) - where - unpack acc i# - | i# <# 0# = acc - | otherwise = - case indexCharOffAddr# addr i# of - ch -> unpack (C# ch : acc) (i# -# 1#) - +-- Rules for C strings (the functions themselves are now in GHC.CString) {-# RULES "unpack" [~1] forall a . unpackCString# a = build (unpackFoldrCString# a) "unpack-list" [1] forall a . unpackFoldrCString# a (:) [] = unpackCString# a @@ -950,6 +821,7 @@ unpackNBytes# addr len# = unpack [] (len# -# 1#) #-} \end{code} + #ifdef __HADDOCK__ \begin{code} -- | A special argument for the 'Control.Monad.ST.ST' type constructor,