From: Taylor R Campbell <campbell@mumble.net>
Date: Mon, 31 Dec 2018 20:32:37 +0000 (+0000)
Subject: Use BTS to affix single-bit type tags.
X-Git-Tag: mit-scheme-pucked-10.1.20~11^2~80^2~14
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=be310b85bbcfc7fbc58b311f799255493d48437e;p=mit-scheme.git

Use BTS to affix single-bit type tags.
---

diff --git a/src/compiler/machines/x86-64/rules1.scm b/src/compiler/machines/x86-64/rules1.scm
index 8dd0daddc..68614917f 100644
--- a/src/compiler/machines/x86-64/rules1.scm
+++ b/src/compiler/machines/x86-64/rules1.scm
@@ -110,8 +110,15 @@ USA.
 	  (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum))))
   (if (zero? type)
       (assign-register->register target datum)
-      (let* ((target (standard-move-to-target! datum target))
-	     (temp (temporary-register-reference)))
+      (affix-type (standard-move-to-target! datum target) type)))
+
+(define (affix-type target type)
+  (if (= 1 (bit-count type))
+      (let ((bit (first-set-bit type)))
+	(assert (<= 0 bit))
+	(assert (< bit scheme-type-width))
+	(LAP (BTS Q ,target (&U ,(+ scheme-datum-width bit)))))
+      (let ((temp (temporary-register-reference)))
 	(LAP (MOV Q ,temp (&U ,(make-non-pointer-literal type 0)))
 	     (OR Q ,target ,temp)))))
 
@@ -201,27 +208,23 @@ USA.
 			(ENTRY:CONTINUATION (? label))))
   (assert (= type type-code:compiled-return))
   (let* ((target (target-register-reference target))
-	 (temp (temporary-register-reference))
 	 (pushed (generate-label 'PUSHED)))
     (LAP (CALL (@PCR ,pushed))
 	 (JMP (@PCRO ,label 8))
 	(LABEL ,pushed)
 	 (POP Q ,target)
-	 (MOV Q ,temp (&U ,(make-non-pointer-literal type 0)))
-	 (OR Q ,target ,temp))))
+	 ,@(affix-type target type))))
 
 (define-rule statement
   (ASSIGN (PRE-INCREMENT (REGISTER 4) -1)
 	  (CONS-POINTER (MACHINE-CONSTANT (? type))
 			(ENTRY:CONTINUATION (? label))))
   (assert (= type type-code:compiled-return))
-  (let* ((temp (temporary-register-reference))
-	 (pushed (generate-label 'PUSHED)))
+  (let ((pushed (generate-label 'PUSHED)))
     (LAP (CALL (@PCR ,pushed))
 	 (JMP (@PCRO ,label 8))
 	(LABEL ,pushed)
-	 (MOV Q ,temp (&U ,(make-non-pointer-literal type 0)))
-	 (OR Q (@R 4) ,temp))))
+	 ,@(affix-type (INST-EA (@R 4)) type))))
 
 (define-rule statement
   (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
@@ -430,6 +433,9 @@ USA.
     (LAP (LEA Q ,target ,source))))  
 
 (define (load-pc-relative-address/typed target type label offset)
+  (LAP (LEA Q ,target (@PCRO ,label ,offset))
+       ,@(affix-type target type))
+  #|
   ;++ This is pretty horrid, especially since it happens for every
   ;++ continuation pushed!  None of the alternatives is much good.
   ;; Twenty bytes, but only three instructions and no extra memory.
@@ -437,6 +443,7 @@ USA.
     (LAP (MOV Q ,temp (&U ,(make-non-pointer-literal type 0)))
 	 (LEA Q ,target (@PCRO ,label ,offset))
 	 (OR Q ,target ,temp)))
+  |#
   #|
   ;; Nineteen bytes, but rather complicated (and needs syntax for an
   ;; addressing mode not presently supported).