ghc/compiler/utils/PrimPacked.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
   3 %
   4 \section{Basic ops on packed representations}
   5
   6 Some basic operations for working on packed representations of series
   7 of bytes (character strings). Used by the interface lexer input
   8 subsystem, mostly.
   9
  10 \begin{code}
  11 {-# OPTIONS -monly-3-regs -optc-DNON_POSIX_SOURCE -#include "hschooks.h" #-}
  12 module PrimPacked
  13        (
  14         strLength,          -- :: _Addr -> Int
  15         copyPrefixStr,      -- :: _Addr -> Int -> ByteArray Int
  16         copySubStr,         -- :: _Addr -> Int -> Int -> ByteArray Int
  17         copySubStrBA,       -- :: ByteArray Int -> Int -> Int -> ByteArray Int
  18
  19         eqStrPrefix,        -- :: Addr# -> ByteArray# -> Int# -> Bool
  20         eqCharStrPrefix,    -- :: Addr# -> Addr# -> Int# -> Bool
  21         eqStrPrefixBA,      -- :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
  22         eqCharStrPrefixBA,  -- :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
  23
  24         addrOffset#         -- :: Addr# -> Int# -> Addr#
  25        ) where
  26
  27 -- This #define suppresses the "import FastString" that
  28 -- HsVersions otherwise produces
  29 #define COMPILING_FAST_STRING
  30 #include "HsVersions.h"
  31
  32 import GlaExts
  33 #if __GLASGOW_HASKELL__ < 411
  34 import PrelAddr ( Addr(..) )
  35 #else
  36 import Addr     ( Addr(..) )
  37 #endif
  38 import ST
  39 import Foreign
  40
  41 #if __GLASGOW_HASKELL__ < 503
  42 import PrelST
  43 #else
  44 import GHC.ST
  45 #endif
  46
  47 \end{code}
  48
  49 Copying a char string prefix into a byte array,
  50 {\em assuming} the prefix does not contain any
  51 NULs.
  52
  53 \begin{code}
  54 copyPrefixStr :: Addr -> Int -> ByteArray Int
  55 copyPrefixStr (A# a) len@(I# length#) =
  56  runST (
  57   {- allocate an array that will hold the string
  58     (not forgetting the NUL at the end)
  59   -}
  60   (new_ps_array (length# +# 1#))             >>= \ ch_array ->
  61 {- Revert back to Haskell-only solution for the moment.
  62    _ccall_ memcpy ch_array (A# a) len        >>=  \ () ->
  63    write_ps_array ch_array length# (chr# 0#) >>
  64 -}
  65    -- fill in packed string from "addr"
  66   fill_in ch_array 0#                        >>
  67    -- freeze the puppy:
  68   freeze_ps_array ch_array length#           >>= \ barr ->
  69   return barr )
  70   where
  71     fill_in :: MutableByteArray s Int -> Int# -> ST s ()
  72
  73     fill_in arr_in# idx
  74       | idx ==# length#
  75       = write_ps_array arr_in# idx (chr# 0#) >>
  76         return ()
  77       | otherwise
  78       = case (indexCharOffAddr# a idx) of { ch ->
  79         write_ps_array arr_in# idx ch >>
  80         fill_in arr_in# (idx +# 1#) }
  81
  82 \end{code}
  83
  84 Copying out a substring, assume a 0-indexed string:
  85 (and positive lengths, thank you).
  86
  87 \begin{code}
  88 copySubStr :: Addr -> Int -> Int -> ByteArray Int
  89 copySubStr a start length =
  90   unsafePerformIO (
  91     _casm_ `` %r= (char *)((char *)%0 + (int)%1); '' a start
  92                                                      >>= \ a_start ->
  93     return (copyPrefixStr a_start length))
  94
  95 -- step on (char *) pointer by x units.
  96 addrOffset# :: Addr# -> Int# -> Addr#
  97 addrOffset# a# i# =
  98   case unsafePerformIO (_casm_ ``%r=(char *)((char *)%0 + (int)%1); '' (A# a#) (I# i#)) of
  99     A# a -> a
 100
 101 copySubStrBA :: ByteArray Int -> Int -> Int -> ByteArray Int
 102 copySubStrBA (ByteArray _ _ barr#) (I# start#) len@(I# length#) =
 103  runST (
 104   {- allocate an array that will hold the string
 105     (not forgetting the NUL at the end)
 106   -}
 107   new_ps_array (length# +# 1#)  >>= \ ch_array ->
 108    -- fill in packed string from "addr"
 109   fill_in ch_array 0#           >>
 110    -- freeze the puppy:
 111   freeze_ps_array ch_array length#)
 112   where
 113     fill_in :: MutableByteArray s Int -> Int# -> ST s ()
 114
 115     fill_in arr_in# idx
 116       | idx ==# length#
 117       = write_ps_array arr_in# idx (chr# 0#) >>
 118         return ()
 119       | otherwise
 120       = case (indexCharArray# barr# (start# +# idx)) of { ch ->
 121         write_ps_array arr_in# idx ch >>
 122         fill_in arr_in# (idx +# 1#) }
 123 \end{code}
 124
 125 (Very :-) ``Specialised'' versions of some CharArray things...
 126 [Copied from PackBase; no real reason -- UGH]
 127
 128 \begin{code}
 129 new_ps_array    :: Int# -> ST s (MutableByteArray s Int)
 130 write_ps_array  :: MutableByteArray s Int -> Int# -> Char# -> ST s ()
 131 freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)
 132
 133 new_ps_array size = ST $ \ s ->
 134 #if __GLASGOW_HASKELL__ < 411
 135     case (newCharArray# size s)   of { (# s2#, barr# #) ->
 136     (# s2#, MutableByteArray bot bot barr# #) }
 137 #else /* 411 and higher */
 138     case (newByteArray# size s)   of { (# s2#, barr# #) ->
 139     (# s2#, MutableByteArray bot bot barr# #) }
 140 #endif
 141   where
 142     bot = error "new_ps_array"
 143
 144 write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# ->
 145     case writeCharArray# barr# n ch s#  of { s2#   ->
 146     (# s2#, () #) }
 147
 148 -- same as unsafeFreezeByteArray
 149 freeze_ps_array (MutableByteArray _ _ arr#) len# = ST $ \ s# ->
 150     case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
 151     (# s2#, ByteArray 0 (I# len#) frozen# #) }
 152 \end{code}
 153
 154
 155 Compare two equal-length strings for equality:
 156
 157 \begin{code}
 158 eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool
 159 eqStrPrefix a# barr# len# =
 160   unsafePerformIO $ do
 161    x <- memcmp_ba a# barr# (I# len#)
 162    return (x == 0)
 163
 164 eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool
 165 eqCharStrPrefix a1# a2# len# =
 166   unsafePerformIO $ do
 167    x <- memcmp a1# a2# (I# len#)
 168    return (x == 0)
 169
 170 eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
 171 eqStrPrefixBA b1# b2# start# len# =
 172   unsafePerformIO $ do
 173     x <- memcmp_baoff_ba b2# (I# start#) b1# (I# len#)
 174     return (x == 0)
 175
 176 eqCharStrPrefixBA :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
 177 eqCharStrPrefixBA a# b2# start# len# =
 178   unsafePerformIO $ do
 179     x <- memcmp_baoff b2# (I# start#) a# (I# len#)
 180     return (x == 0)
 181 \end{code}
 182
 183 \begin{code}
 184 foreign import ccall "ghc_strlen" unsafe
 185   strLength :: Addr -> Int
 186
 187 foreign import ccall "ghc_memcmp" unsafe
 188   memcmp :: Addr# -> Addr# -> Int -> IO Int
 189
 190 foreign import ccall "ghc_memcmp" unsafe
 191   memcmp_ba :: Addr# -> ByteArray# -> Int -> IO Int
 192
 193 foreign import ccall "ghc_memcmp_off" unsafe
 194   memcmp_baoff :: ByteArray# -> Int -> Addr# -> Int -> IO Int
 195
 196 foreign import ccall "ghc_memcmp_off" unsafe
 197   memcmp_baoff_ba :: ByteArray# -> Int -> ByteArray# -> Int -> IO Int
 198 \end{code}