From: Chris Hanson Date: Fri, 29 May 1987 17:57:40 +0000 (+0000) Subject: Add stuff for variable cache entry points to interpreter. X-Git-Tag: 20090517-FFI~13458 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ff51c5cb7e7e8d6f2d84528ca8d40ef49866e999;p=mit-scheme.git Add stuff for variable cache entry points to interpreter. --- diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm index a49294d09..6e679a4bc 100644 --- a/v7/src/compiler/back/lapgn1.scm +++ b/v7/src/compiler/back/lapgn1.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -48,6 +48,8 @@ MIT in each case. |# (lambda () (fluid-let ((*next-constant* 0) (*interned-constants* '()) + (*interned-variables* '()) + (*interned-uuo-links* '()) (*block-start-label* (generate-label)) (*code-object-label*) (*code-object-entry*) @@ -61,33 +63,17 @@ MIT in each case. |# (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) (define (cgen-rnode rnode) (let ((offset (cgen-rnode-1 rnode))) @@ -153,6 +139,26 @@ MIT in each case. |# (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) ;;;; Machine independent stuff @@ -324,21 +330,46 @@ MIT in each case. |# (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)) diff --git a/v7/src/compiler/machines/bobcat/machin.scm b/v7/src/compiler/machines/bobcat/machin.scm index 1753b395e..c3a81061d 100644 --- a/v7/src/compiler/machines/bobcat/machin.scm +++ b/v7/src/compiler/machines/bobcat/machin.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -86,6 +86,8 @@ MIT in each case. |# ((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?)) @@ -113,7 +115,6 @@ MIT in each case. |# (define-integrable d5 5) (define-integrable d6 6) (define-integrable d7 7) - (define-integrable a0 8) (define-integrable a1 9) (define-integrable a2 10) @@ -122,21 +123,25 @@ MIT in each case. |# (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)) @@ -155,18 +160,15 @@ MIT in each case. |# (vector-set! references j `(A ,i)) (loop (1+ i) (1+ j))))) (lambda (register) (vector-ref references register)))) - -(define mask-reference - '(D 7)) -(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)) diff --git a/v7/src/compiler/rtlbase/rtlcon.scm b/v7/src/compiler/rtlbase/rtlcon.scm index 7b19aa71f..49f06cb13 100644 --- a/v7/src/compiler/rtlbase/rtlcon.scm +++ b/v7/src/compiler/rtlbase/rtlcon.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -106,6 +106,11 @@ MIT in each case. |# (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)) @@ -216,7 +221,7 @@ MIT in each case. |# (assign-to-temporary (rtl:make-object->address register) scfg-append! receiver))))) - + (define (locative-fetch-1 locative scfg-append! receiver) (locative-dereference locative scfg-append! receiver @@ -224,7 +229,7 @@ MIT in each case. |# (assign-to-temporary (rtl:make-offset register offset) scfg-append! receiver)))) - + (define-export (expression-simplify-for-statement expression receiver) (expression-simplify expression scfg*scfg->scfg! receiver)) diff --git a/v7/src/compiler/rtlbase/rtlty1.scm b/v7/src/compiler/rtlbase/rtlty1.scm index 45643bc34..35829277d 100644 --- a/v7/src/compiler/rtlbase/rtlty1.scm +++ b/v7/src/compiler/rtlbase/rtlty1.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -46,6 +46,7 @@ MIT in each case. |# (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) @@ -63,6 +64,8 @@ MIT in each case. |# (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?) @@ -132,6 +135,9 @@ MIT in each case. |# (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)) @@ -149,7 +155,7 @@ MIT in each case. |# ((and (pair? locative) (eq? (car locative) 'OFFSET)) `(OFFSET ,(cadr locative) ,(+ (caddr locative) offset))) (else `(OFFSET ,locative ,offset)))) - + ;;; Expressions that are used in the intermediate form. (define-integrable (rtl:make-fetch locative) @@ -163,7 +169,7 @@ MIT in each case. |# (define-integrable (rtl:make-typed-cons:pair type car cdr) `(TYPED-CONS:PAIR ,type ,car ,cdr)) - + ;;; Linearizer Support (define-integrable (rtl:make-jump-statement label) diff --git a/v7/src/compiler/rtlgen/rgrval.scm b/v7/src/compiler/rtlgen/rgrval.scm index cb65626f4..267bfccbf 100644 --- a/v7/src/compiler/rtlgen/rgrval.scm +++ b/v7/src/compiler/rtlgen/rgrval.scm @@ -1,9 +1,9 @@ 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 @@ -64,7 +64,7 @@ promotional, or sales literature without prior written consent from (define-rvalue-generator block-tag (lambda (block) (define-method-table-entry 'BLOCK rvalue-methods - + (define-rvalue-generator reference-tag (lambda (reference) (if (vnode-known-constant? (reference-variable reference)) @@ -74,19 +74,47 @@ promotional, or sales literature without prior written consent from (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))))) - + (define-rvalue-generator access-tag (lambda (*access) (transmit-values (generate/rvalue (access-environment *access)) diff --git a/v7/src/compiler/rtlgen/rgstmt.scm b/v7/src/compiler/rtlgen/rgstmt.scm index ecbcb13bc..aaa2ad815 100644 --- a/v7/src/compiler/rtlgen/rgstmt.scm +++ b/v7/src/compiler/rtlgen/rgstmt.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -65,24 +65,14 @@ MIT in each case. |# lvalue expression subproblem?)))))))) - + (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))))) - + (define-assignment temporary-tag (lambda (block lvalue expression subproblem?) (rtl:make-assignment lvalue expression))) @@ -103,4 +93,34 @@ MIT in each case. |# (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