Unknown changes by Stephen Adams.

diff --git a/v7/src/compiler/rtlbase/rtlty1.scm b/v7/src/compiler/rtlbase/rtlty1.scm
index f48c7f75968e4a6b462cfe7b15e4e293aa87d78b..c32e15dc211f2b273d2b225c56858ded03879844 100644 (file)
--- a/v7/src/compiler/rtlbase/rtlty1.scm
+++ b/v7/src/compiler/rtlbase/rtlty1.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: rtlty1.scm,v 4.21 1993/07/01 03:25:47 gjr Exp $
+$Id: rtlty1.scm,v 4.22 1999/01/02 02:52:22 cph Exp $
 
 Copyright (c) 1987-1993 Massachusetts Institute of Technology
 
@@ -138,6 +138,10 @@ MIT in each case. |#
 (define-rtl-predicate eq-test % expression-1 expression-2)
 (define-rtl-predicate type-test % expression type)
 
+;; General predicates
+(define-rtl-predicate pred-1-arg % predicate operand)
+(define-rtl-predicate pred-2-args % predicate operand-1 operand-2)
+
 (define-rtl-predicate overflow-test rtl:)
 
 (define-rtl-statement assign % address expression)

diff --git a/v7/src/microcode/ppband.c b/v7/src/microcode/ppband.c
index c2d3bf16148a1d2b0f252ceed252a1354b58907c..1ed23c75a68a043849c2355fd9e1db409881395c 100644 (file)
--- a/v7/src/microcode/ppband.c
+++ b/v7/src/microcode/ppband.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: ppband.c,v 9.47 1993/10/14 21:42:03 gjr Exp $
+$Id: ppband.c,v 9.48 1999/01/02 02:52:37 cph Exp $
 
 Copyright (c) 1987-1993 Massachusetts Institute of Technology
 
@@ -299,7 +299,7 @@ DEFUN (Display, (Location, Type, The_Datum),
       }
       NON_POINTER ("NULL");
 
-    case TC_TRUE:
+    case TC_CONSTANT:
       if (The_Datum == 0)
       {
        printf ("#T\n");

diff --git a/v8/src/compiler/back/lapgn3.scm b/v8/src/compiler/back/lapgn3.scm
index 15252fd9b2c8461e8696f91d51ead85af88eaac0..a671232604224485edc49dc7d6793c9dcb44ab7d 100644 (file)
--- a/v8/src/compiler/back/lapgn3.scm
+++ b/v8/src/compiler/back/lapgn3.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: lapgn3.scm,v 1.3 1994/11/26 19:59:00 gjr Exp $
+$Id: lapgn3.scm,v 1.4 1999/01/02 02:52:51 cph Exp $
 
 Copyright (c) 1987-1992 Massachusetts Institute of Technology
 
@@ -233,6 +233,8 @@ MIT in each case. |#
                        counts)))
 
 
