#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn2.scm,v 1.17 1990/01/22 03:01:34 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn2.scm,v 1.18 1990/02/02 18:37:22 cph Rel $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
;; desirable because the register will be used again.
;; Otherwise, this is the last use of this register, so we
;; might as well just use the register's home.
- (if (and (dead-register? register)
- (register-saved-into-home? register))
+ (if (and (register-saved-into-home? register)
+ (or (dead-register? register)
+ (not (allocate-register-without-unload?
+ *register-map*
+ preferred-type
+ *needed-registers*))))
(pseudo-register-home register)
(reference-alias-register! register preferred-type)))))
(let ((no-preference
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/regmap.scm,v 4.9 1990/01/18 22:42:10 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/regmap.scm,v 4.10 1990/02/02 18:37:27 cph Rel $
Copyright (c) 1988, 1990 Massachusetts Institute of Technology
(make-register-map (map-entries:replace map
entry
(let ((home (map-entry-home entry)))
- (make-map-entry home (not home)
+ (make-map-entry home
+ (not home)
(list alias))))
(map-registers:add* map
;; **** Kludge -- again, EQ? is
(and (map-entry-home entry)
(map-entry-saved-into-home? entry)
(reallocate-alias entry))))))
+
+(define (allocate-register-without-spill? map type needed-registers)
+ ;; True iff a register of `type' can be allocated without saving any
+ ;; registers into their homes.
+ (or (free-register-exists? map type needed-registers)
+ (map-entries:search map
+ (lambda (entry)
+ (let ((alias (map-entry:find-alias entry type needed-registers)))
+ (and alias
+ (free-register-exists?
+ map
+ (if (register-types-compatible? type false) false type)
+ (cons alias needed-registers))))))))
+
+(define (free-register-exists? map type needed-registers)
+ ;; True iff a register of `type' can be allocated without first
+ ;; saving its contents.
+ (or (allocate-register-without-unload? map type needed-registers)
+ (map-entries:search map
+ (lambda (entry)
+ (and (map-entry-home entry)
+ (map-entry-saved-into-home? entry)
+ (map-entry:find-alias entry type needed-registers))))))
+
+(define (allocate-register-without-unload? map type needed-registers)
+ ;; True iff a register of `type' can be allocated without displacing
+ ;; any pseudo-registers from the register map.
+ (or (list-search-positive (map-registers map)
+ (lambda (alias)
+ (and (register-type? alias type)
+ (not (memv alias needed-registers)))))
+ (map-entries:search map
+ (lambda (entry)
+ (and (map-entry:find-alias entry type needed-registers)
+ (or (not (map-entry-home entry))
+ (not (null? (cdr (map-entry-aliases entry))))))))))
\f
;;;; Allocator Operations
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.14 1989/10/26 07:35:44 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.15 1990/02/02 18:38:09 cph Rel $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define-integrable (node/virtual-return? node)
(eq? (tagged-vector/tag node) virtual-return-tag))
+(define-integrable (virtual-return/target-lvalue return)
+ (cfg-node-get return virtual-return/target-lvalue/tag))
+
+(define-integrable (set-virtual-return/target-lvalue! return lvalue)
+ (cfg-node-put! return virtual-return/target-lvalue/tag lvalue))
+
+(define virtual-return/target-lvalue/tag
+ "target-lvalue")
+
(define (make-push block rvalue)
(make-virtual-return block
(virtual-continuation/make block continuation-type/push)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.12 1990/01/18 22:42:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.13 1990/02/02 18:38:12 cph Rel $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(define (write-instructions thunk)
(fluid-let ((*show-instruction* write)
- (*unparser-radix* 16))
+ (*unparser-radix* 16)
+ (*unparse-uninterned-symbols-by-name?* true))
(thunk)))
(define (pp-instructions thunk)
(fluid-let ((*show-instruction* pretty-print)
(*pp-primitives-by-name* false)
- (*unparser-radix* 16))
+ (*unparser-radix* 16)
+ (*unparse-uninterned-symbols-by-name?* true))
(thunk)))
(define *show-instruction*)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.16 1989/10/26 07:35:56 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.17 1990/02/02 18:38:16 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
stack-overwrite-target?
;true iff variable is the target of a stack overwrite
indirection ;alias for this variable [variable or #f]
+ source-node ;virtual-return that initializes this variable, or #f
)
(define continuation-variable/type variable-in-cell?)
(define (make-variable block name)
(make-lvalue variable-tag block name '() false false '() false false
- false false))
+ false false false))
(define variable-assoc
(association-procedure eq? variable-name))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.23 1989/10/26 07:36:21 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.24 1990/02/02 18:38:34 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(scode/assignment-components expression
(lambda (name value)
(if (continuation/effect? continuation)
- (generate/assignment* make-assignment find-name 'ASSIGNMENT-CONTINUE
- block continuation expression name value)
+ (generate/assignment* make-assignment
+ find-name
+ 'ASSIGNMENT-CONTINUE
+ block
+ continuation
+ expression
+ name
+ value)
(generate/combination
block
continuation
- (let ((old-value-temp (generate-uninterned-symbol))
- (new-value-temp (generate-uninterned-symbol)))
- (scode/make-let (list old-value-temp new-value-temp)
- (list (scode/make-safe-variable name) value)
- (scode/make-assignment
- name
- (scode/make-variable new-value-temp))
- (scode/make-variable old-value-temp))))))))
-\f
+ (let ((old-value (generate-uninterned-symbol))
+ (new-value (generate-uninterned-symbol)))
+ (scode/make-let (list new-value)
+ (list value)
+ (scode/make-let (list old-value)
+ (list (scode/make-safe-variable name))
+ (scode/make-assignment name (scode/make-variable new-value))
+ (scode/make-variable old-value)))))))))
+
(define (generate/definition block continuation expression)
(scode/definition-components expression
(lambda (name value)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.13 1989/10/26 07:36:55 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.14 1990/02/02 18:38:54 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(order-subproblems/out-of-line application subproblems rest)))
((RETURN)
(values
- (linearize-subproblems! continuation-type/effect subproblems rest)
+ (linearize-subproblems! continuation-type/effect subproblems '() rest)
subproblems))
(else
(error "Unknown application type" application))))
\f
-(define (linearize-subproblems! continuation-type subproblems rest)
+(define (linearize-subproblems! continuation-type subproblems alist rest)
(set-subproblem-types! subproblems continuation-type)
- (linearize-subproblems subproblems rest))
+ (linearize-subproblems subproblems alist rest))
-(define (linearize-subproblem! continuation-type subproblem rest)
+(define (linearize-subproblem! continuation-type subproblem lvalue rest)
(set-subproblem-type! subproblem continuation-type)
- (linearize-subproblem subproblem rest))
+ (linearize-subproblem subproblem lvalue rest))
-(define (linearize-subproblems subproblems rest)
+(define (linearize-subproblems subproblems alist rest)
(let loop ((subproblems subproblems))
(if (null? subproblems)
rest
(linearize-subproblem (car subproblems)
+ (let ((entry (assq (car subproblems) alist)))
+ (and entry
+ (cdr entry)))
(loop (cdr subproblems))))))
-(define (linearize-subproblem subproblem rest)
+(define (linearize-subproblem subproblem lvalue rest)
(let ((continuation (subproblem-continuation subproblem))
(prefix (subproblem-prefix subproblem)))
(if (subproblem-canonical? subproblem)
(if (eq? continuation-type/effect
(virtual-continuation/type continuation))
(make-null-cfg)
- (make-virtual-return (virtual-continuation/context continuation)
- continuation
- (subproblem-rvalue subproblem)))
+ (let ((cfg
+ (make-virtual-return
+ (virtual-continuation/context continuation)
+ continuation
+ (subproblem-rvalue subproblem))))
+ (if lvalue
+ (let ((node (cfg-entry-node cfg)))
+ (set-variable-source-node! lvalue node)
+ (set-virtual-return/target-lvalue! node lvalue)))
+ cfg))
rest)))))
\f
(define (order-subproblems/inline combination subproblems rest)
(values
(linearize-subproblem! continuation-type/effect
operator
- (linearize-subproblems simple rest))
+ false
+ (linearize-subproblems simple
+ '()
+ rest))
(cons operator simple)))
(let ((push-set (cdr complex))
(value-set (cons (car complex) simple)))
(linearize-subproblem!
continuation-type/effect
operator
+ false
(linearize-subproblems
push-set
+ '()
(linearize-subproblems
value-set
+ '()
(scfg*node->node!
(scfg*->scfg!
(reverse!
subproblems))
\f
(define (order-subproblems/out-of-line combination subproblems rest)
- (with-values
- (combination-ordering (combination/context combination)
- (car subproblems)
- (cdr subproblems)
- (combination/model combination))
- (lambda (effect-subproblems push-subproblems)
- (set-combination/frame-size! combination (length push-subproblems))
- (with-values
- (lambda ()
- (order-subproblems/maybe-overwrite-block
- combination push-subproblems rest
- (lambda ()
- (values (linearize-subproblems! continuation-type/push
- push-subproblems
- rest)
- push-subproblems))))
- (lambda (cfg push-subproblem-order)
- (values (linearize-subproblems! continuation-type/effect
- effect-subproblems
- cfg)
- (append effect-subproblems push-subproblem-order)))))))
+ (let ((alist (add-defaulted-subproblems! combination subproblems)))
+ (with-values
+ (combination-ordering (combination/context combination)
+ (car subproblems)
+ (cdr subproblems)
+ (combination/model combination))
+ (lambda (effect-subproblems push-subproblems)
+ (set-combination/frame-size! combination (length push-subproblems))
+ (with-values
+ (lambda ()
+ (order-subproblems/maybe-overwrite-block
+ combination push-subproblems rest alist
+ (lambda ()
+ (values (linearize-subproblems! continuation-type/push
+ push-subproblems
+ alist
+ rest)
+ push-subproblems))))
+ (lambda (cfg push-subproblem-order)
+ (values (linearize-subproblems! continuation-type/effect
+ effect-subproblems
+ alist
+ cfg)
+ (append effect-subproblems push-subproblem-order))))))))
+(define (add-defaulted-subproblems! combination subproblems)
+ (let ((model (combination/model combination)))
+ (if (and model
+ (rvalue/procedure? model)
+ (stack-block? (procedure-block model))
+ (or (procedure-always-known-operator? model)
+ (not (procedure-rest model))))
+ (let ((n-unassigned
+ (let ((n-supplied (length (cdr subproblems)))
+ (n-required
+ (length (cdr (procedure-original-required model)))))
+ (let ((n-expected
+ (+ n-required
+ (length (procedure-original-optional model)))))
+ (if (or (< n-supplied n-required)
+ (and (> n-supplied n-expected)
+ (not (procedure-rest model))))
+ (warn "wrong number of arguments"
+ n-supplied
+ (error-irritant/noise char:newline)
+ (error-irritant/noise "in call to procedure")
+ (procedure-name model)
+ (error-irritant/noise char:newline)
+ (error-irritant/noise
+ "minimum/maximum number of arguments:")
+ n-required
+ n-expected))
+ (- n-expected n-supplied))))
+ (parallel (application-parallel-node combination)))
+ (if (positive? n-unassigned)
+ (set-parallel-subproblems!
+ parallel
+ (append! subproblems
+ (make-unassigned-subproblems
+ (combination/context combination)
+ n-unassigned
+ '()))))
+ (map (lambda (variable subproblem)
+ (cons subproblem variable))
+ (append (cdr (procedure-original-required model))
+ (procedure-original-optional model))
+ (cdr (parallel-subproblems parallel))))
+ '())))
+\f
(define (combination-ordering context operator operands model)
(let ((standard
(lambda ()
(with-values
(lambda ()
(sort-subproblems/out-of-line operands callee))
- (lambda (n-unassigned integrated non-integrated)
+ (lambda (integrated non-integrated)
(handle-operator context
operator
(operator-needed? (subproblem-rvalue operator))
integrated
- (make-unassigned-subproblems context
- n-unassigned
- non-integrated)))))
+ non-integrated))))
(define (known-combination-ordering context operator operands procedure)
(if (and (not (procedure/closure? procedure))
(and (procedure/closure? procedure)
(closure-procedure-needs-operator? procedure)))
'()
- (make-unassigned-subproblems
- context
- (let ((n-supplied (length operands))
- (n-required
- (length (cdr (procedure-original-required procedure))))
- (n-optional (length (procedure-original-optional procedure))))
- (let ((n-expected (+ n-required n-optional)))
- (if (or (< n-supplied n-required) (> n-supplied n-expected))
- (error "known-combination-ordering: wrong number of arguments"
- procedure n-supplied n-expected))
- (- n-expected n-supplied)))
- (reverse operands))))
+ (reverse operands)))
(define (handle-operator context operator operator-needed? effect push)
(if operator-needed?
all-subproblems
'()
'()))
- (lambda (required subproblems integrated non-integrated)
- (let ((unassigned-count 0))
- (if (not (null? required))
- (begin
- ;; This is a wrong number of arguments case, so the code
- ;; we generate will not be any good.
- ;; The missing arguments are defaulted.
- (error "sort-subproblems/out-of-line: Too few arguments"
- callee all-subproblems)
- ;; This does not take into account potential integrated
- ;; required parameters, but they better not be integrated
- ;; if they are not always provided!
- (set! unassigned-count (length required))))
- (with-values
- (lambda ()
- (sort-integrated (procedure-original-optional callee)
- subproblems
- integrated
- non-integrated))
- (lambda (optional subproblems integrated non-integrated)
- (let ((rest (procedure-original-rest callee)))
- (cond ((not (null? optional))
- (values (if rest
- 0 ; unassigned-count might work too
- ;; In this case the caller will
- ;; make slots for the optionals.
- (+ unassigned-count
- (length
- (list-transform-negative optional
- lvalue-integrated?))))
- integrated
- non-integrated))
- ((and (not (null? subproblems)) (not rest))
- (error "sort-subproblems/out-of-line: Too many arguments"
- callee all-subproblems)
- ;; This is a wrong number of arguments case, so
- ;; the code we generate will not be any good.
- ;; The extra arguments are dropped! Note that in
- ;; this case unassigned-count should be 0, since
- ;; we cannot have both too many and too few
- ;; arguments simultaneously.
- (values unassigned-count
+ (lambda (subproblems integrated non-integrated)
+ (with-values
+ (lambda ()
+ (sort-integrated (procedure-original-optional callee)
+ subproblems
integrated
non-integrated))
- ((and rest (variable-unused? rest))
- (values unassigned-count
- (append! (reverse subproblems) integrated)
- non-integrated))
- (else
- (values unassigned-count
- integrated
- (append! (reverse subproblems)
- non-integrated)))))))))))
+ (lambda (subproblems integrated non-integrated)
+ (let ((rest (procedure-original-rest callee)))
+ (cond ((and (not (null? subproblems)) (not rest))
+ ;; This is a wrong number of arguments case, so
+ ;; the code we generate will not be any good.
+ ;; The extra arguments are dropped!
+ (values integrated
+ non-integrated))
+ ((and rest (variable-unused? rest))
+ (values (append! (reverse subproblems) integrated)
+ non-integrated))
+ (else
+ (values integrated
+ (append! (reverse subproblems)
+ non-integrated))))))))))
\f
(define (sort-integrated lvalues subproblems integrated non-integrated)
- (cond ((or (null? lvalues) (null? subproblems))
- (values lvalues subproblems integrated non-integrated))
+ (cond ((null? lvalues)
+ (values subproblems integrated non-integrated))
+ ((null? subproblems)
+ (error "sort-integrated: not enough subproblems" lvalues))
((variable-unused? (car lvalues))
(sort-integrated (cdr lvalues)
(cdr subproblems)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/reuse.scm,v 1.4 1989/10/26 07:37:03 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/reuse.scm,v 1.5 1990/02/02 18:38:59 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
applications))
(define (order-subproblems/maybe-overwrite-block combination subproblems rest
- if-no-overwrite)
+ alist if-no-overwrite)
(let ((caller-block (combination/block combination))
;; This reduces code size.
(if-no-overwrite (lambda () (if-no-overwrite))))
non-terminal-nodes
rest))
(lambda (cfg subproblem-ordering)
- (let ((cfg (linearize-subproblems!
- continuation-type/push
- extra-subproblems
- cfg)))
- (values
- cfg
- (append extra-subproblems subproblem-ordering))))))
+ (values
+ (linearize-subproblems! continuation-type/push
+ extra-subproblems
+ alist
+ cfg)
+ (append extra-subproblems subproblem-ordering)))))
(if-no-overwrite))))
(if-no-overwrite)))))
continuation-type/register
continuation-type/push)
(node-value (car nodes))
+ false
(generate-assignments (cdr nodes)
(overwrite (car nodes) rest))))
(else
rest)
(linearize-subproblem! continuation-type/register
(node-value node)
+ false
(overwrite node rest))))
(define (node/noop? node)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.27 1990/01/22 23:45:02 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.28 1990/02/02 18:39:20 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
show-rtl
write-rtl-instructions)
(import (runtime pretty-printer)
- *pp-primitives-by-name*))
+ *pp-primitives-by-name*)
+ (import (runtime unparser)
+ *unparse-uninterned-symbols-by-name?*))
(define-package (compiler pattern-matcher/lookup)
(files "base/pmlook")
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.25 1990/01/18 22:43:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.26 1990/02/02 18:39:26 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(filename/append "machines/bobcat" "machin"))
(rtl-base
(filename/append "rtlbase"
- "regset" "rgraph" "rtlcfg" "rtlobj"
- "rtlreg" "rtlty1" "rtlty2"))
+ "rgraph" "rtlcfg" "rtlobj" "rtlreg" "rtlty1"
+ "rtlty2"))
(cse-base
(filename/append "rtlopt"
"rcse1" "rcse2" "rcseep" "rcseht" "rcserq" "rcsesr"))
(define-integration-dependencies "machines/bobcat" "machin" "rtlbase"
"rtlreg" "rtlty1" "rtlty2")
- (define-integration-dependencies "rtlbase" "regset" "base")
(define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2")
(define-integration-dependencies "rtlbase" "rgraph" "machines/bobcat"
"machin")
(file-dependency/integration/join cse-base cse-base)
- (define-integration-dependencies "rtlopt" "rcseht" "base" "object")
- (define-integration-dependencies "rtlopt" "rcserq" "base" "object")
+ (file-dependency/integration/join
+ (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife")
+ (filename/append "rtlbase" "regset"))
+
+ (file-dependency/integration/join
+ (filename/append "rtlopt" "rcseht" "rcserq")
+ (filename/append "base" "object"))
+
(define-integration-dependencies "rtlopt" "rlife" "base" "cfg2")
(let ((dependents
(define-integration-dependencies "back" "lapgn1" "base"
"cfg1" "cfg2" "utils")
(define-integration-dependencies "back" "lapgn1" "rtlbase"
- "regset" "rgraph" "rtlcfg")
+ "rgraph" "rtlcfg")
(define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg")
(define-integration-dependencies "back" "lapgn3" "rtlbase" "rtlcfg")
(define-integration-dependencies "back" "linear" "base" "cfg1" "cfg2")
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.65 1990/01/22 23:45:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.66 1990/02/02 18:39:31 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
((package/reference (find-package name) 'INITIALIZE-PACKAGE!)))
'((COMPILER MACROS)
(COMPILER DECLARATIONS)))
-(add-system! (make-system "Liar (Motorola MC68020)" 4 65 '()))
\ No newline at end of file
+(add-system! (make-system "Liar (Motorola MC68020)" 4 66 '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/regset.scm,v 1.2 1988/06/14 08:36:51 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/regset.scm,v 1.3 1990/02/02 18:39:46 cph Rel $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(declare (usual-integrations))
\f
+(define-integrable (make-regset n-registers)
+ (make-bit-string n-registers false))
+
+(define (for-each-regset-member regset procedure)
+ (let ((end (bit-string-length regset)))
+ (let loop ((start 0))
+ (let ((register (bit-substring-find-next-set-bit regset start end)))
+ (if register
+ (begin
+ (procedure register)
+ (loop (1+ register))))))))
+
+(define (regset->list regset)
+ (let ((end (bit-string-length regset)))
+ (let loop ((start 0))
+ (let ((register (bit-substring-find-next-set-bit regset start end)))
+ (if register
+ (cons register (loop (1+ register)))
+ '())))))
+
+(define-integrable (regset-clear! regset)
+ (bit-string-fill! regset false))
+
+(define-integrable (regset-disjoint? x y)
+ (regset-null? (regset-intersection x y)))
+
+(define-integrable regset-allocate bit-string-allocate)
+(define-integrable regset-adjoin! bit-string-set!)
+(define-integrable regset-delete! bit-string-clear!)
+(define-integrable regset-member? bit-string-ref)
+(define-integrable regset=? bit-string=?)
+(define-integrable regset-null? bit-string-zero?)
+
+(define-integrable regset-copy! bit-string-move!)
+(define-integrable regset-union! bit-string-or!)
+(define-integrable regset-difference! bit-string-andc!)
+(define-integrable regset-intersection! bit-string-and!)
+
+(define-integrable regset-copy bit-string-copy)
+(define-integrable regset-union bit-string-or)
+(define-integrable regset-difference bit-string-andc)
+(define-integrable regset-intersection bit-string-and)
+\f
+#| Alternate representation.
+
(define-integrable (make-regset n-registers)
n-registers
(list 'REGSET))
(define-integrable (regset->list regset)
(list-copy (cdr regset)))
-(define-integrable regset-copy list-copy)
-
(define-integrable (regset-clear! regset)
(set-cdr! regset '()))
(define (regset-intersection! destination source)
(set-cdr! destination (eq-set-intersection (cdr source) (cdr destination))))
+(define-integrable regset-copy list-copy)
+
(define-integrable (regset-union x y)
(cons 'REGSET (eq-set-union (cdr x) (cdr y))))
(define-integrable (regset-intersection x y)
(cons 'REGSET (eq-set-intersection (cdr x) (cdr y))))
-\f
-#| Alternate representation.
-
-(define-integrable (make-regset n-registers)
- (make-bit-string n-registers false))
-
-(define (for-each-regset-member regset procedure)
- (let ((end (bit-string-length regset)))
- (define (loop register)
- (if register
- (begin (procedure register)
- (loop (bit-substring-find-next-set-bit regset
- (1+ register)
- end)))))
- (loop (bit-substring-find-next-set-bit regset 0 end))))
-
-(define (regset->list regset)
- (let ((end (bit-string-length regset)))
- (define (loop register)
- (if register
- (cons register
- (loop (bit-substring-find-next-set-bit regset
- (1+ register)
- end)))
- '()))
- (loop (bit-substring-find-next-set-bit regset 0 end))))
-
-(define (regset-copy regset)
- (let ((result (bit-string-allocate (bit-string-length regset))))
- (regset-copy! result regset)
- result))
-
-(define-integrable (regset-clear! regset)
- (bit-string-fill! regset false))
-
-(define-integrable (regset-disjoint? x y)
- (regset-null? (regset-intersection x y)))
-
-(define-integrable regset-allocate bit-string-allocate)
-(define-integrable regset-adjoin! bit-string-set!)
-(define-integrable regset-delete! bit-string-clear!)
-(define-integrable regset-member? bit-string-ref)
-(define-integrable regset=? bit-string=?)
-(define-integrable regset-null? bit-string-zero?)
-(define-integrable regset-copy! bit-string-move!)
-(define-integrable regset-union! bit-string-or!)
-(define-integrable regset-difference! bit-string-andc!)
-(define-integrable regset-intersection! bit-string-and!)
-
-(package (regset-union regset-difference regset-intersection)
- (let ((wrap-operator
- (lambda (operator)
- (lambda (x y)
- (let ((result (regset-copy x)))
- (operator result y)
- result)))))
- (define-export regset-union (wrap-operator regset-union!))
- (define-export regset-difference (wrap-operator regset-difference!))
- (define-export regset-intersection (wrap-operator regset-intersection!))))
|#
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.9 1989/11/21 22:21:12 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.10 1990/02/02 18:40:00 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(lambda (min max)
(if (open-procedure-needs-dynamic-link? procedure)
(scfg*scfg->scfg!
- (rtl:make-procedure-header (procedure-label procedure)
- (1+ min) (-1+ max))
+ (rtl:make-procedure-header
+ (procedure-label procedure)
+ (1+ min)
+ (-1+ max))
(rtl:make-pop-link))
(rtl:make-procedure-header (procedure-label procedure)
min max)))))
(scfg*->scfg! (map cellify-variable variables)))
(define (cellify-variable variable)
- (if (variable-in-cell? variable)
+ (if (and (variable-in-cell? variable)
+ (not (and (variable-source-node variable)
+ (procedure-inline-code? procedure))))
(let ((locative
(let ((register (variable/register variable)))
(or register
- (stack-locative-offset (rtl:make-fetch register:stack-pointer)
- (variable-offset block variable))))))
+ (stack-locative-offset
+ (rtl:make-fetch register:stack-pointer)
+ (variable-offset block variable))))))
(rtl:make-assignment
locative
(rtl:make-cell-cons (rtl:make-fetch locative))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.11 1990/01/18 22:47:15 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.12 1990/02/02 18:40:04 cph Exp $
Copyright (c) 1988, 1990 Massachusetts Institute of Technology
(load-temporary-register scfg*scfg->scfg!
(rtl:make-assignment-cache name)
(lambda (cell)
- (let ((contents (rtl:make-fetch cell)))
- (let ((n2 (rtl:make-type-test (rtl:make-object->type contents)
- (ucode-type reference-trap)))
- (n3 (rtl:make-unassigned-test contents))
- (n4 (rtl:make-assignment cell value))
- (n5
- (load-temporary-register scfg*scfg->scfg! value
- (lambda (value)
+ (load-temporary-register scfg*scfg->scfg! value
+ (lambda (value)
+ (let ((contents (rtl:make-fetch cell)))
+ (let ((n2 (rtl:make-type-test (rtl:make-object->type contents)
+ (ucode-type reference-trap)))
+ (n3 (rtl:make-unassigned-test contents))
+ (n4 (rtl:make-assignment cell value))
+ (n5
(wrap-with-continuation-entry
context
- (rtl:make-interpreter-call:cache-assignment cell value)))))
- ;; Copy prevents premature control merge which confuses CSE
- (n6 (rtl:make-assignment cell value)))
- (pcfg-consequent-connect! n2 n3)
- (pcfg-alternative-connect! n2 n4)
- (pcfg-consequent-connect! n3 n6)
- (pcfg-alternative-connect! n3 n5)
- (make-scfg (cfg-entry-node n2)
- (hooks-union (scfg-next-hooks n4)
- (hooks-union (scfg-next-hooks n5)
- (scfg-next-hooks n6)))))))))
+ (rtl:make-interpreter-call:cache-assignment cell value)))
+ ;; Copy prevents premature control merge which confuses CSE
+ (n6 (rtl:make-assignment cell value)))
+ (pcfg-consequent-connect! n2 n3)
+ (pcfg-alternative-connect! n2 n4)
+ (pcfg-consequent-connect! n3 n6)
+ (pcfg-alternative-connect! n3 n5)
+ (make-scfg (cfg-entry-node n2)
+ (hooks-union
+ (scfg-next-hooks n4)
+ (hooks-union (scfg-next-hooks n5)
+ (scfg-next-hooks n6)))))))))))
(define (generate/definition definition)
(let ((context (definition-context definition))
((rvalue/continuation? operand)
;; This is a pun set up by the FG generator.
(generate/continuation-cons operand))
+ ((let ((variable (virtual-return/target-lvalue return)))
+ (and variable
+ (variable-in-cell? variable)
+ (procedure-inline-code?
+ (block-procedure (variable-block variable)))))
+ (generate/rvalue operand scfg*scfg->scfg!
+ (lambda (expression)
+ (rtl:make-push (rtl:make-cell-cons expression)))))
(else
(operand->push operand))))
(else
(generate/rvalue operand scfg*scfg->scfg!
(lambda (expression)
(rtl:make-assignment register expression))))
-
+\f
(define (load-temporary-register receiver expression generator)
(let ((temporary (rtl:make-pseudo-register)))
;; Force assignment to be made before `generator' is called. This
(scfg*scfg->scfg!
extra
(rtl:make-push-return (continuation/label continuation)))))))
-\f
+
(define (generate/pop pop)
(rtl:make-pop (continuation*/register (pop-continuation pop))))
projects / mit-scheme.git / commitdiff