diff options
| -rw-r--r-- | ghc/compiler/Makefile | 4 | ||||
| -rw-r--r-- | ghc/compiler/parser/hschooks.c | 18 | ||||
| -rw-r--r-- | ghc/compiler/parser/hschooks.h | 7 | ||||
| -rw-r--r-- | ghc/compiler/utils/PrimPacked.lhs | 72 |
4 files changed, 56 insertions, 45 deletions
diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 2deb605d94..5d800ca1cf 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.215 2002/04/22 14:35:02 simonmar Exp $ +# $Id: Makefile,v 1.216 2002/04/22 14:54:09 simonmar Exp $ TOP = .. @@ -241,7 +241,7 @@ endif # because it contains 'ccall strlen' and 'ccall memcmp', which gets # inlined by gcc, causing a lack of registers. # -utils/PrimPacked_HC_OPTS = -fvia-C -monly-2-regs +utils/PrimPacked_HC_OPTS = -fvia-C # ByteCodeItbls uses primops that the NCG doesn't support yet. ghci/ByteCodeItbls_HC_OPTS = -fvia-C diff --git a/ghc/compiler/parser/hschooks.c b/ghc/compiler/parser/hschooks.c index 7d94a7a6d0..6578dbb5f0 100644 --- a/ghc/compiler/parser/hschooks.c +++ b/ghc/compiler/parser/hschooks.c @@ -142,3 +142,21 @@ StackOverflowHook (I_ stack_size) /* in bytes */ } #endif + +HsInt +ghc_strlen( HsAddr a ) +{ + return (strlen((char *)a)); +} + +HsInt +ghc_memcmp( HsAddr a1, HsAddr a2, HsInt len ) +{ + return (memcmp((char *)a1, a2, len)); +} + +HsInt +ghc_memcmp_off( HsAddr a1, HsInt i, HsAddr a2, HsInt len ) +{ + return (memcmp((char *)a1 + i, a2, len)); +} diff --git a/ghc/compiler/parser/hschooks.h b/ghc/compiler/parser/hschooks.h index fa78dcce23..c68b41e23b 100644 --- a/ghc/compiler/parser/hschooks.h +++ b/ghc/compiler/parser/hschooks.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: hschooks.h,v 1.3 2000/12/20 09:56:26 simonmar Exp $ + * $Id: hschooks.h,v 1.4 2002/04/22 14:54:10 simonmar Exp $ * * Hooks into the RTS from the compiler. * @@ -8,3 +8,8 @@ #include "HsFFI.h" void enableTimingStats( void ); void setHeapSize( HsInt size ); + +// Out-of-line string functions, see PrimPacked.lhs +HsInt ghc_strlen( HsAddr a ); +HsInt ghc_memcmp( HsAddr a1, HsAddr a2, HsInt len ); +HsInt ghc_memcmp_off( HsAddr a1, HsInt i, HsAddr a2, HsInt len ); diff --git a/ghc/compiler/utils/PrimPacked.lhs b/ghc/compiler/utils/PrimPacked.lhs index da16a33a11..c8cecffb26 100644 --- a/ghc/compiler/utils/PrimPacked.lhs +++ b/ghc/compiler/utils/PrimPacked.lhs @@ -8,7 +8,7 @@ of bytes (character strings). Used by the interface lexer input subsystem, mostly. \begin{code} -{-# OPTIONS -monly-3-regs -optc-DNON_POSIX_SOURCE #-} +{-# OPTIONS -monly-3-regs -optc-DNON_POSIX_SOURCE -#include "hschooks.h" #-} module PrimPacked ( strLength, -- :: _Addr -> Int @@ -44,18 +44,6 @@ import PrelST import GHC.ST #endif -\end{code} - -Return the length of a @\\NUL@ terminated character string: - -\begin{code} -strLength :: Addr -> Int -strLength a = - unsafePerformIO ( - _ccall_ strlen a >>= \ len@(I# _) -> - return len - ) -{-# NOINLINE strLength #-} \end{code} Copying a char string prefix into a byte array, @@ -169,42 +157,42 @@ Compare two equal-length strings for equality: \begin{code} eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool eqStrPrefix a# barr# len# = - unsafePerformIO ( - _ccall_ memcmp (A# a#) (ByteArray bot bot barr#) (I# len#) >>= \ (I# x#) -> - return (x# ==# 0#)) - where - bot :: Int - bot = error "eqStrPrefix" + unsafePerformIO $ do + x <- memcmp_ba a# barr# (I# len#) + return (x == 0) eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool eqCharStrPrefix a1# a2# len# = - unsafePerformIO ( - _ccall_ memcmp (A# a1#) (A# a2#) (I# len#) >>= \ (I# x#) -> - return (x# ==# 0#)) + unsafePerformIO $ do + x <- memcmp a1# a2# (I# len#) + return (x == 0) eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool eqStrPrefixBA b1# b2# start# len# = - unsafePerformIO ( - _casm_ ``%r=(int)memcmp((char *)%0+(int)%1,%2,%3); '' - (ByteArray bot bot b2#) - (I# start#) - (ByteArray bot bot b1#) - (I# len#) >>= \ (I# x#) -> - return (x# ==# 0#)) - where - bot :: Int - bot = error "eqStrPrefixBA" + unsafePerformIO $ do + x <- memcmp_baoff_ba b2# (I# start#) b1# (I# len#) + return (x == 0) eqCharStrPrefixBA :: Addr# -> ByteArray# -> Int# -> Int# -> Bool eqCharStrPrefixBA a# b2# start# len# = - unsafePerformIO ( - _casm_ ``%r=(int)memcmp((char *)%0+(int)%1,%2,%3); '' - (ByteArray bot bot b2#) - (I# start#) - (A# a#) - (I# len#) >>= \ (I# x#) -> - return (x# ==# 0#)) - where - bot :: Int - bot = error "eqCharStrPrefixBA" + unsafePerformIO $ do + x <- memcmp_baoff b2# (I# start#) a# (I# len#) + return (x == 0) +\end{code} + +\begin{code} +foreign import ccall "ghc_strlen" unsafe + strLength :: Addr -> Int + +foreign import ccall "ghc_memcmp" unsafe + memcmp :: Addr# -> Addr# -> Int -> IO Int + +foreign import ccall "ghc_memcmp" unsafe + memcmp_ba :: Addr# -> ByteArray# -> Int -> IO Int + +foreign import ccall "ghc_memcmp_off" unsafe + memcmp_baoff :: ByteArray# -> Int -> Addr# -> Int -> IO Int + +foreign import ccall "ghc_memcmp_off" unsafe + memcmp_baoff_ba :: ByteArray# -> Int -> ByteArray# -> Int -> IO Int \end{code} |