+;; These belong in the runtime system
+
 (define (compiled-code-block/read-profile-count block count)
   block
   count

diff --git a/v8/src/compiler/midend/simplify.scm b/v8/src/compiler/midend/simplify.scm
index 489557aa1d72e729baa5cf5e66a8d0155323923f..fb3de96aa475f6d5f8ba6fc8923bd010533b45b4 100644 (file)
--- a/v8/src/compiler/midend/simplify.scm
+++ b/v8/src/compiler/midend/simplify.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: simplify.scm,v 1.19 1996/07/30 19:25:02 adams Exp $
+$Id: simplify.scm,v 1.20 1999/01/02 02:52:46 cph Exp $
 
 Copyright (c) 1994-1995 Massachusetts Institute of Technology
 
@@ -162,23 +162,23 @@ MIT in each case. |#
     (do-simplification env0 #T bindings* body* simplify/letrecify)))
 
 (define-simplifier LETREC (env bindings body)
-  (let* ((frame (map (lambda (binding) (simplify/binding/make (car binding)))
+  (let* ((n-bindings (length bindings))
+        (frame (map (lambda (binding) (simplify/binding/make (car binding)))
                     bindings))
         (env0 (simplify/env/make env frame))
         (body* (simplify/expr env0 body)))
 
-    (let ((bindings* '())
-         (initial-queue (map cons frame bindings)))
+    (let ((bindings* (make-vector n-bindings))
+         (initial-queue (map cons* frame (iota n-bindings) bindings)))
 
       (define (finish unused)
-       (let ((bindings*
-              (map* bindings*
-                    (lambda (bnd+var+exp)
-                      (list false (second bnd+var+exp) (third bnd+var+exp)))
-                    unused)))
-         (let ((x
-                (do-simplification env0 #T bindings* body* simplify/letrecify)))
-           x)))
+       (define (insert! elt)
+         (vector-set! bindings*
+                      (second elt)
+                      (list false (third elt) (fourth elt))))
+       (for-each insert! unused)
+       (do-simplification env0 #T (vector->list bindings*)
+                          body* simplify/letrecify))
 
       ;; We scan a queue of bindings to check.  If a binding is referenced, add
       ;; it to the set.  If it is unreferenced, put it in a retry
@@ -200,11 +200,12 @@ MIT in each case. |#
                       (null? (simplify/binding/ordinary-refs (car head))))
                  (loop rest (cons head retry) found-one?)
                  (begin
-                   (set! bindings*
-                         (cons (simplify/binding&value env0 (second head) (third head))
-                               bindings*))
+                   (vector-set! bindings*
+                                (second head)
+                                (simplify/binding&value env0 (third head) (fourth head)))
                    (loop (cdr queue) retry #T)))))))))
 
+
 (define (simplify/binding&value env name value)
   (if (not (LAMBDA/? value))
       (list false name (simplify/expr env value))

diff --git a/v8/src/compiler/rtlbase/rtlpars.scm b/v8/src/compiler/rtlbase/rtlpars.scm
index 2796bbd6ec24b15868892b8ce357cd5a5fa54b5c..7ac8fde1bfde69e58b7b2f8a42010fd7970a443d 100644 (file)
--- a/v8/src/compiler/rtlbase/rtlpars.scm
+++ b/v8/src/compiler/rtlbase/rtlpars.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: rtlpars.scm,v 1.3 1994/12/16 20:18:34 adams Exp $
+$Id: rtlpars.scm,v 1.4 1999/01/02 02:52:56 cph Exp $
 
 Copyright (c) 1994 Massachusetts Institute of Technology
 
@@ -227,12 +227,13 @@ MIT in each case. |#
     unspecific))
 \f
 (define (link-up! slot labels->segments)
-  (define (find-bblock label)
+  (define (find-bblock label seen)
     (let ((desc (hash-table/get labels->segments label false)))
       (if (not desc)
          (internal-error "Missing label" label))
-      (if (eq? (car desc) 'EMPTY)
-         (find-bblock (cadr desc))
+      (if (and (eq? (car desc) 'EMPTY)
+              (not (memq label seen)))
+         (find-bblock (cadr desc) (cons label seen))
          (caddr desc))))
 
   (if (not (eq? (car slot) 'EMPTY))
@@ -242,14 +243,14 @@ MIT in each case. |#
              ((not (pair? next))
               (create-edge! bblock
                             set-snode-next-edge!
-                            (find-bblock next)))
+                            (find-bblock next '())))
              (else
               (create-edge! bblock
                             set-pnode-consequent-edge!
-                            (find-bblock (car next)))
+                            (find-bblock (car next) '()))
               (create-edge! bblock
                             set-pnode-alternative-edge!
-                            (find-bblock (cadr next))))))))
+                            (find-bblock (cadr next) '())))))))
 \f
 (define-macro (%push! object collection)
   `(begin (set! ,collection (cons ,object ,collection))