Partially improve the cabalisation

Language/Hi/PrimPacked.hs

@@ -0,0 +1,194 @@
+{-# OPTIONS -cpp -fglasgow-exts #-}
+{-# OPTIONS -fno-warn-name-shadowing -fno-warn-unused-matches #-}
+
+{-# OPTIONS -#include "hschooks.h" #-}
+
+-- 
+-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
+-- 
+-- This library is free software; you can redistribute it and/or
+-- modify it under the terms of the GNU Lesser General Public
+-- License as published by the Free Software Foundation; either
+-- version 2.1 of the License, or (at your option) any later version.
+-- 
+-- This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+-- Lesser General Public License for more details.
+-- 
+-- You should have received a copy of the GNU Lesser General Public
+-- License along with this library; if not, write to the Free Software
+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
+-- USA
+-- 
+-- Based on $fptools/ghc/compiler/utils/PrimPacked.lhs
+--
+-- (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
+--
+--
+-- Basic ops on packed representations
+--
+-- Some basic operations for working on packed representations of series
+-- of bytes (character strings). Used by the interface lexer input
+-- subsystem, mostly.
+
+{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
+
+module Language.Hi.PrimPacked (
+	Ptr(..), nullPtr, plusAddr#,
+	BA(..),
+	packString, 	   -- :: String -> (Int, BA)
+	unpackNBytesBA,    -- :: BA -> Int -> [Char]
+        strLength,	   -- :: Ptr CChar -> Int
+        copyPrefixStr,	   -- :: Addr# -> Int -> BA
+        copySubStrBA,	   -- :: BA -> Int -> Int -> BA
+        eqStrPrefix,	   -- :: Addr# -> ByteArray# -> Int# -> Bool
+        eqStrPrefixBA,	   -- :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
+ ) where
+
+import Foreign
+import GHC.Exts
+import GHC.ST
+
+-- Wrapper types for bytearrays
+
+data BA    = BA  ByteArray#
+data MBA s = MBA (MutableByteArray# s)
+
+packString :: String -> (Int, BA)
+packString str = (l, arr)
+ where
+  l@(I# length#) = length str
+
+  arr = runST (do
+    ch_array <- new_ps_array length#
+      -- fill in packed string from "str"
+    fill_in ch_array 0# str
+      -- freeze the puppy:
+    freeze_ps_array ch_array length#
+   )
+
+  fill_in :: MBA s -> Int# -> [Char] -> ST s ()
+  fill_in arr_in# idx [] =
+   return ()
+  fill_in arr_in# idx (C# c : cs) =
+   write_ps_array arr_in# idx c	 >>
+   fill_in arr_in# (idx +# 1#) cs
+
+-- Unpacking a string
+
+unpackNBytesBA :: BA -> Int -> [Char]
+unpackNBytesBA (BA bytes) (I# len)
+ = unpack 0#
+ where
+    unpack nh
+      | nh >=# len  = []
+      | otherwise   = C# ch : unpack (nh +# 1#)
+      where
+	ch = indexCharArray# bytes nh
+
+-- Copying a char string prefix into a byte array.
+
+copyPrefixStr :: Addr# -> Int -> BA
+copyPrefixStr a# len@(I# length#) = copy' length#
+ where
+   copy' length# = runST (do
+     {- allocate an array that will hold the string
+     -}
+     ch_array <- new_ps_array length#
+     {- Revert back to Haskell-only solution for the moment.
+     	_ccall_ memcpy ch_array (A# a) len        >>=  \ () ->
+     	write_ps_array ch_array length# (chr# 0#) >>
+     -}
+     -- fill in packed string from "addr"
+     fill_in ch_array 0#
+     -- freeze the puppy:
+     freeze_ps_array ch_array length#
+    )
+
+   fill_in :: MBA s -> Int# -> ST s ()
+   fill_in arr_in# idx
+      | idx ==# length#
+      = return ()
+      | otherwise
+      = case (indexCharOffAddr# a# idx) of { ch ->
+	write_ps_array arr_in# idx ch >>
+	fill_in arr_in# (idx +# 1#) }
+
+-- Copying out a substring, assume a 0-indexed string:
+-- (and positive lengths, thank you).
+
+copySubStrBA :: BA -> Int -> Int -> BA
+copySubStrBA (BA barr#) (I# start#) len@(I# length#) = ba
+ where
+  ba = runST (do
+     -- allocate an array that will hold the string
+    ch_array <- new_ps_array length#
+     -- fill in packed string from "addr"
+    fill_in ch_array 0#
+     -- freeze the puppy:
+    freeze_ps_array ch_array length#
+   )
+
+  fill_in :: MBA s -> Int# -> ST s ()
+  fill_in arr_in# idx
+      | idx ==# length#
+      = return ()
+      | otherwise
+      = case (indexCharArray# barr# (start# +# idx)) of { ch ->
+	write_ps_array arr_in# idx ch >>
+	fill_in arr_in# (idx +# 1#) }
+
+-- (Very :-) ``Specialised'' versions of some CharArray things...
+-- [Copied from PackBase; no real reason -- UGH]
+
+new_ps_array	:: Int# -> ST s (MBA s)
+write_ps_array	:: MBA s -> Int# -> Char# -> ST s () 
+freeze_ps_array :: MBA s -> Int# -> ST s BA
+
+#if __GLASGOW_HASKELL__ < 411
+#define NEW_BYTE_ARRAY newCharArray#
+#else 
+#define NEW_BYTE_ARRAY newByteArray#
+#endif
+
+new_ps_array size = ST $ \ s ->
+    case (NEW_BYTE_ARRAY size s)  of { (# s2#, barr# #) ->
+    (# s2#, MBA barr# #) }
+
+write_ps_array (MBA barr#) n ch = ST $ \ s# ->
+    case writeCharArray# barr# n ch s#	of { s2#   ->
+    (# s2#, () #) }
+
+-- same as unsafeFreezeByteArray
+freeze_ps_array (MBA arr#) len# = ST $ \ s# ->
+    case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
+    (# s2#, BA frozen# #) }
+
+-- Compare two equal-length strings for equality:
+
+eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool
+eqStrPrefix a# barr# len# = 
+  unsafePerformIO $ do
+   x <- memcmp_ba a# barr# (I# len#)
+   return (x == 0)
+
+eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
+eqStrPrefixBA b1# b2# start# len# = 
+  unsafePerformIO $ do
+    x <- memcmp_baoff_ba b2# (I# start#) b1# (I# len#)
+    return (x == 0)
+
+------------------------------------------------------------------------
+-- in hschooks
+--
+
+foreign import ccall unsafe "plugin_strlen"
+        strLength :: Ptr () -> Int
+
+foreign import ccall unsafe "plugin_memcmp"
+        memcmp_ba :: Addr# -> ByteArray# -> Int -> IO Int
+
+foreign import ccall unsafe "plugin_memcmp_off"
+        memcmp_baoff_ba :: ByteArray# -> Int -> ByteArray# -> Int -> IO Int
+