#| -*-Scheme-*-
-$Id: proced.scm,v 4.20 1999/01/02 06:06:43 cph Exp $
+$Id: proced.scm,v 4.21 2001/10/22 19:04:50 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.
|#
;;;; Procedure datatype
name ;name of procedure [symbol]
required ;list of required parameters [variables]
optional ;list of optional parameters [variables]
- rest ;"rest" parameter, if any [variable or false]
+ rest ;"rest" parameter, if any [variable or #f]
names ;list of internal letrec names [variables]
values ;list of internal letrec values [rvalues]
entry-edge ;body of procedure [cfg edge]
closure-context ;for closure, where procedure is closed [block]
closure-offset ;for closure, offset of procedure in stack frame
register ;for continuation, argument register
- closure-size ;for closure, virtual size of frame [integer or false]
+ closure-size ;for closure, virtual size of frame [integer or #f]
target-block ;where procedure is "really" closed [block]
initial-callees ;procs. invoked by me directly
(free-callees ;procs. invoked by means of free variables (1)
'()) ;initial continuation/combinations
(generate-label name)
'() ;applications
- false ;always-known-operator?
- false ;closure-cons
- false ;closure-context
- false ;closure-offset
- false ;register
- false ;closure-size
- false ;target-block
+ #f ;always-known-operator?
+ #f ;closure-cons
+ #f ;closure-context
+ #f ;closure-offset
+ #f ;register
+ #f ;closure-size
+ #f ;target-block
'() ;initial-callees
'() ;[free-]callees
'() ;[free-]callers
- false ;virtual-closure?
+ #f ;virtual-closure?
'() ;closure-reasons
'() ;variables or side-effects
'() ;alist
- false ;debugging-info
+ #f ;debugging-info
)))
(set! *procedures* (cons procedure *procedures*))
(set-block-procedure! block procedure)
(let ((applications (delq! application (procedure-applications procedure))))
(set-procedure-applications! procedure applications)
(if (null? applications)
- (set-procedure-always-known-operator?! procedure false))))
+ (set-procedure-always-known-operator?! procedure #f))))
(define (procedure-get procedure key)
(let ((entry (assq key (procedure-alist procedure))))
(if entry
(set-cdr! entry item)
(set-procedure-alist! procedure
- (cons (cons key item) (procedure-alist procedure))))))
+ (cons (cons key item)
+ (procedure-alist procedure))))))
(define (procedure-remove! procedure key)
(set-procedure-alist! procedure (del-assq! key (procedure-alist procedure))))
((IC) 'IC)
((CLOSURE) (error "Illegal occurrence of CLOSURE block" procedure))
(else (error "Unknown block type" block)))))
-\f
+
(define-integrable (procedure/ic? procedure)
(ic-block? (procedure-block procedure)))
(and (procedure/closure? procedure)
(procedure/trivial-closure? procedure))))
\f
-(define (add-closure-reason! procedure reason1 reason2)
- (let ((reasons (procedure-closure-reasons procedure)))
- (let ((slot (assq reason1 reasons)))
- (cond ((false? slot)
- (set-procedure-closure-reasons!
- procedure
- (cons (cons reason1
- (if (false? reason2)
- '()
- (list reason2)))
- reasons)))
- ((and (not (false? reason2))
- (not (memq reason2 (cdr slot))))
- (set-cdr! slot (cons reason2 (cdr slot))))))))
+;;;; Closure reasons
;; The possible reasons are
;;
-;; - passed-out : procedure is available from outside block
-;; (usually an upwards funarg).
+;; PASSED-OUT: Procedure is available from outside block (usually an
+;; upwards funarg).
;;
-;; - argument : procedure is given as an argument to a procedure does not
-;; share its lexical chain. Some of these cases of downward funargs
-;; could be stack allocated.
+;; ARGUMENT: Procedure is given as an argument to a procedure does not
+;; share its lexical chain. Some of these cases of downward funargs
+;; could be stack allocated.
;;
-;; - assignment: procedure is assigned to some variable outside its closing
-;; block.
+;; ASSIGNMENT: Procedure is assigned to some variable outside its
+;; closing block.
;;
-;; - contagion: procedure is called by some other closure.
+;; CONTAGION: Procedure is called by some other closure.
;;
-;; - compatibility: procedure is called from a location which may have more
-;; than one operator, but the complete set of possibilities is known and
-;; they are compatible closures.
+;; COMPATIBILITY: Procedure is called from a location which may have
+;; more than one operator, but the complete set of possibilities is
+;; known and they are compatible closures.
;;
-;; - apply-compatibility: procedure is called from a location which may have
-;; move than one operator, but the complete set of possibilities is now known
-;; or they are incompatible, so (internal) apply has to be used.
+;; APPLY-COMPATIBILITY: Procedure is called from a location which may
+;; have more than one operator, but the complete set of possibilities
+;; is now known or they are incompatible, so (internal) apply has to
+;; be used.
+
+(define (add-closure-reason! procedure keyword argument)
+ (let ((entries (procedure-closure-reasons procedure)))
+ (let ((entry (assq keyword entries)))
+ (if entry
+ (if (and argument (not (memq argument (cdr entry))))
+ (set-cdr! entry (cons argument (cdr entry))))
+ (set-procedure-closure-reasons! procedure
+ (cons (cons keyword
+ (if argument
+ (list argument)
+ '()))
+ entries))))))
(define (closure-procedure-needs-external-descriptor? procedure)
(let loop ((reasons (procedure-closure-reasons procedure)))
- (and (not (null? reasons))
+ (and (pair? reasons)
(or (memq (caar reasons)
'(PASSED-OUT ARGUMENT ASSIGNMENT
COMPATIBILITY APPLY-COMPATIBILITY))
(loop (cdr reasons))))))
(define (procedure-maybe-registerizable? procedure)
-;;; yields true if the procedure might be able to have some of its
-;;; parameters in registers. Note: This does not mean that the
-;;; procedure WILL have its parameters in registers, or that ALL its
-;;; parameters will be in registers. Which parameters will actually be
-;;; in registers depends on the procedure's argument subproblems, as
-;;; well as the parameter lvalues themselves.
- (and
- (procedure-always-known-operator? procedure)
- (procedure-application-unique? procedure)
- (procedure/virtually-open? procedure)
- (not (block-layout-frozen? (procedure-block procedure)))))
+ ;; Yields true if the procedure might be able to have some of its
+ ;; parameters in registers. Note: This does not mean that the
+ ;; procedure WILL have its parameters in registers, or that ALL its
+ ;; parameters will be in registers. Which parameters will actually
+ ;; be in registers depends on the procedure's argument subproblems,
+ ;; as well as the parameter lvalues themselves.
+ (and (procedure-always-known-operator? procedure)
+ (procedure-application-unique? procedure)
+ (procedure/virtually-open? procedure)
+ (not (block-layout-frozen? (procedure-block procedure)))))
projects / mit-scheme.git / commitdiff