From 332a523b8778ed4fa8b99ee98509fa10595f1327 Mon Sep 17 00:00:00 2001 From: Stephen Adams Date: Sun, 6 Aug 1995 20:00:24 +0000 Subject: [PATCH] Removed %vector-index expressions and the indexify phase. The index computation is now implicit and handled by rtlgen and dbgred. Looking at the structure of some large programs (e.g. symb in nscmutils) revealed that up to 32% of the text of a program was %vector-index expressions. These get copied in every pass after closconv/2. The `elegance' is not worth the performance hit. About 30% of the remaining text is %stack-closure-ref expressions. The overhead could be reduced by introducing another KMP special form (which would also mean that the DBG info would not need to compress the expressions, saving time). --- v8/src/compiler/machines/spectrum/decls.scm | 6 +- v8/src/compiler/midend/compat.scm | 67 ++++--- v8/src/compiler/midend/fakeprim.scm | 23 +-- v8/src/compiler/midend/midend.scm | 4 +- v8/src/compiler/midend/rtlgen.scm | 205 ++++++++++---------- v8/src/compiler/midend/stackopt.scm | 4 +- 6 files changed, 167 insertions(+), 142 deletions(-) diff --git a/v8/src/compiler/machines/spectrum/decls.scm b/v8/src/compiler/machines/spectrum/decls.scm index 5675addbb..bf0bf00a5 100644 --- a/v8/src/compiler/machines/spectrum/decls.scm +++ b/v8/src/compiler/machines/spectrum/decls.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: decls.scm,v 1.6 1995/04/01 16:50:43 adams Exp $ +$Id: decls.scm,v 1.7 1995/08/06 19:59:31 adams Exp $ Copyright (c) 1988-1994 Massachusetts Institute of Technology @@ -352,7 +352,7 @@ MIT in each case. |# "coerce" "dataflow" "dbgstr" "dbgred" "debug" "earlyrew" "envconv" "expand" "fakeprim" "graph" - "indexify" "inlate" "lamlift" "laterew" + "inlate" "lamlift" "laterew" "load" "midend" "rtlgen" "simplify" "split" "stackopt" "staticfy" "synutl" "triveval" "utils" "widen" @@ -501,7 +501,7 @@ MIT in each case. |# ;; "closconv" "compat" "copier" "cpsconv" ;; "dataflow" "dbgstr" "debug" "earlyrew" ;; "envconv" "expand" "graph" - ;; "indexify" "inlate" "lamlift" "laterew" + ;; "inlate" "lamlift" "laterew" ;; "load" "midend" "rtlgen" "simplify" ;; "split" "stackopt" "staticfy" "synutl" ;; "triveval" "widen") diff --git a/v8/src/compiler/midend/compat.scm b/v8/src/compiler/midend/compat.scm index c6b97d675..d44bccdae 100644 --- a/v8/src/compiler/midend/compat.scm +++ b/v8/src/compiler/midend/compat.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -33,12 +33,13 @@ promotional, or sales literature without prior written consent from 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) @@ -104,9 +105,11 @@ MIT in each case. |# (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) @@ -209,17 +212,14 @@ MIT in each case. |# (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 @@ -382,25 +382,44 @@ MIT in each case. |# (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 = (' ') +;; ;; 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 = (' ') + ;; rands = ( ' ') ;; 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))))) (define-rewrite/compat %make-heap-closure ;; The lambda expression in a heap closure is special the closure @@ -727,7 +746,7 @@ MIT in each case. |# (call ',%stack-closure-ref '#F (lookup frame) - (call ',%vector-index '#F ',fv1 'save2) + ',fv1 'save2) (lookup val2) '1000))) diff --git a/v8/src/compiler/midend/fakeprim.scm b/v8/src/compiler/midend/fakeprim.scm index 608e3045d..c24f32fac 100644 --- a/v8/src/compiler/midend/fakeprim.scm +++ b/v8/src/compiler/midend/fakeprim.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: fakeprim.scm,v 1.18 1995/07/24 14:32:57 adams Exp $ +$Id: fakeprim.scm,v 1.19 1995/08/06 20:00:24 adams Exp $ Copyright (c) 1994 Massachusetts Institute of Technology @@ -638,16 +638,17 @@ MIT in each case. |# (make-operator/simple* "#[multicell-set!]" '(UNSPECIFIC-RESULT))) (cookie-call %multicell-set! '#F cell value 'LAYOUT 'NAME) -(define %vector-index - ;; (CALL ',%vector-index '#F 'VECTOR 'NAME) - ;; Note: - ;; VECTOR is a vector of symbols, including NAME - ;; Returns the index of NAME within the vector. - ;; Introduced by closconv.scm and removed (constant folded) by - ;; indexify.scm. Used for referencing variables in closures and - ;; stack frames. - (make-operator/simple "#[vector-index]")) -(cookie-call %vector-index '#F 'VECTOR 'NAME) +;; OBSOLETE +;;(define %vector-index +;; ;; (CALL ',%vector-index '#F 'VECTOR 'NAME) +;; ;; Note: +;; ;; VECTOR is a vector of symbols, including NAME +;; ;; Returns the index of NAME within the vector. +;; ;; Introduced by closconv.scm and removed (constant folded) by +;; ;; indexify.scm. Used for referencing variables in closures and +;; ;; stack frames. +;; (make-operator/simple "#[vector-index]")) +;;(cookie-call %vector-index '#F 'VECTOR 'NAME) ;; %heap-closure-ref, %stack-closure-ref, and %static-binding-ref are not ;; properly simple, but they can be considered such because %heap-closure-set!, diff --git a/v8/src/compiler/midend/midend.scm b/v8/src/compiler/midend/midend.scm index 5bfbf0e5c..df8087f72 100644 --- a/v8/src/compiler/midend/midend.scm +++ b/v8/src/compiler/midend/midend.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: midend.scm,v 1.13 1995/06/26 14:09:49 adams Exp $ +$Id: midend.scm,v 1.14 1995/08/06 19:58:53 adams Exp $ Copyright (c) 1994 Massachusetts Institute of Technology @@ -263,7 +263,7 @@ Example: stackopt/top-level ; reformat stack closures to use ; common formats (prefixes) ;; stackopt/optional-debugging-paranoia - indexify/top-level ; rewrite %vector-index + ;;indexify/top-level ; OBSOLETE rewrite %vector-index dbg-reduce/top-level ; final environment mappings )) diff --git a/v8/src/compiler/midend/rtlgen.scm b/v8/src/compiler/midend/rtlgen.scm index 0f853bae8..619aef253 100644 --- a/v8/src/compiler/midend/rtlgen.scm +++ b/v8/src/compiler/midend/rtlgen.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -159,16 +159,11 @@ MIT in each case. |# (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)) @@ -470,7 +465,7 @@ MIT in each case. |# (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) @@ -555,29 +550,28 @@ MIT in each case. |# (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)))))))))) @@ -1623,16 +1617,11 @@ MIT in each case. |# (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 @@ -2341,12 +2330,7 @@ MIT in each case. |# ;; 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) @@ -2390,10 +2374,9 @@ MIT in each case. |# (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?))) @@ -2406,7 +2389,7 @@ MIT in each case. |# (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)) @@ -2645,20 +2628,14 @@ MIT in each case. |# (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 @@ -3206,6 +3183,11 @@ MIT in each case. |# (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 @@ -3576,22 +3558,23 @@ MIT in each case. |# (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 @@ -4009,23 +3992,24 @@ MIT in each case. |# (define-indexed-mutator 'PRIMITIVE-OBJECT-SET! false 0 3)) (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 @@ -4394,6 +4378,27 @@ MIT in each case. |# (define *rtlgen/valid-remaining-declarations* '()) +(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))))) + #| ;; New RTL: diff --git a/v8/src/compiler/midend/stackopt.scm b/v8/src/compiler/midend/stackopt.scm index 7fc189add..b02c40e31 100644 --- a/v8/src/compiler/midend/stackopt.scm +++ b/v8/src/compiler/midend/stackopt.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: stackopt.scm,v 1.12 1995/08/04 19:45:23 adams Exp $ +$Id: stackopt.scm,v 1.13 1995/08/06 19:56:32 adams Exp $ Copyright (c) 1994-1995 Massachusetts Institute of Technology @@ -232,7 +232,7 @@ End of Big Note A |# `(CALL ',%stack-closure-ref '#F (LOOKUP ,var) - (CALL ',%vector-index '#F ',frame-vector ',name) + ',frame-vector ',name)) (cond ((and (not state) (eq? var *stackopt/lexical-stack-frame-name*)) (good *stackopt/lexical-stack-frame-vector*)) -- 2.25.1