#| -*-Scheme-*-
-$Id: compat.scm,v 1.10 1995/06/22 15:20:40 adams Exp $
+$Id: compat.scm,v 1.11 1995/08/06 19:55:45 adams Exp $
-Copyright (c) 1994 Massachusetts Institute of Technology
+Copyright (c) 1994-1995 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; Compatibility package
-;; Decides which parameters are passed on the stack. Primitives get all
-;; their parameters on the stack in an interpreter-like stack-frame.
-;; Procedures get some arguments in registers and the rest on the
-;; stack, with earlier arguments deeper to facilitate lexprs.
-;; The number of parameters passed in registers is determined by the
-;; back-end (*rtlgen/arguments-registers*)
+;;
+;; Decides which parameters are passed on the stack. Primitives get all
+;; their parameters on the stack in an interpreter-like stack-frame.
+;; Procedures get some arguments in registers and the rest on the
+;; stack, with earlier arguments deeper to facilitate lexprs. The
+;; number of parameters passed in registers is determined by the
+;; back-end (*rtlgen/argument-registers*)
;;; package: (compiler midend)
(let ((place (assq name env)))
(if (not place)
`(LOOKUP ,name)
- ;; Important to copy value so that different debugging info
- ;; can be attached to each copy, since each variable reference
- ;; might have had different debugging info.
+ ;; Important to copy value so that different debugging info can be
+ ;; attached to each copy, since each variable reference might
+ ;; have had different debugging info. Note: It is unlikely
+ ;; that a variable will have debuggig info this late phase
+ ;; sequence [SRA].
(form/copy (cadr place)))))
(define-compatibility-rewrite LAMBDA (env lambda-list body)
(define (compat/rewrite-lambda formals body formals-on-stack)
(define (compat/new-env frame-variable old-frame-vector new-frame-vector)
- ;; The new environment maps names to %stack-closure-refs and %vector-index
+ ;; The new environment maps names to %stack-closure-refs and layout
;; vectors to new, extended vectors
(let ((alist (map (lambda (name)
(list name
`(CALL (QUOTE ,%stack-closure-ref)
(QUOTE #F)
(LOOKUP ,frame-variable)
- (CALL (QUOTE ,%vector-index)
- (QUOTE #F)
- (QUOTE ,new-frame-vector)
- (QUOTE ,name))
+ (QUOTE ,new-frame-vector)
(QUOTE ,name))))
formals-on-stack)))
(if old-frame-vector
(define-rewrite/compat %invoke-continuation compat/standard-call-handler))
-(define-rewrite/compat %vector-index
+;;(define-rewrite/compat %vector-index
+;; (lambda (env rator cont rands)
+;; rator cont
+;; ;; rands = ('<vector> '<name>)
+;; ;; Copy, possibly replacing vector
+;; `(CALL (QUOTE ,%vector-index)
+;; (QUOTE #F)
+;; ,(compat/expr env
+;; (let ((vector-arg (first rands)))
+;; (if (QUOTE/? vector-arg)
+;; (cond ((assq (quote/text vector-arg) env)
+;; => (lambda (old.new)
+;; `(QUOTE ,(second old.new))))
+;; (else vector-arg))
+;; (internal-error
+;; "Illegal (unquoted) %vector-index arguments"
+;; rands))))
+;; ,(compat/expr env (second rands)))))
+
+(define-rewrite/compat %stack-closure-ref
(lambda (env rator cont rands)
rator cont
- ;; rands = ('<vector> '<name>)
+ ;; rands = (<frame> '<vector> '<name>)
;; Copy, possibly replacing vector
- `(CALL (QUOTE ,%vector-index)
+ `(CALL (QUOTE ,%stack-closure-ref)
(QUOTE #F)
+ ,(compat/expr env (first rands))
,(compat/expr env
- (let ((vector-arg (first rands)))
+ (let ((vector-arg (second rands)))
(if (QUOTE/? vector-arg)
(cond ((assq (quote/text vector-arg) env)
=> (lambda (old.new)
`(QUOTE ,(second old.new))))
(else vector-arg))
(internal-error
- "Illegal (unquoted) %vector-index arguments"
+ "Illegal (unquoted) %stack-closure-ref vector"
rands))))
- ,(compat/expr env (second rands)))))
-
+ ,(compat/expr env (third rands)))))
\f
(define-rewrite/compat %make-heap-closure
;; The lambda expression in a heap closure is special the closure
(call ',%stack-closure-ref
'#F
(lookup frame)
- (call ',%vector-index '#F ',fv1 'save2)
+ ',fv1
'save2)
(lookup val2)
'1000)))
#| -*-Scheme-*-
-$Id: rtlgen.scm,v 1.32 1995/07/27 14:28:21 adams Exp $
+$Id: rtlgen.scm,v 1.33 1995/08/06 19:58:11 adams Exp $
Copyright (c) 1994-1995 Massachusetts Institute of Technology
(object (rtlgen/descriptor/object desc)))
(sample/1 '(rtlgen/procedures-by-kind histogram) kind)
(case kind
- ((CONTINUATION)
- (rtlgen/continuation label object))
- ((PROCEDURE)
- (rtlgen/procedure label object))
- ((CLOSURE)
- (rtlgen/closure label object))
- ((TRIVIAL-CLOSURE)
- (rtlgen/trivial-closure label object))
- (else
- (internal-error "Unknown object kind" desc)))))
+ ((CONTINUATION) (rtlgen/continuation label object))
+ ((PROCEDURE) (rtlgen/procedure label object))
+ ((CLOSURE) (rtlgen/closure label object))
+ ((TRIVIAL-CLOSURE) (rtlgen/trivial-closure label object))
+ (else (internal-error "Unknown object kind" desc)))))
(define (rtlgen/enqueue! desc)
(queue/enqueue! *rtlgen/object-queue* desc))
(define (tail-call? form)
(let ((cont (call/continuation form)))
(or (LOOKUP/? cont)
- (form/match rtlgen/stack-overwrite-pattern cont))))
+ (CALL/%stack-closure-ref? cont))))
(let ((unconditional? true)
(tail-call false)
(arg-position 0))
(cond ((or (null? rands) (>= arg-position max-index))
(default env names))
- ((form/match rtlgen/stack-overwrite-pattern (car rands))
- => (lambda (result)
- (let ((name (cadr (assq rtlgen/?var-name result)))
- (offset
- (- first-offset
- (cadr (assq rtlgen/?offset result)))))
- (if (or (memq name names)
- (memq arg-position register-arg-positions-used))
- (target (cdr rands) env names (+ arg-position 1))
- (let* ((home (rtlgen/argument-home arg-position))
- (reg (rtlgen/new-reg)))
- (rtlgen/emit!
- (list
- (rtlgen/read-stack-loc home offset)
- `(ASSIGN ,reg ,home)))
- (target (cdr rands)
- `(,(rtlgen/binding/make
- name
- reg
- (rtlgen/stack-offset offset))
- . ,env)
- (cons name names)
- (+ arg-position 1)))))))
+ ((CALL/%stack-closure-ref? (car rands))
+ (let ((name (quote/text (CALL/%stack-closure-ref/name (car rands))))
+ (offset
+ (- first-offset
+ (CALL/%stack-closure-ref/index (car rands)))))
+ (if (or (memq name names)
+ (memq arg-position register-arg-positions-used))
+ (target (cdr rands) env names (+ arg-position 1))
+ (let* ((home (rtlgen/argument-home arg-position))
+ (reg (rtlgen/new-reg)))
+ (rtlgen/emit!
+ (list
+ (rtlgen/read-stack-loc home offset)
+ `(ASSIGN ,reg ,home)))
+ (target (cdr rands)
+ `(,(rtlgen/binding/make
+ name
+ reg
+ (rtlgen/stack-offset offset))
+ . ,env)
+ (cons name names)
+ (+ arg-position 1))))))
(else
(target (cdr rands) env names (+ arg-position 1))))))))))
\f
(if (not (pair? expr))
(illegal expr))
(case (car expr)
- ((LET)
- (rtlgen/let/stmt state expr))
- ((CALL)
- (rtlgen/call/stmt state expr))
- ((IF)
- (rtlgen/if/stmt state expr))
- ((BEGIN)
- (rtlgen/begin/stmt state expr))
- ((LETREC)
- (rtlgen/letrec/stmt state expr))
+ ((LET) (rtlgen/let/stmt state expr))
+ ((CALL) (rtlgen/call/stmt state expr))
+ ((IF) (rtlgen/if/stmt state expr))
+ ((BEGIN) (rtlgen/begin/stmt state expr))
+ ((LETREC) (rtlgen/letrec/stmt state expr))
((QUOTE LOOKUP LAMBDA DECLARE)
(internal-error "Illegal statement" expr))
(else
;; This assumes that (a) it is the continuation variable and (b) it is at
;; the base of the frame.
(let ((offset
- (let ((offset (call/%stack-closure-ref/offset cont)))
- (if (and (QUOTE/? offset)
- (number? (quote/text offset)))
- (quote/text offset)
- (internal-error "Unexpected offset to %stack-closure-ref"
- offset)))))
+ (CALL/%stack-closure-ref/index cont)))
(rtlgen/bop-stack-pointer! offset)
false))
((CALL/%make-stack-closure? cont)
(elt-regs elt-regs (cdr elt-regs))
(elts elts (cdr elts)))
((null? elts))
- (let ((result (form/match rtlgen/stack-overwrite-pattern (car elts))))
- (cond ((and result
- (= (cadr (assq rtlgen/?offset result))
- frame-offset)))
+ (cond ((and (CALL/%stack-closure-ref? (car elts))
+ (CALL/%stack-closure-ref/index=? (car elts)
+ frame-offset)))
((and (zero? frame-offset)
(not (is-continuation-lookup? (car elts)))
(not (returning-with-stack-arguments?)))
(let* ((loc (or (car elt-regs)
(elt->reg (car elts)))))
(rtlgen/emit!/1
- (rtlgen/write-stack-loc loc stack-offset)))))))))
+ (rtlgen/write-stack-loc loc stack-offset))))))))
(cond ((not (or (is-continuation-stack-ref? (first elts))
(is-continuation-lookup? (first elts))
(if (not (pair? expr))
(illegal expr))
(case (car expr)
- ((LOOKUP)
- (rtlgen/lookup/expr state expr))
- ((QUOTE)
- (rtlgen/quote/expr state expr))
- ((CALL)
- (rtlgen/call/expr state expr))
- ((IF)
- (rtlgen/if/expr state expr))
- ((LET)
- (rtlgen/let/expr state expr))
+ ((LOOKUP) (rtlgen/lookup/expr state expr))
+ ((QUOTE) (rtlgen/quote/expr state expr))
+ ((CALL) (rtlgen/call/expr state expr))
+ ((IF) (rtlgen/if/expr state expr))
+ ((LET) (rtlgen/let/expr state expr))
((LAMBDA BEGIN LETREC DECLARE)
(internal-error "Illegal expression" expr))
- (else
- (illegal expr))))
+ (else (illegal expr))))
(define (rtlgen/expr* state exprs)
;; returns list of result-locations
(exact-integer? (rtlgen/constant-value syllable))
(rtlgen/constant-value syllable)))
+(define-integrable (rtlgen/vector-constant? syllable)
+ (and (rtlgen/constant? syllable)
+ (vector? (rtlgen/constant-value syllable))
+ (rtlgen/constant-value syllable)))
+
(define-open-coder/pred %small-fixnum? 2
(lambda (state rands open-coder)
open-coder ; ignored
(closure-tag (machine-tag 'COMPILED-ENTRY)))
(lambda (state rands open-coder)
open-coder ; ignored
- (let ((index (second rands)))
- (cond ((not (rtlgen/integer-constant? index))
- (internal-error "%heap-closure-ref with non-constant offset"
- rands))
- ((rtlgen/tagged-closures?)
- (rtlgen/fixed-selection state
- closure-tag
- (first rands)
- (+ offset
- (rtlgen/constant-value index))))
- (else
- (rtlgen/value-assignment
- state
- `(OFFSET ,(rtlgen/->register (first rands))
- (MACHINE-CONSTANT
- ,(+ offset (rtlgen/constant-value index)))))))))))
+ (let ((vector (rtlgen/vector-constant? (second rands)))
+ (name (third rands)))
+ (if (and vector
+ (rtlgen/constant? (third rands)))
+ (let ((index (vector-index vector (rtlgen/constant-value name))))
+ (if (rtlgen/tagged-closures?)
+ (rtlgen/fixed-selection state
+ closure-tag
+ (first rands)
+ (+ offset index))
+ (rtlgen/value-assignment
+ state
+ `(OFFSET ,(rtlgen/->register (first rands))
+ (MACHINE-CONSTANT
+ ,(+ offset index))))))
+ (internal-error "%heap-closure-ref: non-constant specifier"
+ rands))))))
;; NOTE: These do not use rtlgen/assign! because the length field
;; may not be an object, and the preservation code assumes that
(define-indexed-mutator 'PRIMITIVE-OBJECT-SET! false 0 3))
\f
(define-open-coder/stmt %heap-closure-set! 4
- (let ((offset (rtlgen/closure-first-offset)))
+ (let ((offset (rtlgen/closure-first-offset))
+ (closure-tag (machine-tag 'COMPILED-ENTRY)))
(lambda (state rands open-coder)
- state open-coder ; ignored
- (let ((index (second rands)))
- (cond ((not (rtlgen/constant? index))
- (internal-error "%heap-closure-set! with non-constant offset"
- rands))
- ((rtlgen/tagged-closures?)
- (rtlgen/fixed-mutation
- (list (first rands) (third rands))
- (+ offset (rtlgen/constant-value index))))
- (else
- (rtlgen/emit!/1
- `(ASSIGN (OFFSET ,(rtlgen/->register (car rands))
- (MACHINE-CONSTANT
- ,(+ offset (rtlgen/constant-value index))))
- ,(rtlgen/->register (caddr rands))))))))))
+ open-coder ; ignored
+ (let ((vector (rtlgen/vector-constant? (second rands)))
+ (name (fourth rands)))
+ (if (and vector (rtlgen/constant? name))
+ (let ((index (vector-index vector (rtlgen/constant-value name))))
+ (if (rtlgen/tagged-closures?)
+ (rtlgen/fixed-mutation
+ (list (first rands) (third rands))
+ (+ offset index))
+ (rtlgen/emit!/1
+ `(ASSIGN (OFFSET ,(rtlgen/->register (car rands))
+ (MACHINE-CONSTANT ,(+ offset index)))
+ ,(rtlgen/->register (third rands))))))
+ (internal-error "%heap-closure-set!: non-constant specifier"
+ rands))))))
(let* ((off (rtlgen/words->chars 2))
(define-string-mutation
(define *rtlgen/valid-remaining-declarations*
'())
\f
+(define (call/%stack-closure-ref/unparse expr receiver)
+ (let ((vector (CALL/%stack-closure-ref/offset expr))
+ (name (CALL/%stack-closure-ref/name expr)))
+ (if (and (QUOTE/? vector)
+ (QUOTE/? name))
+ (let ((v (quote/text vector))
+ (n (quote/text name)))
+ (if (and (vector? v) (symbol? n))
+ (receiver v n))))))
+
+(define (CALL/%stack-closure-ref/index expr)
+ (call/%stack-closure-ref/unparse expr vector-index))
+
+(define (CALL/%stack-closure-ref/index=? expr value)
+ (call/%stack-closure-ref/unparse
+ expr
+ (lambda (v n)
+ (and (vector? v)
+ (< -1 value (vector-length v))
+ (eq? (vector-ref v value) n)))))
+\f
#|
;; New RTL:
projects / mit-scheme.git / commitdiff