From df8d9fc17f6750afe10021cee1b53f200d26d2bf Mon Sep 17 00:00:00 2001
From: Jose Pedro Magalhaes <jpm@cs.uu.nl>
Date: Tue, 3 May 2011 11:50:30 +0200
Subject: [PATCH] Moved the CString functions to GHC.CString in ghc-prim
 (needed for the new generic deriving mechanism).

Import and re-export GHC.CString from GHC.Base.
---
 GHC/Base.lhs |  111 +++-------------------------------------------------------
 1 file changed, 4 insertions(+), 107 deletions(-)

diff --git a/GHC/Base.lhs b/GHC/Base.lhs
index 1a5ce0d..98abed5 100644
--- a/GHC/Base.lhs
+++ b/GHC/Base.lhs
@@ -97,6 +97,7 @@ module GHC.Base
         (
         module GHC.Base,
         module GHC.Classes,
+        module GHC.CString,
         --module GHC.Generics,        -- JPM: We no longer export GHC.Generics
                                       -- by default to avoid name clashes
         module GHC.Ordering,
@@ -108,6 +109,7 @@ module GHC.Base
 
 import GHC.Types
 import GHC.Classes
+import GHC.CString
 -- JPM: Since we don't export it, we don't need to import GHC.Generics
 --import GHC.Generics
 import GHC.Ordering
@@ -155,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}
 
@@ -848,106 +841,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
@@ -959,6 +855,7 @@ unpackNBytes#  addr len# = unpack [] (len# -# 1#)
   #-}
 \end{code}
 
+
 #ifdef __HADDOCK__
 \begin{code}
 -- | A special argument for the 'Control.Monad.ST.ST' type constructor,
-- 
1.7.10.4