From 1bd1f27bdeec8423ecae962c4cb9f88f4a5db783 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 2 Jan 1999 02:52:56 +0000 Subject: [PATCH] Unknown changes by Stephen Adams. --- v7/src/compiler/rtlbase/rtlty1.scm | 6 +++++- v7/src/microcode/ppband.c | 4 ++-- v8/src/compiler/back/lapgn3.scm | 4 +++- v8/src/compiler/midend/simplify.scm | 31 +++++++++++++++-------------- v8/src/compiler/rtlbase/rtlpars.scm | 15 +++++++------- 5 files changed, 34 insertions(+), 26 deletions(-) diff --git a/v7/src/compiler/rtlbase/rtlty1.scm b/v7/src/compiler/rtlbase/rtlty1.scm index f48c7f759..c32e15dc2 100644 --- 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 c2d3bf161..1ed23c75a 100644 --- 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 15252fd9b..a67123260 100644 --- 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 489557aa1..fb3de96aa 100644 --- 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 2796bbd6e..7ac8fde1b 100644 --- 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)) (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) '()))))))) (define-macro (%push! object collection) `(begin (set! ,collection (cons ,object ,collection)) -- 2.25.1