From 4b8ea8e7b6be70a48507b9d4cb4a5859e91e4e82 Mon Sep 17 00:00:00 2001
From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Fri, 17 Feb 1995 23:41:57 +0000
Subject: [PATCH] Added rewrites for EXPT and SQRT which are `enabled' by using
 EXPT and SQRT like this:

	((access SQRT system-global-environment) 6.7)

i.e. they dispatch of (CALL %invoke-remote-operator ...)  (declare
(usual-integrations)) should be changed to make operator references to
these standard procedures into global references.

SQRT just does constant folding.  EXPT also expands to a small
expression trees of <= some number of generic multiplies for a small
exact integer exponent.
---
 v8/src/compiler/midend/earlyrew.scm | 84 ++++++++++++++++++++++++++++-
 1 file changed, 83 insertions(+), 1 deletion(-)

diff --git a/v8/src/compiler/midend/earlyrew.scm b/v8/src/compiler/midend/earlyrew.scm
index 4aa0cb2ba..51c322bd4 100644
--- a/v8/src/compiler/midend/earlyrew.scm
+++ b/v8/src/compiler/midend/earlyrew.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: earlyrew.scm,v 1.4 1995/02/14 02:38:45 adams Exp $
+$Id: earlyrew.scm,v 1.5 1995/02/17 23:41:57 adams Exp $
 
 Copyright (c) 1994 Massachusetts Institute of Technology
 
@@ -590,3 +590,85 @@ MIT in each case. |#
 					      ,text))))
 		      (default))))
 	    (else (default))))))
+
+
+(define (define-rewrite/early/global name arity handler)
+  (let ((slot (hash-table/get *early-rewritten-operators* name '())))
+    (hash-table/put! *early-rewritten-operators*
+		     name
+		     (cons (cons arity handler) slot))))
+
+(define-rewrite/early %invoke-remote-cache 
+  (lambda (descriptor operator-cache . values)
+    (define (default values)
+      `(CALL (QUOTE ,%invoke-remote-cache)
+	     (QUOTE #f)
+	     ,descriptor
+	     ,operator-cache
+	     ,@values))
+    (let* ((descriptor* (quote/text descriptor))
+	   (name  (first descriptor*))
+	   (arity (second descriptor*)))
+      (cond ((rewrite-operator/early? name)
+	     => (lambda (alist)
+		  (cond ((assq arity alist)
+			 => (lambda (arity.handler)
+			      (apply (cdr arity.handler) default values)))
+			(else (default values)))))
+	    (else
+	     (default values))))))
+
+
+(define-rewrite/early/global 'SQRT 1
+  (lambda (default arg)
+    (cond ((earlyrew/number? arg)
+	   => (lambda (number)
+		`(QUOTE ,(sqrt number))))
+	  (else
+	   (default (list arg))))))
+
+
+(define-rewrite/early/global 'EXPT 2
+  (let ((&* (make-primitive-procedure '&*))
+	(max-multiplies 3))
+    (lambda (default* base exponent)
+      (define (default)
+	(default* (list base exponent)))
+      (define (make-product x y)
+	`(CALL (QUOTE ,&*)
+	       (QUOTE #F)
+	       ,x ,y))
+      (define (count-multiplies n)
+	(cond ((= n 1) 0)
+	      ((= n 2) 1)
+	      ((even? n) (+ (count-multiplies (/ n 2)) 1))
+	      ((odd? n)  (+ (count-multiplies (- n 1)) 1))))
+      (define (power variable n)
+	(cond ((= n 1) variable)
+	      ((= n 2) (make-product variable variable))
+	      ((even? n)
+	       (let ((square (earlyrew/new-name 'X)))
+		 (bind square (make-product variable variable)
+		       (power `(LOOKUP ,square) (/ n 2)))))
+	      ((odd? n)
+	       (make-product variable (power variable (- n 1))))))	       
+		       
+      (cond ((earlyrew/number? exponent)
+	     => (lambda (exponent)
+		  (cond ((earlyrew/number? base)
+			 => (lambda (base)
+			      `(QUOTE ,(expt base exponent))))
+			((eqv? exponent 0)
+			 `(QUOTE 1))
+			((eqv? exponent 1)
+			 base)
+			((and (exact-integer? exponent)
+			      (>= exponent 2)
+			      (<= (count-multiplies exponent) max-multiplies))
+			 (let* ((base-name  (earlyrew/new-name 'X))
+				(expression (power `(LOOKUP ,base-name) exponent)))
+			   (bind base-name base
+				 (earlyrew/expr expression))))
+			(else (default)))))
+	    (else
+	     (default))))))
-- 
2.25.1