From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 12 Apr 2017 05:35:10 +0000 (-0700)
Subject: Implement open-coding of byte-ref primitives.
X-Git-Tag: mit-scheme-pucked-9.2.12~158^2~52
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9e261c9ae5dc1d3227264be12d6433b8d0b9c361;p=mit-scheme.git

Implement open-coding of byte-ref primitives.
---

diff --git a/src/compiler/rtlgen/opncod.scm b/src/compiler/rtlgen/opncod.scm
index 842043b5a..35ab015bc 100644
--- a/src/compiler/rtlgen/opncod.scm
+++ b/src/compiler/rtlgen/opncod.scm
@@ -542,7 +542,7 @@ USA.
 			     1
 			     scfg*scfg->scfg!)))
 
-(define string-memory-reference
+(define byte-memory-reference
   (indexed-memory-reference
    (lambda (expression) (rtl:make-fetch (rtl:locative-offset expression 1)))
    (index-locative-generator rtl:locative-byte-offset
@@ -1063,6 +1063,15 @@ USA.
       (finish (rtl:make-fetch locative))))
    '(0 1)
    false))
+
+(define-open-coder/value 'PRIMITIVE-BYTE-REF
+  (simple-open-coder
+   (byte-memory-reference 'PRIMITIVE-BYTE-REF false false
+    (lambda (locative expressions finish)
+      expressions
+      (finish (rtl:make-fetch locative))))
+   '(0 1)
+   false))
 
 (let ((fixed-assignment
        (lambda (name type index)
@@ -1110,6 +1119,16 @@ USA.
 				finish)))
    '(0 1 2)
    false))
+
+(define-open-coder/effect 'PRIMITIVE-BYTE-SET!
+  (simple-open-coder
+   (byte-memory-reference 'PRIMITIVE-BYTE-SET! false false
+    (lambda (locative expressions finish)
+      (finish-vector-assignment locative
+				(caddr expressions)
+				finish)))
+   '(0 1 2)
+   false))
 
 ;;;; Characters
 
@@ -1161,7 +1180,7 @@ USA.
 
 (define-open-coder/value 'STRING-REF
   (simple-open-coder
-   (string-memory-reference 'STRING-REF (ucode-type string) false
+   (byte-memory-reference 'STRING-REF (ucode-type string) false
      (lambda (locative expressions finish)
        expressions
        (finish (rtl:string-fetch locative))))
@@ -1170,7 +1189,7 @@ USA.
 
 (define-open-coder/value 'BYTEVECTOR-U8-REF
   (simple-open-coder
-   (string-memory-reference 'BYTEVECTOR-U8-REF (ucode-type bytevector) #f
+   (byte-memory-reference 'BYTEVECTOR-U8-REF (ucode-type bytevector) #f
      (lambda (locative expressions finish)
        expressions
        (finish (rtl:bytevector-fetch locative))))
@@ -1179,7 +1198,7 @@ USA.
 
 (define-open-coder/value 'VECTOR-8B-REF
   (simple-open-coder
-   (string-memory-reference 'VECTOR-8B-REF (ucode-type string) false
+   (byte-memory-reference 'VECTOR-8B-REF (ucode-type string) false
      (lambda (locative expressions finish)
        expressions
        (finish (rtl:bytevector-fetch locative))))
@@ -1188,9 +1207,9 @@ USA.
 
 (define-open-coder/effect 'STRING-SET!
   (simple-open-coder
-   (string-memory-reference 'STRING-SET!
-			    (ucode-type string)
-			    (ucode-type character)
+   (byte-memory-reference 'STRING-SET!
+			  (ucode-type string)
+			  (ucode-type character)
      (lambda (locative expressions finish)
        (finish-string-assignment locative (caddr expressions) finish)))
    '(0 1 2)
@@ -1198,9 +1217,9 @@ USA.
 
 (define-open-coder/effect 'BYTEVECTOR-U8-SET!
   (simple-open-coder
-   (string-memory-reference 'BYTEVECTOR-U8-SET!
-			    (ucode-type bytevector)
-			    (ucode-type fixnum)
+   (byte-memory-reference 'BYTEVECTOR-U8-SET!
+			  (ucode-type bytevector)
+			  (ucode-type fixnum)
      (lambda (locative expressions finish)
        (finish-bytevector-assignment locative (caddr expressions) finish)))
    '(0 1 2)
@@ -1208,9 +1227,9 @@ USA.
 
 (define-open-coder/effect 'VECTOR-8B-SET!
   (simple-open-coder
-   (string-memory-reference 'VECTOR-8B-SET!
-			    (ucode-type string)
-			    (ucode-type fixnum)
+   (byte-memory-reference 'VECTOR-8B-SET!
+			  (ucode-type string)
+			  (ucode-type fixnum)
      (lambda (locative expressions finish)
        (finish-bytevector-assignment locative (caddr expressions) finish)))
    '(0 1 2)