From: simonmar <unknown>
Date: Mon, 22 Apr 2002 14:54:10 +0000 (+0000)
Subject: [project @ 2002-04-22 14:54:09 by simonmar]
X-Git-Tag: Approx_11550_changesets_converted~2123
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=acaaf62143d015fe66ec9b100bd7f0ea1df523cb;p=ghc-hetmet.git

[project @ 2002-04-22 14:54:09 by simonmar]
Define out-of-line versions of strlen and memcmp for PrimPacked, and
remove the -monly-2-regs flag.
---

diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile
index 2deb605..5d800ca 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 7d94a7a..6578dbb 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 fa78dcc..c68b41e 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 da16a33..c8cecff 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}