From a505c3144baef51bc3deda34039685c7cb82ef51 Mon Sep 17 00:00:00 2001
From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Thu, 19 Feb 1998 08:56:27 +0000
Subject: [PATCH] Improved patterns for (fix:* n 2) and (fix:lsh n -1)

---
 v7/src/compiler/machines/i386/rulfix.scm | 49 +++++++++++++++++++++++-
 1 file changed, 48 insertions(+), 1 deletion(-)

diff --git a/v7/src/compiler/machines/i386/rulfix.scm b/v7/src/compiler/machines/i386/rulfix.scm
index 8c0fe3d78..709e57478 100644
--- a/v7/src/compiler/machines/i386/rulfix.scm
+++ b/v7/src/compiler/machines/i386/rulfix.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: rulfix.scm,v 1.29 1998/02/18 07:46:55 adams Exp $
+$Id: rulfix.scm,v 1.30 1998/02/19 08:56:27 adams Exp $
 
 Copyright (c) 1992-1998 Massachusetts Institute of Technology
 
@@ -136,6 +136,26 @@ MIT in each case. |#
   (fixnum-1-arg target source
    (lambda (target)
      (multiply-fixnum-constant target (* n fixnum-1) false))))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+	  (FIXNUM->OBJECT
+	   (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+			  (OBJECT->FIXNUM (REGISTER (? source)))
+			  (OBJECT->FIXNUM (CONSTANT 2))
+			  #f)))
+  (QUALIFIER (multiply-object-by-2?))
+  (multiply-object-by-2 target source))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+	  (FIXNUM->OBJECT
+	   (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+			  (OBJECT->FIXNUM (CONSTANT 2))
+			  (OBJECT->FIXNUM (REGISTER (? source)))
+			  #f)))
+  (QUALIFIER (multiply-object-by-2?))
+  (multiply-object-by-2 target source))
 
 ;;;; Fixnum Predicates
 
@@ -613,6 +633,33 @@ MIT in each case. |#
     (lambda (target)
       (LAP (SHL W ,target (& ,(+ scheme-type-width n)))))))
 
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+	  (FIXNUM->OBJECT
+	   (FIXNUM-2-ARGS FIXNUM-LSH
+			  (OBJECT->FIXNUM (REGISTER (? source)))
+			  (OBJECT->FIXNUM (CONSTANT 1))
+			  #f)))
+  (QUALIFIER (multiply-object-by-2?))
+  (multiply-object-by-2 target source))
+
+;; Multiply by two by adding.  This can be done directly on the object
+;; if the fixnum tag is even, since the tag lsb acts as a place where
+;; the carry can stop.
+
+(define-integrable (multiply-object-by-2?)
+  (even? (ucode-type fixnum)))
+
+(define (multiply-object-by-2 target source)
+  (let ((src (source-register source)))
+    (let ((tgt (target-register-reference target)))
+      (let ((subtract-one-typecode
+	     (- #x100000000 (make-non-pointer-literal (ucode-type fixnum) 0)))
+	    (mask-out-carry-into-typecode-lsb
+	     (make-non-pointer-literal (ucode-type fixnum) (object-datum -1))))
+	(LAP (LEA ,tgt (@ROI UW ,src ,subtract-one-typecode ,src 1))
+	     (AND W ,tgt (&U ,mask-out-carry-into-typecode-lsb)))))))
+
 (define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args-constant
   (lambda (target n overflow?)
     (multiply-fixnum-constant target n overflow?)))
-- 
2.25.1