#| -*-Scheme-*-
-$Id: blocks.scm,v 4.14 1999/01/02 06:06:43 cph Exp $
+$Id: blocks.scm,v 4.15 2001/10/22 19:17:22 cph Exp $
-Copyright (c) 1988, 1989, 1990, 1999 Massachusetts Institute of Technology
+Copyright (c) 1988-1990, 1999, 2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
|#
;;;; Environment model data structures
;;; package: (compiler)
(declare (usual-integrations))
-\f
+
#|
Interpreter compatible (hereafter, IC) blocks are vectors with an
(define (make-block parent type)
(let ((block
(make-rvalue block-tag (enumeration/name->index block-types type)
- parent '() '() false false '()'() '() '() '() '() '()
- false false 'UNKNOWN 'UNKNOWN 'UNKNOWN false)))
+ parent '() '() #f #f '()'() '() '() '() '() '()
+ #f #f 'UNKNOWN 'UNKNOWN 'UNKNOWN #f)))
(if parent
(set-block-children! parent (cons block (block-children parent))))
(set! *blocks* (cons block *blocks*))
(block-ancestor? block block*)))
(define (block-ancestor? block block*)
- (define (loop block)
+ (let loop ((block (block-parent block)))
(and block
(or (eq? block block*)
- (loop (block-parent block)))))
- (loop (block-parent block)))
+ (loop (block-parent block))))))
(define-integrable (block-child? block block*)
(eq? block (block-parent block*)))
(define (block-nearest-common-ancestor block block*)
(let loop
- ((join false)
+ ((join #f)
(ancestry (block-ancestry block))
(ancestry* (block-ancestry block*)))
- (if (and (not (null? ancestry))
- (not (null? ancestry*))
+ (if (and (pair? ancestry)
+ (pair? ancestry*)
(eq? (car ancestry) (car ancestry*)))
(loop (car ancestry) (cdr ancestry) (cdr ancestry*))
join)))
(let loop
((ancestry (block-ancestry block))
(ancestry* (block-ancestry block*)))
- (and (not (null? ancestry))
- (if (and (not (null? ancestry*))
+ (and (pair? ancestry)
+ (if (and (pair? ancestry*)
(eq? (car ancestry) (car ancestry*)))
(loop (cdr ancestry) (cdr ancestry*))
(car ancestry)))))
(if (block-parent block)
(find-outermost-block (block-parent block))
block))
-\f
+
(define (stack-block/external-ancestor block)
(let ((parent (block-parent block)))
(if (and parent (stack-block? parent))
n
(loop (block-parent block)
(+ n (block-frame-size block))))))
-
+\f
(define (for-each-block-descendant! block procedure)
(let loop ((block block))
(procedure block)
(rvalue/procedure? procedure)
(procedure-target-block procedure))))
-#|
-(define (disown-block-child! block child)
- (set-block-children! block (delq! child (block-children block)))
- (if (eq? block (original-block-parent child))
- (set-block-disowned-children! block
- (cons child (block-disowned-children block))))
- unspecific)
-
-(define (own-block-child! block child)
- (set-block-parent! child block)
- (set-block-children! block (cons child (block-children block)))
- (if (eq? block (original-block-parent child))
- (set-block-disowned-children! block
- (delq! child (block-disowned-children block))))
- unspecific)
-|#
-
(define (transfer-block-child! child block block*)
- ;; equivalent to
- ;; (begin
- ;; (disown-block-child! block child)
- ;; (own-block-child! block* child))
- ;; but faster.
(let ((original-parent (original-block-parent child)))
(set-block-children! block (delq! child (block-children block)))
(if (eq? block original-parent)
(block-entry-number block)))))
(define (block-nearest-closure-ancestor block)
- (let loop ((block block) (last false))
+ (let loop ((block block) (last #f))
(and block
(if (stack-block? block)
(loop (block-parent block) block)
#| -*-Scheme-*-
-$Id: lvalue.scm,v 4.21 1999/01/02 06:06:43 cph Exp $
+$Id: lvalue.scm,v 4.22 2001/10/22 19:10:20 cph Exp $
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-1990, 1999, 2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
|#
;;;; Left (Hand Side) Values
+;;; package: (compiler)
(declare (usual-integrations))
-\f
+
;; IMPORTANT: Change transform/make-lvalue and the call to
;; define-type-definition in macros.scm whenever a field is added or
;; deleted!
;;; (define (make-lvalue tag . extra)
;;; (let ((lvalue
;;; (list->vector
-;;; (cons* tag false '() '() '() '() '() '() 'NOT-CACHED
-;;; false '() false false '() extra))))
+;;; (cons* tag #f '() '() '() '() '() '() 'NOT-CACHED
+;;; #f '() #f #f '() extra))))
;;; (set! *lvalues* (cons lvalue *lvalues*))
;;; lvalue))
(define set-continuation-variable/type! set-variable-in-cell?!)
(define (make-variable block name)
- (make-lvalue variable-tag block name '() false false '() false false
- false false false))
+ (make-lvalue variable-tag block name '() #f #f '() #f #f #f #f #f))
(define variable-assoc
(association-procedure eq? variable-name))
(if (stack-block? block)
(let ((procedure (block-procedure block)))
(cond ((procedure-always-known-operator? procedure)
- true)
+ #t)
((or (memq lvalue
(cdr (procedure-required procedure)))
(memq lvalue (procedure-optional procedure))
(eq? lvalue (procedure-rest procedure)))
- false)
- (else true)))
- true))
- true))))
+ #f)
+ (else #t)))
+ #t))
+ #t))))
(define (variable-unused? variable)
(or (lvalue-integrated? variable)
(define (lvalue/unique-source lvalue)
(let ((source-set (lvalue/source-set lvalue)))
- (and (not (null? source-set))
+ (and (pair? source-set)
(null? (cdr source-set))
(car source-set))))
;; is the outermost IC block of the expression in
;; which the variable is referenced.
(memq variable
- (block-bound-variables reference-block))))))))
-\f
-;; This is not in use anywhere! What is it for? -- Arthur & GJR 1/93
-
-#|
-
-(define (lvalue/articulation-points lvalue)
- ;; This won't work if (memq lvalue (lvalue-backward-links lvalue))?
- (let ((articulation-points '())
- (number-tag "number-tag"))
- (let ((articulation-point!
- (lambda (lvalue)
- (if (not (memq lvalue articulation-points))
- (begin
- (set! articulation-points (cons lvalue articulation-points))
- unspecific))))
- (allocate-number!
- (let ((n 0))
- (lambda ()
- (let ((number n))
- (set! n (1+ n))
- number)))))
- (with-new-lvalue-marks
- (lambda ()
- (let loop ((lvalue lvalue) (parent false) (number (allocate-number!)))
- (lvalue-mark! lvalue)
- (lvalue-put! lvalue number-tag number)
- (if (lvalue/source? lvalue)
- number
- (apply min
- (cons number
- (map (lambda (link)
- (cond ((not (lvalue-marked? link))
- (let ((low
- (loop link
- lvalue
- (allocate-number!))))
- (if (<= number low)
- (articulation-point! lvalue))
- low))
- ((eq? link parent)
- number)
- (else
- (lvalue-get link number-tag))))
- (lvalue-initial-backward-links lvalue)))))))))
- (set! articulation-points
- (sort (delq! lvalue articulation-points)
- (lambda (x y)
- (< (lvalue-get x number-tag) (lvalue-get y number-tag)))))
- (for-each (lambda (lvalue) (lvalue-remove! lvalue number-tag))
- (cons lvalue (lvalue-backward-links lvalue)))
- articulation-points))
-
-|#
\ No newline at end of file
+ (block-bound-variables reference-block))))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: proced.scm,v 4.21 2001/10/22 19:04:50 cph Exp $
+$Id: proced.scm,v 4.22 2001/10/22 19:10:46 cph Exp $
Copyright (c) 1988-1990, 1999, 2001 Massachusetts Institute of Technology
;;; package: (compiler)
(declare (usual-integrations))
-\f
+
(define-rvalue procedure
type ;either PROCEDURE or a continuation type
block ;model of invocation environment [block]
(let ((number-required (length (procedure-required procedure))))
(and (>= argument-count number-required)
(if (procedure-rest procedure)
- true
+ #t
(<= argument-count
(+ number-required
(length (procedure-optional procedure))))))))
#| -*-Scheme-*-
-$Id: rvalue.scm,v 4.7 1999/01/02 06:06:43 cph Exp $
+$Id: rvalue.scm,v 4.8 2001/10/22 19:13:04 cph Exp $
-Copyright (c) 1988, 1989, 1999 Massachusetts Institute of Technology
+Copyright (c) 1988-1989, 1999, 2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
|#
;;;; Right (Hand Side) Values
+;;; package: (compiler)
(declare (usual-integrations))
\f
;;; converted to a macro.
;;; (define (make-rvalue tag . extra)
-;;; (list->vector (cons* tag false extra)))
+;;; (list->vector (cons* tag #f extra)))
(define-enumeration rvalue-type
(block
(if (rvalue/reference? rvalue*)
(eq? rvalue (lvalue-known-value (reference-lvalue rvalue*)))
(eq? rvalue rvalue*))))
-\f
+
;;;; Constant
(define-rvalue constant
(define (reference-to-known-location? reference)
(variable-in-known-location? (reference-context reference)
(reference-lvalue reference)))
-\f
+
;;; This type is only important while we use the `unassigned?' special
;;; form to perform optional argument defaulting. When we switch over
;;; to the new optional argument proposal we can flush this since the
(define-integrable (rvalue/unassigned-test? rvalue)
(eq? (tagged-vector/tag rvalue) unassigned-test-tag))
-\f
+
;;;; Expression
(define-rvalue expression
(let ((expression
(make-rvalue expression-tag block continuation
(node->edge (cfg-entry-node scfg))
- (generate-label 'EXPRESSION) false)))
+ (generate-label 'EXPRESSION) #f)))
(set! *expressions* (cons expression *expressions*))
(set-block-procedure! block expression)
expression))
projects / mit-scheme.git / commitdiff