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 #-}
  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 Return the length of a @\\NUL@ terminated character string:
  50
  51 \begin{code}
  52 strLength :: Addr -> Int
  53 strLength a =
  54  unsafePerformIO (
  55     _ccall_ strlen a  >>= \ len@(I# _) ->
  56     return len
  57  )
  58 {-# NOINLINE strLength #-}
  59 \end{code}
  60
  61 Copying a char string prefix into a byte array,
  62 {\em assuming} the prefix does not contain any
  63 NULs.
  64
  65 \begin{code}
  66 copyPrefixStr :: Addr -> Int -> ByteArray Int
  67 copyPrefixStr (A# a) len@(I# length#) =
  68  runST (
  69   {- allocate an array that will hold the string
  70     (not forgetting the NUL at the end)
  71   -}
  72   (new_ps_array (length# +# 1#))             >>= \ ch_array ->
  73 {- Revert back to Haskell-only solution for the moment.
  74    _ccall_ memcpy ch_array (A# a) len        >>=  \ () ->
  75    write_ps_array ch_array length# (chr# 0#) >>
  76 -}
  77    -- fill in packed string from "addr"
  78   fill_in ch_array 0#                        >>
  79    -- freeze the puppy:
  80   freeze_ps_array ch_array length#           >>= \ barr ->
  81   return barr )
  82   where
  83     fill_in :: MutableByteArray s Int -> Int# -> ST s ()
  84
  85     fill_in arr_in# idx
  86       | idx ==# length#
  87       = write_ps_array arr_in# idx (chr# 0#) >>
  88         return ()
  89       | otherwise
  90       = case (indexCharOffAddr# a idx) of { ch ->
  91         write_ps_array arr_in# idx ch >>
  92         fill_in arr_in# (idx +# 1#) }
  93
  94 \end{code}
  95
  96 Copying out a substring, assume a 0-indexed string:
  97 (and positive lengths, thank you).
  98
  99 \begin{code}
 100 copySubStr :: Addr -> Int -> Int -> ByteArray Int
 101 copySubStr a start length =
 102   unsafePerformIO (
 103     _casm_ `` %r= (char *)((char *)%0 + (int)%1); '' a start
 104                                                      >>= \ a_start ->
 105     return (copyPrefixStr a_start length))
 106
 107 -- step on (char *) pointer by x units.
 108 addrOffset# :: Addr# -> Int# -> Addr#
 109 addrOffset# a# i# =
 110   case unsafePerformIO (_casm_ ``%r=(char *)((char *)%0 + (int)%1); '' (A# a#) (I# i#)) of
 111     A# a -> a
 112
 113 copySubStrBA :: ByteArray Int -> Int -> Int -> ByteArray Int
 114 copySubStrBA (ByteArray _ _ barr#) (I# start#) len@(I# length#) =
 115  runST (
 116   {- allocate an array that will hold the string
 117     (not forgetting the NUL at the end)
 118   -}
 119   new_ps_array (length# +# 1#)  >>= \ ch_array ->
 120    -- fill in packed string from "addr"
 121   fill_in ch_array 0#           >>
 122    -- freeze the puppy:
 123   freeze_ps_array ch_array length#)
 124   where
 125     fill_in :: MutableByteArray s Int -> Int# -> ST s ()
 126
 127     fill_in arr_in# idx
 128       | idx ==# length#
 129       = write_ps_array arr_in# idx (chr# 0#) >>
 130         return ()
 131       | otherwise
 132       = case (indexCharArray# barr# (start# +# idx)) of { ch ->
 133         write_ps_array arr_in# idx ch >>
 134         fill_in arr_in# (idx +# 1#) }
 135 \end{code}
 136
 137 (Very :-) ``Specialised'' versions of some CharArray things...
 138 [Copied from PackBase; no real reason -- UGH]
 139
 140 \begin{code}
 141 new_ps_array    :: Int# -> ST s (MutableByteArray s Int)
 142 write_ps_array  :: MutableByteArray s Int -> Int# -> Char# -> ST s ()
 143 freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)
 144
 145 new_ps_array size = ST $ \ s ->
 146 #if __GLASGOW_HASKELL__ < 411
 147     case (newCharArray# size s)   of { (# s2#, barr# #) ->
 148     (# s2#, MutableByteArray bot bot barr# #) }
 149 #else /* 411 and higher */
 150     case (newByteArray# size s)   of { (# s2#, barr# #) ->
 151     (# s2#, MutableByteArray bot bot barr# #) }
 152 #endif
 153   where
 154     bot = error "new_ps_array"
 155
 156 write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# ->
 157     case writeCharArray# barr# n ch s#  of { s2#   ->
 158     (# s2#, () #) }
 159
 160 -- same as unsafeFreezeByteArray
 161 freeze_ps_array (MutableByteArray _ _ arr#) len# = ST $ \ s# ->
 162     case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
 163     (# s2#, ByteArray 0 (I# len#) frozen# #) }
 164 \end{code}
 165
 166
 167 Compare two equal-length strings for equality:
 168
 169 \begin{code}
 170 eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool
 171 eqStrPrefix a# barr# len# =
 172   unsafePerformIO (
 173    _ccall_ strncmp (A# a#) (ByteArray bot bot barr#) (I# len#) >>= \ (I# x#) ->
 174    return (x# ==# 0#))
 175   where
 176    bot :: Int
 177    bot = error "eqStrPrefix"
 178
 179 eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool
 180 eqCharStrPrefix a1# a2# len# =
 181   unsafePerformIO (
 182    _ccall_ strncmp (A# a1#) (A# a2#) (I# len#) >>= \ (I# x#) ->
 183    return (x# ==# 0#))
 184
 185 eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
 186 eqStrPrefixBA b1# b2# start# len# =
 187   unsafePerformIO (
 188    _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
 189           (ByteArray bot bot b2#)
 190           (I# start#)
 191           (ByteArray bot bot b1#)
 192           (I# len#)                  >>= \ (I# x#) ->
 193    return (x# ==# 0#))
 194   where
 195    bot :: Int
 196    bot = error "eqStrPrefixBA"
 197
 198 eqCharStrPrefixBA :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
 199 eqCharStrPrefixBA a# b2# start# len# =
 200   unsafePerformIO (
 201    _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
 202           (ByteArray bot bot b2#)
 203           (I# start#)
 204           (A# a#)
 205           (I# len#)                  >>= \ (I# x#) ->
 206    return (x# ==# 0#))
 207   where
 208    bot :: Int
 209    bot = error "eqCharStrPrefixBA"
 210 \end{code}