#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.34 1987/05/19 18:04:47 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.35 1987/05/29 17:57:40 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(lambda ()
(fluid-let ((*next-constant* 0)
(*interned-constants* '())
+ (*interned-variables* '())
+ (*interned-uuo-links* '())
(*block-start-label* (generate-label))
(*code-object-label*)
(*code-object-entry*)
(queue-map! *continuation-queue*
(lambda (continuation)
(cgen-entry continuation continuation-rtl-entry)))
- (receiver *interned-constants* *block-start-label*)))))
+ (receiver *block-start-label*
+ (generate/quotation-header *block-start-label*
+ *interned-constants*
+ *interned-variables*
+ *interned-uuo-links*))))))
(define (cgen-entry object extract-entry)
(set! *code-object-label* (code-object-label-initialize object))
(let ((rnode (extract-entry object)))
(set! *code-object-entry* rnode)
(cgen-rnode rnode)))
-
-(define *cgen-rules* '())
-(define *assign-rules* '())
-
-(define (add-statement-rule! pattern result-procedure)
- (let ((result (cons pattern result-procedure)))
- (if (eq? (car pattern) 'ASSIGN)
- (let ((entry (assq (caadr pattern) *assign-rules*)))
- (if entry
- (set-cdr! entry (cons result (cdr entry)))
- (set! *assign-rules*
- (cons (list (caadr pattern) result)
- *assign-rules*))))
- (let ((entry (assq (car pattern) *cgen-rules*)))
- (if entry
- (set-cdr! entry (cons result (cdr entry)))
- (set! *cgen-rules*
- (cons (list (car pattern) result)
- *cgen-rules*))))))
- pattern)
\f
(define (cgen-rnode rnode)
(let ((offset (cgen-rnode-1 rnode)))
(bblock-live-at-entry (node-bblock rnode))))
(lambda (map aliases) map))
map)))))
+
+(define *cgen-rules* '())
+(define *assign-rules* '())
+
+(define (add-statement-rule! pattern result-procedure)
+ (let ((result (cons pattern result-procedure)))
+ (if (eq? (car pattern) 'ASSIGN)
+ (let ((entry (assq (caadr pattern) *assign-rules*)))
+ (if entry
+ (set-cdr! entry (cons result (cdr entry)))
+ (set! *assign-rules*
+ (cons (list (caadr pattern) result)
+ *assign-rules*))))
+ (let ((entry (assq (car pattern) *cgen-rules*)))
+ (if entry
+ (set-cdr! entry (cons result (cdr entry)))
+ (set! *cgen-rules*
+ (cons (list (car pattern) result)
+ *cgen-rules*))))))
+ pattern)
\f
;;;; Machine independent stuff
\f
(define *next-constant*)
(define *interned-constants*)
+(define *interned-variables*)
+(define *interned-uuo-links*)
+
+(define (allocate-constant-label)
+ (let ((label
+ (string->symbol
+ (string-append "CONSTANT-" (write-to-string *next-constant*)))))
+ (set! *next-constant* (1+ *next-constant*))
+ label))
(define (constant->label constant)
(let ((entry (assv constant *interned-constants*)))
(if entry
(cdr entry)
- (let ((label
- (string->symbol
- (string-append "CONSTANT-"
- (write-to-string *next-constant*)))))
- (set! *next-constant* (1+ *next-constant*))
+ (let ((label (allocate-constant-label)))
(set! *interned-constants*
(cons (cons constant label)
*interned-constants*))
label))))
+(define (free-reference-label name)
+ (let ((entry (assq name *interned-variables*)))
+ (if entry
+ (cdr entry)
+ (let ((label (allocate-constant-label)))
+ (set! *interned-variables*
+ (cons (cons name label)
+ *interned-variables*))
+ label))))
+
+(define (free-uuo-link-label name)
+ (let ((entry (assq name *interned-uuo-links*)))
+ (if entry
+ (cdr entry)
+ (let ((label (allocate-constant-label)))
+ (set! *interned-uuo-links*
+ (cons (cons name label)
+ *interned-uuo-links*))
+ label))))
+
(define-integrable (set-current-branches! consequent alternative)
(set-rtl-pnode-consequent-lap-generator! *current-rnode* consequent)
(set-rtl-pnode-alternative-lap-generator! *current-rnode* alternative))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 1.45 1987/05/07 00:24:20 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 1.46 1987/05/29 17:48:56 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
((FRAME-POINTER) (interpreter-frame-pointer))
((STACK-POINTER) (interpreter-stack-pointer))
((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access))
+ ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
+ (interpreter-register:cache-reference))
((INTERPRETER-CALL-RESULT:LOOKUP) (interpreter-register:lookup))
((INTERPRETER-CALL-RESULT:UNASSIGNED?) (interpreter-register:unassigned?))
((INTERPRETER-CALL-RESULT:UNBOUND?) (interpreter-register:unbound?))
(define-integrable d5 5)
(define-integrable d6 6)
(define-integrable d7 7)
-
(define-integrable a0 8)
(define-integrable a1 9)
(define-integrable a2 10)
(define-integrable a5 13)
(define-integrable a6 14)
(define-integrable a7 15)
-
(define number-of-machine-registers 16)
+(define regnum:frame-pointer a4)
+(define regnum:free-pointer a5)
+(define regnum:regs-pointer a6)
+(define regnum:stack-pointer a7)
+
(define-integrable (sort-machine-registers registers)
registers)
-(define (pseudo-register=? x y)
- (= (register-renumber x) (register-renumber y)))
-
(define available-machine-registers
- (list d0 d1 d2 d3 d4 d5 d6 a0 a1 a2 a3))
+ (list d0 d1 d2 d3 d4 d5 d6 a0 a1 a2 a3 a4))
(define-integrable (register-contains-address? register)
(memv register '(12 13 14 15)))
+(define (pseudo-register=? x y)
+ (= (register-renumber x) (register-renumber y)))
+
(define register-type
(let ((types (make-vector 16)))
(let loop ((i 0) (j 8))
(vector-set! references j `(A ,i))
(loop (1+ i) (1+ j))))) (lambda (register)
(vector-ref references register))))
-
-(define mask-reference
- '(D 7))
\f
-(define regnum:frame-pointer a4)
-(define regnum:free-pointer a5)
-(define regnum:regs-pointer a6)
-(define regnum:stack-pointer a7)
+(define mask-reference '(D 7))
(define-integrable (interpreter-register:access)
(rtl:make-machine-register d0))
+(define-integrable (interpreter-register:cache-reference)
+ (rtl:make-machine-register d0))
+
(define-integrable (interpreter-register:enclose)
(rtl:make-offset (interpreter-regs-pointer) 5))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 1.5 1987/05/22 00:10:58 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 1.6 1987/05/29 17:49:58 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define rtl:make-interpreter-call:access
(interpreter-lookup-maker %make-interpreter-call:access))
+(define (rtl:make-interpreter-call:cache-assignment name value)
+ (expression-simplify-for-statement value
+ (lambda (value)
+ (%make-interpreter-call:cache-assignment name value))))
+
(define rtl:make-interpreter-call:define
(interpreter-assignment-maker %make-interpreter-call:define))
(assign-to-temporary (rtl:make-object->address register)
scfg-append!
receiver)))))
-
+\f
(define (locative-fetch-1 locative scfg-append! receiver)
(locative-dereference locative scfg-append!
receiver
(assign-to-temporary (rtl:make-offset register offset)
scfg-append!
receiver))))
-\f
+
(define-export (expression-simplify-for-statement expression receiver)
(expression-simplify expression scfg*scfg->scfg! receiver))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 1.5 1987/05/22 00:11:14 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 1.6 1987/05/29 17:51:15 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define-rtl-expression cons-pointer rtl: type datum)
(define-rtl-expression constant rtl: value)
+(define-rtl-expression variable-cache rtl: name)
(define-rtl-expression entry:continuation % continuation)
(define-rtl-expression entry:procedure % procedure)
(define-rtl-expression offset-address rtl: register number)
(define-rtl-statement setup-lexpr % procedure)
(define-rtl-statement interpreter-call:access % environment name)
+(define-rtl-statement interpreter-call:cache-assignment % name value)
+(define-rtl-statement interpreter-call:cache-reference rtl: name safe?)
(define-rtl-statement interpreter-call:define % environment name value)
(define-rtl-statement interpreter-call:enclose rtl: size)
(define-rtl-statement interpreter-call:lookup % environment name safe?)
(define-integrable (rtl:interpreter-call-result:access)
(rtl:make-fetch 'INTERPRETER-CALL-RESULT:ACCESS))
+(define-integrable (rtl:interpreter-call-result:cache-reference)
+ (rtl:make-fetch 'INTERPRETER-CALL-RESULT:CACHE-REFERENCE))
+
(define-integrable (rtl:interpreter-call-result:enclose)
(rtl:make-fetch 'INTERPRETER-CALL-RESULT:ENCLOSE))
((and (pair? locative) (eq? (car locative) 'OFFSET))
`(OFFSET ,(cadr locative) ,(+ (caddr locative) offset)))
(else `(OFFSET ,locative ,offset))))
-
+\f
;;; Expressions that are used in the intermediate form.
(define-integrable (rtl:make-fetch locative)
(define-integrable (rtl:make-typed-cons:pair type car cdr)
`(TYPED-CONS:PAIR ,type ,car ,cdr))
-\f
+
;;; Linearizer Support
(define-integrable (rtl:make-jump-statement label)
d3 1
a4 1
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 1.6 1987/05/27 18:36:40 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 1.7 1987/05/29 17:53:09 cph Exp $
#| -*-Scheme-*-
Copyright (c) 1987 Massachusetts Institute of Technology
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 1.6 1987/05/27 18:36:40 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 1.7 1987/05/29 17:53:09 cph Exp $
Copyright (c) 1988, 1990 Massachusetts Institute of Technology
(define-rvalue-generator block-tag
(lambda (block)
(define-method-table-entry 'BLOCK rvalue-methods
-
+\f
(define-rvalue-generator reference-tag
(lambda (reference)
(if (vnode-known-constant? (reference-variable reference))
(lambda (locative)
(expression-value/simple (rtl:make-fetch locative)))
(lambda (environment name)
- (expression-value/temporary
- (rtl:make-interpreter-call:lookup
- environment
- (intern-scode-variable! (reference-block reference) name)
- (reference-safe? reference))
- (rtl:interpreter-call-result:lookup)))))))
-
+ (if compiler:cache-free-variables?
+ (generate/cached-reference name (reference-safe? reference))
+ (expression-value/temporary
+ (rtl:make-interpreter-call:lookup
+ environment
+ (intern-scode-variable! (reference-block reference) name)
+ (reference-safe? reference))
+ (rtl:interpreter-call-result:lookup))))))))
+
+(define (generate/cached-reference name safe?)
+ (let ((temp (make-temporary))
+ (result (make-temporary)))
+ (let ((cell (rtl:make-fetch temp)))
+ (let ((reference (rtl:make-fetch cell)))
+ (let ((n1 (rtl:make-assignment temp (rtl:make-variable-cache name)))
+ (n2 (rtl:make-type-test reference (ucode-type reference-trap)))
+ (n4 (rtl:make-assignment result reference))
+ (n5 (rtl:make-interpreter-call:cache-reference cell safe?))
+ (n6
+ (rtl:make-assignment
+ result
+ (rtl:interpreter-call-result:cache-reference))))
+ (scfg-next-connect! n1 n2)
+ (pcfg-alternative-connect! n2 n4)
+ (scfg-next-connect! n5 n6)
+ (if safe?
+ (let ((n3 (rtl:make-unassigned-test reference)))
+ (pcfg-consequent-connect! n2 n3)
+ (pcfg-consequent-connect! n3 n4)
+ (pcfg-alternative-connect! n3 n5))
+ (pcfg-consequent-connect! n2 n5))
+ (make-scfg (cfg-entry-node n1)
+ (hooks-union (scfg-next-hooks n4)
+ (scfg-next-hooks n6))))))))
+ (hooks-union (scfg-next-hooks n3)
(define-rvalue-generator temporary-tag
(lambda (temporary)
(if (vnode-known-constant? temporary)
(generate/constant (vnode-known-value temporary))
(expression-value/simple (rtl:make-fetch temporary)))))
-\f
+
(define-rvalue-generator access-tag
(lambda (*access)
(transmit-values (generate/rvalue (access-environment *access))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 1.3 1987/05/21 15:00:00 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 1.4 1987/05/29 17:54:54 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
lvalue
expression
subproblem?))))))))
-\f
+
(define (generate/assignment block lvalue expression subproblem?)
((vector-method lvalue generate/assignment)
block lvalue expression subproblem?))
(define (define-assignment tag generator)
(define-vector-method tag generate/assignment generator))
-
-(define-assignment variable-tag
- (lambda (block lvalue expression subproblem?)
- (find-variable block lvalue
- (lambda (locative)
- (rtl:make-assignment locative expression))
- (lambda (environment name)
- (rtl:make-interpreter-call:set! environment
- (intern-scode-variable! block name)
- expression)))))
-
+\f
(define-assignment temporary-tag
(lambda (block lvalue expression subproblem?)
(rtl:make-assignment lvalue expression)))
(define-assignment value-ignore-tag
(lambda (block lvalue rvalue subproblem?)
(if subproblem? (error "Return node has next"))
+ (make-null-cfg)))
+
+(define-assignment variable-tag
+ (lambda (block lvalue expression subproblem?)
+ (find-variable block lvalue
+ (lambda (locative)
+ (rtl:make-assignment locative expression))
+ (lambda (environment name)
+ (if compiler:cache-free-variables?
+ (generate/cached-assignment name expression)
+ (rtl:make-interpreter-call:set! environment
+ (intern-scode-variable! block name)
+ expression))))))
+
+(define (generate/cached-assignment name value)
+ (let ((temp (make-temporary)))
+ (let ((cell (rtl:make-fetch temp)))
+ (let ((contents (rtl:make-fetch cell)))
+ (let ((n1 (rtl:make-assignment temp (rtl:make-variable-cache name)))
+ (n2 (rtl:make-type-test contents (ucode-type reference-trap)))
+ (n3 (rtl:make-unassigned-test contents))
+ (n4 (rtl:make-assignment cell value))
+ (n5 (rtl:make-interpreter-call:cache-assignment cell value)))
+ (scfg-next-connect! n1 n2)
+ (pcfg-consequent-connect! n2 n3)
+ (pcfg-alternative-connect! n2 n4)
+ (pcfg-consequent-connect! n3 n4)
+ (pcfg-alternative-connect! n3 n5)
+ (make-scfg (cfg-entry-node n1)
+ (hooks-union (scfg-next-hooks n4)
(scfg-next-hooks n6)))))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff