From: Chris Hanson Date: Thu, 31 Dec 1987 08:51:44 +0000 (+0000) Subject: Implement open coding of `vector' primitive. Change primitive open X-Git-Tag: 20090517-FFI~12962 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4e00329460c568ba5f3d67ad846e4f1562fad647;p=mit-scheme.git Implement open coding of `vector' primitive. Change primitive open coding so that arguments which are known constants or references to known locations do not use intermediate registers if possible. --- diff --git a/v7/src/compiler/fgopt/order.scm b/v7/src/compiler/fgopt/order.scm index 09194cf2b..cbbba837a 100644 --- a/v7/src/compiler/fgopt/order.scm +++ b/v7/src/compiler/fgopt/order.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.2 1987/12/30 06:44:43 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.3 1987/12/31 08:51:44 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -105,7 +105,7 @@ MIT in each case. |# (let ((inliner (combination/inliner combination))) (let ((operands (list-filter-indices (cdr subproblems) (inliner/operands inliner)))) - (set-inliner/operands! inliner (map subproblem-continuation operands)) + (set-inliner/operands! inliner operands) (order-subproblems/inline (car subproblems) operands)))) (define (order-subproblems/inline operator operands) @@ -114,18 +114,32 @@ MIT in each case. |# (lambda (simple complex) (if (null? complex) (begin - (set-subproblem-types! simple continuation-type/value) + (inline-subproblem-types! simple continuation-type/register) (return-2 (cons operator operands) (make-null-cfg))) (let ((push-set (cdr complex)) (value-set (cons (car complex) simple))) - (set-subproblem-types! push-set continuation-type/push) - (set-subproblem-types! value-set continuation-type/register) + (inline-subproblem-types! push-set continuation-type/push) + (inline-subproblem-types! value-set continuation-type/register) (return-2 (cons operator (append! push-set value-set)) (scfg*->scfg! (reverse! (map (lambda (subproblem) (make-pop (subproblem-continuation subproblem))) push-set))))))))) + +(define (inline-subproblem-types! subproblems continuation-type) + (for-each (lambda (subproblem) + (set-subproblem-type! + subproblem + (if (let ((rvalue (subproblem-rvalue subproblem))) + (or (rvalue-known-constant? rvalue) + (and (rvalue/reference? rvalue) + (not (variable/value-variable? + (reference-lvalue rvalue))) + (reference-to-known-location? rvalue)))) + continuation-type/effect + continuation-type))) + subproblems)) (define (order-subproblems/combination/out-of-line combination subproblems) (let ((subproblems diff --git a/v7/src/compiler/machines/bobcat/rules1.scm b/v7/src/compiler/machines/bobcat/rules1.scm index e6766126f..166dc5cf1 100644 --- a/v7/src/compiler/machines/bobcat/rules1.scm +++ b/v7/src/compiler/machines/bobcat/rules1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.1 1987/12/30 07:05:45 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.2 1987/12/31 08:51:22 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -218,6 +218,11 @@ MIT in each case. |# (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (CONSTANT (? object))) (LAP ,(load-constant object (INST-EA (@A+ 5))))) +(define-rule statement + (ASSIGN (POST-INCREMENT (REGISTER 13) 1) + (CONS-POINTER (CONSTANT (? type)) (CONSTANT (? datum)))) + (LAP ,(load-non-pointer type datum (INST-EA (@A+ 5))))) + (define-rule statement (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (UNASSIGNED)) (LAP ,(load-non-pointer (ucode-type unassigned) 0 (INST-EA (@A+ 5))))) diff --git a/v7/src/compiler/rtlbase/rtlcon.scm b/v7/src/compiler/rtlbase/rtlcon.scm index 874ef5aa2..2427eeca6 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 4.2 1987/12/30 07:07:25 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.3 1987/12/31 08:50:36 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -364,6 +364,33 @@ MIT in each case. |# (scfg-append! (%make-assign target cdr) (receiver temporary))))))))))))))) +(define-expression-method 'TYPED-CONS:VECTOR + (lambda (receiver scfg-append! type . elements) + (let ((free (interpreter-free-pointer)) + (header + (rtl:make-cons-pointer + (rtl:make-constant (ucode-type manifest-vector)) + (rtl:make-constant (length elements))))) + (let ((target (rtl:make-post-increment free 1))) + (expression-simplify* type scfg-append! + (lambda (type) + (let loop ((elements elements) (simplified-elements '())) + (if (null? elements) + (assign-to-temporary (rtl:make-cons-pointer type free) + scfg-append! + (lambda (temporary) + (scfg-append! + (%make-assign target header) + (let loop ((elements (reverse! simplified-elements))) + (if (null? elements) + (receiver temporary) + (scfg-append! (%make-assign target (car elements)) + (loop (cdr elements)))))))) + (expression-simplify* (car elements) scfg-append! + (lambda (element) + (loop (cdr elements) + (cons element simplified-elements)))))))))))) + (define (object-selector make-object-selector) (lambda (receiver scfg-append! expression) (expression-simplify* expression scfg-append! diff --git a/v7/src/compiler/rtlbase/rtlexp.scm b/v7/src/compiler/rtlbase/rtlexp.scm index a01a4568b..375138423 100644 --- a/v7/src/compiler/rtlbase/rtlexp.scm +++ b/v7/src/compiler/rtlbase/rtlexp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.1 1987/12/04 20:17:56 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.2 1987/12/31 08:50:47 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -46,14 +46,17 @@ MIT in each case. |# INVOCATION:SPECIAL-PRIMITIVE INVOCATION:UUO-LINK))) -(define-integrable (rtl:trivial-expression? rtl) - (memq (rtl:expression-type rtl) - '(REGISTER - CONSTANT - ENTRY:CONTINUATION - ENTRY:PROCEDURE - UNASSIGNED - VARIABLE-CACHE))) +(define (rtl:trivial-expression? expression) + (if (memq (rtl:expression-type expression) + '(REGISTER + CONSTANT + ENTRY:CONTINUATION + ENTRY:PROCEDURE + UNASSIGNED + VARIABLE-CACHE)) + true + (and (rtl:offset? expression) + (interpreter-stack-pointer? (rtl:offset-register expression))))) (define (rtl:machine-register-expression? expression) (and (rtl:register? expression) @@ -82,14 +85,14 @@ MIT in each case. |# (lambda (x) (and (pair? x) (predicate x)))))) - + (define (rtl:all-subexpressions? expression predicate) (or (rtl:constant? expression) (for-all? (cdr expression) (lambda (x) (or (not (pair? x)) (predicate x)))))) - + (define (rtl:reduce-subparts expression operator initial if-expression if-not) (let ((remap (if (rtl:constant? expression) diff --git a/v7/src/compiler/rtlbase/rtlty2.scm b/v7/src/compiler/rtlbase/rtlty2.scm index 5e473b55d..7dc77596c 100644 --- a/v7/src/compiler/rtlbase/rtlty2.scm +++ b/v7/src/compiler/rtlbase/rtlty2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.1 1987/12/04 20:18:28 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.2 1987/12/31 08:50:53 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -112,6 +112,9 @@ MIT in each case. |# (define-integrable (rtl:make-typed-cons:pair type car cdr) `(TYPED-CONS:PAIR ,type ,car ,cdr)) +(define-integrable (rtl:make-typed-cons:vector type elements) + `(TYPED-CONS:VECTOR ,type ,@elements)) + ;;; Linearizer Support (define-integrable (rtl:make-jump-statement label) diff --git a/v7/src/compiler/rtlgen/fndblk.scm b/v7/src/compiler/rtlgen/fndblk.scm index f1faa5662..e9ea31fb7 100644 --- a/v7/src/compiler/rtlgen/fndblk.scm +++ b/v7/src/compiler/rtlgen/fndblk.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.2 1987/12/30 07:09:45 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.3 1987/12/31 08:50:06 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -59,6 +59,13 @@ MIT in each case. |# (else (if-cached (variable-name variable)))))))) +(define (find-known-variable block variable offset) + (find-variable block variable offset identity-procedure + (lambda (environment name) + (error "Known variable found in IC frame" name)) + (lambda (name) + (error "Known variable found in IC frame" name)))) + (define (find-closure-variable block variable offset) (find-variable-internal block variable offset identity-procedure diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm index b5ea85b39..1f8322fab 100644 --- a/v7/src/compiler/rtlgen/opncod.scm +++ b/v7/src/compiler/rtlgen/opncod.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.2 1987/12/30 07:09:53 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.3 1987/12/31 08:50:13 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -76,30 +76,47 @@ MIT in each case. |# ;;;; Code Generator (define-export (combination/inline combination) - (generate/return* (combination/block combination) - (combination/continuation combination) - (let ((inliner (combination/inliner combination))) - (let ((handler (inliner/handler inliner)) - (generator (inliner/generator inliner)) - (expressions - (map (lambda (continuation) - (rtl:make-fetch - (continuation*/register continuation))) - (inliner/operands inliner)))) - (make-return-operand - (lambda (offset) - ((vector-ref handler 1) generator expressions)) - (lambda (offset finish) - ((vector-ref handler 2) generator - expressions - finish)) - (lambda (offset finish) - ((vector-ref handler 3) generator - expressions - finish)) - false))) - (node/offset combination))) - + (let ((offset (node/offset combination))) + (generate/return* (combination/block combination) + (combination/continuation combination) + (let ((inliner (combination/inliner combination))) + (let ((handler (inliner/handler inliner)) + (generator (inliner/generator inliner)) + (expressions + (map (subproblem->expression offset) + (inliner/operands inliner)))) + (make-return-operand + (lambda (offset) + ((vector-ref handler 1) generator expressions)) + (lambda (offset finish) + ((vector-ref handler 2) generator + expressions + finish)) + (lambda (offset finish) + ((vector-ref handler 3) generator + expressions + finish)) + false))) + offset))) + +(define (subproblem->expression offset) + (lambda (subproblem) + (let ((rvalue (subproblem-rvalue subproblem))) + (let ((value (rvalue-known-value rvalue))) + (cond ((and value (rvalue/constant? value)) + (rtl:make-constant (constant-value value))) + ((and (rvalue/reference? rvalue) + (not (variable/value-variable? (reference-lvalue rvalue))) + (reference-to-known-location? rvalue)) + (rtl:make-fetch + (find-known-variable (reference-block rvalue) + (reference-lvalue rvalue) + offset))) + (else + (rtl:make-fetch + (continuation*/register + (subproblem-continuation subproblem))))))))) + (define (invoke/effect->effect generator expressions) (generator expressions false)) @@ -240,6 +257,22 @@ MIT in each case. |# (filter/nonnegative-integer (car operands) (lambda (type) (return-2 (open-code/pair-cons type) '(1 2))))))) + +(define-open-coder/value 'VECTOR + (lambda (operands) + (and (< (length operands) 32) + (return-2 (lambda (expressions finish) + (finish + (rtl:make-typed-cons:vector + (rtl:make-constant (ucode-type vector)) + expressions))) + (all-operand-indices operands))))) + +(define (all-operand-indices operands) + (let loop ((operands operands) (index 0)) + (if (null? operands) + '() + (cons index (loop (cdr operands) (1+ index)))))) (let ((open-code/memory-length (lambda (index)