From 127a5c5be7807b440a2ccff78987ffe6c55fad50 Mon Sep 17 00:00:00 2001 From: Stephen Adams Date: Sat, 19 Nov 1994 02:11:31 +0000 Subject: [PATCH] Initial revision --- v8/src/compiler/base/asstop.scm | 384 ++ v8/src/compiler/base/blocks.scm | 362 ++ v8/src/compiler/base/cfg1.scm | 180 + v8/src/compiler/base/cfg2.scm | 231 + v8/src/compiler/base/cfg3.scm | 355 ++ v8/src/compiler/base/constr.scm | 270 ++ v8/src/compiler/base/crsend.scm | 190 + v8/src/compiler/base/crstop.scm | 93 + v8/src/compiler/base/debug.scm | 239 + v8/src/compiler/base/enumer.scm | 120 + v8/src/compiler/base/infnew.scm | 386 ++ v8/src/compiler/base/macros.scm | 359 ++ v8/src/compiler/base/make.scm | 67 + v8/src/compiler/base/mvalue.scm | 81 + v8/src/compiler/base/object.scm | 160 + v8/src/compiler/base/parass.scm | 147 + v8/src/compiler/base/pmerly.scm | 729 +++ v8/src/compiler/base/pmlook.scm | 78 + v8/src/compiler/base/pmpars.scm | 213 + v8/src/compiler/base/scode.scm | 173 + v8/src/compiler/base/sets.scm | 197 + v8/src/compiler/base/switch.scm | 99 + v8/src/compiler/base/toplev.scm | 1008 ++++ v8/src/compiler/base/utils.scm | 390 ++ v8/src/compiler/machines/spectrum/assmd.scm | 91 + v8/src/compiler/machines/spectrum/coerce.scm | 161 + .../compiler/machines/spectrum/compiler.cbf | 48 + .../compiler/machines/spectrum/compiler.pkg | 722 +++ v8/src/compiler/machines/spectrum/compiler.sf | 111 + v8/src/compiler/machines/spectrum/dassm1.scm | 518 ++ v8/src/compiler/machines/spectrum/dassm2.scm | 292 ++ v8/src/compiler/machines/spectrum/dassm3.scm | 721 +++ v8/src/compiler/machines/spectrum/decls.scm | 668 +++ v8/src/compiler/machines/spectrum/inerly.scm | 91 + v8/src/compiler/machines/spectrum/insmac.scm | 143 + v8/src/compiler/machines/spectrum/instr1.scm | 291 ++ v8/src/compiler/machines/spectrum/instr2.scm | 799 ++++ v8/src/compiler/machines/spectrum/instr3.scm | 473 ++ v8/src/compiler/machines/spectrum/lapgen.scm | 858 ++++ v8/src/compiler/machines/spectrum/lapopt.scm | 946 ++++ v8/src/compiler/machines/spectrum/machin.scm | 645 +++ v8/src/compiler/machines/spectrum/make.scm | 65 + v8/src/compiler/machines/spectrum/rgspcm.scm | 84 + v8/src/compiler/machines/spectrum/rules1.scm | 496 ++ v8/src/compiler/machines/spectrum/rules2.scm | 184 + v8/src/compiler/machines/spectrum/rules3.scm | 1693 +++++++ v8/src/compiler/machines/spectrum/rules4.scm | 155 + v8/src/compiler/machines/spectrum/rulfix.scm | 1443 ++++++ v8/src/compiler/machines/spectrum/rulflo.scm | 605 +++ v8/src/compiler/machines/spectrum/rulrew.scm | 353 ++ v8/src/compiler/midend/alpha.scm | 178 + v8/src/compiler/midend/applicat.scm | 198 + v8/src/compiler/midend/assconv.scm | 407 ++ v8/src/compiler/midend/cleanup.scm | 472 ++ v8/src/compiler/midend/closconv.scm | 677 +++ v8/src/compiler/midend/compat.scm | 730 +++ v8/src/compiler/midend/copier.scm | 140 + v8/src/compiler/midend/cpsconv.scm | 539 +++ v8/src/compiler/midend/dataflow.scm | 2286 +++++++++ v8/src/compiler/midend/dbgstr.scm | 49 + v8/src/compiler/midend/debug.scm | 205 + v8/src/compiler/midend/earlyrew.scm | 568 +++ v8/src/compiler/midend/envconv.scm | 952 ++++ v8/src/compiler/midend/expand.scm | 347 ++ v8/src/compiler/midend/fakeprim.scm | 1019 ++++ v8/src/compiler/midend/graph.scm | 263 ++ v8/src/compiler/midend/indexify.scm | 141 + v8/src/compiler/midend/inlate.scm | 218 + v8/src/compiler/midend/lamlift.scm | 748 +++ v8/src/compiler/midend/laterew.scm | 307 ++ v8/src/compiler/midend/load.scm | 74 + v8/src/compiler/midend/midend.scm | 337 ++ v8/src/compiler/midend/rtlgen.scm | 4149 +++++++++++++++++ v8/src/compiler/midend/simplify.scm | 473 ++ v8/src/compiler/midend/split.scm | 232 + v8/src/compiler/midend/stackopt.scm | 819 ++++ v8/src/compiler/midend/staticfy.scm | 267 ++ v8/src/compiler/midend/synutl.scm | 63 + v8/src/compiler/midend/triveval.scm | 461 ++ v8/src/compiler/midend/utils.scm | 997 ++++ v8/src/compiler/midend/widen.scm | 764 +++ v8/src/compiler/rtlbase/regset.scm | 143 + v8/src/compiler/rtlbase/rgraph.scm | 72 + v8/src/compiler/rtlbase/rtlcfg.scm | 226 + v8/src/compiler/rtlbase/rtlcon.scm | 801 ++++ v8/src/compiler/rtlbase/rtlexp.scm | 334 ++ v8/src/compiler/rtlbase/rtline.scm | 206 + v8/src/compiler/rtlbase/rtlobj.scm | 137 + v8/src/compiler/rtlbase/rtlpars.scm | 367 ++ v8/src/compiler/rtlbase/rtlreg.scm | 145 + v8/src/compiler/rtlbase/rtlty1.scm | 240 + v8/src/compiler/rtlbase/rtlty2.scm | 252 + v8/src/compiler/rtlbase/valclass.scm | 128 + v8/src/compiler/rtlopt/ralloc.scm | 148 + v8/src/compiler/rtlopt/rcompr.scm | 299 ++ v8/src/compiler/rtlopt/rcse1.scm | 663 +++ v8/src/compiler/rtlopt/rcse2.scm | 329 ++ v8/src/compiler/rtlopt/rcseep.scm | 82 + v8/src/compiler/rtlopt/rcseht.scm | 205 + v8/src/compiler/rtlopt/rcsemrg.scm | 113 + v8/src/compiler/rtlopt/rcserq.scm | 193 + v8/src/compiler/rtlopt/rcsesr.scm | 113 + v8/src/compiler/rtlopt/rdebug.scm | 87 + v8/src/compiler/rtlopt/rdflow.scm | 280 ++ v8/src/compiler/rtlopt/rerite.scm | 198 + v8/src/compiler/rtlopt/rinvex.scm | 392 ++ v8/src/compiler/rtlopt/rlife.scm | 223 + v8/src/compiler/rtlopt/rtlcsm.scm | 331 ++ 108 files changed, 44954 insertions(+) create mode 100644 v8/src/compiler/base/asstop.scm create mode 100644 v8/src/compiler/base/blocks.scm create mode 100644 v8/src/compiler/base/cfg1.scm create mode 100644 v8/src/compiler/base/cfg2.scm create mode 100644 v8/src/compiler/base/cfg3.scm create mode 100644 v8/src/compiler/base/constr.scm create mode 100644 v8/src/compiler/base/crsend.scm create mode 100644 v8/src/compiler/base/crstop.scm create mode 100644 v8/src/compiler/base/debug.scm create mode 100644 v8/src/compiler/base/enumer.scm create mode 100644 v8/src/compiler/base/infnew.scm create mode 100644 v8/src/compiler/base/macros.scm create mode 100644 v8/src/compiler/base/make.scm create mode 100644 v8/src/compiler/base/mvalue.scm create mode 100644 v8/src/compiler/base/object.scm create mode 100644 v8/src/compiler/base/parass.scm create mode 100644 v8/src/compiler/base/pmerly.scm create mode 100644 v8/src/compiler/base/pmlook.scm create mode 100644 v8/src/compiler/base/pmpars.scm create mode 100644 v8/src/compiler/base/scode.scm create mode 100644 v8/src/compiler/base/sets.scm create mode 100644 v8/src/compiler/base/switch.scm create mode 100644 v8/src/compiler/base/toplev.scm create mode 100644 v8/src/compiler/base/utils.scm create mode 100644 v8/src/compiler/machines/spectrum/assmd.scm create mode 100644 v8/src/compiler/machines/spectrum/coerce.scm create mode 100644 v8/src/compiler/machines/spectrum/compiler.cbf create mode 100644 v8/src/compiler/machines/spectrum/compiler.pkg create mode 100644 v8/src/compiler/machines/spectrum/compiler.sf create mode 100644 v8/src/compiler/machines/spectrum/dassm1.scm create mode 100644 v8/src/compiler/machines/spectrum/dassm2.scm create mode 100644 v8/src/compiler/machines/spectrum/dassm3.scm create mode 100644 v8/src/compiler/machines/spectrum/decls.scm create mode 100644 v8/src/compiler/machines/spectrum/inerly.scm create mode 100644 v8/src/compiler/machines/spectrum/insmac.scm create mode 100644 v8/src/compiler/machines/spectrum/instr1.scm create mode 100644 v8/src/compiler/machines/spectrum/instr2.scm create mode 100644 v8/src/compiler/machines/spectrum/instr3.scm create mode 100644 v8/src/compiler/machines/spectrum/lapgen.scm create mode 100644 v8/src/compiler/machines/spectrum/lapopt.scm create mode 100644 v8/src/compiler/machines/spectrum/machin.scm create mode 100644 v8/src/compiler/machines/spectrum/make.scm create mode 100644 v8/src/compiler/machines/spectrum/rgspcm.scm create mode 100644 v8/src/compiler/machines/spectrum/rules1.scm create mode 100644 v8/src/compiler/machines/spectrum/rules2.scm create mode 100644 v8/src/compiler/machines/spectrum/rules3.scm create mode 100644 v8/src/compiler/machines/spectrum/rules4.scm create mode 100644 v8/src/compiler/machines/spectrum/rulfix.scm create mode 100644 v8/src/compiler/machines/spectrum/rulflo.scm create mode 100644 v8/src/compiler/machines/spectrum/rulrew.scm create mode 100644 v8/src/compiler/midend/alpha.scm create mode 100644 v8/src/compiler/midend/applicat.scm create mode 100644 v8/src/compiler/midend/assconv.scm create mode 100644 v8/src/compiler/midend/cleanup.scm create mode 100644 v8/src/compiler/midend/closconv.scm create mode 100644 v8/src/compiler/midend/compat.scm create mode 100644 v8/src/compiler/midend/copier.scm create mode 100644 v8/src/compiler/midend/cpsconv.scm create mode 100644 v8/src/compiler/midend/dataflow.scm create mode 100644 v8/src/compiler/midend/dbgstr.scm create mode 100644 v8/src/compiler/midend/debug.scm create mode 100644 v8/src/compiler/midend/earlyrew.scm create mode 100644 v8/src/compiler/midend/envconv.scm create mode 100644 v8/src/compiler/midend/expand.scm create mode 100644 v8/src/compiler/midend/fakeprim.scm create mode 100644 v8/src/compiler/midend/graph.scm create mode 100644 v8/src/compiler/midend/indexify.scm create mode 100644 v8/src/compiler/midend/inlate.scm create mode 100644 v8/src/compiler/midend/lamlift.scm create mode 100644 v8/src/compiler/midend/laterew.scm create mode 100644 v8/src/compiler/midend/load.scm create mode 100644 v8/src/compiler/midend/midend.scm create mode 100644 v8/src/compiler/midend/rtlgen.scm create mode 100644 v8/src/compiler/midend/simplify.scm create mode 100644 v8/src/compiler/midend/split.scm create mode 100644 v8/src/compiler/midend/stackopt.scm create mode 100644 v8/src/compiler/midend/staticfy.scm create mode 100644 v8/src/compiler/midend/synutl.scm create mode 100644 v8/src/compiler/midend/triveval.scm create mode 100644 v8/src/compiler/midend/utils.scm create mode 100644 v8/src/compiler/midend/widen.scm create mode 100644 v8/src/compiler/rtlbase/regset.scm create mode 100644 v8/src/compiler/rtlbase/rgraph.scm create mode 100644 v8/src/compiler/rtlbase/rtlcfg.scm create mode 100644 v8/src/compiler/rtlbase/rtlcon.scm create mode 100644 v8/src/compiler/rtlbase/rtlexp.scm create mode 100644 v8/src/compiler/rtlbase/rtline.scm create mode 100644 v8/src/compiler/rtlbase/rtlobj.scm create mode 100644 v8/src/compiler/rtlbase/rtlpars.scm create mode 100644 v8/src/compiler/rtlbase/rtlreg.scm create mode 100644 v8/src/compiler/rtlbase/rtlty1.scm create mode 100644 v8/src/compiler/rtlbase/rtlty2.scm create mode 100644 v8/src/compiler/rtlbase/valclass.scm create mode 100644 v8/src/compiler/rtlopt/ralloc.scm create mode 100644 v8/src/compiler/rtlopt/rcompr.scm create mode 100644 v8/src/compiler/rtlopt/rcse1.scm create mode 100644 v8/src/compiler/rtlopt/rcse2.scm create mode 100644 v8/src/compiler/rtlopt/rcseep.scm create mode 100644 v8/src/compiler/rtlopt/rcseht.scm create mode 100644 v8/src/compiler/rtlopt/rcsemrg.scm create mode 100644 v8/src/compiler/rtlopt/rcserq.scm create mode 100644 v8/src/compiler/rtlopt/rcsesr.scm create mode 100644 v8/src/compiler/rtlopt/rdebug.scm create mode 100644 v8/src/compiler/rtlopt/rdflow.scm create mode 100644 v8/src/compiler/rtlopt/rerite.scm create mode 100644 v8/src/compiler/rtlopt/rinvex.scm create mode 100644 v8/src/compiler/rtlopt/rlife.scm create mode 100644 v8/src/compiler/rtlopt/rtlcsm.scm diff --git a/v8/src/compiler/base/asstop.scm b/v8/src/compiler/base/asstop.scm new file mode 100644 index 000000000..aa9374e98 --- /dev/null +++ b/v8/src/compiler/base/asstop.scm @@ -0,0 +1,384 @@ +#| -*-Scheme-*- + +$Id: asstop.scm,v 1.1 1994/11/19 02:01:20 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Assembler and Linker top level +;;; package: (compiler top-level) + +(declare (usual-integrations)) + +;;;; Exports to the compiler + +(define compiled-output-extension "com") + +(define (compiler-file-output object pathname) + (fasdump object pathname)) + +(define (compiler-output->procedure scode environment) + (scode-eval scode environment)) + +(define (compiler-output->compiled-expression cexp) + cexp) + +(define (compile-scode/internal/hook action) + (action)) + +;;; Global variables for the assembler and linker + +(define *recursive-compilation-results*) + +;; First set: phase/rtl-generation +;; Last used: phase/link +(define *block-label*) + +;; First set: phase/lap-generation +;; Last used: phase/info-generation-2 +(define *external-labels*) + +;; First set: phase/assemble +;; Last used: phase/link +(define *label-bindings*) +(define *code-vector*) +(define *entry-points*) + +;; First set: phase/link +;; Last used: result of compilation +(define *result*) + +(define (assemble&link info-output-pathname) + (phase/assemble) + (if compiler:cross-compiling? + (begin + (if info-output-pathname + (cross-compiler-phase/info-generation-2 info-output-pathname)) + (cross-compiler-phase/link)) + (begin + (if info-output-pathname + (phase/info-generation-2 info-output-pathname)) + (phase/link))) + *result*) + +(define (wrap-lap entry-label some-lap) + (LAP ,@(if *procedure-result?* + (LAP (ENTRY-POINT ,entry-label)) + (lap:make-entry-point entry-label *block-label*)) + ,@some-lap)) + +(define (bind-assembler&linker-top-level-variables thunk) + (fluid-let ((*recursive-compilation-results* '())) + (thunk))) + +(define (bind-assembler&linker-variables thunk) + (fluid-let ((*block-associations*) + (*block-label*) + (*external-labels*) + (*end-of-block-code*) + (*next-constant*) + (*interned-assignments*) + (*interned-constants*) + (*interned-global-links*) + (*interned-static-variables*) + (*interned-uuo-links*) + (*interned-variables*) + (*label-bindings*) + (*code-vector*) + (*entry-points*) + (*result*)) + (thunk))) + +(define (assembler&linker-reset!) + (set! *recursive-compilation-results* '()) + (set! *block-associations*) + (set! *block-label*) + (set! *external-labels*) + (set! *end-of-block-code*) + (set! *next-constant*) + (set! *interned-assignments*) + (set! *interned-constants*) + (set! *interned-global-links*) + (set! *interned-static-variables*) + (set! *interned-uuo-links*) + (set! *interned-variables*) + (set! *label-bindings*) + (set! *code-vector*) + (set! *entry-points*) + (set! *result*) + unspecific) + +(define (initialize-back-end!) + (set! *block-associations* '()) + (set! *block-label* (generate-label)) + (set! *external-labels* '()) + (set! *end-of-block-code* '()) + (set! *next-constant* 0) + (set! *interned-assignments* '()) + (set! *interned-constants* '()) + (set! *interned-global-links* '()) + (set! *interned-static-variables* '()) + (set! *interned-uuo-links* '()) + (set! *interned-variables* '()) + unspecific) + +;;;; Assembler and linker + +(define (phase/assemble) + (compiler-phase + "Assembly" + (lambda () + (with-values (lambda () (assemble *block-label* (last-reference *lap*))) + (lambda (count code-vector labels bindings) + (set! *code-vector* code-vector) + (set! *entry-points* labels) + (set! *label-bindings* bindings) + (if compiler:show-phases? + (begin + (newline) + (write-string *output-prefix*) + (write-string " Branch tensioning done in ") + (write (1+ count)) + (write-string + (if (zero? count) " iteration." " iterations."))))))))) + +(define (phase/link) + (compiler-phase + "Linkification" + (lambda () + ;; This has sections locked against GC to prevent relocation + ;; while computing addresses. + (let* ((label->offset + (lambda (label) + (cdr (or (assq label *label-bindings*) + (error "Missing entry point" label))))) + (bindings + (map (lambda (label) + (cons + label + (with-absolutely-no-interrupts + (lambda () + ((ucode-primitive primitive-object-set-type) + type-code:compiled-entry + (make-non-pointer-object + (+ (label->offset label) + (object-datum *code-vector*)))))))) + *entry-points*)) + (label->address + (lambda (label) + (cdr (or (assq label bindings) + (error "Label not defined as entry point" + label)))))) + (set! *result* + (if *procedure-result?* + (let ((linking-info *subprocedure-linking-info*)) + (let ((compiled-procedure (label->address *entry-label*)) + (translate-label + (let ((block-offset (label->offset *block-label*))) + (lambda (index) + (let ((label (vector-ref linking-info index))) + (and label + (- (label->offset label) + block-offset))))))) + (cons compiled-procedure + (vector + (compiled-code-address->block compiled-procedure) + (translate-label 0) + (translate-label 1) + (vector-ref linking-info 2))))) + (label->address *entry-label*))) + (for-each (lambda (entry) + (set-lambda-body! (car entry) + (label->address (cdr entry)))) + *ic-procedure-headers*)) + ((ucode-primitive declare-compiled-code-block 1) *code-vector*) + (if (not compiler:preserve-data-structures?) + (begin + (set! *code-vector*) + (set! *entry-points*) + (set! *subprocedure-linking-info*) + (set! *label-bindings*) + (set! *block-label*) + (set! *entry-label*) + (set! *ic-procedure-headers*) + unspecific))))) + +;;;; Dumping the assembler's symbol table to the debugging file... + +(define (phase/info-generation-2 pathname) + (info-generation-2 pathname set-compiled-code-block/debugging-info!)) + +(define (info-generation-2 pathname set-debugging-info!) + (compiler-phase "Debugging Information Generation" + (lambda () + (set-debugging-info! + *code-vector* + (and *use-debugging-info?* + (let ((info + (info-generation-phase-3 + (last-reference *dbg-expression*) + (last-reference *dbg-procedures*) + (last-reference *dbg-continuations*) + *label-bindings* + (last-reference *external-labels*)))) + (cond ((eq? pathname 'KEEP) ; for dynamic execution + info) + ((eq? pathname 'RECURSIVE) ; recursive compilation + (set! *recursive-compilation-results* + (cons (vector *recursive-compilation-number* + info + *code-vector*) + *recursive-compilation-results*)) + (cons *info-output-filename* + *recursive-compilation-number*)) + (else + (compiler:dump-info-file + (let ((others (recursive-compilation-results))) + (if (null? others) + info + (list->vector + (cons info + (map (lambda (other) (vector-ref other 1)) + others))))) + pathname) + *info-output-filename*)))))))) + +(define (recursive-compilation-results) + (sort *recursive-compilation-results* + (lambda (x y) + (< (vector-ref x 0) + (vector-ref y 0))))) + +;;; Various ways of dumping an info file + +(define (compiler:dump-inf-file binf pathname) + (fasdump binf pathname true) + (announce-info-files pathname)) + +(define (compiler:dump-bif/bsm-files binf pathname) + (let ((bif-path (pathname-new-type pathname "bif")) + (bsm-path (pathname-new-type pathname "bsm"))) + (let ((bsm (split-inf-structure! binf bsm-path))) + (fasdump binf bif-path true) + (fasdump bsm bsm-path true)) + (announce-info-files bif-path bsm-path))) + +(define (compiler:dump-bci/bcs-files binf pathname) + (let ((bci-path (pathname-new-type pathname "bci")) + (bcs-path (pathname-new-type pathname "bcs"))) + (let ((bsm (split-inf-structure! binf bcs-path))) + (call-with-temporary-filename + (lambda (bif-name) + (fasdump binf bif-name true) + (compress bif-name bci-path))) + (call-with-temporary-filename + (lambda (bsm-name) + (fasdump bsm bsm-name true) + (compress bsm-name bcs-path)))) + (announce-info-files bci-path bcs-path))) + +(define (compiler:dump-bci-file binf pathname) + (let ((bci-path (pathname-new-type pathname "bci"))) + (split-inf-structure! binf false) + (call-with-temporary-filename + (lambda (bif-name) + (fasdump binf bif-name true) + (compress bif-name bci-path))) + (announce-info-files bci-path))) + +(define (announce-info-files . files) + (if compiler:noisy? + (let ((port (nearest-cmdl/port))) + (let loop ((files files)) + (if (null? files) + unspecific + (begin + (fresh-line port) + (write-string ";") + (write (->namestring (car files))) + (write-string " dumped ") + (loop (cdr files)))))))) + +(define compiler:dump-info-file + compiler:dump-bci-file) + +;;;; LAP->CODE +;;; Example of `lap->code' usage (MC68020): + +#| +(define bar + ;; defines bar to be a procedure that adds 1 to its argument + ;; with no type or range checks. + (scode-eval + (lap->code + 'start + `((entry-point start) + (dc uw #xffff) + (block-offset start) + (label start) + (pea (@pcr proc)) + (or b (& ,(* (microcode-type 'compiled-entry) 4)) (@a 7)) + (mov l (@a+ 7) (@ao 6 8)) + (and b (& #x3) (@a 7)) + (rts) + (dc uw #x0202) + (block-offset proc) + (label proc) + (mov l (@a+ 7) (d 0)) + (addq l (& 1) (d 0)) + (mov l (d 0) (@ao 6 8)) + (and b (& #x3) (@a 7)) + (rts))) + '())) +|# + +(define (lap->code label instructions) + (in-compiler + (lambda () + (set! *lap* instructions) + (set! *entry-label* label) + (set! *current-label-number* 0) + (set! *next-constant* 0) + (set! *interned-assignments* '()) + (set! *interned-constants* '()) + (set! *interned-global-links* '()) + (set! *interned-static-variables* '()) + (set! *interned-uuo-links* '()) + (set! *interned-variables* '()) + (set! *block-label* (generate-label)) + (set! *external-labels* '()) + (set! *ic-procedure-headers* '()) + (phase/assemble) + (phase/link) + *result*))) + +(define (canonicalize-label-name name) + ;; The Scheme assembler allows any Scheme symbol as a label + name) \ No newline at end of file diff --git a/v8/src/compiler/base/blocks.scm b/v8/src/compiler/base/blocks.scm new file mode 100644 index 000000000..e0aa12c97 --- /dev/null +++ b/v8/src/compiler/base/blocks.scm @@ -0,0 +1,362 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/blocks.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Environment model data structures +;;; package: (compiler) + +(declare (usual-integrations)) + +#| + +Interpreter compatible (hereafter, IC) blocks are vectors with an +implementation dependent number of reserved slots at the beginning, +followed by the variable bindings for that frame, in the usual order. +The parent of such a frame is always an IC block or a global block, +but extracting a pointer to that parent from the frame is again +implementation dependent and possibly a complex operation. During the +execution of an IC procedure, the block pointer is kept in the ENV +register. + +Perfect closure blocks are vectors whose slots contain the values for +the free variables in a closure procedure. The ordering of these +slots is arbitrary. + +Imperfect closure blocks are similar, except that the first slot of +the vector points to the parent, which is always an IC block. + +Stack blocks are contiguous regions of the stack. A stack block +pointer is the address of that portion of the block which is nearest +to the top of the stack (on the 68000, the most negative address in +the block.) + +In closure and stack blocks, variables which the analyzer can +guarantee will not be modified have their values stored directly in +the block. For all other variables, the binding slot in the block +contains a pointer to a cell which contains the value. + +Note that blocks of type CONTINUATION never have any children. This +is because the body of a continuation is always generated separately +from the continuation, and then "glued" into place afterwards. + +|# + +(define-rvalue block + type ;block type (see below) + parent ;lexically enclosing parent + children ;lexically enclosed children + disowned-children ;children whose `parent' used to be this block + frame-size ;for stack-allocated frames, size in words + procedure ;procedure for which this is invocation block, if any + bound-variables ;list of variables bound by this block + free-variables ;list of variables free in this block or any children + variables-nontransitively-free + ;list of variables free in this block + declarations ;list of declarations + applications ;list of applications lexically within this block + interned-variables ;alist of interned SCode variable objects + closure-offsets ;for closure block, alist of bound variable offsets + debugging-info ;dbg-block, if used + (stack-link ;for stack block, adjacent block on stack + shared-block) ;for multi closures, the official block + (static-link? ;for stack block, true iff static link to parent + entry-number) ;for multi closures, entry number + (popping-limits ;for stack block (see continuation analysis) + grafted-blocks) ;for multi closures, list of blocks that share + popping-limit ;for stack block (see continuation analysis) + layout-frozen? ;used by frame reuse to tell parameter + ;analysis not to alter this block's layout + ;(i.e., don't make any of the block's + ;procedure's parameters be passed by register) + ) + +(define *blocks*) + +(define (make-block parent type) + (let ((block + (make-rvalue block-tag (enumeration/name->index block-types type) + parent '() '() false false '()'() '() '() '() '() '() + false false 'UNKNOWN 'UNKNOWN 'UNKNOWN false))) + (if parent + (set-block-children! parent (cons block (block-children parent)))) + (set! *blocks* (cons block *blocks*)) + block)) + +(define-vector-tag-unparser block-tag + (lambda (state block) + ((standard-unparser + (symbol->string 'BLOCK) + (lambda (state block) + (unparse-object state + (enumeration/index->name block-types + (block-type block))) + (let ((procedure (block-procedure block))) + (if (and procedure (rvalue/procedure? procedure)) + (begin + (unparse-string state " ") + (unparse-label state (procedure-label procedure))))))) + state block))) + +(define-integrable (rvalue/block? rvalue) + (eq? (tagged-vector/tag rvalue) block-tag)) + +(define (add-block-application! block application) + (set-block-applications! block + (cons application (block-applications block)))) + +(define (intern-scode-variable! block name) + (let ((entry (assq name (block-interned-variables block)))) + (if entry + (cdr entry) + (let ((variable (scode/make-variable name))) + (set-block-interned-variables! + block + (cons (cons name variable) (block-interned-variables block))) + variable)))) + +(define block-passed-out? + rvalue-%passed-out?) + +;;;; Block Type + +(define-enumeration block-type + (closure ;heap-allocated closing frame, compiler format + continuation ;continuation invocation frame + expression ;execution frame for expression (indeterminate type) + ic ;interpreter compatible heap-allocated frame + procedure ;invocation frame for procedure (indeterminate type) + stack ;invocation frame for procedure, stack-allocated + )) + +(define (ic-block? block) + (let ((type (block-type block))) + (or (eq? type block-type/ic) + (eq? type block-type/expression)))) + +(define-integrable (closure-block? block) + (eq? (block-type block) block-type/closure)) + +(define-integrable (stack-block? block) + (eq? (block-type block) block-type/stack)) + +(define-integrable (continuation-block? block) + (eq? (block-type block) block-type/continuation)) + +(define (block/external? block) + (and (stack-block? block) + (not (stack-parent? block)))) + +(define (block/internal? block) + (and (stack-block? block) + (stack-parent? block))) + +(define (stack-parent? block) + (and (block-parent block) + (stack-block? (block-parent block)))) + +(define (ic-block/use-lookup? block) + (or (rvalue/procedure? (block-procedure block)) + (not compiler:cache-free-variables?))) + +;;;; Block Inheritance + +(define (block-ancestor-or-self? block block*) + (or (eq? block block*) + (block-ancestor? block block*))) + +(define (block-ancestor? block block*) + (define (loop block) + (and block + (or (eq? block block*) + (loop (block-parent block))))) + (loop (block-parent block))) + +(define-integrable (block-child? block block*) + (eq? block (block-parent block*))) + +(define-integrable (block-sibling? block block*) + ;; Assumes that at least one block has a parent. + (eq? (block-parent block) (block-parent block*))) + +(define (block-nearest-common-ancestor block block*) + (let loop + ((join false) + (ancestry (block-ancestry block)) + (ancestry* (block-ancestry block*))) + (if (and (not (null? ancestry)) + (not (null? ancestry*)) + (eq? (car ancestry) (car ancestry*))) + (loop (car ancestry) (cdr ancestry) (cdr ancestry*)) + join))) + +(define (block-farthest-uncommon-ancestor block block*) + (let loop + ((ancestry (block-ancestry block)) + (ancestry* (block-ancestry block*))) + (and (not (null? ancestry)) + (if (and (not (null? ancestry*)) + (eq? (car ancestry) (car ancestry*))) + (loop (cdr ancestry) (cdr ancestry*)) + (car ancestry))))) + +(define (block-ancestry block) + (let loop ((block (block-parent block)) (path (list block))) + (if block + (loop (block-parent block) (cons block path)) + path))) + +(define (block-partial-ancestry block ancestor) + ;; (assert (or (not ancestor) (block-ancestor-or-self? block ancestor))) + (if (eq? block ancestor) + '() + (let loop ((block (block-parent block)) (path (list block))) + (if (eq? block ancestor) + path + (loop (block-parent block) (cons block path)))))) + +(define (find-outermost-block block) + ;; Should this check whether it is an expression/ic block or not? + (if (block-parent block) + (find-outermost-block (block-parent block)) + block)) + +(define (stack-block/external-ancestor block) + (let ((parent (block-parent block))) + (if (and parent (stack-block? parent)) + (stack-block/external-ancestor parent) + block))) + +(define (block/external-ancestor block) + (if (stack-block? block) + (stack-block/external-ancestor block) + block)) + +(define (stack-block/ancestor-distance block offset join) + (let loop ((block block) (n offset)) + (if (eq? block join) + n + (loop (block-parent block) + (+ n (block-frame-size block)))))) + +(define (for-each-block-descendant! block procedure) + (let loop ((block block)) + (procedure block) + (for-each loop (block-children block)))) + +(define-integrable (stack-block/static-link? block) + (block-static-link? block)) + +(define-integrable (stack-block/continuation-lvalue block) + (procedure-continuation-lvalue (block-procedure block))) + +(define (block/dynamic-link? block) + (and (stack-block? block) + (stack-block/dynamic-link? block))) + +(define (stack-block/dynamic-link? block) + (and (stack-parent? block) + (internal-block/dynamic-link? block))) + +(define-integrable (internal-block/dynamic-link? block) + (not (block-popping-limit block))) + +(define-integrable (original-block-parent block) + ;; This only works for the invocation blocks of procedures (not + ;; continuations), and it assumes that all procedures' target-block + ;; fields have been initialized (i.e. the environment optimizer has + ;; been run). + (let ((procedure (block-procedure block))) + (and procedure + (rvalue/procedure? procedure) + (procedure-target-block procedure)))) + +#| +(define (disown-block-child! block child) + (set-block-children! block (delq! child (block-children block))) + (if (eq? block (original-block-parent child)) + (set-block-disowned-children! block + (cons child (block-disowned-children block)))) + unspecific) + +(define (own-block-child! block child) + (set-block-parent! child block) + (set-block-children! block (cons child (block-children block))) + (if (eq? block (original-block-parent child)) + (set-block-disowned-children! block + (delq! child (block-disowned-children block)))) + unspecific) +|# + +(define (transfer-block-child! child block block*) + ;; equivalent to + ;; (begin + ;; (disown-block-child! block child) + ;; (own-block-child! block* child)) + ;; but faster. + (let ((original-parent (original-block-parent child))) + (set-block-children! block (delq! child (block-children block))) + (if (eq? block original-parent) + (set-block-disowned-children! + block + (cons child (block-disowned-children block)))) + (set-block-parent! child block*) + (if block* + (begin + (set-block-children! block* (cons child (block-children block*))) + (if (eq? block* original-parent) + (set-block-disowned-children! + block* + (delq! child (block-disowned-children block*)))))))) + +(define-integrable (block-number-of-entries block) + (block-entry-number block)) + +(define (closure-block-entry-number block) + (if (eq? block (block-shared-block block)) + 0 + (block-entry-number block))) + +(define (closure-block-first-offset block) + (let ((block* (block-shared-block block))) + (closure-first-offset (block-entry-number block*) + (if (eq? block block*) + 0 + (block-entry-number block))))) + +(define (block-nearest-closure-ancestor block) + (let loop ((block block) (last false)) + (and block + (if (stack-block? block) + (loop (block-parent block) block) + (and (closure-block? block) + last))))) \ No newline at end of file diff --git a/v8/src/compiler/base/cfg1.scm b/v8/src/compiler/base/cfg1.scm new file mode 100644 index 000000000..baefcdbc0 --- /dev/null +++ b/v8/src/compiler/base/cfg1.scm @@ -0,0 +1,180 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/cfg1.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1987, 1989 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Control Flow Graph Abstraction + +(declare (usual-integrations)) + +;;;; Node Datatypes + +(define cfg-node-tag (make-vector-tag false 'CFG-NODE false)) +(define cfg-node? (tagged-vector/subclass-predicate cfg-node-tag)) +(define-vector-slots node 1 generation alist previous-edges) + +(set-vector-tag-description! + cfg-node-tag + (lambda (node) + (descriptor-list node generation alist previous-edges))) + +(define snode-tag (make-vector-tag cfg-node-tag 'SNODE false)) +(define snode? (tagged-vector/subclass-predicate snode-tag)) +(define-vector-slots snode 4 next-edge) + +;;; converted to a macro. +;;; (define (make-snode tag . extra) +;;; (list->vector (cons* tag false '() '() false extra))) + +(set-vector-tag-description! + snode-tag + (lambda (snode) + (append! ((vector-tag-description (vector-tag-parent snode-tag)) snode) + (descriptor-list snode next-edge)))) + +(define pnode-tag (make-vector-tag cfg-node-tag 'PNODE false)) +(define pnode? (tagged-vector/subclass-predicate pnode-tag)) +(define-vector-slots pnode 4 consequent-edge alternative-edge) + +;;; converted to a macro. +;;; (define (make-pnode tag . extra) +;;; (list->vector (cons* tag false '() '() false false extra))) + +(set-vector-tag-description! + pnode-tag + (lambda (pnode) + (append! ((vector-tag-description (vector-tag-parent pnode-tag)) pnode) + (descriptor-list pnode consequent-edge alternative-edge)))) + +(define (add-node-previous-edge! node edge) + (set-node-previous-edges! node (cons edge (node-previous-edges node)))) + +(define (delete-node-previous-edge! node edge) + (set-node-previous-edges! node (delq! edge (node-previous-edges node)))) + +(define-integrable (snode-next snode) + (edge-next-node (snode-next-edge snode))) + +(define-integrable (pnode-consequent pnode) + (edge-next-node (pnode-consequent-edge pnode))) + +(define-integrable (pnode-alternative pnode) + (edge-next-node (pnode-alternative-edge pnode))) + +(define (cfg-node-get node key) + (let ((entry (assq key (node-alist node)))) + (and entry + (cdr entry)))) + +(define (cfg-node-put! node key item) + (let ((entry (assq key (node-alist node)))) + (if entry + (set-cdr! entry item) + (set-node-alist! node (cons (cons key item) (node-alist node)))))) + +(define (cfg-node-remove! node key) + (set-node-alist! node (del-assq! key (node-alist node)))) + +;;;; Edge Datatype + +(define-structure (edge (type vector)) + left-node + left-connect + right-node) + +(define (create-edge! left-node left-connect right-node) + (let ((edge (make-edge left-node left-connect right-node))) + (if left-node + (left-connect left-node edge)) + (if right-node + (add-node-previous-edge! right-node edge)) + edge)) + +(define-integrable (node->edge node) + (create-edge! false false node)) + +(define (edge-next-node edge) + (and edge (edge-right-node edge))) + +(define (edge-connect-left! edge left-node left-connect) + (if (edge-left-node edge) + (error "Attempt to doubly connect left node of edge" edge)) + (if left-node + (begin + (set-edge-left-node! edge left-node) + (set-edge-left-connect! edge left-connect) + (left-connect left-node edge)))) + +(define (edge-connect-right! edge right-node) + (if (edge-right-node edge) + (error "Attempt to doubly connect right node of edge" edge)) + (if right-node + (begin + (set-edge-right-node! edge right-node) + (add-node-previous-edge! right-node edge)))) + +(define (edge-disconnect-left! edge) + (let ((left-node (edge-left-node edge)) + (left-connect (edge-left-connect edge))) + (if left-node + (begin + (set-edge-left-node! edge false) + (set-edge-left-connect! edge false) + (left-connect left-node false))))) + +(define (edge-disconnect-right! edge) + (let ((right-node (edge-right-node edge))) + (if right-node + (begin + (set-edge-right-node! edge false) + (delete-node-previous-edge! right-node edge))))) + +(define (edge-disconnect! edge) + (edge-disconnect-left! edge) + (edge-disconnect-right! edge)) + +(define (edge-replace-left! edge left-node left-connect) + (edge-disconnect-left! edge) + (edge-connect-left! edge left-node left-connect)) + +(define (edge-replace-right! edge right-node) + (edge-disconnect-right! edge) + (edge-connect-right! edge right-node)) + +(define (edges-connect-right! edges right-node) + (for-each (lambda (edge) (edge-connect-right! edge right-node)) edges)) + +(define (edges-disconnect-right! edges) + (for-each edge-disconnect-right! edges)) + +(define (edges-replace-right! edges right-node) + (for-each (lambda (edge) (edge-replace-right! edge right-node)) edges)) \ No newline at end of file diff --git a/v8/src/compiler/base/cfg2.scm b/v8/src/compiler/base/cfg2.scm new file mode 100644 index 000000000..208b77531 --- /dev/null +++ b/v8/src/compiler/base/cfg2.scm @@ -0,0 +1,231 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/cfg2.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1987, 1989 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Control Flow Graph Abstraction + +(declare (usual-integrations)) + +;;;; Editing + +(define (snode-delete! snode) + (let ((next-edge (snode-next-edge snode))) + (if next-edge + (begin + (edges-replace-right! (node-previous-edges snode) + (edge-right-node next-edge)) + (edge-disconnect! next-edge)) + (edges-disconnect-right! (node-previous-edges snode))))) + +(define (edge-insert-snode! edge snode) + (let ((next (edge-right-node edge))) + (edge-replace-right! edge snode) + (create-edge! snode set-snode-next-edge! next))) + +(define (node-insert-snode! node snode) + (edges-replace-right! (node-previous-edges node) snode) + (create-edge! snode set-snode-next-edge! node)) + +(define-integrable (node-disconnect-on-right! node) + (edges-disconnect-right! (node-previous-edges node))) + +(define (node-disconnect-on-left! node) + (if (snode? node) + (snode-disconnect-on-left! node) + (pnode-disconnect-on-left! node))) + +(define (snode-disconnect-on-left! node) + (let ((edge (snode-next-edge node))) + (if edge + (edge-disconnect-left! edge)))) + +(define (pnode-disconnect-on-left! node) + (let ((edge (pnode-consequent-edge node))) + (if edge + (edge-disconnect-left! edge))) + (let ((edge (pnode-alternative-edge node))) + (if edge + (edge-disconnect-left! edge)))) + +(define (node-replace! old-node new-node) + (if (snode? old-node) + (snode-replace! old-node new-node) + (pnode-replace! old-node new-node))) + +(define (snode-replace! old-node new-node) + (node-replace-on-right! old-node new-node) + (snode-replace-on-left! old-node new-node)) + +(define (pnode-replace! old-node new-node) + (node-replace-on-right! old-node new-node) + (pnode-replace-on-left! old-node new-node)) + +(define-integrable (node-replace-on-right! old-node new-node) + (edges-replace-right! (node-previous-edges old-node) new-node)) + +(define (node-replace-on-left! old-node new-node) + (if (snode? old-node) + (snode-replace-on-left! old-node new-node) + (pnode-replace-on-left! old-node new-node))) + +(define (snode-replace-on-left! old-node new-node) + (let ((edge (snode-next-edge old-node))) + (if edge + (edge-replace-left! edge new-node set-snode-next-edge!)))) + +(define (pnode-replace-on-left! old-node new-node) + (let ((edge (pnode-consequent-edge old-node))) + (if edge + (edge-replace-left! edge new-node set-pnode-consequent-edge!))) + (let ((edge (pnode-alternative-edge old-node))) + (if edge + (edge-replace-left! edge new-node set-pnode-alternative-edge!)))) + +;;;; Previous Connections + +(define-integrable (node-previous=0? node) + (edges=0? (node-previous-edges node))) + +(define (edges=0? edges) + (cond ((null? edges) true) + ((edge-left-node (car edges)) false) + (else (edges=0? (cdr edges))))) + +(define-integrable (node-previous>0? node) + (edges>0? (node-previous-edges node))) + +(define (edges>0? edges) + (cond ((null? edges) false) + ((edge-left-node (car edges)) true) + (else (edges>0? (cdr edges))))) + +(define-integrable (node-previous=1? node) + (edges=1? (node-previous-edges node))) + +(define (edges=1? edges) + (if (null? edges) + false + ((if (edge-left-node (car edges)) edges=0? edges=1?) (cdr edges)))) + +(define-integrable (node-previous>1? node) + (edges>1? (node-previous-edges node))) + +(define (edges>1? edges) + (if (null? edges) + false + ((if (edge-left-node (car edges)) edges>0? edges>1?) (cdr edges)))) + +(define-integrable (node-previous-first node) + (edges-first-node (node-previous-edges node))) + +(define (edges-first-node edges) + (if (null? edges) + (error "No first hook") + (or (edge-left-node (car edges)) + (edges-first-node (cdr edges))))) + +(define (for-each-previous-node node procedure) + (for-each (lambda (edge) + (let ((node (edge-left-node edge))) + (if node + (procedure node)))) + (node-previous-edges node))) + +;;;; Noops + +(package (cfg-node-tag/noop! cfg-node-tag/noop?) + +(define-export (cfg-node-tag/noop! tag) + (vector-tag-put! tag noop-tag-property true)) + +(define-export (cfg-node-tag/noop? tag) + (vector-tag-get tag noop-tag-property)) + +(define noop-tag-property + "noop-tag-property") + +) + +(define-integrable (cfg-node/noop? node) + (cfg-node-tag/noop? (tagged-vector/tag node))) + +(define noop-node-tag + (make-vector-tag snode-tag 'NOOP false)) + +(cfg-node-tag/noop! noop-node-tag) + +(define-integrable (make-noop-node) + (let ((node (make-snode noop-node-tag))) + (set! *noop-nodes* (cons node *noop-nodes*)) + node)) + +(define *noop-nodes*) + +(define (cleanup-noop-nodes thunk) + (fluid-let ((*noop-nodes* '())) + (let ((value (thunk))) + (for-each snode-delete! *noop-nodes*) + value))) + +(define (make-false-pcfg) + (snode->pcfg-false (make-noop-node))) + +(define (make-true-pcfg) + (snode->pcfg-true (make-noop-node))) + +;;;; Miscellaneous + +(package (with-new-node-marks + node-marked? + node-mark!) + +(define *generation*) + +(define-export (with-new-node-marks thunk) + (fluid-let ((*generation* (make-generation))) + (thunk))) + +(define make-generation + (let ((generation 0)) + (named-lambda (make-generation) + (let ((value generation)) + (set! generation (1+ generation)) + value)))) + +(define-export (node-marked? node) + (eq? (node-generation node) *generation*)) + +(define-export (node-mark! node) + (set-node-generation! node *generation*)) + +) \ No newline at end of file diff --git a/v8/src/compiler/base/cfg3.scm b/v8/src/compiler/base/cfg3.scm new file mode 100644 index 000000000..230ec2810 --- /dev/null +++ b/v8/src/compiler/base/cfg3.scm @@ -0,0 +1,355 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/cfg3.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1987, 1989 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Control Flow Graph Abstraction + +(declare (usual-integrations)) + +;;;; CFG Datatypes + +;;; A CFG is a compound CFG-node, so there are different types of CFG +;;; corresponding to the (connective-wise) different types of +;;; CFG-node. One may insert a particular type of CFG anywhere in a +;;; graph that its corresponding node may be inserted. + +(define-integrable (make-scfg node next-hooks) + (vector 'SNODE-CFG node next-hooks)) + +(define-integrable (make-scfg* node consequent-hooks alternative-hooks) + (make-scfg node (hooks-union consequent-hooks alternative-hooks))) + +(define-integrable (make-pcfg node consequent-hooks alternative-hooks) + (vector 'PNODE-CFG node consequent-hooks alternative-hooks)) + +(define-integrable (cfg-tag cfg) + (vector-ref cfg 0)) + +(define-integrable (cfg-entry-node cfg) + (vector-ref cfg 1)) + +(define-integrable (scfg-next-hooks scfg) + (vector-ref scfg 2)) + +(define-integrable (pcfg-consequent-hooks pcfg) + (vector-ref pcfg 2)) + +(define-integrable (pcfg-alternative-hooks pcfg) + (vector-ref pcfg 3)) + +(define-integrable (make-null-cfg) false) +(define-integrable cfg-null? false?) + +(define-integrable (cfg-entry-edge cfg) + (node->edge (cfg-entry-node cfg))) + +(define-integrable (snode->scfg snode) + (node->scfg snode set-snode-next-edge!)) + +(define (node->scfg node set-node-next!) + (make-scfg node + (list (make-hook node set-node-next!)))) + +(define-integrable (pnode->pcfg pnode) + (node->pcfg pnode + set-pnode-consequent-edge! + set-pnode-alternative-edge!)) + +(define (node->pcfg node set-node-consequent! set-node-alternative!) + (make-pcfg node + (list (make-hook node set-node-consequent!)) + (list (make-hook node set-node-alternative!)))) + +(define (snode->pcfg-false snode) + (make-pcfg snode + (make-null-hooks) + (list (make-hook snode set-snode-next-edge!)))) + +(define (snode->pcfg-true snode) + (make-pcfg snode + (list (make-hook snode set-snode-next-edge!)) + (make-null-hooks))) + +(define (pcfg-invert pcfg) + (make-pcfg (cfg-entry-node pcfg) + (pcfg-alternative-hooks pcfg) + (pcfg-consequent-hooks pcfg))) + +;;;; Hook Datatype + +(define-integrable make-hook cons) +(define-integrable hook-node car) +(define-integrable hook-connect cdr) + +(define (hook=? x y) + (and (eq? (hook-node x) (hook-node y)) + (eq? (hook-connect x) (hook-connect y)))) + +(define hook-member? + (member-procedure hook=?)) + +(define-integrable (make-null-hooks) + '()) + +(define-integrable hooks-null? + null?) + +(define (hooks-union x y) + (let loop ((x x)) + (cond ((null? x) y) + ((hook-member? (car x) y) (loop (cdr x))) + (else (cons (car x) (loop (cdr x))))))) + +(define (hooks-connect! hooks node) + (for-each (lambda (hook) + (hook-connect! hook node)) + hooks)) + +(define (hook-connect! hook node) + (create-edge! (hook-node hook) (hook-connect hook) node)) + +;;;; Simplicity Tests + +(define (scfg-simple? scfg) + (cfg-branch-simple? (cfg-entry-node scfg) (scfg-next-hooks scfg))) + +(define (pcfg-simple? pcfg) + (let ((entry-node (cfg-entry-node pcfg))) + (and (cfg-branch-simple? entry-node (pcfg-consequent-hooks pcfg)) + (cfg-branch-simple? entry-node (pcfg-alternative-hooks pcfg))))) + +(define (cfg-branch-simple? entry-node hooks) + (and (not (null? hooks)) + (null? (cdr hooks)) + (eq? entry-node (hook-node (car hooks))))) + +(define (scfg-null? scfg) + (or (cfg-null? scfg) + (cfg-branch-null? (cfg-entry-node scfg) + (scfg-next-hooks scfg)))) + +(define (pcfg-true? pcfg) + (and (hooks-null? (pcfg-alternative-hooks pcfg)) + (cfg-branch-null? (cfg-entry-node pcfg) + (pcfg-consequent-hooks pcfg)))) + +(define (pcfg-false? pcfg) + (and (hooks-null? (pcfg-consequent-hooks pcfg)) + (cfg-branch-null? (cfg-entry-node pcfg) + (pcfg-alternative-hooks pcfg)))) + +(define (cfg-branch-null? entry-node hooks) + (and (cfg-branch-simple? entry-node hooks) + (cfg-node/noop? entry-node))) + +;;;; Node-result Constructors + +(define (scfg*node->node! scfg next-node) + (if (scfg-null? scfg) + next-node + (begin + (hooks-connect! (scfg-next-hooks scfg) next-node) + (cfg-entry-node scfg)))) + +(define (pcfg*node->node! pcfg consequent-node alternative-node) + (if (cfg-null? pcfg) + (error "PCFG*NODE->NODE!: Can't have null predicate")) + (cond ((pcfg-true? pcfg) consequent-node) + ((pcfg-false? pcfg) alternative-node) + (else + (hooks-connect! (pcfg-consequent-hooks pcfg) consequent-node) + (hooks-connect! (pcfg-alternative-hooks pcfg) alternative-node) + (cfg-entry-node pcfg)))) + +;;;; CFG Construction + +(define-integrable (scfg-next-connect! scfg cfg) + (hooks-connect! (scfg-next-hooks scfg) (cfg-entry-node cfg))) + +(define-integrable (pcfg-consequent-connect! pcfg cfg) + (hooks-connect! (pcfg-consequent-hooks pcfg) (cfg-entry-node cfg))) + +(define-integrable (pcfg-alternative-connect! pcfg cfg) + (hooks-connect! (pcfg-alternative-hooks pcfg) (cfg-entry-node cfg))) + +(define (scfg*scfg->scfg! scfg scfg*) + (cond ((scfg-null? scfg) scfg*) + ((scfg-null? scfg*) scfg) + (else + (scfg-next-connect! scfg scfg*) + (make-scfg (cfg-entry-node scfg) (scfg-next-hooks scfg*))))) + +(define (scfg-append! . scfgs) + (scfg*->scfg! scfgs)) + +(define scfg*->scfg! + (let () + (define (find-non-null scfgs) + (if (and (not (null? scfgs)) + (scfg-null? (car scfgs))) + (find-non-null (cdr scfgs)) + scfgs)) + + (define (loop first second rest) + (scfg-next-connect! first second) + (if (null? rest) + second + (loop second (car rest) (find-non-null (cdr rest))))) + + (named-lambda (scfg*->scfg! scfgs) + (let ((first (find-non-null scfgs))) + (if (null? first) + (make-null-cfg) + (let ((second (find-non-null (cdr first)))) + (if (null? second) + (car first) + (make-scfg (cfg-entry-node (car first)) + (scfg-next-hooks + (loop (car first) + (car second) + (find-non-null (cdr second)))))))))))) + +(package (scfg*pcfg->pcfg! scfg*pcfg->scfg!) + +(define ((scfg*pcfg->cfg! constructor) scfg pcfg) + (if (cfg-null? pcfg) + (error "SCFG*PCFG->CFG!: Can't have null predicate")) + (cond ((scfg-null? scfg) + (constructor (cfg-entry-node pcfg) + (pcfg-consequent-hooks pcfg) + (pcfg-alternative-hooks pcfg))) + ((pcfg-true? pcfg) + (constructor (cfg-entry-node scfg) + (scfg-next-hooks scfg) + (make-null-hooks))) + ((pcfg-false? pcfg) + (constructor (cfg-entry-node scfg) + (make-null-hooks) + (scfg-next-hooks scfg))) + (else + (scfg-next-connect! scfg pcfg) + (constructor (cfg-entry-node scfg) + (pcfg-consequent-hooks pcfg) + (pcfg-alternative-hooks pcfg))))) + +(define-export scfg*pcfg->pcfg! + (scfg*pcfg->cfg! make-pcfg)) + +(define-export scfg*pcfg->scfg! + (scfg*pcfg->cfg! make-scfg*)) + +) + +(package (pcfg*scfg->pcfg! pcfg*scfg->scfg!) + +(define ((pcfg*scfg->cfg! constructor) pcfg consequent alternative) + (if (cfg-null? pcfg) + (error "PCFG*SCFG->CFG!: Can't have null predicate")) + (cond ((pcfg-true? pcfg) + (constructor (cfg-entry-node consequent) + (scfg-next-hooks consequent) + (make-null-hooks))) + ((pcfg-false? pcfg) + (constructor (cfg-entry-node alternative) + (make-null-hooks) + (scfg-next-hooks alternative))) + (else + (constructor (cfg-entry-node pcfg) + (connect! (pcfg-consequent-hooks pcfg) consequent) + (connect! (pcfg-alternative-hooks pcfg) alternative))))) + +(define (connect! hooks scfg) + (if (or (hooks-null? hooks) + (scfg-null? scfg)) + hooks + (begin + (hooks-connect! hooks (cfg-entry-node scfg)) + (scfg-next-hooks scfg)))) + +(define-export pcfg*scfg->pcfg! + (pcfg*scfg->cfg! make-pcfg)) + +(define-export pcfg*scfg->scfg! + (pcfg*scfg->cfg! make-scfg*)) + +) + +(package (pcfg*pcfg->pcfg! pcfg*pcfg->scfg!) + +(define ((pcfg*pcfg->cfg! constructor) pcfg consequent alternative) + (if (cfg-null? pcfg) + (error "PCFG*PCFG->CFG!: Can't have null predicate")) + (cond ((pcfg-true? pcfg) + (constructor (cfg-entry-node consequent) + (pcfg-consequent-hooks consequent) + (pcfg-alternative-hooks consequent))) + ((pcfg-false? pcfg) + (constructor (cfg-entry-node alternative) + (pcfg-consequent-hooks alternative) + (pcfg-alternative-hooks alternative))) + (else + (connect! (pcfg-consequent-hooks pcfg) + consequent + consequent-select + (lambda (cchooks cahooks) + (connect! (pcfg-alternative-hooks pcfg) + alternative + alternative-select + (lambda (achooks aahooks) + (constructor (cfg-entry-node pcfg) + (hooks-union cchooks achooks) + (hooks-union cahooks aahooks))))))))) + +(define (connect! hooks pcfg select receiver) + (cond ((hooks-null? hooks) (receiver (make-null-hooks) (make-null-hooks))) + ((cfg-null? pcfg) (select receiver hooks)) + ((pcfg-true? pcfg) (consequent-select receiver hooks)) + ((pcfg-false? pcfg) (alternative-select receiver hooks)) + (else + (hooks-connect! hooks (cfg-entry-node pcfg)) + (receiver (pcfg-consequent-hooks pcfg) + (pcfg-alternative-hooks pcfg))))) + +(define-integrable (consequent-select receiver hooks) + (receiver hooks (make-null-hooks))) + +(define-integrable (alternative-select receiver hooks) + (receiver (make-null-hooks) hooks)) + +(define-export pcfg*pcfg->pcfg! + (pcfg*pcfg->cfg! make-pcfg)) + +(define-export pcfg*pcfg->scfg! + (pcfg*pcfg->cfg! make-scfg*)) + +) \ No newline at end of file diff --git a/v8/src/compiler/base/constr.scm b/v8/src/compiler/base/constr.scm new file mode 100644 index 000000000..c40d492a0 --- /dev/null +++ b/v8/src/compiler/base/constr.scm @@ -0,0 +1,270 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/constr.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1989-91 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;; Procedures for managing a set of ordering constraints + +(define-structure (constraint + (conc-name constraint/) + (constructor + &make-constraint (element))) + (element false read-only true) + (graph-head false) + (afters '()) + (generation) + (closed? true)) + +(define-structure (constraint-graph + (conc-name constraint-graph/) + (constructor make-constraint-graph ())) + (entry-nodes '()) + (closed? true)) + +(define (make-constraint element #!optional graph-head afters) + (let ((constraint (&make-constraint element))) + (if (and (not (default-object? graph-head)) + (constraint-graph? graph-head)) + (begin + (set-constraint/graph-head! constraint graph-head) + (set-constraint-graph/entry-nodes! + graph-head + (cons constraint (constraint-graph/entry-nodes graph-head))))) + (if (not (default-object? afters)) + (for-each + (lambda (after) (constraint-add! constraint after)) + afters)) + constraint)) + +(define (find-constraint element graph-head) + + (define (loop children) + (if (pair? children) + (or (search (car children)) + (loop (cdr children))) + false)) + + (define (search constraint) + (if (eqv? element (constraint/element constraint)) + constraint + (loop (constraint/afters constraint)))) + + (loop (constraint-graph/entry-nodes graph-head))) + +(define (find-or-make-constraint element graph-head + #!optional afters) + (or (find-constraint element graph-head) + (if (default-object? afters) + (make-constraint element graph-head) + (make-constraint element graph-head afters)))) + + +(define (constraint-add! before after) + (if (eq? (constraint/element before) (constraint/element after)) + (error "A node cannot be constrained to come after itself" after)) + (set-constraint/afters! before (cons after (constraint/afters before))) + (let ((c-graph (constraint/graph-head after))) + (if c-graph + (set-constraint-graph/entry-nodes! + c-graph + (delq! after (constraint-graph/entry-nodes c-graph))))) + (set-constraint/closed?! before false) + (if (constraint/graph-head before) + (set-constraint-graph/closed?! + (constraint/graph-head before) + false))) + +(define (add-constraint-element! before-element after-element + graph-head) + (find-or-make-constraint + before-element + graph-head + (list after-element))) + +(define (add-constraint-set! befores afters graph-head) + (let ((after-constraints + (map (lambda (after) + (find-or-make-constraint after graph-head)) + afters))) + (for-each + (lambda (before) + (find-or-make-constraint before graph-head after-constraints)) + befores))) + +(define (close-constraint-graph! c-graph) + (with-new-constraint-marks + (lambda () + (for-each close-constraint-node! + (constraint-graph/entry-nodes c-graph)))) + (set-constraint-graph/closed?! c-graph true)) + +(define (close-constraint-node! node) + (with-new-constraint-marks + (lambda () + (&close-constraint-node! node)))) + +(define (&close-constraint-node! node) + (transitively-close-dag! + node + constraint/afters + (lambda (before afters) + (set-constraint/afters! + before + (append + (constraint/afters before) + (if (memq node afters) + (error + "Illegal cycle in constraint graph involving node:" + node) + afters)))) + constraint-marked? + (lambda (node) + (constraint-mark! node) + (set-constraint/closed?! node true)))) + +(define (transitively-close-dag! node select update! marked? mark!) + (let transitively-close*! ((node node)) + (let ((elements (select node))) + (if (or (null? elements) (marked? node)) + elements + (begin + (mark! node) + (update! node (append-map transitively-close*! elements)) + (select node)))))) + +(define (order-per-constraints elements constraint-graph) + (order-per-constraints/extracted + elements + constraint-graph + identity-procedure)) + +(define (order-per-constraints/extracted things + constraint-graph + element-extractor) +;;; This orders a set of things according to the constraints where the +;;; things are not elements of the constraint-graph nodes but elements +;;; can be extracted from the things by element-extractor + (let loop ((linearized-constraints + (reverse-postorder + (constraint-graph/entry-nodes constraint-graph) + constraint/afters + with-new-constraint-marks + constraint-mark! + constraint-marked?)) + (things things) + (result '())) + (if (and (pair? linearized-constraints) + (pair? things)) + (let ((match (list-search-positive + things + (lambda (thing) + (eqv? + (constraint/element + (car linearized-constraints)) + (element-extractor thing)))))) + (loop (cdr linearized-constraints) + (delv match things) + (if (and match + (not (memv match result))) + (cons match result) + result))) + (reverse! result)))) + +(define (legal-ordering-per-constraints? element-ordering constraint-graph) + (let loop ((ordering element-ordering) + (nodes (constraint-graph/entry-nodes constraint-graph))) + + (define (depth-first-search? node) + (if (or (null? node) (constraint-marked? node)) + false + (begin + (constraint-mark! node) + (if (eq? (constraint/element node) (car ordering)) + (loop (cdr ordering) (constraint/afters node)) + (multiple-search? (constraint/afters node)))))) + + (define (multiple-search? nodes) + (if (null? nodes) + false + (or (depth-first-search? (car nodes)) + (multiple-search? (cdr nodes))))) + + (if (null? ordering) + true + (with-new-constraint-marks + (lambda () + (multiple-search? nodes)))))) + +(define (reverse-postorder entry-nodes get-children + with-new-node-marks node-mark! + node-marked?) + + (define result) + + (define (loop node) + (node-mark! node) + (for-each next (get-children node)) + (set! result (cons node result))) + + (define (next node) + (and node + (not (node-marked? node)) + (loop node))) + + (define (doit node) + (set! result '()) + (loop node) + (reverse! result)) + + (with-new-node-marks + (lambda () + (append-map! doit entry-nodes)))) + +(define *constraint-generation*) + +(define (with-new-constraint-marks thunk) + (fluid-let ((*constraint-generation* (make-constraint-generation))) + (thunk))) + +(define make-constraint-generation + (let ((constraint-generation 0)) + (named-lambda (make-constraint/generation) + (let ((value constraint-generation)) + (set! constraint-generation (1+ constraint-generation)) + value)))) + +(define (constraint-marked? constraint) + (eq? (constraint/generation constraint) *constraint-generation*)) + +(define (constraint-mark! constraint) + (set-constraint/generation! constraint *constraint-generation*)) + diff --git a/v8/src/compiler/base/crsend.scm b/v8/src/compiler/base/crsend.scm new file mode 100644 index 000000000..ec24191bc --- /dev/null +++ b/v8/src/compiler/base/crsend.scm @@ -0,0 +1,190 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/crsend.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1988-1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Cross Compiler End +;;; This program does not need the rest of the compiler, but should +;;; match the version of the same name in crstop.scm and toplev.scm + +(declare (usual-integrations)) + +(define (cross-compile-bin-file-end input-string #!optional output-string) + (compiler-pathnames input-string + (and (not (default-object? output-string)) output-string) + (make-pathname false false false false "moc" 'NEWEST) + (lambda (input-pathname output-pathname) + output-pathname ;ignore + (cross-compile-scode-end (fasload input-pathname))))) + +(define (compiler-pathnames input-string output-string default transform) + (let ((kernel + (lambda (input-string) + (let ((input-pathname (merge-pathnames input-string default))) + (let ((output-pathname + (let ((output-pathname + (pathname-new-type input-pathname "com"))) + (if output-string + (merge-pathnames output-string output-pathname) + output-pathname)))) + (newline) + (write-string "Compile File: ") + (write (enough-namestring input-pathname)) + (write-string " => ") + (write (enough-namestring output-pathname)) + (fasdump (transform input-pathname output-pathname) + output-pathname)))))) + (if (pair? input-string) + (for-each kernel input-string) + (kernel input-string)))) + +(define (cross-compile-scode-end cross-compilation) + (let ((compile-by-procedures? (vector-ref cross-compilation 0)) + (expression (cross-link-end (vector-ref cross-compilation 1))) + (others (map cross-link-end (vector-ref cross-compilation 2)))) + (if (null? others) + expression + (scode/make-comment + (make-dbg-info-vector + (let ((all-blocks + (list->vector + (cons + (compiled-code-address->block expression) + others)))) + (if compile-by-procedures? + (list 'COMPILED-BY-PROCEDURES + all-blocks + (list->vector others)) + all-blocks))) + expression)))) + +(define-structure (cc-code-block (type vector) + (conc-name cc-code-block/)) + (debugging-info false read-only false) + (bit-string false read-only true) + (objects false read-only true) + (object-width false read-only true)) + +(define-structure (cc-vector (type vector) + (constructor cc-vector/make) + (conc-name cc-vector/)) + (code-vector false read-only true) + (entry-label false read-only true) + (entry-points false read-only true) + (label-bindings false read-only true) + (ic-procedure-headers false read-only true)) + +(define (cross-link-end object) + (let ((code-vector (cc-vector/code-vector object))) + (cross-link/process-code-vector + (cond ((compiled-code-block? code-vector) + code-vector) + ((vector? code-vector) + (let ((new-code-vector (cross-link/finish-assembly + (cc-code-block/bit-string code-vector) + (cc-code-block/objects code-vector) + (cc-code-block/object-width code-vector)))) + (set-compiled-code-block/debugging-info! + new-code-vector + (cc-code-block/debugging-info code-vector)) + new-code-vector)) + (else + (error "cross-link-end: Unexpected code-vector" + code-vector object))) + object))) + +(define (cross-link/process-code-vector code-vector cc-vector) + (let ((bindings + (let ((label-bindings (cc-vector/label-bindings cc-vector))) + (map (lambda (label) + (cons + label + (with-absolutely-no-interrupts + (lambda () + (let-syntax ((ucode-primitive + (macro (name) + (make-primitive-procedure name))) + (ucode-type + (macro (name) + (microcode-type name)))) + ((ucode-primitive PRIMITIVE-OBJECT-SET-TYPE) + (ucode-type COMPILED-ENTRY) + (make-non-pointer-object + (+ (cdr (or (assq label label-bindings) + (error "Missing entry point" label))) + (object-datum code-vector))))))))) + (cc-vector/entry-points cc-vector))))) + (let ((label->expression + (lambda (label) + (cdr (or (assq label bindings) + (error "Label not defined as entry point" label)))))) + (let ((expression (label->expression (cc-vector/entry-label cc-vector)))) + (for-each (lambda (entry) + (set-lambda-body! (car entry) + (label->expression (cdr entry)))) + (cc-vector/ic-procedure-headers cc-vector)) + expression)))) + +(define (cross-link/finish-assembly code-block objects scheme-object-width) + (let-syntax ((ucode-primitive + (macro (name) + (make-primitive-procedure name))) + (ucode-type + (macro (name) + (microcode-type name)))) + (let* ((bl (quotient (bit-string-length code-block) + scheme-object-width)) + (non-pointer-length + ((ucode-primitive make-non-pointer-object) bl)) + (output-block (make-vector (1+ (+ (length objects) bl))))) + (with-absolutely-no-interrupts + (lambda () + (vector-set! output-block 0 + ((ucode-primitive primitive-object-set-type) + (ucode-type manifest-nm-vector) + non-pointer-length)))) + (write-bits! output-block + ;; After header just inserted. + (* scheme-object-width 2) + code-block) + (insert-objects! output-block objects (1+ bl)) + (object-new-type (ucode-type compiled-code-block) + output-block)))) + +(define (insert-objects! v objects where) + (cond ((not (null? objects)) + (vector-set! v where (cadar objects)) + (insert-objects! v (cdr objects) (1+ where))) + ((not (= where (vector-length v))) + (error "insert-objects!: object phase error" where)) + (else + unspecific))) \ No newline at end of file diff --git a/v8/src/compiler/base/crstop.scm b/v8/src/compiler/base/crstop.scm new file mode 100644 index 000000000..6c5261070 --- /dev/null +++ b/v8/src/compiler/base/crstop.scm @@ -0,0 +1,93 @@ +#| -*-Scheme-*- + +$Id: crstop.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1988-1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Cross Compiler Top Level. +;;; This code shares and should be merged with "toplev.scm". +;;; Many of the procedures only differ in the default extensions. + +(declare (usual-integrations)) + +(define (cross-compile-bin-file-end input-string #!optional output-string) + (compiler-pathnames + input-string + (and (not (default-object? output-string)) output-string) + (make-pathname false false false false "moc" 'NEWEST) + (lambda (input-pathname output-pathname) + output-pathname ; ignored + (cross-compile-scode-end (compiler-fasload input-pathname))))) + +(define (cross-compile-scode-end cross-compilation) + (in-compiler + (lambda () + (cross-link-end cross-compilation) + *result*))) + +(define-structure (cc-code-block (type vector) + (conc-name cc-code-block/)) + (debugging-info false read-only false) + (bit-string false read-only true) + (objects false read-only true) + (object-width false read-only true)) + +(define-structure (cc-vector (type vector) + (constructor cc-vector/make) + (conc-name cc-vector/)) + (code-vector false read-only true) + (entry-label false read-only true) + (entry-points false read-only true) + (label-bindings false read-only true) + (ic-procedure-headers false read-only true)) + +(define (cross-compiler-phase/info-generation-2 pathname) + (info-generation-2 pathname set-cc-code-block/debugging-info!)) + +(define (cross-compiler-phase/link) + (compiler-phase + "Cross Linkification" + (lambda () + (set! *result* + (cc-vector/make *code-vector* + (last-reference *entry-label*) + (last-reference *entry-points*) + (last-reference *label-bindings*) + (last-reference *ic-procedure-headers*))) + unspecific))) + +(define (cross-link-end cc-vector) + (set! *code-vector* (cc-vector/code-vector cc-vector)) + (set! *entry-label* (cc-vector/entry-label cc-vector)) + (set! *entry-points* (cc-vector/entry-points cc-vector)) + (set! *label-bindings* (cc-vector/label-bindings cc-vector)) + (set! *ic-procedure-headers* (cc-vector/ic-procedure-headers cc-vector)) + (phase/link)) \ No newline at end of file diff --git a/v8/src/compiler/base/debug.scm b/v8/src/compiler/base/debug.scm new file mode 100644 index 000000000..e91405101 --- /dev/null +++ b/v8/src/compiler/base/debug.scm @@ -0,0 +1,239 @@ +#| -*-Scheme-*- + +$Id: debug.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Compiler Debugging Support + +(declare (usual-integrations)) + +(define (po object) + (let ((object (->tagged-vector object))) + (write-line object) + (for-each pp ((tagged-vector/description object) object)))) + +(define (debug/find-procedure name) + (let loop ((procedures *procedures*)) + (and (not (null? procedures)) + (if (and (not (procedure-continuation? (car procedures))) + (or (eq? name (procedure-name (car procedures))) + (eq? name (procedure-label (car procedures))))) + (car procedures) + (loop (cdr procedures)))))) + +(define (debug/find-continuation number) + (let ((label + (intern (string-append "continuation-" (number->string number))))) + (let loop ((procedures *procedures*)) + (and (not (null? procedures)) + (if (and (procedure-continuation? (car procedures)) + (eq? label (procedure-label (car procedures)))) + (car procedures) + (loop (cdr procedures))))))) + +(define (debug/find-entry-node node) + (let ((node (->tagged-vector node))) + (if (eq? (expression-entry-node *root-expression*) node) + (write-line *root-expression*)) + (for-each (lambda (procedure) + (if (eq? (procedure-entry-node procedure) node) + (write-line procedure))) + *procedures*))) + +(define (debug/where object) + (cond ((compiled-code-block? object) + (write-line (compiled-code-block/debugging-info object))) + ((compiled-code-address? object) + (write-line + (compiled-code-block/debugging-info + (compiled-code-address->block object))) + (write-string "\nOffset: ") + (write-string + (number->string (compiled-code-address->offset object) 16))) + (else + (error "debug/where -- what?" object)))) + +(define (write-rtl-instructions rtl port) + (write-instructions + (lambda () + (with-output-to-port port + (lambda () + (for-each show-rtl-instruction rtl)))))) + +(define (dump-rtl filename) + (write-instructions + (lambda () + (with-output-to-file (pathname-new-type (->pathname filename) "rtl") + (lambda () + (for-each show-rtl-instruction + (linearize-rtl *rtl-graphs* + '() + '() + false))))))) + +(define (show-rtl rtl) + (newline) + (pp-instructions + (lambda () + (for-each show-rtl-instruction rtl)))) + +(define (show-bblock-rtl bblock) + (newline) + (pp-instructions + (lambda () + (bblock-walk-forward (->tagged-vector bblock) + (lambda (rinst) + (show-rtl-instruction (rinst-rtl rinst))))))) + +(define (write-instructions thunk) + (fluid-let ((*show-instruction* write) + (*unparser-radix* 16) + (*unparse-uninterned-symbols-by-name?* true)) + (thunk))) + +(define (pp-instructions thunk) + (fluid-let ((*show-instruction* pretty-print) + (*pp-primitives-by-name* false) + (*unparser-radix* 16) + (*unparse-uninterned-symbols-by-name?* true)) + (thunk))) + +(define *show-instruction*) + +(define (show-rtl-instruction rtl) + (if (memq (car rtl) + '(LABEL CONTINUATION-ENTRY CONTINUATION-HEADER IC-PROCEDURE-HEADER + OPEN-PROCEDURE-HEADER PROCEDURE-HEADER CLOSURE-HEADER + ;; New stuff + RETURN-ADDRESS PROCEDURE TRIVIAL-CLOSURE CLOSURE + EXPRESSION + )) + (newline)) + (*show-instruction* rtl) + (newline)) + +(define procedure-queue) +(define procedures-located) + +(define (show-fg) + (fluid-let ((procedure-queue (make-queue)) + (procedures-located '())) + (write-string "\n---------- Expression ----------") + (fg/print-object *root-expression*) + (with-new-node-marks + (lambda () + (fg/print-entry-node (expression-entry-node *root-expression*)) + (queue-map!/unsafe procedure-queue + (lambda (procedure) + (if (procedure-continuation? procedure) + (write-string "\n\n---------- Continuation ----------") + (write-string "\n\n---------- Procedure ----------")) + (fg/print-object procedure) + (fg/print-entry-node (procedure-entry-node procedure)))))) + (write-string "\n\n---------- Blocks ----------") + (fg/print-blocks (expression-block *root-expression*)))) + +(define (show-fg-node node) + (fluid-let ((procedure-queue false)) + (with-new-node-marks + (lambda () + (fg/print-entry-node + (let ((node (->tagged-vector node))) + (if (procedure? node) + (procedure-entry-node node) + node))))))) + +(define (fg/print-entry-node node) + (if node + (fg/print-node node))) + +(define (fg/print-object object) + (newline) + (po object)) + +(define (fg/print-blocks block) + (fg/print-object block) + (for-each fg/print-object (block-bound-variables block)) + (if (not (block-parent block)) + (for-each fg/print-object (block-free-variables block))) + (for-each fg/print-blocks (block-children block)) + (for-each fg/print-blocks (block-disowned-children block))) + +(define (fg/print-node node) + (if (and node + (not (node-marked? node))) + (begin + (node-mark! node) + (fg/print-object node) + (cfg-node-case (tagged-vector/tag node) + ((PARALLEL) + (for-each fg/print-subproblem (parallel-subproblems node)) + (fg/print-node (snode-next node))) + ((APPLICATION) + (fg/print-rvalue (application-operator node)) + (for-each fg/print-rvalue (application-operands node))) + ((VIRTUAL-RETURN) + (fg/print-rvalue (virtual-return-operand node)) + (fg/print-node (snode-next node))) + ((POP) + (fg/print-rvalue (pop-continuation node)) + (fg/print-node (snode-next node))) + ((ASSIGNMENT) + (fg/print-rvalue (assignment-rvalue node)) + (fg/print-node (snode-next node))) + ((DEFINITION) + (fg/print-rvalue (definition-rvalue node)) + (fg/print-node (snode-next node))) + ((TRUE-TEST) + (fg/print-rvalue (true-test-rvalue node)) + (fg/print-node (pnode-consequent node)) + (fg/print-node (pnode-alternative node))) + ((STACK-OVERWRITE FG-NOOP) + (fg/print-node (snode-next node))))))) + +(define (fg/print-rvalue rvalue) + (if procedure-queue + (let ((rvalue (rvalue-known-value rvalue))) + (if (and rvalue + (rvalue/procedure? rvalue) + (not (memq rvalue procedures-located))) + (begin + (set! procedures-located (cons rvalue procedures-located)) + (enqueue!/unsafe procedure-queue rvalue)))))) + +(define (fg/print-subproblem subproblem) + (fg/print-object subproblem) + (if (subproblem-canonical? subproblem) + (fg/print-rvalue (subproblem-continuation subproblem))) + (let ((prefix (subproblem-prefix subproblem))) + (if (not (cfg-null? prefix)) + (fg/print-node (cfg-entry-node prefix))))) \ No newline at end of file diff --git a/v8/src/compiler/base/enumer.scm b/v8/src/compiler/base/enumer.scm new file mode 100644 index 000000000..9868b2566 --- /dev/null +++ b/v8/src/compiler/base/enumer.scm @@ -0,0 +1,120 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/enumer.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1988, 1989 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Support for enumerations + +(declare (usual-integrations)) + +;;;; Enumerations + +(define-structure (enumeration + (conc-name enumeration/) + (constructor %make-enumeration)) + (enumerands false read-only true)) + +(define-structure (enumerand + (conc-name enumerand/) + (print-procedure + (standard-unparser (symbol->string 'ENUMERAND) + (lambda (state enumerand) + (unparse-object state (enumerand/name enumerand)))))) + (enumeration false read-only true) + (name false read-only true) + (index false read-only true)) + +(define (make-enumeration names) + (let ((enumerands (make-vector (length names)))) + (let ((enumeration (%make-enumeration enumerands))) + (let loop ((names names) (index 0)) + (if (not (null? names)) + (begin + (vector-set! enumerands + index + (make-enumerand enumeration (car names) index)) + (loop (cdr names) (1+ index))))) + enumeration))) + +(define-integrable (enumeration/cardinality enumeration) + (vector-length (enumeration/enumerands enumeration))) + +(define-integrable (enumeration/index->enumerand enumeration index) + (vector-ref (enumeration/enumerands enumeration) index)) + +(define-integrable (enumeration/index->name enumeration index) + (enumerand/name (enumeration/index->enumerand enumeration index))) + +(define (enumeration/name->enumerand enumeration name) + (let ((end (enumeration/cardinality enumeration))) + (let loop ((index 0)) + (if (< index end) + (let ((enumerand (enumeration/index->enumerand enumeration index))) + (if (eqv? (enumerand/name enumerand) name) + enumerand + (loop (1+ index)))) + (error "Unknown enumeration name" name))))) + +(define-integrable (enumeration/name->index enumeration name) + (enumerand/index (enumeration/name->enumerand enumeration name))) + +;;;; Method Tables + +(define-structure (method-table (constructor %make-method-table)) + (enumeration false read-only true) + (vector false read-only true)) + +(define (make-method-table enumeration default-method . method-alist) + (let ((table + (%make-method-table enumeration + (make-vector (enumeration/cardinality enumeration) + default-method)))) + (for-each (lambda (entry) + (define-method-table-entry table (car entry) (cdr entry))) + method-alist) + table)) + +(define (define-method-table-entry name method-table method) + (vector-set! (method-table-vector method-table) + (enumeration/name->index (method-table-enumeration method-table) + name) + method) + name) + +(define (define-method-table-entries names method-table method) + (for-each (lambda (name) + (define-method-table-entry name method-table method)) + names) + names) + +(define-integrable (method-table-lookup method-table index) + (vector-ref (method-table-vector method-table) index)) \ No newline at end of file diff --git a/v8/src/compiler/base/infnew.scm b/v8/src/compiler/base/infnew.scm new file mode 100644 index 000000000..9ec7a679a --- /dev/null +++ b/v8/src/compiler/base/infnew.scm @@ -0,0 +1,386 @@ +#| -*-Scheme-*- + +$Id: infnew.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Debugging Information +;;; package: (compiler debugging-information) + +(declare (usual-integrations)) + +(define (info-generation-phase-1 expression procedures) + (fluid-let ((*integrated-variables* '())) + (set-expression-debugging-info! + expression + (make-dbg-expression (block->dbg-block (expression-block expression)) + (expression-label expression))) + (for-each + (lambda (procedure) + (if (procedure-continuation? procedure) + (set-continuation/debugging-info! + procedure + (let ((block (block->dbg-block (continuation/block procedure)))) + (let ((continuation + (make-dbg-continuation + block + (continuation/label procedure) + (enumeration/index->name continuation-types + (continuation/type procedure)) + (continuation/offset procedure) + (continuation/debugging-info procedure)))) + (set-dbg-block/procedure! block continuation) + continuation))) + (set-procedure-debugging-info! + procedure + (let ((block (block->dbg-block (procedure-block procedure)))) + (let ((procedure + (make-dbg-procedure + block + (procedure-label procedure) + (procedure/type procedure) + (procedure-name procedure) + (map variable->dbg-variable + (cdr (procedure-original-required procedure))) + (map variable->dbg-variable + (procedure-original-optional procedure)) + (let ((rest (procedure-original-rest procedure))) + (and rest (variable->dbg-variable rest))) + (map variable->dbg-variable (procedure-names procedure)) + (procedure-debugging-info procedure)))) + (set-dbg-block/procedure! block procedure) + procedure))))) + procedures) + (for-each process-integrated-variable! *integrated-variables*))) + +(define (generated-dbg-continuation context label) + (let ((block + (make-dbg-block/continuation (reference-context/block context) + false))) + (let ((continuation + (make-dbg-continuation block + label + 'GENERATED + (reference-context/offset context) + false))) + (set-dbg-block/procedure! block continuation) + continuation))) + +(define (block->dbg-block block) + (and block + (or (block-debugging-info block) + (let ((dbg-block + (enumeration-case block-type (block-type block) + ((STACK) (stack-block->dbg-block block)) + ((CONTINUATION) (continuation-block->dbg-block block)) + ((CLOSURE) (closure-block->dbg-block block)) + ((IC) (ic-block->dbg-block block)) + (else + (error "BLOCK->DBG-BLOCK: Illegal block type" block))))) + (set-block-debugging-info! block dbg-block) + dbg-block)))) + +(define (stack-block->dbg-block block) + (let ((parent (block-parent block)) + (frame-size (block-frame-size block)) + (procedure (block-procedure block))) + (let ((layout (make-layout frame-size))) + (for-each (lambda (variable) + (if (not (continuation-variable? variable)) + (layout-set! layout + (variable-normal-offset variable) + (variable->dbg-variable variable)))) + (block-bound-variables block)) + (if (procedure/closure? procedure) + (if (closure-procedure-needs-operator? procedure) + (layout-set! layout + (procedure-closure-offset procedure) + dbg-block-name/normal-closure)) + (if (stack-block/static-link? block) + (layout-set! layout + (-1+ frame-size) + dbg-block-name/static-link))) + (make-dbg-block 'STACK + (block->dbg-block parent) + (if (procedure/closure? procedure) + (block->dbg-block + (reference-context/block + (procedure-closure-context procedure))) + (block->dbg-block + (procedure-target-block procedure))) + layout + (block->dbg-block (block-stack-link block)))))) + +(define (continuation-block->dbg-block block) + (make-dbg-block/continuation + (block-parent block) + (continuation/always-known-operator? (block-procedure block)))) + +(define (make-dbg-block/continuation parent always-known?) + (let ((dbg-parent (block->dbg-block parent))) + (make-dbg-block + 'CONTINUATION + dbg-parent + false + (let ((names + (append (if always-known? + '() + (list dbg-block-name/return-address)) + (if (block/dynamic-link? parent) + (list dbg-block-name/dynamic-link) + '()) + (if (ic-block? parent) + (list dbg-block-name/ic-parent) + '())))) + (let ((layout (make-layout (length names)))) + (do ((names names (cdr names)) + (index 0 (1+ index))) + ((null? names)) + (layout-set! layout index (car names))) + layout)) + dbg-parent))) + +(define (closure-block->dbg-block block) + (let ((parent (block-parent block)) + (start-offset + (closure-object-first-offset + (block-entry-number (block-shared-block block)))) + (offsets + (map (lambda (offset) + (cons (car offset) + (- (cdr offset) + (closure-block-first-offset block)))) + (block-closure-offsets block)))) + (let ((layout (make-layout (1+ (apply max (map cdr offsets)))))) + (for-each (lambda (offset) + (layout-set! layout + (cdr offset) + (variable->dbg-variable (car offset)))) + offsets) + (if (and parent (ic-block/use-lookup? parent)) + (layout-set! layout 0 dbg-block-name/ic-parent)) + (make-dbg-block 'CLOSURE (block->dbg-block parent) false + (cons start-offset layout) + false)))) + +(define (ic-block->dbg-block block) + (make-dbg-block 'IC (block->dbg-block (block-parent block)) + false false false)) + +(define-integrable (make-layout length) + (make-vector length false)) + +(define (layout-set! layout index name) + (let ((name* (vector-ref layout index))) + (if name* (error "LAYOUT-SET!: reusing layout slot" name* name))) + (vector-set! layout index name) + unspecific) + +(define *integrated-variables*) + +(define (variable->dbg-variable variable) + (or (lvalue-get variable dbg-variable-tag) + (let ((integrated? (lvalue-integrated? variable)) + (indirection (variable-indirection variable))) + (let ((dbg-variable + (make-dbg-variable + (variable-name variable) + (cond (integrated? 'INTEGRATED) + (indirection 'INDIRECTED) + ((variable-in-cell? variable) 'CELL) + (else 'NORMAL)) + (cond (integrated? + (lvalue-known-value variable)) + (indirection + ;; This currently does not examine whether it is a + ;; simple indirection, or a closure indirection. + ;; The value displayed will be incorrect if it + ;; is a closure indirection, but... + (variable->dbg-variable (car indirection))) + (else + false))))) + (if integrated? + (set! *integrated-variables* + (cons dbg-variable *integrated-variables*))) + (lvalue-put! variable dbg-variable-tag dbg-variable) + dbg-variable)))) + +(define dbg-variable-tag + "dbg-variable-tag") + +(define (process-integrated-variable! variable) + (set-dbg-variable/value! + variable + (let ((rvalue (dbg-variable/value variable))) + (cond ((rvalue/constant? rvalue) (constant-value rvalue)) + ((rvalue/procedure? rvalue) (procedure-debugging-info rvalue)) + (else (error "Illegal variable value" rvalue)))))) + +(define (info-generation-phase-2 expression procedures continuations) + (let ((debug-info + (lambda (selector object) + (or (selector object) + (error "Missing debugging info" object))))) + (values + (and expression (debug-info rtl-expr/debugging-info expression)) + (map (lambda (procedure) + (let ((info (debug-info rtl-procedure/debugging-info procedure))) + (set-dbg-procedure/external-label! + info + (rtl-procedure/%external-label procedure)) + info)) + procedures) + (map (lambda (continuation) + (debug-info rtl-continuation/debugging-info continuation)) + continuations)))) + +(define (info-generation-phase-3 expression procedures continuations + label-bindings external-labels) + (let ((label-bindings (labels->dbg-labels label-bindings)) + (no-datum '(NO-DATUM))) + (let ((labels (make-string-hash-table))) + (for-each (lambda (label-binding) + (for-each (lambda (key) + (let ((datum + (hash-table/get labels key no-datum))) + (if (not (eq? datum no-datum)) + (error "Redefining label:" key datum))) + (hash-table/put! labels + key + (cdr label-binding))) + (car label-binding))) + label-bindings) + (let ((map-label/fail + (lambda (label) + (let ((key (system-pair-car label))) + (let ((datum (hash-table/get labels key no-datum))) + (if (eq? datum no-datum) + (error "Missing label:" key)) + datum)))) + (map-label/false + (lambda (label) + (hash-table/get labels (system-pair-car label) #f)))) + (for-each (lambda (label) + (set-dbg-label/external?! (map-label/fail label) true)) + external-labels) + (if expression + (set-dbg-expression/label! + expression + (map-label/fail (dbg-expression/label expression)))) + (for-each + (lambda (procedure) + (let* ((internal-label (dbg-procedure/label procedure)) + (mapped-label (map-label/false internal-label))) + (set-dbg-procedure/label! procedure mapped-label) + (cond ((dbg-procedure/external-label procedure) + => (lambda (label) + (set-dbg-procedure/external-label! + procedure + (map-label/fail label)))) + ((not mapped-label) + (error "Missing label" internal-label))))) + procedures) + (for-each + (lambda (continuation) + (set-dbg-continuation/label! + continuation + (map-label/fail (dbg-continuation/label continuation)))) + continuations))) + (make-dbg-info + expression + (list->vector (sort procedures dbg-procedurevector (sort continuations dbg-continuationvector (map cdr label-bindings))))) + +(define (labels->dbg-labels label-bindings) + (map (lambda (offset-binding) + (let ((names (cdr offset-binding))) + (cons names + (make-dbg-label-2 (choose-distinguished-label names) + (car offset-binding))))) + (let ((offsets (make-rb-tree = <))) + (for-each (lambda (binding) + (let ((offset (cdr binding)) + (name (system-pair-car (car binding)))) + (let ((datum (rb-tree/lookup offsets offset #f))) + (if datum + (set-cdr! datum (cons name (cdr datum))) + (rb-tree/insert! offsets offset (list name)))))) + label-bindings) + (rb-tree->alist offsets)))) + +(define (choose-distinguished-label names) + (if (null? (cdr names)) + (car names) + (let ((distinguished + (list-transform-negative names + (lambda (name) + (or (standard-name? name "label") + (standard-name? name "end-label")))))) + (cond ((null? distinguished) + (min-suffix names)) + ((null? (cdr distinguished)) + (car distinguished)) + (else + (min-suffix distinguished)))))) + +(define char-set:label-separators + (char-set #\- #\_)) + +(define (min-suffix names) + (let ((suffix-number + (lambda (name) + (let ((index (string-find-previous-char-in-set + name + char-set:label-separators))) + (if (not index) + (error "Illegal label name" name)) + (let ((suffix (string-tail name (1+ index)))) + (let ((result (string->number suffix))) + (if (not result) + (error "Illegal label suffix" suffix)) + result)))))) + (car (sort names (lambda (x y) + (< (suffix-number x) + (suffix-number y))))))) + +(define (standard-name? string prefix) + (let ((index (string-match-forward-ci string prefix)) + (end (string-length string))) + (and (= index (string-length prefix)) + (>= (- end index) 2) + (let ((next (string-ref string index))) + (or (char=? #\- next) + (char=? #\_ next))) + (let loop ((index (1+ index))) + (or (= index end) + (and (char-numeric? (string-ref string index)) + (loop (1+ index)))))))) \ No newline at end of file diff --git a/v8/src/compiler/base/macros.scm b/v8/src/compiler/base/macros.scm new file mode 100644 index 000000000..ef86cd84d --- /dev/null +++ b/v8/src/compiler/base/macros.scm @@ -0,0 +1,359 @@ +#| -*-Scheme-*- + +$Id: macros.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1988-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Compiler Macros +;;; package: (compiler macros) + +(declare (usual-integrations)) + +(define (initialize-package!) + (for-each (lambda (entry) + (syntax-table-define compiler-syntax-table (car entry) + (cadr entry))) + `((CFG-NODE-CASE ,transform/cfg-node-case) + (DEFINE-ENUMERATION ,transform/define-enumeration) + (DEFINE-EXPORT ,transform/define-export) + (DEFINE-LVALUE ,transform/define-lvalue) + (DEFINE-PNODE ,transform/define-pnode) + (DEFINE-ROOT-TYPE ,transform/define-root-type) + (DEFINE-RTL-EXPRESSION ,transform/define-rtl-expression) + (DEFINE-RTL-PREDICATE ,transform/define-rtl-predicate) + (DEFINE-RTL-STATEMENT ,transform/define-rtl-statement) + (DEFINE-RULE ,transform/define-rule) + (DEFINE-RVALUE ,transform/define-rvalue) + (DEFINE-SNODE ,transform/define-snode) + (DEFINE-VECTOR-SLOTS ,transform/define-vector-slots) + (DESCRIPTOR-LIST ,transform/descriptor-list) + (ENUMERATION-CASE ,transform/enumeration-case) + (INST-EA ,transform/inst-ea) + (LAP ,transform/lap) + (LAST-REFERENCE ,transform/last-reference) + (MAKE-LVALUE ,transform/make-lvalue) + (MAKE-PNODE ,transform/make-pnode) + (MAKE-RVALUE ,transform/make-rvalue) + (MAKE-SNODE ,transform/make-snode) + (PACKAGE ,transform/package))) + (syntax-table-define lap-generator-syntax-table 'DEFINE-RULE + transform/define-rule)) + +(define compiler-syntax-table + (make-syntax-table syntax-table/system-internal)) + +(define lap-generator-syntax-table + (make-syntax-table compiler-syntax-table)) + +(define assembler-syntax-table + (make-syntax-table compiler-syntax-table)) + +(define early-syntax-table + (make-syntax-table compiler-syntax-table)) + +(define transform/last-reference + (macro (name) + (let ((x (generate-uninterned-symbol))) + `(IF COMPILER:PRESERVE-DATA-STRUCTURES? + ,name + (LET ((,x ,name)) + (SET! ,name) + ,x))))) + +(define (transform/package names . body) + (make-syntax-closure + (make-sequence + `(,@(map (lambda (name) + (make-definition name (make-unassigned-reference-trap))) + names) + ,(make-combination + (let ((block (syntax* body))) + (if (open-block? block) + (open-block-components block + (lambda (names* declarations body) + (make-lambda lambda-tag:let '() '() false + (list-transform-negative names* + (lambda (name) + (memq name names))) + declarations + body))) + (make-lambda lambda-tag:let '() '() false '() + '() block))) + '()))))) + +(define transform/define-export + (macro (pattern . body) + (parse-define-syntax pattern body + (lambda (name body) + name + `(SET! ,pattern ,@body)) + (lambda (pattern body) + `(SET! ,(car pattern) + (NAMED-LAMBDA ,pattern ,@body)))))) + +(define transform/define-vector-slots + (macro (class index . slots) + (define (loop slots n) + (if (null? slots) + '() + (let ((make-defs + (lambda (slot) + (let ((ref-name (symbol-append class '- slot))) + `(BEGIN + (DEFINE-INTEGRABLE (,ref-name ,class) + (VECTOR-REF ,class ,n)) + (DEFINE-INTEGRABLE (,(symbol-append 'SET- ref-name '!) + ,class ,slot) + (VECTOR-SET! ,class ,n ,slot)))))) + (rest (loop (cdr slots) (1+ n)))) + (if (pair? (car slots)) + (map* rest make-defs (car slots)) + (cons (make-defs (car slots)) rest))))) + (if (null? slots) + '*THE-NON-PRINTING-OBJECT* + `(BEGIN ,@(loop slots index))))) + +(define transform/define-root-type + (macro (type . slots) + (let ((tag-name (symbol-append type '-TAG))) + `(BEGIN (DEFINE ,tag-name + (MAKE-VECTOR-TAG FALSE ',type FALSE)) + (DEFINE ,(symbol-append type '?) + (TAGGED-VECTOR/SUBCLASS-PREDICATE ,tag-name)) + (DEFINE-VECTOR-SLOTS ,type 1 ,@slots) + (SET-VECTOR-TAG-DESCRIPTION! + ,tag-name + (LAMBDA (,type) + (DESCRIPTOR-LIST ,type ,@slots))))))) + +(define transform/descriptor-list + (macro (type . slots) + (let ((ref-name (lambda (slot) (symbol-append type '- slot)))) + `(LIST ,@(map (lambda (slot) + (if (pair? slot) + (let ((ref-names (map ref-name slot))) + ``(,',ref-names ,(,(car ref-names) ,type))) + (let ((ref-name (ref-name slot))) + ``(,',ref-name ,(,ref-name ,type))))) + slots))))) + +(let-syntax + ((define-type-definition + (macro (name reserved enumeration) + (let ((parent (symbol-append name '-TAG))) + `(DEFINE ,(symbol-append 'TRANSFORM/DEFINE- name) + (macro (type . slots) + (let ((tag-name (symbol-append type '-TAG))) + `(BEGIN (DEFINE ,tag-name + (MAKE-VECTOR-TAG ,',parent ',type ,',enumeration)) + (DEFINE ,(symbol-append type '?) + (TAGGED-VECTOR/PREDICATE ,tag-name)) + (DEFINE-VECTOR-SLOTS ,type ,,reserved ,@slots) + (SET-VECTOR-TAG-DESCRIPTION! + ,tag-name + (LAMBDA (,type) + (APPEND! + ((VECTOR-TAG-DESCRIPTION ,',parent) ,type) + (DESCRIPTOR-LIST ,type ,@slots)))))))))))) + (define-type-definition snode 5 false) + (define-type-definition pnode 6 false) + (define-type-definition rvalue 2 rvalue-types) + (define-type-definition lvalue 14 false)) + +;;; Kludge to make these compile efficiently. + +(define transform/make-snode + (macro (tag . extra) + `((ACCESS VECTOR ,system-global-environment) + ,tag FALSE '() '() FALSE ,@extra))) + +(define transform/make-pnode + (macro (tag . extra) + `((ACCESS VECTOR ,system-global-environment) + ,tag FALSE '() '() FALSE FALSE ,@extra))) + +(define transform/make-rvalue + (macro (tag . extra) + `((ACCESS VECTOR ,system-global-environment) + ,tag FALSE ,@extra))) + +(define transform/make-lvalue + (macro (tag . extra) + (let ((result (generate-uninterned-symbol))) + `(let ((,result + ((ACCESS VECTOR ,system-global-environment) + ,tag FALSE '() '() '() '() '() '() 'NOT-CACHED + FALSE '() FALSE FALSE '() ,@extra))) + (SET! *LVALUES* (CONS ,result *LVALUES*)) + ,result)))) + +(define transform/define-rtl-expression) +(define transform/define-rtl-statement) +(define transform/define-rtl-predicate) +(let ((rtl-common + (lambda (type prefix components wrap-constructor types) + `(BEGIN + (SET! ,types (CONS ',type ,types)) + (DEFINE-INTEGRABLE + (,(symbol-append prefix 'MAKE- type) ,@components) + ,(wrap-constructor `(LIST ',type ,@components))) + (DEFINE-INTEGRABLE (,(symbol-append 'RTL: type '?) EXPRESSION) + (EQ? (CAR EXPRESSION) ',type)) + ,@(let loop ((components components) + (ref-index 6) + (set-index 2)) + (if (null? components) + '() + (let* ((slot (car components)) + (name (symbol-append type '- slot))) + `((DEFINE-INTEGRABLE (,(symbol-append 'RTL: name) ,type) + (GENERAL-CAR-CDR ,type ,ref-index)) + ,(let ((slot (if (eq? slot type) + (symbol-append slot '-VALUE) + slot))) + `(DEFINE-INTEGRABLE + (,(symbol-append 'RTL:SET- name '!) + ,type ,slot) + (SET-CAR! (GENERAL-CAR-CDR ,type ,set-index) + ,slot))) + ,@(loop (cdr components) + (* ref-index 2) + (* set-index 2)))))))))) + (set! transform/define-rtl-expression + (macro (type prefix . components) + (rtl-common type prefix components + identity-procedure + 'RTL:EXPRESSION-TYPES))) + + (set! transform/define-rtl-statement + (macro (type prefix . components) + (rtl-common type prefix components + (lambda (expression) `(STATEMENT->SRTL ,expression)) + 'RTL:STATEMENT-TYPES))) + + (set! transform/define-rtl-predicate + (macro (type prefix . components) + (rtl-common type prefix components + (lambda (expression) `(PREDICATE->PRTL ,expression)) + 'RTL:PREDICATE-TYPES)))) + +;(define transform/define-rule +; (macro (type pattern . body) +; (parse-rule pattern body +; (lambda (pattern variables qualifier actions) +; `(,(case type +; ((STATEMENT) 'ADD-STATEMENT-RULE!) +; ((PREDICATE) 'ADD-STATEMENT-RULE!) +; ((REWRITING) 'ADD-REWRITING-RULE!) +; (else type)) +; ',pattern +; ,(rule-result-expression variables qualifier +; `(BEGIN ,@actions))))))) + +(define transform/define-rule + (macro (type pattern . body) + (parse-rule pattern body + (lambda (pattern variables qualifier actions) + `(,(case type + ((STATEMENT) 'ADD-STATEMENT-RULE!) + ((PREDICATE) 'ADD-STATEMENT-RULE!) + ((REWRITING) 'ADD-REWRITING-RULE!) + (else type)) + ',pattern + ,(compile-pattern + pattern + (rule-result-expression variables qualifier + `(BEGIN ,@actions)))))))) + +;;;; Lap instruction sequences. + +(define transform/lap + (macro some-instructions + (list 'QUASIQUOTE some-instructions))) + +(define transform/inst-ea + (macro (ea) + (list 'QUASIQUOTE ea))) + +(define transform/define-enumeration + (macro (name elements) + (let ((enumeration (symbol-append name 'S))) + `(BEGIN (DEFINE ,enumeration + (MAKE-ENUMERATION ',elements)) + ,@(map (lambda (element) + `(DEFINE ,(symbol-append name '/ element) + (ENUMERATION/NAME->INDEX ,enumeration ',element))) + elements))))) + +(define (macros/case-macro expression clauses predicate default) + (let ((need-temp? (not (symbol? expression)))) + (let ((expression* + (if need-temp? + (generate-uninterned-symbol) + expression))) + (let ((body + `(COND + ,@(let loop ((clauses clauses)) + (cond ((null? clauses) + (default expression*)) + ((eq? (caar clauses) 'ELSE) + (if (null? (cdr clauses)) + clauses + (error "ELSE clause not last" clauses))) + (else + `(((OR ,@(map (lambda (element) + (predicate expression* element)) + (caar clauses))) + ,@(cdar clauses)) + ,@(loop (cdr clauses))))))))) + (if need-temp? + `(LET ((,expression* ,expression)) + ,body) + body))))) + +(define transform/enumeration-case + (macro (name expression . clauses) + (macros/case-macro expression + clauses + (lambda (expression element) + `(EQ? ,expression ,(symbol-append name '/ element))) + (lambda (expression) + expression + '())))) + +(define transform/cfg-node-case + (macro (expression . clauses) + (macros/case-macro expression + clauses + (lambda (expression element) + `(EQ? ,expression ,(symbol-append element '-TAG))) + (lambda (expression) + `((ELSE (ERROR "Unknown node type" ,expression))))))) \ No newline at end of file diff --git a/v8/src/compiler/base/make.scm b/v8/src/compiler/base/make.scm new file mode 100644 index 000000000..d65d97ad7 --- /dev/null +++ b/v8/src/compiler/base/make.scm @@ -0,0 +1,67 @@ +#| -*-Scheme-*- + +$Id: make.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Compiler: System Construction + +(declare (usual-integrations)) + +(lambda (architecture-name) + (let ((core + (lambda () + (load-option 'COMPRESS) + (load-option 'HASH-TABLE) + (load-option 'RB-TREE) + (package/system-loader "compiler" '() 'QUERY)))) + #| + ((access with-directory-rewriting-rule + (->environment '(RUNTIME COMPILER-INFO))) + (working-directory-pathname) + (pathname-as-directory "compiler") + core) + |# + (core) + (let ((initialize-package! + (lambda (package-name) + ((environment-lookup (->environment package-name) + 'INITIALIZE-PACKAGE!))))) + (initialize-package! '(COMPILER MACROS)) + (initialize-package! '(COMPILER DECLARATIONS))) + (add-system! + (make-system (string-append "Liar (" + (if (procedure? architecture-name) + (architecture-name) + architecture-name) + ")") + 5 0 + '())))) \ No newline at end of file diff --git a/v8/src/compiler/base/mvalue.scm b/v8/src/compiler/base/mvalue.scm new file mode 100644 index 000000000..6d601017e --- /dev/null +++ b/v8/src/compiler/base/mvalue.scm @@ -0,0 +1,81 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/mvalue.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Multiple Value Support + +(declare (usual-integrations)) + +(define (transmit-values transmitter receiver) + (transmitter receiver)) + +(define (multiple-value-list transmitter) + (transmitter list)) + +(define (return . values) + (lambda (receiver) + (apply receiver values))) + +;;; For efficiency: + +(define (return-2 v0 v1) + (lambda (receiver) + (receiver v0 v1))) + +(define (return-3 v0 v1 v2) + (lambda (receiver) + (receiver v0 v1 v2))) + +(define (return-4 v0 v1 v2 v3) + (lambda (receiver) + (receiver v0 v1 v2 v3))) + +(define (return-5 v0 v1 v2 v3 v4) + (lambda (receiver) + (receiver v0 v1 v2 v3 v4))) + +(define (return-6 v0 v1 v2 v3 v4 v5) + (lambda (receiver) + (receiver v0 v1 v2 v3 v4 v5))) + +(define (list-multiple first . rest) + (apply call-multiple list first rest)) + +(define (cons-multiple cars cdrs) + (call-multiple cons cars cdrs)) + +(define (call-multiple procedure . transmitters) + (apply return + (apply map + procedure + (map multiple-value-list transmitters)))) \ No newline at end of file diff --git a/v8/src/compiler/base/object.scm b/v8/src/compiler/base/object.scm new file mode 100644 index 000000000..ce027d1a9 --- /dev/null +++ b/v8/src/compiler/base/object.scm @@ -0,0 +1,160 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/object.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1988, 1989 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Support for tagged objects + +(declare (usual-integrations)) + +(define-structure (vector-tag + (constructor %make-vector-tag (parent name index))) + (parent false read-only true) + (name false read-only true) + (index false read-only true) + (%unparser false) + (description false) + (method-alist '())) + +(define make-vector-tag + (let ((root-tag (%make-vector-tag false 'OBJECT false))) + (set-vector-tag-%unparser! + root-tag + (lambda (state object) + ((standard-unparser + (symbol->string (vector-tag-name (tagged-vector/tag object))) + false) + state object))) + (named-lambda (make-vector-tag parent name enumeration) + (let ((tag + (%make-vector-tag (or parent root-tag) + name + (and enumeration + (enumeration/name->index enumeration + name))))) + (unparser/set-tagged-vector-method! tag tagged-vector/unparse) + tag)))) + +(define (define-vector-tag-unparser tag unparser) + (set-vector-tag-%unparser! tag unparser) + (vector-tag-name tag)) + +(define (vector-tag-unparser tag) + (or (vector-tag-%unparser tag) + (let ((parent (vector-tag-parent tag))) + (if parent + (vector-tag-unparser parent) + (error "Missing unparser" tag))))) + +(define (vector-tag-put! tag key value) + (let ((entry (assq key (vector-tag-method-alist tag)))) + (if entry + (set-cdr! entry value) + (set-vector-tag-method-alist! tag + (cons (cons key value) + (vector-tag-method-alist tag)))))) + +(define (vector-tag-get tag key) + (let ((value + (or (assq key (vector-tag-method-alist tag)) + (let loop ((tag (vector-tag-parent tag))) + (and tag + (or (assq key (vector-tag-method-alist tag)) + (loop (vector-tag-parent tag)))))))) + (and value (cdr value)))) + +(define (define-vector-tag-method tag name method) + (vector-tag-put! tag name method) + name) + +(define (vector-tag-method tag name) + (or (vector-tag-get tag name) + (error "Unbound method" name tag))) + +(define-integrable make-tagged-vector + vector) + +(define-integrable (tagged-vector/tag vector) + (vector-ref vector 0)) + +(define-integrable (tagged-vector/index vector) + (vector-tag-index (tagged-vector/tag vector))) + +(define-integrable (tagged-vector/unparser vector) + (vector-tag-unparser (tagged-vector/tag vector))) + +(define (tagged-vector? object) + (and (vector? object) + (not (zero? (vector-length object))) + (vector-tag? (tagged-vector/tag object)))) + +(define (->tagged-vector object) + (let ((object + (if (exact-nonnegative-integer? object) + (unhash object) + object))) + (and (or (tagged-vector? object) + (named-structure? object)) + object))) + +(define (tagged-vector/predicate tag) + (lambda (object) + (and (vector? object) + (not (zero? (vector-length object))) + (eq? tag (tagged-vector/tag object))))) + +(define (tagged-vector/subclass-predicate tag) + (lambda (object) + (and (vector? object) + (not (zero? (vector-length object))) + (let loop ((tag* (tagged-vector/tag object))) + (and (vector-tag? tag*) + (or (eq? tag tag*) + (loop (vector-tag-parent tag*)))))))) + +(define (tagged-vector/description object) + (cond ((named-structure? object) + named-structure/description) + ((tagged-vector? object) + (vector-tag-description (tagged-vector/tag object))) + (else + (error "Not a tagged vector" object)))) + +(define (standard-unparser name unparser) + (let ((name (string-append (symbol->string 'LIAR) ":" name))) + (if unparser + (unparser/standard-method name unparser) + (unparser/standard-method name)))) + +(define (tagged-vector/unparse state vector) + (fluid-let ((*unparser-radix* 16)) + ((tagged-vector/unparser vector) state vector))) \ No newline at end of file diff --git a/v8/src/compiler/base/parass.scm b/v8/src/compiler/base/parass.scm new file mode 100644 index 000000000..5fe51a118 --- /dev/null +++ b/v8/src/compiler/base/parass.scm @@ -0,0 +1,147 @@ +#| -*-Scheme-*- + +$Id: parass.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Parallel assignment code +;;; package: (compiler) + +(declare (usual-integrations)) + +(define (parallel-assignment dependencies) + ;; Each dependency is a list whose car is the target and + ;; whose cdr is the list of locations containing the (old) + ;; values needed to compute the new contents of the target. + (let ((pairs (map (lambda (dependency) + (cons (car dependency) + (topo-node/make dependency))) + dependencies))) + (for-each + (lambda (pair) + (let ((before (cdr pair))) + (for-each + (lambda (dependent) + (let ((pair (assq dependent pairs))) + (and pair + (let ((after (cdr pair))) + ;; For parallel assignment, + ;; self-dependence is irrelevant. + (and (not (eq? after before)) + (set-topo-node/before! + after + (cons before (topo-node/before after))) + (set-topo-node/after! + before + (cons after (topo-node/after before)))))))) + (cdr (topo-node/contents before))))) + pairs) + ;; *** This should use the heuristics for n < 6 *** + (let loop ((nodes* (reverse (sort-topologically (map cdr pairs)))) + (result '()) + (needed-to-right '())) + (if (null? nodes*) + result + (let* ((node (car nodes*)) + (dependency (topo-node/contents node)) + (references (cdr dependency))) + (loop (cdr nodes*) + (cons (vector (topo-node/early? node) + dependency + (eq-set-difference references needed-to-right)) + result) + (eq-set-union references needed-to-right))))))) + +(define-structure (topo-node + (conc-name topo-node/) + (constructor topo-node/make (contents))) + (contents false read-only true) + (before '() read-only false) + (after '() read-only false) + (nbefore false read-only false) + (early? false read-only false) + (dequeued false read-only false)) + +(define (sort-topologically nodes) + (let* ((nnodes (length nodes)) + (buckets (make-vector (+ 1 nnodes) '()))) + (define (update! node) + (set-topo-node/dequeued! node true) + (for-each (lambda (node*) + (if (not (topo-node/dequeued node*)) + (let* ((nbefore (topo-node/nbefore node*)) + (nbefore* (- nbefore 1))) + (set-topo-node/nbefore! node* nbefore*) + (vector-set! buckets + nbefore + (delq node* + (vector-ref buckets nbefore))) + (vector-set! buckets + nbefore* + (cons node* + (vector-ref buckets nbefore*)))))) + (topo-node/after node))) + + (define (phase-2 left accum) + ;; There must be a cycle, remove an early block + ;; (bkpt "Foo") + (let loop ((index 1)) + (cond ((>= index nnodes) + (error "Could not find a node, but some are left" left)) + ((null? (vector-ref buckets index)) + (loop (+ index 1))) + (else + (let* ((bucket (vector-ref buckets index)) + (node (car bucket))) + (set-topo-node/early?! node true) + (vector-set! buckets index (cdr bucket)) + (update! node) + (phase-1 (- left 1) (cons node accum))))))) + + (define (phase-1 left accum) + (cond ((= left 0) + (reverse accum)) + ((null? (vector-ref buckets 0)) + (phase-2 left accum)) + (else + (let ((node (car (vector-ref buckets 0)))) + (vector-set! buckets 0 (cdr (vector-ref buckets 0))) + (update! node) + (phase-1 (- left 1) (cons node accum)))))) + + (for-each (lambda (node) + (let ((n (length (topo-node/before node)))) + (set-topo-node/nbefore! node n) + (vector-set! buckets + n + (cons node (vector-ref buckets n))))) + nodes) + (phase-1 nnodes '()))) \ No newline at end of file diff --git a/v8/src/compiler/base/pmerly.scm b/v8/src/compiler/base/pmerly.scm new file mode 100644 index 000000000..50cb299f5 --- /dev/null +++ b/v8/src/compiler/base/pmerly.scm @@ -0,0 +1,729 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/pmerly.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Very Simple Pattern Matcher: Early rule compilation and lookup + +(declare (usual-integrations)) + +;;;; Database construction + +(define (early-make-rule pattern variables body) + (list pattern variables body)) + +(define (early-parse-rule pattern receiver) + (extract-variables pattern receiver)) + +(define (extract-variables pattern receiver) + (cond ((not (pair? pattern)) + (receiver pattern '())) + ((eq? (car pattern) '@) + (error "early-parse-rule: ?@ is not an implemented pattern" + pattern)) + ((eq? (car pattern) '?) + (receiver (make-pattern-variable (cadr pattern)) + (list (cons (cadr pattern) + (if (null? (cddr pattern)) + '() + (list (cons (car pattern) + (cddr pattern)))))))) + (else + (extract-variables (car pattern) + (lambda (car-pattern car-variables) + (extract-variables (cdr pattern) + (lambda (cdr-pattern cdr-variables) + (receiver (cons car-pattern cdr-pattern) + (merge-variables-lists car-variables + cdr-variables))))))))) + +(define (merge-variables-lists x y) + (cond ((null? x) y) + ((null? y) x) + (else + (let ((entry (assq (caar x) y))) + (if entry + #| + (cons (append! (car x) (cdr entry)) + (merge-variables-lists (cdr x) + (delq! entry y))) + |# + (error "early-parse-rule: repeated variables not supported" + (list (caar x) entry)) + (cons (car x) + (merge-variables-lists (cdr x) + y))))))) + +;;;; Early rule processing and code compilation + +(define (early-pattern-lookup rules instance #!optional transformers unparsed + receiver limit) + (if (default-object? limit) (set! limit *rule-limit*)) + (if (or (default-object? receiver) (null? receiver)) + (set! receiver + (lambda (result code) + (cond ((false? result) + (error "early-pattern-lookup: No pattern matches" + instance)) + ((eq? result 'TOO-MANY) + (error "early-pattern-lookup: Too many patterns match" + limit instance)) + (else code))))) + (parse-instance instance + (lambda (expression bindings) + (apply (lambda (result program) + (receiver result + (if (or (eq? result true) (eq? result 'MAYBE)) + (scode/make-block bindings '() program) + false))) + (fluid-let ((*rule-limit* limit) + (*transformers* (if (default-object? transformers) + '() + transformers))) + (try-rules rules expression + (scode/make-error-combination + "early-pattern-lookup: No pattern matches" + (if (or (default-object? unparsed) (null? unparsed)) + (scode/make-constant instance) + unparsed)) + list)))))) + +(define (parse-instance instance receiver) + (cond ((not (pair? instance)) + (receiver instance '())) + ((eq? (car instance) 'UNQUOTE) + ;; Shadowing may not permit the optimization below. + ;; I think the code is being careful, but... + (let ((expression (cadr instance))) + (if (scode/variable? expression) + (receiver (make-evaluation expression) '()) + (let ((var (make-variable-name 'RESULT))) + (receiver (make-evaluation (scode/make-variable var)) + (list (scode/make-binding var expression))))))) + ((eq? (car instance) 'UNQUOTE-SPLICING) + (error "parse-instance: unquote-splicing not supported" instance)) + (else (parse-instance (car instance) + (lambda (instance-car car-bindings) + (parse-instance (cdr instance) + (lambda (instance-cdr cdr-bindings) + (receiver (cons instance-car instance-cdr) + (append car-bindings cdr-bindings))))))))) + +;;;; Find matching rules and collect them + +(define *rule-limit* '()) + +(define (try-rules rules expression null-form receiver) + (define (loop rules null-form bindings nrules) + (cond ((and (not (null? *rule-limit*)) + (> nrules *rule-limit*)) + (receiver 'TOO-MANY false)) + ((not (null? rules)) + (try-rule (car rules) + expression + null-form + (lambda (result code) + (cond ((false? result) + (loop (cdr rules) null-form bindings nrules)) + ((eq? result 'MAYBE) + (let ((var (make-variable-name 'TRY-NEXT-RULE-))) + (loop (cdr rules) + (scode/make-combination (scode/make-variable var) + '()) + (cons (cons var code) + bindings) + (1+ nrules)))) + (else (receiver true code)))))) + ((null? bindings) + (receiver false null-form)) + ((null? (cdr bindings)) + (receiver 'MAYBE (cdar bindings))) + (else + (receiver 'MAYBE + (scode/make-letrec + (map (lambda (pair) + (scode/make-binding + (car pair) + (scode/make-thunk (cdr pair)))) + bindings) + null-form))))) + (loop rules null-form '() 0)) + +;;;; Match one rule + +(define (try-rule rule expression null-form continuation) + (define (try pattern expression receiver) + (cond ((evaluation? expression) + (receiver '() (list (cons expression pattern)))) + ((not (pair? pattern)) + (if (eqv? pattern expression) + (receiver '() '()) + (continuation false null-form))) + ((pattern-variable? pattern) + (receiver (list (cons (pattern-variable-name pattern) expression)) + '())) + ((not (pair? expression)) + (continuation false null-form)) + (else + (try (car pattern) + (car expression) + (lambda (car-bindings car-evaluations) + (try (cdr pattern) + (cdr expression) + (lambda (cdr-bindings cdr-evaluations) + (receiver (append car-bindings cdr-bindings) + (append car-evaluations + cdr-evaluations))))))))) + (try (car rule) + expression + (lambda (bindings evaluations) + (match-bind bindings evaluations + (cadr rule) (caddr rule) + null-form continuation)))) + +;;;; Early rule processing + +(define (match-bind bindings evaluations variables body null-form receiver) + (process-evaluations evaluations true bindings + (lambda (outer-test bindings) + (define (find-early-bindings original test bindings) + (if (null? original) + (generate-match-code outer-test test + bindings body + null-form receiver) + (bind-variable-early (car original) + variables + (lambda (var-test var-bindings) + (if (false? var-test) + (receiver false null-form) + (find-early-bindings (cdr original) + (scode/merge-tests var-test test) + (append var-bindings bindings))))))) + (if (false? outer-test) + (receiver false null-form) + (find-early-bindings bindings true '()))))) + +(define (process-evaluations evaluations test bindings receiver) + (if (null? evaluations) + (receiver test bindings) + (let ((evaluation (car evaluations))) + (build-comparison (cdr evaluation) + (cdar evaluation) + (lambda (new-test new-bindings) + (process-evaluations + (cdr evaluations) + (scode/merge-tests new-test test) + (append new-bindings bindings) + receiver)))))) + +;;;; Early variable processing + +(define (bind-variable-early var+pattern variables receiver) + (let ((name (car var+pattern)) + (expression (cdr var+pattern))) + (let ((var (assq name variables))) + (cond ((not var) + (error "match-bind: nonexistent variable" + name variables)) + ((null? (cdr var)) + (let ((exp (unevaluate expression))) + (receiver true + (list + (if (scode/constant? exp) + (make-early-binding name exp) + (make-outer-binding name exp)))))) + (else + (if (not (eq? (caadr var) '?)) + (error "match-bind: ?@ unimplemented" var)) + (let ((transformer (cadr (cadr var))) + (rename (if (null? (cddr (cadr var))) + name + (caddr (cadr var))))) + (apply-transformer-early transformer name rename + expression receiver))))))) + +(define (unevaluate exp) + (cond ((not (pair? exp)) + (scode/make-constant exp)) + ((evaluation? exp) + (evaluation-expression exp)) + (else + (let ((the-car (unevaluate (car exp))) + (the-cdr (unevaluate (cdr exp)))) + (if (and (scode/constant? the-car) + (scode/constant? the-cdr)) + (scode/make-constant (cons (scode/constant-value the-car) + (scode/constant-value the-cdr))) + (scode/make-absolute-combination 'CONS + (list the-car the-cdr))))))) + +;;;; Rule output code + +(define (generate-match-code testo testi bindings body null-form receiver) + (define (scode/make-test test body) + (if (eq? test true) + body + (scode/make-conditional test body null-form))) + + (define (collect-bindings bindings outer late early outer-names early-names) + (if (null? bindings) + (receiver + (if (and (eq? testo true) (eq? testi true)) + true + 'MAYBE) + (scode/make-test + testo + (scode/make-block + outer outer-names + (scode/make-block late '() + (scode/make-test + testi + (scode/make-block early early-names + body)))))) + (let ((binding (cdar bindings))) + (case (caar bindings) + ((OUTER) + (collect-bindings + (cdr bindings) (cons binding outer) + late early + (if (or (scode/constant? (scode/binding-value binding)) + (scode/variable? (scode/binding-value binding))) + (cons (scode/binding-variable binding) + outer-names) + outer-names) + early-names)) + ((LATE) + (collect-bindings (cdr bindings) outer + (cons binding late) early + outer-names early-names)) + ((EARLY) + (collect-bindings (cdr bindings) outer + late (cons binding early) + outer-names + (cons (scode/binding-variable binding) + early-names))) + (else (error "collect bindings: Unknown type of binding" + (caar bindings))))))) + (collect-bindings bindings '() '() '() '() '())) + +(define ((make-binding-procedure keyword) name exp) + (cons keyword (scode/make-binding name exp))) + +(define make-early-binding (make-binding-procedure 'EARLY)) +(define make-late-binding (make-binding-procedure 'LATE)) +(define make-outer-binding (make-binding-procedure 'OUTER)) + +;;;; Compiled pattern match + +(define (build-comparison pattern expression receiver) + (define (merge-path path expression) + (if (null? path) + expression + (scode/make-absolute-combination path (list expression)))) + + (define (walk pattern path expression receiver) + (cond ((not (pair? pattern)) + (receiver true + (scode/make-absolute-combination 'EQ? + (list + (scode/make-constant pattern) + (merge-path path expression))) + '())) + ((pattern-variable? pattern) + (receiver false true + (list `(,(pattern-variable-name pattern) + ,@(make-evaluation + (merge-path path expression)))))) + (else + (path-step 'CAR path expression + (lambda (car-path car-expression) + (walk (car pattern) car-path car-expression + (lambda (car-pure? car-test car-bindings) + (path-step 'CDR path expression + (lambda (cdr-path cdr-expression) + (walk (cdr pattern) cdr-path cdr-expression + (lambda (cdr-pure? cdr-test cdr-bindings) + (let ((result (and car-pure? cdr-pure?))) + (receiver + result + (build-pair-test result car-test cdr-test + (merge-path path expression)) + (append car-bindings cdr-bindings)))))))))))))) + + (walk pattern '() expression + (lambda (pure? test bindings) + pure? + (receiver test bindings)))) + +;;; car/cdr decomposition + +(define (build-pair-test pure? car-test cdr-test expression) + (if (not pure?) + (scode/merge-tests (scode/make-absolute-combination 'PAIR? + (list expression)) + (scode/merge-tests car-test cdr-test)) + (combination-components car-test + (lambda (car-operator car-operands) + car-operator + (combination-components cdr-test + (lambda (cdr-operator cdr-operands) + cdr-operator + (scode/make-absolute-combination 'EQUAL? + (list + (scode/make-constant + (cons (scode/constant-value (car car-operands)) + (scode/constant-value (car cdr-operands)))) + expression)))))))) + +;;;; car/cdr path compression + +;; The rest of the elements are provided for canonicalization, not used. + +(define path-compressions + '((car (caar . cdar) car) + (cdr (cadr . cddr) cdr) + + (caar (caaar . cdaar) car car) + (cadr (caadr . cdadr) car cdr) + (cdar (cadar . cddar) cdr car) + (cddr (caddr . cdddr) cdr cdr) + + (caaar (caaaar . cdaaar) car caar) + (caadr (caaadr . cdaadr) car cadr) + (cadar (caadar . cdadar) car cdar) + (caddr (caaddr . cdaddr) car cddr) + (cdaar (cadaar . cddaar) cdr caar) + (cdadr (cadadr . cddadr) cdr cadr) + (cddar (caddar . cdddar) cdr cdar) + (cdddr (cadddr . cddddr) cdr cddr) + + (caaaar () car caaar) + (caaadr () car caadr) + (caadar () car cadar) + (caaddr () car caddr) + (cadaar () car cdaar) + (cadadr () car cdadr) + (caddar () car cddar) + (cadddr () car cdddr) + (cdaaar () cdr caaar) + (cdaadr () cdr caadr) + (cdadar () cdr cadar) + (cdaddr () cdr caddr) + (cddaar () cdr cdaar) + (cddadr () cdr cdadr) + (cdddar () cdr cddar) + (cddddr () cdr cdddr))) + +(define (path-step step path expression receiver) + (let ((info (assq path path-compressions))) + (cond ((not info) + (receiver step expression)) + ((null? (cadr info)) + (receiver step + (scode/make-absolute-combination path (list expression)))) + (else + (receiver (if (eq? step 'CAR) (caadr info) (cdadr info)) + expression))))) + +;;;; Transformers + +(define (apply-transformer-early trans-exp name rename exp receiver) + (let ((transformer (find-transformer trans-exp))) + (if transformer + (transformer trans-exp name rename exp receiver) + (apply-transformer trans-exp name rename exp receiver)))) + +(define (apply-transformer transformer name rename exp receiver) + (receiver (scode/make-variable name) + (transformer-bindings name rename (unevaluate exp) + (lambda (exp) + (scode/make-combination (scode/make-variable transformer) + (list exp)))))) + +(define (transformer-bindings name rename expression mapper) + (if (eq? rename name) + (list (make-outer-binding name (mapper expression))) + (list (make-outer-binding rename expression) + (make-late-binding name (mapper (scode/make-variable rename)))))) + +(define *transformers*) + +(define (find-transformer expression) + (and (symbol? expression) + (let ((place (assq expression *transformers*))) + (and place + (cdr place))))) + +;;;; Database transformers + +(define (make-database-transformer database) + (lambda (texp name rename exp receiver) + (let ((null-form + (scode/make-constant (generate-uninterned-symbol 'NOT-FOUND-)))) + (try-rules database exp null-form + (lambda (result code) + (define (possible test make-binding) + (receiver test + (cons (make-binding rename code) + (if (eq? name rename) + '() + (list (make-binding name + (unevaluate exp))))))) + + (cond ((false? result) + (transformer-fail receiver)) + ((eq? result 'TOO-MANY) + (apply-transformer texp name rename exp receiver)) + ((eq? result 'MAYBE) + (possible (make-simple-transformer-test name null-form) + make-outer-binding)) + ((can-integrate? code) + (possible true make-early-binding)) + (else + (possible true make-late-binding)))))))) + +;; Mega kludge! + +(define (can-integrate? code) + (if (not (scode/let? code)) + true + (scode/let-components + code + (lambda (names values decls body) + values + (and (not (null? names)) + (let ((place (assq 'INTEGRATE decls))) + (and (not (null? place)) + (let ((integrated (cdr place))) + (let loop ((left names)) + (cond ((null? left) + (can-integrate? body)) + ((memq (car left) integrated) + (loop (cdr left))) + (else false))))))))))) + +(define-integrable (make-simple-transformer-test name tag) + (scode/make-absolute-combination 'NOT + (list (scode/make-absolute-combination 'EQ? + (list + (scode/make-variable name) + tag))))) + +(define-integrable (transformer-fail receiver) + (receiver false false)) + +(define-integrable (transformer-result receiver name rename out in) + (receiver true + (cons (make-early-binding name (scode/make-constant out)) + (if (eq? name rename) + '() + (list (make-early-binding rename + (scode/make-constant in))))))) + +;;;; Symbol transformers + +(define (make-symbol-transformer alist) + (lambda (texp name rename exp receiver) + texp + (cond ((null? alist) + (receiver false false)) + ((symbol? exp) + (let ((pair (assq exp alist))) + (if (not pair) + (transformer-fail receiver) + (transformer-result receiver name rename (cdr pair) exp)))) + ((evaluation? exp) + (let ((tag (generate-uninterned-symbol 'NOT-FOUND-))) + (receiver + (make-simple-transformer-test name (scode/make-constant tag)) + (transformer-bindings name + rename + (evaluation-expression exp) + (lambda (expr) + (runtime-symbol-lookup tag + expr + alist)))))) + (else (transformer-fail receiver))))) + +(define (runtime-symbol-lookup not-found-tag expression alist) + (if (>= (length alist) 4) + (scode/make-absolute-combination 'CDR + (list + (scode/make-disjunction + (scode/make-absolute-combination 'ASSQ + (list expression + (scode/make-constant alist))) + (scode/make-constant `(() . ,not-found-tag))))) + (scode/make-case-expression + expression + (scode/make-constant not-found-tag) + (map (lambda (pair) + (list (list (car pair)) + (scode/make-constant (cdr pair)))) + alist)))) + +;;;; Accumulation transformers + +(define (make-bit-mask-transformer size alist) + (lambda (texp name rename exp receiver) + (cond ((null? alist) + (transformer-fail receiver)) + ((evaluation? exp) + (apply-transformer texp name rename exp receiver)) + (else + (let ((mask (make-bit-string size #!FALSE))) + (define (loop symbols) + (cond ((null? symbols) + (transformer-result receiver name rename mask exp)) + ((not (pair? symbols)) + (transformer-fail receiver)) + ((not (symbol? (car symbols))) + (apply-transformer texp name rename exp receiver)) + (else + (let ((place (assq (car symbols) alist))) + (if (not place) + (transformer-fail receiver) + (begin (bit-string-set! mask (cdr place)) + (loop (cdr symbols)))))))) + (loop exp)))))) + +;;;; Scode utilities + +(define-integrable scode/make-binding cons) +(define-integrable scode/binding-variable car) +(define-integrable scode/binding-value cdr) + +(define-integrable (scode/make-conjunction t1 t2) + (scode/make-conditional t1 t2 (scode/make-constant false))) + +(define (scode/merge-tests t1 t2) + (cond ((eq? t1 true) t2) + ((eq? t2 true) t1) + (else (scode/make-conjunction t1 t2)))) + +(define (scode/make-thunk body) + (scode/make-lambda lambda-tag:unnamed '() '() false '() '() body)) + +(define (scode/let? obj) + (and (scode/combination? obj) + (scode/combination-components + obj + (lambda (operator operands) + operands + (and (scode/lambda? operator) + (scode/lambda-components + operator + (lambda (name . ignore) + ignore + (eq? name lambda-tag:let)))))))) + +(define (scode/make-let names values declarations body) + (scode/make-combination + (scode/make-lambda lambda-tag:let + names + '() + false + '() + declarations + body) + values)) + +(define (scode/let-components lcomb receiver) + (scode/combination-components lcomb + (lambda (operator values) + (scode/lambda-components operator + (lambda (tag names opt rest aux decls body) + tag opt rest aux + (receiver names values decls body)))))) + +;;;; Scode utilities (continued) + +(define (scode/make-block bindings integrated body) + (if (null? bindings) + body + (scode/make-let (map scode/binding-variable bindings) + (map scode/binding-value bindings) + (if (null? integrated) + '() + `((INTEGRATE ,@integrated))) + body))) + +(define (scode/make-letrec bindings body) + (scode/make-let + (map scode/binding-variable bindings) + (make-list (length bindings) + (make-unassigned-reference-trap)) + '() + (scode/make-sequence + (map* body + (lambda (binding) + (scode/make-assignment (scode/binding-variable binding) + (scode/binding-value binding))) + bindings)))) + +(define (scode/make-case-expression expression default clauses) + (define (kernel case-selector) + (define (process clauses) + (if (null? clauses) + default + (let ((selector (caar clauses))) + (scode/make-conditional + (if (null? (cdr selector)) + (scode/make-absolute-combination 'EQ? + (list case-selector + (scode/make-constant (car selector)))) + (scode/make-absolute-combination 'MEMQ + (list case-selector + (scode/make-constant selector)))) + (cadar clauses) + (process (cdr clauses)))))) + (process clauses)) + + (if (scode/variable? expression) + (kernel expression) + (let ((var (make-variable-name 'CASE-SELECTOR-))) + (scode/make-let (list var) (list expression) '() + (kernel (scode/make-variable var)))))) + +(define make-variable-name generate-uninterned-symbol) + +(define evaluation-tag (list '*EVALUATION*)) + +(define (evaluation? exp) + (and (pair? exp) + (eq? (car exp) evaluation-tag))) + +(define-integrable (make-evaluation name) + (cons evaluation-tag name)) + +(define-integrable (evaluation-expression exp) + (cdr exp)) \ No newline at end of file diff --git a/v8/src/compiler/base/pmlook.scm b/v8/src/compiler/base/pmlook.scm new file mode 100644 index 000000000..02bc72036 --- /dev/null +++ b/v8/src/compiler/base/pmlook.scm @@ -0,0 +1,78 @@ +#| -*-Scheme-*- + +$Id: pmlook.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1988-1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Very Simple Pattern Matcher: Lookup +;;; package: (compiler pattern-matcher/lookup) + +(declare (usual-integrations)) + +(define pattern-variable-tag + (intern "#[(compiler pattern-matcher/lookup)pattern-variable]")) + +;;; PATTERN-LOOKUP returns either false or a pair whose car is the +;;; item matched and whose cdr is the list of variable values. Use +;;; PATTERN-VARIABLES to get a list of names that is in the same order +;;; as the list of values. + +(define (pattern-lookup entries instance) + (define (lookup-loop entries) + (and (not (null? entries)) + (or ((cdar entries) instance) + (lookup-loop (cdr entries))))) + (lookup-loop entries)) + +(define-integrable (pattern-lookup/bind binder values) + (apply binder values)) + +(define (pattern-variables pattern) + (let ((variables '())) + (define (loop pattern) + (if (pair? pattern) + (if (eq? (car pattern) pattern-variable-tag) + (if (not (memq (cdr pattern) variables)) + (set! variables (cons (cdr pattern) variables))) + (begin (loop (car pattern)) + (loop (cdr pattern)))))) + (loop pattern) + variables)) + +(define-integrable (make-pattern-variable name) + (cons pattern-variable-tag name)) + +(define (pattern-variable? object) + (and (pair? object) + (eq? (car object) pattern-variable-tag))) + +(define-integrable (pattern-variable-name var) + (cdr var)) diff --git a/v8/src/compiler/base/pmpars.scm b/v8/src/compiler/base/pmpars.scm new file mode 100644 index 000000000..34f400726 --- /dev/null +++ b/v8/src/compiler/base/pmpars.scm @@ -0,0 +1,213 @@ +#| -*-Scheme-*- + +$Id: pmpars.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Very Simple Pattern Matcher: Parser + +(declare (usual-integrations)) + +;;; PARSE-RULE and RULE-RESULT-EXPRESSION are used together to parse +;;; pattern/body definitions, producing Scheme code which can then be +;;; compiled. + +;;; PARSE-RULE, given a PATTERN and a BODY, returns: (1) a pattern for +;;; use with the matcher; (2) the variables in the pattern, in the +;;; order that the matcher will produce their corresponding values; +;;; (3) a list of qualifier expressions; and (4) a list of actions +;;; which should be executed sequentially when the rule fires. + +;;; RULE-RESULT-EXPRESSION is used to generate a lambda expression +;;; which, when passed the values resulting from the match as its +;;; arguments, will return either false, indicating that the +;;; qualifications failed, or the result of the body. + +;;; COMPILE-PATTERN takes a pattern produced by PARSE-RULE and a +;;; binder-experssion produced by RULE-RESULT-EXPRESSION and produced +;;; a compound expression that matches the rule and calls the result +;;; expression. + + +(define (compile-pattern pattern binder-expression) + `(LAMBDA (INSTANCE) + (,(compile-pattern-match pattern) + INSTANCE + ,binder-expression))) + +(define (parse-rule pattern body receiver) + (extract-variables + pattern + (lambda (pattern variables) + (extract-qualifier + body + (lambda (qualifiers actions) + (let ((names (pattern-variables pattern))) + (receiver pattern + (reorder-variables variables names) + qualifiers + actions))))))) + +(define (extract-variables pattern receiver) + (if (pair? pattern) + (if (memq (car pattern) '(? ?@)) + (receiver (make-pattern-variable (cadr pattern)) + (list (cons (cadr pattern) + (if (null? (cddr pattern)) + '() + (list (cons (car pattern) + (cddr pattern))))))) + (extract-variables (car pattern) + (lambda (car-pattern car-variables) + (extract-variables (cdr pattern) + (lambda (cdr-pattern cdr-variables) + (receiver (cons car-pattern cdr-pattern) + (merge-variables-lists car-variables + cdr-variables))))))) + (receiver pattern '()))) + +(define (merge-variables-lists x y) + (cond ((null? x) y) + ((null? y) x) + (else + (let ((entry (assq (caar x) y))) + (if entry + (cons (append! (car x) (cdr entry)) + (merge-variables-lists (cdr x) + (delq! entry y))) + (cons (car x) + (merge-variables-lists (cdr x) + y))))))) + +(define (compile-pattern-match pattern) + (let ((bindings '()) + (values '()) + (tests '()) + (var-tests '())) + + (define (add-test! test) + (if (eq? (car test) 'eqv?) + (set! var-tests (cons test var-tests)) + (set! tests (cons test tests)))) + + (define (make-eqv? path constant) + (cond ((number? constant) `(EQV? ,path ',constant)) + ((null? constant) `(NULL? ,path)) + (else `(EQ? ,path ',constant)))) + + (define (match pattern path) + (if (pair? pattern) + (if (pattern-variable? pattern) + (let ((entry (memq (cdr pattern) bindings))) + (if (not entry) + (begin (set! bindings (cons (cdr pattern) bindings)) + (set! values (cons path values)) + true) + (add-test! `(EQV? ,path + ,(list-ref values + (- (length bindings) + (length entry))))))) + (begin + (add-test! `(PAIR? ,path)) + (match (car pattern) `(CAR ,path)) + (match (cdr pattern) `(CDR ,path)))) + (add-test! (make-eqv? path pattern)))) + + (match pattern 'INSTANCE) + + `(LAMBDA (INSTANCE BINDER) + (AND ,@(reverse tests) + ,(if (null? var-tests) + `(BINDER ,@values) + `((LAMBDA ,bindings + (AND ,@(reverse var-tests) + (BINDER ,@bindings))) + ,@values)))))) + + +(define (extract-qualifier body receiver) + (if (and (pair? (car body)) + (eq? (caar body) 'QUALIFIER)) + (receiver (cdar body) (cdr body)) + (receiver '() body))) + +(define (reorder-variables variables names) + (map (lambda (name) (assq name variables)) + names)) + +(define (rule-result-expression variables qualifiers body) + (let ((body `(lambda () ,body))) + (process-transformations variables + (lambda (outer-vars inner-vars xforms xqualifiers) + (if (null? inner-vars) + `(lambda ,outer-vars + ,(if (null? qualifiers) + body + `(and ,@qualifiers ,body))) + `(lambda ,outer-vars + (let ,(map list inner-vars xforms) + (and ,@xqualifiers + ,@qualifiers + ,body)))))))) + +(define (process-transformations variables receiver) + (if (null? variables) + (receiver '() '() '() '()) + (process-transformations (cdr variables) + (lambda (outer inner xform qual) + (let ((name (caar variables)) + (variable (cdar variables))) + (cond ((null? variable) + (receiver (cons name outer) + inner + xform + qual)) + ((not (null? (cdr variable))) + (error "process-trasformations: Multiple qualifiers" + (car variables))) + (else + (let ((var (car variable))) + (define (handle-xform rename) + (if (eq? (car var) '?) + (receiver (cons rename outer) + (cons name inner) + (cons `(,(cadr var) ,rename) + xform) + (cons name qual)) + (receiver (cons rename outer) + (cons name inner) + (cons `(MAP ,(cadr var) ,rename) + xform) + (cons `(APPLY BOOLEAN/AND ,name) qual)))) + (handle-xform + (if (null? (cddr var)) + name + (caddr var))))))))))) \ No newline at end of file diff --git a/v8/src/compiler/base/scode.scm b/v8/src/compiler/base/scode.scm new file mode 100644 index 000000000..80e0a89fe --- /dev/null +++ b/v8/src/compiler/base/scode.scm @@ -0,0 +1,173 @@ +#| -*-Scheme-*- + +$Id: scode.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1988-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Interface + +(declare (usual-integrations)) + +(let-syntax ((define-scode-operators + (macro names + `(BEGIN ,@(map (lambda (name) + `(DEFINE ,(symbol-append 'SCODE/ name) + (ACCESS ,name SYSTEM-GLOBAL-ENVIRONMENT))) + names))))) + (define-scode-operators + make-access access? access-components + access-environment access-name + make-assignment assignment? assignment-components + assignment-name assignment-value + make-combination combination? combination-components + combination-operator combination-operands + make-comment comment? comment-components + comment-expression comment-text + make-conditional conditional? conditional-components + conditional-predicate conditional-consequent conditional-alternative + make-declaration declaration? declaration-components + declaration-expression declaration-text + make-definition definition? definition-components + definition-name definition-value + make-delay delay? delay-components + delay-expression + make-disjunction disjunction? disjunction-components + disjunction-predicate disjunction-alternative + make-in-package in-package? in-package-components + in-package-environment in-package-expression + make-lambda lambda? lambda-components + make-open-block open-block? open-block-components + primitive-procedure? procedure? + make-quotation quotation? quotation-expression + make-sequence sequence? sequence-actions sequence-components + symbol? + make-the-environment the-environment? + make-unassigned? unassigned?? unassigned?-name + make-variable variable? variable-components variable-name + )) + +(define-integrable (scode/make-constant value) value) +(define-integrable (scode/constant-value constant) constant) +(define scode/constant? (access scode-constant? system-global-environment)) + +(define-integrable (scode/quotation-components quot recvr) + (recvr (scode/quotation-expression quot))) + +(define comment-tag:directive + (intern "#[(compiler)comment-tag:directive]")) + +(define (scode/make-directive code directive original-code) + (scode/make-comment + (list comment-tag:directive + directive + (scode/original-expression original-code)) + code)) + +(define (scode/original-expression scode) + (if (and (scode/comment? scode) + (scode/comment-directive? (scode/comment-text scode))) + (caddr (scode/comment-text scode)) + scode)) + +(define (scode/comment-directive? text . kinds) + (and (pair? text) + (eq? (car text) comment-tag:directive) + (or (null? kinds) + (memq (caadr text) kinds)))) + +(define (scode/make-let names values . body) + (scan-defines (scode/make-sequence body) + (lambda (auxiliary declarations body) + (scode/make-combination + (scode/make-lambda lambda-tag:let names '() false + auxiliary declarations body) + values)))) + +;;;; Absolute variables and combinations + +(define-integrable (scode/make-absolute-reference variable-name) + (scode/make-access '() variable-name)) + +(define (scode/absolute-reference? object) + (and (scode/access? object) + (null? (scode/access-environment object)))) + +(define-integrable (scode/absolute-reference-name reference) + (scode/access-name reference)) + +(define-integrable (scode/make-absolute-combination name operands) + (scode/make-combination (scode/make-absolute-reference name) operands)) + +(define (scode/absolute-combination? object) + (and (scode/combination? object) + (scode/absolute-reference? (scode/combination-operator object)))) + +(define-integrable (scode/absolute-combination-name combination) + (scode/absolute-reference-name (scode/combination-operator combination))) + +(define-integrable (scode/absolute-combination-operands combination) + (scode/combination-operands combination)) + +(define (scode/absolute-combination-components combination receiver) + (receiver (scode/absolute-combination-name combination) + (scode/absolute-combination-operands combination))) + +(define (scode/error-combination? object) + (or (and (scode/combination? object) + (eq? (scode/combination-operator object) error-procedure)) + (and (scode/absolute-combination? object) + (eq? (scode/absolute-combination-name object) 'ERROR-PROCEDURE)))) + +(define (scode/error-combination-components combination receiver) + (scode/combination-components combination + (lambda (operator operands) + operator + (receiver + (car operands) + (let loop ((irritants (cadr operands))) + (cond ((null? irritants) '()) + ((and (scode/absolute-combination? irritants) + (eq? (scode/absolute-combination-name irritants) 'LIST)) + (scode/absolute-combination-operands irritants)) + ((and (scode/combination? irritants) + (eq? (scode/combination-operator irritants) cons)) + (let ((operands (scode/combination-operands irritants))) + (cons (car operands) + (loop (cadr operands))))) + (else + (cadr operands)))))))) + +(define (scode/make-error-combination message operand) + (scode/make-absolute-combination + 'ERROR-PROCEDURE + (list message + (scode/make-combination cons (list operand '())) + (scode/make-the-environment)))) \ No newline at end of file diff --git a/v8/src/compiler/base/sets.scm b/v8/src/compiler/base/sets.scm new file mode 100644 index 000000000..eb3751994 --- /dev/null +++ b/v8/src/compiler/base/sets.scm @@ -0,0 +1,197 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/sets.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Simple Set Abstraction + +(declare (usual-integrations)) + +(define (eq-set-adjoin element set) + (if (memq element set) + set + (cons element set))) + +(define (eqv-set-adjoin element set) + (if (memv element set) + set + (cons element set))) + +(define (eq-set-delete set item) + (define (loop set) + (cond ((null? set) '()) + ((eq? (car set) item) (cdr set)) + (else (cons (car set) (loop (cdr set)))))) + (loop set)) + +(define (eqv-set-delete set item) + (define (loop set) + (cond ((null? set) '()) + ((eqv? (car set) item) (cdr set)) + (else (cons (car set) (loop (cdr set)))))) + (loop set)) + +(define (eq-set-substitute set old new) + (define (loop set) + (cond ((null? set) '()) + ((eq? (car set) old) (cons new (cdr set))) + (else (cons (car set) (loop (cdr set)))))) + (loop set)) + +(define (eqv-set-substitute set old new) + (define (loop set) + (cond ((null? set) '()) + ((eqv? (car set) old) (cons new (cdr set))) + (else (cons (car set) (loop (cdr set)))))) + (loop set)) + +(define (set-search set procedure) + (define (loop items) + (and (not (null? items)) + (or (procedure (car items)) + (loop (cdr items))))) + (loop set)) + +;;; The dataflow analyzer assumes that +;;; (eq? (list-tail (eq-set-union x y) n) y) for some n. + +(define (eq-set-union x y) + (if (null? y) + x + (let loop ((x x) (y y)) + (if (null? x) + y + (loop (cdr x) + (if (memq (car x) y) + y + (cons (car x) y))))))) + +(define (eqv-set-union x y) + (if (null? y) + x + (let loop ((x x) (y y)) + (if (null? x) + y + (loop (cdr x) + (if (memv (car x) y) + y + (cons (car x) y))))))) + +(define (eq-set-difference x y) + (define (loop x) + (cond ((null? x) '()) + ((memq (car x) y) (loop (cdr x))) + (else (cons (car x) (loop (cdr x)))))) + (loop x)) + +(define (eqv-set-difference x y) + (define (loop x) + (cond ((null? x) '()) + ((memv (car x) y) (loop (cdr x))) + (else (cons (car x) (loop (cdr x)))))) + (loop x)) + +(define (eq-set-intersection x y) + (define (loop x) + (cond ((null? x) '()) + ((memq (car x) y) (cons (car x) (loop (cdr x)))) + (else (loop (cdr x))))) + (loop x)) + +(define (eqv-set-intersection x y) + (define (loop x) + (cond ((null? x) '()) + ((memv (car x) y) (cons (car x) (loop (cdr x)))) + (else (loop (cdr x))))) + (loop x)) + +(define (eq-set-disjoint? x y) + (define (loop x) + (cond ((null? x) true) + ((memq (car x) y) false) + (else (loop (cdr x))))) + (loop x)) + +(define (eqv-set-disjoint? x y) + (define (loop x) + (cond ((null? x) true) + ((memv (car x) y) false) + (else (loop (cdr x))))) + (loop x)) + +(define (eq-set-subset? x y) + (define (loop x) + (cond ((null? x) true) + ((memq (car x) y) (loop (cdr x))) + (else false))) + (loop x)) + +(define (eqv-set-subset? x y) + (define (loop x) + (cond ((null? x) true) + ((memv (car x) y) (loop (cdr x))) + (else false))) + (loop x)) + +(define (eq-set-same-set? x y) + (and (eq-set-subset? x y) + (eq-set-subset? y x))) + +(define (eqv-set-same-set? x y) + (and (eqv-set-subset? x y) + (eqv-set-subset? y x))) + +(define (list->eq-set elements) + (if (null? elements) + '() + (eq-set-adjoin (car elements) + (list->eq-set (cdr elements))))) + +(define (list->eqv-set elements) + (if (null? elements) + '() + (eqv-set-adjoin (car elements) + (list->eqv-set (cdr elements))))) + +(define (map->eq-set procedure items) + (let loop ((items items)) + (if (null? items) + '() + (eq-set-adjoin (procedure (car items)) + (loop (cdr items)))))) + +(define (map->eqv-set procedure items) + (let loop ((items items)) + (if (null? items) + '() + (eqv-set-adjoin (procedure (car items)) + (loop (cdr items)))))) \ No newline at end of file diff --git a/v8/src/compiler/base/switch.scm b/v8/src/compiler/base/switch.scm new file mode 100644 index 000000000..38c9dea5d --- /dev/null +++ b/v8/src/compiler/base/switch.scm @@ -0,0 +1,99 @@ +#| -*-Scheme-*- + +$Id: switch.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Compiler Option Switches +;;; package: (compiler) + +(declare (usual-integrations)) + +;;; Binary switches + +(define compiler:enable-integration-declarations? true) +(define compiler:enable-expansion-declarations? false) +(define compiler:compile-by-procedures? true) +(define compiler:noisy? true) +(define compiler:show-time-reports? false) +(define compiler:show-procedures? true) +(define compiler:show-phases? false) +(define compiler:show-subphases? false) +(define compiler:preserve-data-structures? false) +(define compiler:code-compression? true) +(define compiler:cache-free-variables? true) +(define compiler:implicit-self-static? true) +(define compiler:optimize-environments? true) +(define compiler:analyze-side-effects? true) +(define compiler:cse? true) +(define compiler:open-code-primitives? true) +(define compiler:generate-kmp-files? false) +(define compiler:generate-rtl-files? false) +(define compiler:generate-lap-files? false) +(define compiler:intersperse-rtl-in-lap? true) +(define compiler:generate-range-checks? false) +(define compiler:generate-type-checks? false) +(define compiler:generate-stack-checks? true) +(define compiler:open-code-flonum-checks? false) +(define compiler:use-multiclosures? true) +(define compiler:coalescing-constant-warnings? true) +(define compiler:cross-compiling? false) +(define compiler:compress-top-level? false) +(define compiler:avoid-scode? true) + +;; If true, the compiler is allowed to assume that fixnum operations +;; are only applied to inputs for which the operation is closed, i.e. +;; generates a valid fixnum. If false, the compiler will ensure that +;; the result of a fixnum operation is a fixnum, although it may be an +;; incorrect result for screw cases. + +(define compiler:assume-safe-fixnums? true) + +;; +(define compiler:generate-trap-on-null-valued-conditional? false) + + +;; The switch COMPILER:OPEN-CODE-FLOATING-POINT-ARITHMETIC? is in machin.scm. + +;;; Nary switches + +(define compiler:package-optimization-level + ;; Possible values: NONE LOW HYBRID HIGH + 'HYBRID) + +(define compiler:default-top-level-declarations + '((UUO-LINK ALL))) + +;;; Hook: bind this to a procedure of one argument and it will receive +;;; each phase of the compiler as a thunk. It is expected to call the +;;; thunk after any appropriate processing. +(define compiler:phase-wrapper + false) \ No newline at end of file diff --git a/v8/src/compiler/base/toplev.scm b/v8/src/compiler/base/toplev.scm new file mode 100644 index 000000000..866a4046b --- /dev/null +++ b/v8/src/compiler/base/toplev.scm @@ -0,0 +1,1008 @@ +#| -*-Scheme-*- + +$Id: toplev.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Compiler Top Level +;;; package: (compiler top-level) + +(declare (usual-integrations)) + +;;;; Usual Entry Point: File Compilation + +(define (make-cf compile-bin-file) + (lambda (input #!optional output) + (let ((kernel + (lambda (source-file) + (with-values + (lambda () (sf/pathname-defaulting source-file false false)) + (lambda (source-pathname bin-pathname spec-pathname) + ;; Maybe this should be done only if scode-file + ;; does not exist or is older than source-file. + (sf source-pathname bin-pathname spec-pathname) + (if (default-object? output) + (compile-bin-file bin-pathname) + (compile-bin-file bin-pathname output))))))) + (if (pair? input) + (for-each kernel input) + (kernel input))))) + +(define (make-cbf compile-bin-file) + (lambda (input . rest) + (apply compile-bin-file input rest))) + +(define (make-compile-bin-file compile-scode/internal) + (lambda (input-string #!optional output-string) + (let ((input-default + (make-pathname false false false false "bin" 'NEWEST)) + (output-default + (if compiler:cross-compiling? + (make-pathname false false false false "moc" false) + #F)) + (inf-file-type (if compiler:cross-compiling? "fni" "inf"))) + (perhaps-issue-compatibility-warning) + (compiler-pathnames + input-string + (if compiler:cross-compiling? + (if (not (default-object? output-string)) + output-string + (merge-pathnames output-default + (merge-pathnames input-string input-default))) + (and (not (default-object? output-string)) output-string)) + (make-pathname false false false false "bin" 'NEWEST) + (lambda (input-pathname output-pathname) + (maybe-open-file + compiler:generate-kmp-files? + (pathname-new-type output-pathname "kmp") + (lambda (kmp-output-port) + (maybe-open-file + compiler:generate-rtl-files? + (pathname-new-type output-pathname "rtl") + (lambda (rtl-output-port) + (maybe-open-file + compiler:generate-lap-files? + (pathname-new-type output-pathname "lap") + (lambda (lap-output-port) + (compile-scode/internal + (compiler-fasload input-pathname) + (pathname-new-type output-pathname inf-file-type) + kmp-output-port + rtl-output-port + lap-output-port))))))))) + unspecific))) + +(define (maybe-open-file open? pathname receiver) + (if open? + (call-with-output-file pathname receiver) + (receiver false))) + +(define (make-compile-expression compile-scode) + (perhaps-issue-compatibility-warning) + (lambda (expression #!optional declarations) + (let ((declarations (if (default-object? declarations) + '((usual-integrations)) + declarations))) + (compile-scode (syntax&integrate expression declarations) + 'KEEP)))) + +(define (make-compile-procedure compile-scode) + (lambda (procedure #!optional keep-debugging-info?) + (perhaps-issue-compatibility-warning) + (compiler-output->procedure + (compile-scode + (procedure-lambda procedure) + (and (or (default-object? keep-debugging-info?) + keep-debugging-info?) + 'KEEP)) + (procedure-environment procedure)))) + +(define (compiler-pathnames input-string output-string default transform) + (let* ((core + (lambda (input-string) + (let ((input-pathname (merge-pathnames input-string default))) + (let ((output-pathname + (let ((output-pathname + (pathname-new-type input-pathname + compiled-output-extension))) + (if output-string + (merge-pathnames output-string output-pathname) + output-pathname)))) + (if compiler:noisy? + (begin + (newline) + (write-string "Compile File: ") + (write (enough-namestring input-pathname)) + (write-string " => ") + (write (enough-namestring output-pathname)))) + (compiler-file-output + (transform input-pathname output-pathname) + output-pathname))))) + (kernel + (if compiler:batch-mode? + (batch-kernel core) + core))) + (if (pair? input-string) + (for-each kernel input-string) + (kernel input-string)))) + +(define (compiler-fasload pathname) + (let ((scode + (let ((scode (fasload pathname))) + (if (scode/comment? scode) + (scode/comment-expression scode) + scode)))) + (if (scode/open-block? scode) + (scode/open-block-components scode + (lambda (names declarations body) + (if (null? names) + (scan-defines body + (lambda (names declarations* body) + (make-open-block names + (append declarations declarations*) + body))) + scode))) + (scan-defines scode make-open-block)))) + +;;;; Alternate Entry Points + +(define (compile-scode/new scode #!optional keep-debugging-info?) + keep-debugging-info? ; ignored + (perhaps-issue-compatibility-warning) + (compile-scode/%new scode)) + +(define compatibility-detection-frob (vector #F '())) + +(define (perhaps-issue-compatibility-warning) + (if (eq? (vector-ref compatibility-detection-frob 0) + (vector-ref compatibility-detection-frob 1)) + (begin + (warn "!! You are compiling while in compatibility mode,") + (warn "!! where #F is the !! same as '().") + (warn "!! The compiled code will be incorrect for the") + (warn "!! standard environment.")))) + +(define (compile-scode/%new scode #!optional keep-debugging-info?) + keep-debugging-info? ; ignored + (compiler-output->compiled-expression + (let* ((kmp-file-name (temporary-file-pathname)) + (rtl-file-name (temporary-file-pathname)) + (lap-file-name (temporary-file-pathname)) + (info-output-pathname false)) + (warn "KMP Output to temporary file" (->namestring kmp-file-name)) + (warn "RTL Output to temporary file" (->namestring rtl-file-name)) + (warn "LAP Output to temporary file" (->namestring lap-file-name)) + (let ((win? false)) + (dynamic-wind + (lambda () unspecific) + (lambda () + (call-with-output-file kmp-file-name + (lambda (kmp-output-port) + (call-with-output-file rtl-file-name + (lambda (rtl-output-port) + (call-with-output-file lap-file-name + (lambda (lap-output-port) + (let ((result + (%compile/new scode + false + info-output-pathname + kmp-output-port + rtl-output-port + lap-output-port))) + (set! win? true) + result)))))))) + (lambda () + (if (not win?) + (begin + (warn "Deleting KMP, RTL and LAP output files") + (delete-file kmp-file-name) + (delete-file rtl-file-name) + (delete-file lap-file-name))))))))) + +;; First set: phase/scode->kmp +;; Last used: phase/optimize-kmp +(define *kmp-program*) + +;; First set: phase/optimize-kmp +;; Last used: phase/kmp->rtl +(define *optimized-kmp-program*) + +;; First set: phase/kmp->rtl +;; Last used: phase/rtl-program->rtl-graph +(define *rtl-program*) +(define *rtl-entry-label*) + +(define *argument-registers* '()) +(define *use-debugging-info?* true) + +(define (%compile/new program + recursive? + info-output-pathname + kmp-output-port + rtl-output-port + lap-output-port) + (initialize-machine-register-map!) + (fluid-let ((*info-output-filename* info-output-pathname) + (*rtl-output-port* rtl-output-port) + (*lap-output-port* lap-output-port) + (*kmp-output-port* kmp-output-port) + (compiler:generate-lap-files? true) + (*use-debugging-info?* false) + (*argument-registers* (rtlgen/argument-registers)) + (available-machine-registers + ;; Order is important! + (rtlgen/available-registers available-machine-registers)) + (*strongly-heed-branch-preferences?* true) + (*envconv/compile-by-procedures?* + (if compiler:cross-compiling? + #F + compiler:compile-by-procedures?))) + + ((if recursive? + bind-compiler-variables + in-compiler) + (lambda () + (set! *current-label-number* 0) + (within-midend + recursive? + (lambda () + (if (not recursive?) + (begin + (set! *input-scode* program) + (phase/scode->kmp)) + (begin + (set! *kmp-program* program))) + (phase/optimize-kmp recursive?) + (phase/kmp->rtl))) + (if rtl-output-port + (phase/rtl-file-output "Original" + false + false + program + rtl-output-port + *rtl-program*)) + (phase/rtl-program->rtl-graph) + (if rtl-output-port + (phase/rtl-file-output "Unoptimized" + false + false + program + rtl-output-port + false)) + (phase/rtl-optimization) + (if rtl-output-port + (phase/rtl-file-output "Optimized" + true + true + program + rtl-output-port + false)) + (phase/lap-generation) + (phase/lap-linearization) + (if lap-output-port + (phase/lap-file-output program lap-output-port)) + (assemble&link info-output-pathname))))) + +(define (phase/scode->kmp) + (compiler-phase + "Scode->KMP" + (lambda () + (with-kmp-output-port + (lambda () + (write-string "Input") + (newline) + (pp *input-scode*))) + (set! *kmp-program* + (scode->kmp (last-reference *input-scode*))) + (with-kmp-output-port + (lambda () + (newline) + (write-char #\Page) + (newline) + (write-string "Initial KMP program") + (newline) + (fluid-let (;; (*pp-uninterned-symbols-by-name* false) + (*pp-primitives-by-name* false)) + (pp *kmp-program* (current-output-port) true)))) + unspecific))) + +(define (phase/optimize-kmp recursive?) + (compiler-phase + "Optimize KMP" + (lambda () + (set! *optimized-kmp-program* + (optimize-kmp recursive? (last-reference *kmp-program*))) + (with-kmp-output-port + (lambda () + (newline) + (write-char #\Page) + (newline) + (write-string "Final KMP program ") + (write *recursive-compilation-number*) + (if *kmp-output-abbreviated?* + (begin + (write-string " (*kmp-output-abbreviated?* is #T)") + (newline) + (kmp/ppp *optimized-kmp-program*)) + (fluid-let (;; (*pp-uninterned-symbols-by-name* false) + (*pp-primitives-by-name* false)) + (newline) + (pp *optimized-kmp-program* (current-output-port) true))))) + unspecific))) + +(define (with-kmp-output-port thunk) + (if *kmp-output-port* + (begin + (with-output-to-port *kmp-output-port* thunk) + (output-port/flush-output *kmp-output-port*)))) + +(define (phase/kmp->rtl) + (compiler-phase "KMP->RTL" + (lambda () + (call-with-values + (lambda () + (kmp->rtl (last-reference *optimized-kmp-program*))) + (lambda (program entry-label) + (set! *rtl-program* program) + (set! *rtl-entry-label* entry-label) + unspecific))))) + +(define (phase/rtl-program->rtl-graph) + (compiler-phase + "RTL->RTL graph" + (lambda () + (set! *ic-procedure-headers* '()) + (initialize-machine-register-map!) + (call-with-values + (lambda () + (rtl->rtl-graph (last-reference *rtl-program*))) + (lambda (expression procedures continuations rgraphs) + (set! label->object + (make/label->object expression + procedures + continuations)) + (set! *rtl-expression* expression) + (set! *rtl-procedures* procedures) + (set! *rtl-continuations* continuations) + (set! *rtl-graphs* rgraphs) + (set! *rtl-root* + (or expression + (label->object *rtl-entry-label*))) + unspecific))))) + +(define compile-bin-file/new + (make-compile-bin-file + (lambda (scode info-pathname kmp-port rtl-port lap-port) + (%compile/new scode + false + info-pathname + kmp-port + rtl-port + lap-port)))) + +(define cbf/new (make-cbf compile-bin-file/new)) +(define cf/new (make-cf compile-bin-file/new)) +(define compile-expression/new (make-compile-expression compile-scode/%new)) +(define compile-procedure/new (make-compile-procedure compile-scode/%new)) + +(define (compile-recursively/new kmp-program procedure-result? procedure-name) + ;; Used by the compiler when it wants to compile subexpressions as + ;; separate code-blocks. + ;; (values result must-be-called?) + (let ((my-number *recursive-compilation-count*) + (output? (and compiler:show-phases? + (not (and procedure-result? + compiler:show-procedures?))))) + + (define (compile-it) + ;; (values (compiled-obj . compiled-code-block) must-call-it?) + (fluid-let ((*recursive-compilation-number* my-number) + (*procedure-result?* procedure-result?) + (*envconv/procedure-result?* + procedure-result?)) + (let ((result + (%compile/new kmp-program + true + (and *info-output-filename* + (if (eq? *info-output-filename* + 'KEEP) + 'KEEP + 'RECURSIVE)) + *kmp-output-port* + *rtl-output-port* + *lap-output-port*))) + (values result (not (eq? procedure-result? + *procedure-result?*)))))) + + (define (link-it) + ;; (values compiled-obj must-call-it?) + (let ((simple-link + (lambda () + (with-values compile-it + (lambda (compiler-output must-call?) + ;; Add compiled code block for later linking + (set! *remote-links* + (cons (cdr compiler-output) + *remote-links*)) + (values (car compiler-output) must-call?)))))) + (if procedure-result? + (if compiler:show-procedures? + (compiler-phase/visible + (string-append + "Compiling procedure: " + (write-to-string procedure-name)) + simple-link) + (simple-link)) + (fluid-let ((*remote-links* '())) + (compile-it))))) + + (set! *recursive-compilation-count* (1+ my-number)) + (if output? + (begin + (newline) + (newline) + (write-string *output-prefix*) + (write-string "*** Recursive compilation ") + (write my-number) + (write-string " ***"))) + (with-values link-it + (lambda (value must-call?) + (if output? + (begin + (newline) + (write-string *output-prefix*) + (write-string "*** Done with recursive compilation ") + (write my-number) + (write-string " ***") + (newline))) + (values value must-call?))))) + +;; End of New stuff + +(define (compiler:batch-compile input #!optional output) + (fluid-let ((compiler:batch-mode? true)) + (bind-condition-handler (list condition-type:error) + compiler:batch-error-handler + (lambda () + (if (default-object? output) + (compile-bin-file input) + (compile-bin-file input output)))))) + +(define (compiler:batch-error-handler condition) + (let ((port (nearest-cmdl/port))) + (newline port) + (write-condition-report condition port)) + (compiler:abort false)) + +(define (compiler:abort value) + (if (not compiler:abort-handled?) + (error "Not set up to abort" value)) + (newline) + (write-string "*** Aborting...") + (compiler:abort-continuation value)) + +(define (batch-kernel real-kernel) + (lambda (input-string) + (call-with-current-continuation + (lambda (abort-compilation) + (fluid-let ((compiler:abort-continuation abort-compilation) + (compiler:abort-handled? true)) + (real-kernel input-string)))))) + +(define compiler:batch-mode? false) +(define compiler:abort-handled? false) +(define compiler:abort-continuation) + +;;;; Global variables + +(define *recursive-compilation-count*) +(define *recursive-compilation-number*) +(define *procedure-result?*) +(define *remote-links*) +(define *process-time*) +(define *real-time*) + +(define *kmp-output-port* false) +(define *kmp-output-abbreviated?* true) + +(define *info-output-filename* false) +(define *rtl-output-port* false) +(define *rtl-output-all-phases?* false) +(define *lap-output-port* false) + +;; First set: input to compilation +;; Last used: phase/canonicalize-scode +(define *input-scode*) + +;; First set: phase/canonicalize-scode +;; Last used: phase/translate-scode +(define *scode*) + +;; First set: phase/translate-scode +;; Last used: phase/fg-optimization-cleanup +(define *root-block*) + +;; First set: phase/translate-scode +;; Last used: phase/rtl-generation +(define *root-expression*) +(define *root-procedure*) + +;; First set: phase/rtl-generation +;; Last used: phase/lap-linearization +(define *rtl-expression*) +(define *rtl-procedures*) +(define *rtl-continuations*) +(define *rtl-graphs*) +(define label->object) +(define *rtl-root*) + +;; First set: phase/rtl-generation +;; Last used: phase/link +(define *ic-procedure-headers*) +(define *entry-label*) + +;; First set: phase/lap-generation +;; Last used: phase/link +(define *subprocedure-linking-info*) + +;; First set: phase/lap-linearization +;; Last used: phase/assemble +(define *lap*) + +;; First set: phase/lap-linearization +;; Last used: phase/info-generation-2 +(define *dbg-expression*) +(define *dbg-procedures*) +(define *dbg-continuations*) + +(define (in-compiler thunk) + (let ((run-compiler + (lambda () + (let ((value + (let ((expression (thunk))) + (let ((others + (map (lambda (other) (vector-ref other 2)) + (recursive-compilation-results)))) + (cond ((not (compiled-code-address? expression)) + (vector compiler:compile-by-procedures? + expression + others)) + ((null? others) + expression) + (else + (scode/make-comment + (make-dbg-info-vector + (let ((all-blocks + (list->vector + (cons + (compiled-code-address->block + expression) + others)))) + (if compiler:compile-by-procedures? + (list 'COMPILED-BY-PROCEDURES + all-blocks + (list->vector others)) + all-blocks))) + expression))))))) + (if compiler:show-time-reports? + (compiler-time-report "Total compilation time" + *process-time* + *real-time*)) + value)))) + (if compiler:preserve-data-structures? + (begin + (compiler:reset!) + (run-compiler)) + (fluid-let ((*recursive-compilation-number* 0) + (*recursive-compilation-count* 1) + (*procedure-result?* false) + (*remote-links* '()) + (*process-time* 0) + (*real-time* 0)) + (bind-assembler&linker-top-level-variables + (lambda () + (bind-compiler-variables run-compiler))))))) + +(define (bind-compiler-variables thunk) + ;; Split this fluid-let because compiler was choking on it. + (fluid-let ((*ic-procedure-headers*) + (*current-label-number*) + (*dbg-expression*) + (*dbg-procedures*) + (*dbg-continuations*) + (*lap*) + (*expressions*) + (*procedures*)) + (fluid-let ((*input-scode*) + (*scode*) + (*kmp-program*) + (*optimized-kmp-program*) + (*rtl-program*) + (*rtl-entry-label*) + (*root-expression*) + (*root-procedure*) + (*root-block*) + (*rtl-expression*) + (*rtl-procedures*) + (*rtl-continuations*) + (*rtl-graphs*) + (label->object) + (*rtl-root*) + (*machine-register-map*) + (*entry-label*) + (*subprocedure-linking-info*)) + (bind-assembler&linker-variables thunk)))) + +(define (compiler:reset!) + (set! *recursive-compilation-number* 0) + (set! *recursive-compilation-count* 1) + (set! *procedure-result?* false) + (set! *remote-links* '()) + (set! *process-time* 0) + (set! *real-time* 0) + + (set! *ic-procedure-headers*) + (set! *current-label-number*) + (set! *dbg-expression*) + (set! *dbg-procedures*) + (set! *dbg-continuations*) + (set! *lap*) + (set! *expressions*) + (set! *procedures*) + (set! *input-scode*) + (set! *scode*) + (set! *kmp-program*) + (set! *optimized-kmp-program*) + (set! *rtl-program*) + (set! *rtl-entry-label*) + (set! *root-expression*) + (set! *root-procedure*) + (set! *root-block*) + (set! *rtl-expression*) + (set! *rtl-procedures*) + (set! *rtl-continuations*) + (set! *rtl-graphs*) + (set! label->object) + (set! *rtl-root*) + (set! *machine-register-map*) + (set! *entry-label*) + (set! *subprocedure-linking-info*) + (assembler&linker-reset!)) + +(define (compiler-phase name thunk) + (if compiler:show-phases? + (compiler-phase/visible name + (lambda () + (compiler-phase/invisible thunk))) + (compiler-phase/invisible thunk))) + +(define (compiler-superphase name thunk) + (if compiler:show-subphases? + (thunk) + (compiler-phase name thunk))) + +(define (compiler-subphase name thunk) + (if compiler:show-subphases? + (compiler-phase name thunk) + (compiler-phase/invisible thunk))) + +(define (compiler-phase/visible name thunk) + (fluid-let ((*output-prefix* (string-append " " *output-prefix*))) + (newline) + (write-string *output-prefix*) + (write-string name) + (write-string "...") + (if compiler:show-time-reports? + (let ((process-start *process-time*) + (real-start *real-time*)) + (let ((value (thunk))) + (compiler-time-report " Time taken" + (- *process-time* process-start) + (- *real-time* real-start)) + value)) + (thunk)))) + +(define *output-prefix* "") +(define *phase-level* 0) + +(define (compiler-phase/invisible thunk) + (fluid-let ((*phase-level* (1+ *phase-level*))) + (let ((do-it + (if compiler:phase-wrapper + (lambda () (compiler:phase-wrapper thunk)) + thunk))) + (if (= 1 *phase-level*) + (let ((process-start (process-time-clock)) + (real-start (real-time-clock))) + (let ((value (do-it))) + (let ((process-delta (- (process-time-clock) process-start)) + (real-delta (- (real-time-clock) real-start))) + (set! *process-time* (+ process-delta *process-time*)) + (set! *real-time* (+ real-delta *real-time*))) + value)) + (do-it))))) + +(define (compiler-time-report prefix process-time real-time) + (newline) + (write-string *output-prefix*) + (write-string prefix) + (write-string ": ") + (write (/ (exact->inexact process-time) 1000)) + (write-string " (process time); ") + (write (/ (exact->inexact real-time) 1000)) + (write-string " (real time)")) + +(define (phase/canonicalize-scode) + (compiler-subphase "Scode Canonicalization" + (lambda () + (set! *scode* (canonicalize/top-level (last-reference *input-scode*))) + unspecific))) + +(define (phase/rtl-optimization) + (compiler-superphase "RTL Optimization" + (lambda () + (phase/rtl-dataflow-analysis) + (phase/rtl-rewriting rtl-rewriting:pre-cse) + (if (and *rtl-output-all-phases?* *rtl-output-port*) + (phase/rtl-file-output "Post Rtl-rewriting:pre-cse" + false + false + false + *rtl-output-port* + false)) + (if compiler:cse? + (phase/common-subexpression-elimination)) + (if *rtl-output-port* + (phase/rtl-file-output "Post CSE" + false + false + false + *rtl-output-port* + false)) + (phase/invertible-expression-elimination) + (if (and *rtl-output-all-phases?* *rtl-output-port*) + (phase/rtl-file-output "Post Invertible-Expression-Elimination" + false + false + false + *rtl-output-port* + false)) + (phase/rtl-rewriting rtl-rewriting:post-cse) + (phase/common-suffix-merging) + (phase/linearization-analysis) + (phase/lifetime-analysis) + (if (and *rtl-output-all-phases?* *rtl-output-port*) + (phase/rtl-file-output "Post Lifetime-Analysis" + false + false + false + *rtl-output-port* + false)) + (if compiler:code-compression? + (phase/code-compression)) + (phase/register-allocation) + (phase/rtl-optimization-cleanup)))) + +(define (phase/rtl-dataflow-analysis) + (compiler-subphase "RTL Dataflow Analysis" + (lambda () + (rtl-dataflow-analysis *rtl-graphs*)))) + +(define (phase/rtl-rewriting rtl-rewriting) + (compiler-subphase "RTL Rewriting" + (lambda () + (rtl-rewriting *rtl-graphs*)))) + +(define (phase/common-subexpression-elimination) + (compiler-subphase "Common Subexpression Elimination" + (lambda () + (common-subexpression-elimination *rtl-graphs*)))) + +(define (phase/invertible-expression-elimination) + (compiler-subphase "Invertible Expression Elimination" + (lambda () + (invertible-expression-elimination *rtl-graphs*)))) + +(define (phase/common-suffix-merging) + (compiler-subphase "Common Suffix Merging" + (lambda () + (merge-common-suffixes! *rtl-graphs*)))) + +(define (phase/lifetime-analysis) + (compiler-subphase "Lifetime Analysis" + (lambda () + (lifetime-analysis *rtl-graphs*)))) + +(define (phase/code-compression) + (compiler-subphase "Instruction Combination" + (lambda () + (code-compression *rtl-graphs*)))) + +(define (phase/linearization-analysis) + (compiler-subphase "Linearization Analysis" + (lambda () + (setup-bblock-continuations! *rtl-graphs*)))) + +(define (phase/register-allocation) + (compiler-subphase "Register Allocation" + (lambda () + (register-allocation *rtl-graphs*)))) + +(define (phase/rtl-optimization-cleanup) + (if (not compiler:preserve-data-structures?) + (for-each (lambda (rgraph) + (set-rgraph-bblocks! rgraph false) + ;; **** this slot is reused. **** + ;;(set-rgraph-register-bblock! rgraph false) + (set-rgraph-register-crosses-call?! rgraph false) + (set-rgraph-register-n-deaths! rgraph false) + (set-rgraph-register-live-length! rgraph false) + (set-rgraph-register-n-refs! rgraph false) + (set-rgraph-register-known-values! rgraph false) + (set-rgraph-register-known-expressions! rgraph false)) + *rtl-graphs*))) + +(define (phase/rtl-file-output class continuations-linked? + last-for-this-scode? scode port code) + (compiler-phase "RTL File Output" + (lambda () + (write-string class port) + (write-string " RTL for object " port) + (write *recursive-compilation-number* port) + (newline port) + (if scode + (begin (pp scode port #t 4) + (newline port) + (newline port))) + (write-rtl-instructions (or code + (linearize-rtl *rtl-root* + *rtl-procedures* + *rtl-continuations* + continuations-linked?)) + port) + (if (or (not (zero? *recursive-compilation-number*)) + (not last-for-this-scode?)) + (begin + (write-char #\page port) + (newline port))) + (output-port/flush-output port)))) + +(define (phase/lap-generation) + (compiler-phase "LAP Generation" + (lambda () + (initialize-back-end!) + (if *procedure-result?* + (generate-lap *rtl-graphs* '() + (lambda (prefix environment-label free-ref-label n-sections) + (node-insert-snode! (rtl-procedure/entry-node *rtl-root*) + (make-sblock prefix)) + (set! *entry-label* + (rtl-procedure/external-label *rtl-root*)) + (set! *subprocedure-linking-info* + (vector environment-label free-ref-label n-sections)) + unspecific)) + (begin + (let ((prefix (generate-lap *rtl-graphs* *remote-links* false))) + (node-insert-snode! (rtl-expr/entry-node *rtl-root*) + (make-sblock prefix))) + (set! *entry-label* (rtl-expr/label *rtl-root*)) + unspecific))))) + +(define (phase/lap-linearization) + (compiler-phase "LAP Linearization" + (lambda () + (set! *lap* + (optimize-linear-lap + (wrap-lap *entry-label* + (linearize-lap *rtl-root* + *rtl-procedures* + *rtl-continuations* + true)))) + (if *use-debugging-info?* + (with-values + (lambda () + (info-generation-phase-2 *rtl-expression* + *rtl-procedures* + *rtl-continuations*)) + (lambda (expression procedures continuations) + (set! *dbg-expression* expression) + (set! *dbg-procedures* procedures) + (set! *dbg-continuations* continuations) + unspecific))) + (if (not compiler:preserve-data-structures?) + (begin + (set! *rtl-expression*) + (set! *rtl-procedures*) + (set! *rtl-continuations*) + (set! *rtl-graphs*) + (set! label->object) + (set! *rtl-root*) + unspecific))))) + +(define (phase/lap-file-output scode port) + (compiler-phase "LAP File Output" + (lambda () + (fluid-let ((*unparser-radix* 16) + (*unparse-uninterned-symbols-by-name?* true)) + (with-output-to-port port + (lambda () + (define (hack-rtl rtl) + (if (pair? rtl) + (cond ((eq? (car rtl) 'REGISTER) + (string->uninterned-symbol + (with-output-to-string + (lambda () (display "r") (display (cadr rtl)))))) + ((eq? (car rtl) 'CONSTANT) + rtl) + (else + (map hack-rtl rtl))) + rtl)) + + (write-string "LAP for object ") + (write *recursive-compilation-number*) + (newline) + (pp scode (current-output-port) #T 4) + (newline) + (newline) + (newline) + (for-each + (lambda (instruction) + (cond ((and (pair? instruction) + (eq? (car instruction) 'LABEL)) + (write (cadr instruction)) + (write-char #\:)) + ((and (pair? instruction) + (eq? (car instruction) 'COMMENT)) + (write-char #\tab) + (write-string ";;") + (for-each (lambda (frob) + (write-string " ") + (write (if (and (pair? frob) + (eq? (car frob) 'RTL)) + (hack-rtl (cadr frob)) + frob))) + (cdr instruction))) + (else + (write-char #\tab) + (write instruction))) + (newline)) + *lap*) + (if (not (zero? *recursive-compilation-number*)) + (begin + (write-char #\page) + (newline))) + (output-port/flush-output port))))))) + +(define compile-bin-file compile-bin-file/new) +(define cbf cbf/new) +(define cf cf/new) +(define compile-expression compile-expression/new) +(define compile-procedure compile-procedure/new) diff --git a/v8/src/compiler/base/utils.scm b/v8/src/compiler/base/utils.scm new file mode 100644 index 000000000..4830c6f9c --- /dev/null +++ b/v8/src/compiler/base/utils.scm @@ -0,0 +1,390 @@ +#| -*-Scheme-*- + +$Id: utils.scm,v 1.1 1994/11/19 02:02:36 adams Exp $ + +Copyright (c) 1987-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Compiler Utilities +;; package: (compiler) + +(declare (usual-integrations)) + +;;;; Miscellaneous + +(define (three-way-sort = set set* receiver) + (let ((member? (member-procedure =))) + (define (loop set set* receiver) + (if (null? set) + (receiver '() '() set*) + (let ((item (member? (car set) set*))) + (if item + (loop (cdr set) (delq! (car item) set*) + (lambda (set-only both set*-only) + (receiver set-only + (cons (cons (car set) (car item)) both) + set*-only))) + (loop (cdr set) set* + (lambda (set-only both set*-only) + (receiver (cons (car set) set-only) + both + set*-only))))))) + (loop set (list-copy set*) receiver))) + +(define (discriminate-items items predicate) + (let loop ((items items) (passed '()) (failed '())) + (cond ((null? items) + (values (reverse! passed) (reverse! failed))) + ((predicate (car items)) + (loop (cdr items) (cons (car items) passed) failed)) + (else + (loop (cdr items) passed (cons (car items) failed)))))) + +(define (generate-label #!optional prefix) + (if (default-object? prefix) (set! prefix 'LABEL)) + (string->uninterned-symbol + (canonicalize-label-name + (string-append + (symbol->string + (cond ((eq? prefix lambda-tag:unnamed) 'LAMBDA) + ((eq? prefix lambda-tag:let) 'LET) + ((eq? prefix lambda-tag:make-environment) 'MAKE-ENVIRONMENT) + ((eq? prefix lambda-tag:fluid-let) 'FLUID-LET) + (else prefix))) + "-" + (number->string (generate-label-number)))))) + +(define *current-label-number*) + +(define (generate-label-number) + (let ((number *current-label-number*)) + (set! *current-label-number* (1+ *current-label-number*)) + number)) + +(define (list-filter-indices items indices) + (let loop ((items items) (indices indices) (index 0)) + (cond ((null? indices) '()) + ((= (car indices) index) + (cons (car items) + (loop (cdr items) (cdr indices) (1+ index)))) + (else + (loop (cdr items) indices (1+ index)))))) + +(define (all-eq? items) + (if (null? items) + (error "ALL-EQ?: undefined for empty set")) + (or (null? (cdr items)) + (for-all? (cdr items) + (let ((item (car items))) + (lambda (item*) + (eq? item item*)))))) + +(define (all-eq-map? items map) + (if (null? items) + (error "ALL-EQ-MAP?: undefined for empty set")) + (let ((item (map (car items)))) + (if (or (null? (cdr items)) + (for-all? (cdr items) (lambda (item*) (eq? item (map item*))))) + (values true item) + (values false false)))) + +(define (eq-set-union* set sets) + (let loop ((set set) (sets sets) (accum '())) + (if (null? sets) + (eq-set-union set accum) + (loop (car sets) (cdr sets) (eq-set-union set accum))))) + +(package (transitive-closure enqueue-node! enqueue-nodes!) + +(define *queue*) + +(define-export (transitive-closure initialization process-node nodes) + (fluid-let ((*queue* true)) + (if initialization (initialization)) + (set! *queue* nodes) + (let loop () + (if (not (null? *queue*)) + (begin (let ((node (car *queue*))) + (set! *queue* (cdr *queue*)) + (process-node node)) + (loop)))))) + +(define-export (enqueue-node! node) + (if (and (not (eq? *queue* true)) + (not (memq node *queue*))) + (set! *queue* (cons node *queue*)))) + +(define-export (enqueue-nodes! nodes) + (if (not (eq? *queue* true)) + (set! *queue* (eq-set-union nodes *queue*)))) + +) + +;;;; Type Codes + +(let-syntax ((define-type-code + (macro (var-name #!optional type-name) + (if (default-object? type-name) (set! type-name var-name)) + `(DEFINE-INTEGRABLE ,(symbol-append 'TYPE-CODE: var-name) + ',(microcode-type type-name))))) + (define-type-code lambda) + (define-type-code extended-lambda) + (define-type-code procedure) + (define-type-code extended-procedure) + (define-type-code cell) + (define-type-code environment) + (define-type-code unassigned) + (define-type-code stack-environment) + (define-type-code compiled-entry)) + +(define (scode/procedure-type-code *lambda) + (cond ((object-type? type-code:lambda *lambda) + type-code:procedure) + ((object-type? type-code:extended-lambda *lambda) + type-code:extended-procedure) + (else + (error "SCODE/PROCEDURE-TYPE-CODE: Unknown lambda type" *lambda)))) + +;;; Primitive Procedures + +(define (primitive-procedure? object) + (or (eq? compiled-error-procedure object) + (scode/primitive-procedure? object))) + +(define (primitive-arity-correct? primitive argument-count) + (if (eq? primitive compiled-error-procedure) + (positive? argument-count) + (let ((arity (primitive-procedure-arity primitive))) + (or (= arity -1) + (= arity argument-count))))) + +;;;; Special Compiler Support + +(define compiled-error-procedure + "Compiled error procedure") + +(define lambda-tag:delay + (intern "#[delay-lambda]")) + +(define (non-pointer-object? object) + ;; Any reason not to use `object/non-pointer?' here? -- cph + (or (object-type? (ucode-type false) object) + (object-type? (ucode-type true) object) + (fix:fixnum? object) + (object-type? (ucode-type character) object) + (object-type? (ucode-type unassigned) object) + (object-type? (ucode-type the-environment) object) + (object-type? (ucode-type manifest-nm-vector) object) + (object-type? (ucode-type manifest-special-nm-vector) object))) + +(define (object-immutable? object) + (or (non-pointer-object? object) + (number? object) + (symbol? object) + (scode/primitive-procedure? object) + (eq? object compiled-error-procedure))) + +(define boolean-valued-function-names + '( + OBJECT-TYPE? EQ? FALSE? NULL? PAIR? VECTOR? SYMBOL? STRING? + NUMBER? CHAR? PROMISE? BIT-STRING? CELL? + COMPLEX? REAL? RATIONAL? INTEGER? EXACT? INEXACT? + ZERO? POSITIVE? NEGATIVE? ODD? EVEN? + = < > <= >= + INDEX-FIXNUM? + FIX:FIXNUM? FIX:ZERO? FIX:NEGATIVE? FIX:POSITIVE? FIX:= FIX:< FIX:> + FLO:FLONUM? FLO:ZERO? FLO:NEGATIVE? FLO:POSITIVE? FLO:= FLO:< FLO:> + INT:INTEGER? INT:ZERO? INT:NEGATIVE? INT:POSITIVE? INT:= INT:< INT:> + NOT BIT-STRING-REF + )) + +(define function-names + (append + boolean-valued-function-names + '( + ;; Numbers + MAX MIN + - * / 1+ -1+ CONJUGATE ABS QUOTIENT REMAINDER MODULO + INTEGER-DIVIDE GCD LCM NUMERATOR DENOMINATOR FLOOR CEILING TRUNCATE ROUND + FLOOR->EXACT CEILING->EXACT TRUNCATE->EXACT ROUND->EXACT + RATIONALIZE RATIONALIZE->EXACT SIMPLEST-RATIONAL SIMPLEST-EXACT-RATIONAL + EXP LOG SIN COS TAN ASIN ACOS ATAN SQRT EXPT MAKE-RECTANGULAR MAKE-POLAR + REAL-PART IMAG-PART MAGNITUDE ANGLE EXACT->INEXACT INEXACT->EXACT + FIX:1+ FIX:-1+ FIX:+ FIX:- FIX:* + FIX:DIVIDE FIX:GCD FIX:QUOTIENT FIX:REMAINDER + FIX:AND FIX:ANDC FIX:NOT FIX:OR FIX:XOR + + INT:+ INT:- INT:* INT:DIVIDE INT:QUOTIENT INT:REMAINDER INT:ABS + INT:1+ INT:-1+ INT:NEGATE + FLO:+ FLO:- FLO:* FLO:/ FLO:NEGATE FLO:ABS FLO:EXP FLO:LOG FLO:SIN FLO:COS + FLO:TAN FLO:ASIN FLO:ACOS FLO:ATAN FLO:ATAN2 FLO:SQRT FLO:EXPT FLO:FLOOR + FLO:CEILING FLO:TRUNCATE FLO:ROUND FLO:FLOOR->EXACT FLO:CEILING->EXACT + FLO:TRUNCATE->EXACT FLO:ROUND->EXACT + + ;; Random + OBJECT-TYPE CHAR-ASCII? ASCII->CHAR CHAR->INTEGER CHAR-BITS CHAR-CODE + CHAR-DOWNCASE CHAR-UPCASE INTEGER->CHAR MAKE-CHAR + PRIMITIVE-PROCEDURE-ARITY + + ;; References (assumes immediate constants are immutable) + CAR CDR LENGTH + VECTOR-REF VECTOR-LENGTH + STRING-REF STRING-LENGTH STRING-MAXIMUM-LENGTH + BIT-STRING-LENGTH + ))) + +;; The following definition is used to avoid computation if possible. +;; Not to avoid recomputation. To avoid recomputation, function-names +;; should be used. +;; +;; Example: CONS has no side effects, yet it is not a function. +;; Thus if the result of a CONS is not going to be used, we can avoid the +;; CONS operation, yet we can't reuse its result even when given the same +;; arguments again because the two pairs should not be EQ?. + +(define side-effect-free-additional-names + `( + ;; Constructors + CONS LIST CONS* MAKE-STRING VECTOR MAKE-VECTOR LIST-COPY VECTOR-COPY + LIST->VECTOR VECTOR->LIST MAKE-BIT-STRING MAKE-CELL STRING->SYMBOL + )) + +(define additional-boolean-valued-function-primitives + (list (ucode-primitive zero?) + (ucode-primitive positive?) + (ucode-primitive negative?) + (ucode-primitive &=) + (ucode-primitive &<) + (ucode-primitive &>))) + +(define additional-function-primitives + (list (ucode-primitive 1+) + (ucode-primitive -1+) + (ucode-primitive &+) + (ucode-primitive &-) + (ucode-primitive &*) + (ucode-primitive &/))) + +;;;; "Foldable" and side-effect-free operators + +(define boolean-valued-function-variables) +(define function-variables) +(define side-effect-free-variables) +(define boolean-valued-function-primitives) +(define function-primitives) +(define side-effect-free-primitives) + +(let ((global-valued + (lambda (names) + (list-transform-negative names + (lambda (name) + (lexical-unreferenceable? system-global-environment name))))) + (global-value + (lambda (name) + (lexical-reference system-global-environment name))) + (primitives + (let ((primitive-procedure? + (lexical-reference system-global-environment + 'PRIMITIVE-PROCEDURE?))) + (lambda (procedures) + (list-transform-positive procedures primitive-procedure?))))) + (let ((names (global-valued boolean-valued-function-names))) + (let ((procedures (map global-value names))) + (set! boolean-valued-function-variables (map cons names procedures)) + (set! boolean-valued-function-primitives + (append! (primitives procedures) + additional-boolean-valued-function-primitives)))) + (let ((names (global-valued function-names))) + (let ((procedures (map global-value names))) + (set! function-variables + (map* boolean-valued-function-variables cons names procedures)) + (set! function-primitives + (append! (primitives procedures) + (append additional-function-primitives + boolean-valued-function-primitives))))) + (let ((names (global-valued side-effect-free-additional-names))) + (let ((procedures (map global-value names))) + (set! side-effect-free-variables + (map* function-variables cons names procedures)) + (set! side-effect-free-primitives + (append! (primitives procedures) + function-primitives)) + unspecific))) + +(define-integrable (boolean-valued-function-variable? name) + (assq name boolean-valued-function-variables)) + +(define-integrable (constant-foldable-variable? name) + (assq name function-variables)) + +(define-integrable (side-effect-free-variable? name) + (assq name side-effect-free-variables)) + +(define (variable-usual-definition name) + (let ((place (assq name side-effect-free-variables))) + (and place + (cdr place)))) + +(define-integrable (boolean-valued-function-primitive? operator) + (memq operator boolean-valued-function-primitives)) + +(define-integrable (constant-foldable-primitive? operator) + (memq operator function-primitives)) + +(define-integrable (side-effect-free-primitive? operator) + (memq operator side-effect-free-primitives)) + +(define procedure-object? + (lexical-reference system-global-environment 'PROCEDURE?)) + +;;!(define (careful-object-datum object) +;;! ;; This works correctly when cross-compiling. +;;! (if (and (object-type? (ucode-type fixnum) object) +;;! (negative? object)) +;;! (+ object unsigned-fixnum/upper-limit) +;;! (object-datum object))) + +(define (careful-object-datum object) + ;; This works correctly when cross-compiling. + (if (and (fix:fixnum? object) + (negative? object)) + (+ object unsigned-fixnum/upper-limit) + (object-datum object))) + +(define (list-split ol predicate) + ;; (values yes no) + (let loop ((l (reverse ol)) + (yes '()) + (no '())) + (cond ((null? l) + (values yes no)) + ((predicate (car l)) + (loop (cdr l) (cons (car l) yes) no)) + (else + (loop (cdr l) yes (cons (car l) no)))))) \ No newline at end of file diff --git a/v8/src/compiler/machines/spectrum/assmd.scm b/v8/src/compiler/machines/spectrum/assmd.scm new file mode 100644 index 000000000..b2a65ff5d --- /dev/null +++ b/v8/src/compiler/machines/spectrum/assmd.scm @@ -0,0 +1,91 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/spectrum/assmd.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ +$MC68020-Header: assmd.scm,v 1.36 89/08/28 18:33:33 GMT cph Exp $ + +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Assembler Machine Dependencies + +(declare (usual-integrations)) + +(let-syntax ((ucode-type (macro (name) `',(microcode-type name)))) + +(define-integrable maximum-padding-length + ;; Instruction length is always a multiple of 32 bits + ;; Would 0 work here? + 32) + +(define padding-string + ;; Pad with `DIAG SCM' instructions + (unsigned-integer->bit-string maximum-padding-length + #b00010100010100110100001101001101)) + +(define-integrable block-offset-width + ;; Block offsets are always 16 bit words + 16) + +(define-integrable maximum-block-offset + ;; PC always aligned on longword boundary. Use the extra bit. + (- (expt 2 (1+ block-offset-width)) 4)) + +(define (block-offset->bit-string offset start?) + (unsigned-integer->bit-string block-offset-width + (+ (quotient offset 2) + (if start? 0 1)))) + +(define (make-nmv-header n) + (bit-string-append (unsigned-integer->bit-string scheme-datum-width n) + nmv-type-string)) + +(define nmv-type-string + (unsigned-integer->bit-string scheme-type-width + (ucode-type manifest-nm-vector))) + +(define (object->bit-string object) + (bit-string-append + (unsigned-integer->bit-string scheme-datum-width + (careful-object-datum object)) + (unsigned-integer->bit-string scheme-type-width (object-type object)))) + +;;; Machine dependent instruction order + +(define (instruction-insert! bits block position receiver) + (let* ((l (bit-string-length bits)) + (new-position (- position l))) + (bit-substring-move-right! bits 0 l block new-position) + (receiver new-position))) + +(define instruction-initial-position bit-string-length) +(define-integrable instruction-append bit-string-append-reversed) + +;;; end let-syntax +) \ No newline at end of file diff --git a/v8/src/compiler/machines/spectrum/coerce.scm b/v8/src/compiler/machines/spectrum/coerce.scm new file mode 100644 index 000000000..2ee5d39c5 --- /dev/null +++ b/v8/src/compiler/machines/spectrum/coerce.scm @@ -0,0 +1,161 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/spectrum/coerce.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ +$MC68020-Header: coerce.scm,v 1.10 88/08/31 05:56:37 GMT cph Exp $ + +Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +(declare (usual-integrations)) + +;;;; Strange hppa coercions + +(define (coerce-right-signed nbits) + (let ((offset (1+ (expt 2 nbits)))) + (lambda (n) + (unsigned-integer->bit-string nbits + (if (negative? n) + (+ (* n 2) offset) + (* n 2)))))) + +(define (coerce-assemble12:x nbits) + (let ((range (expt 2 11))) + (lambda (n) + (let ((n (machine-word-offset n range)) + (r (unsigned-integer->bit-string nbits 0))) + (bit-substring-move-right! n 0 10 r 1) + (bit-substring-move-right! n 10 11 r 0) + r)))) + +(define (coerce-assemble12:y nbits) + (let ((range (expt 2 11))) + (lambda (n) + (let ((r (unsigned-integer->bit-string nbits 0))) + (bit-substring-move-right! (machine-word-offset n range) 11 12 r 0) + r)))) + +(define (coerce-assemble17:x nbits) + (let ((range (expt 2 16))) + (lambda (n) + (let ((r (unsigned-integer->bit-string nbits 0))) + (bit-substring-move-right! (machine-word-offset n range) 11 16 r 0) + r)))) + +(define (coerce-assemble17:y nbits) + (let ((range (expt 2 16))) + (lambda (n) + (let ((n (machine-word-offset n range)) + (r (unsigned-integer->bit-string nbits 0))) + (bit-substring-move-right! n 0 10 r 1) + (bit-substring-move-right! n 10 11 r 0) + r)))) + +(define (coerce-assemble17:z nbits) + (let ((range (expt 2 16))) + (lambda (n) + (let ((r (unsigned-integer->bit-string nbits 0))) + (bit-substring-move-right! (machine-word-offset n range) 16 17 r 0) + r)))) + +(define (coerce-assemble21:x nbits) + ;; This one does not check for range. Should it? + (lambda (n) + (let ((n (integer->word n)) + (r (unsigned-integer->bit-string nbits 0))) + (bit-substring-move-right! n 0 2 r 12) + (bit-substring-move-right! n 2 7 r 16) + (bit-substring-move-right! n 7 9 r 14) + (bit-substring-move-right! n 9 20 r 1) + (bit-substring-move-right! n 20 21 r 0) + r))) + +(define (machine-word-offset n range) + (let ((value (integer-divide n 4))) + (if (not (zero? (integer-divide-remainder value))) + (error "machine-word-offset: Invalid offset" n)) + (let ((result (integer-divide-quotient value))) + (if (and (< result range) + (>= result (- range))) + (integer->word result) + (error "machine-word-offset: Doesn't fit" n range))))) + +(define (integer->word x) + (unsigned-integer->bit-string + 32 + (let ((x (if (negative? x) (+ x #x100000000) x))) + (if (not (and (not (negative? x)) (< x #x100000000))) + (error "Integer too large to be encoded" x)) + x))) + +;;; Coercion top level + +(define make-coercion + (coercion-maker + `((ASSEMBLE12:X . ,coerce-assemble12:x) + (ASSEMBLE12:Y . ,coerce-assemble12:y) + (ASSEMBLE17:X . ,coerce-assemble17:x) + (ASSEMBLE17:Y . ,coerce-assemble17:y) + (ASSEMBLE17:Z . ,coerce-assemble17:z) + (ASSEMBLE21:X . ,coerce-assemble21:x) + (RIGHT-SIGNED . ,coerce-right-signed) + (UNSIGNED . ,coerce-unsigned-integer) + (SIGNED . ,coerce-signed-integer)))) + +(define coerce-1-bit-unsigned (make-coercion 'UNSIGNED 1)) +(define coerce-2-bit-unsigned (make-coercion 'UNSIGNED 2)) +(define coerce-3-bit-unsigned (make-coercion 'UNSIGNED 3)) +(define coerce-4-bit-unsigned (make-coercion 'UNSIGNED 4)) +(define coerce-5-bit-unsigned (make-coercion 'UNSIGNED 5)) +(define coerce-6-bit-unsigned (make-coercion 'UNSIGNED 6)) +(define coerce-7-bit-unsigned (make-coercion 'UNSIGNED 7)) +(define coerce-8-bit-unsigned (make-coercion 'UNSIGNED 8)) +(define coerce-9-bit-unsigned (make-coercion 'UNSIGNED 9)) +(define coerce-10-bit-unsigned (make-coercion 'UNSIGNED 10)) +(define coerce-11-bit-unsigned (make-coercion 'UNSIGNED 11)) +(define coerce-12-bit-unsigned (make-coercion 'UNSIGNED 12)) +(define coerce-13-bit-unsigned (make-coercion 'UNSIGNED 13)) +(define coerce-14-bit-unsigned (make-coercion 'UNSIGNED 14)) +(define coerce-15-bit-unsigned (make-coercion 'UNSIGNED 15)) +(define coerce-16-bit-unsigned (make-coercion 'UNSIGNED 16)) +(define coerce-32-bit-unsigned (make-coercion 'UNSIGNED 32)) + +(define coerce-8-bit-signed (make-coercion 'SIGNED 8)) +(define coerce-16-bit-signed (make-coercion 'SIGNED 16)) +(define coerce-32-bit-signed (make-coercion 'SIGNED 32)) + +(define coerce-5-bit-right-signed (make-coercion 'RIGHT-SIGNED 5)) +(define coerce-11-bit-right-signed (make-coercion 'RIGHT-SIGNED 11)) +(define coerce-14-bit-right-signed (make-coercion 'RIGHT-SIGNED 14)) +(define coerce-11-bit-assemble12:x (make-coercion 'ASSEMBLE12:X 11)) +(define coerce-1-bit-assemble12:y (make-coercion 'ASSEMBLE12:Y 1)) +(define coerce-5-bit-assemble17:x (make-coercion 'ASSEMBLE17:X 5)) +(define coerce-11-bit-assemble17:y (make-coercion 'ASSEMBLE17:Y 11)) +(define coerce-1-bit-assemble17:z (make-coercion 'ASSEMBLE17:Z 1)) +(define coerce-21-bit-assemble21:x (make-coercion 'ASSEMBLE21:X 21)) \ No newline at end of file diff --git a/v8/src/compiler/machines/spectrum/compiler.cbf b/v8/src/compiler/machines/spectrum/compiler.cbf new file mode 100644 index 000000000..dadce775a --- /dev/null +++ b/v8/src/compiler/machines/spectrum/compiler.cbf @@ -0,0 +1,48 @@ +#| -*-Scheme-*- + +$Id: compiler.cbf,v 1.1 1994/11/19 02:11:31 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Script to incrementally compile the compiler (from .bins) + +(fluid-let ((compiler:coalescing-constant-warnings? #f)) + (for-each compile-directory + '("back" + "base" + "machines/spectrum" + "rtlbase" + ; unused "rtlgen" + "rtlopt" + "midend" + ; unused "fggen" + ; unused "fgopt" + ))) \ No newline at end of file diff --git a/v8/src/compiler/machines/spectrum/compiler.pkg b/v8/src/compiler/machines/spectrum/compiler.pkg new file mode 100644 index 000000000..a35c8efd7 --- /dev/null +++ b/v8/src/compiler/machines/spectrum/compiler.pkg @@ -0,0 +1,722 @@ +#| -*-Scheme-*- + +$Id: compiler.pkg,v 1.1 1994/11/19 02:09:58 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Compiler Packaging + +(global-definitions "../runtime/runtime") + +(define-package (compiler) + (files "base/switch" + "base/object" ;tagged object support + "base/enumer" ;enumerations + "base/sets" ;set abstraction + "base/mvalue" ;multiple-value support + "base/scode" ;SCode abstraction + "machines/spectrum/machin" ;machine dependent stuff + "back/asutl" ;back-end odds and ends + "base/utils" ;odds and ends + + "base/cfg1" ;control flow graph + "base/cfg2" + "base/cfg3" + + "base/ctypes" ;CFG datatypes + + "base/rvalue" ;Right hand values + "base/lvalue" ;Left hand values + "base/blocks" ;rvalue: blocks + "base/proced" ;rvalue: procedures + "base/contin" ;rvalue: continuations + + "base/subprb" ;subproblem datatype + + "rtlbase/rgraph" ;program graph abstraction + "rtlbase/rtlty1" ;RTL: type definitions + "rtlbase/rtlty2" ;RTL: type definitions + "rtlbase/rtlexp" ;RTL: expression operations + "rtlbase/rtlcon" ;RTL: complex constructors + "rtlbase/rtlreg" ;RTL: registers + "rtlbase/rtlcfg" ;RTL: CFG types + "rtlbase/rtlobj" ;RTL: CFG objects + "rtlbase/regset" ;RTL: register sets + "rtlbase/valclass" ;RTL: value classes + + "back/insseq" ;LAP instruction sequences + ;; New stuff + "base/parass" ;parallel assignment + ;; End of new stuff + ) + (parent ()) + (export () + compiler:analyze-side-effects? + compiler:assume-safe-fixnums? + compiler:cache-free-variables? + compiler:coalescing-constant-warnings? + compiler:code-compression? + compiler:compile-by-procedures? + compiler:cse? + compiler:default-top-level-declarations + compiler:enable-expansion-declarations? + compiler:enable-integration-declarations? + compiler:generate-kmp-files? + compiler:generate-lap-files? + compiler:generate-range-checks? + compiler:generate-rtl-files? + compiler:generate-stack-checks? + compiler:generate-type-checks? + compiler:implicit-self-static? + compiler:intersperse-rtl-in-lap? + compiler:noisy? + compiler:open-code-flonum-checks? + compiler:open-code-primitives? + compiler:optimize-environments? + compiler:package-optimization-level + compiler:preserve-data-structures? + compiler:show-phases? + compiler:show-procedures? + compiler:show-subphases? + compiler:show-time-reports? + compiler:use-multiclosures?)) + +(define-package (compiler reference-contexts) + (files "base/refctx") + (parent (compiler)) + (export (compiler) + add-reference-context/adjacent-parents! + initialize-reference-contexts! + make-reference-context + modify-reference-contexts! + reference-context/adjacent-parent? + reference-context/block + reference-context/offset + reference-context/procedure + reference-context? + set-reference-context/offset!)) + +(define-package (compiler macros) + (files "base/macros") + (parent ()) + (export (compiler) + assembler-syntax-table + compiler-syntax-table + early-syntax-table + lap-generator-syntax-table) + (import (runtime macros) + parse-define-syntax) + (initialization (initialize-package!))) + +(define-package (compiler declarations) + (files "machines/spectrum/decls") + (parent (compiler)) + (export (compiler) + sc + syntax-files!) + (import (scode-optimizer top-level) + sf/internal) + (initialization (initialize-package!))) + +(define-package (compiler top-level) + (files "base/toplev" + "base/crstop" + "base/asstop") + (parent (compiler)) + (export () + ;; New stuff + cbf/new + cf/new + compile-bin-file/new + compile-expression/new + compile-procedure/new + compile-scode/new + ;; End of new stuff + cbf + cf + compile-bin-file + compile-expression + compile-procedure + compile-scode + compiler:dump-bci-file + compiler:dump-bci/bcs-files + compiler:dump-bif/bsm-files + compiler:dump-inf-file + compiler:dump-info-file + compiler:reset! + cross-compile-bin-file + cross-compile-bin-file-end) + (export (compiler) + canonicalize-label-name + ;; New stuff + *argument-registers* + ;; End of new stuff + *procedure-result?* + ) + (export (compiler midend) + *kmp-output-abbreviated?* + with-kmp-output-port + compile-recursively/new) +; (export (compiler fg-generator) +; compile-recursively) + (export (compiler rtl-generator) + *ic-procedure-headers* + *rtl-continuations* + *rtl-expression* + *rtl-graphs* + *rtl-procedures*) + (export (compiler lap-syntaxer) + *block-label* + *external-labels* + label->object) + (export (compiler debug) + *root-expression* + *rtl-procedures* + *rtl-graphs*) + (import (runtime compiler-info) + make-dbg-info-vector + split-inf-structure!) + (import (runtime unparser) + *unparse-uninterned-symbols-by-name?*)) + +(define-package (compiler debug) + (files "base/debug") + (parent (compiler)) + (export () + debug/find-continuation + debug/find-entry-node + debug/find-procedure + debug/where + dump-rtl + po + show-bblock-rtl + show-fg + show-fg-node + show-rtl + write-rtl-instructions) + (import (runtime pretty-printer) + *pp-primitives-by-name*) + (import (runtime unparser) + *unparse-uninterned-symbols-by-name?*)) + +(define-package (compiler pattern-matcher/lookup) + (files "base/pmlook") + (parent (compiler)) + (export (compiler) + make-pattern-variable + pattern-lookup + pattern-variable-name + pattern-variable? + pattern-variables)) + +(define-package (compiler pattern-matcher/parser) + (files "base/pmpars") + (parent (compiler)) + (export (compiler) + parse-rule + compile-pattern + rule-result-expression) + (export (compiler macros) + parse-rule + compile-pattern + rule-result-expression)) + +(define-package (compiler pattern-matcher/early) + (files "base/pmerly") + (parent (compiler)) + (export (compiler) + early-parse-rule + early-pattern-lookup + early-make-rule + make-database-transformer + make-symbol-transformer + make-bit-mask-transformer)) + +(define-package (compiler debugging-information) + (files "base/infnew") + (parent (compiler)) + (export (compiler top-level) + info-generation-phase-1 + info-generation-phase-2 + info-generation-phase-3) + (export (compiler rtl-generator) + generated-dbg-continuation) + (import (runtime compiler-info) + make-dbg-info + + make-dbg-expression + dbg-expression/block + dbg-expression/label + set-dbg-expression/label! + + make-dbg-procedure + dbg-procedure/block + dbg-procedure/label + set-dbg-procedure/label! + dbg-procedure/name + dbg-procedure/required + dbg-procedure/optional + dbg-procedure/rest + dbg-procedure/auxiliary + dbg-procedure/external-label + set-dbg-procedure/external-label! + dbg-procedureflow-graph converter + "fggen/declar" ;Declaration handling + ) + (parent (compiler)) + (export (compiler top-level) + canonicalize/top-level + construct-graph) + (import (runtime scode-data) + &pair-car + &pair-cdr + &triple-first + &triple-second + &triple-third)) + + (define-package (compiler fg-optimizer) + (files "fgopt/outer" ;outer analysis + "fgopt/sideff" ;side effect analysis + ) + (parent (compiler)) + (export (compiler top-level) + clear-call-graph! + compute-call-graph! + outer-analysis + side-effect-analysis)) + + (define-package (compiler fg-optimizer fold-constants) + (files "fgopt/folcon") + (parent (compiler fg-optimizer)) + (export (compiler top-level) fold-constants)) + + (define-package (compiler fg-optimizer operator-analysis) + (files "fgopt/operan") + (parent (compiler fg-optimizer)) + (export (compiler top-level) operator-analysis)) + + (define-package (compiler fg-optimizer variable-indirection) + (files "fgopt/varind") + (parent (compiler fg-optimizer)) + (export (compiler top-level) initialize-variable-indirections!)) + + (define-package (compiler fg-optimizer environment-optimization) + (files "fgopt/envopt") + (parent (compiler fg-optimizer)) + (export (compiler top-level) optimize-environments!)) + + (define-package (compiler fg-optimizer closure-analysis) + (files "fgopt/closan") + (parent (compiler fg-optimizer)) + (export (compiler top-level) identify-closure-limits!)) + + (define-package (compiler fg-optimizer continuation-analysis) + (files "fgopt/contan") + (parent (compiler fg-optimizer)) + (export (compiler top-level) + continuation-analysis + setup-block-static-links!)) + + (define-package (compiler fg-optimizer compute-node-offsets) + (files "fgopt/offset") + (parent (compiler fg-optimizer)) + (export (compiler top-level) compute-node-offsets)) + + (define-package (compiler fg-optimizer connectivity-analysis) + (files "fgopt/conect") + (parent (compiler fg-optimizer)) + (export (compiler top-level) connectivity-analysis)) + + (define-package (compiler fg-optimizer delete-integrated-parameters) + (files "fgopt/delint") + (parent (compiler fg-optimizer)) + (export (compiler top-level) delete-integrated-parameters)) + + (define-package (compiler fg-optimizer design-environment-frames) + (files "fgopt/desenv") + (parent (compiler fg-optimizer)) + (export (compiler top-level) design-environment-frames!)) + + (define-package (compiler fg-optimizer setup-block-types) + (files "fgopt/blktyp") + (parent (compiler fg-optimizer)) + (export (compiler top-level) + setup-block-types! + setup-closure-contexts!) + (export (compiler) + indirection-block-procedure)) + + (define-package (compiler fg-optimizer simplicity-analysis) + (files "fgopt/simple") + (parent (compiler fg-optimizer)) + (export (compiler top-level) simplicity-analysis) + (export (compiler fg-optimizer subproblem-ordering) + new-subproblem/compute-simplicity!)) + + (define-package (compiler fg-optimizer simulate-application) + (files "fgopt/simapp") + (parent (compiler fg-optimizer)) + (export (compiler top-level) simulate-application)) + + (define-package (compiler fg-optimizer subproblem-free-variables) + (files "fgopt/subfre") + (parent (compiler fg-optimizer)) + (export (compiler top-level) compute-subproblem-free-variables) + (export (compiler fg-optimizer) map-union) + (export (compiler fg-optimizer subproblem-ordering) + new-subproblem/compute-free-variables!)) + + (define-package (compiler fg-optimizer subproblem-ordering) + (files "fgopt/order") + (parent (compiler fg-optimizer)) + (export (compiler top-level) subproblem-ordering)) + + (define-package (compiler fg-optimizer subproblem-ordering reuse-frames) + (files "fgopt/reord" "fgopt/reuse") + (parent (compiler fg-optimizer subproblem-ordering)) + (export (compiler top-level) setup-frame-adjustments) + (export (compiler fg-optimizer subproblem-ordering) + order-subproblems/maybe-overwrite-block)) + + (define-package (compiler fg-optimizer subproblem-ordering parameter-analysis) + (files "fgopt/param") + (parent (compiler fg-optimizer subproblem-ordering)) + (export (compiler fg-optimizer subproblem-ordering) + parameter-analysis)) + + (define-package (compiler fg-optimizer return-equivalencing) + (files "fgopt/reteqv") + (parent (compiler fg-optimizer)) + (export (compiler top-level) find-equivalent-returns!)) +|# + +(define-package (compiler rtl-generator) + (files + "rtlbase/rtline" ;linearizer + ) + (parent (compiler)) + (export (compiler) + make-linearizer) + (export (compiler top-level) + linearize-rtl + setup-bblock-continuations! + ) + (export (compiler debug) + linearize-rtl) + (import (compiler top-level) + label->object)) + +(define-package (compiler rtl-cse) + (files "rtlopt/rcse1" ;RTL common subexpression eliminator + "rtlopt/rcse2" + "rtlopt/rcsemrg" ;CSE control-flow merge + "rtlopt/rcseep" ;CSE expression predicates + "rtlopt/rcseht" ;CSE hash table + "rtlopt/rcserq" ;CSE register/quantity abstractions + "rtlopt/rcsesr" ;CSE stack references + ) + (parent (compiler)) + (export (compiler top-level) common-subexpression-elimination)) + +(define-package (compiler rtl-optimizer) + (files "rtlopt/rdebug") + (parent (compiler))) + +(define-package (compiler rtl-optimizer invertible-expression-elimination) + (files "rtlopt/rinvex") + (parent (compiler rtl-optimizer)) + (export (compiler top-level) invertible-expression-elimination)) + +(define-package (compiler rtl-optimizer common-suffix-merging) + (files "rtlopt/rtlcsm") + (parent (compiler rtl-optimizer)) + (export (compiler top-level) merge-common-suffixes!)) + +(define-package (compiler rtl-optimizer rtl-dataflow-analysis) + (files "rtlopt/rdflow") + (parent (compiler rtl-optimizer)) + (export (compiler top-level) rtl-dataflow-analysis)) + +(define-package (compiler rtl-optimizer rtl-rewriting) + (files "rtlopt/rerite") + (parent (compiler rtl-optimizer)) + (export (compiler top-level) + rtl-rewriting:post-cse + rtl-rewriting:pre-cse) + (export (compiler lap-syntaxer) + add-pre-cse-rewriting-rule! + add-rewriting-rule!)) + +(define-package (compiler rtl-optimizer lifetime-analysis) + (files "rtlopt/rlife") + (parent (compiler rtl-optimizer)) + (export (compiler top-level) lifetime-analysis) + (export (compiler rtl-optimizer code-compression) mark-set-registers!)) + +(define-package (compiler rtl-optimizer code-compression) + (files "rtlopt/rcompr") + (parent (compiler rtl-optimizer)) + (export (compiler top-level) code-compression)) + +(define-package (compiler rtl-optimizer register-allocation) + (files "rtlopt/ralloc") + (parent (compiler rtl-optimizer)) + (export (compiler top-level) register-allocation)) + +(define-package (compiler lap-syntaxer) + (files "back/lapgn1" ;LAP generator + "back/lapgn2" ; " " + "back/lapgn3" ; " " + "back/regmap" ;Hardware register allocator + "machines/spectrum/lapgen" ;code generation rules + "machines/spectrum/rules1" ; " " " + "machines/spectrum/rules2" ; " " " + "machines/spectrum/rules3" ; " " " + "machines/spectrum/rules4" ; " " " + "machines/spectrum/rulfix" ; " " " + "machines/spectrum/rulflo" ; " " " + "machines/spectrum/rulrew" ;code rewriting rules + "back/syntax" ;Generic syntax phase + "back/syerly" ;Early binding version + "machines/spectrum/coerce" ;Coercions: integer -> bit string + "back/asmmac" ;Macros for hairy syntax + "machines/spectrum/insmac" ;Macros for hairy syntax + "machines/spectrum/inerly" ;Early binding version + "machines/spectrum/instr1" ;Spectrum instruction utilities + "machines/spectrum/instr2" ;Spectrum instructions + "machines/spectrum/instr3" ; " " + ) + (parent (compiler)) + (export (compiler) + available-machine-registers + pseudo-register-offset + interpreter-memtop-pointer + fits-in-5-bits-signed? + lap-generator/match-rtl-instruction + lap:make-entry-point + lap:make-label-statement + lap:make-unconditional-branch + lap:syntax-instruction) + (export (compiler top-level) + *block-associations* + *interned-assignments* + *interned-constants* + *interned-global-links* + *interned-uuo-links* + *interned-static-variables* + *interned-variables* + *next-constant* + generate-lap) + (import (scode-optimizer expansion) + scode->scode-expander)) + +(define-package (compiler lap-syntaxer map-merger) + (files "back/mermap") + (parent (compiler lap-syntaxer)) + (export (compiler lap-syntaxer) + merge-register-maps)) + +(define-package (compiler lap-syntaxer linearizer) + (files "back/linear") + (parent (compiler lap-syntaxer)) + (export (compiler lap-syntaxer) + add-end-of-block-code! + add-extra-code! + bblock-linearize-lap + extra-code-block/xtra + declare-extra-code-block! + find-extra-code-block + linearize-lap + set-current-branches! + set-extra-code-block/xtra!) + ;; New stuff + (export (compiler) + *strongly-heed-branch-preferences?*) + ;; End of new stuff + (export (compiler top-level) + *end-of-block-code* + linearize-lap)) + +(define-package (compiler lap-optimizer) + (files "machines/spectrum/lapopt") + (parent (compiler)) + (import (compiler lap-syntaxer) + entry->address + invert-condition) + (export (compiler lap-syntaxer) + lap:mark-preferred-branch!) + (export (compiler top-level) + optimize-linear-lap)) + +(define-package (compiler assembler) + (files "machines/spectrum/assmd" ;Machine dependent + "back/symtab" ;Symbol tables + "back/bitutl" ;Assembly blocks + "back/bittop" ;Assembler top level + ) + (parent (compiler)) + (export (compiler) + instruction-append) + (export (compiler top-level) + assemble)) + +(define-package (compiler disassembler) + (files "machines/spectrum/dassm1" + "machines/spectrum/dassm2" + "machines/spectrum/dassm3") + (parent (compiler)) + (export () + compiler:write-lap-file + compiler:disassemble + compiler:disassemble-memory) + (import (compiler lap-syntaxer) + code:-alist + hook:-alist) + (import (runtime compiler-info) + compiled-code-block/dbg-info + dbg-info-vector/blocks-vector + dbg-info-vector? + dbg-info/labels + dbg-label/external? + dbg-label/name + dbg-labels/find-offset)) + +;;; New stuff + +(define-package (compiler midend) + (files "midend/graph" + "midend/synutl" + "midend/midend" + "midend/utils" + "midend/fakeprim" + "midend/dbgstr" + "midend/inlate" + "midend/envconv" + "midend/alpha" + "midend/expand" + "midend/assconv" + "midend/cleanup" + "midend/earlyrew" + "midend/lamlift" + "midend/closconv" + ;; "midend/staticfy" ; broken, for now + "midend/applicat" + "midend/simplify" + "midend/cpsconv" + "midend/laterew" + "midend/compat" ; compatibility with current compiler + "midend/stackopt" + "midend/indexify" + "midend/rtlgen" + "midend/copier" + "midend/dataflow" + "midend/split" + "midend/widen") + (parent (compiler)) + (export (compiler top-level) + kmp/pp kmp/ppp + *envconv/compile-by-procedures?* + *envconv/procedure-result?* + kmp->rtl + optimize-kmp + rtlgen/top-level + rtlgen/argument-registers + rtlgen/available-registers + scode->kmp + within-midend) + (export (compiler) + internal-error + internal-warning)) + +(define-package (compiler rtl-parser) + (files "rtlbase/rtlpars") + (parent (compiler)) + (export (compiler) + rtl->rtl-graph)) + +;; End of New stuff diff --git a/v8/src/compiler/machines/spectrum/compiler.sf b/v8/src/compiler/machines/spectrum/compiler.sf new file mode 100644 index 000000000..fb1c43851 --- /dev/null +++ b/v8/src/compiler/machines/spectrum/compiler.sf @@ -0,0 +1,111 @@ +#| -*-Scheme-*- + +$Id: compiler.sf,v 1.1 1994/11/19 02:09:58 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Script to incrementally syntax the compiler + +;; Guarantee that the package modeller is loaded. +(if (not (name->package '(CROSS-REFERENCE))) + (with-working-directory-pathname "../cref" (lambda () (load "make")))) + +;; Guarantee that the compiler's package structure exists. +(if (not (name->package '(COMPILER))) + (begin + ;; If there is no existing package constructor, generate one. + (if (not (file-exists? "compiler.bcon")) + (begin + ((access cref/generate-trivial-constructor + (->environment '(CROSS-REFERENCE))) + "compiler") + (sf "compiler.con" "compiler.bcon"))) + (load "compiler.bcon"))) + +;; Guarantee that the necessary syntactic transforms and optimizers +;; are loaded. +(if (lexical-unreferenceable? (->environment '(COMPILER)) 'SYNTAX-FILES!) + (let ((sf-and-load + (lambda (files package) + (sf-conditionally files) + (for-each (lambda (file) + (load (string-append file ".bin") package)) + files)))) + (load-option 'HASH-TABLE) + (write-string "\n\n---- Loading compile-time files ----") + (sf-and-load '("midend/synutl") '()) ;; This should go elsewhere! + (sf-and-load '("base/switch") '(COMPILER)) + (sf-and-load '("base/macros") '(COMPILER MACROS)) + ((access initialize-package! (->environment '(COMPILER MACROS)))) + (sf-and-load '("machines/spectrum/decls") '(COMPILER DECLARATIONS)) + (let ((environment (->environment '(COMPILER DECLARATIONS)))) + (set! (access source-file-expression environment) "*.scm") + ((access initialize-package! environment))) + (sf-and-load '("base/pmlook") '(COMPILER PATTERN-MATCHER/LOOKUP)) + (sf-and-load '("base/pmpars") '(COMPILER PATTERN-MATCHER/PARSER)) + (fluid-let ((sf/default-syntax-table + (access compiler-syntax-table + (->environment '(COMPILER MACROS))))) + (sf-and-load '("machines/spectrum/machin") '(COMPILER))) + (fluid-let ((sf/default-declarations + '((integrate-external "insseq") + (integrate-external "machin") + (usual-definition (set expt))))) + (sf-and-load '("machines/spectrum/assmd") '(COMPILER ASSEMBLER))) + (sf-and-load '("back/syntax") '(COMPILER LAP-SYNTAXER)) + (sf-and-load '("machines/spectrum/coerce" "back/asmmac" + "machines/spectrum/insmac") + '(COMPILER LAP-SYNTAXER)) + (sf-and-load '("base/scode") '(COMPILER)) + (sf-and-load '("base/pmerly") '(COMPILER PATTERN-MATCHER/EARLY)) + (sf-and-load '("machines/spectrum/inerly" "back/syerly") + '(COMPILER LAP-SYNTAXER)))) + +;; Load the assembler instruction database. +(in-package (->environment '(COMPILER LAP-SYNTAXER)) + (if (and compiler:enable-expansion-declarations? + (null? early-instructions)) + (fluid-let ((load-noisily? false) + (load/suppress-loading-message? false)) + (write-string "\n\n---- Pre-loading instruction sets ----") + (for-each (lambda (name) + (load (string-append "machines/spectrum/" name ".scm") + '(COMPILER LAP-SYNTAXER) + early-syntax-table)) + '("instr1" "instr2" "instr3"))))) + +;; Resyntax any files that need it. +((access syntax-files! (->environment '(COMPILER)))) + +;; Rebuild the package constructors and cref. +(cref/generate-constructors "compiler") +(sf "compiler.con" "compiler.bcon") +(sf "compiler.ldr" "compiler.bldr") \ No newline at end of file diff --git a/v8/src/compiler/machines/spectrum/dassm1.scm b/v8/src/compiler/machines/spectrum/dassm1.scm new file mode 100644 index 000000000..d72ad26a3 --- /dev/null +++ b/v8/src/compiler/machines/spectrum/dassm1.scm @@ -0,0 +1,518 @@ +#| -*-Scheme-*- + +$Id: dassm1.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Disassembler: User Level +;;; package: (compiler disassembler) + +(declare (usual-integrations)) + +;;; Flags that control disassembler behavior + +(define disassembler/symbolize-output? true) +(define disassembler/compiled-code-heuristics? true) +(define disassembler/write-offsets? true) +(define disassembler/write-addresses? false) + +;;;; Top level entries + +(define (compiler:write-lap-file filename #!optional symbol-table?) + (let ((pathname (->pathname filename)) + (symbol-table? + (if (default-object? symbol-table?) true symbol-table?))) + (with-output-to-file (pathname-new-type pathname "lap") + (lambda () + (let ((com-file (pathname-new-type pathname "com"))) + (let ((object (fasload com-file))) + (if (compiled-code-address? object) + (let ((block (compiled-code-address->block object))) + (disassembler/write-compiled-code-block + block + (compiled-code-block/dbg-info block symbol-table?))) + (begin + (if (not + (and (scode/comment? object) + (dbg-info-vector? (scode/comment-text object)))) + (error "Not a compiled file" com-file)) + (let ((blocks + (vector->list + (dbg-info-vector/blocks-vector + (scode/comment-text object))))) + (if (not (null? blocks)) + (do ((blocks blocks (cdr blocks))) + ((null? blocks) unspecific) + (disassembler/write-compiled-code-block + (car blocks) + (compiled-code-block/dbg-info (car blocks) + symbol-table?)) + (if (not (null? (cdr blocks))) + (begin + (write-char #\page) + (newline)))))))))))))) + +(define disassembler/base-address) + +(define (compiler:disassemble entry) + (let ((block (compiled-entry/block entry))) + (let ((info (compiled-code-block/dbg-info block true))) + (fluid-let ((disassembler/write-offsets? true) + (disassembler/write-addresses? true) + (disassembler/base-address (object-datum block))) + (newline) + (newline) + (disassembler/write-compiled-code-block block info))))) + +(define (compiler:disassemble-memory start words) + (fluid-let ((disassembler/write-offsets? false) + (disassembler/write-addresses? true) + (disassembler/base-address start)) + (newline) + (newline) + (disassembler/write-instruction-stream + #F + (disassembler/instructions/address start (+ start (* 4 words)))))) + +(define (disassembler/write-compiled-code-block block info) + (let ((symbol-table (and info (dbg-info/labels info)))) + (write-string "Disassembly of ") + (write block) + (let loop ((info (compiled-code-block/debugging-info block))) + (cond ((string? info) + (write-string " (") + (write-string info) + (write-string ")")) + ((not (pair? info))) + ((vector? (car info)) + (loop (cdr info))) + (else + (write-string " (Block ") + (write (cdr info)) + (write-string " in ") + (write-string (car info)) + (write-string ")")))) + (write-string ":\n") + (write-string "Code:\n\n") + (disassembler/write-instruction-stream + symbol-table + (disassembler/instructions/compiled-code-block block symbol-table)) + (write-string "\nConstants:\n\n") + (disassembler/write-constants-block block symbol-table) + (newline))) + +(define (disassembler/instructions/compiled-code-block block symbol-table) + (disassembler/instructions block + (compiled-code-block/code-start block) + (compiled-code-block/code-end block) + symbol-table)) + +(define (disassembler/instructions/address start-address end-address) + (disassembler/instructions false start-address end-address false)) + +(define (disassembler/write-instruction-stream symbol-table instruction-stream) + (fluid-let ((*unparser-radix* 16)) + (disassembler/for-each-instruction instruction-stream + (lambda (offset instruction) + (disassembler/write-instruction symbol-table + offset + (lambda () (display-instruction offset instruction))))))) + +(define (disassembler/for-each-instruction instruction-stream procedure) + (let loop ((instruction-stream instruction-stream)) + (if (not (disassembler/instructions/null? instruction-stream)) + (disassembler/instructions/read instruction-stream + (lambda (offset instruction instruction-stream) + (procedure offset instruction) + (loop (instruction-stream))))))) + +(define (disassembler/write-constants-block block symbol-table) + (fluid-let ((*unparser-radix* 16)) + (let ((end (system-vector-length block))) + (let loop ((index (compiled-code-block/constants-start block))) + (cond ((not (< index end)) 'DONE) + ((object-type? + (let-syntax ((ucode-type + (macro (name) (microcode-type name)))) + (ucode-type linkage-section)) + (system-vector-ref block index)) + (loop (disassembler/write-linkage-section block + symbol-table + index))) + ((object-type? + (let-syntax ((ucode-type + (macro (name) (microcode-type name)))) + (ucode-type manifest-closure)) + (system-vector-ref block index)) + (loop (disassembler/write-manifest-closure-pattern block + symbol-table + index))) + (else + (disassembler/write-instruction + symbol-table + (compiled-code-block/index->offset index) + (lambda () + (write-constant block + symbol-table + (system-vector-ref block index)))) + (loop (1+ index)))))))) + +(define (write-constant block symbol-table constant) + (write-string (cdr (write-to-string constant 60))) + (cond ((lambda? constant) + (let ((expression (lambda-body constant))) + (if (and (compiled-code-address? expression) + (eq? (compiled-code-address->block expression) block)) + (begin + (write-string " (") + (let ((offset (compiled-code-address->offset expression))) + (let ((label + (disassembler/lookup-symbol symbol-table offset))) + (if label + (write-string label) + (write offset)))) + (write-string ")"))))) + ((compiled-code-address? constant) + (write-string " (offset ") + (write (compiled-code-address->offset constant)) + (write-string " in ") + (write (compiled-code-address->block constant)) + (write-string ")")) + (else false))) + +(define (disassembler/write-linkage-section block symbol-table index) + (let* ((field (object-datum (system-vector-ref block index))) + (descriptor (integer-divide field #x10000))) + (let ((kind (integer-divide-quotient descriptor)) + (length (integer-divide-remainder descriptor))) + + (define (write-caches offset size writer) + (let loop ((index (1+ (+ offset index))) + (how-many (quotient (- length offset) size))) + (if (zero? how-many) + 'DONE + (begin + (disassembler/write-instruction + symbol-table + (compiled-code-block/index->offset index) + (lambda () + (writer block index))) + (loop (+ size index) (-1+ how-many)))))) + + (disassembler/write-instruction + symbol-table + (compiled-code-block/index->offset index) + (lambda () + (write-string "#[LINKAGE-SECTION ") + (write field) + (write-string "]"))) + (case kind + ((0 3) + (write-caches + compiled-code-block/procedure-cache-offset + compiled-code-block/objects-per-procedure-cache + disassembler/write-procedure-cache)) + ((1) + (write-caches + 0 + compiled-code-block/objects-per-variable-cache + (lambda (block index) + (disassembler/write-variable-cache "Reference" block index)))) + ((2) + (write-caches + 0 + compiled-code-block/objects-per-variable-cache + (lambda (block index) + (disassembler/write-variable-cache "Assignment" block index)))) + ((4) + (disassembler/write-instruction + symbol-table + (compiled-code-block/index->offset (1+ index)) + (lambda () + (write-string "Closure linkage cache")))) + (else + (error "disassembler/write-linkage-section: Unknown section kind" + kind))) + (1+ (+ index length))))) + + +(define-integrable (variable-cache-name cache) + ((ucode-primitive primitive-object-ref 2) cache 1)) + +(define (disassembler/write-variable-cache kind block index) + (write-string kind) + (write-string " cache to ") + (write (variable-cache-name (disassembler/read-variable-cache block index)))) + +(define (disassembler/write-procedure-cache block index) + (let ((result (disassembler/read-procedure-cache block index))) + (write (vector-ref result 2)) + (write-string " argument procedure cache to ") + (case (vector-ref result 0) + ((COMPILED INTERPRETED) + (write (vector-ref result 1))) + ((VARIABLE) + (write-string "variable ") + (write (vector-ref result 1))) + (else + (error "disassembler/write-procedure-cache: Unknown cache kind" + (vector-ref result 0)))))) + +(define closure-entry-size 4) + +(define (disassembler/write-manifest-closure-pattern block symbol-table index) + (let* ((descriptor (integer-divide (system-vector-ref block (+ index 1)) + #x10000)) + (offset (integer-divide-remainder descriptor)) + (multiclosure? (= offset 0)) + (closures (if multiclosure? + (integer-divide-quotient descriptor) + 1)) + (pattern-len (if multiclosure? + (+ 1 (* closures closure-entry-size)) + closure-entry-size)) + (closure-len (object-datum (system-vector-ref block index))) + (free-vars (- closure-len pattern-len))) + (disassembler/write-instruction + symbol-table + (compiled-code-block/index->offset index) + (lambda () + (write-string "#[MANIFEST-CLOSURE-PATTERN ") + (write closure-len) + (if multiclosure? + (begin (write-string " ") + (write closures) + (write-string "-closure"))) + (write-string " with ") + (write free-vars) + (write-string " free variable") + (if (not (= free-vars 1)) + (write-string "s")) + (write-string "]"))) + (+ index pattern-len 1))) + +(define (disassembler/write-instruction symbol-table offset write-instruction) + (if symbol-table + (let ((label (dbg-labels/find-offset symbol-table offset))) + (if label + (begin + (write-char #\Tab) + (write-string (dbg-label/name label)) + (write-char #\:) + (newline))))) + + (if disassembler/write-addresses? + (begin + (write-string + (number->string (+ offset disassembler/base-address) 16)) + (write-char #\Tab))) + + (if disassembler/write-offsets? + (begin + (write-string (number->string offset 16)) + (write-char #\Tab))) + + (if symbol-table + (write-string " ")) + (write-instruction) + (newline)) + +(let-syntax ((define-codes + (macro (start . names) + (define (loop names index assocs) + (if (null? names) + `((DEFINE CODE:COMPILER-XXX-ALIST ',assocs)) + (loop (cdr names) (1+ index) + (cons (cons index (car names)) assocs)))) + `(BEGIN ,@(loop names start '()))))) + ;; Copied from lapgen.scm + (define-codes #x012 + primitive-apply primitive-lexpr-apply + apply error lexpr-apply link + interrupt-closure interrupt-dlink interrupt-procedure + interrupt-continuation interrupt-ic-procedure + assignment-trap cache-reference-apply + reference-trap safe-reference-trap unassigned?-trap + -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero? + access lookup safe-lookup unassigned? unbound? + set! define lookup-apply primitive-error + quotient remainder modulo + reflect-to-interface interrupt-continuation-2 + compiled-code-bkpt compiled-closure-bkpt + new-interrupt-procedure)) + +(let-syntax ((define-hooks + (macro (start . names) + (define (loop names index assocs) + (if (null? names) + `((DEFINE HOOK:COMPILER-XXX-ALIST ',assocs)) + (loop (cdr names) (+ 8 index) + (cons (cons index (car names)) assocs)))) + `(BEGIN ,@(loop names start '()))))) + ;; Copied from lapgen.scm + (define-hooks 100 + store-closure-code + store-closure-entry ; newer version of store-closure-code. + multiply-fixnum + fixnum-quotient + fixnum-remainder + fixnum-lsh + &+ + &- + &* + &/ + &= + &< + &> + 1+ + -1+ + zero? + positive? + negative? + shortcircuit-apply + shortcircuit-apply-1 + shortcircuit-apply-2 + shortcircuit-apply-3 + shortcircuit-apply-4 + shortcircuit-apply-5 + shortcircuit-apply-6 + shortcircuit-apply-7 + shortcircuit-apply-8 + stack-and-interrupt-check + invoke-primitive + vector-cons + string-allocate + floating-vector-cons + flonum-sin + flonum-cos + flonum-tan + flonum-asin + flonum-acos + flonum-atan + flonum-exp + flonum-log + flonum-truncate + flonum-ceiling + flonum-floor + flonum-atan2 + compiled-code-bkpt + compiled-closure-bkpt + copy-closure-pattern + copy-multiclosure-pattern + closure-entry-bkpt-hook + interrupt-procedure/new + interrupt-continuation/new + quotient + remainder + interpreter-call)) + +(define display-instruction + (let ((prev-instruction '()) + (prev-prev-instruction '())) + (lambda (offset instruction) + + (define (unannotated) (display instruction)) + + (define (annotated) + (let ((s (with-output-to-string (lambda() (display instruction))))) + (write-string s) + (write-string (make-string (max 1 (- 40 (string-length s))) #\Space)) + (write-string ";"))) + + (define (annotate-with-name name) + (annotated) + (write-string " ") + (display name)) + + (define (annotate-with-target address) + (annotated) + (write-string " ") + (write-string (number->string address 16))) + + (define (match? pat obj) + (or (eq? pat '?) + (and (eq? pat '?n) (number? obj)) + (and (pair? pat) (pair? obj) + (match? (car pat) (car obj)) + (match? (cdr pat) (cdr obj))) + (equal? pat obj))) + + (define (code?) + (match? '(ble ? (offset ? 4 3)) instruction)) + (define (code-name) + (let ((id.name (assoc (second (third instruction)) + hook:compiler-xxx-alist))) + (and id.name + (cdr id.name)))) + + (define (hook?) + (and (or (equal? '(ble () (offset 0 4 3)) prev-instruction) + (equal? '(ble () (offset 12 4 3)) prev-instruction)) + (match? '(ldi () ? 28) instruction))) + (define (hook-name) + (let ((id.name (assoc (third instruction) code:compiler-xxx-alist))) + (and id.name + (cdr id.name)))) + + (define (external-label?) + (match? '(external-label . ?) instruction)) + + (define (offset->address field adjustment) + (+ (+ offset disassembler/base-address) field adjustment)) + (define (offset-targets) + (let ((res + (map (lambda (@pco.n) + (offset->address (second @pco.n) 8)) + (list-transform-positive instruction + (lambda (part) (and (pair? part) + (eq? (car part) '@pco) + (not (equal? (cadr part) 0)))))))) + (if (null? res) #f res))) + + (define (special-offset-target) + (cond ((and (match? '(bl () ? (@pco 0)) prev-instruction) + (match? '(? ? (offset ?n 0 ?) ?) instruction) + (eqv? (third prev-instruction) (fourth (third instruction)))) + (offset->address (second (third instruction)) (+ 8 -4 3))) + ((match? '(uword () ?n) instruction) + (offset->address (third instruction) 3)) + (else #f))) + + (cond ((and (code?) (code-name)) => annotate-with-name) + ((and (hook?) (hook-name)) => annotate-with-name) + ((external-label?) (unannotated)) + ((special-offset-target) => annotate-with-target) + ((offset-targets) => (lambda (x) + (annotate-with-target (car x)))) + (else (unannotated))) + + (set! prev-prev-instruction prev-instruction) + (set! prev-instruction instruction)))) \ No newline at end of file diff --git a/v8/src/compiler/machines/spectrum/dassm2.scm b/v8/src/compiler/machines/spectrum/dassm2.scm new file mode 100644 index 000000000..ab028e248 --- /dev/null +++ b/v8/src/compiler/machines/spectrum/dassm2.scm @@ -0,0 +1,292 @@ +#| -*-Scheme-*- + +$Id: dassm2.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ + +Copyright (c) 1988-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Spectrum Disassembler: Top Level +;;; package: (compiler disassembler) + +(declare (usual-integrations)) + +(define (disassembler/read-variable-cache block index) + (let-syntax ((ucode-type + (macro (name) (microcode-type name))) + (ucode-primitive + (macro (name arity) + (make-primitive-procedure name arity)))) + ((ucode-primitive primitive-object-set-type 2) + (ucode-type quad) + (system-vector-ref block index)))) + +(define (disassembler/read-procedure-cache block index) + (fluid-let ((*block block)) + (let* ((offset (compiled-code-block/index->offset index)) + (opcode (fix:lsh (read-unsigned-integer offset 8) -2))) + (case opcode + ((#x08) ; LDIL + ;; This should learn how to decode trampolines. + (vector 'COMPILED + (read-procedure offset) + (read-unsigned-integer (+ offset 10) 16))) + (else + (error "disassembler/read-procedure-cache: Unknown opcode" + opcode block index)))))) + +(define (disassembler/instructions block start-offset end-offset symbol-table) + (let loop ((offset start-offset) (state (disassembler/initial-state))) + (if (and end-offset (< offset end-offset)) + (disassemble-one-instruction + block offset symbol-table state + (lambda (offset* instruction state) + (make-instruction offset + instruction + (lambda () (loop offset* state))))) + '()))) + +(define (disassembler/instructions/null? obj) + (null? obj)) + +(define (disassembler/instructions/read instruction-stream receiver) + (receiver (instruction-offset instruction-stream) + (instruction-instruction instruction-stream) + (instruction-next instruction-stream))) + +(define-structure (instruction (type vector)) + (offset false read-only true) + (instruction false read-only true) + (next false read-only true)) + +(define *block) +(define *current-offset) +(define *symbol-table) +(define *ir) +(define *valid?) + +(define (disassemble-one-instruction block offset symbol-table state receiver) + (fluid-let ((*block block) + (*current-offset offset) + (*symbol-table symbol-table) + (*ir) + (*valid? true)) + (set! *ir (get-longword)) + (let ((start-offset *current-offset)) + (if (external-label-marker? symbol-table offset state) + (receiver start-offset + (make-external-label *ir start-offset) + 'INSTRUCTION) + (let ((instruction (disassemble-word *ir))) + (if (not *valid?) + (let ((inst (make-word *ir))) + (receiver start-offset + inst + (disassembler/next-state inst state))) + (let ((next-state (disassembler/next-state instruction state))) + (receiver + *current-offset + (if (and (pair? state) + (eq? (car state) 'PC-REL-OFFSET)) + (pc-relative-inst offset instruction (cdr state)) + instruction) + next-state)))))))) + +(define-integrable *privilege-level* 3) + +(define (pc-relative-inst start-address instruction base-reg) + (let ((opcode (car instruction))) + (if (not (memq opcode '(LDO LDW))) + instruction + (let ((offset-exp (caddr instruction)) + (target (cadddr instruction))) + (let ((offset (cadr offset-exp)) + (space-reg (caddr offset-exp)) + (base-reg* (cadddr offset-exp))) + (if (not (= base-reg* base-reg)) + instruction + (let* ((real-address + (+ start-address + (- offset *privilege-level*) + #| + (if (not left-side) + 0 + (- (let ((val (* left-side #x800))) + (if (>= val #x80000000) + (- val #x100000000) + val)) + 4)) + |# + )) + (label + (disassembler/lookup-symbol *symbol-table real-address))) + (if (not label) + instruction + `(,opcode () (OFFSET `(- ,label *PC*) + #| + ,(if left-side + `(RIGHT (- ,label (- *PC* 4))) + `(- ,label *PC*)) + |# + ,space-reg + ,base-reg) + ,target))))))))) + +(define (disassembler/initial-state) + 'INSTRUCTION-NEXT) + +(define (disassembler/next-state instruction state) + (cond ((not disassembler/compiled-code-heuristics?) + 'INSTRUCTION) + ((and (eq? state 'INSTRUCTION) + (eq? (list-ref instruction 0) 'BL) + (equal? (list-ref instruction 3) '(@PCO 0))) + (cons 'PC-REL-OFFSET (list-ref instruction 2))) + ((memq (car instruction) '(B BV BLE)) + (if (memq 'N (cadr instruction)) + 'EXTERNAL-LABEL + 'DELAY-SLOT)) + ((eq? state 'DELAY-SLOT) + 'EXTERNAL-LABEL) + (else + 'INSTRUCTION))) + +(define (disassembler/lookup-symbol symbol-table offset) + (and symbol-table + (let ((label (dbg-labels/find-offset symbol-table offset))) + (and label + (dbg-label/name label))))) + +(define (external-label-marker? symbol-table offset state) + (if symbol-table + (let ((label (dbg-labels/find-offset symbol-table (+ offset 4)))) + (and label + (dbg-label/external? label))) + (and *block + (eq? state 'EXTERNAL-LABEL) + (let loop ((offset (+ offset 4))) + (let* ((contents (read-bits (- offset 2) 16)) + (odd? (bit-string-clear! contents 0)) + (delta (* 2 (bit-string->unsigned-integer contents)))) + (if odd? + (let ((offset1 (- offset delta))) + (and (positive? offset1) + (not (= offset1 offset)) + (loop offset1))) + (= offset delta)) ))))) + +(define (make-word bit-string) + `(UWORD () ,(bit-string->unsigned-integer bit-string))) + +(define (make-external-label bit-string offset) + `(EXTERNAL-LABEL () + ,(extract bit-string 16 32) + ,(offset->pc-relative (* 4 (extract bit-string 1 16)) + offset))) + +(define (read-procedure offset) + (define (bit-string-andc-bang x y) + (bit-string-andc! x y) + x) + + (define-integrable (low-21-bits offset) + #| + (bit-string->unsigned-integer + (bit-string-andc-bang (read-bits offset 32) + #*11111111111000000000000000000000)) + |# + (fix:and (read-unsigned-integer (1+ offset) 24) #x1FFFFF)) + + (define (assemble-21 val) + (fix:or (fix:or (fix:lsh (fix:and val 1) 20) + (fix:lsh (fix:and val #xffe) 8)) + (fix:or (fix:or (fix:lsh (fix:and val #xc000) -7) + (fix:lsh (fix:and val #x1f0000) -14)) + (fix:lsh (fix:and val #x3000) -12)))) + + + (define (assemble-17 val) + (fix:or (fix:or (fix:lsh (fix:and val 1) 16) + (fix:lsh (fix:and val #x1f0000) -5)) + (fix:or (fix:lsh (fix:and val #x4) 8) + (fix:lsh (fix:and val #x1ff8) -3)))) + + (with-absolutely-no-interrupts + (lambda () + (let* ((address + (+ (* (assemble-21 (low-21-bits offset)) #x800) + (fix:lsh (assemble-17 (low-21-bits (+ offset 4))) 2))) + (bitstr (bit-string-andc-bang + (unsigned-integer->bit-string 32 address) + #*11111100000000000000000000000000))) + (let-syntax ((ucode-type + (macro (name) (microcode-type name))) + (ucode-primitive + (macro (name arity) + (make-primitive-procedure name arity)))) + ((ucode-primitive primitive-object-set-type 2) + (ucode-type compiled-entry) + ((ucode-primitive make-non-pointer-object 1) + (bit-string->unsigned-integer bitstr)))))))) + +(define (read-unsigned-integer offset size) + (bit-string->unsigned-integer (read-bits offset size))) + +(define (read-bits offset size-in-bits) + (let ((word (bit-string-allocate size-in-bits)) + (bit-offset (* offset addressing-granularity))) + (with-absolutely-no-interrupts + (lambda () + (if *block + (read-bits! *block bit-offset word) + (read-bits! offset 0 word)))) + word)) + +(define (invalid-instruction) + (set! *valid? false) + false) + +(define (offset->pc-relative pco reference-offset) + (if (not disassembler/symbolize-output?) + `(@PCO ,pco) + ;; Only add 4 because it has already been bumped to the + ;; next instruction. + (let* ((absolute (+ pco (+ 4 reference-offset))) + (label (disassembler/lookup-symbol *symbol-table absolute))) + (if label + `(@PCR ,label) + `(@PCO ,pco))))) + +(define compiled-code-block/procedure-cache-offset 0) +(define compiled-code-block/objects-per-procedure-cache 3) +(define compiled-code-block/objects-per-variable-cache 1) + +;; global variable used by runtime/udata.scm -- Moby yuck! + +(set! compiled-code-block/bytes-per-object 4) \ No newline at end of file diff --git a/v8/src/compiler/machines/spectrum/dassm3.scm b/v8/src/compiler/machines/spectrum/dassm3.scm new file mode 100644 index 000000000..789dc0832 --- /dev/null +++ b/v8/src/compiler/machines/spectrum/dassm3.scm @@ -0,0 +1,721 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/spectrum/dassm3.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ + +Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;; Spectrum Disassembler: Internals +;;; package: (compiler disassembler) + +(declare (usual-integrations)) + +;;;; Utilities + +(define (get-longword) + (let ((word (read-bits *current-offset 32))) + (set! *current-offset (+ *current-offset 4)) + word)) + +(declare (integrate-operator extract)) + +(define (extract bit-string start end) + (declare (integrate bit-string start end)) + (bit-string->unsigned-integer (bit-substring bit-string start end))) + +#| +(define disassembly '()) + +(define (verify-instruction instruction) + (let ((bits (car (syntax-instruction instruction)))) + (if (and (bit-string? bits) + (= (bit-string-length bits) 32)) + (begin (set! disassembly (disassemble-word bits)) + (newline) + (newline) + (if (equal? instruction disassembly) + (write "EQUAL") + (write "************************* NOT EQUAL")) + (newline) + (newline) + (write instruction) + (newline) + (newline) + (write "Disassembly: ") + (write disassembly))))) + +(define v verify-instruction) +|# + +(define-integrable Mask-2-9 #b0011111111000000) +(define-integrable Mask-2-16 #b0011111111111111) +(define-integrable Mask-3-14 #b0001111111111100) +(define-integrable Mask-3-10 #b0001111111100000) +(define-integrable Mask-3-5 #b0001110000000000) +(define-integrable Mask-4-10 #b0000111111100000) +(define-integrable Mask-4-5 #b0000110000000000) +(define-integrable Mask-6-9 #b0000001111000000) +(define-integrable Mask-6-10 #b0000001111100000) +(define-integrable Mask-11-15 #b0000000000011111) +(define-integrable mask-copr #b0000000111000000) + +;;;; The disassembler proper + +(define (disassemble-word word) + (let ((hi-halfword (extract word 16 32)) + (lo-halfword (extract word 0 16))) + (let ((opcode (fix:quotient hi-halfword #x400))) + ((case opcode + ((#x00) sysctl-1) + ((#x01) sysctl-2) + ((#x02) arith&log) + ((#x03) indexed-mem) + ((#x04) #| SFUop |# unknown-major-opcode) + ((#x05) + (lambda (opcode hi lo) + opcode hi lo ;ignore + `(DIAG () ,(extract word 0 26)))) + ((#x08 #x0a) ldil&addil) + ((#x09 #x0b) #| COPR-w and COPR-dw |# float-mem) + ((#x0c) #| COPRop |# float-op) + ((#x0d #x10 #x11 #x12 #x13) scalar-load) + ((#x18 #x19 #x1a #x1b) scalar-store) + ((#x20 #x21 #x22 #x23 #x28 #x29 #x2a #x2b #x30 #x31 #x32 #x33) + cond-branch) + ((#x24 #x25 #x2c #x2d) addi&subi) + ((#x34 #x35) extr&dep) + ((#x38 #x39) be&ble) + ((#x3a) branch) + (else unknown-major-opcode)) + opcode hi-halfword lo-halfword)))) + +(define (unknown-major-opcode opcode hi lo) + opcode hi lo ;ignore + (invalid-instruction)) + +(define (sysctl-1 opcode hi-halfword lo-halfword) + ;; BREAK SYNC MFSP MFCTL MTSP MTCTL LDSID + ;; Missing other system control: + ;; MTSM, RSM, SSM, RFI. + opcode ;ignore + (let ((opcode-extn (fix:quotient (fix:and lo-halfword Mask-3-10) #x20))) + (case opcode-extn + ((#x00) + (let ((immed-13-hi (fix:and hi-halfword 1023)) + (immed-13-lo (fix:quotient lo-halfword #x2000)) + (immed-5 (fix:and lo-halfword #x1f))) + `(BREAK () ,immed-5 ,(+ (* immed-13-hi #x100) immed-13-lo)))) + ((#x20) + `(SYNC ())) + ((#x25) + (let ((target-reg (fix:and hi-halfword #x1f)) + (space-reg (fix:quotient lo-halfword #x2000))) + `(MFSP () ,space-reg ,target-reg))) + ((#x45) + (let ((ctl-reg (fix:quotient (fix:and Mask-6-10 hi-halfword) + #x20)) + (target-reg (fix:and lo-halfword #x1f))) + `(MFCTL () ,ctl-reg ,target-reg))) + ((#xc1) + (let ((source-reg hi-halfword) + (space-reg (fix:quotient lo-halfword #x2000))) + `(MTSP () ,source-reg ,space-reg))) + ((#xc2) + (let ((ctl-reg (fix:quotient (fix:and Mask-6-10 hi-halfword) + #x20)) + (source-reg (fix:and hi-halfword #x1f))) + `(MTCTL () ,source-reg ,ctl-reg))) + ((#x85) + (let ((base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword) + #x20)) + (space-spec (fix:quotient lo-halfword #x4000)) + (target-reg (fix:and lo-halfword #x1f))) + `(LDSID () (OFFSET ,space-spec ,base-reg) + ,target-reg))) + (else + (invalid-instruction))))) + +(define (sysctl-2 opcode hi-halfword lo-halfword) + ;; PROBER PROBERI PROBEW PROBEWI + ;; Missing other system control: + ;; LPA, LHA, PDTLB, PITLB, PDTLBE, PITLBE, IDTLBA, IITLBA, + ;; IDTLBP, IITLBP, PDC, FDC, FIC, FDCE, FICE. + opcode ;ignore + (let ((opcode-extn (fix:quotient (fix:and lo-halfword Mask-2-9) #x40))) + (let ((mnemonic (case opcode-extn + ((#x46) 'PROBER) + ((#xc6) 'PROBERI) + ((#x47) 'PROBEW) + ((#xc7) 'PROBEWI) + (else (invalid-instruction)))) + (base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword) + #x20)) + (priv-reg (fix:and hi-halfword #x1f)) + (space-spec (fix:quotient lo-halfword #x4000)) + (target-reg (fix:and lo-halfword #x1f))) + `(,mnemonic () (OFFSET ,space-spec ,base-reg) + ,priv-reg ,target-reg)))) + +(define (arith&log opcode hi-halfword lo-halfword) + opcode ;ignore + (let ((opcode-extn (fix:quotient (fix:and Mask-4-10 lo-halfword) #x20))) + (let ((source-reg-2 (fix:quotient (fix:and Mask-6-10 hi-halfword) + #x20)) + (source-reg-1 (fix:and hi-halfword #x1f)) + (target-reg (fix:and lo-halfword #x1f)) + (completer (x-arith-log-completer lo-halfword opcode-extn)) + (mnemonic + (case opcode-extn + ((#x00) 'ANDCM) + ((#x10) 'AND) + ((#x12) 'OR) + ((#x14) 'XOR) + ((#x1c) 'UXOR) + ((#x20) 'SUB) + ((#x22) 'DS) + ((#x26) 'SUBT) + ((#x28) 'SUBB) + ((#x30) 'ADD) + ((#x32) 'SH1ADD) + ((#x34) 'SH2ADD) + ((#x36) 'SH3ADD) + ((#x38) 'ADDC) + ((#x44) 'COMCLR) + ((#x4c) 'UADDCM) + ((#x4e) 'UADDCMT) + ((#x50) 'ADDL) + ((#x52) 'SH1ADDL) + ((#x54) 'SH2ADDL) + ((#x56) 'SH3ADDL) + ((#x5c) 'DCOR) + ((#x5e) 'IDCOR) + ((#x60) 'SUBO) + ((#x66) 'SUBTO) + ((#x68) 'SUBBO) + ((#x70) 'ADDO) + ((#x72) 'SH1ADDO) + ((#x74) 'SH2ADDO) + ((#x76) 'SH3ADDO) + ((#x78) 'ADDCO) + (else (invalid-instruction))))) + (cond ((or (eq? mnemonic 'DCOR) (eq? mnemonic 'IDCOR)) + `(,mnemonic ,completer ,source-reg-2 ,target-reg)) + ((and (eq? mnemonic 'OR) (zero? source-reg-2)) + (if (and (zero? source-reg-1) (zero? target-reg)) + `(NOP ,completer) + `(COPY ,completer ,source-reg-1 ,target-reg))) + (else + `(,mnemonic ,completer ,source-reg-1 ,source-reg-2 + ,target-reg)))))) + +(define (indexed-mem opcode hi-halfword lo-halfword) + ;; LDBX/S LDHX/S LDWX/S LDCWX/S STWS STHS STBS STBYS + opcode ;ignore + (let ((short-flag (fix:and lo-halfword #x1000))) + (let ((base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword) + #x20)) + (index-or-source (fix:and hi-halfword #x1f)) + (space-spec (fix:quotient lo-halfword #x4000)) + (opcode-extn (fix:quotient (fix:and lo-halfword Mask-6-9) #x40)) + (target-or-index (fix:and lo-halfword #x1f)) + (cc-print-completer (cc-completer lo-halfword)) + (um-print-completer (um-completer short-flag lo-halfword))) + (let ((mnemonic + (if (zero? short-flag) + (case opcode-extn + ((#x0) 'LDBX) + ((#x1) 'LDHX) + ((#x2) 'LDWX) + ((#x7) 'LDCWX) + (else (invalid-instruction))) + (case opcode-extn + ((#x0) 'LDBS) + ((#x1) 'LDHS) + ((#x2) 'LDWS) + ((#x7) 'LDCWS) + ((#x8) 'STBS) + ((#x9) 'STHS) + ((#xa) 'STWS) + ((#xc) 'STBYS) + (else (invalid-instruction)))))) + (if (< opcode-extn 8) + `(,mnemonic (,@um-print-completer ,@cc-print-completer) + (,(if (zero? short-flag) 'INDEX 'OFFSET) + ,(if (zero? short-flag) + index-or-source + (X-Signed-5-Bit index-or-source)) + ,space-spec ,base-reg) + ,target-or-index) + `(,mnemonic (,@um-print-completer ,@cc-print-completer) + ,index-or-source + (,(if (zero? short-flag) 'INDEX 'OFFSET) + ,(if (zero? short-flag) + target-or-index + (X-Signed-5-Bit target-or-index)) + ,space-spec ,base-reg))))))) + +(define (ldil&addil opcode hi-halfword lo-halfword) + ;; LDIL ADDIL + (let* ((reg (fix:quotient (fix:and Mask-6-10 hi-halfword) #x20)) + (hi-immed (fix:and hi-halfword #x1f)) + (immed (assemble-21 (+ (* hi-immed #x10000) lo-halfword)))) + `(,(if (= opcode #x08) 'LDIL 'ADDIL) () ,immed ,reg))) + +(define (float-mem opcode hi-halfword lo-halfword) + ;; FLDWX/S FLDDX/S FSTWX/S FSTDX/S + (let ((short-flag (fix:and lo-halfword #x1000)) + (index (fix:and hi-halfword #x1f))) + (let ((base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword) #x20)) + (index (if (zero? short-flag) + index + (X-Signed-5-Bit index))) + (space-spec (fix:quotient lo-halfword #x4000)) + (opcode-extn (fix:quotient (fix:and lo-halfword Mask-6-9) #x40)) + (source-or-target (fix:and lo-halfword #x1f)) + (cc-print-completer (cc-completer lo-halfword)) + (um-print-completer (um-completer short-flag lo-halfword))) + (let ((mnemonic + (if (zero? short-flag) + (if (= opcode #x09) + (if (= opcode-extn 0) 'FLDWX 'FSTWX) + (if (= opcode-extn 0) 'FLDDX 'FSTDX)) + (if (= opcode #x09) + (if (= opcode-extn 0) 'FLDWS 'FSTWS) + (if (= opcode-extn 0) 'FLDDS 'FSTDS))))) + (if (< opcode-extn 8) + `(,mnemonic (,@um-print-completer ,@cc-print-completer) + (,(if (zero? short-flag) 'INDEX 'OFFSET) + ,index ,space-spec ,base-reg) + ,source-or-target) + `(,mnemonic (,@um-print-completer ,@cc-print-completer) + ,source-or-target + (,(if (zero? short-flag) 'INDEX 'OFFSET) + ,index ,space-spec ,base-reg))))))) + +(define (scalar-load opcode hi-halfword lo-halfword) + ;; LDO LDB LDH LDW LDWM + (let ((base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword) #x20)) + (space-spec (fix:quotient lo-halfword #x4000)) + (target-reg (fix:and hi-halfword #x1f)) + (displacement (XRight2s (fix:and lo-halfword Mask-2-16))) + (mnemonic + (case opcode + ((#x0d) 'LDO) + ((#x10) 'LDB) + ((#x11) 'LDH) + ((#x12) 'LDW) + ((#x13) 'LDWM) + (else (invalid-instruction))))) + (cond ((not (eq? mnemonic 'LDO)) + `(,mnemonic () + (OFFSET ,displacement ,space-spec ,base-reg) + ,target-reg)) + ((zero? base-reg) + `(LDI () ,displacement ,target-reg)) + (else + `(,mnemonic () + (OFFSET ,displacement 0 ,base-reg) + ,target-reg))))) + +(define (scalar-store opcode hi-halfword lo-halfword) + ;; STB STH STW STWM + (let ((base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword) + #x20)) + (space-spec (fix:quotient lo-halfword #x4000)) + (source-reg (fix:and hi-halfword #x1f)) + (displacement (XRight2s (fix:and lo-halfword Mask-2-16))) + (mnemonic + (case opcode + ((#x18) 'STB) + ((#x19) 'STH) + ((#x1a) 'STW) + ((#x1b) 'STWM) + (else (invalid-instruction))))) + `(,mnemonic () ,source-reg + (OFFSET ,displacement ,space-spec ,base-reg)))) + +(define (cond-branch opcode hi-halfword lo-halfword) + ;; MOVB MOVIB COMB COMIB ADDB ADDIB BVB BB + (let* ((reg-2 (fix:quotient (fix:and Mask-6-10 hi-halfword) #x20)) + (reg-1 (if (and (not (= opcode #x31)) + (odd? opcode)) + ;; For odd opcodes, this is immed-5 data, not reg-1 + (X-Signed-5-Bit (fix:and hi-halfword #x1f)) + (fix:and hi-halfword #x1f))) + (c (fix:quotient lo-halfword #x2000)) + (word-displacement (collect-14 lo-halfword)) + (null-completer (nullify-bit lo-halfword)) + (mnemonic (case opcode + ((#x20) 'COMBT) + ((#x21) 'COMIBT) + ((#x22) 'COMBF) + ((#x23) 'COMIBF) + ((#x28) 'ADDBT) + ((#x29) 'ADDIBT) + ((#x2a) 'ADDBF) + ((#x2b) 'ADDIBF) + ((#x30) 'BVB) + ((#x31) 'BB) + ((#x32) 'MOVB) + ((#x33) 'MOVIB) + (else (invalid-instruction)))) + (completer-symbol + (X-Extract-Deposit-Completers c))) + (if (eq? mnemonic 'BVB) + `(,mnemonic (,@completer-symbol ,@null-completer) ,reg-1 + ,word-displacement) + `(,mnemonic (,@completer-symbol ,@null-completer) ,reg-1 ,reg-2 + ,word-displacement)))) + +(define (addi&subi opcode hi-halfword lo-halfword) + ;; ADDI-T-O SUBI-O COMICLR + (let ((opcode-extn (fix:quotient (fix:and 2048 lo-halfword) #x800))) + (let ((source-reg (fix:quotient (fix:and Mask-6-10 hi-halfword) + #x20)) + (target-reg (fix:and hi-halfword #x1f)) + (immed-value (X-Signed-11-Bit (fix:and lo-halfword 2047))) + (completer-symbol (x-arith-log-completer lo-halfword opcode)) + (mnemonic + (if (= opcode-extn 0) + (case opcode + ((#x24) 'COMICLR) + ((#x25) 'SUBI) + ((#x2c) 'ADDIT) + ((#x2d) 'ADDI) + (else (invalid-instruction))) + (case opcode + ((#x25) 'SUBIO) + ((#x2c) 'ADDITO) + ((#x2d) 'ADDIO) + (else (invalid-instruction)))))) + `(,mnemonic ,completer-symbol ,immed-value + ,source-reg ,target-reg)))) + +(define (extr&dep opcode hi-halfword lo-halfword) + ;; VEXTRU VEXTRS VDEP ZVDEP + (let* ((reg-2 (fix:quotient (fix:and Mask-6-10 hi-halfword) #x20)) + (reg-1 (fix:and hi-halfword #x1f)) + (c (fix:quotient lo-halfword #x2000)) + (opcode-extn (fix:quotient (fix:and lo-halfword Mask-3-5) #x400)) + (cp (fix:quotient (fix:and lo-halfword Mask-6-10) #x20)) + (clen (fix:and lo-halfword #x1f)) + (completer-symbol (X-Extract-Deposit-Completers c)) + (mnemonic + (vector-ref (if (= opcode #x34) + '#(VSHD *INVALID* SHD *INVALID* + VEXTRU VEXTRS EXTRU EXTRS) + '#(ZVDEP VDEP ZDEP DEP + ZVDEPI VDEPI ZDEPI DEPI)) + opcode-extn))) + + (define (process reg-1 reg-2) + (cond ((or (<= 4 opcode-extn 5) + (and (= opcode #x35) + (< opcode-extn 2))) + ;; Variable dep/ext + `(,mnemonic ,completer-symbol ,reg-1 ,(- 32 clen) ,reg-2)) + ((eq? mnemonic 'VSHD) + `(,mnemonic ,completer-symbol ,reg-1 ,reg-2 ,clen)) + ((eq? mnemonic 'SHD) + `(,mnemonic ,completer-symbol ,reg-1 ,reg-2 ,(- 31 cp) ,clen)) + (else + `(,mnemonic ,completer-symbol + ,reg-1 + ,(if (= opcode #x34) cp (- 31 cp)) + ,(- 32 clen) , + reg-2)))) + + (cond ((eq? mnemonic '*INVALID*) + (invalid-instruction)) + ((<= opcode-extn 3) + (process reg-1 reg-2)) + ((= opcode #x34) + (process reg-2 reg-1)) + (else + (process (X-Signed-5-Bit reg-1) reg-2))))) + +(define (be&ble opcode hi-halfword lo-halfword) + ;; BE BLE + (let ((base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword) #x20)) + (space-reg (Assemble-3 (fix:quotient lo-halfword #x2000))) + (null-completer (nullify-bit lo-halfword)) + (word-displacement (collect-19 lo-halfword hi-halfword false)) + (mnemonic (if (= opcode #x38) 'BE 'BLE))) + `(,mnemonic ,null-completer + (OFFSET ,word-displacement ,space-reg ,base-reg)))) + +(define (branch opcode hi-halfword lo-halfword) + ;; B, BL, BLR, BV, GATE + opcode ;ignore + (let ((opcode-extension (fix:quotient lo-halfword #x2000))) + (case opcode-extension + ((0 1) + ;; B BL GATE + (let ((return-reg (fix:quotient (fix:and Mask-6-10 hi-halfword) + #x20)) + (word-displacement (collect-19 lo-halfword hi-halfword true)) + (null-completer (nullify-bit lo-halfword))) + (let ((mnemonic (cond ((= opcode-extension 1) 'GATE) + ((= return-reg 0) 'B) + (else 'BL)))) + (if (eq? mnemonic 'B) + `(,mnemonic ,null-completer ,word-displacement) + `(,mnemonic ,null-completer ,return-reg ,word-displacement))))) + ((2 6) + ;; BLR BV + (let ((return-reg (fix:quotient (fix:and Mask-6-10 hi-halfword) + #x20)) + (offset-reg (fix:and hi-halfword #x1f)) + (null-completer (nullify-bit lo-halfword)) + (mnemonic (if (= opcode-extension 2) + 'BLR + 'BV))) + `(,mnemonic ,null-completer ,offset-reg ,return-reg))) + (else (invalid-instruction))))) + +;;;; FLoating point operations + +(define (float-op opcode hi-halfword lo-halfword) + ;; Copr 0 is the floating point copr. + opcode ;ignore + (if (not (zero? (fix:and (fix:quotient lo-halfword #x40) 7))) + (invalid-instruction) + ((case (fix:and (fix:quotient lo-halfword #x200) 3) + ((0) float-op0) + ((1) float-op1) + ((2) float-op2) + (else float-op3)) + hi-halfword lo-halfword))) + +(define (float-op0 hi-halfword lo-halfword) + (let ((mnemonic + (vector-ref '#(COPR *INVALID* FCPY FABS FSQRT FRND + *INVALID* *INVALID*) + (fix:quotient lo-halfword #x2000))) + (fmt (floating-format (fix:and (fix:quotient lo-halfword #x800) 3))) + (r (fix:and (fix:quotient hi-halfword #x20) #x1f)) + (t (fix:and lo-halfword #x1f))) + (if (eq? mnemonic '*INVALID*) + (invalid-instruction) + `(,mnemonic (,fmt) ,r ,t)))) + +(define (float-op1 hi-halfword lo-halfword) + (let ((mnemonic + (vector-ref '#(FCNVFF FCNVXF FCNVFX FCNVFXT) + (+ (* 2 (fix:and hi-halfword 1)) + (fix:quotient lo-halfword #x8000)))) + (sf (floating-format (fix:and (fix:quotient lo-halfword #x800) 3))) + (df (floating-format (fix:and (fix:quotient lo-halfword #x2000) 3))) + (r (fix:and (fix:quotient hi-halfword #x20) #x1f)) + (t (fix:and lo-halfword #x1f))) + `(,mnemonic (,sf ,df) ,r ,t))) + +(define (float-op2 hi-halfword lo-halfword) + (case (fix:quotient lo-halfword #x2000) + ((0) + (let ((fmt (floating-format (fix:and (fix:quotient lo-halfword #x800) 3))) + (r1 (fix:and (fix:quotient hi-halfword #x20) #x1f)) + (r2 (fix:and hi-halfword #x1f)) + (c (float-completer (fix:and lo-halfword #x1f)))) + `(FCMP (,c ,fmt) ,r1 ,r2))) + ((1) + `(FTEST)) + (else + (invalid-instruction)))) + +(define (float-op3 hi-halfword lo-halfword) + (let ((mnemonic + (vector-ref '#(FADD FSUB FMPY FDIV FREM *INVALID* *INVALID* *INVALID*) + (fix:quotient lo-halfword #x2000))) + (fmt (floating-format (fix:and (fix:quotient lo-halfword #x800) 3))) + (r1 (fix:and (fix:quotient hi-halfword #x20) #x1f)) + (r2 (fix:and hi-halfword #x1f)) + (t (fix:and lo-halfword #x1f))) + (if (eq? mnemonic '*INVALID*) + (invalid-instruction) + `(,mnemonic (,fmt) ,r1 ,r2 ,t)))) + +;;;; Field extraction + +(define (assemble-3 x) + (let ((split (integer-divide x 2))) + (+ (* (integer-divide-remainder split) 4) + (integer-divide-quotient split)))) + +(define (assemble-12 x y) + (let ((split (integer-divide x 2))) + (+ (* y #x800) + (* (integer-divide-remainder split) #x400) + (integer-divide-quotient split)))) + +(define (assemble-17 x y z) + (let ((split (integer-divide y 2))) + (+ (* z #x10000) + (* x #x800) + (* (integer-divide-remainder split) #x400) + (integer-divide-quotient split)))) + +#| +(define (assemble-21 x) ; Source Dest + (+ (* (* (fix:and x 1) #x10000) #x10) ; bit 20 bit 0 + (* (fix:and x #xffe) #x100) ; bits 9-19 bits 1-11 + (fix:quotient (fix:and x #xc000) #x80) ; bits 5-6 bits 12-13 + (fix:quotient (fix:and x #x1f0000) #x4000) ; bits 0-4 bits 14-18 + (fix:quotient (fix:and x #x3000) #x1000))) ; bits 7-8 bits 19-20 +|# + +(define (assemble-21 x) + (let ((b (unsigned-integer->bit-string 21 x))) + (+ (* (extract b 0 1) #x100000) + (* (extract b 1 12) #x200) + (* (extract b 14 16) #x80) + (* (extract b 16 21) #x4) + (extract b 12 14)))) + +(define (x-signed-5-bit x) ; Sign bit is lo. + (let ((sign-bit (fix:and x 1)) + (hi-bits (fix:quotient x 2))) + (if (= sign-bit 0) + hi-bits + (- hi-bits 16)))) + +(define (x-signed-11-bit x) ; Sign bit is lo. + (let ((sign-bit (fix:and x 1)) + (hi-bits (fix:quotient x 2))) + (if (= sign-bit 0) + hi-bits + (- hi-bits #x400)))) + +(define (xright2s d) + (let ((sign-bit (fix:and d 1))) + (- (fix:quotient d 2) + (if (= sign-bit 0) + 0 + #x2000)))) + +(define-integrable (make-pc-relative value) + (offset->pc-relative value *current-offset)) + +(define (collect-14 lo-halfword) + (let* ((sign (fix:and lo-halfword 1)) + (w (* 4 (assemble-12 (fix:quotient (fix:and lo-halfword #x1ffc) 4) + sign)))) + (make-pc-relative (if (= sign 1) + (- w #x4000) ; (expt 2 14) + w)))) + +(define (collect-19 lo-halfword hi-halfword pc-rel?) + (let* ((sign (fix:and 1 lo-halfword)) + (w (* 4 (assemble-17 (fix:and Mask-11-15 hi-halfword) + (fix:quotient (fix:and Mask-3-14 lo-halfword) + 4) + sign))) + (disp (if (= sign 1) + (- w #x80000) ; (expt 2 19) + w))) + (if pc-rel? + (make-pc-relative disp) + disp))) + +;;;; Completers (modifier suffixes) + +(define (x-arith-log-completer lo-halfword xtra) + ;; c is 3-bit, f 1-bit + (let ((c (fix:quotient lo-halfword #x2000)) + (f (fix:quotient (fix:and lo-halfword 4096) #x1000))) + (let ((index (+ (* f 8) c))) + (case xtra + ((#x2c #x2d #x30 #x32 #x34 #x36 #x38 #x4c #x4e + #x50 #x52 #x54 #x56 #x70 #x72 #x74 #x76 #x78) + ;; adds: #x2c #x2d are ADDI + (vector-ref + '#(() (=) (<) (<=) (NUV) (ZNV) (SV) (OD) + (TR) (<>) (>=) (>) (UV) (VNZ) (NSV) (EV)) + #| + '#(() (Eq) (Lt) (LtEq) (NUV) (ZNV) (SV) (OD) + (TR) (LtGt) (GtEq) (Gt) (UV) (VNZ) (NSV) (EV)) + |# + index)) + ((#x20 #x22 #x24 #x25 #x26 #x28 #x44 #x60 #x66 #x68) + ;; subtract/compare: #x24 #x25 are SUBI + (vector-ref + '#(() (=) (<) (<=) (<<) (<<=) (SV) (OD) + (TR) (<>) (>=) (>) (>>=) (>>) (NSV) (EV)) + #| + '#(() (Eq) (Lt) (LtEq) (LtLt) (LtLtEq) (SV) (OD) + (TR) (LtGt) (GtEq) (Gt) (GtGtEq) (GtGt) (NSV) (EV)) + |# + index)) + ((0 #x10 #x12 #x14 #x1c) + ;; logical + (vector-ref + '#(() (=) (<) (<=) () () () (OD) + (TR) (<>) (>=) (>) () () () (EV)) + #| + '#(() (Eq) (Lt) (LtEq) () () () (OD) + (TR) (LtGt) (GtEq) (Gt) () () () (EV)) + |# + index)) + ((#x5c #x5e) + ;; unit + (vector-ref '#(() () (SBZ) (SHZ) (SDC) () (SBC) (SHC) + (TR) () (NBZ) (NHZ) (NDC) () (NBC) (NHC)) + index)))))) + +(define (X-Extract-Deposit-Completers c) + (vector-ref '#(() (=) (<) (OD) (TR) (<>) (>=) (EV)) + #| '#(() (Eq) (Lt) (OD) (TR) (LtGt) (GtEq) (EV)) |# + c)) + +(define (cc-completer lo-halfword) + (vector-ref '#(() (C) (Q) (P)) + (fix:quotient (fix:and lo-halfword Mask-4-5) #x400))) + +(define (um-completer short-flag lo-halfword) + (let ((u-completer (fix:and lo-halfword #x2000)) + (m-completer (fix:and lo-halfword #x20))) + (if (zero? short-flag) + (if (zero? u-completer) + (if (zero? m-completer) '() '(M)) + (if (zero? m-completer) '(S) '(SM))) + (if (zero? m-completer) + '() + (if (zero? u-completer) '(MA) '(MB)))))) + +(define-integrable (nullify-bit lo-halfword) + (if (= (fix:and lo-halfword 2) 2) '(N) '())) + +(define-integrable (floating-format value) + (vector-ref '#(SGL DBL FMT=2 QUAD) value)) + +(define-integrable (float-completer value) + (vector-ref '#(false? false ? !<=> = =T ?= !<> !?>= < ?< !>= !?> <= ?<= !> + !?<= > ?> !<= !?< >= ?>= !< !?= <> != !=T !? <=> true? true) + value)) \ No newline at end of file diff --git a/v8/src/compiler/machines/spectrum/decls.scm b/v8/src/compiler/machines/spectrum/decls.scm new file mode 100644 index 000000000..9a918ef41 --- /dev/null +++ b/v8/src/compiler/machines/spectrum/decls.scm @@ -0,0 +1,668 @@ +#| -*-Scheme-*- + +$Id: decls.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Compiler File Dependencies +;;; package: (compiler declarations) + +(declare (usual-integrations)) + +(define (initialize-package!) + (add-event-receiver! event:after-restore reset-source-nodes!) + (reset-source-nodes!)) + +(define (reset-source-nodes!) + (set! source-filenames '()) + (set! source-hash) + (set! source-nodes) + (set! source-nodes/by-rank) + unspecific) + +(define (maybe-setup-source-nodes!) + (if (null? source-filenames) + (setup-source-nodes!))) + +(define (setup-source-nodes!) + (let ((filenames + (append-map! + (lambda (subdirectory) + (map (lambda (pathname) + (string-append subdirectory + "/" + (pathname-name pathname))) + (directory-read + (string-append subdirectory + "/" + source-file-expression)))) + '("back" "base" + ;;"fggen" "fgopt" + "midend" + "rtlbase" + ;;"rtlgen" + "rtlopt" + "machines/spectrum")))) + (if (null? filenames) + (error "Can't find source files of compiler")) + (set! source-filenames filenames)) + (set! source-hash (make-string-hash-table)) + (set! source-nodes + (map (lambda (filename) + (let ((node (make/source-node filename))) + (hash-table/put! source-hash filename node) + node)) + source-filenames)) + (initialize/syntax-dependencies!) + (initialize/integration-dependencies!) + (initialize/expansion-dependencies!) + (source-nodes/rank!)) + +(define source-file-expression "*.scm") +(define source-filenames) +(define source-hash) +(define source-nodes) +(define source-nodes/by-rank) + +(define (filename/append directory . names) + (map (lambda (name) (string-append directory "/" name)) names)) + +(define-structure (source-node + (conc-name source-node/) + (constructor make/source-node (filename))) + (filename false read-only true) + (pathname (->pathname filename) read-only true) + (forward-links '()) + (backward-links '()) + (forward-closure '()) + (backward-closure '()) + (dependencies '()) + (dependents '()) + (rank false) + (syntax-table false) + (declarations '()) + (modification-time false)) + +(define (filename->source-node filename) + (let ((node (hash-table/get source-hash filename #f))) + (if (not node) + (error "Unknown source file:" filename)) + node)) + +(define (source-node/circular? node) + (memq node (source-node/backward-closure node))) + +(define (source-node/link! node dependency) + (if (not (memq dependency (source-node/backward-links node))) + (begin + (set-source-node/backward-links! + node + (cons dependency (source-node/backward-links node))) + (set-source-node/forward-links! + dependency + (cons node (source-node/forward-links dependency))) + (source-node/close! node dependency)))) + +(define (source-node/close! node dependency) + (if (not (memq dependency (source-node/backward-closure node))) + (begin + (set-source-node/backward-closure! + node + (cons dependency (source-node/backward-closure node))) + (set-source-node/forward-closure! + dependency + (cons node (source-node/forward-closure dependency))) + (for-each (lambda (dependency) + (source-node/close! node dependency)) + (source-node/backward-closure dependency)) + (for-each (lambda (node) + (source-node/close! node dependency)) + (source-node/forward-closure node))))) + +;;;; Rank + +(define (source-nodes/rank!) + (compute-dependencies! source-nodes) + (compute-ranks! source-nodes) + (set! source-nodes/by-rank (source-nodes/sort-by-rank source-nodes)) + unspecific) + +(define (compute-dependencies! nodes) + (for-each (lambda (node) + (set-source-node/dependencies! + node + (list-transform-negative (source-node/backward-closure node) + (lambda (node*) + (memq node (source-node/backward-closure node*))))) + (set-source-node/dependents! + node + (list-transform-negative (source-node/forward-closure node) + (lambda (node*) + (memq node (source-node/forward-closure node*)))))) + nodes)) + +(define (compute-ranks! nodes) + (let loop ((nodes nodes) (unranked-nodes '())) + (if (null? nodes) + (if (not (null? unranked-nodes)) + (loop unranked-nodes '())) + (loop (cdr nodes) + (let ((node (car nodes))) + (let ((rank (source-node/rank* node))) + (if rank + (begin + (set-source-node/rank! node rank) + unranked-nodes) + (cons node unranked-nodes)))))))) + +(define (source-node/rank* node) + (let loop ((nodes (source-node/dependencies node)) (rank -1)) + (if (null? nodes) + (1+ rank) + (let ((rank* (source-node/rank (car nodes)))) + (and rank* + (loop (cdr nodes) (max rank rank*))))))) + +(define (source-nodes/sort-by-rank nodes) + (sort nodes (lambda (x y) (< (source-node/rank x) (source-node/rank y))))) + +;;;; File Syntaxer + +(define (syntax-files!) + (maybe-setup-source-nodes!) + (for-each + (lambda (node) + (let ((modification-time + (let ((source (modification-time node "scm")) + (binary (modification-time node "bin"))) + (if (not source) + (error "Missing source file" (source-node/filename node))) + (and binary (< source binary) binary)))) + (set-source-node/modification-time! node modification-time) + (if (not modification-time) + (begin (write-string "\nSource file newer than binary: ") + (write (source-node/filename node)))))) + source-nodes) + (if compiler:enable-integration-declarations? + (begin + (for-each + (lambda (node) + (let ((time (source-node/modification-time node))) + (if (and time + (there-exists? (source-node/dependencies node) + (lambda (node*) + (let ((newer? + (let ((time* + (source-node/modification-time node*))) + (or (not time*) + (> time* time))))) + (if newer? + (begin + (write-string "\nBinary file ") + (write (source-node/filename node)) + (write-string " newer than dependency ") + (write (source-node/filename node*)))) + newer?)))) + (set-source-node/modification-time! node false)))) + source-nodes) + (for-each + (lambda (node) + (if (not (source-node/modification-time node)) + (for-each (lambda (node*) + (if (source-node/modification-time node*) + (begin + (write-string "\nBinary file ") + (write (source-node/filename node*)) + (write-string " depends on ") + (write (source-node/filename node)))) + (set-source-node/modification-time! node* false)) + (source-node/forward-closure node)))) + source-nodes))) + (for-each (lambda (node) + (if (not (source-node/modification-time node)) + (pathname-delete! + (pathname-new-type (source-node/pathname node) "ext")))) + source-nodes/by-rank) + (write-string "\n\nBegin pass 1:") + (for-each (lambda (node) + (if (not (source-node/modification-time node)) + (source-node/syntax! node))) + source-nodes/by-rank) + (if (there-exists? source-nodes/by-rank + (lambda (node) + (and (not (source-node/modification-time node)) + (source-node/circular? node)))) + (begin + (write-string "\n\nBegin pass 2:") + (for-each (lambda (node) + (if (not (source-node/modification-time node)) + (if (source-node/circular? node) + (source-node/syntax! node) + (source-node/touch! node)))) + source-nodes/by-rank)))) + +(define (source-node/touch! node) + (with-values + (lambda () + (sf/pathname-defaulting (source-node/pathname node) "" false)) + (lambda (input-pathname bin-pathname spec-pathname) + input-pathname + (pathname-touch! bin-pathname) + (pathname-touch! (pathname-new-type bin-pathname "ext")) + (if spec-pathname (pathname-touch! spec-pathname))))) + +(define (pathname-touch! pathname) + (if (file-exists? pathname) + (begin + (write-string "\nTouch file: ") + (write (enough-namestring pathname)) + (file-touch pathname)))) + +(define (pathname-delete! pathname) + (if (file-exists? pathname) + (begin + (write-string "\nDelete file: ") + (write (enough-namestring pathname)) + (delete-file pathname)))) + +(define (sc filename) + (maybe-setup-source-nodes!) + (source-node/syntax! (filename->source-node filename))) + +(define (source-node/syntax! node) + (with-values + (lambda () + (sf/pathname-defaulting (source-node/pathname node) "" false)) + (lambda (input-pathname bin-pathname spec-pathname) + (sf/internal + input-pathname bin-pathname spec-pathname + (source-node/syntax-table node) + ((if compiler:enable-integration-declarations? + identity-procedure + (lambda (declarations) + (list-transform-negative declarations + integration-declaration?))) + ((if compiler:enable-expansion-declarations? + identity-procedure + (lambda (declarations) + (list-transform-negative declarations + expansion-declaration?))) + (source-node/declarations node))))))) + +(define-integrable (modification-time node type) + (file-modification-time + (pathname-new-type (source-node/pathname node) type))) + +;;;; Syntax dependencies + +(define (initialize/syntax-dependencies!) + (let ((file-dependency/syntax/join + (lambda (filenames syntax-table) + (for-each (lambda (filename) + (set-source-node/syntax-table! + (filename->source-node filename) + syntax-table)) + filenames)))) + (file-dependency/syntax/join + (append (filename/append "base" + "toplev" "asstop" "crstop" + "blocks" "cfg1" "cfg2" "cfg3" "constr" + "contin" "ctypes" "debug" "enumer" + "infnew" "lvalue" "object" "pmerly" "proced" + "refctx" "rvalue" "scode" "sets" "subprb" + "switch" "utils") + (filename/append "back" + "asmmac" "bittop" "bitutl" "insseq" "lapgn1" + "lapgn2" "lapgn3" "linear" "regmap" "symtab" + "syntax") + (filename/append "machines/spectrum" + "dassm1" "insmac" "lapopt" "machin" "rgspcm" + "rulrew") + ;;(filename/append "fggen" + ;; "declar" "fggen" "canon") + ;;(filename/append "fgopt" + ;; "blktyp" "closan" "conect" "contan" "delint" + ;; "desenv" "envopt" "folcon" "offset" "operan" + ;; "order" "outer" "param" "reord" "reteqv" "reuse" + ;; "sideff" "simapp" "simple" "subfre" "varind") + (filename/append "midend" + "alpha" "applicat" "assconv" "cleanup" + "closconv" "compat" "copier" "cpsconv" + "dataflow" "dbgstr" "debug" "earlyrew" + "envconv" "expand" "fakeprim" "graph" + "indexify" "inlate" "lamlift" "laterew" + "load" "midend" "rtlgen" "simplify" + "split" "stackopt" "staticfy" "synutl" + "triveval" "utils" "widen" + ) + (filename/append "rtlbase" + "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp" + "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2" + "valclass" + ;; New stuff + "rtlpars" + ;; End of New stuff + ) + ;;(filename/append "rtlgen" + ;; "fndblk" "fndvar" "opncod" "rgcomb" "rgproc" + ;; "rgretn" "rgrval" "rgstmt" "rtlgen") + (filename/append "rtlopt" + "ralloc" "rcompr" "rcse1" "rcse2" "rcseep" + "rcseht" "rcserq" "rcsesr" "rcsemrg" + "rdebug" "rdflow" "rerite" "rinvex" + "rlife" "rtlcsm")) + compiler-syntax-table) + (file-dependency/syntax/join + (filename/append "machines/spectrum" + "lapgen" + "rules1" "rules2" "rules3" "rules4" "rulfix" "rulflo") + lap-generator-syntax-table) + (file-dependency/syntax/join + (filename/append "machines/spectrum" "instr1" "instr2" "instr3") + assembler-syntax-table))) + +;;;; Integration Dependencies + +(define (initialize/integration-dependencies!) + (define (add-declaration! declaration filenames) + (for-each (lambda (filenames) + (let ((node (filename->source-node filenames))) + (set-source-node/declarations! + node + (cons declaration + (source-node/declarations node))))) + filenames)) + + (let* ((front-end-base + (filename/append "base" + "blocks" "cfg1" "cfg2" "cfg3" + "contin" "ctypes" "enumer" "lvalue" + "object" "proced" "rvalue" + "scode" "subprb" "utils")) + (midend-base + (filename/append "midend" + "fakeprim" "utils")) + (spectrum-base + (append (filename/append "machines/spectrum" "machin") + (filename/append "back" "asutl"))) + (rtl-base + (filename/append "rtlbase" + "rgraph" "rtlcfg" "rtlobj" "rtlreg" "rtlty1" + "rtlty2")) + (cse-base + (filename/append "rtlopt" + "rcse1" "rcseht" "rcserq" "rcsesr")) + (cse-all + (append (filename/append "rtlopt" + "rcse2" "rcsemrg" "rcseep") + cse-base)) + (instruction-base + (filename/append "machines/spectrum" "assmd" "machin")) + (lapgen-base + (append (filename/append "back" "linear" "regmap") + (filename/append "machines/spectrum" "lapgen"))) + (assembler-base + (append (filename/append "back" "symtab") + (filename/append "machines/spectrum" "instr1"))) + (lapgen-body + (append + (filename/append "back" "lapgn1" "lapgn2" "syntax") + (filename/append "machines/spectrum" + "rules1" "rules2" "rules3" "rules4" + "rulfix" "rulflo"))) + (assembler-body + (append + (filename/append "back" "bittop") + (filename/append "machines/spectrum" + "instr1" "instr2" "instr3")))) + + (define (file-dependency/integration/join filenames dependencies) + (for-each (lambda (filename) + (file-dependency/integration/make filename dependencies)) + filenames)) + + (define (file-dependency/integration/make filename dependencies) + (let ((node (filename->source-node filename))) + (for-each (lambda (dependency) + (let ((node* (filename->source-node dependency))) + (if (not (eq? node node*)) + (source-node/link! node node*)))) + dependencies))) + + (define (define-integration-dependencies directory name directory* . names) + (file-dependency/integration/make + (string-append directory "/" name) + (apply filename/append directory* names))) + + (define-integration-dependencies "machines/spectrum" "machin" "back" "asutl") + (define-integration-dependencies "base" "object" "base" "enumer") + (define-integration-dependencies "base" "enumer" "base" "object") + (define-integration-dependencies "base" "utils" "base" "scode") + (define-integration-dependencies "base" "cfg1" "base" "object") + (define-integration-dependencies "base" "cfg2" "base" + "cfg1" "cfg3" "object") + (define-integration-dependencies "base" "cfg3" "base" "cfg1" "cfg2") + (define-integration-dependencies "base" "ctypes" "base" + "blocks" "cfg1" "cfg2" "cfg3" "contin" "lvalue" "object" "subprb") + (define-integration-dependencies "base" "rvalue" "base" + "blocks" "cfg1" "cfg2" "cfg3" "enumer" "lvalue" "object" "utils") + (define-integration-dependencies "base" "lvalue" "base" + "blocks" "object" "proced" "rvalue" "utils") + (define-integration-dependencies "base" "blocks" "base" + "enumer" "lvalue" "object" "proced" "rvalue" "scode") + (define-integration-dependencies "base" "proced" "base" + "blocks" "cfg1" "cfg2" "cfg3" "contin" "enumer" "lvalue" "object" + "rvalue" "utils") + (define-integration-dependencies "base" "contin" "base" + "blocks" "cfg3" "ctypes") + (define-integration-dependencies "base" "subprb" "base" + "cfg3" "contin" "enumer" "object" "proced") + + (define-integration-dependencies "machines/spectrum" "machin" "rtlbase" + "rtlreg" "rtlty1" "rtlty2") + + (define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2") + (define-integration-dependencies "rtlbase" "rgraph" "machines/spectrum" + "machin") + (define-integration-dependencies "rtlbase" "rtlcfg" "base" + "cfg1" "cfg2" "cfg3") + (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils") + (define-integration-dependencies "rtlbase" "rtlcon" "machines/spectrum" + "machin") + (define-integration-dependencies "rtlbase" "rtlexp" "rtlbase" + "rtlreg" "rtlty1") + (define-integration-dependencies "rtlbase" "rtline" "base" "cfg1" "cfg2") + (define-integration-dependencies "rtlbase" "rtline" "rtlbase" + "rtlcfg" "rtlty2") + (define-integration-dependencies "rtlbase" "rtlobj" "base" + "cfg1" "object" "utils") + (define-integration-dependencies "rtlbase" "rtlreg" "machines/spectrum" + "machin") + (define-integration-dependencies "rtlbase" "rtlreg" "rtlbase" + "rgraph" "rtlty1") + (define-integration-dependencies "rtlbase" "rtlty1" "rtlbase" "rtlcfg") + (define-integration-dependencies "rtlbase" "rtlty2" "base" "scode") + (define-integration-dependencies "rtlbase" "rtlty2" "machines/spectrum" + "machin") + (define-integration-dependencies "rtlbase" "rtlty2" "rtlbase" "rtlty1") + + (file-dependency/integration/join + (append + (filename/append "base" "refctx") + ;;(filename/append "fggen" + ;; "declar" "fggen") ; "canon" needs no integrations + ;;(filename/append "fgopt" + ;; "blktyp" "closan" "conect" "contan" "delint" "desenv" + ;; "envopt" "folcon" "offset" "operan" "order" "param" + ;; "outer" "reuse" "reteqv" "sideff" "simapp" "simple" + ;; "subfre" "varind") + ) + (append spectrum-base front-end-base)) + + ;;(define-integration-dependencies "fgopt" "reuse" "fgopt" "reord") + + ;;(file-dependency/integration/join + ;; (filename/append "rtlgen" + ;; "fndblk" "fndvar" "opncod" "rgcomb" "rgproc" "rgretn" + ;; "rgrval" "rgstmt" "rtlgen") + ;;(append spectrum-base front-end-base rtl-base)) + + ;; New stuff + (file-dependency/integration/join (filename/append "rtlbase" "rtlpars") + rtl-base) + ;;(file-dependency/integration/join + ;; (filename/append "midend" + ;; "alpha" "applicat" "assconv" "cleanup" + ;; "closconv" "compat" "copier" "cpsconv" + ;; "dataflow" "dbgstr" "debug" "earlyrew" + ;; "envconv" "expand" "graph" + ;; "indexify" "inlate" "lamlift" "laterew" + ;; "load" "midend" "rtlgen" "simplify" + ;; "split" "stackopt" "staticfy" "synutl" + ;; "triveval" "widen") + ;; midend-base) + + ;; End of new stuff + + (file-dependency/integration/join + (append cse-all + (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow" + "rerite" "rinvex" "rlife" "rtlcsm") + (filename/append "machines/spectrum" "rulrew")) + (append spectrum-base rtl-base)) + + (file-dependency/integration/join cse-all cse-base) + + (file-dependency/integration/join + (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife") + (filename/append "rtlbase" "regset")) + + (file-dependency/integration/join + (filename/append "rtlopt" "rcseht" "rcserq") + (filename/append "base" "object")) + + (define-integration-dependencies "rtlopt" "rlife" "base" "cfg2") + + (let ((dependents + (append instruction-base + lapgen-base + lapgen-body + assembler-base + assembler-body + (filename/append "back" "linear" "syerly")))) + (add-declaration! '(USUAL-DEFINITION (SET EXPT)) dependents) + (file-dependency/integration/join dependents instruction-base)) + + (file-dependency/integration/join (append lapgen-base lapgen-body) + lapgen-base) + + (file-dependency/integration/join (append assembler-base assembler-body) + assembler-base) + + (define-integration-dependencies "back" "lapgn1" "base" + "cfg1" "cfg2" "utils") + (define-integration-dependencies "back" "lapgn1" "rtlbase" + "rgraph" "rtlcfg") + (define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg") + (define-integration-dependencies "back" "linear" "base" "cfg1" "cfg2") + (define-integration-dependencies "back" "linear" "rtlbase" "rtlcfg") + (define-integration-dependencies "back" "mermap" "back" "regmap") + (define-integration-dependencies "back" "regmap" "base" "utils") + (define-integration-dependencies "back" "symtab" "base" "utils")) + + (for-each (lambda (node) + (let ((links (source-node/backward-links node))) + (if (not (null? links)) + (set-source-node/declarations! + node + (cons (make-integration-declaration + (source-node/pathname node) + (map source-node/pathname links)) + (source-node/declarations node)))))) + source-nodes)) + +(define (make-integration-declaration pathname integration-dependencies) + `(INTEGRATE-EXTERNAL + ,@(map (let ((default + (make-pathname + false + false + (cons 'RELATIVE + (make-list + (length (cdr (pathname-directory pathname))) + 'UP)) + false + false + false))) + (lambda (pathname) + (merge-pathnames pathname default))) + integration-dependencies))) + +(define-integrable (integration-declaration? declaration) + (eq? (car declaration) 'INTEGRATE-EXTERNAL)) + +;;;; Expansion Dependencies + +(define (initialize/expansion-dependencies!) + (let ((file-dependency/expansion/join + (lambda (filenames expansions) + (for-each (lambda (filename) + (let ((node (filename->source-node filename))) + (set-source-node/declarations! + node + (cons (make-expansion-declaration expansions) + (source-node/declarations node))))) + filenames)))) + (file-dependency/expansion/join + (filename/append "machines/spectrum" + "lapgen" "rules1" "rules2" "rules3" "rules4" + "rulfix" "rulflo") + (map (lambda (entry) + `(,(car entry) + (PACKAGE/REFERENCE (FIND-PACKAGE '(COMPILER LAP-SYNTAXER)) + ',(cadr entry)))) + '((LAP:SYNTAX-INSTRUCTION LAP:SYNTAX-INSTRUCTION-EXPANDER) + (INSTRUCTION->INSTRUCTION-SEQUENCE + INSTRUCTION->INSTRUCTION-SEQUENCE-EXPANDER) + (SYNTAX-EVALUATION SYNTAX-EVALUATION-EXPANDER) + (CONS-SYNTAX CONS-SYNTAX-EXPANDER) + (OPTIMIZE-GROUP-EARLY OPTIMIZE-GROUP-EXPANDER) + (EA-KEYWORD-EARLY EA-KEYWORD-EXPANDER) + (EA-MODE-EARLY EA-MODE-EXPANDER) + (EA-REGISTER-EARLY EA-REGISTER-EXPANDER) + (EA-EXTENSION-EARLY EA-EXTENSION-EXPANDER) + (EA-CATEGORIES-EARLY EA-CATEGORIES-EXPANDER)))))) + +(define-integrable (make-expansion-declaration expansions) + `(EXPAND-OPERATOR ,@expansions)) + +(define-integrable (expansion-declaration? declaration) + (eq? (car declaration) 'EXPAND-OPERATOR)) \ No newline at end of file diff --git a/v8/src/compiler/machines/spectrum/inerly.scm b/v8/src/compiler/machines/spectrum/inerly.scm new file mode 100644 index 000000000..00eda09ad --- /dev/null +++ b/v8/src/compiler/machines/spectrum/inerly.scm @@ -0,0 +1,91 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/spectrum/inerly.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ +$MC68020-Header: inerly.scm,v 1.6 88/08/31 06:00:59 GMT cph Exp $ + +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;; Spectrum Instruction Set Macros. Early version +;;; NOPs for now. + +(declare (usual-integrations)) + +;;;; Transformers and utilities + +(define early-instructions '()) +(define early-transformers '()) + +(define (define-early-transformer name transformer) + (set! early-transformers + (cons (cons name transformer) + early-transformers))) + +(define (eq-subset? s1 s2) + (or (null? s1) + (and (memq (car s1) s2) + (eq-subset? (cdr s1) s2)))) + +;;; Instruction and addressing mode macros + +(syntax-table-define early-syntax-table 'DEFINE-INSTRUCTION + (macro (opcode . patterns) + `(SET! EARLY-INSTRUCTIONS + (CONS + (LIST ',opcode + ,@(map (lambda (pattern) + `(early-parse-rule + ',(car pattern) + (lambda (pat vars) + (early-make-rule + pat + vars + (scode-quote + (instruction->instruction-sequence + ,(parse-instruction (cadr pattern) + (cddr pattern) + true))))))) + patterns)) + EARLY-INSTRUCTIONS)))) + + + + + + + + + + + + + + + diff --git a/v8/src/compiler/machines/spectrum/insmac.scm b/v8/src/compiler/machines/spectrum/insmac.scm new file mode 100644 index 000000000..ae2670f80 --- /dev/null +++ b/v8/src/compiler/machines/spectrum/insmac.scm @@ -0,0 +1,143 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/spectrum/insmac.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ + +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Spectrum Instruction Set Macros + +(declare (usual-integrations)) + +;;;; Definition macros + +(syntax-table-define assembler-syntax-table 'DEFINE-SYMBOL-TRANSFORMER + (macro (name . alist) + `(begin + (declare (integrate-operator ,name)) + (define (,name symbol) + (declare (integrate symbol)) + (let ((place (assq symbol ',alist))) + (if (not place) + #F + (cdr place))))))) + +(syntax-table-define assembler-syntax-table 'DEFINE-TRANSFORMER + (macro (name value) + `(define ,name ,value))) + +;;;; Fixed width instruction parsing + +(define (parse-instruction first-word tail early?) + (cond ((not (null? tail)) + (error "parse-instruction: Unknown format" (cons first-word tail))) + ((eq? (car first-word) 'LONG) + (process-fields (cdr first-word) early?)) + ((eq? (car first-word) 'VARIABLE-WIDTH) + (process-variable-width first-word early?)) + (else + (error "parse-instruction: Unknown format" first-word)))) + +(define (process-variable-width descriptor early?) + (let ((binding (cadr descriptor)) + (clauses (cddr descriptor))) + `(LIST + ,(variable-width-expression-syntaxer + (car binding) ; name + (cadr binding) ; expression + (map (lambda (clause) + (expand-fields + (cdadr clause) + early? + (lambda (code size) + (if (not (zero? (remainder size 32))) + (error "process-variable-width: bad clause size" size)) + `((LIST ,(optimize-group-syntax code early?)) + ,size + ,@(car clause))))) + clauses))))) + +(define (process-fields fields early?) + (expand-fields fields + early? + (lambda (code size) + (if (not (zero? (remainder size 32))) + (error "process-fields: bad syllable size" size)) + `(LIST ,(optimize-group-syntax code early?))))) + +(define (expand-fields fields early? receiver) + (define (expand first-word word-size fields receiver) + (if (null? fields) + (receiver '() 0) + (expand-field + (car fields) early? + (lambda (car-field car-size) + (if (and (eq? endianness 'LITTLE) + (= 32 (+ word-size car-size))) + (expand '() 0 (cdr fields) + (lambda (tail tail-size) + (receiver + (append (cons car-field first-word) tail) + (+ car-size tail-size)))) + (expand (cons car-field first-word) + (+ car-size word-size) + (cdr fields) + (lambda (tail tail-size) + (receiver + (if (or (zero? car-size) + (not (eq? endianness 'LITTLE))) + (cons car-field tail) + tail) + (+ car-size tail-size))))))))) + (expand '() 0 fields receiver)) + +(define (expand-field field early? receiver) + early? ; ignored for now + (let ((size (car field)) + (expression (cadr field))) + + (define (default type) + (receiver (integer-syntaxer expression type size) + size)) + + (if (null? (cddr field)) + (default 'UNSIGNED) + (case (caddr field) + ((PC-REL) + (receiver + (integer-syntaxer ``(- ,,expression (+ *PC* 8)) + (cadddr field) + size) + size)) + ((BLOCK-OFFSET) + (receiver (list 'list ''BLOCK-OFFSET expression) + size)) + (else + (default (caddr field))))))) \ No newline at end of file diff --git a/v8/src/compiler/machines/spectrum/instr1.scm b/v8/src/compiler/machines/spectrum/instr1.scm new file mode 100644 index 000000000..bfa8c69f4 --- /dev/null +++ b/v8/src/compiler/machines/spectrum/instr1.scm @@ -0,0 +1,291 @@ +#| -*-Scheme-*- + +$Id: instr1.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ + +Copyright (c) 1987-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; HP Spectrum instruction utilities +;;; Originally from Walt Hill, who did the hard part. +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +(define-transformer complx + (lambda (completer) + (vector (encode-S/SM completer) + (cc-val completer) + (m-val completer)))) + +(define-transformer compls + (lambda (completer) + (vector (encode-MB completer) + (cc-val completer) + (m-val completer)))) + +(define-transformer compledb + (lambda (completer) + (cons (encode-n completer) + (extract-deposit-condition completer)))) + +(define-transformer compled + (lambda (completer) + (extract-deposit-condition completer))) + +(define-transformer complalb + (lambda (completer) + (cons (encode-n completer) + (arith-log-condition completer)))) + +(define-transformer complaltfb + (lambda (completer) + (list (encode-n completer) + (let ((val (arith-log-condition completer))) + (if (not (zero? (cadr val))) + (error "complaltfb: Bad completer" completer) + (car val)))))) + +(define-transformer complal + (lambda (completer) + (arith-log-condition completer))) + +(define-transformer complaltf + (lambda (completer) + (let ((val (arith-log-condition completer))) + (if (not (zero? (cadr val))) + (error "complaltf: Bad completer" completer) + val)))) + +(define-transformer fpformat + (lambda (completer) + (encode-fpformat completer))) + +(define-transformer fpcond + (lambda (completer) + (encode-fpcond completer))) + +(define-transformer sr3 + (lambda (value) + (let ((place (assq value '((0 . 0) (1 . 2) (2 . 4) (3 . 6) + (4 . 1) (5 . 3) (6 . 5) (7 . 7))))) + (if place + (cdr place) + (error "sr3: Invalid space register descriptor" value))))) + +;;;; Utilities + +(define-integrable (branch-extend-pco disp nullify?) + (if (and (= nullify? 1) + (negative? disp)) + 4 + 0)) + +(define-integrable (branch-extend-nullify disp nullify?) + (if (and (= nullify? 1) + (not (negative? disp))) + 1 + 0)) + +(define-integrable (branch-extend-disp disp) + (- disp 4)) + +(define-integrable (branch-extend-edcc cc) + (remainder (+ cc 4) 8)) + +(define-integrable (encode-N completers) + (if (memq 'N completers) + 1 + 0)) + +(define-integrable (encode-S/SM completers) + (if (or (memq 'S completers) (memq 'SM completers)) + 1 + 0)) + +(define-integrable (encode-MB completers) + (if (memq 'MB completers) + 1 + 0)) + +(define-integrable (m-val compl-list) + (if (or (memq 'M compl-list) + (memq 'SM compl-list) + (memq 'MA compl-list) + (memq 'MB compl-list)) + 1 + 0)) + +(define-integrable (cc-val compl-list) + (cond ((memq 'P compl-list) 3) + ((memq 'Q compl-list) 2) + ((memq 'C compl-list) 1) + (else 0))) + +(define (extract-deposit-condition compl) + (cond ((or (null? compl) (memq 'NV compl)) 0) + ((or (memq 'EQ compl) (memq '= compl)) 1) + ((or (memq 'LT compl) (memq '< compl)) 2) + ((memq 'OD compl) 3) + ((memq 'TR compl) 4) + ((or (memq 'LTGT compl) (memq '<> compl)) 5) + ((or (memq 'GTEQ compl) (memq '>= compl)) 6) + ((memq 'EV compl) 7) + (else + ;; This should really error out, but it's hard to + ;; arrange given that the compl includes other + ;; fields. + 0))) + +(define-integrable (encode-fpformat compl) + (case compl + ((DBL) 1) + ((SGL) 0) + ((QUAD) 3) + (else + (error "Missing Floating Point Format" compl)))) + +(define-integrable (encode-fpcond fpcond) + (let ((place (assq fpcond float-condition-table))) + (if place + (cadr place) + (error "encode-fpcond: Unknown condition" fpcond)))) + +(define float-condition-table + '((false? 0) + (false 1) + (? 2) + (!<=> 3) + (= 4) + (=T 5) + (?= 6) + (!<> 7) + (!?>= 8) + (< 9) + (?< 10) + (!>= 11) + (!?> 12) + (<= 13) + (?<= 14) + (!> 15) + (!?<= 16) + (> 17) + (?> 18) + (!<= 19) + (!?< 20) + (>= 21) + (?>= 22) + (!< 23) + (!?= 24) + (<> 25) + (!= 26) + (!=T 27) + (!? 28) + (<=> 29) + (true? 30) + (true 31))) + +(define (arith-log-condition compl-list) + ;; Returns (c f) + (let loop ((compl-list compl-list)) + (if (null? compl-list) + '(0 0) + (let ((val (assq (car compl-list) arith-log-condition-table))) + (if val + (cadr val) + (loop (cdr compl-list))))))) + +(define arith-log-condition-table + '((NV (0 0)) + (EQ (1 0)) + (= (1 0)) + (LT (2 0)) + (< (2 0)) + (SBZ (2 0)) + (LTEQ (3 0)) + (<= (3 0)) + (SHZ (3 0)) + (LTLT (4 0)) + (<< (4 0)) + (NUV (4 0)) + (SDC (4 0)) + (LTLTEQ (5 0)) + (<<= (5 0)) + (ZNV (5 0)) + (SV (6 0)) + (SBC (6 0)) + (OD (7 0)) + (SHC (7 0)) + (TR (0 1)) + (LTGT (1 1)) + (<> (1 1)) + (GTEQ (2 1)) + (>= (2 1)) + (NBZ (2 1)) + (GT (3 1)) + (> (3 1)) + (NHZ (3 1)) + (GTGTEQ (4 1)) + (>>= (4 1)) + (UV (4 1)) + (NDC (4 1)) + (GTGT (5 1)) + (>> (5 1)) + (VNZ (5 1)) + (NSV (6 1)) + (NBC (6 1)) + (EV (7 1)) + (NHC (7 1)))) + +(define-integrable (tf-adjust opcode condition) + (+ opcode (* 2 (cadr condition)))) + +(define (tf-adjust-inverted opcode condition) + (+ opcode (* 2 (- 1 (cadr condition))))) + +(define (make-operator name handler) + (lambda (value) + (if (exact-integer? value) + (handler value) + `(,name ,value)))) + +(let-syntax ((define-operator + (macro (name handler) + `(define ,name + (make-operator ',name ,handler))))) + +(define-operator LEFT + (lambda (number) + (bit-string->signed-integer + (bit-substring (signed-integer->bit-string 32 number) 11 32)))) + +(define-operator RIGHT + (lambda (number) + (bit-string->unsigned-integer + (bit-substring (signed-integer->bit-string 32 number) 0 11))))) \ No newline at end of file diff --git a/v8/src/compiler/machines/spectrum/instr2.scm b/v8/src/compiler/machines/spectrum/instr2.scm new file mode 100644 index 000000000..28da574d1 --- /dev/null +++ b/v8/src/compiler/machines/spectrum/instr2.scm @@ -0,0 +1,799 @@ +#| -*-Scheme-*- + +$Id: instr2.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ + +Copyright (c) 1987-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; HP Spectrum Instruction Set Description +;;; Originally from Walt Hill, who did the hard part. +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +;;;; Memory and offset operations + +;;; The long forms of many of the following instructions use register +;;; 1 -- this may be inappropriate for assembly-language programs, but +;;; is OK for the output of the compiler. +(let-syntax ((long-load + (macro (keyword opcode) + `(define-instruction ,keyword + ((() (OFFSET (? offset) (? space) (? base)) (? reg)) + (VARIABLE-WIDTH (disp offset) + ((#x-2000 #x1FFF) + (LONG (6 ,opcode) + (5 base) + (5 reg) + (2 space) + (14 disp RIGHT-SIGNED))) + ((() ()) + (LONG + ;; (ADDIL () L$,offset ,base) + (6 #x0A) + (5 base) + (21 (quotient disp #x800) ASSEMBLE21:X) + ;; (LDW () (OFFSET R$,offset ,space 1) ,reg) + (6 ,opcode) + (5 1) + (5 reg) + (2 space) + (14 (remainder disp #x800) RIGHT-SIGNED)))))))) + + (long-store + (macro (keyword opcode) + `(define-instruction ,keyword + ((() (? reg) (OFFSET (? offset) (? space) (? base))) + (VARIABLE-WIDTH (disp offset) + ((#x-2000 #x1FFF) + (LONG (6 ,opcode) + (5 base) + (5 reg) + (2 space) + (14 disp RIGHT-SIGNED))) + ((() ()) + (LONG + ;; (ADDIL () L$,offset ,base) + (6 #x0A) + (5 base) + (21 (quotient disp #x800) ASSEMBLE21:X) + ;; (STW () ,reg (OFFSET R$,offset ,space 1)) + (6 ,opcode) + (5 1) + (5 reg) + (2 space) + (14 (remainder disp #x800) RIGHT-SIGNED)))))))) + + (load-offset + (macro (keyword opcode) + `(define-instruction ,keyword + ((() (OFFSET (? offset) 0 (? base)) (? reg)) + (VARIABLE-WIDTH (disp offset) + ((#x-2000 #x1FFF) + (LONG (6 ,opcode) + (5 base) + (5 reg) + (2 #b00) + (14 disp RIGHT-SIGNED))) + ((() ()) + (LONG + ;; (ADDIL () L$,offset ,base) + (6 #x0A) + (5 base) + (21 (quotient disp #x800) ASSEMBLE21:X) + ;; (LDO () (OFFSET R$,offset 0 1) ,reg) + (6 ,opcode) + (5 1) + (5 reg) + (2 #b00) + (14 (remainder disp #x800) RIGHT-SIGNED)))))))) + + (load-immediate + (macro (keyword opcode) + `(define-instruction ,keyword + ((() (? offset) (? reg)) + (VARIABLE-WIDTH (disp offset) + ((#x-2000 #x1FFF) + (LONG (6 ,opcode) + (5 0) + (5 reg) + (2 #b00) + (14 disp RIGHT-SIGNED))) + ((() ()) + (LONG + ;; (LDIL () L$,offset ,base) + (6 #x08) + (5 reg) + (21 (quotient disp #x800) ASSEMBLE21:X) + ;; (LDO () (OFFSET R$,offset 0 ,reg) ,reg) + (6 ,opcode) + (5 reg) + (5 reg) + (2 #b00) + (14 (remainder disp #x800) RIGHT-SIGNED)))))))) + + (left-immediate + (macro (keyword opcode) + `(define-instruction ,keyword + ((() (? immed-21) (? reg)) + (LONG (6 ,opcode) + (5 reg) + (21 immed-21 ASSEMBLE21:X))))))) + + (long-load LDW #x12) + (long-load LDWM #x13) + (long-load LDH #x11) + (long-load LDB #x10) + + (long-store STW #x1a) + (long-store STWM #x1b) + (long-store STH #x19) + (long-store STB #x18) + + (load-offset LDO #x0d) + (load-immediate LDI #x0d) ; pseudo-op (LDO complt (OFFSET displ 0) reg) + + (left-immediate LDIL #x08) + (left-immediate ADDIL #x0a)) + +;; In the following, the middle completer field (2 bits) appears to be zero, +;; according to the hardware. Also, the u-bit seems not to exist in the +;; cache instructions. + +(let-syntax ((indexed-load + (macro (keyword opcode extn) + `(define-instruction ,keyword + (((? compl complx) (INDEX (? index-reg) (? space) (? base)) + (? reg)) + (LONG (6 ,opcode) + (5 base) + (5 index-reg) + (2 space) + (1 (vector-ref compl 0)) + (1 #b0) + (2 (vector-ref compl 1)) + (4 ,extn) + (1 (vector-ref compl 2)) + (5 reg)))))) + + (indexed-store + (macro (keyword opcode extn) + `(define-instruction ,keyword + (((? compl complx) (? reg) + (INDEX (? index-reg) (? space) (? base))) + (LONG (6 ,opcode) + (5 base) + (5 index-reg) + (2 space) + (1 (vector-ref compl 0)) + (1 #b0) + (2 (vector-ref compl 1)) + (4 ,extn) + (1 (vector-ref compl 2)) + (5 reg)))))) + + (indexed-d-cache + (macro (keyword extn) + `(define-instruction ,keyword + (((? compl m-val) (INDEX (? index-reg) (? space) (? base))) + (LONG (6 #x01) + (5 base) + (5 index-reg) + (2 space) + (8 ,extn) + (1 compl) + (5 #x0)))))) + + (indexed-i-cache + (macro (keyword extn) + `(define-instruction ,keyword + (((? compl m-val) + (INDEX (? index-reg) (? space sr3) (? base))) + (LONG (6 #x01) + (5 base) + (5 index-reg) + (3 space) + (7 ,extn) + (1 compl) + (5 #x0))))))) + + (indexed-load LDWX #x03 #x2) + (indexed-load LDHX #x03 #x1) + (indexed-load LDBX #x03 #x0) + (indexed-load LDCWX #x03 #x7) + (indexed-load FLDWX #x09 #x0) + (indexed-load FLDDX #x0B #x0) + + (indexed-store FSTWX #x09 #x8) + (indexed-store FSTDX #x0b #x8) + + (indexed-d-cache PDC #x4e) + (indexed-d-cache FDC #x4a) + (indexed-i-cache FIC #x0a) + (indexed-d-cache FDCE #x4b) + (indexed-i-cache FICE #x0b)) + +(let-syntax ((scalr-short-load + (macro (keyword extn) + `(define-instruction ,keyword + (((? compl compls) (OFFSET (? offset) (? space) (? base)) + (? reg)) + (LONG (6 #x03) + (5 base) + (5 offset RIGHT-SIGNED) + (2 space) + (1 (vector-ref compl 0)) + (1 #b1) + (2 (vector-ref compl 1)) + (4 ,extn) + (1 (vector-ref compl 2)) + (5 reg)))))) + + (scalr-short-store + (macro (keyword extn) + `(define-instruction ,keyword + (((? compl compls) (? reg) + (OFFSET (? offset) (? space) (? base))) + (LONG (6 #x03) + (5 base) + (5 reg) + (2 space) + (1 (vector-ref compl 0)) + (1 #b1) + (2 (vector-ref compl 1)) + (4 ,extn) + (1 (vector-ref compl 2)) + (5 offset RIGHT-SIGNED)))))) + + (float-short-load + (macro (keyword opcode extn) + `(define-instruction ,keyword + (((? compl compls) (OFFSET (? offset) (? space) (? base)) + (? reg)) + (LONG (6 ,opcode) + (5 base) + (5 offset RIGHT-SIGNED) + (2 space) + (1 (vector-ref compl 0)) + (1 #b1) + (2 (vector-ref compl 1)) + (4 ,extn) + (1 (vector-ref compl 2)) + (5 reg)))))) + + (float-short-store + (macro (keyword opcode extn) + `(define-instruction ,keyword + (((? compl compls) (? reg) + (OFFSET (? offset) (? space) (? base))) + (LONG (6 ,opcode) + (5 base) + (5 offset RIGHT-SIGNED) + (2 space) + (1 (vector-ref compl 0)) + (1 #b1) + (2 (vector-ref compl 1)) + (4 ,extn) + (1 (vector-ref compl 2)) + (5 reg))))))) + + (scalr-short-load LDWS #x02) + (scalr-short-load LDHS #x01) + (scalr-short-load LDBS #x00) + (scalr-short-load LDCWS #x07) + + (scalr-short-store STWS #x0a) + (scalr-short-store STHS #x09) + (scalr-short-store STBS #x08) + (scalr-short-store STBYS #x0c) + + (float-short-load FLDWS #x09 #x00) + (float-short-load FLDDS #x0b #x00) + + (float-short-store FSTWS #x09 #x08) + (float-short-store FSTDS #x0b #x08)) + +;;;; Control transfer instructions + +;;; Note: For the time being the unconditionaly branch instructions are not +;;; branch tensioned since their range is pretty large (1/2 Mbyte). +;;; They should be eventually (by using an LDIL,LDI,BLR sequence, for example). + +(let-syntax ((branch&link + (macro (keyword extn) + `(define-instruction ,keyword + ((() (? reg) (@PCR (? label))) + (LONG (6 #x3a) + (5 reg) + (5 label PC-REL ASSEMBLE17:X) + (3 ,extn) + (11 label PC-REL ASSEMBLE17:Y) + (1 0) + (1 label PC-REL ASSEMBLE17:Z))) + + (((N) (? reg) (@PCR (? label))) + (LONG (6 #x3a) + (5 reg) + (5 label PC-REL ASSEMBLE17:X) + (3 ,extn) + (11 label PC-REL ASSEMBLE17:Y) + (1 1) + (1 label PC-REL ASSEMBLE17:Z))) + + ((() (? reg) (@PCO (? offset))) + (LONG (6 #x3a) + (5 reg) + (5 offset ASSEMBLE17:X) + (3 ,extn) + (11 offset ASSEMBLE17:Y) + (1 0) + (1 offset ASSEMBLE17:Z))) + + (((N) (? reg) (@PCO (? offset))) + (LONG (6 #x3a) + (5 reg) + (5 offset ASSEMBLE17:X) + (3 ,extn) + (11 offset ASSEMBLE17:Y) + (1 1) + (1 offset ASSEMBLE17:Z)))))) + + (branch + (macro (keyword extn) + `(define-instruction ,keyword + ((() (@PCR (? l))) + (LONG (6 #x3a) + (5 #b00000) + (5 l PC-REL ASSEMBLE17:X) + (3 #b000) + (11 l PC-REL ASSEMBLE17:Y) + (1 0) + (1 l PC-REL ASSEMBLE17:Z))) + + (((N) (@PCR (? l))) + (LONG (6 #x3a) + (5 #b00000) + (5 l PC-REL ASSEMBLE17:X) + (3 #b000) + (11 l PC-REL ASSEMBLE17:Y) + (1 1) + (1 l PC-REL ASSEMBLE17:Z))) + + ((() (@PCO (? offset))) + (LONG (6 #x3a) + (5 #b00000) + (5 offset ASSEMBLE17:X) + (3 #b000) + (11 offset ASSEMBLE17:Y) + (1 0) + (1 offset ASSEMBLE17:Z))) + + (((N) (@PCO (? offset))) + (LONG (6 #x3a) + (5 #b00000) + (5 offset ASSEMBLE17:X) + (3 #b000) + (11 offset ASSEMBLE17:Y) + (1 1) + (1 offset ASSEMBLE17:Z))))))) + + (branch B 0) ; pseudo-op (BL complt 0 displ) + (branch&link BL 0) + (branch&link GATE 1)) + +(let-syntax ((BV&BLR + (macro (keyword extn) + `(define-instruction ,keyword + ((() (? offset-reg) (? reg)) + (LONG (6 #x3a) + (5 reg) + (5 offset-reg) + (3 ,extn) + (11 #b00000000000) + (1 0) + (1 #b0))) + + (((N) (? offset-reg) (? reg)) + (LONG (6 #x3a) + (5 reg) + (5 offset-reg) + (3 ,extn) + (11 #b00000000000) + (1 1) + (1 #b0)))))) + + (BE&BLE + (macro (keyword opcode) + `(define-instruction ,keyword + ((() (OFFSET (? offset) (? space sr3) (? base))) + (LONG (6 ,opcode) + (5 base) + (5 offset ASSEMBLE17:X) + (3 space) + (11 offset ASSEMBLE17:Y) + (1 0) + (1 offset ASSEMBLE17:Z))) + + (((N) (OFFSET (? offset) (? space sr3) (? base))) + (LONG (6 ,opcode) + (5 base) + (5 offset ASSEMBLE17:X) + (3 space) + (11 offset ASSEMBLE17:Y) + (1 1) + (1 offset ASSEMBLE17:Z))))))) + (BV&BLR BLR 2) + (BV&BLR BV 6) + (BE&BLE BE #x38) + (BE&BLE BLE #x39)) + +;;;; Conditional branch instructions + +#| + +Branch tensioning notes for the conditional branch instructions: + +The sequence + + combt,cc r1,r2,label + instr1 + instr2 + +becomes + + combf,cc,n r1,r2,tlabel ; pco = 0 + b label ; no nullification +tlabel instr1 + instr2 + +The sequence + + combt,cc,n r1,r2,label + instr1 + instr2 + +becomes either + + combf,cc,n r1,r2,tlabel ; pco = 0 + b,n label ; nullification +tlabel instr1 + instr2 + +when label is downstream (a forwards branch) + +or + + combf,cc,n r1,r2,tlabel ; pco = 4 + b label ; no nullification + instr1 +tlabel instr2 + +when label is upstream (a backwards branch). + +This adjusting of the nullify bits, the pc offset, etc. for tlabel are +performed by the utilities branch-extend-pco, branch-extend-disp, and +branch-extend-nullify in instr1. +|# + +;;;; Compare/compute and branch. + +(let-syntax + ((defccbranch + (macro (keyword completer opcode1 opcode2 opr1) + `(define-instruction ,keyword + (((? compl ,completer) (? ,(car opr1)) (? reg-2) (@PCO (? offset))) + (LONG (6 ,opcode1) + (5 reg-2) + (5 ,@opr1) + (3 (cadr compl)) + (11 offset ASSEMBLE12:X) + (1 (car compl)) + (1 offset ASSEMBLE12:Y))) + + (((? compl ,completer) (? ,(car opr1)) (? reg-2) (@PCR (? l))) + (VARIABLE-WIDTH + (disp `(- ,l (+ *PC* 8))) + ((#x-2000 #x1FFF) + (LONG (6 ,opcode1) + (5 reg-2) + (5 ,@opr1) + (3 (cadr compl)) + (11 disp ASSEMBLE12:X) + (1 (car compl)) + (1 disp ASSEMBLE12:Y))) + + ((() ()) + ;; See page comment above. + (LONG (6 ,opcode2) ; COMBF + (5 reg-2) + (5 ,@opr1) + (3 (cadr compl)) + (11 (branch-extend-pco disp (car compl)) ASSEMBLE12:X) + (1 1) + (1 (branch-extend-pco disp (car compl)) ASSEMBLE12:Y) + + (6 #x3a) ; B + (5 0) + (5 (branch-extend-disp disp) ASSEMBLE17:X) + (3 0) + (11 (branch-extend-disp disp) ASSEMBLE17:Y) + (1 (branch-extend-nullify disp (car compl))) + (1 (branch-extend-disp disp) ASSEMBLE17:Z))))))))) + + (define-macro (defcond name opcode1 opcode2 opr1) + `(defccbranch ,name complaltfb ,opcode1 ,opcode2 ,opr1)) + + (define-macro (defpseudo name opcode opr1) + `(defccbranch ,name complalb + (TF-adjust ,opcode (cdr compl)) + (TF-adjust-inverted ,opcode (cdr compl)) + ,opr1)) + + (defcond COMBT #x20 #x22 (reg-1)) + (defcond COMBF #x22 #x20 (reg-1)) + (defcond ADDBT #x28 #x2a (reg-1)) + (defcond ADDBF #x2a #x28 (reg-1)) + + (defcond COMIBT #x21 #x23 (immed-5 right-signed)) + (defcond COMIBF #x23 #x21 (immed-5 right-signed)) + (defcond ADDIBT #x29 #x2b (immed-5 right-signed)) + (defcond ADDIBF #x2b #x29 (immed-5 right-signed)) + + (defpseudo COMB #x20 (reg-1)) + (defpseudo ADDB #x28 (reg-1)) + (defpseudo COMIB #x21 (immed-5 right-signed)) + (defpseudo ADDIB #x29 (immed-5 right-signed))) + +;;;; Pseudo branch instructions. + +#| + +These nullify the following instruction when the branch is taken. +irrelevant of the sign of the displacement (unlike the real instructions). +If the displacement is positive, they use the nullify bit. +If the displacement is negative, they use a NOP. + + combn,cc r1,r2,label + +becomes either + + comb,cc,n r1,r2,label + +if label is downstream (forward branch) + +or + + comb,cc r1,r2,label + nop + +if label is upstream (backward branch) + +If the displacement is too large, it becomes + + comb,!cc,n r1,r2,tlabel ; pco = 0 + b,n label +tlabel + +Note: Only those currently used by the code generator are implemented. +|# + +(let-syntax + ((defccbranch + (macro (keyword completer opcode1 opcode2 opr1) + `(define-instruction ,keyword + ;; No @PCO form. + ;; This is a pseudo-instruction used by the code-generator + (((? compl ,completer) (? ,(car opr1)) (? reg-2) (@PCR (? l))) + (VARIABLE-WIDTH + (disp `(- ,l (+ *PC* 8))) + ((0 #x1FFF) + ;; Forward branch. Nullify. + (LONG (6 ,opcode1) ; COMB,cc,n + (5 reg-2) + (5 ,@opr1) + (3 (car compl)) + (11 disp ASSEMBLE12:X) + (1 1) + (1 disp ASSEMBLE12:Y))) + + ((#x-2000 -1) + ;; Backward branch. No nullification, insert NOP. + (LONG (6 ,opcode1) ; COMB,cc + (5 reg-2) + (5 ,@opr1) + (3 (car compl)) + (11 disp ASSEMBLE12:X) + (1 0) + (1 disp ASSEMBLE12:Y) + + (6 #x02) ; NOP (OR 0 0 0) + (10 #b0000000000) + (3 0) + (1 0) + (7 #x12) + (5 #b00000))) + + ((() ()) + (LONG (6 ,opcode2) ; COMB!,n + (5 reg-2) + (5 ,@opr1) + (3 (car compl)) + (11 0 ASSEMBLE12:X) + (1 1) + (1 0 ASSEMBLE12:Y) + + (6 #x3a) ; B,n + (5 0) + (5 (branch-extend-disp disp) ASSEMBLE17:X) + (3 0) + (11 (branch-extend-disp disp) ASSEMBLE17:Y) + (1 1) + (1 (branch-extend-disp disp) ASSEMBLE17:Z))))))))) + + (define-macro (defcond name opcode1 opcode2 opr1) + `(defccbranch ,name complaltf ,opcode1 ,opcode2 ,opr1)) + + (define-macro (defpseudo name opcode opr1) + `(defccbranch ,name complal + (TF-adjust ,opcode compl) + (TF-adjust-inverted ,opcode compl) + ,opr1)) + + (defcond COMIBTN #x21 #x23 (immed-5 right-signed)) + (defcond COMIBFN #x23 #x21 (immed-5 right-signed)) + + (defpseudo COMIBN #x21 (immed-5 right-signed)) + (defpseudo COMBN #x20 (reg-1))) + +;;;; Miscellaneous control + +(let-syntax + ((defmovb&bb + (macro (name opcode opr1 opr2 field2) + `(define-instruction ,name + (((? compl compledb) (? ,(car opr1)) ,@opr2 (@PCO (? offset))) + (LONG (6 ,opcode) + (5 ,field2) + (5 ,@opr1) + (3 (cdr compl)) + (11 offset ASSEMBLE12:X) + (1 (car compl)) + (1 offset ASSEMBLE12:Y))) + + (((? compl compledb) (? ,(car opr1)) ,@opr2 (@PCR (? l))) + (VARIABLE-WIDTH + (disp `(- ,l (+ *PC* 8))) + ((#x-2000 #x1FFF) + (LONG (6 ,opcode) + (5 ,field2) + (5 ,@opr1) + (3 (cdr compl)) + (11 l PC-REL ASSEMBLE12:X) + (1 (car compl)) + (1 l PC-REL ASSEMBLE12:Y))) + + ((() ()) + ;; See page comment above. + (LONG (6 ,opcode) ; MOVB + (5 ,field2) + (5 ,@opr1) + (3 (branch-extend-edcc (cdr compl))) + (11 (branch-extend-pco disp (car compl)) ASSEMBLE12:X) + (1 1) + (1 (branch-extend-pco disp (car compl)) ASSEMBLE12:Y) + + (6 #x3a) ; B + (5 0) + (5 (branch-extend-disp disp) ASSEMBLE17:X) + (3 0) + (11 (branch-extend-disp disp) ASSEMBLE17:Y) + (1 (branch-extend-nullify disp (car compl))) + (1 (branch-extend-disp disp) ASSEMBLE17:Z))))))))) + + + (defmovb&bb BVB #x30 (reg) () #b00000) + (defmovb&bb BB #x31 (reg) ((? pos)) pos) + (defmovb&bb MOVB #x32 (reg-1) ((? reg-2)) reg-2) + (defmovb&bb MOVIB #x33 (immed-5 right-signed) ((? reg-2)) reg-2)) + +;;;; Assembler pseudo-ops + +(define-instruction USHORT + ((() (? high) (? low)) + (LONG (16 high UNSIGNED) + (16 low UNSIGNED)))) + +(define-instruction WORD + ((() (? expression)) + (LONG (32 expression SIGNED)))) + +(define-instruction UWORD + ((() (? expression)) + (LONG (32 expression UNSIGNED)))) + +(define-instruction EXTERNAL-LABEL + ((() (? format-word) (@PCR (? label))) + (LONG (16 format-word UNSIGNED) + (16 label BLOCK-OFFSET))) + + ((() (? format-word) (@PCO (? offset))) + (LONG (16 format-word UNSIGNED) + (16 offset UNSIGNED)))) + +(define-instruction PCR-HOOK + ((() (? target) + (OFFSET (? offset) (? space sr3) (? base)) + (@PCR (? label))) + (VARIABLE-WIDTH + (disp `(- ,label (+ *PC* 8))) + ((#x-2000 #x1FFF) + (LONG + ;; (BLE () (OFFSET ,offset ,space ,base)) + (6 #x39) + (5 base) + (5 offset ASSEMBLE17:X) + (3 space) + (11 offset ASSEMBLE17:Y) + (1 0) + (1 offset ASSEMBLE17:Z) + ;; (LDO () (OFFSET ,disp 0 31) ,target) + (6 #x0D) + (5 31) + (5 target) + (2 #b00) + (14 disp RIGHT-SIGNED))) + ((() ()) + (LONG + ;; (LDIL () L$disp-8 target) + (6 #x08) + (5 1) + (21 (quotient (- disp 8) #x800) ASSEMBLE21:X) + ;; (LDO () (OFFSET R$disp-4 0 1) target) + (6 #x0D) + (5 1) + (5 1) + (2 #b00) + (14 (remainder (- disp 8) #x800) RIGHT-SIGNED) + ;; (BLE () (OFFSET ,offset ,space ,base)) + (6 #x39) + (5 base) + (5 offset ASSEMBLE17:X) + (3 space) + (11 offset ASSEMBLE17:Y) + (1 0) + (1 offset ASSEMBLE17:Z) + ;; (ADD () 31 1 target) + (6 #x02) + (5 31) + (5 1) + (3 0) + (1 0) + (7 #x30) + (5 target)))))) \ No newline at end of file diff --git a/v8/src/compiler/machines/spectrum/instr3.scm b/v8/src/compiler/machines/spectrum/instr3.scm new file mode 100644 index 000000000..cb7cf653b --- /dev/null +++ b/v8/src/compiler/machines/spectrum/instr3.scm @@ -0,0 +1,473 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/spectrum/instr3.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ + +Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; HP Spectrum Instruction Set Description +;;; Originally from Walt Hill, who did the hard part. + +(declare (usual-integrations)) + +;;;; Computation instructions + +(let-syntax ((arith-logical + (macro (keyword extn) + `(define-instruction ,keyword + (((? compl complal) (? source-reg1) (? source-reg2) + (? target-reg)) + (LONG (6 #x02) + (5 source-reg2) + (5 source-reg1) + (3 (car compl)) + (1 (cadr compl)) + (7 ,extn) + (5 target-reg))))))) + + (arith-logical ANDCM #x00) + (arith-logical AND #x10) + (arith-logical OR #x12) + (arith-logical XOR #x14) + (arith-logical UXOR #x1c) + (arith-logical SUB #x20) + (arith-logical DS #x22) + (arith-logical SUBT #x26) + (arith-logical SUBB #x28) + (arith-logical ADD #x30) + (arith-logical SH1ADD #x32) + (arith-logical SH2ADD #x34) + (arith-logical SH3ADD #x36) + (arith-logical ADDC #x38) + (arith-logical COMCLR #x44) + (arith-logical UADDCM #x4c) + (arith-logical UADDCMT #x4e) + (arith-logical ADDL #x50) + (arith-logical SH1ADDL #x52) + (arith-logical SH2ADDL #x54) + (arith-logical SH3ADDL #x56) + (arith-logical SUBO #x60) + (arith-logical SUBTO #x66) + (arith-logical SUBBO #x68) + (arith-logical ADDO #x70) + (arith-logical SH1ADDO #x72) + (arith-logical SH2ADDO #x74) + (arith-logical SH3ADDO #x76) + (arith-logical ADDCO #x78)) + +;; WH Maybe someday. (Spec-DefOpcode DCOR 2048 DecimalCorrect) % 02 +;; (Spec-DefOpcode IDCOR 2048 DecimalCorrect) % 02 + +;;;; Assembler pseudo-ops + +(define-instruction NOP ; pseudo-op: (OR complt 0 0 0) + (((? compl complal)) + (LONG (6 #x02) + (10 #b0000000000) + (3 (car compl)) + (1 (cadr compl)) + (7 #x12) + (5 #b00000)))) + +(define-instruction COPY ; pseudo-op (OR complt 0 s t) + (((? compl complal) (? source-reg) (? target-reg)) + (LONG (6 #x02) + (5 #b00000) + (5 source-reg) + (3 (car compl)) + (1 (cadr compl)) + (7 #x12) + (5 target-reg)))) + +(define-instruction SKIP ; pseudo-op (ADD complt 0 0 0) + (((? compl complal)) + (LONG (6 #x02) + (10 #b0000000000) + (3 (car compl)) + (1 (cadr compl)) + (7 #x30) + (5 #b00000)))) + +(let-syntax ((immed-arith + (macro (keyword opcode extn) + `(define-instruction ,keyword + (((? compl complal) (? immed-11) (? source-reg) + (? target-reg)) + (LONG (6 ,opcode) + (5 source-reg) + (5 target-reg) + (3 (car compl)) + (1 (cadr compl)) + (1 ,extn) + (11 immed-11 RIGHT-SIGNED))))))) + (immed-arith ADDI #x2d 0) + (immed-arith ADDIO #x2d 1) + (immed-arith ADDIT #x2c 0) + (immed-arith ADDITO #x2c 1) + (immed-arith SUBI #x25 0) + (immed-arith SUBIO #x25 1) + (immed-arith COMICLR #x24 0)) + +(define-instruction VSHD + (((? compl compled) (? source-reg1) (? source-reg2) + (? target-reg)) + (LONG (6 #x34) + (5 source-reg2) + (5 source-reg1) + (3 compl) + (3 0) + (5 #b00000) + (5 target-reg)))) + +(define-instruction SHD + (((? compl compled) (? source-reg1) (? source-reg2) (? pos) + (? target-reg)) + (LONG (6 #x34) + (5 source-reg2) + (5 source-reg1) + (3 compl) + (3 2) + (5 (- 31 pos)) + (5 target-reg)))) + +(let-syntax ((extr (macro (keyword extn) + `(define-instruction ,keyword + (((? compl compled) (? source-reg) (? pos) (? len) + (? target-reg)) + (LONG (6 #x34) + (5 source-reg) + (5 target-reg) + (3 compl) + (3 ,extn) + (5 pos) + (5 (- 32 len))))))) + (vextr (macro (keyword extn) + `(define-instruction ,keyword + (((? compl compled) (? source-reg) (? len) + (? target-reg)) + (LONG (6 #x34) + (5 source-reg) + (5 target-reg) + (3 compl) + (3 ,extn) + (5 #b00000) + (5 (- 32 len)))))))) + (extr EXTRU 6) + (extr EXTRS 7) + (vextr VEXTRU 4) + (vextr VEXTRS 5)) + +(let-syntax ((depos + (macro (keyword extn) + `(define-instruction ,keyword + (((? compl compled) (? source-reg) (? pos) (? len) + (? target-reg)) + (LONG (6 #x35) + (5 target-reg) + (5 source-reg) + (3 compl) + (3 ,extn) + (5 (- 31 pos)) + (5 (- 32 len))))))) + (vdepos + (macro (keyword extn) + `(define-instruction ,keyword + (((? compl compled) (? source-reg) (? len) + (? target-reg)) + (LONG (6 #x35) + (5 target-reg) + (5 source-reg) + (3 compl) + (3 ,extn) + (5 #b00000) + (5 (- 32 len))))))) + (idepos + (macro (keyword extn) + `(define-instruction ,keyword + (((? compl compled) (? immed) (? pos) (? len) + (? target-reg)) + (LONG (6 #x35) + (5 target-reg) + (5 immed RIGHT-SIGNED) + (3 compl) + (3 ,extn) + (5 (- 31 pos)) + (5 (- 32 len))))))) + + (videpos + (macro (keyword extn) + `(define-instruction ,keyword + (((? compl compled) (? immed) (? len) + (? target-reg)) + (LONG (6 #x35) + (5 target-reg) + (5 immed RIGHT-SIGNED) + (3 compl) + (3 ,extn) + (5 #b00000) + (5 (- 32 len)))))))) + + (idepos DEPI 7) + (idepos ZDEPI 6) + (videpos VDEPI 5) + (videpos ZVDEPI 4) + (depos DEP 3) + (depos ZDEP 2) + (vdepos VDEP 1) + (vdepos ZVDEP 0)) + +(let-syntax ((Probe-Read-Write + (macro (keyword extn) + `(define-instruction ,keyword + ((() (OFFSET 0 (? space) (? base)) (? priv-reg) + (? target-reg)) + (LONG (6 1) + (5 base) + (5 priv-reg) + (2 space) + (8 ,extn) + (1 #b0) + (5 target-reg))))))) + (Probe-Read-Write PROBER #x46) + (Probe-Read-Write PROBEW #x47) + (Probe-Read-Write PROBERI #xc6) + (Probe-Read-Write PROBEWI #xc7)) + +(define-instruction BREAK + ((() (? immed-5) (? immed-13)) + (LONG (6 #b000000) + (13 immed-13) + (8 #b00000000) + (5 immed-5)))) + +(define-instruction LDSID + ((() (OFFSET 0 (? space) (? base)) (? target-reg)) + (LONG (6 #b000000) + (5 base) + (5 #b00000) + (2 space) + (1 #b0) + (8 #x85) + (5 target-reg)))) + +(define-instruction MTSP + ((() (? source-reg) (? space-reg sr3)) + (LONG (6 #b000000) + (5 #b00000) + (5 source-reg) + (3 space-reg) + (8 #xc1) + (5 #b00000)))) + +(define-instruction MTCTL + ((() (? source-reg) (? control-reg)) + (LONG (6 #b000000) + (5 control-reg) + (5 source-reg) + (3 #b000) + (8 #xc2) + (5 #b00000)))) + +(define-instruction MTSAR ; pseudo-oop (MTCLT () source 11) + ((() (? source-reg)) + (LONG (6 #b000000) + (5 #x0b) + (5 source-reg) + (3 #b000) + (8 #xc2) + (5 #b00000)))) + +(define-instruction MFSP + ((() (? space-reg sr3) (? target-reg)) + (LONG (16 #b0000000000000000) + (3 space-reg) + (8 #x25) + (5 target-reg)))) + +(define-instruction MFCTL + ((() (? control-reg) (? target-reg)) + (LONG (6 #b000000) + (5 control-reg) + (5 #b00000) + (3 #b000) + (8 #x45) + (5 target-reg)))) + +(define-instruction SYNC + ((()) + (LONG (16 #b0000000000000000) + (3 #b000) + (8 #x20) + (5 #b00000)))) + +#| +Missing: + +LPA +LHA +PDTLB +PITLB +PDTLBE +PITLBE +IDTLBA +IITLBA +IDTLBP +IITLBP +DIAG + +|# + +(let-syntax ((floatarith-1 + (macro (keyword extn-a extn-b) + `(define-instruction ,keyword + ((((? fmt fpformat)) (? source-reg) (? target-reg)) + (LONG (6 #x0c) + (5 source-reg) + (5 #b00000) + (3 ,extn-a) + (2 fmt) + (2 ,extn-b) + (4 #b0000) + (5 target-reg)))))) + (floatarith-2 + (macro (keyword extn-a extn-b) + `(define-instruction ,keyword + ((((? fmt fpformat)) (? source-reg1) (? source-reg2) + (? target-reg)) + (LONG (6 #x0c) + (5 source-reg1) + (5 source-reg2) + (3 ,extn-a) + (2 fmt) + (2 ,extn-b) + (4 #b0000) + (5 target-reg))))))) + + (floatarith-2 FADD 0 3) + (floatarith-2 FSUB 1 3) + (floatarith-2 FMPY 2 3) + (floatarith-2 FDIV 3 3) + (floatarith-1 FSQRT 4 0) + (floatarith-1 FABS 3 0) + (floatarith-2 FREM 4 3) + (floatarith-1 FRND 5 0) + (floatarith-1 FCPY 2 0)) + +(define-instruction FCMP + ((((? condition fpcond) (? fmt fpformat)) (? reg1) (? reg2)) + (LONG (6 #x0c) + (5 reg1) + (5 reg2) + (3 #b000) + (2 fmt) + (6 #b100000) + (5 condition)))) + +(let-syntax ((fpconvert + (macro (keyword extn) + `(define-instruction ,keyword + ((((? sf fpformat) (? df fpformat)) + (? source-reg1) + (? reg-t)) + (LONG (6 #x0c) + (5 source-reg1) + (4 #b0000) + (2 ,extn) + (2 df) + (2 sf) + (6 #b010000) + (5 reg-t))))))) + (fpconvert FCNVFF 0) + (fpconvert FCNVFX 1) + (fpconvert FCNVXF 2) + (fpconvert FCNVFXT 3)) + +(define-instruction FTEST + ((()) + (LONG (6 #x0c) + (10 #b0000000000) + (16 #b0010010000100000)))) + +#| +;; What SFU is this? -- Jinx + +;; WARNING The SFU instruction code below should be +;; tested before use. WLH 11/18/86 + +(let-syntax ((multdiv + (macro (keyword extn) + `(define-instruction ,keyword + ((() (? reg-1) (? reg-2)) + (LONG (6 #x04) + (5 reg-2) + (5 reg-1) + (5 ,extn) + (11 #b11000000000))))))) + (multdiv MPYS #x08) + (multdiv MPYU #x0a) + (multdiv MPYSCV #x0c) + (multdiv MPYUCV #x0e) + (multdiv MPYACCS #x0d) + (multdiv MPYACCU #x0f) + (multdiv DIVSIR #x00) + (multdiv DIVSFR #x04) + (multdiv DIVUIR #x03) + (multdiv DIVUFR #x07) + (multdiv DIVSIM #x01) + (multdiv DIVSFM #x05) + (multdiv MDRR #x06)) + +(define-instruction MDRO + ((() (? reg)) + (LONG (6 #x04) + (5 reg) + (5 #b00000) + (16 #b1000000000000000)))) + +(let-syntax ((multdivresult + (macro (keyword extn-a extn-b) + `(define-instruction ,keyword + ((() (? reg-t)) + (LONG (6 #x04) + (10 #b0000000000) + (5 ,extn-a) + (5 #b01000) + (1 ,extn-b) + (5 reg-t))))))) + (multdivresult MDLO 4 0) + (multdivresult MDLNV 4 1) + (multdivresult MDLV 5 1) + (multdivresult MDL 5 0) + (multdivresult MDHO 6 0) + (multdivresult MDHNV 6 1) + (multdivresult MDHV 7 1) + (multdivresult MDH 7 0) + (multdivresult MDSFUID 0 0)) +|# \ No newline at end of file diff --git a/v8/src/compiler/machines/spectrum/lapgen.scm b/v8/src/compiler/machines/spectrum/lapgen.scm new file mode 100644 index 000000000..0c32cc2a7 --- /dev/null +++ b/v8/src/compiler/machines/spectrum/lapgen.scm @@ -0,0 +1,858 @@ +#| -*-Scheme-*- + +$Id: lapgen.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Rules for HPPA. Shared utilities. +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +;;;; Register-Allocator Interface + +(define (register->register-transfer source target) + (if (not (register-types-compatible? source target)) + (error "Moving between incompatible register types" source target)) + (case (register-type source) + ((GENERAL) (copy source target)) + ((FLOAT) (fp-copy source target)) + (else (error "unknown register type" source)))) + +(define (home->register-transfer source target) + ;;! Until untagged-fixnums allowed object<->fixnum conversions to be + ;; elided the following test was not necessary because there would always + ;; be a conversion inbetween `thinking' about a register's home and + ;; moving the result to the return-value register. The real issue + ;; is that the return-value register always lives in a machine + ;; register and is never stored like the other pseudo-registers. + ;; ?Perhaps this behaviour ought to be (or is?) codified elsewhere? + (if (machine-register? source) + (register->register-transfer source target) + (memory->register-transfer (pseudo-register-displacement source) + regnum:regs-pointer + target))) + +(define (register->home-transfer source target) + ;;! See above. + (if (machine-register? target) + (register->register-transfer source target) + (register->memory-transfer source + (pseudo-register-displacement target) + regnum:regs-pointer))) + +(define (reference->register-transfer source target) + (case (ea/mode source) + ((GR) + (copy (register-ea/register source) target)) + ((FPR) + (fp-copy (fpr->float-register (register-ea/register source)) target)) + ((OFFSET) + (memory->register-transfer (offset-ea/offset source) + (offset-ea/register source) + target)) + (else + (error "unknown effective-address mode" source)))) + +(define (pseudo-register-home register) + ;; Register block consists of 16 4-byte registers followed by 256 + ;; 8-byte temporaries. + (INST-EA (OFFSET ,(pseudo-register-displacement register) + 0 + ,regnum:regs-pointer))) + +(define-integrable (sort-machine-registers registers) + registers) + +;; *** +;; Note: fp16-fp31 only exist on PA-RISC 1.1 or later. +;; If compiling for PA-RISC 1.0, truncate this +;; list after fp15. +;; *** + +(define available-machine-registers + ;; g1 removed from this list since it is the target of ADDIL, + ;; needed to expand some rules. g31 may want to be removed + ;; too. + (list + ;; g0 g1 g2 g3 g4 g5 + g6 g7 g8 g9 + g10 g11 g12 g13 g14 g15 g16 g17 + ;; g18: holds '() + ;; g19 g20 g21 g22 + g23 g24 ;; g25 + g26 + ;; g27 + g28 g29 + ;; g30 + g31 + ;; fp0 fp1 fp2 fp3 + fp12 fp13 fp14 fp15 + fp4 fp5 fp6 fp7 fp8 fp9 fp10 fp11 + ;; The following are only available on newer processors + fp16 fp17 fp18 fp19 fp20 fp21 fp22 fp23 + fp24 fp25 fp26 fp27 fp28 fp29 fp30 fp31 + )) + +(define-integrable (float-register? register) + (eq? (register-type register) 'FLOAT)) + +(define-integrable (general-register? register) + (eq? (register-type register) 'GENERAL)) + +(define-integrable (word-register? register) + (eq? (register-type register) 'GENERAL)) + +(define (register-types-compatible? type1 type2) + (boolean=? (eq? type1 'FLOAT) (eq? type2 'FLOAT))) + +(define (register-type register) + (cond ((machine-register? register) + (vector-ref + '#(GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL + GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL + GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL + GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL + FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT + FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT + FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT + FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT) + register)) + ((register-value-class=word? register) 'GENERAL) + ((register-value-class=float? register) 'FLOAT) + (else (error "unable to determine register type" register)))) + +(define register-reference + (let ((references (make-vector number-of-machine-registers))) + (let loop ((register 0)) + (if (< register 32) + (begin + (vector-set! references register (INST-EA (GR ,register))) + (loop (1+ register))))) + (let loop ((register 32) (fpr 0)) + (if (< register 64) + (begin + (vector-set! references register (INST-EA (FPR ,fpr))) + (loop (1+ register) (1+ fpr))))) + (lambda (register) + (vector-ref references register)))) + +;;;; Useful Cliches + +(define (memory->register-transfer offset base target) + (case (register-type target) + ((GENERAL) (load-word offset base target)) + ((FLOAT) (fp-load-doubleword offset base target)) + (else (error "unknown register type" target)))) + +(define (register->memory-transfer source offset base) + (case (register-type source) + ((GENERAL) (store-word source offset base)) + ((FLOAT) (fp-store-doubleword source offset base)) + (else (error "unknown register type" source)))) + +(define (load-constant constant target) + ;; Load a Scheme constant into a machine register. + (if (or (eq? constant '()) (eq? constant #F)) + (warn "load-constant: register constant slipped through:" constant)) + (if (non-pointer-object? constant) + (load-immediate (non-pointer->literal constant) target) + (load-pc-relative (constant->label constant) target 'CONSTANT))) + +(define (load-non-pointer type datum target) + ;; Load a Scheme non-pointer constant, defined by type and datum, + ;; into a machine register. + (load-immediate (make-non-pointer-literal type datum) target)) + +(define (non-pointer->literal constant) + (make-non-pointer-literal (target-object-type constant) + (careful-object-datum constant))) + +(define-integrable (make-non-pointer-literal type datum) + (let ((unsigned-value (+ (* type type-scale-factor) datum))) + (if (<= unsigned-value #x7FFFFFFF) + unsigned-value + (- unsigned-value #x100000000)))) + +(define-integrable type-scale-factor + ;; (expt 2 scheme-datum-width) *** + #x4000000) + +(define-integrable (deposit-type type target) + (adjust-type #F type target)) + +;;;; Regularized Machine Instructions + +(define (copy r t) + (if (= r t) + (LAP) + (LAP (COPY () ,r ,t)))) + +(define-integrable ldil-scale + ;; (expt 2 11) *** + 2048) + +(define (load-immediate i t) + (if (fits-in-14-bits-signed? i) + (LAP (LDI () ,i ,t)) + (let ((split (integer-divide i ldil-scale))) + (LAP (LDIL () ,(integer-divide-quotient split) ,t) + ,@(let ((r%i (integer-divide-remainder split))) + (if (zero? r%i) + (LAP) + (LAP (LDO () (OFFSET ,r%i 0 ,t) ,t)))))))) + +(define (deposit-immediate i p len t) + (cond ((fits-in-5-bits-signed? i) + (LAP (DEPI () ,i ,p ,len ,t))) + ((and (<= len 5) + (fix:fixnum? i)) + (LAP (DEPI () ,(fix:- (fix:xor (fix:and i #b11111) #b10000) #b10000) + ,p ,len ,t))) + ((and (= len scheme-type-width) + (fits-in-5-bits-signed? (- i (1+ max-type-code)))) + (LAP (DEPI () ,(- i (1+ max-type-code)) ,p ,len ,t))) + ;;((machine-register-containing-value-satifying + ;; (lambda (v) (and (fix:fixnum? v) + ;; (= i (fix:and v max-type-code))))) + ;; => (lambda (reg) + ;; (LAP (DEP () ,reg ,p ,len ,t)))) + ((= i quad-mask-value) + (LAP (DEP () ,regnum:quad-bitmask ,p ,len ,t))) + (else + (LAP ,@(load-immediate i regnum:addil-result) + (DEP () ,regnum:addil-result ,p ,len ,t))))) + +(define (load-offset d b t) + (cond ((and (zero? d) (= b t)) + (LAP)) + ((fits-in-14-bits-signed? d) + (LAP (LDO () (OFFSET ,d 0 ,b) ,t))) + (else + (let ((split (integer-divide d ldil-scale))) + (LAP (ADDIL () ,(integer-divide-quotient split) ,b) + (LDO () (OFFSET ,(integer-divide-remainder split) 0 1) ,t)))))) + +(define (load-word d b t) + (if (fits-in-14-bits-signed? d) + (LAP (LDW () (OFFSET ,d 0 ,b) ,t)) + (let ((split (integer-divide d ldil-scale))) + (LAP (ADDIL () ,(integer-divide-quotient split) ,b) + (LDW () (OFFSET ,(integer-divide-remainder split) 0 1) ,t))))) + +(define (load-byte d b t) + (if (fits-in-14-bits-signed? d) + (LAP (LDB () (OFFSET ,d 0 ,b) ,t)) + (let ((split (integer-divide d ldil-scale))) + (LAP (ADDIL () ,(integer-divide-quotient split) ,b) + (LDB () (OFFSET ,(integer-divide-remainder split) 0 1) ,t))))) + +(define (store-word b d t) + (if (fits-in-14-bits-signed? d) + (LAP (STW () ,b (OFFSET ,d 0 ,t))) + (let ((split (integer-divide d ldil-scale))) + (LAP (ADDIL () ,(integer-divide-quotient split) ,t) + (STW () ,b (OFFSET ,(integer-divide-remainder split) 0 1)))))) + +(define (store-byte b d t) + (if (fits-in-14-bits-signed? d) + (LAP (STB () ,b (OFFSET ,d 0 ,t))) + (let ((split (integer-divide d ldil-scale))) + (LAP (ADDIL () ,(integer-divide-quotient split) ,t) + (STB () ,b (OFFSET ,(integer-divide-remainder split) 0 1)))))) + +(define (fp-copy r t) + (if (= r t) + (LAP) + (LAP (FCPY (DBL) ,(float-register->fpr r) ,(float-register->fpr t))))) + +(define (fp-load-doubleword d b t) + (let ((t (float-register->fpr t))) + (if (fits-in-5-bits-signed? d) + (LAP (FLDDS () (OFFSET ,d 0 ,b) ,t)) + (LAP ,@(load-offset d b regnum:addil-result) + (FLDDS () (OFFSET 0 0 ,regnum:addil-result) ,t))))) + +(define (fp-store-doubleword r d b) + (let ((r (float-register->fpr r))) + (if (fits-in-5-bits-signed? d) + (LAP (FSTDS () ,r (OFFSET ,d 0 ,b))) + (LAP ,@(load-offset d b regnum:addil-result) + (FSTDS () ,r (OFFSET 0 0 ,regnum:addil-result)))))) + +#| +(define (load-pc-relative label target type) + type ; ignored + ;; Load a pc-relative location's contents into a machine register. + ;; This assumes that the offset fits in 14 bits! + ;; We should have a pseudo-op for LDW that does some "branch" tensioning. + (LAP (BL () ,regnum:addil-result (@PCO 0)) + ;; Clear the privilege level, making this a memory address. + (DEP () 0 31 2 ,regnum:addil-result) + (LDW () (OFFSET (- ,label *PC*) 0 ,regnum:addil-result) ,target))) + +(define (load-pc-relative-address label target type) + type ; ignored + ;; Load a pc-relative address into a machine register. + ;; This assumes that the offset fits in 14 bits! + ;; We should have a pseudo-op for LDO that does some "branch" tensioning. + (LAP (BL () ,regnum:addil-result (@PCO 0)) + ;; Clear the privilege level, making this a memory address. + (DEP () 0 31 2 ,regnum:addil-result) + (LDO () (OFFSET (- ,label *PC*) 0 ,regnum:addil-result) ,target))) +|# + +;; These versions of load-pc-... remember what they obtain, to avoid +;; doing the sequence multiple times. +;; In addition, they assume that the code is running in the least +;; privilege, and avoid the DEP in the sequences above. + +(define-integrable *privilege-level* 3) + +(define-integrable (close? label label*) + ;; Heuristic + label label* ; ignored + compiler:compile-by-procedures?) + +(define (load-pc-relative label target type) + (load-pc-relative-internal label target type + (lambda (offset base target) + (LAP (LDW () (OFFSET ,offset 0 ,base) + ,target))))) + +(define (load-pc-relative-address label target type) + (load-pc-relative-internal label target type + (lambda (offset base target) + (LAP (LDO () (OFFSET ,offset 0 ,base) + ,target))))) + +(define (load-pc-relative-internal label target type gen) + (with-values (lambda () (get-typed-label type)) + (lambda (label* alias type*) + (define (closer label* alias) + (let ((temp (standard-temporary!))) + (set-typed-label! type label temp) + (LAP (LDO () (OFFSET (- ,label ,label*) 0 ,alias) ,temp) + ,@(gen 0 temp target)))) + + (cond ((not label*) + (let ((temp (standard-temporary!)) + (here (generate-label))) + (let ((value `(+ ,here ,(+ 8 *privilege-level*)))) + (set-typed-label! 'CODE value temp) + (LAP (LABEL ,here) + (BL () ,temp (@PCO 0)) + ,@(if (or (eq? type 'CODE) (close? label label*)) + (gen (INST-EA (- ,label ,value)) temp target) + (closer value temp)))))) + ((or (eq? type* type) (close? label label*)) + (gen (INST-EA (- ,label ,label*)) alias target)) + (else + (closer label* alias)))))) + +;;; Typed labels provide further optimization. There are two types, +;;; CODE and CONSTANT, that say whether the label is located in the +;;; code block or the constants block of the output. Statistically, +;;; a label is likely to be closer to another label of the same type +;;; than to a label of the other type. + +(define (get-typed-label type) + (let ((entries (register-map-labels *register-map* 'GENERAL))) + (let loop ((entries* entries)) + (cond ((null? entries*) + ;; If no entries of the given type, use any entry that is + ;; available. + (let loop ((entries entries)) + (cond ((null? entries) + (values false false false)) + ((pair? (caar entries)) + (values (cdaar entries) (cadar entries) (caaar entries))) + (else + (loop (cdr entries)))))) + ((and (pair? (caar entries*)) + (eq? type (caaar entries*))) + (values (cdaar entries*) (cadar entries*) type)) + (else + (loop (cdr entries*))))))) + +(define (set-typed-label! type label alias) + (set! *register-map* + (set-machine-register-label *register-map* alias (cons type label))) + unspecific) + +;; COMIBTN, COMIBFN, and COMBN are pseudo-instructions that nullify +;; the following instruction when the branch is taken. Since COMIBT, +;; etc. nullify according to the sign of the displacement, the branch +;; tensioner inserts NOPs as necessary (backward branches). + +(define (compare-immediate cc i r2) + (cond ((zero? i) + (compare cc 0 r2)) + ((fits-in-5-bits-signed? i) + (let* ((inverted? (memq cc '(TR <> >= > >>= >> NSV EV + LTGT GTEQ GT GTGTEQ GTGT))) + (cc (if inverted? (invert-condition cc) cc)) + (set-branches! + (lambda (if-true if-false) + (if inverted? + (set-current-branches! if-false if-true) + (set-current-branches! if-true if-false))))) + + (set-branches! + (lambda (label) + (LAP (COMIBTN (,cc) ,i ,r2 (@PCR ,label)))) + (lambda (label) + (LAP (COMIBFN (,cc) ,i ,r2 (@PCR ,label))))) + (LAP))) + ((fits-in-11-bits-signed? i) + (set-current-branches! + (lambda (label) + (LAP (COMICLR (,(invert-condition cc)) ,i ,r2 0) + (B (N) (@PCR ,label)))) + (lambda (label) + (LAP (COMICLR (,cc) ,i ,r2 0) + (B (N) (@PCR ,label))))) + (LAP)) + (else + (let ((temp (standard-temporary!))) + (LAP ,@(load-immediate i temp) + ,@(compare cc temp r2)))))) + +(define (compare condition r1 r2) + (set-current-branches! + (lambda (label) + (LAP (COMBN (,condition) ,r1 ,r2 (@PCR ,label)))) + (lambda (label) + (LAP (COMBN (,(invert-condition condition)) ,r1 ,r2 (@PCR ,label))))) + (LAP)) + +;;;; Conditions + +(define (invert-condition condition) + (let ((place (assq condition condition-inversion-table))) + (if (not place) + (error "unknown condition" condition)) + (cadr place))) + +(define (invert-condition-noncommutative condition) + (let ((place (assq condition condition-inversion-table))) + (if (not place) + (error "unknown condition" condition)) + (caddr place))) + +(define condition-inversion-table + '((= <> =) + (< >= >) + (> <= <) + (NUV UV NUV) + (TR NV TR) + (<< >>= >>) + (>> <<= <<) + (<> = <>) + (<= > >=) + (>= < <=) + (<<= >> >>=) + (>>= << <<=) + (NV TR NV) + (EQ LTGT EQ) + (LT GTEQ GT) + (SBZ NBZ SBZ) + (LTEQ GT GTEQ) + (SHZ NHZ SHZ) + (LTLT GTGTEQ GTGT) + (SDC NDC SDC) + (LTLTEQ GTGT GTGTEQ) + (ZNV VNZ ZNV) + (SV NSV SV) + (SBC NBC SBC) + (OD EV OD) + (SHC NHC SHC) + (LTGT EQ LTGT) + (GTEQ LT LTEQ) + (NBZ SBZ NBZ) + (GT LTEQ LT) + (NHZ SHZ NHZ) + (GTGTEQ LTLT LTLTEQ) + (UV NUV UV) + (NDC SDC NDC) + (GTGT LTLTEQ LTLT) + (VNZ ZNV NVZ) + (NSV SV NSV) + (NBC SBC NBC) + (EV OD EV) + (NHC SHC NHC))) + +;;;; Miscellaneous + +(define-integrable (object->datum src tgt) + (LAP (ZDEP () ,src 31 ,scheme-datum-width ,tgt))) + +(define (adjust-type from to reg) + ;; FROM is either a typecode if it is known that reg has that typecode, + ;; else it is #F. TO is a constant desired typecode + (cond ((eqv? from to) + (LAP)) + ((or (false? from) + (fits-in-5-bits-signed? to) + (and (= scheme-type-width 6) + (<= (- max-type-code 15) to max-type-code))) + (deposit-immediate TO + (-1+ scheme-type-width) + scheme-type-width + reg)) + (;; the msb is the same in both so we dont need to change it and the + ;; remaining bits can be set with a single DEPI + ;; this happens with values of the form #01xxxx + (and (= scheme-type-width 6) + (fix:= 0 (fix:and (fix:xor from to) #b100000))) + (deposit-immediate (fix:and TO #b011111) + (-1+ scheme-type-width) + (-1+ scheme-type-width) + reg)) + (;; If the lsb is the same in both we can just set the msbs + (and (= scheme-type-width 6) + (fix:= 0 (fix:and (fix:xor from to) #b000001))) + (deposit-immediate (fix:lsh TO -1) + (- scheme-type-width 2) + (-1+ scheme-type-width) + reg)) + (else + (deposit-immediate TO + (-1+ scheme-type-width) + scheme-type-width + reg)))) + +(define-integrable (object->address reg) + (adjust-type #F quad-mask-value reg)) + +(define-integrable (object->type src tgt) + (LAP (EXTRU () ,src ,(-1+ scheme-type-width) ,scheme-type-width ,tgt))) + +(define (standard-unary-conversion source target conversion) + ;; `source' is any register, `target' a pseudo register. + (let ((source (standard-source! source))) + (conversion source (standard-target! target)))) + +(define (standard-binary-conversion source1 source2 target conversion) + ;; The sources are any register, `target' a pseudo register. + (let ((source1 (standard-source! source1)) + (source2 (standard-source! source2))) + (conversion source1 source2 (standard-target! target)))) + +(define (standard-source! register) + (load-alias-register! register (register-type register))) + +(define (standard-target! register) + (delete-dead-registers!) + (allocate-alias-register! register (register-type register))) + +(define-integrable (standard-temporary!) + (allocate-temporary-register! 'GENERAL)) + +(define (standard-move-to-target! source target) + (move-to-alias-register! source (register-type source) target)) + +(define (standard-move-to-temporary! source) + (move-to-temporary-register! source (register-type source))) + +(define (register-expression expression) + (case (rtl:expression-type expression) + ((REGISTER) + (rtl:register-number expression)) + ((CONSTANT) + (let ((object (rtl:constant-value expression))) + (cond ((and (zero? (object-type object)) + (zero? (object-datum object))) + 0) + ((eq? object #F) + regnum:false-value) + ((eq? object '()) + regnum:empty-list) + (else + false)))) + ((MACHINE-CONSTANT) + (let ((value (rtl:machine-constant-value expression))) + (cond ((zero? value) + 0) + (else + false)))) + ((CONS-POINTER) + (and (let ((type (rtl:cons-pointer-type expression))) + (and (rtl:machine-constant? type) + (zero? (rtl:machine-constant-value type)))) + (let ((datum (rtl:cons-pointer-datum expression))) + (and (rtl:machine-constant? datum) + (zero? (rtl:machine-constant-value datum)))) + 0)) + (else false))) + +(define (define-arithmetic-method operator methods method) + (let ((entry (assq operator (cdr methods)))) + (if entry + (set-cdr! entry method) + (set-cdr! methods (cons (cons operator method) (cdr methods))))) + operator) + +(define (lookup-arithmetic-method operator methods) + (cdr (or (assq operator (cdr methods)) + (error "Unknown operator" operator)))) + +(define-integrable (arithmetic-method? operator methods) + (assq operator (cdr methods))) + +(define (fits-in-5-bits-signed? value) + (<= #x-10 value #xF)) + +(define (fits-in-11-bits-signed? value) + (<= #x-400 value #x3FF)) + +(define (fits-in-14-bits-signed? value) + (<= #x-2000 value #x1FFF)) + +(define-integrable (ea/mode ea) (car ea)) +(define-integrable (register-ea/register ea) (cadr ea)) +(define-integrable (offset-ea/offset ea) (cadr ea)) +(define-integrable (offset-ea/space ea) (caddr ea)) +(define-integrable (offset-ea/register ea) (cadddr ea)) + +(define (pseudo-register-displacement register) + ;; Register block consists of 16 4-byte registers followed by 256 + ;; 8-byte temporaries. + (+ (* 4 16) (* 8 (register-renumber register)))) + +(define (pseudo-register-offset register) + ;; Like above, but in words. + ;;dubious. using register-renumber expects an bound *current-rgraph* + (+ 16 (* 2 register))) + +(define-integrable (float-register->fpr register) + ;; Float registers are represented by 32 through 47/63 in the RTL, + ;; corresponding to registers 0 through 15/31 in the machine. + (- register 32)) + +(define-integrable (fpr->float-register register) + (+ register 32)) + +(define-integrable reg:memtop + (INST-EA (OFFSET #x0000 0 ,regnum:regs-pointer))) + +(define-integrable reg:environment + (INST-EA (OFFSET #x000C 0 ,regnum:regs-pointer))) + +(define-integrable reg:lexpr-primitive-arity + (INST-EA (OFFSET #x001C 0 ,regnum:regs-pointer))) + +(define-integrable reg:stack-guard + (INST-EA (OFFSET #x002C 0 ,regnum:regs-pointer))) + +(define (lap:make-label-statement label) + (LAP (LABEL ,label))) + +(define (lap:make-unconditional-branch label) + (LAP (B (N) (@PCR ,label)))) + +(define (lap:make-entry-point label block-start-label) + block-start-label + (LAP (ENTRY-POINT ,label) + ,@(make-external-label expression-code-word label))) + +;;;; Codes and Hooks + +(let-syntax ((define-codes + (macro (start . names) + (define (loop names index assocs) + (if (null? names) + '() ;;`((DEFINE CODE:COMPILER-XXX-ALIST ',assocs)) + (cons `(DEFINE-INTEGRABLE + ,(symbol-append 'CODE:COMPILER- + (car names)) + ,index) + (loop (cdr names) (1+ index) + (cons (cons index (car names)) assocs))))) + `(BEGIN ,@(loop names start '()))))) + ;; Remember to duplicate changes to this list to the copy in dassm1.scm + (define-codes #x012 + primitive-apply primitive-lexpr-apply + apply error lexpr-apply link + interrupt-closure interrupt-dlink interrupt-procedure + interrupt-continuation interrupt-ic-procedure + assignment-trap cache-reference-apply + reference-trap safe-reference-trap unassigned?-trap + -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero? + access lookup safe-lookup unassigned? unbound? + set! define lookup-apply primitive-error + quotient remainder modulo + reflect-to-interface interrupt-continuation-2 + compiled-code-bkpt compiled-closure-bkpt + new-interrupt-procedure)) + +(define-integrable (invoke-interface-ble code) + ;; Jump to scheme-to-interface-ble + (LAP (BLE () (OFFSET 0 4 ,regnum:scheme-to-interface-ble)) + (LDI () ,code 28))) + +;;; trampoline-to-interface uses (OFFSET 4 4 ,regnum:scheme-to-interface-ble) + +(define-integrable (invoke-interface code) + ;; Jump to scheme-to-interface + (LAP (BLE () (OFFSET 12 4 ,regnum:scheme-to-interface-ble)) + (LDI () ,code 28))) + +(let-syntax ((define-hooks + (macro (start . names) + (define (loop names index assocs) + (if (null? names) + '() ;;`((DEFINE HOOK:COMPILER-XXX-ALIST ',assocs)) + (cons `(DEFINE-INTEGRABLE + ,(symbol-append 'HOOK:COMPILER- + (car names)) + ,index) + (loop (cdr names) (+ 8 index) + (cons (cons index (car names)) assocs))))) + `(BEGIN ,@(loop names start '()))))) + ;; Remember to copy this list to dassm1.scm if you change it. + (define-hooks 100 + store-closure-code + store-closure-entry ; newer version of store-closure-code. + multiply-fixnum + fixnum-quotient + fixnum-remainder + fixnum-lsh + &+ + &- + &* + &/ + &= + &< + &> + 1+ + -1+ + zero? + positive? + negative? + shortcircuit-apply + shortcircuit-apply-1 + shortcircuit-apply-2 + shortcircuit-apply-3 + shortcircuit-apply-4 + shortcircuit-apply-5 + shortcircuit-apply-6 + shortcircuit-apply-7 + shortcircuit-apply-8 + stack-and-interrupt-check + invoke-primitive + vector-cons + string-allocate + floating-vector-cons + flonum-sin + flonum-cos + flonum-tan + flonum-asin + flonum-acos + flonum-atan + flonum-exp + flonum-log + flonum-truncate + flonum-ceiling + flonum-floor + flonum-atan2 + compiled-code-bkpt + compiled-closure-bkpt + copy-closure-pattern + copy-multiclosure-pattern + closure-entry-bkpt-hook + interrupt-procedure/new + interrupt-continuation/new + interrupt-closure/new + quotient + remainder + interpreter-call)) + +;; There is a NOP here because otherwise the return address would have +;; to be adjusted by the hook code. This gives more flexibility to the +;; compiler since it may be able to eliminate the NOP by moving an +;; instruction preceding the BLE to the delay slot. + +(define (invoke-hook hook) + (LAP (BLE () (OFFSET ,hook 4 ,regnum:scheme-to-interface-ble)) + (NOP ()))) + +;; This is used when not returning. It uses BLE instead of BE as a debugging +;; aid. The hook gets a return address pointing to the caller, even +;; though the code will not return. + +(define (invoke-hook/no-return hook) + (LAP (BLE (N) (OFFSET ,hook 4 ,regnum:scheme-to-interface-ble)))) + +(define (require-registers! . regs) + (let ((code (apply clean-registers! regs))) + (need-registers! regs) + code)) + +(define (load-interface-args! first second third fourth) + (let ((clear-regs + (apply clear-registers! + (append (if first (list regnum:first-arg) '()) + (if second (list regnum:second-arg) '()) + (if third (list regnum:third-arg) '()) + (if fourth (list regnum:fourth-arg) '())))) + (load-reg + (lambda (arg reg) + (if arg (load-machine-register! arg reg) (LAP))))) + (let ((load-regs + (LAP ,@(load-reg first regnum:first-arg) + ,@(load-reg second regnum:second-arg) + ,@(load-reg third regnum:third-arg) + ,@(load-reg fourth regnum:fourth-arg)))) + (LAP ,@clear-regs + ,@load-regs + ,@(clear-map!))))) + +(define (%load-interface-args! first second third fourth) + (let* ((load-reg + (lambda (arg reg) + (if arg + (load-machine-register! arg reg) + (clean-registers! reg)))) + (load-one (load-reg first regnum:first-arg)) + (load-two (load-reg second regnum:second-arg)) + (load-three (load-reg third regnum:third-arg)) + (load-four (load-reg fourth regnum:fourth-arg))) + (LAP ,@load-one + ,@load-two + ,@load-three + ,@load-four))) + +(define (->machine-register source machine-reg) + (let ((code (load-machine-register! source machine-reg))) + ;; Prevent it from being allocated again. + (need-register! machine-reg) + code)) \ No newline at end of file diff --git a/v8/src/compiler/machines/spectrum/lapopt.scm b/v8/src/compiler/machines/spectrum/lapopt.scm new file mode 100644 index 000000000..f7a07be35 --- /dev/null +++ b/v8/src/compiler/machines/spectrum/lapopt.scm @@ -0,0 +1,946 @@ +#| -*-Scheme-*- + +$Id: lapopt.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ + +Copyright (c) 1991-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Optimizer for HP Precision Archtecture. +;; package: (compiler lap-optimizer) + +(declare (usual-integrations)) + +;;;; An instruction classifier and decomposer + +(define-integrable (float-reg reg) + (+ 32 reg)) + +(define (classify-instruction instr) + ;; (values type writes reads offset) + ;; The types are ALU, MEMORY, FALU (floating ALU), CONTROL + (let ((opcode (car instr))) + (case opcode + ((ANDCM AND OR XOR UXOR SUB DS SUBT + SUBB ADD SH1ADD SH2ADD SH3ADD ADDC + COMCLR UADDCM UADDCMT ADDL SH1ADDL + SH2ADDL SH3ADDL SUBO SUBTO SUBBO + ADDO SH1ADDO SH2ADDO SH3ADDO ADDCO + VSHD SHD) + ;; operator conditions source source ... target + (values 'ALU + ;; not (list-ref instr 4) + (list (car (last-pair instr))) ; Skip the "..." + (list (list-ref instr 2) (list-ref instr 3)) + false)) + ((ADDI ADDIO ADDIT ADDITO SUBI SUBIO COMICLR) + ;; operator conditions immed source target + (values 'ALU + (list (list-ref instr 4)) + (list (list-ref instr 3)) + false)) + ((COPY) + ;; operator conditions source target + (values 'ALU + (list (list-ref instr 3)) + (list (list-ref instr 2)) + false)) + + ((LDW LDB LDO LDH) + ;; operator completer (offset bytes space source) target + ;; the completer isn't actually used! + (let ((offset (list-ref instr 2))) + (values (if (eq? opcode 'LDO) + 'ALU + 'MEMORY) + (list (list-ref instr 3)) + (list (cadddr offset)) + (cadr offset)))) + ((LDWM) + ;; operator completer (offset bytes space target/source) target + ;; Notice that this writes BOTH registers: one from memory + ;; contents, the other by adding the offset to the register + (let* ((offset (list-ref instr 2)) + (base (cadddr offset))) + (values 'MEMORY + (list base (list-ref instr 3)) + (list base) + (cadr offset)))) + ((LDWS LDHS LDBS LDWAS LDCWS) + ;; operator completer (offset bytes space target/source) target + (let* ((completer (cadr instr)) + (offset (list-ref instr 2)) + (base (cadddr offset))) + (values 'MEMORY + (cons (list-ref instr 3) + (if (or (memq 'MA completer) + (memq 'MB completer)) + (list base) + '())) + (list base) + (cadr offset)))) + + ((LDWX LDHX LDBX LDWAX LDCWX) + ;; operator completer (INDEX source1 m source2/target) target + (let* ((completer (cadr instr)) + (index (list-ref instr 2)) + (base (cadddr index))) + (values 'MEMORY + (cons (list-ref instr 3) + (if (or (memq 'M completer) + (memq 'SM completer)) + (list base) + '())) + (list (cadr index) base) + false))) + ((STW STB STH) + ;; operator completer source1 (offset bytes space source2) + (let ((offset (list-ref instr 3))) + (values 'MEMORY + '() + (list (list-ref instr 2) (cadddr offset)) + (cadr offset)))) + ((STWM) + ;; operator completer source1 (offset n m target/source) + (let* ((offset (list-ref instr 3)) + (base (cadddr offset))) + (values 'MEMORY + (list base) + (list (list-ref instr 2) base) + (cadr offset)))) + ((STWS STHS STBS STWAS) + ;; operator completer source1 (offset n m target/source) + (let* ((offset (list-ref instr 3)) + (base (cadddr offset))) + (values 'MEMORY + (if (or (memq 'MA (cadr instr)) + (memq 'MB (cadr instr))) + (list base) + '()) + (list base (list-ref instr 2)) + (cadr offset)))) + ((LDI LDIL) + ;; immed target + (values 'ALU + (list (list-ref instr 3)) + '() + (list-ref instr 2))) + ((ADDIL) + ;; immed source + (values 'ALU + (list regnum:addil-result) + (list (list-ref instr 3)) + (list-ref instr 2))) + ((NOP SKIP) + (values 'ALU '() '() false)) + ((VDEPI DEPI) + (values 'ALU + (list (car (last-pair instr))) + (list (car (last-pair instr))) + false)) + ((ZVDEPI ZDEPI) + (values 'ALU + (list (car (last-pair instr))) + '() + false)) + ((EXTRU EXTRS ZDEP) + (values 'ALU + (list (list-ref instr 5)) + (list (list-ref instr 2)) + false)) + + ((DEP) + (values 'ALU + (list (list-ref instr 5)) + (list (list-ref instr 5) (list-ref instr 2)) + false)) + ((VEXTRU VEXTRS VDEP ZVDEP) + (values 'ALU + (list (list-ref instr 4)) + (list (list-ref instr 2)) + false)) + ((FCPY FABS FSQRT FRND) + ;; source target + (values 'FALU + (list (float-reg (list-ref instr 3))) + (list (float-reg (list-ref instr 2))) + false)) + ((FADD FSUB FMPY FDIV FREM) + ;; source1 source2 target + (values 'FALU + (list (float-reg (list-ref instr 4))) + (list (float-reg (list-ref instr 2)) + (float-reg (list-ref instr 3))) + false)) + ((FSTDS) + ;; source (offset n m base) + (let* ((offset (list-ref instr 3)) + (base (cadddr offset))) + (values 'MEMORY + (if (or (memq 'MA (cadr instr)) + (memq 'MB (cadr instr))) + (list base) + '()) + (list base + (float-reg (list-ref instr 2))) + (cadr offset)))) + ((COMBT COMBF COMB COMBN) + ;; source1 source2 + (values 'CONTROL + '() + (list (list-ref instr 2) (list-ref instr 3)) + false)) + ((COMIBT COMIBF COMIB COMIBTN COMIBFN) + ;; immediate source + (values 'CONTROL + '() + (list (list-ref instr 3)) + false)) + ((BL) + ;; target + (values 'CONTROL + (list (list-ref instr 2)) + '() + false)) + ((B) + ;; target + (values 'CONTROL + '() + '() + false)) + ((BV) + ;; source-1 source-2 + (values 'CONTROL + '() + (list (list-ref instr 2) (list-ref instr 3)) + false)) + + ((BLR) + ;; source target + (values 'CONTROL + (list (list-ref instr 3)) + (list (list-ref instr 2)) + false)) + ((BLE) + (let ((offset-expr (list-ref instr 2))) + (values 'CONTROL + (list 31) + (list (list-ref offset-expr 3)) + (list-ref offset-expr 1)))) + ((BE) + (let ((offset-expr (list-ref instr 2))) + (values 'CONTROL + '() + (list (list-ref offset-expr 3)) + (list-ref offset-expr 1)))) + #| + ((ADDBT ADDBF ADDB) + ;; source1 source2/target + (let ((target (list-ref instr 3))) + (values 'CONTROL + (list target) + (list (list-ref instr 2) target) + false))) + ((ADDIBT ADDIBF ADDIB) + ;; immediate source/target + (let ((target (list-ref instr 3))) + (values 'CONTROL + (list target) + (list target) + false))) + ((GATE) + <>) + ((MOVB ...) + <>) + ((PCR-HOOK) + <>) + ((LABEL EQUATE ENTRY-POINT + EXTERNAL-LABEL BLOCK-OFFSET + SCHEME-OBJECT SCHEME-EVALUATION PADDING) + (values 'DIRECTIVE '() '() false)) + |# + (else + (values 'UNKNOWN '() '() false))))) + +(define (offset-fits? offset opcode) + (and (number? offset) + (memq opcode '(LDW LDB LDO LDI LDH STW STB STH STWM LDWM + STWS LDWS FLDWS FLDDS FSTWS FSTDS)) + (<= -8192 offset 8191))) + +;;;; Utilities + +;; A trivial pattern matcher + +(define (match pattern instance) + (let ((dict '(("empty" . empty)))) + + (define (match-internal pattern instance) + (cond ((not (pair? pattern)) + (eqv? pattern instance)) + ((eq? (car pattern) '?) + (let ((var (cadr pattern)) + (val instance)) + (cond ((eq? var '?) ; quoting ? + (eq? val '?)) + ((assq var dict) + => (lambda (place) + (equal? (cdr place) val))) + (else + (set! dict (cons (cons var val) dict)) + true)))) + (else + (and (pair? instance) + (match-internal (car pattern) (car instance)) + (match-internal (cdr pattern) (cdr instance)))))) + + (and (match-internal pattern instance) + dict))) + +(define (directive? instr) + (memq (car instr) + '(COMMENT + LABEL EQUATE ENTRY-POINT + EXTERNAL-LABEL BLOCK-OFFSET + SCHEME-OBJECT SCHEME-EVALUATION PADDING))) + +(define (find-or-label instrs) + (and (not (null? instrs)) + (if (memq (caar instrs) + '(COMMENT SCHEME-OBJECT SCHEME-EVALUATION EQUATE)) + (find-or-label (cdr instrs)) + instrs))) + +(define (find-non-label instrs) + (and (not (null? instrs)) + (if (memq (caar instrs) + '(LABEL COMMENT SCHEME-OBJECT SCHEME-EVALUATION EQUATE)) + (find-non-label (cdr instrs)) + instrs))) + +(define (list-difference whole suffix) + (if (eq? whole suffix) + '() + (cons (car whole) + (list-difference (cdr whole) suffix)))) + +(define (fix-complex-return ret frame junk instr avoid) + (let ((syll `(OFFSET ,frame 0 ,regnum:stack-pointer))) + (if (and (eq? (car instr) 'STW) + (equal? (cadddr instr) syll)) + ;; About to store return address. Forego store completely + ;; FORMAT: (STW () ret (OFFSET frame 0 regnum:stack-pointer)) + (let ((ret (caddr instr))) + `(,@(reverse junk) + ,@(entry->address ret) + (BV () 0 ,ret) + (LDO () (OFFSET ,(+ frame 4) 0 ,regnum:stack-pointer) + ,regnum:stack-pointer))) + (let ((ret (list-search-positive + (list ret regnum:first-arg regnum:second-arg + regnum:third-arg regnum:fourth-arg) + (lambda (reg) + (not (memq reg avoid)))))) + `(,@(reverse junk) + (LDW () ,syll ,ret) + ,instr + ,@(entry->address ret) + (BV () 0 ,ret) + (LDO () (OFFSET ,(+ frame 4) 0 ,regnum:stack-pointer) + ,regnum:stack-pointer)))))) + +(define (fix-simple-return ret frame junk) + ;; JSM: Why can't the LDO be in the delay slot of the BV? + `(,@(reverse junk) + (LDW () (OFFSET ,frame 0 ,regnum:stack-pointer) ,ret) + (LDO () (OFFSET ,(+ frame 4) 0 ,regnum:stack-pointer) + ,regnum:stack-pointer) + ,@(entry->address ret) + (BV (N) 0 ,ret))) + +(define (fix-a-return dict1 junk dict2 rest) + (let* ((next (find-or-label rest)) + (next* (and next (find-non-label next))) + (frame (cdr (assq 'frame dict2))) + (ret (cdr (assq 'ret dict1)))) + (cond ((or (not next) + (instr-pc-sensitive? (car next)) + (memq (caar next) + '(ENTRY-POINT EXTERNAL-LABEL BLOCK-OFFSET PCR-HOOK)) + (and (eq? (caar next) 'LABEL) + (or (not next*) + (not (instr-skips? (car next*)))))) + (values (fix-simple-return ret frame junk) + rest)) + ((or (eq? (caar next) 'LABEL) + (instr-skips? (car next))) + (values '() false)) + (else + (call-with-values + (lambda () (classify-instruction (car next))) + (lambda (type writes reads offset) + offset ; ignored + (if (or (not (memq type '(ALU MEMORY FALU))) + (equal? writes (list regnum:stack-pointer))) + (values (fix-simple-return ret frame junk) + rest) + (values + (fix-complex-return ret frame + (append junk + (list-difference rest next)) + (car next) + (append writes reads)) + (cdr next))))))))) + +(define (fix-sequences instrs tail) + (define-integrable (single instr) + (fix-sequences (cdr instrs) + (cons instr tail))) + + (define-integrable (fail) + (single (car instrs))) + + (if (null? instrs) + tail + (let* ((instr (car instrs)) + (opcode (car instr))) + + (define (try-skip) + (let ((label (let ((address (list-ref instr 4))) + (and (eq? (car address) '@PCR) + (cadr address))))) + (if (not label) + (fail) + (let* ((next (find-non-label tail)) + (instr* (and next + (not (directive? (car next))) + (car next))) + (next* (and instr* (find-or-label (cdr next)))) + (instr** (and next* (car next*)))) + (if (or (not instr**) + (not (eq? (car instr**) 'LABEL)) + (not (eq? (cadr instr**) label)) + (instr-expands? instr*)) + (fail) + (case opcode + ((COMB COMBT COMBN) + (single + `(COMCLR ,(delq 'N (cadr instr)) + ,(caddr instr) + ,(cadddr instr) + 0))) + ((COMIB COMIBT COMIBTN) + (single + `(COMICLR ,(delq 'N (cadr instr)) + ,(caddr instr) + ,(cadddr instr) + 0))) + ((COMBF) + (single + `(COMCLR ,(map invert-condition + (delq 'N (cadr instr))) + ,(caddr instr) + ,(cadddr instr) + 0))) + ((COMIBF COMIBFN) + (single + `(COMICLR ,(map invert-condition + (delq 'N (cadr instr))) + ,(caddr instr) + ,(cadddr instr) + 0))) + (else "LAPOPT: try-skip bad case" instr))))))) + + (define (fix-unconditional-branch) + (if (not (equal? (cadr instr) '(N))) + (fail) + (call-with-values + (lambda () + (find-movable-instr/delay instr (cdr instrs))) + (lambda (movable junk rest) + (if (not movable) + (fail) + (fix-sequences + rest + `(,@(reverse junk) + (,opcode () ,@(cddr instr)) + ,movable + ,@tail))))))) + + (define (drop-instr) + (fix-sequences (cdr instrs) + (cons '(COMMENT (branch removed)) + tail))) + + (define (generate-skip) + (let* ((default (lambda () (single `(SKIP (TR))))) + (previous (find-or-label (cdr instrs))) + (skipify + (lambda (instr*) + (fix-sequences + (cdr previous) + (cons instr* + (append + (reverse (list-difference (cdr instrs) previous)) + tail))))) + (instr (and previous (car previous))) + (previous* (and previous (find-non-label (cdr previous))))) + (if (or (not instr) + (not (null? (cadr instr))) + (directive? instr) + (and previous* + (instr-skips? (car previous*)))) + (default) + (call-with-values + (lambda () + (classify-instruction instr)) + (lambda (type writes reads offset) + (cond ((or (not (eq? type 'ALU)) + (memq (car instr) '(LDIL ADDIL))) + (default)) + ((not (memq (car instr) '(LDO LDI))) + (skipify + `(,(car instr) (TR) ,@(cddr instr)))) + ((not (fits-in-11-bits-signed? offset)) + (default)) + (else + (skipify + `(ADDI (TR) + ,offset + ,(if (null? reads) + 0 + (car reads)) + ,(car writes)))))))))) + + (case opcode + ((BV) + (let ((dict1 (match (cdr return-pattern) instrs))) + (if (not dict1) + (fix-unconditional-branch) + (let* ((tail* (cddr instrs)) + (next (find-or-label tail*)) + (fail* + (lambda () + (fix-sequences + tail* + (append (reverse (list-head instrs 2)) + tail)))) + (dict2 + (and next + (match (car return-pattern) (car next))))) + + (if (not dict2) + (fail*) + (call-with-values + (lambda () + (fix-a-return dict1 + (list-difference tail* next) + dict2 + (cdr next))) + (lambda (frobbed untouched) + (if (null? frobbed) + (fail*) + (fix-sequences untouched + (append frobbed tail)))))))))) + + ((B) + (let ((address (caddr instr))) + (if (not (eq? (car address) '@PCR)) + (fix-unconditional-branch) + (let ((label (cadr address))) + (if (equal? (cadr instr) '(N)) + ;; Branch with nullification + (let* ((next (find-or-label tail)) + (instr* (and next (car next)))) + (cond ((not instr*) + (fix-unconditional-branch)) + ((eq? (car instr*) 'LABEL) + (if (not (eq? (cadr instr*) label)) + (fix-unconditional-branch) + (drop-instr))) + ((eq? (car instr*) 'EXTERNAL-LABEL) + (let ((address* (list-ref instr* 3))) + (if (or (not (eq? (car address*) '@PCR)) + (not (eq? label (cadr address*)))) + (fix-unconditional-branch) + (generate-skip)))) + (else + (fix-unconditional-branch)))) + ;; Branch with no nullification + (let* ((next (find-non-label tail)) + (instr* (and next (car next))) + (next* (and next (find-or-label (cdr next)))) + (instr** (and next* (car next*)))) + (cond ((not instr**) + (fix-unconditional-branch)) + ((and (eq? (car instr**) 'LABEL) + (eq? (cadr instr**) label) + (not (instr-expands? instr*))) + (drop-instr)) + (else + (fix-unconditional-branch))))))))) + + ((BE BLE) + (fix-unconditional-branch)) + ((NOP) + (let ((dict (match hook-pattern instrs))) + (if (not dict) + (fail) + (call-with-values + (lambda () + (find-movable-instr/delay (cadr instrs) ; The BLE + (cddr instrs))) + (lambda (movable junk rest) + (if (not movable) + (fail) + (fix-sequences + rest + `(,@(reverse junk) + ,(cadr instrs) + ,movable + ,@tail)))))))) + ((LDW LDB LDH) + #| + ;; yyy + ;; LD[WB] ... Rx + ;; use Rx + ;; => + ;; LD[WB] ... Rx + ;; yyy + ;; use Rx + |# + (let* ((writes (fourth instr)) + (next (find-non-label tail))) + (if (or (not next) + (not (instr-uses? (car next) writes))) + (fail) + (call-with-values + (lambda () + (find-movable-instr/load (cdr instrs) + (list (fourth (third instr))) + (list writes) + (car next))) + (lambda (movable junk rest) + (if (not movable) + (fix-sequences + (cdr instrs) + (cons* instr '(COMMENT *load-stall*) tail)) + (fix-sequences + rest + `(,@(reverse junk) + (COMMENT (moved for load scheduling)) + ,instr + ,movable + ,@tail)))))))) + + #| + (else + (cond (;; Load scheduling + ;; xxx + ;; LD[WB] ... Rx + ;; use Rx + ;; => + ;; LD[WB] ... Rx + ;; xxx + ;; use Rx + (and (pair? (cdr instrs)) + ;; `use Rx' is not, say, a comment + (not (directive? instr)) + (eq? instrs (find-or-label instrs)) + (memq (caar (find-or-label (cdr instrs))) '(LDW LDB)) + (instr-uses? + instr + (fourth (car (find-or-label (cdr instrs)))))) + (call-with-values + (lambda () + (find-movable-instr-for-load-slot + (cdr (find-or-label (cdr instrs))))) + (lambda (movable junk rest) + (if (or (not movable) + (memq (car movable) '(LDWM STWM))) + ;; This annotates them, otherwise eqv to (fail): + (fix-sequences (cdr instrs) + (cons* '(COMMENT *load-stall*) + (car instrs) tail)) + (fix-sequences + rest + `(,@(reverse junk) + ,(car (find-or-label (cdr instrs))) + (COMMENT (moved for load scheduling)) + ,movable + ,(car instrs) + ,@tail)))))) + (else + (fail)))) + |# + ((COMB COMBT COMBF COMIB COMIBT COMIBF) + (if (not (memq 'N (cadr instr))) + (fail) + (try-skip))) + ((COMBN COMIBTN COMIBFN) + (try-skip)) + (else + (fail)))))) + +(define (fits-in-11-bits-signed? value) + (and (< value 1024) + (>= value -1024))) + +(define (instr-skips? instr) + ;; Not really true, for example + ;; (COMBT (<) ...) + (or (and (pair? (cadr instr)) + (not (memq (car instr) + '(B BL BV BLR BLE BE + LDWS LDHS LDBS LDCWS + STWS STHS STBS STBYS + FLDWS FLDDS FSTWS FSTDS + COMBN COMIBTN COMIBFN))) + ;; or SGL, or QUAD, but not used now. + (not (memq 'DBL (cadr instr)))) + + ;; A jump with a non-nullified delay slot + (and (memq (car instr) '(B BL BV BLR BLE BE)) + (null? (cadr instr))))) + +(define (instr-uses? instr reg) + ;; Might INSTR have a data dependency on REG? + (call-with-values + (lambda () (classify-instruction instr)) + (lambda (type writes reads offset) + writes offset ; ignored + (or (eq? type 'UNKNOWN) + (eq? type 'DIRECTIVE) + (memq reg reads))))) + +(define (instr-expands? instr) + (call-with-values + (lambda () (classify-instruction instr)) + (lambda (type writes reads offset) + writes reads ; ignored + (or (eq? type 'UNKNOWN) + (eq? type 'DIRECTIVE) + (cond (offset + (not (offset-fits? offset (car instr)))) + ((eq? type 'CONTROL) + (instr-pc-sensitive? instr)) + (else + false)))))) + +(define (instr-pc-sensitive? instr) + (let walk ((instr instr)) + (or (memq instr '(*PC* @PCR)) + (and (pair? instr) + (or (walk (car instr)) + (walk (cdr instr))))))) + +(define (find-movable-instr/delay instr instrs) + (let* ((next (find-or-label instrs)) + (instr* (and next (car next))) + (next* (and next (find-non-label (cdr next))))) + (if (and instr* + (call-with-values + (lambda () (classify-instruction instr*)) + (lambda (type writes reads offset) + (and (memq type '(ALU MEMORY FALU)) + (or (not offset) + (offset-fits? offset (car instr*))) + (call-with-values + (lambda () (classify-instruction instr)) + (lambda (type* writes* reads* offset*) + type* offset* ; ignored + ;;(pp `((,instr* writes ,writes reads ,reads) + ;; (,instr writes* ,writes* reads* ,reads*))) + (and (null? (eq-set-intersection writes reads*)) + (null? (eq-set-intersection reads writes*)))))))) + (not (instr-skips? instr*)) + (not (instr-pc-sensitive? instr*)) + (or (not next*) + (not (instr-skips? (car next*))))) + (values instr* + (list-difference instrs next) + (cdr next)) + (values false false false)))) + +;; Certainly dont try (equal? instr recache-memtop) in above as it causes the +;; branch for which we are seeking an instruction to fill its delay slot to +;; be put in the delay slot of the COMB instruction. + +#| +(define (find-movable-instr-for-load-slot instrs) + ;; This needs to be taught about dependencies between instructiions. + ;; Currently it will only reschedule the recaching of memtop as that has no + ;; dependencies at all. + (let* ((next (find-or-label instrs)) + (instr (and next (car next)))) + (if (or (equal? instr recache-memtop) + #F) + (values instr + (list-difference instrs next) + (cdr next)) + (values false false false)))) +|# + +(define (find-movable-instr/load instrs reads writes next**) + (let* ((next (find-or-label instrs)) + (instr (and next (car next))) + (next* (and next (find-non-label (cdr next))))) + (if (and instr + (not (instr-skips? instr)) + (call-with-values + (lambda () (classify-instruction instr)) + (lambda (type writes* reads* offset) + offset ; ignored + (and (memq type '(ALU MEMORY FALU)) + (null? (eq-set-intersection writes* reads)) + (null? (eq-set-intersection writes reads*)) + (or (null? writes*) + (not (there-exists? writes* + (lambda (tgt) + (instr-uses? next** tgt)))))))) + (or (not (memq (car instr) + '(STW STB STH STWM STWS STHS STBS STWAS))) + ;; Don't move a memory store instruction past + ;; a load. There are cases where this is OK, + ;; but we're not going to handle them now. -- JSM + (begin + ;;(write-line (list 'FIND-MOVABLE-INSTR/LOAD instr)) + #F)) + (or (not next*) + (not (instr-skips? (car next*))) + (equal? instr recache-memtop))) + (values instr + (list-difference instrs next) + (cdr next)) + (values false false false)))) + +(define return-pattern ; reversed + (cons + `(LDO () (OFFSET (? frame) 0 ,regnum:stack-pointer) ,regnum:stack-pointer) + `((BV (N) 0 (? ret)) + (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) (? ret)) + . (? more-insts)))) + +(define hook-pattern + `((NOP ()) + (BLE () (OFFSET (? hook) 4 ,regnum:scheme-to-interface-ble)) + . (? more-insts))) + +(define recache-memtop '(LDW () (OFFSET 0 0 4) #x14)) + +(define (old-optimize-linear-lap instructions) + (fix-sequences (reverse! instructions) '())) + +#| +** I believe that I have fixed this - there are cdd..drs and list + indexes in the code that assume that the return pattern has a + certain length. + +;; At the moment the code removes the assignment to r2 in the following: + +((entry-point fixmul-5) + (scheme-object CONSTANT-0 debugging-info) + (scheme-object CONSTANT-1 environment) + (comment (rtl (procedure-header fixmul-0 3 3))) + (equate fixmul-5 fixmul-0) + (label label-4) + (ble () (offset 0 4 3)) + (ldi () 26 28) + (external-label () 771 (@pcr fixmul-0)) + (label fixmul-0) + (comb (>=) 21 20 (@pcr label-4)) + (ldw () (offset 0 0 4) 20) + (comment + (rtl (assign (register 65) (offset (register 22) (machine-constant 0))))) + (ldw () (offset 0 0 22) 6) + (comment + (rtl (assign (register 66) (offset (register 22) (machine-constant 1))))) + (ldw () (offset 4 0 22) 7) + (comment + (rtl + (assign + (register 2) + (fixnum-2-args multiply-fixnum (register 65) (register 66) #f)))) + (copy () 6 26) + (copy () 7 25) + (ble () (offset 116 4 3)) + (nop ()) + (comment + (rtl + (assign + (register 22) + (offset-address (register 22) (machine-constant 2))))) + (ldo () (offset 8 0 22) 22) + (comment (rtl (pop-return))) + (copy () 26 2) + (ldwm () (offset 4 0 22) 6) + (bv (n) 0 6)) + +** But there is still a bug: + +gc.scm when optimized SEGVs in flush-purification-queue for no apparent reason + + +|# +(define (optimize-linear-lap instructions) + (old-optimize-linear-lap instructions)) + +;;;; This works in conjuction with try-skip in fix-sequences. + +(define (lap:mark-preferred-branch! pblock cn an) + ;; This can leave pblock unchanged + (define (single-instruction bblock other) + (and (sblock? bblock) + (let ((next (snode-next bblock))) + (or (not next) + (eq? next other))) + (let find-first ((instrs (bblock-instructions bblock))) + (and (not (null? instrs)) + (let ((instr (car instrs))) + (if (eq? 'COMMENT (car instr)) + (find-first (cdr instrs)) + (and (let find-next ((instrs (cdr instrs))) + (or (null? instrs) + (and (eq? 'COMMENT (car (car instrs))) + (find-next (cdr instrs))))) + instr))))))) + + (define (try branch bblock other) + (let ((instr (single-instruction bblock other))) + (and instr + (not (instr-expands? instr)) + (pnode/prefer-branch! pblock branch) + true))) + + (let ((branch-instr + (car (last-pair ((pblock-consequent-lap-generator pblock) 'FOO))))) + (and (memq (car branch-instr) + '(COMB COMBT COMBF COMIB COMIBT COMIBF COMBN COMIBTN COMIBFN)) + (or (try 'CONSEQUENT cn an) + (try 'ALTERNATIVE an cn))))) \ No newline at end of file diff --git a/v8/src/compiler/machines/spectrum/machin.scm b/v8/src/compiler/machines/spectrum/machin.scm new file mode 100644 index 000000000..3f7b585d6 --- /dev/null +++ b/v8/src/compiler/machines/spectrum/machin.scm @@ -0,0 +1,645 @@ +#| -*-Scheme-*- + +$Id: machin.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;; Machine Model for Spectrum +;;; package: (compiler) + +;;! Changes for split fixnum tags makeed with ;;! + +(declare (usual-integrations)) + +;;;; Architecture Parameters + +(define stack-use-pre/post-increment? true) +(define heap-use-pre/post-increment? true) +(define continuation-in-stack? false) +(define closure-in-stack? false) + +(define-integrable endianness 'BIG) +(define-integrable addressing-granularity 8) +(define-integrable scheme-object-width 32) +(define-integrable scheme-type-width 6) ;or 8 + +;; NOTE: expt is not being constant-folded now. +;; For the time being, some of the parameters below are +;; pre-computed and marked with *** +;; There are similar parameters in lapgen.scm +;; Change them if any of the parameters above do. + +(define-integrable scheme-datum-width + (- scheme-object-width scheme-type-width)) + +(define-integrable type-scale-factor + ;; (expt 2 (- 8 scheme-type-width)) *** + 4) + +(define-integrable float-width 64) +(define-integrable float-alignment 64) + +(define-integrable address-units-per-float + (quotient float-width addressing-granularity)) + +;;; It is currently required that both packed characters and objects +;;; be integrable numbers of address units. Furthermore, the number +;;; of address units per object must be an integral multiple of the +;;; number of address units per character. This will cause problems +;;; on a machine that is word addressed: we will have to rethink the +;;; character addressing strategy. + +(define-integrable address-units-per-object + (quotient scheme-object-width addressing-granularity)) + +(define-integrable address-units-per-packed-char 1) + +(define-integrable max-type-code + ;; (-1+ (expt 2 scheme-type-width)) *** + 63) + +(define #|-integrable|# untagged-fixnums? + ;; true when fixnums have tags 000000... and 111111... + (and (= 0 (ucode-type positive-fixnum)) + (= max-type-code (ucode-type negative-fixnum)))) + +(if (and (not untagged-fixnums?) + (not (= (ucode-type positive-fixnum) (ucode-type negative-fixnum)))) + (error "machin.scm: split fixnum type-codes must be 000... and 111...")) + +(define #|-integrable|# signed-fixnum/upper-limit + (if untagged-fixnums? + ;; (expt 2 scheme-datum-width) *** + 67108864 + ;; (expt 2 (-1+ scheme-datum-width)) *** + 33554432)) + +(define-integrable signed-fixnum/lower-limit + (- signed-fixnum/upper-limit)) + +(define #|-integrable|# unsigned-fixnum/upper-limit + (if untagged-fixnums? + signed-fixnum/upper-limit + (* 2 signed-fixnum/upper-limit))) + +(define #|-integrable|# quad-mask-value + (cond ((= scheme-type-width 5) #b01000) + ((= scheme-type-width 6) #b010000) + ((= scheme-type-width 8) #b01000000) + (else (error "machin.scm: weird type width:" scheme-type-width)))) + +(define #|-integrable|# untagged-entries? + ;; This is true if the value we have chosen for the compiled-entry + ;; type-code is equal to the bits in the type-code field of an + ;; address. + (= quad-mask-value (ucode-type compiled-entry))) + +(define-integrable (stack->memory-offset offset) offset) +(define-integrable ic-block-first-parameter-offset 2) +(define-integrable execute-cache-size 3) ; Long words per UUO link slot + +;;;; Closures and multi-closures + +;; On the 68k, to save space, entries can be at 2 mod 4 addresses, +;; which makes it impossible to use an arbitrary closure entry-point +;; to reference closed-over variables since the compiler only uses +;; long-word offsets. Instead, all closure entry points are bumped +;; back to the first entry point, which is always long-word aligned. + +;; On the HP-PA, and all other RISCs, all the entry points are +;; long-word aligned, so there is no need to bump back to the first +;; entry point. + +(define-integrable closure-entry-size + #| + Long words in a single closure entry: + GC offset word + LDIL L'target,26 + BLE R'target(5,26) + ADDI -12,31,31 + |# + 4) + +;; Given: the number of entry points in a closure, and a particular +;; entry point number, compute the distance from that entry point to +;; the first variable slot in the closure object (in long words). + +(define (closure-first-offset nentries entry) + (if (zero? nentries) + 1 ; Strange boundary case + (- (* closure-entry-size (- nentries entry)) 1))) + +;; Like the above, but from the start of the complete closure object, +;; viewed as a vector, and including the header word. + +(define (closure-object-first-offset nentries) + (case nentries + ((0) + ;; Vector header only + 1) + ((1) + ;; Manifest closure header followed by single entry point + (+ 1 closure-entry-size)) + (else + ;; Manifest closure header, number of entries, then entries. + (+ 1 1 (* closure-entry-size nentries))))) + +;; Bump distance in bytes from one entry point to another. +;; Used for invocation purposes. + +(define (closure-entry-distance nentries entry entry*) + nentries ; ignored + (* (* closure-entry-size 4) (- entry* entry))) + +;; Bump distance in bytes from one entry point to the entry point used +;; for variable-reference purposes. +;; On a RISC, this is the entry point itself. + +(define (closure-environment-adjustment nentries entry) + nentries entry ; ignored + 0) + +;;;; Machine Registers + +(define-integrable g0 0) +(define-integrable g1 1) +(define-integrable g2 2) +(define-integrable g3 3) +(define-integrable g4 4) +(define-integrable g5 5) +(define-integrable g6 6) +(define-integrable g7 7) +(define-integrable g8 8) +(define-integrable g9 9) +(define-integrable g10 10) +(define-integrable g11 11) +(define-integrable g12 12) +(define-integrable g13 13) +(define-integrable g14 14) +(define-integrable g15 15) +(define-integrable g16 16) +(define-integrable g17 17) +(define-integrable g18 18) +(define-integrable g19 19) +(define-integrable g20 20) +(define-integrable g21 21) +(define-integrable g22 22) +(define-integrable g23 23) +(define-integrable g24 24) +(define-integrable g25 25) +(define-integrable g26 26) +(define-integrable g27 27) +(define-integrable g28 28) +(define-integrable g29 29) +(define-integrable g30 30) +(define-integrable g31 31) + +;; fp0 - fp3 are status registers. The rest are real registers +(define-integrable fp0 32) +(define-integrable fp1 33) +(define-integrable fp2 34) +(define-integrable fp3 35) +(define-integrable fp4 36) +(define-integrable fp5 37) +(define-integrable fp6 38) +(define-integrable fp7 39) +(define-integrable fp8 40) +(define-integrable fp9 41) +(define-integrable fp10 42) +(define-integrable fp11 43) +(define-integrable fp12 44) +(define-integrable fp13 45) +(define-integrable fp14 46) +(define-integrable fp15 47) + +;; The following registers are available only on the newer processors +(define-integrable fp16 48) +(define-integrable fp17 49) +(define-integrable fp18 50) +(define-integrable fp19 51) +(define-integrable fp20 52) +(define-integrable fp21 53) +(define-integrable fp22 54) +(define-integrable fp23 55) +(define-integrable fp24 56) +(define-integrable fp25 57) +(define-integrable fp26 58) +(define-integrable fp27 59) +(define-integrable fp28 60) +(define-integrable fp29 61) +(define-integrable fp30 62) +(define-integrable fp31 63) + +(define-integrable number-of-machine-registers 64) +(define-integrable number-of-temporary-registers 256) + +;;; Fixed-use registers for Scheme compiled code. +(define-integrable regnum:return-value g2) +(define-integrable regnum:scheme-to-interface-ble g3) +(define-integrable regnum:regs-pointer g4) +(define-integrable regnum:quad-bitmask g5) +(define-integrable regnum:false-value g5) ; Yes: same as quad-bitmask +(define-integrable regnum:empty-list g18) +(define-integrable regnum:continuation g19) +(define-integrable regnum:memtop-pointer g20) +(define-integrable regnum:free-pointer g21) +(define-integrable regnum:stack-pointer g22) +(define-integrable regnum:closure g25) + +;;; Fixed-use registers due to architecture or OS calling conventions. +(define-integrable regnum:zero g0) +(define-integrable regnum:addil-result g1) +(define-integrable regnum:C-global-pointer g27) +(define-integrable regnum:C-return-value g28) +(define-integrable regnum:C-stack-pointer g30) +(define-integrable regnum:ble-return g31) +(define-integrable regnum:fourth-arg g23) +(define-integrable regnum:third-arg g24) +(define-integrable regnum:second-arg g25) +(define-integrable regnum:first-arg g26) + +(define (machine-register-value-class register) + (cond ((or (= register 0) + (= register 26) + (= register 29) + (= register regnum:ble-return)) + value-class=word) + ((or (= register regnum:addil-result) + (= register regnum:scheme-to-interface-ble)) + value-class=unboxed) + ((or (= register regnum:continuation) + (= register regnum:closure)) + (if untagged-entries? + value-class=object ; because it is untagged + value-class=address)) + (;; argument registers + (or (= register 2) + (<= 6 register 17) + (<= 23 register 24)) + value-class=object) + ((or (= register regnum:false-value) + (= register regnum:empty-list)) + value-class=object) + ((or (= register regnum:regs-pointer) + (= register regnum:memtop-pointer) + (= register regnum:free-pointer) + (= register regnum:stack-pointer) + (= register 27) + (= register 30)) + value-class=address) + ((= register 28) + value-class=object) + ((<= 32 register 63) + value-class=float) + (else + (error "illegal machine register" register)))) + +;;(define *rtlgen/argument-registers* +;; ;; arbitrary small number for debugging stack arguments +;; '#(2 6 7)) + +(define *rtlgen/argument-registers* + ;; Leave 28, 29, and 31 as temporaries + ;; For now, 25 and 26 cannot be used because closure patterns + ;; use them to jump. + '#(#| 0 1 |# + 2 #| 3 4 5 |# + 6 7 8 9 10 11 12 13 14 15 16 17 #| 18 19 20 21 22 |# + 23 24 #| 25 26 27 28 29 30 31 |# + )) + +(define-integrable (machine-register-known-value register) + register ;ignore + false) + +(define (machine-register-known-type register) + (cond ((and (machine-register? register) + (value-class=address? (machine-register-value-class register))) + quad-mask-value) + (else + #F))) + +;;;; Interpreter Registers + +(define-integrable (interpreter-free-pointer) + (rtl:make-machine-register regnum:free-pointer)) + +(define (interpreter-free-pointer? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:free-pointer))) + +(define-integrable (interpreter-regs-pointer) + (rtl:make-machine-register regnum:regs-pointer)) + +(define (interpreter-regs-pointer? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:regs-pointer))) + +(define-integrable (interpreter-value-register) + (rtl:make-machine-register regnum:return-value)) + +(define (interpreter-value-register? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:return-value))) + +(define-integrable (interpreter-stack-pointer) + (rtl:make-machine-register regnum:stack-pointer)) + +(define (interpreter-stack-pointer? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:stack-pointer))) + +(define-integrable (interpreter-dynamic-link) + (rtl:make-machine-register regnum:dynamic-link)) + +(define (interpreter-dynamic-link? expression) + (and (rtl:register? expression) + (= (rtl:register-number expression) regnum:dynamic-link))) + +(define-integrable (interpreter-int-mask-register) + (rtl:make-offset (interpreter-regs-pointer) + (rtl:make-machine-constant 1))) + +(define-integrable (interpreter-environment-register) + (rtl:make-offset (interpreter-regs-pointer) + (rtl:make-machine-constant 3))) + +(define (interpreter-environment-register? expression) + (and (rtl:offset? expression) + (interpreter-regs-pointer? (rtl:offset-base expression)) + (let ((offset (rtl:offset-offset expression))) + (and (rtl:machine-constant? offset) + (= 3 (rtl:machine-constant-value offset)))))) + +(define-integrable (interpreter-register:access) + (rtl:make-machine-register g28)) + +(define-integrable (interpreter-register:cache-reference) + (rtl:make-machine-register g28)) + +(define-integrable (interpreter-register:cache-unassigned?) + (rtl:make-machine-register g28)) + +(define-integrable (interpreter-register:lookup) + (rtl:make-machine-register g28)) + +(define-integrable (interpreter-register:unassigned?) + (rtl:make-machine-register g28)) + +(define-integrable (interpreter-register:unbound?) + (rtl:make-machine-register g28)) + + +(define-integrable (interpreter-continuation-register) + ;; defined only if not continuation-in-stack? + ;; Needs to be a param in machin.scm + ;; ***IMPORTANT: cannot be 31 because BLE clobbers + ;; it when going to the interface*** + ;; It should be 2, like for C, but we can't do this + ;; until the calling interface is changed. + (rtl:make-machine-register regnum:continuation)) + +(define-integrable (interpreter-closure-register) + ;; defined only if not closure-in-stack? + (rtl:make-machine-register regnum:closure)) + +(define-integrable (interpreter-memtop-register) + (rtl:make-machine-register regnum:memtop-pointer)) + +;;;; Parameters moved from RTLGEN + +(define (rtlgen/interpreter-call/argument-home index) + (case index + ((1) `(REGISTER 25)) + ((2) `(REGISTER 24)) + (else + (internal-error "Unexpected interpreter-call argument index" index)))) + +(define (machine/indexed-loads? type) + type ; for all types + #T) + +(define (machine/indexed-stores? type) + (eq? type 'FLOAT)) + +(define (machine/cont-adjustment) + ;; Distance in bytes between a raw continuation + ;; (as left behind by JSR) and the real continuation + ;; (after descriptor) + 0) + + +;;;; RTL Registers, Constants, and Primitives + +(define (rtl:machine-register? rtl-register) + (case rtl-register + ((STACK-POINTER) + (interpreter-stack-pointer)) + ;((DYNAMIC-LINK) + ; (interpreter-dynamic-link)) + ((VALUE) + (interpreter-value-register)) + ((FREE) + (interpreter-free-pointer)) + ((MEMORY-TOP) + (rtl:make-machine-register regnum:memtop-pointer)) + ((INTERPRETER-CALL-RESULT:ACCESS) + (interpreter-register:access)) + ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE) + (interpreter-register:cache-reference)) + ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?) + (interpreter-register:cache-unassigned?)) + ((INTERPRETER-CALL-RESULT:LOOKUP) + (interpreter-register:lookup)) + ((INTERPRETER-CALL-RESULT:UNASSIGNED?) + (interpreter-register:unassigned?)) + ((INTERPRETER-CALL-RESULT:UNBOUND?) + (interpreter-register:unbound?)) + (else false))) + +(define (rtl:interpreter-register? rtl-register) + (case rtl-register + ((INT-MASK) 1) + ((ENVIRONMENT) 3) + ((TEMPORARY) 4) + (else false))) + +(define (rtl:interpreter-register->offset locative) + (or (rtl:interpreter-register? locative) + (error "Unknown register type" locative))) + +(define (rtl:constant-cost expression) + ;; Magic numbers. + ;; 0, #F and '() all live in registers. + ;; Is there any reason that all these costs were originally >0 ? + ;; Making 0 #F and '() all 0 cost prevents any spurious rtl cse. + ;; *** THIS IS A BAD IDEA - it makes substitutions even though there might + ;; not be rules to handle it! + (let ((if-integer + (lambda (value) + (cond ((zero? value) 1) + ((fits-in-5-bits-signed? value) 2) + (else 3))))) + (let ((if-synthesized-constant + (lambda (type datum) + (if-integer (make-non-pointer-literal type datum))))) + (case (rtl:expression-type expression) + ((CONSTANT) + (let ((value (rtl:constant-value expression))) + (cond ((eq? value #F) 1) + ((eq? value '()) 1) + ((non-pointer-object? value) + (if-synthesized-constant (object-type value) + (object-datum value))) + (else 3)))) + ((MACHINE-CONSTANT) + (if-integer (rtl:machine-constant-value expression))) + ((ENTRY:PROCEDURE + ENTRY:CONTINUATION + ASSIGNMENT-CACHE + VARIABLE-CACHE + OFFSET-ADDRESS + BYTE-OFFSET-ADDRESS + FLOAT-OFFSET-ADDRESS) + 3) + ((CONS-POINTER) + (and (rtl:machine-constant? (rtl:cons-pointer-type expression)) + (rtl:machine-constant? (rtl:cons-pointer-datum expression)) + (if-synthesized-constant + (rtl:machine-constant-value (rtl:cons-pointer-type expression)) + (rtl:machine-constant-value + (rtl:cons-pointer-datum expression))))) + ;; This case causes OBJECT->FIXNUM to be combined with + ;; FIXNUM-PRED-1-ARGs and FIXNUM-PRED-2-ARGS: + ;((OBJECT->FIXNUM) + ; (if (rtl:register? (rtl:object->fixnum-expression expression)) + ; 0 + ; (rtl:expression-cost (rtl:object->fixnum-expression expression)))) + ;;((OBJECT->UNSIGNED-FIXNUM) + ;; (- (rtl:expression-cost + ;; (rtl:object->unsigned-fixnum-expression expression)) + ;; 1)) + ;;((FIXNUM->OBJECT) + ;; (+ (rtl:expression-cost (rtl:fixnum->object-expression expression)) + ;; 1)) + (else false))))) + +(define compiler:open-code-floating-point-arithmetic? + true) + +(define compiler:primitives-with-no-open-coding + '(DIVIDE-FIXNUM GCD-FIXNUM &/ FLONUM-ROUND->EXACT + FLONUM-TRUNCATE->EXACT FLONUM-FLOOR->EXACT + FLONUM-CEILING->EXACT FLONUM-NORMALIZE + FLONUM-DENORMALIZE FLONUM-EXPT)) + +(define (generic->inline-data generic-op) + (define (generic-additive-test constant) + (and (exact-integer? constant) + (< (abs constant) (/ unsigned-fixnum/upper-limit 2)))) + (define (fixnum? x) + (fix:fixnum? x)) + (define (make-rtl-fixnum-1-arg-coder name) + (lambda (operand) + (rtl:make-fixnum-1-arg + name (rtl:make-object->fixnum operand) true))) + (define (make-rtl-fixnum-pred-1-arg-coder name) + (lambda (operand) + (rtl:make-fixnum-pred-1-arg name (rtl:make-object->fixnum operand)))) + (define (make-rtl-fixnum-2-arg-coder name) + (lambda (operand1 operand2) + (rtl:make-fixnum-2-args name + (rtl:make-object->fixnum operand1) + (rtl:make-object->fixnum operand2) + true))) + (define (make-rtl-fixnum-pred-2-arg-coder name) + (lambda (operand1 operand2) + (if (eq? name 'EQUAL-FIXNUM?) + ;; This produces better code. + (rtl:make-eq-test operand1 operand2) + (rtl:make-fixnum-pred-2-args name + (rtl:make-object->fixnum operand1) + (rtl:make-object->fixnum operand2))))) + (case generic-op + ;; Returns # + ((integer-add &+) + (values 'GENERIC-ADDITIVE-TEST generic-additive-test + (make-rtl-fixnum-2-arg-coder 'PLUS-FIXNUM))) + ((integer-subtract &-) + (values 'GENERIC-ADDITIVE-TEST generic-additive-test + (make-rtl-fixnum-2-arg-coder 'MINUS-FIXNUM))) + ((integer-multiply &*) + (values 'FIXNUM? fixnum? + (make-rtl-fixnum-2-arg-coder 'MULTIPLY-FIXNUM))) + ((integer-quotient quotient) + (values 'FIXNUM? fixnum? + (make-rtl-fixnum-2-arg-coder 'FIXNUM-QUOTIENT))) + ((integer-remainder remainder) + (values 'FIXNUM? fixnum? + (make-rtl-fixnum-2-arg-coder 'FIXNUM-REMAINDER))) + ((integer-add-1 1+) + (values 'GENERIC-ADDITIVE-TEST generic-additive-test + (make-rtl-fixnum-1-arg-coder 'ONE-PLUS-FIXNUM))) + ((integer-subtract-1 -1+) + (values 'GENERIC-ADDITIVE-TEST generic-additive-test + (make-rtl-fixnum-1-arg-coder 'MINUS-ONE-PLUS-FIXNUM))) + ((integer-negate) + (values 'GENERIC-ADDITIVE-TEST generic-additive-test + (make-rtl-fixnum-1-arg-coder 'FIXNUM-NEGATE))) + ((integer-less? &<) + (values 'FIXNUM? fixnum? + (make-rtl-fixnum-pred-2-arg-coder 'LESS-THAN-FIXNUM?))) + ((integer-greater? &>) + (values 'FIXNUM? fixnum? + (make-rtl-fixnum-pred-2-arg-coder 'GREATER-THAN-FIXNUM?))) + ((integer-equal? &=) + (values 'FIXNUM? fixnum? + (make-rtl-fixnum-pred-2-arg-coder 'EQUAL-FIXNUM?))) + ((integer-zero? zero?) + (values 'FIXNUM? fixnum? + (make-rtl-fixnum-pred-1-arg-coder 'ZERO-FIXNUM?))) + ((integer-positive? positive?) + (values 'FIXNUM? fixnum? + (make-rtl-fixnum-pred-1-arg-coder 'POSITIVE-FIXNUM?))) + ((integer-negative? negative?) + (values 'FIXNUM? fixnum? + (make-rtl-fixnum-pred-1-arg-coder 'NEGATIVE-FIXNUM?))) + (else (error "Can't find corresponding fixnum op:" generic-op)))) + +;(define (target-object-type object) +; ;; This should be fixed for cross-compilation +; (if (and (fix:fixnum? object) +; (negative? object)) +; #x3F +; (object-type object))) + +(define (target-object-type object) + (object-type object)) diff --git a/v8/src/compiler/machines/spectrum/make.scm b/v8/src/compiler/machines/spectrum/make.scm new file mode 100644 index 000000000..3fdcbf30e --- /dev/null +++ b/v8/src/compiler/machines/spectrum/make.scm @@ -0,0 +1,65 @@ +#| -*-Scheme-*- + +$Id: make.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ + +Copyright (c) 1988-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Compiler: System Construction + +(declare (usual-integrations)) + +(let ((old-purify purify)) + ;; This temporary monkey-business stops uncompiled code from being + ;; purified so that TRACE & BREAK dont take so long + (fluid-let + ((purify (lambda (thing) + (if (not (comment? thing)) + (old-purify thing))))) + + ;; Original expression + (let ((value ((load "base/make") + (lambda () + (string-append + "HP PA untagged fixnums and entries, " + (number->string + ((access rtlgen/number-of-argument-registers + (->environment '(compiler midend))))) + " arg regs"))))) + (set! (access compiler:compress-top-level? (->environment '(compiler))) + true) + value))) + + + +(load "midend/load" #F) + + + diff --git a/v8/src/compiler/machines/spectrum/rgspcm.scm b/v8/src/compiler/machines/spectrum/rgspcm.scm new file mode 100644 index 000000000..590f4f8be --- /dev/null +++ b/v8/src/compiler/machines/spectrum/rgspcm.scm @@ -0,0 +1,84 @@ +#| -*-Scheme-*- + +$Id: rgspcm.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ + +Copyright (c) 1987-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Generation: Special primitive combinations. Spectrum version. + +(declare (usual-integrations)) + +(define (define-special-primitive-handler name handler) + (let ((primitive (make-primitive-procedure name true))) + (let ((entry (assq primitive special-primitive-handlers))) + (if entry + (set-cdr! entry handler) + (set! special-primitive-handlers + (cons (cons primitive handler) + special-primitive-handlers))))) + name) + +(define (special-primitive-handler primitive) + (let ((entry (assq primitive special-primitive-handlers))) + (and entry + ((cdr entry))))) + +(define special-primitive-handlers + '()) + +(define (define-special-primitive/standard primitive) + (define-special-primitive-handler primitive + (lambda () + rtl:make-invocation:special-primitive))) + +(define (define-special-primitive/if-open-coding primitive) + (define-special-primitive-handler primitive + (lambda () + (and compiler:open-code-primitives? + rtl:make-invocation:special-primitive)))) + +(define-special-primitive/standard '&+) +(define-special-primitive/standard '&-) +(define-special-primitive/standard '&*) +(define-special-primitive/standard '&/) +(define-special-primitive/standard '&=) +(define-special-primitive/standard '&<) +(define-special-primitive/standard '&>) +(define-special-primitive/standard '1+) +(define-special-primitive/standard '-1+) +(define-special-primitive/standard 'zero?) +(define-special-primitive/standard 'positive?) +(define-special-primitive/standard 'negative?) +(define-special-primitive/standard 'quotient) +(define-special-primitive/standard 'remainder) +(define-special-primitive/if-open-coding 'vector-cons) +(define-special-primitive/if-open-coding 'string-allocate) +(define-special-primitive/if-open-coding 'floating-vector-cons) \ No newline at end of file diff --git a/v8/src/compiler/machines/spectrum/rules1.scm b/v8/src/compiler/machines/spectrum/rules1.scm new file mode 100644 index 000000000..90a28439a --- /dev/null +++ b/v8/src/compiler/machines/spectrum/rules1.scm @@ -0,0 +1,496 @@ +#| -*-Scheme-*- + +$Id: rules1.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ + +Copyright (c) 1989-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Data Transfers +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +;;;; Simple Operations + +;;; All assignments to pseudo registers are required to delete the +;;; dead registers BEFORE performing the assignment. However, it is +;;; necessary to derive the effective address of the source +;;; expression(s) before deleting the dead registers. Otherwise any +;;; source expression containing dead registers might refer to aliases +;;; which have been reused. + +;;(define-rule statement +;; (ASSIGN (REGISTER (? target)) (REGISTER (? source))) +;; (standard-move-to-target! source target) +;; (LAP)) + +(define-rule statement + ;; tag the contents of a register + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum)))) + (let* ((type (standard-source! type)) + (target (standard-move-to-target! datum target))) + (LAP (DEP () ,type ,(-1+ scheme-type-width) ,scheme-type-width ,target)))) + +(define-rule statement + ;; tag the contents of a register + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source)))) + ;; (QUALIFIER (fits-in-5-bits-signed? type)) + ;; This qualifier does not work because the qualifiers are not + ;; tested in the rtl compressor. The qualifier is combined with + ;; the rule body into a single procedure, and the rtl compressor + ;; cannot invoke it since it is not in the context of the lap + ;; generator. Thus the qualifier is not checked, the RTL instruction + ;; is compressed, and then the lap generator fails when the qualifier + ;; fails. + (if (= 0 type) + (standard-unary-conversion source target object->datum) + (adjust-type (if (value-class=address? (register-value-class source)) + quad-mask-value + #F) + type + (standard-move-to-target! source target)))) + +(define-rule statement + ;; Tag the contents of a register. This rule is here just to fix the + ;; poor targeting of the value register when returning an open coded + ;; allocator. Usually target=r2 and base=free. + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (OFFSET-ADDRESS (REGISTER (? base)) + (MACHINE-CONSTANT (? offset))))) + (let ((base (standard-source! base)) + (target (standard-target! target))) + (LAP ,@(load-offset (* 4 offset) base target) + ,@(adjust-type (if (value-class=address? (register-value-class base)) + quad-mask-value + #F) + type + target)))) + +(define-rule statement + ;; extract the type part of a register's contents + (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source)))) + (standard-unary-conversion source target object->type)) + +(define-rule statement + ;; extract the datum part of a register's contents + (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source)))) + (standard-unary-conversion source target object->datum)) + + +;(define-rule statement +; ;; extract the value of a scheme fixnum as an unsigned machine value +; (ASSIGN (REGISTER (? target)) (OBJECT->UNSIGNED-FIXNUM (REGISTER (? source)))) +; (standard-move-to-target! source target) +; (LAP)) + +(define-rule statement + ;; convert the contents of a register to an address + (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source)))) + (object->address (standard-move-to-target! source target))) + +(define-rule statement + ;; pop an object off the stack + (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER (? reg)) 1)) + (QUALIFIER (= reg regnum:stack-pointer)) + (LAP + (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,(standard-target! target)))) + +(define-rule statement + ;; pop an address off the stack: usually the dynamic link + (ASSIGN (REGISTER (? target)) + (OBJECT->ADDRESS (POST-INCREMENT (REGISTER (? reg)) 1))) + (QUALIFIER (= reg regnum:stack-pointer)) + (let ((tgt (standard-target! target))) + (LAP + (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,tgt) + ,@(object->address tgt)))) + +;;;; Indexed modes + +(define-rule statement + ;; read an object from memory + (ASSIGN (REGISTER (? target)) + (OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))) + (standard-unary-conversion base target + (lambda (base target) + (load-word (* 4 offset) base target)))) + +(define-rule statement + ;; read an object from memory + (ASSIGN (REGISTER (? target)) + (OFFSET (REGISTER (? base)) (REGISTER (? offset)))) + (let ((base (standard-source! base)) + (offset (standard-source! offset))) + (let ((target (standard-target! target))) + (LAP (LDWX (S) (INDEX ,offset 0 ,base) ,target))))) + +;;;; Address manipulation + +(define-rule statement + ;; add a constant offset (in long words) to a register's contents + (ASSIGN (REGISTER (? target)) + (OFFSET-ADDRESS (REGISTER (? base)) + (MACHINE-CONSTANT (? offset)))) + (standard-unary-conversion base target + (lambda (base target) + (load-offset (* 4 offset) base target)))) + +(define-rule statement + ;; add a constant offset (in bytes) to a register's contents + (ASSIGN (REGISTER (? target)) + (BYTE-OFFSET-ADDRESS (REGISTER (? base)) + (MACHINE-CONSTANT (? offset)))) + (standard-unary-conversion base target + (lambda (base target) + (load-offset offset base target)))) + +(define-rule statement + ;; add a constant offset (in bytes) to a register's contents + (ASSIGN (REGISTER (? target)) + (FLOAT-OFFSET-ADDRESS (REGISTER (? base)) + (MACHINE-CONSTANT (? offset)))) + (standard-unary-conversion base target + (lambda (base target) + (load-offset (* 8 offset) base target)))) + +(define-rule statement + ;; add a computed offset (in long words) to a register's contents + (ASSIGN (REGISTER (? target)) + (OFFSET-ADDRESS (REGISTER (? base)) + (REGISTER (? offset)))) + (indexed-load-address target base offset 4)) + +(define-rule statement + ;; add a computed offset (in long words) to a register's contents + (ASSIGN (REGISTER (? target)) + (BYTE-OFFSET-ADDRESS (REGISTER (? base)) + (REGISTER (? offset)))) + (indexed-load-address target base offset 1)) + +(define-rule statement + ;; add a computed offset (in long words) to a register's contents + (ASSIGN (REGISTER (? target)) + (FLOAT-OFFSET-ADDRESS (REGISTER (? base)) + (REGISTER (? offset)))) + (indexed-load-address target base offset 8)) + +;;; Optimized address operations + +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base))) +; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index))))) +; (indexed-object->address target base index 4)) + +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (BYTE-OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base))) +; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index))))) +; (indexed-object->address target base index 1)) + +;; These have to be here because the instruction combiner +;; operates by combining one piece at a time, and the intermediate +;; pieces can be generated. + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base))) + (REGISTER (? index)))) + (indexed-object->address target base index 4)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (BYTE-OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base))) + (REGISTER (? index)))) + (indexed-object->address target base index 1)) + +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (OFFSET-ADDRESS (REGISTER (? base)) +; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index))))) +; (indexed-object->datum target base index 4)) + +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (BYTE-OFFSET-ADDRESS (REGISTER (? base)) +; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index))))) +; (indexed-object->datum target base index 1)) + +(define (indexed-load-address target base index scale) + (let ((base (standard-source! base)) + (index (standard-source! index))) + (%indexed-load-address (standard-target! target) base index scale))) + +;(define (indexed-object->datum target base index scale) +; (let ((base (standard-source! base)) +; (index (standard-source! index)) +; (temp (standard-temporary!))) +; (let ((target (standard-target! target))) +; ;;(LAP ,@(object->datum index temp) +; ;; ,@(%indexed-load-address target base temp scale)) +; (LAP ,@(%indexed-load-address target base index scale))))) + +(define (indexed-object->address target base index scale) + (let ((base (standard-source! base)) + (index (standard-source! index))) + (let ((target (standard-target! target))) + (LAP ,@(%indexed-load-address target base index scale) + ,@(object->address target))))) + +(define (%indexed-load-address target base index scale) + (case scale + ((4) + (LAP (SH2ADDL () ,index ,base ,target))) + ((8) + (LAP (SH3ADDL () ,index ,base ,target))) + ((1) + (LAP (ADDL () ,index ,base ,target))) + ((2) + (LAP (SH1ADDL () ,index ,base ,target))) + (else + (error "%indexed-load-address: Unknown scale")))) + +;;;; Loading of Constants + +(define-rule statement + ;; load a machine constant + (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? source))) + (load-immediate source (standard-target! target))) + +(define-rule statement + ;; load a Scheme constant + (ASSIGN (REGISTER (? target)) (CONSTANT (? source))) + (load-constant source (standard-target! target))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) (? source register-expression)) + (standard-move-to-target! source target) + (LAP)) + +(define-rule statement + ;; load the type part of a Scheme constant + (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (CONSTANT (? constant)))) + (load-non-pointer 0 (object-type constant) (standard-target! target))) + +(define-rule statement + ;; load the datum part of a Scheme constant + (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant)))) + (QUALIFIER (non-pointer-object? constant)) + (load-non-pointer 0 + (careful-object-datum constant) + (standard-target! target))) + +(define-rule statement + ;; load a synthesized constant + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum)))) + (load-non-pointer type datum (standard-target! target))) + +(define-rule statement + ;; load the address of a variable reference cache + (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name))) + (load-pc-relative (free-reference-label name) + (standard-target! target) + 'CONSTANT)) + +(define-rule statement + ;; load the address of an assignment cache + (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name))) + (load-pc-relative (free-assignment-label name) + (standard-target! target) + 'CONSTANT)) + +(define-rule statement + ;; load the address of a procedure's entry point + (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label))) + (load-pc-relative-address label (standard-target! target) 'CODE)) + +(define-rule statement + ;; load the address of a continuation + (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label))) + (load-pc-relative-address label (standard-target! target) 'CODE)) + +;;; Spectrum optimizations + +(define (load-entry label target) + (let ((target (standard-target! target))) + (LAP ,@(load-pc-relative-address label target 'CODE) + ,@(address->entry target)))) + +(define-rule statement + ;; load a procedure object + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (ENTRY:PROCEDURE (? label)))) + (QUALIFIER (= type (ucode-type compiled-entry))) + (load-entry label target)) + +(define-rule statement + ;; load a return address object + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (ENTRY:CONTINUATION (? label)))) + (QUALIFIER (= type (ucode-type compiled-entry))) + (load-entry label target)) + +;;;; Transfers to Memory + +(define-rule statement + ;; store an object in memory + (ASSIGN (OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset))) + (? source register-expression)) + (QUALIFIER (word-register? source)) + (store-word (standard-source! source) + (* 4 offset) + (standard-source! base))) + +(define-rule statement + ;; Push an object register on the heap + ;; *** IMPORTANT: This uses a STWS instruction with the cache hint set. + ;; The cache hint prevents newer HP PA processors from loading a cache + ;; line from memory when it is about to be overwritten. + ;; In theory this could cause a problem at the very end (64 bytes) of the + ;; heap, since the last cache line may overlap the next area (the stack). + ;; *** + (ASSIGN (POST-INCREMENT (REGISTER (? reg)) 1) (? source register-expression)) + (QUALIFIER (and (= reg regnum:free-pointer) + (word-register? source))) + (LAP + (STWS (MA C) ,(standard-source! source) (OFFSET 4 0 ,regnum:free-pointer)))) + +(define-rule statement + ;; Push an object register on the stack + (ASSIGN (PRE-INCREMENT (REGISTER (? reg)) -1) (? source register-expression)) + (QUALIFIER (and (word-register? source) + (= reg regnum:stack-pointer))) + (LAP + (STWM () ,(standard-source! source) (OFFSET -4 0 ,regnum:stack-pointer)))) + +;; Cheaper, common patterns. + +;(define-rule statement +; (ASSIGN (OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset))) +; (MACHINE-CONSTANT 0)) +; (store-word 0 +; (* 4 offset) +; (standard-source! base))) +; +;(define-rule statement +; (ASSIGN (POST-INCREMENT (REGISTER (? reg)) 1) (MACHINE-CONSTANT 0)) +; (QUALIFIER (= reg regnum:free-pointer)) +; (LAP (STWS (MA C) 0 (OFFSET 4 0 ,regnum:free-pointer)))) +; +;(define-rule statement +; (ASSIGN (PRE-INCREMENT (REGISTER (? reg)) -1) (MACHINE-CONSTANT 0)) +; (QUALIFIER (= reg regnum:stack-pointer)) +; (LAP (STWM () 0 (OFFSET -4 0 ,regnum:stack-pointer)))) + +;;;; CHAR->ASCII/BYTE-OFFSET + +(define-rule statement + ;; load char object from memory and convert to ASCII byte + (ASSIGN (REGISTER (? target)) + (CHAR->ASCII (OFFSET (REGISTER (? base)) + (MACHINE-CONSTANT (? offset))))) + (standard-unary-conversion base target + (lambda (base target) + (load-byte (+ 3 (* 4 offset)) base target)))) + +(define-rule statement + ;; load ASCII byte from memory + (ASSIGN (REGISTER (? target)) + (BYTE-OFFSET (REGISTER (? base)) + (MACHINE-CONSTANT (? offset)))) + (standard-unary-conversion base target + (lambda (base target) + (load-byte offset base target)))) + +(define-rule statement + ;; load ASCII byte from memory + (ASSIGN (REGISTER (? target)) + (BYTE-OFFSET (REGISTER (? base)) + (REGISTER (? offset)))) + (let ((base (standard-source! base)) + (offset (standard-source! offset))) + (let ((target (standard-target! target))) + (LAP (LDBX () (INDEX ,offset 0 ,base) ,target))))) + +(define-rule statement + ;; convert char object to ASCII byte + ;; Missing optimization: If source is home and this is the last + ;; reference (it is dead afterwards), an LDB could be done instead + ;; of an LDW followed by an object->datum. This is unlikely since + ;; the value will be home only if we've spilled it, which happens + ;; rarely. + (ASSIGN (REGISTER (? target)) + (CHAR->ASCII (REGISTER (? source)))) + (standard-unary-conversion source target + (lambda (source target) + (LAP (EXTRU () ,source 31 8 ,target))))) + +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (CHAR->ASCII (CONS-POINTER (? anything) (REGISTER (? source))))) +; anything ; ignore +; (standard-unary-conversion source target +; (lambda (source target) +; (LAP (EXTRU () ,source 31 8 ,target))))) + +(define-rule statement + ;; store ASCII byte in memory + (ASSIGN (BYTE-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset))) + (REGISTER (? source))) + (store-byte (standard-source! source) offset (standard-source! base))) + +(define-rule statement + ;; convert char object to ASCII byte and store it in memory + ;; register + byte offset <- contents of register (clear top bits) + (ASSIGN (BYTE-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset))) + (CHAR->ASCII (REGISTER (? source)))) + (store-byte (standard-source! source) offset (standard-source! base))) + +(define-rule statement + ;; store null byte in memory + (ASSIGN (BYTE-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset))) + (CHAR->ASCII (CONSTANT #\NUL))) + (store-byte 0 offset (standard-source! base))) + +;(define-rule statement +; ;; store a character without bothering to put a typecode on it +; (ASSIGN (BYTE-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset))) +; (CHAR->ASCII (CONS-POINTER (? anything) +; (REGISTER (? source))))) +; anything ; ignore +; (store-byte (standard-source! source) offset (standard-source! base))) + diff --git a/v8/src/compiler/machines/spectrum/rules2.scm b/v8/src/compiler/machines/spectrum/rules2.scm new file mode 100644 index 000000000..d42f7f279 --- /dev/null +++ b/v8/src/compiler/machines/spectrum/rules2.scm @@ -0,0 +1,184 @@ +#| -*-Scheme-*- + +$Id: rules2.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Predicates + +(declare (usual-integrations)) + +;(define-rule predicate +; ;; test for two registers EQ? +; (EQ-TEST (REGISTER (? source1)) (REGISTER (? source2))) +; (compare '= (standard-source! source1) (standard-source! source2))) +; +;(define-rule predicate +; (EQ-TEST (MACHINE-CONSTANT 0) (REGISTER (? register))) +; (compare-immediate '= 0 (standard-source! register))) +; +;(define-rule predicate +; (EQ-TEST (REGISTER (? register)) (MACHINE-CONSTANT 0)) +; (compare-immediate '= 0 (standard-source! register))) + +(define-rule predicate + ;; test for register EQ? to constant + (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register))) + (eq-test/constant*register constant register)) + +(define-rule predicate + ;; test for register EQ? to constant + (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant))) + (eq-test/constant*register constant register)) + +(define (eq-test/constant*register constant source) + (let ((source (standard-source! source))) + (if (non-pointer-object? constant) + (compare-immediate '= (non-pointer->literal constant) source) + (let ((temp (standard-temporary!))) + (LAP ,@(load-constant constant temp) + ,@(compare '= temp source)))))) + +(define-rule predicate + ;; test for register EQ? to synthesized constant + (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum))) + (REGISTER (? register))) + (eq-test/synthesized-constant*register type datum register)) + +(define-rule predicate + ;; test for register EQ? to synthesized constant + (EQ-TEST (REGISTER (? register)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum)))) + (eq-test/synthesized-constant*register type datum register)) + +(define (eq-test/synthesized-constant*register type datum source) + (compare-immediate '= + (make-non-pointer-literal type datum) + (standard-source! source))) + +(define-rule predicate + ;; test for two registers, or values EQ? + (EQ-TEST (? source1 register-expression) (? source2 register-expression)) + (compare '= (standard-source! source1) (standard-source! source2))) + +(define-rule predicate + (PRED-1-ARG FALSE? (REGISTER (? source))) + (if compiler:generate-trap-on-null-valued-conditional? + (let ((source (standard-source! source))) + (set-current-branches! + (lambda (label) + (LAP (COMBN (=) ,regnum:false-value ,source (@PCR ,label)) + (COMCLR (<>) ,regnum:empty-list ,source 0) + (BREAK () 0 0))) + (lambda (label) + (let ((local-label (generate-uninterned-symbol 'quasi-bogon-))) + (LAP (COMBN (=) ,regnum:false-value ,source (@PCR ,local-label)) + (COMBN (<>) ,regnum:empty-list ,source (@PCR ,label)) + (BREAK () 0 0) + (LABEL ,local-label))))) + (LAP)) + (compare '= regnum:false-value (standard-source! source)))) + +(define-rule predicate + (PRED-1-ARG NULL? (REGISTER (? source))) + (compare '= regnum:empty-list (standard-source! source))) + +(define-rule predicate + ;; Branch if virtual register contains the specified type number + (TYPE-TEST (REGISTER (? register)) (? type)) + (QUALIFIER (exact-integer? type)) + (compare-immediate '= type (standard-source! register))) + +(define-rule predicate + ;; Branch if virtual register contains the specified type number + (TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) 0) + (let ((src (standard-source! register))) + (set-current-branches! + (lambda (if-true) + (LAP (EXTRU (<>) ,src ,(-1+ scheme-type-width) ,scheme-type-width 0) + (B (N) (@PCR ,if-true)))) + (lambda (if-false) + (LAP (EXTRU (=) ,src ,(-1+ scheme-type-width) ,scheme-type-width 0) + (B (N) (@PCR ,if-false))))) + (LAP))) + +(define-rule predicate + (PRED-2-ARGS SMALL-FIXNUM? + (REGISTER (? source)) + (MACHINE-CONSTANT (? nbits))) + (let* ((src (standard-source! source)) + (temp (standard-temporary!))) + (LAP (EXTRS () ,src 31 ,(- (+ scheme-datum-width 1) nbits) ,temp) + ,@(COMPARE '= src temp)))) + +(define-rule predicate + (PRED-1-ARG GENERIC-ADDITIVE-TEST (REGISTER (? source))) + (let ((temp (standard-temporary!)) + (src (standard-source! source))) + (LAP (EXTRS () ,src 31 ,scheme-datum-width ,temp) + ,@(compare '= src temp)))) + +(define-rule predicate + (PRED-1-ARG FIXNUM? (REGISTER (? source))) + (let ((temp (standard-temporary!)) + (src (standard-source! source))) + (LAP (EXTRS () ,src 31 ,(1+ scheme-datum-width) ,temp) + ,@(compare '= src temp)))) + +#| +;; Taken care of by rewrite +(define-rule predicate + (PRED-1-ARG INDEX-FIXNUM? (REGISTER (? source))) + (let ((temp (standard-temporary!)) + (src (standard-source! source))) + (LAP (blah blah blah)))) +|# + +(define-rule predicate + (PRED-2-ARGS WORD-LESS-THAN-UNSIGNED? + (REGISTER (? smaller)) + (REGISTER (? larger))) + (compare '<< (standard-source! smaller) (standard-source! larger))) + +(define-rule predicate + (PRED-2-ARGS WORD-LESS-THAN-UNSIGNED? + (CONSTANT (? smaller)) + (REGISTER (? larger))) + (compare-immediate '<< smaller (standard-source! larger))) + +(define-rule predicate + (PRED-2-ARGS WORD-LESS-THAN-UNSIGNED? + (REGISTER (? smaller)) + (CONSTANT (? larger))) + (compare-immediate '>> (standard-source! smaller) larger)) + diff --git a/v8/src/compiler/machines/spectrum/rules3.scm b/v8/src/compiler/machines/spectrum/rules3.scm new file mode 100644 index 000000000..707b04932 --- /dev/null +++ b/v8/src/compiler/machines/spectrum/rules3.scm @@ -0,0 +1,1693 @@ +#| -*-Scheme-*- + +$Id: rules3.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Invocations and Entries +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +;;;; Invocations + +(define-rule statement + (POP-RETURN) + (pop-return)) + +(define (pop-return) + (let ((temp (standard-temporary!))) + (LAP ,@(clear-map!) + ;; This assumes that the return address is always longword aligned + ;; (it better be, since instructions should be longword aligned). + ;; Thus the bottom two bits of temp are 0, representing the + ;; highest privilege level, and the privilege level will + ;; not be changed by the BV instruction. + (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,temp) + ;; Originally was ,@(object->address temp) + ,@(entry->address temp) + (BV (N) 0 ,temp)))) + +(define (%invocation:apply frame-size) + (case frame-size + ((1) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-1 4 + ,regnum:scheme-to-interface-ble)))) + ((2) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-2 4 + ,regnum:scheme-to-interface-ble)))) + ((3) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-3 4 + ,regnum:scheme-to-interface-ble)))) + ((4) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-4 4 + ,regnum:scheme-to-interface-ble)))) + ((5) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-5 4 + ,regnum:scheme-to-interface-ble)))) + ((6) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-6 4 + ,regnum:scheme-to-interface-ble)))) + ((7) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-7 4 + ,regnum:scheme-to-interface-ble)))) + ((8) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-8 4 + ,regnum:scheme-to-interface-ble)))) + (else + (LAP ,@(load-immediate frame-size regnum:second-arg) + (BLE () (OFFSET ,hook:compiler-shortcircuit-apply 4 + ,regnum:scheme-to-interface-ble)))))) + +(define-rule statement + (INVOCATION:APPLY (? frame-size) (? continuation)) + continuation ;ignore + (LAP ,@(clear-map!) + ,@(%invocation:apply frame-size) + (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,regnum:first-arg))) + +(define-rule statement + (INVOCATION:JUMP (? frame-size) (? continuation) (? label)) + frame-size continuation ;ignore + (LAP ,@(clear-map!) + (B (N) (@PCR ,label)))) + +(define-rule statement + (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation)) + frame-size continuation ;ignore + ;; It expects the procedure at the top of the stack + (pop-return)) + +(define-rule statement + (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label)) + continuation ;ignore + (LAP ,@(clear-map!) + ,@(load-immediate number-pushed regnum:second-arg) + ,@(load-pc-relative-address label regnum:first-arg 'CODE) + ,@(invoke-interface code:compiler-lexpr-apply))) + +(define-rule statement + (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation)) + continuation ;ignore + ;; Destination address is at TOS; pop it into first-arg + (LAP ,@(clear-map!) + (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,regnum:first-arg) + ,@(load-immediate number-pushed regnum:second-arg) + ,@(object->address regnum:first-arg) + ,@(invoke-interface code:compiler-lexpr-apply))) + +#| + (define-rule statement + (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name)) + continuation ;ignore + (LAP ,@(clear-map!) + (B (N) (@PCR ,(free-uuo-link-label name frame-size))))) +|# +(define-rule statement + (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name)) + (invocation:some-uuo-link frame-size continuation name free-uuo-link-label)) + +(define-rule statement + (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name)) + (invocation:some-uuo-link frame-size continuation name + global-uuo-link-label)) + +(define (invocation:some-uuo-link frame-size continuation name label-generator) + (if continuation + (if compiler:compile-by-procedures? ; i.e. small offsets + ;; Perhaps a better idea than this would be to generate the general + ;; code and peephole optimise + ;; (BL () r (@pco 0)) + ;; (LDO/LDW () (offset d 0 r) t) + ;; (B (N) (@pcr label)) + ;; to + ;; (BL () t (@pcr label) + ;; (LDO/LDW () (offset d 0 t) t) + ;; where d' + + (let ((here (generate-label))) + (let ((value `(+ ,here ,(+ 8 *privilege-level*)))) + (LAP ,@(clear-map!) + (LABEL ,here) + (BL () 19 (@PCR ,(label-generator name frame-size))) + (LDO () (OFFSET (- ,continuation ,value) 0 19) 19)))) + (LAP ,@(clear-map!) + ,@(load-pc-relative-address continuation 19 'CODE) + (B (N) (@PCR ,(label-generator name frame-size))))) + (LAP ,@(clear-map!) + (B (N) (@PCR ,(label-generator name frame-size)))))) + + +(define-rule statement + (INVOCATION:CACHE-REFERENCE (? frame-size) + (? continuation) + (? extension register-expression)) + continuation ;ignore + (LAP ,@(load-interface-args! extension false false false) + ,@(load-immediate frame-size regnum:third-arg) + ,@(load-pc-relative-address *block-label* regnum:second-arg 'CODE) + ,@(invoke-interface code:compiler-cache-reference-apply))) + +(define-rule statement + (INVOCATION:LOOKUP (? frame-size) + (? continuation) + (? environment register-expression) + (? name)) + continuation ;ignore + (LAP ,@(load-interface-args! environment false false false) + ,(load-constant name regnum:second-arg) + ,(load-immediate frame-size regnum:third-arg) + ,@(invoke-interface code:compiler-lookup-apply))) + +(define-rule statement + (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive)) + continuation ;ignore + (if (eq? primitive compiled-error-procedure) + (LAP ,@(clear-map!) + ,@(load-immediate frame-size regnum:first-arg) + ,@(invoke-interface code:compiler-error)) + (let ((arity (primitive-procedure-arity primitive))) + (if (not (negative? arity)) + (invoke-primitive primitive + hook:compiler-invoke-primitive) + (LAP ,@(clear-map!) + ,@(load-pc-relative (constant->label primitive) + regnum:first-arg + 'CONSTANT) + ,@(cond ((= arity -1) + (LAP ,@(load-immediate (-1+ frame-size) 1) + (STW () 1 ,reg:lexpr-primitive-arity) + ,@(invoke-interface + code:compiler-primitive-lexpr-apply))) + #| + ((not (negative? arity)) + (invoke-interface code:compiler-primitive-apply)) + |# + (else + ;; Unknown primitive arity. Go through apply. + (LAP ,@(load-immediate frame-size regnum:second-arg) + ,@(invoke-interface code:compiler-apply))))))))) + +(define (invoke-primitive primitive hook) + ;; Only for known, fixed-arity primitives + (LAP ,@(clear-map!) + ,@(invoke-hook hook) + (WORD () (- ,(constant->label primitive) *PC*)))) + +(let-syntax + ((define-old-optimized-primitive-invocation + (macro (name) + `(define-rule statement + (INVOCATION:SPECIAL-PRIMITIVE + (? frame-size) + (? continuation) + ,(make-primitive-procedure name true)) + frame-size + (old-optimized-primitive-invocation + ,(symbol-append 'HOOK:COMPILER- name) + continuation)))) + + (define-optimized-primitive-invocation + (macro (name) + `(define-rule statement + (INVOCATION:SPECIAL-PRIMITIVE + (? frame-size) + (? continuation) + ,(make-primitive-procedure name true)) + frame-size + (optimized-primitive-invocation + ,(symbol-append 'HOOK:COMPILER- name) + continuation)))) + + (define-allocation-primitive + (macro (name) + (let ((prim (make-primitive-procedure name true))) + `(define-rule statement + (INVOCATION:SPECIAL-PRIMITIVE + (? frame-size) + (? continuation) + ,prim) + (open-code-block-allocation ',name ',prim + ,(symbol-append 'HOOK:COMPILER- name) + frame-size continuation)))))) + + (define-optimized-primitive-invocation &+) + (define-optimized-primitive-invocation &-) + (define-optimized-primitive-invocation &*) + (define-optimized-primitive-invocation &/) + (define-optimized-primitive-invocation &=) + (define-optimized-primitive-invocation &<) + (define-optimized-primitive-invocation &>) + (define-old-optimized-primitive-invocation 1+) + (define-old-optimized-primitive-invocation -1+) + (define-old-optimized-primitive-invocation zero?) + (define-old-optimized-primitive-invocation positive?) + (define-old-optimized-primitive-invocation negative?) + (define-optimized-primitive-invocation quotient) + (define-optimized-primitive-invocation remainder) + (define-allocation-primitive vector-cons) + (define-allocation-primitive string-allocate) + (define-allocation-primitive floating-vector-cons)) + +(define (preserving-regs clobbered-regs gen-suffix) + ;; THIS IS ***NOT*** GENERAL PURPOSE CODE. + ;; It assumes a bunch of things, like "the pseudo-registers + ;; currently assigned to the clobbered registers aren't going to be + ;; referenced before their contents are restored." + ;; It is intended only for preserving registers around in-line calls + ;; that may need to back in to the interpreter in rare cases. + (define *comments* '()) + (define (delete-clobbered-aliases-for-recomputable-pseudo-registers preserved) + (let* ((how (cadr preserved)) + (reg (car preserved))) + (if (eq? how 'RECOMPUTE) + (let ((entry (map-entries:find-home *register-map* reg))) + (if entry + (let* ((aliases (map-entry-aliases entry)) + (new-entry + (make-map-entry + (map-entry-home entry) + false ; Not in home anymore + (list-transform-negative aliases + (lambda (alias) (memq alias clobbered-regs))) + ; No clobbered regs. for aliases + (map-entry-label entry)))) + (set! *comments* + (append + *comments* + `((COMMENT CLOBBERDATA: (,reg ,how ,entry ,new-entry))))) + (set! *register-map* + (make-register-map + (map-entries:replace *register-map* entry new-entry) + (map-registers *register-map*))))))))) + (for-each delete-clobbered-aliases-for-recomputable-pseudo-registers + *preserved-registers*) + (let ((clean (apply require-registers! clobbered-regs))) + (LAP ,@clean + ,@*comments* + ,@(call-with-values + clear-map!/preserving + (lambda (machine-regs pseudo-regs) + (cond ((and (null? machine-regs) (null? pseudo-regs)) + (gen-suffix false)) + ((null? pseudo-regs) + (gen-suffix (->mask machine-regs false false))) + (else + (call-with-values + (lambda () (->bytes pseudo-regs)) + (lambda (gen-int-regs gen-float-regs) + (gen-suffix (->mask machine-regs + gen-int-regs + gen-float-regs))))))))))) + +(define (->bytes pseudo-regs) + ;; (values gen-int-regs gen-float-regs) + (define (do-regs regs) + (LAP (COMMENT (PSEUDO-REGISTERS . ,regs)) + ,@(bytes->uwords + (let* ((l (length regs)) + (bytes (reverse (cons l + (map register-renumber regs))))) + (append (let ((r (remainder (+ l 1) 4))) + (if (zero? r) + '() + (make-list (- 4 r) 0))) + bytes))))) + + (call-with-values + (lambda () + (list-split pseudo-regs + (lambda (reg) + (value-class=float? (pseudo-register-value-class reg))))) + (lambda (float-regs int-regs) + (values (and (not (null? int-regs)) + (lambda () (do-regs int-regs))) + (and (not (null? float-regs)) + (lambda () (do-regs float-regs))))))) + +(define (->mask machine-regs gen-int-regs gen-float-regs) + (let ((int-mask (make-bit-string 32 false)) + (flo-mask (make-bit-string 32 false))) + (if gen-int-regs + (bit-string-set! int-mask (- 31 0))) + (if gen-float-regs + (bit-string-set! int-mask (- 31 1))) + (let loop ((regs machine-regs)) + (cond ((not (null? regs)) + (let ((reg (car regs))) + (if (< reg 32) + (bit-string-set! int-mask (- 31 reg)) + (bit-string-set! flo-mask (- 31 (- reg 32)))) + (loop (cdr regs)))) + ((bit-string-zero? flo-mask) + (lambda () + (LAP ,@(if gen-float-regs (gen-float-regs) (LAP)) + ,@(if gen-int-regs (gen-int-regs) (LAP)) + (COMMENT (MACHINE-REGS . ,machine-regs)) + (UWORD () ,(bit-string->unsigned-integer int-mask))))) + (else + (bit-string-set! int-mask (- 31 31)) + (lambda () + (LAP ,@(if gen-float-regs (gen-float-regs) (LAP)) + (COMMENT (MACHINE-REGS . ,machine-regs)) + (UWORD () ,(bit-string->unsigned-integer flo-mask)) + ,@(if gen-int-regs (gen-int-regs) (LAP)) + (COMMENT (MACHINE-REGS . ,machine-regs)) + (UWORD () ,(bit-string->unsigned-integer int-mask))))))))) + +;; *** optimized-primitive-invocation and open-code-block-allocation +;; skip the first instruction of the hook as a way of signalling +;; that there are registers to preserve. Eventually the convention +;; can be changed, but this one is backwards compatible. *** + +(define *optimized-clobbered-regs* + (list g31 g2 g26 g25 g28 g29 fp4 fp5)) + +(define (optimized-primitive-invocation hook cont-label) + (preserving-regs + *optimized-clobbered-regs* + (lambda (gen-preservation-info) + (let ((load-continuation + (if cont-label + (load-pc-relative-address cont-label 19 'CODE) + '()))) + (if (not gen-preservation-info) + (LAP ,@load-continuation + ,@(invoke-hook/no-return hook)) + (let ((label1 (generate-label)) + (label2 (generate-label))) + (LAP ,@load-continuation + (BLE () (OFFSET ,hook 4 ,regnum:scheme-to-interface-ble)) + (LDO () (OFFSET (- (- ,label2 ,label1) ,*privilege-level*) + 0 31) + 31) + (LABEL ,label1) + ,@(gen-preservation-info) + (LABEL ,label2)))))))) + +(define (old-optimized-primitive-invocation hook cont-label) + (let ((load-continuation + (if cont-label + (load-pc-relative-address cont-label 19 'CODE) + '()))) + (LAP ,@(clear-map!) + ,@load-continuation + ,@(invoke-hook/no-return hook)))) + +(define *allocation-clobbered-regs* + (list g31 g2 g26 g25 g28 g29)) + +(define (open-code-block-allocation name prim hook frame-size cont-label) + name frame-size cont-label ; ignored + (preserving-regs + *allocation-clobbered-regs* + (lambda (gen-preservation-info) + (let ((load-continuation + (if cont-label + (load-pc-relative-address cont-label 19 'CODE) + '()))) + (if (not gen-preservation-info) + (LAP ,@(clear-map!) + ,@load-continuation + ,@(invoke-hook hook) + (WORD () (- ,(constant->label prim) *PC*))) + (let ((label1 (generate-label)) + (label2 (generate-label))) + (LAP ,@load-continuation + (BLE () (OFFSET ,hook 4 ,regnum:scheme-to-interface-ble)) + (ADDI () (- (- ,label2 ,label1) ,*privilege-level*) 31 31) + (LABEL ,label1) + ,@(gen-preservation-info) + (LABEL ,label2) + (WORD () (- ,(constant->label prim) *PC*))))))))) + +#| +(define (open-code-block-allocation name prim hook frame-size cont-label) + ;; One argument (length in units) on top of the stack. + ;; Note: The length checked is not necessarily the complete length + ;; of the object, but is off by a constant number of words, which + ;; is OK, since we can cons a finite number of words without + ;; checking. + (define (default) + (LAP ,@(clear-map!) + ,@(load-pc-relative (constant->label prim) + regnum:first-arg + 'CONSTANT) + ,@(invoke-interface code:compiler-primitive-apply))) + + hook ; ignored + (cond ((not (= frame-size 2)) + (error "open-code-allocate-block: Wrong number of arguments" + prim frame-size)) + ((not compiler:open-code-primitives?) + (default)) + (else + (let ((label (generate-label)) + (rsp regnum:stack-pointer) + (rfp regnum:free-pointer) + (rmp regnum:memtop-pointer) + (ra1 regnum:first-arg) + (ra2 regnum:second-arg) + (ra3 regnum:third-arg) + (rrv regnum:return-value)) + + (define (end tag rl) + (LAP ,@(deposit-type (ucode-type manifest-nm-vector) rl) + (STW () ,rl (OFFSET 0 0 ,rrv)) + ,@(deposit-type tag rrv) + (LDO () (OFFSET ,(* 4 frame-size) 0 ,rsp) ,rsp) + (B (N) (@PCR ,cont-label)) + (LABEL ,label) + ,@(default))) + + (case name + ((STRING-ALLOCATE) + (LAP (LDW () (OFFSET 0 0 ,rsp) ,ra1) + (COPY () ,rfp ,rrv) + ,@(object->datum ra1 ra1) + (ADD () ,ra1 ,rfp ,ra2) + (COMB (>= N) ,ra2 ,rmp (@PCR ,label)) + (STB () 0 (OFFSET 8 0 ,ra2)) + (SHD () 0 ,ra1 2 ,ra3) + (LDO () (OFFSET 2 0 ,ra3) ,ra3) + (STWS (MB) ,ra1 (OFFSET 4 0 ,rfp)) + (SH2ADD () ,ra3 ,rfp ,rfp) + ,@(end (ucode-type string) ra3))) + ((FLOATING-VECTOR-CONS) + (LAP (LDW () (OFFSET 0 0 ,rsp) ,ra1) + ;; (STW () 0 (OFFSET 0 0 ,rfp)) + (DEPI () #b100 31 3 ,rfp) ; 8-byte alignment for elements + (COPY () ,rfp ,rrv) + ,@(object->datum ra1 ra1) + (SH3ADD () ,ra1 ,rfp ,ra2) + (COMB (>= N) ,ra2 ,rmp (@PCR ,label)) + (SHD () ,ra1 0 31 ,ra1) + (LDO () (OFFSET 4 0 ,ra2) ,rfp) + ,@(end (ucode-type flonum) ra1))) + (else + (error "open-code-block-allocation: Unknown primitive" + name))))))) +|# + +;;;; Invocation Prefixes + +;;; MOVE-FRAME-UP size address +;;; +;;; Moves up the last words of the stack so that the first of +;;; these words is at location
, and resets the stack pointer +;;; to the last of these words. That is, it pops off all the words +;;; between
and TOS+/-. + +(define-rule statement + ;; Move up 0 words back to top of stack : a No-Op + (INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER (? reg))) + (QUALIFIER (= reg regnum:stack-pointer)) + (LAP)) + +#| +(define-rule statement + ;; Move words back to dynamic link marker + (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER (? reg))) + (QUALIFIER (= reg regnum:dynamic-link)) + (generate/move-frame-up frame-size + (lambda (reg) + (LAP (COPY () ,regnum:dynamic-link ,reg))))) +|# + +(define-rule statement + ;; Move words back to SP+offset + (INVOCATION-PREFIX:MOVE-FRAME-UP + (? frame-size) + (OFFSET-ADDRESS (REGISTER (? reg)) + (MACHINE-CONSTANT (? offset)))) + (QUALIFIER (= reg regnum:stack-pointer)) + (let ((how-far (* 4 (- offset frame-size)))) + (cond ((zero? how-far) + (LAP)) + ((negative? how-far) + (error "invocation-prefix:move-frame-up: bad specs" + frame-size offset)) + ((zero? frame-size) + (load-offset how-far regnum:stack-pointer regnum:stack-pointer)) + ((= frame-size 1) + (let ((temp (standard-temporary!))) + (LAP (LDWM () (OFFSET ,how-far 0 ,regnum:stack-pointer) ,temp) + (STW () ,temp (OFFSET 0 0 ,regnum:stack-pointer))))) + ((= frame-size 2) + (let ((temp1 (standard-temporary!)) + (temp2 (standard-temporary!))) + (LAP (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,temp1) + (LDWM () (OFFSET ,(- how-far 4) 0 ,regnum:stack-pointer) + ,temp2) + (STW () ,temp1 (OFFSET 0 0 ,regnum:stack-pointer)) + (STW () ,temp2 (OFFSET 4 0 ,regnum:stack-pointer))))) + (else + (generate/move-frame-up frame-size + (lambda (reg) + (load-offset (* 4 offset) regnum:stack-pointer reg))))))) + +(define-rule statement + ;; Move words back to base virtual register + offset + (INVOCATION-PREFIX:MOVE-FRAME-UP + (? frame-size) + (OFFSET-ADDRESS (REGISTER (? base)) + (MACHINE-CONSTANT (? offset)))) + (generate/move-frame-up frame-size + (lambda (reg) + (load-offset (* 4 offset) (standard-source! base) reg)))) + +;;; DYNAMIC-LINK instructions have a , , +;;; and as arguments. They pop the stack by +;;; removing the lesser of the amount needed to move the stack pointer +;;; back to the or . The last +;;; words on the stack (the stack frame for the procedure +;;; about to be called) are then put back onto the newly adjusted +;;; stack. + +#| +(define-rule statement + (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size) + (REGISTER (? source)) + (REGISTER (? reg))) + (QUALIFIER (= reg regnum:dynamic-link)) + (if (and (zero? frame-size) + (= source regnum:stack-pointer)) + (LAP) + (let ((env-reg (standard-move-to-temporary! source))) + (LAP + ;; skip if env LS dyn link + (SUB (<<=) ,env-reg ,regnum:dynamic-link 0) + ;; env <- dyn link + (COPY () ,regnum:dynamic-link ,env-reg) + ,@(generate/move-frame-up* frame-size env-reg))))) +|# + +(define (generate/move-frame-up frame-size destination-generator) + (let ((temp (standard-temporary!))) + (LAP ,@(destination-generator temp) + ,@(generate/move-frame-up* frame-size temp)))) + +(define (generate/move-frame-up* frame-size destination) + ;; Destination is guaranteed to be a machine register number; that + ;; register has the destination base address for the frame. The stack + ;; pointer is reset to the top end of the copied area. + (LAP ,@(case frame-size + ((0) + (LAP)) + ((1) + (let ((temp (standard-temporary!))) + (LAP (LDW () (OFFSET 0 0 ,regnum:stack-pointer) ,temp) + (STWM () ,temp (OFFSET -4 0 ,destination))))) + (else + (generate/move-frame-up** frame-size destination))) + (COPY () ,destination ,regnum:stack-pointer))) + +(define (generate/move-frame-up** frame-size dest) + (let ((from (standard-temporary!)) + (temp1 (standard-temporary!)) + (temp2 (standard-temporary!))) + (LAP ,@(load-offset (* 4 frame-size) regnum:stack-pointer from) + ,@(if (<= frame-size 3) + ;; This code can handle any number > 1 (handled above), + ;; but we restrict it to 3 for space reasons. + (let loop ((n frame-size)) + (case n + ((0) + (LAP)) + ((3) + (let ((temp3 (standard-temporary!))) + (LAP (LDWM () (OFFSET -4 0 ,from) ,temp1) + (LDWM () (OFFSET -4 0 ,from) ,temp2) + (LDWM () (OFFSET -4 0 ,from) ,temp3) + (STWM () ,temp1 (OFFSET -4 0 ,dest)) + (STWM () ,temp2 (OFFSET -4 0 ,dest)) + (STWM () ,temp3 (OFFSET -4 0 ,dest))))) + (else + (LAP (LDWM () (OFFSET -4 0 ,from) ,temp1) + (LDWM () (OFFSET -4 0 ,from) ,temp2) + (STWM () ,temp1 (OFFSET -4 0 ,dest)) + (STWM () ,temp2 (OFFSET -4 0 ,dest)) + ,@(loop (- n 2)))))) + (LAP ,@(load-immediate frame-size temp2) + (LDWM () (OFFSET -4 0 ,from) ,temp1) + (ADDIBF (=) -1 ,temp2 (@PCO -12)) + (STWM () ,temp1 (OFFSET -4 0 ,dest))))))) + +;;;; External Labels + +(define (make-external-label code label) + (set! *external-labels* (cons label *external-labels*)) + (LAP (EXTERNAL-LABEL () ,code (@PCR ,label)) + (LABEL ,label))) + +;;; Entry point types + +(define-integrable (make-code-word min max) + (+ (* #x100 min) max)) + +(define (make-procedure-code-word min max) + ;; The "min" byte must be less than #x80; the "max" byte may not + ;; equal #x80 but can take on any other value. + (if (or (negative? min) (>= min #x80)) + (error "MAKE-PROCEDURE-CODE-WORD: minimum out of range" min)) + (if (>= (abs max) #x80) + (error "MAKE-PROCEDURE-CODE-WORD: maximum out of range" max)) + (make-code-word min (if (negative? max) (+ #x100 max) max))) + +(define expression-code-word + (make-code-word #xff #xff)) + +(define internal-entry-code-word + (make-code-word #xff #xfe)) + +(define internal-continuation-code-word + (make-code-word #xff #xfc)) + +;; #xff #xfb taken up by return-to-interpreter and reflect-to-interface + +(define internal-closure-code-word + (make-code-word #xff #xfa)) + +(define (continuation-code-word label) + (frame-size->code-word + (if label + (rtl-continuation/next-continuation-offset (label->object label)) + 0) + internal-continuation-code-word)) + +(define (internal-procedure-code-word rtl-proc) + ;; represented as return addresses so the debugger will + ;; not barf when it sees them (on the stack if interrupted). + (frame-size->code-word + (rtl-procedure/next-continuation-offset rtl-proc) + internal-entry-code-word)) + +(define (frame-size->code-word offset default) + (cond ((not offset) + default) + ((< offset #x2000) + ;; This uses up through (#xff #xdf). + (let ((qr (integer-divide offset #x80))) + (make-code-word (+ #x80 (integer-divide-remainder qr)) + (+ #x80 (integer-divide-quotient qr))))) + (else + (error "Unable to encode continuation offset" offset)))) + +;;;; Procedure headers + +;;; The following calls MUST appear as the first thing at the entry +;;; point of a procedure. They assume that the register map is clear +;;; and that no register contains anything of value. +;;; +;;; The only reason that this is true is that no register is live +;;; across calls. If that were not true, then we would have to save +;;; any such registers on the stack so that they would be GC'ed +;;; appropriately. +;;; +;;; The only exception is the dynamic link register, handled +;;; specially. Procedures that require a dynamic link use a different +;;; interrupt handler that saves and restores the dynamic link +;;; register. + +#| +(define (simple-procedure-header code-word label code) + (let ((gc-label (generate-label))) + (LAP (LABEL ,gc-label) + ,@(invoke-interface-ble code) + ,@(make-external-label code-word label) + ,@(interrupt-check label gc-label)))) +|# + +#| +(define (dlink-procedure-header code-word label) + (let ((gc-label (generate-label))) + (LAP (LABEL ,gc-label) + (COPY () ,regnum:dynamic-link ,regnum:second-arg) + ,@(invoke-interface-ble code:compiler-interrupt-dlink) + ,@(make-external-label code-word label) + ,@(interrupt-check label gc-label)))) +|# + +#| +(define (interrupt-check label gc-label) + (case (let ((object (label->object label))) + (and (rtl-procedure? object) + (not (rtl-procedure/stack-leaf? object)) + compiler:generate-stack-checks?)) + ((#F) + (LAP (COMB (>=) ,regnum:free-pointer ,regnum:memtop-pointer + (@PCR ,gc-label)) + (LDW () ,reg:memtop ,regnum:memtop-pointer))) + ((OUT-OF-LINE) + (let ((label (generate-label))) + (LAP (BLE () + (OFFSET ,hook:compiler-stack-and-interrupt-check + 4 + ,regnum:scheme-to-interface-ble)) + ;; Assumes that (<= #x-2000 (- ,gc-label ,label) #x1fff) + ;; otherwise this assembles to two instructions, and it + ;; won't fit in the branch-delay slot. + (LDI () (- ,gc-label ,label) ,regnum:first-arg) + (LABEL ,label)))) + (else + (LAP (LDW () ,reg:stack-guard ,regnum:first-arg) + (COMB (>=) ,regnum:free-pointer ,regnum:memtop-pointer + (@PCR ,gc-label)) + (COMB (<=) ,regnum:stack-pointer ,regnum:first-arg (@PCR ,gc-label)) + (LDW () ,reg:memtop ,regnum:memtop-pointer))))) +|# + +(define-rule statement + (CONTINUATION-ENTRY (? internal-label)) + (make-external-label (continuation-code-word internal-label) + internal-label)) + +(define-rule statement + (CONTINUATION-HEADER (? internal-label)) + (simple-procedure-header (continuation-code-word internal-label) + internal-label + code:compiler-interrupt-continuation)) + +(define-rule statement + (IC-PROCEDURE-HEADER (? internal-label)) + (let ((procedure (label->object internal-label))) + (let ((external-label (rtl-procedure/external-label procedure))) + (LAP (ENTRY-POINT ,external-label) + (EQUATE ,external-label ,internal-label) + ,@(simple-procedure-header expression-code-word + internal-label + code:compiler-interrupt-ic-procedure))))) + +(define-rule statement + (OPEN-PROCEDURE-HEADER (? internal-label)) + (let ((rtl-proc (label->object internal-label))) + (LAP (EQUATE ,(rtl-procedure/external-label rtl-proc) ,internal-label) + ,@((if (rtl-procedure/dynamic-link? rtl-proc) + dlink-procedure-header + (lambda (code-word label) + (simple-procedure-header code-word label + code:compiler-interrupt-procedure))) + (internal-procedure-code-word rtl-proc) + internal-label)))) + +(define-rule statement + (PROCEDURE-HEADER (? internal-label) (? min) (? max)) + (LAP (EQUATE ,(rtl-procedure/external-label (label->object internal-label)) + ,internal-label) + ,@(simple-procedure-header (make-procedure-code-word min max) + internal-label + code:compiler-interrupt-procedure))) + +;;;; Closures. These two statements are intertwined: + +(define-rule statement + ;; This depends on the following facts: + ;; 1- TC_COMPILED_ENTRY is a multiple of two. + ;; 2- all the top 6 bits in a data address are 0 except the quad bit + ;; 3- type codes are 6 bits long. + (CLOSURE-HEADER (? internal-label) (? nentries) (? entry)) + entry ; Used only if entries may not be word-aligned. + (if (zero? nentries) + (error "Closure header for closure with no entries!" + internal-label)) + + ;; Closures used to use (internal-procedure-code-word rtl-proc) + ;; instead of internal-closure-code-word. + ;; This confused the bkpt utilties and was unnecessary because + ;; these entry points cannot properly be used as return addresses. + + (let* ((rtl-proc (label->object internal-label)) + (external-label (rtl-procedure/external-label rtl-proc))) + (let ((suffix + (lambda (gc-label) + (LAP ,@(make-external-label internal-closure-code-word + external-label) + ,@(address->entry g25) + (STWM () ,g25 (OFFSET -4 0 ,regnum:stack-pointer)) + (LABEL ,internal-label) + ,@(interrupt-check internal-label gc-label))))) + (share-instruction-sequence! + 'CLOSURE-GC-STUB + suffix + (lambda (gc-label) + (LAP (LABEL ,gc-label) + ,@(invoke-interface code:compiler-interrupt-closure) + ,@(suffix gc-label))))))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label)) + (? min) (? max) (? size))) + (cons-closure target procedure-label min max size)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-MULTICLOSURE (? nentries) (? size) (? entries))) + ;; entries is a vector of all the entry points + (case nentries + ((0) + (let ((dest (standard-target! target))) + (LAP ,@(load-non-pointer (ucode-type manifest-vector) + size + dest) + (STW () ,dest (OFFSET 0 0 ,regnum:free-pointer)) + (COPY () ,regnum:free-pointer ,dest) + ,@(load-offset (* 4 (1+ size)) + regnum:free-pointer + regnum:free-pointer)))) + ((1) + (let ((entry (vector-ref entries 0))) + (cons-closure + target (car entry) (cadr entry) (caddr entry) size))) + (else + (cons-multiclosure target nentries size (vector->list entries))))) + +#| +;;; Old style closure consing -- Out of line. + +(define (%cons-closure target total-size size core) + (let* ((flush-reg (require-registers! regnum:first-arg + #| regnum:addil-result |# + regnum:ble-return)) + (target (standard-target! target))) + (LAP ,@flush-reg + ;; Vector header + ,@(load-non-pointer (ucode-type manifest-closure) + total-size + regnum:first-arg) + (STWS (MA C) ,regnum:first-arg (OFFSET 4 0 ,regnum:free-pointer)) + ;; Make entries and store result + ,@(core target) + ;; Allocate space for closed-over variables + ,@(load-offset (* 4 size) + regnum:free-pointer + regnum:free-pointer)))) + +(define (cons-closure target entry min max size) + (%cons-closure + target + (+ size closure-entry-size) + size + (lambda (target) + (LAP ;; Entry point is result. + ,@(load-offset 4 regnum:free-pointer target) + ,@(cons-closure-entry entry min max 8))))) + +(define (cons-multiclosure target nentries size entries) + (define (generate-entries offset entries) + (if (null? entries) + (LAP) + (let ((entry (car entries))) + (LAP ,@(cons-closure-entry (car entry) (cadr entry) (caddr entry) + offset) + ,@(generate-entries (+ offset (* 4 closure-entry-size)) + (cdr entries)))))) + + (%cons-closure + target + (+ 1 (* closure-entry-size nentries) size) + size + (lambda (target) + (LAP ;; Number of closure entries + ,@(load-entry-format nentries 0 target) + (STWS (MA C) ,target (OFFSET 4 0 ,regnum:free-pointer)) + ;; First entry point is result. + ,@(load-offset 4 regnum:free-pointer target) + ,@(generate-entries 12 entries))))) + +;; Utilities for old-style closure consing. + +(define (load-entry-format code-word gc-offset dest) + (load-immediate (+ (* code-word #x10000) + (quotient gc-offset 2)) + dest)) + +(define (cons-closure-entry entry min max offset) + ;; Call an out-of-line hook to do this. + ;; Making the instructions is a lot of work! + ;; Perhaps there should be a closure hook invoked and the real + ;; entry point could follow. It would also be easier on the GC. + (let ((entry-label (rtl-procedure/external-label (label->object entry)))) + (LAP ,@(load-entry-format (make-procedure-code-word min max) + offset + regnum:first-arg) + #| + ;; This does not work!!! The LDO may overflow. + ;; A new pseudo-op has been introduced for this purpose. + (BLE () + (OFFSET ,hook:compiler-store-closure-entry + 4 + ,regnum:scheme-to-interface-ble)) + (LDO () + (OFFSET (- ,entry-label (+ *PC* 4)) + 0 + ,regnum:ble-return) + ,regnum:addil-result) + |# + (PCR-HOOK () + ,regnum:addil-result + (OFFSET ,hook:compiler-store-closure-entry + 4 + ,regnum:scheme-to-interface-ble) + (@PCR ,entry-label))))) +|# + +;; Magic for compiled entries. + +(define-integrable (address->entry register) + (adjust-type quad-mask-value (ucode-type compiled-entry) register)) + +(define-integrable (entry->address register) + (adjust-type (ucode-type compiled-entry) quad-mask-value register)) + +;;; New style closure consing using compiler-prepared and +;;; linker-maintained patterns + +;; Compiled code blocks are aligned like floating-point numbers and vectors. +;; That is, the address of their header word is congruent 4 mod 8 + +(define *initial-dword-offset* 4) +(define *closure-padding-bitstring* (make-bit-string 32 false)) + +;; This agrees with hppa_extract_absolute_address in microcode/cmpintmd/hppa.h + +(define *ldil/ble-split* + ;; (expt 2 13) *** + 8192) + +(define *ldil-factor* + ;; (/ *ldil/ble-split* ldil-scale) + 4) + +(define (declare-closure-pattern! pattern) + (add-extra-code! + (or (find-extra-code-block 'CLOSURE-PATTERNS) + (let ((section-label (generate-label)) + (ev-label (generate-label))) + (let ((block (declare-extra-code-block! + 'CLOSURE-PATTERNS + 'LAST + `(((/ (- ,ev-label ,section-label) 4) + . ,ev-label))))) + (add-extra-code! block + (LAP (LABEL ,section-label))) + block))) + (LAP (PADDING ,(- 4 *initial-dword-offset*) 8 ,*closure-padding-bitstring*) + ,@pattern))) + +(define (generate-closure-entry offset pattern label min max) + (let ((entry-label (rtl-procedure/external-label (label->object label)))) + (LAP (USHORT () + ,(make-procedure-code-word min max) + ,(quotient offset 2)) + ;; This contains an offset -- the linker turns it to an abs. addr. + (LDIL () (* (QUOTIENT (- (+ ,pattern ,offset) ,entry-label) + ,*ldil/ble-split*) + ,*ldil-factor*) + 26) + (BLE () (OFFSET (REMAINDER (- (+ ,pattern ,offset) ,entry-label) + ,*ldil/ble-split*) + 5 26)) + (ADDI () -15 31 25)))) + +(define (cons-closure target entry-label min max size) + (let ((offset 8) + (total-size (+ size closure-entry-size)) + (pattern (generate-label))) + + (declare-closure-pattern! + (LAP ,@(lap:comment `(CLOSURE-PATTERN ,entry-label)) + (LABEL ,pattern) + (UWORD () ,(make-non-pointer-literal (ucode-type manifest-closure) + total-size)) + ,@(generate-closure-entry offset pattern entry-label min max))) + #| + ;; This version uses ordinary integer instructions + + (let* ((offset* (* 4 (1+ closure-entry-size))) + (target (standard-target! target)) + (temp1 (standard-temporary!)) + (temp2 (standard-temporary!)) + (temp3 (standard-temporary!))) + + (LAP ,@(load-pc-relative-address pattern target 'CODE) + (LDWS (MA) (OFFSET 4 0 ,target) ,temp1) + (LDWS (MA) (OFFSET 4 0 ,target) ,temp2) + (LDWS (MA) (OFFSET 4 0 ,target) ,temp3) + (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer)) + (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer)) + (STWS (MA C) ,temp3 (OFFSET 4 0 ,regnum:free-pointer)) + + (LDWS (MA) (OFFSET 4 0 ,target) ,temp1) + (LDWS (MA) (OFFSET 4 0 ,target) ,temp2) + (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer)) + (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer)) + (LDO () (OFFSET ,(- offset offset*) 0 ,regnum:free-pointer) ,target) + (FDC () (INDEX 0 0 ,target)) + (FDC () (INDEX 0 0 ,regnum:free-pointer)) + (SYNC ()) + (FIC () (INDEX 0 5 ,target)) + (SYNC ()) + (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer) + ,regnum:free-pointer))) + |# + + #| + ;; This version is faster by using floating-point (doubleword) moves + + (let* ((offset* (* 4 (1+ closure-entry-size))) + (target (standard-target! target)) + (dwtemp1 (flonum-temporary!)) + (dwtemp2 (flonum-temporary!)) + (swtemp (standard-temporary!))) + + (LAP ,@(load-pc-relative-address pattern target 'CODE) + (DEPI () #b100 31 3 ,regnum:free-pointer) ; quad align + (LDWS (MA) (OFFSET 4 0 ,target) ,swtemp) + (FLDDS (MA) (OFFSET 8 0 ,target) ,dwtemp1) + (STWS (MA) ,swtemp (OFFSET 4 0 ,regnum:free-pointer)) + (FLDDS (MA) (OFFSET 8 0 ,target) ,dwtemp2) + (FSTDS (MA) ,dwtemp1 (OFFSET 8 0 ,regnum:free-pointer)) + (LDO () (OFFSET ,(- offset (- offset* 8)) 0 ,regnum:free-pointer) + ,target) + (FSTDS (MA) ,dwtemp2 (OFFSET 8 0 ,regnum:free-pointer)) + (FDC () (INDEX 0 0 ,target)) + (FDC () (INDEX 0 0 ,regnum:free-pointer)) + (SYNC ()) + (FIC () (INDEX 0 5 ,target)) + (SYNC ()) + (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer) + ,regnum:free-pointer))) + |# + + ;; This version does the copy out of line, using fp instructions. + + (let* ((hook-label (generate-label)) + (flush-reg (require-registers! g29 g28 g26 g25 fp11 fp10 + #| regnum:addil-result |# + regnum:ble-return))) + (delete-register! target) + (delete-dead-registers!) + (add-pseudo-register-alias! target g25) + (LAP ,@flush-reg + ,@(invoke-hook hook:compiler-copy-closure-pattern) + (LABEL ,hook-label) + (UWORD () (- (- ,pattern ,hook-label) ,*privilege-level*)) + (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer) + ,regnum:free-pointer))))) + +(define (cons-multiclosure target nentries size entries) + ;; nentries > 1 + (let ((offset 12) + (total-size (+ (+ 1 (* closure-entry-size nentries)) size)) + (pattern (generate-label))) + + (declare-closure-pattern! + (LAP ,@(lap:comment `(CLOSURE-PATTERN ,(caar entries))) + (LABEL ,pattern) + (UWORD () ,(make-non-pointer-literal (ucode-type manifest-closure) + total-size)) + (USHORT () ,nentries 0) + ,@(let make-entries ((entries entries) + (offset offset)) + (if (null? entries) + (LAP) + (let ((entry (car entries))) + (LAP ,@(generate-closure-entry offset + pattern + (car entry) + (cadr entry) + (caddr entry)) + ,@(make-entries (cdr entries) + (+ offset + (* 4 closure-entry-size))))))))) + #| + ;; This version uses ordinary integer instructions + + (let ((target (standard-target! target))) + (let ((temp1 (standard-temporary!)) + (temp2 (standard-temporary!)) + (ctr (standard-temporary!)) + (srcptr (standard-temporary!)) + (index (standard-temporary!)) + (loop-label (generate-label))) + + (LAP ,@(load-pc-relative-address pattern srcptr 'CODE) + (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp1) + (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp2) + (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer)) + (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer)) + (LDO () (OFFSET 4 0 ,regnum:free-pointer) ,target) + (LDI () -16 ,index) + (LDI () ,nentries ,ctr) + ;; The loop copies 16 bytes, and the architecture specifies + ;; that a cache line must be a multiple of this value. + ;; Therefore we only need to flush once per loop, + ;; and once more (D only) to take care of phase. + (LABEL ,loop-label) + (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp1) + (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp2) + (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer)) + (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer)) + (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp1) + (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp2) + (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer)) + (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer)) + (FDC () (INDEX ,index 0 ,regnum:free-pointer)) + (SYNC ()) + (ADDIB (>) -1 ,ctr ,ctr (@PCR ,loop-label)) + (FIC () (INDEX ,index 5 ,regnum:free-pointer)) + (FDC () (INDEX 0 0 ,regnum:free-pointer)) + (SYNC ()) + (FIC () (INDEX 0 5 ,regnum:free-pointer)) + (SYNC ()) + (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer) + ,regnum:free-pointer)))) + |# + + #| + ;; This version is faster by using floating-point (doubleword) moves + + (let ((target (standard-target! target))) + (let ((dwtemp1 (flonum-temporary!)) + (dwtemp2 (flonum-temporary!)) + (temp (standard-temporary!)) + (ctr (standard-temporary!)) + (srcptr (standard-temporary!)) + (index (standard-temporary!)) + (loop-label (generate-label))) + + (LAP ,@(load-pc-relative-address pattern srcptr 'CODE) + (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp) + (DEPI () #b100 31 3 ,regnum:free-pointer) ; quad align + (STWS (MA C) ,temp (OFFSET 4 0 ,regnum:free-pointer)) + (LDO () (OFFSET 8 0 ,regnum:free-pointer) ,target) + (LDI () -16 ,index) + (LDI () ,nentries ,ctr) + + ;; The loop copies 16 bytes, and the architecture specifies + ;; that a cache line must be a multiple of this value. + ;; Therefore we only need to flush (D) once per loop, + ;; and once more to take care of phase. + ;; We only need to flush the I cache once because it is + ;; newly allocated memory. + + (LABEL ,loop-label) + (FLDDS (MA) (OFFSET 8 0 ,srcptr) ,dwtemp1) + (FLDDS (MA) (OFFSET 8 0 ,srcptr) ,dwtemp2) + (FSTDS (MA) ,dwtemp1 (OFFSET 8 0 ,regnum:free-pointer)) + (FSTDS (MA) ,dwtemp2 (OFFSET 8 0 ,regnum:free-pointer)) + (ADDIB (>) -1 ,ctr (@PCR ,loop-label)) + (FDC () (INDEX ,index 0 ,regnum:free-pointer)) + + (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp) + (LDI () ,(* -4 (1+ size)) ,index) + (STWM () ,temp (OFFSET ,(* 4 (1+ size)) 0 ,regnum:free-pointer)) + (FDC () (INDEX ,index 0 ,regnum:free-pointer)) + (SYNC ()) + (FIC () (INDEX 0 5 ,target)) + (SYNC ())))) + |# + + ;; This version does the copy out of line, using fp instructions. + + (let* ((hook-label (generate-label)) + (flush-reg (require-registers! g29 g28 g26 g25 fp11 fp10 + #| regnum:addil-result |# + regnum:ble-return))) + (delete-register! target) + (delete-dead-registers!) + (add-pseudo-register-alias! target g25) + (LAP ,@flush-reg + (LDI () ,nentries 1) + ,@(invoke-hook hook:compiler-copy-multiclosure-pattern) + (LABEL ,hook-label) + (UWORD () (- (- ,pattern ,hook-label) ,*privilege-level*)) + (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer) + ,regnum:free-pointer))))) + +;;;; Entry Header +;;; This is invoked by the top level of the LAP generator. + +(define (generate/quotation-header environment-label free-ref-label n-sections) + ;; Calls the linker + (in-assembler-environment + (empty-register-map) + (list 2 19 + regnum:first-arg regnum:second-arg + regnum:third-arg regnum:fourth-arg) + (lambda () + (let* ((segment (load-pc-relative-address environment-label 1 'CONSTANT))) + (LAP (STWM () 2 (OFFSET -4 0 ,regnum:stack-pointer)) ; Push Env + (STWM () 19 (OFFSET -4 0 ,regnum:stack-pointer)) ; Push continuation + ,@segment + (STW () 2 (OFFSET 0 0 1)) + ,@(load-pc-relative-address *block-label* regnum:second-arg 'CODE) + ,@(load-pc-relative-address free-ref-label regnum:third-arg + 'CONSTANT) + ,@(load-immediate n-sections regnum:fourth-arg) + ,@(invoke-interface-ble code:compiler-link) + ,@(make-external-label (continuation-code-word false) + (generate-label)) + ;; 19 popped by call to code:compiler-link + (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) 2) ; Env + ))))) + + +(define (generate/remote-link code-block-label + environment-offset + free-ref-offset + n-sections) + ;; Link all of the top level procedures within the file + (in-assembler-environment + (empty-register-map) + (list 2 19 + regnum:first-arg regnum:second-arg + regnum:third-arg regnum:fourth-arg) + (lambda () + (let* ((segment (load-pc-relative code-block-label regnum:second-arg + 'CONSTANT))) + (LAP (STWM () 2 (OFFSET -4 0 ,regnum:stack-pointer)) ; Push Env + (STWM () 19 (OFFSET -4 0 ,regnum:stack-pointer)) ; Push continuation + ,@segment + ,@(object->address regnum:second-arg) + ,@(load-offset environment-offset regnum:second-arg 1) + (STW () 2 (OFFSET 0 0 1)) + ,@(load-offset free-ref-offset regnum:second-arg regnum:third-arg) + ,@(load-immediate n-sections regnum:fourth-arg) + ,@(invoke-interface-ble code:compiler-link) + ,@(make-external-label (continuation-code-word false) + (generate-label)) + ;; 19 popped by call to code:compiler-link + (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) 2) ; Env + ))))) + +(define (in-assembler-environment map needed-registers thunk) + (fluid-let ((*register-map* map) + (*prefix-instructions* (LAP)) + (*suffix-instructions* (LAP)) + (*needed-registers* needed-registers)) + (let ((instructions (thunk))) + (LAP ,@*prefix-instructions* + ,@instructions + ,@*suffix-instructions*)))) + +(define (generate/remote-links n-code-blocks code-blocks-label n-sections) + (if (= n-code-blocks 0) + (LAP) + (let ((loop (generate-label)) + (bytes (generate-label)) + (after-bytes (generate-label))) + (LAP (STWM () 0 (OFFSET -4 0 ,regnum:stack-pointer)) + (COPY () 0 ,regnum:first-arg) + (LABEL ,loop) + (LDO () (OFFSET 1 0 ,regnum:first-arg) ,regnum:second-arg) + (STW () ,regnum:second-arg (OFFSET 0 0 ,regnum:stack-pointer)) + (BL () ,regnum:third-arg (@PCR ,after-bytes)) + (DEP () 0 31 2 ,regnum:third-arg) + (LABEL ,bytes) + ,@(sections->bytes n-code-blocks n-sections) + (LABEL ,after-bytes) + (LDBX () (INDEX ,regnum:first-arg 0 ,regnum:third-arg) + ,regnum:fourth-arg) + (LDW () (OFFSET (- ,code-blocks-label ,bytes) 0 ,regnum:third-arg) + ,regnum:third-arg) + ,@(object->address regnum:third-arg) + (LDWX (S) (INDEX ,regnum:second-arg 0 ,regnum:third-arg) + ,regnum:second-arg) + ,@(object->address regnum:second-arg) + (LDW () (OFFSET 4 0 ,regnum:second-arg) ,regnum:third-arg) + (LDW () (OFFSET 0 0 ,regnum:second-arg) ,regnum:first-arg) + ,@(object->datum regnum:third-arg regnum:third-arg) + ,@(object->datum regnum:first-arg regnum:first-arg) + (SH2ADD () ,regnum:third-arg ,regnum:second-arg ,regnum:third-arg) + (SH2ADD () ,regnum:first-arg ,regnum:second-arg + ,regnum:first-arg) + (LDO () (OFFSET 8 0 ,regnum:third-arg) ,regnum:third-arg) + (STW () 2 (OFFSET 0 0 ,regnum:first-arg)) + (STWM () 2 (OFFSET -4 0 ,regnum:stack-pointer)) ;Push Env + (STWM () 19 (OFFSET -4 0 ,regnum:stack-pointer)) ;Push continuation + ,@(invoke-interface-ble code:compiler-link) + ,@(make-external-label (continuation-code-word false) + (generate-label)) + ;; 19 popped by call to code:compiler-link + (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) 2) ; Env + (LDW () (OFFSET 0 0 ,regnum:stack-pointer) ,regnum:first-arg) + ,@(cond ((fits-in-5-bits-signed? n-code-blocks) + (LAP (COMIBF (<=) ,n-code-blocks ,regnum:first-arg + (@PCR ,loop)) + (NOP ()))) + ((fits-in-11-bits-signed? n-code-blocks) + (LAP (COMICLR (<=) ,n-code-blocks ,regnum:first-arg 0) + (B (N) (@PCR ,loop)))) + (else + (LAP (LDI () ,n-code-blocks ,regnum:second-arg) + (COMBF (<=) ,regnum:second-arg ,regnum:first-arg + (@PCR ,loop)) + (NOP ())))) + (LDO () (OFFSET 4 0 ,regnum:stack-pointer) + ,regnum:stack-pointer))))) + +(define (sections->bytes n-code-blocks n-sections) + (bytes->uwords (append (vector->list n-sections) + (let ((left (remainder n-code-blocks 4))) + (if (zero? left) + '() + (make-list (- 4 left) 0)))))) + +(define (bytes->uwords bytes) + ;; There must be a multiple of 4 bytes + (let walk ((bytes bytes)) + (if (null? bytes) + (LAP) + (let ((hi (car bytes)) + (midhi (cadr bytes)) + (midlo (caddr bytes)) + (lo (cadddr bytes))) + (LAP (UWORD () + ,(+ lo (* 256 (+ midlo (* 256 (+ midhi (* 256 hi))))))) + ,@(walk (cddddr bytes))))))) + +(define (generate/constants-block constants references assignments + uuo-links global-links static-vars) + (let ((constant-info + ;; Note: generate/remote-links depends on all the linkage sections + ;; (references & uuos) being first! + (declare-constants 0 (transmogrifly uuo-links) + (declare-constants 1 references + (declare-constants 2 assignments + (declare-constants 3 (transmogrifly global-links) + (declare-closure-patterns + (declare-constants false (map (lambda (pair) + (cons false (cdr pair))) + static-vars) + (declare-constants false constants + (cons false (LAP))))))))))) + (let ((free-ref-label (car constant-info)) + (constants-code (cdr constant-info)) + (debugging-information-label (allocate-constant-label)) + (environment-label (allocate-constant-label)) + (n-sections + (+ (if (null? uuo-links) 0 1) + (if (null? references) 0 1) + (if (null? assignments) 0 1) + (if (null? global-links) 0 1) + (if (not (find-extra-code-block 'CLOSURE-PATTERNS)) 0 1)))) + (values + (LAP ,@constants-code + ;; Place holder for the debugging info filename + (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO) + ;; Place holder for the load time environment if needed + (SCHEME-OBJECT ,environment-label + ,(if (null? free-ref-label) 0 'ENVIRONMENT))) + environment-label + free-ref-label + n-sections)))) + +(define (declare-constants/tagged tag header constants info) + (define-integrable (wrap tag label value) + (LAP (,tag ,label ,value))) + + (define (inner constants) + (if (null? constants) + (cdr info) + (let ((entry (car constants))) + (LAP ,@(wrap tag (cdr entry) (car entry)) + ,@(inner (cdr constants)))))) + + (if (and header (not (null? constants))) + (let ((label (allocate-constant-label))) + (cons label + (LAP (SCHEME-OBJECT + ,label + ,(let ((datum (length constants))) + (if (> datum #xffff) + (error "datum too large" datum)) + (+ (* header #x10000) datum))) + ,@(inner constants)))) + (cons (car info) (inner constants)))) + +(define (declare-constants header constants info) + (declare-constants/tagged 'SCHEME-OBJECT header constants info)) + +(define (declare-closure-patterns info) + (let ((block (find-extra-code-block 'CLOSURE-PATTERNS))) + (if (not block) + info + (declare-constants/tagged 'SCHEME-EVALUATION + 4 + (extra-code-block/xtra block) + info)))) + +(define (declare-evaluations header evals info) + (declare-constants/tagged 'SCHEME-EVALUATION header evals info)) + +(define (transmogrifly uuos) + (define (inner name assoc) + (if (null? assoc) + (transmogrifly (cdr uuos)) + `((,name . ,(cdar assoc)) ; uuo-label LDIL + (0 . ,(allocate-constant-label)) ; spare BLE + (,(caar assoc) . ; frame-size + ,(allocate-constant-label)) + ,@(inner name (cdr assoc))))) + (if (null? uuos) + '() + (inner (caar uuos) (cdar uuos)))) + +;;;; New RTL + +(define-rule statement + (INVOCATION:REGISTER 0 #F (REGISTER (? reg)) + #F (MACHINE-CONSTANT (? nregs))) + nregs ; ignored + (let ((addr (standard-source! reg))) + (LAP ,@(clear-map!) + (BV (N) 0 ,addr)))) + +(define-rule statement + (INVOCATION:PROCEDURE 0 (? continuation) (? destination) + (MACHINE-CONSTANT (? nregs))) + nregs ; ignored + (LAP ,@(clear-map!) + ,@(if (not continuation) + (LAP (B (N) (@PCR ,destination))) + (LAP (BL () 19 (@PCR ,destination)) + (LDO () (OFFSET ,(- 4 *privilege-level*) 0 19) 19))))) + +(define-rule statement + (INVOCATION:NEW-APPLY (? frame-size) (? continuation) + (REGISTER (? dest)) (MACHINE-CONSTANT (? nregs))) + ;; *** For now, ignore nregs and use frame-size *** + nregs + (let* ((obj (register-alias dest (register-type dest))) + (prefix (if obj + (LAP) + (%load-machine-register! dest regnum:first-arg + delete-dead-registers!))) + (obj* (or obj regnum:first-arg))) + (need-register! obj*) + (let ((addr (if untagged-entries? obj* (standard-temporary!))) + (temp (standard-temporary!)) + (label (generate-label)) + (load-continuation + (if continuation + (load-pc-relative-address continuation 19 'CODE) + '()))) + (LAP ,@prefix + ,@(clear-map!) + ,@load-continuation + ,@(object->type obj* temp) + ,@(let ((tag (ucode-type compiled-entry))) + (if (fits-in-5-bits-signed? tag) + (LAP (COMIBN (<>) ,tag ,temp (@PCR ,label))) + (LAP (COMICLR (=) ,tag ,temp 0) + (B (N) (@PCR ,label))))) + ,@(if untagged-entries? + (LAP) + (LAP (COPY () ,obj* ,addr) + ,@(adjust-type (ucode-type compiled-entry) + quad-mask-value + addr))) + (LDB () (OFFSET -3 0 ,addr) ,temp) + (COMICLR (<>) ,frame-size ,temp 0) + (BV (N) 0 ,addr) + (LABEL ,label) + ,@(copy obj* regnum:first-arg) + ,@(%invocation:apply frame-size) + (NOP ()))))) + +(define-rule statement + (RETURN-ADDRESS (? label) + (MACHINE-CONSTANT (? frame-size)) + (MACHINE-CONSTANT (? nregs))) + nregs ; ignored + (begin + (restore-registers!) + (make-external-label + (frame-size->code-word frame-size internal-continuation-code-word) + label))) + +(define-rule statement + (PROCEDURE (? label) (MACHINE-CONSTANT (? frame-size))) + (make-external-label (frame-size->code-word frame-size + internal-continuation-code-word) + label)) + +(define-rule statement + (TRIVIAL-CLOSURE (? label) + (MACHINE-CONSTANT (? min)) + (MACHINE-CONSTANT (? max))) + (make-external-label (make-procedure-code-word min max) + label)) + +(define-rule statement + (CLOSURE (? label) (MACHINE-CONSTANT (? frame-size))) + frame-size ; ignored + (LAP ,@(make-external-label internal-closure-code-word label))) + +(define-rule statement + (EXPRESSION (? label)) + #| + ;; Prefix takes care of this + (LAP ,@(make-external-label expression-code-word label)) + |# + label ; ignored + (LAP)) + +(define-rule statement + (INTERRUPT-CHECK:PROCEDURE (? intrpt) (? heap) (? stack) (? label) + (MACHINE-CONSTANT (? frame-size))) + (generate-interrupt-check/new + intrpt heap stack + (lambda (interrupt-label) + (let ((ret-add-label (generate-label))) + (LAP (LABEL ,interrupt-label) + (LDI () ,(- frame-size 1) 1) + ,@(invoke-hook hook:compiler-interrupt-procedure/new) + (LABEL ,ret-add-label) + (WORD () (- (- ,label ,ret-add-label) ,*privilege-level*))))))) + +(define-rule statement + (INTERRUPT-CHECK:CONTINUATION (? intrpt) (? heap) (? stack) (? label) + (MACHINE-CONSTANT (? frame-size))) + ;; Generated both for continuations and in some weird case of + ;; top-level expressions. + (generate-interrupt-check/new + intrpt heap + (and (= frame-size 1) stack) ; expressions only + (lambda (interrupt-label) + (let ((ret-add-label (generate-label))) + (LAP (LABEL ,interrupt-label) + (LDI () ,(- frame-size 1) 1) + #| (LDI () + ,(if (= nregs 0) ; **** probably wrong + code:compiler-interrupt-procedure + code:compiler-interrupt-continuation) + 28) |# + ,@(invoke-hook hook:compiler-interrupt-continuation/new) + (LABEL ,ret-add-label) + (WORD () (- (- ,label ,ret-add-label) ,*privilege-level*))))))) + +(define-rule statement + (INTERRUPT-CHECK:CLOSURE (? intrpt) (? heap) (? stack) + (MACHINE-CONSTANT (? frame-size))) + (generate-interrupt-check/new + intrpt heap stack + (lambda (interrupt-label) + (LAP (LABEL ,interrupt-label) + (LDI () ,(- frame-size 2) 1) ; Continuation and self + ; register are saved by other + ; means. + ,@(invoke-hook hook:compiler-interrupt-closure/new))))) + +(define-rule statement + (INTERRUPT-CHECK:SIMPLE-LOOP (? intrpt) (? heap) (? stack) + (? loop-label) (? header-label) + (MACHINE-CONSTANT (? frame-size))) + ;; Nothing generates this now -- JSM + loop-label ; ignored + (generate-interrupt-check/new + intrpt heap stack + (lambda (interrupt-label) + (let ((ret-add-label (generate-label))) + (LAP (LABEL ,interrupt-label) + (LDI () ,(- frame-size 1) 1) + ,@(invoke-hook hook:compiler-interrupt-procedure/new) + (LABEL ,ret-add-label) + (WORD () (- (- ,header-label ,ret-add-label) + ,*privilege-level*))))))) + +(define (generate-interrupt-check/new intrpt heap stack generate-stub) + ;; This does not check the heap because it is assumed that there is + ;; a large buffer at the end of the heap. As long as the code can't + ;; loop without checking, which is what intrpt guarantees, there + ;; is no need to check. + heap ; ignored + (let* ((interrupt-label (generate-label)) + (heap-check? intrpt) + (stack-check? (and stack compiler:generate-stack-checks?)) + (need-interrupt-code (lambda () + (add-end-of-block-code! + (lambda () + (generate-stub interrupt-label)))))) + (cond ((and heap-check? stack-check?) + (need-interrupt-code) + (LAP (LDW () ,reg:stack-guard 1) + (COMB (>=) ,regnum:free-pointer ,regnum:memtop-pointer + (@PCR ,interrupt-label)) + (COMB (<=) ,regnum:stack-pointer 1 (@PCR ,interrupt-label)) + (LDW () ,reg:memtop ,regnum:memtop-pointer))) + (heap-check? + (need-interrupt-code) + (LAP (COMB (>=) ,regnum:free-pointer ,regnum:memtop-pointer + (@PCR ,interrupt-label)) + (LDW () ,reg:memtop ,regnum:memtop-pointer))) + (stack-check? + (need-interrupt-code) + (LAP (LDW () ,reg:stack-guard 1) + (COMBN (<=) ,regnum:stack-pointer 1 (@PCR ,interrupt-label)))) + (else + (LAP))))) + +(define-rule statement + (ASSIGN (REGISTER (? dst)) (ALIGN-FLOAT (REGISTER (? src)))) + (let ((dst (standard-move-to-target! src dst))) + (LAP + ;; The STW instruction would make the heap parsable forwards + ;; (STW () 0 (OFFSET 0 0 ,dst)) + (DEPI () #b100 31 3 ,dst)))) + +;; *** For now *** + +(define-rule statement + (ASSIGN (REGISTER (? target)) (STATIC-CELL (? name))) + (***unimplemented-rtl*** + `(ASSIGN (REGISTER ,target) (STATIC-CELL ,name)))) + +(define (***unimplemented-rtl*** inst) + (error "Unimplemented RTL statement" inst)) + +;;; Local Variables: *** +;;; eval: (put 'declare-constants 'scheme-indent-hook 2) *** +;;; End: *** diff --git a/v8/src/compiler/machines/spectrum/rules4.scm b/v8/src/compiler/machines/spectrum/rules4.scm new file mode 100644 index 000000000..d4ea384d7 --- /dev/null +++ b/v8/src/compiler/machines/spectrum/rules4.scm @@ -0,0 +1,155 @@ +#| -*-Scheme-*- + +$Id: rules4.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Interpreter Calls +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +;;;; Variable cache trap handling. + +(define *interpreter-call-clobbered-regs* + ;; g26 g25 g24 g23 used for argument passing, already cleared + ;; SRA - dont think so? + (list g31 g2 g28 g29 g26 g25 g24 g23)) + +(define (interpreter-call code extension extra) + (let ((start (%load-interface-args! false extension extra false))) + (LAP (COMMENT >> %interface-load-args) + ,@start + (COMMENT << %interface-load-args) + ,@(preserving-regs + *interpreter-call-clobbered-regs* + (lambda (gen-preservation-info) + (if (not gen-preservation-info) + (invoke-interface-ble code) + (let ((label1 (generate-label)) + (label2 (generate-label))) + (LAP (LDI () ,code ,g28) + (BLE () (OFFSET ,hook:compiler-interpreter-call 4 + ,regnum:scheme-to-interface-ble)) + (LDO () + (OFFSET (- (- ,label2 ,label1) + ,*privilege-level*) + 0 31) + 31) + (LABEL ,label1) + ,@(gen-preservation-info) + (LABEL ,label2))))))))) + +(define-rule statement + (INTERPRETER-CALL:CACHE-REFERENCE (? cont) + (REGISTER (? extension)) + (? safe?)) + cont ; ignored + (interpreter-call (if safe? + code:compiler-safe-reference-trap + code:compiler-reference-trap) + extension false)) + +(define-rule statement + (INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont) + (REGISTER (? extension)) + (? value register-expression)) + cont ; ignored + (interpreter-call code:compiler-assignment-trap extension value)) + +(define-rule statement + (INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont) + (REGISTER (? extension))) + cont ; ignored + (interpreter-call code:compiler-unassigned?-trap extension false)) + +;;;; Interpreter Calls + +;;; All the code that follows is obsolete. It hasn't been used in a while. +;;; It is provided in case the relevant switches are turned off, but there +;;; is no real reason to do this. Perhaps the switches should be removed. + +(define-rule statement + (INTERPRETER-CALL:ACCESS (? cont) + (? environment register-expression) + (? name)) + cont ; ignored + (lookup-call code:compiler-access environment name)) + +(define-rule statement + (INTERPRETER-CALL:LOOKUP (? cont) + (? environment register-expression) + (? name) + (? safe?)) + cont ; ignored + (lookup-call (if safe? code:compiler-safe-lookup code:compiler-lookup) + environment + name)) + +(define-rule statement + (INTERPRETER-CALL:UNASSIGNED? (? cont) + (? environment register-expression) + (? name)) + cont ; ignored + (lookup-call code:compiler-unassigned? environment name)) + +(define-rule statement + (INTERPRETER-CALL:UNBOUND? (? cont) + (? environment register-expression) + (? name)) + cont ; ignored + (lookup-call code:compiler-unbound? environment name)) + +(define (lookup-call code environment name) + (LAP ,@(load-interface-args! false environment false false) + ,@(load-constant name regnum:third-arg) + ,@(invoke-interface-ble code))) + +(define-rule statement + (INTERPRETER-CALL:DEFINE (? cont) + (? environment register-expression) + (? name) + (? value register-expression)) + cont ; ignored + (assignment-call code:compiler-define environment name value)) + +(define-rule statement + (INTERPRETER-CALL:SET! (? cont) + (? environment register-expression) + (? name) + (? value register-expression)) + cont ; ignored + (assignment-call code:compiler-set! environment name value)) + +(define (assignment-call code environment name value) + (LAP ,@(load-interface-args! false environment false value) + ,@(load-constant name regnum:third-arg) + ,@(invoke-interface-ble code))) \ No newline at end of file diff --git a/v8/src/compiler/machines/spectrum/rulfix.scm b/v8/src/compiler/machines/spectrum/rulfix.scm new file mode 100644 index 000000000..c2dc99bb2 --- /dev/null +++ b/v8/src/compiler/machines/spectrum/rulfix.scm @@ -0,0 +1,1443 @@ +#| -*-Scheme-*- + +$Id: rulfix.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ + +Copyright (c) 1989-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Fixnum Rules +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +;;;; Conversions + +;;; NOTE: The **only** part of the compiler that currently (12/28/93) +;;; generates (OBJECT->FIXNUM ...) is opncod.scm and it guarantees +;;; that these are either preceded by a type check for fixnum or the +;;; user has open-coded a fixnum operation indicating that type +;;; checking isn't necessary. So we don't bother to clear type bits +;;; if untagged-fixnums? is #T. + +;;; NOTE(2): rulrew.scm removes all the occurences of +;;; OBJECT->FIXNUM, FIXNUM->OBJECT and OBJECT->UNSIGNED-FIXNUM +;;; as these are no-ops when using untagged fixnums + +;;; NOMENCLATURE: +;;; OBJECT means an object represented in standard Scheme form +;;; ADDRESS means a hardware pointer to an address; on the PA this +;;; means it has the quad bits set correctly +;;; FIXNUM means a value without type code, in a form suitable for +;;; machine arithmetic. If UNTAGGED-FIXNUMS? is #T (i.e. +;;; POSITIVE-FIXNUM is type code 0, NEGATIVE-FIXNUM is type +;;; code -1), then we simply use the standard hardware +;;; representation of integers. Otherwise, we shift the +;;; integer so that the Scheme fixnum sign bit is stored in the +;;; hardware sign bit: i.e. left shifted by typecode-width (6) +;;; bits. + +;(define (copy-instead-of-object->fixnum source target) +; (standard-move-to-target! source target) +; (LAP)) + +;(define (copy-instead-of-fixnum->object source target) +; (standard-move-to-target! source target) +; (LAP)) + +;(define-rule statement +; ;; convert a fixnum object to a "fixnum integer" +; (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source)))) +; (if untagged-fixnums? +; (copy-instead-of-object->fixnum source target) +; (standard-unary-conversion source target object->fixnum))) + +;(define-rule statement +; ;; load a fixnum constant as a "fixnum integer" +; (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant)))) +; (load-fixnum-constant constant (standard-target! target))) + +(define-rule statement + ;; convert a memory address to a "fixnum integer" + (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source)))) + (standard-unary-conversion source target address->fixnum)) + +(define-rule statement + ;; convert an object's address to a "fixnum integer" + (ASSIGN (REGISTER (? target)) + (ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source))))) + (if untagged-fixnums? + (standard-unary-conversion source target object->datum) + ;;(standard-unary-conversion source target object->fixnum) + )) + +;(define-rule statement +; ;; convert a "fixnum integer" to a fixnum object +; (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source)))) +; (standard-move-to-target! source target) +; (LAP (COMMENT (elided (object->fixnum (register ,source)))))) +; ;; (standard-unary-conversion source target fixnum->object) + +(define-rule statement + ;; convert a "fixnum integer" to a memory address + (ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source)))) + (standard-unary-conversion source target fixnum->address)) + +(let ((make-scaled-object->fixnum + (lambda (factor) + (let ((shift (integer-log-base-2? factor))) + (cond ((not shift) + (error "make-scaled-object->fixnum: Not a power of 2" + factor)) + ((> shift scheme-datum-width) + (error "make-scaled-object->fixnum: shift too large" shift)) + (else + (lambda (src tgt) + (if untagged-fixnums? + (LAP (SHD () ,src 0 ,(- 32 shift) ,tgt)) + (LAP (SHD () ,src 0 ,(- scheme-datum-width shift) + ,tgt)))))))))) + + (define-rule statement + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS MULTIPLY-FIXNUM + (CONSTANT (? value)) + (REGISTER (? source)) + #F)) + (QUALIFIER (integer-log-base-2? value)) + (standard-unary-conversion source target + (make-scaled-object->fixnum value))) + + (define-rule statement + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS MULTIPLY-FIXNUM + (REGISTER (? source)) + (CONSTANT (? value)) + #F)) + (QUALIFIER (integer-log-base-2? value)) + (standard-unary-conversion source target + (make-scaled-object->fixnum value)))) + +(define-integrable (fixnum->index-fixnum src tgt) + ;; Takes a register containing a FIXNUM representing an index in + ;; units of Scheme object units and generates the + ;; corresponding FIXNUM for the byte offset: it multiplies by 4. + ;;! (if untagged-fixnums? 'nothing-different) + (LAP (SHD () ,src 0 30 ,tgt))) + +;(define-integrable (object->fixnum src tgt) +; ;; With untagged-fixnums this is called *only* when we are not +; ;; treating the src as containing a signed fixnum -- i.e. when we +; ;; have a pointer and want to do integer arithmetic on it. In this +; ;; case it is OK to generate positive numbers in all cases. Notice +; ;; that we *also* choose, in this case, to have "fixnums" be +; ;; unshifted, while with tagged-fixnums we shift to put the Scheme +; ;; sign bit in the hardware sign bit, and unshift later. +; (if untagged-fixnums? +; (begin +; (warn "object->fixum: " src tgt) +; ;; This is wrong! +; ;;(deposit-type 0 (standard-move-to-target! src tgt)) +; (LAP ,@(copy src tgt) +; ,@(deposit-type 0 tgt))) +; (LAP (SHD () ,src 0 ,scheme-datum-width ,tgt)))) + +(define-integrable (address->fixnum src tgt) + ;; This happens to be the same as object->fixnum + ;; With untagged-fixnums we need to clear the quad bits, With single tag + ;; fixnums shift the sign into the machine sign, shifting out the + ;; quad bits. + (if untagged-fixnums? + (deposit-type 0 (standard-move-to-target! src tgt)) + (LAP (SHD () ,src 0 ,scheme-datum-width ,tgt)))) + +;(define-integrable (fixnum->object src tgt) +; (if untagged-fixnums? +; ;;B?(copy-instead-of-fixnum->object src tgt) +; (untagged-fixnum-sign-extend src tgt) +; (LAP ,@(load-immediate (ucode-type positive-fixnum) regnum:addil-result) +; (SHD () ,regnum:addil-result ,src ,scheme-type-width ,tgt)))) + +(define (fixnum->address src tgt) + (if untagged-fixnums? + (LAP (DEP () ,regnum:quad-bitmask ,(-1+ scheme-type-width) + ,scheme-type-width ,tgt)) + (LAP (SHD () ,regnum:quad-bitmask ,src ,scheme-type-width ,tgt)))) + +(define (fixnum->datum src tgt) + (if untagged-fixnums? + (deposit-type 0 (standard-move-to-target! src tgt)) + (LAP (SHD () 0 ,src ,scheme-type-width ,tgt)))) + +(define (load-fixnum-constant constant target) + (load-immediate (* constant fixnum-1) target)) + +(define #|-integrable|# fixnum-1 + ;; (expt 2 scheme-type-width) *** + (if untagged-fixnums? 1 64)) + +;;;; Arithmetic Operations + +(define-rule statement + ;; execute a unary fixnum operation + (ASSIGN (REGISTER (? target)) + (FIXNUM-1-ARG (? operation) + (REGISTER (? source)) + (? overflow?))) + (QUALIFIER (fixnum-1-arg/operator? operation)) + (standard-unary-conversion + source + target + (lambda (source target) + ((fixnum-1-arg/operator operation) target source overflow?)))) + +(define-integrable (fixnum-1-arg/operator operation) + (lookup-arithmetic-method operation fixnum-methods/1-arg)) + +(define-integrable (fixnum-1-arg/operator? operation) + (arithmetic-method? operation fixnum-methods/1-arg)) + +(define fixnum-methods/1-arg + (list 'FIXNUM-METHODS/1-ARG)) + +;(define-rule statement +; ;; execute a binary fixnum operation +; (ASSIGN (REGISTER (? target)) +; (FIXNUM->OBJECT +; (FIXNUM-2-ARGS (? operation) +; (OBJECT->FIXNUM (REGISTER (? source1))) +; (OBJECT->FIXNUM (REGISTER (? source2))) +; (? overflow?)))) +; (QUALIFIER (fixnum-2-args/operator? operation)) +; (standard-binary-conversion source1 source2 target +; (lambda (source1 source2 target) +; ((fixnum-2-args/operator operation) +; target source1 source2 overflow?)))) + +(define-rule statement + ;; execute a binary fixnum operation + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS (? operation) + (REGISTER (? source1)) + (REGISTER (? source2)) + (? overflow?))) + (QUALIFIER (fixnum-2-args/operator? operation)) + (standard-binary-conversion source1 source2 target + (lambda (source1 source2 target) + ((fixnum-2-args/operator operation) + target source1 source2 overflow?)))) + +(define-integrable (fixnum-2-args/operator operation) + (lookup-arithmetic-method operation fixnum-methods/2-args)) + +(define-integrable (fixnum-2-args/operator? operation) + (arithmetic-method? operation fixnum-methods/2-args)) + +(define fixnum-methods/2-args + (list 'FIXNUM-METHODS/2-ARGS)) + +;; Some operations are too long to do in-line. +;; Use out-of-line utilities. + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS (? operation) + (REGISTER (? source1)) + (REGISTER (? source2)) + (? overflow?))) + (QUALIFIER (fixnum-2-args/special-operator? operation)) + (special-binary-operation + operation + (fixnum-2-args/special-operator operation) + target source1 source2 overflow?)) + +(define-integrable (fixnum-2-args/special-operator operation) + (lookup-arithmetic-method operation fixnum-methods/2-args/special)) + +(define-integrable (fixnum-2-args/special-operator? operation) + (arithmetic-method? operation fixnum-methods/2-args/special)) + +(define fixnum-methods/2-args/special + (list 'FIXNUM-METHODS/2-ARGS/SPECIAL)) + +;; Note: Bit-wise operations never overflow, therefore they always +;; skip the branch (cond = TR). Perhaps they should error? + +;; Note: The commas in the macros do not follow normal QUASIQUOTE patterns. +;; This is due to a bad interaction between QUASIQUOTE and LAP! + +(let-syntax + ((unary-fixnum + (macro (name instr nsv fixed-operand) + `(define-arithmetic-method ',name fixnum-methods/1-arg + (lambda (tgt src overflow?) + (if untagged-fixnums? + (begin + (if overflow? (no-overflow-branches!)) + (LAP (,instr () ,fixed-operand ,',src ,',tgt))) + (if overflow? + (LAP (,instr (,nsv) ,fixed-operand ,',src ,',tgt)) + (LAP (,instr () ,fixed-operand ,',src ,',tgt)))))))) + + (binary-fixnum + (macro (name instr nsv) + `(define-arithmetic-method ',name fixnum-methods/2-args + (lambda (tgt src1 src2 overflow?) + (if untagged-fixnums? + (begin + (if overflow? (no-overflow-branches!)) + (LAP (,instr () ,',src1 ,',src2 ,',tgt))) + (if overflow? + (LAP (,instr (,nsv) ,',src1 ,',src2 ,',tgt)) + (LAP (,instr () ,',src1 ,',src2 ,',tgt)))))))) + + (binary-out-of-line + (macro (name . regs) + `(define-arithmetic-method ',name fixnum-methods/2-args/special + (cons ,(symbol-append 'HOOK:COMPILER- name) + (lambda () + ,(if (null? regs) + `(LAP) + `(require-registers! ,@regs)))))))) + + (unary-fixnum ONE-PLUS-FIXNUM ADDI NSV ,fixnum-1) + (unary-fixnum MINUS-ONE-PLUS-FIXNUM ADDI NSV ,(- fixnum-1)) + (unary-fixnum FIXNUM-NOT SUBI TR ,(- fixnum-1));;?? XOR? + + (binary-fixnum PLUS-FIXNUM ADD NSV) + (binary-fixnum MINUS-FIXNUM SUB NSV) + (binary-fixnum FIXNUM-AND AND TR) + (binary-fixnum FIXNUM-ANDC ANDCM TR) + (binary-fixnum FIXNUM-OR OR TR) + (binary-fixnum FIXNUM-XOR XOR TR) + + (binary-out-of-line MULTIPLY-FIXNUM fp4 fp5) + (binary-out-of-line FIXNUM-QUOTIENT fp4 fp5) + (binary-out-of-line FIXNUM-REMAINDER fp4 fp5 regnum:addil-result) + (binary-out-of-line FIXNUM-LSH)) + +;;; Out of line calls. + +;; Arguments are passed in regnum:first-arg and regnum:second-arg. +;; Result is returned in regnum:first-arg, and a boolean is returned +;; in regnum:second-arg indicating wheter there was overflow. +#| +(define (special-binary-operation operation hook target source1 source2 ovflw?) + (if (not (pair? hook)) + (error "special-binary-operation: Unknown operation" operation)) + + (let* ((extra ((cdr hook))) + (load-1 (->machine-register source1 regnum:first-arg)) + (load-2 (->machine-register source2 regnum:second-arg))) + ;; Make regnum:first-arg the only alias for target + (delete-register! target) + (delete-dead-registers!) + (add-pseudo-register-alias! target regnum:first-arg) + (if (and untagged-fixnums? ovflw?) + (overflow-branch-if-not-nullified!)) + (LAP ,@extra + ,@load-1 + ,@load-2 + ,@(invoke-hook (car hook)) + ,@(if (not ovflw?) + (LAP) + (LAP (COMICLR (=) 0 ,regnum:second-arg 0)))))) +|# + +;; This version fixes the problem with the previous that a reduction merge +;; like (if ... (fix:remainder x y) 0) would never assign target (=r2) + +(define (special-binary-operation operation hook target source1 source2 ovflw?) + (if (not (pair? hook)) + (error "special-binary-operation: Unknown operation" operation)) + + (let* ((extra ((cdr hook))) + (load-1 (->machine-register source1 regnum:first-arg)) + (load-2 (->machine-register source2 regnum:second-arg))) + (let ((core + (lambda (extra-2) + (if (and untagged-fixnums? ovflw?) + (overflow-branch-if-not-nullified!)) + (LAP ,@extra + ,@load-1 + ,@load-2 + ,@(invoke-hook (car hook)) + ,@extra-2 + ,@(if (not ovflw?) + (LAP) + (LAP (COMICLR (=) 0 ,regnum:second-arg 0))))))) + (if (machine-register? target) + (begin + (delete-dead-registers!) + (core (copy regnum:first-arg target))) + (begin + (delete-register! target) + (delete-dead-registers!) + (add-pseudo-register-alias! target regnum:first-arg) + (core (LAP))))))) + +;;; Binary operations with one argument constant. + +(define-rule statement + ;; execute binary fixnum operation with constant second arg + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS (? operation) + (REGISTER (? source)) + (CONSTANT (? constant)) + (? overflow?))) + (QUALIFIER + (fixnum-2-args/operator/register*constant? operation constant overflow?)) + (standard-unary-conversion + source target + (lambda (source target) + ((fixnum-2-args/operator/register*constant operation) + target source constant overflow?)))) + +(define-rule statement + ;; execute binary fixnum operation with constant first arg + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS (? operation) + (CONSTANT (? constant)) + (REGISTER (? source)) + (? overflow?))) + (QUALIFIER + (fixnum-2-args/operator/constant*register? operation constant overflow?)) + (standard-unary-conversion + source target + (lambda (source target) + (if (fixnum-2-args/commutative? operation) + ((fixnum-2-args/operator/register*constant operation) + target source constant overflow?) + ((fixnum-2-args/operator/constant*register operation) + target constant source overflow?))))) + +(define (define-arithconst-method name table qualifier code-gen) + (define-arithmetic-method name table + (cons code-gen qualifier))) + +(define (fixnum-2-args/commutative? operator) + (memq operator '(PLUS-FIXNUM + MULTIPLY-FIXNUM + FIXNUM-AND + FIXNUM-OR + FIXNUM-XOR))) + +(define-integrable (fixnum-2-args/operator/register*constant operation) + (car (lookup-arithmetic-method operation + fixnum-methods/2-args/register*constant))) + +(define (fixnum-2-args/operator/register*constant? operation constant ovflw?) + (let ((handler (arithmetic-method? operation + fixnum-methods/2-args/register*constant))) + (and handler + ((cddr handler) constant ovflw?)))) + +(define fixnum-methods/2-args/register*constant + (list 'FIXNUM-METHODS/2-ARGS/REGISTER*CONSTANT)) + +(define-integrable (fixnum-2-args/operator/constant*register operation) + (car (lookup-arithmetic-method operation + fixnum-methods/2-args/constant*register))) + +(define (fixnum-2-args/operator/constant*register? operation constant ovflw?) + (let ((handler (arithmetic-method? operation + fixnum-methods/2-args/constant*register))) + (or (and handler + ((cddr handler) constant ovflw?)) + (and (fixnum-2-args/commutative? operation) + (fixnum-2-args/operator/register*constant? operation + constant ovflw?))))) + +(define fixnum-methods/2-args/constant*register + (list 'FIXNUM-METHODS/2-ARGS/CONSTANT*REGISTER)) + +(define (guarantee-signed-fixnum n) + (if (not (signed-fixnum? n)) (error "Not a signed fixnum" n)) + n) + +(define (signed-fixnum? n) + (and (exact-integer? n) + (>= n signed-fixnum/lower-limit) + (< n signed-fixnum/upper-limit))) + +;;;; The following are for special case handling where one argument is +;;;; a compile-time constant. Each has a predicate to see if the +;;;; constant is of the form required for the open coding to work. + +(define-integrable (divisible? m n) + (zero? (remainder m n))) + +(define (integer-log-base-2? n) + (let loop ((power 1) (exponent 0)) + (cond ((< n power) false) + ((= n power) exponent) + (else + (loop (* 2 power) (1+ exponent)))))) + +(if untagged-fixnums? + + (define-arithconst-method 'PLUS-FIXNUM + fixnum-methods/2-args/register*constant + (lambda (constant ovflw?) + ovflw? + ;; ignored because success of generic arithmetic pretest + ;; guarantees it won't overflow + (fits-in-14-bits-signed? (* constant fixnum-1))) + (lambda (tgt src constant overflow?) + (guarantee-signed-fixnum constant) + (if overflow? (no-overflow-branches!)) + (let ((value (* constant fixnum-1))) + (load-offset value src tgt)))) + + (define-arithconst-method 'PLUS-FIXNUM + fixnum-methods/2-args/register*constant + (lambda (constant ovflw?) + ovflw? ; ignored + (fits-in-11-bits-signed? (* constant fixnum-1))) + (lambda (tgt src constant overflow?) + (guarantee-signed-fixnum constant) + (let ((value (* constant fixnum-1))) + (if overflow? + (cond ((zero? constant) + (LAP (ADD (TR) ,src 0 ,tgt))) + ((fits-in-11-bits-signed? value) + (LAP (ADDI (NSV) ,value ,src ,tgt))) + (else + (let ((temp (standard-temporary!))) + (LAP ,@(load-fixnum-constant constant temp) + (ADD (NSV) ,src ,temp ,tgt))))) + (load-offset value src tgt))))) + ) + +(if untagged-fixnums? + + (define-arithconst-method 'MINUS-FIXNUM + fixnum-methods/2-args/register*constant + (lambda (constant ovflw?) + ovflw? + ;; ignored because success of generic arithmetic pretest + ;; guarantees it won't overflow + (fits-in-14-bits-signed? (- (* constant fixnum-1)))) + (lambda (tgt src constant overflow?) + (guarantee-signed-fixnum constant) + (if overflow? (no-overflow-branches!)) + (let ((value (- (* constant fixnum-1)))) + (load-offset value src tgt)))) + + (define-arithconst-method 'MINUS-FIXNUM + fixnum-methods/2-args/register*constant + (lambda (constant ovflw?) + ovflw? ; ignored + (fits-in-11-bits-signed? (- (* constant fixnum-1)))) + (lambda (tgt src constant overflow?) + (guarantee-signed-fixnum constant) + (let ((value (- (* constant fixnum-1)))) + (if overflow? + (cond ((zero? constant) + (LAP (ADD (TR) ,src 0 ,tgt))) + ((fits-in-11-bits-signed? value) + (LAP (ADDI (NSV) ,value ,src ,tgt))) + (else + (let ((temp (standard-temporary!))) + (LAP ,@(load-fixnum-constant constant temp) + (ADD (NSV) ,src ,temp ,tgt))))) + (load-offset value src tgt))))) + ) + +(if untagged-fixnums? + (define-arithconst-method 'MINUS-FIXNUM + fixnum-methods/2-args/constant*register + (lambda (constant ovflw?) + ovflw? ; ignored + (fits-in-11-bits-signed? (* constant fixnum-1))) + (lambda (tgt constant src overflow?) + (guarantee-signed-fixnum constant) + (if overflow? (no-overflow-branches!)) + (let ((value (* constant fixnum-1))) + (if (fits-in-11-bits-signed? value) + (LAP (SUBI () ,value ,src ,tgt)) + (error "MINUS-FIXNUM * with bad constant" value))))) + + (define-arithconst-method 'MINUS-FIXNUM + fixnum-methods/2-args/constant*register + (lambda (constant ovflw?) + ovflw? ; ignored + (fits-in-11-bits-signed? (* constant fixnum-1))) + (lambda (tgt constant src overflow?) + (guarantee-signed-fixnum constant) + (let ((value (* constant fixnum-1))) + (if (fits-in-11-bits-signed? value) + (if overflow? + (LAP (SUBI (NSV) ,value ,src ,tgt)) + (LAP (SUBI () ,value ,src ,tgt))) + (let ((temp (standard-temporary!))) + (LAP ,@(load-fixnum-constant constant temp) + ,@(if overflow? + (LAP (SUB (NSV) ,temp ,src ,tgt)) + (LAP (SUB () ,temp ,src ,tgt))))))))) + ) + + +(if untagged-fixnums? + (define-arithconst-method 'FIXNUM-AND + fixnum-methods/2-args/register*constant + (lambda (constant ovflw?) + ovflw? + ;; ignored because can never happen + (integer-log-base-2? (+ constant 1))) + (lambda (tgt src constant overflow?) + (guarantee-signed-fixnum constant) + (if overflow? (no-overflow-branches!)) + (let ((bits (integer-log-base-2? (+ constant 1)))) + (LAP (EXTRU () ,src 31 ,bits ,tgt)))))) + +(if untagged-fixnums? + (define-arithconst-method 'FIXNUM-LSH + fixnum-methods/2-args/register*constant + (lambda (constant ovflw?) + (if ovflw? (error "RULFIX: FIXNUM-LSH with overflow check requested")) + constant ; ignored + true) + ;; OVERFLOW? should never be set, because there is no generic + ;; LSH operation and only generics cause overflow detection + (lambda (tgt src shift overflow?) + (if overflow? + (error "RULFIX: FIXNUM-LSH with overflow check requested")) + (guarantee-signed-fixnum shift) + (cond ((zero? shift) + (copy src tgt)) + ((negative? shift) + ;; Right shift + (let ((shift (- shift))) + (if (>= shift scheme-datum-width) + (copy 0 tgt) + (LAP (SHD () 0 ,src ,shift ,tgt))))) + (else + ;; Left shift + (if (>= shift scheme-datum-width) + (copy 0 tgt) + (LAP (SHD () ,src 0 ,(- 32 shift) ,tgt))))))) + + (define-arithconst-method 'FIXNUM-LSH + fixnum-methods/2-args/register*constant + (lambda (constant ovflw?) + constant ovflw? ; ignored + true) + (lambda (tgt src shift overflow?) + ;; What does overflow mean for a logical shift? + ;; The code commented out below corresponds to arithmetic shift + ;; overflow conditions. + (guarantee-signed-fixnum shift) + (cond ((zero? shift) + (cond ((not overflow?) + (copy src tgt)) + ((= src tgt) + (LAP (SKIP (TR)))) + (else + (LAP (COPY (TR) ,src ,tgt))))) + ((negative? shift) + ;; Right shift + (let ((shift (- shift))) + (cond ((< shift scheme-datum-width) + (LAP (SHD () 0 ,src ,shift ,tgt) + ;; clear shifted bits + (DEP (,(if overflow? 'TR 'NV)) + 0 31 ,scheme-type-width ,tgt))) + ((not overflow?) + (copy 0 tgt)) + (else + (LAP (COPY (TR) 0 ,tgt)))))) + (else + ;; Left shift + (if (>= shift scheme-datum-width) + (if (not overflow?) + (copy 0 tgt) + #| (LAP (COMICLR (=) 0 ,src ,tgt)) |# + (LAP (COMICLR (TR) 0 ,src ,tgt))) + (let ((nbits (- 32 shift))) + (if overflow? + #| + ;; Arithmetic overflow condition accomplished + ;; by skipping all over the place. + ;; Another possibility is to use the shift-and-add + ;; instructions, which compute correct signed overflow + ;; conditions. + (let ((nkept (- 32 shift)) + (temp (standard-temporary!))) + (LAP (ZDEP () ,src ,(- nkept 1) ,nkept ,tgt) + (EXTRS (=) ,src ,(- shift 1) ,shift ,temp) + (COMICLR (<>) -1 ,temp 0) + (SKIP (TR)))) + |# + (LAP (ZDEP (TR) ,src ,(- nbits 1) ,nbits ,tgt)) + (LAP (ZDEP () ,src ,(- nbits 1) ,nbits ,tgt))))))))) + ) + +(define (no-overflow-branches!) + (set-current-branches! + (lambda (if-overflow) + if-overflow + (LAP)) + (lambda (if-no-overflow) + (LAP (B (N) (@PCR ,if-no-overflow)) + (NOP ()))))) + +(define (untagged-fixnum-sign-extend source target) + (let ((len (+ 1 scheme-datum-width))) + (LAP (EXTRS () ,source 31 ,len ,target)))) + +(define (fix:fixnum?-overflow-branches! register) + (let ((temp (standard-temporary!))) + (set-current-branches! + (lambda (if-overflow) + (LAP ,@(untagged-fixnum-sign-extend register temp) + (COMBN (<>) ,register ,temp (@PCR ,if-overflow)))) + (lambda (if-no-overflow) + (LAP ,@(untagged-fixnum-sign-extend register temp) + (COMBN (=) ,register ,temp (@PCR ,if-no-overflow))))))) + +(define (overflow-branch-if-not-nullified!) + (set-current-branches! + (lambda (if-overflow) + (LAP (B (N) (@PCR ,if-overflow)))) + (lambda (if-no-overflow) + (LAP (SKIP (TR)) + (B (N) (@PCR ,if-no-overflow)))))) + +(define (expand-factor tgt src factor skipping? condition skip) + (define (sh3add condition src1 src2 tgt) + (LAP (SH3ADD ,condition ,src1 ,src2 ,tgt))) + + (define (sh2add condition src1 src2 tgt) + (LAP (SH2ADD ,condition ,src1 ,src2 ,tgt))) + + (define (sh1add condition src1 src2 tgt) + (LAP (SH1ADD ,condition ,src1 ,src2 ,tgt))) + + (define (handle factor fixed) + (define (wrap instr next value) + (let ((code? (car next)) + (result-reg (cadr next)) + (temp-reg (caddr next)) + (code (cadddr next))) + (list true + tgt + temp-reg + (LAP ,@code + ,@(if code? + (skip) + (LAP)) + ,@(instr condition result-reg value tgt))))) + + (cond ((zero? factor) (list false 0 fixed (LAP))) + ((= factor 1) (list false fixed fixed (LAP))) + ((divisible? factor 8) + (wrap sh3add (handle (/ factor 8) fixed) 0)) + ((divisible? factor 4) + (wrap sh2add (handle (/ factor 4) fixed) 0)) + ((divisible? factor 2) + (wrap sh1add (handle (/ factor 2) fixed) 0)) + (else + (let* ((f1 (-1+ factor)) + (fixed (if (or (not (= fixed src)) + (not (= src tgt)) + (and (integer-log-base-2? f1) + (< f1 16))) + fixed + (standard-temporary!)))) + (cond ((divisible? f1 8) + (wrap sh3add (handle (/ f1 8) fixed) fixed)) + ((divisible? f1 4) + (wrap sh2add (handle (/ f1 4) fixed) fixed)) + (else + (wrap sh1add (handle (/ f1 2) fixed) fixed))))))) + + (let ((result (handle factor src))) + (let ((result-reg (cadr result)) + (temp-reg (caddr result)) + (code (cadddr result))) + + (LAP ,@(cond ((= temp-reg src) + (LAP)) + ((not skipping?) + (LAP (COPY () ,src ,temp-reg))) + (else + (LAP (COPY (TR) ,src ,temp-reg) + ,@(skip)))) + ,@code + ,@(cond ((= result-reg tgt) + (LAP)) + ((or (null? condition) + (memq 'NV condition)) + (LAP (COPY () ,result-reg ,tgt))) + (else + (LAP (COPY (TR) ,result-reg ,tgt) + ,@(skip)))))))) + ; end of EXPAND-FACTOR + +(if untagged-fixnums? + (define-arithconst-method 'MULTIPLY-FIXNUM + fixnum-methods/2-args/register*constant + (lambda (constant ovflw?) + (let ((factor (abs constant))) + (or (not ovflw?) + (< factor 64) ; Can't overflow out of 32-bit word + (and + (< (abs factor) (expt 2 (-1+ scheme-datum-width))) + (integer-log-base-2? factor))))) + + (lambda (tgt src constant overflow?) + (guarantee-signed-fixnum constant) + (let* ((factor (abs constant)) + (xpt (integer-log-base-2? factor))) + (case constant + ((0) (if overflow? (no-overflow-branches!)) + (LAP (COPY () 0 ,tgt))) + ((1) (if overflow? (no-overflow-branches!)) + (copy src tgt)) + ((-1) (if overflow? (fix:fixnum?-overflow-branches! tgt)) + (LAP (SUB () 0 ,src ,tgt))) + ((and overflow? xpt (> xpt 6)) + (let ((true-src (if (negative? constant) tgt src)) + (temp (standard-temporary!))) + (set-current-branches! + (lambda (if-oflow) + (LAP (COMBN (<>) ,true-src ,temp ,if-oflow) + (SHD ,true-src 0 ,(- 32 xpt) ,tgt))) + (lambda (if-no-oflow) + (LAP (COMB (=) ,true-src ,temp ,if-no-oflow) + (SHD ,true-src 0 ,(- 32 xpt) ,tgt)))) + (LAP ,@(if (negative? constant) + (LAP (SUB () 0 ,src ,true-src)) + (LAP)) + (EXTRS () ,true-src 31 + ,(- 31 (+ xpt scheme-type-width)) + ,temp)))) + (else + ;; No overflow, or small constant + (if overflow? (fix:fixnum?-overflow-branches! tgt)) + (let ((src+ (if (negative? constant) tgt src))) + (LAP ,@(if (negative? constant) + (LAP (SUB () 0 ,src ,tgt)) + (LAP)) + ,@(if xpt + (LAP (SHD () ,src+ 0 ,(- 32 xpt) ,tgt)) + (expand-factor tgt src+ factor false '() + (lambda () (LAP))))))))))) + + (define-arithconst-method 'MULTIPLY-FIXNUM + fixnum-methods/2-args/register*constant + (lambda (constant ovflw?) + (let ((factor (abs constant))) + #| + (or (integer-log-base-2? factor) + (and (<= factor 64) + (or (not ovflw?) + (<= factor (expt 2 scheme-type-width))))) + |# + (or (not ovflw?) + (<= factor 64) + (integer-log-base-2? factor)))) + + (lambda (tgt src constant overflow?) + (guarantee-signed-fixnum constant) + (let ((skip (if overflow? 'NSV 'NV))) + (case constant + ((0) + (if overflow? + (LAP (COPY (TR) 0 ,tgt)) + (LAP (COPY () 0 ,tgt)))) + ((1) + (if overflow? + (LAP (COPY (TR) ,src ,tgt)) + (copy src tgt))) + ((-1) + (LAP (SUB (,skip) 0 ,src ,tgt))) + (else + (let* ((factor (abs constant)) + (src+ (if (negative? constant) tgt src)) + (xpt (integer-log-base-2? factor))) + (cond ((not overflow?) + (LAP ,@(if (negative? constant) + (LAP (SUB () 0 ,src ,tgt)) + (LAP)) + ,@(if xpt + (LAP (SHD () ,src+ 0 ,(- 32 xpt) ,tgt)) + (expand-factor tgt src+ factor false '() + (lambda () + (LAP)))))) + ((and xpt (> xpt 6)) + (let* ((high (standard-temporary!)) + (low (if (or (= src tgt) (negative? constant)) + (standard-temporary!) + src)) + (nbits (- 32 xpt)) + (core + (LAP (SHD () ,low 0 ,nbits ,tgt) + (SHD (=) ,high ,low ,(-1+ nbits) ,high) + (COMICLR (<>) -1 ,high 0) + (SKIP (TR))))) + (if (negative? constant) + (LAP (EXTRS () ,src 0 1 ,high) + (SUB () 0 ,src ,low) + (SUBB () 0 ,high ,high) + ,@core) + (LAP ,@(if (not (= src low)) + (LAP (COPY () ,src ,low)) + (LAP)) + (EXTRS () ,low 0 1 ,high) + ,@core)))) + (else + (LAP ,@(if (negative? constant) + (LAP (SUB (SV) 0 ,src ,tgt)) + (LAP)) + ,@(expand-factor tgt src+ factor + (negative? constant) + '(NSV) + (lambda () + (LAP (SKIP (TR)))))))))))))) + ) + +;;;; Division + +(if untagged-fixnums? + (define-arithconst-method 'FIXNUM-QUOTIENT + fixnum-methods/2-args/register*constant + (lambda (constant ovflw?) + ovflw? ; ignored + (integer-log-base-2? (abs constant))) + (lambda (tgt src constant ovflw?) + (guarantee-signed-fixnum constant) + (case constant + ((1) (if ovflw? (no-overflow-branches!)) + (copy src tgt)) + ((-1) + (if ovflw? (fix:fixnum?-overflow-branches!)) + (LAP (SUB () 0 ,src ,tgt))) + (else + (let* ((factor (abs constant)) + (xpt (integer-log-base-2? factor))) + (cond ((not xpt) + (error "fixnum-quotient: Inconsistency" constant)) + ((>= xpt scheme-datum-width) + (if ovflw? (no-overflow-branches!)) + (copy 0 tgt)) + (else + ;; Note: The following cannot overflow because we are + ;; dividing by a constant whose absolute value is + ;; strictly greater than 1. + (if ovflw? (no-overflow-branches!)) + (let* ((posn (- 32 xpt)) + (delta (* (-1+ factor) fixnum-1)) + (fits? (fits-in-11-bits-signed? delta)) + (temp (and (not fits?) (standard-temporary!)))) + (LAP ,@(if fits? + (LAP) + (load-immediate delta temp)) + (ADD (>=) 0 ,src ,tgt) ; Copy to tgt & test + ; negative dividend + ,@(if fits? ; For negative dividend ONLY + (LAP (ADDI () ,delta ,tgt ,tgt)) + (LAP (ADD () ,temp ,tgt ,tgt))) + (EXTRS () ,tgt ,(-1+ posn) ,posn ,tgt) + ,@(if (negative? constant) + (LAP (SUB () 0 ,tgt ,tgt)) + (LAP))))))))))) + + (define-arithconst-method 'FIXNUM-QUOTIENT + fixnum-methods/2-args/register*constant + (lambda (constant ovflw?) + ovflw? ; ignored + (integer-log-base-2? (abs constant))) + (lambda (tgt src constant ovflw?) + (guarantee-signed-fixnum constant) + (case constant + ((1) + (if ovflw? + (LAP (COPY (TR) ,src ,tgt)) + (copy src tgt))) + ((-1) + (let ((skip (if ovflw? 'NSV 'NV))) + (LAP (SUB (,skip) 0 ,src ,tgt)))) + (else + (let* ((factor (abs constant)) + (xpt (integer-log-base-2? factor))) + (cond ((not xpt) + (error "fixnum-quotient: Inconsistency" constant)) + ((>= xpt scheme-datum-width) + (if ovflw? + (LAP (COPY (TR) 0 ,tgt)) + (copy 0 tgt))) + (else + ;; Note: The following cannot overflow because we are + ;; dividing by a constant whose absolute value is + ;; strictly greater than 1. However, we need to + ;; negate after shifting, not before, because negating + ;; the input can overflow (if it is -0). + ;; This unfortunately implies an extra instruction in the + ;; case of negative constants because if this weren't the + ;; case, we could substitute the first ADD instruction for + ;; a SUB for negative constants, and eliminate the SUB later. + (let* ((posn (- 32 xpt)) + (delta (* (-1+ factor) fixnum-1)) + (fits? (fits-in-11-bits-signed? delta)) + (temp (and (not fits?) (standard-temporary!)))) + + (LAP ,@(if fits? + (LAP) + (load-immediate delta temp)) + (ADD (>=) 0 ,src ,tgt) + ,@(if fits? + (LAP (ADDI () ,delta ,tgt ,tgt)) + (LAP (ADD () ,temp ,tgt ,tgt))) + (EXTRS () ,tgt ,(-1+ posn) ,posn ,tgt) + ,@(let ((skip (if ovflw? 'TR 'NV))) + (if (negative? constant) + (LAP (DEP () 0 31 ,scheme-type-width ,tgt) + (SUB (,skip) 0 ,tgt ,tgt)) + (LAP + (DEP (,skip) 0 31 ,scheme-type-width + ,tgt))))))))))))) + ) + +(if untagged-fixnums? + (define-arithconst-method 'FIXNUM-REMAINDER + fixnum-methods/2-args/register*constant + (lambda (constant ovflw?) + ovflw? ; ignored + (integer-log-base-2? (abs constant))) + (lambda (tgt src constant ovflw?) + (guarantee-signed-fixnum constant) + (if ovflw? (no-overflow-branches!)) + (case constant + ((1 -1) + (LAP (COPY () 0 ,tgt))) + (else + (let ((sign (standard-temporary!)) + (len (integer-log-base-2? (abs constant)))) + (let ((sgn-len (- 32 len))) + (LAP (EXTRS () ,src 0 1 ,sign) + (EXTRU (=) ,src 31 ,len ,tgt) + (DEP () ,sign ,(- sgn-len 1) ,sgn-len ,tgt)))))))) + + (define-arithconst-method 'FIXNUM-REMAINDER + fixnum-methods/2-args/register*constant + (lambda (constant ovflw?) + ovflw? ; ignored + (integer-log-base-2? (abs constant))) + (lambda (tgt src constant ovflw?) + (guarantee-signed-fixnum constant) + (case constant + ((1 -1) + (if ovflw? + (LAP (COPY (TR) 0 ,tgt)) + (LAP (COPY () 0 ,tgt)))) + (else + (let ((sign (standard-temporary!)) + (len (let ((xpt (integer-log-base-2? (abs constant)))) + (and xpt (+ xpt scheme-type-width))))) + (let ((sgn-len (- 32 len))) + (if (not len) + (error "fixnum-remainder: Inconsistency" constant ovflw?)) + (LAP (EXTRS () ,src 0 1 ,sign) + (EXTRU (=) ,src 31 ,len ,tgt) + (DEP () ,sign ,(- sgn-len 1) ,sgn-len ,tgt) + ,@(if ovflw? + (LAP (SKIP (TR))) + (LAP))))))))) + ) + +;;;; Predicates + +;; This is a kludge. It assumes that the last instruction of the +;; arithmetic operation that may cause an overflow condition will skip +;; the following instruction if there was no overflow, ie., the last +;; instruction will nullify using NSV (or TR if overflow is +;; impossible). The code for the alternative is a real kludge because +;; we can't force the arithmetic instruction that precedes this code +;; to use the inverted condition. Hopefully a peep-hole optimizer +;; will fix this. The linearizer attempts to use the "good" branch. + +(define-rule predicate + (OVERFLOW-TEST) + ;; Overflow test handling for untagged-fixnums is embedded in the + ;; code for the operator. + (if (not untagged-fixnums?) + (overflow-branch-if-not-nullified!)) + (LAP)) + +(define-rule predicate + (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? source))) + (QUALIFIER (memq predicate '(ZERO-FIXNUM? EQUAL-FIXNUM? + NEGATIVE-FIXNUM? LESS-THAN-FIXNUM? + POSITIVE-FIXNUM? GREATER-THAN-FIXNUM?))) + (compare (fixnum-pred->cc predicate) + (standard-source! source) + 0)) + +(define-rule predicate + (FIXNUM-PRED-2-ARGS (? predicate) + (REGISTER (? source1)) + (REGISTER (? source2))) + (compare (fixnum-pred->cc predicate) + (standard-source! source1) + (standard-source! source2))) + +;(define-rule predicate +; (FIXNUM-PRED-2-ARGS (? predicate) +; (OBJECT->FIXNUM (REGISTER (? source1))) +; (OBJECT->FIXNUM (REGISTER (? source2)))) +; (compare (fixnum-pred->cc predicate) +; (standard-source! source1) +; (standard-source! source2))) + +(define-rule predicate + (FIXNUM-PRED-2-ARGS (? predicate) + (REGISTER (? source)) + (CONSTANT (? constant))) + (compare-fixnum/constant*register (invert-condition-noncommutative + (fixnum-pred->cc predicate)) + constant + (standard-source! source))) + +(define-rule predicate + (FIXNUM-PRED-2-ARGS (? predicate) + (CONSTANT (? constant)) + (REGISTER (? source))) + (compare-fixnum/constant*register (fixnum-pred->cc predicate) + constant + (standard-source! source))) + +(define-integrable (compare-fixnum/constant*register cc n r) + (guarantee-signed-fixnum n) + (compare-immediate cc (* n fixnum-1) r)) + +(define (fixnum-pred->cc predicate) + (case predicate + ((ZERO-FIXNUM? EQUAL-FIXNUM?) '=) + ((NEGATIVE-FIXNUM? LESS-THAN-FIXNUM?) '<) + ((POSITIVE-FIXNUM? GREATER-THAN-FIXNUM?) '>) + (else + (error "fixnum-pred->cc: unknown predicate" predicate)))) + +;;;; New "optimizations" + +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (OBJECT->DATUM (FIXNUM->OBJECT (REGISTER (? source))))) +; (standard-unary-conversion source target fixnum->datum)) + +(define (constant->additive-operand operation constant) + (case operation + ((PLUS-FIXNUM ONE-PLUS-FIXNUM) constant) + ((MINUS-FIXNUM MINUS-ONE-PLUS-FIXNUM) (- constant)) + (else + (error "constant->additive-operand: Unknown operation" + operation)))) + +(define (guarantee-fixnum-result target) + (if untagged-fixnums? + (if compiler:assume-safe-fixnums? + (LAP) + (untagged-fixnum-sign-extend target target)) + (let ((default + (lambda () + (deposit-immediate (ucode-type positive-fixnum) + (-1+ scheme-type-width) + scheme-type-width + target)))) + #| + ;; Unsafe at sign crossings until the tags are changed. + (if compiler:assume-safe-fixnums? + (LAP) + (default)) + |# + (default)))) + +;(define (obj->fix-of-reg*obj->fix-of-const operation target source constant) +; (let* ((source (standard-source! source)) +; (temp (standard-temporary!)) +; (target (standard-target! target))) +; (pp (list 'obj->fix-of-reg*obj->fix-of-const operation target source constant)) +; (LAP ,@(load-offset (constant->additive-operand operation constant) +; source temp) +; ,@(if untagged-fixnums? +; ;;B? (copy-instead-of-object->fixnum temp target) +; (object->fixnum temp target) +; (object->fixnum temp target))))) +; +;(define (obj->fix-of-reg*obj->fix-of-const operation target source constant) +; (let* ((source (standard-source! source)) +; (target (standard-target! target))) +; (LAP ,@(load-offset (constant->additive-operand operation constant) +; source target) +; ,@(guarantee-fixnum-result target)))) + + +;(define (fix->obj-of-obj->fix-of-reg*obj->fix-of-const operation target +; source constant) +; (let* ((source (standard-source! source)) +; (target (standard-target! target))) +; (LAP ,@(load-offset (constant->additive-operand operation constant) +; source target) +; ,@(guarantee-fixnum-result target)))) +; +;(define (obj->dat-of-fix->obj-of-obj->fix-of-reg*obj->fix-of-const +; operation target source constant) +; (let* ((source (standard-source! source)) +; (temp (standard-temporary!)) +; (target (standard-target! target))) +; (LAP ,@(load-offset (constant->additive-operand operation constant) +; source temp) +; ,@(object->datum temp target)))) +; +;(define (fix->obj-of-reg*obj->fix-of-const operation target source constant) +; (let* ((source (standard-source! source)) +; (temp (standard-temporary!)) +; (target (standard-target! target))) +; (LAP ,@(load-offset +; (constant->additive-operand operation (* constant fixnum-1)) +; source temp) +; ,@(fixnum->object temp target)))) +; +;(define (obj->dat-of-fix->obj-of-reg*obj->fix-of-const +; operation target source constant) +; (let* ((source (standard-source! source)) +; (temp (standard-temporary!)) +; (target (standard-target! target))) +; (LAP ,@(load-offset +; (constant->additive-operand operation (* constant fixnum-1)) +; source temp) +; ,@(fixnum->datum temp target)))) + +;(define (incr-or-decr? operation) +; (and (memq operation '(ONE-PLUS-FIXNUM MINUS-ONE-PLUS-FIXNUM)) +; operation)) +; +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (FIXNUM-1-ARG (? operation incr-or-decr?) +; (OBJECT->FIXNUM (REGISTER (? source))) +; #F)) +; (obj->fix-of-reg*obj->fix-of-const operation target source 1)) +; +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (FIXNUM-1-ARG (? operation incr-or-decr?) +; (OBJECT->FIXNUM (REGISTER (? source))) +; #F)) +; (fix->obj-of-obj->fix-of-reg*obj->fix-of-const operation target source 1)) +; +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (OBJECT->DATUM +; (FIXNUM->OBJECT +; (FIXNUM-1-ARG (? operation incr-or-decr?) +; (OBJECT->FIXNUM (REGISTER (? source))) +; #F)))) +; (obj->dat-of-fix->obj-of-obj->fix-of-reg*obj->fix-of-const +; operation target source 1)) +; +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (FIXNUM-1-ARG (? operation incr-or-decr?) +; (REGISTER (? source)) +; #F)) +; (fix->obj-of-reg*obj->fix-of-const operation target source 1)) +; +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (OBJECT->DATUM +; (FIXNUM->OBJECT +; (FIXNUM-1-ARG (? operation incr-or-decr?) +; (REGISTER (? source)) +; #F)))) +; (obj->dat-of-fix->obj-of-reg*obj->fix-of-const +; operation target source 1)) + +(define (plus-or-minus? operation) + (and (memq operation '(PLUS-FIXNUM MINUS-FIXNUM)) + operation)) + +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (FIXNUM-2-ARGS (? operation plus-or-minus?) +; (OBJECT->FIXNUM (REGISTER (? source))) +; (OBJECT->FIXNUM (CONSTANT (? constant))) +; #F)) +; (obj->fix-of-reg*obj->fix-of-const operation target source constant)) + +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (FIXNUM->OBJECT +; (FIXNUM-2-ARGS (? operation plus-or-minus?) +; (OBJECT->FIXNUM (REGISTER (? source))) +; (OBJECT->FIXNUM (CONSTANT (? constant))) +; #F))) +; (QUALIFIER (memq operation '(PLUS-FIXNUM MINUS-FIXNUM))) +; (fix->obj-of-obj->fix-of-reg*obj->fix-of-const operation target +; source constant)) +; +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (OBJECT->DATUM +; (FIXNUM->OBJECT +; (FIXNUM-2-ARGS (? operation plus-or-minus?) +; (OBJECT->FIXNUM (REGISTER (? source))) +; (OBJECT->FIXNUM (CONSTANT (? constant))) +; #F)))) +; (QUALIFIER (memq operation '(PLUS-FIXNUM MINUS-FIXNUM))) +; (obj->dat-of-fix->obj-of-obj->fix-of-reg*obj->fix-of-const +; operation target source constant)) +; +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (FIXNUM->OBJECT +; (FIXNUM-2-ARGS (? operation plus-or-minus?) +; (REGISTER (? source)) +; (OBJECT->FIXNUM (CONSTANT (? constant))) +; #F))) +; (QUALIFIER (memq operation '(PLUS-FIXNUM MINUS-FIXNUM))) +; (fix->obj-of-reg*obj->fix-of-const operation target source constant)) +; +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (OBJECT->DATUM +; (FIXNUM->OBJECT +; (FIXNUM-2-ARGS (? operation plus-or-minus?) +; (REGISTER (? source)) +; (OBJECT->FIXNUM (CONSTANT (? constant))) +; #F)))) +; (QUALIFIER (memq operation '(PLUS-FIXNUM MINUS-FIXNUM))) +; (obj->dat-of-fix->obj-of-reg*obj->fix-of-const +; operation target source constant)) + +;(define (additive-operate operation target source-1 source-2) +; (case operation +; ((PLUS-FIXNUM) +; (LAP (ADD () ,source-1 ,source-2 ,target))) +; ((MINUS-FIXNUM) +; (LAP (SUB () ,source-1 ,source-2 ,target))) +; (else +; (error "constant->additive-operand: Unknown operation" +; operation)))) +; +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (FIXNUM-2-ARGS (? operation plus-or-minus?) +; (REGISTER (? source-1)) +; (REGISTER (? source-2)) +; #F)) +; (let* ((source-1 (standard-source! source-1)) +; (source-2 (standard-source! source-2)) +; (target (standard-target! target))) +; (LAP ,@(additive-operate operation target source-1 source-2)))) +; +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (FIXNUM-2-ARGS (? operation plus-or-minus?) +; (REGISTER (? source-1)) +; (REGISTER (? source-2)) +; #F)) +; (let* ((source-1 (standard-source! source-1)) +; (source-2 (standard-source! source-2)) +; (target (standard-target! target))) +; (LAP ,@(additive-operate operation target source-1 source-2)))) +; +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (FIXNUM-2-ARGS (? operation plus-or-minus?) +; (REGISTER (? source-1)) +; (REGISTER (? source-2)) +; #F)) +; (let* ((source-1 (standard-source! source-1)) +; (source-2 (standard-source! source-2)) +; (target (standard-target! target))) +; (LAP ,@(additive-operate operation target source-1 source-2)))) +; +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (FIXNUM-2-ARGS (? operation plus-or-minus?) +; (REGISTER (? source-1)) +; (REGISTER (? source-2)) +; #F)) +; (let* ((source-1 (standard-source! source-1)) +; (source-2 (standard-source! source-2)) +; (target (standard-target! target))) +; (LAP ,@(additive-operate operation target source-1 source-2) +; ,@(guarantee-fixnum-result target)))) + + +;; This recognises the pattern for flo:vector-length: + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT 0) + (FIXNUM-2-ARGS FIXNUM-LSH + (OBJECT->DATUM (REGISTER (? source))) + (CONSTANT (? constant)) + #F))) + (QUALIFIER (and (integer? constant) + (<= (- 1 scheme-datum-width) constant -1))) + (let* ((source (standard-source! source)) + (target (standard-target! target))) + (LAP (EXTRU () ,source ,(+ 31 constant) ,(+ scheme-datum-width constant) + ,target)))) + +;; Intermediate patterns of above: + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS FIXNUM-LSH + (OBJECT->DATUM (REGISTER (? source))) + (CONSTANT (? constant)) + #F)) + (QUALIFIER (and (integer? constant) + (<= (- 1 scheme-datum-width) constant -1))) + (let* ((source (standard-source! source)) + (target (standard-target! target))) + (LAP (EXTRU () ,source ,(+ 31 constant) ,(+ scheme-datum-width constant) + ,target)))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-NON-POINTER (MACHINE-CONSTANT 0) + (FIXNUM-2-ARGS FIXNUM-LSH + (REGISTER (? source)) + (CONSTANT (? constant)) + #F))) + (QUALIFIER (and (integer? constant) + (<= (- 1 scheme-datum-width) constant -1))) + (let* ((source (standard-source! source)) + (target (standard-target! target))) + (LAP ;; Without OBJECT->DATUM the high order bits could be anything and + ;; some could creep into the result. + (EXTRU () ,source ,(+ 31 constant) ,(+ 32 constant) ,target) + (DEPI () 0 ,(- scheme-type-width 1) ,scheme-type-width ,target)))) + diff --git a/v8/src/compiler/machines/spectrum/rulflo.scm b/v8/src/compiler/machines/spectrum/rulflo.scm new file mode 100644 index 000000000..1789660bd --- /dev/null +++ b/v8/src/compiler/machines/spectrum/rulflo.scm @@ -0,0 +1,605 @@ +#| -*-Scheme-*- + +$Id: rulflo.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ + +Copyright (c) 1989-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; LAP Generation Rules: Flonum rules +;; Package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +(define (flonum-source! register) + (float-register->fpr (load-alias-register! register 'FLOAT))) + +(define (flonum-target! pseudo-register) + (delete-dead-registers!) + (float-register->fpr (allocate-alias-register! pseudo-register 'FLOAT))) + +(define (flonum-temporary!) + (float-register->fpr (allocate-temporary-register! 'FLOAT))) + +(define-rule statement + ;; convert a floating-point number to a flonum object + (ASSIGN (REGISTER (? target)) + (FLOAT->OBJECT (REGISTER (? source)))) + (let ((source (flonum-source! source)) + (temp (standard-temporary!))) + (let ((target (standard-target! target))) + (LAP + ;; make heap parsable forwards + ;; (STW () 0 (OFFSET 0 0 ,regnum:free-pointer)) + (DEPI () #b100 31 3 ,regnum:free-pointer) ; quad align + (COPY () ,regnum:free-pointer ,target) + ,@(deposit-type (ucode-type flonum) target) + ,@(load-non-pointer (ucode-type manifest-nm-vector) 2 temp) + (STWS (MA C) ,temp (OFFSET 4 0 ,regnum:free-pointer)) + (FSTDS (MA) ,source (OFFSET 8 0 ,regnum:free-pointer)))))) + +(define-rule statement + ;; convert a flonum object to a floating-point number + (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source)))) + (let ((source (standard-move-to-temporary! source))) + (LAP ,@(object->address source) + (FLDDS () (OFFSET 4 0 ,source) ,(flonum-target! target))))) + +;; This is endianness dependent! + +(define (flonum-value->data-decl value) + (let ((high (make-bit-string 32 false)) + (low (make-bit-string 32 false))) + (read-bits! value 32 high) + (read-bits! value 64 low) + (LAP ,@(lap:comment `(FLOAT ,value)) + (UWORD () ,(bit-string->unsigned-integer high)) + (UWORD () ,(bit-string->unsigned-integer low))))) + +(define (flonum->label value) + (let* ((block + (or (find-extra-code-block 'FLOATING-CONSTANTS) + (let ((block (declare-extra-code-block! 'FLOATING-CONSTANTS + 'ANYWHERE + '()))) + (add-extra-code! + block + (LAP (PADDING ,(- 0 *initial-dword-offset*) 8))) + block))) + (pairs (extra-code-block/xtra block)) + (place (assoc value pairs))) + (if place + (cdr place) + (let ((label (generate-label))) + (set-extra-code-block/xtra! + block + (cons (cons value label) pairs)) + (add-extra-code! block + (LAP (LABEL ,label) + ,@(flonum-value->data-decl value))) + label)))) + +#| +(define-rule statement + (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (CONSTANT 0.))) + (LAP (FCPY (DBL) 0 ,(flonum-target! target)))) +|# + +(define-rule statement + (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (CONSTANT (? fp-value)))) + (cond ((not (flo:flonum? fp-value)) + (error "OBJECT->FLOAT: Not a floating-point value" fp-value)) + (compiler:cross-compiling? + (let ((temp (standard-temporary!))) + (LAP ,@(load-constant fp-value temp) + ,@(object->address temp) + (FLDDS () (OFFSET 4 0 ,temp) ,(flonum-target! target))))) + ((flo:= fp-value 0.0) + (LAP (FCPY (DBL) 0 ,(flonum-target! target)))) + (else + (let* ((temp (standard-temporary!)) + (target (flonum-target! target))) + (LAP ,@(load-pc-relative-address (flonum->label fp-value) + temp + 'CONSTANT) + (FLDDS () (OFFSET 0 0 ,temp) ,target)))))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLOAT-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))) + (float-load/offset target base (* 8 offset))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base)) + (MACHINE-CONSTANT (? w-offset))) + (MACHINE-CONSTANT (? f-offset)))) + (float-load/offset target base (+ (* 4 w-offset) (* 8 f-offset)))) + +(define-rule statement + (ASSIGN (FLOAT-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset))) + (REGISTER (? source))) + (float-store/offset base (* 8 offset) source)) + +(define-rule statement + (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base)) + (MACHINE-CONSTANT (? w-offset))) + (MACHINE-CONSTANT (? f-offset))) + (REGISTER (? source))) + (float-store/offset base (+ (* 4 w-offset) (* 8 f-offset)) source)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLOAT-OFFSET (REGISTER (? base)) (REGISTER (? index)))) + (let* ((base (standard-source! base)) + (index (standard-source! index)) + (target (flonum-target! target))) + (LAP (FLDDX (S) (INDEX ,index 0 ,base) ,target)))) + +(define-rule statement + (ASSIGN (FLOAT-OFFSET (REGISTER (? base)) (REGISTER (? index))) + (REGISTER (? source))) + (let ((source (flonum-source! source)) + (base (standard-source! base)) + (index (standard-source! index))) + (LAP (FSTDX (S) ,source (INDEX ,index 0 ,base))))) + +(define (float-load/offset target base offset) + (let ((base (standard-source! base))) + (%float-load/offset (flonum-target! target) + base + offset))) + +(define (float-store/offset base offset source) + (%float-store/offset (standard-source! base) + offset + (flonum-source! source))) + +(define (%float-load/offset target base offset) + (if (<= -16 offset 15) + (LAP (FLDDS () (OFFSET ,offset 0 ,base) ,target)) + (let ((base* (standard-temporary!))) + (LAP (LDO () (OFFSET ,offset 0 ,base) ,base*) + (FLDDS () (OFFSET 0 0 ,base*) ,target))))) + +(define (%float-store/offset base offset source) + (if (<= -16 offset 15) + (LAP (FSTDS () ,source (OFFSET ,offset 0 ,base))) + (let ((base* (standard-temporary!))) + (LAP (LDO () (OFFSET ,offset 0 ,base) ,base*) + (FSTDS () ,source (OFFSET 0 0 ,base*)))))) + +;;;; Optimized floating-point references + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLOAT-OFFSET (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base))) + (MACHINE-CONSTANT (? w-offset))) + (MACHINE-CONSTANT (? f-offset)))) + (let ((b-offset (+ (* 4 w-offset) (* 8 f-offset)))) + (reuse-pseudo-register-alias! + base 'GENERAL + (lambda (base) + (let ((target (flonum-target! target))) + (LAP ,@(object->address base) + ,@(%float-load/offset target base b-offset)))) + (lambda () + (let* ((base (standard-source! base)) + (base* (standard-temporary!)) + (target (flonum-target! target))) + (LAP (LDO () (OFFSET ,b-offset 0 ,base) ,base*) + ,@(object->address base*) + (FLDDS () (OFFSET 0 0 ,base*) ,target))))))) + +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (FLOAT-OFFSET (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base))) +; (MACHINE-CONSTANT (? offset))) +; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index))))) +; (let ((base (standard-source! base)) +; (index (standard-source! index)) +; (temp (standard-temporary!))) +; (let ((target (flonum-target! target))) +; (LAP (SH3ADDL () ,index ,base ,temp) +; ,@(object->address temp) +; ,@(%float-load/offset target temp (* 4 offset)))))) + +;(define-rule statement +; (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base))) +; (MACHINE-CONSTANT (? offset))) +; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index)))) +; (REGISTER (? source))) +; (let ((source (flonum-source! source)) +; (base (standard-source! base)) +; (index (standard-source! index)) +; (temp (standard-temporary!))) +; (LAP (SH3ADDL () ,index ,base ,temp) +; ,@(object->address temp) +; ,@(%float-store/offset temp (* 4 offset) source)))) + +;;;; Intermediate rules needed to generate the above. + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base))) + (MACHINE-CONSTANT (? offset)))) + (let* ((base (standard-source! base)) + (target (standard-target! target))) + (LAP (LDO () (OFFSET ,(* 4 offset) 0 ,base) ,target) + ,@(object->address target)))) + +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base)) +; (MACHINE-CONSTANT (? offset))) +; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index))))) +; (let ((base (standard-source! base)) +; (index (standard-source! index)) +; (temp (standard-temporary!))) +; (let ((target (flonum-target! target))) +; (LAP ;; ,@(object->datum index temp) +; ;; (SH3ADDL () ,temp ,base ,temp) +; (SH3ADDL () ,index ,base ,temp) +; ,@(%float-load/offset target temp (* 4 offset)))))) + + +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (FLOAT-OFFSET (REGISTER (? base)) +; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index))))) +; (let ((base (standard-source! base)) +; (index (standard-source! index)) +; (temp (standard-temporary!))) +; (let ((target (flonum-target! target))) +; (LAP ,@(object->datum index temp) +; (FLDDX (S) (INDEX ,temp 0 ,base) ,target))))) + +;(define-rule statement +; (ASSIGN (REGISTER (? target)) +; (FLOAT-OFFSET (REGISTER (? base)) +; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index))))) +; (let ((base (standard-source! base)) +; (index (standard-source! index))) +; (let ((target (flonum-target! target))) +; (LAP (FLDDX (S) (INDEX ,index 0 ,base) ,target))))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base)) + (MACHINE-CONSTANT (? offset))) + (REGISTER (? index)))) + (let ((base (standard-source! base)) + (index (standard-source! index)) + (temp (standard-temporary!))) + (let ((target (flonum-target! target))) + (LAP (SH3ADDL () ,index ,base ,temp) + ,@(%float-load/offset target temp (* 4 offset)))))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLOAT-OFFSET (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base))) + (MACHINE-CONSTANT (? offset))) + (REGISTER (? index)))) + (let ((base (standard-source! base)) + (index (standard-source! index)) + (temp (standard-temporary!))) + (let ((target (flonum-target! target))) + (LAP (SH3ADDL () ,index ,base ,temp) + ,@(object->address temp) + ,@(%float-load/offset target temp (* 4 offset)))))) + +;(define-rule statement +; (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base)) +; (MACHINE-CONSTANT (? offset))) +; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index)))) +; (REGISTER (? source))) +; (let ((base (standard-source! base)) +; (index (standard-source! index)) +; (temp (standard-temporary!)) +; (source (flonum-source! source))) +; (LAP ;; ,@(object->datum index temp) +; ;; (SH3ADDL () ,temp ,base ,temp) +; (SH3ADDL () ,index ,base ,temp) +; ,@(%float-store/offset temp (* 4 offset) source)))) + +;(define-rule statement +; (ASSIGN (FLOAT-OFFSET (REGISTER (? base)) +; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index)))) +; (REGISTER (? source))) +; (let ((base (standard-source! base)) +; (index (standard-source! index)) +; (temp (standard-temporary!)) +; (source (flonum-source! source))) +; (LAP ,@(object->datum index temp) +; (FSTDX (S) ,source (INDEX ,temp 0 ,base))))) + +;(define-rule statement +; (ASSIGN (FLOAT-OFFSET (REGISTER (? base)) +; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index)))) +; (REGISTER (? source))) +; (let ((base (standard-source! base)) +; (index (standard-source! index)) +; (source (flonum-source! source))) +; (LAP (FSTDX (S) ,source (INDEX ,index 0 ,base))))) + +(define-rule statement + (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base)) + (MACHINE-CONSTANT (? offset))) + (REGISTER (? index))) + (REGISTER (? source))) + (let ((base (standard-source! base)) + (index (standard-source! index)) + (temp (standard-temporary!)) + (source (flonum-source! source))) + (LAP (SH3ADDL () ,index ,base ,temp) + ,@(%float-store/offset temp (* 4 offset) source)))) + +(define-rule statement + (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base))) + (MACHINE-CONSTANT (? offset))) + (REGISTER (? index))) + (REGISTER (? source))) + (let ((base (standard-source! base)) + (index (standard-source! index)) + (temp (standard-temporary!)) + (source (flonum-source! source))) + (LAP (SH3ADDL () ,index ,base ,temp) + ,@(object->address temp) + ,@(%float-store/offset temp (* 4 offset) source)))) + +;;;; Flonum Arithmetic + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?))) + (QUALIFIER (arithmetic-method? operation flonum-methods/1-arg)) + overflow? ;ignore + (let ((source (flonum-source! source))) + ((flonum-1-arg/operator operation) (flonum-target! target) source))) + +(define (flonum-1-arg/operator operation) + (lookup-arithmetic-method operation flonum-methods/1-arg)) + +(define flonum-methods/1-arg + (list 'FLONUM-METHODS/1-ARG)) + +;;; Notice the weird ,', syntax here. +;;; If LAP changes, this may also have to change. + +(let-syntax + ((define-flonum-operation + (macro (primitive-name opcode) + `(define-arithmetic-method ',primitive-name flonum-methods/1-arg + (lambda (target source) + (LAP (,opcode (DBL) ,',source ,',target))))))) + (define-flonum-operation FLONUM-ABS FABS) + (define-flonum-operation FLONUM-SQRT FSQRT) + (define-flonum-operation FLONUM-ROUND FRND)) + +(define-arithmetic-method 'FLONUM-NEGATE flonum-methods/1-arg + (lambda (target source) + ;; The status register (fr0) reads as 0 for non-store instructions. + (LAP (FSUB (DBL) 0 ,source ,target)))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?))) + (QUALIFIER (arithmetic-method? operation flonum-methods/1-arg/special)) + overflow? ;ignore + (flonum/1-arg/special + (lookup-arithmetic-method operation flonum-methods/1-arg/special) + target source)) + +(define flonum-methods/1-arg/special + (list 'FLONUM-METHODS/1-ARG/SPECIAL)) + +(let-syntax ((define-out-of-line + (macro (name) + `(define-arithmetic-method ',name flonum-methods/1-arg/special + ,(symbol-append 'HOOK:COMPILER- name))))) + (define-out-of-line FLONUM-SIN) + (define-out-of-line FLONUM-COS) + (define-out-of-line FLONUM-TAN) + (define-out-of-line FLONUM-ASIN) + (define-out-of-line FLONUM-ACOS) + (define-out-of-line FLONUM-ATAN) + (define-out-of-line FLONUM-EXP) + (define-out-of-line FLONUM-LOG) + (define-out-of-line FLONUM-TRUNCATE) + (define-out-of-line FLONUM-CEILING) + (define-out-of-line FLONUM-FLOOR)) + +(define caller-saves-registers + (list + ;; g1 g19 g20 g21 g22 ; Not available for allocation + g23 g24 g25 g26 g28 g29 g31 + ;; fp0 fp1 fp2 fp3 ; Not real registers + fp4 fp5 fp6 fp7 fp8 fp9 fp10 fp11)) + +(define registers-to-preserve-around-special-calls + (append (list g14 g15 g16 g17) + caller-saves-registers)) + +(define (flonum/1-arg/special hook target source) + (let ((load-arg (->machine-register source fp5))) + (delete-register! target) + (delete-dead-registers!) + (let ((clear-regs + (apply clean-registers! + registers-to-preserve-around-special-calls))) + (add-pseudo-register-alias! target fp4) + (LAP ,@load-arg + ,@clear-regs + ,@(invoke-hook hook))))) + +;; Missing operations + +#| +;; Return integers +(define-out-of-line FLONUM-ROUND->EXACT) +(define-out-of-line FLONUM-TRUNCATE->EXACT) +(define-out-of-line FLONUM-FLOOR->EXACT) +(define-out-of-line FLONUM-CEILING->EXACT) + +;; Returns a pair +(define-out-of-line FLONUM-NORMALIZE) + +;; Two arguments +(define-out-of-line FLONUM-DENORMALIZE) ; flo*int +|# + +;;;; Two arg operations + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLONUM-2-ARGS FLONUM-SUBTRACT + (OBJECT->FLOAT (CONSTANT 0.)) + (REGISTER (? source)) + (? overflow?))) + overflow? ; ignore + (let ((source (flonum-source! source))) + (LAP (FSUB (DBL) 0 ,source ,(flonum-target! target))))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLONUM-2-ARGS (? operation) + (REGISTER (? source1)) + (REGISTER (? source2)) + (? overflow?))) + (QUALIFIER (arithmetic-method? operation flonum-methods/2-args)) + overflow? ;ignore + (let ((source1 (flonum-source! source1)) + (source2 (flonum-source! source2))) + ((flonum-2-args/operator operation) (flonum-target! target) + source1 + source2))) + +(define (flonum-2-args/operator operation) + (lookup-arithmetic-method operation flonum-methods/2-args)) + +(define flonum-methods/2-args + (list 'FLONUM-METHODS/2-ARGS)) + +(let-syntax + ((define-flonum-operation + (macro (primitive-name opcode) + `(define-arithmetic-method ',primitive-name flonum-methods/2-args + (lambda (target source1 source2) + (LAP (,opcode (DBL) ,',source1 ,',source2 ,',target))))))) + (define-flonum-operation flonum-add fadd) + (define-flonum-operation flonum-subtract fsub) + (define-flonum-operation flonum-multiply fmpy) + (define-flonum-operation flonum-divide fdiv) + (define-flonum-operation flonum-remainder frem)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLONUM-2-ARGS FLONUM-ATAN2 + (REGISTER (? source1)) + (REGISTER (? source2)) + (? overflow?))) + overflow? ;ignore + (let* ((load-arg-1 (->machine-register source1 fp5)) + (load-arg-2 (->machine-register source2 fp7))) + (delete-register! target) + (delete-dead-registers!) + (let ((clear-regs + (apply clean-registers! + registers-to-preserve-around-special-calls))) + (add-pseudo-register-alias! target fp4) + (LAP ,@load-arg-1 + ,@load-arg-2 + ,@clear-regs + ,@(invoke-hook hook:compiler-flonum-atan2))))) + +;;;; Flonum Predicates + +(define-rule predicate + (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? source))) + #| + ;; No immediate zeros, easy to generate by subtracting from itself + (let ((temp (flonum-temporary!))) + (LAP (FSUB (DBL) ,temp ,temp ,temp) + ,@(flonum-compare + (case predicate + ((FLONUM-ZERO?) '=) + ((FLONUM-NEGATIVE?) '<) + ((FLONUM-POSITIVE?) '>) + (else (error "unknown flonum predicate" predicate))) + (flonum-source! source) + temp))) + |# + ;; The status register (fr0) reads as 0 for non-store instructions. + (flonum-compare (case predicate + ((FLONUM-ZERO?) '=) + ((FLONUM-NEGATIVE?) '<) + ((FLONUM-POSITIVE?) '>) + (else (error "unknown flonum predicate" predicate))) + (flonum-source! source) + 0)) + +(define-rule predicate + (FLONUM-PRED-2-ARGS (? predicate) + (REGISTER (? source1)) + (REGISTER (? source2))) + (flonum-compare (case predicate + ((FLONUM-EQUAL?) '=) + ((FLONUM-LESS?) '<) + ((FLONUM-GREATER?) '>) + (else (error "unknown flonum predicate" predicate))) + (flonum-source! source1) + (flonum-source! source2))) + +(define (flonum-compare cc r1 r2) + (set-current-branches! + (lambda (true-label) + (LAP (FCMP (,(invert-float-condition cc) DBL) ,r1 ,r2) + (FTEST ()) + (B (N) (@PCR ,true-label)))) + (lambda (false-label) + (LAP (FCMP (,cc DBL) ,r1 ,r2) + (FTEST ()) + (B (N) (@PCR ,false-label))))) + (LAP)) + +;; invert-float-condition makes sure that NaNs are taken care of +;; correctly. + +(define (invert-float-condition cc) + (let ((place (assq cc float-inversion-table))) + (if (not place) + (error "invert-float-condition: Unknown condition" + cc) + (cadr place)))) + +(define float-inversion-table + ;; There are many others, but only these are used here. + '((> !>) + (< !<) + (= !=))) \ No newline at end of file diff --git a/v8/src/compiler/machines/spectrum/rulrew.scm b/v8/src/compiler/machines/spectrum/rulrew.scm new file mode 100644 index 000000000..d87fe90f4 --- /dev/null +++ b/v8/src/compiler/machines/spectrum/rulrew.scm @@ -0,0 +1,353 @@ +#| -*-Scheme-*- + +$Id: rulrew.scm,v 1.1 1994/11/19 02:08:04 adams Exp $ + +Copyright (c) 1990-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Rewrite Rules +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +;;;; Synthesized Data + +(define-rule rewriting + (CONS-NON-POINTER (? type) (? datum)) + ;; Since we use DEP instructions to insert type codes, there's no + ;; difference between the way that pointers and non-pointers are + ;; constructed. + (rtl:make-cons-pointer type datum)) + + +(define-rule add-pre-cse-rewriting-rule! + (CONS-POINTER (REGISTER (? type register-known-value)) + (? datum)) + (QUALIFIER + (and (rtl:machine-constant? type) + (let ((value (rtl:machine-constant-value type)) + (class (rtl:expression-value-class datum))) + ;; Typecode values that we can use for DEPI instruction, even + ;; though the type cant be specified in 6 bits (01xxxx/10xxxx) + ;; If the quad mask bits are 0xxxx0 then we can do (0xxxxx/xxxxx0) + ;; In a single DEPI. + ;; Forcing them to be constants prevents any cse on the values. + (and (value-class=address? class) + (fix:fixnum? value) + (or (even? (fix:or quad-mask-value value)) + (fix:<= (fix:or quad-mask-value value) #b11111)))))) + (rtl:make-cons-pointer type datum)) + + +;(define-rule add-pre-cse-rewriting-rule! +; (CONS-POINTER (REGISTER (? type register-known-value)) +; (? datum)) +; (QUALIFIER +; (and (rtl:machine-constant? type) +; (let ((value (rtl:machine-constant-value type)) +; (class (rtl:expression-value-class datum))) +; ;; Elide a (CONS-POINTER address-bits address-register) +; (and (eq? class value-class=address) +; (fix:fixnum? value) +; (fix:= value quad-mask-value value))))) +; datum) + +(define-rule add-pre-cse-rewriting-rule! + (CONS-POINTER (REGISTER (? type register-known-value)) + (? datum)) + (QUALIFIER + (and (rtl:machine-constant? type) + (let ((value (rtl:machine-constant-value type))) + ;; Typecode values that we can use for DEPI instructions. + ;; Forcing them to be constants prevents any cse on the values. + (or (fits-in-5-bits-signed? value) + (fits-in-5-bits-signed? (- value (1+ max-type-code))) + (= value quad-mask-value) ; for which we use r5 + )))) + (rtl:make-cons-pointer type datum)) + +(define-rule add-pre-cse-rewriting-rule! + (CONS-NON-POINTER (REGISTER (? type register-known-value)) + (? datum)) + (QUALIFIER + (and (rtl:machine-constant? type) + (let ((value (rtl:machine-constant-value type))) + ;; Typecode values that we can use for DEPI instructions. + ;; Forcing them to be constants prevents any cse on the values. + (or (fits-in-5-bits-signed? value) + (fits-in-5-bits-signed? (- value (1+ max-type-code))) + (= value quad-mask-value) ; for which we use + )))) + (rtl:make-cons-pointer type datum)) + + +(define-rule rewriting + (CONS-POINTER (REGISTER (? type register-known-value)) + (REGISTER (? datum register-known-value))) + (QUALIFIER (and (rtl:machine-constant? type) + (rtl:machine-constant? datum))) + (rtl:make-cons-pointer type datum)) + +(define-rule rewriting + (CONS-POINTER (REGISTER (? type register-known-value)) (? datum)) + (QUALIFIER + (and (rtl:object->type? type) + (rtl:constant? (rtl:object->type-expression type)))) + (rtl:make-cons-pointer + (rtl:make-machine-constant + (target-object-type + (rtl:constant-value (rtl:object->type-expression datum)))) + datum)) + +(define-rule rewriting + (CONS-POINTER (? type) (REGISTER (? datum register-known-value))) + (QUALIFIER (and (rtl:object->datum? datum) + (not (rtl:constant-non-pointer? + (rtl:object->datum-expression datum))))) + ;; Since we use DEP/DEPI, there is no need to clear the old bits + (rtl:make-cons-pointer type (rtl:object->datum-expression datum))) + +(define-rule rewriting + (OBJECT->TYPE (REGISTER (? source register-known-value))) + (QUALIFIER (rtl:constant? source)) + (rtl:make-machine-constant (target-object-type (rtl:constant-value source)))) + +(define-rule rewriting + (OBJECT->DATUM (REGISTER (? source register-known-value))) + (QUALIFIER (rtl:constant-non-pointer? source)) + (rtl:make-machine-constant + (careful-object-datum (rtl:constant-value source)))) + +(define (rtl:constant-non-pointer? expression) + (and (rtl:constant? expression) + (non-pointer-object? (rtl:constant-value expression)))) + + +;;; These rules are losers because there's no abstract way to cons a +;;; statement or a predicate without also getting some CFG structure. + +(define-rule rewriting + ;; Use register 0, always 0. + (ASSIGN (? target) (REGISTER (? comparand register-known-value))) + (QUALIFIER (rtl:immediate-zero-constant? comparand)) + (list 'ASSIGN target (rtl:make-machine-constant 0))) + +(define-rule rewriting + ;; Compare to register 0, always 0. + (EQ-TEST (? source) (REGISTER (? comparand register-known-value))) + (QUALIFIER (rtl:immediate-zero-constant? comparand)) + (list 'EQ-TEST source (rtl:make-machine-constant 0))) + +(define-rule rewriting + ;; Compare to register 0, always 0. + (EQ-TEST (REGISTER (? comparand register-known-value)) (? source)) + (QUALIFIER (rtl:immediate-zero-constant? comparand)) + (list 'EQ-TEST source (rtl:make-machine-constant 0))) + +(define (rtl:immediate-zero-constant? expression) + (cond ((rtl:constant? expression) + (let ((value (rtl:constant-value expression))) + (and (non-pointer-object? value) + (zero? (target-object-type value)) + (zero? (careful-object-datum value))))) + ((rtl:cons-pointer? expression) + (and (let ((expression (rtl:cons-pointer-type expression))) + (and (rtl:machine-constant? expression) + (zero? (rtl:machine-constant-value expression)))) + (let ((expression (rtl:cons-pointer-datum expression))) + (and (rtl:machine-constant? expression) + (zero? (rtl:machine-constant-value expression)))))) + (else false))) + +;;;; Fixnums +;;; +;; Some constants should always be folded into the operation because either +;; they are encodable as an immediate value in the instruction at no cost +;; or they are open coded specially in a way that does not put the value in +;; a register. We detect these cases by inspecting the arithconst predicates +;; in fulfix.scm. +;; This is done pre-cse so that cse doesnt decide to hide the constant in a +;; register in expressions like (cons (fix:quotient x 8) (fix:remainder x 8))) + +(define-rule add-pre-cse-rewriting-rule! + (FIXNUM-2-ARGS (? operation) + (REGISTER (? operand-1 register-known-fixnum-constant)) + (? operand-2) + (? overflow?)) + (QUALIFIER + (and (rtl:register? operand-2) + (fixnum-2-args/operator/constant*register? + operation + (known-fixnum-constant/fixnum-value operand-1) + overflow?))) + (rtl:make-fixnum-2-args operation operand-1 operand-2 overflow?)) + +(define-rule add-pre-cse-rewriting-rule! + (FIXNUM-2-ARGS (? operation) + (? operand-1) + (REGISTER (? operand-2 register-known-fixnum-constant)) + (? overflow?)) + (QUALIFIER + (and (rtl:register? operand-1) + (fixnum-2-args/operator/register*constant? + operation + (known-fixnum-constant/fixnum-value operand-2) + overflow?))) + (rtl:make-fixnum-2-args operation operand-1 operand-2 overflow?)) + + +(define (register-known-fixnum-constant regnum) + ;; returns the rtl of a constant that is a fixnum, i.e (CONSTANT 1000) + ;; recognizes (CONSTANT x) + ;; (OBJECT->FIXNUM (CONSTANT x)) + ;; (OBJECT->FIXNUM (REGISTER y)) where y also satisfies this pred + (let ((expr (register-known-value regnum))) + (and expr + (cond ((and (rtl:constant? expr) + (fix:fixnum? (rtl:constant-value expr))) + expr) + ((and (rtl:object->fixnum? expr) + (rtl:constant? (rtl:object->fixnum-expression expr)) + (fix:fixnum? (rtl:constant-value + (rtl:object->fixnum-expression expr)))) + (rtl:object->fixnum-expression expr)) + ((and (rtl:object->fixnum? expr) + (rtl:register? (rtl:object->fixnum-expression expr))) + (register-known-fixnum-constant + (rtl:register-number (rtl:object->fixnum-expression expr)))) + (else #F))))) + +(define (known-fixnum-constant/fixnum-value constant) + (rtl:constant-value constant)) + +(define-rule add-pre-cse-rewriting-rule! + (PRED-1-ARG INDEX-FIXNUM? (? source)) + + ;; This is a predicate so we can't use rtl:make-type-test + + (list 'TYPE-TEST (rtl:make-object->type source) (ucode-type positive-fixnum))) + + +;;;; Closures and other optimizations. + +;; These rules are Spectrum specific + +(define-rule rewriting + (CONS-POINTER (REGISTER (? type register-known-value)) + (REGISTER (? datum register-known-value))) + (QUALIFIER (and (rtl:machine-constant? type) + (= (rtl:machine-constant-value type) + (ucode-type compiled-entry)) + (or (rtl:entry:continuation? datum) + (rtl:entry:procedure? datum) + (rtl:cons-closure? datum)))) + (rtl:make-cons-pointer type datum)) + + +(define-rule rewriting + (FLOAT-OFFSET (REGISTER (? base register-known-value)) + (MACHINE-CONSTANT 0)) + (QUALIFIER (rtl:simple-float-offset-address? base)) + (rtl:make-float-offset (rtl:float-offset-address-base base) + (rtl:float-offset-address-offset base))) + +;; This is here to avoid generating things like +;; +;; (float-offset (offset-address (object->address (constant #(foo bar baz gack))) +;; (machine-constant 1)) +;; (register 84)) +;; +;; since the offset-address subexpression is constant, and therefore +;; known! + +(define (rtl:simple-float-offset-address? expr) + (and (rtl:float-offset-address? expr) + (let ((offset (rtl:float-offset-address-offset expr))) + (or (rtl:machine-constant? offset) + (rtl:register? offset) + (and (rtl:object->datum? offset) + (rtl:register? (rtl:object->datum-expression offset))))) + (let ((base (rtl:float-offset-address-base expr))) + (or (rtl:register? base) + (and (rtl:offset-address? base) + (let ((base* (rtl:offset-address-base base)) + (offset* (rtl:offset-address-offset base))) + (and (rtl:machine-constant? offset*) + (or (rtl:register? base*) + (and (rtl:object->address? base*) + (rtl:register? + (rtl:object->address-expression + base*))))))))))) + + +;; +;; (CONS-NON-POINTER (MACHINE-CONSTANT 0) +;; (? thing-with-known-type-already=0)) => thing +;; + +(define-rule add-pre-cse-rewriting-rule! + (CONS-NON-POINTER (REGISTER (? type register-known-value)) + (? datum)) + (QUALIFIER + (and (rtl:machine-constant? type) + (= 0 (rtl:machine-constant-value type)) + (rtl:has-type-zero? datum))) + datum) + +(define (rtl:has-type-zero? expr) + (or (value-class=ascii? (rtl:expression-value-class expr)) + (value-class=datum? (rtl:expression-value-class expr)) + #F)) + + +;; Remove all object->fixnum and fixnum->object and object->unsigned-fixnum + +(define-rule add-pre-cse-rewriting-rule! + (OBJECT->FIXNUM (? frob)) + frob) + +(define-rule add-pre-cse-rewriting-rule! + (OBJECT->UNSIGNED-FIXNUM (? frob)) + frob) + +(define-rule add-pre-cse-rewriting-rule! + (FIXNUM->OBJECT (? frob)) + frob) + +(define-rule add-pre-cse-rewriting-rule! + (COERCE-VALUE-CLASS (? frob) (? class)) + class ; ignored + (error "Unknown expression for " frob) + frob) + +(define-rule add-pre-cse-rewriting-rule! + (COERCE-VALUE-CLASS (REGISTER (? frob register-known-expression)) (? class)) + class ; ignored + frob) diff --git a/v8/src/compiler/midend/alpha.scm b/v8/src/compiler/midend/alpha.scm new file mode 100644 index 000000000..144001c88 --- /dev/null +++ b/v8/src/compiler/midend/alpha.scm @@ -0,0 +1,178 @@ +;;; -*- Scheme -*- + +(declare (usual-integrations)) + +(define (alphaconv/top-level program) + (alphaconv/expr (alphaconv/state/make alphaconv/remember) + '() + program)) + +(define-macro (define-alphaconv keyword bindings . body) + (let ((proc-name (symbol-append 'ALPHACONV/ keyword))) + (call-with-values + (lambda () (%matchup (cddr bindings) '(handler state env) '(cdr form))) + (lambda (names code) + `(define ,proc-name + (let ((handler (lambda ,(cons* (car bindings) (cadr bindings) names) ,@body))) + (named-lambda (,proc-name state env form) + ,code))))))) + +(define-alphaconv LOOKUP (state env name) + env ; ignored + `(LOOKUP ,(alphaconv/env/lookup name env))) + +(define-alphaconv LAMBDA (state env lambda-list body) + (let* ((names (lambda-list->names lambda-list)) + (new-names (alphaconv/renamings env names)) + (env* (alphaconv/env/extend env names new-names))) + `(LAMBDA ,(alphaconv/rename-lambda-list lambda-list new-names) + ,(alphaconv/expr state env* body)))) + +(define (alphaconv/rename-lambda-list lambda-list new-names) + (let loop ((ll lambda-list) (nn new-names) (result '())) + (cond ((null? ll) (reverse! result)) + ((memq (car ll) '(#!AUX #!OPTIONAL #!REST)) + (loop (cdr ll) nn (cons (car ll) result))) + (else + (loop (cdr ll) (cdr nn) (cons (car nn) result)))))) + +(define-alphaconv CALL (state env rator cont #!rest rands) + `(CALL ,(alphaconv/expr state env rator) + ,(alphaconv/expr state env cont) + ,@(alphaconv/expr* state env rands))) + +(define-alphaconv LET (state env bindings body) + (alphaconv/let-like 'LET state env bindings body)) + +(define-alphaconv LETREC (state env bindings body) + (alphaconv/let-like 'LETREC state env bindings body)) + +(define (alphaconv/let-like keyword state env bindings body) + (let* ((names (lmap car bindings)) + (new-names (alphaconv/renamings env names)) + (inner-env (alphaconv/env/extend env names new-names)) + (expr-env (if (eq? keyword 'LETREC) inner-env env)) + (bindings* (map (lambda (new-name binding) + (list new-name + (alphaconv/expr state expr-env (second binding)))) + new-names + bindings))) + `(,keyword ,bindings* ,(alphaconv/expr state inner-env body)))) + +(define-alphaconv QUOTE (state env object) + env ; ignored + `(QUOTE ,object)) + +(define-alphaconv DECLARE (state env #!rest anything) + env ; ignored + `(DECLARE ,@anything)) + +(define-alphaconv BEGIN (state env #!rest actions) + `(BEGIN ,@(alphaconv/expr* state env actions))) + +(define-alphaconv IF (state env pred conseq alt) + `(IF ,(alphaconv/expr state env pred) + ,(alphaconv/expr state env conseq) + ,(alphaconv/expr state env alt))) + +(define-alphaconv SET! (state env name value) + `(SET! ,(alphaconv/env/lookup name env) ,(alphaconv/expr state env value))) + +(define-alphaconv UNASSIGNED? (state env name) + env ; ignored + `(UNASSIGNED? ,(alphaconv/env/lookup name env))) + +(define-alphaconv OR (state env pred alt) + `(OR ,(alphaconv/expr state env pred) + ,(alphaconv/expr state env alt))) + +(define-alphaconv DELAY (state env expr) + `(DELAY ,(alphaconv/expr state env expr))) + +(define (alphaconv/expr state env expr) + (if (not (pair? expr)) + (illegal expr)) + (let ((new-expr + (case (car expr) + ((QUOTE) + (alphaconv/quote state env expr)) + ((LOOKUP) + (alphaconv/lookup state env expr)) + ((LAMBDA) + (alphaconv/lambda state env expr)) + ((LET) + (alphaconv/let state env expr)) + ((DECLARE) + (alphaconv/declare state env expr)) + ((CALL) + (alphaconv/call state env expr)) + ((BEGIN) + (alphaconv/begin state env expr)) + ((IF) + (alphaconv/if state env expr)) + ((LETREC) + (alphaconv/letrec state env expr)) + ((SET!) + (alphaconv/set! state env expr)) + ((UNASSIGNED?) + (alphaconv/unassigned? state env expr)) + ((OR) + (alphaconv/or state env expr)) + ((DELAY) + (alphaconv/delay state env expr)) + ((ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT) + (no-longer-legal expr)) + (else + (illegal expr))))) + ((alphaconv/state/remember state) new-expr expr))) + +(define (alphaconv/expr* state env exprs) + (lmap (lambda (expr) + (alphaconv/expr state env expr)) + exprs)) + +(define-integrable (alphaconv/remember new old) + old ; ignored for now and forever + new) + +(define-structure + (alphaconv/state + (conc-name alphaconv/state/) + (constructor alphaconv/state/make)) + remember) + + + +(define-structure + (alphaconv/binding + (conc-name alphaconv/binding/) + (constructor alphaconv/binding/make (name renaming)) + (print-procedure + (standard-unparser-method 'ALPHACONV/BINDING + (lambda (binding port) + (write-char #\space port) + (write-string (symbol-name (alphaconv/binding/name binding)) port))))) + + (name false read-only true) + (renaming false read-only true)) + +(define alphaconv/env/lookup + (let ((finder (association-procedure eq? alphaconv/binding/name))) + (lambda (name env) + (cond ((finder name env) + => (lambda (binding) + (alphaconv/binding/renaming binding))) + (else + name))))) + +(define (alphaconv/env/extend env names new-names) + (map* env + alphaconv/binding/make + names + new-names)) + +(define (alphaconv/renamings env names) + env ; ignored + (map (lambda (name) + (variable/rename name)) + names)) \ No newline at end of file diff --git a/v8/src/compiler/midend/applicat.scm b/v8/src/compiler/midend/applicat.scm new file mode 100644 index 000000000..b4c98f5d8 --- /dev/null +++ b/v8/src/compiler/midend/applicat.scm @@ -0,0 +1,198 @@ +#| -*-Scheme-*- + +$Id: applicat.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Use special pseudo primitives to call funky stuff +;;; package: (compiler midend) + +(declare (usual-integrations)) + +(define (applicat/top-level program) + (applicat/expr '() program)) + +(define-macro (define-applicator keyword bindings . body) + (let ((proc-name (symbol-append 'APPLICAT/ keyword))) + (call-with-values + (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form))) + (lambda (names code) + `(define ,proc-name + (let ((handler (lambda ,(cons (car bindings) names) ,@body))) + (named-lambda (,proc-name env form) + (applicat/remember ,code + form)))))))) + +(define-applicator LOOKUP (env name) + env ; ignored + `(LOOKUP ,name)) + +(define-applicator LAMBDA (env lambda-list body) + `(LAMBDA ,lambda-list + ,(applicat/expr (append (lmap (lambda (name) + (list name false)) + (lambda-list->names lambda-list)) + env) + body))) + +(define-applicator QUOTE (env object) + env ; ignored + `(QUOTE ,object)) + +(define-applicator DECLARE (env #!rest anything) + env ; ignored + `(DECLARE ,@anything)) + +(define-applicator BEGIN (env #!rest actions) + `(BEGIN ,@(applicat/expr* env actions))) + +(define-applicator IF (env pred conseq alt) + `(IF ,(applicat/expr env pred) + ,(applicat/expr env conseq) + ,(applicat/expr env alt))) + +(define-applicator CALL (env rator cont #!rest rands) + (define (default) + `(CALL (QUOTE ,%internal-apply) + ,(applicat/expr env cont) + (QUOTE ,(length rands)) + ,(applicat/expr env rator) + ,@(applicat/expr* env rands))) + (cond ((QUOTE/? rator) + (cond ((and (known-operator? (cadr rator)) + (not (and (primitive-procedure? (cadr rator)) + (memq (primitive-procedure-name (cadr rator)) + compiler:primitives-with-no-open-coding)))) + `(CALL ,(applicat/expr env rator) + ,(applicat/expr env cont) + ,@(applicat/expr* env rands))) + ((primitive-procedure? (cadr rator)) + `(CALL (QUOTE ,%primitive-apply) + ,(applicat/expr env cont) + (QUOTE ,(length rands)) + ,(applicat/expr env rator) + ,@(applicat/expr* env rands))) + (else + (default)))) + ((LOOKUP/? rator) + (let ((place (assq (cadr rator) env))) + (if (or (not place) (not (cadr place))) + (default) + `(CALL ,(applicat/expr env rator) + ,(applicat/expr env cont) + ,@(applicat/expr* env rands))))) + ((LAMBDA/? rator) + (let* ((lambda-list (cadr rator)) + (rator* `(LAMBDA ,lambda-list + ,(applicat/expr + (append + (map (lambda (name rand) + (list name + (and (pair? rand) + (eq? (car rand) 'LAMBDA)))) + lambda-list + rands) + env) + (caddr rator))))) + `(CALL ,(applicat/remember rator* rator) + ,(applicat/expr env cont) + ,@(applicat/expr* env rands)))) + (else + (default)))) + +(define-applicator LET (env bindings body) + `(LET ,(lmap (lambda (binding) + (list (car binding) + (applicat/expr env (cadr binding)))) + bindings) + ,(applicat/expr + (append (lmap (lambda (binding) + (list (car binding) + (let ((value (cadr binding))) + (and (pair? value) + (eq? (car value) 'LAMBDA))))) + bindings) + env) + body))) + +(define-applicator LETREC (env bindings body) + (let ((env* + (append (lmap (lambda (binding) + (list (car binding) + (let ((value (cadr binding))) + (and (pair? value) + (eq? (car value) 'LAMBDA))))) + bindings) + env))) + `(LETREC ,(lmap (lambda (binding) + (list (car binding) + (applicat/expr env* (cadr binding)))) + bindings) + ,(applicat/expr env* body)))) + +(define (applicat/expr env expr) + (if (not (pair? expr)) + (illegal expr)) + (case (car expr) + ((QUOTE) + (applicat/quote env expr)) + ((LOOKUP) + (applicat/lookup env expr)) + ((LAMBDA) + (applicat/lambda env expr)) + ((LET) + (applicat/let env expr)) + ((DECLARE) + (applicat/declare env expr)) + ((CALL) + (applicat/call env expr)) + ((BEGIN) + (applicat/begin env expr)) + ((IF) + (applicat/if env expr)) + ((LETREC) + (applicat/letrec env expr)) + ((SET! UNASSIGNED? OR DELAY + ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT) + (no-longer-legal expr)) + (else + (illegal expr)))) + +(define (applicat/expr* env exprs) + (lmap (lambda (expr) + (applicat/expr env expr)) + exprs)) + +(define (applicat/remember new old) + (code-rewrite/remember new old)) + +(define (applicat/new-name prefix) + (new-variable prefix)) \ No newline at end of file diff --git a/v8/src/compiler/midend/assconv.scm b/v8/src/compiler/midend/assconv.scm new file mode 100644 index 000000000..d61dbd04d --- /dev/null +++ b/v8/src/compiler/midend/assconv.scm @@ -0,0 +1,407 @@ +#| -*-Scheme-*- + +$Id: assconv.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Assignment Converter +;;; package: (compiler midend) + +(declare (usual-integrations)) + +(define (assconv/top-level program) + (assconv/expr '() program)) + +(define-macro (define-assignment-converter keyword bindings . body) + (let ((proc-name (symbol-append 'ASSCONV/ keyword))) + (call-with-values + (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form))) + (lambda (names code) + `(define ,proc-name + (let ((handler (lambda ,(cons (car bindings) names) ,@body))) + (named-lambda (,proc-name env form) + (assconv/remember ,code form)))))))) + +;;;; Variable manipulation forms + +(define-assignment-converter LAMBDA (env lambda-list body) + (call-with-values + (lambda () + (assconv/binding-body env + (lambda-list->names lambda-list) + body)) + (lambda (shadowed body*) + `(LAMBDA ,(if (null? shadowed) + lambda-list + (lmap (lambda (name) + (if (memq name shadowed) + (assconv/new-name 'IGNORED) + name)) + lambda-list)) + ,body*)))) + +(define-assignment-converter LET (env bindings body) + (call-with-values + (lambda () + (assconv/binding-body env (lmap car bindings) body)) + (lambda (shadowed body*) + `(LET ,(lmap (lambda (binding) + (list (car binding) + (assconv/expr env (cadr binding)))) + (if (null? shadowed) + bindings + (list-transform-negative bindings + (lambda (binding) + (memq (car binding) shadowed))))) + ,body*)))) + +(define-assignment-converter LOOKUP (env name) + (let ((binding (assconv/env-lookup env name))) + (if (not binding) + (free-var-error name) + (let ((result `(LOOKUP ,name))) + (set-assconv/binding/references! + binding + (cons result (assconv/binding/references binding))) + result)))) + +(define-assignment-converter SET! (env name value) + (let ((binding (assconv/env-lookup env name))) + (if (not binding) + (free-var-error name) + (let ((result `(SET! ,name ,(assconv/expr env value)))) + (set-assconv/binding/assignments! + binding + (cons result (assconv/binding/assignments binding))) + result)))) + +;;;; Trivial forms + +(define-assignment-converter QUOTE (env object) + env ; ignored + `(QUOTE ,object)) + +(define-assignment-converter DECLARE (env #!rest anything) + env ; ignored + `(DECLARE ,@anything)) + +(define-assignment-converter CALL (env rator cont #!rest rands) + `(CALL ,(assconv/expr env rator) + ,(assconv/expr env cont) + ,@(assconv/expr* env rands))) + +(define-assignment-converter BEGIN (env #!rest actions) + `(BEGIN ,@(assconv/expr* env actions))) + +(define-assignment-converter IF (env pred conseq alt) + `(IF ,(assconv/expr env pred) + ,(assconv/expr env conseq) + ,(assconv/expr env alt))) + +;;; Dispatcher + +(define (assconv/expr env expr) + (if (not (pair? expr)) + (illegal expr)) + (case (car expr) + ((QUOTE) + (assconv/quote env expr)) + ((LOOKUP) + (assconv/lookup env expr)) + ((LAMBDA) + (assconv/lambda env expr)) + ((LET) + (assconv/let env expr)) + ((DECLARE) + (assconv/declare env expr)) + ((CALL) + (assconv/call env expr)) + ((BEGIN) + (assconv/begin env expr)) + ((IF) + (assconv/if env expr)) + ((SET!) + (assconv/set! env expr)) + ((LETREC) + (not-yet-legal expr)) + ((UNASSIGNED? OR DELAY + ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT) + (no-longer-legal expr)) + (else + (illegal expr)))) + +(define (assconv/expr* env exprs) + (lmap (lambda (expr) + (assconv/expr env expr)) + exprs)) + +(define (assconv/remember new old) + (code-rewrite/remember new old) + new) + +(define (assconv/new-name prefix) + (new-variable prefix)) + +(define (assconv/new-cell-name prefix) + (new-variable (string-append (symbol-name prefix) "-cell"))) + +;;;; Utilities for variable manipulation forms + +(define-structure (assconv/binding + (conc-name assconv/binding/) + (constructor assconv/binding/make (name))) + (name false read-only true) + (cell-name false read-only false) + (references '() read-only false) + (assignments '() read-only false)) + +(define (assconv/binding-body env names body) + ;; (values shadowed-names body*) + (let* ((frame (lmap assconv/binding/make names)) + (env* (cons frame env)) + (body* (assconv/expr env* body)) + (assigned + (list-transform-positive frame + (lambda (binding) + (not (null? (assconv/binding/assignments binding)))))) + (ssa-candidates + (list-transform-positive assigned + (lambda (binding) + (let ((assignments (assconv/binding/assignments binding))) + (and (null? (cdr assignments)) + (assconv/single-assignment/trivial? + (car assignments)))))))) + (if (null? ssa-candidates) + (assconv/bind-cells '() assigned body*) + (call-with-values + (lambda () + (assconv/single-analyze ssa-candidates body*)) + (lambda (let-like letrec-like) + (assconv/bind-cells + (lmap assconv/binding/name (append let-like letrec-like)) + (list-transform-negative assigned + (lambda (binding) + (or (memq binding let-like) + (memq binding letrec-like)))) + (assconv/letify 'LET + let-like + (assconv/letify 'LETREC + letrec-like + body*)))))))) + +(define (assconv/first-assignment body) + (let loop ((actions (list body))) + (and (not (null? actions)) + (pair? (car actions)) + (case (car (car actions)) + ((BEGIN) + (loop (append (cdr (car actions)) (cdr actions)))) + ((DECLARE) + (loop (cdr actions))) + ((SET!) + (and (not (null? (cdr actions))) + (car actions))) + (else + false))))) + +(define (assconv/bind-cells shadowed-names bindings body) + ;; (values shadowed-names body*) + ;; Last chance to undo an assignment + (define (finish shadowed-names bindings body) + (if (null? bindings) + (values shadowed-names body) + (begin + (for-each assconv/cellify! bindings) + (values + shadowed-names + `(LET ,(lmap (lambda (binding) + (let ((name (assconv/binding/name binding))) + `(,(assconv/binding/cell-name binding) + (CALL (QUOTE ,%make-cell) + (QUOTE #F) + (LOOKUP ,name) + (QUOTE ,name))))) + bindings) + ,body))))) + + (define (default) + (finish shadowed-names bindings body)) + + (cond ((null? bindings) + (default)) + ((assconv/first-assignment body) + => (lambda (ass) + (let* ((name (cadr ass)) + (binding + (list-search-positive bindings + (lambda (binding) + (eq? (assconv/binding/name binding) + name)))) + (value (caddr ass))) + (if (or (not binding) + (not (null? (cdr (assconv/binding/assignments + binding)))) + (memq name (form/free-vars value))) ; JSM + (default) + (begin + (form/rewrite! ass `(QUOTE ,%unspecific)) + (finish (cons name shadowed-names) + (delq binding bindings) + (bind name value body))))))) + (else (default)))) + +(define (assconv/letify keyword bindings body) + `(,keyword + ,(lmap (lambda (binding) + (let* ((ass (car (assconv/binding/assignments binding))) + (value (caddr ass))) + (form/rewrite! ass `(QUOTE ,%unassigned)) + `(,(assconv/binding/name binding) ,value))) + bindings) + ,body)) + +(define (assconv/cell-reference binding) + `(CALL (QUOTE ,%cell-ref) + (QUOTE #F) + (LOOKUP ,(assconv/binding/cell-name binding)) + (QUOTE ,(assconv/binding/name binding)))) + +(define (assconv/cell-assignment binding value) + (let ((cell-name (assconv/binding/cell-name binding)) + (value-name (assconv/binding/name binding))) + #| + ;; This returns the new value + (bind value-name value + `(BEGIN + (CALL (QUOTE ,%cell-set!) + (QUOTE #F) + (LOOKUP ,cell-name) + (LOOKUP ,value-name) + (QUOTE ,value-name)) + (LOOKUP ,value-name))) + |# + ;; This returns the old value + (bind value-name + `(CALL (QUOTE ,%cell-ref) + (QUOTE #F) + (LOOKUP ,cell-name) + (QUOTE ,value-name)) + `(BEGIN + (CALL (QUOTE ,%cell-set!) + (QUOTE #F) + (LOOKUP ,cell-name) + ,value + (QUOTE ,value-name)) + (LOOKUP ,value-name))))) + +(define (assconv/cellify! binding) + (let ((cell-name (assconv/new-cell-name (assconv/binding/name binding)))) + (set-assconv/binding/cell-name! binding cell-name) + (for-each (lambda (ref) + (form/rewrite! + ref + (assconv/cell-reference binding))) + (assconv/binding/references binding)) + (for-each (lambda (ass) + (form/rewrite! + ass + (assconv/cell-assignment binding (caddr ass)))) + (assconv/binding/assignments binding)))) + +(define (assconv/env-lookup env name) + (let spine-loop ((env env)) + (and (not (null? env)) + (let rib-loop ((rib (car env))) + (cond ((null? rib) + (spine-loop (cdr env))) + ((eq? name (assconv/binding/name (car rib))) + (car rib)) + (else + (rib-loop (cdr rib)))))))) + +(define (assconv/single-assignment/trivial? assignment-form) + (let ((name (second assignment-form)) + (value (third assignment-form))) + (and (pair? value) + (or (eq? (car value) 'QUOTE) + (and (eq? (car value) 'LAMBDA) + #| (not (memq name (form/free-vars value))) |# + ))))) + +(define (assconv/single-analyze ssa-candidates body) + ;; (values let-like letrec-like) + ;; This only recognizes very simple patterns. + ;; It can be improved in the future. + (if (not (pair? body)) + (values '() '()) + (let ((single-assignments + (lmap (lambda (binding) + (cons (car (assconv/binding/assignments binding)) + binding)) + ssa-candidates)) + (finish + (lambda (bindings) + (values + (reverse + (list-transform-positive bindings + (lambda (binding) + (eq? (car (caddr (car (assconv/binding/assignments + binding)))) + 'QUOTE)))) + (reverse + (list-transform-positive bindings + (lambda (binding) + (eq? (car (caddr (car (assconv/binding/assignments + binding)))) + 'LAMBDA)))))))) + + (let loop ((bindings '()) + (actions (if (eq? (car body) 'BEGIN) + (cdr body) + (list body)))) + (cond ((null? actions) + (finish bindings)) + ((assq (car actions) single-assignments) + => (lambda (single-assignment) + (loop (cons (cdr single-assignment) bindings) + (cdr actions)))) + ((not (pair? (car actions))) + (finish bindings)) + (else + (case (caar actions) + ((DECLARE) + (loop bindings (cdr actions))) + ((SET!) + (if (assconv/single-assignment/trivial? (car actions)) + (loop bindings (cdr actions)) + (finish bindings))) + (else + (finish bindings))))))))) \ No newline at end of file diff --git a/v8/src/compiler/midend/cleanup.scm b/v8/src/compiler/midend/cleanup.scm new file mode 100644 index 000000000..e3cafbfb1 --- /dev/null +++ b/v8/src/compiler/midend/cleanup.scm @@ -0,0 +1,472 @@ +#| -*-Scheme-*- + +$Id: cleanup.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Rename to avoid conflict, substitute parameters, etc. +;;; package: (compiler midend) + +(declare (usual-integrations)) + +(define (cleanup/top-level program) + (cleanup/expr '() program)) + +(define-macro (define-cleanup-handler keyword bindings . body) + (let ((proc-name (symbol-append 'CLEANUP/ keyword))) + (call-with-values + (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form))) + (lambda (names code) + `(DEFINE ,proc-name + (LET ((HANDLER (LAMBDA ,(cons (car bindings) names) ,@body))) + (NAMED-LAMBDA (,proc-name ENV FORM) + (CLEANUP/REMEMBER ,code FORM)))))))) + +(define-cleanup-handler LOOKUP (env name) + (let ((place (assq name env))) + (if (not place) + (free-var-error name) + (form/copy (cadr place))))) + +(define-cleanup-handler LAMBDA (env lambda-list body) + (let ((renames (cleanup/renamings env (lambda-list->names lambda-list)))) + `(LAMBDA ,(lmap (lambda (token) + (cleanup/rename renames token)) + lambda-list) + ,(cleanup/expr (append renames env) body)))) + +(define-cleanup-handler LETREC (env bindings body) + (do-letrec-cleanup env bindings body)) + +(define (do-letrec-cleanup env bindings body) + (let* ((renames (cleanup/renamings env (lmap car bindings))) + (env* (append renames env)) + (body* (cleanup/expr env* body))) + (if (null? bindings) + body* + `(LETREC ,(lmap (lambda (binding) + (list (cleanup/rename renames (car binding)) + (cleanup/expr env* (cadr binding)))) + bindings) + ,body*)))) + +(define-cleanup-handler QUOTE (env object) + env ; ignored + `(QUOTE ,object)) + +(define-cleanup-handler DECLARE (env #!rest anything) + env ; ignored + `(DECLARE ,@anything)) + +(define-cleanup-handler IF (env pred conseq alt) + (let* ((pred* (cleanup/expr env pred)) + (default (lambda () + `(IF ,pred* + ,(cleanup/expr env conseq) + ,(cleanup/expr env alt))))) + (cond ((QUOTE/? pred*) + (case (boolean/discriminate (quote/text pred*)) + ((FALSE) + (cleanup/expr env alt)) + ((TRUE) + (cleanup/expr env conseq)) + (else + (default)))) + ((CALL/? pred*) + ;; (if (not p) c a) => (if p a c) + (let ((pred-rator (call/operator pred*))) + (if (and (QUOTE/? pred-rator) + (eq? (quote/text pred-rator) not) + (equal? (call/continuation pred*) `(QUOTE #F))) + `(IF ,(first (call/operands pred*)) + ,(cleanup/expr env alt) + ,(cleanup/expr env conseq)) + (default)))) + (else + (default))))) + +(define-cleanup-handler BEGIN (env #!rest actions) + (beginnify (cleanup/expr* env actions))) + +(define-cleanup-handler LET (env bindings body) + (cleanup/let* cleanup/letify env bindings body)) + +(define-cleanup-handler CALL (env rator cont #!rest rands) + (define (default) + `(CALL ,(cleanup/expr env rator) + ,(cleanup/expr env cont) + ,@(cleanup/expr* env rands))) + (cond ((LAMBDA/? rator) + (let ((lambda-list (lambda/formals rator)) + (lambda-body (lambda/body rator))) + (define (generate env let-names let-values) + (cleanup/let* + (lambda (bindings* body*) + (cleanup/pseudo-letify rator bindings* body*)) + env + (cleanup/bindify let-names let-values) + lambda-body)) + #|(define (build-call-lambda/try1 new-cont-var body closure) + `(CALL (LAMBDA (,new-cont-var) ,body) ,closure)) + |# + (define (build-call-lambda/try2 new-cont-var body closure) + ;; We can further reduce one special case: when the body is an + ;; invoke-continuation and the stack closure is a real + ;; continuation (not just a push) + (if (and (CALL/%invoke-continuation? body) + (LOOKUP/? (CALL/%invoke-continuation/cont body)) + (eq? new-cont-var + (LOOKUP/name (CALL/%invoke-continuation/cont body))) + (CALL/%make-stack-closure? closure) + (LAMBDA/? + (CALL/%make-stack-closure/lambda-expression closure))) + `(CALL (QUOTE ,%invoke-continuation) + ,closure + ,@(CALL/%invoke-continuation/values body)) + `(CALL (LAMBDA (,new-cont-var) ,body) ,closure))) + (if (call/%make-stack-closure? cont) + ;; Cannot substitute a make-stack-closure because both pushing + ;; and poping have to be kept in the right order. + (let* ((old-cont-var (car lambda-list)) + (new-cont-var (variable/rename old-cont-var)) + (new-env `((,old-cont-var (LOOKUP ,new-cont-var)) + ,@env))) + (build-call-lambda/try2 + new-cont-var + (generate new-env (cdr lambda-list) rands) + (cleanup/expr env cont))) + (generate env lambda-list (cons cont rands))))) + ((not *flush-closure-calls?*) + (default)) + (else + (let ((call* (default))) + (cond ((form/match cleanup/call-closure-pattern call*) + => (lambda (result) + (cleanup/call/maybe-flush-closure call* + env + result))) + ((form/match cleanup/call-trivial-pattern call*) + => (lambda (result) + (let ((lam-expr + (cadr (assq cleanup/?lam-expr result))) + (rands + (cadr (assq cleanup/?rands result))) + (cont + (cadr (assq cleanup/?cont result)))) + (cleanup/expr env + `(CALL ,lam-expr ,cont ,@rands))))) + (else + call*)))))) + +(define (cleanup/call/maybe-flush-closure call* env match-result) + (let ((lambda-expr (cadr (assq cleanup/?lam-expr match-result))) + (cont (cadr (assq cleanup/?cont match-result))) + (closure-elts (cadr (assq cleanup/?closure-elts match-result))) + (closure-vector (cadr (assq cleanup/?closure-vector match-result))) + (rands (cadr (assq cleanup/?rands match-result)))) + (let* ((lambda-list (cadr lambda-expr)) + (lambda-body (caddr lambda-expr)) + (closure-name (cadr lambda-list))) + (call-with-values + (lambda () (cleanup/closure-refs lambda-body closure-name)) + (lambda (self-refs ordinary-refs) + (if (not (null? self-refs)) + call* + (let ((bindings (map list + (vector->list closure-vector) + closure-elts))) + (for-each (lambda (ref) + (let ((name (cadr (sixth ref)))) + (form/rewrite! ref `(LOOKUP ,name)))) + ordinary-refs) + (let ((cont-name (car lambda-list))) + (cleanup/expr + env + (bind* (cons cont-name (lmap car bindings)) + (cons cont (lmap cadr bindings)) + `(CALL (LAMBDA ,(cons (car lambda-list) + (cddr lambda-list)) + ,lambda-body) + ,(if (equal? cont `(QUOTE #F)) + `(QUOTE #F) + `(LOOKUP ,cont-name)) + ,@rands))))))))))) + +(define cleanup/?closure-elts (->pattern-variable 'CLOSURE-ELTS)) +(define cleanup/?closure-vector (->pattern-variable 'CLOSURE-VECTOR)) +(define cleanup/?cont (->pattern-variable 'CONT)) +(define cleanup/?nrands (->pattern-variable 'NRANDS)) +(define cleanup/?rands (->pattern-variable 'RANDS)) +(define cleanup/?lam-expr (->pattern-variable 'LAM-EXPR)) +(define cleanup/?rest (->pattern-variable 'REST)) + +(define cleanup/call-closure-pattern + `(CALL (QUOTE ,%internal-apply) + ,cleanup/?cont + (QUOTE ,cleanup/?nrands) + (CALL (QUOTE ,%make-heap-closure) + (QUOTE #F) + ,cleanup/?lam-expr + (QUOTE ,cleanup/?closure-vector) + ,@cleanup/?closure-elts) + ,@cleanup/?rands)) + +(define cleanup/call-trivial-pattern + `(CALL (QUOTE ,%internal-apply) + ,cleanup/?cont + (QUOTE ,cleanup/?nrands) + (CALL (QUOTE ,%make-trivial-closure) + (QUOTE #F) + ,cleanup/?lam-expr) + ,@cleanup/?rands)) + +#| +(define cleanup/continuation-call-pattern + `(CALL (QUOTE ,%make-stack-closure) . ,cleanup/?rest)) +|# + +(define (cleanup/closure-refs form var-name) + ;; (values self-refs ordinary-refs) + ;; var-name is assumed to be unique, so there is + ;; no need to worry about shadowing. + (list-split + (let walk ((form form)) + (and (pair? form) + (case (car form) + ((QUOTE DECLARE) '()) + ((LOOKUP) + (if (eq? (lookup/name form) var-name) + (list form) + '())) + ((LAMBDA) + (walk (lambda/body form))) + ((LET LETREC) + (append-map* (walk (caddr form)) + (lambda (binding) + (walk (cadr binding))) + (cadr form))) + ((BEGIN IF) + (append-map walk (cdr form))) + ((CALL) + (if (call/%heap-closure-ref? form) + (if (eq? (lookup/name (call/%heap-closure-ref/closure form)) + var-name) + (list form) + '()) + (append-map walk (cdr form)))) + (else + (no-longer-legal form))))) + LOOKUP/?)) + +(define (cleanup/let* letify env bindings body) + ;; Some bindings bind names to trivial expressions (e.g. constant) and + ;; easy expression (e.g. closure references). We substitute the + ;; expressions for these names in BODY, but first we look at the + ;; names in these expressions and rename to avoid name capture. + (let ((bindings* (lmap (lambda (binding) + (list (car binding) + (cleanup/expr env (cadr binding)))) + bindings))) + (call-with-values + (lambda () + (list-split bindings* + (lambda (binding*) + (let ((form (cadr binding*))) + (and (pair? form) + (eq? (car form) 'QUOTE)))))) + (lambda (trivial non-trivial) + (call-with-values + (lambda () + (list-split non-trivial + (lambda (binding*) + (cleanup/easy? (cadr binding*))))) + (lambda (easy non-easy) + (let* ((possibly-captured + (lmap (lambda (binding) + (cleanup/easy/name (cadr binding))) + easy)) + (complex-triplets + ;; (original-name renamed-version value-expression) + (lmap (lambda (binding) + (let ((name (car binding))) + (list name + (if (memq name possibly-captured) + (variable/rename name) + name) + (cadr binding)))) + non-easy)) + (body* + (cleanup/expr + (append trivial + easy + (lmap (lambda (triplet) + (list (car triplet) + `(LOOKUP ,(cadr triplet)))) + complex-triplets) + env) + body))) + (if (null? complex-triplets) + body* + (letify (lmap cdr complex-triplets) + body*))))))))) + +(define (cleanup/easy? form) + (and (pair? form) + (case (car form) + ((LOOKUP) true) + ((CALL) + (let ((rator (cadr form))) + (and (pair? rator) + (eq? (car rator) 'QUOTE) + (memq (cadr rator) cleanup/easy/ops) + (let ((cont&rands (cddr form))) + (and (for-all? cont&rands cleanup/trivial?) + (let ((all-lookups + (list-transform-positive cont&rands + (lambda (rand) + (and (pair? rand) + (eq? (car rand) 'LOOKUP)))))) + (or (null? all-lookups) + (null? (cdr all-lookups))))))))) + (else + false)))) + +(define (cleanup/trivial? form) + (and (pair? form) + (or (memq (car form) '(QUOTE LOOKUP)) + (and (eq? (car form) 'CALL) + (pair? (cadr form)) + (eq? 'QUOTE (car (cadr form))) + (memq (cadr (cadr form)) cleanup/trivial/ops) + (for-all? (cddr form) + (lambda (rand) + (and (pair? rand) + (eq? 'QUOTE (car rand))))))))) + +(define (cleanup/easy/name form) + ;; form must satisfy cleanup/easy? + (case (car form) + ((LOOKUP) (cadr form)) + ((CALL) + (let ((lookup-rand (list-search-positive (cddr form) + (lambda (rand) + (eq? (car rand) 'LOOKUP))))) + (and lookup-rand + (cadr lookup-rand)))) + (else + (internal-error "Unrecognized easy form" form)))) + +(define cleanup/trivial/ops + (list %vector-index)) + +(define cleanup/easy/ops + (append cleanup/trivial/ops + (list %stack-closure-ref %heap-closure-ref))) + +(define (cleanup/letify bindings body) + `(LET ,bindings ,body)) + +(define (cleanup/bindify lambda-list operands) + (map (lambda (name operand) (list name operand)) + (lambda-list->names lambda-list) + (lambda-list/applicate lambda-list operands))) + +(define (cleanup/pseudo-letify rator bindings body) + (define (default) + (pseudo-letify rator bindings body cleanup/remember)) + (define (trivial last bindings) + (beginnify (map* (list last) cadr bindings))) + (cond ((memq *order-of-argument-evaluation* '(ANY LEFT-TO-RIGHT)) + (default)) + ((LOOKUP/? body) + (let* ((name (lookup/name body)) + (place (assq name bindings))) + (if (not place) + (trivial body bindings) + (trivial + (cadr place) + (delq place bindings))))) + ((QUOTE/? body) + (trivial body bindings)) + (else + (default)))) + +(define (cleanup/rename renames token) + (let ((place (assq token renames))) + (if (not place) + token + (cadr (cadr place))))) + +(define (cleanup/renamings env names) + (lmap (lambda (name) + (let ((place (assq name env))) + ;; Do not rename if the shadowed binding is disappearing + (if (or (not place) + (QUOTE/? (cadr place))) + `(,name (LOOKUP ,name)) + `(,name (LOOKUP ,(variable/rename name)))))) + names)) + +(define (cleanup/expr env expr) + (if (not (pair? expr)) + (illegal expr)) + (case (car expr) + ((QUOTE) + (cleanup/quote env expr)) + ((LOOKUP) + (cleanup/lookup env expr)) + ((LAMBDA) + (cleanup/lambda env expr)) + ((LET) + (cleanup/let env expr)) + ((DECLARE) + (cleanup/declare env expr)) + ((CALL) + (cleanup/call env expr)) + ((BEGIN) + (cleanup/begin env expr)) + ((IF) + (cleanup/if env expr)) + ((LETREC) + (cleanup/letrec env expr)) + ((SET! UNASSIGNED? OR DELAY + ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT) + (no-longer-legal expr)) + (else + (illegal expr)))) + +(define (cleanup/expr* env exprs) + (lmap (lambda (expr) + (cleanup/expr env expr)) + exprs)) + +(define (cleanup/remember new old) + (code-rewrite/remember new old)) \ No newline at end of file diff --git a/v8/src/compiler/midend/closconv.scm b/v8/src/compiler/midend/closconv.scm new file mode 100644 index 000000000..a263c2962 --- /dev/null +++ b/v8/src/compiler/midend/closconv.scm @@ -0,0 +1,677 @@ +#| -*-Scheme-*- + +$Id: closconv.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Closure converter +;;; package: (compiler midend) + +(declare (usual-integrations)) + +(define *closconv-operator-and-operand-illegal?* true) + +(define (closconv/top-level program #!optional after-cps?) + (closconv/bind-parameters + (and (not (default-object? after-cps?)) + after-cps?) + (lambda () + (let* ((env (closconv/env/%make 'STATIC false)) + (program* (closconv/expr env (lifter/letrecify program)))) + (closconv/analyze! env program*))))) + +(define-macro (define-closure-converter keyword bindings . body) + (let ((proc-name (symbol-append 'CLOSCONV/ keyword))) + (call-with-values + (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form))) + (lambda (names code) + `(define ,proc-name + (let ((handler (lambda ,(cons (car bindings) names) ,@body))) + (named-lambda (,proc-name env form) + (closconv/remember ,code + form)))))))) + +(define-closure-converter LOOKUP (env name) + (closconv/lookup* env name 'ORDINARY)) + +(define-closure-converter LAMBDA (env lambda-list body) + (call-with-values + (lambda () (closconv/lambda* 'DYNAMIC env lambda-list body)) + (lambda (expr* env*) + (set-closconv/env/close?! env* true) + expr*))) + +(define-closure-converter LET (env bindings body) + (let* ((env* (closconv/env/make + (binding-context-type 'LET + (closconv/env/context env) + bindings) + env + (lmap car bindings))) + (expr* `(LET ,(closconv/bindings env* env bindings) + ,(closconv/expr env* body)))) + (set-closconv/env/form! env* expr*) + expr*)) + +(define-closure-converter LETREC (env bindings body) + (let* ((env* (closconv/env/make + (binding-context-type 'LETREC + (closconv/env/context env) + bindings) + env + (lmap car bindings))) + (expr* `(LETREC ,(closconv/bindings env* env* bindings) + ,(closconv/expr env* body)))) + (set-closconv/env/form! env* expr*) + expr*)) + +(define-closure-converter CALL (env rator cont #!rest rands) + (let* ((rands (cons cont rands)) + (default + (lambda () + `(CALL ,(closconv/expr env rator) + ,@(closconv/expr* env rands))))) + (cond ((not (pair? rator)) + (default)) + ((eq? (car rator) 'LOOKUP) + (let* ((name (cadr rator)) + (rator* (closconv/remember + (closconv/lookup* env name 'OPERATOR) + rator))) + `(CALL ,rator* + ,@(closconv/expr* env rands)))) + ((eq? (car rator) 'LAMBDA) + (let ((ll (cadr rator)) + (body (caddr rator))) + (guarantee-simple-lambda-list ll) + (guarantee-argument-list rands (length ll)) + (let ((bindings (map list ll rands))) + (call-with-values + (lambda () + (closconv/lambda* + (binding-context-type 'CALL + (closconv/env/context env) + bindings) + env ll body)) + (lambda (rator* env*) + (let ((bindings* (closconv/bindings env* env bindings))) + `(CALL ,(closconv/remember rator* rator) + ,@(lmap cadr bindings*)))))))) + (else + (default))))) + +(define-closure-converter QUOTE (env object) + env + `(QUOTE ,object)) + +(define-closure-converter DECLARE (env #!rest anything) + env ; ignored + `(DECLARE ,@anything)) + +(define-closure-converter BEGIN (env #!rest actions) + `(BEGIN ,@(closconv/expr* env actions))) + +(define-closure-converter IF (env pred conseq alt) + `(IF ,(closconv/expr env pred) + ,(closconv/expr env conseq) + ,(closconv/expr env alt))) + +(define (closconv/expr env expr) + ;; This copies the expression and returns the copy. It + ;; simultaneously builds an environment representation (see the data + ;; structure closconv/expr, below) by mutating the ENV argument. + (if (not (pair? expr)) + (illegal expr)) + (case (car expr) + ((QUOTE) + (closconv/quote env expr)) + ((LOOKUP) + (closconv/lookup env expr)) + ((LAMBDA) + (closconv/lambda env expr)) + ((LET) + (closconv/let env expr)) + ((DECLARE) + (closconv/declare env expr)) + ((CALL) + (closconv/call env expr)) + ((BEGIN) + (closconv/begin env expr)) + ((IF) + (closconv/if env expr)) + ((LETREC) + (closconv/letrec env expr)) + ((SET! UNASSIGNED? OR DELAY + ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT) + (no-longer-legal expr)) + (else + (illegal expr)))) + +(define (closconv/expr* env exprs) + (lmap (lambda (expr) + (closconv/expr env expr)) + exprs)) + +(define (closconv/remember new old) + (code-rewrite/remember new old)) + +(define (closconv/split new old) + ;; The old code is being duplicated in the output, so the debugging + ;; information must understand the split. + (let ((old* (code-rewrite/original-form old))) + (if old* + (code-rewrite/remember* + new + (if (new-dbg-procedure? old*) + (new-dbg-procedure/copy old*) + old*))) + new)) + +(define (closconv/new-name prefix) + (new-variable prefix)) + +;;;; Parameterization for invocation before and after cps conversion + +;; Before CPS + +(define (closconv/closure/new-name/pre-cps) + (new-closure-variable)) + +(define (closconv/closure/sort-variables/pre-cps variable-refs) + (if (there-exists? variable-refs continuation-variable?) + (internal-error "Closing over continuation variable before CPS" + variable-refs)) + variable-refs) + +(define (closconv/closure/make-handler/pre-cps closure-name params body + captured) + captured ; ignored + `(LAMBDA (,(car params) ,closure-name ,@(cdr params)) + ,body)) + +(define (closconv/closure/make-trivial/pre-cps handler) + `(CALL (QUOTE ,%make-trivial-closure) (QUOTE #F) ,handler)) + +(define (closconv/closure/make-set!/pre-cps closure-name index name*) + `(CALL (QUOTE ,%heap-closure-set!) (QUOTE #F) (LOOKUP ,closure-name) + ,index (LOOKUP ,name*) (QUOTE ,name*))) + +;; After CPS + +(define (closconv/closure/new-name/post-cps) + (let ((name (closconv/new-name 'FRAME))) + (declare-variable-property! name '(FRAME-VARIABLE)) + name)) + +(define (closconv/closure/sort-variables/post-cps variable-refs) + (call-with-values + (lambda () + (list-split variable-refs + (lambda (free-ref) + (continuation-variable? + (closconv/binding/name (car free-ref)))))) + (lambda (cont-refs non-cont-refs) + (append cont-refs non-cont-refs)))) + +(define (closconv/closure/make-handler/post-cps closure-name params body + captured) + `(LAMBDA ,params + (LET ((,closure-name + (CALL (QUOTE ,%fetch-stack-closure) + (QUOTE #F) + (QUOTE ,captured)))) + ,body))) + +(define (closconv/closure/make-trivial/post-cps handler) + ;; This gets invoked on lambda expressions that appear in several + ;; places (e.g. args to %make-heap-closure, %make-trivial-closure, etc.) + handler) + +(define (closconv/closure/make-set!/post-cps closure-name index name*) + closure-name index ; ignored + (internal-error "Assigning closure after CPS conversion?" name*)) + +(define %make-closure %make-heap-closure) +(define %closure-ref %heap-closure-ref) + +(let-syntax ((define-closconv-parameter + (macro (name) + `(define ,name ,(symbol-append name '/pre-cps))))) + (define-closconv-parameter closconv/closure/sort-variables) + (define-closconv-parameter closconv/closure/make-handler) + (define-closconv-parameter closconv/closure/make-trivial) + (define-closconv-parameter closconv/closure/make-set!) + (define-closconv-parameter closconv/closure/new-name)) + +(define (closconv/bind-parameters after-cps? thunk) + (let ((bind-parameters + (lambda (lift? sort handler trivial + constructor refer + set new-name) + (fluid-let ((*lift-closure-lambdas?* lift?) + (closconv/closure/sort-variables sort) + (closconv/closure/make-handler handler) + (closconv/closure/make-trivial trivial) + (%make-closure constructor) + (%closure-ref refer) + (closconv/closure/make-set! set) + (closconv/closure/new-name new-name)) + (thunk))))) + (if after-cps? + (bind-parameters false + closconv/closure/sort-variables/post-cps + closconv/closure/make-handler/post-cps + closconv/closure/make-trivial/post-cps + %make-stack-closure + %stack-closure-ref + closconv/closure/make-set!/post-cps + closconv/closure/new-name/post-cps) + (bind-parameters *lift-closure-lambdas?* + closconv/closure/sort-variables/pre-cps + closconv/closure/make-handler/pre-cps + closconv/closure/make-trivial/pre-cps + %make-heap-closure + %heap-closure-ref + closconv/closure/make-set!/pre-cps + closconv/closure/new-name/pre-cps)))) + +(define-structure (closconv/env + (conc-name closconv/env/) + (constructor closconv/env/%make (context parent))) + (context false read-only true) ; Dynamic or static + (parent false read-only true) + (children '() read-only false) + (bound '() read-only false) ; list of closconv/binding structures + (free '() read-only false) ; list of (closconv/binding reference) + (form false read-only false) + (close? false read-only false) ; should be considered for + ; having its form closed (i.e. + ; converted to a %make-xxx-closure) + (closed-over false read-only false) ; slots required in closure + ; object: either #F, #T + ; (closed, but no slots), or a + ; list of (closconv/binding + ; reference) elements from free + (binding false read-only false)) ; known self-reference binding + +(define-structure (closconv/binding + (conc-name closconv/binding/) + (constructor closconv/binding/make (name env))) + (name false read-only true) + (env false read-only true) + (operator-refs '() read-only false) + (ordinary-refs '() read-only false) + (value false read-only false)) + +(define (closconv/env/make context parent bound-names) + (let ((env (closconv/env/%make context parent))) + (set-closconv/env/bound! + env + (lmap (lambda (name) + (closconv/binding/make name env)) + bound-names)) + (set-closconv/env/children! parent + (cons env (closconv/env/children parent))) + env)) + +(define (closconv/lookup* env name kind) + (let ((ref `(LOOKUP ,name))) + (let walk-spine ((env env)) + (cond ((not env) + (free-var-error name)) + ((closconv/binding/find (closconv/env/bound env) name) + => (lambda (binding) + (if (eq? kind 'OPERATOR) + (set-closconv/binding/operator-refs! + binding + (cons ref (closconv/binding/operator-refs binding))) + (set-closconv/binding/ordinary-refs! + binding + (cons ref (closconv/binding/ordinary-refs binding)))) + binding)) + (else + (let* ((binding (walk-spine (closconv/env/parent env))) + (free (closconv/env/free env)) + (place (assq binding free))) + (if (not place) + (set-closconv/env/free! env + (cons (list binding ref) free)) + (set-cdr! place (cons ref (cdr place)))) + binding)))) + ref)) + +(define (closconv/binding/find bindings name) + (let find ((bindings bindings)) + (and (not (null? bindings)) + (let ((binding (car bindings))) + (if (not (eq? name (closconv/binding/name (car bindings)))) + (find (cdr bindings)) + binding))))) + +(define (closconv/lambda* context env lambda-list body) + ;; (values expr* env*) + (let* ((env* (closconv/env/make context + env + (lambda-list->names lambda-list))) + (expr* `(lambda ,lambda-list + ,(closconv/expr env* body)))) + (set-closconv/env/form! env* expr*) + (values expr* env*))) + +(define (closconv/bindings env* env bindings) + ;; ENV* is the environment to which the bindings are being added + ;; ENV is the environment in which the form part of the binding is + ;; to be evaluated (i.e. it will be EQ? to ENV* for LETREC but + ;; not for LET) + (lmap (lambda (binding) + (let ((name (car binding)) + (value (cadr binding))) + (list + name + (if (or (not (pair? value)) + (not (eq? (car value) 'LAMBDA))) + (closconv/expr env value) + (call-with-values + (lambda () + (closconv/lambda* 'DYNAMIC ; bindings are dynamic + env + (cadr value) ; lambda list + (caddr value))) ; body + (lambda (value* env**) + (let ((binding + (or (closconv/binding/find (closconv/env/bound env*) + name) + (internal-error "Missing binding" name)))) + (set-closconv/env/binding! env** binding) + (set-closconv/binding/value! binding env**) + value*))))))) + bindings)) + +;;;; The Analyzer/Converter Proper + +(define (closconv/analyze! env program) + (closconv/contaminate! env) + (closconv/rewrite! env) + program) + +(define (closconv/contaminate! env) + (cond ((closconv/env/closed-over env)) ; Already figured out + ((closconv/env/close? env) + (closconv/close! env)) + ((not (closconv/env/binding env))) ; No known self-binding + ((not (null? (closconv/binding/ordinary-refs + (closconv/env/binding env)))) + ;; Self-binding is referenced other than by a call + (closconv/close! env))) + (for-each closconv/contaminate! (closconv/env/children env))) + +(define (closconv/close! env) + (let ((closed-over + (list-transform-negative (closconv/env/free env) + (lambda (free-ref) + (closconv/static-binding? (car free-ref)))))) + (set-closconv/env/closed-over! + env + (if (or (null? closed-over) + ;; Do not close if only free reference is self! + (and (null? (cdr closed-over)) + (closconv/self-reference? env (car (car closed-over))))) + true + closed-over)) + (for-each (lambda (free-ref) + (let* ((binding (car free-ref)) + (env* (closconv/binding/value binding))) + (if (and env* + (not (closconv/env/closed-over env*))) + (closconv/close! env*)))) + closed-over))) + +(define (closconv/static-binding? binding) + (and (eq? (closconv/env/context (closconv/binding/env binding)) 'STATIC) + (not (pseudo-static-variable? (closconv/binding/name binding))))) + +(define (closconv/self-reference? env binding) + (let ((value (closconv/binding/value binding))) + (and value + (eq? value env)))) + +(define (closconv/rewrite! env) + ;; This must work from the root to the leaves, because a reference + ;; may be rewritten multiple times as it is copied from closure + ;; to closure. + (let ((form (closconv/env/form env)) + (closed-over (closconv/env/closed-over env))) + (cond ((or (not form) + (not (pair? form)) + (eq? (car form) 'LET)) + (if closed-over + (internal-error "Form can't be closed" form)) + (for-each closconv/rewrite! (closconv/env/children env))) + ((eq? (car form) 'LETREC) + ;; Handled specially because it must ensure that recursive + ;; references work, and the LETREC must remain syntactically + ;; acceptable (only lambda bindings allowed). + (if closed-over + (internal-error "Form can't be closed" form)) + (let ((closed + (list-transform-positive (closconv/env/bound env) + (lambda (binding) + (let ((value (closconv/binding/value binding))) + (and value + (closconv/env/closed-over value))))))) + (if (null? closed) + (closconv/rewrite/letrec/trivial! env) + (closconv/rewrite/letrec! env closed)))) + ((eq? (car form) 'LAMBDA) + (cond ((closconv/env/binding env) => closconv/verify-binding)) + (cond ((pair? closed-over) + (closconv/rewrite/lambda! env '())) + (closed-over + (closconv/rewrite/lambda/trivial! env))) + (for-each closconv/rewrite! (closconv/env/children env))) + (else + (internal-error "Unknown binding form" form))))) + +(define (closconv/rewrite/lambda/trivial! env) + (closconv/maybe-lift! env + (let ((form (closconv/env/form env))) + (closconv/split (form/preserve form) + form)) + closconv/closure/make-trivial)) + +(define (closconv/verify-binding binding) + (if (and (not (null? (closconv/binding/operator-refs binding))) + (not (null? (closconv/binding/ordinary-refs binding))) + *closconv-operator-and-operand-illegal?*) + (internal-error "Binding is both operator and operand" binding))) + +(define (closconv/rewrite/lambda! env circular) + ;; Env is a LAMBDA env + (let ((closure-name (closconv/closure/new-name)) + (closed-over* + (closconv/closure/sort-variables (closconv/env/closed-over env)))) + (let* ((closed-over ; Remove self-reference if present + (let ((binding (closconv/env/binding env))) + (cond ((and binding (assq binding closed-over*)) + => (lambda (free-ref) + (delq free-ref closed-over*))) + (else + closed-over*)))) + (closed-over-names + (list->vector (lmap (lambda (free-ref) + (closconv/binding/name (car free-ref))) + closed-over))) + (captured + (lmap (lambda (free-ref) + (let ((binding (car free-ref))) + (if (memq binding circular) + `(QUOTE ,#f) + (form/preserve (cadr free-ref))))) + closed-over)) + (form (closconv/env/form env))) + ;; Rewrite references to closed variables + (for-each + (lambda (free-ref) + (let ((name (closconv/binding/name (car free-ref)))) + (for-each (lambda (ref) + (form/rewrite! + ref + `(CALL (QUOTE ,%closure-ref) + (QUOTE #F) + (LOOKUP ,closure-name) + (CALL (QUOTE ,%vector-index) + (QUOTE #F) + (QUOTE ,closed-over-names) + (QUOTE ,name)) + (QUOTE ,name)))) + (cdr free-ref)))) + closed-over) + ;; Rewrite self references + (if (not (eq? closed-over closed-over*)) + (let* ((self-binding (closconv/env/binding env)) + (free-ref (assq self-binding closed-over*))) + (for-each (lambda (ref) + (form/rewrite! ref + `(LOOKUP ,closure-name))) + (cdr free-ref)))) + ;; Convert to closure and maybe lift to top level + (closconv/maybe-lift! + env + (closconv/split + (closconv/closure/make-handler closure-name + (cadr form) + (caddr form) + closed-over-names) + form) + (lambda (handler) + `(CALL (QUOTE ,%make-closure) (QUOTE #F) ,handler + (QUOTE ,closed-over-names) ,@captured))) + closed-over-names))) + +(define (closconv/maybe-lift! env handler transform) + (form/rewrite! (closconv/env/form env) + (if *lift-closure-lambdas?* + (let ((handler-name + (let ((binding (closconv/env/binding env))) + (or (and binding + (variable/rename + (closconv/binding/name binding))) + (closconv/new-name 'LAMBDA))))) + (closconv/lift! env handler-name handler) + (transform `(LOOKUP ,handler-name))) + (transform handler)))) + +(define (closconv/rewrite/letrec/trivial! env) + (for-each closconv/rewrite! (closconv/env/children env))) + +(define (closconv/rewrite/letrec! env closed*) + ;; Env is a LETREC env + (for-each closconv/verify-binding closed*) + (call-with-values + (lambda () + (list-split closed* + (lambda (binding) + (let ((value (closconv/binding/value binding))) + (pair? (closconv/env/closed-over value)))))) + (lambda (closed trivial) + ;; IMPORTANT: This assumes that make-trivial-closure can be called + ;; multiple times for the same lambda expression and returns + ;; eq? results! + (for-each + (lambda (binding) + (for-each (lambda (ref) + (let ((ref* (form/preserve ref))) + (form/rewrite! ref + (closconv/closure/make-trivial ref*)))) + (closconv/binding/ordinary-refs binding))) + trivial) + (let* ((envs (lmap closconv/binding/value closed)) + (circular + (lmap + (lambda (env) + (let ((closed-over (closconv/env/closed-over env))) + (list-transform-positive closed + (lambda (binding) + (assq binding closed-over))))) + envs))) + (let* ((circ-results (map closconv/rewrite/lambda! envs circular)) + (form (closconv/env/form env))) + (form/rewrite! + form + + (bind* (lmap closconv/binding/name closed) + (lmap closconv/env/form envs) + (beginnify + (append-map* + (list + (let ((ok (delq* closed (closconv/env/bound env)))) + (if (null? ok) + (caddr form) + (let ((ok-names (lmap closconv/binding/name ok))) + `(LETREC ,(list-transform-positive (cadr form) + (lambda (binding) + (memq (car binding) ok-names))) + ,(caddr form)))))) + (lambda (binding captured-names circular) + (let ((name (closconv/binding/name binding)) + (l (vector->list captured-names))) + (append-map + (lambda (binding) + (let ((name* (closconv/binding/name binding))) + (if (not (memq name* l)) + '() + (list + (closconv/closure/make-set! + name + `(CALL (QUOTE ,%vector-index) + (QUOTE #F) + (QUOTE ,captured-names) + (QUOTE ,name*)) + name*))))) + circular))) + closed circ-results circular))))) + (let ((envs (append (lmap closconv/binding/value trivial) envs))) + (for-each (lambda (closed-env) + (for-each closconv/rewrite! + (closconv/env/children closed-env))) + envs) + (for-each closconv/rewrite! + (delq* envs (closconv/env/children env)))))))) + +(define closconv/lift! + (lifter/make (lambda (env) + (let loop ((env env)) + (cond ((not env) + (internal-error "No static frame" env)) + ((eq? (closconv/env/context env) 'STATIC) + (closconv/env/form env)) + (else + (loop (closconv/env/parent env)))))))) \ No newline at end of file diff --git a/v8/src/compiler/midend/compat.scm b/v8/src/compiler/midend/compat.scm new file mode 100644 index 000000000..67781040e --- /dev/null +++ b/v8/src/compiler/midend/compat.scm @@ -0,0 +1,730 @@ +#| -*-Scheme-*- + +$Id: compat.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +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 begin deeper to facilitate lexprs. +;; The number of parameters passed in registers is determined by the +;; back-end (*rtlgen/arguments-registers*) + + +;;; package: (compiler midend) + +(declare (usual-integrations)) + +(define (compat/top-level program) + (let ((result (form/match compat/expression-pattern program))) + (if (not result) + (internal-error "Expression does not bind continuation" program)) + (compat/remember + (compat/expr '() ; Nothing known about stack yet + (let ((continuation-variable + (cadr (assq compat/?cont-variable result))) + (body (cadr (assq compat/?expr-body result)))) + (let ((result (form/match compat/needs-environment-pattern body))) + (if result + `(LAMBDA (,continuation-variable + ,(cadr (assq compat/?env-variable result))) + ,(cadr (assq compat/?expr-body result))) + `(LAMBDA (,continuation-variable + ,(new-ignored-variable 'IGNORED-ENVIRONMENT)) + ,body))))) + program))) + +(define compat/?cont-variable (->pattern-variable 'CONT-VARIABLE)) +(define compat/?env-variable (->pattern-variable 'ENV-VARIABLE)) +(define compat/?frame-variable (->pattern-variable 'FRAME-VARIABLE)) +(define compat/?frame-vector (->pattern-variable 'FRAME-VECTOR)) +(define compat/?expr-body (->pattern-variable 'EXPR-BODY)) +(define compat/?body (->pattern-variable 'BODY)) + +(define compat/expression-pattern + `(LET ((,compat/?cont-variable + (CALL (QUOTE ,%fetch-continuation) + (QUOTE #F)))) + ,compat/?expr-body)) + +(define compat/needs-environment-pattern + `(LET ((,compat/?env-variable + (CALL (QUOTE ,%fetch-environment) + (QUOTE #F)))) + ,compat/?expr-body)) + +(define compat/frame-pattern + `(LET ((,compat/?frame-variable + (CALL (QUOTE ,%fetch-stack-closure) + (QUOTE #F) + (QUOTE ,compat/?frame-vector)))) + ,compat/?body)) + +(define-macro (define-compatibility-rewrite keyword bindings . body) + (let ((proc-name (symbol-append 'COMPAT/ keyword))) + (call-with-values + (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form))) + (lambda (names code) + `(define ,proc-name + (let ((handler (lambda ,(cons (car bindings) names) ,@body))) + (named-lambda (,proc-name env form) + (compat/remember ,code form)))))))) + +(define-compatibility-rewrite LOOKUP (env name) + (let ((place (assq name env))) + (if (not place) + `(LOOKUP ,name) + (cadr place)))) + +(define-compatibility-rewrite LAMBDA (env lambda-list body) + env ; ignored + (compat/rewrite-lambda lambda-list body + (compat/choose-stack-formals 1 lambda-list))) + + +(define-compatibility-rewrite LET (env bindings body) + `(LET ,(lmap (lambda (binding) + (list (car binding) + (compat/expr env (cadr binding)))) + bindings) + ,(compat/expr env body))) + +(define-compatibility-rewrite LETREC (env bindings body) + `(LETREC ,(lmap (lambda (binding) + (list (car binding) + (compat/expr env (cadr binding)))) + bindings) + ,(compat/expr env body))) + +(define-compatibility-rewrite QUOTE (env object) + env ; ignored + `(QUOTE ,object)) + +(define-compatibility-rewrite BEGIN (env #!rest actions) + `(BEGIN ,@(compat/expr* env actions))) + +(define-compatibility-rewrite DECLARE (env #!rest anything) + env ; ignored + `(DECLARE ,@anything)) + +(define-compatibility-rewrite IF (env pred conseq alt) + `(IF ,(compat/expr env pred) + ,(compat/expr env conseq) + ,(compat/expr env alt))) + +(define-compatibility-rewrite CALL (env rator cont #!rest rands) + (compat/rewrite-call env rator cont rands)) + +(define (compat/rewrite-call env rator cont rands) + + (define (possibly-pass-some-args-on-stack) + (compat/standard-call-handler env rator cont rands)) + + (define (dont-split-cookie-call) + `(CALL ,(compat/expr env rator) + ,(compat/expr env cont) + ,@(compat/expr* env rands))) + + (cond ((or (not (pair? rator)) + (not (eq? (car rator) 'QUOTE))) + (possibly-pass-some-args-on-stack)) + ((rewrite-operator/compat? (quote/text rator)) + => (lambda (handler) + (handler env rator cont rands))) + #| Hooks into the compiler interface, when they must tail + into another computation, are now called with the default + (args. in registers) calling convention. This is not a + problem because they have fixed arity. + ((and (operator/satisfies? (quote/text rator) '(OUT-OF-LINE-HOOK)) + (not (operator/satisfies? (quote/text rator) '(SPECIAL-INTERFACE))) + (not (equal? cont '(QUOTE #F)))) + (compat/out-of-line env rator cont rands)) + |# + (else (dont-split-cookie-call)))) + +(define (compat/expr env expr) + (if (not (pair? expr)) + (illegal expr)) + (case (car expr) + ((QUOTE) (compat/quote env expr)) + ((LOOKUP) (compat/lookup env expr)) + ((LAMBDA) (compat/lambda env expr)) + ((LET) (compat/let env expr)) + ((DECLARE) (compat/declare env expr)) + ((CALL) (compat/call env expr)) + ((BEGIN) (compat/begin env expr)) + ((IF) (compat/if env expr)) + ((LETREC) (compat/letrec env expr)) + ((SET! UNASSIGNED? OR DELAY + ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT) + (no-longer-legal expr)) + (else + (illegal expr)))) + +(define (compat/expr* env exprs) + (lmap (lambda (expr) + (compat/expr env expr)) + exprs)) + +(define (compat/remember new old) + (code-rewrite/remember new old)) + +(define (compat/new-name prefix) + (new-variable prefix)) + +(define (compat/lambda-list->frame lambda-list) + (let ((names (lambda-list->names lambda-list))) + (let ((first (car names))) + (if (not (continuation-variable? first)) + (internal-error "No continuation variable found" lambda-list)) + (list->vector (cons first (reverse (cdr names))))))) + + +(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 + ;; vectors to new, extended vectors + (let ((alist (lmap (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 ,name)))) + formals-on-stack))) + (if old-frame-vector + (cons (list old-frame-vector new-frame-vector) + alist) + alist))) + + (define (make-new-lambda frame-variable old-frame-vector new-frame-vector + body) + `(LAMBDA ,formals + (LET ((,frame-variable + (CALL (QUOTE ,%fetch-stack-closure) + (QUOTE #F) + (QUOTE ,new-frame-vector)))) + ,(compat/expr (compat/new-env + frame-variable old-frame-vector new-frame-vector) + body)))) + + (cond ((null? formals-on-stack) + `(LAMBDA ,formals + ,(compat/expr '() body))) + ((form/match compat/frame-pattern body) + => (lambda (match) + (let* ((old-frame-vector (cadr(assq compat/?frame-vector match))) + (new-frame-vector + (list->vector (append (vector->list old-frame-vector) + formals-on-stack)))) + (make-new-lambda + (cadr (assq compat/?frame-variable match)) + old-frame-vector + new-frame-vector + (cadr (assq compat/?body match)))))) + (else + (let ((frame (compat/new-name 'FRAME))) + (declare-variable-property! frame '(FRAME-VARIABLE)) + (make-new-lambda frame + #F + (list->vector formals-on-stack) + body))))) + +(define (compat/choose-stack-formals special-arguments lambda-list) + ;; SPECIAL-ARGUMENTS is the number of arguments passed by a special + ;; mechanism, usually 1 for the continuation, or 2 for the + ;; continuation and heap closure. + (with-values + (lambda () + (%compat/split-register&stack special-arguments + (lambda-list->names lambda-list))) + (lambda (register-formals stack-formals) + register-formals ; ignored + stack-formals))) + + +(define (compat/split-register&stack expressions) + (%compat/split-register&stack 0 expressions)) + +(define (%compat/split-register&stack special-arguments args-or-formals) + ;;(values for-regsiters for-stack) + (let* ((len (length args-or-formals)) + (argument-register-count + (+ special-arguments + (vector-length *rtlgen/argument-registers*)))) + (if (> len argument-register-count) + (values (list-head args-or-formals argument-register-count) + (list-tail args-or-formals argument-register-count)) + (values args-or-formals + '())))) + +(define (compat/expression->name expr) + (cond ((LOOKUP/? expr) + (lookup/name expr)) + ((CALL/%stack-closure-ref? expr) + (quote/text (CALL/%stack-closure-ref/name expr))) + (else + (compat/new-name 'ARG)))) + + +(define (compat/uniquify-append prefix addends) + ;; append addends, ensuring that each is a unique name + (define (uniquify names) + (if (null? names) + '() + (let ((unique-tail (uniquify (cdr names)))) + (cons (if (or (memq (car names) unique-tail) + (memq (car names) prefix)) + (variable/rename (car names)) + (car names)) + unique-tail)))) + (append prefix (uniquify addends))) + + +(define (compat/rewrite-call/split env operator continuation + register-operands stack-operands) + + (define (pushed-arg-name form) + (compat/expression->name form)) + + (define (make-call new-continuation) + `(CALL ,(compat/expr env operator) + ,(compat/expr env new-continuation) + ,@(compat/expr* env register-operands))) + + (define (make-pushing-call continuation old-frame old-pushed-expressions) + (make-call + `(CALL ',%make-stack-closure + '#F + ,continuation + ',(list->vector + (compat/uniquify-append + (vector->list old-frame) + (map pushed-arg-name stack-operands))) + ,@old-pushed-expressions + ,@stack-operands))) + + (cond ((null? stack-operands) + (make-call continuation)) + ((call/%make-stack-closure? continuation) + ;; extend the stack closure with parameters + (make-pushing-call + (call/%make-stack-closure/lambda-expression continuation) + (quote/text (call/%make-stack-closure/vector continuation)) + (call/%make-stack-closure/values continuation))) + (else + ;; introduce a new stack closure for extra parameters + (make-pushing-call continuation + '#() + '())))) + +(define *compat-rewritten-operators* + (make-eq-hash-table)) + +(define-integrable (rewrite-operator/compat? rator) + (hash-table/get *compat-rewritten-operators* rator false)) + +(define (define-rewrite/compat operator handler) + (hash-table/put! *compat-rewritten-operators* operator handler)) + +(define (compat/standard-call-handler env rator cont rands) + (with-values (lambda () (compat/split-register&stack rands)) + (lambda (reg-rands stack-rands) + (compat/rewrite-call/split env rator cont reg-rands stack-rands)))) + +(let* ((compat/invocation-cookie + (lambda (n) + (lambda (env rator cont rands) + (with-values + (lambda () (compat/split-register&stack (list-tail rands n))) + (lambda (reg-rands stack-rands) + (compat/rewrite-call/split + env rator cont + (append (list-head rands n) reg-rands) + stack-rands)))))) + (invocation+2-handler (compat/invocation-cookie 2))) + + ;; These are kinds of calls which have extra arguments like arity or cache + (define-rewrite/compat %invoke-operator-cache invocation+2-handler) + (define-rewrite/compat %invoke-remote-cache invocation+2-handler) + (define-rewrite/compat %internal-apply invocation+2-handler) + (define-rewrite/compat %invoke-continuation compat/standard-call-handler)) + + +(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 (and (pair? vector-arg) + (eq? (car vector-arg) 'QUOTE)) + (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 %make-heap-closure + ;; The lambda expression in a heap closure is special the closure + ;; formal is passed by a special mechanism + (lambda (env rator cont rands) + rator ; ignored + (let ((lam-expr (first rands))) + (if (not (LAMBDA/? lam-expr)) + (internal-error "%make-heap-closure is missing a LAMBDA-expression" + rands)) + (let ((lambda-list (lambda/formals lam-expr))) + (if (or (< (length lambda-list) 2) + (not (closure-variable? (second lambda-list)))) + (internal-error + "%make-heap-closure LAMBDA-expression has bad formals" lam-expr)) + `(CALL (QUOTE ,%make-heap-closure) + ,(compat/expr env cont) + ,(compat/rewrite-lambda + lambda-list + (lambda/body lam-expr) + (compat/choose-stack-formals 2 lambda-list)) + . ,(compat/expr* env (cdr rands))))))) + + +(define-rewrite/compat %variable-cache-ref + ;; (CALL ',%variable-cache-ref '#F 'NAME) + ;; ------- rator ------- cont -------- rands ----------- + (lambda (env rator cont rands) + rator ; ignored + (let ((cont (compat/expr env cont)) + (cell (compat/expr env (first rands))) + (quoted-name (compat/expr env (second rands)))) + (compat/verify-hook-continuation cont) + (compat/verify-cache cell quoted-name) + (let* ((%continue + (if (not (QUOTE/? cont)) + (lambda (expr) + `(CALL (QUOTE ,%invoke-continuation) + ,cont + ,expr)) + (lambda (expr) expr))) + (name (quote/text quoted-name)) + (cell-name + (new-variable-cache-variable name `(VARIABLE-CACHE ,name))) + (value-name (compat/new-name name))) + (if (compat/ignore-reference-traps? name) + (%continue `(CALL (QUOTE ,%variable-cell-ref) + (QUOTE #F) + (CALL (QUOTE ,%variable-read-cache) (QUOTE #F) + ,cell ,quoted-name))) + `(LET ((,cell-name + (CALL (QUOTE ,%variable-read-cache) (QUOTE #F) + ,cell ,quoted-name))) + (LET ((,value-name (CALL (QUOTE ,%variable-cell-ref) + (QUOTE #F) + (LOOKUP ,cell-name)))) + (IF (CALL (QUOTE ,%reference-trap?) + (QUOTE #F) + (LOOKUP ,value-name)) + (CALL (QUOTE ,%hook-variable-cell-ref) + ,cont + (LOOKUP ,cell-name)) + ,(%continue `(LOOKUP ,value-name)))))))))) + +(define-rewrite/compat %safe-variable-cache-ref + (lambda (env rator cont rands) + ;; (CALL ',%safe-variable-cache-ref '#F 'NAME) + ;; --------- rator --------- cont -------- rands ----------- + rator ; ignored + (let ((cont (compat/expr env cont)) + (cell (compat/expr env (first rands))) + (quoted-name (compat/expr env (second rands)))) + (compat/verify-hook-continuation cont) + (compat/verify-cache cell quoted-name) + (let* ((%continue + (if (not (QUOTE/? cont)) + (lambda (expr) + `(CALL (QUOTE ,%invoke-continuation) + ,cont + ,expr)) + (lambda (expr) expr))) + (name (quote/text quoted-name)) + (cell-name + (new-variable-cache-variable name `(VARIABLE-CACHE ,name))) + (value-name (compat/new-name name))) + `(LET ((,cell-name + (CALL (QUOTE ,%variable-read-cache) (QUOTE #F) + ,cell ,quoted-name))) + (LET ((,value-name (CALL (QUOTE ,%variable-cell-ref) + (QUOTE #F) + (LOOKUP ,cell-name)))) + ,(if (compat/ignore-reference-traps? name) + (%continue `(LOOKUP ,value-name)) + `(IF (IF (CALL (QUOTE ,%reference-trap?) + (QUOTE #F) + (LOOKUP ,value-name)) + (CALL (QUOTE ,%unassigned?) + (QUOTE #F) + (LOOKUP ,value-name)) + (QUOTE #T)) + ,(%continue `(LOOKUP ,value-name)) + (CALL (QUOTE ,%hook-safe-variable-cell-ref) + ,cont + (LOOKUP ,cell-name)))))))))) + + +;;; These predicates should determine the right answers from declarations: + +(define (compat/ignore-reference-traps? name) + name + #F) + +(define (compat/ignore-assignment-traps? name) + name + #F) + +;; NOTE: This is never in value position because envconv expands +;; all cell sets into begins. In particular, this means that cont +;; should always be #F! +;; The expansion in envconv implies that SET! for value is more +;; expensive than necessary, since it could use the same cell +;; for the read and the write. + +(define-rewrite/compat %variable-cache-set! + (lambda (env rator cont rands) + ;; (CALL ',%variable-write-cache '#F 'NAME) + ;; -------- rator -------- cont -------- rands ----------- + rator ; ignored + (let ((cont (compat/expr env cont)) + (cell (compat/expr env (first rands))) + (value (compat/expr env (second rands))) + (quoted-name (compat/expr env (third rands)))) + ;; (compat/verify-hook-continuation cont) + (if (not (equal? cont '(QUOTE #F))) + (internal-error "Unexpected continuation to variable cache assignment" + cont)) + (compat/verify-cache cell quoted-name) + (let* ((name (quote/text quoted-name)) + (cell-name + (new-variable-cache-variable name `(ASSIGNMENT-CACHE ,name))) + (old-value-name (compat/new-name name)) + (value-name (compat/new-name 'VALUE))) + `(LET ((,value-name ,value)) + (LET ((,cell-name + (CALL (QUOTE ,%variable-write-cache) (QUOTE #F) + ,cell ,quoted-name))) + ,(if (compat/ignore-assignment-traps? name) + + `(CALL (QUOTE ,%variable-cell-set!) + ,cont + (LOOKUP ,cell-name) + (LOOKUP ,value-name)) + + `(LET ((,old-value-name (CALL (QUOTE ,%variable-cell-ref) + (QUOTE #F) + (LOOKUP ,cell-name)))) + (IF (IF (CALL (QUOTE ,%reference-trap?) + (QUOTE #F) + (LOOKUP ,old-value-name)) + (CALL (QUOTE ,%unassigned?) + (QUOTE #F) + (LOOKUP ,old-value-name)) + (QUOTE #T)) + (CALL (QUOTE ,%variable-cell-set!) + ,cont + (LOOKUP ,cell-name) + (LOOKUP ,value-name)) + (CALL (QUOTE ,%hook-variable-cell-set!) + ,cont + (LOOKUP ,cell-name) + (LOOKUP ,value-name))))))))))) + +(define (compat/verify-cache cell name) + (if (and (LOOKUP/? cell) + (QUOTE/? name)) + 'ok + (internal-error "Unexpected arguments to variable cache operation" + cell name))) + +(define (compat/verify-hook-continuation cont) + (if (or (QUOTE/? cont) + (LOOKUP/? cont) + (CALL/%stack-closure-ref? cont)) + 'ok + (internal-error "Unexpected continuation to out-of-line hook" cont))) + +(let ((known-operator->primitive + (lambda (env rator cont rands) + (compat/->stack-closure + env cont (cddr rands) + (lambda (cont*) + `(CALL ,(compat/remember `(QUOTE ,%primitive-apply/compatible) + rator) + ,cont* + ,(compat/expr env (car rands)) ; Primitive + ,(compat/expr env (cadr rands)))))))) ; Arity + + ;; Because these are reflected into the standard C coded primitives, + ;; there's no reason to target the machine registers -- they'd wind + ;; up on the Scheme stack anyway since that's the only place C can + ;; see them! + (define-rewrite/compat %primitive-apply known-operator->primitive)) + + +(define (compat/->stack-closure env cont rands gen) + (define (compat/->stack-names rands) + (compat/uniquify-append + '() + (lmap compat/expression->name + rands))) + + (define (compat/->stack-frame names) + (list->vector (cons (car names) (reverse (cdr names))))) + + (let* ((cont (compat/expr env cont))) + (define (fail) + (internal-error "Illegal continuation" cont)) + (define (default cont-name cont) + (let ((names + (cons cont-name (compat/->stack-names rands)))) + `(CALL (QUOTE ,%make-stack-closure) + (QUOTE #F) + (QUOTE #F) ; magic cookie + (QUOTE ,(compat/->stack-frame names)) + ,cont + ,@(compat/expr* env (reverse rands))))) + (cond ((LOOKUP/? cont) + (gen (default (lookup/name cont) cont))) + ((CALL/%make-stack-closure? cont) + (let ((cont-var (new-continuation-variable))) + `(CALL + (LAMBDA (,cont-var) + ,(gen (default cont-var `(LOOKUP ,cont-var)))) + ,cont))) + ((CALL/%stack-closure-ref? cont) + (gen (default (cadr (list-ref cont 5)) cont))) + (else (fail))))) + +(let () + (define (define-primitive-call rator arity name) + (let ((prim (make-primitive-procedure name))) + (define-rewrite/compat rator + (lambda (env rator cont rands) + rator ; ignored + (compat/->stack-closure + env cont rands + (lambda (cont*) + `(CALL (QUOTE ,%primitive-apply/compatible) + ,cont* + (QUOTE ,arity) + (QUOTE ,prim)))))))) + + (define (define-truncated-call rator arity name) + (let ((prim (make-primitive-procedure name))) + (define-rewrite/compat rator + (lambda (env rator cont rands) + rator ; ignored + (compat/->stack-closure + env cont (list-head rands arity) + (lambda (cont*) + `(CALL (QUOTE ,%primitive-apply/compatible) + ,cont* + (QUOTE ,arity) + (QUOTE ,prim)))))))) + + (define (define-global-call rator arity name) + (define-rewrite/compat rator + (lambda (env rator cont rands) + rator ; ignored + (let ((desc (list name arity))) + ;; This way ensures it works with very small numbers of + ;; argument registers: + (compat/rewrite-call env + `(QUOTE ,%invoke-remote-cache) + cont + (cons* `(QUOTE ,desc) + `(QUOTE #F) + rands)))))) + + (define-primitive-call %*define 3 'LOCAL-ASSIGNMENT) + (define-primitive-call %execute 2 'SCODE-EVAL) + + (define-global-call %*define* 3 'DEFINE-MULTIPLE) + (define-global-call %*make-environment false '*MAKE-ENVIRONMENT) + (define-global-call %copy-program 1 'COPY-PROGRAM) + + ;; *** Until the full version is implemented *** + ;; The parameters dropped are the expected depth and offset. + + (define-truncated-call %*lookup 2 'LEXICAL-REFERENCE) + (define-truncated-call %*set! 3 'LEXICAL-ASSIGNMENT) + (define-truncated-call %*unassigned? 2 'LEXICAL-UNASSIGNED?)) + + +#| Test: + +(set! *rtlgen/argument-registers* '#(2 6)) + +(let ((fv1 '#(save1 save2 save3))) + (kmp/pp + (compat/expr + '() + `(call (lookup proc) + (call ',%make-stack-closure + '#f + (lambda (k val1 val2 val3 val4) + (let ((frame (call ',%fetch-stack-closure '#f ',fv1))) + (call (lookup val4) + (call ',%stack-closure-ref + '#F + (lookup frame) + (call ',%vector-index '#F ',fv1 'save2) + 'save2) + (lookup val2) + '1000))) + ',fv1 + 's1 + 's2 + 's3) + 'arg1 + 'arg2 + 'arg3)))) +|# \ No newline at end of file diff --git a/v8/src/compiler/midend/copier.scm b/v8/src/compiler/midend/copier.scm new file mode 100644 index 000000000..4bbd03a23 --- /dev/null +++ b/v8/src/compiler/midend/copier.scm @@ -0,0 +1,140 @@ +;;; -*- Scheme -*- + +(declare (usual-integrations)) + +(define (copier/top-level program remember) + (copier/expr remember program)) + +(define-macro (define-copier-handler keyword bindings . body) + (let ((proc-name (symbol-append 'COPIER/ keyword))) + (call-with-values + (lambda () (%matchup (cdr bindings) '(handler state) '(cdr form))) + (lambda (names code) + `(define ,proc-name + (let ((handler (lambda ,(cons (car bindings) names) ,@body))) + (named-lambda (,proc-name state form) + (copier/remember ,code + form)))))))) + +(define-copier-handler LOOKUP (state name) + state ; ignored + `(LOOKUP ,name)) + +(define-copier-handler LAMBDA (state lambda-list body) + `(LAMBDA ,lambda-list + ,(copier/expr state body))) + +(define-copier-handler CALL (state rator cont #!rest rands) + `(CALL ,(copier/expr state rator) + ,(copier/expr state cont) + ,@(copier/expr* state rands))) + +(define-copier-handler LET (state bindings body) + `(LET ,(lmap (lambda (binding) + (list (car binding) + (copier/expr state (cadr binding)))) + bindings) + ,(copier/expr state body))) + +(define-copier-handler LETREC (state bindings body) + `(LETREC ,(lmap (lambda (binding) + (list (car binding) + (copier/expr state (cadr binding)))) + bindings) + ,(copier/expr state body))) + +(define-copier-handler QUOTE (state object) + state ; ignored + `(QUOTE ,object)) + +(define-copier-handler DECLARE (state #!rest anything) + state ; ignored + `(DECLARE ,@anything)) + +(define-copier-handler BEGIN (state #!rest actions) + `(BEGIN ,@(copier/expr* state actions))) + +(define-copier-handler IF (state pred conseq alt) + `(IF ,(copier/expr state pred) + ,(copier/expr state conseq) + ,(copier/expr state alt))) + +(define-copier-handler SET! (state name value) + `(SET! ,name ,(copier/expr state value))) + +(define-copier-handler ACCESS (state name env-expr) + `(ACCESS ,name ,(copier/expr state env-expr))) + +(define-copier-handler UNASSIGNED? (state name) + state ; ignored + `(UNASSIGNED? ,name)) + +(define-copier-handler OR (state pred alt) + `(OR ,(copier/expr state pred) + ,(copier/expr state alt))) + +(define-copier-handler DELAY (state expr) + `(DELAY ,(copier/expr state expr))) + +(define-copier-handler DEFINE (state name value) + `(DEFINE ,name ,(copier/expr state value))) + +(define-copier-handler IN-PACKAGE (state envexpr bodyexpr) + `(IN-PACKAGE ,(copier/expr state envexpr) + ,(copier/expr state bodyexpr))) + +(define-copier-handler THE-ENVIRONMENT (state) + state ; ignored + `(THE-ENVIRONMENT)) + + +(define (copier/expr state expr) + (if (not (pair? expr)) + (illegal expr)) + (state (case (car expr) + ((QUOTE) + (copier/quote state expr)) + ((LOOKUP) + (copier/lookup state expr)) + ((LAMBDA) + (copier/lambda state expr)) + ((LET) + (copier/let state expr)) + ((DECLARE) + (copier/declare state expr)) + ((CALL) + (copier/call state expr)) + ((BEGIN) + (copier/begin state expr)) + ((IF) + (copier/if state expr)) + ((LETREC) + (copier/letrec state expr)) + ((SET!) + (copier/set! state expr)) + ((UNASSIGNED?) + (copier/unassigned? state expr)) + ((OR) + (copier/or state expr)) + ((DELAY) + (copier/delay state expr)) + ((ACCESS) + (copier/access state expr)) + ((DEFINE) + (copier/define state expr)) + ((IN-PACKAGE) + (copier/in-package state expr)) + ((THE-ENVIRONMENT) + (copier/the-environment state expr)) + (else + (illegal expr))) + expr)) + +(define (copier/expr* state exprs) + (lmap (lambda (expr) + (copier/expr state expr)) + exprs)) + +(define-integrable (copier/remember new old) + old ; ignored for now and forever + new) diff --git a/v8/src/compiler/midend/cpsconv.scm b/v8/src/compiler/midend/cpsconv.scm new file mode 100644 index 000000000..ce0d1e588 --- /dev/null +++ b/v8/src/compiler/midend/cpsconv.scm @@ -0,0 +1,539 @@ +#| -*-Scheme-*- + +$Id: cpsconv.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Continuation-passing style Converter +;;; package: (compiler midend) + +(declare (usual-integrations)) + +(define (cpsconv/top-level program) + (let ((name (new-continuation-variable))) + `(LET ((,name (CALL (QUOTE ,%fetch-continuation) (QUOTE #F)))) + ,(cpsconv/expr (cpsconv/named-continuation name) + program)))) + +(define-macro (define-cps-converter keyword bindings . body) + (let ((proc-name (symbol-append 'CPSCONV/ keyword))) + (call-with-values + (lambda () (%matchup (cdr bindings) '(handler cont) '(cdr form))) + (lambda (names code) + `(define ,proc-name + (let ((handler (lambda ,(cons (car bindings) names) ,@body))) + (named-lambda (,proc-name cont form) + (cpsconv/remember ,code + form)))))))) + +(define-cps-converter LOOKUP (cont name) + (cpsconv/return cont `(LOOKUP ,name))) + +(define-cps-converter LAMBDA (cont lambda-list body) + (cpsconv/return cont + (cpsconv/lambda* lambda-list body))) + +#| +(define-cps-converter LET (cont bindings body) + (cpsconv/call** (lmap cpsconv/classify-let-binding bindings) + (lambda (names* rands*) + `(LET ,(map list names* rands*) + ,(cpsconv/expr cont body))))) +|# + +(define (cpsconv/let cont form) + (cpsconv/remember + (let ((bindings (cadr form)) + (body (caddr form))) + (cpsconv/call** (lmap cpsconv/classify-let-binding bindings) + (lambda (names* rands*) + `(LET ,(map list names* rands*) + ,(cpsconv/expr cont body))) + form)) + form)) + +(define-cps-converter LETREC (cont bindings body) + `(LETREC ,(lmap (lambda (binding) + (let ((value (cadr binding))) + (list (car binding) + (cpsconv/lambda* (cadr value) (caddr value))))) + bindings) + ,(cpsconv/expr cont body))) + +(define (cpsconv/lambda* lambda-list body) + `(LAMBDA ,lambda-list + ,(cpsconv/expr (cpsconv/named-continuation (car lambda-list)) + body))) + +#| +(define-cps-converter CALL (cont rator orig-cont #!rest rands) + (if (not (equal? orig-cont '(QUOTE #F))) + (internal-error "Already cps-converted?" + `(CALL ,rator ,orig-cont ,@rands))) + (cpsconv/call* cont rator rands)) +|# + +(define (cpsconv/call cont form) + (cpsconv/remember + (let ((rator (call/operator form)) + (orig-cont (call/continuation form)) + (rands (call/operands form))) + (if (not (equal? orig-cont '(QUOTE #F))) + (internal-error "Already cps-converted?" + `(CALL ,rator ,orig-cont ,@rands))) + (cpsconv/call* cont rator rands form)) + form)) + +(define (cpsconv/call* cont rator rands form) + (let* ((do-call + (lambda (elements names call-gen) + (cpsconv/call** (map cpsconv/classify-operand elements names) + call-gen + form))) + (default + (lambda () + (let ((rator&rands (cons rator rands))) + (do-call rator&rands + (lmap (lambda (x) + x ; ignored + false) + rator&rands) + (lambda (new-names rator*&rands*) + new-names ; ignored + `(CALL ,(car rator*&rands*) + ,(cpsconv/invocation/continuation cont) + ,@(cdr rator*&rands*))))))) + (simple + (lambda (expr*) + (cond ((not (simple-operator? (cadr rator))) + (cpsconv/hook-return (cadr rator) cont expr*)) + ((operator/satisfies? (cadr rator) '(UNSPECIFIC-RESULT)) + `(BEGIN + ,expr* + ,(cpsconv/return cont `(QUOTE ,%unspecific)))) + (else + (cpsconv/return cont expr*)))))) + (cond ((LAMBDA/? rator) + (if (there-exists? rands + (lambda (rand) + (or (LOOKUP/? rand) + (QUOTE/? rand)))) + (internal-error "Silly arguments in lambda-combination" rands)) + (let ((names (lambda/formals rator))) + (do-call rands (cdr names) + (lambda (names* rands*) + `(CALL (LAMBDA ,(cons (cpsconv/new-ignored-continuation) + names*) + ,(cpsconv/expr cont (caddr rator))) + (QUOTE #F) + ,@rands*))))) + ((not (QUOTE/? rator)) + (default)) + ((and (simple-operator? (quote/text rator)) + (for-all? rands form/simple&side-effect-free?)) + (simple (cpsconv/simple/copy `(CALL ,rator (QUOTE #F) ,@rands)))) + ((or (simple-operator? (quote/text rator)) + (hook-operator? (quote/text rator))) + (do-call rands + (lmap (lambda (x) + x ; ignored + false) + rands) + (lambda (new-names rands*) + new-names ; ignored + (simple `(CALL ,rator (QUOTE ,#f) ,@rands*))))) + (else + (default))))) + +(define (cpsconv/call** classified-operands call-gen form) + (define (walk-simple simple) + (if (null? simple) + (call-gen + (lmap (lambda (classified) + (vector-fourth classified)) + classified-operands) + (lmap (lambda (classified) + (let ((name (vector-second classified))) + (if name + `(LOOKUP ,name) + (cpsconv/simple/copy (vector-first classified))))) + classified-operands)) + `(LET ((,(vector-second (car simple)) + ,(cpsconv/simple/copy (vector-first (car simple))))) + ,(walk-simple (cdr simple))))) + + (define (walk-hard hard) + (if (null? hard) + (walk-simple (cpsconv/sort/simple + (list-transform-positive classified-operands + (lambda (operand) + (and (vector-second operand) + (vector-third operand)))))) + (let* ((next-name (cpsconv/new-name 'RECEIVER)) + (ignore (cpsconv/new-ignored-continuation))) + `(LET ((,next-name + (LAMBDA (,ignore ,(vector-second (car hard))) + ,(walk-hard (cdr hard))))) + ,(let ((next (vector-first (car hard)))) + (cpsconv/expr + (cpsconv/value-continuation + next-name + (cpsconv/dbg-continuation/make 'RATOR-OR-RAND form next)) + next)))))) + + (walk-hard (cpsconv/sort/hard + (list-transform-negative classified-operands + (lambda (operand) + (vector-third operand)))))) + +(define (cpsconv/classify-operand operand name) + ;; operand -> #(operand early-name easy? late-name) + ;; easy? if does not need a return address + (let ((early-name + (and (not (cpsconv/trivial? operand)) + (or name + (cpsconv/new-name 'RAND))))) + (vector operand early-name + (if (eq? *order-of-argument-evaluation* 'ANY) + (form/simple&side-effect-free? operand) + (form/simple&side-effect-insensitive? operand)) + (and name + (if early-name + (cpsconv/new-name 'DUMMY) + name))))) + +(define (cpsconv/trivial? operand) + (or (LOOKUP/? operand) + (QUOTE/? operand) + (LAMBDA/? operand))) + +(define (cpsconv/classify-let-binding binding) + (let ((name (car binding)) + (operand (cadr binding))) + (let ((early-name + (and (not (cpsconv/trivial? operand)) + name))) + (vector operand early-name true + (if early-name + (cpsconv/new-name 'DUMMY) + name))))) + +(define (cpsconv/sort/hard operands) + (case *order-of-argument-evaluation* + ((LEFT-TO-RIGHT) operands) + ((RIGHT-TO-LEFT) (reverse operands)) + (else + ;; *** For now *** + operands))) + +(define (cpsconv/sort/simple operands) + ;; Either order is ANY, or they are insensitive + ;; *** For now *** + operands) + +(define (cpsconv/simple/copy form) + (let walk ((form form)) + (cpsconv/remember + (case (car form) + ((LOOKUP) + `(LOOKUP ,(cadr form))) + ((QUOTE) + `(QUOTE ,(cadr form))) + ((LAMBDA) + (cpsconv/lambda* (cadr form) (caddr form))) + ((IF) + `(IF ,(walk (cadr form)) + ,(walk (caddr form)) + ,(walk (cadddr form)))) + ((CALL) + (if (not (equal? (call/continuation form) '(QUOTE #F))) + (internal-error "Already cps-converted?" form)) + `(CALL ,(walk (call/operator form)) + ,@(lmap walk (call/cont-and-operands form)))) + (else + (internal-error "Non simple expression" form))) + form))) + +(define-cps-converter QUOTE (cont object) + (cpsconv/return cont `(QUOTE ,object))) + +(define-cps-converter DECLARE (cont #!rest anything) + (cpsconv/return cont `(DECLARE ,@anything))) + +#| +(define-cps-converter BEGIN (cont #!rest actions) + (if (null? actions) + (internal-error "Empty begin") + (let walk ((next (car actions)) + (actions (cdr actions))) + (if (null? actions) + (cpsconv/expr cont next) + (let ((next-name (cpsconv/new-name 'NEXT)) + (ignore (cpsconv/new-ignored-continuation))) + `(LET ((,next-name + (LAMBDA (,ignore) + ,(walk (car actions) + (cdr actions))))) + ,(cpsconv/expr + (cpsconv/begin-continuation + next-name + (cspconv/dbg-continuation/make 'BEGIN + <> + next)) + next))))))) + +(define-cps-converter IF (cont pred conseq alt) + ;; This does anchor pointing by default? + (let ((consname (cpsconv/new-name 'CONS)) + (altname (cpsconv/new-name 'ALT)) + (ignore (cpsconv/new-ignored-continuation))) + `(LET ((,consname (LAMBDA (,ignore) ,(cpsconv/expr cont conseq))) + (,altname (LAMBDA (,ignore) ,(cpsconv/expr cont alt)))) + ,(cpsconv/expr + (cpsconv/predicate-continuation + consname altname + (cpsconv/dbg-continuation/make 'PREDICATE <> pred)) + pred)))) +|# + +(define (cpsconv/begin cont form) + (cpsconv/remember + (let ((actions (cdr form))) + (if (null? actions) + (internal-error "Empty begin") + (let walk ((next (car actions)) + (actions (cdr actions))) + (if (null? actions) + (cpsconv/expr cont next) + (let ((next-name (cpsconv/new-name 'NEXT)) + (ignore (cpsconv/new-ignored-continuation))) + `(LET ((,next-name + (LAMBDA (,ignore) + ,(walk (car actions) + (cdr actions))))) + ,(cpsconv/expr + (cpsconv/begin-continuation + next-name + (cpsconv/dbg-continuation/make 'BEGIN form next)) + next))))))) + form)) + +(define (cpsconv/if cont form) + (cpsconv/remember + (let ((pred (if/predicate form)) + (conseq (if/consequent form)) + (alt (if/alternate form))) + (let ((consname (cpsconv/new-name 'CONS)) + (altname (cpsconv/new-name 'ALT)) + (ignore1 (cpsconv/new-ignored-continuation)) + (ignore2 (cpsconv/new-ignored-continuation))) + `(LET ((,consname (LAMBDA (,ignore1) ,(cpsconv/expr cont conseq))) + (,altname (LAMBDA (,ignore2) ,(cpsconv/expr cont alt)))) + ,(cpsconv/expr (cpsconv/predicate-continuation + consname altname + (cpsconv/dbg-continuation/make 'PREDICATE form pred)) + pred)))) + form)) + +(define (cpsconv/expr cont expr) + (if (not (pair? expr)) + (illegal expr)) + (case (car expr) + ((QUOTE) + (cpsconv/quote cont expr)) + ((LOOKUP) + (cpsconv/lookup cont expr)) + ((LAMBDA) + (cpsconv/lambda cont expr)) + ((LET) + (cpsconv/let cont expr)) + ((DECLARE) + (cpsconv/declare cont expr)) + ((CALL) + (cpsconv/call cont expr)) + ((BEGIN) + (cpsconv/begin cont expr)) + ((IF) + (cpsconv/if cont expr)) + ((LETREC) + (cpsconv/letrec cont expr)) + ((SET! UNASSIGNED? OR DELAY + ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT) + (no-longer-legal expr)) + (else + (illegal expr)))) + +(define (cpsconv/expr* cont exprs) + (lmap (lambda (expr) + (cpsconv/expr cont expr)) + exprs)) + +(define (cpsconv/remember new old) + (code-rewrite/remember new old)) + +(define (cpsconv/remember* new old) + (code-rewrite/remember* new old)) + +(define (cpsconv/new-name prefix) + (new-variable prefix)) + +(define (cpsconv/new-ignored-continuation) + (new-ignored-continuation-variable)) + +(define-structure (cpsconv/cont + (conc-name cpsconv/cont/) + (constructor cpsconv/cont/make)) + (kind false read-only true) + (field1 false read-only true) + (field2 false read-only true) + (dbg-cont false read-only true)) + +(define (cpsconv/named-continuation name) + (cpsconv/cont/make 'NAMED name false false)) + +(define (cpsconv/predicate-continuation conseq alt dbg-cont) + (cpsconv/cont/make 'PREDICATE conseq alt dbg-cont)) + +(define (cpsconv/begin-continuation next dbg-cont) + (cpsconv/cont/make 'BEGIN next false dbg-cont)) + +(define (cpsconv/value-continuation receiver dbg-cont) + (cpsconv/cont/make 'VALUE receiver false dbg-cont)) + +(define (cpsconv/dbg-continuation/make kind outer inner) + (new-dbg-continuation/make kind + (code-rewrite/original-form/previous outer) + (code-rewrite/original-form/previous inner))) + +(define (cpsconv/return cont expression) + (define (default name) + `(CALL (LOOKUP ,name) + (QUOTE #F) + ,expression)) + (if (and (not (eq? (cpsconv/cont/kind cont) 'BEGIN)) + (DECLARE/? expression)) + (internal-error "DECLARE expression in value position")) + (case (cpsconv/cont/kind cont) + ((VALUE) + (default (cpsconv/cont/field1 cont))) + ((NAMED) + `(CALL (QUOTE ,%invoke-continuation) + (LOOKUP ,(cpsconv/cont/field1 cont)) + ,expression)) + ((PREDICATE) + (let* ((pred-default + (lambda (name) + `(CALL (LOOKUP ,name) + (QUOTE #F)))) + (full-pred + (lambda () + `(IF ,expression + ,(pred-default (cpsconv/cont/field1 cont)) + ,(pred-default (cpsconv/cont/field2 cont)))))) + (cond ((QUOTE/? expression) + (case (boolean/discriminate (cadr expression)) + ((FALSE) + (pred-default (cpsconv/cont/field2 cont))) + ((TRUE) + (pred-default (cpsconv/cont/field1 cont))) + (else + (full-pred)))) + ((LAMBDA/? expression) + (pred-default (cpsconv/cont/field1 cont))) + (else + (full-pred))))) + ((BEGIN) + (let ((return + `(CALL (LOOKUP ,(cpsconv/cont/field1 cont)) + (QUOTE #F)))) + (if (form/simple&side-effect-free? expression) + return + `(LET ((,(cpsconv/new-name 'IGNORE) ,expression)) + ,return)))) + (else + (internal-error "Unknown continuation kind" cont)))) + +(define (cpsconv/invocation/continuation cont) + ;; This eta converts non-named continuations + ;; to make the continuations be stack closed, + ;; not the receivers, which may be shared. + (case (cpsconv/cont/kind cont) + ((NAMED) + `(LOOKUP ,(cpsconv/cont/field1 cont))) + ((VALUE) + (let ((value (cpsconv/new-name 'VALUE))) + (cpsconv/remember* + `(LAMBDA (,(cpsconv/new-ignored-continuation) ,value) + (CALL (LOOKUP ,(cpsconv/cont/field1 cont)) + (QUOTE #F) + (LOOKUP ,value))) + (cpsconv/cont/dbg-cont cont)))) + ((PREDICATE) + (let ((value (cpsconv/new-name 'VALUE))) + (cpsconv/remember* + `(LAMBDA (,(cpsconv/new-ignored-continuation) ,value) + (IF (LOOKUP ,value) + (CALL (LOOKUP ,(cpsconv/cont/field1 cont)) + (QUOTE #F)) + (CALL (LOOKUP ,(cpsconv/cont/field2 cont)) + (QUOTE #F)))) + (cpsconv/cont/dbg-cont cont)))) + ((BEGIN) + (cpsconv/remember* + `(LAMBDA (,(cpsconv/new-ignored-continuation) ,(cpsconv/new-name 'IGNORE)) + (CALL (LOOKUP ,(cpsconv/cont/field1 cont)) + (QUOTE #F))) + (cpsconv/cont/dbg-cont cont))) + (else + (internal-error "Unknown continuation kind" cont)))) + +(define (cpsconv/hook-return rator cont expr*) + (define (default) + (let ((name (cpsconv/new-name 'VALUE))) + `(LET ((,name ,expr*)) + ,(cpsconv/return cont `(LOOKUP ,name))))) + (if (not (operator/satisfies? rator '(OUT-OF-LINE-HOOK))) + (default) + (case (cpsconv/cont/kind cont) + ((PREDICATE) + (if (not (operator/satisfies? rator '(OPEN-CODED-PREDICATE))) + (default) + `(IF ,expr* + (CALL (LOOKUP ,(cpsconv/cont/field1 cont)) + (QUOTE #F)) + (CALL (LOOKUP ,(cpsconv/cont/field2 cont)) + (QUOTE #F))))) + ((NAMED) + `(CALL ,(cadr expr*) + (LOOKUP ,(cpsconv/cont/field1 cont)) + ,@(cdddr expr*))) + (else + (default))))) \ No newline at end of file diff --git a/v8/src/compiler/midend/dataflow.scm b/v8/src/compiler/midend/dataflow.scm new file mode 100644 index 000000000..e159e0c96 --- /dev/null +++ b/v8/src/compiler/midend/dataflow.scm @@ -0,0 +1,2286 @@ +#| -*-Scheme-*- + +$Id: dataflow.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; ?? +;;; package: (compiler midend) + +(declare (usual-integrations)) + +(define *dataflow-report-applied-non-procedures?* #T) +(define *node-count*) + +(define (dataflow/top-level program) + (let* ((env (dataflow/make-env)) + (graph (make-graph program)) + (result-node (dataflow/expr env graph program))) + (fluid-let ((*node-count* (graph/node-count graph))) + (if result-node + (initial-link-nodes! result-node (graph/escape-node graph))) + (dataflow/make-globals-escape! env graph) + (if (> (graph/node-count graph) 5000) + (pp `(big graph: ,(graph/node-count graph) nodes))) + ((if (graph/interesting? graph) + show-time + (lambda (thunk) (thunk))) + (lambda () + (graph/initialize-links! graph) + (graph/dataflow! graph))) + (graph/substitite-simple-constants graph graph/read-eqv?-preserving-constant?) + (if (graph/interesting? graph) + (graph/display-statistics! graph)) + graph))) + +(define (graph/interesting? g) + #F + ;(> (graph/node-count g) 10000) +) + + +(define-macro (define-dataflow-handler keyword bindings . body) + (let ((proc-name (symbol-append 'DATAFLOW/ keyword))) + (call-with-values + (lambda () (%matchup (cdddr bindings) '(handler env graph form) '(cdr form))) + (lambda (names code) + `(define ,proc-name + (let ((handler (lambda ,(cons* (car bindings) (cadr bindings) 'form names) + ,@body))) + (named-lambda (,proc-name env graph form) + (let ((result ,code)) + (graph/associate! graph form result) + result)))))))) + +;; handler: env x graph! x fields -> node + + +(define-dataflow-handler LOOKUP (env graph form name) + (let* ((reference-node (dataflow/name->node env graph name)) + (result-node (graph/add-expression-node! graph form name))) + (if (not reference-node) + (internal-error "LOOKUP: Cant find:" name)) + (initial-link-nodes! reference-node result-node) + result-node)) + + +(define-dataflow-handler SET! (env graph form name expr) + ;; This version models the MIT scheme SET! form which returns the + ;; previous value of the binding. + (let ((expr-node (dataflow/expr env graph expr)) + (name-node (dataflow/name->node env graph name)) + (result-node (graph/add-expression-node! graph form "#[set!-result]"))) + (initial-link-nodes! expr-node name-node) + (initial-link-nodes! name-node result-node) + result-node)) + + +(define-dataflow-handler DEFINE (env graph form name expr) + ;; DEFINE is like SET!, except that the value is unspecified previous + ;; value of the binding. The node for the name is in the + ;; environment because it is put there by scanning for defines in + ;; BEGIN. + form ; ignore + (let ((expr-node (dataflow/expr env graph expr)) + (name-node (dataflow/name->node env graph name))) + (initial-link-nodes! expr-node name-node) + #F)) + +(define (dataflow/name->node env graph name) + ;; Lookup name, possibly creating a global node for the name if it is + ;; global and we do not yet know about the name. In this case we + ;; ensure that the value escapes (some other program may copy the + ;; variable) and the values comming from that variable are unknown + ;; (some other program may set the variable). + (let* ((binding (dataflow/env/lookup env name)) + (ref-node (or + (and binding (dataflow/binding/value binding)) + (let ((value (graph/add-location-node! graph + 'global-variable + name))) + (dataflow/env/define-global! env name value) + value)))) + ref-node)) + + +;; A distinction is made between before and after CPS conversion. After +;; CPS conversion procedures do not `return' results, so we need not +;; create nodes for the procedure results. It is important not to +;; create these nodes for performance reasons because they all form a +;; huge equivalence class. + +(define-dataflow-handler LAMBDA (env graph form lambda-list body) + (let* ((input-names (lambda-list->names lambda-list)) + (input-nodes (map (lambda (name) (graph/add-location-node! graph form name)) + input-names)) + (body-node (dataflow/expr (dataflow/env/push-frame env + input-names + input-nodes) + graph body)) + (result-node (and body-node + (graph/add-expression-node! + graph form "#[procedure-result]"))) + (procedure-node (graph/add-location-node! graph form + "#[procedure-value]")) + (value (graph/add-procedure! + graph form input-nodes result-node))) + (if (eq? body-node #F) + (if *after-cps-conversion?* + 'ok + (error "CPS procedure returns result " form)) + (if *after-cps-conversion?* + (error "Pre-CPS procedure returns not result " form) + (initial-link-nodes! body-node result-node))) + (add! procedure-node value node/initial-values set-node/initial-values!) + procedure-node)) + + + +(define-dataflow-handler LET (env graph form bindings body) + (dataflow/let-like-handler "#[let-result]" #F + env graph form bindings body)) + +(define-dataflow-handler LETREC (env graph form bindings body) + (dataflow/let-like-handler "#[letrec-result]" #T + env graph form bindings body)) + +(define (dataflow/let-like-handler result-name recursive? + env graph form bindings body) + (let* ((binding-names (map (lambda (x) (car x)) bindings)) + (binding-exprs (map (lambda (x) (second x)) bindings)) + (binding-nodes (map (lambda (name) (graph/add-location-node! graph form name)) + binding-names)) + (inner-env (dataflow/env/push-frame env binding-names binding-nodes)) + (expr-nodes (dataflow/expr* (if recursive? inner-env env) + graph binding-exprs)) + (body-node (dataflow/expr inner-env graph body)) + (result-node (and body-node + (graph/add-expression-node! graph form result-name)))) + + (map initial-link-nodes! expr-nodes binding-nodes) + (if result-node + (initial-link-nodes! body-node result-node)) + result-node)) + + +(define-dataflow-handler QUOTE (env graph form object) + env object ; ignore + (graph/add-constant-node! graph form)) + + +(define-dataflow-handler DECLARE (env graph form #!rest anything) + env graph ; ignored + form anything + 'declaration-does-not-have-a-node) + + +(define-dataflow-handler BEGIN (env graph form #!rest actions) + ;; Only top-level BEGINs contain DEFINEs but this code show work for + ;; internal defines too, had they not been converted to #!AUXes and + ;; then (a little later) LET[REC]s + (dataflow/scan-defines! actions env graph) + (let* ((nodes (dataflow/expr* env graph actions)) + (last-node (car (last-pair nodes))) + (result-node (and last-node + (graph/add-expression-node! graph form + "#[begin-result]")))) + (if (node? result-node) + (initial-link-nodes! last-node result-node)) + result-node)) + + +(define (dataflow/scan-defines! forms env graph) + (define names '()) + (define defines '()) + (define (scan forms) + (cond ((null? forms) + unspecific) + ((not (and (pair? forms) (pair? (car forms)))) + (user-error "scan-defines - not legal KMP scheme: " forms)) + ((eq? (caar forms) 'BEGIN) + (dataflow/scan-defines! (cdr (car forms)) env graph) + (scan (cdr forms))) + ((eq? (caar forms) 'DEFINE) + (set! names (cons (second (car forms)) names)) + (set! defines (cons (car forms) defines)) + (scan (cdr forms))) + (else + (scan (cdr forms))))) + (scan forms) + (dataflow/env/extend-frame! + env + names + (map (lambda (name defn) (graph/add-location-node! graph defn name)) + names defines))) + + +(define-dataflow-handler IF (env graph form pred conseq alt) + (let ((predicate-node (dataflow/expr env graph pred)) + (consequent-node (dataflow/expr env graph conseq)) + (alternative-node (dataflow/expr env graph alt))) + (let ((result-node (and consequent-node + alternative-node + (graph/add-expression-node! graph form + "#[if-result]")))) + predicate-node ; unused + (cond ((node? result-node) + (initial-link-nodes! consequent-node result-node) + (initial-link-nodes! alternative-node result-node)) + ((or (node? consequent-node) + (node? alternative-node)) + (internal-error "Mismatch between CPS states of branches" + consequent-node alternative-node form))) + result-node))) + + +(define-dataflow-handler OR (env graph form pred alt) + (let ((predicate-node (dataflow/expr env graph pred)) + (alternative-node (dataflow/expr env graph alt)) + (result-node (graph/add-expression-node! graph form + "#[or-result]"))) + ;; No worry about CPS style as OR is removed before CPS conversion + (initial-link-nodes! predicate-node result-node) + (initial-link-nodes! alternative-node result-node) + result-node)) + + +(define-dataflow-handler ACCESS (env graph form name env-expr) + (let* ((env-node (dataflow/expr env graph env-expr)) + (result-node (graph/add-expression-node! graph form + "#[access-result]"))) + ;; IF env is system-global-environment and the name is standard (like + ;; cons, car, apply, append etc) we should do something better. + env-node name + (initial-link-nodes! (graph/unknown-input-node graph) result-node) + result-node)) + + +(define-dataflow-handler CALL (env graph form rator cont #!rest rands) + (let* ((special-result + (dataflow/handler/special-call env graph form rator cont rands)) + (result + (if (eq? special-result 'ORDINARY) + (dataflow/handler/ordinary-call env graph form rator cont rands) + special-result))) + (if (or (and (node? result) (not (equal? cont '(QUOTE #F)))) + (and (not (node? result)) (equal? cont '(QUOTE #F)))) + (internal-error "result/CPS mismatch" result form)) + result)) + +(define (dataflow/handler/ordinary-call env graph form rator cont rands) + (let* ((operator-node (dataflow/expr env graph rator)) + (operand-nodes (dataflow/expr* env graph rands)) + (direct-style? (equal? cont '(QUOTE #F))) + (cont-node (if direct-style? #F (dataflow/expr env graph cont))) + (result-node (if direct-style? + (graph/add-expression-node! graph form + "#[call-result]") + (graph/add-location-node! graph form + "#[call-result]")))) + (graph/add-application! graph form + operator-node + (cons cont-node operand-nodes) + result-node) + (and direct-style? result-node))) + + +(define (dataflow/handler/special-call env graph form rator cont rands) + (if (QUOTE/? rator) + (let ((operator (quote/text rator))) + (define (use method) (method env graph form rator cont rands)) + (cond ((eq? operator %make-heap-closure) + (use dataflow/handler/%make-heap-closure)) + ((eq? operator %make-stack-closure) + (use dataflow/handler/%make-stack-closure)) + ((eq? operator %make-trivial-closure) + (use dataflow/handler/%make-trivial-closure)) + ((eq? operator %heap-closure-ref) + (use dataflow/handler/%heap-closure-ref)) + ((eq? operator %stack-closure-ref) + (use dataflow/handler/%stack-closure-ref)) + ((eq? operator %internal-apply) + (use dataflow/handler/%internal-apply)) + ((eq? operator %fetch-stack-closure) + (use dataflow/handler/%fetch-stack-closure)) + ((eq? operator %fetch-continuation) + (use dataflow/handler/%fetch-continuation)) + ((eq? operator %invoke-continuation) + (use dataflow/handler/%invoke-continuation)) + ;;((eq? operator %invoke-operator-cache) + ;; (use dataflow/handler/%invoke-operator-cache)) + (else + 'ORDINARY))) + 'ORDINARY)) + + +(define (dataflow/handler/%make-heap-closure env graph form rator cont rands) + ;; (CALL ',%make-heap-closure '#F '#(name*) *) + ;; -------rator-------- cont ---------------rands--------------- + ;; + rator cont ; ignore + (let* ((lambda-expr (first rands)) + (value-exprs (cddr rands)) + (closure-name (second (second lambda-expr))) ; (LAMBDA (k ...)) + (names-vector (second (second rands))) + + (lambda-node (dataflow/expr env graph lambda-expr)) + (expr-nodes (dataflow/expr* env graph value-exprs)) + (closed-names (map (lambda (name) (cons closure-name name)) + (vector->list names-vector))) + (closed-nodes (map (lambda (name) (graph/add-location-node! + graph form name)) + closed-names)) + (procedure (node/the-procedure-value lambda-node)) + (closure-node (graph/add-expression-node! graph form + "#[heap-closure-value]")) + (value (graph/add-closure! graph + form + 'HEAP + procedure + names-vector + (list->vector closed-nodes) + closure-node))) + + (map initial-link-nodes! expr-nodes closed-nodes) + (add! closure-node value node/initial-values set-node/initial-values!) + (graph/add-special-application! graph form + %make-heap-closure + expr-nodes + '() ; no triggers + closure-node) + closure-node)) + + + +(define dataflow/?closure-elts (->pattern-variable 'CLOSURE-ELTS)) +(define dataflow/?closure-vector (->pattern-variable 'CLOSURE-VECTOR)) +(define dataflow/?cont (->pattern-variable 'CONT)) +(define dataflow/?expr1 (->pattern-variable 'EXPR1)) +(define dataflow/?expr2 (->pattern-variable 'EXPR2)) +(define dataflow/?args (->pattern-variable 'ARGS)) +(define dataflow/?frame-var (->pattern-variable 'FRAME-VAR)) +(define dataflow/?nrands (->pattern-variable 'NRANDS)) +(define dataflow/?rands (->pattern-variable 'RANDS)) +(define dataflow/?lam-expr (->pattern-variable 'LAM-EXPR)) + +(define dataflow/stack-closure-pattern + `(CALL (QUOTE ,%make-stack-closure) + (QUOTE #F) + (LAMBDA (,dataflow/?cont ,@dataflow/?args) + (LET ((,dataflow/?frame-var ,dataflow/?expr1)) + ,dataflow/?expr2)) + (QUOTE ,dataflow/?closure-vector) + . ,dataflow/?closure-elts)) + +(define dataflow/implicit-stack-frame + (generate-uninterned-symbol "*STACK-FRAME*")) + +(define (dataflow/handler/%make-stack-closure env graph form rator cont rands) + ;; (CALL ',%make-stack-closure '#F '#(name*) *) + ;; -------rator-------- cont ---------------rands--------------- + ;; push a frame on the environment for the closed-over variables. The + ;; variables are named as pairs (closure . variable) + rator cont ; ignore + (let* ((lambda-expr (first rands)) + (parts (form/match dataflow/stack-closure-pattern form)) + (closure-name (cadr (assq dataflow/?frame-var parts))) + (names-vector (cadr (assq dataflow/?closure-vector parts))) + (value-exprs (cadr (assq dataflow/?closure-elts parts))) + (closed-names (map (lambda (name) (cons closure-name name)) + (vector->list names-vector))) + (closed-nodes (map (lambda (name) (graph/add-location-node! + graph form name)) + closed-names)) + (closure-node (graph/add-expression-node! graph form + "#[stack-closure-value]")) + (inner-env (dataflow/env/push-frame env + (list dataflow/implicit-stack-frame) + (list closure-node))) + (lambda-node (dataflow/expr inner-env graph lambda-expr)) + (procedure (node/the-procedure-value lambda-node)) + (expr-nodes (dataflow/expr* env graph value-exprs)) + (value (graph/add-closure! graph + form + 'STACK + procedure + names-vector + (list->vector closed-nodes) + closure-node))) + + (map initial-link-nodes! expr-nodes closed-nodes) + (add! closure-node value node/initial-values set-node/initial-values!) + (graph/add-special-application! graph form + %make-stack-closure + expr-nodes + '() ; no triggers + closure-node) + closure-node)) + +(define (dataflow/handler/%fetch-stack-closure env graph form rator cont rands) + ;; (CALL ',%fetch-stack-closure '#F ') + ;; --------rator--------- cont ----rands----- + ;; + rator cont rands ; ignore + (let* ((closure-node + (dataflow/name->node env graph dataflow/implicit-stack-frame)) + (result-node + (graph/add-expression-node! graph form + "#[fetch-stack-closure-result]"))) + (initial-link-nodes! closure-node result-node) + result-node)) + + +(define (dataflow/handler/%make-trivial-closure env graph form rator cont rands) + ;; (CALL ',%make-trivial-closure '#F ) + ;; --------rator---------- cont -----------rands------------ + ;; Initially we add the closure with a NODE for the procedure part. + ;; After initial value propagation replace this with the procedure value. + rator cont ; ignore + (define (finish lambda-node) + (let* ((closure-node (graph/add-expression-node! graph form + "#[trivial-closure]")) + (value (graph/add-closure! graph + form + 'TRIVIAL + lambda-node ;procedure + #() + #() + closure-node))) + (add! closure-node value node/initial-values set-node/initial-values!) + closure-node)) + + (let* ((procedure-expr (first rands))) + (cond ((LOOKUP/? procedure-expr) + ;; This occurs in a really wierd screw-case, documented elsewhere. + ;; The in (LOOKUP ) is bound to the lambda, so we + ;; can find the lambda node by searching the initial links + ;; backwards + (finish + (dataflow/name->node env graph (lookup/name procedure-expr)))) + ((LAMBDA/? procedure-expr) + (finish (dataflow/expr env graph procedure-expr))) + (else + (internal-error "Procedure is neither LAMBDA nor LOOKUP" form))))) + + +(define (graph/initialize-closure-procedures! graph) + (define (fix-closure-procedure closure) + (if (eq? 'TRIVIAL (value/closure/kind closure)) + (let ((proc-node (value/closure/procedure closure))) + (set-value/closure/procedure! closure + (node/the-procedure-value proc-node))))) + (for-each-item fix-closure-procedure (graph/closures graph))) + + +(define (dataflow/handler/%heap-closure-ref env graph form rator cont rands) + ;; (CALL ',%heap-closure-ref '#F 'NAME) + ;; -------rator------- cont ---------------rands--------------- + ;; is always (LOOKUP closure-name) + rator cont ; ignore + (let* ((closure-node (dataflow/expr env graph (first rands))) + (result-node (graph/add-expression-node! graph form + (second (third rands))))) + + (graph/add-special-application! graph form + %heap-closure-ref + (list closure-node) + (list closure-node) + result-node) + result-node)) + + +(define (dataflow/handler/%stack-closure-ref env graph form rator cont rands) + ;; (CALL ',%stack-closure-ref '#F 'NAME) + ;; -------rator------- cont ---------------rands--------------- + ;; is always (LOOKUP closure-name) + rator cont ; ignore + (let* ((closure-node (dataflow/expr env graph (first rands))) + (result-node (graph/add-expression-node! graph form + (second (third rands))))) + + (graph/add-special-application! graph form + %stack-closure-ref + (list closure-node) + (list closure-node) + result-node) + result-node)) + + +(define (dataflow/handler/%internal-apply env graph form rator cont rands) + ;; (CALL ',%internal-apply 'NARGS *) + ;; ------rator------ -----cont----- ----------rands------------ + ;; + ;; Treated like a normal call + rator ; ignore + (let* ((operator-node (dataflow/expr env graph (second rands))) + (operand-nodes (dataflow/expr* env graph (cddr rands))) + (direct-style? (equal? cont '(QUOTE #F))) + (cont-node (if direct-style? #F (dataflow/expr env graph cont))) + (result-node (if direct-style? + (graph/add-expression-node! + graph form "#[internal-apply-result]") + (graph/add-location-node! + graph form "#[internal-apply-result]")))) + + (graph/add-application! graph form operator-node (cons cont-node operand-nodes) result-node) + (and direct-style? result-node))) + +(define (dataflow/handler/%fetch-continuation env graph form rator cont rands) + ;; (CALL ',%fetch-continuation '#F) + ;; --------rator-------- cont --no rands-- + ;; + env rator cont rands ; ignore + (let* ((result-node + (graph/add-expression-node! graph form + "#[fetch-continuation-result]")) + (value (value/make-unknown 'top-level-continuation))) + (add! result-node value node/initial-values set-node/initial-values!) + result-node)) + +(define (dataflow/handler/%invoke-continuation env graph form rator cont rands) + ;; (CALL ',%invoke-continuation *) + ;; --------rator-------- -----cont----- --rands-- + ;; The continuation could be anything and invoking it is like an + ;; application, but it will ignore its own continuation parameter + + rator ; ignore + (let* ((operator-node (dataflow/expr env graph cont)) + (operand-nodes (dataflow/expr* env graph rands)) + (bogus-continuation #F) ;(graph/add-constant-node! graph `(QUOTE #F)) + (result-node #F)) + + (graph/add-application! graph form operator-node + (cons bogus-continuation operand-nodes) + result-node) + result-node)) + + +;;(define (dataflow/handler/%invoke-operator-cache env graph form rator cont rands) +;; ;; (CALL ',%invoke-operator-cache +;; ;; '(NAME NARGS) *) +;; ;; ---------------rands-------------------- +;; rator +;; (let* ((cont-node (dataflow/expr env graph cont)) +;; (expr-nodes (dataflow/expr* env graph (cddr rands))) +;; (result-node (graph/add-node! graph form +;; "#[invoke-operator-cache-result]")) +;; (escape-node (graph/escape-node graph))) +;; (for-each (lambda (node) +;; (initial-link-nodes! node escape-node)) +;; expr-nodes) +;; (initial-link-nodes! cont-node escape-node) +;; (initial-link-nodes! (graph/unknown-input-node graph) result-node) +;; result-node)) + + + +(define (dataflow/expr env graph expr) + (if (not (pair? expr)) + (illegal expr)) + (case (car expr) + ((QUOTE) + (dataflow/quote env graph expr)) + ((LOOKUP) + (dataflow/lookup env graph expr)) + ((LAMBDA) + (dataflow/lambda env graph expr)) + ((LET) + (dataflow/let env graph expr)) + ((DECLARE) + (dataflow/declare env graph expr)) + ((CALL) + (dataflow/call env graph expr)) + ((BEGIN) + (dataflow/begin env graph expr)) + ((IF) + (dataflow/if env graph expr)) + ((LETREC) + (dataflow/letrec env graph expr)) + ((OR) + (dataflow/or env graph expr)) + ((SET!) + (dataflow/set! env graph expr)) + ((DEFINE) + (dataflow/define env graph expr)) + ((ACCESS) + (dataflow/access env graph expr)) + ((UNASSIGNED? DELAY + IN-PACKAGE THE-ENVIRONMENT) + (no-longer-legal expr)) + (else + (illegal expr)))) + +(define (dataflow/expr* env graph exprs) + (lmap (lambda (expr) + (dataflow/expr env graph expr)) + exprs)) + +(define (dataflow/remember new old) + old ; ignored for now + new) + +(define (dataflow/new-name prefix) + (new-variable prefix)) + + +(define-structure (dataflow/binding + (conc-name dataflow/binding/) + (print-procedure + (standard-unparser-method 'DATAFLOW/BINDING + (lambda (binding port) + (write-char #\Space port) + (write (dataflow/binding/name binding) port))))) + (name false read-only true) + (value false read-only false)) + +(define (dataflow/make-env) (cons '() '())) + +(define (dataflow/env/lookup env name) + (let spine-loop ((env env)) + (and (not (null? env)) + (let rib-loop ((rib (car env))) + (cond ((null? rib) + (spine-loop (cdr env))) + ((name-eq? name (dataflow/binding/name (car rib))) + (car rib)) + (else + (rib-loop (cdr rib)))))))) + +(define-integrable (name-eq? name1 name2) + (let ((name1 name1) + (name2 name2)) + (or (eq? name1 name2) + (and (pair? name1) + (pair? name2) + (eq? (car name1) (car name2)) + (eq? (cdr name1) (cdr name2)))))) + +(define-integrable dataflow/binding/make make-dataflow/binding) + +(define (dataflow/env/push-frame env names values) + (cons (map make-dataflow/binding names values) + env)) + +(define (dataflow/env/extend-frame! env names values) + (set-car! env (append! (car env) + (map make-dataflow/binding names values))) + env) + +(define (dataflow/env/global-environment env) + (let spine-loop ((env env)) + (if (null? (cdr env)) + env + (spine-loop (cdr env))))) + +(define (dataflow/env/define-global! env name value) + (let ((env (dataflow/env/global-environment env))) + (set-car! env (cons (dataflow/binding/make name value) (car env))))) + +(define (dataflow/env/for-each-global-binding procedure env) + (map procedure (car (dataflow/env/global-environment env)))) + +;;; Data flow graph +;; +;; There are two prinicipal kinds of things: NODEs which represent a +;; place in te program, and VALUE-SETs which represent the set of +;; values that may be the value of a particular expression identified +;; by the node. +;; +;; Nodes are either of class LOCATION, being an abstract storage location +;; (e.g. a formal parameter or closure `slot', or of class +;; EXPRESSION, for nodes that correspond directly to the source.) It +;; might be possible to store this value implicitly in terms of the +;; text an name fields. + +(define-structure + (node + (conc-name node/) + (constructor %make-node)) + number ; each node is numbered + text ; source code + name ; name with source code + initial-values ; list of initial values + initial-links-in + initial-links-out + values ; value-set intermediate & final values + links-in ; nodes which sink values to here + links-out ; nodes which source values from here + connectivity ; data structure for efficient + ; predicate for membership in links-in + uses/operator ; applications with this node as operator + uses/operand ; applications with this node as operand + ; or continuation + uses/trigger ; graph computations that should be + ; reconsidered when the values change + class ; LOCATION or EXPRESSION + ) + +;; Note: node/name is either a string or a symbol. Strings are used to +;; name otherwise unnamed places, like the result of an IF. Symbols +;; are used for names which occur in the program. LAMBDA-parameters +;; and LET-bindings have the parameter/binding name as node/name and +;; the binding form (i.e. the LAMBDA expression or LET expression) as +;; node/text. Thus we can distinguish the nodes representing: +;; . The LAMBDA parameter X (name=x, text=(LAMBDA (... X ...) ...)) +;; . The LAMBDA expression (name="#[procedure-expression]", text=(LAMBDA...)) +;; . The value returned by the procedure +;; (name="#[procedure-result]", text=(LAMBDA...)) +;; . The LET binding X (name=x, text=(LET (... (X ...) ...) ...)) +;; . The LET expresion result (name="...", text=(LET (... (X ...) ...) ...)) + +(define (%graph/make-node graph text name class) + graph + (let ((node (%make-node (graph/node-count graph) + text + name ; name + '() ; initial-values + '() ; initial-links-in + '() ; initial-links-out + 'NOT-CACHED ; values + (make-empty-node-set) ; links-in + (make-empty-node-set) ; links-out + #F ; connectivity + '() ; uses/operator + '() ; uses/operand + '() ; uses/trigger + class + ))) + (set-graph/node-count! graph (+ (graph/node-count graph) 1)) + node)) + + +(define (initial-link-nodes! from to) + (add! to from node/initial-links-in set-node/initial-links-in!) + (add! from to node/initial-links-out set-node/initial-links-out!)) + +(define (node/the-constant-value node) + (if (not (and (pair? (node/initial-values node)) + (null? (cdr (node/initial-values node))) + (value/constant? (car (node/initial-values node))))) + (internal-error "Constant node does not have unique value" node) + (value/constant/value (car (node/initial-values node))))) + +(define (node/the-procedure-value node) + (define (bad) + (internal-error "Node does not have an initial known procedure value" node)) + (if (null? (node/initial-values node)) + (let ((values (value-set/new-singletons (node/values node)))) + (if (and (pair? values) + (null? (cdr values)) + (value/procedure? (car values))) + (car values) + (bad))) + (if (and (pair? (node/initial-values node)) + (null? (cdr (node/initial-values node))) + (value/procedure? (car (node/initial-values node)))) + (car (node/initial-values node)) + (bad)))) + +(define (node/unique-value node) + (value-set/unique-value (node/values node))) + +(define (node/formal-parameter? node) + (and (pair? (node/text node)) + (eq? (car (node/text node)) 'LAMBDA) + (symbol? (node/name node)))) + + +(define (expression-node? node) + (eq? (node/class node) 'EXPRESSION)) + +(define (location-node? node) + (eq? (node/class node) 'LOCATION)) + + +;; +;; Values +;; + +;;(define-structure (value +;; named +;; (type vector) +;; (conc-name value/) +;; ;(constructor %make-value) +;; (predicate %value?)) +;; text ; source code resulting in this value +;; nodes ; nodes which get this value +;; ) + +(define value/subtypes '()) + +(define-macro (define-value structure-description . slots) + (let ((name (car structure-description)) + (structure-options (cdr structure-description))) + + `(BEGIN + (DEFINE-STRUCTURE + (,name + NAMED (TYPE VECTOR) + . ,structure-options) + TEXT ; source code resulting in this value + NODES ; nodes which get this value + . ,slots) + (SET! VALUE/SUBTYPES (CONS ,name VALUE/SUBTYPES))))) + + +;;(define (value? structure) +;; (and (vector? structure) +;; (memq (vector-ref structure 0) value/subtypes))) + +(define-integrable (value/text structure) (vector-ref structure 1)) +(define-integrable (value/nodes structure) (vector-ref structure 2)) + +;;(define-integrable (set-value/text! structure x) (vector-set! structure 1 x)) +(define-integrable (set-value/nodes! structure x) (vector-set! structure 2 x)) + +;;(define-integrable (value/initialize! value text) +;; (set-value/text! value text) +;; (set-value/nodes! value '()) +;; value) + + +(define-value (value/constant + (conc-name value/constant/) + (constructor %value/make-constant)) + ;; No extra fields + ) + +(define (value/make-constant text) + (%value/make-constant text '() )) + +(define (value/constant/value constant) + ;; get the quoted thing + (second (value/text constant))) + + +(define-value (value/procedure + (conc-name value/procedure/) + (constructor %value/make-procedure)) + ;; Nodes for arguments and auxes. We distinguish them by looking at the + ;; lambda list of the text slot: + input-nodes + result-node ; node for result value of procedure + ) + +(define (value/make-procedure text input-nodes result-node) + (%value/make-procedure text '() + input-nodes result-node)) + +(define (value/procedure/lambda-list procedure-value) + (second (value/text procedure-value))) + + +(define-value + (value/closure + (conc-name value/closure/) + (constructor %value/make-closure) + (print-procedure + (standard-unparser-method 'VALUE/CLOSURE + (lambda (value port) + (write-char #\space port) + (write (value/closure/kind value) port))))) + + kind ; 'HEAP or 'STACK or 'TRIVIAL + procedure ; a procedure value (lambda (k self ..)) + location-names ; vector of symbols + location-nodes ; nodes for closed-over values + ;; the SELF-NODE has this closure as its initial (and only) value + self-node + ;; CALL-SITES is a list of applications and symbols. Symbols denote + ;; external known call sites, for example, the continuation + ;; invocation implicit in &<. + call-sites + ;; ESCAPES? is #T or #F. To cause the closure to escape, link the node + ;; to the escape node (or add the value to the escape node's value + ;; set). This will cause the closure to be applied to unknown + ;; values. Setting this bit marks the closure as escaped, which + ;; might be useful if the closure partially escapes, for example, as + ;; a continuation of a known but not inlined primitive. + escapes? ; #T or #F + ) + +(define (value/closure/trivial? closure) + (eq? (value/closure/kind closure) 'TRIVIAL)) + + +(define (value/make-closure text ; e.g. (CALL '#[make-heap-closure] ...) + kind + procedure + location-names ; vector + location-nodes ; vector + self-node + ) + (%value/make-closure text '() + kind procedure location-names + location-nodes self-node + '() + #F)) + +(define (value/closure/lookup-location-node closure name) + (let* ((names (value/closure/location-names closure)) + (n (vector-length names))) + (let loop ((i 0)) + (cond ((>= i n) (internal-error "Non-closed name" name closure)) + ((eq? (vector-ref names i) name) + (vector-ref (value/closure/location-nodes closure) i)) + (else (loop (1+ i))))))) + + +(define-value (value/unknown + (conc-name value/unknown/) + (constructor %value/make-unknown)) + ) + +(define (value/make-unknown text) + (%value/make-unknown text '())) + +;; Sets of values +;; +;; A value set must collect all the known procedures and closures that +;; arrive at a node. It may also collect other values in some form. +;; + +(define value-set/print-procedure + (standard-unparser-method + 'VALUE-SET + (lambda (object port) + (cond ((value-set/unknown? object) + => (lambda (unk) + (write-string " " port) + (write unk port))) + ((value-set/unique-value object) + => (lambda (value) + (write-string " = " port) + (write value port))) + ((and (null? (value-set/singletons object)) + (null? (value-set/new-singletons object))) + (write-string " EMPTY" port)) + (else + (write-string " *" port)))))) + +(define-structure (value-set + (conc-name value-set/) + (constructor %make-value-set) + (print-procedure value-set/print-procedure)) + unknown? ;; either #F or the offending value/unknown + singletons ;; value/procedure & value/constant & value/unknown + new-singletons + other-values ;; whatever - perhaps some lattice element + ) + + +(define-integrable (make-value-set) + (%make-value-set #F '() '() '())) + +(define (value-set/unique-value set) + ;; returns the unique value or #F if there is no unique value. + ;; This procedure is valid only after dataflow. + (if (or (value-set/unknown? set) + (null? (value-set/singletons set)) + (not (null? (cdr (value-set/singletons set))))) + #F + (car (value-set/singletons set)))) + + +(define (value-set/age-value! set) + ;; Moves a singleton value from the new values to the old, and returns it. + ;; Updates unknown? slot + (if (eq-set/empty? (value-set/new-singletons set)) + #f + (let ((elt (car (value-set/new-singletons set)))) + (begin + (set-value-set/singletons! set (cons elt (value-set/singletons set))) + (set-value-set/new-singletons! set (cdr (value-set/new-singletons set))) + (if (and (value/unknown? elt) + (not (value-set/unknown? set))) + (set-value-set/unknown?! set elt)) + elt)))) + +(define (value-set/union!? set additions) + ;; Returns #t if the union operation added new elements, false if the + ;; operation turned out to be idempotent + (let* ((old-singletons (value-set/singletons set)) + (new-singletons (value-set/new-singletons set)) + (updated-singletons + (eq-set/union3-difference new-singletons + old-singletons + (value-set/new-singletons additions) + (value-set/singletons additions))) + (changed? (not (eq? new-singletons updated-singletons)))) + (set-value-set/new-singletons! set updated-singletons) + ;; 1. An unknown frob, if present, will find its way via the above proc. + ;; 2. Do something with other-values + changed?)) + +(define (value-set/union!*? set sets) + (let loop ((sets sets) (changed? #F)) + (if (null? sets) + changed? + (loop (cdr sets) (or (value-set/union!? set (car sets)) changed?))))) + +(define (value-set/add-singleton!? set value) + ;; Returns #t if the value was added, false it was already an element. + (let* ((old-singletons (value-set/singletons set)) + (new-singletons (value-set/new-singletons set))) + (cond ((memq value old-singletons) #F) + ((memq value new-singletons) #F) + (else (set-value-set/new-singletons! set (cons value new-singletons)) + #T)))) + +;; eq-sets +;; + +(define (eq-set/empty) '()) +(define (eq-set/empty? set) (null? set)) +(define (eq-set/union s1 s2) + (cond ((null? s1) s2) + ((null? s2) s1) + ((memq (car s1) s2) (eq-set/union (cdr s1) s2)) + (else (cons (car s1) (eq-set/union (cdr s1) s2))))) + +(define (eq-set/union-difference initial exclude additions) + (cond ((null? additions) + initial) + ((memq (car additions) initial) + (eq-set/union-difference initial exclude (cdr additions))) + ((memq (car additions) exclude) + (eq-set/union-difference initial exclude (cdr additions))) + (else + (cons (car additions) + (eq-set/union-difference initial exclude (cdr additions)))))) + +(define (eq-set/union3-difference new old new2 old2) + ;; This result has the property of being EQ? with new if no elements are + ;; added to the set. + (eq-set/union-difference (eq-set/union-difference new old old2) + old new2)) + +(define-structure (graph + (conc-name graph/) + (constructor %make-graph)) + program + escape-node ; values that escape collect here + unknown-input-node ; values that arrive from unknown + ; places (calls in, global vars) + nodes ; all nodes in graph + procedures ; all procedure values in graph + closures ; all closures + applications ; all call sites + ;;references ; all variable references + text->node-table + constant->node-table ; cache of constants + node-count + ) + + +(define (make-graph program) + (let* ((graph + (%make-graph program + #f ; escape-node + #f ; unknown-input-node + '() ; nodes + '() ; procedures + '() ; closures + '() ; applications + ;;'() ; references + (make-eq-hash-table) ; text->node-table + (make-eqv-hash-table) ; constant->node-table + 0 ; node-count + )) + (escape-node + (graph/add-location-node! graph 'escape-node #f)) + (unknown-input-node + (graph/add-location-node! graph 'unknown-input-node #f))) + (set-graph/escape-node! graph escape-node) + (add! escape-node 'ESCAPE-APPLICATION + node/uses/trigger set-node/uses/trigger!) + (set-graph/unknown-input-node! graph unknown-input-node) + ;; I am not sure that this is either necessary or advisable, but it + ;; ensures that the escaping nodes are fed back as possible inputs: + ;; (initial-link-nodes! escape-node unknown-input-node) + (add! unknown-input-node (value/make-unknown 'unknown-input) + node/initial-values set-node/initial-values!) + graph)) + + +(define (graph/associate! graph text node) + (hash-table/put! (graph/text->node-table graph) text node)) + +(define (graph/text->node graph text) + (hash-table/get (graph/text->node-table graph) text #F)) + + +(define (graph/add-expression-node! graph text name) + ;; Nodes corresponding to expressions in the source + (let ((node (%graph/make-node graph text name 'EXPRESSION))) + (add! graph node graph/nodes set-graph/nodes!) + node)) + +(define (graph/add-location-node! graph text name) + ;; Nodes corresponding to hidden locations (formals, bindings, cells,...) + (let ((node (%graph/make-node graph text name 'LOCATION))) + (add! graph node graph/nodes set-graph/nodes!) + node)) + +(define (graph/for-each-node graph procedure) + (for-each procedure (graph/nodes graph))) + +;; THIS USED TO BE TRUE BUT NOW WE DONT CACHE THE NODES THEMSELVES +;; Both constants and nodes are cached in the constant->node-table. +;; If the node exists the constant is the node's initial value. + +(define (graph/add-constant! graph text) + ;; Text = (QUOTE constant) + (let* ((table (graph/constant->node-table graph)) + (constant (second text)) + (cached-node (hash-table/get table constant #F))) + (cond ((value/constant? cached-node) + cached-node) + ((node? cached-node) + (car (node/initial-values cached-node))) + (else + (let* ((value (value/make-constant text))) + (hash-table/put! table constant value) + value))))) + +;;(define (graph/add-constant-node! graph text) +;; ;; Text = (QUOTE constant) +;; (let* ((table (graph/constant->node-table graph)) +;; (constant (second text)) +;; (cached-node (hash-table/get table constant #F))) +;; (if (node? cached-node) +;; cached-node +;; (let* ((value (or cached-node (value/make-constant text))) +;; (node (graph/add-node! graph text "#[constant]"))) +;; (add! node value node/initial-values set-node/initial-values!) +;; (hash-table/put! table constant node) +;; node)))) + +;;(define (graph/add-constant-node! graph text) +;; ;; Text = (QUOTE constant) +;; (let* ((value (value/make-constant text)) +;; (node (graph/add-expression-node! graph text "#[constant]"))) +;; (add! node value node/initial-values set-node/initial-values!) +;; ;;(hash-table/put! table (quote/text text) node) +;; node)) + +(define (graph/add-constant-node! graph text) + ;; Text = (QUOTE constant) + (let* ((value (graph/add-constant! graph text)) + (node (graph/add-expression-node! graph text "#[constant]"))) + (add! node value node/initial-values set-node/initial-values!) + ;;(hash-table/put! table (quote/text text) node) + node)) + +;;(define (graph/add-reference! graph text variable-node) +;; (let ((reference (value/make-reference text variable-node))) +;; (add! graph reference graph/references set-graph/references!) +;; (add! variable-node reference node/references set-node/references!) +;; reference)) + +(define (graph/add-procedure! graph text input-nodes result-node) + (let ((procedure (value/make-procedure text input-nodes result-node))) + (add! graph procedure graph/procedures set-graph/procedures!) + procedure)) + + +(define (graph/add-closure! graph text kind procedure location-names location-nodes self-node) + (let ((closure (value/make-closure + text kind procedure + location-names + location-nodes + self-node))) + (add! graph closure graph/closures set-graph/closures!) + closure)) + +(define (graph/initialize-links! graph) + + (define (connect! from to) + ;; link nodes transitively + (if (not (nodes-linked? from to)) + (begin + (link-nodes! from to) + (node-set/for-each (node/links-in from) + (lambda (from) (connect! from to))) + (node-set/for-each (node/links-out to) + (lambda (to) (connect! from to)))))) + + (graph/for-each-node graph + (lambda (node) + (for-each-item (lambda (to) + (connect! node to)) + (node/initial-links-out node)) + (for-each-item (lambda (from) + (connect! from node)) + (node/initial-links-in node))))) + + +(define-structure + (application + (conc-name application/) + (print-procedure + (standard-unparser-method 'APPLICATION + (lambda (application port) + (if (CALL/? (application/text application)) + (let ((operator (call/operator (application/text application)))) + (write-char #\Space port) + (cond ((QUOTE/? operator) + (write operator port)) + ((LOOKUP/? operator) + (write (lookup/name operator) port)) + ((LAMBDA/? operator) + (write-string "(lambda)" port)) + (else + (write-string "" port))))))))) + text + operator-node + operand-nodes + ;; The result node is the expected thing in Direct style. In CPS it + ;; holds the value that should be passed to the continuation, which + ;; is only really useful when modelling calls to external known + ;; operators. For these we create special-applications on the fly + ;; that feed the result back to the continuation. + result-node + ) + +(define (graph/add-application! graph text + operator-node operand-nodes result-node) + (let ((application (make-application + text operator-node operand-nodes result-node))) + + (add! operator-node application node/uses/trigger set-node/uses/trigger!) + + (add! graph application graph/applications set-graph/applications!) + (add! operator-node application node/uses/operator set-node/uses/operator!) + (for-each + (lambda (node) + (if node + (add! node application node/uses/operand set-node/uses/operand!))) + operand-nodes) + application)) + + + +(define-structure + (special-application + (conc-name special-application/) + (print-procedure + (standard-unparser-method 'SPECIAL-APPLICATION + (lambda (application port) + (write-char #\Space port) + (write (special-application/operator application) port))))) + text + operator ; cookie + operand-nodes + result-node) + +(define (graph/add-special-application! + graph text + operator operand-nodes + trigger-nodes + result-node) + (let ((application (make-special-application + text operator operand-nodes result-node))) + + (add! graph application graph/applications set-graph/applications!) + (for-each + (lambda (node) + (add! node application node/uses/operand set-node/uses/operand!)) + operand-nodes) + (for-each + (lambda (node) + (add! node application node/uses/trigger set-node/uses/trigger!)) + trigger-nodes) + application)) + + + +;; +;; The abstraction that we use for lists of things + +(define-integrable (add! structure item accessor setter!) + (let ((structure structure)) + (setter! structure (cons item (accessor structure))))) + +(define (empty? frob) + (null? frob)) + +(define-integrable (in? item collection) + (memq item collection)) + +(define-integrable (for-each-item proc things) + (for-each proc things)) + + + +(define (graph/pp graph) + (define (ppp x) (pp x (current-output-port) #T)) + + (define (section heading selector pp) + (newline) (newline) (display heading) + (for-each (lambda (proc) + (newline) + (pp proc)) + (selector graph))) + + (pp graph) + + (section "NODES" graph/nodes pp) + + (newline) (newline) (display "TEXT->NODE map") (newline) + (for-each ppp (hash-table->alist (graph/text->node-table graph))) + + (section "APPLICATIONS" graph/applications ppp) + (section "PROCEDURES" graph/procedures pp) + (section "CLOSURES" graph/closures pp) +) + + +;; +;; Simulated application +;; + +;; Normal procedures: connect up the arguments to the parameters. This +;; may invalidate other application nodes if an operator flow out +;; +;; Primitives: output must be monotonic on each inputs. Need to rerun +;; any application which has a new value for any of the arguments. +;; +;; Values which escape end up in the escape-node. + +(define (graph/dataflow! graph) + (graph/for-each-node graph + (lambda (node) (set-node/values! node 'NOT-CACHED))) + (graph/for-each-node graph node/initialize-cache!) + ;; Trivial cloaures need to + (graph/initialize-closure-procedures! graph) + (let ((queue (queue/make))) + (queue/enqueue!* queue (graph/applications graph)) + (queue/enqueue! queue 'ESCAPE-APPLICATION) + (queue/drain! queue (simulate-combination graph queue))) + ;; This ensures that unknown values get into the flag position in nodes + ;; that are not used in an application: + (graph/for-each-node graph + (lambda (node) + (let loop () + (if (value-set/age-value! (node/values node)) (loop))))) + ;; Mark all closures that escape. Must be done after the above step. + (for-each-item (lambda (value) + (if (value/closure? value) + (set-value/closure/escapes?! value #T))) + (value-set/singletons (node/values (graph/escape-node graph)))) + + ;; Invert graph to obtain values->nodes + (graph/for-each-node graph + (lambda (node) + (for-each-item + (lambda (value) + (add! value node value/nodes set-value/nodes!)) + (value-set/singletons (node/values node))))) + + ) + + +(define ((simulate-combination graph queue) application) + (cond ((eq? 'ESCAPE-APPLICATION application) + (dataflow/apply-escapees! graph queue)) + ((application? application) + (simulate-application application graph queue)) + ((special-application? application) + (simulate-special-application application graph queue)) + (else + (internal-error "Illegal graph application" application)))) + + +(define (simulate-application application graph queue) + + (define (connect! from to) (connect-nodes! graph queue from to)) + + (let* ((operator-node (application/operator-node application)) + (operand-nodes (application/operand-nodes application)) + (result-node (application/result-node application))) + + (define (apply-next-operator) + (let ((operator (value-set/age-value! (node/values operator-node)))) + (cond ((false? operator) + 'done) + + ((value/unknown? operator) + (for-each + (lambda (operand-node) + (if operand-node + (connect! operand-node (graph/escape-node graph)))) + operand-nodes) + (if result-node + (connect! (graph/unknown-input-node graph) result-node)) + (apply-next-operator)) + + ((value/constant? operator) + ;; all the magic cookies + (dataflow/applicate-constant! + graph queue application operator) + (apply-next-operator)) + + ((value/procedure? operator) + (dataflow/applicate! graph + queue + (value/procedure/lambda-list operator) + (value/procedure/input-nodes operator) + operand-nodes) + (cond ((and result-node (value/procedure/result-node operator)) + ;; i.e. direct style + (connect! (value/procedure/result-node operator) + result-node)) + ;;((or (value/procedure/result-node operator) + ;; (first operand-nodes)) + ;;(internal-error "Direct/CPS mismatch" + ;; operator application)) + ) + (apply-next-operator)) + + ((value/closure? operator) + ;; This is slightly more involved as we have to extract the + ;; procedure and arrange for the closure to be passed for + ;; non-trivial closures + (let* ((procedure (value/closure/procedure operator))) + + (add! operator application value/closure/call-sites + set-value/closure/call-sites!) + (dataflow/applicate! + graph + queue + (value/procedure/lambda-list procedure) + (value/procedure/input-nodes procedure) + (if (memq (value/closure/kind operator) '(TRIVIAL STACK)) + operand-nodes + (cons* (first operand-nodes) + (value/closure/self-node operator) + (cdr operand-nodes)))) + (cond ((and result-node (value/procedure/result-node procedure)) + ;; i.e. direct style + (connect! (value/procedure/result-node procedure) + result-node)) + ;;((or result-node (value/procedure/result-node procedure)) + ;;(internal-error "Direct/CPS mismatch" + ;; operator application)) + ) + (apply-next-operator))) + + (else + (internal-error "Dont know how to apply" + operator application))))) + + (apply-next-operator))) + + +(define (simulate-special-application application graph queue) + + (define (connect! from to) (connect-nodes! graph queue from to)) + + graph + + (let ((operator (special-application/operator application)) + (operand-nodes (special-application/operand-nodes application)) + (result-node (special-application/result-node application))) + + (cond ((eq? operator %make-heap-closure) + ;;no action required - closure value precomputed + unspecific) + ((eq? operator %make-stack-closure) + ;;no action required - closure value precomputed + unspecific) + + ((or (eq? operator %heap-closure-ref) + (eq? operator %stack-closure-ref)) + ;; (CALL ',%heap-closure-ref '#F 'NAME) + ;; (CALL ',%stack-closure-ref '#F 'NAME) + (let* ((text (special-application/text application)) + (name (second (sixth text))) + (ref-kind (second (second text))) + (closure-node (first operand-nodes)) + (closure (value-set/age-value! + (node/values closure-node)))) + (if closure + (if (not (node-set/empty? (node/links-in result-node))) + (internal-error "Multiple linkings at " application) + (begin + ;;(pp `(,ref-kind ,closure ,name)) + (connect! (value/closure/lookup-location-node closure name) + result-node) + (let ((bad (value-set/age-value! + (node/values closure-node)))) + (if bad + (internal-error + "Multiple closures at" ref-kind + application)))))))) + + (else + (internal-error + "Unknown special-application operator" operator application))))) + + +(define (dataflow/apply-escapees! graph queue) + ;; Ensure any procedure that escapes is called with unknown arguments and + ;; its result escapes too. + + (define (connect! from to) (connect-nodes! graph queue from to)) + + (let* ((unknown-input-node (graph/unknown-input-node graph)) + (escape-node (graph/escape-node graph)) + (values (node/values escape-node))) + (let escape-next-object () + (let ((object (value-set/age-value! values))) + (cond ((false? object) + unspecific) + ((value/procedure? object) + ;;(pp (list 'escaped: object)) + (for-each (lambda (input-node) + (connect! unknown-input-node input-node)) + (value/procedure/input-nodes object)) + (if (value/procedure/result-node object) + (connect! (value/procedure/result-node object) + escape-node)) + (escape-next-object)) + + ((value/closure? object) + ;; This is slightly more involved as we have to link up a heap + ;; closure's procedure with the correct value (node) for the + ;; closure argument. + + ;; NOTE: Perhaps this code should also escape the closure + ;; locations? + ;;(pp (list 'escaped: object)) + (let* ((procedure (value/closure/procedure object)) + (input-nodes (value/procedure/input-nodes procedure))) + (if (value/procedure/result-node procedure) + (connect! (value/procedure/result-node procedure) + escape-node)) + (connect! unknown-input-node (first input-nodes)) + (if (eq? 'HEAP (value/closure/kind object)) + (begin + (connect! (value/closure/self-node object) + (second input-nodes)) + (for-each + (lambda (input-node) + (connect! unknown-input-node input-node)) + (cddr input-nodes))) + (begin ; TRIVIAL or STACK + (for-each + (lambda (input-node) + (connect! unknown-input-node input-node)) + (cdr input-nodes))))) + + (escape-next-object)) + + (#F + ;; Anything containing locations that are accessible by accessor + ;; procedures needs to escape the locations. + ) + (else;; unknown, constants, primitives + (escape-next-object))))))) + + +(define (dataflow/make-globals-escape! env graph) + (dataflow/env/for-each-global-binding + (lambda (binding) + (let ((value (dataflow/binding/value binding))) + (initial-link-nodes! value (graph/escape-node graph)) + (initial-link-nodes! (graph/unknown-input-node graph) value))) + env)) + +(define (dataflow/applicate-constant! graph + queue + application + operator) + + (let ((operator (value/constant/value operator))) + (if (and (not (primitive-procedure? operator)) + (not (compiled-procedure? operator)) + (not (known-operator? operator)) + *dataflow-report-applied-non-procedures?*) + (warn "Possibly applied non-procedure object: " operator))) + + ((dataflow/get-method (value/constant/value operator)) + graph + queue + application + operator)) + + +(define dataflow/cookie-methods (make-eq-hash-table)) + +(define (define-dataflow-method cookie method) + (hash-table/put! dataflow/cookie-methods cookie method)) + +(define (dataflow/get-method cookie) + (hash-table/get dataflow/cookie-methods cookie + dataflow/method/default-method)) + +(define (dataflow/method/default-method graph queue application operator) + ;; The default method assumes the very worst about the operator: all the + ;; arguments escape and the result, if any, is completely unknown + (define (connect! from to) (connect-nodes! graph queue from to)) + operator + (if (application/result-node application) + (connect! (graph/unknown-input-node graph) + (application/result-node application))) + (for-each (lambda (node) + (if node + (connect! node (graph/escape-node graph)))) + (application/operand-nodes application))) + +(define (dataflow/method/simple graph queue application operator) + ;; The simple method assumes that none of the arguments escape and the + ;; result is completely unknown + operator + (define (connect! from to) (connect-nodes! graph queue from to)) + (define result-node (application/result-node application)) + (connect! (graph/unknown-input-node graph) result-node)) + +(define (dataflow/method/simple-predicate graph queue application operator) + ;; The simple method assumes that none of the arguments escape and the + ;; result is either #F or #T + operator + (define result-node (application/result-node application)) + (node/add-value! result-node (graph/add-constant! graph `(QUOTE #F)) queue) + (node/add-value! result-node (graph/add-constant! graph `(QUOTE #T)) queue)) + + +(define (dataflow/external-return graph queue application operator) + (let ((result-node (application/result-node application)) + (cont-node (first (application/operand-nodes application)))) + (if cont-node + (let ((application + (graph/add-application! graph + `(EXTERNAL-RETURN ,operator) + cont-node + (list #F result-node) + #F))) + ;; enqueue it in case the result is already available + (queue/enqueue! queue application)) + ;; In direct style the result is already in place. + 'ok))) + + +(define (dataflow/method/external-predicate graph queue application operator) + ;; The simple method assumes that none of the arguments escape and the + ;; result is either #F or #T + operator + (define result-node (application/result-node application)) + (node/add-value! result-node (graph/add-constant! graph `(QUOTE #F)) queue) + (node/add-value! result-node (graph/add-constant! graph `(QUOTE #T)) queue) + (dataflow/external-return graph queue application operator)) + + + +(define-dataflow-method fix:+ dataflow/method/simple) +(define-dataflow-method fix:- dataflow/method/simple) +(define-dataflow-method fix:* dataflow/method/simple) + +(define-dataflow-method fix:< dataflow/method/simple-predicate) + +(for-each + (lambda (name) + (define-dataflow-method (make-primitive-procedure name) + dataflow/method/external-predicate)) + '(&< &= &>)) + + + +;;(define (dataflow/method/%make-heap-closure graph queue application operator) +;; ;; (CALL ,%make-heap-closure '#F (lambda (k closure ..) ..) '#(x y) x y) +;; (define (connect! from to) (connect-nodes! graph queue from to)) +;; +;; (let* ((arg-nodes (application/operand-nodes application)) +;; (text (application/text application)) +;; (location-names (second (fifth text))) +;; (cont-node (first arg-nodes)) +;; (lambda-node (second arg-nodes)) +;; (vector-node (third arg-nodes)) +;; (value-nodes (cdddr arg-nodes)) +;; (procedure (node/the-procedure-value lambda-node)) +;; (self-node (application/result-node application)) +;; (closure (graph/add-closure! +;; graph +;; text +;; 'HEAP +;; procedure +;; location-names +;; self-node))) +;; (let loop ((i 0) (value-nodes value-nodes)) +;; (if (< i (vector-length location-names)) +;; (let ((node (vector-ref (value/closure/location-nodes closure) i))) +;; (node/initialize-cache! node) +;; (connect! (car value-nodes) node) +;; (loop (+ i 1) (cdr value-nodes))))) +;; (node/add-value! self-node closure queue))) +;; +;;(define-dataflow-method %make-heap-closure dataflow/method/%make-heap-closure) +;; +;; +;;(define (dataflow/method/%heap-closure-ref graph queue application operator) +;; ;; (CALL ,%heap-closure-ref '#F 'NAME) +;; +;; (define (connect! from to) (connect-nodes! graph queue from to)) +;; +;; (let* ((text (application/text application)) +;; (arg-nodes (application/operand-nodes application)) +;; (closure-node (second arg-nodes)) +;; (closure-values (node/values closure-node)) +;; (name (second (fifth text))) +;; (result-node (application/result-node application))) +;; ;; This procedure should only ever be called with a single known closure +;; ;; value. We connect the named slot +;; +;; (let loop ((closure (value-set/age-value! closure-values))) +;; (cond ((false? closure) +;; unspecific) +;; ((value/closure? closure) +;; (if (null? (node/links-in result-node)) +;; (connect! (value/closure/lookup-location-node closure name) +;; result-node) +;; (internal-error "%heap-closure-ref again!" +;; closure application)) +;; (loop (value/set/age-value! closure-values))) +;; (else +;; (internal-error "%heap-closure-ref of non-closure" +;; closure application)))))) +;; +;;(define-dataflow-method %heap-closure-ref dataflow/method/%heap-closure-ref) +;; + + + +(define (dataflow/applicate! graph + queue + whole-lambda-list + whole-formals ; abstract names in lambda list + whole-args) + + (define (connect! from to) + (connect-nodes! graph queue from to)) + + (define (do-normal! name formal arg) + name + (if arg + (connect! arg formal))) + + (define (do-optional! name formal arg) + name + (if arg + (connect! arg formal) + (node/add-value! + formal + (graph/add-constant! graph `(QUOTE ,(make-unassigned-reference-trap))) + queue))) + + (define (do-rest! name formal args) + name + (if (null? args) + ;;(connect! (graph/add-constant-node! graph '(QUOTE ())) formal) + (node/add-value! formal + (graph/add-constant! graph `(QUOTE ())) + queue) + (connect! (graph/unknown-input-node graph) formal))) + + (define (normal-loop lambda-list formals args) + (cond ((null? lambda-list) + (if (not (null? args)) + (warn "Too many args" whole-lambda-list whole-args))) + ((eq? (car lambda-list) '#!OPTIONAL) + (optional-loop (cdr lambda-list) formals args)) + ((eq? (car lambda-list) '#!REST) + (rest-loop (cdr lambda-list) formals args)) + ((null? args) + (warn "Too few arguments" whole-lambda-list whole-args)) + (else + (do-normal! (car lambda-list) (car formals) (car args)) + (normal-loop (cdr lambda-list) (cdr formals) (cdr args))))) + + (define (optional-loop lambda-list formals args) + (cond ((null? lambda-list) + (if (not (null? args)) + (warn "Too many args" whole-lambda-list whole-args))) + ((eq? (car lambda-list) '#!REST) + (rest-loop (cdr lambda-list) formals args)) + ((null? args) + (do-optional! (car lambda-list) (car formals) #f) + (optional-loop (cdr lambda-list) (cdr formals) '())) + (else + (do-optional! (car lambda-list) (car formals) (car args)) + (optional-loop (cdr lambda-list) (cdr formals) (cdr args))))) + + (define (rest-loop lambda-list formals args) + (do-rest! (car lambda-list) (car formals) args)) + + (normal-loop whole-lambda-list whole-formals whole-args)) + + + +;;;; +;;;; Node sets allow insertion while the set is being traversed. This is +;;;; node by keeping the items added during the traversal and inserting +;;;; them later. +;; +;;(load-option 'rb-tree) +;; +;;(define-integrable (node-set/lock s) (car s)) +;;(define-integrable (node-set/elements s) (cdr s)) +;;(define-integrable (node-set/set-lock! s v) (set-car! s v)) +;;(define-integrable (node-set/set-elements! s v) (set-cdr! s v)) +;; +;;(define-integrable (node-set/locked? s) (not (symbol? (node-set/lock s)))) +;; +;;(define (node-set/add-unlocked! set elt) +;; (node-set/set-elements! set (cons elt (node-set/elements set)))) +;; +;;(define (link-nodes! from to) +;; (define-integrable (add! set elt) +;; (if (node-set/locked? set) +;; (node-set/set-lock! set (cons elt (node-set/lock set))) +;; (node-set/add-unlocked! set elt))) +;; (add! (node/links-in to) from) +;; (add! (node/links-out from) to)) +;; +;;(define (nodes-linked? from to) +;; (or (eq? from to) +;; (node-set/member? from (node/links-in to)))) +;; +;;(define (make-empty-node-set) +;; (cons 'unlocked '())) +;; +;;(define (node-set/empty? set) +;; (null? (node-set/elements set))) +;; +;;(define (node-set/member? node set) +;; (or (memq node (node-set/elements set)) +;; (and (node-set/locked? set) +;; (memq node (node-set/lock set))))) +;; +;;(define (node-set/for-each set proc) +;; (let ((old-lock (node-set/lock set))) +;; (node-set/set-lock! set '()) +;; (for-each proc (node-set/elements set)) +;; (if (not (null? (node-set/lock set))) +;; (pp `(deferred . ,(node-set/lock set)))) +;; (for-each (lambda (addend) +;; (node-set/add-unlocked! set addend)) +;; (node-set/lock set)) +;; (node-set/set-lock! set old-lock) +;; unspecific)) +;; +;;(define (node-set/size set) +;; (length (node-set/elements set))) + + +;;______________________________________________________________________________ +;; +;; A note about the structure of the graph. About 80% of the nodes have +;; 3 or fewer in-edges. The most popular in-degree is 0 (~35%), then +;; 3 and 1 (at 15%) and then 2 (at 8%) [after cps conversion, one +;; large sample]. +;; +;; The node(s) which collect escaped values have a huge number of edges. +;; +;; The overhead of deciding to use the bit-strings is not worth it for +;; graphs with < 3k nodes. +;; +;;(define (link-nodes! from to) +;; (define-integrable (add! structure item accessor setter!) +;; (let ((structure structure)) +;; (setter! structure (cons item (accessor structure))))) +;; (add! to from node/links-in set-node/links-in!) +;; (add! from to node/links-out set-node/links-out!) +;; (cond ((node/connectivity to) +;; (bit-string-set! (node/connectivity to) (node/number from))) +;; ((>= (length (node/links-in to)) 10) +;; (let ((bs (make-bit-string *node-count* #F))) +;; (for-each (lambda (node) +;; (bit-string-set! bs (node/number node))) +;; (node/links-in to)) +;; (set-node/connectivity! to bs)))) +;; unspecific) +;; +;;(define (nodes-linked? from to) +;; (cond ((eq? from to) +;; #T) +;; ((node/connectivity to) +;; (bit-string-ref (node/connectivity to) (node/number from))) +;; ((memq from (node/links-in to)) +;; #T) +;; (else #F))) +;; +;;(define (make-empty-node-set) +;; '()) +;; +;;(define (node-set/empty? set) +;; (null? set)) +;; +;;(define (node-set/for-each set proc) +;; (for-each proc set)) +;; +;;(define (node-set/size set) +;; (length set)) +;;______________________________________________________________________________ + + + +;;______________________________________________________________________________ +;; +;; Simple lists are slow and take 2n words per entry +;; +;;(define (link-nodes! from to) +;; (define-integrable (add! structure item accessor setter!) +;; (let ((structure structure)) +;; (setter! structure (cons item (accessor structure))))) +;; (add! to from node/links-in set-node/links-in!) +;; (add! from to node/links-out set-node/links-out!)) +;; +;;(define (nodes-linked? from to) +;; (or (eq? from to) +;; (memq from (node/links-in to)))) +;; +;;(define (make-empty-node-set) +;; '()) +;; +;;(define (node-set/empty? set) +;; (null? set)) +;; +;;(define (node-set/for-each set proc) +;; (for-each proc set)) +;; +;;(define (node-set/size set) +;; (length set)) +;;______________________________________________________________________________ + +;; The growing vector approach. Uses at most kN+2 works where k in 4/3. +;; as k -> 1 the overhead reduced by the vector has to be grown more +;; often (see GROW) below. The vector contains a count C in the first +;; (0 index) slot and set elements in slots 1..C. + +(define (link-nodes! from to) + + (define (initial-vector elt) (vector 1 elt)) + + (define (grow v) + ;; Fast open-coded grow operations for common cases. All vectors start + ;; out small and so benefit from this (I hope). + (case (vector-length v) + ((2) (vector (vector-ref v 0) (vector-ref v 1) #F)) + ((3) (vector (vector-ref v 0) (vector-ref v 1) (vector-ref v 2) #F)) + (else + (vector-grow v (fix:quotient (fix:* (vector-length v) 4) 3))))) + + (define (add! structure item accessor setter!) + (let ((set (accessor structure))) + (if set + (let ((index (fix:+ (vector-ref set 0) 1)) + (vlen (vector-length set))) + (if (fix:>= index vlen) + (let ((set* (grow set))) + (vector-set! set* index item) + (vector-set! set* 0 index) + (setter! structure set*)) + (begin + (vector-set! set index item) + (vector-set! set 0 index)))) + (setter! structure (initial-vector item))))) + + (add! to from node/links-in set-node/links-in!) + (add! from to node/links-out set-node/links-out!)) + +(define (nodes-linked? from to) + (or (eq? from to) + (let ((set (node/links-in to))) + (and set + (let loop ((i (vector-ref set 0))) + (and (fix:> i 0) + ;; Loop unrolled 1 time is safe because the zero slot + ;; contains a fixnum that will never match a node + (or (eq? from (vector-ref set i)) + (eq? from (vector-ref set (fix:- i 1))) + (loop (fix:- i 2))))))))) + + +(define (make-empty-node-set) + '#F) + +(define-integrable (node-set/empty? set) + (eq? set '#F)) + +(define (node-set/for-each set proc) + (if set + (let loop ((i (vector-ref set 0))) + (if (fix:> i 0) + (begin + (proc (vector-ref set i)) + (loop (fix:- i 1))))))) + +(define (node-set/size set) + (if set + (vector-ref set 0) + 0)) + +(define (connect-nodes! graph queue from to) + graph + + (define (link! from to) + (if (not (nodes-linked? from to)) + (link-nodes! from to))) + + (link! from to) + (node-set/for-each (node/links-in from) + (lambda (from*) + (link! from* to))) + (node-set/for-each (node/links-out to) + (lambda (to*) + (link! from to*))) + (node-set/for-each (node/links-in from) + (lambda (from*) + (node-set/for-each (node/links-out to) + (lambda (to*) + (link! from* to*))))) + + ;; Now any node newly reachable from any predecessor of FROM is in FROM's + ;; successors, so we can just do a one-level propagation of values + ;;(node/propagate! from queue) + ;; + ;; This is better as it does not needlessly propagate preexisting + ;; successors of from: + (if (value-set/union!? (node/values to) (node/values from)) + (begin + (node/enqueue-applications! to queue) + (node/propagate! to queue)))) + + + +(define (node/add-value! node value queue) + (if (value-set/add-singleton!? (node/values node) value) + (begin + (node/enqueue-applications! node queue) + (node/propagate! node queue)))) + +(define (node/enqueue-applications! node queue) + (queue/enqueue!* queue (node/uses/trigger node))) + +(define (node/propagate! node queue) + ;; This is a node who's value has changed, so propagate to successors + (let ((values (node/values node))) + (node-set/for-each (node/links-out node) + (lambda (dest) + (if (value-set/union!? (node/values dest) values) + (node/enqueue-applications! dest queue)))))) + +(define (node/initialize-cache! node) + (node/compute-initial-values! node)) + +#| +(define (node/compute-initial-values node) + ;; This is slow but works even with cycles in the DFG. + ;; Only works if there are no links in from a node with a reference value + (let ((nodes '())) + (let walk ((node node)) + (if (not (memq node nodes)) + (begin (set! nodes (cons node nodes)) + (for-each walk (node/links-in node))))) + (value-set/union* (node/initial-values (car nodes)) + (map node/initial-values (cdr nodes))))) +|# + + +(define (node/compute-initial-values! target-node) + ;; This is slow but works even with cycles in the DFG. + (let ((nodes '())) + (define (eval-node! node) + (cond ((memq node nodes) + unspecific) + ((eq? (node/values node) 'NOT-CACHED) + (set! nodes (cons node nodes)) + (node-set/for-each (node/links-in node) eval-node!) + (let ((vs (make-value-set))) + (set-node/values! node vs) + (set-value-set/new-singletons! vs (node/initial-values node)) + (node-set/for-each + (node/links-in node) + (lambda (input-node) + (if (value-set? (node/values input-node)) + (value-set/union!? vs (node/values input-node))))))) + (else + unspecific))) + (eval-node! target-node))) + +(define (graph/substitite-simple-constants graph simple-constant?) + ;; Rewrite any node with a unique constant value K satisfying + ;; SIMPLE-CONSTANT? as (QUOTE K) + (for-each (lambda (node) + (if (expression-node? node) + (let ((value (node/unique-value node))) + (cond ((QUOTE/? (node/text node)) + unspecific) + ((and (value/constant? value) + (simple-constant? (value/constant/value value))) + (display "\n; Constant propagation:") + (kmp/ppp + `(,node ,(node/text node) => + (QUOTE ,(value/constant/value value)))) + (form/rewrite! (node/text node) + `(QUOTE ,(value/constant/value value)))) + (else unspecific))))) + (graph/nodes graph))) + +(define (graph/read-eq?-preserving-constant? value) + (or (fixnum? value) + (char? value) + (symbol? value) + (memq value '(#F () #T)))) + +(define (graph/read-eqv?-preserving-constant? value) + (or (graph/read-eq?-preserving-constant? value) + (number? value))) + +(define (graph/display-statistics! graph) + (define (say . things) (for-each display things)) + (define (histogram aspect measure) + (let ((data (map measure (aspect graph))) + (hist (make-eq-hash-table))) + (let loop ((data data)) + (if (not (null? data)) + (let ((datum (car data))) + (hash-table/put! hist datum (+ 1 (hash-table/get hist datum 0))) + (loop (cdr data))))) + (sort (hash-table->alist hist) (lambda (u v) (< (car u) (car v)))))) + + (define ((edge-count aspect) node) + (node-set/size (aspect node))) + + (define (count-pairs object) + (define (count it n) + (if (pair? it) + (count (car it) (count (cdr it) (+ n 1))) + n)) + (count object 0)) + + (say "\n; " graph + " " (length (graph/nodes graph)) + " nodes " (graph/node-count graph) + " (" (reduce + 0 (map (lambda (node) (if (node/connectivity node) 1 0)) + (graph/nodes graph))) + " with bit strings)") + (say "\n; Source has " (count-pairs (graph/program graph)) " pairs.") + (say "\n; " + (reduce + 0 (map (edge-count node/links-in) + (graph/nodes graph))) + " in-edges, " + (reduce + 0 (map (edge-count node/links-out) + (graph/nodes graph))) + " out-edges.") + ;;(say "\n; Histogram ((out-edges . node-count) ...)") + ;;(pp (histogram graph/nodes (lambda (node) (length (node/links-out node)))) + ;; (current-output-port) #F) + (say "\n; Histogram ((in-edges . node-count) ...)") + (pp (histogram graph/nodes (edge-count node/links-in)) + (current-output-port) #F)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (find-all pattern program) + + (define (match? pattern text) + (or (eq? pattern '?) + (eq? pattern text) + (and (symbol? pattern) (symbol? text) + (string-ci=? (symbol-name pattern) (symbol-name text))) + (and (pair? pattern) (pair? text) + (match? (car pattern) (car text)) + (match? (cdr pattern) (cdr text))))) + + (define (search text) + (if (match? pattern text) + (list text) + (let loop ((text* text) + (frobs '())) + (cond ((not (pair? text*)) + frobs) + ((search (car text*)) + => (lambda (x) (loop (cdr text*) (append! frobs x)))) + (else (loop (cdr text*) frobs)))))) + + (set! *finds* (search program)) + *finds*) + +(define *finds*) + +(define (find pattern #!optional program) + (find-all pattern (if (default-object? program) + *current-phase-input* + program)) + (if (null? *finds*) + #F + (car *finds*))) + +(define (find* pattern #!optional program) + (find-all pattern (if (default-object? program) + *current-phase-input* + program)) + *finds*) + +(define (refind) + (if (or (not *finds*) + (null? (cdr *finds*))) + #F + (begin (set! *finds* (cdr *finds*)) + (car *finds*)))) + + +(define (parents expr #!optional program) + ;; EQ? parents of an expression + (define (find text) + (if (pair? text) + (apply + append + (if (there-exists? text (lambda (x) (eq? x expr))) + (list text) + '()) + (map find text)) + '())) + (find (if (default-object? program) + *current-phase-input* + program))) + +;;; +;;; Local Variables: +;;; eval: (put 'graph/for-each-node 'scheme-indent-function 1) +;;; eval: (put 'node-set/for-each 'scheme-indent-function 1) +;;; End: +;;; +;;; Edwin variables: +;;; End: +;;; diff --git a/v8/src/compiler/midend/dbgstr.scm b/v8/src/compiler/midend/dbgstr.scm new file mode 100644 index 000000000..afff941f5 --- /dev/null +++ b/v8/src/compiler/midend/dbgstr.scm @@ -0,0 +1,49 @@ +;;; -*- Scheme -*- + +(declare (usual-integrations)) + +(define-structure (new-dbg-expression + (conc-name new-dbg-expression/) + (constructor new-dbg-expression/make (expr))) + (expr false read-only true) + (block false read-only false)) + +(define-structure (new-dbg-procedure + (conc-name new-dbg-procedure/) + (constructor new-dbg-procedure/make (lam-expr lambda-list)) + (constructor new-dbg-procedure/%make)) + (lam-expr false read-only true) + (lambda-list false read-only true) + (block false read-only false)) + +(define (new-dbg-procedure/copy dbg-proc) + (new-dbg-procedure/%make (new-dbg-procedure/lam-expr dbg-proc) + (new-dbg-procedure/lambda-list dbg-proc) + (new-dbg-procedure/block dbg-proc))) + +(define-structure (new-dbg-continuation + (conc-name new-dbg-continuation/) + (constructor new-dbg-continuation/make (type outer inner))) + (type false read-only true) + (outer false read-only true) + (inner false read-only true) + (block false read-only false)) + +(define-structure (new-dbg-variable + (conc-name new-dbg-variable/) + (constructor new-dbg-variable/make (name block))) + (name false read-only true) + (original-name name read-only true) + (block false read-only false) + (original-block block read-only false) + (offset false read-only false) + (extra false read-only false)) + +(define-structure (new-dbg-block + (conc-name new-dbg-block/) + (constructor new-dbg-block/make (type parent))) + (type false read-only false) + (variables '() read-only false) + (parent false read-only false) + (flattened false read-only false)) + \ No newline at end of file diff --git a/v8/src/compiler/midend/debug.scm b/v8/src/compiler/midend/debug.scm new file mode 100644 index 000000000..25639edd0 --- /dev/null +++ b/v8/src/compiler/midend/debug.scm @@ -0,0 +1,205 @@ +#| -*-Scheme-*- + +$Id: debug.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Useful debugging syntax + +(declare (usual-integrations)) + +(syntax-table-define (repl/syntax-table (nearest-repl)) 'SHOW + (macro (form) + `(kmp/pp + (%compile-proc ',(eval (list 'quasiquote form) + (repl/environment (nearest-repl))))))) + +(syntax-table-define (repl/syntax-table (nearest-repl)) 'SHOW-RTL + (macro (form) + `(for-each + pp + (%compile-proc/rtl ',(eval (list 'quasiquote form) + (repl/environment (nearest-repl))))))) + +(syntax-table-define (repl/syntax-table (nearest-repl)) 'RUN + (macro (form) + `(execute (%compile-proc ',(eval (list 'quasiquote form) + (repl/environment (nearest-repl)))) + (the-environment)))) + +(syntax-table-define (repl/syntax-table (nearest-repl)) '%COMPILE + (macro (form) + `(%compile-proc + ',(eval (list 'quasiquote form) + (repl/environment (nearest-repl)))))) + +(define %compile-proc + (lambda (form) + (compile + (compile/syntax form)))) + +(define %compile-proc/rtl + (lambda (form) + (source->rtl + (compile/syntax form)))) + +(define (compile/syntax form) + (syntax form (repl/syntax-table (nearest-repl)))) + +(define &+ (make-primitive-procedure '&+)) +(define &- (make-primitive-procedure '&-)) +(define &* (make-primitive-procedure '&*)) +(define &/ (make-primitive-procedure '&/)) +(define &= (make-primitive-procedure '&=)) +(define &< (make-primitive-procedure '&<)) +(define &> (make-primitive-procedure '&>)) + +#| + +(show (let () + (define fib + (lambda (n) + (cond ((< n 0) + (bkpt "Fib" n)) + ((< n 2) + n) + (else + (+ (fib (- n 1)) (fib (- n 2))))))) + (fib 6))) + +(show (let () + (define fib + (lambda (n) + (cond ((,&< n 2) + n) + (else + (,&+ (fib (,&- n 1)) (fib (,&- n 2))))))) + fib)) + +(show (let () + (define fib + (lambda (n) + (cond ((,fix:< n 2) + n) + (else + (,fix:+ (fib (,fix:- n 1)) (fib (,fix:- n 2))))))) + fib)) + +(show (define (smemq el l) + (define (phase-1 l1 l2) + (cond ((,not (,pair? l1)) ,false) + ((,eq? el (,car l1)) l1) + (else + (phase-2 (,cdr l1) l2)))) + + (define (phase-2 l1 l2) + (cond ((,not (,pair? l1)) ,false) + ((,eq? el (,car l1)) l1) + ((,eq? l1 l2) ,false) + (else + (phase-1 (,cdr l1) (,cdr l2))))) + + (phase-1 l l))) + +(show (lambda (x) + (letrec ((foo (lambda () (bar x))) + (bar (lambda (z) (,+ z (foo))))) + bar))) + +(show (lambda (x y) + (if (and x (foo y)) + (foo y) + (foo x)))) + +(define (simplify/open-code? value name) + false) + +(show (lambda (x) + (let ((foo (lambda (y z) (,+ y z)))) + (foo x (foo x (foo x x)))))) + +(show (lambda (x y q w) + (let* ((z (foo y q x)) + (t (foo x y w)) + (h (foo z t y))) + (bar h z q)))) + +(show (lambda (x y q w) + (let* ((z (foo y q x)) + (t (foo x y w)) + (h (foo z t y)) + (l (foo h t w))) + (bar l z q)))) + +(show (lambda (x y z w q) + (foo x y z) + (foo y z w) + (foo z w q) + (foo w q x) + (foo q x y))) + +(show (lambda (n) + (do ((i 0 (,+ i 1)) + (fn 0 fn+1) + (fn+1 1 (,+ fn fn+1))) + ((,= i n) fn)))) + +(show (lambda (ol) + (define (loop l accum) + (cond ((,pair? l) + (loop (,cdr l) (,cons (,car l) accum))) + ((,null? l) + accum) + (else + (error "Not a list" ol)))) + (loop ol '()))) + +(show (if (foo) + 23 + (let ((y (bar))) + (lambda (x) + (,fix:- x y))))) + +(show (define (foo x) + (let loop ((x x)) + (let ((y (,cons x x))) + (loop (,car y)))))) + +(show (define (foo x n) + (let loop ((x x) + (n n)) + (if (,not (,fix:> n 0)) + x + (let ((y (,cons x x))) + (loop (,car y) + (,fix:- n 1))))))) + +|# diff --git a/v8/src/compiler/midend/earlyrew.scm b/v8/src/compiler/midend/earlyrew.scm new file mode 100644 index 000000000..6beeaf434 --- /dev/null +++ b/v8/src/compiler/midend/earlyrew.scm @@ -0,0 +1,568 @@ +#| -*-Scheme-*- + +$Id: earlyrew.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Early generic arithmetic rewrite +;;; package: (compiler midend) + +(declare (usual-integrations)) + +(define (earlyrew/top-level program) + (earlyrew/expr program)) + +(define-macro (define-early-rewriter keyword bindings . body) + (let ((proc-name (symbol-append 'EARLYREW/ keyword))) + (call-with-values + (lambda () (%matchup bindings '(handler) '(cdr form))) + (lambda (names code) + `(define ,proc-name + (let ((handler (lambda ,names ,@body))) + (named-lambda (,proc-name form) + (earlyrew/remember ,code form)))))))) + +(define-early-rewriter LOOKUP (name) + `(LOOKUP ,name)) + +(define-early-rewriter LAMBDA (lambda-list body) + `(LAMBDA ,lambda-list + ,(earlyrew/expr body))) + +(define-early-rewriter CALL (rator cont #!rest rands) + (define (default) + `(CALL ,(earlyrew/expr rator) + ,(earlyrew/expr cont) + ,@(earlyrew/expr* rands))) + (cond ((and (QUOTE/? rator) + (rewrite-operator/early? (quote/text rator))) + => (lambda (handler) + (if (not (equal? cont '(QUOTE #F))) + (internal-error "Early rewrite done after CPS conversion?" + cont)) + (apply handler (earlyrew/expr* rands)))) + (else + (default)))) + +(define-early-rewriter LET (bindings body) + `(LET ,(lmap (lambda (binding) + (list (car binding) + (earlyrew/expr (cadr binding)))) + bindings) + ,(earlyrew/expr body))) + +(define-early-rewriter LETREC (bindings body) + `(LETREC ,(lmap (lambda (binding) + (list (car binding) + (earlyrew/expr (cadr binding)))) + bindings) + ,(earlyrew/expr body))) + +(define-early-rewriter QUOTE (object) + `(QUOTE ,object)) + +(define-early-rewriter DECLARE (#!rest anything) + `(DECLARE ,@anything)) + +(define-early-rewriter BEGIN (#!rest actions) + `(BEGIN ,@(earlyrew/expr* actions))) + +(define-early-rewriter IF (pred conseq alt) + `(IF ,(earlyrew/expr pred) + ,(earlyrew/expr conseq) + ,(earlyrew/expr alt))) + +(define (earlyrew/expr expr) + (if (not (pair? expr)) + (illegal expr)) + (case (car expr) + ((QUOTE) + (earlyrew/quote expr)) + ((LOOKUP) + (earlyrew/lookup expr)) + ((LAMBDA) + (earlyrew/lambda expr)) + ((LET) + (earlyrew/let expr)) + ((DECLARE) + (earlyrew/declare expr)) + ((CALL) + (earlyrew/call expr)) + ((BEGIN) + (earlyrew/begin expr)) + ((IF) + (earlyrew/if expr)) + ((LETREC) + (earlyrew/letrec expr)) + ((SET! UNASSIGNED? OR DELAY + ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT) + (no-longer-legal expr)) + (else + (illegal expr)))) + +(define (earlyrew/expr* exprs) + (lmap (lambda (expr) + (earlyrew/expr expr)) + exprs)) + +(define (earlyrew/remember new old) + (code-rewrite/remember new old)) + +(define (earlyrew/new-name prefix) + (new-variable prefix)) + +(define *early-rewritten-operators* + (make-eq-hash-table 311)) + +(define-integrable (rewrite-operator/early? rator) + (hash-table/get *early-rewritten-operators* rator false)) + +(define (define-rewrite/early operator-name-or-object handler) + (hash-table/put! *early-rewritten-operators* + (if (hash-table/get *operator-properties* + operator-name-or-object + false) + operator-name-or-object + (make-primitive-procedure operator-name-or-object)) + handler)) + +(define (earlyrew/number? form) + (and (QUOTE/? form) + (number? (quote/text form)) + (quote/text form))) + +(define (earlyrew/nothing-special x y) + x y ; ignored + false) + +(define (earlyrew/binaryop op &op-name %fixop %genop n-bits + #!optional opt-x opt-y right-sided?) + (let ((&op (make-primitive-procedure &op-name)) + (optimize-x (if (default-object? opt-x) + earlyrew/nothing-special + opt-x)) + (optimize-y (if (default-object? opt-y) + earlyrew/nothing-special + opt-y)) + (right-sided? (if (default-object? right-sided?) + false + right-sided?)) + (%test (if (zero? n-bits) + (lambda (name) + `(CALL (QUOTE ,%machine-fixnum?) + (QUOTE #F) + (LOOKUP ,name))) + (lambda (name) + `(CALL (QUOTE ,%small-fixnum?) + (QUOTE #F) + (LOOKUP ,name) + (QUOTE ,n-bits))))) + (test (if (zero? n-bits) + machine-fixnum? + (lambda (value) + (small-fixnum? value n-bits))))) + (lambda (x y) + (cond ((earlyrew/number? x) + => (lambda (x-value) + (cond ((earlyrew/number? y) + => (lambda (y-value) + `(QUOTE ,(op x-value y-value)))) + ((optimize-x x-value y)) + ((not (test x-value)) + `(CALL (QUOTE ,%genop) + (QUOTE #F) + (QUOTE ,x-value) + ,y)) + ((not *earlyrew-expand-genarith?*) + `(CALL (QUOTE ,&op) + (QUOTE #F) + (QUOTE ,x-value) + ,y)) + (right-sided? + `(CALL (QUOTE ,%genop) + (QUOTE #F) + (QUOTE ,x-value) + ,y)) + (else + (let ((y-name (earlyrew/new-name 'Y))) + `(CALL (LAMBDA (,y-name) + (IF ,(%test y-name) + (CALL (QUOTE ,%fixop) + (QUOTE #F) + (QUOTE ,x-value) + (LOOKUP ,y-name)) + (CALL (QUOTE ,%genop) + (QUOTE #F) + (QUOTE ,x-value) + (LOOKUP ,y-name)))) + ,y)))))) + + ((earlyrew/number? y) + => (lambda (y-value) + (cond ((optimize-y x y-value)) + ((not (test y-value)) + `(CALL (QUOTE ,%genop) + (QUOTE #F) + ,x + (QUOTE ,y-value))) + ((not *earlyrew-expand-genarith?*) + `(CALL (QUOTE ,&op) + (QUOTE #F) + ,x + (QUOTE ,y-value))) + (else + (let ((x-name (earlyrew/new-name 'X))) + `(CALL (LAMBDA (,x-name) + (IF ,(%test x-name) + (CALL (QUOTE ,%fixop) + (QUOTE #F) + (LOOKUP ,x-name) + (QUOTE ,y-value)) + (CALL (QUOTE ,%genop) + (QUOTE #F) + (LOOKUP ,x-name) + (QUOTE ,y-value)))) + ,x)))))) + ((not *earlyrew-expand-genarith?*) + `(CALL (QUOTE ,&op) (QUOTE #F) ,x ,y)) + (right-sided? + `(CALL (QUOTE ,%genop) (QUOTE #F) ,x ,y)) + (else + (let ((x-name (earlyrew/new-name 'X)) + (y-name (earlyrew/new-name 'Y))) + (bind* (list x-name y-name) + (list x y) + `(IF ,(andify (%test x-name) (%test y-name)) + (CALL (QUOTE ,%fixop) + (LOOKUP ,x-name) + (LOOKUP ,y-name)) + (CALL (QUOTE ,%genop) + (LOOKUP ,x-name) + (LOOKUP ,y-name)))))))))) + +(define-rewrite/early '&+ + (earlyrew/binaryop + '&+ fix:+ %+ 1 + (lambda (x-value y) + (and (zero? x-value) + y)) + (lambda (x y-value) + (and (zero? y-value) + x)))) + +(define-rewrite/early '&- + (earlyrew/binaryop - '&- fix:- %- 1 + earlyrew/nothing-special + (lambda (x y-value) + (and (zero? y-value) + x)))) + +(define-rewrite/early 'QUOTIENT + ;; quotient can overflow only when dividing by 0 or -1. + ;; When dividing by -1 it can only overflow when the value is the + ;; most negative fixnum (-2^(word-size-1)) + (earlyrew/binaryop careful/quotient 'QUOTIENT fix:quotient %quotient 1 + (lambda (x-value y) + y ; ignored + (and (zero? x-value) `(QUOTE 0))) + (lambda (x y-value) + (cond ((zero? y-value) + (user-error "quotient: Division by zero" + x y-value)) + ((= y-value 1) + x) + ((= y-value -1) + (earlyrew/negate x)) + (else + false))) + true)) + +(define-rewrite/early 'REMAINDER + (earlyrew/binaryop careful/remainder 'REMAINDER fix:remainder %remainder 0 + (lambda (x-value y) + y ; ignored + (and (zero? x-value) `(QUOTE 0))) + (lambda (x y-value) + (cond ((zero? y-value) + (user-error "remainder: Division by zero" + x y-value)) + ((or (= y-value 1) (= y-value -1)) + `(QUOTE 0)) + (else + false))) + true)) + +(define earlyrew/negate + (let ((&- (make-primitive-procedure '&-))) + (lambda (z) + ;; z is assumed to be non-constant + (if *earlyrew-expand-genarith?* + (let ((z-name (earlyrew/new-name 'Z))) + `(CALL (LAMBDA (,z-name) + (IF (CALL (QUOTE ,%small-fixnum?) + (QUOTE #F) + (LOOKUP ,z-name) + (QUOTE 1)) + (CALL (QUOTE ,fix:-) + (QUOTE #F) + (QUOTE 0) + (LOOKUP ,z-name)) + (CALL (QUOTE ,%-) + (QUOTE #F) + (QUOTE 0) + (LOOKUP ,z-name)))) + ,z)) + `(CALL (QUOTE ,&-) (QUOTE #F) (QUOTE 0) ,z))))) + +(define-rewrite/early '&* + (let ((&* (make-primitive-procedure '&*))) + (lambda (x y) + (cond ((earlyrew/number? x) + => (lambda (x-value) + (cond ((earlyrew/number? y) + => (lambda (y-value) + `(QUOTE ,(* x-value y-value)))) + ((zero? x-value) + `(QUOTE 0)) + ((= x-value 1) + y) + ((= x-value -1) + (earlyrew/negate y)) + ((good-factor? x-value) + (if (not *earlyrew-expand-genarith?*) + `(CALL (QUOTE ,&*) (QUOTE #F) (QUOTE ,x-value) ,y) + (let ((y-name (earlyrew/new-name 'Y)) + (n-bits (good-factor->nbits x-value))) + `(CALL + (LAMBDA (,y-name) + (IF (CALL (QUOTE ,%small-fixnum?) + (QUOTE #F) + (LOOKUP ,y-name) + (QUOTE ,n-bits)) + (CALL (QUOTE ,fix:*) + (QUOTE #F) + (QUOTE ,x-value) + (LOOKUP ,y-name)) + (CALL (QUOTE ,%*) + (QUOTE #F) + (QUOTE ,x-value) + (LOOKUP ,y-name)))) + ,y)))) + (else + `(CALL (QUOTE ,%*) (QUOTE #F) (QUOTE ,x-value) ,y))))) + ((earlyrew/number? y) + => (lambda (y-value) + (cond ((zero? y-value) + `(QUOTE 0)) + ((= y-value 1) + x) + ((= y-value -1) + (earlyrew/negate x)) + ((good-factor? y-value) + (if (not *earlyrew-expand-genarith?*) + `(CALL (QUOTE ,&*) (QUOTE #F) ,x (QUOTE ,y-value)) + (let ((x-name (earlyrew/new-name 'X)) + (n-bits (good-factor->nbits y-value))) + (bind x-name x + `(IF (CALL (QUOTE ,%small-fixnum?) + (QUOTE #F) + (LOOKUP ,x-name) + (QUOTE ,n-bits)) + (CALL (QUOTE ,fix:*) + (QUOTE #F) + (LOOKUP ,x-name) + (QUOTE ,y-value)) + (CALL (QUOTE ,%*) + (QUOTE #F) + (LOOKUP ,x-name) + (QUOTE ,y-value))))))) + (else + `(CALL (QUOTE ,%*) (QUOTE #F) ,x (QUOTE ,y-value)))))) + (else + `(CALL (QUOTE ,%*) (QUOTE #F) ,x ,y)))))) + +;; NOTE: these could use 0 as the number of bits, but this would prevent +;; a common RTL-level optimization triggered by CSE. + +(define-rewrite/early '&= (earlyrew/binaryop = '&= fix:= %= 1)) +(define-rewrite/early '&< (earlyrew/binaryop < '&< fix:< %< 1)) +(define-rewrite/early '&> (earlyrew/binaryop > '&> fix:> %> 1)) + +(define-rewrite/early '&/ + (lambda (x y) + (cond ((earlyrew/number? x) + => (lambda (x-value) + (cond ((earlyrew/number? y) + => (lambda (y-value) + `(QUOTE ,(careful// x-value y-value)))) + ((zero? x-value) + `(QUOTE 0)) + (else + `(CALL (QUOTE ,%/) (QUOTE #F) (QUOTE ,x-value) ,y))))) + ((earlyrew/number? y) + => (lambda (y-value) + (cond ((zero? y-value) + (user-error "/: Division by zero" x y-value)) + ((= y-value 1) + x) + ((= y-value -1) + (earlyrew/negate x)) + (else + `(CALL (QUOTE ,%/) (QUOTE #F) ,x (QUOTE ,y-value)))))) + (else + `(CALL (QUOTE ,%/) (QUOTE #F) ,x ,y))))) + +;;;; Rewrites of unary operations in terms of binary operations + +(let ((unary-rewrite + (lambda (binary-name rand2) + (let ((binary-operation (make-primitive-procedure binary-name))) + (lambda (rand1) + ((rewrite-operator/early? binary-operation) + rand1 + `(QUOTE ,rand2)))))) + (special-rewrite + (lambda (binary-name rand2) + (let ((binary-operation (make-primitive-procedure binary-name))) + (lambda (rand1) + `(CALL (QUOTE ,binary-operation) + (QUOTE #F) + ,rand1 + (QUOTE ,rand2)))))) + (special-rewrite/left + (lambda (binary-name rand1) + (let ((binary-operation (make-primitive-procedure binary-name))) + (lambda (rand2) + `(CALL (QUOTE ,binary-operation) + (QUOTE #F) + (QUOTE ,rand1) + ,rand2)))))) + + (define-rewrite/early 'ZERO? (unary-rewrite '&= 0)) + (define-rewrite/early 'POSITIVE? (unary-rewrite '&> 0)) + (define-rewrite/early 'NEGATIVE? (unary-rewrite '&< 0)) + (define-rewrite/early '1+ (unary-rewrite '&+ 1)) + (define-rewrite/early '-1+ (unary-rewrite '&- 1)) + + (define-rewrite/early 'ZERO-FIXNUM? + (special-rewrite 'EQUAL-FIXNUM? 0)) + (define-rewrite/early 'NEGATIVE-FIXNUM? + (special-rewrite 'LESS-THAN-FIXNUM? 0)) + (define-rewrite/early 'POSITIVE-FIXNUM? + (special-rewrite 'GREATER-THAN-FIXNUM? 0)) + (define-rewrite/early 'ONE-PLUS-FIXNUM + (special-rewrite 'PLUS-FIXNUM 1)) + (define-rewrite/early 'MINUS-ONE-PLUS-FIXNUM + (special-rewrite 'MINUS-FIXNUM 1)) + + (define-rewrite/early 'FLONUM-ZERO? (special-rewrite 'FLONUM-EQUAL? 0.)) + (define-rewrite/early 'FLONUM-NEGATIVE? (special-rewrite 'FLONUM-LESS? 0.)) + (define-rewrite/early 'FLONUM-POSITIVE? (special-rewrite 'FLONUM-GREATER? 0.)) + + (define-rewrite/early 'FLONUM-NEGATE + (special-rewrite/left 'FLONUM-SUBTRACT 0.))) + +#| +;; Some machines have an ABS instruction. +;; This should be enabled according to the back end. + +(define-rewrite/early 'FLONUM-ABS + (let ((flo:> (make-primitive-procedure 'FLONUM-GREATER?)) + (flo:- (make-primitive-procedure 'FLONUM-SUBTRACT))) + (lambda (x) + (let ((x-name (earlyrew/new-name 'X))) + (bind x-name x + `(IF (CALL (QUOTE ,flo:>) (QUOTE #F) (QUOTE 0.) (LOOKUP ,x-name)) + (CALL (QUOTE ,flo:-) (QUOTE #F) (QUOTE 0.) (LOOKUP ,x-name)) + (LOOKUP ,x-name))))))) +|# + +;;;; *** Special, for now *** +;; This is done this way because of current rtl generator + +(let ((allocation-rewriter + (lambda (name out-of-line) + (let ((primitive (make-primitive-procedure name))) + (lambda (size) + (let ((default + (lambda () + `(CALL (QUOTE ,out-of-line) (QUOTE #F) ,size)))) + (cond ((earlyrew/number? size) + => (lambda (nbytes) + (if (not (exact-nonnegative-integer? nbytes)) + (default) + `(CALL (QUOTE ,primitive) (QUOTE #F) ,size)))) + (else + (default))))))))) + (define-rewrite/early 'STRING-ALLOCATE + (allocation-rewriter 'STRING-ALLOCATE %string-allocate)) + (define-rewrite/early 'FLOATING-VECTOR-CONS + (allocation-rewriter 'FLOATING-VECTOR-CONS %floating-vector-cons))) + +;; *** This can be improved by using %vector-allocate, +;; and a non-marked header moved through the vector as it is filled. *** + +(define-rewrite/early 'VECTOR-CONS + (let ((primitive (make-primitive-procedure 'VECTOR-CONS))) + (lambda (size fill) + (define (default) + `(CALL (QUOTE ,%vector-cons) (QUOTE #F) ,size ,fill)) + (cond ((earlyrew/number? size) + => (lambda (nbytes) + (if (or (not (exact-nonnegative-integer? nbytes)) + (> nbytes *vector-cons-max-open-coded-length*)) + (default) + `(CALL (QUOTE ,primitive) (QUOTE #F) ,size ,fill)))) + (else + (default)))))) + + +(define-rewrite/early 'GENERAL-CAR-CDR + (let ((prim-general-car-cdr (make-primitive-procedure 'GENERAL-CAR-CDR)) + (prim-car (make-primitive-procedure 'CAR)) + (prim-cdr (make-primitive-procedure 'CDR))) + (lambda (term pattern) + (define (default) + `(CALL (QUOTE ,prim-general-car-cdr) (QUOTE #f) ,term ,pattern)) + (cond ((earlyrew/number? pattern) + => (lambda (pattern) + (if (and (integer? pattern) (> pattern 0)) + (let walk-bits ((num pattern) + (text term)) + (if (= num 1) + text + (walk-bits (quotient num 2) + `(CALL (QUOTE ,(if (odd? num) + prim-car + prim-cdr)) + (QUOTE #f) + ,text)))) + (default)))) + (else (default)))))) diff --git a/v8/src/compiler/midend/envconv.scm b/v8/src/compiler/midend/envconv.scm new file mode 100644 index 000000000..d5a22f26b --- /dev/null +++ b/v8/src/compiler/midend/envconv.scm @@ -0,0 +1,952 @@ +#| -*-Scheme-*- + +$Id: envconv.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Environment Converter +;;; package: (compiler midend) + +(declare (usual-integrations)) + +;; ENVCONV replaces instances of +;; (LOOKUP ) +;; where is bound in a reified frame with either of +;; 1. +;; (CALL (QUOTE ,%*lookup) (QUOTE #F) (LOOKUP ,env-variable) +;; (QUOTE ) (QUOTE ) (QUOTE )) +;; where and represent the lexical address of the binding +;; of from the referencing frame. +;; 2. +;; (CALL (QUOTE ,%variable-cache-ref) (QUOTE #F) +;; (LOOKUP ) (QUOTE )) +;; where is a new variable bound to +;; (CALL (QUOTE ,%make-read-variable-cache) (QUOTE #F) +;; (LOOKUP ,env-variable) (QUOTE )) +;; +;; (UNASSIGNED? ), (SET! ), and (CALL (LOOKUP ) ...) +;; are translated simiarly +;; +;; Variable references to variables bound in reified frames are considered +;; captured by closest reified frame to the frame in which the reference +;; occurs. References to such captured variables may be implemented using +;; calls or variable caches. +;; The environment optimization level determines which of these frames +;; use variable cells: +;; A. If LOW, none. +;; B. If MEDIUM, only those whose context is TOP-LEVEL. (maybe ONCE-ONLY too?) +;; C. If HIGH, all. + +;; Parameters + +(define envconv/optimization-level 'MEDIUM) +(define envconv/variable-caches-must-be-static? true) +(define envconv/top-level-name (intern "#[top-level]")) + +(define *envconv/compile-by-procedures?* false) +(define *envconv/procedure-result?* false) +(define *envconv/copying?*) +(define *envconv/separate-queue*) +(define *envconv/top-level-program*) +(define *envconv/debug/walking-queue* #F) + +(define (envconv/top-level program) + (fluid-let ((*envconv/copying?* false) + (*envconv/separate-queue* '()) + (*envconv/top-level-program* program)) + (let ((result (envconv/trunk 'TOP-LEVEL program + (lambda (copy? program*) + copy? ; ignored + program*)))) + (fluid-let ((*envconv/debug/walking-queue* #T)) + (for-each envconv/do-compile! + (reverse *envconv/separate-queue*))) + result))) + +(define-macro (define-environment-converter keyword bindings . body) + (let ((proc-name (symbol-append 'ENVCONV/ keyword))) + (call-with-values + (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form))) + (lambda (names code) + `(define ,proc-name + (let ((handler (lambda ,(cons (car bindings) names) ,@body))) + (named-lambda (,proc-name env form) + (envconv/remember ,code + form + (envconv/env/block env))))))))) + +;;;; Environment-sensitive forms + +(define-environment-converter LOOKUP (env name) + (envconv/new-reference env name `(LOOKUP ,name))) + +(define-environment-converter UNASSIGNED? (env name) + (envconv/new-reference env name `(UNASSIGNED? ,name))) + +(define-environment-converter SET! (env name value) + (let ((value* (envconv/expr-with-name env value name))) + (envconv/new-reference env name `(SET! ,name ,value*)))) + +(define (envconv/lambda env form name) + (let ((form* + (let ((lambda-list (lambda/formals form)) + (body (lambda/body form))) + (if (or (not (eq? (envconv/env/context env) 'TOP-LEVEL)) + (not *envconv/compile-by-procedures?*) + *envconv/procedure-result?* + (eq? form *envconv/top-level-program*)) + (envconv/lambda* 'ARBITRARY env lambda-list body) + (envconv/compile-separately form name true env))))) + (envconv/remember form* + form + (if (LAMBDA/? form*) + (let* ((body (lambda/body form*)) + (body-info (code-rewrite/original-form body))) + (cond ((not body-info) false) + ((new-dbg-procedure? body-info) + (new-dbg-block/parent + (new-dbg-procedure/block body-info))) + (else + (new-dbg-expression/block body-info)))) + (envconv/env/block env))))) + + +(define (envconv/lambda* context* env lambda-list body) + (envconv/binding-body context* + env + (lambda-list->names lambda-list) + body + (lambda (body*) + `(LAMBDA ,lambda-list + ,body*)))) + +(define-environment-converter LET (env bindings body) + (let ((bindings* (lmap (lambda (binding) + (list (car binding) + (envconv/expr env (cadr binding)))) + bindings))) + (envconv/binding-body (let ((context (envconv/env/context env))) + (if (eq? context 'TOP-LEVEL) + 'ONCE-ONLY + context)) + env + (lmap car bindings) + body + (lambda (body*) + `(LET ,bindings* + ,body*))))) + +;;;; Forms removed + +(define-environment-converter THE-ENVIRONMENT (env) + (envconv/env/reify! env) + `(LOOKUP ,(envconv/env/reified-name env))) + +(define-environment-converter ACCESS (env name envxpr) + (cond ((equal? envxpr `(THE-ENVIRONMENT)) + (envconv/lookup env `(LOOKUP ,name))) + ;; The linker cannot currently hack this + ((envconv/package-reference? envxpr) + (envconv/package-lookup (envconv/package-name envxpr) name)) + (else + `(CALL (QUOTE ,%*lookup) + (QUOTE #F) + ,(envconv/expr env envxpr) + (QUOTE ,name) + ;; No lexical information known + (QUOTE #f) + (QUOTE #f))))) + +(define-environment-converter DEFINE (env name value) + (let ((value* (envconv/expr-with-name env value name))) + (cond ((not (envconv/env/parent env)) + ;; Incremental at top-level + (envconv/env/reify! env) + `(CALL (QUOTE ,%*define) + (QUOTE #F) + (LOOKUP ,(envconv/env/reified-name env)) + (QUOTE ,name) + ,value*)) + ((envconv/env/locally-bound? env name) + (envconv/new-reference env name `(SET! ,name ,value*))) + (else + (internal-error "Unscanned definition encountered" + `(DEFINE ,name ,value)))))) + +#| + (define-environment-converter IN-PACKAGE (env envxpr bodyxpr) + (if (equal? envxpr `(THE-ENVIRONMENT)) + (envconv/expr env bodyxpr) + (envconv/trunk/new (envconv/env/context env) + (envconv/expr env envxpr) + bodyxpr))) +|# + +(define-environment-converter IN-PACKAGE (env env-expr body-expr) + (if (equal? env-expr `(THE-ENVIRONMENT)) + (envconv/expr env body-expr) + (envconv/split-subprogram + (or (eq? (envconv/env/context env) 'ARBITRARY) + *envconv/copying?*) + body-expr + (envconv/expr env env-expr)))) + +;;;; Environment-insensitive forms + +;; CALL is conceptually insensitive, but common cases are optimized. + +(define-environment-converter CALL (env rator cont #!rest rands) + (define (default) + `(CALL ,(if (LAMBDA/? rator) + (envconv/remember + (envconv/lambda* + (if (eq? (envconv/env/context env) 'ARBITRARY) + 'ARBITRARY + 'ONCE-ONLY) + env (lambda/formals rator) (lambda/body rator)) + rator + (envconv/env/block env)) + (envconv/expr env rator)) + + ,(envconv/expr env cont) + ,@(envconv/expr* env rands))) + + (cond ((LOOKUP/? rator) + (let ((name (lookup/name rator))) + (envconv/new-reference + env + name + `(CALL ,(envconv/remember `(LOOKUP ,name) + rator + (envconv/env/block env)) + ,(envconv/expr env cont) + ,@(envconv/expr* env rands))))) + ((ACCESS/? rator) + (if (not (envconv/package-reference? (access/env-expr rator))) + (default) + (begin + (envconv/env/reify-top-level! env) + (envconv/new-reference + env + envconv/top-level-name + `(CALL ,(envconv/remember + `(ACCESS ,(access/name rator) + ,(envconv/expr env (access/env-expr rator))) + rator + (envconv/env/block env)) + ,(envconv/expr env cont) + ,@(envconv/expr* env rands)))))) + (else + (default)))) + +(define-environment-converter BEGIN (env #!rest actions) + `(BEGIN ,@(envconv/expr* env actions))) + +(define-environment-converter IF (env pred conseq alt) + `(IF ,(envconv/expr env pred) + ,(envconv/expr env conseq) + ,(envconv/expr env alt))) + +(define-environment-converter OR (env pred alt) + `(OR ,(envconv/expr env pred) + ,(envconv/expr env alt))) + +(define-environment-converter DELAY (env expr) + `(DELAY ,(envconv/expr env expr))) + +(define-environment-converter QUOTE (env object) + env ; ignored + `(QUOTE ,object)) + +(define-environment-converter DECLARE (env #!rest anything) + env ; ignored + `(DECLARE ,@anything)) + +;;;; Dispatcher + +(define (envconv/expr-with-name env expr name) + (if (not (pair? expr)) + (illegal expr)) + (case (car expr) + ((QUOTE) + (envconv/quote env expr)) + ((LOOKUP) + (envconv/lookup env expr)) + ((LAMBDA) + (envconv/lambda env expr name)) + ((LET) + (envconv/let env expr)) + ((DECLARE) + (envconv/declare env expr)) + ((CALL) + (envconv/call env expr)) + ((BEGIN) + (envconv/begin env expr)) + ((IF) + (envconv/if env expr)) + ((SET!) + (envconv/set! env expr)) + ((UNASSIGNED?) + (envconv/unassigned? env expr)) + ((OR) + (envconv/or env expr)) + ((DELAY) + (envconv/delay env expr)) + ((ACCESS) + (envconv/access env expr)) + ((DEFINE) + (envconv/define env expr)) + ((IN-PACKAGE) + (envconv/in-package env expr)) + ((THE-ENVIRONMENT) + (envconv/the-environment env expr)) + ((LETREC) + (not-yet-legal expr)) + (else + (illegal expr)))) + +(define (envconv/expr env expr) + (envconv/expr-with-name env expr #f)) + +(define (envconv/expr* env exprs) + (lmap (lambda (expr) + (envconv/expr env expr)) + exprs)) + +(define (envconv/remember new old block) + (call-with-values + (lambda () (code-rewrite/original-form*/previous old)) + (lambda (available? dbg-info) + (if available? + (if (new-dbg-procedure? dbg-info) + (begin + (if (not (new-dbg-procedure/block dbg-info)) + (set-new-dbg-procedure/block! dbg-info block)) + (code-rewrite/remember* new dbg-info)) + (begin + (if (not (new-dbg-expression/block dbg-info)) + (set-new-dbg-expression/block! dbg-info block)) + (code-rewrite/remember* new dbg-info)))))) + new) + +(define (envconv/split new old) + (let ((old* (code-rewrite/original-form old))) + (if old* + (code-rewrite/remember* new + (if (new-dbg-procedure? old*) + (new-dbg-procedure/copy old*) + old*))) + new)) + +(define (envconv/new-name prefix) + (new-variable prefix)) + +;;;; Environment utilities + +(define-structure (envconv/env + (conc-name envconv/env/) + (constructor envconv/env/%make (context parent block))) + (context false read-only true) + (reified-name false read-only false) + (depth (if parent + (1+ (envconv/env/depth parent)) + 0) + read-only true) + (nearest-reified false read-only false) + (parent false read-only true) + (children '() read-only false) + (bindings '() read-only false) + (number 0 read-only false) + (captured '() read-only false) + (wrapper false read-only false) + (body false read-only false) + (result false read-only false) + (block false read-only false)) + +(define-structure + (envconv/binding + (conc-name envconv/binding/) + (constructor envconv/binding/make (name env number)) + (print-procedure + (standard-unparser-method 'ENVCONV/BINDING + (lambda (binding port) + (write-char #\space port) + (write-string (symbol-name (envconv/binding/name binding)) port))))) + + (name false read-only true) + (env false read-only true) + (number false read-only true) + (references '() read-only false)) + +(define-structure (envconv/separate-compilation-key + (conc-name envconv/key/) + (constructor envconv/key/make + (form name procedure? env))) + (form false read-only false) ; The form to compile later + (name false read-only false) ; Name, if any, for procedures + (procedure? false read-only false) ; Must generate a procedure? + (env false read-only false)) ; Environment when enqueued + +(define (envconv/env/make context parent) + (let ((env + (envconv/env/%make + context parent + (new-dbg-block/make (if (eq? context 'TOP-LEVEL) + 'FIRST-CLASS + 'NESTED) + (and parent + (envconv/env/block parent)))))) + (if parent + (set-envconv/env/children! parent + (cons env (envconv/env/children parent)))) + env)) + +(define-integrable (envconv/env/reified? env) + (envconv/env/reified-name env)) + +(define (envconv/env/reify! env) + (if (not (envconv/env/reified? env)) + (let ((env-var (new-environment-variable))) + (set-envconv/env/reified-name! env env-var) + (let ((block (envconv/env/block env))) + (if block + (set-new-dbg-block/type! block 'FIRST-CLASS))) + (let ((parent (envconv/env/parent env))) + (and parent + (envconv/env/reify! parent)))))) + +(define (envconv/env/reify-top-level! env) + (if (not (envconv/env/reified? env)) + (let ((parent (envconv/env/parent env))) + (if (not parent) + (envconv/env/reify! env) + (envconv/env/reify-top-level! parent))))) + +(define (envconv/new-reference env name reference) + (let ((binding (envconv/env/lookup! env name))) + (set-envconv/binding/references! + binding + (cons (cons env reference) + (envconv/binding/references binding))) + reference)) + +(define (envconv/env/lookup! env name) + (let spine-loop ((frame env) (frame* false)) + (cond ((not frame) + (let* ((number (envconv/env/number frame*)) + (binding (envconv/binding/make name frame* number))) + (set-envconv/env/number! frame* (1+ number)) + (envconv/env/reify! frame*) + (set-envconv/env/bindings! + frame* + (cons binding (envconv/env/bindings frame*))) + binding)) + ((envconv/env/lookup/local frame name)) + (else + (spine-loop (envconv/env/parent frame) frame))))) + +(define (envconv/env/lookup/local env name) + (let rib-loop ((bindings (envconv/env/bindings env))) + (cond ((null? bindings) + false) + ((eq? name (envconv/binding/name (car bindings))) + (car bindings)) + (else + (rib-loop (cdr bindings)))))) + +(define (envconv/env/locally-bound? env name) + (envconv/env/lookup/local env name)) + +#| +(define (envconv/trunk/new context envcode program) + (envconv/trunk context program + (lambda (copy? program*) + (envconv/split-subprogram copy? program* envcode)))) +|# + +(define (envconv/trunk context program wrapper) + (let* ((copying* (or (eq? context 'ARBITRARY) *envconv/copying?*)) + (env (envconv/env/make 'TOP-LEVEL #f)) + (result (fluid-let ((*envconv/copying?* copying*)) + (envconv/expr env program))) + (needs? (or (envconv/env/reified? env) + (not (null? (envconv/env/bindings env)))))) + (envconv/process-root! + env + (envconv/env/setup! + env result + (lambda (result) + (wrapper copying* + (if (not needs?) + result + `(LET ((,(envconv/env/reified-name env) + (CALL (QUOTE ,%fetch-environment) (QUOTE #F)))) + ,result)))))))) + +(define (envconv/binding-body context* env names body body-wrapper) + (let* ((env* (envconv/env/make context* env)) + (body* + (begin + (let loop ((number 0) + (names* names) + (bindings '())) + (if (null? names*) + (let ((block (envconv/env/block env*))) + (if block + (set-new-dbg-block/variables! + block + (map (lambda (name) + (new-dbg-variable/make name block)) + names))) + (set-envconv/env/bindings! env* bindings) + (set-envconv/env/number! env* number)) + (loop (1+ number) + (cdr names*) + (cons (envconv/binding/make (car names*) env* number) + bindings)))) + (envconv/expr env* body)))) + (envconv/env/setup! + env* body* + (if (not (envconv/env/reified? env*)) + body-wrapper + (lambda (body*) + (body-wrapper + (envconv/bind-new-environment env* names body*))))))) + +(define (envconv/env/setup! env result wrapper) + (let ((result* (wrapper result))) + (set-envconv/env/body! env result) + (set-envconv/env/wrapper! env wrapper) + (set-envconv/env/result! env result*) + result*)) + +(define (envconv/bind-new-environment env* names body*) + (bind (envconv/env/reified-name env*) + `(CALL (QUOTE ,%*make-environment) + (QUOTE #F) + (LOOKUP ,(envconv/env/reified-name (envconv/env/parent env*))) + (QUOTE ,(list->vector (cons lambda-tag:make-environment + names))) + ,@(lmap (lambda (name) + `(LOOKUP ,name)) + names)) + body*)) + +(define (envconv/process-root! top-level-env top-level-program) + (if (envconv/env/reified? top-level-env) + (begin + (envconv/shorten-paths! top-level-env) + (envconv/capture! top-level-env) + (envconv/rewrite-references! top-level-env))) + top-level-program) + +(define (envconv/shorten-paths! env) + (set-envconv/env/nearest-reified! + env + (if (envconv/env/reified? env) + env + (envconv/env/nearest-reified (envconv/env/parent env)))) + (for-each envconv/shorten-paths! (envconv/env/children env))) + +(define (envconv/capture! env) + (if (envconv/env/reified? env) + (begin + (for-each + (lambda (binding) + (let loop ((refs (envconv/binding/references binding))) + (if (not (null? refs)) + (let* ((ref (car refs)) + (env* (envconv/env/nearest-reified (car ref))) + (place (assq binding (envconv/env/captured env*)))) + (if (not place) + (set-envconv/env/captured! + env* + (cons (list binding (cdr ref)) + (envconv/env/captured env*))) + (set-cdr! place + (cons (cdr ref) (cdr place)))) + (loop (cdr refs)))))) + (envconv/env/bindings env)) + (for-each envconv/capture! (envconv/env/children env))))) + +(define (envconv/rewrite-references! env) + (if (envconv/env/reified? env) + (begin + (if (not (null? (envconv/env/captured env))) + (let ((process-captures! + (case envconv/optimization-level + ((LOW) envconv/use-calls!) + ((MEDIUM) + (if (envconv/medium/cache? (envconv/env/context env)) + envconv/use-caches! + envconv/use-calls!)) + ((HIGH) envconv/use-caches!) + (else + (configuration-error "Illegal switch setting" + 'ENVCONV/OPTIMIZATION-LEVEL + envconv/optimization-level))))) + (process-captures! env))) + (for-each envconv/rewrite-references! (envconv/env/children env))))) + +(define (envconv/medium/cache? context) + (eq? context 'TOP-LEVEL)) + +(define (envconv/use-calls! env) + (let ((env-name (envconv/env/reified-name env))) + (for-each + (lambda (capture) + (let ((binding (car capture))) + (let ((var-name (envconv/binding/name binding)) + (binding-env (envconv/binding/env binding))) + (let* ((depth (and (envconv/env/parent binding-env) + (- (envconv/env/depth env) + (envconv/env/depth binding-env)))) + (offset (and depth (envconv/binding/number binding)))) + (for-each + (lambda (reference) + (let ((simple-var + (lambda () + `(CALL (QUOTE ,%*lookup) + (QUOTE #f) + (LOOKUP ,env-name) + (QUOTE ,var-name) + (QUOTE ,depth) + (QUOTE ,offset))))) + (form/rewrite! + reference + (case (car reference) + ((LOOKUP) + (simple-var)) + ((SET!) + `(CALL (QUOTE ,%*set!) + (QUOTE #F) + (LOOKUP ,env-name) + (QUOTE ,var-name) + (QUOTE ,depth) + (QUOTE ,offset) + ,(set!/expr reference))) + ((UNASSIGNED?) + `(CALL (QUOTE ,%*unassigned?) + (QUOTE #F) + (LOOKUP ,env-name) + (QUOTE ,var-name) + (QUOTE ,depth) + (QUOTE ,offset))) + ((CALL) + (let ((rator (call/operator reference))) + (case (car rator) + ((LOOKUP) + (form/rewrite! rator (simple-var))) + ((ACCESS) + ;; Only done for packages + (form/rewrite! + rator + (envconv/package-lookup + (envconv/package-name (access/env-expr rator)) + (access/name rator)))) + (else + (internal-error "Unknown reference kind" + reference)))) + reference) + (else + (internal-error "Unknown reference kind" + reference)))))) + (cdr capture)))))) + (envconv/env/captured env)))) + +(define (envconv/use-caches! env) + (let ((env-name (envconv/env/reified-name env))) + (define (local-operator-variable-cache-maker ignore name arity) + ignore ; ignored + `(CALL (QUOTE ,%make-operator-variable-cache) + (QUOTE #F) + (LOOKUP ,env-name) + (QUOTE ,name) + (QUOTE ,arity))) + + (define (remote-operator-variable-cache-maker package-name name arity) + `(CALL (QUOTE ,%make-remote-operator-variable-cache) + (QUOTE #F) + (QUOTE ,package-name) + (QUOTE ,name) + (QUOTE ,arity))) + + (define (read-variable-cache-maker name) + `(CALL (QUOTE ,%make-read-variable-cache) + (QUOTE #F) + (LOOKUP ,env-name) + (QUOTE ,name))) + + (define (write-variable-cache-maker name) + `(CALL (QUOTE ,%make-write-variable-cache) + (QUOTE #F) + (LOOKUP ,env-name) + (QUOTE ,name))) + + (define (new-cell! kind name maker) + (let ((place (assq name (cdr kind)))) + (if place + (cadr place) + (let ((cell-name + (envconv/new-name (symbol-append name (car kind))))) + (declare-variable-property! cell-name '(VARIABLE-CELL)) + (set-cdr! kind + (cons (list name cell-name (maker name)) + (cdr kind))) + cell-name)))) + + (define (new-operator-cell! name arity refs by-arity maker extra) + (define (new-cell!) + (let ((cell-name + (envconv/new-name + (symbol-append name '- + (string->symbol (number->string arity)) + (car refs))))) + (declare-variable-property! cell-name '(VARIABLE-CELL)) + (set-cdr! refs + (cons (list name cell-name + (maker extra name arity)) + (cdr refs))) + cell-name)) + + (let ((place (assq name (cdr by-arity)))) + (if (not place) + (let ((cell-name (new-cell!))) + (set-cdr! by-arity + (cons (list name (cons arity cell-name)) + (cdr by-arity))) + cell-name) + (let ((place* (assq arity (cdr place)))) + (if (not place*) + (let ((cell-name (new-cell!))) + (set-cdr! place + (cons (cons arity cell-name) (cdr place))) + cell-name) + (cdr place*)))))) + + (let ((read-refs (list '-READ-CELL)) + (write-refs (list '-WRITE-CELL)) + (exe-refs (list '-EXECUTE-CELL)) + (exe-by-arity (list 'EXE-BY-ARITY)) + (remote-exe-refs (list '-REMOTE-EXECUTE-CELL)) + (remote-exe-by-package '())) + + (for-each + (lambda (capture) + (let ((binding (car capture))) + (let ((var-name (envconv/binding/name binding))) + (for-each + (lambda (reference) + (form/rewrite! + reference + (case (car reference) + ((LOOKUP) + (let ((cell-name + (new-cell! read-refs var-name + read-variable-cache-maker))) + `(CALL (QUOTE ,%variable-cache-ref) + (QUOTE #F) + (LOOKUP ,cell-name) + (QUOTE ,var-name)))) + ((SET!) + (let ((write-cell-name + (new-cell! write-refs var-name + write-variable-cache-maker)) + (read-cell-name + (new-cell! read-refs var-name + read-variable-cache-maker)) + (temp-name (envconv/new-name var-name))) + (bind temp-name + `(CALL (QUOTE ,%safe-variable-cache-ref) + (QUOTE #F) + (LOOKUP ,read-cell-name) + (QUOTE ,var-name)) + `(BEGIN + (CALL (QUOTE ,%variable-cache-set!) + (QUOTE #F) + (LOOKUP ,write-cell-name) + ,(set!/expr reference) + (QUOTE ,var-name)) + (LOOKUP ,temp-name))))) + ((UNASSIGNED?) + (let ((cell-name (new-cell! read-refs var-name + read-variable-cache-maker))) + `(CALL (QUOTE ,%unassigned?) + (QUOTE #F) + (CALL (QUOTE ,%safe-variable-cache-ref) + (QUOTE #F) + (LOOKUP ,cell-name) + (QUOTE ,var-name))))) + + ((CALL) + (let ((rator (call/operator reference))) + (define (operate %invoke name refs by-arity maker extra) + (let* ((arity (length (cdddr reference))) + (cell-name + (new-operator-cell! + name + arity + refs by-arity maker extra))) + (form/rewrite! rator `(LOOKUP ,cell-name)) + `(CALL (QUOTE ,%invoke) + ,(call/continuation reference) + (QUOTE (,name ,arity)) + ,rator + ,@(cdddr reference)))) + + (case (car rator) + ((LOOKUP) + (operate %invoke-operator-cache + var-name exe-refs exe-by-arity + local-operator-variable-cache-maker + false)) + ((ACCESS) + (let ((package (envconv/package-name + (access/env-expr rator)))) + (operate + %invoke-remote-cache + (access/name rator) remote-exe-refs + (or (assoc package remote-exe-by-package) + (let ((new (list package))) + (set! remote-exe-by-package + (cons new remote-exe-by-package)) + new)) + remote-operator-variable-cache-maker + package))) + (else + (internal-error "Unknown reference kind" + reference))))) + (else + (internal-error "Unknown reference kind" + reference))))) + (cdr capture))))) + (envconv/env/captured env)) + + ;; Rewrite top-level to bind caches, separately compile, and + ;; copy if necessary, according to context. + (form/rewrite! (envconv/env/result env) + ((envconv/env/wrapper env) + (envconv/wrap-with-cache-bindings + env + (append (cdr read-refs) + (cdr write-refs) + (cdr exe-refs) + (cdr remote-exe-refs)) + (let ((form (envconv/env/body env))) + (envconv/split (form/preserve form) + form)))))))) + +(define (envconv/wrap-with-cache-bindings env cells body) + (let ((body* + `(CALL (LAMBDA (,(new-continuation-variable) ,@(lmap cadr cells)) + ,body) + (QUOTE #F) + ,@(lmap caddr cells)))) + (if (or (eq? (envconv/env/context env) 'TOP-LEVEL) + (not envconv/variable-caches-must-be-static?)) + body* + (envconv/split-subprogram + (eq? (envconv/env/context env) 'ARBITRARY) + `(LET ((,(envconv/env/reified-name env) + (CALL (QUOTE ,%fetch-environment) (QUOTE #F)))) + ,body*) + `(LOOKUP ,(envconv/env/reified-name env)))))) + +(define (envconv/split-subprogram copy? program envcode) + (let ((program* (envconv/compile-separately program #f #f #f))) + `(CALL (QUOTE ,%execute) + (QUOTE #F) + ,(if copy? + `(CALL (QUOTE ,%copy-program) (QUOTE #F) ,program*) + program*) + ,envcode))) + +(define (envconv/compile-separately form name procedure? env) + (let* ((form* `(QUOTE ,form)) + (key (envconv/key/make form* name procedure? env))) + ;;(if *envconv/debug/walking-queue* + ;; (internal-error + ;; "ENVCONV/COMPILE-SEPARATELY: Walking queue" key)) + (set! *envconv/separate-queue* + (cons key *envconv/separate-queue*)) + form*)) + +(define (envconv/do-compile! key) + ;; *** Worry about debugging info propagation *** + ;; It should not be difficult since it performs a single traversal + ;; through the compiler. However, the sequence of transforms + ;; needs to be collected and integrated into the current one. + ;; KEY is (form procedure? . name) + (let ((form (envconv/key/form key)) + (procedure? (envconv/key/procedure? key)) + (name (envconv/key/name key)) + (env (envconv/key/env key))) + (call-with-values + (lambda () + (compile-recursively (quote/text form) procedure? name)) + (lambda (compiled must-be-called?) + (if must-be-called? + (let ((env-var-name + (and env (envconv/env/reified-name env)))) + (if env-var-name + (let ((proc-name (envconv/new-name + (or name 'ENVCONV-PROCEDURE)))) + (form/rewrite! form + `(LET ((,proc-name (QUOTE ,compiled))) + (CALL (LOOKUP ,proc-name) + (QUOTE #F) + (LOOKUP ,env-var-name))))) + (internal-error + "ENVCONV/DO-COMPILE!: environment not reified" + key))) + (form/rewrite! form `(QUOTE ,compiled))))))) + +;; The linker knows how to make global operator references, +;; but could be taught how to make arbitrary package references. +;; *** IMPORTANT: These must be captured! **** + +(define %system-global-environment #f) + +(define (envconv/package-reference? expr) + (equal? expr `(QUOTE ,%system-global-environment))) + +(define (envconv/package-name expr) + expr ; ignored + #f) + +(define (envconv/package-lookup package name) + package ; ignored + `(CALL (QUOTE ,%*lookup) + (QUOTE #F) + (QUOTE ,%system-global-environment) + (QUOTE ,name) + (QUOTE #f) + (QUOTE #f))) \ No newline at end of file diff --git a/v8/src/compiler/midend/expand.scm b/v8/src/compiler/midend/expand.scm new file mode 100644 index 000000000..faee124df --- /dev/null +++ b/v8/src/compiler/midend/expand.scm @@ -0,0 +1,347 @@ +#| -*-Scheme-*- + +$Id: expand.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Simple special form expansion +;;; package: (compiler midend) + +(declare (usual-integrations)) + +(define (expand/top-level program) + (expand/expr program)) + +(define-macro (define-expander keyword bindings . body) + (let ((proc-name (symbol-append 'EXPAND/ keyword))) + (call-with-values + (lambda () + (%matchup bindings '(handler) '(cdr form))) + (lambda (names code) + `(define ,proc-name + (let ((handler (lambda ,names ,@body))) + (named-lambda (,proc-name form) + (expand/remember ,code + form)))))))) + +;;;; Core forms: simply expand components + +(define-expander QUOTE (object) + `(QUOTE ,object)) + +(define-expander LOOKUP (name) + `(LOOKUP ,name)) + +(define-expander SET! (name value) + `(SET! ,name ,(expand/expr value))) + +(define-expander LAMBDA (lambda-list body) + (expand/rewrite/lambda lambda-list (expand/expr body))) + +(define (expand/rewrite/lambda lambda-list body) + (cond ((memq '#!AUX lambda-list) + => (lambda (tail) + (let ((rest (list-prefix lambda-list tail)) + (auxes (cdr tail))) + `(LAMBDA ,rest + ,(if (null? auxes) + body + `(LET ,(lmap (lambda (aux) + (list aux `(QUOTE ,%unassigned))) + auxes) + ,(expand/aux/sort auxes body))))))) + (else + `(LAMBDA ,lambda-list ,body)))) + +(define-expander LET (bindings body) + (expand/let* expand/letify bindings body)) + +(define-expander DECLARE (#!rest anything) + `(DECLARE ,@anything)) + +(define-expander CALL (rator cont #!rest rands) + (if (and (pair? rator) (eq? (car rator) 'LAMBDA)) + (let ((result + (let ((rator* (expand/rewrite/lambda (cadr rator) (caddr rator)))) + (expand/let* (lambda (bindings body) + (expand/pseudo-letify rator bindings body)) + (expand/bindify (cadr rator*) + (cons cont rands)) + (caddr rator*))))) + (expand/remember (cadr result) rator) + result) + `(CALL ,(expand/expr rator) + ,(expand/expr cont) + ,@(expand/expr* rands)))) + +(define-expander BEGIN (#!rest actions) + (expand/code-compress (expand/expr* actions))) + +(define-expander IF (pred conseq alt) + `(IF ,(expand/expr pred) + ,(expand/expr conseq) + ,(expand/expr alt))) + +;;;; Sort AUX bindings so that ASSCONV will do a better job. + +(define (expand/aux/sort auxes body) + (if (or (not (pair? body)) + (not (eq? (car body) 'BEGIN))) + body + (let loop ((actions (simplify-actions (cdr body))) + (last false) + (decls '()) + (early '()) + (late '())) + + (define (done) + (beginnify + (append decls + (reverse early) + (reverse late) + (cond ((not (null? actions)) + actions) + ((not last) + (user-error "Empty body" body)) + (else + ;; MIT Scheme semantics: the value of a + ;; DEFINE is the name defined. + (list `(QUOTE ,(set!/name last)))))))) + + (if (or (null? actions) + (not (pair? (car actions)))) + (done) + (let ((action (car actions))) + (case (car action) + ((SET!) + (if (not (memq (set!/name action) auxes)) + (done) + (let ((value (set!/expr action)) + (next + (lambda (early* late*) + (loop (cdr actions) action + decls early* late*)))) + (set! auxes (delq (set!/name action) auxes)) + (if (or (not (pair? value)) + (not (memq (car value) '(QUOTE LAMBDA)))) + (next early (cons action late)) + (next (cons action early) late))))) + ((DECLARE) + (loop (cdr actions) + last (cons action decls) + early late)) + (else + (done)))))))) + +;;;; Derived forms: macro expand + +(define-expander UNASSIGNED? (name) + `(CALL (QUOTE ,%unassigned?) (QUOTE #F) (LOOKUP ,name))) + +(define-expander OR (pred alt) + ;; Trivial optimization here. + (let ((new-pred (expand/expr pred)) + (new-alt (expand/expr alt))) + + (define (default) + (let ((new-name (expand/new-name 'OR))) + (bind new-name + new-pred + `(IF (LOOKUP ,new-name) + (LOOKUP ,new-name) + ,new-alt)))) + + (case (car new-pred) + ((QUOTE) + (case (boolean/discriminate (cadr new-pred)) + ((TRUE) + new-pred) + ((FALSE) + new-alt) + (else ; UNKNOWN + (default)))) + ((LOOKUP) + `(IF ,new-pred ,new-pred ,new-alt)) + ((CALL) + (let ((rator (cadr new-pred))) + (if (and (pair? rator) + (eq? 'QUOTE (car rator)) + (operator/satisfies? (cadr rator) '(PROPER-PREDICATE))) + `(IF ,new-pred (QUOTE #t) ,new-alt) + (default)))) + (else + (default))))) + +(define-expander DELAY (expr) + `(CALL (QUOTE ,%make-promise) + (QUOTE #F) + (LAMBDA (,(new-continuation-variable)) + ,(expand/expr expr)))) + +(define (expand/expr expr) + (if (not (pair? expr)) + (illegal expr)) + (case (car expr) + ((QUOTE) + (expand/quote expr)) + ((LOOKUP) + (expand/lookup expr)) + ((LAMBDA) + (expand/lambda expr)) + ((LET) + (expand/let expr)) + ((DECLARE) + (expand/declare expr)) + ((CALL) + (expand/call expr)) + ((BEGIN) + (expand/begin expr)) + ((IF) + (expand/if expr)) + ((SET!) + (expand/set! expr)) + ((UNASSIGNED?) + (expand/unassigned? expr)) + ((OR) + (expand/or expr)) + ((DELAY) + (expand/delay expr)) + ((LETREC) + (not-yet-legal expr)) + ((ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT) + (no-longer-legal expr)) + (else + (illegal expr)))) + +(define (expand/expr* exprs) + (lmap expand/expr exprs)) + +(define (expand/remember new old) + (code-rewrite/remember new old)) + +(define (expand/new-name prefix) + (new-variable prefix)) + +(define (expand/let* letify bindings body) + (let ((bindings* (lmap (lambda (binding) + (list (car binding) + (expand/expr (cadr binding)))) + bindings))) + (let ((body* (expand/expr body))) + (if (null? bindings*) + body* + (letify bindings* body*))))) + +(define (expand/letify bindings body) + `(LET ,bindings + ,body)) + +(define (expand/pseudo-letify rator bindings body) + (pseudo-letify rator bindings body expand/remember)) + +(define (expand/bindify lambda-list operands) + (map (lambda (name operand) (list name operand)) + (lambda-list->names lambda-list) + (lambda-list/applicate lambda-list operands))) + +(define (expand/code-compress actions) + (define (->vector exprs) + (if (not (for-all? exprs + (lambda (expr) + (and (pair? expr) + (eq? (car expr) 'QUOTE))))) + `(CALL (QUOTE ,%vector) + (QUOTE #F) + ,@exprs) + `(QUOTE ,(list->vector (lmap cadr exprs))))) + + (define (->multi-define defns) + `(CALL (QUOTE ,%*define*) + (QUOTE #F) + ,(list-ref (car defns) 3) + (QUOTE ,(list->vector (lmap (lambda (defn) + (cadr (list-ref defn 4))) + defns))) + ,(->vector + (lmap (lambda (defn) + (list-ref defn 5)) + defns)))) + + (define (collect defns actions) + (cond ((null? defns) actions) + ((null? (cdr defns)) + (append defns actions)) + (else + (cons (->multi-define (reverse defns)) + actions)))) + + (let loop ((actions actions) + (defns '()) + (actions* '())) + (if (null? actions) + (beginnify (reverse (collect defns actions*))) + (let ((action (car actions))) + (cond ((not (and (pair? action) + (eq? (car action) 'CALL) + (let ((rator (cadr action))) + (and (pair? rator) + (eq? 'QUOTE (car rator)) + (eq? %*define (cadr rator)) + (expand/code-compress/trivial? + (list-ref action 5)))))) + (loop (cdr actions) + '() + (cons action + (collect defns actions*)))) + ((or (null? defns) + (not (equal? (list-ref action 3) + (list-ref (car defns) 3)))) + (loop (cdr actions) + (list action) + (collect defns actions*))) + (else + (loop (cdr actions) + (cons action defns) + actions*))))))) + +(define (expand/code-compress/trivial? expr) + (and (pair? expr) + (or (eq? (car expr) 'QUOTE) + (and (eq? (car expr) 'LAMBDA) + #| (let ((params (cadr expr))) + (if (or (null? params) + (null? cdr params) + (not (null? (cddr params)))) + (internal-error + "EXPAND/CODE-COMPRESS/TRIVIAL? param error" + params) + (ignored-variable? (second params)))) + |# )))) diff --git a/v8/src/compiler/midend/fakeprim.scm b/v8/src/compiler/midend/fakeprim.scm new file mode 100644 index 000000000..661ebfc01 --- /dev/null +++ b/v8/src/compiler/midend/fakeprim.scm @@ -0,0 +1,1019 @@ +#| -*-Scheme-*- + +$Id: fakeprim.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Pseudo primitives +;;; package: (compiler midend) + +(declare (usual-integrations)) + +;;;; Pseudo primitives + +(define *operator-properties* + (make-eq-hash-table)) + +(define (known-operator? rator) + (hash-table/get *operator-properties* rator false)) + +(define (simple-operator? rator) + (assq 'SIMPLE (hash-table/get *operator-properties* rator '()))) + +(define (hook-operator? rator) + (assq 'OUT-OF-LINE-HOOK (hash-table/get *operator-properties* rator '()))) + +(define (operator/satisfies? rator properties) + (let ((props (hash-table/get *operator-properties* rator '()))) + (for-all? properties + (lambda (prop) + (assq prop props))))) + +(define (make-constant name) + (intern name)) + +(define (make-operator name . properties) + (let ((operator (make-constant name))) + (hash-table/put! *operator-properties* + operator + (if (null? properties) + (list '(KNOWN)) + properties)) + operator)) + +(define (make-operator/simple name . more) + (apply make-operator name + '(SIMPLE) '(SIDE-EFFECT-INSENSITIVE) '(SIDE-EFFECT-FREE) more)) + +(define (make-operator/effect-sensitive name . more) + (apply make-operator name '(SIMPLE) '(SIDE-EFFECT-FREE) more)) + +(define (make-operator/simple* name . more) + (apply make-operator name '(SIMPLE) more)) + + +(define-macro (cookie-call name . parts) + (define (->string x) (if (symbol? x) (symbol-name x) x)) + (define (->sym . stuff) + (intern (apply string-append (map ->string stuff)))) + (define (make-predicate) + `(DEFINE-INTEGRABLE (,(->sym "call/" name "?") FORM) + (AND (PAIR? FORM) + (EQ? (CAR FORM) 'CALL) + (PAIR? (CDR FORM)) + (PAIR? (CADR FORM)) + (PAIR? (CDADR FORM)) + (EQ? (CAADR FORM) 'QUOTE) + (EQ? (CADADR FORM) ,name)))) + (define (loop args path defs) + (define (add-def field path quoted?) + (let* ((base-name (->sym "call/" name "/" field)) + (safe-name (->sym base-name "/safe")) + (unsafe-name (->sym base-name "/unsafe"))) + (cons* + `(DEFINE-INTEGRABLE (,base-name FORM) + (,safe-name FORM)) + `(DEFINE (,safe-name FORM) + (IF (AND (,(->sym "call/" name "?") FORM)(PAIR? FORM) + ,@(if quoted? + `((PAIR? ,path) + (EQ? (CAR ,path) 'QUOTE) + (PAIR? (CDR ,path))) + `())) + ,path + (INTERNAL-ERROR "Illegal Cookie call syntax" ',name FORM))) + `(DEFINE-INTEGRABLE (,unsafe-name FORM) + ,(if quoted? + `(CADR ,path) + path)) + defs))) + (cond ((null? args) + defs) + ((eq? (car args) '#!REST) + (add-def (cadr args) path #F)) + ((eq? (car args) '#F) + (loop (cdr args) `(CDR ,path) defs)) + ((equal? (car args) ''#F) + (loop (cdr args) `(CDR ,path) defs)) + ((and (pair? (car args)) (eq? (car (car args)) 'QUOTE)) + (loop (cdr args) + `(CDR ,path) + (add-def (cadr (car args)) `(CAR ,path) #T))) + (else + (loop (cdr args) + `(CDR ,path) + (add-def (car args) `(CAR ,path) #F))))) + `(BEGIN ,(make-predicate) + ,@(reverse (loop parts `(CDDR FORM) '())))) + +(define %*lookup + ;; (CALL ',%*lookup + ;; 'VARIABLE-NAME 'DEPTH 'OFFSET) + ;; Note: + ;; DEPTH and OFFSET are #F (unknown) or non-negative fixnums + ;; Introduced by envconv.scm, removed by compat.scm (replaced + ;; by a call to the primitive LEXICAL-REFERENCE) + (make-operator "#[*lookup]" '(SIDE-EFFECT-FREE))) + +(cookie-call %*lookup cont environment 'variable-name 'depth 'offset) + + +(define %*set! + ;; (CALL ',%*set! + ;; 'VARIABLE-NAME 'DEPTH 'OFFSET ) + ;; Note: + ;; DEPTH and OFFSET are #F (unknown) or non-negative fixnums + ;; Introduced by envconv.scm, removed by compat.scm (replaced + ;; by a call to the primitive LEXICAL-ASSIGNMENT) + (make-operator "#[*set!]")) + +(cookie-call %*set! cont environment 'VARIABLE-NAME 'DEPTH 'OFFSET value) + +(define %*unassigned? + ;; (CALL ',%*unassigned? + ;; 'VARIABLE-NAME 'DEPTH 'OFFSET) + ;; Note: + ;; DEPTH and OFFSET are #F (unknown) or non-negative fixnums + ;; Introduced by envconv.scm, removed by compat.scm (replaced + ;; by a call to the primitive LEXICAL-UNASSIGNED?) + ;; Returns a boolean value + (make-operator "#[*unassigned?]" '(SIDE-EFFECT-FREE))) + +(cookie-call %*unassigned? cont environment 'variable-name 'depth 'offset) + + +(define %*define + ;; (CALL ',%*define + ;; 'VARIABLE-NAME ) + ;; Note: + ;; Introduced by envconv.scm, removed by compat.scm (replaced + ;; by a call to the primitive LOCAL-ASSIGNMENT) + (make-operator "#[*define]")) + +(cookie-call %*define cont environment 'VARIABLE-NAME value) + + +(define %*define* + ;; (CALL ',%*define* + ;; ) + ;; Note: + ;; Introduced by expand.scm, removed by compat.scm (replaced + ;; by a call to the global procedure DEFINE-MULTIPLE) + (make-operator "#[*define*]")) + +(cookie-call %*define* cont environment 'names-vector 'values-vector) + + +(define %*make-environment + ;; (CALL ',%*make-environment + ;; *) + ;; Note: + ;; Introduced by envconv.scm, removed by compat.scm (replaced + ;; by a call to the global procedure *MAKE-ENVIRONMENT) + ;; The vector of names has one MORE name than values: the + ;; first name is the value of the variable + ;; LAMBDA-TAG:MAKE-ENVIRONMENT (self-name for use by + ;; unsyntaxer). + (make-operator "#[*make-environment]" '(SIDE-EFFECT-FREE))) + +(cookie-call %*make-environment cont env 'names-vector #!rest values) + + +;; %fetch-environment, %fetch-continuation, %fetch-stack-closure, and +;; the variable cache operations are simple, but should not be +;; substituted or reordered, hence they are not defined as +;; effect-insensitive or effect-free + +(define %fetch-environment + ;; (CALL ',%fetch-environment '#F) + ;; Note: + ;; Introduced by envconv.scm, open coded by RTL generator. + ;; Appears at the top-level of expressions to be executed at + ;; load-time or in first-class environment code. + (make-operator/simple* "#[fetch-environment]" '(STATIC))) + +(cookie-call %fetch-environment '#F) + +(define %make-operator-variable-cache + ;; (CALL ',%make-operator-variable-cache '#F + ;; 'NAME 'NARGS) + ;; Note: + ;; Introduced by envconv.scm, ignored by RTL generator. + ;; It is required to make the trivial KMP-Scheme evaluator work + ;; and to guarantee no free variable references in KMP-Scheme + ;; code. + (make-operator/effect-sensitive "#[make-operator-variable-cache]" + '(STATIC))) + +(cookie-call %make-operator-variable-cache '#F environment 'NAME 'NARGS) + +(define %make-remote-operator-variable-cache + ;; (CALL ',%make-remote-operator-variable-cache '#F + ;; 'PACKAGE-DESCRIPTOR 'NAME 'NARGS) + ;; Note: + ;; For now, the linker only supports #F (global environment) for + ;; the PACKAGE-DESCRIPTOR. + ;; Introduced by envconv.scm, ignored by RTL generator. + ;; It is required to make the trivial KMP-Scheme evaluator + ;; work and to guarantee no free variable references in + ;; KMP-Scheme code. + (make-operator/effect-sensitive "#[make-remote-operator-variable-cache]" + '(STATIC))) + + +(cookie-call %make-remote-operator-variable-cache '#F + 'PACKAGE-DESCRIPTOR 'NAME 'NARGS) + +(define %make-read-variable-cache + ;; (CALL ',%make-read-variable-cache '#F 'NAME) + ;; Note: + ;; Introduced by envconv.scm, ignored by RTL generator. + ;; It is required to make the trivial KMP-Scheme evaluator + ;; work and to guarantee no free variable references in + ;; KMP-Scheme code. + (make-operator/effect-sensitive "#[make-read-variable-cache]" + '(STATIC))) + +(cookie-call %make-read-variable-cache '#F environment 'NAME) + +(define %make-write-variable-cache + ;; (CALL ',%make-write-variable-cache '#F 'NAME) + ;; Note: + ;; Introduced by envconv.scm, ignored by RTL generator. + ;; It is required to make the trivial KMP-Scheme evaluator + ;; work and to guarantee no free variable references in + ;; KMP-Scheme code. + (make-operator/effect-sensitive "#[make-write-variable-cache]" + '(STATIC))) + +(cookie-call %make-write-variable-cache '#F environment 'NAME) + + +(define %invoke-operator-cache + ;; (CALL ',%invoke-operator-cache + ;; '(NAME NARGS) *) + ;; Note: + ;; Introduced by envconv.scm. + ;; NARGS is redundant with both the number of * + ;; expressions and the expression creating the + ;; This is used for operators to be referenced from the top-level + ;; (load-time) environment. + (make-operator "#[invoke-operator-cache]")) + +(cookie-call %invoke-operator-cache cont + 'descriptor operator-cache #!rest values) + +(define %invoke-remote-cache + ;; (CALL ',%invoke-remote-cache + ;; '(NAME NARGS) *) + ;; Note: + ;; Introduced by envconv.scm. + ;; NARGS is mostly redundant with both the number of * + ;; expressions and the expression creating the + ;; (but see *make-environment in compat.scm for an exception) + ;; This is used for operators to be referenced from arbitrary + ;; named packages, although the linker currently only supports + ;; the global environment. + (make-operator "#[invoke-remote-operator-cache]")) + +(cookie-call %invoke-remote-cache cont + 'descriptor operator-cache #!rest values) + +(define %variable-cache-ref + ;; (CALL ',%variable-cache-ref '#F 'NAME) + ;; Note: + ;; Introduced by envconv.scm, removed by compat.scm (replaced by a + ;; lot of hairy code) + ;; The NAME is redundant with the code that creates the variable cache + ;; Errors if the variable is unassigned or unbound. + (make-operator "#[variable-cache-ref]" + '(SIDE-EFFECT-FREE) '(OUT-OF-LINE-HOOK))) + +(cookie-call %variable-cache-ref '#F read-variable-cache 'NAME) + +(define %variable-cache-set! + ;; (CALL ',%variable-cache-set! '#F + ;; 'NAME) + ;; Note: + ;; Introduced by envconv.scm, removed by compat.scm (replaced by a + ;; lot of hairy code) + ;; The NAME is redundant with the code that creates the variable cache + (make-operator "#[variable-cache-set!]" '(OUT-OF-LINE-HOOK))) + +(cookie-call %variable-cache-set! '#F write-variable-cache value 'NAME) + +(define %safe-variable-cache-ref + ;; (CALL ',%safe-variable-cache-ref '#F 'NAME) + ;; Note: + ;; Introduced by envconv.scm, removed by compat.scm (replaced by a + ;; lot of hairy code) + ;; Doesn't error if the variable is currently unassigned (but it + ;; does error on unbound) + ;; The NAME is redundant with the code that creates the variable cache + (make-operator "#[safe-variable-cache-ref]" + '(SIDE-EFFECT-FREE) '(OUT-OF-LINE-HOOK))) + + +(cookie-call %safe-variable-cache-ref '#F read-variable-cache 'NAME) + +(define %variable-read-cache + ;; (CALL ',%variable-read-cache '#F 'NAME) + ;; Note: + ;; Introduced by compat.scm as part of rewriting + ;; %variable-cache-ref and %safe-variable-cache-ref + ;; This declares the existence of a variable cache, but doesn't + ;; read the contents. + (make-operator/simple "#[variable-read-cache]")) + +(cookie-call %variable-read-cache '#F read-variable-cache 'NAME) + +(define %variable-write-cache + ;; (CALL ',%variable-write-cache '#F 'NAME) + ;; Note: + ;; Introduced by compat.scm as part of rewriting + ;; %variable-cache-set! + ;; This declares the existence of a variable cache, but doesn't + ;; read the contents. + (make-operator/simple "#[variable-write-cache]")) + +(cookie-call %variable-write-cache '#F write-variable-cache 'NAME) + +(define %variable-cell-ref + ;; (CALL ',%variable-cell-ref '#F ) + ;; Note: + ;; Introduced by compat.scm as part of rewriting + ;; %variable-cache-ref and %safe-variable-cache-ref + ;; Does not checking of contents of cache (i.e. doesn't look for + ;; unassigned or unbound trap objects). Simply a data selector. + (make-operator/effect-sensitive "#[variable-cell-ref]")) + +(cookie-call %variable-cell-ref '#F read-variable-cache) + +(define %variable-cell-set! + ;; (CALL ',%variable-cell-ref '#F ) + ;; Note: + ;; Introduced by compat.scm as part of rewriting + ;; %variable-cache-set! + ;; Simply a data mutator. + (make-operator/simple* "#[variable-cell-set!]")) + +(cookie-call %variable-cell-set! '#F write-variable-cache value) + +(define %hook-variable-cell-ref + ;; (CALL ',%hook-variable-cell-ref + ;; ) + ;; Note: + ;; Introduced by compat.scm as part of rewriting + ;; %variable-cache-ref + ;; The reference must be done out of line for some reason. + ;; If the continuation is #F then the code generator is + ;; responsible for creating a return address and preserving all + ;; necessary state (registers) needed upon return. Otherwise + ;; there is no need to save state, but the variable reference + ;; should tail call into the continuation. + (make-operator "#[hook-variable-cell-ref]" + '(OUT-OF-LINE-HOOK) '(SPECIAL-INTERFACE))) + +(cookie-call %hook-variable-cell-ref cont read-variable-cache) + + +(define %hook-safe-variable-cell-ref + ;; (CALL ',%hook-safe-variable-cell-ref + ;; ) + ;; Note: + ;; Introduced by compat.scm as part of rewriting + ;; %safe-variable-cache-ref (qv) + ;; The reference must be done out of line for some reason. + ;; If the continuation is #F then the code generator is + ;; responsible for creating a return address and preserving all + ;; necessary state (registers) needed upon return. Otherwise + ;; there is no need to save state, but the variable reference + ;; should tail call into the continuation. + (make-operator "#[hook-safe-variable-cell-ref]" + '(OUT-OF-LINE-HOOK) '(SPECIAL-INTERFACE))) + +(cookie-call %hook-safe-variable-cell-ref cont read-variable-cache) + +(define %hook-variable-cell-set! + ;; (CALL ',%hook-safe-variable-cell-set! '#F + ;; ) + ;; Note: + ;; Introduced by compat.scm as part of rewriting + ;; %variable-cache-set! + ;; The reference must be done out of line for some reason. + ;; No is allowed because this would have been + ;; rewritten into something like + ;; (LET ((old-value ...)) (set! ...) (LOOKUP old-value)) + (make-operator "#[hook-variable-cell-set!]" + '(OUT-OF-LINE-HOOK) '(SPECIAL-INTERFACE))) + +(cookie-call %hook-variable-cell-set! '#F write-variable-cache value) + +(define %copy-program + ;; (CALL ',%copy-program ) + ;; Note: + ;; Introduced by envconv.scm and removed by compat.scm (replaced + ;; by a call to the global procedure COPY-PROGRAM). + ;; The value of is a compiled expression object. + ;; This is generated under the following (unusual?) circumstances: + ;; when a closure must be generated with variable caches (for + ;; free references) to an environment that is reified (because, + ;; for example, of a call to (the-environment)) and is neither the + ;; global nor the top-level (load-time) environment. By + ;; default, the compiler switches don't allow variable caches in + ;; this case. + ;; Typical code: + ;; (CALL ',%copy-program (LOOKUP CONT47) + ;; '#[COMPILED-EXPRESSION 23]) + (make-operator "#[copy-program]")) + +(cookie-call %copy-program cont program) + + +(define %execute + ;; (CALL ',%execute ) + ;; Note: + ;; Introduced by envconv.scm and removed by compat.scm (replaced + ;; by a call to the primitive procedure SCODE-EVAL). + ;; The value of is a compiled expression object. + ;; Typical code: + ;; (CALL ',%execute (LOOKUP CONT47) + ;; '#[COMPILED-EXPRESSION 23] (LOOKUP ENV43)) + (make-operator "#[execute]")) + +(cookie-call %execute cont program environment) + +(define %internal-apply + ;; (CALL ',%internal-apply 'NARGS *) + ;; Note: + ;; NARGS = number of expressions + ;; Introduced by applicat.scm. + (make-operator "#[internal-apply]")) + +(cookie-call %internal-apply cont 'NARGS procedure #!REST values) + + +(define %primitive-apply + ;; (CALL ',%primitive-apply + ;; 'NARGS ' *) + ;; Note: + ;; NARGS = number of expressions + ;; Introduced by applicat.scm and removed by compat.scm (replaced + ;; by %PRIMITIVE-APPLY/COMPATIBLE). + (make-operator "#[primitive-apply]")) + +(cookie-call %primitive-apply cont 'NARGS 'primitive-object #!rest values) + +(define %unspecific + ;; Magic cookie representing an ignorable value + (make-constant "#[unspecific]")) + +(define %unassigned + ;; The value of variables that do not yet have values ... + (make-constant "#[unassigned]")) + +(define %unassigned? + ;; (CALL ',%unassigned? '#F ) + ;; Note: + ;; Introduced by envconv.scm and expand.scm from the MIT Scheme + ;; special form (UNASSIGNED? ) + (make-operator/simple "#[unassigned?]" '(PROPER-PREDICATE))) + +(cookie-call %unassigned? '#F value) + + +(define %reference-trap? + ;; (CALL ',%reference-trap? '#F ) + ;; Note: + ;; Introduced by compat.scm as part of the rewrite of + ;; %variable-cache-ref, %safe-variable-cache-ref, and + ;; %variable-cache-set! + (make-operator/simple "#[reference-trap?]" '(PROPER-PREDICATE))) + +(cookie-call %reference-trap? '#F value) + +(define %cons + ;; (CALL ',%cons '#F ) + ;; Note: + ;; Introduced by LAMBDA-LIST/APPLICATE to do early application of + ;; a known lexpr (avoids an out-of-line call at runtime) + (make-operator/simple "#[cons]")) + +(cookie-call %cons '#F car-value cdr-value) + +(define %vector + ;; (CALL ',%vector '#F *) + ;; Note: + ;; Introduced by expand.scm for DEFINE-MULTIPLE + (make-operator/simple "#[vector]")) + +(cookie-call %vector '#F #!rest values) + +(define %make-promise + ;; (CALL ',%make-promise '#F ) + ;; Note: + ;; Introduced by expand.scm for DELAY + (make-operator/simple "#[make-promise]")) +(cookie-call %make-promise '#F thunk) + +(define %make-cell + ;; (CALL ',%make-cell '#F 'NAME) + ;; Note: + ;; Introduced by assconv.scm for local assigned variables. + (make-operator/simple "#[make-cell]")) +(cookie-call %make-cell '#F value 'NAME) + +(define %cell-ref + ;; (CALL ',%CALL '#F 'NAME) + ;; Note: + ;; Introduced by assconv.scm for read references to local assigned + ;; variables. + (make-operator/effect-sensitive "#[cell-ref]")) +(cookie-call %cell-ref '#F cell 'NAME) + +(define %cell-set! + ;; (CALL ',%CALL '#F 'NAME) + ;; Note: + ;; Introduced by assconv.scm for write references to local + ;; assigned variables. + ;; Returns no value, because the rewrite is to something like + ;; (LET ((old-value ...)) + ;; (CALL ',%cell-set! ...) + ;; (LOOKUP old-value)) + (make-operator/simple* "#[cell-set!]" '(UNSPECIFIC-RESULT))) + +(cookie-call %cell-set! '#F cell value '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) + +;; %heap-closure-ref, %stack-closure-ref, and %static-binding-ref are not +;; properly simple, but they can be considered such because %heap-closure-set!, +;; %make-stack-closure, and %static-binding-set! are used only in limited ways. + +(define %make-heap-closure + ;; (CALL ',%make-heap-closure '#F 'VECTOR + ;; *) + ;; Note: + ;; Introduced by closconv.scm (first time it is invoked). + ;; VECTOR is a vector of symbols whose length is the same as the + ;; number of expressions. + (make-operator/simple "#[make-heap-closure]")) + +(cookie-call %make-heap-closure '#F lambda-expression 'VECTOR #!rest values) + +(define %heap-closure-ref + ;; (CALL ',%heap-closure-ref '#F 'NAME) + ;; Note: + ;; Introduced by closconv.scm (first time it is invoked) + (make-operator/simple "#[heap-closure-ref]")) +(cookie-call %heap-closure-ref '#F closure offset 'NAME) + +(define %heap-closure-set! + ;; (CALL ',%heap-closure-set! '#F 'NAME) + (make-operator/simple* "#[heap-closure-set!]" '(UNSPECIFIC-RESULT))) +(cookie-call %heap-closure-set! '#F closure offset value 'NAME) + +(define %make-trivial-closure + ;; (CALL ',%make-trivial-closure '#F ) + ;; Note: + ;; Introduced by closconv.scm (first time it is invoked). + ;; Constructs an externally callable procedure object (all free + ;; variables are accessible through the variable caching + ;; mechanism). + ;; A LOOKUP is permitted only in a LETREC at the top level of a + ;; program. It is used to export one of the mutually recursive + ;; procedures introduced by the LETREC to the external + ;; environment. + (make-operator/simple "#[make-trivial-closure]")) +(cookie-call %make-trivial-closure '#F procedure) + +(define %make-static-binding + ;; (CALL ',%make-static-binding '#F 'NAME) + ;; Note: + ;; Generate a static binding cell for NAME, containing . + ;; Introduced by staticfy.scm (not currently working). + (make-operator/simple "#[make-static-binding]")) +(cookie-call %make-static-binding '#F value 'NAME) + +(define %static-binding-ref + ;; (CALL ',%static-binding-ref '#F 'NAME) + ;; Note: + ;; Introduced by staticfy.scm (not currently working). + (make-operator/simple "#[static-binding-ref]")) +(cookie-call %static-binding-ref '#F static-cell 'NAME) + +(define %static-binding-set! + ;; (CALL ',%static-binding-set! '#F 'NAME) + ;; Note: + ;; Introduced by staticfy.scm (not currently working). + (make-operator/simple* "#[static-binding-set!]" '(UNSPECIFIC-RESULT))) +(cookie-call %static-binding-set! '#F static-cell value 'NAME) + +(define %make-return-address + ;; (CALL ',%make-return-address '#F ) + ;; Note: + ;; Used internally in rtlgen.scm when performing trivial rewrites + ;; before calling itself recursively. + (make-operator/simple "#[make-return-address]")) +(cookie-call %make-return-address '#F lambda-expression) + +;; %fetch-continuation is not static, but things get confused otherwise +;; It is handled specially by lamlift and closconv + +(define %fetch-continuation + ;; (CALL ',%fetch-continuation '#F) + ;; Note: + ;; Grab return address, for use in top-level expressions since they + ;; (unlike procedures) do not receive a continuation. + ;; Introduced by cpsconv.scm. + (make-operator/simple* "#[fetch-continuation]" '(STATIC))) +(cookie-call %fetch-continuation '#F) + +(define %invoke-continuation + ;; (CALL ',%invoke-continuation *) + ;; Note: + ;; Introduced by cpsconv.scm + (make-operator "#[invoke-continuation]")) +(cookie-call %invoke-continuation cont #!rest values) + +(define %fetch-stack-closure + ;; (CALL ',%fetch-stack-closure '#F 'VECTOR) + ;; Note: + ;; VECTOR contains symbols only. + ;; This is supposed to return a pointer to the current top of + ;; stack, which contains values (or cells for values) of the + ;; variables named in VECTOR. In fact, rtlgen.scm knows about + ;; this special case and generates no output code. + (make-operator/simple* "#[fetch-stack-closure]")) +(cookie-call %fetch-stack-closure '#F 'VECTOR) + +(define %make-stack-closure + ;; (CALL ',%make-stack-closure '#F + ;; 'VECTOR *) + ;; Note: + ;; This appears *only* as the continuation of some KMP-Scheme CALL. + ;; If a lambda-expression is supplied, it pushes the values on the + ;; stack (creating a stack closure of the format specified) and + ;; loads the return address specified by the lambda-expression + ;; into the return address location (register or stack + ;; location). If no lambda expression is provided, simply + ;; pushes the values. + ;; Introduced by closconv.scm specifying a lambda expression, and + ;; by compat.scm with #F. + (make-operator/simple "#[make-stack-closure]")) +(cookie-call %make-stack-closure '#F lambda-expression 'VECTOR #!rest values) + +(define %stack-closure-ref + ;; (CALL ',%stack-closure-ref '#F 'NAME) + ;; Note: + ;; Introduced by closconv.scm. + ;; Handled specially by rtlgen.scm + (make-operator/simple "#[stack-closure-ref]")) +(cookie-call %stack-closure-ref '#F closure offset 'NAME) + +(define %machine-fixnum? + ;; (CALL ',%machine-fixnum? '#F ) + ;; Note: + ;; #T if is a fixnum on the target machine, else #F + (make-operator/simple "#[machine-fixnum?]" '(PROPER-PREDICATE))) +(cookie-call %machine-fixnum? '#F value) + +(define %small-fixnum? + ;; (CALL ',%small-fixnum? '#F 'FIXNUM) + ;; Note: + ;; #T iff is a fixnum on the target machine and all of top + ;; FIXNUM+1 bits are the same (i.e. the top FIXNUM precision bits + ;; match the sign bit, i.e. it can be represented in FIXNUM fewer + ;; bits than a full fixnum on the target machine). This is used + ;; in the expansion of generic arithmetic to guarantee no + ;; overflow is possible on the target machine. + ;; If FIXNUM is 0, then this is the same as %machine-fixnum? + (make-operator/simple "#[small-fixnum?]" '(PROPER-PREDICATE))) + +(cookie-call %small-fixnum? '#F value 'precision-bits) + +(define (make-operator/out-of-line name . more) + (apply make-operator name + '(SIDE-EFFECT-INSENSITIVE) + '(SIDE-EFFECT-FREE) + '(OUT-OF-LINE-HOOK) + more)) + +;; The following operations are used as: +;; (CALL ', ) +;; Note: +;; If the continuation is #F then the code generator is responsible +;; for creating a return address and preserving all necessary +;; state (registers) needed upon return. Otherwise there is no +;; need to save state, but the operation should tail call into the +;; continuation. + +(define %+ (make-operator/out-of-line "#[+]")) +(define %- (make-operator/out-of-line "#[-]")) +(define %* (make-operator/out-of-line "#[*]")) +(define %/ (make-operator/out-of-line "#[/]")) +(define %quotient (make-operator/out-of-line "#[quotient]")) +(define %remainder (make-operator/out-of-line "#[remainder]")) +(define %= (make-operator/out-of-line "#[=]" '(PROPER-PREDICATE))) +(define %< (make-operator/out-of-line "#[<]" '(PROPER-PREDICATE))) +(define %> (make-operator/out-of-line "#[>]" '(PROPER-PREDICATE))) + +(define *vector-cons-max-open-coded-length* 5) + +(define %vector-cons + ;; (CALL ',%vector-cons ) + ;; Note: + ;; If the continuation is #F then the code generator is responsible + ;; for creating a return address and preserving all necessary + ;; state (registers) needed upon return. Otherwise there is no + ;; need to save state, but the operation should tail call into the + ;; continuation. + (make-operator/out-of-line "#[vector-cons]")) + +(define %string-allocate + ;; (CALL ',%string-allocate ) + ;; Note: + ;; If the continuation is #F then the code generator is responsible + ;; for creating a return address and preserving all necessary + ;; state (registers) needed upon return. Otherwise there is no + ;; need to save state, but the operation should tail call into the + ;; continuation. + (make-operator/out-of-line "#[string-allocate]")) + +(define %floating-vector-cons + ;; (CALL ',%floating-vector-cons ) + ;; Note: + ;; If the continuation is #F then the code generator is responsible + ;; for creating a return address and preserving all necessary + ;; state (registers) needed upon return. Otherwise there is no + ;; need to save state, but the operation should tail call into the + ;; continuation. + (make-operator/out-of-line "#[floating-vector-cons]")) + +;;; Inform the compiler about system primitives + +(for-each + (lambda (simple-operator) + (hash-table/put! *operator-properties* + simple-operator + (list '(SIMPLE) + '(SIDE-EFFECT-INSENSITIVE) + '(SIDE-EFFECT-FREE) + '(PROPER-PREDICATE)))) + (list not eq? null? false? + boolean? cell? pair? vector? %record? string? + fixnum? index-fixnum? flo:flonum? object-type? + fix:= fix:> fix:< fix:<= fix:>= + fix:zero? fix:positive? fix:negative? + flo:= flo:> flo:< #| flo:<= flo:>= |# + flo:zero? flo:positive? flo:negative?)) + +(for-each + (lambda (simple-operator) + (hash-table/put! *operator-properties* + simple-operator + (list '(SIMPLE) + '(SIDE-EFFECT-FREE) + '(PROPER-PREDICATE)))) + (list (make-primitive-procedure 'HEAP-AVAILABLE? 1) + )) + +(for-each + (lambda (simple-operator) + (hash-table/put! *operator-properties* + simple-operator + (list '(SIMPLE) + '(SIDE-EFFECT-INSENSITIVE) + '(SIDE-EFFECT-FREE)))) + (list make-cell cons vector %record string-allocate flo:vector-cons + system-pair-cons %record-length vector-length flo:vector-length + object-type object-datum + (make-primitive-procedure 'PRIMITIVE-OBJECT-SET-TYPE) + fix:-1+ fix:1+ fix:+ fix:- fix:* + fix:quotient fix:remainder ; fix:gcd + fix:andc fix:and fix:or fix:xor fix:not fix:lsh + flo:+ flo:- flo:* flo:/ + flo:negate flo:abs flo:sqrt + flo:floor flo:ceiling flo:truncate flo:round + flo:exp flo:log flo:sin flo:cos flo:tan flo:asin + flo:acos flo:atan flo:atan2 flo:expt + flo:floor->exact flo:ceiling->exact + flo:truncate->exact flo:round->exact + ascii->char integer->char char->ascii char-code char->integer)) + +(for-each + (lambda (simple-operator) + (hash-table/put! *operator-properties* + simple-operator + (list '(SIMPLE) + '(SIDE-EFFECT-FREE)))) + (list cell-contents car cdr %record-ref vector-ref string-ref + string-length vector-8b-ref flo:vector-ref + system-pair-car system-pair-cdr + system-hunk3-cxr0 system-hunk3-cxr1 system-hunk3-cxr2 + (make-primitive-procedure 'PRIMITIVE-GET-FREE) + (make-primitive-procedure 'PRIMITIVE-OBJECT-REF))) + +(for-each + (lambda (operator) + (hash-table/put! *operator-properties* + operator + (list '(SIMPLE) '(UNSPECIFIC-RESULT)))) + (list set-cell-contents! set-car! set-cdr! %record-set! vector-set! + string-set! vector-8b-set! flo:vector-set! + (make-primitive-procedure 'PRIMITIVE-INCREMENT-FREE) + (make-primitive-procedure 'PRIMITIVE-OBJECT-SET!))) + +(for-each + (lambda (prim-name) + (hash-table/put! *operator-properties* + (make-primitive-procedure prim-name) + (list '(SIDE-EFFECT-FREE) + '(SIDE-EFFECT-INSENSITIVE) + '(OUT-OF-LINE-HOOK) + '(OPEN-CODED-PREDICATE) + '(PROPER-PREDICATE)))) + '(&= &< &>)) + +(for-each + (lambda (prim-name) + (hash-table/put! *operator-properties* + (make-primitive-procedure prim-name) + (list '(SIDE-EFFECT-FREE) + '(SIDE-EFFECT-INSENSITIVE) + '(OUT-OF-LINE-HOOK)))) + '(&+ &- &* &/ quotient remainder)) + +;;;; Compatibility operators + +(define %primitive-apply/compatible + ;; (CALL ',%primitive-apply/compatible '#F 'NARGS + ;; ') + ;; Note: + ;; Introduced by compat.scm from %primitive-apply + (make-operator "#[primitive-apply 2]")) +(cookie-call %primitive-apply/compatible '#F 'NARG primitive-object) + +;;; Operators for calling procedures, with a description of the calling +;; convention. +;; +;; Note these have not been implemented but please leave them here for +;; when we come back to passing unboxed floats. + +(define %call/convention + ;; (CALL ',%call/convention ) + ;; Note: + ;; Introduced by compat.scm from CALL + (make-operator "#[call 2]")) + +(define %invoke-operator-cache/convention + ;; (CALL ',%invoke-operator-cache/convention + ;; '(NAME NARGS) *) + ;; Note: + ;; Introduced by compat.scm from %invoke-operator-cache + (make-operator "#[invoke-operator-cache 2]")) + +(define %invoke-remote-cache/convention + ;; (CALL ',%invoke-remote-cache/convention + ;; '(NAME NARGS) *) + ;; Note: + ;; Introduced by compat.scm from %invoke-remote-cache + (make-operator "#[invoke-remote-cache 2]")) + +(define %internal-apply/convention + ;; (CALL ',%interna-apply/convention + ;; 'NARGS *) + ;; Note: + ;; Introduced by compat.scm from %internal-apply + (make-operator "#[internal-apply 2]")) + +(define %primitive-apply/convention + ;; (CALL ',%primitive-apply/convention + ;; 'NARGS ' *) + ;; Note: + ;; Introduced by compat.scm from %primitive-apply + (make-operator "#[primitive-apply 2]")) + +(define %invoke-continuation/convention + ;; (CALL ',%invoke-continuation/convention + ;; *) + ;; Note: + ;; Introduced by compat.scm from %invoke-continuation + (make-operator "#[invoke-continuation 2]")) + +(define %fetch-parameter-frame + ;; (CALL ',%fetch-parameter-frame '#F ) + ;; Note: + ;; This is supposed to return an accessor for local parameters. + ;; In fact, rtlgen.scm knows about this special case and generates + ;; no output code. It is used to set an initial model of how + ;; parameters are passed in to a procedure, so it must appear + ;; immediately after the parameter list for a LAMBDA expression. + (make-operator "#[fetch-parameter-frame]")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Syntax abstractions + +(let-syntax + ((kmp-form-accessors + (macro (name . args) + (define (->string x) (if (symbol? x) (symbol-name x) x)) + (define (->sym . stuff) + (intern (apply string-append (map ->string stuff)))) + (define (loop args path defs) + (define (add-def field path) + (let ((base-name (->sym name "/" field)) + (safe-name (->sym name "/" field "/safe")) + (unsafe-name (->sym name "/" field "/unsafe"))) + (cons* `(DEFINE-INTEGRABLE (,base-name FORM) + (,safe-name FORM)) + `(DEFINE-INTEGRABLE (,unsafe-name FORM) + ,path) + `(DEFINE (,safe-name FORM) + (IF (AND (PAIR? FORM) + (EQ? (CAR FORM) ',name)) + ,path + (INTERNAL-ERROR "Illegal KMP syntax" ',name FORM))) + defs))) + (cond ((null? args) + defs) + ((eq? (car args) '#!REST) + (add-def (cadr args) path)) + ((eq? (car args) '#F) + (loop (cdr args) `(CDR ,path) defs)) + (else + (loop (cdr args) + `(CDR ,path) + (add-def (car args) `(CAR ,path)))))) + `(BEGIN 1 ;bogon for 0 defs + ,@(reverse (loop args `(CDR FORM) '()))))) + + (alternate-kmp-form + (macro (name . args) + `(kmp-form-accessors ,name . ,args))) + (kmp-form + (macro (name . args) + `(BEGIN (DEFINE-INTEGRABLE (,(symbol-append name '/?) FORM) + (AND (PAIR? FORM) + (EQ? (CAR FORM) ',name))) + (kmp-form-accessors ,name . ,args))))) + + ;; Generate KMP accessors like QUOTE/TEXT (doesn't check head of + ;; form) and QUOTE/TEXT/SAFE (requires head of form to be QUOTE) + + (kmp-form QUOTE text) + (kmp-form LOOKUP name) + (kmp-form LAMBDA formals body) + (kmp-form LET bindings body) + (kmp-form DECLARE #!rest declarations) + (kmp-form CALL operator continuation #!rest operands) + (alternate-kmp-form + CALL #F #!rest cont-and-operands) + (kmp-form BEGIN #!rest exprs) ; really 1 or more + (kmp-form IF predicate consequent alternate) + (kmp-form LETREC bindings body) + + (kmp-form SET! name expr) + (kmp-form ACCESS name env-expr) + (kmp-form DEFINE name expr) + (kmp-form THE-ENVIRONMENT) + (kmp-form IN-PACKAGE env-expr expr) + ) diff --git a/v8/src/compiler/midend/graph.scm b/v8/src/compiler/midend/graph.scm new file mode 100644 index 000000000..1d0a82bb2 --- /dev/null +++ b/v8/src/compiler/midend/graph.scm @@ -0,0 +1,263 @@ +(load-option 'hash-table) + +(define make-attribute make-eq-hash-table) + +(define (set-attribute! object attribute value) + (hash-table/put! attribute object value)) + +(define (get-attribute object attribute) + (hash-table/get attribute object #F)) + +(define (adj-transpose vertices adj) + ;; Given a graph (vertices and adjacency matrix) construct the + ;; inverse adjacency matrix + (define adj/T (make-attribute)) + (for-every vertices + (lambda (v) + (for-every (adj v) + (lambda (u) + (set-attribute! u adj/T (cons v (or (get-attribute u adj/T) '()))))))) + (lambda (v) + (or (get-attribute v adj/T) '()))) + +(define (strongly-connected-components vertices adj) + + ;; Inputs: a list of VERTICES, and a function ADJ from a vertex to the + ;; adjacency list for that vertex. Return a list of components, + ;; where each component is a list of vertices. + ;; + ;; Example: + ;; (define vertices '(c d b a e f g h)) + ;; (define (adj v) + ;; (case v + ;; ((a) '(b)) + ;; ((b) '(c f e)) + ;; ((c) '(g d)) + ;; ((d) '(c h)) + ;; ((e) '(f a)) + ;; ((f) '(g)) + ;; ((g) '(f h)) + ;; ((h) '(h)) + ;; (else (error "Bad vertex" v)))) + ;; (strongly-connected-components vertices adj) + ;; => ((h) (f g) (d c) (e a b)) + ;; + ;; Reference: Algorithm and example from: Cormen, Leiserson & Rivest, + ;; Introduction to ALGORITHMS, p489 + + (define (dfs-1 vertices adj) + + (define time 0) + (define seen? (make-attribute)) + (define finish (make-attribute)) + + (define (visit u) + (set-attribute! u seen? #T) + (for-each (lambda (v) + (if (not (get-attribute v seen?)) + (visit v))) + (adj u)) + (set! time (+ time 1)) + (set-attribute! u finish time)) + + (for-each (lambda (vertex) + (if (not (get-attribute vertex seen?)) + (visit vertex))) + vertices) + + (lambda (v) (get-attribute v finish))) + + + (define (dfs-2 vertices adj) + + (define seen? (make-attribute)) + (define components '()) + (define component '()) + + (define (visit u) + (set-attribute! u seen? #T) + (set! component (cons u component)) + (for-each (lambda (v) + (if (not (get-attribute v seen?)) + (visit v))) + (adj u))) + + (for-each (lambda (vertex) + (if (not (get-attribute vertex seen?)) + (begin (set! component '()) + (visit vertex) + (set! components (cons component components))))) + vertices) + components) + + (let ((finish (dfs-1 vertices adj))) + (dfs-2 (sort vertices (lambda (u v) (> (finish u) (finish v)))) + (adj-transpose vertices adj)))) + + +(define (distribute-component-property components component->property + vertex-acknowledge-property!) + ;; For each component to something to every member of that component based on + ;; some property of the component. + (for-each (lambda (component) + (let ((property (component->property component))) + (for-each (lambda (vertex) + (vertex-acknowledge-property! vertex property)) + component))) + components)) + + +(define (s-c-c->adj components adj) + ;; Given a list of strongly connected components and the adjacency relation + ;; over the vertices in those components, return the adjacency matrix for + ;; the strongly connect components themselves. + (define new-adj (make-attribute)) + (define elements (make-attribute)) + (define (adjoin elem set) + (if (memq elem set) + set + (cons elem set))) + (define (v->s-c-c vertex) (get-attribute vertex elements)) + (define (result s-c-c) + (or (get-attribute s-c-c new-adj) + (error "S-C-C->ADJ: No such strongly connected component" + s-c-c components))) + ;; Elements maps a vertex to the strongly connected component containing it + (for-every components + (lambda (component) + (for-every component + (lambda (vertex) + (set-attribute! vertex elements component))))) + (for-every components + (lambda (component) + (set-attribute! component new-adj '()))) + ;; Calculate the adjacency matrix + (for-every components + (lambda (component) + (for-every component + (lambda (vertex) + (let ((adjacent (adj vertex))) + (for-every adjacent + (lambda (adj-vertex) + (let ((new-component (v->s-c-c adj-vertex))) + (if (not (eq? new-component component)) + (set-attribute! component new-adj + (adjoin new-component (result component)))))))))))) + result) + + +(define (make-in-cycle? vertices adj) + ;; Takes: a set (list) of vertices and an adjacency function from that + ;; set to a list of neighbours. Returns: a predicate on a vertex + ;; determining if that vertex is on a cycle + + (define vertex->component (make-attribute)) + + (for-each (lambda (component) + (for-each (lambda (vertex) + (set-attribute! vertex vertex->component component)) + component)) + (strongly-connected-components vertices adj)) + + (lambda (vertex) + (let ((component (get-attribute vertex vertex->component))) + (and (pair? component) + (or (pair? (cdr component)) + (memq vertex (adj vertex))))))) + + +(define (make-breaks-cycle? vertices adj #!optional break-vertices) + ;; Takes VERTICES & ADJ as above. Decides which elemenent of a cycle are + ;; `harmless' and which should break-points to break cycles. + ;; BREAK-VERTICES is a list of vertices where we want to break already. + + (define seen? (make-attribute)) + ;; The seen? marker is either + ;; . #F - never, + ;; . #T - breaks cycle, + ;; . found to be safe in dfs generation + (define generation 0) + + (define (visit u) + (let ((attr (get-attribute u seen?))) + (cond ((eq? attr #T) #T) + ((eq? attr #F) + (set-attribute! u seen? generation) + (for-each visit (adj u))) + ((= generation attr) + (set-attribute! u seen? #T) + #T) + (else + #F)))) + + (if (not (default-object? break-vertices)) + (for-each (lambda (u) (set-attribute! u seen? #T)) break-vertices)) + + ;; slight improvement - look for trivial loops first + (for-each (lambda (u) + (if (memq u (adj u)) + (set-attribute! u seen? #T))) + vertices) + + (lambda (v) + (set! generation (1+ generation)) + (visit v) + (if (eq? #T (get-attribute v seen?)) + #T + #F))) + + +(define (dfs-dag-walk vertices adj operation) + ;; Visit all nodes in the graph defined by VERTICES and ADJ, performing + ;; OPERATION at every vertex. OPERATION takes the current vertex and a + ;; list of vertices as returned by ADJ. The DFS ensures (provided the + ;; graph is a DAG) that OPERATION has already been called on all the + ;; members of this list, and is visited exactly once. + ;; + ;; Example: sum the values over the children: + ;; (dfs-dag-walk Vertices Adj + ;; (lambda (vertex children) + ;; (set-vertex-value! + ;; vertex + ;; (apply + (vertex-value vertex) (map vertex-value children))))) + + (define seen? (make-attribute)) + (define (visit u) + (if (not (get-attribute u seen?)) + (let ((adj-list (adj u))) + (set-attribute! u seen? #T) + (for-each visit adj-list) + (operation u adj-list)))) + (for-each visit vertices)) + + + +(define (dfs-dag-sum vertices adj function) + ;; Returns a procedure on members of VERTICES which returns the DFS sum + ;; function FUNCTION of a vertex. FUNCTION takes the current vertex and + ;; a list of values for the vertices returned by ADJ. The DFS ensures + ;; (provided the graph is a DAG) that FUNCTION has already been computed + ;; for all ADJacent vertices and that FUNCTION is called at most once for + ;; any vertex. + ;; + ;; Note: the procedure returned is lazy, and should be forced if your program + ;; relies upon a side-effect produced by FUNCTION. + ;; + ;; Example: sum the values over the children: + ;; ((dfs-dag-walk Vertices Adj + ;; (lambda (vertex children-values) + ;; (apply + (vertex-value vertex) chilren))) + ;; a-vertex) => the-sum + + (define seen? (make-attribute)) + (define value (make-attribute)) + (define (visit u) + (if (not (get-attribute u seen?)) + (begin + (set-attribute! u seen? #T) + (let ((result (function u (map visit (adj u))))) + (set-attribute! u value result) + result)) + (get-attribute u value))) + vertices ;; ignored + visit) diff --git a/v8/src/compiler/midend/indexify.scm b/v8/src/compiler/midend/indexify.scm new file mode 100644 index 000000000..6f5820325 --- /dev/null +++ b/v8/src/compiler/midend/indexify.scm @@ -0,0 +1,141 @@ +#| -*-Scheme-*- + +$Id: indexify.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Constant folder for closure and stack closure indices +;;; package: (compiler midend) + +(declare (usual-integrations)) + +(define (indexify/top-level program) + (indexify/expr program)) + +(define-macro (define-indexifier keyword bindings . body) + (let ((proc-name (symbol-append 'INDEXIFY/ keyword))) + (call-with-values + (lambda () (%matchup bindings '(handler) '(cdr form))) + (lambda (names code) + `(define ,proc-name + (let ((handler (lambda ,names ,@body))) + (named-lambda (,proc-name form) + (indexify/remember ,code form)))))))) + +(define-indexifier LOOKUP (name) + `(LOOKUP ,name)) + +(define-indexifier LAMBDA (lambda-list body) + `(LAMBDA ,lambda-list + ,(indexify/expr body))) + +(define-indexifier LET (bindings body) + `(LET ,(lmap (lambda (binding) + (list (car binding) + (indexify/expr (cadr binding)))) + bindings) + ,(indexify/expr body))) + +(define-indexifier LETREC (bindings body) + `(LETREC ,(lmap (lambda (binding) + (list (car binding) + (indexify/expr (cadr binding)))) + bindings) + ,(indexify/expr body))) + +(define-indexifier IF (pred conseq alt) + `(IF ,(indexify/expr pred) + ,(indexify/expr conseq) + ,(indexify/expr alt))) + +(define-indexifier QUOTE (object) + `(QUOTE ,object)) + +(define-indexifier DECLARE (#!rest anything) + `(DECLARE ,@anything)) + +(define-indexifier BEGIN (#!rest actions) + `(BEGIN ,@(indexify/expr* actions))) + +(define-indexifier CALL (rator cont #!rest rands) + (let ((constant? (lambda (form) + (and (pair? form) + (eq? (car form) 'QUOTE))))) + (cond ((or (not (constant? rator)) + (not (eq? (cadr rator) %vector-index))) + `(CALL ,(indexify/expr rator) + ,(indexify/expr cont) + ,@(indexify/expr* rands))) + ((or (not (equal? cont '(QUOTE #F))) + (not (= (length rands) 2)) + (not (constant? (car rands))) + (not (constant? (cadr rands)))) + (internal-error "Unexpected use of %vector-index" + `(CALL ,rator ,cont ,@rands))) + (else + `(QUOTE ,(vector-index (cadr (car rands)) + (cadr (cadr rands)))))))) + +(define (indexify/expr expr) + (if (not (pair? expr)) + (illegal expr)) + (case (car expr) + ((QUOTE) + (indexify/quote expr)) + ((LOOKUP) + (indexify/lookup expr)) + ((LAMBDA) + (indexify/lambda expr)) + ((LET) + (indexify/let expr)) + ((DECLARE) + (indexify/declare expr)) + ((CALL) + (indexify/call expr)) + ((BEGIN) + (indexify/begin expr)) + ((IF) + (indexify/if expr)) + ((LETREC) + (indexify/letrec expr)) + ((SET! UNASSIGNED? OR DELAY + ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT) + (no-longer-legal expr)) + (else + (illegal expr)))) + +(define (indexify/expr* exprs) + (lmap (lambda (expr) + (indexify/expr expr)) + exprs)) + +(define (indexify/remember new old) + (code-rewrite/remember new old)) \ No newline at end of file diff --git a/v8/src/compiler/midend/inlate.scm b/v8/src/compiler/midend/inlate.scm new file mode 100644 index 000000000..7b2b781d7 --- /dev/null +++ b/v8/src/compiler/midend/inlate.scm @@ -0,0 +1,218 @@ +#| -*-Scheme-*- + +$Id: inlate.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Scode->KMP Scheme +;;; package: (compiler midend) + +(declare (usual-integrations)) + +(define (inlate/top-level scode) + (inlate/remember (inlate/scode scode) + (new-dbg-expression/make scode))) + +(define-macro (define-inlator scode-type components . body) + (let ((proc-name (symbol-append 'INLATE/ scode-type)) + (destructor (symbol-append scode-type '-COMPONENTS))) + `(define ,proc-name + (let ((handler (lambda ,components ,@body))) + (named-lambda (,proc-name form) + (inlate/remember (,destructor form handler) + (new-dbg-expression/make form))))))) + +(define (inlate/sequence+ form) + ;; Kludge + (if (not (open-block? form)) + (inlate/sequence form) + (inlate/remember + (let ((form* (open-block-components form unscan-defines))) + (if (sequence? form*) + (beginnify (lmap inlate/scode (sequence-actions form*))) + (inlate/scode form*))) + (new-dbg-expression/make form)))) + +(define (inlate/constant object) + `(QUOTE ,(if (unassigned-reference-trap? object) %unassigned object))) + +(define-inlator VARIABLE (name) + `(LOOKUP ,name)) + +(define-inlator ASSIGNMENT (name svalue) + `(SET! ,name ,(inlate/scode svalue))) + +(define-inlator DEFINITION (name svalue) + `(DEFINE ,name ,(inlate/scode svalue))) + +(define-inlator THE-ENVIRONMENT () + `(THE-ENVIRONMENT)) + +(define (inlate/lambda form) + (lambda-components form + (lambda (name req opt rest aux decls sbody) + name ; Not used + (let* ((lambda-list + (append req + (if (null? opt) + '() + (cons '#!OPTIONAL opt)) + (if (not rest) + '() + (list '#!REST rest)) + (if (null? aux) + '() + (cons '#!AUX aux)))) + (new + `(LAMBDA ,(cons (new-continuation-variable) lambda-list) + ,(let ((body (inlate/scode sbody))) + (if (null? decls) + body + (beginnify + (list `(DECLARE ,@decls) + body))))))) + (inlate/remember new + (new-dbg-procedure/make form lambda-list)))))) + +(define (inlate/lambda* name req opt rest aux decls sbody) + name ; ignored + `(LAMBDA ,(append (cons (new-continuation-variable) req) + (if (null? opt) + '() + (cons '#!OPTIONAL opt)) + (if (not rest) + '() + (list '#!REST rest)) + (if (null? aux) + '() + (cons '#!AUX aux))) + ,(let ((body (inlate/scode sbody))) + (if (null? decls) + body + (beginnify + (list `(DECLARE ,@decls) + body)))))) + +(define-inlator IN-PACKAGE (environment expression) + `(IN-PACKAGE ,(inlate/scode environment) + ,(inlate/scode expression))) + +(define-inlator COMBINATION (rator rands) + (let-syntax ((ucode-primitive + (macro (name) + (make-primitive-procedure name)))) + (let-syntax ((is-operator? + (macro (value name) + `(or (eq? ,value (ucode-primitive ,name)) + (and (absolute-reference? ,value) + (eq? (absolute-reference-name ,value) + ',name)))))) + (if (and (is-operator? rator LEXICAL-UNASSIGNED?) + (not (null? rands)) + (the-environment? (car rands)) + (not (null? (cdr rands))) + (symbol? (cadr rands))) + `(UNASSIGNED? ,(cadr rands)) + `(CALL ,(inlate/scode rator) + (QUOTE #F) ; continuation + ,@(lmap inlate/scode rands)))))) + +(define-inlator COMMENT (text body) + text ; ignored + (inlate/scode body)) + +(define-inlator SEQUENCE (actions) + (beginnify (lmap inlate/scode actions))) + +(define-inlator CONDITIONAL (pred conseq alt) + `(IF ,(inlate/scode pred) + ,(inlate/scode conseq) + ,(inlate/scode alt))) + +(define-inlator DISJUNCTION (pred alt) + `(OR ,(inlate/scode pred) + ,(inlate/scode alt))) + +(define-inlator ACCESS (environment name) + `(ACCESS ,name ,(inlate/scode environment))) + +(define-inlator DELAY (expression) + `(DELAY ,(inlate/scode expression))) + +(define inlate/scode + (let ((dispatch-vector + (make-vector (microcode-type/code-limit) inlate/constant))) + + (let-syntax + ((dispatch-entry + (macro (type handler) + `(VECTOR-SET! DISPATCH-VECTOR ,(microcode-type type) + (LAMBDA (EXPR) + (,handler EXPR)))))) + + (let-syntax + ((dispatch-entries + (macro (types handler) + `(BEGIN ,@(map (lambda (type) + `(DISPATCH-ENTRY ,type ,handler)) + types)))) + (standard-entry + (macro (name) + `(DISPATCH-ENTRY ,name ,(symbol-append 'INLATE/ name))))) + + ;; quotations are treated as constants. + (standard-entry access) + (standard-entry assignment) + (standard-entry comment) + (standard-entry conditional) + (standard-entry definition) + (standard-entry delay) + (standard-entry disjunction) + (standard-entry variable) + (standard-entry in-package) + (standard-entry the-environment) + (dispatch-entries (combination-1 combination-2 combination + primitive-combination-0 + primitive-combination-1 + primitive-combination-2 + primitive-combination-3) + inlate/combination) + (dispatch-entries (lambda lexpr extended-lambda) inlate/lambda) + (dispatch-entries (sequence-2 sequence-3) inlate/sequence+)) + + (named-lambda (inlate/expression expression) + ((vector-ref dispatch-vector (object-type expression)) + expression))))) + +;; Utilities + +(define (inlate/remember new old) + (code-rewrite/remember* new old)) \ No newline at end of file diff --git a/v8/src/compiler/midend/lamlift.scm b/v8/src/compiler/midend/lamlift.scm new file mode 100644 index 000000000..5fe0236b3 --- /dev/null +++ b/v8/src/compiler/midend/lamlift.scm @@ -0,0 +1,748 @@ +#| -*-Scheme-*- + +$Id: lamlift.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Lambda lifter +;;; package: (compiler midend) + +(declare (usual-integrations)) + +(define (lamlift/top-level program) + (let* ((env (lamlift/env/%make 'STATIC #F 0)) + (program* (lamlift/expr env (lifter/letrecify program)))) + (lamlift/analyze! env) + program*)) + +(define lamlift/*lift-stubs-aggressively?* #F) + +(define-macro (define-lambda-lifter keyword bindings . body) + (let ((proc-name (symbol-append 'LAMLIFT/ keyword))) + (call-with-values + (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form))) + (lambda (names code) + `(define ,proc-name + (let ((handler (lambda ,(cons (car bindings) names) ,@body))) + (named-lambda (,proc-name env form) + (lamlift/remember ,code + form)))))))) + +(define-lambda-lifter LOOKUP (env name) + (call-with-values + (lambda () (lamlift/lookup* env name 'ORDINARY)) + (lambda (ref binding) + (set-lamlift/binding/operand-uses! binding + (cons ref (lamlift/binding/operand-uses binding))) + ref))) + +(define-lambda-lifter LAMBDA (env lambda-list body) + (call-with-values + (lambda () + (lamlift/lambda* 'DYNAMIC env lambda-list body)) + (lambda (expr* env*) + env* ; ignored + expr*))) + +(define (lamlift/lambda* context env lambda-list body) + ;; (values expr* env*) + (let* ((env* (lamlift/env/make + context env (lambda-list->names lambda-list))) + (expr* `(LAMBDA ,lambda-list ,(lamlift/expr env* body)))) + (set-lamlift/env/form! env* expr*) + (values expr* env*))) + +(define-lambda-lifter LET (env bindings body) + (lamlift/let* 'LET env bindings body)) + +(define-lambda-lifter LETREC (env bindings body) + (lamlift/let* 'LETREC env bindings body)) + +(define-lambda-lifter CALL (env rator cont #!rest rands) + (cond ((LOOKUP/? rator) + (call-with-values + (lambda () (lamlift/lookup* env (lookup/name rator) 'OPERATOR)) + (lambda (rator* binding) + (let ((result + `(CALL ,(lamlift/remember rator* rator) + ,(lamlift/expr env cont) + ,@(lamlift/expr* env rands)))) + (set-lamlift/binding/calls! + binding + (cons result (lamlift/binding/calls binding))) + result)))) + ((LAMBDA/? rator) + (let ((ll (lambda/formals rator)) + (body (lambda/body rator)) + (cont+rands (cons cont rands))) + (guarantee-simple-lambda-list ll) + (guarantee-argument-list cont+rands (length ll)) + (let ((bindings (map list ll cont+rands))) + (call-with-values + (lambda () + (lamlift/lambda* + (binding-context-type 'CALL + (lamlift/env/context env) + bindings) + env ll body)) + (lambda (rator* env*) + (let ((bindings* (lamlift/bindings env* env bindings))) + (set-lamlift/env/split?! env* 'UNNECESSARY) + `(CALL ,(lamlift/remember rator* rator) + ,@(lmap cadr bindings*)))))))) + (else + `(CALL ,(lamlift/expr env rator) + ,(lamlift/expr env cont) + ,@(lamlift/expr* env rands))))) + +(define-lambda-lifter QUOTE (env object) + env ; ignored + `(QUOTE ,object)) + +(define-lambda-lifter DECLARE (env #!rest anything) + env ; ignored + `(DECLARE ,@anything)) + +(define-lambda-lifter BEGIN (env #!rest actions) + `(BEGIN ,@(lamlift/expr* env actions))) + +(define-lambda-lifter IF (env pred conseq alt) + `(IF ,(lamlift/expr env pred) + ,(lamlift/expr env conseq) + ,(lamlift/expr env alt))) + +(define (lamlift/expr env expr) + (if (not (pair? expr)) + (illegal expr)) + (case (car expr) + ((QUOTE) (lamlift/quote env expr)) + ((LOOKUP) (lamlift/lookup env expr)) + ((LAMBDA) (lamlift/lambda env expr)) + ((LET) (lamlift/let env expr)) + ((DECLARE) (lamlift/declare env expr)) + ((CALL) (lamlift/call env expr)) + ((BEGIN) (lamlift/begin env expr)) + ((IF) (lamlift/if env expr)) + ((LETREC) (lamlift/letrec env expr)) + ((SET! UNASSIGNED? OR DELAY ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT) + (no-longer-legal expr)) + (else + (illegal expr)))) + +(define (lamlift/expr* env exprs) + (lmap (lambda (expr) + (lamlift/expr env expr)) + exprs)) + +(define (lamlift/remember new old) + (code-rewrite/remember new old)) + +(define (lamlift/split new old) + (let ((old* (code-rewrite/original-form old))) + (if old* + (code-rewrite/remember* + new + (if (new-dbg-procedure? old*) + (new-dbg-procedure/copy old*) + old*))) + new)) + +(define (lamlift/new-name prefix) + (new-variable prefix)) + +(define-structure (lamlift/env + (conc-name lamlift/env/) + (constructor lamlift/env/%make (context parent depth)) + (print-procedure + (standard-unparser-method 'LAMLIFT/ENV + (lambda (env port) + (write-char #\space port) + (write (lamlift/env/context env) port) + (write-char #\space port) + (write (car (or (lamlift/env/form env) '(ROOT))) port) + (write-char #\space port) + (write (lamlift/env/depth env) port))))) + + (context false read-only true) ; STATIC or DYNAMIC + (parent false read-only true) ; #F or another environment + (children '() read-only false) + (depth 0 read-only true) ; depth from root + (bound '() read-only false) ; A list of LAMLIFT/BINDINGs + + ;; Each of the next two slots is a list of associations between bindings + ;; and lists of references: Each association is a list headed by a + ;; binding, with the rest of the list being a list of references: + ;; (LAMLIFT/BINDING reference reference ...) where reference is + ;; (LOOKUP ) + (free-ordinary-refs '() read-only false) + (free-operator-refs '() read-only false) + + (form false read-only false) + + ;; When this is a lambda's env and the lambda is bound to a name, BINDING + ;; is that LAMLIFT/BINDING. #F implies either this frame is an anonymous + ;; lambda or a let(rec) frame. + (binding false read-only false) + + (split? 'YES read-only false) ; 'YES, 'NO, or 'UNNECESSARY + + ;; Formals to be added (formerly free variables) + (extended '() read-only false) + + ;; The new parent for this frame should we choose to drift it up. This + ;; is the highest frame that could be a parent without adding new + ;; extra parameters. + (drift-frame #F read-only false) + ) + +(define-structure (lamlift/binding + (conc-name lamlift/binding/) + (constructor lamlift/binding/make (name env)) + (print-procedure + (standard-unparser-method 'LAMLIFT/BINDING + (lambda (v port) + (write-char #\space port) + (write-string (symbol-name (lamlift/binding/name v)) + port))))) + + (name #F read-only true) + (env #F read-only true) ; a LAMLIFT/ENV + (calls '() read-only false) ; List of call sites + (operand-uses '() read-only false) ; List of operand use (LOOKUP ) + (value #F read-only false)) ; a LAMLIFT/ENV for use in body + +(define-integrable (lamlift/binding/operator-only? binding) + (null? (lamlift/binding/operand-uses binding))) + +(define (lamlift/env/make context parent names) + (let* ((depth (if parent (1+ (lamlift/env/depth parent)) 0)) + (env (lamlift/env/%make context parent depth))) + (set-lamlift/env/bound! env + (map (lambda (name) + (lamlift/binding/make name env)) + names)) + (set-lamlift/env/children! parent (cons env (lamlift/env/children parent))) + env)) + +(define (lamlift/lookup* env name kind) + ;; (values copied-reference-form binding) + (define (traverse fetch store!) + (let walk-spine ((env env)) + (cond ((not env) + (free-var-error name)) + ((lamlift/binding/find (lamlift/env/bound env) name) + => (lambda (binding) + (values `(LOOKUP ,(lamlift/binding/name binding)) + binding))) + (else + (call-with-values + (lambda () (walk-spine (lamlift/env/parent env))) + (lambda (ref binding) + (let* ((free (fetch env)) + (place (assq binding free))) + (if (not place) + (store! env (cons (list binding ref) free)) + (set-cdr! place (cons ref (cdr place)))) + (values ref binding)))))))) + + (case kind + ((ORDINARY) + (traverse lamlift/env/free-ordinary-refs + set-lamlift/env/free-ordinary-refs!)) + ((OPERATOR) + (traverse lamlift/env/free-operator-refs + set-lamlift/env/free-operator-refs!)) + (else + (internal-error "Unknown reference kind" kind)))) + +(define (lamlift/binding/find bindings name) + (let find ((bindings bindings)) + (and (not (null? bindings)) + (let ((binding (car bindings))) + (if (not (eq? name (lamlift/binding/name (car bindings)))) + (find (cdr bindings)) + binding))))) + +(define (lamlift/renames env names) + (lmap (lambda (name) + (cons name + (if (not (lamlift/bound? env name)) + name + (variable/rename name)))) + names)) + +(define (lamlift/rename-lambda-list lambda-list pairs) + (lmap (lambda (token) + (let ((pair (assq token pairs))) + (if (not pair) + token + (cdr pair)))) + lambda-list)) + +(define (lamlift/bound? env name) + (let loop ((env env)) + (and env + (or (lamlift/binding/find (lamlift/env/bound env) name) + (loop (lamlift/env/parent env)))))) + +(define (lamlift/let* keyword outer-env bindings body) + (let* ((inner-env (lamlift/env/make + (binding-context-type keyword + (lamlift/env/context outer-env) + bindings) + outer-env + (lmap car bindings))) + (expr* `(,keyword + ,(lamlift/bindings + inner-env + (if (eq? keyword 'LETREC) inner-env outer-env) + bindings) + ,(lamlift/expr inner-env body)))) + (set-lamlift/env/form! inner-env expr*) + expr*)) + +(define (lamlift/bindings binding-env body-env bindings) + (lmap (lambda (binding) + (let ((name (car binding)) + (value (cadr binding))) + (list + name + (if (not (LAMBDA/? value)) + (lamlift/expr body-env value) + (call-with-values + (lambda () + (lamlift/lambda* 'DYNAMIC ; bindings are dynamic + body-env + (lambda/formals value) + (lambda/body value))) + (lambda (value* lambda-body-env) + (let ((binding + (or (lamlift/binding/find + (lamlift/env/bound binding-env) name) + (internal-error "Missing binding" name)))) + (set-lamlift/env/binding! lambda-body-env binding) + (set-lamlift/binding/value! binding lambda-body-env) + value*))))))) + bindings)) + +(define (lamlift/analyze! env) + (lamlift/decide-split! env) + (lamlift/decide! env) + ;;(bkpt 'about-to-rewrite) + (lamlift/rewrite! env) +) + +(define (lamlift/decide-split! env) + (cond ((lamlift/env/binding env) ; This LAMBDA has a known binding + => (lambda (binding) + (if (lamlift/binding/operator-only? binding) + (set-lamlift/env/split?! env 'NO))))) + (for-each lamlift/decide-split! (lamlift/env/children env))) + +(define (lamlift/decide! env) + (let ((form (lamlift/env/form env))) + (cond ((or (eq? form #F) ; root env + (LET/? form)) + (lamlift/decide!* (lamlift/env/children env))) + ((LETREC/? form) + (lamlift/decide/letrec! env)) + ((LAMBDA/? form) + (lamlift/decide/lambda! env) + (lamlift/decide!* (lamlift/env/children env))) + (else + (internal-error "Unknown binding form" form))))) + +(define (lamlift/decide!* envs) + (for-each lamlift/decide! envs)) + +(define (lamlift/decide/lambda! env) + (case (lamlift/env/split? env) + ((NO YES) + (set-lamlift/env/extended! env (lamlift/decide/imports env '()))) + ((UNNECESSARY) + (set-lamlift/env/extended! env '())) + (else + (internal-error "Unknown split field" env)))) + +(define (lamlift/decide/imports env avoid) + ;; Find all free references in ENV except those in AVOID. Requires + ;; that ?? all LAMBDA siblings already have their LAMLIFT/ENV/EXTENDED + ;; slot calculated, as we have to pass their extensions as well. + (define (filter-refs refs avoid) + ;; Remove static bindings and members of AVOID from REFS + (list-transform-negative refs + (lambda (free-ref) + (let ((binding (car free-ref))) + (or (lamlift/static-binding? binding) + (lamlift/binding-lifts-to-static-frame? binding) + (memq binding avoid)))))) + (union-map* + (lmap (lambda (free-ref) + ;; Extract the name of the variable + (cadr (cadr free-ref))) + (filter-refs (lamlift/env/free-ordinary-refs env) + '())) + (lambda (free-ref) + (let* ((binding (car free-ref)) + (value (lamlift/binding/value binding))) + ;; If this free reference is visibly bound to a LAMBDA + ;; expression, then the free variables of that LAMBDA are also + ;; free variables of this expression; otherwise, just the + ;; variable itself. + (if (not value) + (list (cadr (cadr free-ref))) + (lamlift/env/extended value)))) + (filter-refs (lamlift/env/free-operator-refs env) + avoid))) + +(define (lamlift/static-binding? binding) + (and (eq? (lamlift/env/context (lamlift/binding/env binding)) 'STATIC) + (not (pseudo-static-variable? (lamlift/binding/name binding))))) + +(define (lamlift/binding-lifts-to-static-frame? binding) + (let ((value (lamlift/binding/value binding))) + (and value + (let ((drift-frame (lamlift/env/drift-frame value))) + (and drift-frame + (eq? (lamlift/env/context drift-frame) 'STATIC)))))) + + + +(define (lamlift/applicate! call reorder lambda-list var extra-args) + (form/rewrite! + call + `(CALL (LOOKUP ,var) + ,@(reorder (append extra-args + (lambda-list/applicate lambda-list + (call/cont-and-operands call))))))) + +(define (lamlift/reorderer original final) + ;; This is slow... + (lambda (args) + (let ((pairs (map list original args))) + (map (lambda (final) + (cadr (assq final pairs))) + final)))) + +(define (lamlift/decide/letrec! letrec-env) + + (define (decide-remaining-children! child-bindings-done) + (let ((children-done (lmap lamlift/binding/value child-bindings-done))) + (for-each (lambda (child) + (lamlift/decide!* (lamlift/env/children child))) + children-done) + (lamlift/decide!* + (delq* children-done (lamlift/env/children letrec-env))))) + + (let ((bound (lamlift/env/bound letrec-env))) + ;; All these cases are optimizations. + (cond ((null? bound) + (decide-remaining-children! '())) + ((and (eq? (lamlift/env/context letrec-env) 'STATIC) + (for-all? bound + (lambda (binding) + (let ((env* (lamlift/binding/value binding))) + (eq? (lamlift/env/split? env*) 'NO))))) + ;; A static frame with none of the LAMBDAs appearing in + ;; operand position (i.e. no splitting) + (decide-remaining-children! bound)) + ((eq? (lamlift/env/context letrec-env) 'STATIC) + (let ((splits (list-transform-negative bound + (lambda (binding) + (let ((env* (lamlift/binding/value binding))) + (eq? (lamlift/env/split? env*) 'NO)))))) + (for-each + (lambda (binding) + (let ((env* (lamlift/binding/value binding))) + ;; No bindings need be added before lifting this, + ;; because all free references from a static frame + ;; are to static variables and hence lexically + ;; visible after lifting. + (set-lamlift/env/extended! env* '()))) + splits) + (decide-remaining-children! splits))) + (else + (lamlift/decide/letrec!/dynamic-frame letrec-env) + (decide-remaining-children! bound))))) + +(define (lamlift/decide/letrec!/dynamic-frame letrec-env) + + (define (letrec-binding? binding) + (eq? (lamlift/binding/env binding) letrec-env)) + + (define (letrec-self-references list-of-binding.reference) + (list-transform-positive list-of-binding.reference + (lambda (binding.reference) + (letrec-binding? (car binding.reference))))) + + (define (letrec-other-references list-of-binding.reference) + (list-transform-negative list-of-binding.reference + (lambda (binding.reference) + (letrec-binding? (car binding.reference))))) + + (define (make-adj-list list-of-binding.reference) + (map (lambda (binding.reference) + (lamlift/binding/value (car binding.reference))) + (letrec-self-references list-of-binding.reference))) + + (define (lamlift/env/free-all-refs env) + (append (lamlift/env/free-ordinary-refs env) + (lamlift/env/free-operator-refs env))) + + ;; remember that components are lists of nodes + (define-integrable component-exemplar car) + + (let* ((nodes (map lamlift/binding/value (lamlift/env/bound letrec-env))) + + (reference-adj + (eq?-memoize + (lambda (node-env) + (make-adj-list (lamlift/env/free-all-refs node-env))))) + (reference-components + (strongly-connected-components nodes reference-adj)) + (reference-dag-adj (s-c-c->adj reference-components reference-adj)) + + (call-adj + (eq?-memoize + (lambda (node-env) + (make-adj-list (lamlift/env/free-operator-refs node-env))))) + (call-components (strongly-connected-components nodes call-adj)) + (call-dag-adj (s-c-c->adj call-components call-adj))) + + (define (component-free-dynamic-names component-members) + ;; calculate ordinary extended parameters + (union-map* + '() + (lambda (node) + (lamlift/decide/imports node (lamlift/env/bound letrec-env))) + component-members)) + + (define (combine-names my-new-names callees-new-names) + ;;* Ought to reorder CALLEES-NEW-NAMES to reduce amount of register + ;; shuffling and take into account existing arguments. + ;;* This version ensures that the arguments passed to callees preceed the + ;; new extra arguments, and the new argument list is coherent with at + ;; least one callee. + (define (adjoin names set) (append set (delq* set names))) + (adjoin my-new-names (fold-left adjoin '() callees-new-names))) + + (define (component-drift-frame-depth component maximum-from-dag-children) + ;; Search for a drift frame by depth, picking the deepest frame that + ;; imposes a restriction. + + (define (binding/drifted-frame-depth binding) + ;; Find the depth of a binding, taking into account that it might be a + ;; binding to a lambda that was drifted up from some outer frame. + (define (default) (lamlift/env/depth (lamlift/binding/env binding))) + (let ((value (lamlift/binding/value binding))) + (if value + (let ((drift-frame (lamlift/env/drift-frame value))) + (if drift-frame + (lamlift/env/depth drift-frame) + (default))) + (default)))) + + (define (maximum-over-binding.references-list list maximum) + (if (null? list) + maximum + (maximum-over-binding.references-list + (cdr list) + (max maximum (binding/drifted-frame-depth (car (car list))))))) + + (define (node-maximum maximum node) + (maximum-over-binding.references-list + (letrec-other-references (lamlift/env/free-ordinary-refs node)) + (maximum-over-binding.references-list + (letrec-other-references (lamlift/env/free-operator-refs node)) + maximum))) + + (fold-left node-maximum maximum-from-dag-children component)) + + (let ((depth-of-static-frame + (lamlift/env/depth (lamlift/find-static-frame letrec-env)))) + ;; This has to be a walk, not a sum: COMPONENT-DRIFT-FRAME-DEPTH + ;; (indirectly) uses the drift-frame slot, so this has to be set + ;; immediately. + (dfs-dag-walk reference-components reference-dag-adj + (lambda (component children) + (let* ((children-depths + (map (lambda (c) + (lamlift/env/depth + (lamlift/env/drift-frame (component-exemplar c)))) + children)) + (drift-depth + (component-drift-frame-depth + component + (fold-left max depth-of-static-frame children-depths))) + (drift-frame + (lamlift/env/depth->frame letrec-env drift-depth))) + (for-each (lambda (node) + (set-lamlift/env/drift-frame! node drift-frame)) + component))))) + + (let ((component->extra-names + (dfs-dag-sum call-components call-dag-adj + (lambda (component callees-extendeds) + (combine-names (component-free-dynamic-names component) + callees-extendeds))))) + (distribute-component-property + call-components component->extra-names set-lamlift/env/extended!)))) + + +(define (lamlift/env/find-frame start-env predicate?) + (let loop ((env start-env)) + (cond ((not env) + (internal-error "Cant find frame satisfying" predicate? start-env)) + ((predicate? env) + env) + (else + (loop (lamlift/env/parent env)))))) + +(define (lamlift/find-static-frame env) + (define (static-frame? env) + (eq? (lamlift/env/context env) 'STATIC)) + (lamlift/env/find-frame env static-frame?)) + +(define (lamlift/env/depth->frame env depth) + (lamlift/env/find-frame env (lambda (e) (= depth (lamlift/env/depth e))))) + +(define lamlift/lift! + (lifter/make + (lambda (env) (lamlift/env/form (lamlift/find-static-frame env))))) + +(define (lamlift/rewrite! env) + (let ((form (lamlift/env/form env))) + (cond ((or (eq? form #F) ; root env + (LET/? form)) + (lamlift/rewrite!* (lamlift/env/children env))) + ((LETREC/? form) + (lamlift/rewrite!* (lamlift/env/children env))) + ((LAMBDA/? form) + (lamlift/rewrite!* (lamlift/env/children env)) + (lamlift/rewrite/lambda! env)) + (else + (internal-error "Unknown binding form" form))))) + +(define (lamlift/rewrite!* envs) + (for-each lamlift/rewrite! envs)) + +(define (lamlift/rewrite/lambda! env) + (if (not (eq? (lamlift/env/split? env) 'UNNECESSARY)) + (lamlift/rewrite/lambda/finish! env))) + +(define (lamlift/rewrite/lambda/finish! env) + (define (make-new-name) + (lamlift/new-name + (if (lamlift/env/binding env) + (lamlift/binding/name (lamlift/env/binding env)) + 'LAMBDA))) + (let* ((form (lamlift/env/form env)) + (orig-lambda-list (lambda/formals form)) + (extra-formals (lamlift/env/extended env)) + (lifted-name (make-new-name)) + (split? (or (not (eq? (lamlift/env/split? env) 'NO)) + (hairy-lambda-list? orig-lambda-list)))) + (let* ((lambda-list** + (append extra-formals (lambda-list->names orig-lambda-list))) + (lifted-lambda-list + ;; continuation variable always leftmost + (call-with-values + (lambda () + (list-split lambda-list** referenced-continuation-variable?)) + (lambda (cont-vars other-vars) + (if (or (null? cont-vars) + (not (null? (cdr cont-vars)))) + (internal-error "Creating LAMBDA with non-unique continuation" + env)) + (append cont-vars other-vars))))) + ;; If this LAMBDA expression has a name, find all call sites and + ;; rewrite to pass additional arguments + (cond ((lamlift/env/binding env) + => (lambda (binding) + (let ((reorder + (lamlift/reorderer lambda-list** lifted-lambda-list))) + (for-each + (lambda (call) + (lamlift/applicate! + call reorder orig-lambda-list lifted-name + (lmap (lambda (arg-name) `(LOOKUP ,arg-name)) + extra-formals))) + (lamlift/binding/calls binding)))))) + (let ((lifted-form `(LAMBDA ,lifted-lambda-list ,(lambda/body form))) + (stub-lambda + (lambda (body-lambda-name) + ;; Should be modified to preserve complete alpha renaming + `(LAMBDA ,orig-lambda-list + (CALL (LOOKUP ,body-lambda-name) + ,@(lmap (lambda (name) + (if (or *after-cps-conversion?* + (not (continuation-variable? name))) + `(LOOKUP ,name) + `(QUOTE #F))) + lifted-lambda-list))))) + (lift-stub? + (or + ;; The stub can drift to a static frame, the stub is named, + ;; and there are operand uses that expect it to be in a static + ;; frame (because we did not add the static-liftable stubs to + ;; the extended parameter lists) + (and (lamlift/env/drift-frame env) + (eq? (lamlift/env/context (lamlift/env/drift-frame env)) + 'STATIC) + (lamlift/env/binding env) + (not (null? (lamlift/binding/operand-uses + (lamlift/env/binding env))))) + ;; Add your favourite other reasons here: + lamlift/*lift-stubs-aggressively?* + #F)) + (lift-to-drift-frame + (lambda (name lambda-form) + ((lifter/make + (lambda (env) + (lamlift/env/form (lamlift/env/drift-frame env)))) + env name lambda-form)))) + + ;; Rewrite the stub to call the split version with additional arguments + (lamlift/split lifted-form form) + (form/rewrite! + form + (cond (lift-stub? + (let ((stub-name (make-new-name))) + (for-each + (lambda (reference) + (form/rewrite! reference `(LOOKUP ,stub-name))) + (lamlift/binding/operand-uses (lamlift/env/binding env))) + (lift-to-drift-frame stub-name (stub-lambda lifted-name)) + `(QUOTE #F))) + (split? + (stub-lambda lifted-name)) + (else `(QUOTE #F)))) + (lamlift/lift! env lifted-name lifted-form))))) diff --git a/v8/src/compiler/midend/laterew.scm b/v8/src/compiler/midend/laterew.scm new file mode 100644 index 000000000..5680d4dc7 --- /dev/null +++ b/v8/src/compiler/midend/laterew.scm @@ -0,0 +1,307 @@ +#| -*-Scheme-*- + +$Id: laterew.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Late generic arithmetic rewrite +;;; package: (compiler midend) + +(declare (usual-integrations)) + +(define (laterew/top-level program) + (laterew/expr program)) + +(define-macro (define-late-rewriter keyword bindings . body) + (let ((proc-name (symbol-append 'LATEREW/ keyword))) + (call-with-values + (lambda () (%matchup bindings '(handler) '(cdr form))) + (lambda (names code) + `(define ,proc-name + (let ((handler (lambda ,names ,@body))) + (named-lambda (,proc-name form) + (laterew/remember ,code form)))))))) + +(define-late-rewriter LOOKUP (name) + `(LOOKUP ,name)) + +(define-late-rewriter LAMBDA (lambda-list body) + `(LAMBDA ,lambda-list + ,(laterew/expr body))) + +(define-late-rewriter LET (bindings body) + `(LET ,(lmap (lambda (binding) + (list (car binding) + (laterew/expr (cadr binding)))) + bindings) + ,(laterew/expr body))) + +(define-late-rewriter LETREC (bindings body) + `(LETREC ,(lmap (lambda (binding) + (list (car binding) + (laterew/expr (cadr binding)))) + bindings) + ,(laterew/expr body))) + +(define-late-rewriter QUOTE (object) + `(QUOTE ,object)) + +(define-late-rewriter DECLARE (#!rest anything) + `(DECLARE ,@anything)) + +(define-late-rewriter BEGIN (#!rest actions) + `(BEGIN ,@(laterew/expr* actions))) + +(define-late-rewriter IF (pred conseq alt) + `(IF ,(laterew/expr pred) + ,(laterew/expr conseq) + ,(laterew/expr alt))) + +(define-late-rewriter CALL (rator #!rest rands) + (cond ((and (QUOTE/? rator) + (rewrite-operator/late? (quote/text rator))) + => (lambda (handler) + (handler (laterew/expr* rands)))) + (else + `(CALL ,(laterew/expr rator) + ,@(laterew/expr* rands))))) + + +(define (laterew/expr expr) + (if (not (pair? expr)) + (illegal expr)) + (case (car expr) + ((QUOTE) + (laterew/quote expr)) + ((LOOKUP) + (laterew/lookup expr)) + ((LAMBDA) + (laterew/lambda expr)) + ((LET) + (laterew/let expr)) + ((DECLARE) + (laterew/declare expr)) + ((CALL) + (laterew/call expr)) + ((BEGIN) + (laterew/begin expr)) + ((IF) + (laterew/if expr)) + ((LETREC) + (laterew/letrec expr)) + ((SET! UNASSIGNED? OR DELAY + ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT) + (no-longer-legal expr)) + (else + (illegal expr)))) + +(define (laterew/expr* exprs) + (lmap (lambda (expr) + (laterew/expr expr)) + exprs)) + +(define (laterew/remember new old) + (code-rewrite/remember new old)) + +(define (laterew/new-name prefix) + (new-variable prefix)) + +;;;; Late open-coding of generic arithmetic + +(define (laterew/binaryop op %fixop %genop n-bits #!optional right-sided?) + (let ((right-sided? + (if (default-object? right-sided?) + false + right-sided?)) + (%test + (cond ((not (number? n-bits)) + (lambda (name constant-rand) + `(CALL (QUOTE ,%small-fixnum?) + (QUOTE #F) + (LOOKUP ,name) + (QUOTE ,(n-bits constant-rand))))) + #| + ;; Always open code as %small-fixnum? + ;; So that generic arithmetic can be + ;; recognized=>optimized at the RTL level + ((zero? n-bits) + (lambda (name constant-rand) + constant-rand ; ignored + `(CALL (QUOTE ,%machine-fixnum?) + (QUOTE #F) + (LOOKUP ,name)))) + |# + (else + (lambda (name constant-rand) + constant-rand ; ignored + `(CALL (QUOTE ,%small-fixnum?) + (QUOTE #F) + (LOOKUP ,name) + (QUOTE ,n-bits))))))) + (lambda (rands) + (let ((cont (car rands)) + (x (cadr rands)) + (y (caddr rands))) + (laterew/verify-hook-continuation cont) + (let ((%continue + (if (eq? (car cont) 'QUOTE) + (lambda (expr) + expr) + (lambda (expr) + `(CALL (QUOTE ,%invoke-continuation) + ,cont + ,expr))))) + + (cond ((laterew/number? x) + => (lambda (x-value) + (cond ((laterew/number? y) + => (lambda (y-value) + `(QUOTE ,(op x-value y-value)))) + (right-sided? + `(CALL (QUOTE ,%genop) ,cont ,x ,y)) + (else + (let ((y-name (laterew/new-name 'Y))) + `(LET ((,y-name ,y)) + (IF ,(%test y-name x-value) + ,(%continue + `(CALL (QUOTE ,%fixop) + (QUOTE #f) + (QUOTE ,x-value) + (LOOKUP ,y-name))) + (CALL (QUOTE ,%genop) + ,cont + (QUOTE ,x-value) + (LOOKUP ,y-name))))))))) + + ((laterew/number? y) + => (lambda (y-value) + (let ((x-name (laterew/new-name 'X))) + `(LET ((,x-name ,x)) + (IF ,(%test x-name y-value) + ,(%continue + `(CALL (QUOTE ,%fixop) + (QUOTE #f) + (LOOKUP ,x-name) + (QUOTE ,y-value))) + (CALL (QUOTE ,%genop) + ,cont + (LOOKUP ,x-name) + (QUOTE ,y-value))))))) + (right-sided? + `(CALL (QUOTE ,%genop) ,cont ,x ,y)) + (else + (let ((x-name (laterew/new-name 'X)) + (y-name (laterew/new-name 'Y))) + `(LET ((,x-name ,x) + (,y-name ,y)) + ;; There is no AND, since this occurs + ;; after macro-expansion + (IF ,(andify (%test x-name false) + (%test y-name false)) + ,(%continue + `(CALL (QUOTE ,%fixop) + (QUOTE #F) + (LOOKUP ,x-name) + (LOOKUP ,y-name))) + (CALL (QUOTE ,%genop) + ,cont + (LOOKUP ,x-name) + (LOOKUP ,y-name)))))))))))) + + +(define (laterew/verify-hook-continuation cont) + (if (not (or (QUOTE/? cont) + (LOOKUP/? cont) + (CALL/%stack-closure-ref? cont))) + (internal-error "Unexpected continuation to out-of-line hook" + cont)) + unspecific) + +(define *late-rewritten-operators* + (make-eq-hash-table 311)) + +(define-integrable (rewrite-operator/late? rator) + (hash-table/get *late-rewritten-operators* rator false)) + +(define (define-rewrite/late operator-name-or-object handler) + (hash-table/put! *late-rewritten-operators* + (if (hash-table/get *operator-properties* + operator-name-or-object + false) + operator-name-or-object + (make-primitive-procedure operator-name-or-object)) + handler)) + +(define (laterew/number? form) + (and (QUOTE/? form) + (number? (quote/text form)) + (quote/text form))) + +(define-rewrite/late '&+ + (laterew/binaryop + fix:+ %+ 1)) + +(define-rewrite/late '&- + (laterew/binaryop - fix:- %- 1)) + +(define-rewrite/late '&* + (laterew/binaryop * fix:* %* good-factor->nbits)) + +;; NOTE: these could use 0 as the number of bits, but this would prevent +;; a common RTL-level optimization triggered by CSE. + +(define-rewrite/late '&= + (laterew/binaryop = fix:= %= 1)) + +(define-rewrite/late '&< + (laterew/binaryop < fix:< %< 1)) + +(define-rewrite/late '&> + (laterew/binaryop > fix:> %> 1)) + +(define-rewrite/late 'QUOTIENT + (laterew/binaryop careful/quotient fix:quotient %quotient + (lambda (value) + (cond ((zero? value) + (user-error "QUOTIENT by 0")) + ((= value -1) + ;; Most negative fixnum overflows! + 1) + (else + 0))) + true)) + +(define-rewrite/late 'REMAINDER + (laterew/binaryop careful/remainder fix:remainder %remainder + (lambda (value) + (if (zero? value) + (user-error "REMAINDER by 0") + 0)) + true)) \ No newline at end of file diff --git a/v8/src/compiler/midend/load.scm b/v8/src/compiler/midend/load.scm new file mode 100644 index 000000000..e879bc162 --- /dev/null +++ b/v8/src/compiler/midend/load.scm @@ -0,0 +1,74 @@ +#| -*-Scheme-*- + +$Id: load.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Load script + +(declare (usual-integrations)) + +(define (reload file) + (fluid-let ((syntaxer/default-environment (nearest-repl/environment))) + (load-latest file))) + +(define (loadup) + (load-option 'HASH-TABLE) + (load "synutl") + (fluid-let ((syntaxer/default-environment (nearest-repl/environment))) + (load "midend") ; top level + (load "utils") + (load "fakeprim") ; pseudo primitives + (load "dbgstr") + (load "inlate") + (load "envconv") + (load "expand") + (load "assconv") + (load "cleanup") + (load "earlyrew") + (load "lamlift") + (load "closconv") + ;; (load "staticfy") ; broken, for now + (load "applicat") + (load "simplify") + (load "cpsconv") + (load "laterew") + (load "compat") ; compatibility with current code + (load "stackopt") + (load "indexify") + (load "rtlgen") + ;; The following are not necessary for execution + (load "debug") + (load "triveval"))) + +(define (load.scm:init) + (if (not (environment-bound? (nearest-repl/environment) 'execute)) + (load/push-hook! loadup))) \ No newline at end of file diff --git a/v8/src/compiler/midend/midend.scm b/v8/src/compiler/midend/midend.scm new file mode 100644 index 000000000..935bc3840 --- /dev/null +++ b/v8/src/compiler/midend/midend.scm @@ -0,0 +1,337 @@ +;;; -*- Scheme -*- + +(declare (usual-integrations)) + +;;;; Phase structure + +(define *phases-to-show* '()) +(define *announce-phases?* false) +(define *debugging?* true) +(define *current-phase-input* false) +(define *entry-label*) + +(define debugging-phase-wrapper + (let ((pending-message #F)) + + (lambda (proc this-phase next-phase) + (define (show-message message) + (newline) + ;(write-string ";---") + (write-string message) + (write this-phase)) + + (define (show-program message program) + (newline) + (write-char #\Page) + (if pending-message + (display pending-message)) + (set! pending-message #F) + (show-message message) + (write-string " #@") (display (hash program)) + (if *kmp-output-abbreviated?* + (begin + (write-string " (*kmp-output-abbreviated?* is #T)") + (newline) + (kmp/ppp program)) + (begin + (newline) + (kmp/pp program)))) + + (define (show? phase) + (and phase + (let ((switch *phases-to-show*)) + (or (eq? switch 'ALL) + (memq phase switch))))) + + (lambda (program) + (set! *current-phase* this-phase) + (set! *current-phase-input* (and *debugging?* program)) + (if *announce-phases?* + (begin + (newline) + (write-string ";; Phase ") + (write this-phase))) + (if (not (show? this-phase)) + (proc program) + (begin + (with-kmp-output-port + (lambda () + (show-program "Input to phase " program))) + (let ((result (proc program))) + (if (show? next-phase) + (set! pending-message + (with-output-to-string + (lambda () + (show-message "Output from phase ")))) + (with-kmp-output-port + (lambda () + (show-program "Output from phase " result)))) + result))))))) + +(define (phase-wrapper rewrite) + (lambda (program) + (let ((table *code-rewrite-table*)) + (set! *previous-code-rewrite-table* table) + (set! *code-rewrite-table* (and table (code/rewrite-table/make))) + (rewrite program)))) + +(define (dummy-phase rewrite) + (lambda (program) + (set! *code-rewrite-table* *previous-code-rewrite-table*) + (rewrite program))) + +;;;; Top level + +(define *current-phase* 'UNKNOWN) +(define *allow-random-choices?* false) +(define *after-cps-conversion?* false) +(define *lift-closure-lambdas?* false) +(define *flush-closure-calls?* false) +(define *order-of-argument-evaluation* 'ANY) ; LEFT-TO-RIGHT, RIGHT-TO-LEFT +(define *earlyrew-expand-genarith?* false) +(define *sup-good-factor* 512) +(define *variable-properties* false) +(define *previous-code-rewrite-table* false) +(define *code-rewrite-table* false) + +(let-syntax ((cascade + (macro all + (let ((name (generate-uninterned-symbol 'FORM))) + (let loop ((result name) + (all all)) + (if (null? all) + `(lambda (,name) + ,result) + (loop `((debugging-phase-wrapper + (phase-wrapper ,(car all)) + ',(car all) + ',(if (null? (cdr all)) + false + (cadr all))) + ,result) + (cdr all)))))))) + + (define compile-0 + (cascade inlate/top-level ; scode->kmp-scheme + )) + + (define compile-1 + (cascade envconv/top-level ; eliminate free variables + ; and (the-environment) + ; introducing cache references + ; rewriting LOOKUP, SET!, etc. + )) + + (define compile-2 + (cascade alphaconv/top-level ; makes all bindings have unique names + expand/top-level ; rewrite OR, and DELAY + assconv/top-level ; eliminate SET! and introduce LETREC + ; rewriting LOOKUP and SET! + cleanup/top-level/1 ; as below + earlyrew/top-level ; rewrite -1+ into -, etc. + lamlift/top-level/1 ; flatten environment structure + ; splitting lambda nodes if necessary + closconv/top-level/1 ; introduce %make-heap-closure + ; and %heap-closure-ref + ; after this pass there are no + ; non-local variable references + ;; staticfy/top-level ; broken, for now + applicat/top-level ; get rid of #!OPTIONAL and #!REST when + ; calling known operators + ; Introduce %internal-apply + simplify/top-level/1 ; 1st-half of beta substitution + ; replace variable operators with + ; lambda expressions + cleanup/top-level/2 ; 2nd-half of beta substitution + ; substituting values for bindings + cpsconv/top-level/1 ; cps conversion, sequencing of + ; parallel expressions + simplify/top-level/2 ; as above + cleanup/top-level/3 ; as above + lamlift/top-level/2 ; as above + + closconv/top-level/2 ; as above, but using + ; %make-stack-closure and + ; %stack-closure-ref + simplify/top-level/3 ; as above + cleanup/top-level/4 ; as above + + closan/top-level/split + simplify/top-level/4 ; as above + cleanup/top-level/5 ; as above + + closan/top-level/widen + simplify/top-level/5 ; as above + cleanup/top-level/6 ; as above + + laterew/top-level ; rewrite &+, vector-cons, + cleanup/top-level/7 ; as above + compat/top-level ; rewrite code for compatibility + ; with current compiled code + stackopt/top-level ; reformat stack closures to use + ; common formats (prefixes) + ;; stackopt/optional-debugging-paranoia + indexify/top-level ; rewrite %vector-index + )) + + (define %optimized-kmp->rtl + (cascade rtlgen/top-level)) + + (define compile-0* + (cascade (dummy-phase compile-0) + (dummy-phase compile-1) + (dummy-phase compile-2))) + + (define compile-1* + (cascade (dummy-phase compile-1) + (dummy-phase compile-2)))) + +(define (within-midend recursive? thunk) + (fluid-let ((*current-phase* false) + (*current-phase-input* false) + (*variable-properties* + (if (not recursive?) + (make-variable-properties) + (copy-variable-properties))) + (*after-cps-conversion?* false) + (*previous-code-rewrite-table* false) + (*code-rewrite-table* + (if (not recursive?) + (code/rewrite-table/make) + (code/rewrite-table/copy *code-rewrite-table*)))) + (if (not recursive?) + (begin + ;; Initialize the uninterned symbol generator + ;; in order to obtain comparable programs + (generate-uninterned-symbol 'initial) + (generate-uninterned-symbol 0) + (initialize-new-variable!))) + (thunk))) + +(define *last-code-rewrite-table*) + +(define (compile program) + (within-midend false + (lambda () + (let ((result (compile-0* program))) + (set! *last-code-rewrite-table* *code-rewrite-table*) + result)))) + +(define (scode->kmp program) + (compile-0 program)) + +(define (optimize-kmp recursive? program) + (compile-1* program)) + +(define (kmp->rtl program) + (fluid-let ((*entry-label* false)) + (let ((code (%optimized-kmp->rtl program))) + (values code *entry-label*)))) + +(define (compile-recursively program procedure? name) + ;; (values result must-be-called?) + (compile-recursively/new program procedure? name)) + +;; Some of these have independent names only for debugging + +(define (cpsconv/top-level/1 program) + (let ((result (cpsconv/top-level program))) + (set! *after-cps-conversion?* true) + result)) + +(define (lamlift/top-level/1 program) + (lamlift/top-level program)) + +(define (lamlift/top-level/2 program) + (lamlift/top-level program)) + +(define (closan/top-level/split program) + (split-and-drift program)) + +(define (closan/top-level/widen program) + (widen-parameter-lists program)) + +(define (closconv/top-level/1 program) + (closconv/top-level program *after-cps-conversion?*)) + +(define (closconv/top-level/2 program) + (closconv/top-level program *after-cps-conversion?*)) + +(define (simplify/top-level/1 program) + (simplify/top-level program)) + +(define (simplify/top-level/2 program) + (simplify/top-level program)) + +(define (simplify/top-level/3 program) + (simplify/top-level program)) + +(define (simplify/top-level/4 program) + (simplify/top-level program)) + +(define (simplify/top-level/5 program) + (simplify/top-level program)) + +(define (simplify/top-level/6 program) + (simplify/top-level program)) + +(define (cleanup/top-level/1 program) + (cleanup/top-level program)) + +(define (cleanup/top-level/2 program) + (fluid-let ((*flush-closure-calls?* true)) + (cleanup/top-level program))) + +(define (cleanup/top-level/3 program) + (cleanup/top-level program)) + +(define (cleanup/top-level/4 program) + (cleanup/top-level program)) + +(define (cleanup/top-level/5 program) + (cleanup/top-level program)) + +(define (cleanup/top-level/6 program) + (cleanup/top-level program)) + +(define (cleanup/top-level/7 program) + (cleanup/top-level program)) + +;;;; Debugging aids + +;;; Errors and warnings + +;; These should have their own condition types so that specific handlers +;; can be established. + +(define (configuration-error complaint . reasons) + (apply error complaint *current-phase* reasons)) + +(define (internal-error complaint . reasons) + (apply error complaint *current-phase* reasons)) + +(define (user-error complaint . reasons) + (apply error complaint *current-phase* reasons)) + +(define (internal-warning complaint . reasons) + (apply warn complaint *current-phase* reasons)) + +(define (user-warning complaint . reasons) + (apply warn complaint *current-phase* reasons)) + +(define (illegal form) + (internal-error "Illegal KMP form" form)) + +(define (no-longer-legal form) + (internal-error "Unexpected KMP form -- should have been expanded" + form)) + +(define (not-yet-legal form) + (internal-error "Unexpected KMP form -- should not occur yet" + form)) + +(define (free-var-error name) + (internal-error "Free variable found" name)) + +(define (unimplemented name) + (internal-error "Unimplemented procedure" name)) \ No newline at end of file diff --git a/v8/src/compiler/midend/rtlgen.scm b/v8/src/compiler/midend/rtlgen.scm new file mode 100644 index 000000000..0437acab4 --- /dev/null +++ b/v8/src/compiler/midend/rtlgen.scm @@ -0,0 +1,4149 @@ +#| -*-Scheme-*- + +$Id: rtlgen.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; ?? +;;; package: (compiler midend) + +(declare (usual-integrations)) + +(define *rtlgen/procedures*) +(define *rtlgen/continuations*) +(define *rtlgen/object-queue*) +(define *rtlgen/delayed-objects*) +(define *rtlgen/fold-tag-predicates?* true) +(define *rtlgen/fold-simple-value-tests?* #T) + +(define (rtlgen/top-level program) + (initialize-machine-register-map!) + (fluid-let ((*rtlgen/object-queue* (queue/make)) + (*rtlgen/delayed-objects* '()) + (*rtlgen/procedures* '()) + (*rtlgen/continuations* '())) + (call-with-values + (lambda () + (if *procedure-result?* + (rtlgen/top-level-procedure program) + (rtlgen/expression program))) + (lambda (root label) + (queue/drain! *rtlgen/object-queue* rtlgen/dispatch) + (set! *entry-label* label) + (append! root + (fold-right append! + (fold-right append! '() + (reverse! *rtlgen/continuations*)) + (reverse! *rtlgen/procedures*))))))) + +(define (rtlgen/expression form) + (let ((label (rtlgen/new-name 'EXPRESSION))) + (values (rtlgen/%%procedure label form rtlgen/wrap-expression) + label))) + +(define (rtlgen/top-level-procedure form) + (define (fail) + (internal-error + "Improperly formatted top-level procedure expression")) + (define result (form/match rtlgen/outer-expression-pattern form)) + (if (not result) + (fail)) + (let ((continuation-name (cadr (assq rtlgen/?cont-name result))) + (env-name (cadr (assq rtlgen/?env-name result)))) + (let loop ((body (third form))) + (cond + ((LET/? body) + ;; Assume static binding + (loop (let/body body))) + ((LETREC/? body) + (rtlgen/letrec/bindings (letrec/bindings body)) + (loop (letrec/body body))) + ((form/match rtlgen/top-level-trivial-closure-pattern body) + => (lambda (result) + (let ((cont-name (cadr (assq rtlgen/?cont-name result))) + (lam-expr (cadr (assq rtlgen/?lambda-expression result)))) + (if (not (eq? continuation-name cont-name)) + (fail) + (let* ((label (rtlgen/new-name 'TOP-LEVEL)) + (code (rtlgen/%%procedure + label lam-expr rtlgen/wrap-trivial-closure))) + (values code label)))))) + ((form/match rtlgen/top-level-heap-closure-pattern body) + => (lambda (result) + (let ((cont-name (cadr (assq rtlgen/?cont-name result)))) + (if (not (eq? continuation-name cont-name)) + (fail) + (let* ((label (rtlgen/new-name 'TOP-LEVEL-CLOSURE)) + (code + (rtlgen/%%procedure label + `(LAMBDA (,cont-name ,env-name) + ,body) + rtlgen/wrap-trivial-closure))) + (set! *procedure-result?* 'CALL-ME) + (values code label)))))) + (else (fail)))))) + +(define (rtlgen/dispatch desc) + (let ((kind (vector-ref desc 0)) + (label (vector-ref desc 1)) + (object (vector-ref desc 2))) + (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))))) + +(define (rtlgen/enqueue! desc) + (queue/enqueue! *rtlgen/object-queue* desc)) + +(define (rtlgen/trivial-closure label lam-expr) + (rtlgen/%procedure label lam-expr rtlgen/wrap-trivial-closure)) + +(define (rtlgen/closure label lam-expr) + (rtlgen/%procedure label lam-expr rtlgen/wrap-closure)) + +(define (rtlgen/procedure label lam-expr) + (rtlgen/%procedure label lam-expr rtlgen/wrap-procedure)) + +(define (rtlgen/%procedure label lam-expr wrap) + (set! *rtlgen/procedures* + (cons (rtlgen/%%procedure label lam-expr wrap) + *rtlgen/procedures*)) + unspecific) + +(define (rtlgen/%%procedure label lam-expr wrap) + ;; This is called directly for top-level expressions and procedures. + ;; All other calls are from rtlgen/%procedure which adds the result + ;; to the list of all procedures (*rtlgen/procedures*) + (rtlgen/%body-with-stack-references label lam-expr wrap + (lambda () + (let ((lambda-list (lambda/formals lam-expr)) + (body (lambda/body lam-expr))) + (rtlgen/body + body + (lambda (body*) (wrap label body* lambda-list 0)) + (lambda () (rtlgen/initial-state lambda-list false body))))))) + +(define (rtlgen/wrap-expression label body lambda-list saved-size) + lambda-list ; Not used + saved-size ; only continuations + (cons `(EXPRESSION ,label) + (rtlgen/wrap-with-interrupt-check/expression + body + `(INTERRUPT-CHECK:CONTINUATION ,label (MACHINE-CONSTANT 1))))) + +(define (rtlgen/wrap-continuation label body lambda-list saved-size) + (let* ((arity (lambda-list/count-names lambda-list)) + (frame-size + (+ (- saved-size 1) ; Don't count the return address + (- arity + (min arity (rtlgen/number-of-argument-registers)))))) + (cons `(RETURN-ADDRESS ,label + (MACHINE-CONSTANT ,frame-size) + (MACHINE-CONSTANT 1)) + (rtlgen/wrap-with-interrupt-check/continuation + body + `(INTERRUPT-CHECK:CONTINUATION ,label (MACHINE-CONSTANT 2)))))) + +(define (rtlgen/wrap-closure label body lambda-list saved-size) + saved-size ; only continuations have this + (let ((frame-size (lambda-list/count-names lambda-list))) + (cons `(CLOSURE ,label (MACHINE-CONSTANT ,frame-size)) + (rtlgen/wrap-with-interrupt-check/procedure + true + body + `(INTERRUPT-CHECK:CLOSURE (MACHINE-CONSTANT ,frame-size)))))) + +(define (rtlgen/wrap-trivial-closure label body lambda-list saved-size) + saved-size ; only continuations have this + (let ((frame-size (lambda-list/count-names lambda-list))) + (cons `(TRIVIAL-CLOSURE ,label + ,@(map + (lambda (value) + `(MACHINE-CONSTANT ,value)) + (lambda-list/arity-info lambda-list))) + (rtlgen/wrap-with-interrupt-check/procedure + true + body + `(INTERRUPT-CHECK:PROCEDURE ,label (MACHINE-CONSTANT ,frame-size)))))) + +(define (rtlgen/wrap-procedure label body lambda-list saved-size) + saved-size ; only continuations have this + (let ((frame-size (lambda-list/count-names lambda-list))) + (cons `(PROCEDURE ,label (MACHINE-CONSTANT ,frame-size)) + (rtlgen/wrap-with-interrupt-check/procedure + false + body + `(INTERRUPT-CHECK:PROCEDURE ,label + (MACHINE-CONSTANT ,frame-size)))))) + +(define (rtlgen/continuation label lam-expr) + (set! *rtlgen/continuations* + (cons (rtlgen/%%continuation + label lam-expr rtlgen/wrap-continuation) + *rtlgen/continuations*)) + unspecific) + +(define *rtlgen/frame-size* false) + +(define (rtlgen/->number-of-args-on-stack lambda-list frame-vector) + ;; The lambda list is like (cont arg1 ... argn) including #!optional, etc. + ;; The frame-vector is #(saved1 ... savedm argk+1 ... argn) + ;; Returns n-k + ;; NOTE: Assumes that the arguments passed on the stack are taken + ;; from the end of the formal parameter list. + (let ((n (vector-length frame-vector))) + (let loop ((lst (reverse (lambda-list->names lambda-list))) + (i (- n 1))) + (if (or (null? lst) + (negative? i) + (not (eq? (vector-ref frame-vector i) (car lst)))) + (- n i 1) + (loop (cdr lst) (- i 1)))))) + +(define (rtlgen/%%continuation label lam-expr wrap) + (rtlgen/%body-with-stack-references label lam-expr wrap + (lambda () (internal-error "continuation without stack frame" lam-expr)))) + +(define (rtlgen/%body-with-stack-references label lam-expr wrap no-stack-refs) + (cond ((form/match rtlgen/continuation-pattern lam-expr) + => (lambda (result) + (let ((lambda-list (cadr (assq rtlgen/?lambda-list result))) + (frame-vector (cadr (assq rtlgen/?frame-vector result))) + (body (cadr (assq rtlgen/?continuation-body + result)))) + (let ((frame-size (vector-length frame-vector))) + (fluid-let ((*rtlgen/frame-size* frame-size)) + (rtlgen/body + body + (lambda (body*) + (let ((saved-size + (- frame-size + (rtlgen/->number-of-args-on-stack + lambda-list frame-vector)))) + (wrap label body* lambda-list saved-size))) + (lambda () + (rtlgen/initial-state lambda-list + frame-vector body)))))))) + (else (no-stack-refs)))) + +(define (rtlgen/initial-state params frame-vector body) + + (define env '()) + (define (add-binding! name reg home) + (let ((binding (rtlgen/binding/make name reg home))) + (set! env (cons binding env)) + binding)) + + (define register-arg-positions-used '()) + (define (add-used! home i) + (if (rtlgen/register? home) + (set! register-arg-positions-used + (cons i register-arg-positions-used)))) + + (define (do-register-params params) + (let ((first-stack-param ; stop at first stack param + (if frame-vector + (let ((n-on-stack + (rtlgen/->number-of-args-on-stack params frame-vector))) + (if (zero? n-on-stack) + #F + (vector-ref frame-vector + (- (vector-length frame-vector) + n-on-stack)))) + #F))) + (let loop ((params params) + (i 0)) + (cond ((or (null? params) (eq? (car params) first-stack-param)) + 'done) + ((memq (car params) '(#!rest #!optional)) + (loop (cdr params) i)) + (else + (let* ((home (rtlgen/argument-home i)) + (reg (rtlgen/new-reg)) + (home-syllable (and (rtlgen/register? home) home))) + (rtlgen/emit!/1 `(ASSIGN ,reg ,home)) + (add-binding! (car params) reg home-syllable) + (add-used! home i) + (loop (cdr params) (+ i 1)))))))) + + (define (do-continuation name stack-offset) + ;; We previously removed the assignment if NAME wasn't a + ;; referenced-continuation-variable, but that caused problems + ;; because "unreferenced" in this case actually means "never + ;; invoked", not "never passed as an argument"! However, we + ;; must be careful to make sure we dont think that the + ;; unreferenced continuation has a stack slot! + (let* ((used? (referenced-continuation-variable? name)) + (source (cond ((not used?) + `(CONSTANT unused-continuation-variable)) + ((rtlgen/cont-in-stack?) + (rtlgen/stack-ref stack-offset)) + (else + (rtlgen/reference-to-cont)))) + (home (if used? source #F)) + (coerce? (and used? (rtlgen/tagged-entry-points?))) + (raw-reg (rtlgen/new-reg)) + (cont-reg (if coerce? (rtlgen/new-reg) raw-reg))) + (rtlgen/emit!/1 + `(ASSIGN ,raw-reg ,source)) + (if coerce? + (rtlgen/emit!/1 + `(ASSIGN ,cont-reg (COERCE-VALUE-CLASS ,raw-reg ADDRESS)))) + (add-binding! name cont-reg home))) + + (define (do-closure name stack-offset) + (let* ((source (if (rtlgen/closure-in-stack?) + (rtlgen/stack-ref stack-offset) + (rtlgen/reference-to-closure))) + (coerce? (rtlgen/tagged-entry-points?)) + (raw-reg (rtlgen/new-reg)) + (closure-reg (if coerce? (rtlgen/new-reg) raw-reg))) + (rtlgen/emit!/1 + `(ASSIGN ,raw-reg ,source)) + (if coerce? + (rtlgen/emit!/1 + `(ASSIGN ,closure-reg (COERCE-VALUE-CLASS ,raw-reg ADDRESS)))) + (add-binding! name closure-reg source))) + + (let* ((continuation-name (if (and (pair? params) + (continuation-variable? (car params))) + (car params) + #F)) + (sans-cont (if continuation-name (cdr params) params)) + (closure-name (if (and (pair? sans-cont) + (closure-variable? (car sans-cont))) + (car sans-cont) + #F)) + (sans-special (if closure-name (cdr sans-cont) sans-cont)) + + (receives-continuation? + (and continuation-name + (referenced-continuation-variable? continuation-name))) + (closure-offset (and (rtlgen/closure-in-stack?) + (if closure-name 0 #F))) + (continuation-offset (and (rtlgen/cont-in-stack?) + receives-continuation? + (if closure-offset 1 0))) + (stack-offset-adjustment (+ 1 (max (or closure-offset -1) + (or continuation-offset -1))))) + + (do-register-params sans-special) + (let* ((closure-binding + (and closure-name (do-closure closure-name closure-offset))) + (continuation-binding + (and continuation-name + (do-continuation continuation-name continuation-offset)))) + + (rtlgen/state/stmt/make + (if frame-vector + (rtlgen/initial-stack-state + env register-arg-positions-used + stack-offset-adjustment + frame-vector body) + env) + (and receives-continuation? continuation-binding) + closure-binding + (+ (if frame-vector + (vector-length frame-vector) + 0) + stack-offset-adjustment))))) + + +(define (rtlgen/find-preferred-call stmt) + ;; (values call operator unconditional?) + (define (tail-call? form) + (let ((cont (call/continuation form))) + (or (LOOKUP/? cont) + (form/match rtlgen/stack-overwrite-pattern cont)))) + + (let ((unconditional? true) + (tail-call false) + (other-call false) + (any-call false)) + (let walk ((form stmt)) + (and (pair? form) + (case (car form) + ((CALL) + (if (LOOKUP/? (call/operator form)) + (if (and (not tail-call) (tail-call? form)) + (set! tail-call form) + (set! other-call form)) + (set! any-call form)) + unspecific) + ((LET) + (walk (let/body form))) + ((IF) + (set! unconditional? false) + (walk (if/consequent form)) + (walk (if/alternate form))) + ((BEGIN) + (walk (car (last-pair (cdr form))))) + (else + false)))) + (let ((call (or tail-call other-call any-call))) + (values call (and call (call/operator call)) unconditional?)))) + +(define (rtlgen/initial-stack-state + env register-arg-positions-used + stack-offset-adjustment + frame-vector body) + + (define (first-stack-offset) + (+ (vector-length frame-vector) + stack-offset-adjustment + -1)) + + (define (default env handled) + ;; Continuation dealt with specially + (let loop ((stack-offset (first-stack-offset)) + (i 0) + (env env)) + (cond ((= i (vector-length frame-vector)) env) + ((continuation-variable? (vector-ref frame-vector i)) + (loop (- stack-offset 1) (+ i 1) env)) + (else + (loop (- stack-offset 1) + (+ i 1) + (let ((name (vector-ref frame-vector i))) + (if (memq name handled) + env + (cons (let ((home (rtlgen/stack-ref stack-offset))) + (rtlgen/binding/make name + (rtlgen/->register home) home)) + env)))))))) + + ;; Try to target register assignments from stack locations + (call-with-values + (lambda () (rtlgen/find-preferred-call body)) + (lambda (call rator unconditional?) + unconditional? ; ignored + (if (or (not call) (QUOTE/? rator)) + ;; THIS IS OVERKILL. We need to analyze the "known operators" and do + ;; something to target well for things like %internal-apply. + ;; Or ditch this and have Daniel write a good register + ;; allocator. + (default env '()) + (let ((max-index (rtlgen/number-of-argument-registers)) + (first-offset (first-stack-offset))) + ;; Directly target the arguments registers for a likely + ;; call and move any stack references into the argument + ;; registers for that particular call. All other stack + ;; references will be targeted to default locations. + (let target ((rands (call/operands call)) + (env env) + (names '()) + (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))))))) + (else + (target (cdr rands) env names (+ arg-position 1)))))))))) + +(define *rtlgen/next-rtl-pseudo-register*) +(define *rtlgen/pseudo-register-values*) +(define *rtlgen/pseudo-registers*) +(define *rtlgen/statements*) +(define *rtlgen/words-allocated*) +(define *rtlgen/stack-depth*) +(define *rtlgen/max-stack-depth*) +(define *rtlgen/form-calls-external?*) +(define *rtlgen/form-calls-internal?*) +(define *rtlgen/form-returns?*) + +(define (rtlgen/body form wrap gen-state) + (fluid-let ((*rtlgen/next-rtl-pseudo-register* 0) + (*rtlgen/pseudo-registers* '()) + (*rtlgen/pseudo-register-values* '()) + (*rtlgen/words-allocated* 0) + (*rtlgen/stack-depth* 0) + (*rtlgen/max-stack-depth* 0) + (*rtlgen/statements* (queue/make)) + (*rtlgen/form-calls-internal?* false) + (*rtlgen/form-calls-external?* false) + (*rtlgen/form-returns?* false)) + (rtlgen/stmt (gen-state) form) + (rtlgen/renumber-pseudo-registers! + (rtlgen/first-pseudo-register-number)) + (wrap (queue/contents *rtlgen/statements*)))) + +(define (rtlgen/wrap-with-interrupt-check/expression body desc) + ;; *** For now, this does not check interrupts. + ;; The environment must be handled specially *** + desc ; ignored + body) + +(define (rtlgen/wrap-with-interrupt-check/procedure external? body desc) + (rtlgen/wrap-with-intrpt-check (and (rtlgen/generate-interrupt-checks?) + (or *rtlgen/form-calls-external?* + (and (not external?) + *rtlgen/form-calls-internal?*))) + (and (rtlgen/generate-heap-checks?) + (not (= *rtlgen/words-allocated* 0)) + *rtlgen/words-allocated*) + (and (rtlgen/generate-stack-checks?) + (not (= *rtlgen/max-stack-depth* 0)) + *rtlgen/max-stack-depth*) + body + desc)) + +(define (rtlgen/wrap-with-interrupt-check/continuation body desc) + ;; For now, this is dumb about interrupt checks. + (rtlgen/wrap-with-intrpt-check (rtlgen/generate-interrupt-checks?) + (and (rtlgen/generate-heap-checks?) + (not (= *rtlgen/words-allocated* 0)) + *rtlgen/words-allocated*) + (and (rtlgen/generate-stack-checks?) + (not (= *rtlgen/max-stack-depth* 0)) + *rtlgen/max-stack-depth*) + body + desc)) + +(define (rtlgen/wrap-with-intrpt-check calls? heap-check? stack-check? + body desc) + (if (not (or calls? heap-check? stack-check?)) + body + (cons `(,(car desc) ,calls? ,heap-check? ,stack-check? ,@(cdr desc)) + body))) + +(define-integrable (rtlgen/emit! insts) + (queue/enqueue!* *rtlgen/statements* insts)) + +(define-integrable (rtlgen/emit!/1 inst) + (queue/enqueue! *rtlgen/statements* inst)) + +(define-integrable (rtlgen/declare-allocation! nwords) + ;; *** NOTE: This does not currently include floats! *** + (set! *rtlgen/words-allocated* (+ nwords *rtlgen/words-allocated*)) + unspecific) + +(define (rtlgen/declare-stack-allocation! nwords) + (let ((new (+ nwords *rtlgen/stack-depth*))) + (set! *rtlgen/stack-depth* new) + (if (> new *rtlgen/max-stack-depth*) + (set! *rtlgen/max-stack-depth* new))) + unspecific) + +(define (rtlgen/stack-allocation/protect thunk) ; /compatible ? + (let ((sd *rtlgen/stack-depth*) + (msd *rtlgen/max-stack-depth*)) + (let ((result (thunk))) + (set! *rtlgen/stack-depth* sd) + (set! *rtlgen/max-stack-depth* msd) + result))) + +(define (rtlgen/emit-alternatives! gen1 gen2 need-merge?) + (let ((merge-label (and need-merge? (rtlgen/new-name 'MERGE)))) + (let ((orig-depth *rtlgen/stack-depth*) + (orig-heap *rtlgen/words-allocated*) + (orig-values *rtlgen/pseudo-register-values*)) + (gen1) + (if merge-label + (rtlgen/emit!/1 `(JUMP ,merge-label))) + (let ((heap-after-one *rtlgen/words-allocated*)) + (set! *rtlgen/stack-depth* orig-depth) + (set! *rtlgen/words-allocated* orig-heap) + (set! *rtlgen/pseudo-register-values* orig-values) + (gen2) + (if merge-label + (rtlgen/emit!/1 `(LABEL ,merge-label))) + (let ((heap-after-two *rtlgen/words-allocated*)) + (set! *rtlgen/stack-depth* orig-depth) + (if (> heap-after-one heap-after-two) + (set! *rtlgen/words-allocated* heap-after-one)) + (set! *rtlgen/pseudo-register-values* orig-values) + unspecific))))) + +(define-integrable (rtlgen/register? frob) + (and (pair? frob) + (eq? (car frob) 'REGISTER))) + +(define-integrable (rtlgen/%pseudo-register? frob) + (not (null? (cddr frob)))) + +(define-integrable (rtlgen/%machine-register? frob) + (null? (cddr frob))) + +(define-integrable (rtlgen/machine-register? frob) + (and (rtlgen/register? frob) + (rtlgen/%machine-register? frob))) + +(define (rtlgen/new-reg) + (let ((next-reg *rtlgen/next-rtl-pseudo-register*)) + (set! *rtlgen/next-rtl-pseudo-register* (+ next-reg 1)) + (let ((result `(REGISTER ,next-reg PSEUDO))) + (set! *rtlgen/pseudo-registers* (cons result *rtlgen/pseudo-registers*)) + result))) + +(define (rtlgen/renumber-pseudo-registers! base) + (for-each (lambda (reg) + (set-cdr! (cdr reg) '()) + (set-car! (cdr reg) (+ (cadr reg) base))) + *rtlgen/pseudo-registers*)) + +(define (rtlgen/assign! rand* rand) + (if (not (rtlgen/register? rand*)) + (internal-error "rtlgen/assign! invoked on non-register")) + (if (rtlgen/%pseudo-register? rand*) + ;; Pseudo register + (set! *rtlgen/pseudo-register-values* + (cons (list rand* rand) + *rtlgen/pseudo-register-values*))) + (rtlgen/emit!/1 `(ASSIGN ,rand* ,rand))) + +(define (rtlgen/assign!* instructions) + (for-each + (lambda (instruction) + (if (and (pair? instruction) + (eq? (first instruction) 'ASSIGN) + (rtlgen/register? (second instruction))) + (rtlgen/assign! (second instruction) (third instruction)) + (rtlgen/emit!/1 instruction))) + instructions)) + +(define (rtlgen/->register rand) + (if (rtlgen/register? rand) + rand + (let ((rand* (rtlgen/new-reg))) + (rtlgen/assign! rand* rand) + rand*))) + +(define (rtlgen/value-assignment state value) + (let* ((target (rtlgen/state/expr/target state)) + (target* + (case (car target) + ((ANY) + (rtlgen/new-reg)) + ((REGISTER) + target) + (else + (internal-error "Unexpected target for value" target))))) + (rtlgen/assign! target* value) + target*)) + +;;;; Stack and Heap allocation + +(define (rtlgen/heap-push! elts) + (rtlgen/declare-allocation! (length elts)) + (if (rtlgen/heap-post-increment?) + (rtlgen/heap-push!/post-increment elts) + (rtlgen/heap-push!/bump-once elts))) + +(define (rtlgen/heap-push!/post-increment elts) + (let ((free (rtlgen/reference-to-free))) + (rtlgen/emit! + (map (lambda (elt) + `(ASSIGN (POST-INCREMENT ,free 1) ,(rtlgen/->register elt))) + elts)))) + +(define (rtlgen/heap-push!/post-increment elts) + (let ((free (rtlgen/reference-to-free))) + (for-each + (lambda (elt) + (rtlgen/emit!/1 + `(ASSIGN (POST-INCREMENT ,free 1) ,(rtlgen/->register elt)))) + elts))) + + + +(define (rtlgen/heap-push!/bump-once elts) + (let ((free (rtlgen/reference-to-free))) + (do ((i 0 (+ i 1)) + (elts elts (cdr elts)) + (acc '() (cons `(ASSIGN (OFFSET ,free (MACHINE-CONSTANT ,i)) + ,(rtlgen/->register (car elts))) + acc))) + ((null? elts) + (rtlgen/emit! + (reverse! + (cons `(ASSIGN ,free (OFFSET-ADDRESS ,free (MACHINE-CONSTANT ,i))) + acc))))))) + +(define (rtlgen/stack-push! elts) + (rtlgen/declare-stack-allocation! (length elts)) + (if (rtlgen/stack-pre-increment?) + (rtlgen/stack-push!/pre-increment elts) + (rtlgen/stack-push!/bump-once elts))) + +(define-integrable (rtlgen/stack-push!/1 elt) + (rtlgen/stack-push! (list elt))) + +(define (rtlgen/stack-push!/pre-increment elts) + (let ((sp (rtlgen/reference-to-sp))) + (rtlgen/emit! + (map (lambda (elt) + `(ASSIGN (PRE-INCREMENT ,sp -1) ,(rtlgen/->register elt))) + elts)))) + +(define (rtlgen/stack-push!/bump-once elts) + (let ((nelts (length elts))) + (do ((i (- nelts 1) (- i 1)) + (elts elts (cdr elts)) + (acc '() (cons (rtlgen/write-stack-loc + (rtlgen/->register (car elts)) + i) + acc))) + ((null? elts) + (rtlgen/emit! + (cons (rtlgen/bop-stack-pointer (- 0 nelts)) + (reverse! acc))))))) + +(define (rtlgen/stack-pop!) + (let ((target (rtlgen/new-reg))) + (rtlgen/%stack-pop! target) + target)) + +(define (rtlgen/%stack-pop! target) + (let ((rsp (rtlgen/reference-to-sp))) + (if (rtlgen/stack-post-increment?) + (rtlgen/emit!/1 + `(ASSIGN ,target (POST-INCREMENT ,rsp 1))) + (rtlgen/emit! + (list (rtlgen/read-stack-loc target 0) + (rtlgen/bop-stack-pointer 1)))))) + +(define (rtlgen/bop-stack-pointer! n) + (if (not (= n 0)) + (rtlgen/emit!/1 (rtlgen/bop-stack-pointer n)))) + +;;;; Machine-dependent parameters +;; *** Currently Spectrum-specific *** + +;; The rtlgen/reference-* are expected to return an RTL register reference + +(define (rtlgen/cont-in-stack?) + continuation-in-stack?) + +(define (rtlgen/closure-in-stack?) + closure-in-stack?) + +(define (rtlgen/reference-to-free) + (interpreter-free-pointer)) + +(define-integrable (rtlgen/reference-to-sp) + (interpreter-stack-pointer)) + +(define-integrable (rtlgen/stack-ref n) + `(OFFSET ,(rtlgen/reference-to-sp) (MACHINE-CONSTANT ,n))) + +(define-integrable (rtlgen/stack-offset n) + `(OFFSET-ADDRESS ,(rtlgen/reference-to-sp) (MACHINE-CONSTANT ,n))) + +(define #|-integrable|# (rtlgen/bop-stack-pointer n) + `(ASSIGN ,(rtlgen/reference-to-sp) ,(rtlgen/stack-offset n))) + +(define-integrable (rtlgen/read-stack-loc reg n) + `(ASSIGN ,reg ,(rtlgen/stack-ref n))) + +(define-integrable (rtlgen/write-stack-loc reg n) + `(ASSIGN ,(rtlgen/stack-ref n) ,reg)) + +(define (rtlgen/stack-ref? syllable) + (and (pair? syllable) + (eq? (first syllable) 'OFFSET) + (eq? (second syllable) (rtlgen/reference-to-sp)))) + +(define (rtlgen/reference-to-regs) + (interpreter-regs-pointer)) + + +(define (rtlgen/reference-to-cont) + ;; defined only if not cont-in-stack? + (interpreter-continuation-register)) + +(define (rtlgen/reference-to-closure) + (interpreter-closure-register)) + +(define (rtlgen/fetch-memtop) + (interpreter-memtop-register)) + +(define (rtlgen/fetch-int-mask) + (interpreter-int-mask-register)) + +(define (rtlgen/fetch-environment) + (interpreter-environment-register)) + +;; *rtlgen/argument-registers* +;; This is a parameter in machin.scm +;; for index = 0, it must be the same as reference-to-val +;; This should leave some temps (e.g. 1, 28, 29, 30) + +(define rtlgen/reference-to-val + (let ((reg (vector-ref *rtlgen/argument-registers* 0))) + (lambda () `(REGISTER ,reg)))) + +(define (rtlgen/argument-registers) + (if (rtlgen/cont-in-stack?) + (vector->list *rtlgen/argument-registers*) + (cons (rtl:register-number (rtlgen/reference-to-closure)) + (vector->list *rtlgen/argument-registers*)))) + +#| +(define (rtlgen/available-registers available) + (let ((arg-regs (rtlgen/argument-registers))) + ;; Order is important! + (append arg-regs + (eq-set-difference (delq rtlgen/cont-register available) + arg-regs)))) +|# +(define (rtlgen/available-registers available) + (let ((arg-regs (rtlgen/argument-registers))) + ;; Order is important! + (append arg-regs + (eq-set-difference (if (rtlgen/cont-in-stack?) + available + (delq (rtl:register-number + (rtlgen/reference-to-cont)) + available)) + arg-regs)))) + +(define (rtlgen/number-of-argument-registers) + (vector-length *rtlgen/argument-registers*)) + +(define (rtlgen/home-offset reg-index) + (pseudo-register-offset reg-index)) + +(define (rtlgen/argument-home index) + (let ((vlen (vector-length *rtlgen/argument-registers*))) + (if (< index vlen) + `(REGISTER ,(vector-ref *rtlgen/argument-registers* index)) + (internal-error "more arguments than registers" index)))) + +;; rtlgen/interpreter-call/argument-home moved to machin.sc, + +(define (rtlgen/first-pseudo-register-number) + number-of-machine-registers) + +(define (rtlgen/number-of-pseudo-register-homes) + number-of-temporary-registers) + +;;;; Machine-dependent parameters (continued) + +(define (rtlgen/stack-post-increment?) + stack-use-pre/post-increment?) + +(define (rtlgen/stack-pre-increment?) + stack-use-pre/post-increment?) + +(define (rtlgen/heap-post-increment?) + heap-use-pre/post-increment?) + + +(define (rtlgen/indexed-loads? type) + (machine/indexed-loads? type)) + +(define (rtlgen/indexed-stores? type) + (machine/indexed-stores? type)) + +(define (rtlgen/tagged-entry-points?) + (not untagged-entries?)) + +(define (rtlgen/tagged-closures?) + ;; Closures are represented as entry points + (rtlgen/tagged-entry-points?)) + +(define (rtlgen/cont-adjustment) + ;; This needs to be a parameter in machin.scm + ;; Distance in bytes between a raw continuation + ;; (as left behind by JSR) and the real continuation + ;; (after descriptor) + (machine/cont-adjustment)) + +(define (rtlgen/closure-adjustment) + 0) + +(define-integrable rtlgen/chars-per-object + (quotient address-units-per-object address-units-per-packed-char)) + +(define (rtlgen/chars->words nchars) + ;; Rounds up to word size and includes a zero byte. + (quotient (+ nchars rtlgen/chars-per-object) rtlgen/chars-per-object)) + +(define (rtlgen/words->chars nwords) + (* nwords rtlgen/chars-per-object)) + +(define rtlgen/fp->words + (let ((objects-per-float + (quotient address-units-per-float address-units-per-object))) + (lambda (nfp) + (* objects-per-float nfp)))) + +(define (rtlgen/closure-first-offset) + (closure-first-offset 1 0)) + +(define (rtlgen/closure-prefix-size) + (closure-object-first-offset 1)) + +(define (rtlgen/floating-align-free) + (let ((free (rtlgen/reference-to-free))) + (rtlgen/emit!/1 `(ASSIGN ,free (ALIGN-FLOAT ,free))))) + +(define (rtlgen/generate-interrupt-checks?) + true) + +(define (rtlgen/generate-heap-checks?) + true) + +(define (rtlgen/generate-stack-checks?) + true) + +(define rtlgen/unassigned-object + (let ((tag (machine-tag 'REFERENCE-TRAP))) + (lambda () + `(CONS-NON-POINTER (MACHINE-CONSTANT ,tag) (MACHINE-CONSTANT 0))))) + +(define (rtlgen/preserve-state state) + ;; (values gen-prefix gen-suffix) + ;; IMPORTANT: this depends crucially on the fact that variables are + ;; bound to objects. The exceptions to this are the continuation + ;; and variable caches that are treated specially. In the future, + ;; when variables are bound to floats and other non-objects, they + ;; will have to be tagged and handled appropriately. + + (define (invoke-thunk thunk) + (thunk)) + + (define (preserve infos) + (let loop ((infos infos) + (prefix '()) + (suffix '())) + + (define (%preserve&restore preserve restore) + (loop (cdr infos) + (cons preserve prefix) + (cons restore suffix))) + + (define (preserve&restore reg how value) + (if (not (pair? value)) + (internal-error "Bad preservation" reg how value)) + (%preserve&restore + (lambda () (rtlgen/emit!/1 `(PRESERVE ,reg ,how))) + (lambda () (rtlgen/emit!/1 `(RESTORE ,reg ,value))))) + + (define (box/unbox-preserve&restore reg value box-gen unbox-gen) + (if (rtlgen/stack-ref? value) + (%preserve&restore + (lambda () + (rtlgen/emit!/1 + `(ASSIGN ,value ,(rtlgen/->register (box-gen state))))) + (lambda () + (rtlgen/emit! + `((ASSIGN ,reg ,(unbox-gen value)) + (ASSIGN ,value ,reg))))) + (%preserve&restore + (lambda () + (rtlgen/stack-push!/1 (rtlgen/->register (box-gen state)))) + (lambda () + (rtlgen/emit! + `((ASSIGN ,reg ,(unbox-gen (rtlgen/stack-pop!))) + (ASSIGN ,value ,reg))))))) + + (if (null? infos) + (values (lambda () + (for-each invoke-thunk (reverse prefix))) + (lambda () + (for-each invoke-thunk suffix))) + (let* ((first (car infos)) + (name (vector-ref first 0)) + (reg (vector-ref first 1)) + (value (vector-ref first 2)) + (how (vector-ref first 3))) + name ; unused + (case how + ((SAVE) + (preserve&restore reg 'SAVE reg)) + ((IF-AVAILABLE RECOMPUTE) + (preserve&restore reg how value)) + ((PUSH) + ;; These cases should really communicate with the LAP level + ;; rather than emitting voluminous code + (cond ((continuation-variable? name) + (box/unbox-preserve&restore reg value + rtlgen/boxed-continuation + rtlgen/unboxed-continuation)) + ((closure-variable? name) + (box/unbox-preserve&restore reg value + rtlgen/boxed-closure + rtlgen/unboxed-closure)) + (else + (internal-error "Cannot preserve by PUSHing" + (car infos))))) + (else + (internal-error "Unknown preservation kind" how))))))) + + (call-with-values + (lambda () + (list-split (rtlgen/preservation-state state + *rtlgen/pseudo-register-values*) + (lambda (info) + (eq? (vector-ref info 3) 'PUSH)))) + (lambda (pushed-info other-info) + (call-with-values + (lambda () + (list-split other-info + (lambda (info) + (eq? (vector-ref info 3) 'RECOMPUTE)))) + (lambda (recomputed maybe-preserved) + (preserve (append pushed-info + (reverse recomputed) + maybe-preserved))))))) + +(define (rtlgen/preservation-state state orig-reg-defns) + ;; Returns a list to 4-vectors: + ;; #(variable-name register home PUSH/SAVE/RECOMPUTE/IF-AVAILABLE) + + (define (check result) + (if (not (= (length (remove-duplicates + (map (lambda (4v) (second (vector-ref 4v 1))) result))) + (length result))) + (begin + (internal-warning "Duplicate preservation:") + (pp `((,(length (rtlgen/state/env state)) bindings) + (,(length orig-reg-defns) orig-reg-defns) + (,(length result) result))))) + result) + + (define (preservations-from-state state) + (let loop + ((bindings + (list-transform-positive (rtlgen/state/env state) + (lambda (binding) + (rtlgen/register? (rtlgen/binding/place binding))))) + (preservations '())) + (if (null? bindings) + preservations + (let* ((binding (car bindings)) + (name (rtlgen/binding/name binding)) + (reg (rtlgen/binding/place binding)) + (regno (second reg))) + (loop + (cdr bindings) + (if (assq regno preservations) + preservations + (cons + (cons regno + (cond ((variable-cache-variable? name) + => (lambda (info) + (vector name reg (cadr info) 'RECOMPUTE))) + (else + (vector + name + reg + (rtlgen/binding/home binding) + (cond ((eq? binding + (rtlgen/state/continuation state)) + 'PUSH) + ((eq? binding + (rtlgen/state/closure state)) + 'PUSH) + (else 'SAVE)))))) + preservations))))))) + + ;; The following loop is basically optional; it could be replaced by + ;; (reverse (map cdr (preservations-from-state state))) + ;; + ;; You *MUST* generate PRESERVEs for all registers that are referenced in + ;; the state, since they will be referenced by RTL code after the + ;; return point. All other registers are optionally saved: if they + ;; can be saved safely (i.e. they are guaranteed to to be valid + ;; Scheme objects), they are. Later on, CSE will decide to reuse + ;; some of these registers. Thus, not saving a register inhibits + ;; CSE but doesn't change the correctness of the algorithm. Those + ;; values which are unboxed must be preserved some other way, for + ;; example by recomputing it from the objects from which it was + ;; derived. + + + (let loop + ((reg-defns (reverse orig-reg-defns)) + (preservations (preservations-from-state state))) + + (if (null? reg-defns) + (check (reverse! (map cdr preservations))) + (let* ((defn (car reg-defns)) + (reg (car defn)) + (value (cadr defn)) + (regno (cadr reg))) + + (define (ignore) + (loop (cdr reg-defns) preservations)) + + (define (preserve) + (loop (cdr reg-defns) + (cons (cons regno (vector false reg false 'SAVE)) + preservations))) + + (define (maybe-preserve) + (loop (cdr reg-defns) + (cons (cons regno (vector false reg value 'IF-AVAILABLE)) + preservations))) + + (define (reg-preserved? reg) + (and (rtlgen/%pseudo-register? reg) + (assq (cadr reg) preservations))) + + (define (compute) + (loop (cdr reg-defns) + (cons (cons (cadr reg) + (vector false reg value 'RECOMPUTE)) + preservations))) + + (define (non-pointer-memory-operation) + (let ((index (caddr value))) + (cond ((not (reg-preserved? (cadr value))) + (ignore)) + ((or (not (rtlgen/register? index)) + (reg-preserved? index)) + (compute)) + (else + (ignore))))) + + (if (assq regno preservations) + (ignore) + (case (car value) + ((REGISTER) ; Added by JSM + ;;(bkpt "; case = register") + (if (reg-preserved? value) + (internal-warning + "rtlgen/preservation-state register preserved" + reg value) + (internal-warning + "rtlgen/preservation-state register not preserved" + reg value)) + (ignore)) + ((OFFSET) + ;; *** Kludge *** + (let ((old (reg-preserved? (cadr value)))) + (if (or (not old) + (not (vector-ref (cdr old) 2)) + (not (memq (car (vector-ref (cdr old) 2)) + '(VARIABLE-CACHE ASSIGNMENT-CACHE)))) + (preserve) + (compute)))) + ((FLOAT->OBJECT CONS-POINTER CONS-NON-POINTER) + ;; This assumes they are proper objects, and therefore + ;; can be preserved on their own + (preserve)) + ((CONS-CLOSURE) + (if (rtlgen/tagged-entry-points?) + (ignore) + (preserve))) + ((OFFSET-ADDRESS BYTE-OFFSET-ADDRESS FLOAT-OFFSET-ADDRESS) + (non-pointer-memory-operation)) + ((OBJECT->ADDRESS OBJECT->TYPE OBJECT->DATUM OBJECT->FLOAT) + (if (reg-preserved? (cadr value)) + (compute) + (ignore))) + ((FLOAT-OFFSET) + ;; *** These should be preserved, since the preservation + ;; mechanism should handle floating objects. For now... *** + (non-pointer-memory-operation)) + ((BYTE-OFFSET) + (non-pointer-memory-operation)) + ((ENTRY:PROCEDURE ENTRY:CONTINUATION) + (compute)) + ((VARIABLE-CACHE ASSIGNMENT-CACHE) + (compute)) + ((CONSTANT) + (maybe-preserve)) + ((FIXNUM-2-ARGS FIXNUM-1-ARG FLONUM-2-ARGS FLONUM-2-ARG) + ;;(internal-warning + ;; "rtlgen/preservation-state: arithmetic" value) + (preserve)) + (else + (internal-warning + "rtlgen/preservation-state: unknown operation" value) + (ignore)))))))) + +;;;; RTL generation of statements + +(define-macro (define-rtl-generator/stmt keyword bindings . body) + (let ((proc-name (symbol-append 'RTLGEN/ keyword '/STMT))) + (call-with-values + (lambda () (%matchup (cdr bindings) '(handler state) '(cdr form))) + (lambda (names code) + `(define ,proc-name + (let ((handler (lambda ,(cons (car bindings) names) ,@body))) + (named-lambda (,proc-name state form) + ,code))))))) + +(define-rtl-generator/stmt LET (state bindings body) + (define (default) + (rtlgen/let* state bindings body rtlgen/stmt rtlgen/state/stmt/new-env)) + (cond ((or (not (eq? 'STATIC (binding-context-type 'LET 'STATIC bindings))) + (and (not (null? bindings)) + (continuation-variable? (caar bindings)))) + (default)) + ((or (null? bindings) + (not (null? (cdr bindings))) + (not (form/match rtlgen/fetch-env-pattern + (cadr (car bindings))))) + (rtlgen/stmt state body)) + (else + (default)))) + +(define rtlgen/fetch-env-pattern + `(CALL (QUOTE ,%fetch-environment) (QUOTE #F))) + +(define (rtlgen/let* state bindings body rtlgen/body rtlgen/state/new-env) + (let* ((env (rtlgen/state/env state)) + (rands (rtlgen/expr* state (lmap cadr bindings)))) + (rtlgen/body (rtlgen/state/new-env + state + (map* env + (lambda (binding rand) + (rtlgen/binding/make (car binding) rand false)) + bindings + rands)) + body))) + +(define-rtl-generator/stmt BEGIN (state #!rest actions) + (if (null? actions) + (internal-error "Empty BEGIN")) + (let loop ((next (car actions)) + (rest (cdr actions))) + (if (null? rest) + (rtlgen/stmt state next) + (begin + (rtlgen/stmt/begin state next) + (loop (car rest) (cdr rest)))))) + +(define (rtlgen/stmt/begin state form) + (define (illegal-action) + (internal-error "Illegal BEGIN action" form)) + (cond ((not (pair? form)) + (illegal-action)) + ((DECLARE/? form) + false) + (else + (rtlgen/expr (rtlgen/state/->expr state '(NONE)) form)))) + +(define-rtl-generator/stmt CALL (state rator cont #!rest rands) + ;; This CALL must be in tail-recursive position of the combination + (define (bad-rator) + (internal-error "Illegal CALL statement operator" rator)) + (cond + ((QUOTE/? rator) + (rtlgen/call* state (quote/text rator) cont rands)) + ((LOOKUP/? rator) + (set! *rtlgen/form-calls-internal?* true) + (rtlgen/jump state (lookup/name rator) cont rands)) + ((LAMBDA/? rator) + (let ((call `(CALL ,rator ,cont ,@rands))) + (cond ((not (null? rands)) (bad-rator)) + ((form/match rtlgen/extended-call-pattern call) + ;; /compatible + ;; Compatibility only, extended stack frame + => (lambda (result) + (rtlgen/extended-call state result call))) + ((form/match rtlgen/call-lambda-with-stack-closure-pattern call) + => (lambda (result) + (rtlgen/call-lambda-with-stack-closure + state result call rator cont rands))) + (else (bad-rator))))) + (else (bad-rator)))) + +(define (rtlgen/extended-call state match-result call) + (let (#| (cont-name (cadr (assq rtlgen/?cont-name match-result))) |# + (rator (cadr (assq rtlgen/?rator match-result))) + (frame-vector* (cadr (assq rtlgen/?frame-vector* match-result))) + (closure-elts* (cadr (assq rtlgen/?closure-elts* match-result))) + (rands (cadr (assq rtlgen/?rands match-result))) + (ret-add (cadr (assq rtlgen/?return-address match-result))) + (frame-vector (cadr (assq rtlgen/?frame-vector match-result))) + (closure-elts (cadr (assq rtlgen/?closure-elts match-result)))) + (if (not (LAMBDA/? ret-add)) + (internal-error "Bad extended call" call) + (rtlgen/call* state + rator + `(CALL (QUOTE ,%make-stack-closure) + (QUOTE #F) + (QUOTE #F) + (QUOTE ,(list->vector + (append (vector->list frame-vector) + (vector->list frame-vector*)))) + ,@closure-elts + (CALL (QUOTE ,%make-return-address) + (QUOTE #F) + ,ret-add) + ,@closure-elts*) + rands)))) + + +(define (rtlgen/call-lambda-with-stack-closure state dict call rator cont rands) + ;; (CALL (LAMBDA (CONT) ...) + ;; (call %make-stack-closure ...)) + ;; This is nasty because the LAMBDA has free variables which might be + ;; stack references and the stack might contain a (raw) closure + ;; pointer. + ;; + ;; We rely on the fact that the state bindings for stack resident names + ;; are already loaded into pseudo-registers, as are the continuation + ;; and closure pointers. We also rely on the continuation CONT + ;; being a make-stack-closure that saves the current valid + ;; continuation. + ;; + ;; Most of the work is loading the continuation (register or stack + ;; location) with the right value, and making a state for compiling + ;; the body of the LAMBDA in-line. + + (define (bad-rator) + (internal-error "Illegal CALL statement operator" rator)) + + (internal-warning "call-lambda-with-stack-closure" call) + + ;; Sanity check: we can only rearrange the stack if all stack references + ;; have already been loaded into pseudo-registers. This may include + ;; the continuation and closure pointer. + (for-each + (lambda (binding) + (define (on-stack? syllable) + (form/match + `(OFFSET ,(rtlgen/reference-to-sp) + (MACHINE-CONSTANT ,(->pattern-variable 'offset))) + syllable)) + (if (and (on-stack? (rtlgen/binding/home binding)) + (not (rtlgen/register? + (rtlgen/binding/place binding)))) + (internal-error "Stack variable not in register" binding))) + (rtlgen/state/stmt/env state)) + + (let ((cont-var (cadr (assq rtlgen/?cont-name dict))) + (code-body (cadr (assq rtlgen/?body dict)))) + (let* ((old-closure-binding (rtlgen/state/stmt/closure state)) + (clos-reg (and old-closure-binding (rtlgen/new-reg))) + (new-closure-binding + (and old-closure-binding + (rtlgen/binding/make + (rtlgen/binding/name old-closure-binding) + clos-reg + (rtlgen/binding/home old-closure-binding)))) + (old-continuation-binding (rtlgen/state/stmt/continuation state)) + (cont-label + (rtlgen/continuation-is-stack-closure state cont bad-rator #F #T)) + (cont-adj (rtlgen/cont-adjustment)) + (label-reg (rtlgen/new-reg)) + (cont-reg (if (zero? cont-adj) label-reg (rtlgen/new-reg))) + (new-continuation-home + (if (rtlgen/cont-in-stack?) + (rtlgen/stack-ref + (if (and (rtlgen/closure-in-stack?) new-closure-binding) 1 0)) + (rtlgen/reference-to-cont))) + (new-continuation-binding + (rtlgen/binding/make cont-var cont-reg new-continuation-home)) + (new-size + (+ (if (and (rtlgen/cont-in-stack?) new-continuation-binding) 1 0) + (if (and (rtlgen/closure-in-stack?) new-closure-binding) 1 0)))) + + (if (not cont-label) + (internal-error "call-lambda-with-stack-closure and no label" call)) + + ;; JIM says "I don't see what guarantees + ;; me that no one needs the current value + ;; of the physical continuation register!" + ;; SRA: It should be saved by the stack rewriting. + + ;; Allocate stack space for stack-based values: + (rtlgen/bop-stack-pointer! (- new-size)) + + (rtlgen/emit!/1 + `(ASSIGN ,label-reg (ENTRY:CONTINUATION ,cont-label))) + (if (not (zero? cont-adj)) + (rtlgen/emit!/1 + `(ASSIGN ,cont-reg + (BYTE-OFFSET-ADDRESS ,label-reg + (MACHINE-CONSTANT ,(- 0 cont-adj)))))) + + (if (rtlgen/cont-in-stack?) + (begin + ;; write the continuation into the stack + (rtlgen/emit!/1 + `(ASSIGN ,(rtlgen/binding/home new-continuation-binding) + ,cont-reg))) + (begin + (rtlgen/emit!/1 + `(ASSIGN ,(rtlgen/reference-to-cont) ,cont-reg)))) + + (if old-closure-binding + (begin + (if (rtlgen/closure-in-stack?) + (begin + ;; write closure pointer back into stack + (rtlgen/emit!/1 + `(ASSIGN ,(rtlgen/binding/home old-closure-binding) + ,(rtlgen/binding/place old-closure-binding))))) + (rtlgen/emit!/1 + `(ASSIGN ,clos-reg ,(rtlgen/binding/place old-closure-binding))))) + + ;;(bkpt "\n;;; rtlgen/call-lambda-with-stack-closure") + + (let ((new-state + (rtlgen/state/stmt/make + `(,new-continuation-binding + ,@(if new-closure-binding (list new-closure-binding) '()) + . ,(rtlgen/state/stmt/env state)) + new-continuation-binding + new-closure-binding + new-size))) + (bkpt 'hi) + (rtlgen/stmt new-state code-body))))) + + +(define-rtl-generator/stmt LETREC (state bindings body) + (rtlgen/letrec/bindings bindings) + (rtlgen/stmt state body)) + +(define (rtlgen/letrec/bindings bindings) + (set! *rtlgen/delayed-objects* + (fold-right (lambda (binding rest) + (cons (cons (car binding) + (vector 'PROCEDURE false (cadr binding))) + rest)) + *rtlgen/delayed-objects* + bindings)) + unspecific) + +(define-rtl-generator/stmt IF (state pred conseq alt) + (rtlgen/if* state pred conseq alt rtlgen/stmt false)) + +(define (rtlgen/if* state pred conseq alt rtlgen/form need-merge?) + (let ((true-label (rtlgen/new-name 'TRUE)) + (false-label (rtlgen/new-name 'FALSE))) + (call-with-values + (lambda () + (rtlgen/predicate state true-label false-label pred)) + (lambda (true-label-taken? false-label-taken?) + (define (do-true) + (rtlgen/with-label true-label rtlgen/form state conseq)) + (define (do-false) + (rtlgen/with-label false-label rtlgen/form state alt)) + (cond ((not true-label-taken?) + (if (not false-label-taken?) + (internal-error "Predicate takes neither branch" pred)) + (do-false)) + ((not false-label-taken?) + (do-true)) + (else + (rtlgen/emit-alternatives! do-true do-false need-merge?))))))) + +(define (rtlgen/stmt state expr) + ;; No meaningful value + (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)) + ((QUOTE LOOKUP LAMBDA DECLARE) + (internal-error "Illegal statement" expr)) + ((SET! UNASSIGNED? OR DELAY + ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT) + (no-longer-legal expr)) + (else + (illegal expr)))) + +(define (rtlgen/with-label label generator state expr) + (rtlgen/emit!/1 `(LABEL ,label)) + (generator state expr)) + +(define (rtlgen/predicate state true-label false-label pred) + (let ((tl (list true-label 0)) + (fl (list false-label 0))) + (let ((loc (rtlgen/expr (rtlgen/state/->expr state `(PREDICATE ,tl ,fl)) + pred))) + (if loc + (internal-warning "Predicate returned a value" pred loc)) + (values (not (zero? (cadr tl))) + (not (zero? (cadr fl))))))) + +(define (rtlgen/reference-true-label! target) + (let ((true-label (cadr target))) + (set-car! (cdr true-label) (+ (cadr true-label) 1)) + (car true-label))) + +(define (rtlgen/reference-false-label! target) + (let ((false-label (caddr target))) + (set-car! (cdr false-label) (+ (cadr false-label) 1)) + (car false-label))) + +(define (rtlgen/branch/true state) + (let ((cont (rtlgen/state/expr/target state))) + (rtlgen/emit!/1 `(JUMP ,(rtlgen/reference-true-label! cont))))) + +(define (rtlgen/branch/false state) + (let ((cont (rtlgen/state/expr/target state))) + (rtlgen/emit!/1 `(JUMP ,(rtlgen/reference-false-label! cont))))) + +(define (rtlgen/branch/likely state predicate) + (let ((cont (rtlgen/state/expr/target state))) + (rtlgen/emit! + (list `(JUMPC ,predicate ,(rtlgen/reference-true-label! cont)) + `(JUMP ,(rtlgen/reference-false-label! cont)))) + false)) + +(define (rtlgen/branch/unlikely state predicate) + (let ((cont (rtlgen/state/expr/target state))) + (rtlgen/emit! + (list `(JUMPC (NOT ,predicate) ,(rtlgen/reference-false-label! cont)) + `(JUMP ,(rtlgen/reference-true-label! cont)))) + false)) + +(define (rtlgen/branch/unpredictable state predicate) + (let ((cont (rtlgen/state/expr/target state))) + (rtlgen/emit! + (list `(JUMPC (UNPREDICTABLE ,predicate) + ,(rtlgen/reference-true-label! cont)) + `(JUMP ,(rtlgen/reference-false-label! cont)))) + false)) + +(define (rtlgen/branch/false? state loc) + (let* ((cont (rtlgen/state/expr/target state)) + (default + (lambda () + (let ((reg (rtlgen/->register loc))) + (rtlgen/emit! + (list `(JUMPC (NOT (PRED-1-ARG FALSE? ,reg)) + ,(rtlgen/reference-true-label! cont)) + `(JUMP ,(rtlgen/reference-false-label! cont)))))))) + (if (not (rtlgen/constant? loc)) + (default) + (case (boolean/discriminate (rtlgen/constant-value loc)) + ((FALSE) + (rtlgen/emit!/1 `(JUMP ,(rtlgen/reference-false-label! cont)))) + ((TRUE) + (rtlgen/emit!/1 `(JUMP ,(rtlgen/reference-true-label! cont)))) + (else + (default))))) + false) + +(define (rtlgen/call* state rator* cont rands) + (define (bad-rator) + (internal-error "Illegal CALL statement operator" rator*)) + + (define (verify-rands len) + (if (not (= len (length rands))) + (internal-error "Wrong number of arguments" rator* rands))) + + (cond ((eq? rator* %invoke-continuation) + (set! *rtlgen/form-returns?* true) + (rtlgen/return state cont rands)) + ((eq? rator* %internal-apply) + (set! *rtlgen/form-calls-external?* true) + (rtlgen/%apply state (second rands) cont + (quote/text (first rands)) (cddr rands))) + ((eq? rator* %invoke-operator-cache) + (set! *rtlgen/form-calls-external?* true) + (rtlgen/invoke-operator-cache state + 'INVOCATION:UUO-LINK + (first rands) ; name+nargs + cont + (cddr rands))) ; exprs + ((eq? rator* %invoke-remote-cache) + (set! *rtlgen/form-calls-external?* true) + (rtlgen/invoke-operator-cache state + 'INVOCATION:GLOBAL-LINK + (first rands) ; name+nargs + cont + (cddr rands))) ; exprs + ((eq? rator* %primitive-apply/compatible) + (verify-rands 2) ; arity, primitive + (set! *rtlgen/form-calls-external?* true) + (rtlgen/invoke-primitive/compatible state + (first rands) ; nargs + (second rands) ; prim + cont)) + ((hash-table/get *open-coders* rator* false) + (set! *rtlgen/form-returns?* true) + (if (not (operator/satisfies? rator* '(SPECIAL-INTERFACE))) + (begin + (rtlgen/invoke-out-of-line state rator* cont rands)) + (rtlgen/invoke-special state rator* cont rands))) + (else + (bad-rator)))) + +(define (rtlgen/return state cont exprs) + (define (illegal-continuation) + (internal-error "Unexpected continuation for return" cont)) + (rtlgen/exprs->call-registers state #F exprs) + (cond ((LOOKUP/? cont) + (let* ((adj (rtlgen/cont-adjustment)) + (rcont (rtlgen/state/reference-to-cont state)) + (result (if (zero? adj) rcont (rtlgen/new-reg)))) + (rtlgen/bop-stack-pointer! (rtlgen/state/stmt/size state)) + (if (not (zero? adj)) + (rtlgen/emit!/1 + `(ASSIGN ,result + (BYTE-OFFSET-ADDRESS ,rcont + (MACHINE-CONSTANT ,adj))))) + (rtlgen/emit!/1 + `(INVOCATION:REGISTER 0 + #F + ,result + #F + (MACHINE-CONSTANT 1))))) + ((CALL/%stack-closure-ref? cont) + (let ((size (rtlgen/state/stmt/size state))) + (let* ((offset (- size 1)) + (obj (rtlgen/new-reg)) + (retad (if (rtlgen/tagged-entry-points?) + (rtlgen/new-reg) + obj))) + (rtlgen/emit! + (list (rtlgen/read-stack-loc obj offset) + (rtlgen/bop-stack-pointer size))) + (if (rtlgen/tagged-entry-points?) + (rtlgen/emit!/1 + `(ASSIGN ,retad (OBJECT->ADDRESS ,obj)))) + (rtlgen/emit!/1 + `(INVOCATION:REGISTER 0 + #F + ,retad + #F + (MACHINE-CONSTANT 1)))))) + ((CALL/%make-stack-closure? cont) + ;; This will not work for stack closures used just to push + ;; arguments, but it makes no sense to encounter that case + ;;(let ((handler (rtlgen/continuation-is-stack-closure + ;; state cont illegal-continuation #F #F))) + ;; (rtlgen/emit! + ;; (rtlgen/%%continuation + ;; 'FAKE-LABEL handler + ;; (lambda (label body saved-size arity) + ;; saved-size arity ; Unused + ;; (if (not (eq? label 'FAKE-LABEL)) + ;; (internal-error "New label generated for FAKE-LABEL")) + ;; body)))) + (let ((label (rtlgen/continuation-is-stack-closure + state cont illegal-continuation #F #T))) + (if label + (begin + ;; Cant use jump because jump in an internal edge in rtl graph + ;;(rtlgen/emit!/1 `(JUMP ,label)) + + ;; The mention of the continuation is necessary otherwise the + ;; lap linearizer fails to see the continuation and discards + ;; it. + (rtlgen/emit!/1 `(ASSIGN ,(rtlgen/new-reg) + (ENTRY:CONTINUATION ,label))) + (rtlgen/emit!/1 + `(INVOCATION:PROCEDURE 0 #F ,label (MACHINE-CONSTANT 1))) + + ;; This also works but produces poor code: + ;;(let ((reg (rtlgen/new-reg))) + ;; (rtlgen/emit! + ;; `((ASSIGN ,reg (ENTRY:CONTINUATION ,label)) + ;; (INVOCATION:REGISTER 0 #F ,reg #F (MACHINE-CONSTANT 1))))) + ) + ;; If it was not a label then ../continuation-is-stack-closure + ;; left the raw continuation in the standard place: + (let* ((adj (rtlgen/cont-adjustment)) + (rcont (if (rtlgen/cont-in-stack?) + (rtlgen/new-reg) + (rtlgen/state/reference-to-cont state))) + (result (if (zero? adj) rcont (rtlgen/new-reg)))) + (if (rtlgen/cont-in-stack?) + (rtlgen/stack-pop! rcont)) + (if (not (zero? adj)) + (rtlgen/emit!/1 + `(ASSIGN ,result + (BYTE-OFFSET-ADDRESS ,rcont + (MACHINE-CONSTANT ,adj))))) + (rtlgen/emit!/1 + `(INVOCATION:REGISTER 0 + #F + ,result + #F + (MACHINE-CONSTANT 1))))))) + (else (illegal-continuation)))) + + +(define (rtlgen/continuation-label->object label) + (rtlgen/continuation->object `(ENTRY:CONTINUATION ,label))) + +(define-integrable (rtlgen/continuation->object cont) + (rtlgen/entry->object cont)) + +(define compiled-entry-tag + (machine-tag 'COMPILED-ENTRY)) + +(define (rtlgen/entry->object cont) + (if (not (rtlgen/tagged-entry-points?)) + cont + (let ((rand (rtlgen/->register cont))) + `(CONS-POINTER (MACHINE-CONSTANT ,compiled-entry-tag) + ,rand)))) + +(define (rtlgen/%apply state rator cont nargs rands) + (let ((rator (rtlgen/->register + (rtlgen/expr (rtlgen/state/->expr state '(ANY)) + rator)))) + (rtlgen/invoke + state cont rands + (lambda (cont-label) + (rtlgen/emit!/1 + `(INVOCATION:NEW-APPLY ,(+ nargs 1) + ,cont-label + ,rator + (MACHINE-CONSTANT 0))))))) + +(define (rtlgen/invoke-operator-cache state kind name+arity cont rands) + (if (not (QUOTE/? name+arity)) + (internal-error "Unexpected execute cache descriptor" name+arity)) + (let ((name+arity* (cadr name+arity))) + (let ((name (car name+arity*)) + (nargs* (cadr name+arity*))) + (let ((nargs + (if nargs* + (if (and #F ; SRA - no longer true! + (not (= nargs* (length rands)))) + (internal-error + "RTLGEN/INVOKE-OPERATOR-CACHE: actuals/args mismatch" + nargs* (length rands)) + nargs*) + (length rands)))) + (rtlgen/invoke + state cont rands + (lambda (cont-label) + (rtlgen/emit!/1 `(,kind ,(+ nargs 1) ,cont-label ,name)))))))) + +(define (rtlgen/invoke-primitive/compatible state nargs prim cont) + (rtlgen/invoke/compatible + state cont + (lambda (cont-label) + (rtlgen/emit!/1 + `(INVOCATION:PRIMITIVE ,(+ (cadr nargs) 1) ,cont-label + ,(cadr prim)))))) + +(define (rtlgen/invoke-out-of-line state rator* cont rands) + (rtlgen/exprs->call-registers state #F rands) + (rtlgen/open-code/out-of-line + (rtlgen/continuation-setup/jump! state cont) + rator*)) + +(define (rtlgen/invoke-special state rator* cont rands) + (let ((rands* (rtlgen/expr* state rands))) + (rtlgen/with-local-continuation + state cont + (lambda (cont-label) + (rtlgen/open-code/special cont-label rator* rands*))))) + +(define (rtlgen/with-local-continuation state cont codegen) + (rtlgen/stack-allocation/protect ; /compatible + (lambda () + (let ((cont-label (rtlgen/continuation-setup/saved! state cont))) + (if cont-label + (codegen cont-label) + (let ((label* (rtlgen/new-name 'AFTER-HOOK))) + (codegen label*) + (rtlgen/emit! + (list `(RETURN-ADDRESS ,label* + (MACHINE-CONSTANT 0) + (MACHINE-CONSTANT 1)) + `(POP-RETURN))))))))) + +(define (rtlgen/invoke/compatible state cont jump-gen) + ;; rands will be on the stack by now + (jump-gen (rtlgen/continuation-setup/compatible! state cont))) + +(define (rtlgen/invoke state cont rands jump-gen) + ;; SRA - should the continuation setup be done before call register setup + ;; to reduce register pressure (as saved argument registers might + ;; then be dead) ?? -- NO: the registers may be set up from the + ;; stack-frame, so it must be setup after -- is this true?? + (rtlgen/exprs->call-registers state #F rands) + ; JSM ... double check this + (jump-gen (rtlgen/continuation-setup/jump! state cont))) + +(define (rtlgen/continuation-setup/compatible! state cont) + (define (bad-cont) + (internal-error "Unexpected CALL continuation [compatible!]" + cont)) + (rtlgen/continuation-is-stack-closure state cont bad-cont #T #T)) + +(define (rtlgen/exprs->call-registers state *self* rands) + ;; *self* is either #F or the expression which must be loaded into + ;; the closure register before calling the destination procedure. + (define (rtlgen/possibly-used-regs env form) + (let loop ((vars (form/%free-vars form false)) + (regs '())) + (if (null? vars) + regs + (let* ((var (car vars)) + (place (rtlgen/binding/find var env))) + (cond ((not place) + (if (or (get-variable-property var 'VARIABLE-CELL) + (get-variable-property var 'FRAME-VARIABLE) + (assq var *rtlgen/delayed-objects*)) + (loop (cdr vars) regs) + (free-var-error var))) + ((rtlgen/machine-register? (rtlgen/binding/home place)) + (loop (cdr vars) + (eqv-set-adjoin (cadr (rtlgen/binding/home place)) + regs))) + (else + (loop (cdr vars) regs))))))) + (define (do-rand rand target) + (let ((result (rtlgen/expr (rtlgen/state/->expr state target) + rand))) + (if (not (equal? result target)) + (internal-error "Argument value not in expected place" + result)))) + + (let* ((env (rtlgen/state/env state)) + (arg-info + (do ((arg-number 0 (+ arg-number 1)) + (rands rands (cdr rands)) + (result + (if *self* + `((,(rtlgen/reference-to-closure) + ,*self* + ,(rtlgen/possibly-used-regs env *self*))) + '()) + (let ((target (rtlgen/argument-home arg-number))) + (cons + (list target + (car rands) + (rtlgen/possibly-used-regs env (car rands))) + result)))) + ((null? rands) + result)))) + + (call-with-values + (lambda () + (list-split arg-info (lambda (arg) (rtlgen/register? (car arg))))) + (lambda (->regs ->homes) + (let ((->homes* + (map (lambda (arg) + (cons (rtlgen/new-reg) arg)) + ->homes))) + (for-each (lambda (arg) + (do-rand (caddr arg) (car arg))) + ->homes*) + (let* ((pairs (map (lambda (info) (cons (cadr (car info)) info)) + ->regs)) + (sorted + (map (lambda (result) + (let ((pair (assv (car (vector-ref result 1)) + pairs))) + (cond ((not pair) + (internal-error + "Parallel assignment found a register" + result)) + ((vector-ref result 0) ; early? + (cons (rtlgen/new-reg) (cdr pair))) + (else + (cons (cadr pair) (cdr pair)))))) + (parallel-assignment + (map (lambda (arg) + (cons (cadr (car arg)) (caddr arg))) + ->regs))))) + (for-each (lambda (arg) + (do-rand (caddr arg) (car arg))) + sorted) + (for-each (lambda (arg) + (if (not (eq? (car arg) (cadr arg))) + (rtlgen/emit!/1 `(ASSIGN ,(cadr arg) ,(car arg))))) + sorted)) + (for-each (lambda (arg) + (rtlgen/emit!/1 `(ASSIGN ,(cadr arg) ,(car arg)))) + ->homes*)))))) + +(define (rtlgen/expr-results->call-registers state rands) + state ; Not used + (define (make-descr rand home) (cons rand home)) + ; (define (descr/rand descr) (car descr)) + (define (descr/home descr) (cdr descr)) + + (let ((homes (let process ((rands rands) (i 0)) + (if (null? rands) + '() + (cons (make-descr (car rands) (rtlgen/argument-home i)) + (process (cdr rands) (1+ i)))))) + (temps (map (lambda (ignore) ignore (rtlgen/new-reg)) rands))) + + (for-each (lambda (rand temp) + (rtlgen/emit!/1 `(ASSIGN ,temp ,rand))) + rands + temps) + (for-each (lambda (temp descr) + (rtlgen/emit!/1 `(ASSIGN ,(descr/home descr) ,temp))) + temps + homes))) + +(define (rtlgen/jump state var-name cont rands) + (let* ((cont-label (rtlgen/continuation-setup/jump! state cont)) + (label (rtlgen/enqueue-delayed-object! var-name 'PROCEDURE))) + (let* ((proc-info (rtlgen/find-delayed-object var-name)) + (lambda-expr (vector-ref proc-info 2)) + (params (and (LAMBDA/? lambda-expr) + (lambda/formals lambda-expr)))) + (if (not params) + (internal-error "rtlgen/jump: bad destination" + var-name lambda-expr)) + (let* ((needs-self? (and (pair? (cdr params)) + (closure-variable? (cadr params)))) + (true-rands (if needs-self? (cdr rands) rands))) + (if needs-self? + (rtlgen/exprs->call-registers state (car rands) (cdr rands)) + (rtlgen/exprs->call-registers state #F rands)) + (rtlgen/emit!/1 + `(INVOCATION:PROCEDURE 0 ,cont-label ,label + (MACHINE-CONSTANT ,(+ (length true-rands) 1)))))))) + +(define (rtlgen/continuation-setup/jump! state cont) + (define (bad-cont) + (internal-error "Unexpected CALL continuation [jump!]" + cont)) + (cond ((LOOKUP/? cont) + ;; Continuation already in the right place! + (rtlgen/pop state)) + ((CALL/%stack-closure-ref? cont) + ;; This assumes it is the continuation variable! + (rtlgen/reload-continuation&pop state)) + ((CALL/%make-stack-closure? cont) + (rtlgen/continuation-is-stack-closure + state cont bad-cont #F #T)) + (else + (bad-cont)))) + +(define (rtlgen/pop state) + (cond ((and state + (rtlgen/state/stmt/size state)) + => rtlgen/%pop)) + false) + +(define (rtlgen/%pop size) + ;; Pop off the current stack frame, but be sure to leave the current + ;; continuation (which may be at the top of the stack) in the usual + ;; place. + (cond ((zero? size) false) ; No work to do + ((rtlgen/cont-in-stack?) + (let ((tempreg (rtlgen/stack-pop!))) + (rtlgen/bop-stack-pointer! (- size 1)) + (rtlgen/emit!/1 (rtlgen/write-stack-loc tempreg 0)))) + (else + (rtlgen/bop-stack-pointer! size)))) + +(define (rtlgen/reload-continuation&pop state) + (rtlgen/%reload-continuation&pop (rtlgen/state/stmt/guaranteed-size state))) + +(define (rtlgen/%reload-continuation&pop size) + (let* ((adj (rtlgen/cont-adjustment)) + (in-stack? (rtlgen/cont-in-stack?)) + (pop? (and (= size 1) + (rtlgen/stack-post-increment?) + (not in-stack?))) + (offset (cond (pop? 0) + (in-stack? (- size 1)) + (else size))) + (contreg (if in-stack? + (rtlgen/new-reg) + (rtlgen/reference-to-cont))) + (tempreg (if (zero? adj) + contreg + (rtlgen/new-reg))) + (contobj (if (rtlgen/tagged-entry-points?) + (rtlgen/new-reg) + tempreg))) + (cond (pop? + (rtlgen/%stack-pop! contobj)) + (else + (rtlgen/emit!/1 (rtlgen/read-stack-loc contobj (- size 1))) + (rtlgen/bop-stack-pointer! offset))) + (if (rtlgen/tagged-entry-points?) + (rtlgen/emit!/1 `(ASSIGN ,tempreg (OBJECT->ADDRESS ,contobj)))) + (if (not (zero? adj)) + (rtlgen/emit!/1 + `(ASSIGN ,contreg + (BYTE-OFFSET-ADDRESS ,tempreg + (MACHINE-CONSTANT ,(- 0 adj)))))) + (if in-stack? (rtlgen/emit!/1 (rtlgen/write-stack-loc contreg 0)))) + false) + +(define (rtlgen/boxed-continuation state) + (let ((adj (rtlgen/cont-adjustment)) + (raw (rtlgen/->register (rtlgen/state/reference-to-cont state)))) + (rtlgen/continuation->object + (if (zero? adj) + raw + (rtlgen/->register + `(BYTE-OFFSET-ADDRESS ,raw (MACHINE-CONSTANT ,adj))))))) + +(define (rtlgen/unboxed-continuation reg) + (let ((adj (rtlgen/cont-adjustment)) + (untagged (if (rtlgen/tagged-entry-points?) + `(OBJECT->ADDRESS ,(rtlgen/->register reg)) + reg))) + (if (zero? adj) + untagged + `(BYTE-OFFSET-ADDRESS ,(rtlgen/->register untagged) + (MACHINE-CONSTANT ,(- adj)))))) + +(define (rtlgen/boxed-closure state) + (let ((adj (rtlgen/closure-adjustment)) + (raw (rtlgen/->register (rtlgen/state/reference-to-closure state)))) + (rtlgen/entry->object + (if (zero? adj) + raw + (rtlgen/->register + `(BYTE-OFFSET-ADDRESS ,raw (MACHINE-CONSTANT ,adj))))))) + +(define (rtlgen/unboxed-closure reg) + (let ((adj (rtlgen/closure-adjustment)) + (untagged (if (rtlgen/tagged-entry-points?) + `(OBJECT->ADDRESS ,(rtlgen/->register reg)) + reg))) + (if (zero? adj) + untagged + `(BYTE-OFFSET-ADDRESS ,(rtlgen/->register untagged) + (MACHINE-CONSTANT ,(- adj)))))) + + +(define (rtlgen/continuation-is-stack-closure + state cont bad-cont allow-sharp-f? enqueue?) + ;; Returns the continuation's label or #F if not known, adjusts + ;; the stack to match the model specified by the continuation, and + ;; moves the continuation to the standard location (register or top + ;; of stack) + (define (core) (rtlgen/setup-stack-closure! state cont)) + (define (setup! label) + (if (not label) + ;; Not a true subproblem, no need to stack + ;; check if this is the only stuff on the stack. + (rtlgen/stack-allocation/protect core) + (core)) + label) + (if (not (CALL/%make-stack-closure? cont)) (bad-cont)) + (let ((handler (call/%make-stack-closure/lambda-expression cont))) + (cond ((LAMBDA/? handler) + (setup! + (if enqueue? + (rtlgen/enqueue-object! handler 'CONTINUATION) + handler))) + ((LOOKUP/? handler) ;stack adjustment using unboxed cont. + (if (rtlgen/cont-in-stack?) + (let ((temp-reg (rtlgen/state/reference-to-cont state))) + (setup! false) + (rtlgen/stack-push!/1 temp-reg) + false) + (setup! false))) + ((CALL/%stack-closure-ref? handler) ; + (if (rtlgen/state/continuation state) + (internal-error "Continuation has a raw continuation" + cont state)) + (rtlgen/setup-stack-closure/saved-continuation + (rtlgen/state/stmt/guaranteed-size state) + handler + (lambda () (setup! false)))) + ((and allow-sharp-f? (equal? ''#F handler)) + (setup! false)) + (else (bad-cont))))) + + +(define (rtlgen/setup-stack-closure/saved-continuation size ref rearrange!) + ;; A continuation is returning/tailing using a saved & boxed continuation/ + ;; Assumption: the %stack-closure-ref REF is to the base of the stack frame. + ;; This looks too much like RTLGEN/%RELOAD-CONTINUATION&POP for comfort + ref ; Unused + (let* ((adj (rtlgen/cont-adjustment)) + (in-stack? (rtlgen/cont-in-stack?)) + (contreg (if in-stack? + (rtlgen/new-reg) + (rtlgen/reference-to-cont))) + (tempreg (if (zero? adj) + contreg + (rtlgen/new-reg))) + (contobj (if (rtlgen/tagged-entry-points?) + (rtlgen/new-reg) + tempreg))) + (rtlgen/emit! + (list (rtlgen/read-stack-loc contobj (- size 1)))) + (if (rtlgen/tagged-entry-points?) + (rtlgen/emit!/1 `(ASSIGN ,tempreg (OBJECT->ADDRESS ,contobj)))) + (if (not (zero? adj)) + (rtlgen/emit!/1 + `(ASSIGN ,contreg + (BYTE-OFFSET-ADDRESS ,tempreg + (MACHINE-CONSTANT ,(- 0 adj)))))) + (rearrange!) + (if in-stack? (rtlgen/stack-push!/1 contreg))) + false) + + +(define (rtlgen/continuation-setup/saved! state cont) + (define (bad-cont) + (internal-error "Unexpected CALL continuation [saved!]" cont)) + (cond + ((LOOKUP/? cont) + (if state + (let ((temp-reg (rtlgen/new-reg))) + (rtlgen/assign! temp-reg (rtlgen/boxed-continuation state)) + (rtlgen/bop-stack-pointer! (rtlgen/state/stmt/size state)) + (rtlgen/stack-push!/1 temp-reg) + (rtlgen/stack-push!/1 (rtlgen/boxed-continuation state)))) + false) + ((CALL/%stack-closure-ref? cont) + ;; 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))))) + (rtlgen/bop-stack-pointer! offset) + false)) + ((CALL/%make-stack-closure? cont) + (rtlgen/continuation-is-stack-closure state cont bad-cont #F #T)) + (else (bad-cont)))) + +(define (rtlgen/setup-stack-closure! state cont) + (let* ((size (rtlgen/state/stmt/size state)) + (elts (call/%make-stack-closure/values cont)) + (size* (length elts))) + + (define (is-continuation-lookup? form) + (and (LOOKUP/? form) + (continuation-variable? (lookup/name form)))) + + (define (is-continuation-stack-ref? form) + (and (CALL/%stack-closure-ref? form) + (continuation-variable? + (quote/text (call/%stack-closure-ref/name form))))) + + (define (returning-with-stack-arguments?) + ;; The pushed values are all parameters, not saved values as this is a + ;; reduction or return. + (let ((lambda-slot (call/%make-stack-closure/lambda-expression cont))) + (or (is-continuation-stack-ref? lambda-slot) + (is-continuation-lookup? lambda-slot)))) + + (define (overwrite elts) + (do ((frame-offset 0 (+ frame-offset 1)) + (stack-offset (- size 1) (- stack-offset 1)) + (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))) + ((and (zero? frame-offset) + (not (is-continuation-lookup? (car elts))) + (not (returning-with-stack-arguments?))) + (internal-error "Unexpected previous continuation (1)" cont)) + ((and (is-continuation-lookup? (car elts)) + (not (zero? frame-offset)) + (internal-error "Continuation saved at non-0 slot" cont))) + (else + (let* ((loc (rtlgen/->register + (rtlgen/expr (rtlgen/state/->expr state '(ANY)) + (car elts))))) + (rtlgen/emit!/1 + (rtlgen/write-stack-loc loc stack-offset)))))))) + + (cond ((not (or (is-continuation-stack-ref? (first elts)) + (is-continuation-lookup? (first elts)) + (returning-with-stack-arguments?))) + (internal-error "Unexpected previous continuation (2)" cont)) + ((> size* size) + (overwrite (list-head elts size)) + (rtlgen/stack-push! + (rtlgen/expr* state (list-tail elts size)))) + (else + (overwrite elts) + (rtlgen/bop-stack-pointer! (- size size*)))))) + +;;;; RTL generation of expressions and pseudo-expressions + +(define-macro (define-rtl-generator/expr keyword bindings . body) + (let ((proc-name (symbol-append 'RTLGEN/ keyword '/EXPR))) + (call-with-values + (lambda () (%matchup (cdr bindings) '(handler state) '(cdr form))) + (lambda (names code) + `(define ,proc-name + (let ((handler (lambda ,(cons (car bindings) names) ,@body))) + (named-lambda (,proc-name state form) + ,code))))))) + +(define-rtl-generator/expr LOOKUP (state name) + (let ((place (rtlgen/binding/find name (rtlgen/state/env state)))) + (cond ((not place) + (free-var-error name)) + ((eq? place (rtlgen/state/continuation state)) + (rtlgen/expr/simple-value state (rtlgen/boxed-continuation state))) + ((eq? place (rtlgen/state/closure state)) + (rtlgen/expr/simple-value state (rtlgen/boxed-closure state))) + (else + (rtlgen/expr/simple-value state (rtlgen/binding/place place)))))) + +(define map-any-%unassigneds + (let ((trap (make-unassigned-reference-trap))) + (lambda (object) + (cond ((pair? object) + (cons + (map-any-%unassigneds (car object)) + (map-any-%unassigneds (cdr object)))) + ((vector? object) + (vector-map object map-any-%unassigneds)) + ((eq? object %unassigned) + (unmap-reference-trap trap)) + (else object))))) + +(define-rtl-generator/expr QUOTE (state object) + (rtlgen/expr/simple-value + state + (if (eq? object %unassigned) + (rtlgen/unassigned-object) + `(CONSTANT ,(if (eq? object %unspecific) + unspecific + (map-any-%unassigneds object)))))) + +(define (rtlgen/expr/simple-value state loc) + (let ((target (rtlgen/state/expr/target state))) + (case (car target) + ((ANY) + loc) + ((REGISTER) + (rtlgen/assign! target loc) + target) + ((PREDICATE) + (rtlgen/branch/false? state loc)) + ((NONE) + (internal-error "Unexpected target kind for value" state)) + (else + (internal-error "Unknown target kind" state))))) + +(define-rtl-generator/expr LET (state bindings body) + (rtlgen/let* state bindings body rtlgen/expr rtlgen/state/expr/new-env)) + +(define-rtl-generator/expr IF (state pred conseq alt) + (let ((state* + (if (eq? (car (rtlgen/state/expr/target state)) 'ANY) + (rtlgen/state/->expr state (rtlgen/new-reg)) + state))) + (rtlgen/if* state* pred conseq alt rtlgen/pseudo-stmt + (not (eq? (car (rtlgen/state/expr/target state*)) + 'PREDICATE))) + (let ((target (rtlgen/state/expr/target state*))) + (and (eq? (car target) 'REGISTER) + target)))) + +(define (rtlgen/pseudo-stmt state expr) + (let* ((target (rtlgen/state/expr/target state)) + (result (rtlgen/expr state expr))) + (case (car target) + ((REGISTER) + (if (not (equal? result target)) + (internal-error "Non-register result when register demanded" + target result))) + ((PREDICATE) + (if result + (internal-error "Result for predicate found" target result))) + ((NONE)) + (else + (internal-error "Illegal expression predicate target" target))))) + +(define-rtl-generator/expr CALL (state rator cont #!rest rands) + (define (illegal message) + (internal-error message `(CALL ,rator ,cont ,@rands))) + (cond ((not (equal? cont '(QUOTE #F))) + (illegal "CALL expression with non-false continuation")) + ((not (and (QUOTE/? rator) + (pseudo-simple-operator? (quote/text rator)))) + (illegal "CALL expression with non-simple operator")) + (else + (let ((rator (quote/text rator))) + (cond ((eq? rator %make-trivial-closure) + (rtlgen/expr/make-trivial-closure state (car rands))) + ((eq? rator %make-heap-closure) + (rtlgen/expr/make-closure state rands)) + ((eq? rator %stack-closure-ref) + (rtlgen/expr/stack-closure-ref state rands)) + ((eq? rator %make-return-address) + (rtlgen/expr/make-return-address state (car rands))) + ((eq? rator %variable-read-cache) + (rtlgen/variable-cache state (cadr rands) 'VARIABLE-CACHE)) + ((eq? rator %variable-write-cache) + (rtlgen/variable-cache state (cadr rands) 'ASSIGNMENT-CACHE)) + ((eq? rator %make-stack-closure) + (internal-error "CALL to make-stack-closure" cont rands)) + (else + (let* ((rands* (rtlgen/expr* state rands)) + (target (rtlgen/state/expr/target state))) + (case (car target) + ((ANY REGISTER) + (rtlgen/open-code/value state rands* rator)) + ((PREDICATE) + (rtlgen/open-code/pred state rands* rator)) + ((NONE) + (rtlgen/open-code/stmt state rands* rator)) + (else + (internal-error "Unknown value destination" + target + `(CALL ,rator ,cont + ,@rands))))))))))) + +(define (rtlgen/variable-cache state name keyword) + (if (not (QUOTE/? name)) + (internal-error "Unexpected variable cache name" name)) + (rtlgen/value-assignment state `(,keyword ,(quote/text name)))) + +(define (rtlgen/expr/make-return-address state rand) + state ; ignored + (rtlgen/continuation-label->object + (rtlgen/enqueue-object! rand 'CONTINUATION))) + +(define (rtlgen/expr/make-trivial-closure state rand) + (define (finish! entry-label) + (let ((label-reg (rtlgen/new-reg))) + (rtlgen/assign! label-reg `(ENTRY:PROCEDURE ,entry-label)) + (rtlgen/value-assignment state (rtlgen/entry->object label-reg)))) + (cond ((LOOKUP/? rand) + (finish! + (rtlgen/enqueue-delayed-object! (lookup/name rand) 'TRIVIAL-CLOSURE))) + ((LAMBDA/? rand) + (finish! (rtlgen/enqueue-object! rand 'TRIVIAL-CLOSURE))) + (else + (internal-error "Unexpected argument to make-trivial-closure" rand)))) + +(define (rtlgen/enqueue-object! object kind) + (let ((label* (rtlgen/new-name kind))) + (rtlgen/enqueue! (vector kind label* object)) + label*)) + +(define (rtlgen/enqueue-delayed-object! name kind) + (let ((place (assq name *rtlgen/delayed-objects*))) + (if (not place) + (internal-error "Unknown binding for operand" name kind)) + (let* ((vec (cdr place)) + (label (vector-ref vec 1))) + (cond ((not label) + (let ((label* (car place))) + (vector-set! vec 0 kind) + (vector-set! vec 1 label*) + (rtlgen/enqueue! vec) + label*)) + ((not (eq? (vector-ref vec 0) kind)) + (internal-error "Inconsistent usage" + (vector-ref vec 2) + (vector-ref vec 0) + kind)) + (else + label))))) + +(define (rtlgen/find-delayed-object name) + ;; Lookup by name, result is #(kind label object) + (let ((result (assq name *rtlgen/delayed-objects*))) + (if (not result) + (internal-error + "rtlgen/find-delayed-object: not found" name) + (cdr result)))) + +(define (rtlgen/expr/make-closure state rands) + (if (or (null? rands) + (null? (cdr rands)) + (not (LAMBDA/? (first rands)))) + (internal-error "Unexpected argument to rtlgen/expr/make-closure")) + ;; (second rands) is closure name vector, ignored + (rtlgen/make-closure* state + (lambda-list/arity-info + (cdr (lambda/formals (first rands)))) + (rtlgen/enqueue-object! (first rands) 'CLOSURE) + (rtlgen/expr* state (cddr rands)))) + +(define (rtlgen/make-closure* state arity-info label elts) + (let ((clos (rtlgen/new-reg)) + (nelts (length elts))) + (rtlgen/declare-allocation! (+ (rtlgen/closure-prefix-size) nelts)) + (rtlgen/assign! clos + `(CONS-CLOSURE (ENTRY:PROCEDURE ,label) + ,(car arity-info) + ,(cadr arity-info) + ,nelts)) + (do ((elts elts (cdr elts)) + (offset (rtlgen/closure-first-offset) (+ offset 1))) + ((null? elts) 'DONE) + (rtlgen/emit!/1 + `(ASSIGN (OFFSET ,clos (MACHINE-CONSTANT ,offset)) + ,(rtlgen/->register (car elts))))) + (rtlgen/value-assignment state (rtlgen/entry->object clos)))) + +(define (rtlgen/expr state expr) + ;; returns result-location + (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)) + ((LAMBDA BEGIN LETREC DECLARE) + (internal-error "Illegal expression" expr)) + ((SET! UNASSIGNED? OR DELAY + ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT) + (no-longer-legal expr)) + (else + (illegal expr)))) + +(define (rtlgen/expr* state exprs) + ;; returns list of result-locations + (let ((state (rtlgen/state/->expr state '(ANY)))) + (let loop ((exprs exprs) + (results '())) + (if (null? exprs) + (reverse! results) + (loop (cdr exprs) + (cons (rtlgen/expr state (car exprs)) + results)))))) + +(define (rtlgen/remember new old) + old ; ignored + new) + +(define (rtlgen/new-name prefix) + (generate-uninterned-symbol prefix)) + +;;;; States +;; +;; States contain the contextual information needed to translate a piece +;; of KMP code into RTL. There are statement states (for reductions) +;; and expression states (for open-coded subproblems). States are +;; initially set up at procedure (continuation etc) entry. +;; RTLGEN/STATE/->EXPR is the only way to construct an expression +;; state. It builds on some existing (statement or expression) +;; state. +;; +;; The ENV is a map from names to machine places. RTLGEN/STATE/ENV +;; retrives the state and (RTLGEN/STATE/NEW-ENV/variant state env) +;; returns a new state like the old but with a different ENV. +;; +;; CLOSURE and CONTINUATION are set to the bindings for the heap closure +;; and continuation parameters, or #F if that parameter is absent +;; (e.g. continuations are not themselves passed a continuation). +;; These bindings are also in ENV. The binding is to an RTL register +;; containing to the RAW object, which may have been loaded from +;; either the stack or standard registers. +;; +;; Statements are compiled in the context of a stack frame. SIZE is the +;; number of elements on the stack, INCLUDING the continuation and +;; closure pointer if these are on the stack. +;; +;; Expressions are compiled in the context of a target. A target may be +;; any of the following: +;; (ANY) any location will do +;; (NONE) the value is not required +;; (REGISTER number) target this register +;; (PREDICATE (true-label count) (false-label count)) +;; `target' is a predicate. The count slots are initially 0 and are +;; updated to count the number of branches to the true and false +;; labels. + +(define-structure (rtlgen/state/stmt + (conc-name rtlgen/state/stmt/) + (constructor rtlgen/state/stmt/make)) + (env '() read-only true) + (continuation #F read-only true) + (closure #F read-only true) + (size false read-only true)) + +(define-structure (rtlgen/state/expr + (conc-name rtlgen/state/expr/) + (constructor %rtlgen/state/expr/make)) + (env '() read-only true) + (continuation #F read-only true) + (closure #F read-only true) + (target false read-only true)) + +;; RTLGEN/STATE/{ENV,CONTINUATION,CLOSURE} all depend on the fact that +;; both states have the same layout and that there is no error +;; checking by default. Otherwise they could be written to dispatch. + +(define-integrable (rtlgen/state/env state) + (rtlgen/state/stmt/env state)) + +(define-integrable (rtlgen/state/continuation state) + (rtlgen/state/stmt/continuation state)) + +(define-integrable (rtlgen/state/closure state) + (rtlgen/state/stmt/closure state)) + +(define (rtlgen/state/reference-to-cont state) + (if (rtlgen/state/continuation state) + (rtlgen/binding/place (rtlgen/state/continuation state)) + (internal-error "No continuation in this state " state))) + +(define (rtlgen/state/reference-to-closure state) + (if (rtlgen/state/closure state) + (rtlgen/binding/place (rtlgen/state/closure state)) + (internal-error "No continuation in this state " state))) + +(define-integrable (rtlgen/state/->expr state target) + (%rtlgen/state/expr/make (rtlgen/state/env state) + (rtlgen/state/continuation state) + (rtlgen/state/closure state) + target)) + +(define (rtlgen/state/stmt/new-env state env) + (rtlgen/state/stmt/make env + (rtlgen/state/stmt/continuation state) + (rtlgen/state/stmt/closure state) + (rtlgen/state/stmt/size state))) + +(define (rtlgen/state/expr/new-env state env) + (%rtlgen/state/expr/make env + (rtlgen/state/expr/continuation state) + (rtlgen/state/expr/closure state) + (rtlgen/state/expr/target state))) + +(define (rtlgen/state/stmt/guaranteed-size state) + (or (and (rtlgen/state/stmt? state) (rtlgen/state/stmt/size state)) + (internal-error "Cannot find stack frame size" state))) + +;; In the state structures, ENV is a list of bindings: + +(define-structure (rtlgen/binding + (conc-name rtlgen/binding/) + (constructor rtlgen/binding/make) + (print-procedure + (standard-unparser-method 'RTLGEN/BINDING + (lambda (binding port) + (write-char #\space port) + (write (rtlgen/binding/name binding) port))))) + (name #F read-only true) + (place #F read-only true) ; Where it is currently + (home #F read-only true)) + +(define (rtlgen/binding/find name env) + (let loop ((env env)) + (cond ((null? env) #F) + ((eq? name (rtlgen/binding/name (car env))) + (car env)) + (else (loop (cdr env)))))) + +;;;; Open coding + +(define *open-coders* + (make-eq-hash-table)) + +(define-integrable (rtlgen/get-open-coder rator) + (let ((open-coder (hash-table/get *open-coders* rator false))) + (if (not open-coder) + (internal-error "No open coder known" rator) + open-coder))) + +(define-integrable (rtlgen/get-open-coder/checked rator rands) + (let ((open-coder (rtlgen/get-open-coder rator))) + (if (and (rtlgen/open-coder/nargs open-coder) + (not (= (length rands) (rtlgen/open-coder/nargs open-coder)))) + (user-error "Wrong number of arguments" rator) + open-coder))) + +(define (rtlgen/open-code/pred state rands rator) + ;; No meaningful value + (let ((open-coder (rtlgen/get-open-coder/checked rator rands))) + ((rtlgen/open-coder/pred open-coder) state rands open-coder))) + +(define (rtlgen/open-code/stmt state rands rator) + ;; No meaningful value + (let ((open-coder (rtlgen/get-open-coder/checked rator rands))) + ((rtlgen/open-coder/stmt open-coder) state rands open-coder))) + +(define (rtlgen/open-code/value state rands rator) + ;; Returns location of result + (let ((open-coder (rtlgen/get-open-coder/checked rator rands))) + ((rtlgen/open-coder/value open-coder) state rands open-coder))) + +(define (rtlgen/open-code/out-of-line cont-label rator) + ;; No meaningful value + (let ((open-coder (hash-table/get *open-coders* rator false))) + (cond ((not open-coder) + (internal-error "No open coder known" rator)) + (else + ((rtlgen/open-coder/outl open-coder) cont-label open-coder))))) + +(define (rtlgen/open-code/special cont-label rator rands) + ;; No meaningful value + (let ((open-coder (rtlgen/get-open-coder/checked rator rands))) + ((rtlgen/open-coder/special open-coder) cont-label rands open-coder))) + + +(define-structure (rtlgen/open-coder + (conc-name rtlgen/open-coder/) + (constructor rtlgen/open-coder/make)) + (rator false read-only true) + (nargs false read-only true) + (value false read-only true) + (stmt false read-only true) + (pred false read-only true) + (outl false read-only true) + (special false read-only true)) + +(define (define-open-coder name-or-object nargs + vhandler shandler phandler ohandler sphandler) + (let ((rator (if (hash-table/get *operator-properties* name-or-object false) + name-or-object + (make-primitive-procedure name-or-object nargs)))) + (hash-table/put! + *open-coders* + rator + (rtlgen/open-coder/make rator nargs + vhandler shandler phandler + ohandler sphandler)))) + +(define (rtlgen/no-predicate-open-coder state rands open-coder) + state rands ; ignored + (internal-error "Statement operation used as predicate" + (rtlgen/open-coder/rator open-coder))) + +(define (rtlgen/no-stmt-open-coder state rands open-coder) + state rands ; ignored + (internal-error "Predicate/value operation used as statement" + (rtlgen/open-coder/rator open-coder))) + +(define (rtlgen/no-value-open-coder state rands open-coder) + state rands ; ignored + (internal-error "Statement operation used as value" + (rtlgen/open-coder/rator open-coder))) + +(define (rtlgen/no-out-of-line-open-coder cont-label open-coder) + cont-label ; ignored + (internal-error "Attempt to call open-coded operation" + (rtlgen/open-coder/rator open-coder))) + +(define (rtlgen/no-special-open-coder cont-label rator rands open-coder) + cont-label rator rands ; ignored + (internal-error "Attempt to call open-coded operation" + (rtlgen/open-coder/rator open-coder))) + +(define (define-open-coder/pred name-or-object nargs handler) + (define-open-coder name-or-object nargs + (rtlgen/pred->value handler) + rtlgen/no-stmt-open-coder + handler + rtlgen/no-out-of-line-open-coder + rtlgen/no-special-open-coder)) + +(define (define-open-coder/stmt name-or-object nargs handler) + (define-open-coder name-or-object nargs + rtlgen/no-value-open-coder + handler + rtlgen/no-predicate-open-coder + rtlgen/no-out-of-line-open-coder + rtlgen/no-special-open-coder)) + +(define (define-open-coder/value name-or-object nargs handler) + (define-open-coder name-or-object nargs + handler + rtlgen/no-stmt-open-coder + (rtlgen/value->pred handler) + rtlgen/no-out-of-line-open-coder + rtlgen/no-special-open-coder)) + +(define (define-open-coder/out-of-line name-or-object nargs handler) + (define-open-coder name-or-object nargs + (rtlgen/out-of-line->value handler) + (rtlgen/out-of-line->stmt handler) + (rtlgen/out-of-line->pred handler) + handler + rtlgen/no-special-open-coder)) + +(define (define-open-coder/special name-or-object nargs handler) + (define-open-coder name-or-object nargs + (rtlgen/special->value handler) + (rtlgen/special->stmt handler) + (rtlgen/special->pred handler) + rtlgen/no-out-of-line-open-coder + handler)) + +(define (rtlgen/pred->value handler) + (lambda (state rands open-coder) + (let* ((target (rtlgen/state/expr/target state)) + (target* (case (car target) + ((ANY) + (rtlgen/new-reg)) + ((REGISTER) + target) + (else + (internal-error "Unexpected value target" target + (rtlgen/open-coder/rator + open-coder)))))) + (let ((merge-label (rtlgen/new-name 'MERGE)) + (true-label (rtlgen/new-name 'TRUE)) + (false-label (rtlgen/new-name 'FALSE))) + (handler (rtlgen/state/->expr + state + `(PREDICATE ,(list true-label 0) ,(list false-label 0))) + rands open-coder) + (rtlgen/assign!* + `((LABEL ,true-label) + (ASSIGN ,target* (CONSTANT ,#t)) + (JUMP ,merge-label) + (LABEL ,false-label) + (ASSIGN ,target* (CONSTANT ,#f)) + (LABEL ,merge-label))) + target*)))) + +(define (rtlgen/value->pred handler) + (lambda (state rands open-coder) + (rtlgen/branch/false? state + (handler (rtlgen/state/->expr state '(ANY)) + rands open-coder)))) + +(define (rtlgen/with-preservation state code-gen-1 code-gen-2) + (rtlgen/stack-allocation/protect ; /compatible ? + (lambda () + (call-with-values + (lambda () (rtlgen/preserve-state state)) + (lambda (gen-prefix gen-suffix) + (let ((cont-label (rtlgen/new-name 'CONT))) + (gen-prefix) + (code-gen-1 cont-label) + (rtlgen/emit!/1 + `(RETURN-ADDRESS ,cont-label + (MACHINE-CONSTANT ,(if (not *rtlgen/frame-size*) + 0 + (- *rtlgen/frame-size* 1))) + (MACHINE-CONSTANT 1))) + (let ((result (code-gen-2 state))) + (gen-suffix) + result))))))) + +(define (rtlgen/out-of-line->pred handler) + (rtlgen/value->pred (rtlgen/out-of-line->value handler))) + +#| +(define (rtlgen/out-of-line->stmt handler) + ;; /compatible + (lambda (state rands open-coder) + (rtlgen/with-preservation + state + (lambda (cont-label) + (rtlgen/stack-push! + (cons (rtlgen/continuation-label->object cont-label) + (reverse rands))) + (handler cont-label open-coder)) + (lambda (state) + state ; ignored + unspecific)))) + +(define (rtlgen/out-of-line->value handler) + ;; /compatible + (lambda (state rands open-coder) + (rtlgen/with-preservation + state + (lambda (cont-label) + (rtlgen/stack-push! + (cons (rtlgen/continuation-label->object cont-label) + (reverse rands))) + (handler cont-label open-coder)) + (lambda (state) + (rtlgen/value-assignment state (rtlgen/reference-to-val)))))) +|# + +(define (rtlgen/out-of-line->stmt handler) + (lambda (state rands open-coder) + (rtlgen/with-preservation + state + (lambda (cont-label) + (rtlgen/expr-results->call-registers state rands) + (handler cont-label open-coder)) + (lambda (state) + state ; ignored + unspecific)))) + +(define (rtlgen/out-of-line->value handler) + (lambda (state rands open-coder) + (rtlgen/with-preservation + state + (lambda (cont-label) + (rtlgen/expr-results->call-registers state rands) + (handler cont-label open-coder)) + (lambda (state) + (rtlgen/value-assignment state (rtlgen/reference-to-val)))))) + +(define (rtlgen/special->pred handler) + (rtlgen/value->pred (rtlgen/special->value handler))) + +(define (rtlgen/special->stmt handler) + (lambda (state rands open-coder) + (rtlgen/with-preservation + state + (lambda (cont-label) + (handler cont-label rands open-coder)) + (lambda (state) + state ; ignored + unspecific)))) + +(define (rtlgen/special->value handler) + (lambda (state rands open-coder) + (rtlgen/with-preservation + state + (lambda (cont-label) + (handler cont-label rands open-coder)) + (lambda (state) + (rtlgen/value-assignment state (rtlgen/reference-to-val)))))) + +;;;; Open-coded predicates + +;;; These open codings do not do anything about type and range checking. +;;; Such things are assumed to have been done by an earlier stage. + +(let* ((simple-value-tester + (lambda (rtlgen/branch/) + (lambda (name rtl-pred compile-time-pred?) + (define-open-coder/pred name 1 + (lambda (state rands open-coder) + open-coder ; ignored + (let ((rand (car rands))) + (cond ((or (not (rtlgen/constant? rand)) + (not *rtlgen/fold-simple-value-tests?*)) + (let* ((rand* (rtlgen/->register rand))) + (rtlgen/branch/ + state `(PRED-1-ARG ,rtl-pred ,rand*)))) + ((compile-time-pred? (rtlgen/constant-value rand)) + (rtlgen/branch/true state)) + (else + (rtlgen/branch/false state))))))))) + (define-simple-value-test + (simple-value-tester rtlgen/branch/likely)) + (define-simple-value-test/inverted + (simple-value-tester rtlgen/branch/unlikely))) + + (define-simple-value-test/inverted 'NULL? 'NULL? null?) + (define-simple-value-test/inverted 'NOT 'FALSE? not) + (define-simple-value-test/inverted 'FALSE? 'FALSE? false?) + (define-simple-value-test 'FIXNUM? 'FIXNUM? fixnum?) + (define-simple-value-test %machine-fixnum? 'FIXNUM? fixnum?) + (define-simple-value-test 'INDEX-FIXNUM? 'INDEX-FIXNUM? index-fixnum?)) + +(let ((define-simple-tag-test + (lambda (name tag) + (define-open-coder/pred name 1 + (lambda (state rands open-coder) + open-coder ; ignored + (let ((rand (car rands))) + (cond ((or (not (rtlgen/constant? rand)) + (not *rtlgen/fold-tag-predicates?*)) + (let* ((rand* (rtlgen/->register rand)) + (rand** (rtlgen/new-reg))) + (rtlgen/assign! rand** `(OBJECT->TYPE ,rand*)) + (rtlgen/branch/likely state + `(TYPE-TEST ,rand** ,tag)))) + ((object-type? tag (rtlgen/constant-value rand)) + (rtlgen/branch/true state)) + (else + (rtlgen/branch/false state))))))))) + (define-simple-tag-test 'CELL? (machine-tag 'CELL)) + (define-simple-tag-test 'PAIR? (machine-tag 'PAIR)) + (define-simple-tag-test 'VECTOR? (machine-tag 'VECTOR)) + (define-simple-tag-test '%RECORD? (machine-tag 'RECORD)) + (define-simple-tag-test 'STRING? (machine-tag 'STRING)) + (define-simple-tag-test 'BIT-STRING? (machine-tag 'VECTOR-1B)) + (define-simple-tag-test 'FLONUM? (machine-tag 'FLONUM))) + +(define-open-coder/pred 'EQ? 2 + (lambda (state rands open-coder) + open-coder ; ignored + (let ((rand1 (car rands)) + (rand2 (cadr rands))) + (cond ((or (not (rtlgen/constant? rand1)) + (not (rtlgen/constant? rand2)) + (not *rtlgen/fold-tag-predicates?*)) + (let* ((rand1* (rtlgen/->register rand1)) + (rand2* (rtlgen/->register rand2))) + (rtlgen/branch/unlikely state `(EQ-TEST ,rand1* ,rand2*)))) + ((eq? (rtlgen/constant-value rand1) (rtlgen/constant-value rand2)) + (rtlgen/branch/true state)) + (else + (rtlgen/branch/false state)))))) + +(define-open-coder/pred %unassigned? 1 + (lambda (state rands open-coder) + open-coder ; ignored + (let* ((rand1 (rtlgen/->register (car rands))) + (rand2 (rtlgen/->register (rtlgen/unassigned-object)))) + (rtlgen/branch/unlikely state `(EQ-TEST ,rand1 ,rand2))))) + +(define-open-coder/pred %reference-trap? 1 + (let ((tag (machine-tag 'REFERENCE-TRAP))) + (lambda (state rands open-coder) + open-coder ; ignored + (let* ((rand (rtlgen/->register (car rands))) + (temp (rtlgen/new-reg))) + (rtlgen/assign! temp `(OBJECT->TYPE ,rand)) + (rtlgen/branch/unlikely state `(TYPE-TEST ,temp ,tag)))))) + +(define-open-coder/pred 'OBJECT-TYPE? 2 + (lambda (state rands open-coder) + open-coder ; ignored + (let* ((tag (car rands)) + (obj (rtlgen/->register (second rands))) + (obj* (rtlgen/new-reg))) + (rtlgen/assign! obj* `(OBJECT->TYPE ,obj)) + (cond ((rtlgen/constant? tag) + (rtlgen/branch/likely + state + `(TYPE-TEST ,obj* ,(rtlgen/constant-value tag)))) + (else + (let* ((tag* (rtlgen/->register tag)) + (tag** (rtlgen/new-reg))) + (rtlgen/assign! tag** `(OBJECT->DATUM ,tag*)) + (rtlgen/branch/likely state `(EQ-TEST ,obj* ,tag**)))))))) + +(define-integrable (rtlgen/constant? syllable) + (and (pair? syllable) + (eq? (car syllable) 'CONSTANT))) + +(define-integrable (rtlgen/constant-value syllable) + (cadr syllable)) + +(define-integrable (rtlgen/integer-constant? syllable) + (and (rtlgen/constant? syllable) + (number? (rtlgen/constant-value syllable)) + (rtlgen/constant-value syllable))) + +(define-open-coder/pred %small-fixnum? 2 + (lambda (state rands open-coder) + open-coder ; ignored + (let* ((value (rtlgen/->register (car rands))) + (nbits (cadr rands))) + (if (not (rtlgen/constant? nbits)) + (internal-error "small-fixnum? needs constant nbits" nbits)) + (rtlgen/branch/likely + state + `(PRED-2-ARGS SMALL-FIXNUM? + ,value + (MACHINE-CONSTANT ,(rtlgen/constant-value nbits))))))) + +(let ((define-fixnum-predicate + (lambda (proc name rtlgen/branch) + (define-open-coder/pred proc 2 + (lambda (state rands open-coder) + open-coder ; ignored + (let* ((rand1 (rtlgen/->register (car rands))) + (rand2 (rtlgen/->register (cadr rands)))) + (rtlgen/branch + state + `(FIXNUM-PRED-2-ARGS ,name ,rand1 ,rand2)))))))) + (define-fixnum-predicate fix:= 'EQUAL-FIXNUM? + rtlgen/branch/unlikely) + (define-fixnum-predicate fix:< 'LESS-THAN-FIXNUM? + rtlgen/branch/unpredictable) + (define-fixnum-predicate fix:> 'GREATER-THAN-FIXNUM? + rtlgen/branch/unpredictable)) + +(let ((define-flonum-predicate + (lambda (proc name rtlgen/branch) + (define-open-coder/pred proc 2 + (lambda (state rands open-coder) + open-coder ; ignored + (let* ((rand1 (rtlgen/->register (car rands))) + (rand2 (rtlgen/->register (cadr rands))) + (flo1 (rtlgen/new-reg)) + (flo2 (rtlgen/new-reg))) + (rtlgen/assign! flo1 `(OBJECT->FLOAT ,rand1)) + (rtlgen/assign! flo2 `(OBJECT->FLOAT ,rand2)) + (rtlgen/branch state + `(FLONUM-PRED-2-ARGS ,name ,flo1 ,flo2)))))))) + (define-flonum-predicate flo:= 'FLONUM-EQUAL? + rtlgen/branch/unlikely) + (define-flonum-predicate flo:< 'FLONUM-LESS? + rtlgen/branch/unpredictable) + (define-flonum-predicate flo:> 'FLONUM-GREATER? + rtlgen/branch/unpredictable)) + +#| +;; These don't work, because the operands are evaluated by this point, +;; and one of the operands is (LOOKUP ,cache-name) where cache-name +;; is unbound! + +(let ((define-reference-to-cache + (lambda (%variable-cache keyword) + (define-open-coder/value %variable-cache 2 + (lambda (state rands open-coder) + open-coder ; ignored + (let ((name (second rands))) + (if (not (QUOTE/? name)) + (internal-error "Unexpected variable cache name" name)) + (rtlgen/value-assignment state `(,keyword ,(cadr name))))))))) + + (define-reference-to-cache %variable-read-cache 'VARIABLE-CACHE) + (define-reference-to-cache %variable-write-cache 'ASSIGNMENT-CACHE)) +|# + +(for-each + (lambda (prim-name) + (define-open-coder/value prim-name 1 + (lambda (state rands open-coder) + open-coder ; ignored + (let ((rand (rtlgen/->register (first rands)))) + (rtlgen/value-assignment state `(OBJECT->TYPE ,rand)))))) + '(OBJECT-TYPE + PRIMITIVE-OBJECT-TYPE)) + +(define-open-coder/value 'OBJECT-DATUM 1 + (lambda (state rands open-coder) + open-coder ; ignored + (let ((rand (rtlgen/->register (first rands)))) + (rtlgen/value-assignment state `(OBJECT->DATUM ,rand))))) + +(define-open-coder/value 'PRIMITIVE-OBJECT-SET-TYPE 2 + (lambda (state rands open-coder) + open-coder ; ignored + (let ((tag (first rands)) + (obj (rtlgen/->register (second rands)))) + (let ((obj* (rtlgen/new-reg))) + (rtlgen/assign! obj* `(OBJECT->DATUM ,obj)) + (cond ((rtlgen/constant? tag) + (rtlgen/value-assignment + state + `(CONS-NON-POINTER + (MACHINE-CONSTANT ,(rtlgen/constant-value tag)) + ,obj*))) + (else + (let* ((tag* (rtlgen/->register tag)) + (tag** (rtlgen/new-reg))) + (rtlgen/assign! tag** `(OBJECT->DATUM ,tag*)) + (rtlgen/value-assignment + state + `(CONS-NON-POINTER ,tag** ,obj*))))))))) + +(define (rtlgen/cons state rands tag) + (rtlgen/heap-push! rands) + (rtlgen/value-assignment + state + `(CONS-POINTER + ,tag + ,(rtlgen/->register + `(OFFSET-ADDRESS ,(rtlgen/reference-to-free) + (MACHINE-CONSTANT ,(- 0 (length rands)))))))) + +(let ((define-tagged-allocator + (lambda (name arity tag) + (define-open-coder/value name arity + (lambda (state rands open-coder) + open-coder ; ignored + (rtlgen/cons state rands `(MACHINE-CONSTANT ,tag))))))) + (define-tagged-allocator 'MAKE-CELL 1 (machine-tag 'CELL)) + (define-tagged-allocator %make-static-binding 1 (machine-tag 'CELL)) + (define-tagged-allocator 'CONS 2 (machine-tag 'PAIR)) + (define-tagged-allocator %cons 2 (machine-tag 'PAIR))) + +(define-open-coder/value %make-cell 2 + (let ((tag (machine-tag 'CELL))) + (lambda (state rands open-coder) + open-coder ; ignored + (rtlgen/cons state (list (first rands)) `(MACHINE-CONSTANT ,tag))))) + +(define-open-coder/value %make-promise 1 + (let ((tag (machine-tag 'DELAYED))) + (lambda (state rands open-coder) + open-coder ; ignored + (rtlgen/cons state + (cons `(CONSTANT 0) rands) + `(MACHINE-CONSTANT ,tag))))) + +(let ((define-vector-allocator + (lambda (name tag) + (define-open-coder/value name false + (lambda (state rands open-coder) + open-coder ; ignored + (rtlgen/cons state + (cons `(CONSTANT ,(length rands)) rands) + `(MACHINE-CONSTANT ,tag))))))) + (define-vector-allocator 'VECTOR (machine-tag 'VECTOR)) + (define-vector-allocator %vector (machine-tag 'VECTOR)) + (define-vector-allocator '%RECORD (machine-tag 'RECORD))) + +(define-open-coder/value 'SYSTEM-PAIR-CONS 3 + (lambda (state rands open-coder) + open-coder ; ignored + (rtlgen/cons state + (cdr rands) + (let ((tag (car rands))) + (if (rtlgen/constant? tag) + `(MACHINE-CONSTANT ,(rtlgen/constant-value tag)) + (rtlgen/->register tag)))))) + +(define-open-coder/value 'STRING-ALLOCATE 1 + (let ((string-tag (machine-tag 'STRING)) + (nmv-tag (machine-tag 'MANIFEST-NM-VECTOR))) + (lambda (state rands open-coder) + open-coder ; ignored + (let ((char-len (rtlgen/allocate-length (first rands) 'STRING-ALLOCATE))) + (let* ((free (rtlgen/reference-to-free)) + (result (rtlgen/value-assignment + state + `(CONS-POINTER (MACHINE-CONSTANT ,string-tag) + ,free))) + (word-len (rtlgen/chars->words char-len)) + (nmv-header (rtlgen/new-reg)) + (slen (rtlgen/new-reg)) + (zero (rtlgen/new-reg))) + (rtlgen/declare-allocation! (+ word-len 2)) + (rtlgen/assign!* + `((ASSIGN ,nmv-header + (CONS-NON-POINTER (MACHINE-CONSTANT ,nmv-tag) + (MACHINE-CONSTANT ,(+ word-len 1)))) + (ASSIGN (OFFSET ,free (MACHINE-CONSTANT 0)) ,nmv-header) + (ASSIGN ,slen (CONSTANT ,char-len)) + (ASSIGN (OFFSET ,free (MACHINE-CONSTANT 1)) ,slen) + (ASSIGN ,free + (OFFSET-ADDRESS ,free + (MACHINE-CONSTANT ,(+ word-len 2)))) + (ASSIGN ,zero (MACHINE-CONSTANT 0)) + (ASSIGN (OFFSET ,free (MACHINE-CONSTANT -1)) ,zero))) + result))))) + +(define-open-coder/value 'FLOATING-VECTOR-CONS 1 + (let ((fv-tag (machine-tag 'FLOATING-POINT-VECTOR)) + (nmv-tag (machine-tag 'MANIFEST-NM-VECTOR))) + (lambda (state rands open-coder) + open-coder ; ignored + (rtlgen/floating-align-free) + (let* ((free (rtlgen/reference-to-free)) + (result (rtlgen/value-assignment + state + `(CONS-POINTER (MACHINE-CONSTANT ,fv-tag) + ,free))) + (len (rtlgen/allocate-length (first rands) 'FLOATING-VECTOR-CONS)) + (word-len (rtlgen/fp->words len)) + (nmv-header (rtlgen/new-reg))) + (rtlgen/declare-allocation! (+ word-len 1)) + (rtlgen/assign!* + `((ASSIGN ,nmv-header + (CONS-NON-POINTER (MACHINE-CONSTANT ,nmv-tag) + (MACHINE-CONSTANT ,word-len))) + (ASSIGN (OFFSET ,free (MACHINE-CONSTANT 0)) ,nmv-header) + (ASSIGN ,free + (OFFSET-ADDRESS ,free + (MACHINE-CONSTANT + ,(+ word-len 1)))))) + result)))) + +(define-open-coder/value 'VECTOR-CONS 2 + (let ((vector-tag (machine-tag 'VECTOR))) + (lambda (state rands open-coder) + open-coder ; ignored + (let ((len (rtlgen/allocate-length (first rands) 'VECTOR-CONS)) + (fill (rtlgen/->register (second rands)))) + (if (> len *vector-cons-max-open-coded-length*) + (internal-error "Open coding VECTOR-CONS with too large a length" + len)) + (rtlgen/cons state + (cons `(CONSTANT ,len) (make-list len fill)) + vector-tag))))) + +;; *** STRING-ALLOCATE, FLOATING-VECTOR-CONS, and perhaps VECTOR-CONS +;; should always be in-lined, even when the length argument is not known. +;; They can do a late back out when there is no space, much like generic +;; arithmetic backs out when the operands are not appropriate fixnums. *** + +(define (rtlgen/allocate-length len proc) + (if (not (rtlgen/integer-constant? len)) + (internal-error + "Open coding allocation primitive with non-constant/non-integer length" + len proc)) + (rtlgen/constant-value len)) + +(define-open-coder/value %variable-cell-ref 1 + (lambda (state rands open-coder) + open-coder + (let ((cell (rtlgen/->register (first rands)))) + (rtlgen/value-assignment state `(OFFSET ,cell (MACHINE-CONSTANT 0)))))) + +(define-open-coder/value %static-binding-ref 2 + (lambda (state rands open-coder) + open-coder ; ignored + (let ((name (second rands))) + (if (not (rtlgen/constant? name)) + (internal-error "Unexpected name to static-binding-ref" name)) + (let ((cell (rtlgen/->register + `(STATIC-CELL ,(rtlgen/constant-value name))))) + (rtlgen/value-assignment state + `(OFFSET ,cell (MACHINE-CONSTANT 0))))))) + +#| +;; This is not done this way because stack closures are handled specially, +;; with RTL registers assigned early to their elements to allow painless +;; stack reformatting later. +;; In particular, %stack-closure-ref cannot be open-coded in the normal +;; way because it wants to examine the rands BEFORE rtl generation. + +(define-open-coder/value %stack-closure-ref 3 + (lambda (state rands open-coder) + open-coder ; ignored + (let ((closure (rtlgen/->register (first rands))) + (offset (second rands))) + (if (not (rtlgen/integer-constant? offset)) + (internal-error "Non-constant index to stack-closure-ref" offset)) + (rtlgen/value-assignment + state + `(OFFSET ,closure + (MACHINE-CONSTANT ,(rtlgen/constant-value offset))))))) +|# + +(define (rtlgen/expr/stack-closure-ref state rands) + (let ((name (third rands))) + (if (not (QUOTE/? name)) + (internal-error "Unexpected name to stack-closure-ref" rands)) + (let* ((name* (quote/text name)) + (place (rtlgen/binding/find name* (rtlgen/state/env state)))) + (if (not place) + (internal-error "stack binding not found" name*) + (rtlgen/expr/simple-value state (rtlgen/binding/place place)))))) + +(define (rtlgen/fixed-selection state rand offset) + (let* ((rand (rtlgen/->register rand)) + (address (rtlgen/new-reg))) + (rtlgen/assign! address `(OBJECT->ADDRESS ,rand)) + (rtlgen/value-assignment state + `(OFFSET ,address (MACHINE-CONSTANT ,offset))))) + +(let ((define-fixed-selector + (lambda (name tag offset arity) + tag ; unused + (define-open-coder/value name arity + (lambda (state rands open-coder) + open-coder ; ignored + (rtlgen/fixed-selection state (first rands) offset)))))) + (define-fixed-selector 'CELL-CONTENTS (machine-tag 'CELL) 0 1) + (define-fixed-selector %cell-ref (machine-tag 'CELL) 0 2) + (define-fixed-selector 'CAR (machine-tag 'PAIR) 0 1) + (define-fixed-selector 'CDR (machine-tag 'PAIR) 1 1) + (define-fixed-selector 'SYSTEM-PAIR-CAR false 0 1) + (define-fixed-selector 'SYSTEM-PAIR-CDR false 1 1) + (define-fixed-selector 'SYSTEM-HUNK3-CXR0 false 0 1) + (define-fixed-selector 'SYSTEM-HUNK3-CXR1 false 1 1) + (define-fixed-selector 'SYSTEM-HUNK3-CXR2 false 2 1)) + +(let ((define-indexed-selector + (lambda (name tag offset arity) + tag ; unused + (define-open-coder/value name arity + (lambda (state rands open-coder) + open-coder ; ignored + (let ((index (second rands))) + (cond ((rtlgen/integer-constant? index) + (rtlgen/fixed-selection + state + (first rands) + (+ offset (rtlgen/constant-value index)))) + ((rtlgen/indexed-loads? 'WORD) + ;; This allows CSE of the offset-address + (let* ((rand (rtlgen/->register (first rands))) + (index* (rtlgen/->register index)) + (address (rtlgen/new-reg)) + (ptr (rtlgen/new-reg))) + (rtlgen/assign! address `(OBJECT->ADDRESS ,rand)) + (rtlgen/assign! + ptr + `(OFFSET-ADDRESS ,address + (MACHINE-CONSTANT ,offset))) + (rtlgen/value-assignment state + `(OFFSET ,ptr ,index*)))) + (else + (let* ((rand (rtlgen/->register (first rands))) + (index* (rtlgen/->register index)) + (address (rtlgen/new-reg)) + (ptr (rtlgen/new-reg))) + (rtlgen/assign! address `(OBJECT->ADDRESS ,rand)) + (rtlgen/assign! ptr + `(OFFSET-ADDRESS ,address ,index*)) + (rtlgen/value-assignment + state + `(OFFSET ,ptr (MACHINE-CONSTANT ,offset)))))))))))) + (define-indexed-selector 'VECTOR-REF (machine-tag 'VECTOR) 1 2) + (define-indexed-selector '%RECORD-REF (machine-tag 'RECORD) 1 2) + ;; NOTE: This assumes that the result of the following two is always + ;; an object. If it isn't it could be incorrectly preserved, and... + (define-indexed-selector 'SYSTEM-VECTOR-REF false 1 2) + (define-indexed-selector 'PRIMITIVE-OBJECT-REF false 0 2)) + +(define-open-coder/value %heap-closure-ref 3 + (let ((offset (rtlgen/closure-first-offset))) + (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 + (first rands) + (+ offset + (rtlgen/constant-value index)))) + (else + (rtlgen/value-assignment + state + `(OFFSET ,(rtlgen/->register (first rands)) + (MACHINE-CONSTANT + ,(+ offset (rtlgen/constant-value index))))))))))) + +;; NOTE: These do not use rtlgen/assign! because the length field +;; may not be an object, and the preservation code assumes that +;; the OFFSET address syllable always denotes an object. + +(let* ((fixnum-tag (machine-tag 'POSITIVE-FIXNUM)) + (define-fixnumized-selector/tagged + (lambda (name tag off) + tag + (define-open-coder/value name 1 + (lambda (state rands open-coder) + open-coder ; ignored + (let* ((rand (rtlgen/->register (first rands))) + (address (rtlgen/new-reg)) + (field (rtlgen/new-reg)) + (datum (rtlgen/new-reg))) + (rtlgen/assign! address `(OBJECT->ADDRESS ,rand)) + (rtlgen/assign!* + (list + `(ASSIGN ,field (OFFSET ,address (MACHINE-CONSTANT ,off))) + `(ASSIGN ,datum (OBJECT->DATUM ,field)))) + (rtlgen/value-assignment + state + `(CONS-NON-POINTER (MACHINE-CONSTANT ,fixnum-tag) + ,datum))))))) + (define-fixnumized-selector + (lambda (name tag off) + tag + (define-open-coder/value name 1 + (lambda (state rands open-coder) + open-coder ; ignored + (let* ((rand (rtlgen/->register (car rands))) + (address (rtlgen/new-reg)) + (field (rtlgen/new-reg))) + (rtlgen/assign! address `(OBJECT->ADDRESS ,rand)) + (rtlgen/assign! field `(OFFSET ,address (MACHINE-CONSTANT ,off))) + (rtlgen/value-assignment + state + `(CONS-NON-POINTER (MACHINE-CONSTANT ,fixnum-tag) + ,field)))))))) + (define-fixnumized-selector/tagged 'VECTOR-LENGTH (machine-tag 'VECTOR) 0) + (define-fixnumized-selector/tagged '%RECORD-LENGTH (machine-tag 'RECORD) 0) + (define-fixnumized-selector/tagged 'SYSTEM-VECTOR-SIZE false 1) + (define-fixnumized-selector 'STRING-LENGTH (machine-tag 'STRING) 1) + (define-fixnumized-selector 'BIT-STRING-LENGTH (machine-tag 'STRING) 1)) + +(define-open-coder/value 'FLOATING-VECTOR-LENGTH 1 + (let ((factor (rtlgen/fp->words 1)) + (tag (machine-tag 'POSITIVE-FIXNUM))) + (cond ((= factor 1) + (lambda (state rands open-coder) + open-coder ; ignored + (let* ((rand (rtlgen/->register (first rands))) + (address (rtlgen/new-reg)) + (field (rtlgen/new-reg)) + (datum (rtlgen/new-reg))) + (rtlgen/assign!* + (list + `(ASSIGN ,address (OBJECT->ADDRESS ,rand)) + `(ASSIGN ,field (OFFSET ,address (MACHINE-CONSTANT 0))) + `(ASSIGN ,datum (OBJECT->DATUM ,field)))) + (rtlgen/value-assignment + state + `(CONS-NON-POINTER (MACHINE-CONSTANT ,tag) ,datum))))) + ((power-of-two? factor) + => (lambda (shift) + (lambda (state rands open-coder) + open-coder ; ignored + (let* ((rand (rtlgen/->register (first rands))) + (address (rtlgen/new-reg)) + (field (rtlgen/new-reg)) + (datum (rtlgen/new-reg)) + (constant (rtlgen/new-reg)) + (datum2 (rtlgen/new-reg))) + (rtlgen/assign!* + (list + `(ASSIGN ,address (OBJECT->ADDRESS ,rand)) + `(ASSIGN ,field (OFFSET ,address (MACHINE-CONSTANT 0))) + `(ASSIGN ,datum (OBJECT->DATUM ,field)) + `(ASSIGN ,constant (CONSTANT ,(- 0 shift))) + `(ASSIGN ,datum2 (FIXNUM-2-ARGS FIXNUM-LSH ,datum ,constant #F)))) + (rtlgen/value-assignment + state + `(CONS-NON-POINTER (MACHINE-CONSTANT ,tag) ,datum2)))))) + (else + (internal-error + "Floating-point values have unexpected size in words" factor))))) + +(let ((define-fixnum-primitive/1 + (lambda (prim-name operation-name) + (define-open-coder/value prim-name 1 + (lambda (state rands open-coder) + open-coder ; ignored + (let ((rand (rtlgen/->register (first rands)))) + (rtlgen/value-assignment state + `(FIXNUM-1-ARG ,operation-name ,rand #F))))))) + (define-fixnum-primitive/2 + (lambda (prim-name operation-name) + (define-open-coder/value prim-name 2 + (lambda (state rands open-coder) + open-coder ; ignored + (let* ((rand1 (rtlgen/->register (first rands))) + (rand2 (rtlgen/->register (second rands)))) + (rtlgen/value-assignment state + `(FIXNUM-2-ARGS ,operation-name + ,rand1 ,rand2 #F)))))))) + #| DIVIDE-FIXNUM GCD-FIXNUM |# + (define-fixnum-primitive/2 'PLUS-FIXNUM 'PLUS-FIXNUM) + (define-fixnum-primitive/2 'MINUS-FIXNUM 'MINUS-FIXNUM) + (define-fixnum-primitive/2 'MULTIPLY-FIXNUM 'MULTIPLY-FIXNUM) + (define-fixnum-primitive/2 'FIXNUM-QUOTIENT 'FIXNUM-QUOTIENT) + (define-fixnum-primitive/2 'FIXNUM-REMAINDER 'FIXNUM-REMAINDER) + (define-fixnum-primitive/2 'FIXNUM-ANDC 'FIXNUM-ANDC) + (define-fixnum-primitive/2 'FIXNUM-AND 'FIXNUM-AND) + (define-fixnum-primitive/2 'FIXNUM-OR 'FIXNUM-OR) + (define-fixnum-primitive/2 'FIXNUM-XOR 'FIXNUM-XOR) + (define-fixnum-primitive/2 'FIXNUM-LSH 'FIXNUM-LSH) + (define-fixnum-primitive/1 'ONE-PLUS-FIXNUM 'ONE-PLUS-FIXNUM) + (define-fixnum-primitive/1 'MINUS-ONE-PLUS-FIXNUM 'MINUS-ONE-PLUS-FIXNUM) + (define-fixnum-primitive/1 'FIXNUM-NOT 'FIXNUM-NOT)) + +(let ((define-flonum-primitive/1 + (lambda (prim-name operation) + (define-open-coder/value prim-name 1 + (lambda (state rands open-coder) + open-coder ; ignored + (let* ((rand (rtlgen/->register (first rands))) + (flo (rtlgen/new-reg))) + (rtlgen/assign! flo `(OBJECT->FLOAT ,rand)) + (rtlgen/value-assignment + state + `(FLOAT->OBJECT + ,(rtlgen/->register + `(FLONUM-1-ARG ,operation ,flo #F))))))))) + (define-flonum-primitive/2 + (lambda (prim-name operation) + (define-open-coder/value prim-name 2 + (lambda (state rands open-coder) + open-coder ; ignored + (let* ((rand1 (rtlgen/->register (first rands))) + (rand2 (rtlgen/->register (second rands))) + (flo1 (rtlgen/new-reg)) + (flo2 (rtlgen/new-reg))) + (rtlgen/assign! flo1 `(OBJECT->FLOAT ,rand1)) + (rtlgen/assign! flo2 `(OBJECT->FLOAT ,rand2)) + (rtlgen/value-assignment + state + `(FLOAT->OBJECT + ,(rtlgen/->register + `(FLONUM-2-ARGS ,operation ,flo1 ,flo2 #F)))))))))) + + (define-flonum-primitive/1 'FLONUM-ABS 'FLONUM-ABS) + (define-flonum-primitive/1 'FLONUM-ACOS 'FLONUM-ACOS) + (define-flonum-primitive/1 'FLONUM-ASIN 'FLONUM-ASIN) + (define-flonum-primitive/1 'FLONUM-ATAN 'FLONUM-ATAN) + (define-flonum-primitive/1 'FLONUM-CEILING 'FLONUM-CEILING) + (define-flonum-primitive/1 'FLONUM-CEILING->EXACT 'FLONUM-CEILING->EXACT) + (define-flonum-primitive/1 'FLONUM-COS 'FLONUM-COS) + (define-flonum-primitive/1 'FLONUM-EXP 'FLONUM-EXP) + (define-flonum-primitive/1 'FLONUM-FLOOR 'FLONUM-FLOOR) + (define-flonum-primitive/1 'FLONUM-FLOOR->EXACT 'FLONUM-FLOOR->EXACT) + (define-flonum-primitive/1 'FLONUM-LOG 'FLONUM-LOG) + (define-flonum-primitive/1 'FLONUM-NEGATE 'FLONUM-NEGATE) + (define-flonum-primitive/1 'FLONUM-NORMALIZE 'FLONUM-NORMALIZE) + (define-flonum-primitive/1 'FLONUM-ROUND 'FLONUM-ROUND) + (define-flonum-primitive/1 'FLONUM-ROUND->EXACT 'FLONUM-ROUND->EXACT) + (define-flonum-primitive/1 'FLONUM-SIN 'FLONUM-SIN) + (define-flonum-primitive/1 'FLONUM-SQRT 'FLONUM-SQRT) + (define-flonum-primitive/1 'FLONUM-TAN 'FLONUM-TAN) + (define-flonum-primitive/1 'FLONUM-TRUNCATE 'FLONUM-TRUNCATE) + (define-flonum-primitive/1 'FLONUM-TRUNCATE->EXACT 'FLONUM-TRUNCATE->EXACT) + + (define-flonum-primitive/2 'FLONUM-ADD 'FLONUM-ADD) + (define-flonum-primitive/2 'FLONUM-ATAN2 'FLONUM-ATAN2) + (define-flonum-primitive/2 'FLONUM-DENORMALIZE 'FLONUM-DENORMALIZE) + (define-flonum-primitive/2 'FLONUM-DIVIDE 'FLONUM-DIVIDE) + (define-flonum-primitive/2 'FLONUM-EXPT 'FLONUM-EXPT) + (define-flonum-primitive/2 'FLONUM-MULTIPLY 'FLONUM-MULTIPLY) + (define-flonum-primitive/2 'FLONUM-SUBTRACT 'FLONUM-SUBTRACT)) + +(let ((char-tag (machine-tag 'CHARACTER)) + (fixnum-tag (machine-tag 'POSITIVE-FIXNUM))) + (let ((define-datum-conversion + (lambda (name output-tag) + (define-open-coder/value name 1 + (lambda (state rands open-coder) + open-coder ; ignored + (let* ((rand* (rtlgen/->register (first rands))) + (temp (rtlgen/new-reg))) + (rtlgen/assign! temp `(OBJECT->DATUM ,rand*)) + (rtlgen/value-assignment + state + `(CONS-NON-POINTER (MACHINE-CONSTANT ,output-tag) + ,temp))))))) + + (define-masked-datum-conversion + (lambda (name mask) + (define-open-coder/value name 1 + (lambda (state rands open-coder) + open-coder ; ignored + (let* ((rand* (rtlgen/->register (first rands))) + (temp (rtlgen/new-reg)) + (mask-reg (rtlgen/new-reg)) + (masked (rtlgen/new-reg))) + (rtlgen/assign!* + `((ASSIGN ,temp (OBJECT->DATUM ,rand*)) + (ASSIGN ,mask-reg (CONSTANT ,mask)) + (ASSIGN ,masked + (FIXNUM-2-ARGS FIXNUM-AND ,temp ,mask-reg #F)))) + (rtlgen/value-assignment + state + `(CONS-NON-POINTER (MACHINE-CONSTANT ,fixnum-tag) + ,masked)))))))) + + (define-datum-conversion 'INTEGER->CHAR char-tag) + (define-datum-conversion 'ASCII->CHAR char-tag) + (define-masked-datum-conversion 'CHAR->ASCII #xff) + (define-masked-datum-conversion 'CHAR-CODE #x7f) + (define-datum-conversion 'CHAR->INTEGER fixnum-tag))) + +(let* ((off (rtlgen/words->chars 2)) + (define-string-reference + (lambda (name tag) + (define-open-coder/value name 2 + (lambda (state rands open-coder) + open-coder ; ignored + (let* ((index (second rands)) + (rand (rtlgen/->register (first rands))) + (address (rtlgen/new-reg)) + (byte (rtlgen/new-reg))) + (rtlgen/assign! address `(OBJECT->ADDRESS ,rand)) + (cond ((rtlgen/constant? index) + (let ((index* (rtlgen/constant-value index))) + (rtlgen/assign! byte + `(BYTE-OFFSET ,address + (MACHINE-CONSTANT + ,(+ off index*)))))) + ((rtlgen/indexed-loads? 'BYTE) + (let* ((index* (rtlgen/->register index)) + (ptr (rtlgen/new-reg))) + (rtlgen/assign! + ptr + `(BYTE-OFFSET-ADDRESS ,address + (MACHINE-CONSTANT ,off))) + (rtlgen/assign! byte `(BYTE-OFFSET ,ptr ,index*)))) + (else + (let* ((index* (rtlgen/->register index)) + (ptr (rtlgen/new-reg))) + (rtlgen/assign! + ptr + `(BYTE-OFFSET-ADDRESS ,address ,index*)) + (rtlgen/assign! + byte + `(BYTE-OFFSET ,ptr + (MACHINE-CONSTANT ,off)))))) + (rtlgen/value-assignment + state + `(CONS-NON-POINTER (MACHINE-CONSTANT ,tag) ,byte)))))))) + (define-string-reference 'VECTOR-8B-REF (machine-tag 'POSITIVE-FIXNUM)) + (define-string-reference 'STRING-REF (machine-tag 'CHARACTER))) + +(define-open-coder/value 'FLOATING-VECTOR-REF 2 + (let ((factor (rtlgen/fp->words 1))) + (if (= factor 1) + (lambda (state rands open-coder) + open-coder ; ignored + (let* ((index (second rands)) + (rand (rtlgen/->register (first rands))) + (address (rtlgen/new-reg)) + (float (rtlgen/new-reg))) + (rtlgen/assign! address `(OBJECT->ADDRESS ,rand)) + (cond ((rtlgen/constant? index) + (let ((index* (rtlgen/constant-value index))) + (rtlgen/assign! float + `(FLOAT-OFFSET ,address + (MACHINE-CONSTANT + ,(+ 1 index*)))))) + ((rtlgen/indexed-loads? 'FLOAT) + (let* ((index* (rtlgen/->register index)) + (ptr (rtlgen/new-reg))) + (rtlgen/assign! + ptr + `(FLOAT-OFFSET-ADDRESS ,address (MACHINE-CONSTANT 1))) + (rtlgen/assign! float `(FLOAT-OFFSET ,ptr ,index*)))) + (else + (let* ((index* (rtlgen/->register index)) + (ptr (rtlgen/new-reg))) + (rtlgen/assign! + ptr + `(FLOAT-OFFSET-ADDRESS ,address ,index*)) + (rtlgen/assign! + float + `(FLOAT-OFFSET ,ptr (MACHINE-CONSTANT 1)))))) + (rtlgen/value-assignment state `(FLOAT->OBJECT ,float)))) + (lambda (state rands open-coder) + open-coder ; ignored + (let* ((index (second rands)) + (rand (rtlgen/->register (first rands))) + (address (rtlgen/new-reg)) + (ptr (rtlgen/new-reg)) + (float (rtlgen/new-reg))) + (rtlgen/assign! address `(OBJECT->ADDRESS ,rand)) + (rtlgen/assign! ptr `(OFFSET-ADDRESS ,address (MACHINE-CONSTANT 1))) + (cond ((rtlgen/constant? index) + (let ((index* (rtlgen/constant-value index))) + (rtlgen/assign! + float + `(FLOAT-OFFSET ,ptr (MACHINE-CONSTANT ,index*))))) + ((rtlgen/indexed-loads? 'FLOAT) + (let ((index* (rtlgen/->register index))) + (rtlgen/assign! float `(FLOAT-OFFSET ,ptr ,index*)))) + (else + (let* ((index* (rtlgen/->register index)) + (ptr2 (rtlgen/new-reg))) + (rtlgen/assign! ptr2 + `(FLOAT-OFFSET-ADDRESS ,ptr ,index*)) + (rtlgen/assign! + float + `(FLOAT-OFFSET ,ptr2 (MACHINE-CONSTANT 0)))))) + (rtlgen/value-assignment state `(FLOAT->OBJECT ,float))))))) + +(define (rtlgen/fixed-mutation rands offset) + (let* ((rand (rtlgen/->register (first rands))) + (value (rtlgen/->register (second rands))) + (address (rtlgen/new-reg))) + (rtlgen/assign! address `(OBJECT->ADDRESS ,rand)) + (rtlgen/emit!/1 + `(ASSIGN (OFFSET ,address (MACHINE-CONSTANT ,offset)) + ,value)))) + +(define-open-coder/stmt %variable-cell-set! 2 + (lambda (state rands open-coder) + state open-coder ; ignored + (let* ((cell (rtlgen/->register (first rands))) + (value (rtlgen/->register (second rands)))) + (rtlgen/emit!/1 `(ASSIGN (OFFSET ,cell (MACHINE-CONSTANT 0)) + ,value))))) + +(define-open-coder/stmt %static-binding-set! 3 + (lambda (state rands open-coder) + state open-coder ; ignored + (let ((name (third rands))) + (if (not (rtlgen/constant? name)) + (internal-error "Unexpected name to static-binding-set!" name)) + (let ((cell (rtlgen/->register + `(STATIC-CELL ,(rtlgen/constant-value name)))) + (value (rtlgen/->register (second rands)))) + (rtlgen/emit!/1 + `(ASSIGN (OFFSET ,cell (MACHINE-CONSTANT 0)) ,value)))))) + +(let ((define-fixed-mutator + (lambda (name tag offset arity) + tag ; unused + (define-open-coder/stmt name arity + (lambda (state rands open-coder) + state open-coder ; ignored + (rtlgen/fixed-mutation rands offset)))))) + (define-fixed-mutator 'SET-CELL-CONTENTS! (machine-tag 'CELL) 0 2) + (define-fixed-mutator %cell-set! (machine-tag 'CELL) 0 3) + (define-fixed-mutator 'SET-CAR! (machine-tag 'PAIR) 0 2) + (define-fixed-mutator 'SET-CDR! (machine-tag 'PAIR) 1 2) + (define-fixed-mutator 'SET-STRING-LENGTH! (machine-tag 'STRING) 1 2)) + +(let ((define-indexed-mutator + (lambda (name tag offset arity) + tag ; unused + (define-open-coder/stmt name arity + (lambda (state rands open-coder) + state open-coder ; ignored + (let ((index (second rands))) + (cond ((rtlgen/constant? index) + (rtlgen/fixed-mutation + (list (first rands) (third rands)) + (+ offset (rtlgen/constant-value index)))) + ((rtlgen/indexed-stores? 'WORD) + (let* ((rand (rtlgen/->register (first rands))) + (index* (rtlgen/->register index)) + (value (rtlgen/->register (third rands))) + (address (rtlgen/new-reg)) + (ptr (rtlgen/new-reg))) + (rtlgen/assign! address `(OBJECT->ADDRESS ,rand)) + (rtlgen/assign! + ptr + `(OFFSET-ADDRESS ,address + (MACHINE-CONSTANT ,offset))) + (rtlgen/emit!/1 + `(ASSIGN (OFFSET ,ptr ,index*) ,value)))) + (else + (let* ((rand (rtlgen/->register (first rands))) + (index* (rtlgen/->register index)) + (value (rtlgen/->register (third rands))) + (address (rtlgen/new-reg)) + (ptr (rtlgen/new-reg))) + (rtlgen/assign! address `(OBJECT->ADDRESS ,rand)) + (rtlgen/assign! ptr + `(OFFSET-ADDRESS ,address ,index*)) + (rtlgen/emit!/1 + `(ASSIGN (OFFSET ,ptr (MACHINE-CONSTANT ,offset)) + ,value))))))))))) + (define-indexed-mutator 'VECTOR-SET! (machine-tag 'VECTOR) 1 3) + (define-indexed-mutator '%RECORD-SET! (machine-tag 'RECORD) 1 3) + (define-indexed-mutator 'PRIMITIVE-OBJECT-SET! false 0 3)) + +(define-open-coder/stmt %heap-closure-set! 4 + (let ((offset (rtlgen/closure-first-offset))) + (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)))))))))) + +(let* ((off (rtlgen/words->chars 2)) + (define-string-mutation + (lambda (name) + (define-open-coder/stmt name 3 + (lambda (state rands open-coder) + state open-coder ; ignored + (let* ((index (second rands)) + (rand (rtlgen/->register (first rands))) + (address (rtlgen/new-reg)) + (value (rtlgen/->register (third rands))) + (byte (rtlgen/new-reg))) + (rtlgen/assign! address `(OBJECT->ADDRESS ,rand)) + (rtlgen/assign! byte `(OBJECT->DATUM ,value)) + (cond ((rtlgen/constant? index) + (let* ((index* (rtlgen/constant-value index))) + (rtlgen/emit!/1 + `(ASSIGN (BYTE-OFFSET ,address + (MACHINE-CONSTANT + ,(+ off index*))) + ,byte)))) + ((rtlgen/indexed-stores? 'BYTE) + (let* ((index* (rtlgen/->register index)) + (ptr (rtlgen/new-reg))) + (rtlgen/assign! + ptr + `(BYTE-OFFSET-ADDRESS ,address + (MACHINE-CONSTANT ,off))) + (rtlgen/emit!/1 + `(ASSIGN (BYTE-OFFSET ,ptr ,index*) ,byte)))) + (else + (let* ((index* (rtlgen/->register index)) + (ptr (rtlgen/new-reg))) + (rtlgen/assign! + ptr + `(BYTE-OFFSET-ADDRESS ,address ,index*)) + (rtlgen/emit!/1 + `(ASSIGN (BYTE-OFFSET ,ptr (MACHINE-CONSTANT ,off)) + ,byte))))))))))) + (define-string-mutation 'VECTOR-8B-SET!) + (define-string-mutation 'STRING-SET!)) + +(define-open-coder/stmt 'FLOATING-VECTOR-SET! 3 + (let ((factor (rtlgen/fp->words 1))) + (if (= factor 1) + (lambda (state rands open-coder) + state open-coder ; ignored + (let* ((index (second rands)) + (rand (rtlgen/->register (first rands))) + (address (rtlgen/new-reg)) + (value (rtlgen/->register (third rands))) + (float (rtlgen/new-reg))) + (rtlgen/assign! address `(OBJECT->ADDRESS ,rand)) + (rtlgen/assign! float `(OBJECT->FLOAT ,value)) + (cond ((rtlgen/constant? index) + (let ((index* (rtlgen/constant-value index))) + (rtlgen/emit!/1 + `(ASSIGN (FLOAT-OFFSET ,address + (MACHINE-CONSTANT ,(+ 1 index*))) + ,float)))) + ((rtlgen/indexed-stores? 'FLOAT) + (let* ((index* (rtlgen/->register index)) + (ptr (rtlgen/new-reg))) + (rtlgen/assign! + ptr + `(FLOAT-OFFSET-ADDRESS ,address (MACHINE-CONSTANT 1))) + (rtlgen/emit!/1 + `(ASSIGN (FLOAT-OFFSET ,ptr ,index*) ,float)))) + (else + (let* ((index* (rtlgen/->register index)) + (ptr (rtlgen/new-reg))) + (rtlgen/assign! ptr + `(FLOAT-OFFSET-ADDRESS ,address ,index*)) + (rtlgen/emit!/1 + `(ASSIGN (FLOAT-OFFSET ,ptr (MACHINE-CONSTANT 1)) + ,float))))))) + (lambda (state rands open-coder) + state open-coder ; ignored + (let* ((index (second rands)) + (rand (rtlgen/->register (first rands))) + (address (rtlgen/new-reg)) + (ptr (rtlgen/new-reg)) + (value (rtlgen/->register (third rands))) + (float (rtlgen/new-reg))) + (rtlgen/assign! address `(OBJECT->ADDRESS ,rand)) + (rtlgen/assign! ptr `(OFFSET-ADDRESS ,address + (MACHINE-CONSTANT 1))) + (rtlgen/assign! float `(OBJECT->FLOAT ,value)) + (cond ((rtlgen/constant? index) + (let ((index* (rtlgen/constant-value index))) + (rtlgen/emit!/1 + `(ASSIGN (FLOAT-OFFSET ,ptr + (MACHINE-CONSTANT ,index*)) + ,float)))) + ((rtlgen/indexed-stores? 'FLOAT) + (let ((index* (rtlgen/->register index))) + (rtlgen/emit!/1 + `(ASSIGN (FLOAT-OFFSET ,ptr ,index*) ,float)))) + (else + (let* ((index* (rtlgen/->register index)) + (ptr2 (rtlgen/new-reg))) + (rtlgen/assign! ptr2 + `(FLOAT-OFFSET-ADDRESS ,ptr ,index*)) + (rtlgen/emit!/1 + `(ASSIGN (FLOAT-OFFSET ,ptr2 (MACHINE-CONSTANT 0)) + ,float)))))))))) + +;;;; Miscellaneous system primitives + +(define-open-coder/pred 'HEAP-AVAILABLE? 1 + (lambda (state rands open-coder) + open-coder ; ignored + (let* ((free (rtlgen/reference-to-free)) + (memtop (rtlgen/->register (rtlgen/fetch-memtop))) + (rand (rtlgen/->register (first rands))) + (temp1 (rtlgen/new-reg)) + (temp2 (rtlgen/new-reg))) + (rtlgen/assign!* + `((ASSIGN ,temp1 (OBJECT->DATUM ,rand)) + (ASSIGN ,temp2 (OFFSET-ADDRESS ,free ,temp1)))) + (rtlgen/branch/likely + state + `(FIXNUM-PRED-2-ARGS LESS-THAN-FIXNUM? ,temp2 ,memtop))))) + +(define-open-coder/value 'PRIMITIVE-GET-FREE 1 + (lambda (state rands open-coder) + open-coder ; ignored + (let* ((free (rtlgen/reference-to-free)) + (rand (rtlgen/->register (first rands))) + (temp (rtlgen/new-reg))) + (rtlgen/assign! temp `(OBJECT->DATUM ,rand)) + (rtlgen/value-assignment state `(CONS-POINTER ,temp ,free))))) + +(define-open-coder/stmt 'PRIMITIVE-INCREMENT-FREE 1 + (lambda (state rands open-coder) + state open-coder ; ignored + (let* ((free (rtlgen/reference-to-free)) + (rand (rtlgen/->register (first rands))) + (temp (rtlgen/new-reg))) + (rtlgen/assign!* + `((ASSIGN ,temp (OBJECT->DATUM ,rand)) + (ASSIGN ,free (OFFSET-ADDRESS ,free ,temp))))))) + +(define-open-coder/value 'GET-INTERRUPT-ENABLES 0 + (let ((tag (machine-tag 'POSITIVE-FIXNUM))) + (lambda (state rands open-coder) + open-coder rands ; ignored + (let ((int-mask (rtlgen/->register (rtlgen/fetch-int-mask)))) + (rtlgen/value-assignment + state + `(CONS-NON-POINTER (MACHINE-CONSTANT ,tag) ,int-mask)))))) + +(define-open-coder/value %fetch-environment 0 + (lambda (state rands open-coder) + rands open-coder ; ignored + (rtlgen/value-assignment state (rtlgen/fetch-environment)))) + +;;;; Out of line hooks + +(let ((define-out-of-line-primitive + (lambda (operator prim-name arity) + (let ((primitive (make-primitive-procedure prim-name))) + (define-open-coder/out-of-line operator arity + (lambda (cont-label open-coder) + open-coder ; ignored + (rtlgen/emit!/1 + `(INVOCATION:SPECIAL-PRIMITIVE ,(+ arity 1) + ,cont-label + ,primitive)))))))) + (define-out-of-line-primitive %+ '&+ 2) + (define-out-of-line-primitive %- '&- 2) + (define-out-of-line-primitive %* '&* 2) + (define-out-of-line-primitive %/ '&/ 2) + (define-out-of-line-primitive %quotient 'QUOTIENT 2) + (define-out-of-line-primitive %remainder 'REMAINDER 2) + (define-out-of-line-primitive %= '&= 2) + (define-out-of-line-primitive %< '&< 2) + (define-out-of-line-primitive %> '&> 2) + (define-out-of-line-primitive %string-allocate 'STRING-ALLOCATE 1) + (define-out-of-line-primitive %floating-vector-cons 'FLOATING-VECTOR-CONS 1) + (define-out-of-line-primitive %vector-cons 'VECTOR-CONS 2)) + +(let ((define-variable-ref + (lambda (operator safe?) + (define-open-coder/special operator 1 + (lambda (cont-label rands open-coder) + open-coder ; ignored + (let ((cell (rtlgen/->register (first rands))) + (cell-loc (rtlgen/interpreter-call/argument-home 1))) + (rtlgen/assign!* + (list `(ASSIGN ,cell-loc ,cell) + `(INTERPRETER-CALL:CACHE-REFERENCE ,cont-label + ,cell-loc + ,safe?))))))))) + (define-variable-ref %hook-variable-cell-ref false) + (define-variable-ref %hook-safe-variable-cell-ref true)) + +(define-open-coder/special %hook-variable-cell-set! 2 + (lambda (cont-label rands open-coder) + open-coder ; ignored + (let ((cell (rtlgen/->register (first rands))) + (value (rtlgen/->register (second rands))) + (cell-loc (rtlgen/interpreter-call/argument-home 1)) + (value-loc (rtlgen/interpreter-call/argument-home 2))) + (rtlgen/assign!* + (list `(ASSIGN ,value-loc ,value) + `(ASSIGN ,cell-loc ,cell) + `(INTERPRETER-CALL:CACHE-ASSIGNMENT ,cont-label + ,cell-loc + ,value-loc)))))) + +(let ((unexpected + (lambda all + (let ((open-coder (car (last-pair all)))) + (internal-error "Unexpected operator" + (rtlgen/open-coder/rator open-coder)))))) + + (for-each + (lambda (operation) + (define-open-coder operation false + unexpected unexpected unexpected unexpected unexpected)) + ;; These are rewritten by earlier stages or handled specially. + ;; They should never be found. + (list %vector-index %variable-cache-ref %variable-cache-set! + %safe-variable-cache-ref %stack-closure-ref + %internal-apply %primitive-apply %invoke-continuation + %invoke-operator-cache %invoke-remote-cache + %make-read-variable-cache %make-write-variable-cache + %make-operator-variable-cache %fetch-continuation + %fetch-stack-closure %make-stack-closure + %*define %execute %*define* %*make-environment + %copy-program %*lookup %*set! %*unassigned? + ;; Replaced for compatibility + %make-heap-closure %make-trivial-closure))) + +#| +;; Missing: + +'SET-INTERRUPT-ENABLES! +|# + +;;;; Patterns + +(define rtlgen/?lambda-list (->pattern-variable 'LAMBDA-LIST)) +(define rtlgen/?frame-var (->pattern-variable 'FRAME-VAR)) +(define rtlgen/?frame-vector (->pattern-variable 'FRAME-VECTOR)) +(define rtlgen/?frame-vector* (->pattern-variable 'FRAME-VECTOR*)) +(define rtlgen/?continuation-body (->pattern-variable 'CONTINUATION-BODY)) +(define rtlgen/?rator (->pattern-variable 'RATOR)) +(define rtlgen/?return-address (->pattern-variable 'RETURN-ADDRESS)) +(define rtlgen/?closure-elts (->pattern-variable 'CLOSURE-ELTS)) +(define rtlgen/?closure-elts* (->pattern-variable 'CLOSURE-ELTS*)) +(define rtlgen/?rands (->pattern-variable 'RANDS)) +(define rtlgen/?cont-name (->pattern-variable 'CONT-NAME)) +(define rtlgen/?env-name (->pattern-variable 'ENV-NAME)) +(define rtlgen/?body (->pattern-variable 'BODY)) +(define rtlgen/?closed-vars (->pattern-variable 'CLOSED-VARS)) +(define rtlgen/?closed-over-env-var + (->pattern-variable 'CLOSED-OVER-ENV-VAR)) + +(define rtlgen/?closure-name (->pattern-variable 'CLOSURE-NAME)) +(define rtlgen/?offset (->pattern-variable 'OFFSET)) +(define rtlgen/?var-name (->pattern-variable 'VAR-NAME)) + +(define rtlgen/?lambda-expression (->pattern-variable 'LAMBDA-EXPRESSION)) + +(define rtlgen/continuation-pattern + `(LAMBDA ,rtlgen/?lambda-list + (LET ((,rtlgen/?frame-var + (CALL (QUOTE ,%fetch-stack-closure) + (QUOTE #F) + (QUOTE ,rtlgen/?frame-vector)))) + ,rtlgen/?continuation-body))) + +(define rtlgen/stack-overwrite-pattern + `(CALL (QUOTE ,%stack-closure-ref) + (QUOTE #F) + (LOOKUP ,rtlgen/?closure-name) + (QUOTE ,rtlgen/?offset) + (QUOTE ,rtlgen/?var-name))) + +(define rtlgen/outer-expression-pattern + `(LAMBDA (,rtlgen/?cont-name ,rtlgen/?env-name) + ,rtlgen/?body)) + +(define rtlgen/top-level-trivial-closure-pattern + `(CALL (QUOTE ,%invoke-continuation) + (LOOKUP ,rtlgen/?cont-name) + (CALL (QUOTE ,%make-trivial-closure) + (QUOTE #F) + ,rtlgen/?lambda-expression))) + +(define rtlgen/top-level-heap-closure-pattern + `(CALL (QUOTE ,%invoke-continuation) + (LOOKUP ,rtlgen/?cont-name) + (CALL (QUOTE ,%make-heap-closure) + (QUOTE #F) + ,rtlgen/?lambda-expression + ,rtlgen/?closed-vars + ,rtlgen/?closed-over-env-var))) + +(define rtlgen/extended-call-pattern + `(CALL (LAMBDA (,rtlgen/?cont-name) + (CALL (QUOTE ,rtlgen/?rator) + (CALL (QUOTE ,%make-stack-closure) + (QUOTE #F) + (QUOTE #F) + (QUOTE ,rtlgen/?frame-vector*) + (LOOKUP ,rtlgen/?cont-name) + ,@rtlgen/?closure-elts*) + ,@rtlgen/?rands)) + (CALL (QUOTE ,%make-stack-closure) + (QUOTE #F) + ,rtlgen/?return-address + (QUOTE ,rtlgen/?frame-vector) + ,@rtlgen/?closure-elts))) + +(define rtlgen/make-stack-closure-handler-pattern + `(CALL ',%make-stack-closure + '#F + ,rtlgen/?lambda-expression + (QUOTE ,rtlgen/?frame-vector*) + ,rtlgen/?return-address + ,@rtlgen/?closure-elts*)) + +(define rtlgen/lambda-expr-pattern + `(LAMBDA ,rtlgen/?lambda-list ,rtlgen/?body)) + +(define rtlgen/call-lambda-with-stack-closure-pattern + `(CALL (LAMBDA (,rtlgen/?cont-name) ,rtlgen/?body) + (CALL ',%make-stack-closure + '#F + ,rtlgen/?lambda-expression + (QUOTE ,rtlgen/?frame-vector*) + ,rtlgen/?return-address + ,@rtlgen/?closure-elts*))) + + +#| +;; New RTL: + +(INVOCATION:REGISTER 0 #F (REGISTER n) #F (MACHINE-CONSTANT nregs)) +(INVOCATION:PROCEDURE 0 cont-label label (MACHINE-CONSTANT nregs)) +;; if cont-label is not false, this is expected to set up the +;; continuation in the standard location (register or top of stack) + +(INVOCATION:NEW-APPLY + frame-size cont-label (REGISTER dest) (MACHINE-CONSTANT nregs)) +;; if cont-label is not false, this is expected to set up the +;; continuation in the standard location (register or top of stack) + +(RETURN-ADDRESS label (MACHINE-CONSTANT n) (MACHINE-CONSTANT m)) + n --> number of items saved on the stack + m --> arity +(PROCEDURE label (MACHINE-CONSTANT frame-size)) +(TRIVIAL-CLOSURE label (MACHINE-CONSTANT min) (MACHINE-CONSTANT max)) +(CLOSURE label (MACHINE-CONSTANT n)) +(EXPRESSION label) + +(INTERRUPT-CHECK:CLOSURE intrpt? heap? stack? (MACHINE-CONSTANT fs)) +(INTERRUPT-CHECK:PROCEDURE intrpt? heap? stack? label (MACHINE-CONSTANT fs)) +(INTERRUPT-CHECK:CONTINUATION intrpt? heap? stack? label (MACHINE-CONSTANT fs)) +;; fs is the frame size, including the continuation and the +;; self-reference (heap closures only) + +(ASSIGN (REGISTER n) (ALIGN-FLOAT (REGISTER m))) ; float alignment +(ASSIGN (REGISTER n) (STATIC-CELL name)) ; static binding +(ASSIGN (REGISTER n) ; type & range check + (PRED-2-ARGS SMALL-FIXNUM? + (REGISTER m) + (MACHINE-CONSTANT nbits))) +(PRESERVE (REGISTER n) ) +(RESTORE (REGISTER m) ) + +;; where how is one of SAVE, IF-AVAILABLE, and RECOMPUTE + +|# diff --git a/v8/src/compiler/midend/simplify.scm b/v8/src/compiler/midend/simplify.scm new file mode 100644 index 000000000..0c617db70 --- /dev/null +++ b/v8/src/compiler/midend/simplify.scm @@ -0,0 +1,473 @@ +#| -*-Scheme-*- + +$Id: simplify.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Substitute simple and used-only-once parameters +;;; package: (compiler midend) + +(declare (usual-integrations)) + +(define (simplify/top-level program) + (simplify/expr #F program)) + +(define-macro (define-simplifier keyword bindings . body) + (let ((proc-name (symbol-append 'SIMPLIFY/ keyword))) + (call-with-values + (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form))) + (lambda (names code) + `(define ,proc-name + (let ((handler (lambda ,(cons (car bindings) names) ,@body))) + (named-lambda (,proc-name env form) + (simplify/remember ,code + form)))))))) + +(define-simplifier LOOKUP (env name) + (let ((ref `(LOOKUP ,name))) + (simplify/lookup*! env name ref #T))) + +(define-simplifier LAMBDA (env lambda-list body) + `(LAMBDA ,lambda-list + ,(simplify/expr + (simplify/env/make env + (lmap simplify/binding/make (lambda-list->names lambda-list))) + body))) + +(define-simplifier QUOTE (env object) + env ; ignored + `(QUOTE ,object)) + +(define-simplifier DECLARE (env #!rest anything) + env ; ignored + `(DECLARE ,@anything)) + +(define-simplifier BEGIN (env #!rest actions) + `(BEGIN ,@(simplify/expr* env actions))) + +(define-simplifier IF (env pred conseq alt) + `(IF ,(simplify/expr env pred) + ,(simplify/expr env conseq) + ,(simplify/expr env alt))) + +(define (do-simplification env mutually-recursive? bindings body continue) + ;; BINDINGS is a list of triples: (environment name expression) + ;; where ENVIRONMENT is either #F or the environment for the lambda + ;; expression bound to this name + (define unsafe-cyclic-reference? + (if mutually-recursive? + (let ((finder (association-procedure eq? second))) + (make-breaks-cycle? (map second bindings) + (lambda (name) + (let* ((triple (finder name bindings)) + (env (first triple))) + (if env + (simplify/env/free-calls env) + '()))))) + (lambda (lambda-expr) lambda-expr #F))) + + (simplify/bindings env unsafe-cyclic-reference? + (simplify/delete-parameters env bindings + unsafe-cyclic-reference?) + body continue)) + +(define-simplifier CALL (env rator cont #!rest rands) + (define (do-ops rator*) + `(CALL ,rator* + ,(simplify/expr env cont) + ,@(simplify/expr* env rands))) + + (cond ((LOOKUP/? rator) + (let* ((name (lookup/name rator)) + (rator* (simplify/remember `(LOOKUP ,name) rator)) + (result (do-ops rator*))) + (simplify/lookup*! env name result #F))) + ((LAMBDA/? rator) + (guarantee-simple-lambda-list (lambda/formals rator)) ;Miller & Adams + (let* ((lambda-list (lambda/formals rator)) + (env0 (simplify/env/make env + (lmap simplify/binding/make lambda-list))) + (body* (simplify/expr env0 (caddr rator))) + (bindings* (map (lambda (name value) + (simplify/binding&value env name value)) + lambda-list + (cons cont rands)))) + (do-simplification env0 #F bindings* body* + (lambda (bindings* body*) + (simplify/pseudo-letify rator bindings* body*))))) + (else + (do-ops (simplify/expr env rator))))) + +(define-simplifier LET (env bindings body) + (let* ((env0 (simplify/env/make env + (lmap (lambda (binding) (simplify/binding/make (car binding))) + bindings))) + (body* (simplify/expr env0 body)) + (bindings* + (lmap (lambda (binding) + (simplify/binding&value env (car binding) (cadr binding))) + bindings))) + (do-simplification env0 #F bindings* body* simplify/letify))) + +(define-simplifier LETREC (env bindings body) + (let* ((env0 (simplify/env/make env + (lmap (lambda (binding) (simplify/binding/make (car binding))) + bindings))) + (body* (simplify/expr env0 body)) + (bindings* + (lmap (lambda (binding) + (simplify/binding&value env0 (car binding) (cadr binding))) + bindings))) + (do-simplification env0 #T bindings* body* simplify/letrecify))) + +(define (simplify/binding&value env name value) + (if (not (LAMBDA/? value)) + (list false name (simplify/expr env value)) + (let* ((lambda-list (lambda/formals value)) + (env1 (simplify/env/make env + (lmap simplify/binding/make + (lambda-list->names lambda-list))))) + (let ((value* + `(LAMBDA ,lambda-list + ,(simplify/expr env1 (lambda/body value))))) + (list env1 name (simplify/remember value* value)))))) + +(define (simplify/delete-parameters env0 bindings unsafe-cyclic-reference?) + ;; ENV0 is the current environment frame + ;; BINDINGS is parallel to that, but is a list of + ;; (frame* name expression) triplet lists as returned by + ;; simplify/binding&value, where frame* is either #F or the frame + ;; for the LAMBDA expression that is bound to this name + (for-each + (lambda (bnode triplet) + (let ((env1 (first triplet)) + (name (second triplet)) + (value (third triplet))) + (and env1 + (null? (simplify/binding/ordinary-refs bnode)) + (not (null? (simplify/binding/operator-refs bnode))) + ;; Don't bother if it will be open coded + (not (null? (cdr (simplify/binding/operator-refs bnode)))) + (not (simplify/open-code? name value unsafe-cyclic-reference?)) + ;; At this point, env1 and triplet represent a LAMBDA + ;; expression to which there are no regular references and + ;; which will not be open coded. We consider altering its + ;; formal parameter list. + (let ((unrefd + (list-transform-positive (simplify/env/bindings env1) + (lambda (bnode*) + (and (null? (simplify/binding/ordinary-refs bnode*)) + (null? (simplify/binding/operator-refs bnode*)) + (not (continuation-variable? + (simplify/binding/name bnode*)))))))) + (and (not (null? unrefd)) + (for-each (lambda (unrefd) + (simplify/maybe-delete unrefd + bnode + (caddr triplet))) + unrefd)))))) + (simplify/env/bindings env0) + bindings) + (lmap cdr bindings)) + +(define (simplify/maybe-delete unrefd bnode form) + (let ((position (simplify/operand/position unrefd form)) + (operator-refs (simplify/binding/operator-refs bnode))) + (and (positive? position) ; continuation/ignore must remain + (if (for-all? operator-refs + (lambda (call) + (simplify/deletable-operand? call position))) + (begin + (for-each + (lambda (call) + (simplify/delete-operand! call position)) + operator-refs) + (simplify/delete-parameter! form position)))))) + +(define (simplify/operand/position bnode* form) + (let ((name (simplify/binding/name bnode*))) + (let loop ((ll (cadr form)) + (index 0)) + (cond ((null? ll) + (internal-error "Missing operand" name form)) + ((eq? name (car ll)) index) + ((or (eq? (car ll) '#!OPTIONAL) + (eq? (car ll) '#!REST)) + -1) + (else + (loop (cdr ll) (+ index 1))))))) + +(define (simplify/deletable-operand? call position) + (let loop ((rands (call/cont-and-operands call)) + (position position)) + (and (not (null? rands)) + (if (zero? position) + (form/simple&side-effect-free? (car rands)) + (loop (cdr rands) (- position 1)))))) + +(define (simplify/delete-operand! call position) + (form/rewrite! + call + `(CALL ,(call/operator call) + ,@(list-delete/index (call/cont-and-operands call) position)))) + +(define (simplify/delete-parameter! form position) + (set-car! (cdr form) + (list-delete/index (cadr form) position))) + +(define (list-delete/index l index) + (let loop ((l l) + (index index) + (accum '())) + (if (zero? index) + (append (reverse accum) (cdr l)) + (loop (cdr l) + (- index 1) + (cons (car l) accum))))) + +(define (simplify/bindings env0 unsafe-cyclic-reference? bindings body letify) + ;; ENV0 is the current environment frame + ;; BINDINGS is parallel to that, but is a list of + ;; (name expression) two-lists as returned by + ;; simplify/delete-parameters + (let* ((frame-bindings (simplify/env/bindings env0)) + (unused + (list-transform-positive frame-bindings + (lambda (binding) + (and (null? (simplify/binding/ordinary-refs binding)) + (null? (simplify/binding/operator-refs binding))))))) + (call-with-values + (lambda () + (list-split unused + (lambda (binding) + (let* ((place (assq (simplify/binding/name binding) + bindings))) + (form/simple&side-effect-free? (cadr place)))))) + (lambda (simple-unused hairy-unused) + ;; simple-unused can be flushed, since they have no side effects + (let ((bindings* (delq* (lmap (lambda (simple) + (assq (simplify/binding/name simple) + bindings)) + simple-unused) + bindings)) + (not-simple-unused (delq* simple-unused frame-bindings))) + (if (or (not (eq? *order-of-argument-evaluation* 'ANY)) + (null? hairy-unused)) + (let ((new-env + (simplify/env/modified-copy env0 not-simple-unused))) + (simplify/bindings* new-env bindings* unsafe-cyclic-reference? body letify)) + (let ((hairy-bindings + (lmap (lambda (hairy) + (assq (simplify/binding/name hairy) + bindings*)) + hairy-unused)) + (used-bindings (delq* hairy-unused not-simple-unused))) + (beginnify + (append + (map cadr hairy-bindings) + (list + (let ((new-env (simplify/env/modified-copy env0 used-bindings))) + (simplify/bindings* new-env (delq* hairy-bindings bindings*) + unsafe-cyclic-reference? body letify)))))))))))) + +(define (simplify/bindings* env0 bindings unsafe-cyclic-reference? body letify) + ;; ENV0 is the current environment frame, as simplified by simplify/bindings + ;; BINDINGS is parallel to that, but is a list of + ;; (name expression) two-lists as returned by + ;; simplify/delete-parameters + (let* ((frame-bindings (simplify/env/bindings env0)) + (to-substitute + (list-transform-positive frame-bindings + (lambda (node) + (let* ((name (simplify/binding/name node)) + (value (second (assq name bindings)))) + (and (pair? value) + (let ((ordinary (simplify/binding/ordinary-refs node)) + (operator (simplify/binding/operator-refs node))) + (if (LAMBDA/? value) + (or (and (null? ordinary) + (or (null? (cdr operator)) + (simplify/open-code? + name value unsafe-cyclic-reference?))) + (and (null? operator) + (null? (cdr ordinary)))) + (and (= (+ (length ordinary) (length operator)) 1) + (simplify/substitute? value body)))))))))) + (for-each + (lambda (node) + (simplify/substitute! node + (cadr (assq (simplify/binding/name node) + bindings)))) + to-substitute) + ;; This works only as long as all references are replaced. + (letify (delq* (lmap (lambda (node) + (assq (simplify/binding/name node) + bindings)) + to-substitute) + bindings) + body))) + +(define (simplify/substitute? value body) + (or (form/simple&side-effect-insensitive? value) + (and *after-cps-conversion?* + (CALL/? body) + (form/simple&side-effect-free? value) + (not (form/satisfies? value '(STATIC)))))) + +;; Note: this only works if no variable free in value is captured +;; at any reference in node. +;; This is currently true by construction, but may not be in the future. + +(define (simplify/substitute! node value) + (for-each (lambda (ref) + (form/rewrite! ref value)) + (simplify/binding/ordinary-refs node)) + (for-each (lambda (ref) + (form/rewrite! ref `(CALL ,value ,@(cddr ref)))) + (simplify/binding/operator-refs node))) + +(define (simplify/pseudo-letify rator bindings body) + (pseudo-letify rator bindings body simplify/remember)) + +(define (simplify/letify bindings body) + `(LET ,bindings ,body)) + +(define (simplify/letrecify bindings body) + `(LETREC ,bindings ,body)) + +(define (simplify/open-code? name value unsafe-cyclic-reference?) + ;; VALUE must be a lambda expression + (let ((body (lambda/body value))) + (or (QUOTE/? body) + (LOOKUP/? body) + (and *after-cps-conversion?* + (CALL/? body) + (<= (length (call/cont-and-operands body)) + (1+ (length (lambda/formals value)))) + (not (unsafe-cyclic-reference? name)) + (for-all? (cdr body) + (lambda (element) + (or (QUOTE/? element) + (LOOKUP/? element)))))))) + +(define (simplify/expr env expr) + (if (not (pair? expr)) + (illegal expr)) + (case (car expr) + ((QUOTE) + (simplify/quote env expr)) + ((LOOKUP) + (simplify/lookup env expr)) + ((LAMBDA) + (simplify/lambda env expr)) + ((LET) + (simplify/let env expr)) + ((DECLARE) + (simplify/declare env expr)) + ((CALL) + (simplify/call env expr)) + ((BEGIN) + (simplify/begin env expr)) + ((IF) + (simplify/if env expr)) + ((LETREC) + (simplify/letrec env expr)) + ((SET! UNASSIGNED? OR DELAY + ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT) + (no-longer-legal expr)) + (else + (illegal expr)))) + +(define (simplify/expr* env exprs) + (lmap (lambda (expr) + (simplify/expr env expr)) + exprs)) + +(define (simplify/remember new old) + (code-rewrite/remember new old)) + +(define (simplify/new-name prefix) + (new-variable prefix)) + +(define-structure + (simplify/binding + (conc-name simplify/binding/) + (constructor simplify/binding/make (name)) + (print-procedure + (standard-unparser-method 'SIMPLIFY/BINDING + (lambda (binding port) + (write-char #\space port) + (write-string (symbol-name (simplify/binding/name binding)) port))))) + + (name false read-only true) + (ordinary-refs '() read-only false) + (operator-refs '() read-only false)) + +(define-structure (simplify/env + (conc-name simplify/env/) + (constructor simplify/env/make (parent bindings))) + (bindings '() read-only true) + (parent #F read-only true) + ;; This is used to mark calls to names free in this frame but bound + ;; in the parent frame ... used to detect mutual recursion in LETREC. + (free-calls '() read-only false)) + +(define (simplify/env/modified-copy old-env new-bindings) + (let ((result (simplify/env/make (simplify/env/parent old-env) + new-bindings))) + (set-simplify/env/free-calls! result + (simplify/env/free-calls old-env)) + result)) + + +(define simplify/env/frame-lookup + (association-procedure (lambda (x y) (eq? x y)) simplify/binding/name)) + +(define (simplify/lookup*! env name reference ordinary?) + (let loop ((prev #F) + (env env)) + (cond ((not env) (free-var-error name)) + ((simplify/env/frame-lookup name (simplify/env/bindings env)) + => (lambda (binding) + (if ordinary? + (set-simplify/binding/ordinary-refs! + binding + (cons reference (simplify/binding/ordinary-refs binding))) + (begin + (set-simplify/binding/operator-refs! + binding + (cons reference (simplify/binding/operator-refs binding))) + (if prev + (set-simplify/env/free-calls! + prev + (cons name (simplify/env/free-calls prev)))))) + reference)) + (else (loop env (simplify/env/parent env)))))) diff --git a/v8/src/compiler/midend/split.scm b/v8/src/compiler/midend/split.scm new file mode 100644 index 000000000..f0db115f6 --- /dev/null +++ b/v8/src/compiler/midend/split.scm @@ -0,0 +1,232 @@ +;;; -*- Scheme -*- + +(declare (usual-integrations)) + +;;;; CLOSURE ANALYZERS + +;;; A closure analyzer is just a phase that requires a dataflow graph to perform +;;; its function. Maybe we should rename it some day. + +(define (make-dataflow-analyzer transformer) + (lambda (KMP-Program) + (let* ((new-text (copier/top-level KMP-Program dataflow/remember)) + (graph (dataflow/top-level new-text))) + (transformer new-text graph (graph/closures graph))))) + +;;;; SPLIT-AND-DRIFT + +;;; Goal: the output code has (CALL (LOOKUP ...) ...) only when the +;;; target is a known lambda expression. Otherwise it will be +;;; (CALL ',%INTERNAL-APPLY ...) + +;;; This phase splits closures that have at least one "known call site" (i.e. a +;;; call site where the closure is the only possible destination), moving the +;;; body to a top-level LETREC and replacing all of the known calls with direct +;;; references to the moved code, avoiding the indirect jump via the closure +;;; object. + +;;; There is a screw case that requires us to deal with %make-trivial-closure +;;; with a LOOKUP rather than a LAMBDA expression as the code body. These +;;; closures form a simple special case, since the body doesn't need to be +;;; moved, but the calls must still be rewritten. + +;;; If we start with: +;;; (LETREC ((foo (lambda (x) (foo 3)))) +;;; (list foo foo)) +;;; We'd like to generate something like: +;;; (LETREC ((foo (make-trivial-closure ...))) (list foo foo)) +;;; but that isn't legal in KMP-Scheme because the right hand side of +;;; a LETREC binding must be a LAMBDA expression. + +;;; After conversion, the code above becomes: +;;; (LETREC ((foo (lambda (cont-43 x) +;;; (CALL (LOOKUP foo) (LOOKUP cont-43) '3)))) +;;; (CALL ',%list cont-85 +;;; (CALL ',%make-trivial-closure '#F (LOOKUP foo)) +;;; (CALL ',%make-trivial-closure '#F (LOOKUP foo))) + +;;; Note: the assumption here is that code generation guarantees that +;;; both calls to %make-trivial-closure generate the same (EQ?) +;;; object. + +;;; We can't replace the LOOKUPs inside of %make-trivial-closure with +;;; LAMBDAs because the resulting procedures wouldn't be EQ? as +;;; required by the original source code. + +(define split-and-drift + (make-dataflow-analyzer + (lambda (code graph closures) + graph ; Not needed + (let* ((output-code `(LET () ,code)) + ;; LET inserted so we can create a LETREC frame inside, if + ;; needed, in find-lambda-drift-frame + (lambda-drift-point (find-lambda-drift-frame output-code))) + (let ((movable-closures + ;; Movable iff there is a call that is always and only to an + ;; instance of this closure. + (list-transform-positive closures + (lambda (closure) + (and (not (value/closure/escapes? closure)) + (there-exists? (value/closure/call-sites closure) + (lambda (call-site) + (operator-is-unique? call-site)))))))) + (for-every movable-closures + (lambda (closure) + (split-closure-and-drift closure lambda-drift-point))) + output-code))))) + +;;; Split and drift operations + +(define drift-lambda! + ;; Extends the LETREC-expr with a binding for new-name to lambda-expr + (let* ((bindings (->pattern-variable 'BINDINGS)) + (body (->pattern-variable 'BODY)) + (pattern `(LETREC ,bindings ,body))) + (lambda (LETREC-expr new-name lambda-expr) + (cond ((form/match pattern LETREC-expr) + => (lambda (match-result) + (let ((bindings (cadr (assq bindings match-result))) + (body (cadr (assq body match-result)))) + (form/rewrite! LETREC-expr + `(LETREC ((,new-name ,lambda-expr) ,@bindings) + ,body))))) + (else + (internal-error "No LETREC in DRIFT-LAMBDA!" LETREC-expr)))))) + +(define (make-closure->lambda-expression make-closure-expression) + ;; (Values lambda-expr format) + (cond ((CALL/%make-heap-closure? make-closure-expression) + (values + (CALL/%make-heap-closure/lambda-expression make-closure-expression) + 'HEAP)) + ((CALL/%make-trivial-closure? make-closure-expression) + (values + (CALL/%make-trivial-closure/procedure make-closure-expression) + 'TRIVIAL)) + ((CALL/%make-stack-closure? make-closure-expression) + (values + (CALL/%make-stack-closure/lambda-expression make-closure-expression) + 'STACK)) + (else (internal-error + "Unexpected expression in make-closure->lambda-expression" + make-closure-expression)))) + +;;; Split and drift operations, continued + +(define (split-closure-and-drift closure lambda-drift-point) + (let ((mutable-call-sites ; Call only this closure + (list-transform-positive (value/closure/call-sites closure) + (lambda (call-site) + (operator-is-unique? call-site))))) + (call-with-values + (lambda () + (make-closure->lambda-expression (value/text closure))) + (lambda (lambda-expr format) + ;; LAMBDA-EXPR is the body of the closure: either a LAMBDA or + ;; LOOKUP expression; + ;; FORMAT is 'TRIVIAL, 'STACK, or 'HEAP + (cond ((eq? format 'STACK) 'not-yet-implemented) + ((LOOKUP/? lambda-expr) ; See screw case above + (for-every mutable-call-sites + (lambda (site) + (let ((form (application/text site))) + ;; FORM is (CALL ',%internal-apply + ;; ...) + (form/rewrite! form + `(BEGIN + ,(fifth form) ; In case of side-effects! + (CALL ,lambda-expr ,(third form) + ,@(list-tail form 5)))))))) + + ((LAMBDA/? lambda-expr) + ;; Clean up the lambda bindings to remove optionals and lexprs in + ;; the lifted version. + (let* ((lambda-list (cadr lambda-expr)) + (names (lambda-list->names lambda-list)) + (lifted-lambda + `(LAMBDA ,names ,(third lambda-expr))) + (new-name (closan/new-name 'CLOSURE-GUTS))) + (drift-lambda! ; Drift to top-level LETREC + lambda-drift-point new-name lifted-lambda) + (form/rewrite! lambda-expr + ;; Rewrite body of closing code to call new top-level LAMBDA + (if *after-cps-conversion?* + `(LAMBDA ,lambda-list + (CALL (LOOKUP ,new-name) + ,@(map (lambda (name) `(LOOKUP ,name)) names))) + `(LAMBDA ,lambda-list + (CALL (LOOKUP ,new-name) (QUOTE #F) ; Continuation + ,@(map (lambda (name) `(LOOKUP ,name)) + (cdr names)))))) + (for-every mutable-call-sites + (lambda (site) + ;; Rewrite calls that are known to be to heap or trivial + ;; closures, bypassing the closure and going + ;; direct to the top-level LAMBDA + (let ((form (application/text site))) + ;; FORM is + ;; (CALL ',%internal-apply + ;; ...) + (form/rewrite! form + (case format + ((TRIVIAL) + `(BEGIN + ,(fifth form) ; In case of side-effects! + (CALL (LOOKUP ,new-name) + ,(third form) + ,@(lambda-list/applicate + (cdr lambda-list) + (list-tail form 5))))) + ((HEAP) + `(CALL (LOOKUP ,new-name) + ,(third form) + ,@(lambda-list/applicate + (cdr lambda-list) + (list-tail form 4)))) + (else (internal-error "Unknown format" + format))))))))) + (else (internal-error "Unknown handler" lambda-expr))))))) + +;;; Support operations for split-and-drift + +(define (find-lambda-drift-frame code) + (define (loop previous code) + (define (insert-LETREC!) + (let ((old-body (let/body previous))) + (if (LETREC/? old-body) + old-body + (let ((result `(LETREC () ,old-body))) + (form/rewrite! previous `(LET ,(let/bindings previous) ,result)) + result)))) + ;; Unwrap all static (and pseudo-static) bindings, and force the + ;; next level to be a LETREC. Return a pointer to the LETREC. + (cond ((LET/? code) + (let ((bindings (let/bindings code)) + (body (LET/body code))) + (if (for-all? bindings + (lambda (binding) + (let ((value (cadr binding))) + (form/static? value)))) + (loop code body) + (insert-LETREC!)))) + (else (insert-LETREC!)))) + + (if (not (and (LET/? code) (null? (let/bindings code)))) + (internal-error "Incorrect outer form for FIND-LAMBDA-DRIFT-FRAME" + code)) + (loop code (let/body code))) + +;;; General utility routines + +(define (closan/new-name prefix) + (new-variable prefix)) + +(define (for-every things proc) + (for-each proc things)) + +(define (operator-is-unique? call-site) + ;; Call-site is an application structure, or a symbol denoting an + ;; external known call site. + (if (symbol? call-site) + #F + (node/unique-value (application/operator-node call-site)))) diff --git a/v8/src/compiler/midend/stackopt.scm b/v8/src/compiler/midend/stackopt.scm new file mode 100644 index 000000000..05423f799 --- /dev/null +++ b/v8/src/compiler/midend/stackopt.scm @@ -0,0 +1,819 @@ +#| -*-Scheme-*- + +$Id: stackopt.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Stack optimization (reordering) +;;; package: (compiler midend) + +(declare (usual-integrations)) + +#| Big Note A + +This optimizer works by building a model of the current stack frame, +with parent and child links mapping from the state of the stack frame +at one point in time to the state earlier/later. It then attempts to +make the frames similar by assigning the slots in the frame to contain +the same object where possible, thus reducing shuffling. The bulk of +the reordering calculation is contained in the procedures +STACKOPT/REARRANGE! and STACKOPT/REARRANGE/PROCESS!. + +The algorithm is complicated by two issues: some elements of a stack +frame have fixed locations that cannot be changed at a given point in +the computation: values pushed for calls to primitives, and values +pushed for passing the last arguments to unknown procedures with a +large number of arguments. The former case is detectable because the +call to MAKE-STACK-CLOSURE (which announces the new format of the +stack frame) will not contain a LAMBDA expression in the +CALL/%MAKE-STACK-CLOSURE/LAMBDA-EXPRESSION slot. + +The latter case is detected by looking at the vector of names +available to the continuation (from the +CALL/%FETCH-STACK-CLOSURE/VECTOR slot that must exist within the +lambda-expresion) and comparing it with the names +available at the call side in the CALL/%MAKE-STACK-CLOSURE/VECTOR +slot. These will have a common prefix consisting of the values to be +saved, followed in one case by the parameters being passed on the +stack and in the other the values being passed to the continuation on +the stack. Only the common prefix is subject to reordering, the other +parts being fixed by the parameter passing convention. + +There is one unusual property of the stack model currently produced. +Consider the case of a many-argument call to a procedure where the +continuation receives many values. We produce a separate model for +the stack frame on the call side (showing the values saved on the +stack for use in the continuation plus the values being passed as +parameters to the called procedure on the stack) and the stack frame +on the continuation side (showing the values saved on the stack plus +the values being supplied by the procedure to the continuation). We +require the following property of any implementation of the reordering +algorithm: the stack slot assignments provided for the saved values in +these two frames must be identical -- the compiler is free to reorder +them in any way, but the reordering must be the same on both sides of +the call. This is in addition to the requirement that the slot +assignments for the parameters and values are fixed by the calling +sequence. + + THEOREM AND PROOF + +THEOREM: The stack slot assignments provided for the saved values in +these two frames will be identical. + +We prove the following stronger property of the *CURRENT* algorithm, +from which the theorem follows directly. + +THEOREM: For any frame with a single child in which the names of the +unwired variables and the numbers of the unwired slots are the same in +the parent and child, the slot assignments for these variables will be +the same in the parent and the child. + +PROOF: Inductively on the number of unwired names/slots in the parent +frame. If there are no unwired names/slots then the theorem follows +trivially. We prove that wiring a name to a slot in either the parent +or child frame preserves the invariant. + +Whenever an assignment transforms an unwired name to a wired +name, the assignment is propagated to the parent and all children of +the model in which the assignment occurs (see PROPAGATE in +STACKOPT/REARRANGE/PROCESS!). For convenience, let us call the models +PARENT and CHILD. We consider two cases: + a: An assignment is generated in PARENT. It will be propagated to + CHILD. By our induction hypothesis, the child will have both the + name and the slot unwired, and will proceed to wire them + together. + b: An assignment is generated in CHILD. Conversely, it will be + propagated to PARENT, where the induction hypothesis also implies + that the name and slot are free, hence will be wired. + +End of Big Note A |# + +(define (stackopt/top-level program) + (stackopt/expr false program)) + +(define-macro (define-stack-optimizer keyword bindings . body) + (let ((proc-name (symbol-append 'STACKOPT/ keyword))) + (call-with-values + (lambda () (%matchup (cdr bindings) '(handler state) '(cdr form))) + (lambda (names code) + `(define ,proc-name + (let ((handler (lambda ,(cons (car bindings) names) ,@body))) + (named-lambda (,proc-name state form) + (stackopt/remember ,code + form)))))))) + +(define-stack-optimizer LOOKUP (state name) + state ; ignored + `(LOOKUP ,name)) + +(define-stack-optimizer LAMBDA (state lambda-list body) + state ; ignored + `(LAMBDA ,lambda-list + ,(stackopt/expr false body))) + +(define-stack-optimizer LET (state bindings body) + `(LET ,(lmap (lambda (binding) + (list (car binding) + (stackopt/expr false (cadr binding)))) + bindings) + ,(stackopt/expr state body))) + +(define-stack-optimizer LETREC (state bindings body) + `(LETREC ,(lmap (lambda (binding) + (list (car binding) + (stackopt/expr false (cadr binding)))) + bindings) + ,(stackopt/expr state body))) + +(define-stack-optimizer QUOTE (state object) + state ; ignored + (if (eq? object %make-stack-closure) + (internal-error "Explicit make-stack-closure") + `(QUOTE ,object))) + +(define-stack-optimizer DECLARE (state #!rest anything) + state ; ignored + `(DECLARE ,@anything)) + +(define-stack-optimizer IF (state pred conseq alt) + `(IF ,(stackopt/expr false pred) + ,(stackopt/expr state conseq) + ,(stackopt/expr state alt))) + +(define-stack-optimizer BEGIN (state #!rest actions) + (if (null? actions) + `(BEGIN) + (let ((actions* (reverse actions))) + `(BEGIN ,@(stackopt/expr* false (reverse (cdr actions*))) + ,(stackopt/expr state (car actions*)))))) + +(define-stack-optimizer CALL (state rator cont #!rest rands) + (with-letfied-nested-stack-closures rator cont rands + (lambda (rator cont rands) + (define (wrap cont*) + `(CALL ,(stackopt/expr false rator) + ,cont* + ,@(stackopt/expr* false rands))) + (cond ((form/match stackopt/cont-pattern cont) + => (lambda (result) + (wrap (stackopt/call/can-see-both-frames + state + (call/%make-stack-closure/lambda-expression cont) + result)))) + ((call/%make-stack-closure? cont) + (wrap (stackopt/call/terminal state cont))) + (else + (wrap (stackopt/expr false cont))))))) + +(define (with-letfied-nested-stack-closures rator cont rands + receiver-of-rator+cont+rands) + ;; The loop does the `letifying' transformation until there are no + ;; calls to %make-stack-closure in the top-level position. + ;; (CALL + ;; (CALL 'make-stack-closure + ;; #F + ;; + ;; # + ;; (CALL 'make-stack-closure #F ...) + ;; ...) + ;; ...) + ;; Is transformed to + ;; (CALL (LAMBDA (cont) + ;; (CALL + ;; (CALL 'make-stack-closure + ;; #F + ;; + ;; # + ;; (lookup cont) + ;; ...) + ;; ...)) + ;; (CALL 'make-stack-closure #F ...)) + (let loop ((rator rator) (cont cont) (rands rands)) + (if (and (call/%make-stack-closure? cont) + (pair? (call/%make-stack-closure/values cont)) + (call/%make-stack-closure? + (first (call/%make-stack-closure/values cont)))) + (let ((cont-var (new-continuation-variable))) + (loop + `(LAMBDA (,cont-var) + (CALL ,rator + (CALL ',%make-stack-closure + '#F + ,(call/%make-stack-closure/lambda-expression cont) + ,(call/%make-stack-closure/vector cont) + (LOOKUP ,cont-var) + ,@(cdr (call/%make-stack-closure/values cont))) + ,@rands)) + (first (call/%make-stack-closure/values cont)) + '() )) + (receiver-of-rator+cont+rands rator cont rands)))) + + +(define (stackopt/expr state expr) + (if (not (pair? expr)) + (illegal expr)) + (case (car expr) + ((QUOTE) + (stackopt/quote state expr)) + ((LOOKUP) + (stackopt/lookup state expr)) + ((LAMBDA) + (stackopt/lambda state expr)) + ((LET) + (stackopt/let state expr)) + ((DECLARE) + (stackopt/declare state expr)) + ((CALL) + (stackopt/call state expr)) + ((BEGIN) + (stackopt/begin state expr)) + ((IF) + (stackopt/if state expr)) + ((LETREC) + (stackopt/letrec state expr)) + ((SET! UNASSIGNED? OR DELAY + ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT) + (no-longer-legal expr)) + (else + (illegal expr)))) + +(define (stackopt/expr* state exprs) + (lmap (lambda (expr) + (stackopt/expr state expr)) + exprs)) + +(define (stackopt/remember new old) + (code-rewrite/remember new old)) + +(define stackopt/?lambda-list (->pattern-variable 'LAMBDA-LIST)) +(define stackopt/?frame-name (->pattern-variable 'FRAME-VECTOR-NAME)) +(define stackopt/?frame-vector (->pattern-variable 'FRAME-VECTOR)) +(define stackopt/?call-side-frame-vector (->pattern-variable 'CALL-FRAME)) +(define stackopt/?continuation-side-frame-vector (->pattern-variable 'CONT-FRAME)) +(define stackopt/?body (->pattern-variable 'BODY)) +(define stackopt/?closure-elts (->pattern-variable 'CLOSURE-ELTS)) +(define stackopt/?non-lambda-expression (->pattern-variable 'NON-LAMBDA)) + +(define stackopt/cont-pattern + `(CALL (QUOTE ,%make-stack-closure) + (QUOTE #F) + (LAMBDA ,stackopt/?lambda-list + (LET ((,stackopt/?frame-name + (CALL (QUOTE ,%fetch-stack-closure) + (QUOTE #F) + (QUOTE ,stackopt/?continuation-side-frame-vector)))) + ,stackopt/?body)) + (QUOTE ,stackopt/?call-side-frame-vector) + ,@stackopt/?closure-elts)) + + +(define (stackopt/call/can-see-both-frames state handler match-result) + + (define (first-mismatch v1 v2) + (let ((length (min (vector-length v1) (vector-length v2)))) + (let loop ((i 0)) + (cond ((= i length) length) + ((eq? (vector-ref v1 i) (vector-ref v2 i)) + (loop (+ i 1))) + (else i))))) + + (define (wire-from! model frame from) + (let ((end (vector-length frame))) + (do ((i from (+ i 1))) + ((= i end) 'OK) + (let ((var (vector-ref frame i))) + (if (not (continuation-variable? var)) + (stackopt/wire! model `((,var . ,i)))))))) + + ;; Handler for "standard" %make-stack-closure (those with a LAMBDA + ;; expression) + (let ((lambda-list (cadr (assq stackopt/?lambda-list match-result))) + (frame-name (cadr (assq stackopt/?frame-name match-result))) + (call-frame-vector + (cadr (assq stackopt/?call-side-frame-vector match-result))) + (cont-frame-vector + (cadr (assq stackopt/?continuation-side-frame-vector + match-result))) + (body (cadr (assq stackopt/?body match-result))) + (real-rands (cadr (assq stackopt/?closure-elts match-result)))) + (let* ((call-model (stackopt/model/make state call-frame-vector #F)) + (cont-model + (if (eq? call-frame-vector cont-frame-vector) + call-model + (stackopt/model/make call-model cont-frame-vector #F))) + ;; See Big Note A at the top of this file. + (handler* + `(LAMBDA ,lambda-list + (LET ((,frame-name (CALL (QUOTE ,%fetch-stack-closure) + (QUOTE #F) + (QUOTE ,cont-frame-vector)))) + ,(stackopt/expr cont-model body)))) + (form* + `(CALL (QUOTE ,%make-stack-closure) + (QUOTE #F) + ,(stackopt/remember handler* handler) + (QUOTE ,call-frame-vector) + ,@(stackopt/expr* false real-rands)))) + (if (not (eq? call-model cont-model)) + (let ((mismatch (first-mismatch call-frame-vector + cont-frame-vector))) + (wire-from! call-model call-frame-vector mismatch) + (wire-from! cont-model cont-frame-vector mismatch) + (set-stackopt/model/form! cont-model #F))) + (stackopt/%call state call-model form*)))) + +(define (stackopt/call/terminal state cont) + ;; Handler for CONT being the "push" %make-stack-closure (i.e. with + ;; anything other than a LAMBDA expression) + (let ((frame-vector (quote/text (call/%make-stack-closure/vector cont))) + (real-rands (call/%make-stack-closure/values cont)) + (non-lambda (call/%make-stack-closure/lambda-expression cont))) + (let* ((model (stackopt/model/make state frame-vector #T)) + (form* `(CALL (QUOTE ,%make-stack-closure) + (QUOTE #F) + ,(stackopt/expr false non-lambda) + (QUOTE ,frame-vector) + ,@(stackopt/expr* false real-rands)))) + (stackopt/%call state model form*)))) + +(define (stackopt/%call state model form*) + (set-stackopt/model/form! model form*) + (if (not state) + (stackopt/reorder! model)) + form*) + +;; For now, this is a very simple rearranger. +;; The problem is really complicated (probably NP-complete), +;; and it's not clear how to even do a good heuristic. +;; The problem is simplified if we allow stack frames to have holes, +;; as C compilers do, since then each preserved variable can have a +;; home in the stack. The problem is garbage collection: +;; no-longer-used slots need to be cleared, and this is as costly as +;; reshuffling. + +(define (stackopt/reorder! model) + (define (stackopt/model-intersection model) + ;; Find the set of variables present in the model and all of its children + (define (walk set models) + (cond ((null? models) set) + ((null? set) set) + (else (walk + (intersection set + (vector->list + (stackopt/model/frame + (car models)))) + (append (stackopt/model/children (car models)) + (cdr models)))))) + (walk (vector->list (stackopt/model/frame model)) + (stackopt/model/children model))) + + (stackopt/rearrange! model + (stackopt/constrain model + (stackopt/model-intersection model) + (let min-all ((model model)) + ;; Calculate the smallest frame size that appears anywhere in + ;; the tree of frame extensions + (fold-right (lambda (model current-min) + (min (min-all model) current-min)) + (vector-length (stackopt/model/frame model)) + (stackopt/model/children model))))) + (stackopt/rewrite! model)) + +(define (stackopt/rewrite! model) + ;; Rewrite the form for this model and those for all of its children + ;; by calculating the new order of names in the frame and reordering + ;; the value expressions to match the new order. + (for-each stackopt/rewrite! (stackopt/model/children model)) + (let* ((frame* (stackopt/model/frame model)) + (frame (vector-copy frame*)) + (form (stackopt/model/form model))) + (stackopt/update-frame! model) + (if (and form (not (equal? frame* frame))) + (let* ((names&values + (map cons + (vector->list frame) + (call/%make-stack-closure/values form))) + (values* + (map (lambda (name*) + (let ((place (assq name* names&values))) + (if (not place) + (stackopt/inconsistency model)) + (cdr place))) + (vector->list frame*)))) + (form/rewrite! form + `(CALL ,(call/operator form) + ,(call/continuation form) + ,(call/%make-stack-closure/lambda-expression form) + ,(call/%make-stack-closure/vector form) + ,@values*)))))) + +(define (stackopt/rearrange! model wired) + (define (arrange-locally! model) + ;; Generate the wiring for a model by performing a union of WIRED + ;; with the wired elements of the model's frame (WIRED wins if a + ;; name is wired in two different places?!) + (let* ((wired* + (let ((wired* (stackopt/model/wired model))) + (if (not wired*) + wired + (append wired + (list-transform-negative wired* + (lambda (wired-pair) + (assq (car wired-pair) wired))))))) + (unwired + (list-transform-negative + (vector->list (stackopt/model/frame model)) + (lambda (var) + (assq var wired*))))) + (set-stackopt/model/wired! model wired*) + (set-stackopt/model/unwired! model unwired) + (set-stackopt/model/n-unwired! model (length unwired)))) + + (define (max-all model) + ;; Maximum number of unwired slots in this frame or any + ;; [grand*]child frame + (fold-right (lambda (model current-max) + (max (max-all model) current-max)) + (stackopt/model/n-unwired model) + (stackopt/model/children model))) + + ;; Walk the model's frame and all of its (recursive) children. This + ;; will add the WIRED set to all of the wired names of this frame + ;; and its children. + (let walk ((model model)) + (arrange-locally! model) + (for-each walk (stackopt/model/children model))) + + ;; If this model has children and they aren't all wired down by this + ;; time, gyrate around filling in the unfilled slots. + (if (not (null? (stackopt/model/children model))) + (let ((max-unwired (max-all model))) + (if (not (zero? max-unwired)) + (let ((buckets (make-vector max-unwired '()))) + (let insert! ((model model)) + (for-each insert! (stackopt/model/children model)) + (let ((n-unwired (stackopt/model/n-unwired model))) + (if (not (zero? n-unwired)) + (let ((index (- n-unwired 1))) + (vector-set! buckets index + (cons model + (vector-ref buckets index))))))) + (stackopt/rearrange/process! buckets)))))) + +(define (stackopt/rearrange/process! buckets) + ;; BUCKETS is a vector long enough to hold an entry for each unwired + ;; slot in the largest frame here or in one of the children. It + ;; maps from number of open slots to models with that number of open + ;; slots (off by one). That is, entry 0 has a list of all models + ;; with one unwired slot,etc. + (define (propagate model unwired index) + ;; Do the assignment in the model itself, and then propagate it as + ;; far up and down the tree as possible. + (define (wire!? model unwired index) + ;; Wire the name UNWIRED to offset INDEX in the MODEL if that slot + ;; is available, and return a boolean indicating whether it was + ;; done. + (and (memq unwired (stackopt/model/unwired model)) + (stackopt/free-index? model index) + (let ((bucket (- (stackopt/model/n-unwired model) 1))) + (stackopt/wire! model (list (cons unwired index))) + (vector-set! buckets bucket + (delq model (vector-ref buckets bucket))) + ;; Move this model to a bucket indicating the next + ;; available location to be filled. + (if (not (zero? bucket)) + (let ((bucket* (- bucket 1))) + (vector-set! buckets bucket* + (cons model (vector-ref buckets bucket*))))) + true))) + + (define (try-up model unwired index) + ;; Try to wire UNWIRED to offset INDEX in this MODEL and all of + ;; its parents. Stops when it can't be wired or the top of the + ;; frame tree is encountered. + (let loop ((model model)) + (and model + (wire!? model unwired index) + (loop (stackopt/model/parent model))))) + + (define (try-down model unwired index) + ;; Try to wire UNWIRED to offset INDEX in this MODEL and all of + ;; its descendents. Stops when it can't be wired any lower in + ;; this branch of the frame tree. + (let walk ((model model)) + (and (wire!? model unwired index) + (for-each walk (stackopt/model/children model))))) + + (if (not (wire!? model unwired index)) + (internal-error "STACKOPT/REARRANGE/PROCESS!: Can't wire" + model unwired index)) + (try-up (stackopt/model/parent model) unwired index) + (for-each (lambda (model*) + (try-down model* unwired index)) + (stackopt/model/children model))) + + (define (find-wired model models*) + ;; Return the first model in MODELS* which has already decided on + ;; a binding for one of the unwired variables in MODEL and for + ;; which that same binding slot is available in MODEL; otherwise + ;; #F. + (and (not (null? models*)) + (let ((model* (car models*))) + (or (list-search-positive (stackopt/model/wired model*) + (lambda (wired*) + (and (memq (car wired*) (stackopt/model/unwired model)) + (stackopt/free-index? model (cdr wired*))))) + (find-wired model (cdr models*)))))) + + (define (pick-to-wire model) + ;; Assigns an unwired variable to a free index at random. + (cons (pick-random (stackopt/model/unwired model)) + (pick-random (stackopt/free-indices model)))) + + (define (phase-2) + ;; For all of the frames that have more than one free slot, grab + ;; the most highly constrained frame (fewest free slots), assign + ;; an unwired variable, propagate, and repeat from phase-1 until + ;; there are no models remaining. + (let ((bucketlen (vector-length buckets))) + (let loop ((i 1)) + (and (< i bucketlen) + (if (null? (vector-ref buckets i)) + (loop (1+ i)) + (let* ((model (car (vector-ref buckets i))) + (children (stackopt/model/children model)) + (to-wire + (or (find-wired + model + (if (stackopt/model/parent model) + (cons (stackopt/model/parent model) + children) + children)) + (pick-to-wire model)))) + (propagate model (car to-wire) (cdr to-wire)) + (phase-1))))))) + + (define (phase-1) + ;; For all of the models that have only one free slot available, + ;; wire their first unwired variable to that slot and propagate + ;; that choice up and down the tree. This may promote other + ;; models to having only one free slot, so the iteration doesn't + ;; terminate in the obvious manner. When all remaining models + ;; have more than one free slot, go on to phase-2. + (let ((bucket0 (vector-ref buckets 0))) + (if (null? bucket0) + (phase-2) + (let* ((model (car bucket0)) + (unwired (car (stackopt/model/unwired model))) + (index (car (stackopt/free-indices model)))) + (vector-set! buckets 0 (delq model bucket0)) + (propagate model unwired index) + (phase-1))))) + + (phase-1)) + +(define (stackopt/update-frame! model) + ;; Calculate offsets for all elements in this model's frame by first + ;; using the wired offsets and then filling in order from the + ;; unwired list. + (let* ((frame (stackopt/model/frame model)) + (len (vector-length frame)) + (frame* (make-vector len false))) + (for-each (lambda (wired) + (let ((name (car wired)) + (index (cdr wired))) + (if (vector-ref frame* index) + (stackopt/inconsistency model) + (vector-set! frame* index name)))) + (stackopt/model/wired model)) + (let loop ((i (- len 1)) + (unwired (stackopt/model/unwired model))) + (cond ((negative? i) + (if (not (null? unwired)) + (stackopt/inconsistency model))) + ((vector-ref frame* i) ; This slot wired + (loop (- i 1) unwired)) + ((null? unwired) + (stackopt/inconsistency model)) + (else + (vector-set! frame* i (car unwired)) + (loop (- i 1) (cdr unwired))))) + (stackopt/clobber! frame frame*))) + +(define (stackopt/free-index? model index) + ;; #T iff the index-th entry in the frame is not in use for a wired + ;; value. + (let ((len (vector-length (stackopt/model/frame model)))) + (and (< index len) + (not (rassq index (stackopt/model/wired model)))))) + +(define (stackopt/free-indices model) + ;; Return a list of all offsets in the frame that aren't currently + ;; in use for a wired value. + (let* ((len (vector-length (stackopt/model/frame model))) + (frame* (make-vector len true))) + (for-each (lambda (wired) + (vector-set! frame* (cdr wired) false)) + (stackopt/model/wired model)) + (let loop ((index 0) + (free '())) + (cond ((= index len) + free) + ((vector-ref frame* index) + (loop (+ index 1) + (cons index free))) + (else + (loop (+ index 1) free)))))) + +(define (stackopt/wire! model pairs) + ;; Each element of PAIRS is ( . ) + (let ((wired* (append pairs (stackopt/model/wired model))) + (unwired* (delq* (lmap car pairs) + (stackopt/model/unwired model)))) + (set-stackopt/model/wired! model wired*) + (set-stackopt/model/unwired! model unwired*) + (set-stackopt/model/n-unwired! model (length unwired*)))) + +(define (stackopt/inconsistency model) + (internal-error "Inconsistent wiring" model)) + +(define (stackopt/clobber! v1 v2) + ;; Copy the values from v2 into v1 (sort of like "v1 := v2") + (do ((i (- (vector-length v1) 1) (- i 1))) + ((< i 0) 'done) + (vector-set! v1 i (vector-ref v2 i)))) + +(define (stackopt/new-name prefix) + (new-variable prefix)) + +(define-structure (stackopt/model + (conc-name stackopt/model/) + (constructor stackopt/model/%make (parent frame))) + (parent false read-only true) + (frame false read-only true) ; Vector of variable names + (wired '() read-only false) ; List mapping names to offsets + (unwired '() read-only false) ; List of names, currently + ; without offsets + (form false read-only false) + (children '() read-only false) + (n-unwired false read-only false) + (extended? false read-only false)) + +(define (stackopt/model/make parent frame wire-all?) + (let ((new (stackopt/model/%make parent frame))) + (if parent + (set-stackopt/model/children! parent + (cons new + (stackopt/model/children parent)))) + (call-with-values + (lambda () + (list-split (vector->list frame) continuation-variable?)) + (lambda (cont-vars others) + (cond ((null? cont-vars) 'OK) + ((null? (cdr cont-vars)) + (set-stackopt/model/wired! new `((,(car cont-vars) . 0)))) + (else (internal-error + "STACKOPT/MODEL/MAKE: multiple continuation variables" + frame))) + (if wire-all? + (let* ((zero-counts (iota (length others))) + (counts (if (null? cont-vars) + zero-counts + (map 1+ zero-counts)))) + (set-stackopt/model/wired! new + (append (stackopt/model/wired new) + (map cons others counts))))))) + new)) + +;; This is more general than it needs to be, because it accomodates +;; partially wired frames. + +(define (stackopt/constrain model common sup-index) + ;; MODEL is a model to be processed + ;; COMMON is the list of variables that appears in the model's frame + ;; and all of its descendent frames + ;; SUP-INDEX is the size of the smallest frame appearing in + ;; the tree of frames rooted in this model's frame. + ;; + ;; Returns a mapping from names in the COMMON set to fixed stack + ;; offsets. This might not provide locations for all values, + ;; because it treats a wiring in any frame as though it applied to + ;; all frames. Later we will generate final assignments that allow + ;; assignments in one frame configuration to be wired but will use + ;; the same slot for another purpose in a different configuration. + + (define (walk model pairs) + ;; Each element of PAIRS is ( ) + ;; Returns a similar list of pairs, but the possible offsets have + ;; been corrected to account for wired down names. The entry for + ;; a name may become '() if there's no place to put it (i.e. you + ;; lose track of the name if it can't go anywhere). + (if (null? pairs) + pairs + (fold-right + walk + (let ((wired (stackopt/model/wired model))) + (if (not wired) + pairs + (let ((nogood (lmap cdr wired))) + (append-map + (lambda (pair) + (let* ((name (car pair)) + (place (assq name wired))) + (cond ((not place) + (let ((possible (difference (cadr pair) nogood))) + (if (null? possible) + '() ; Nowhere to go + (list (list name possible))))) + ; Anywhere but the wired locations + ((memq (cdr place) (cadr pair)) + (list (list name (list (cdr place))))) + ; Wired location is free, so + ; that's it + (else '())))) ; Wired but slot's not free + pairs)))) + (stackopt/model/children model)))) + + (call-with-values + (lambda () + (list-split (walk model + (lmap (lambda (common) + (list common (iota sup-index))) + common)) + (lambda (pair) + (continuation-variable? (car pair))))) + (lambda (cont-variables rest) + ;; At least the continuation variable must be shared if there are + ;; any children frames, and the continuation must be in slot 0. + (cond ((null? cont-variables) + ;; This is no longer true. A better test would be that the + ;; continuation variables must be shared across non-leaf models + ;; (if (not (null? (stackopt/model/children model))) + ;; (internal-error "No continuation variables shared" + ;; model common)) + (stackopt/constrain* rest)) + ((not (null? (cdr cont-variables))) + (internal-error "Too many continuation variables" + model common)) + ((not (memq 0 (cadr (car cont-variables)))) + (internal-error "Unexpected offset for shared continuation" + model (car cont-variables))) + (else + (stackopt/constrain* (cons (list (car (car cont-variables)) '(0)) + rest))))))) + +(define (stackopt/constrain* pairs) + ;; PAIRS maps names to possible stack offset locations + ;; Returns a mapping from names to fixed stack offsets. This may + ;; not provide locations for all values originally in PAIRS. + (call-with-values + (lambda () + (list-split pairs + (lambda (pair) + (null? (cdr (cadr pair)))))) + (lambda (wired free) + ;; WIRED variables now have no other place they can go + (let loop ((wired (lmap (lambda (pair) + (cons (car pair) (car (cadr pair)))) + wired)) + (free free)) + (if (null? free) + wired + ;; This is not necessarily a good choice + (let* ((next (car free)) + (index (list-search-negative (cadr next) + (lambda (index) + (rassq index wired))))) + (loop (if (not index) + wired + (cons (cons (car next) index) + wired)) + (cdr free)))))))) diff --git a/v8/src/compiler/midend/staticfy.scm b/v8/src/compiler/midend/staticfy.scm new file mode 100644 index 000000000..ea8194d02 --- /dev/null +++ b/v8/src/compiler/midend/staticfy.scm @@ -0,0 +1,267 @@ +#| -*-Scheme-*- + +$Id: staticfy.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Static binding annotator +;;; package: (compiler midend) + +(declare (usual-integrations)) + +(define (staticfy/top-level program) + (staticfy/expr (staticfy/env/make 'STATIC false '()) program)) + +(define-macro (define-staticfier keyword bindings . body) + (let ((proc-name (symbol-append 'STATICFY/ keyword))) + (call-with-values + (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form))) + (lambda (names code) + `(define ,proc-name + (let ((handler (lambda ,(cons (car bindings) names) ,@body))) + (named-lambda (,proc-name env form) + (staticfy/remember ,code + form)))))))) + +(define-staticfier LOOKUP (env name) + (staticfy/lookup* env name `(LOOKUP ,name))) + +(define-staticfier LAMBDA (env lambda-list body) + `(LAMBDA ,lambda-list + ,(staticfy/expr (staticfy/bind 'DYNAMIC + env + (lambda-list->names lambda-list)) + body))) + +(define-staticfier LETREC (env bindings body) + (let ((env* (staticfy/bind (staticfy/env/context env) + env + (lmap car bindings)))) + `(LETREC ,(lmap (lambda (binding) + (list (car binding) + (staticfy/expr env* (cadr binding)))) + bindings) + ,(staticfy/expr env* body)))) + +(define-staticfier QUOTE (env object) + env ; ignored + `(QUOTE ,object)) + +(define-staticfier DECLARE (env #!rest anything) + env ; ignored + `(DECLARE ,@anything)) + +(define-staticfier BEGIN (env #!rest actions) + `(BEGIN ,@(staticfy/expr* env actions))) + +(define-staticfier IF (env pred conseq alt) + `(IF ,(staticfy/expr env pred) + ,(staticfy/expr env conseq) + ,(staticfy/expr env alt))) + +(define-staticfier CALL (env cont rator #!rest rands) + (if (or (not (pair? rator)) + (not (eq? (car rator) 'LAMBDA)) + (eq? (staticfy/env/context env) 'DYNAMIC) + (not (equal? cont '(QUOTE #F)))) + `(CALL ,(staticfy/expr env rator) + ,(staticfy/expr env cont) + ,@(staticfy/expr* env rands)) + (staticfy/let* (lambda (bindings* body*) + (staticfy/pseudo-letify rator bindings* body*)) + env + (map list (cdr (cadr rator)) rands) + (caddr rator)))) + +(define-staticfier LET (env bindings body) + (if (eq? (staticfy/env/context env) 'DYNAMIC) + `(LET ,(lmap (lambda (binding) + (list (car binding) + (staticfy/expr env (cadr binding)))) + bindings) + ,(staticfy/expr (staticfy/bind 'DYNAMIC env (lmap car bindings)) + body)) + (staticfy/let* staticfy/letify + env + bindings + body))) + +(define (staticfy/letify bindings body) + `(LET ,bindings ,body)) + +(define (staticfy/pseudo-letify rator bindings body) + `(CALL ,(staticfy/remember + `(LAMBDA (,(car (cadr rator)) ,@(lmap car bindings)) + ,body) + rator) + (QUOTE #F) + ,@(lmap cadr bindings))) + +(define (staticfy/let* letify env bindings body) + (let* ((bindings* (lmap (lambda (binding) + (list (car binding) + (staticfy/expr env (cadr binding)))) + bindings)) + (env* (staticfy/bind (staticfy/env/context env) + env + (lmap car bindings))) + (body* (staticfy/expr env* body))) + (call-with-values + (lambda () + (list-split bindings* + (lambda (binding*) + (staticfy/simple? (cadr binding*))))) + (lambda (simple hairy) + (if (null? hairy) + (letify bindings* body*) + (begin + (for-each + (lambda (hairy) + (let* ((name (car hairy)) + (binding (assq name (staticfy/env/bindings env*)))) + (for-each + (lambda (ref) + (form/rewrite! + ref + `(CALL (QUOTE ,%static-binding-ref) + (QUOTE #F) + (LOOKUP ,name) + (QUOTE ,name)))) + (cdr binding)))) + hairy) + (letify + (lmap (lambda (binding*) + (if (memq binding* simple) + simple + (let ((name (car binding*))) + (list name + `(CALL (QUOTE ,%make-static-binding) + (QUOTE #F) + (QUOTE ,%unassigned) + (QUOTE ,name)))))) + bindings*) + (beginnify + (append + (let ((actions* + (lmap (lambda (hairy) + (let ((name (car hairy))) + `(CALL (QUOTE ,%static-binding-set!) + (QUOTE #F) + (LOOKUP ,name) + ,(cadr hairy) + (QUOTE ,name)))) + hairy))) + (case *order-of-argument-evaluation* + ((ANY LEFT-TO-RIGHT) actions*) + ((RIGHT-TO_LEFT) (reverse actions*)) + (else + (configuration-error + "Unknown order of argument evaluation" + *order-of-argument-evaluation*)))) + (list body*)))))))))) + +(define (staticfy/expr env expr) + (if (not (pair? expr)) + (illegal expr)) + (case (car expr) + ((QUOTE) + (staticfy/quote env expr)) + ((LOOKUP) + (staticfy/lookup env expr)) + ((LAMBDA) + (staticfy/lambda env expr)) + ((LET) + (staticfy/let env expr)) + ((DECLARE) + (staticfy/declare env expr)) + ((CALL) + (staticfy/call env expr)) + ((BEGIN) + (staticfy/begin env expr)) + ((IF) + (staticfy/if env expr)) + ((LETREC) + (staticfy/letrec env expr)) + ((SET! UNASSIGNED? OR DELAY + ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT) + (no-longer-legal expr)) + (else + (illegal expr)))) + +(define (staticfy/expr* env exprs) + (lmap (lambda (expr) + (staticfy/expr env expr)) + exprs)) + +(define (staticfy/remember new old) + (code-rewrite/remember new old)) + +(define (staticfy/new-name prefix) + (new-variable prefix)) + +(define staticfy/guaranteed-static-operators + (list %make-operator-variable-cache + %make-remote-operator-variable-cache + %make-read-variable-cache + %make-write-variable-cache + %fetch-environment)) + +(define (staticfy/simple? form) + (and (pair? form) + (or (eq? (car form) 'QUOTE) + (and (eq? (car form) 'CALL) + (pair? (cadr form)) + (eq? (car (cadr form)) 'QUOTE) + (memq (cadr (cadr form)) + staticfy/guaranteed-static-operators))))) + +(define-structure (staticfy/env + (conc-name staticfy/env/) + (constructor staticfy/env/make)) + (context false read-only true) + (parent false read-only true) + (bindings '() read-only true)) + +(define (staticfy/lookup* env name ref) + (let loop ((env env)) + (cond ((not env) + (free-var-error name)) + ((assq name (staticfy/env/bindings env)) + => (lambda (binding) + (set-cdr! binding (cons ref (cdr binding))))) + (else + (loop (staticfy/env/parent env))))) + ref) + +(define-integrable (staticfy/bind context env names) + (staticfy/env/make context + env + (lmap list names))) \ No newline at end of file diff --git a/v8/src/compiler/midend/synutl.scm b/v8/src/compiler/midend/synutl.scm new file mode 100644 index 000000000..ab5ce6081 --- /dev/null +++ b/v8/src/compiler/midend/synutl.scm @@ -0,0 +1,63 @@ +#| -*-Scheme-*- + +$Id: synutl.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; ?? +;;; package: (compiler midend) + +(declare (usual-integrations)) + +;;; Syntax-time utilities + +(define (%matchup lambda-list prefix expr) + (if (null? lambda-list) + (values '() prefix) + (let ((var* (generate-uninterned-symbol "SUBFORM"))) + (let loop ((ll lambda-list) + (names '()) + (args '()) + (path var*)) + (cond ((null? ll) + (values (reverse names) + `(let ((,var* ,expr)) + (,@prefix ,@(reverse args))))) + ((eq? (car ll) '#!rest) + (loop '() + (cons (cadr ll) names) + (cons path args) + false)) + (else + (loop (cdr ll) + (cons (car ll) names) + (cons `(car ,path) args) + `(cdr ,path)))))))) \ No newline at end of file diff --git a/v8/src/compiler/midend/triveval.scm b/v8/src/compiler/midend/triveval.scm new file mode 100644 index 000000000..26a9c1a08 --- /dev/null +++ b/v8/src/compiler/midend/triveval.scm @@ -0,0 +1,461 @@ +#| -*-Scheme-*- + +$Id: triveval.scm,v 1.1 1994/11/19 02:04:29 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; "Trivial" KMP Scheme evaluator +;;; package: (compiler midend) + +(declare (usual-integrations)) + +;;;; Trivial evaluator's runtime library + +;; New special forms handled as procedures + +(define (lookup value) + value) + +(define (call operator cont . operands) + (if (eq? operator %invoke-continuation) + (apply cont operands) + (let ((rator (operator->procedure operator))) + (cond ((cps-proc? rator) + (cps-proc/apply rator cont operands)) + ((not cont) + (apply rator operands)) + ((continuation? cont) + (within-continuation cont + (lambda () + (apply rator operands)))) + (else + (cont (apply rator operands))))))) + +(define-structure (cps-proc + (conc-name cps-proc/) + (constructor %cps-proc/make%)) + (handler false read-only true)) + +(define (cps-proc/apply proc cont operands) + ;; if cont is false, proc should not need it + #| + (if (not cont) + (apply proc operands) + (apply (cps-proc/handler proc) cont operands)) + |# + (apply (cps-proc/handler proc) cont operands)) + +(define (funcall nargs operator . operands) + nargs ; ignored + (apply operator operands)) + +(define *last-env*) +(define *this-env* (the-environment)) + +(define (fetch-environment) + (let ((env *last-env*)) + (set! *last-env*) + env)) + +(define (execute expr env) + (set! *last-env* env) + (eval (cond ((cps-program1? expr) + (cps-rewrite (caddr expr))) + ((cps-program2? expr) + (cps-rewrite expr)) + ((compatible-program? expr) + (compatible-rewrite expr)) + (else + (pre-cps-rewrite expr))) + *this-env*)) + +(define (pre-cps-rewrite expr) + `(let-syntax ((NON-CPS-LAMBDA + (macro (param-list body) + (list 'LAMBDA (cdr param-list) body)))) + ,(form/replace expr '((LAMBDA NON-CPS-LAMBDA))))) + +(define triveval/?cont-variable (->pattern-variable 'CONT-VARIABLE)) +(define triveval/?body (->pattern-variable 'BODY)) +(define triveval/?ignore (->pattern-variable 'IGNORE)) +(define triveval/?frame (->pattern-variable 'FRAME)) +(define triveval/?frame-vector (->pattern-variable 'FRAME-VECTOR)) + +(define triveval/compatible-expr-pattern + `(LAMBDA (,triveval/?ignore) + (LET ((,triveval/?frame + (CALL (QUOTE ,%fetch-stack-closure) + (QUOTE #F) + (QUOTE ,triveval/?frame-vector)))) + ,triveval/?body))) + +(define (compatible-program? expr) + (form/match triveval/compatible-expr-pattern expr)) + +(define (compatible-rewrite expr) + (let ((expr* (%cps-rewrite (caddr expr))) + (name (generate-uninterned-symbol 'CONT))) + `(call-with-current-continuation + (lambda (,name) + (set! *stack-closure* (make-stack-closure false '() ,name)) + ,expr*)))) + +;;this no longer appears to be the only correct pattern, a (letrec () appears +;;before this let, so I just make two tests, and do the appropriate thing +;;JBANK + +(define triveval/cps-expr-pattern1 + `(LETREC () + (LET ((,triveval/?cont-variable + (CALL (QUOTE ,%fetch-continuation) + (QUOTE #F)))) + ,triveval/?body))) + +(define triveval/cps-expr-pattern1-2 + `(LET () + (LET ((,triveval/?cont-variable + (CALL (QUOTE ,%fetch-continuation) + (QUOTE #F)))) + ,triveval/?body))) + +(define triveval/cps-expr-pattern2 + `(LET ((,triveval/?cont-variable + (CALL (QUOTE ,%fetch-continuation) + (QUOTE #F)))) + ,triveval/?body)) + +(define (cps-program1? expr) + (or (form/match triveval/cps-expr-pattern1 expr) + (form/match triveval/cps-expr-pattern1-2 expr))) + +(define (cps-program2? expr) + (form/match triveval/cps-expr-pattern2 expr)) + +(define (%cps-rewrite expr) + `(let-syntax ((cps-lambda + (macro (param-list body) + (list '%cps-proc/make% + (list 'LAMBDA param-list body))))) + ,(form/replace expr '((LAMBDA CPS-LAMBDA))))) + +(define (cps-rewrite expr) + `(call-with-current-continuation + (lambda (,(car (car (cadr expr)))) ; cont variable + ,(%cps-rewrite (caddr expr))))) + +(define-structure (variable-cache + (conc-name variable-cache/) + (constructor variable-cache/make)) + env name) + +(define (make-read-variable-cache env name) + (variable-cache/make env name)) + +(define (make-write-variable-cache env name) + (variable-cache/make env name)) + +(define (variable-cache-ref cache name) + name ; ignored + (lexical-reference (variable-cache/env cache) + (variable-cache/name cache))) + +(define (variable-cache-set! cache value name) + name ; ignored + (lexical-assignment (variable-cache/env cache) + (variable-cache/name cache) + value)) + +(define (safe-variable-cache-ref cache name) + name ; ignored + (let ((env (variable-cache/env cache)) + (name (variable-cache/name cache))) + (if (lexical-unassigned? env name) + %unassigned + (lexical-reference env name)))) + +(define (variable-cell-ref cache) + (let ((env (variable-cache/env cache)) + (name (variable-cache/name cache))) + (if (lexical-unassigned? env name) + %unassigned + (lexical-reference env name)))) + +(define (variable-cell-set! cache value) + (lexical-assignment (variable-cache/env cache) + (variable-cache/name cache) + value)) + +(define-structure (operator-cache + (conc-name operator-cache/) + (constructor operator-cache/make)) + env name arity) + +(define (make-operator-variable-cache env name arity) + (operator-cache/make env name arity)) + +(define (make-remote-operator-variable-cache package name arity) + (operator-cache/make (->environment package) name arity)) + +(define (invoke-operator-cache name cache . args) + name ; ignored + (let ((arity (operator-cache/arity cache))) + (if (not (= (length args) arity)) + (error "Operator cache called with wrong number of arguments" + args arity) + (apply (lexical-reference (operator-cache/env cache) + (operator-cache/name cache)) + args)))) + +(define (cell/make value name) + name ; ignored + (make-cell value)) + +(define (cell-ref cell name) + name ; ignored + (cell-contents cell)) + +(define (cell-set! cell value name) + name ; ignored + (set-cell-contents! cell value)) + +(define (make-closure proc names . values) + names ; ignored + (make-entity proc (list->vector values))) + +(define (closure-ref closure index name) + name ; ignored + (vector-ref (entity-extra closure) index)) + +(define (closure-set! closure index value name) + name ; ignored + (vector-set! (entity-extra closure) index value)) + +(define *stack-closure*) + +(define (fetch-stack-closure names) + names ; ignored + (let ((closure *stack-closure*)) + (set! *stack-closure*) ; clear for gc + closure)) + +(define (make-stack-closure proc names . values) + names ; ignored + (make-entity (lambda (closure . args) + (set! *stack-closure* closure) + (apply proc args)) + (list->vector values))) + +(define (stack-closure-ref closure index name) + name ; ignored + (vector-ref (entity-extra closure) index)) + +(define (projection/2/0 x y) + y ; ignored + x) + +(define (%unknown . all) + all ; ignored + (error "Unknown operator")) + +;; *** These two do not currently work for #!optional or #!rest! *** + +(define (make-closure/compatible proc names . values) + (let ((proc (cps-proc/handler proc))) + (apply make-closure + (lambda (closure . args) + (call-with-current-continuation + (lambda (cont) + (set! *stack-closure* + (apply make-stack-closure + false + '() + (cons cont + (append (reverse args) + (list closure))))) + (apply proc (cons* cont closure args))))) + names + values))) + +(define *trivial-closures* ; to preserve eq-ness + (make-eq-hash-table)) + +(define (make-trivial-closure/compatible proc) + (let ((proc (cps-proc/handler proc))) + (or (hash-table/get *trivial-closures* proc false) + (let ((new + (lambda args + (call-with-current-continuation + (lambda (cont) + (set! *stack-closure* + (apply make-stack-closure + false + '() + (cons cont (reverse args)))) + (apply proc (cons cont args))))))) + (hash-table/put! *trivial-closures* proc new) + new)))) + +(define internal-apply/compatible + (%cps-proc/make% + (lambda (stack-closure nargs operator) + nargs ; ignored + (let ((elements (vector->list (entity-extra stack-closure)))) + (apply call + operator + (car elements) + (reverse (cdr elements))))))) + +(define invoke-operator-cache/compatible + (%cps-proc/make% + (lambda (stack-closure desc cache) + (let ((elements (vector->list (entity-extra stack-closure)))) + (apply call + (let ((cache + (or cache + (make-remote-operator-variable-cache + '() + (car desc) + (cadr desc))))) + (lexical-reference (operator-cache/env cache) + (operator-cache/name cache))) + (car elements) + (reverse (cdr elements))))))) + +(define *operator->procedure* + (make-eq-hash-table 311)) + +(define (operator->procedure rator) + (if (not (symbol? rator)) + rator + (hash-table/get *operator->procedure* rator rator))) + +(define (init-operators!) + (let* ((table *operator->procedure*) + (declare-operator + (lambda (token handler) + (hash-table/put! table token handler)))) + + (declare-operator %invoke-operator-cache invoke-operator-cache) + (declare-operator %invoke-remote-cache invoke-operator-cache) + (declare-operator %variable-cache-ref variable-cache-ref) + (declare-operator %variable-cache-set! variable-cache-set!) + (declare-operator %safe-variable-cache-ref safe-variable-cache-ref) + (declare-operator %unassigned? (lambda (obj) (eq? obj %unassigned))) + (declare-operator %make-promise (lambda (proc) (delay (proc)))) + (declare-operator %make-cell cell/make) + (declare-operator %make-static-binding cell/make) + (declare-operator %cell-ref cell-ref) + (declare-operator %static-binding-ref cell-ref) + (declare-operator %cell-set! cell-set!) + (declare-operator %static-binding-set! cell-set!) + (declare-operator %cons cons) + (declare-operator %vector vector) + (declare-operator %*lookup + (lambda (env name depth offset) + depth offset ; ignored + (lexical-reference env name))) + (declare-operator %*set! + (lambda (env name depth offset value) + depth offset ; ignored + (lexical-assignment env name value))) + (declare-operator %*unassigned? + (lambda (env name depth offset) + depth offset ; ignored + (lexical-unassigned? env name))) + (declare-operator %*define local-assignment) + (declare-operator %*define* define-multiple) + (declare-operator %*make-environment *make-environment) + (declare-operator %execute execute) + (declare-operator %fetch-environment fetch-environment) + (declare-operator %fetch-continuation + (lambda () + (error "Fetch-continuation executed!"))) + (declare-operator %make-read-variable-cache make-read-variable-cache) + (declare-operator %make-write-variable-cache make-write-variable-cache) + (declare-operator %make-operator-variable-cache + make-operator-variable-cache) + (declare-operator %make-remote-operator-variable-cache + make-remote-operator-variable-cache) + (declare-operator %copy-program %copy-program) + (declare-operator %make-heap-closure make-closure) + (declare-operator %make-trivial-closure identity-procedure) + (declare-operator %heap-closure-ref closure-ref) + (declare-operator %heap-closure-set! closure-set!) + (declare-operator %make-stack-closure make-stack-closure) + (declare-operator %stack-closure-ref stack-closure-ref) + (declare-operator %fetch-stack-closure fetch-stack-closure) + (declare-operator %internal-apply funcall) + (declare-operator %primitive-apply funcall) + ; (declare-operator %invoke-continuation identity-procedure) + (declare-operator %vector-index vector-index) + + (declare-operator %machine-fixnum? machine-fixnum?) + (declare-operator %small-fixnum? small-fixnum?) + (declare-operator %+ +) + (declare-operator %- -) + (declare-operator %* *) + (declare-operator %/ /) + (declare-operator %quotient quotient) + (declare-operator %remainder remainder) + (declare-operator %= =) + (declare-operator %< <) + (declare-operator %> >) + (declare-operator %vector-cons make-vector) + (declare-operator %string-allocate string-allocate) + (declare-operator %floating-vector-cons flo:vector-cons) + + ;; Compatiblity operators: + + (declare-operator %make-return-address + (lambda (obj) + obj ; ignored + (error "make-return-address executed!"))) + + (declare-operator %variable-read-cache projection/2/0) + (declare-operator %variable-write-cache projection/2/0) + (declare-operator %variable-cell-ref variable-cell-ref) + (declare-operator %hook-variable-cell-ref variable-cell-ref) + (declare-operator %hook-safe-variable-cell-ref variable-cell-ref) + (declare-operator %variable-cell-set! variable-cell-set!) + (declare-operator %hook-variable-cell-set! variable-cell-set!) + (declare-operator %reference-trap? (lambda (obj) (eq? obj %unassigned))) + (declare-operator %primitive-apply/compatible internal-apply/compatible))) + +;; This makes cps procs and ordinary procs intermixable + +(set-record-type-application-method! + cps-proc + (lambda (the-proc . args) + (call-with-current-continuation + (lambda (cont) + (apply (cps-proc/handler the-proc) cont args))))) + +(init-operators!) \ No newline at end of file diff --git a/v8/src/compiler/midend/utils.scm b/v8/src/compiler/midend/utils.scm new file mode 100644 index 000000000..d6576b78b --- /dev/null +++ b/v8/src/compiler/midend/utils.scm @@ -0,0 +1,997 @@ +;;; -*- Scheme -*- + +(declare (usual-integrations)) + +;;; Compile-time handling of booleans + +(define (boolean/discriminate object) + (cond ((eq? object #f) + 'FALSE) + ((eq? object #t) + 'TRUE) + ((eq? object '()) + ;; 'UNKNOWN + 'TRUE) + (else + 'TRUE))) + +;;; Compile-time handling of numbers (*** For now ***) + +(define machine-tag-renames + '((floating-point-vector flonum))) + +(define (machine-tag tag-name) + (let ((place (assq tag-name machine-tag-renames))) + (microcode-type + (if (not place) + tag-name + (cadr place))))) + +(define (machine-fixnum? value) + (fix:fixnum? value)) + +(define (small-fixnum? value nbits) + (and (machine-fixnum? value) + (machine-fixnum? (* (expt 2 nbits) value)))) + +;; Trivial pretty printer + +(define kmp/pp-unparser-table + (unparser-table/copy system-global-unparser-table)) + +(define *unparse-string + (lexical-reference (->environment '(runtime unparser)) '*unparse-string)) + +(unparser-table/set-entry! + kmp/pp-unparser-table + 'UNINTERNED-SYMBOL + (lambda (symbol) + (let ((name (symbol-name symbol))) + (cond ((= 0 (vector-8b-ref name 0)) + (*unparse-string (substring name 1 (string-length name)))) + ((new-variable->index symbol) + => (lambda (index) + (*unparse-string name) + (*unparse-string kmp/pp-symbol-glue) + (*unparse-string (number->string index)))) + (else + ;;(*unparse-string "#[uninterned-symbol ") + (*unparse-string name) + ;;(*unparse-string " ") + ;;(*unparse-string (number->string (hash symbol))) + ;;(*unparse-string "]") + ))))) + +(define kmp/pp-symbol-glue "-") + +(define (kmp/pp kmp-code) + (fluid-let ((*pp-primitives-by-name* false) + (*pp-uninterned-symbols-by-name* false) + (*pp-avoid-circularity?* true) + (*pp-default-as-code?* true)) + (pp kmp-code))) + +(define (kmp/ppp kmp-code) + (kmp/pp (kmp/->ppp kmp-code))) + +(define (kmp/->ppp kmp-code) + (define (->string x) + (cond ((interned-symbol? x) (symbol-name x)) + ((uninterned-symbol? x) + (let ((index (new-variable->index x)) + (name (symbol-name x))) + (cond (index + (string-append name kmp/pp-symbol-glue + (number->string index))) + ((= 0 (vector-8b-ref name 0)) + (substring name 1 (string-length name))) + (else + (string-append name "[#@" + (number->string (hash x)) "]"))))) + (else x))) + (define (->sym . stuff) + (string->uninterned-symbol + (apply string-append "\000" (map ->string stuff)))) + (let walk ((expr kmp-code)) + (define (format-ref get-closure get-name) + (define (gen closure) + (->sym closure "." (quote/text (get-name expr)))) + (let* ((expr (map walk expr)) + (closure (get-closure expr))) + (cond ((symbol? closure) (gen closure)) + ((LOOKUP/? closure) (gen (lookup/name closure))) + (else expr)))) + (cond ((QUOTE/? expr) + expr) + ;;((LET/? expr) + ;; (let do-let ((names '()) (values '()) (form expr)) + ;; (cond ((and (LET/? form) + ;; (= (length (let/bindings form)) 1)) + ;; (do-let (cons (first (first (let/bindings form))) names) + ;; (cons (second (first (let/bindings form))) values) + ;; (let/body form))) + ;; ((null? names) + ;; (map walk expr)) + ;; ((= (length names) 1) + ;; `(LET (,(car names) ,(walk (car values))) + ;; ,(walk form))) + ;; (else + ;; `(LET* ,(reverse (map (lambda (n v) `(,n ,(walk v))) + ;; names values)) + ;; ,(walk form)))))) + ((LOOKUP/? expr) + (lookup/name expr)) + ((CALL/%heap-closure-ref? expr) + (format-ref CALL/%heap-closure-ref/closure + CALL/%heap-closure-ref/name)) + ((CALL/%stack-closure-ref? expr) + (format-ref CALL/%stack-closure-ref/closure + CALL/%stack-closure-ref/name)) + ((pair? expr) + (map walk expr)) + (else expr)))) + +;;; Simple form utilities + +(define (bind name value body) + `(CALL (LAMBDA (,(new-continuation-variable) ,name) + ,body) + (QUOTE #F) + ,value)) + +(define (bind* names values body) + `(CALL (LAMBDA (,(new-continuation-variable) ,@names) + ,body) + (QUOTE #F) + ,@values)) + +(define (andify left right) + `(IF ,left ,right (QUOTE #F))) + +(define (beginnify actions) + ;; Flattens the ACTIONS, discarding any in non-tail position that + ;; are side-effect free or static (compile-time only). It + ;; returns (BEGIN) or (BEGIN + ) or + (let loop ((actions (reverse actions)) + (actions* '())) + (cond ((null? actions) + (if (or (null? actions*) + (not (null? (cdr actions*)))) + `(BEGIN ,@actions*) + (car actions*))) + ((not (pair? (car actions))) + (internal-warning "BEGINNIFY: Non-pair form in BEGIN:" (car actions)) + (loop (cdr actions) + (cons (car actions) actions*))) + ((eq? (caar actions) 'BEGIN) + (loop (append (reverse (cdar actions)) (cdr actions)) + actions*)) + ((and (not (null? actions*)) + (or (form/satisfies? (car actions) '(SIDE-EFFECT-FREE)) + (and (form/satisfies? (car actions) '(STATIC)) + (begin + (write-line `(BEGINNIFY ELIDING ,(car actions))) + #T)))) + (loop (cdr actions) actions*)) + (else + (loop (cdr actions) + (cons (car actions) actions*)))))) + +(define (simplify-actions expressions) + ;; Takes a list of expressions, as in a BEGIN body, and produces a + ;; simplified list of expressions (i.e. removes side-effect-free + ;; expressions in non-tail position). + (let ((simplified (beginnify expressions))) + (if (and (pair? simplified) + (eq? (car simplified) 'BEGIN)) + (cdr simplified) + (list simplified)))) + +(define (pseudo-letify rator bindings body remember) + ;; Using pseudo-letify ensures that LET is only inserted for simple, + ;; non-continuation bindings. + (if (and (for-all? bindings + (lambda (binding) + (and (form/simple? (cadr binding)) + (not (continuation-variable? (car binding)))))) + *after-cps-conversion?*) + `(LET ,bindings + ,body) + (let ((cont-binding + (list-search-positive bindings + (lambda (binding) + (continuation-variable? (car binding))))) + (finish + (lambda (cont-name cont-expr bindings*) + (let ((rator* `(LAMBDA (,cont-name + ,@(lmap car bindings*)) + ,body))) + `(CALL ,(remember rator* rator) + ,cont-expr + ,@(lmap cadr bindings*)))))) + (if (not cont-binding) + (finish (new-continuation-variable) + `(QUOTE #F) + bindings) + (finish (car cont-binding) + (cadr cont-binding) + (delq cont-binding bindings)))))) + +(define (hash-table/copy table make-hash-table) + (let ((new-table (make-hash-table (hash-table/size table)))) + (hash-table/for-each table + (lambda (key datum) + (hash-table/put! new-table key datum))) + new-table)) + +(define (make-variable-properties) + (make-eq-hash-table)) + +(define (copy-variable-properties) + (let ((var-props *variable-properties*)) + (and var-props + (hash-table/copy var-props make-eq-hash-table)))) + +(define (get-variable-properties var) + (let ((var-props *variable-properties*)) + (and var-props + (hash-table/get var-props var '())))) + +(define (set-variable-properties! var alist) + (let ((var-props *variable-properties*)) + (and var-props + (hash-table/put! var-props var alist)))) + +(define (get-variable-property var property) + (let ((properties (get-variable-properties var))) + (and properties + (assq property properties)))) + +(define (declare-variable-property! var property) + (let ((var-props *variable-properties*)) + (and var-props + (hash-table/put! + var-props + var + (let* ((all (hash-table/get var-props var '())) + (place (assq (car property) all))) + (cons property + (if (not place) + all + (delq place all)))))))) + +;; NEW-VARIABLE +;; +;; The only reason for this table is to canonocalize the names to allow +;; comparison across compilations. If you want to use something like +;; this for a code rewrite, dont use this table. Use the variable +;; properties or something else. + +(define new-variable-index) +(define new-variable-table #F) + +(define (initialize-new-variable!) + (set! new-variable-index 0) + (set! new-variable-table (make-eq-hash-table))) + +(define (new-variable prefix) + ;;(generate-uninterned-symbol prefix) + (set! new-variable-index (+ new-variable-index 1)) + (let ((symbol (string->uninterned-symbol + (if (symbol? prefix) + (symbol-name prefix) + prefix)))) + (hash-table/put! new-variable-table symbol new-variable-index) + symbol)) + +(define (new-variable->index symbol) + (and new-variable-table + (hash-table/get new-variable-table symbol #F))) + + +(define (closure-variable? var) + (get-variable-property var 'CLOSURE)) + +(define (new-closure-variable) + (let ((name (new-variable 'CLOSURE))) + (declare-variable-property! name '(CLOSURE)) + name)) + +(define-integrable (new-ignored-variable name) + (let ((name (new-variable name))) + (declare-variable-property! name '(IGNORED)) + name)) + +(define-integrable (ignored-variable? var) + (get-variable-property var 'IGNORED)) + +(define (continuation-variable? var) + (get-variable-property var 'CONTINUATION)) + +(define (ignored-continuation-variable? var) + (and (get-variable-property var 'CONTINUATION) + (ignored-variable? var))) + +(define (referenced-continuation-variable? var) + (and (get-variable-property var 'CONTINUATION) + (not (ignored-variable? var)))) + +(define (new-continuation-variable) + (let ((name (new-variable 'CONT))) + (declare-variable-property! name '(CONTINUATION)) + name)) + +(define (new-ignored-continuation-variable) + (let ((name (new-ignored-variable 'IGNORED-CONTINUATION))) + (declare-variable-property! name '(CONTINUATION)) + name)) + +(define (environment-variable? var) + (get-variable-property var 'ENVIRONMENT)) + +(define (new-environment-variable) + (let ((name (new-variable 'ENV))) + (declare-variable-property! name '(ENVIRONMENT)) + name)) + +(define (new-variable-cache-variable name desc) + name ; ignored + (let ((name* (new-variable 'CACHE))) + (declare-variable-property! name* `(CACHE ,desc)) + name*)) + +(define (variable-cache-variable? var) + (get-variable-property var 'CACHE)) + +(define (variable/rename var) + (let ((new + ;;(generate-uninterned-symbol (string-append (symbol-name var) "-")) + (new-variable var) + ) + (original-properties (get-variable-properties var))) + (if original-properties + (set-variable-properties! new (alist-copy original-properties))) + (declare-variable-property! new `(ORIGINAL-NAME ,var)) + new)) + +(define (variable/original-name var) + (let loop ((var var)) + (let ((place (get-variable-property var 'ORIGINAL-NAME))) + (if (not place) + var + (loop (cadr place)))))) + +(define (pseudo-static-variable? var) + (let ((var-props *variable-properties*)) + (and var-props + (let ((props (hash-table/get var-props var false))) + (and props + (or (assq 'CONTINUATION props) + (assq 'ENVIRONMENT props))))))) + + +(define (lifter/letrecify program) + ;; Ensure that there is a place to attach lifted stuff, + ;; by introducing a LETREC if necessary. + (if (LETREC/? program) + program + `(LETREC () ,program))) + +(define (lifter/make find-static-form) + (lambda (env lamname form*) + (define (clobber-letrec! form) + (set-car! (cdr form) + (cons (list lamname form*) + (cadr form)))) + + (let ((form (find-static-form env))) + (if (or (not form) (not (pair? form))) + (internal-error "Nowhere to insert" form) + (case (car form) + ((LETREC) + (clobber-letrec! form)) + ((LET LAMBDA) + (let ((body (caddr form))) + (if (and (pair? body) (eq? (car body) 'LETREC)) + (clobber-letrec! body) + (set-car! (cddr form) + `(LETREC ((,lamname ,form*)) + ,body))))) + (else + (internal-error "Invalid place to insert" form))))))) + +(define (form/rewrite! old new) + (set-car! old (car new)) + (set-cdr! old (cdr new))) + +(define (form/preserve form) + ;; This makes a copy that won't be affected by later rewriting + ;; of the original. Rewritten components will be present in both. + (cons (car form) (cdr form))) + +(define (form/copy form) + (let walk ((form form)) + (cond ((not (pair? form)) + form) + ((eq? 'QUOTE (car form)) + `(QUOTE ,(cadr form))) + (else + (cons (walk (car form)) + (walk (cdr form))))))) + +(define (form/replace form replacements) + (let walk ((form form)) + (cond ((not (pair? form)) + (let ((place (assq form replacements))) + (if (not place) + form + (cadr place)))) + ((eq? 'QUOTE (car form)) + `(QUOTE ,(cadr form))) + (else + (cons (walk (car form)) + (walk (cdr form))))))) + +(define (form/satisfies? form operator-properties) + (let walk ((expr form)) + (and (pair? expr) + (case (car expr) + ((LOOKUP QUOTE LAMBDA) true) + ((IF) + (and (walk (cadr expr)) + (walk (caddr expr)) + (walk (cadddr expr)))) + ((CALL) + (let ((rator (cadr expr))) + (and (pair? rator) + (eq? (car rator) 'QUOTE) + (operator/satisfies? (cadr rator) operator-properties) + (for-all? (cddr expr) walk)))) + (else false))))) + +(define (form/simple&side-effect-free? operand) + (form/satisfies? operand '(SIMPLE SIDE-EFFECT-FREE))) + +(define (form/simple&side-effect-insensitive? operand) + (form/satisfies? operand '(SIMPLE SIDE-EFFECT-INSENSITIVE))) + +(define (form/simple? form) + (and (pair? form) + (case (car form) + ((LOOKUP QUOTE LAMBDA) true) + ((IF) + (and (form/simple&side-effect-free? (cadr form)) + (form/simple&side-effect-free? (caddr form)) + (form/simple&side-effect-free? (caddr form)))) + ((CALL) + (let ((rator (cadr form))) + (and (QUOTE/? rator) + (operator/satisfies? (cadr rator) '(SIMPLE)) + (for-all? (cddr form) form/simple&side-effect-free?)))) + (else false)))) + +(define (pseudo-simple-operator? rator) + (or (operator/satisfies? rator '(SIMPLE)) + (operator/satisfies? rator '(OUT-OF-LINE-HOOK)))) + +(define (form/pseudo-simple? form) + (and (pair? form) + (case (car form) + ((LOOKUP QUOTE LAMBDA) true) + ((IF) + (and (form/simple&side-effect-free? (cadr form)) + (form/simple&side-effect-free? (caddr form)) + (form/simple&side-effect-free? (caddr form)))) + ((CALL) + (let ((rator (cadr form))) + (and (QUOTE/? rator) + (pseudo-simple-operator? (cadr rator)) + (for-all? (cddr form) form/simple&side-effect-free?)))) + (else false)))) + +(define (binding-context-type keyword context bindings) + (if (or (eq? keyword 'LETREC) + (eq? context 'DYNAMIC)) + context + (call-with-values + (lambda () + (list-split + (list-transform-negative bindings + (lambda (binding) + ;; eliminate any continuation variables. They will not + ;; be considered as either dynamic or static (as + ;; suggested by Jinx) + ;; --JBANK + (continuation-variable? (car binding)))) + (lambda (binding) (form/static? (cadr binding))))) + (lambda (static dynamic) + (cond ((null? dynamic) 'STATIC) + ((null? static) 'DYNAMIC) + (else (internal-error + "Frame with static and dynamic bindings"))))))) + +(define (form/static? form) + ;; This assumes that the operands are OK. + (and (pair? form) + (eq? (car form) 'CALL) + (let ((rator (cadr form))) + (and (pair? rator) + (eq? 'QUOTE (car rator)) + (operator/satisfies? (cadr rator) '(STATIC)))))) + +(define (form/free-vars form) + (form/%free-vars form true)) + +(define (form/%free-vars form inside-lambda?) + ;; Only valid after environment conversion. + (define (free-vars* exprs bound acc) + (let loop ((acc acc) + (exprs exprs)) + (if (null? exprs) + acc + (loop (free-vars (car exprs) bound acc) + (cdr exprs))))) + + (define (maybe-add var bound acc) + (if (or (memq var bound) (memq var acc)) + acc + (cons var acc))) + + (define (free-vars expr bound acc) + (if (not (pair? expr)) + (internal-error "form/free-vars: Not a KMP expression" expr)) + (case (car expr) + ((LOOKUP) + (maybe-add (cadr expr) bound acc)) + ((LAMBDA) + (if (not inside-lambda?) + acc + (free-vars (caddr expr) + (append (lambda-list->names (cadr expr)) + bound) + acc))) + ((LET) + (free-vars* (map cadr (cadr expr)) + bound + (free-vars (caddr expr) + (map* bound car (cadr expr)) + acc))) + ((CALL BEGIN IF DELAY OR) + (free-vars* (cdr expr) bound acc)) + ((LETREC) + (free-vars* (cons (caddr expr) (map cadr (cadr expr))) + (map* bound car (cadr expr)) + acc)) + ((SET!) + (maybe-add (cadr expr) + bound + (free-vars (caddr expr) bound acc))) + ((QUOTE DECLARE) + acc) + ((ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT) + (no-longer-legal expr 'FORM/FREE-VARS)) + (else + (illegal expr)))) + + (free-vars form '() '())) + +(define-structure (pattern-variable + (conc-name pattern-variable/) + (constructor ->pattern-variable) + (print-procedure + (standard-unparser-method 'PATTERN-VARIABLE + (lambda (v port) + (write-char #\space port) + (display (pattern-variable/name v) port))))) + (name false read-only true)) + +(define (form/equal? form1 form2) + (define (walk form1 form2) + (or (eq? form1 form2) + (and (pair? form1) + (pair? form2) + (walk (car form1) (car form2)) + (walk (cdr form1) (cdr form2))))) + + (walk form1 form2)) + +(define (form/match pattern form) + (define (walk pattern form dict) + (and dict + (cond ((pattern-variable? pattern) + (let ((place (assq pattern (cdr dict)))) + (cond ((not place) + (cons 'DICT + (cons (list pattern form) + (cdr dict)))) + ((form/equal? (cadr place) form) + dict) + (else + false)))) + ((eq? pattern form) + dict) + ((pair? pattern) + (and (pair? form) + (walk (cdr pattern) + (cdr form) + (walk (car pattern) + (car form) + dict)))) + (else + false)))) + + (let ((result (walk pattern form (list 'DICT)))) + (and result + (or (null? (cdr result)) + (cdr result))))) + +;;;; Lambda-list utilities + +(define (lambda-list->names lambda-list) + (delq* '(#!OPTIONAL #!REST #!AUX) lambda-list)) + +(define (lambda-list/count-names lambda-list) + (let loop ((list lambda-list) (count 0)) + (cond ((null? list) count) + ((memq (car list) '(#!OPTIONAL #!REST #!AUX)) + (loop (cdr list) count)) + (else + (loop (cdr list) (+ count 1)))))) + +(define (hairy-lambda-list? lambda-list) + (there-exists? lambda-list + (lambda (token) + (or (eq? token '#!OPTIONAL) + (eq? token '#!REST) + (eq? token '#!AUX))))) + +(define (guarantee-simple-lambda-list lambda-list) + (if (hairy-lambda-list? lambda-list) + (internal-error "Unexpected lambda list keywords" lambda-list))) + +(define (guarantee-argument-list args len) + (if (not (= (length args) len)) + (internal-error "Wrong number of arguments" len args))) + +(define (lambda-list/applicate lambda-list args) + ;; No #!AUX allowed here + (let loop ((ll lambda-list) + (ops args) + (ops* '())) + (cond ((null? ll) + (if (not (null? ops)) + (user-error "Too many arguments" lambda-list args)) + (reverse! ops*)) + ((eq? (car ll) '#!OPTIONAL) + (loop (if (or (null? (cddr ll)) + (eq? '#!REST (caddr ll))) + (cddr ll) + (cons '#!OPTIONAL (cddr ll))) + (if (null? ops) + ops + (cdr ops)) + (cons (if (null? ops) + `(QUOTE ,%unassigned) + (car ops)) + ops*))) + ((eq? (car ll) '#!REST) + ;; This only works before CPS conversion. + ;; By that time, all "lexprs" should have been split. + (reverse! + (cons (let listify ((ops ops)) + (if (null? ops) + `(QUOTE ()) + `(CALL (QUOTE ,%cons) + (QUOTE #F) + ,(car ops) + ,(listify (cdr ops))))) + ops*))) + ((null? ops) + (user-error "Too few arguments" lambda-list args)) + (else + (loop (cdr ll) (cdr ops) (cons (car ops) ops*)))))) + +(define (lambda-list/parse lambda-list) + ;; (values required optional rest) + ;; No #!AUX allowed here + (let parse ((ll lambda-list)) + (cond ((null? ll) + (values '() '() false)) + ((eq? (car ll) '#!OPTIONAL) + (call-with-values + (lambda () (parse (cdr ll))) + (lambda (opt opt* rest) + (if (not (null? opt*)) + (internal-error "Multiple #!OPTIONAL specifiers" + lambda-list)) + (values '() opt rest)))) + ((eq? (car ll) '#!REST) + (if (or (null? (cdr ll)) + (not (null? (cddr ll)))) + (internal-error "Parameters follow #!REST" lambda-list)) + (values '() '() (cdr ll))) + (else + (call-with-values + (lambda () (parse (cdr ll))) + (lambda (req opt rest) + (values (cons (car ll) req) + opt + rest))))))) + +(define (lambda-list/arity-info lambda-list) + ;; This includes the return address, since the + ;; current convention includes that. + (call-with-values + (lambda () (lambda-list/parse lambda-list)) + (lambda (required optional rest) + ;; min includes the continuation, since after CPS! + (let* ((min (length required)) + (max (+ min (length optional)))) + (list min + (if rest + (- 0 (+ max 1)) + max)))))) + +;;;; List & vector utilities + +(define (delq* to-remove some-list) + (if (null? to-remove) + some-list + (let loop ((al some-list) + (names '())) + (cond ((null? al) + (reverse! names)) + ((memq (car al) to-remove) + (loop (cdr al) names)) + (else + (loop (cdr al) + (cons (car al) names))))))) + +(define (list-prefix ol tail) + (let loop ((elements '()) + (l ol)) + (cond ((eq? l tail) + (reverse! elements)) + ((null? l) + (error "list-prefix: not a prefix" ol tail)) + (else + (loop (cons (car l) elements) + (cdr l)))))) + +(define-integrable (lmap proc l) + (let loop ((l l) (l* '())) + (if (null? l) + (reverse! l*) + (loop (cdr l) + (cons (proc (car l)) + l*))))) + +(define (difference set1 set2) + (list-transform-negative set1 + (lambda (element) + (memq element set2)))) + +(define (intersection set1 set2) + (cond ((null? set1) + '()) + ((null? set2) + '()) + (else + (list-transform-positive set1 + (lambda (element) + (memq element set2)))))) + +(define (union set1 set2) + (cond ((null? set1) + set2) + ((null? set2) + set1) + (else + (append (delq* set2 set1) set2)))) + +(define (union-map* set0 proc l) + ;; Apply PROC to each element of L and union the results with SET0 + (let loop ((set set0) + (l l)) + (if (null? l) + set + (loop (union (proc (car l)) set) + (cdr l))))) + + +(define (remove-duplicates l) + (let loop ((l l) (l* '())) + (cond ((null? l) (reverse! l*)) + ((memq (car l) l*) (loop (cdr l) l*)) + (else (loop (cdr l) (cons (car l) l*)))))) + +(define (null-intersection? set1 set2) + (cond ((null? set1) #T) + ((null? set2) #T) + ((memq (car set1) set2) #F) + (else (null-intersection? (cdr set1) set2)))) + + +(define (list-split ol predicate) + ;; (values yes no) + (let loop ((l (reverse ol)) + (yes '()) + (no '())) + (cond ((null? l) + (values yes no)) + ((predicate (car l)) + (loop (cdr l) (cons (car l) yes) no)) + (else + (loop (cdr l) yes (cons (car l) no)))))) + +(define (rassq value alist) + (let loop ((alist alist)) + (and (pair? alist) + (pair? (car alist)) + (if (eq? value (cdar alist)) + (car alist) + (loop (cdr alist)))))) + +(define (pick-random l) + (let ((len (length l))) + (list-ref l (if *allow-random-choices?* + (random len) + (quotient len 2))))) + +(define (vector-index vector name) + (if (not (vector? vector)) + (internal-error "vector-index: Not a vector" vector name) + (do ((i (- (vector-length vector) 1) (- i 1))) + ((eq? name (vector-ref vector i)) i) + (if (= i 0) + (internal-error "vector-index: component not found" + vector name))))) + + +(define-structure (queue + (conc-name queue/) + (constructor queue/%make)) + (head false read-only true) + (tail false read-only false)) + +(define (queue/make) + (let ((pair (cons '*HEAD* '()))) + (queue/%make pair pair))) + +(define (queue/enqueue! queue object) + (let ((pair (cons object '()))) + (set-cdr! (queue/tail queue) pair) + (set-queue/tail! queue pair))) + +(define (queue/enqueue!* queue objects) + (if (not (null? objects)) + (let ((objects* (list-copy objects))) + (set-cdr! (queue/tail queue) objects*) + (set-queue/tail! queue (last-pair objects*))))) + +(define (queue/drain! queue process) + ;; process can cause more queueing + (let loop ((pair (queue/head queue))) + (if (not (null? (cdr pair))) + (begin + (process (cadr pair)) + ;; This can GC by bashing the queue! + (loop (cdr pair)))))) + +(define (queue/contents queue) + (cdr (queue/head queue))) + +;;;; Miscellaneous + +(define (eq?-memoize function) + (let ((table (make-eq-hash-table)) + (absent (cons #f #f))) + (lambda (arg) + (let ((value (hash-table/get table arg absent))) + (if (eq? value absent) + (let ((value (function arg))) + (hash-table/put! table arg value) + value) + value))))) + +;; Missing SCODE utilities for input + +(define (the-environment-components tenv receiver) + tenv ; ignored + (receiver)) + +(define (scode/absolute-reference? object) + (and (access? object) + (null? (access-environment object)))) + +(define (absolute-reference-name reference) + (access-name reference)) + +(define (good-factor? value) + (and (machine-fixnum? value) + (< (abs value) *sup-good-factor*))) + +(define (good-factor->nbits value) + (if (not (good-factor? value)) + (internal-error "constant factors can only be good factors" + value) + (ceiling->exact (/ (log (abs value)) (log 2))))) + +(define (power-of-two? n) + (let loop ((power 1) (exponent 0)) + (cond ((< n power) false) + ((= n power) exponent) + (else + (loop (* 2 power) (1+ exponent)))))) + +(define (careful/quotient x y) + (if (zero? y) + (user-error "quotient: Division by zero" x y) + (quotient x y))) + +(define (careful/remainder x y) + (if (zero? y) + (user-error "remainder: Division by zero" x y) + (remainder x y))) + +(define (careful// x y) + (if (zero? y) + (user-error "/: Division by zero" x y) + (/ x y))) + +(define (iota n) + (do ((i (- n 1) (- i 1)) + (acc '() (cons i acc))) + ((< i 0) acc))) + +(define code/rewrite-table/make + (strong-hash-table/constructor eq-hash-mod eq?)) + +(define code-rewrite/remember + (let ((not-found (list '*NOT-FOUND*))) + (lambda (new old) + (let ((crt *code-rewrite-table*)) + (if (and crt (eq? not-found (hash-table/get crt new not-found))) + (let* ((pcrt *previous-code-rewrite-table*) + (old* (if (not pcrt) + not-found + (hash-table/get pcrt + old + not-found)))) + (cond ((not (eq? old* not-found)) + (hash-table/put! crt new old*)) + ((eq? pcrt #t) + (hash-table/put! crt new old)))))) + new))) + +(define code-rewrite/remember* + (let ((not-found (list '*NOT-FOUND*))) + (lambda (new old) + (let ((crt *code-rewrite-table*)) + (if (and crt (eq? not-found (hash-table/get crt new not-found))) + (hash-table/put! crt new old))) + new))) + +(define (code-rewrite/original-form new) + (and *code-rewrite-table* + (hash-table/get *code-rewrite-table* new false))) + +(define code-rewrite/original-form*/previous + (let ((not-found (list '*NOT-FOUND*))) + (lambda (old) + ;; (values available? form) + (if (not *previous-code-rewrite-table*) + (values false old) + (let ((ancient + (hash-table/get *previous-code-rewrite-table* old not-found))) + (if (eq? not-found ancient) + (values false old) + (values true ancient))))))) + +(define (code-rewrite/original-form/previous old) + (and *previous-code-rewrite-table* + (hash-table/get *previous-code-rewrite-table* old false))) + +(define (code/rewrite-table/copy table) + (hash-table/copy table + code/rewrite-table/make)) diff --git a/v8/src/compiler/midend/widen.scm b/v8/src/compiler/midend/widen.scm new file mode 100644 index 000000000..ca779ee16 --- /dev/null +++ b/v8/src/compiler/midend/widen.scm @@ -0,0 +1,764 @@ +;;; -*- Scheme -*- + +(declare (usual-integrations)) + +;;; Widen parameter lists where a known closure is being passed around, so that +;;; the component parts can be passed rather than the closure object itself. We +;;; do this only when the closure can be eliminated entirely; hence, the +;;; requirement that the closure not escape. + +(define (reject-reason closure) + ;; Returns the reason a closure can't be considered for widening. + ;; This is referred to later as "undeniably-dirty?". Current + ;; reasons are: + ;; 1. The value ESCAPES. + ;; 2. There is some use of the value where other values might also + ;; occur. (Could be weakened to sites where other values occur + ;; that don't widen the same way.) + ;; 3. There is some use of the value that we don't know how to + ;; widen. We can widen expressions that create closures, + ;; references to closed over variables, operands of + ;; applications, bindings of LET or LETREC variables, formal + ;; parameters of LAMBDA, and the expressions which fetches a + ;; stack closure. + (cond ((value/closure/escapes? closure) 'escapes) + #| ((eq? 'STACK (value/closure/kind closure)) 'stack-closure) |# + (else + (let ((reasons '())) + (define (new-reason! reason) + (set! reasons (cons reason reasons))) + (do ((nodes (value/nodes closure) (cdr nodes))) + ((null? nodes) + (if (null? reasons) + (if (eq? 'STACK (value/closure/kind closure)) + (begin + (internal-warning "I want to widen a stack closure" + closure) + #F) + #F) + reasons)) + (let ((node (car nodes))) + (cond ((not (node/unique-value node)) + (new-reason! (list 'not-unique node))) + #| ((continuation-invocation-operand? node) + (new-reason! (list 'continuation-invocation node))) + |# + ((not (or #| (not (null? (node/uses/operator node))) |# + (closure-constructor-node? node) + (closure-slot-node? node) + (not (null? (node/uses/operand node))) + (let-binding-node? node) + (node/formal-parameter? node) + (fetch-stack-closure-node? node))) + (new-reason! (list 'unusual-use node))) + (else 'OK)))))))) + +(define widen-parameter-lists + ;; Generate the data flow graph, separate out the closures that + ;; appear to be widenable, then do a more careful analysis to + ;; actually choose the ones which will be widened (i.e. converted + ;; from single objects into a set of the closed-over values). + (make-dataflow-analyzer + (lambda (code graph closures) + ;;(write-line graph) + (rewrite-as-widened graph code + (analyze-widenable-closures + (list-transform-negative closures + reject-reason)))))) + +(define closure/name + (let* ((name (->pattern-variable 'NAME)) + (pattern + `(CALL ',%make-heap-closure '#F + (LAMBDA (,(->pattern-variable 'CONTINUE) + ,name + . ,(->pattern-variable 'FORMALS)) + ,(->pattern-variable 'BODY)) + . ,(->pattern-variable 'CRAP)))) + (lambda (closure) + (symbol->string + (case (value/closure/kind closure) + ((STACK) 'STACK-CLOSURE) + ((TRIVIAL) 'TRIVIAL-CLOSURE) + ((HEAP) (let ((match (form/match pattern (value/text closure)))) + (if match + (cadr (assq name match)) + (internal-error "Heap closure naming error")))) + (else (internal-error "Unknown closure type"))))))) + +;; Functions to retrieve the representations (list of variable names +;; to replace) and name maps (maps from old closed variable name to +;; list of new variable names) for each of the widenable closures. +(define value/closure.representation 'LATER) +(define set-value/closure.representation! 'LATER) +(define value/closure.name-map 'LATER) +(define set-value/closure.name-map! 'LATER) + +;; Now initialize those functions +(let ((representations (make-attribute)) + (name-maps (make-attribute))) + ;; For each closure that is widenable, we store the representation + ;; we choose for the closure as a list of closed over variables. + (set! value/closure.representation + (lambda (value/closure) (get-attribute value/closure representations))) + (set! set-value/closure.representation! + (lambda (value/closure rep) + (set-attribute! value/closure representations rep))) + (set! value/closure.name-map + (lambda (value/closure) (get-attribute value/closure name-maps))) + (set! set-value/closure.name-map! + (lambda (value/closure rep) + (set-attribute! value/closure name-maps rep)))) + +(define (analyze-widenable-closures widenable-closures) + ;; The WIDENABLE-CLOSURES all have the property that whenever they appear as a + ;; value somewhere, they are the only possible value, and they appear only in + ;; restricted contexts, as defined by REJECT-REASON. + + ;; Returns the list of closures that will actually be widened. As a + ;; side-effect, it computes and stores the representations and name maps for + ;; these closures. + + (define (transitively-dirty? undeniably-dirty? components adj) + ;; Given a set of nodes (COMPONENTS) and an ADJacency function + ;; (from nodes to a list of adjacent nodes), return a function on + ;; the nodes which is true IFF the node is UNDENIABLY-DIRTY? or is + ;; adjacent to a node that is transitively-dirty. The algorithm + ;; is simply depth first search. + (define dirty? (make-attribute)) + (define seen? (make-attribute)) + (define (visit u) + (if (not (get-attribute u seen?)) + (begin + (set-attribute! u seen? #T) + (if (undeniably-dirty? u) + (set-attribute! u dirty? #T) + (for-every (adj u) + (lambda (v) + (if (visit v) (set-attribute! u dirty? #T))))))) + (get-attribute u dirty?)) + (for-each visit components) + (lambda (u) (get-attribute u dirty?))) + + (let ((closure.adjacent-closures (make-attribute)) + (closure.closed-over-non-closures? (make-attribute))) + + ;; A closure C (in WIDENABLE-CLOSURES) is adjacent to other + ;; widenable-closures over which it is closed. + (define (adj c) (or (get-attribute c closure.adjacent-closures) '())) + (define (adj! c1 c2) + (set-attribute! c1 closure.adjacent-closures + (cons c2 (adj c1)))) + + ;; True IFF a closure C (in WIDENABLE-CLOSURES) is closed over + ;; anything other than another one of the widenable-closures. + (define (external? c) + (get-attribute c closure.closed-over-non-closures?)) + (define (external! c) + (set-attribute! c closure.closed-over-non-closures? #T)) + + ;; Initialize the ADJ and EXTERNAL? functions + (for-every widenable-closures + (lambda (c) + (let ((values-closed-over + (vector->list (value/closure/location-nodes c)))) + (for-every (map node/unique-value values-closed-over) + (lambda (value) + (if (memq value widenable-closures) + (adj! c value) + (external! c))))))) + + (let* ((components (strongly-connected-components widenable-closures adj)) + (scc-graph (s-c-c->adj components adj))) + ;; Identify the strongly connected components of the graph of + ;; widenable closures closed over one another. All of the + ;; closures in a given component either widen or don't widen. + ;; When they widen, they widen into an odd kind of union of + ;; their closed over components. + + (define (cyclic? component) + ;; By their nature, strongly-connected-components that have + ;; more than one element are cyclic. + (or (not (null? (cdr component))) + (let ((closure (car component))) + (there-exists? (adj closure) + (lambda (adjacent) (eq? closure adjacent)))))) + + (define (primordially-dirty? component) + ;; A strongly connected component can't be widened if it is + ;; cyclic and any component is closed over something outside + ;; itself, since this would lead to an infinite number of + ;; items in its widened representation. + (and (cyclic? component) + (there-exists? component external?))) + + (define (generate-reps-and-name-maps! closures) + (define seen? (make-attribute)) + (define (visit u) + ;; Returns the representation of this closure and calculates + ;; the name map. + (if (get-attribute u seen?) + (value/closure.representation u) + (begin + (set-attribute! u seen? #T) + (set-value/closure.representation! u '()) + (let ((values-closed-over + (vector->list (value/closure/location-nodes u))) + (names-closed-over + (vector->list (value/closure/location-names u))) + (closure-name (closure/name u)) + (the-map '())) + (define (new! old-name new-names) + (define (new-name name) + (dataflow/new-name (string-append + closure-name "." + (symbol-name old-name) "/" + (symbol-name name) "+"))) + (set! the-map + `((,old-name . ,(map new-name new-names)) + . ,the-map)) + 'OK) + (for-each + (lambda (value-node name) + (let ((neighbor (node/unique-value value-node))) + (new! name + (if (memq neighbor closures) + (visit neighbor) + (list name))))) + values-closed-over names-closed-over) + (set-value/closure.name-map! u the-map) + (let ((rep (apply append (reverse (map cdr the-map))))) + ;; The choice of representation is not freely made + ;; here. The actual order must match the order of + ;; the value-computing expressions that appear where + ;; the closure is created, and we don't want to have + ;; to permute those expressions. + (set-value/closure.representation! u rep) + rep))))) + (for-each visit closures)) + + (let* ((is-dirty-because-of-kids? + (transitively-dirty? primordially-dirty? components scc-graph)) + (finally-widenable-closures + (apply append + (list-transform-negative components + (lambda (component) + (and (cyclic? component) + (is-dirty-because-of-kids? component))))))) + (if (not (null? finally-widenable-closures)) + (pp (list 'finally (length finally-widenable-closures) 'widened))) + (generate-reps-and-name-maps! finally-widenable-closures) + finally-widenable-closures)))) + +(define-macro (define-widen-handler keyword bindings . body) + (let ((proc-name (symbol-append 'WIDEN/ keyword))) + (call-with-values + (lambda () (%matchup (cdddr bindings) + '(handler graph name-map form) + '(cdr form))) + (lambda (names code) + `(define ,proc-name + (let ((handler + (lambda ,(cons* (first bindings) (second bindings) + (third bindings) names) + ,@body))) + (named-lambda (,proc-name graph name-map form) + ;; These handlers return a list of forms, to account for the fact + ;; that widening turns single expressions into multiple ones + ,code))))))) + +(define (widen/expr graph name-map expr) + ;; Maps a single expression to a list of (zero or more) expressions + (if (not (pair? expr)) + (illegal expr)) + (case (car expr) + ((ACCESS) (widen/access graph name-map expr)) + ((BEGIN) (widen/begin graph name-map expr)) + ((CALL) (widen/call graph name-map expr)) + ((DECLARE) (widen/declare graph name-map expr)) + ((DEFINE) (widen/define graph name-map expr)) + ((DELAY) (widen/delay graph name-map expr)) + ((IF) (widen/if graph name-map expr)) + ((IN-PACKAGE) (widen/in-package graph name-map expr)) + ((LAMBDA) (widen/lambda graph name-map expr)) + ((LET) (widen/let graph name-map expr)) + ((LETREC) (widen/letrec graph name-map expr)) + ((LOOKUP) (widen/lookup graph name-map expr)) + ((OR) (widen/or graph name-map expr)) + ((QUOTE) (widen/quote graph name-map expr)) + ((SET!) (widen/set! graph name-map expr)) + ((THE-ENVIRONMENT) (widen/the-environment graph name-map expr)) + ((UNASSIGNED?) (widen/unassigned? graph name-map expr)) + (else (illegal expr)))) + + +(define (widen->expr graph name-map expr) + ;; Requires that the widened version be exactly one expression, and + ;; returns that expression + (let ((result (widen/expr graph name-map expr))) + (if (not (singleton-list? result)) + (internal-error "Did not widen to ONE expression" expr result)) + (car result))) + +(define (widen/expr* graph name-map exprs) + ;; Returns a list of lists of expressions + (map (lambda (exp) (widen/expr graph name-map exp)) exprs)) + +(define (widen/flatten-expr* graph name-map exprs) + ;; Maps a list of expressions to a list of expressions (not + ;; necessarily length preserving, of course) + (apply append (widen/expr* graph name-map exprs))) + +(define-widen-handler LOOKUP (graph name-map LOOKUP-form name) + ;; If the name being looked up is one to widen, return lookups of + ;; the names to which it expands; otherwise just return the original + ;; lookup + graph ; Not used + (cond ((assq name name-map) + => (lambda (entry) + (map (lambda (name) `(LOOKUP ,name)) (cdr entry)))) + (else (list LOOKUP-form)))) + +(define (widen/rewrite-bindings name-map names value-nodes continue) + ;; Calls CONTINUE with a (possibly) new name-map and names. + (define (rename formal closure) + ;; Return a list of new names to reference the widened form of a + ;; given FORMAL whose value will be the value represented by CLOSURE + (map (lambda (closed-over) + (dataflow/new-name + (string-append (symbol->string formal) "." + (symbol->string closed-over) + "-"))) + (value/closure.representation closure))) + (let loop ((name-map name-map) + (new-names '()) + (names names) + (nodes value-nodes)) + (cond ((null? nodes) + (continue name-map (reverse new-names))) + ((memq (car names) '(#!REST #!OPTIONAL #!AUX)) + (loop name-map (cons (car names) new-names) (cdr names) nodes)) + ((widen/rewrite? (car nodes)) + (let* ((this (car nodes)) + (formal (car names)) + (closure (node/unique-value this)) + (rep (rename formal closure))) + (loop `((,formal . ,rep) . ,name-map) + `(,@(reverse rep) . ,new-names) + (cdr names) + (cdr nodes)))) + (else (loop name-map + `(,(car names) . ,new-names) + (cdr names) + (cdr nodes)))))) + +(define-widen-handler LAMBDA (graph name-map LAMBDA-form lambda-list body) + ;; The body needs to be rewritten. If the parameter list needs widening it + ;; will require that the body be rewritten with additional local variables + ;; alpha-renamed. Widening happens after CPS conversion, so the body + ;; shouldn't need widening. + + (define (graph->parameter-nodes graph lambda-expr) + (value/procedure/input-nodes + (node/the-procedure-value + (graph/text->node graph lambda-expr)))) + + (no-widening-allowed graph LAMBDA-form) + (widen/rewrite-bindings + name-map + lambda-list + (graph->parameter-nodes graph LAMBDA-form) + (lambda (name-map lambda-list) + `((LAMBDA ,lambda-list ,(widen->expr graph name-map body)))))) + +(define (widen/let-like graph name-map let-or-letrec bindings body) + (let ((bound-names (map car bindings)) + (binding-exprs (map cadr bindings))) + (widen/rewrite-bindings + name-map + bound-names + (map (lambda (expr) (graph/text->node graph expr)) binding-exprs) + (lambda (new-name-map names) + (let* ((which-map (if (eq? let-or-letrec 'LET) name-map new-name-map)) + (value-exprs + (widen/flatten-expr* graph which-map binding-exprs))) + (if (not (= (length value-exprs) (length names))) + (internal-error "LET expansion error" (list names value-exprs))) + `((,let-or-letrec ,(map list names value-exprs) + ,(widen->expr graph new-name-map body)))))))) + +(define-widen-handler LET (graph name-map LET-form bindings body) + (no-widening-allowed graph LET-form) + (widen/let-like graph name-map 'LET bindings body)) + +(define-widen-handler LETREC (graph name-map LETREC-form bindings body) + (no-widening-allowed graph LETREC-form) + (widen/let-like graph name-map 'LETREC bindings body)) + +;;; CONTAINERS: When a non-widenable closure is closed over a +;;; widenable closure, we choose to pack and unpack the elements of +;;; the widened closure in the single slot provided by the unwidened +;;; one. An alternate (preferable?) choice would be to alter the +;;; representation of the non-widenable closure to have extra slots, +;;; but that would require transitively rewriting all references to +;;; those closures. + +(define (widen/create-container exprs) + ;; We choose to use #F ('deleted-container just for now so we can see it) + ;; where it expands to 0 values, the value itself where it expands + ;; to one value, a pair for 2 values, and a vector for any other + ;; case. + (pp `("Creating container" ,(length exprs))) + (case (length exprs) + ;;((0) `'#F) + ((0) `'deleted-container) + ((1) (car exprs)) + ((2) `(CALL ',%cons '#F ,(car exprs) ,(cadr exprs))) + (else `(CALL ',%vector '#F . ,exprs)))) + +(define (widen/unwrap-container n expr) + ;; N is the number of items in the container, and EXPR is the + ;; expression that generates the container's value. + ;; NOTE: We expect RTL CSE to remove the redundant evaluations of EXPR. + ;;(pp `("Unwrapping containter (form below)" ,n)) + ;;(kmp/pp expr) + (case n + ((0) '()) + ((1) (list expr)) + ((2) `((CALL ',car '#F ,expr) + (CALL ',cdr '#F ,expr))) + (else (let loop ((m (- n 1)) + (result '())) + (if (negative? m) + result + (loop (- m 1) + `((CALL ',vector-ref '#F ,expr ',m) . ,result))))))) + +(define (no-CONT-allowed cont) + (if (not (equal? CONT ''#F)) + (internal-error "No continuation allowed" cont))) + +(define (no-widening-allowed graph form) + (if (widen/rewrite? (graph/text->node graph form)) + (internal-error "Widening non-widenable form" form))) + +(define (widen/handler/make-closure graph name-map form rator cont rands) + ;; (CALL ',%make-????-closure '#F 'VECTOR *) + ;; -------- rator ----- cont ------------ rands ------------ + + (define (containerize exprs node) + ;; EXPRS are the expressions corresponding to the value for this NODE. + (if (widen/rewrite? node) + (if (not (= (length exprs) + (length (value/closure.representation node)))) + (internal-error + "Representation mismatch of widened closed value" exprs node) + (widen/create-container exprs)) + (if (not (singleton-list? exprs)) + (internal-error + "Representation mismatch of non-widened closed value" + exprs node) + (car exprs)))) + + ;; If a closure is being widened, it is converted to just + ;; the rewritten * expressions. Otherwise, any closed-over + ;; widenable closures must be converted to containers (see + ;; WIDEN/CREATE-CONTAINER, above). + + (no-CONT-allowed cont) + (let ((value-exprs (cddr rands)) + (the-closure-node (graph/text->node graph form))) + (let ((closure (node/unique-value the-closure-node)) + (exprs (widen/expr* graph name-map value-exprs))) + (if (widen/rewrite? the-closure-node) + (let ((values (apply append exprs))) + (if (not (= (length values) + (length (value/closure.representation closure)))) + (internal-error + "Representation mismatch of make-heap-closure" + rator rands values) + values)) + `((CALL ,rator ,cont + ,(widen->expr graph name-map (car rands)) + ,(cadr rands) + . ,(map containerize + exprs + (map node/unique-value + (vector->list (value/closure/location-nodes closure)))))))))) + +(define (widen/handler/%make-heap-closure graph name-map form rator cont rands) + ;; (CALL ',%make-heap-closure '#F 'VECTOR *) + ;; -------- rator ----- cont ------------ rands ------------ + (no-CONT-allowed cont) + (widen/handler/make-closure graph name-map form rator cont rands)) + +(define (widen/handler/%make-stack-closure + graph name-map form rator cont rands) + ;; (CALL ',%make-stack-closure '#F 'VECTOR *) + ;; -------- rator ------ cont --------------- rands -------------- + (no-CONT-allowed cont) + (widen/handler/make-closure graph name-map form rator cont rands)) + +(define (widen/handler/%make-trivial-closure graph name-map form rator cont rands) + ;; (CALL ',%make-trivial-closure '#F ) + ;; --------- rator ------- cont ----------- rands ---------- + (no-CONT-allowed cont) + (let ((the-closure-node (graph/text->node graph form))) + (if (widen/rewrite? the-closure-node) + '() ; Vanishes entirely! + `((CALL ,rator ,cont ,(widen->expr graph name-map (car rands))))))) + +(define (widen/closure-ref graph name-map form rator cont rands) + ;; (CALL ',%????-closure-ref '#F 'NAME) + ;; ------ rator ------ cont ------- rands --------- + ;; NOTE: is assumed not to require examination (i.e. it + ;; doesn't contain names that are remapped by the NAME-MAP) + (define (widen-closure-ref closure closure-exprs name) + (let ((rep-vector (list->vector (value/closure.representation closure))) + (name-map (value/closure.name-map closure))) + (if (not (= (vector-length rep-vector) (length closure-exprs))) + (internal-error "Closure didn't widen as expected" + closure closure-exprs rep-vector)) + (let ((entry (assq name name-map))) + (if (not entry) + (internal-error "Closure doesn't have desired slot" + closure rep-vector name)) + (map (lambda (name) + (list-ref closure-exprs (vector-index rep-vector name))) + (cdr entry))))) + (let ((my-value (graph/text->node graph form)) + (closure-node (graph/text->node graph (car rands))) + (closure-exprs (widen/expr graph name-map (car rands)))) + (if (widen/rewrite? closure-node) + (widen-closure-ref + (node/unique-value closure-node) closure-exprs (cadr (third rands))) + (if (not (singleton-list? closure-exprs)) + (internal-error + "Unexpected widening of closure being dereferenced" + my-value closure-exprs) + (let ((slot-extractor `(CALL ,rator ,cont ,(car closure-exprs) + ,(second rands) ,(third rands)))) + (if (widen/rewrite? my-value) + (let* ((result-closure (node/unique-value my-value)) + (rep (value/closure.representation result-closure))) + (widen/unwrap-container (length rep) slot-extractor)) + (list slot-extractor))))))) + +(define (widen/handler/%heap-closure-ref graph name-map form rator cont rands) + ;; (CALL ',%heap-closure-ref '#F 'NAME) + ;; ------ rator ------ cont ------- rands --------- + (no-CONT-allowed cont) + (widen/closure-ref graph name-map form rator cont rands)) + +(define (widen/handler/%stack-closure-ref graph name-map form rator cont rands) + ;; (CALL ',%stack-closure-ref '#F 'NAME) + (no-CONT-allowed cont) + (widen/closure-ref graph name-map form rator cont rands)) + +(define (widen/handler/%internal-apply + graph name-map form rator cont rands) + ;; (CALL ',%internal-apply 'NARGS *) + ;; ------ rator ---- ------cont --- --------- rands ----------- + form ; Not used + (let ((widened-operands + (widen/flatten-expr* graph name-map (cddr rands)))) + `((CALL ,rator ,(widen->expr graph name-map cont) + ',(length widened-operands) + ,(widen->expr graph name-map (second rands)) + . ,widened-operands)))) + +(define (widen/handler/%fetch-stack-closure + graph name-map form rator cont rands) + ;; (CALL ',%fetch-stack-closure '#F 'VECTOR) + name-map rator rands ; Not used + (no-widening-allowed graph form) + (no-CONT-allowed cont) + (list form)) + +;;;;;;;;;;;;;;;;;;;;; STEPHEN CHECK TO HERE + +(define (widen/handler/%fetch-continuation + graph name-map form rator cont rands) + ;; (CALL ',%fetch-continuation '#F) + name-map rator ; Not used + (no-CONT-allowed cont) + (no-widening-allowed graph form) + (if (not (null? rands)) + (internal-error "FETCH-CONTINUATION with operands" form rands)) + (list form)) + +(define (widen/handler/%invoke-continuation + graph name-map form rator cont rands) + ;; (CALL ',%invoke-continuation *) + form ; Not used + `((CALL ,rator ,(widen->expr graph name-map cont) + . ,(widen/flatten-expr* graph name-map rands)))) + +(define (widen/handler/default graph name-map form rator cont rands) + form ; Not used + `((CALL ,(widen->expr graph name-map rator) + ,(widen->expr graph name-map cont) + . ,(widen/flatten-expr* graph name-map rands)))) + +(define-widen-handler CALL (graph name-map CALL-form rator cont #!rest rands) + (define (use method) + (method graph name-map CALL-form rator cont rands)) + (if (QUOTE/? rator) + (let ((operator (QUOTE/text rator))) + (cond ((eq? operator %make-heap-closure) + (use widen/handler/%make-heap-closure)) + ((eq? operator %make-stack-closure) + (use widen/handler/%make-stack-closure)) + ((eq? operator %make-trivial-closure) + (use widen/handler/%make-trivial-closure)) + ((eq? operator %heap-closure-ref) + (use widen/handler/%heap-closure-ref)) + ((eq? operator %stack-closure-ref) + (use widen/handler/%stack-closure-ref)) + ((eq? operator %internal-apply) + (use widen/handler/%internal-apply)) + ((eq? operator %fetch-stack-closure) + (use widen/handler/%fetch-stack-closure)) + ((eq? operator %fetch-continuation) + (use widen/handler/%fetch-continuation)) + ((eq? operator %invoke-continuation) + (use widen/handler/%invoke-continuation)) + (else (use widen/handler/default)))) + (use widen/handler/default))) + +(define-widen-handler QUOTE (graph name-map QUOTE-form object) + graph name-map ; ignored + (no-widening-allowed graph QUOTE-form) + `((QUOTE ,object))) + +(define-widen-handler DECLARE (graph name-map DECLARE-form #!rest anything) + graph name-map + (no-widening-allowed graph DECLARE-form) + `((DECLARE ,@anything))) + +(define-widen-handler BEGIN (graph name-map BEGIN-form #!rest actions) + (define (separate l cont) + (if (null? l) + (cont '() '()) + (let loop ((before '()) + (after l)) + (if (null? (cdr after)) + (cont (reverse before) after) + (loop (cons (car after) before) (cdr after)))))) + BEGIN-form ; Unused + (separate actions + (lambda (for-effect value) + (let ((for-effect-exprs (widen/flatten-expr* graph name-map for-effect)) + (value-exprs (widen/flatten-expr* graph name-map value))) + (if (null? value-exprs) + (if (null? for-effect-exprs) + '() ; Vanishes entirely + (internal-error "BEGIN with effects and vanishing value")) + `((BEGIN ,@for-effect-exprs ,(car value-exprs)) + ,@(cdr value-exprs))))))) + +(define-widen-handler IF (graph name-map IF-form pred conseq alt) + (no-widening-allowed graph IF-form) + `((IF ,(widen->expr graph name-map pred) + ,(widen->expr graph name-map conseq) + ,(widen->expr graph name-map alt)))) + +(define-widen-handler SET! (graph name-map SET!-form name value) + (no-widening-allowed graph SET!-form) + (if (assq name name-map) + (internal-error "Widening SET! variable" name)) + `((SET! ,name ,(widen->expr graph name-map value)))) + +(define-widen-handler ACCESS (graph name-map ACCESS-form name env-expr) + (no-widening-allowed graph ACCESS-form) + (if (assq name name-map) + (internal-error "Widening ACCESS variable" name)) + `((ACCESS ,name ,(widen->expr graph name-map env-expr)))) + +(define-widen-handler UNASSIGNED? (graph name-map UNASSIGNED?-form name) + graph name-map ; ignored + (no-widening-allowed graph UNASSIGNED?-form) + (if (assq name name-map) + (internal-error "Widening UNASSIGNED? variable" name) + `((UNASSIGNED? ,name)))) + +(define-widen-handler OR (graph name-map OR-form pred alt) + (no-widening-allowed graph OR-form) + `((OR ,(widen->expr graph name-map pred) + ,(widen->expr graph name-map alt)))) + +(define-widen-handler DELAY (graph name-map DELAY-form expr) + (no-widening-allowed graph DELAY-form) + `((DELAY ,(widen->expr graph name-map expr)))) + +(define-widen-handler DEFINE (graph name-map DEFINE-form name value) + (no-widening-allowed graph DEFINE-form) + `((DEFINE ,name ,(widen->expr graph name-map value)))) + +(define-widen-handler IN-PACKAGE (graph name-map IN-PACKAGE-form envexpr bodyexpr) + (no-widening-allowed graph IN-PACKAGE-form) + `((IN-PACKAGE ,(widen->expr graph name-map envexpr) + ,(widen->expr graph name-map bodyexpr)))) + +(define-widen-handler THE-ENVIRONMENT (graph name-map THE-ENVIRONMENT-form) + graph name-map ; Ignored + (no-widening-allowed graph THE-ENVIRONMENT-form) + `((THE-ENVIRONMENT))) + +(define widen/rewrite! 'LATER) +(define widen/rewrite? 'LATER) +(let ((*nodes-to-rewrite* (make-attribute))) + (set! widen/rewrite! + (lambda (node) (set-attribute! node *nodes-to-rewrite* #T))) + (set! widen/rewrite? + (lambda (node) (get-attribute node *nodes-to-rewrite*)))) + +(define (rewrite-as-widened graph code widenable) + ;; Rewrite CODE after widening all references to the WIDENABLE closures. The + ;; widening is done by side-effecting CODE, and the rewritten CODE is + ;; returned. + (for-every widenable + (lambda (closure) + ;; Mark the closures and all nodes at which the value arrives as + ;; rewritable. + (widen/rewrite! closure) + (for-every (value/nodes closure) widen/rewrite!))) + (form/rewrite! code (widen->expr graph '() code)) + code) + +(define (closure/closed-over-names closure) + (vector->list (value/closure/location-names closure))) + +(define (closure-constructor-text? text) + (or (CALL/%make-heap-closure? text) + (CALL/%make-trivial-closure? text) + (CALL/%make-stack-closure? text))) + +(define (closure-constructor-node? node) + (and (closure-constructor-text? (node/text node)) + (string? (node/name node)))) + +(define (closure-constructor-node/closed-expressions node) + (if (eq? 'TRIVIAL (value/closure/kind (node/unique-value node))) + '() + (cdr (cddddr (node/text node))))) + +(define (fetch-stack-closure-node? node) + (CALL/%fetch-stack-closure? (node/text node))) + +(define let-binding-node? + (let ((pattern `(LET ,(->pattern-variable 'BINDINGS) + ,(->pattern-variable 'BODY)))) + (lambda (node) + (and + (form/match pattern (node/text node)) + #T)))) + +(define (closure-slot-node? node) + (and (closure-constructor-text? (node/text node)) + (pair? (node/name node)))) + +(define-integrable (singleton-list? x) + (and (pair? x) + (null? (cdr x)))) + diff --git a/v8/src/compiler/rtlbase/regset.scm b/v8/src/compiler/rtlbase/regset.scm new file mode 100644 index 000000000..5f5657f81 --- /dev/null +++ b/v8/src/compiler/rtlbase/regset.scm @@ -0,0 +1,143 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/rtlbase/regset.scm,v 1.1 1994/11/19 02:05:54 adams Exp $ + +Copyright (c) 1988, 1990 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Register Sets + +(declare (usual-integrations)) + +(define-integrable (make-regset n-registers) + (make-bit-string n-registers false)) + +(define (for-each-regset-member regset procedure) + (let ((end (bit-string-length regset))) + (let loop ((start 0)) + (let ((register (bit-substring-find-next-set-bit regset start end))) + (if register + (begin + (procedure register) + (loop (1+ register)))))))) + +(define (regset->list regset) + (let ((end (bit-string-length regset))) + (let loop ((start 0)) + (let ((register (bit-substring-find-next-set-bit regset start end))) + (if register + (cons register (loop (1+ register))) + '()))))) + +(define-integrable (regset-clear! regset) + (bit-string-fill! regset false)) + +(define-integrable (regset-disjoint? x y) + (regset-null? (regset-intersection x y))) + +(define-integrable regset-allocate bit-string-allocate) +(define-integrable regset-adjoin! bit-string-set!) +(define-integrable regset-delete! bit-string-clear!) +(define-integrable regset-member? bit-string-ref) +(define-integrable regset=? bit-string=?) +(define-integrable regset-null? bit-string-zero?) + +(define-integrable regset-copy! bit-string-move!) +(define-integrable regset-union! bit-string-or!) +(define-integrable regset-difference! bit-string-andc!) +(define-integrable regset-intersection! bit-string-and!) + +(define-integrable regset-copy bit-string-copy) +(define-integrable regset-union bit-string-or) +(define-integrable regset-difference bit-string-andc) +(define-integrable regset-intersection bit-string-and) + +#| Alternate representation. + +(define-integrable (make-regset n-registers) + n-registers + (list 'REGSET)) + +(define-integrable (regset-allocate n-registers) + n-registers + (list 'REGSET)) + +(define-integrable (for-each-regset-member regset procedure) + (for-each procedure (cdr regset))) + +(define-integrable (regset->list regset) + (list-copy (cdr regset))) + +(define-integrable (regset-clear! regset) + (set-cdr! regset '())) + +(define-integrable (regset-disjoint? x y) + (eq-set-disjoint? (cdr x) (cdr y))) + +(define (regset-adjoin! regset register) + (if (not (memq register (cdr regset))) + (set-cdr! regset (cons register (cdr regset))))) + +(define (regset-delete! regset register) + (set-cdr! regset (delq register (cdr regset)))) + +(define-integrable (regset-member? regset register) + (memq register (cdr regset))) + +(define-integrable (regset=? x y) + (eq-set-same-set? (cdr x) (cdr y))) + +(define-integrable (regset-null? regset) + (null? (cdr regset))) + +(define-integrable (regset-copy! destination source) + (set-cdr! destination (cdr source))) + +(define (regset-union! destination source) + (set-cdr! destination (eq-set-union (cdr source) (cdr destination)))) + +(define (regset-difference! destination source) + (set-cdr! destination (eq-set-difference (cdr destination) (cdr source)))) + +(define (regset-intersection! destination source) + (set-cdr! destination (eq-set-intersection (cdr source) (cdr destination)))) + +(define-integrable regset-copy list-copy) + +(define-integrable (regset-union x y) + (cons 'REGSET (eq-set-union (cdr x) (cdr y)))) + +(define-integrable (regset-difference x y) + (cons 'REGSET (eq-set-difference (cdr x) (cdr y)))) + +(define-integrable (regset-intersection x y) + (cons 'REGSET (eq-set-intersection (cdr x) (cdr y)))) + +|# \ No newline at end of file diff --git a/v8/src/compiler/rtlbase/rgraph.scm b/v8/src/compiler/rtlbase/rgraph.scm new file mode 100644 index 000000000..6c11bf624 --- /dev/null +++ b/v8/src/compiler/rtlbase/rgraph.scm @@ -0,0 +1,72 @@ +#| -*-Scheme-*- + +$Id: rgraph.scm,v 1.1 1994/11/19 02:05:54 adams Exp $ + +Copyright (c) 1987-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Program Graph Abstraction + +(declare (usual-integrations)) + +(define-structure (rgraph (type vector) + (copier false) + (constructor make-rgraph (n-registers))) + n-registers + (entry-edges '()) + (bblocks '()) + register-bblock + register-n-refs + register-n-deaths + register-live-length + register-crosses-call? + register-value-classes + register-known-values + register-known-expressions) + +(define (add-rgraph-bblock! rgraph bblock) + (set-rgraph-bblocks! rgraph (cons bblock (rgraph-bblocks rgraph)))) + +(define (delete-rgraph-bblock! rgraph bblock) + (set-rgraph-bblocks! rgraph (delq! bblock (rgraph-bblocks rgraph)))) + +(define (add-rgraph-entry-edge! rgraph edge) + (set-rgraph-entry-edges! rgraph (cons edge (rgraph-entry-edges rgraph)))) + +(define-integrable rgraph-register-renumber rgraph-register-bblock) +(define-integrable set-rgraph-register-renumber! set-rgraph-register-bblock!) + +(define *rgraphs*) +(define *current-rgraph*) + +(define (rgraph-initial-edges rgraph) + (list-transform-positive (rgraph-entry-edges rgraph) + (lambda (edge) + (node-previous=0? (edge-right-node edge))))) \ No newline at end of file diff --git a/v8/src/compiler/rtlbase/rtlcfg.scm b/v8/src/compiler/rtlbase/rtlcfg.scm new file mode 100644 index 000000000..41e2bc422 --- /dev/null +++ b/v8/src/compiler/rtlbase/rtlcfg.scm @@ -0,0 +1,226 @@ +#| -*-Scheme-*- + +$Id: rtlcfg.scm,v 1.1 1994/11/19 02:05:54 adams Exp $ + +Copyright (c) 1987-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL CFG Nodes + +(declare (usual-integrations)) + +(define-snode sblock) +(define-pnode pblock) + +(define-vector-slots bblock 6 + instructions + live-at-entry + live-at-exit + (new-live-at-exit register-map) + label + continuations) + +(define-vector-slots sblock 12 + continuation) + +(define (make-sblock instructions) + (make-pnode sblock-tag instructions false false false false '() false)) + +(define-vector-slots pblock 12 + consequent-lap-generator + alternative-lap-generator) + +(define (make-pblock instructions) + (make-pnode pblock-tag instructions false false false false '() false false)) + +(define-integrable (statement->srtl statement) + (snode->scfg (make-sblock (make-rtl-instruction statement)))) + +(define-integrable (predicate->prtl predicate) + (pnode->pcfg (make-pblock (make-rtl-instruction predicate)))) + +(let ((bblock-describe + (lambda (bblock) + (descriptor-list bblock + instructions + live-at-entry + live-at-exit + register-map + label + continuations)))) + (set-vector-tag-description! + sblock-tag + (lambda (sblock) + (append! ((vector-tag-description snode-tag) sblock) + (bblock-describe sblock) + (descriptor-list sblock + continuation)))) + (set-vector-tag-description! + pblock-tag + (lambda (pblock) + (append! ((vector-tag-description pnode-tag) pblock) + (bblock-describe pblock) + (descriptor-list pblock + consequent-lap-generator + alternative-lap-generator))))) + +(define-integrable (bblock-reversed-instructions bblock) + (rinst-reversed (bblock-instructions bblock))) + +(define (bblock-compress! bblock limit-predicate) + (let ((walk-next? + (if limit-predicate + (lambda (next) (and next (not (limit-predicate next)))) + (lambda (next) next)))) + (let walk-bblock ((bblock bblock)) + (if (not (node-marked? bblock)) + (begin + (node-mark! bblock) + (if (sblock? bblock) + (let ((next (snode-next bblock))) + (if (walk-next? next) + (begin + (if (null? (cdr (node-previous-edges next))) + (begin + (set-rinst-next! + (rinst-last (bblock-instructions bblock)) + (bblock-instructions next)) + (set-bblock-instructions! + next + (bblock-instructions bblock)) + (snode-delete! bblock))) + (walk-bblock next)))) + (begin + (let ((consequent (pnode-consequent bblock))) + (if (walk-next? consequent) + (walk-bblock consequent))) + (let ((alternative (pnode-alternative bblock))) + (if (walk-next? alternative) + (walk-bblock alternative)))))))))) + +(define (bblock-walk-forward bblock procedure) + (let loop ((rinst (bblock-instructions bblock))) + (procedure rinst) + (if (rinst-next rinst) (loop (rinst-next rinst))))) + +(define (bblock-walk-backward bblock procedure) + (let loop ((rinst (bblock-instructions bblock))) + (if (rinst-next rinst) (loop (rinst-next rinst))) + (procedure rinst))) + +(define (bblock-label! bblock) + (or (bblock-label bblock) + (let ((label (generate-label))) + (set-bblock-label! bblock label) + label))) + +(define (bblock-perform-deletions! bblock) + (define (loop rinst) + (let ((next + (and (rinst-next rinst) + (loop (rinst-next rinst))))) + (if (rinst-rtl rinst) + (begin (set-rinst-next! rinst next) + rinst) + next))) + (let ((instructions (loop (bblock-instructions bblock)))) + (if instructions + (set-bblock-instructions! bblock instructions) + (begin + (snode-delete! bblock) + (set-rgraph-bblocks! *current-rgraph* + (delq! bblock + (rgraph-bblocks *current-rgraph*))))))) + +(define-integrable (pcfg/prefer-consequent! pcfg) + (pcfg/prefer-branch! 'CONSEQUENT pcfg)) + +(define-integrable (pcfg/prefer-alternative! pcfg) + (pcfg/prefer-branch! 'ALTERNATIVE pcfg)) + +(define (pcfg/prefer-branch! branch pcfg) + (let loop ((bblock (cfg-entry-node pcfg))) + (cond ((pblock? bblock) + (pnode/prefer-branch! bblock branch)) + ((sblock? bblock) + (loop (snode-next bblock))) + (else + (error "PCFG/PREFER-BRANCH!: Unknown bblock type" bblock)))) + pcfg) + +(define (pnode/prefer-branch! pnode branch) + (if (not (eq? branch 'NEITHER)) + (cfg-node-put! pnode cfg/prefer-branch/tag branch)) + pnode) + +(define-integrable (pnode/preferred-branch pnode) + (cfg-node-get pnode cfg/prefer-branch/tag)) + +(define cfg/prefer-branch/tag + (intern "#[(compiler)cfg/prefer-branch]")) + +;;;; RTL Instructions + +(define-vector-slots rinst 0 + rtl + dead-registers + next) + +(define-integrable (make-rtl-instruction rtl) + (vector rtl '() false)) + +(define-integrable (make-rtl-instruction* rtl next) + (vector rtl '() next)) + +(define-integrable (rinst-dead-register? rinst register) + (memq register (rinst-dead-registers rinst))) + +(define (rinst-last rinst) + (if (rinst-next rinst) + (rinst-last (rinst-next rinst)) + rinst)) + +(define (rinst-disconnect-previous! bblock rinst) + (let loop ((rinst* (bblock-instructions bblock))) + (if (eq? rinst (rinst-next rinst*)) + (set-rinst-next! rinst* false) + (loop (rinst-next rinst*))))) + +(define (rinst-length rinst) + (let loop ((rinst rinst) (length 0)) + (if rinst + (loop (rinst-next rinst) (1+ length)) + length))) + +(define (rinst-reversed rinst) + (let loop ((rinst rinst) (result '())) + (if rinst + (loop (rinst-next rinst) (cons rinst result)) + result))) \ No newline at end of file diff --git a/v8/src/compiler/rtlbase/rtlcon.scm b/v8/src/compiler/rtlbase/rtlcon.scm new file mode 100644 index 000000000..88b989cd2 --- /dev/null +++ b/v8/src/compiler/rtlbase/rtlcon.scm @@ -0,0 +1,801 @@ +#| -*-Scheme-*- + +$Id: rtlcon.scm,v 1.1 1994/11/19 02:05:54 adams Exp $ + +Copyright (c) 1988-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Register Transfer Language: Complex Constructors +;;; package: (compiler) + +(declare (usual-integrations)) + +;;;; Statements + +(define (rtl:make-assignment locative expression) + (locative-dereference-for-statement locative + (lambda (locative) + (let ((receiver + (lambda (expression) + (rtl:make-assignment-internal locative expression)))) + (if (rtl:pseudo-register-expression? locative) + (expression-simplify-for-pseudo-assignment expression receiver) + (expression-simplify-for-statement expression receiver)))))) + +(define (rtl:make-assignment-internal locative expression) + (cond ((and (or (rtl:register? locative) (rtl:offset? locative)) + (equal? locative expression)) + (make-null-cfg)) + ((or (rtl:register? locative) (rtl:register? expression)) + (%make-assign locative expression)) + (else + (let ((register (rtl:make-pseudo-register))) + (scfg*scfg->scfg! (%make-assign register expression) + (%make-assign locative register)))))) + +(define (rtl:make-pop locative) + (locative-dereference-for-statement locative + (lambda (locative) + (rtl:make-assignment-internal locative (stack-pop-address))))) + +(define (rtl:make-push expression) + (expression-simplify-for-statement expression + (lambda (expression) + (rtl:make-assignment-internal (stack-push-address) expression)))) + +(define (rtl:make-eq-test expression-1 expression-2) + (expression-simplify-for-predicate expression-1 + (lambda (expression-1) + (expression-simplify-for-predicate expression-2 + (lambda (expression-2) + (%make-eq-test expression-1 expression-2)))))) + +;;(define (rtl:make-false-test expression) +;; (rtl:make-eq-test expression (rtl:make-constant false))) +(define (rtl:make-false-test expression) + (rtl:make-pred-1-arg 'FALSE? expression)) + +(define (rtl:make-true-test expression) + (pcfg-invert (rtl:make-false-test expression))) + +(define (rtl:make-type-test expression type) + (expression-simplify-for-predicate expression + (lambda (expression) + (%make-type-test expression type)))) + +(define (rtl:make-pred-1-arg predicate operand) + (expression-simplify-for-predicate operand + (lambda (operand) + (%make-pred-1-arg predicate operand)))) + +(define (rtl:make-pred-2-args predicate operand1 operand2) + (expression-simplify-for-predicate operand1 + (lambda (operand1) + (expression-simplify-for-predicate operand2 + (lambda (operand2) + (%make-pred-2-args predicate operand1 operand2)))))) + +(define (rtl:make-unassigned-test expression) + (rtl:make-eq-test + expression + (rtl:make-cons-non-pointer + (rtl:make-machine-constant (ucode-type unassigned)) + (rtl:make-machine-constant 0)))) + + +(define (rtl:make-fixnum-pred-1-arg predicate operand) + (expression-simplify-for-predicate operand + (lambda (operand) + (%make-fixnum-pred-1-arg predicate operand)))) + +(define (rtl:make-fixnum-pred-2-args predicate operand1 operand2) + (expression-simplify-for-predicate operand1 + (lambda (operand1) + (expression-simplify-for-predicate operand2 + (lambda (operand2) + (%make-fixnum-pred-2-args predicate operand1 operand2)))))) + +(define (rtl:make-flonum-pred-1-arg predicate operand) + (expression-simplify-for-predicate operand + (lambda (operand) + (%make-flonum-pred-1-arg predicate operand)))) + +(define (rtl:make-flonum-pred-2-args predicate operand1 operand2) + (expression-simplify-for-predicate operand1 + (lambda (operand1) + (expression-simplify-for-predicate operand2 + (lambda (operand2) + (%make-flonum-pred-2-args predicate operand1 operand2)))))) + +(define (rtl:make-push-return continuation) + (rtl:make-push + (rtl:make-cons-pointer (rtl:make-machine-constant type-code:compiled-entry) + (rtl:make-entry:continuation continuation)))) + +(define (rtl:make-push-link) + (rtl:make-push + (rtl:make-environment (rtl:make-fetch register:dynamic-link)))) + +(define (rtl:make-pop-link) + (rtl:make-assignment register:dynamic-link + (rtl:make-object->address (stack-pop-address)))) + +(define (rtl:make-stack-pointer->link) + (rtl:make-assignment register:dynamic-link + (rtl:make-fetch register:stack-pointer))) + +(define (rtl:make-link->stack-pointer) + (rtl:make-assignment register:stack-pointer + (rtl:make-fetch register:dynamic-link))) + +(define (rtl:make-constant value) + (if (unassigned-reference-trap? value) + (rtl:make-cons-non-pointer + (rtl:make-machine-constant type-code:unassigned) + (rtl:make-machine-constant 0)) + (%make-constant value))) + + +;;; Interpreter Calls + +(define rtl:make-interpreter-call:access) +(define rtl:make-interpreter-call:unassigned?) +(define rtl:make-interpreter-call:unbound?) +(let ((interpreter-lookup-maker + (lambda (%make) + (lambda (cont environment name) + (expression-simplify-for-statement environment + (lambda (environment) + (%make cont environment name))))))) + (set! rtl:make-interpreter-call:access + (interpreter-lookup-maker %make-interpreter-call:access)) + (set! rtl:make-interpreter-call:unassigned? + (interpreter-lookup-maker %make-interpreter-call:unassigned?)) + (set! rtl:make-interpreter-call:unbound? + (interpreter-lookup-maker %make-interpreter-call:unbound?))) + +(define rtl:make-interpreter-call:define) +(define rtl:make-interpreter-call:set!) +(let ((interpreter-assignment-maker + (lambda (%make) + (lambda (cont environment name value) + (expression-simplify-for-statement value + (lambda (value) + (expression-simplify-for-statement environment + (lambda (environment) + (%make cont environment name value))))))))) + (set! rtl:make-interpreter-call:define + (interpreter-assignment-maker %make-interpreter-call:define)) + (set! rtl:make-interpreter-call:set! + (interpreter-assignment-maker %make-interpreter-call:set!))) + +(define (rtl:make-interpreter-call:lookup cont environment name safe?) + (expression-simplify-for-statement environment + (lambda (environment) + (%make-interpreter-call:lookup cont environment name safe?)))) + +(define (rtl:make-interpreter-call:cache-assignment cont name value) + (expression-simplify-for-statement name + (lambda (name) + (expression-simplify-for-statement value + (lambda (value) + (%make-interpreter-call:cache-assignment cont name value)))))) + +(define (rtl:make-interpreter-call:cache-reference cont name safe?) + (expression-simplify-for-statement name + (lambda (name) + (%make-interpreter-call:cache-reference cont name safe?)))) + +(define (rtl:make-interpreter-call:cache-unassigned? cont name) + (expression-simplify-for-statement name + (lambda (name) + (%make-interpreter-call:cache-unassigned? cont name)))) + +;;;; Expression Simplification + +(package (locative-dereference-for-statement + expression-simplify-for-statement + expression-simplify-for-predicate + expression-simplify-for-pseudo-assignment) + +(define-export (locative-dereference-for-statement locative receiver) + (locative-dereference locative scfg*scfg->scfg! + receiver + (lambda (register offset granularity) + (receiver (make-offset register offset granularity))))) + +(define-export (expression-simplify-for-statement expression receiver) + (expression-simplify expression scfg*scfg->scfg! receiver)) + +(define-export (expression-simplify-for-predicate expression receiver) + (expression-simplify expression scfg*pcfg->pcfg! receiver)) + +(define-export (expression-simplify-for-pseudo-assignment expression receiver) + (let ((entry (assq (car expression) expression-methods))) + (if entry + (apply (cdr entry) receiver scfg*scfg->scfg! (cdr expression)) + (receiver expression)))) + +(define (expression-simplify expression scfg-append! receiver) + (if (rtl:register? expression) + (receiver expression) + (let ((entry (assq (car expression) expression-methods))) + (if entry + (apply (cdr entry) + (lambda (expression) + (if (rtl:register? expression) + (receiver expression) + (assign-to-temporary expression + scfg-append! + receiver))) + scfg-append! + (cdr expression)) + (assign-to-temporary expression scfg-append! receiver))))) + +(define (simplify-expressions expressions scfg-append! generator) + (let loop ((expressions* expressions) (simplified-expressions '())) + (if (null? expressions*) + (generator (reverse! simplified-expressions)) + (expression-simplify (car expressions*) scfg-append! + (lambda (expression) + (loop (cdr expressions*) + (cons expression simplified-expressions))))))) + +(define (assign-to-temporary expression scfg-append! receiver) + (let ((pseudo (rtl:make-pseudo-register))) + (scfg-append! (rtl:make-assignment-internal pseudo expression) + (receiver pseudo)))) + +(define (make-offset register offset granularity) + (case granularity + ((OBJECT) + (rtl:make-offset register (rtl:make-machine-constant offset))) + ((BYTE) + (rtl:make-byte-offset register (rtl:make-machine-constant offset))) + ((FLOAT) + (rtl:make-float-offset register (rtl:make-machine-constant offset))) + (else + (error "unknown offset granularity" granularity)))) + +(define (make-offset-address register offset granularity) + (case granularity + ((OBJECT) + (rtl:make-offset-address register offset)) + ((BYTE) + (rtl:make-byte-offset-address register offset)) + ((FLOAT) + (rtl:make-float-offset-address register offset)) + (else + (error "unknown offset granularity" granularity)))) + +(define (locative-dereference locative scfg-append! if-register if-memory) + (let ((dereference-fetch + (lambda (locative offset granularity) + (let ((if-address + (lambda (address) + (if-memory address offset granularity)))) + (let ((if-not-address + (lambda (register) + (assign-to-address-temporary register + scfg-append! + if-address)))) + (locative-dereference (cadr locative) scfg-append! + (lambda (expression) + (let ((register (rtl:register-number expression))) + (if (and (machine-register? register) + (register-value-class=address? register)) + (if-address expression) + (if-not-address expression)))) + (lambda (register offset granularity) + (assign-to-temporary + (make-offset register offset granularity) + scfg-append! + if-not-address))))))) + (dereference-constant + (lambda (locative offset granularity) + (assign-to-temporary locative scfg-append! + (lambda (register) + (assign-to-address-temporary register scfg-append! + (lambda (register) + (if-memory register offset granularity)))))))) + (cond ((symbol? locative) + (let ((register (rtl:machine-register? locative))) + (if register + (if-register register) + (if-memory (interpreter-regs-pointer) + (rtl:interpreter-register->offset locative) + 'OBJECT)))) + ((pair? locative) + (case (car locative) + ((REGISTER) + (if-register locative)) + ((FETCH) + (dereference-fetch locative 0 'OBJECT)) + ((OFFSET) + (let ((base (rtl:locative-offset-base locative)) + (offset (rtl:locative-offset-offset locative)) + (granularity (rtl:locative-offset-granularity locative))) + (if (not (pair? base)) + (error "offset base not pair" locative)) + (case (car base) + ((FETCH) + (dereference-fetch base offset granularity)) + ((CONSTANT) + (dereference-constant base offset granularity)) + ((INDEX) + (locative-dereference + base + scfg-append! + (lambda (reg) + (error "Can't be a reg" locative reg)) + (lambda (base* zero granularity*) + zero granularity* ; ignored + (if-memory base* offset granularity)))) + ((OFFSET) + (locative-dereference + base + scfg-append! + (lambda (reg) + (error "Can't be a reg" locative reg)) + (lambda (base* offset* granularity*) + (assign-to-temporary + (make-offset-address + base* + (rtl:make-machine-constant offset*) + granularity*) + scfg-append! + (lambda (base-reg) + (if-memory base-reg offset granularity)))))) + (else + (error "illegal offset base" locative))))) + ((INDEX) + (let ((base (rtl:locative-index-base locative)) + (offset (rtl:locative-index-offset locative)) + (granularity (rtl:locative-index-granularity locative))) + (define (finish base-reg-expr offset-expr) + (assign-to-temporary + (make-offset-address base-reg-expr offset-expr granularity) + scfg-append! + (lambda (loc-reg-expr) + ;; granularity ok? + (if-memory loc-reg-expr 0 granularity)))) + (expression-simplify + offset + scfg-append! + (lambda (offset-expr) + (locative-dereference + base + scfg-append! + (lambda (base-reg-expr) + (finish base-reg-expr offset-expr)) + (lambda (base*-reg-expr offset* granularity*) + (if (zero? offset*) + (finish base*-reg-expr offset-expr) + (assign-to-temporary + (make-offset-address + base*-reg-expr + (rtl:make-machine-constant offset*) + granularity*) + scfg-append! + (lambda (loc-reg-expr) + (finish loc-reg-expr offset-expr)))))))))) + ((CONSTANT) + (dereference-constant locative 0 'OBJECT)) + (else + (error "unknown keyword" locative)))) + (else + (error "illegal locative" locative))))) + +(define (assign-to-address-temporary expression scfg-append! receiver) + (let ((pseudo (rtl:make-pseudo-register))) + (scfg-append! + (rtl:make-assignment-internal pseudo + (rtl:make-object->address expression)) + (receiver pseudo)))) + +(define (define-expression-method name method) + (let ((entry (assq name expression-methods))) + (if entry + (set-cdr! entry method) + (set! expression-methods + (cons (cons name method) expression-methods)))) + name) + +(define expression-methods + '()) + +(define-expression-method 'FETCH + (lambda (receiver scfg-append! locative) + (locative-dereference locative scfg-append! + receiver + (lambda (register offset granularity) + (receiver (make-offset register offset granularity)))))) + +(define (address-method generator) + (lambda (receiver scfg-append! locative) + (locative-dereference locative scfg-append! + (lambda (register) + register + (error "Can't take ADDRESS of a register" locative)) + (generator receiver scfg-append!)))) + +(define-expression-method 'ADDRESS + (address-method + (lambda (receiver scfg-append!) + scfg-append! ;ignore + (lambda (address offset granularity) + (receiver + (case granularity + ((OBJECT) + (if (zero? offset) + address + (rtl:make-offset-address address + (rtl:make-machine-constant offset)))) + ((BYTE) + (rtl:make-byte-offset-address address + (rtl:make-machine-constant offset))) + ((FLOAT) + (rtl:make-float-offset-address address + (rtl:make-machine-constant offset))) + (else + (error "ADDRESS: Unknown granularity" granularity)))))))) + +(define-expression-method 'ENVIRONMENT + (address-method + (lambda (receiver scfg-append!) + (lambda (address offset granularity) + (if (not (eq? granularity 'OBJECT)) + (error "can't take address of non-object offset" granularity)) + (let ((receiver + (lambda (address) + (expression-simplify + (rtl:make-cons-pointer + (rtl:make-machine-constant (ucode-type stack-environment)) + address) + scfg-append! + receiver)))) + (if (zero? offset) + (receiver address) + (assign-to-temporary + (rtl:make-offset-address address + (rtl:make-machine-constant offset)) + scfg-append! + receiver))))))) + +(define-expression-method 'CONS-POINTER + (lambda (receiver scfg-append! type datum) + (expression-simplify type scfg-append! + (lambda (type) + (expression-simplify datum scfg-append! + (lambda (datum) + (receiver (rtl:make-cons-pointer type datum)))))))) + +(define-expression-method 'CONS-NON-POINTER + (lambda (receiver scfg-append! type datum) + (expression-simplify type scfg-append! + (lambda (type) + (expression-simplify datum scfg-append! + (lambda (datum) + (receiver (rtl:make-cons-non-pointer type datum)))))))) + +;; +;; The two allocation schemes are: +;; +;; *free++ = r1 +;; ... +;; *free++ = rk +;; rx = (offset-address free -k) +;; result = (cons-pointer type rx) +;; +;; and +;; +;; free[0] = r1 +;; ... +;; free[k-1] = rk +;; result = (cons-pointer type free) +;; free = (offset-address free k) + + +(define (store-element! free element offset) + (if use-pre/post-increment? + (rtl:make-assignment-internal + (rtl:make-post-increment free 1) + element) + (rtl:make-assignment-internal + (rtl:make-offset free (rtl:make-machine-constant offset)) + element))) + +(define (finish-allocation free type words receiver) + (expression-simplify type scfg-append! + (lambda (type) + (if use-pre/post-increment? + (assign-to-temporary + (rtl:make-offset-address free (rtl:make-machine-constant (- words))) + scfg-append! + (lambda (temporary) + (assign-to-temporary + (rtl:make-cons-pointer type temporary) + scfg-append! + receiver))) + (scfg-append! + (assign-to-temporary + (rtl:make-cons-pointer type free) + scfg-append! + (lambda (the-new-object) + (scfg-append! + (rtl:make-assignment-internal + free + (rtl:make-offset-address free + (rtl:make-machine-constant words))) + (receiver the-new-object))))))))) + + +(define-expression-method 'CELL-CONS + (lambda (receiver scfg-append! expression) + (expression-simplify expression scfg-append! + (lambda (expression) + (let ((free (interpreter-free-pointer))) + (scfg-append! + (store-element! free expression 0) + (finish-allocation free + (rtl:make-machine-constant type-code:cell) + 1 receiver))))))) + + +(define-expression-method 'TYPED-CONS:PAIR + (lambda (receiver scfg-append! type car cdr) + (let ((free (interpreter-free-pointer))) + (expression-simplify car scfg-append! + (lambda (car) + (expression-simplify cdr scfg-append! + (lambda (cdr) + (scfg-append! + (store-element! free car 0) + (scfg-append! + (store-element! free cdr 1) + (finish-allocation free type 2 receiver)))))))))) + + +(define-expression-method 'TYPED-CONS:VECTOR + (lambda (receiver scfg-append! type . elements) + (let ((nelements (length elements))) + (if (> nelements (-1+ (number-of-available-word-registers))) + (simplify-cons-long-vector nelements receiver + scfg-append! type elements) + (let* ((free (interpreter-free-pointer))) + (simplify-expressions elements scfg-append! + (lambda (elements) + (expression-simplify + (rtl:make-cons-non-pointer + (rtl:make-machine-constant + (ucode-type manifest-vector)) + (rtl:make-machine-constant (length elements))) + scfg-append! + (lambda (header) + (assign-to-temporary header scfg-append! + (lambda (header-temporary) + (scfg-append! + (store-element! free header-temporary 0) + (let loop ((elements elements) (offset 1)) + (if (null? elements) + (finish-allocation free type offset receiver) + (scfg-append! + (store-element! free (car elements) offset) + (loop (cdr elements) + (+ offset 1))))))))))))))))) + +(define (simplify-cons-long-vector nelements receiver + scfg-append! type elements) + (let* ((chunk-size (-1+ (number-of-available-word-registers))) + (free (interpreter-free-pointer)) + (nchunks (quotient (+ nelements (-1+ chunk-size)) chunk-size))) + + (define (do-chunk elements offset tail) + (simplify-expressions elements scfg-append! + (lambda (elements) + (let loop ((elements elements) (offset offset)) + (if (null? elements) + tail + (scfg-append! (store-element! free (car elements) offset) + (loop (cdr elements) + (1+ offset)))))))) + + (expression-simplify + (rtl:make-cons-non-pointer + (rtl:make-machine-constant + (ucode-type manifest-vector)) + (rtl:make-machine-constant (length elements))) + scfg-append! + (lambda (header) + (scfg-append! + (store-element! free header 0) + (let process ((elements elements) + (offset 1) + (chunk 1)) + (if (= chunk nchunks) + (do-chunk elements + offset + (finish-allocation + free type (1+ nelements) receiver)) + (do-chunk (list-head elements chunk-size) + offset + (process (list-tail elements chunk-size) + (+ offset chunk-size) + (1+ chunk)))))))))) + +;; This re-caches and re-computes if we change the number of registers + +(define number-of-available-word-registers + (let ((reg-list false) + (value false)) + (lambda () + (if (and value + (eq? reg-list available-machine-registers)) + value + (begin + (set! reg-list available-machine-registers) + (set! value + (length (list-transform-positive reg-list + (lambda (reg) + (value-class=word? + (machine-register-value-class reg)))))) + value))))) + +(define-expression-method 'TYPED-CONS:PROCEDURE + (lambda (receiver scfg-append! entry) + (expression-simplify + entry scfg-append! + (lambda (entry) + (receiver (rtl:make-cons-pointer + (rtl:make-machine-constant type-code:compiled-entry) + entry)))))) + +(define-expression-method 'BYTE-OFFSET-ADDRESS + (lambda (receiver scfg-append! base offset) + (expression-simplify + base scfg-append! + (lambda (base) + (expression-simplify + offset scfg-append! + (lambda (offset) + (receiver (rtl:make-byte-offset-address base offset)))))))) + +(define-expression-method 'FLOAT-OFFSET-ADDRESS + (lambda (receiver scfg-append! base offset) + (expression-simplify + base scfg-append! + (lambda (base) + (expression-simplify + offset scfg-append! + (lambda (offset) + (receiver (rtl:make-float-offset-address base offset)))))))) + +;; NOPs for simplification + +(define-expression-method 'ENTRY:CONTINUATION + (lambda (receiver scfg-append! label) + scfg-append! ; unused + (receiver (rtl:make-entry:continuation label)))) + +(define-expression-method 'ENTRY:PROCEDURE + (lambda (receiver scfg-append! label) + scfg-append! ; unused + (receiver (rtl:make-entry:procedure label)))) + +(define-expression-method 'CONS-CLOSURE + (lambda (receiver scfg-append! entry min max size) + scfg-append! ; unused + (receiver (rtl:make-cons-closure entry min max size)))) + +(define-expression-method 'CONS-MULTICLOSURE + (lambda (receiver scfg-append! nentries size entries) + scfg-append! ; unused + (receiver (rtl:make-cons-multiclosure nentries size entries)))) + +(define (object-selector make-object-selector) + (lambda (receiver scfg-append! expression) + (expression-simplify expression scfg-append! + (lambda (expression) + (receiver (make-object-selector expression)))))) + +(define-expression-method 'OBJECT->TYPE + (object-selector rtl:make-object->type)) + +(define-expression-method 'CHAR->ASCII + (object-selector rtl:make-char->ascii)) + +(define-expression-method 'OBJECT->DATUM + (object-selector rtl:make-object->datum)) + +(define-expression-method 'OBJECT->ADDRESS + (object-selector rtl:make-object->address)) + +(define-expression-method 'FIXNUM->OBJECT + (object-selector rtl:make-fixnum->object)) + +(define-expression-method 'FIXNUM->ADDRESS + (object-selector rtl:make-fixnum->address)) + +(define-expression-method 'ADDRESS->FIXNUM + (object-selector rtl:make-address->fixnum)) + +(define-expression-method 'OBJECT->FIXNUM + (object-selector rtl:make-object->fixnum)) + +(define-expression-method 'OBJECT->UNSIGNED-FIXNUM + (object-selector rtl:make-object->unsigned-fixnum)) + +(define-expression-method 'FLOAT->OBJECT + (object-selector rtl:make-float->object)) + +(define-expression-method 'OBJECT->FLOAT + (object-selector rtl:make-object->float)) + +(define-expression-method 'FIXNUM-2-ARGS + (lambda (receiver scfg-append! operator operand1 operand2 overflow?) + (expression-simplify operand1 scfg-append! + (lambda (operand1) + (expression-simplify operand2 scfg-append! + (lambda (operand2) + (receiver + (rtl:make-fixnum-2-args operator + operand1 + operand2 + overflow?)))))))) + +(define-expression-method 'FIXNUM-1-ARG + (lambda (receiver scfg-append! operator operand overflow?) + (expression-simplify operand scfg-append! + (lambda (operand) + (receiver (rtl:make-fixnum-1-arg operator operand overflow?)))))) + +(define-expression-method 'FLONUM-1-ARG + (lambda (receiver scfg-append! operator operand overflow?) + (expression-simplify operand scfg-append! + (lambda (s-operand) + (receiver (rtl:make-flonum-1-arg + operator + s-operand + overflow?)))))) + +(define-expression-method 'FLONUM-2-ARGS + (lambda (receiver scfg-append! operator operand1 operand2 overflow?) + (expression-simplify operand1 scfg-append! + (lambda (s-operand1) + (expression-simplify operand2 scfg-append! + (lambda (s-operand2) + (receiver (rtl:make-flonum-2-args + operator + s-operand1 + s-operand2 + overflow?)))))))) + +;;; end EXPRESSION-SIMPLIFY package +) diff --git a/v8/src/compiler/rtlbase/rtlexp.scm b/v8/src/compiler/rtlbase/rtlexp.scm new file mode 100644 index 000000000..5d824c708 --- /dev/null +++ b/v8/src/compiler/rtlbase/rtlexp.scm @@ -0,0 +1,334 @@ +#| -*-Scheme-*- + +$Id: rtlexp.scm,v 1.1 1994/11/19 02:05:54 adams Exp $ + +Copyright (c) 1987-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Register Transfer Language: Expression Operations +;;; package: (compiler) + +(declare (usual-integrations)) + +(define (rtl:invocation? rtl) + (memq (rtl:expression-type rtl) + '(INVOCATION:APPLY + INVOCATION:JUMP + INVOCATION:COMPUTED-JUMP + INVOCATION:LEXPR + INVOCATION:COMPUTED-LEXPR + INVOCATION:PRIMITIVE + INVOCATION:SPECIAL-PRIMITIVE + INVOCATION:UUO-LINK + INVOCATION:GLOBAL-LINK + INVOCATION:CACHE-REFERENCE + INVOCATION:LOOKUP + INVOCATION:REGISTER + INVOCATION:PROCEDURE + INVOCATION:NEW-APPLY))) + +(define (rtl:invocation-prefix? rtl) + (memq (rtl:expression-type rtl) + '(INVOCATION-PREFIX:DYNAMIC-LINK + INVOCATION-PREFIX:MOVE-FRAME-UP))) + +(define (rtl:expression-value-class expression) + (case (rtl:expression-type expression) + ((REGISTER) + (register-value-class (rtl:register-number expression))) + ((CONS-NON-POINTER CONS-POINTER CONSTANT FIXNUM->OBJECT FLOAT->OBJECT + GENERIC-BINARY GENERIC-UNARY OFFSET POST-INCREMENT + PRE-INCREMENT) + value-class=object) + ((FIXNUM->ADDRESS OBJECT->ADDRESS + ASSIGNMENT-CACHE VARIABLE-CACHE + OFFSET-ADDRESS + FLOAT-OFFSET-ADDRESS + BYTE-OFFSET-ADDRESS + STATIC-CELL ALIGN-FLOAT) + value-class=address) + ((CONS-CLOSURE CONS-MULTICLOSURE ENTRY:CONTINUATION ENTRY:PROCEDURE) + (if untagged-entries? + value-class=object + value-class=address)) + ((MACHINE-CONSTANT) + value-class=immediate) + ((BYTE-OFFSET CHAR->ASCII) + value-class=ascii) + ((OBJECT->DATUM) + value-class=datum) + ((ADDRESS->FIXNUM FIXNUM-1-ARG FIXNUM-2-ARGS OBJECT->FIXNUM + OBJECT->UNSIGNED-FIXNUM) + value-class=fixnum) + ((OBJECT->TYPE) + value-class=type) + ((OBJECT->FLOAT FLONUM-1-ARG FLONUM-2-ARGS FLOAT-OFFSET) + value-class=float) + ((COERCE-VALUE-CLASS) + (case (rtl:coerce-value-class-class expression) + ((ADDRESS) value-class=address) + (else (error "Unknown value class coercion:" expression)))) + (else + (error "Unknown RTL expression type:" expression)))) + +(define (rtl:object-valued-expression? expression) + (value-class=object? (rtl:expression-value-class expression))) + +(define (rtl:volatile-expression? expression) + (memq (rtl:expression-type expression) '(POST-INCREMENT PRE-INCREMENT))) + +(define (rtl:machine-register-expression? expression) + (and (rtl:register? expression) + (machine-register? (rtl:register-number expression)))) + +(define (rtl:pseudo-register-expression? expression) + (and (rtl:register? expression) + (pseudo-register? (rtl:register-number expression)))) + +(define (rtl:stack-reference-expression? expression) + (and (rtl:offset? expression) + (interpreter-stack-pointer? (rtl:offset-base expression)))) + +(define (rtl:register-assignment? rtl) + (and (rtl:assign? rtl) + (rtl:register? (rtl:assign-address rtl)))) + +(define (rtl:expression-cost expression) + (if (rtl:register? expression) + 1 + (or (rtl:constant-cost expression) + (let loop ((parts (cdr expression)) (cost 2)) + (if (null? parts) + cost + (loop (cdr parts) + (if (pair? (car parts)) + (+ cost (rtl:expression-cost (car parts))) + cost))))))) + +(define (rtl:map-subexpressions expression procedure) + (if (rtl:constant? expression) + expression + (cons (car expression) + (map (lambda (x) + (if (pair? x) + (procedure x) + x)) + (cdr expression))))) + +(define (rtl:for-each-subexpression expression procedure) + (if (not (rtl:constant? expression)) + (for-each (lambda (x) + (if (pair? x) + (procedure x))) + (cdr expression)))) + +(define (rtl:any-subexpression? expression predicate) + (and (not (rtl:constant? expression)) + (there-exists? (cdr expression) + (lambda (x) + (and (pair? x) + (predicate x)))))) + +(define (rtl:expression-contains? expression predicate) + (let loop ((expression expression)) + (or (predicate expression) + (rtl:any-subexpression? expression loop)))) + +(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) + if-not + (lambda (x) + (if (pair? x) + (if-expression x) + (if-not x)))))) + (let loop ((parts (cdr expression)) (accum initial)) + (if (null? parts) + accum + (loop (cdr parts) + (operator accum (remap (car parts)))))))) + +(define (rtl:expression=? x y) + (let ((type (car x))) + (and (eq? type (car y)) + (if (eq? type 'CONSTANT) + (eqv? (cadr x) (cadr y)) + (let loop ((x (cdr x)) (y (cdr y))) + ;; Because of fixed format, all expressions of same + ;; type have the same length, and each entry is either + ;; a subexpression or a non-expression. + (or (null? x) + (and (if (pair? (car x)) + (rtl:expression=? (car x) (car y)) + (eqv? (car x) (car y))) + (loop (cdr x) (cdr y))))))))) + +(define (rtl:match-subexpressions x y predicate) + (let ((type (car x))) + (and (eq? type (car y)) + (if (eq? type 'CONSTANT) + (eqv? (cadr x) (cadr y)) + (let loop ((x (cdr x)) (y (cdr y))) + (or (null? x) + (and (if (pair? (car x)) + (predicate (car x) (car y)) + (eqv? (car x) (car y))) + (loop (cdr x) (cdr y))))))))) + +(define (rtl:refers-to-register? rtl register) + (let loop + ((expression + (if (rtl:register-assignment? rtl) (rtl:assign-expression rtl) rtl))) + (cond ((not (pair? expression)) false) + ((rtl:register? expression) + (= (rtl:register-number expression) register)) + ((rtl:contains-no-substitutable-registers? expression) false) + (else (there-exists? (cdr expression) loop))))) + +(define (rtl:subst-register rtl register substitute) + (letrec + ((loop + (lambda (expression) + (cond ((not (pair? expression)) expression) + ((rtl:register? expression) + (if (= (rtl:register-number expression) register) + substitute + expression)) + ((rtl:contains-no-substitutable-registers? expression) + expression) + (else (cons (car expression) (map loop (cdr expression)))))))) + (if (rtl:register-assignment? rtl) + (list (rtl:expression-type rtl) + (rtl:assign-address rtl) + (loop (rtl:assign-expression rtl))) + (loop rtl)))) + +(define (rtl:substitutable-registers rtl) + (if (rtl:register-assignment? rtl) + (rtl:substitutable-registers (rtl:assign-expression rtl)) + (let outer ((expression rtl) (registers '())) + (cond ((not (pair? expression)) registers) + ((rtl:register? expression) + (let ((register (rtl:register-number expression))) + (if (memq register registers) + registers + (cons register registers)))) + ((rtl:contains-no-substitutable-registers? expression) registers) + (else + (let inner + ((subexpressions (cdr expression)) (registers registers)) + (if (null? subexpressions) + registers + (inner (cdr subexpressions) + (outer (car subexpressions) registers))))))))) + +(define (rtl:contains-no-substitutable-registers? expression) + ;; True for all expressions that cannot possibly contain registers. + ;; In addition, this is also true of expressions that do contain + ;; registers but are not candidates for substitution (e.g. + ;; `pre-increment'). + (memq (rtl:expression-type expression) + '(ASSIGNMENT-CACHE + CONS-CLOSURE + CONS-MULTICLOSURE + CONSTANT + ENTRY:CONTINUATION + ENTRY:PROCEDURE + MACHINE-CONSTANT + POST-INCREMENT + PRE-INCREMENT + VARIABLE-CACHE + STATIC-CELL))) + +(define (rtl:constant-expression? expression) + (case (rtl:expression-type expression) + ((ASSIGNMENT-CACHE + CONSTANT + ENTRY:CONTINUATION + ENTRY:PROCEDURE + MACHINE-CONSTANT + VARIABLE-CACHE + STATIC-CELL) + true) + ((BYTE-OFFSET-ADDRESS + CHAR->ASCII + CONS-NON-POINTER + CONS-POINTER + FIXNUM-1-ARG + FIXNUM-2-ARGS + FIXNUM->ADDRESS + FIXNUM->OBJECT + FLOAT-OFFSET-ADDRESS + FLONUM-1-ARG + FLONUM-2-ARGS + GENERIC-BINARY + GENERIC-UNARY + OBJECT->ADDRESS + OBJECT->DATUM + OBJECT->FIXNUM + OBJECT->TYPE + OBJECT->UNSIGNED-FIXNUM + OFFSET-ADDRESS) + (let loop ((subexpressions (cdr expression))) + (or (null? subexpressions) + (and (let ((expression (car subexpressions))) + (or (not (pair? expression)) + (rtl:constant-expression? expression))) + (loop (cdr subexpressions)))))) + (else + false))) + +(define (rtx-set/union* set sets) + (let loop ((set set) (sets sets) (accum '())) + (let ((set (rtx-set/union set accum))) + (if (null? sets) + set + (loop (car sets) (cdr sets) set))))) + +(define (rtx-set/union x y) + (if (null? y) + x + (let loop ((x x) (y y)) + (if (null? x) + y + (loop (cdr x) + (let ((x (car x))) + (if (there-exists? y + (lambda (y) + (rtl:expression=? x y))) + y + (cons x y)))))))) \ No newline at end of file diff --git a/v8/src/compiler/rtlbase/rtline.scm b/v8/src/compiler/rtlbase/rtline.scm new file mode 100644 index 000000000..7e4c65ee5 --- /dev/null +++ b/v8/src/compiler/rtlbase/rtline.scm @@ -0,0 +1,206 @@ +#| -*-Scheme-*- + +$Id: rtline.scm,v 1.1 1994/11/19 02:05:54 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL linearizer +;; package: (compiler rtl-generator) + +(declare (usual-integrations)) + +(define ((make-linearizer bblock-linearize + initial-value + instruction-append! + final-value) + root procedures continuations conts-linked?) + (with-new-node-marks + (lambda () + (let ((input-queue (make-queue)) + (output (initial-value))) + (let* ((queue-continuations! + (lambda (bblock) + (for-each (lambda (bblock) + (if (not (node-marked? bblock)) + (enqueue!/unsafe input-queue bblock))) + (bblock-continuations bblock)))) + (process-bblock! + (lambda (bblock) + (if (not (node-marked? bblock)) + (set! output + (instruction-append! + output + (bblock-linearize bblock + queue-continuations!))))))) + (if (pair? root) + (for-each (lambda (rgraph) + (for-each + (lambda (edge) + (process-bblock! (edge-right-node edge))) + (rgraph-entry-edges rgraph))) + root) + (process-bblock! + (cond ((rtl-expr? root) (rtl-expr/entry-node root)) + ((rtl-procedure? root) (rtl-procedure/entry-node root)) + (else (error "Illegal linearization root" root))))) + (queue-map!/unsafe input-queue process-bblock!) + (for-each (lambda (procedure) + (process-bblock! (rtl-procedure/entry-node procedure)) + (queue-map!/unsafe input-queue process-bblock!)) + procedures) + (if (not conts-linked?) + (for-each + (lambda (cont) + (process-bblock! (rtl-continuation/entry-node cont)) + (queue-map!/unsafe input-queue process-bblock!)) + continuations)) + (final-value output)))))) + +(define (setup-bblock-continuations! rgraphs) + (for-each + (lambda (rgraph) + (for-each + (lambda (bblock) + (let ((continuations '())) + (bblock-walk-forward bblock + (lambda (rinst) + (let loop ((expression (cdr (rinst-rtl rinst)))) + (if (pair? expression) + (cond ((eq? (car expression) 'ENTRY:CONTINUATION) + ;; Because the average number of + ;; continuations per basic block is usually + ;; less than one, we optimize this case to + ;; speed up the accumulation. + (cond ((null? continuations) + (set! continuations + (list (cadr expression)))) + ((not (memq (cadr expression) continuations)) + (set! continuations + (cons (cadr expression) + continuations))))) + ((not (eq? (car expression) 'CONSTANT)) + (for-each loop (cdr expression)))))))) + (set-bblock-continuations! + bblock + (map (lambda (label) + (rtl-continuation/entry-node (label->object label))) + continuations))) + (if (sblock? bblock) + (let ((rtl (rinst-rtl (rinst-last (bblock-instructions bblock))))) + (if (rtl:invocation? rtl) + (let ((continuation (rtl:invocation-continuation rtl))) + (if continuation + (set-sblock-continuation! + bblock + (rtl-continuation/entry-node + (label->object continuation))))))))) + (rgraph-bblocks rgraph))) + rgraphs)) + +;;; The linearizer attaches labels to nodes under two conditions. The +;;; first is that the node in question has more than one previous +;;; neighboring node. The other is when a conditional branch requires +;;; such a label. It is assumed that if one encounters a node that +;;; has already been linearized, that it has a label, since this +;;; implies that it has more than one previous neighbor. + +(define (bblock-linearize-rtl bblock queue-continuations!) + (define (linearize-bblock bblock) + (node-mark! bblock) + (queue-continuations! bblock) + (if (and (not (bblock-label bblock)) + (node-previous>1? bblock)) + (bblock-label! bblock)) + (let ((kernel + (lambda () + (let loop ((rinst (bblock-instructions bblock))) + (cond ((rinst-next rinst) + (cons (rinst-rtl rinst) (loop (rinst-next rinst)))) + ((sblock? bblock) + (cons (rinst-rtl rinst) + (let ((next (snode-next bblock))) + (if next + (linearize-sblock-next next) + (let ((bblock (sblock-continuation bblock))) + (if (and bblock + (not (node-marked? bblock))) + (linearize-bblock bblock) + '())))))) + (else + (linearize-pblock bblock + (rinst-rtl rinst) + (pnode-consequent bblock) + (pnode-alternative bblock)))))))) + (if (bblock-label bblock) + `(,(rtl:make-label-statement (bblock-label bblock)) ,@(kernel)) + (kernel)))) + + (define (linearize-sblock-next bblock) + (if (node-marked? bblock) + `(,(rtl:make-jump-statement (bblock-label bblock))) + (linearize-bblock bblock))) + + (define (linearize-pblock pblock predicate cn an) + (let ((heed-preference + (lambda (finish) + (if (eq? 'CONSEQUENT (pnode/preferred-branch pblock)) + (finish (rtl:negate-predicate predicate) an cn) + (finish predicate cn an))))) + (if (node-marked? cn) + (if (node-marked? an) + (heed-preference + (lambda (predicate cn an) + `(,(rtl:make-jumpc-statement predicate (bblock-label cn)) + ,(rtl:make-jump-statement (bblock-label an))))) + `(,(rtl:make-jumpc-statement predicate (bblock-label cn)) + ,@(linearize-bblock an))) + (if (node-marked? an) + `(,(rtl:make-jumpc-statement (rtl:negate-predicate predicate) + (bblock-label an)) + ,@(linearize-bblock cn)) + (heed-preference + (lambda (predicate cn an) + (let ((clabel (bblock-label! cn)) + (alternative (linearize-bblock an))) + `(,(rtl:make-jumpc-statement predicate clabel) + ,@alternative + ,@(if (node-marked? cn) '() (linearize-bblock cn)))))))))) + + (linearize-bblock bblock)) + +(define linearize-rtl + (make-linearizer bblock-linearize-rtl + (lambda () (let ((value (list false))) (cons value value))) + (lambda (accumulator instructions) + (set-cdr! (cdr accumulator) instructions) + (set-cdr! accumulator (last-pair instructions)) + accumulator) + cdar)) \ No newline at end of file diff --git a/v8/src/compiler/rtlbase/rtlobj.scm b/v8/src/compiler/rtlbase/rtlobj.scm new file mode 100644 index 000000000..3e7ea6969 --- /dev/null +++ b/v8/src/compiler/rtlbase/rtlobj.scm @@ -0,0 +1,137 @@ +#| -*-Scheme-*- + +$Id: rtlobj.scm,v 1.1 1994/11/19 02:05:54 adams Exp $ + +Copyright (c) 1988-92 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Register Transfer Language: Object Datatypes + +(declare (usual-integrations)) + +(define-structure (rtl-expr + (conc-name rtl-expr/) + (constructor make-rtl-expr + (rgraph label entry-edge debugging-info)) + (print-procedure + (standard-unparser (symbol->string 'RTL-EXPR) + (lambda (state expression) + (unparse-object state (rtl-expr/label expression)))))) + (rgraph false read-only true) + (label false read-only true) + (entry-edge false read-only true) + (debugging-info false read-only true)) + +(define-integrable (rtl-expr/entry-node expression) + (edge-right-node (rtl-expr/entry-edge expression))) + +(define-structure (rtl-procedure + (conc-name rtl-procedure/) + (constructor make-rtl-procedure + (rgraph label entry-edge name n-required + n-optional rest? closure? + dynamic-link? type + debugging-info + next-continuation-offset stack-leaf?)) + (print-procedure + (standard-unparser (symbol->string 'RTL-PROCEDURE) + (lambda (state procedure) + (unparse-object state + (rtl-procedure/label procedure)))))) + (rgraph false read-only true) + (label false read-only true) + (entry-edge false read-only true) + (name false read-only true) + (n-required false read-only true) + (n-optional false read-only true) + (rest? false read-only true) + (closure? false read-only true) + (dynamic-link? false read-only true) + (type false read-only true) + (%external-label false) + (debugging-info false read-only true) + (next-continuation-offset false read-only true) + (stack-leaf? false read-only true)) + +(define-integrable (rtl-procedure/entry-node procedure) + (edge-right-node (rtl-procedure/entry-edge procedure))) + +(define (rtl-procedure/external-label procedure) + (or (rtl-procedure/%external-label procedure) + (let ((label (generate-label (rtl-procedure/name procedure)))) + (set-rtl-procedure/%external-label! procedure label) + label))) + +(define-structure (rtl-continuation + (conc-name rtl-continuation/) + (constructor make-rtl-continuation + (rgraph label entry-edge + next-continuation-offset + debugging-info)) + (print-procedure + (standard-unparser (symbol->string 'RTL-CONTINUATION) + (lambda (state continuation) + (unparse-object + state + (rtl-continuation/label continuation)))))) + (rgraph false read-only true) + (label false read-only true) + (entry-edge false read-only true) + (next-continuation-offset false read-only true) + (debugging-info false read-only true)) + +(define-integrable (rtl-continuation/entry-node continuation) + (edge-right-node (rtl-continuation/entry-edge continuation))) + +(define (make/label->object expression procedures continuations) + (let ((hash-table + (make-eq-hash-table + (+ (if expression 1 0) + (length procedures) + (length continuations))))) + (if expression + (hash-table/put! hash-table + (rtl-expr/label expression) + expression)) + (for-each (lambda (procedure) + (hash-table/put! hash-table + (rtl-procedure/label procedure) + procedure)) + procedures) + (for-each (lambda (continuation) + (hash-table/put! hash-table + (rtl-continuation/label continuation) + continuation)) + continuations) + (lambda (label) + (let ((datum (hash-table/get hash-table label #f))) + (if (not datum) + (error "Undefined label:" label)) + datum)))) \ No newline at end of file diff --git a/v8/src/compiler/rtlbase/rtlpars.scm b/v8/src/compiler/rtlbase/rtlpars.scm new file mode 100644 index 000000000..5440c0bd5 --- /dev/null +++ b/v8/src/compiler/rtlbase/rtlpars.scm @@ -0,0 +1,367 @@ +#| -*-Scheme-*- + +$Id: rtlpars.scm,v 1.1 1994/11/19 02:05:54 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL parser +;;; package: (compiler rtl-parser) + +(declare (usual-integrations)) + +(define label-like-statements + '(LABEL RETURN-ADDRESS PROCEDURE TRIVIAL-CLOSURE CLOSURE EXPRESSION)) + +(define jump-like-statements + ;; JUMPC is special. + ;; Also missing some other INVOCATION:s and INTERPRETER-CALL:s + ;; but the new compiler never uses them. + '(JUMP + POP-RETURN INVOCATION:NEW-APPLY + INVOCATION:REGISTER INVOCATION:PROCEDURE + INVOCATION:UUO-LINK INVOCATION:GLOBAL-LINK + INVOCATION:PRIMITIVE INVOCATION:APPLY + INVOCATION:SPECIAL-PRIMITIVE + INTERPRETER-CALL:CACHE-REFERENCE + INTERPRETER-CALL:CACHE-ASSIGNMENT)) + +(define (internal-error message . more) + (apply error "rtl->rtl-graph internal error:" message more)) + +(define *rgraphs*) +(define *expressions*) +(define *procedures*) +(define *continuations*) + +(define (rtl->rtl-graph rtl-program) + ;; (values expression procedures continuations rgraphs) + (fluid-let ((*rgraphs* '()) + (*expressions* '()) + (*procedures* '()) + (*continuations* '())) + (let ((labels->segments (parse-rtl rtl-program))) + (hash-table/for-each labels->segments reformat!) + (hash-table/for-each labels->segments + (lambda (label slot) + label ; ignored + (link-up! slot labels->segments))) + (hash-table/for-each labels->segments rgraphify!/1) + (hash-table/for-each labels->segments rgraphify!/2) + (hash-table/for-each labels->segments rgraphify!/3) + (values (cond ((null? *expressions*) + (if *procedure-result?* + false + (internal-error "No expression found"))) + ((not (null? (cdr *expressions*))) + (internal-error "Too many expressions found")) + (else + (car *expressions*))) + *procedures* + *continuations* + *rgraphs*)))) + +;;; The following procedures solve a union/find problem. +;;; They use the bblock-live-at-entry field temporarily to associate +;;; a bblock with its set. The field is cleared at the end. + +(define (rgraphify!/1 label slot) + label ; ignored + (if (not (eq? (car slot) 'EMPTY)) + (let ((bblock (caddr slot))) + (set-bblock-live-at-entry! bblock (list false bblock))))) + +(define (rgraphify!/2 label slot) + label ; ignored + (if (not (eq? (car slot) 'EMPTY)) + (let* ((bblock (caddr slot)) + (set (bblock-live-at-entry bblock)) + (to-bash set) + (unify! + (lambda (bblock*) + (let ((set* (bblock-live-at-entry bblock*))) + (if (not (eq? set* set)) + (let ((set** (cdr set*))) + (for-each (lambda (bblock**) + (set-bblock-live-at-entry! bblock** set)) + set**) + (append! to-bash set**) + (set! to-bash set**))))))) + (for-each (lambda (edge) + (unify! (edge-left-node edge))) + (node-previous-edges bblock))))) + +(define (rgraphify!/3 label slot) + label ; ignored + (if (not (eq? (car slot) 'EMPTY)) + (let* ((bblock (caddr slot)) + (set (bblock-live-at-entry bblock))) + (if (not (car set)) + (set-car! set (->rgraph (cdr set)))) + (classify! bblock (car set)) + (set-bblock-live-at-entry! bblock false)))) + +(define (->rgraph bblocks) + (let* ((max-reg + (fold-right (lambda (bblock max-reg) + (max (bblock->max-reg bblock) + max-reg)) + (- number-of-machine-registers 1) + bblocks)) + (rgraph (make-rgraph (+ max-reg 1)))) + (set-rgraph-bblocks! rgraph bblocks) + (set! *rgraphs* (cons rgraph *rgraphs*)) + rgraph)) + +(define (bblock->max-reg bblock) + (let loop ((insts (bblock-instructions bblock)) + (max-reg -1)) + (if (not insts) + max-reg + (loop (rinst-next insts) + (max max-reg + (let walk ((rtl (rinst-rtl insts))) + (cond ((not (pair? rtl)) + max-reg) + ((eq? (car rtl) 'REGISTER) + (cadr rtl)) + ((eq? (car rtl) 'CONSTANT) + max-reg) + (else + (max (walk (car rtl)) (walk (cdr rtl))))))))))) + +(define (reformat! label slot) + (define (->rinsts stmts) + (let loop ((stmts stmts) + (next false)) + (if (null? stmts) + next + (loop (cdr stmts) + (make-rtl-instruction* (car stmts) next))))) + + (let* ((stmts (cadr slot)) + (result + (cond ((null? stmts) + (internal-error "Null segment" label)) + ((not (eq? (caar stmts) 'JUMP)) + (list (let ((stmt (car stmts))) + (cond ((eq? (car stmt) 'INVOCATION:SPECIAL-PRIMITIVE) + (caddr stmt)) + ((memq (car stmt) + '(INTERPRETER-CALL:CACHE-REFERENCE + INTERPRETER-CALL:CACHE-ASSIGNMENT)) + (cadr stmt)) + (else + false))) + (make-sblock (->rinsts stmts)))) + ((and (not (null? (cdr stmts))) + (eq? (car (cadr stmts)) 'JUMPC)) + (let ((jump-inst (car stmts)) + (jumpc-inst (cadr stmts))) + (let ((jump-label (cadr jump-inst)) + (jumpc-label (caddr jumpc-inst)) + (predicate (cadr jumpc-inst)) + (finish + (lambda (predicate preference trueb falseb) + (list (list trueb falseb) + (pnode/prefer-branch! + (make-pblock + (->rinsts (cons predicate (cddr stmts)))) + preference))))) + (cond ((not (pair? predicate)) + (finish predicate + 'NEITHER + jumpc-label + jump-label)) + ((eq? 'UNPREDICTABLE (car predicate)) + (finish (cadr predicate) + 'NEITHER + jumpc-label + jump-label)) + ((eq? 'NOT (car predicate)) + (finish (cadr predicate) + 'ALTERNATIVE + jump-label + jumpc-label)) + (else + (finish predicate + 'CONSEQUENT + jumpc-label + jump-label)))))) + (else + (list (cadr (car stmts)) + (make-sblock (->rinsts (cdr stmts)))))))) + (set-car! slot + (if (bblock-instructions (cadr result)) + 'BBLOCK + 'EMPTY)) + (set-cdr! slot result) + #| (set-bblock-label! (cadr result) label) |# + unspecific)) + +(define (link-up! slot labels->segments) + (define (find-bblock label) + (let ((desc (hash-table/get labels->segments label false))) + (if (not desc) + (internal-error "Missing label" label)) + (if (eq? (car desc) 'EMPTY) + (find-bblock (cadr desc)) + (caddr desc)))) + + (if (not (eq? (car slot) 'EMPTY)) + (let ((next (cadr slot)) + (bblock (caddr slot))) + (cond ((not next)) + ((not (pair? next)) + (create-edge! bblock + set-snode-next-edge! + (find-bblock next))) + (else + (create-edge! bblock + set-pnode-consequent-edge! + (find-bblock (car next))) + (create-edge! bblock + set-pnode-alternative-edge! + (find-bblock (cadr next)))))))) + +(define-macro (%push! object collection) + `(begin (set! ,collection (cons ,object ,collection)) + unspecific)) + +(define (classify! bblock rgraph) + ;; Most of the fields are meaningless for the new headers + ;; since the information is explicit in the RTL (e.g. INTERRUPT-CHECK:) + (let* ((gen-edge + (lambda () + (let ((edge (create-edge! false false bblock))) + (add-rgraph-entry-edge! rgraph edge) + edge))) + (insts (bblock-instructions bblock)) + (rtl (rinst-rtl insts))) + (case (car rtl) + ((RETURN-ADDRESS) + (%push! + (make-rtl-continuation + rgraph ; rgraph + (cadr rtl) ; label + (gen-edge) ; entry edge + false ; next continuation offset + false ; debugging info + ) + *continuations*)) + ((PROCEDURE CLOSURE TRIVIAL-CLOSURE) + (let ((proc + (make-rtl-procedure + rgraph ; rgraph + (cadr rtl) ; label + (gen-edge) ; entry edge + (cadr rtl) ; name + false ; nrequired + false ; noptional + false ; rest + (not (eq? (car rtl) 'PROCEDURE)) ; closure? + false ; dynamic link? + (car rtl) ; type + false ; debugging info + false ; next continuation offset + false ; stack leaf? + ))) + (set-rtl-procedure/%external-label! proc (cadr rtl)) + (%push! proc *procedures*))) + ((EXPRESSION) + (%push! + (make-rtl-expr + rgraph ; rgraph + (cadr rtl) ; label + (gen-edge) ; entry edge + false ; debugging info + ) + *expressions*))))) + +(define (parse-rtl rtl-program) + (cond ((null? rtl-program) + (internal-error "Empty program")) + ((not (memq (caar rtl-program) label-like-statements)) + (internal-error "Program does not start with label" rtl-program))) + (let ((labels->segments (make-eq-hash-table))) + (define (found-one label stmts) + (hash-table/put! labels->segments + label + (list 'STATEMENTS stmts))) + + (let loop ((program (cdr rtl-program)) + (label (cadr (car rtl-program))) + (segment (if (eq? (caar rtl-program) 'LABEL) + '() + (list (car rtl-program))))) + (if (null? program) + (begin + (if (not (null? segment)) + (internal-error "Last segment falls through" + (reverse segment)))) + (let ((stmt (car program))) + (cond ((memq (car stmt) jump-like-statements) + (found-one label (cons stmt segment)) + (if (not (null? (cdr program))) + (let ((next (cadr program))) + (if (not (memq (car next) label-like-statements)) + (internal-error "No label following jump" + program)) + (loop (cddr program) + (cadr next) + (if (eq? (car next) 'LABEL) + '() + (list next)))))) + ((eq? (car stmt) 'JUMPC) + (if (null? (cdr program)) + (internal-error "Last segment falls through when false" + (reverse (cons stmt segment)))) + (let ((next (cadr program))) + (if (eq? 'JUMP (car next)) + (loop (cdr program) + label + (cons stmt segment)) + (let ((label (generate-label))) + (loop (cons `(LABEL ,label) (cdr program)) + label + (cons stmt segment)))))) + ((memq (car stmt) label-like-statements) + (if (not (eq? (car stmt) 'LABEL)) + (internal-error "Falling through to non-label label" + (car stmt))) + (found-one label (cons `(JUMP ,(cadr stmt)) segment)) + (loop (cdr program) + (cadr stmt) + '())) + (else + (loop (cdr program) + label + (cons stmt segment))))))) + labels->segments)) \ No newline at end of file diff --git a/v8/src/compiler/rtlbase/rtlreg.scm b/v8/src/compiler/rtlbase/rtlreg.scm new file mode 100644 index 000000000..f54399938 --- /dev/null +++ b/v8/src/compiler/rtlbase/rtlreg.scm @@ -0,0 +1,145 @@ +#| -*-Scheme-*- + +$Id: rtlreg.scm,v 1.1 1994/11/19 02:05:54 adams Exp $ + +Copyright (c) 1987-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Registers + +(declare (usual-integrations)) + +(define *machine-register-map*) + +(define (initialize-machine-register-map!) + (set! *machine-register-map* + (let ((map (make-vector number-of-machine-registers))) + (let loop ((n 0)) + (if (< n number-of-machine-registers) + (begin (vector-set! map n (%make-register n)) + (loop (1+ n))))) + map))) + +(define-integrable (rtl:make-machine-register n) + (vector-ref *machine-register-map* n)) + +(define-integrable (machine-register? register) + (< register number-of-machine-registers)) + +(define (for-each-machine-register procedure) + (let ((limit number-of-machine-registers)) + (define (loop register) + (if (< register limit) + (begin (procedure register) + (loop (1+ register))))) + (loop 0))) + +(define (rtl:make-pseudo-register) + (let ((n (rgraph-n-registers *current-rgraph*))) + (set-rgraph-n-registers! *current-rgraph* (1+ n)) + (%make-register n))) + +(define-integrable (pseudo-register? register) + (>= register number-of-machine-registers)) + +(define (for-each-pseudo-register procedure) + (let ((n-registers (rgraph-n-registers *current-rgraph*))) + (define (loop register) + (if (< register n-registers) + (begin (procedure register) + (loop (1+ register))))) + (loop number-of-machine-registers))) + +(let-syntax + ((define-register-references + (macro (slot) + (let ((name (symbol-append 'REGISTER- slot))) + (let ((vector `(,(symbol-append 'RGRAPH- name) *CURRENT-RGRAPH*))) + `(BEGIN (DEFINE-INTEGRABLE (,name REGISTER) + (VECTOR-REF ,vector REGISTER)) + (DEFINE-INTEGRABLE + (,(symbol-append 'SET- name '!) REGISTER VALUE) + (VECTOR-SET! ,vector REGISTER VALUE)))))))) + (define-register-references bblock) + (define-register-references n-refs) + (define-register-references n-deaths) + (define-register-references live-length) + (define-register-references renumber)) + +(define-integrable (reset-register-n-refs! register) + (set-register-n-refs! register 0)) + +(define (increment-register-n-refs! register) + (set-register-n-refs! register (1+ (register-n-refs register)))) + +(define-integrable (reset-register-n-deaths! register) + (set-register-n-deaths! register 0)) + +(define (increment-register-n-deaths! register) + (set-register-n-deaths! register (1+ (register-n-deaths register)))) + +(define-integrable (reset-register-live-length! register) + (set-register-live-length! register 0)) + +(define (increment-register-live-length! register) + (set-register-live-length! register (1+ (register-live-length register)))) + +(define (decrement-register-live-length! register) + (set-register-live-length! register (-1+ (register-live-length register)))) + +(define (register-crosses-call? register) + (bit-string-ref (rgraph-register-crosses-call? *current-rgraph*) register)) + +(define (register-crosses-call! register) + (bit-string-set! (rgraph-register-crosses-call? *current-rgraph*) register)) + +(define (pseudo-register-value-class register) + (vector-ref (rgraph-register-value-classes *current-rgraph*) register)) + +(define (pseudo-register-known-value register) + (vector-ref (rgraph-register-known-values *current-rgraph*) register)) + +(define (pseudo-register-known-expression register) + (vector-ref (rgraph-register-known-expressions *current-rgraph*) register)) + +(define (register-value-class register) + (if (machine-register? register) + (machine-register-value-class register) + (pseudo-register-value-class register))) + +(define (register-known-value register) + (if (machine-register? register) + (machine-register-known-value register) + (pseudo-register-known-value register))) + +(define (register-known-expression register) + (if (machine-register? register) + #F + (pseudo-register-known-expression register))) \ No newline at end of file diff --git a/v8/src/compiler/rtlbase/rtlty1.scm b/v8/src/compiler/rtlbase/rtlty1.scm new file mode 100644 index 000000000..fb21f037a --- /dev/null +++ b/v8/src/compiler/rtlbase/rtlty1.scm @@ -0,0 +1,240 @@ +#| -*-Scheme-*- + +$Id: rtlty1.scm,v 1.1 1994/11/19 02:05:54 adams Exp $ + +Copyright (c) 1987-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Register Transfer Language Type Definitions +;;; package: (compiler) + +(declare (usual-integrations)) + +;;; These three lists will be filled in by the type definitions that +;;; follow. See those macros for details. +(define rtl:expression-types '()) +(define rtl:statement-types '()) +(define rtl:predicate-types '()) + +(define-rtl-expression register % number) + +;;; Scheme object +(define-rtl-expression constant % value) + +;;; Memory references that return Scheme objects +(define-rtl-expression offset rtl: base offset) +(define-rtl-expression pre-increment rtl: register number) +(define-rtl-expression post-increment rtl: register number) + +;;; Memory reference that returns ASCII integer +(define-rtl-expression byte-offset rtl: base offset) +;;; Memory reference that returns a floating-point number +(define-rtl-expression float-offset rtl: base offset) + +;;; Generic arithmetic operations on Scheme number objects +;;; (define-rtl-expression generic-unary rtl: operator operand) +;;; (define-rtl-expression generic-binary rtl: operator operand-1 operand-2) + +;;; Code addresses +(define-rtl-expression entry:continuation rtl: continuation) +(define-rtl-expression entry:procedure rtl: procedure) + +;;; Allocating a closure object (returns its address) +(define-rtl-expression cons-closure rtl: entry min max size) +;;; Allocating a multi-closure object +;;; (returns the address of first entry point) +(define-rtl-expression cons-multiclosure rtl: nentries size entries) + +;;; Cache addresses +(define-rtl-expression assignment-cache rtl: name) +(define-rtl-expression variable-cache rtl: name) + +;;; Get the address of a Scheme object +(define-rtl-expression object->address rtl: expression) + +;;; Convert between a datum and an address +;;; (define-rtl-expression datum->address rtl: expression) +;;; (define-rtl-expression address->datum rtl: expression) + +;;; Add a constant offset to an address +(define-rtl-expression offset-address rtl: base offset) +(define-rtl-expression byte-offset-address rtl: base offset) +(define-rtl-expression float-offset-address rtl: base offset) + +;;; A machine constant (an integer, usually unsigned) +(define-rtl-expression machine-constant rtl: value) + +;;; Destructuring Scheme objects +(define-rtl-expression object->datum rtl: expression) +(define-rtl-expression object->type rtl: expression) +(define-rtl-expression cons-pointer rtl: type datum) +(define-rtl-expression cons-non-pointer rtl: type datum) + +;;; Convert a character object to an ASCII machine integer +(define-rtl-expression char->ascii rtl: expression) + +;;; Conversion between fixnum objects and machine integers +(define-rtl-expression object->fixnum rtl: expression) +(define-rtl-expression object->unsigned-fixnum rtl: expression) +(define-rtl-expression fixnum->object rtl: expression) + +;;; Conversion between machine integers and addresses +(define-rtl-expression fixnum->address rtl: expression) +(define-rtl-expression address->fixnum rtl: expression) + +;;; Machine integer arithmetic operations +(define-rtl-expression fixnum-1-arg rtl: + operator operand overflow?) +(define-rtl-expression fixnum-2-args rtl: + operator operand-1 operand-2 overflow?) + +;;; Conversion between flonums and machine floats +(define-rtl-expression float->object rtl: expression) +(define-rtl-expression object->float rtl: expression) + +;;; Floating-point arithmetic operations +(define-rtl-expression flonum-1-arg rtl: + operator operand overflow?) +(define-rtl-expression flonum-2-args rtl: + operator operand-1 operand-2 overflow?) + +;; Predicates whose inputs are fixnums +(define-rtl-predicate fixnum-pred-1-arg % + predicate operand) +(define-rtl-predicate fixnum-pred-2-args % + predicate operand-1 operand-2) + +;; Predicates whose inputs are flonums +(define-rtl-predicate flonum-pred-1-arg % + predicate operand) +(define-rtl-predicate flonum-pred-2-args % + predicate operand-1 operand-2) + +(define-rtl-predicate eq-test % expression-1 expression-2) + +;; Type tests compare an extracted type field with a constant type +(define-rtl-predicate type-test % expression type) + +;; General predicates +(define-rtl-predicate pred-1-arg % predicate operand) +(define-rtl-predicate pred-2-args % predicate operand-1 operand-2) + +(define-rtl-predicate overflow-test rtl:) + +(define-rtl-statement assign % address expression) + +(define-rtl-statement pop-return rtl:) + +(define-rtl-statement continuation-entry rtl: continuation) +(define-rtl-statement continuation-header rtl: continuation) +(define-rtl-statement ic-procedure-header rtl: procedure) +(define-rtl-statement open-procedure-header rtl: procedure) +(define-rtl-statement procedure-header rtl: procedure min max) +(define-rtl-statement closure-header rtl: procedure nentries entry) + +(define-rtl-statement interpreter-call:access % + continuation environment name) +(define-rtl-statement interpreter-call:define % + continuation environment name value) +(define-rtl-statement interpreter-call:lookup % + continuation environment name safe?) +(define-rtl-statement interpreter-call:set! % + continuation environment name value) +(define-rtl-statement interpreter-call:unassigned? % + continuation environment name) +(define-rtl-statement interpreter-call:unbound? % + continuation environment name) + +(define-rtl-statement interpreter-call:cache-assignment % + continuation name value) +(define-rtl-statement interpreter-call:cache-reference % + continuation name safe?) +(define-rtl-statement interpreter-call:cache-unassigned? % + continuation name) + +(define-rtl-statement invocation:apply rtl: + pushed continuation) +(define-rtl-statement invocation:jump rtl: + pushed continuation procedure) +(define-rtl-statement invocation:computed-jump rtl: + pushed continuation) +(define-rtl-statement invocation:lexpr rtl: + pushed continuation procedure) +(define-rtl-statement invocation:computed-lexpr rtl: + pushed continuation) +(define-rtl-statement invocation:uuo-link rtl: + pushed continuation name) +(define-rtl-statement invocation:global-link rtl: + pushed continuation name) +(define-rtl-statement invocation:primitive rtl: + pushed continuation procedure) +(define-rtl-statement invocation:special-primitive rtl: + pushed continuation procedure) +(define-rtl-statement invocation:cache-reference rtl: + pushed continuation name) +(define-rtl-statement invocation:lookup rtl: + pushed continuation environment name) + +(define-rtl-statement invocation-prefix:move-frame-up rtl: + frame-size locative) +(define-rtl-statement invocation-prefix:dynamic-link rtl: + frame-size locative register) + +;;;; New RTL + +(define-rtl-statement invocation:register rtl: + pushed continuation destination cont-defined? nregs) +(define-rtl-statement invocation:procedure rtl: + pushed continuation procedure nregs) +(define-rtl-statement invocation:new-apply rtl: + pushed continuation destination nregs) + +(define-rtl-statement return-address rtl: label frame-size nregs) +(define-rtl-statement procedure rtl: label frame-size) +(define-rtl-statement trivial-closure rtl: label min max) +(define-rtl-statement closure rtl: label frame-size) +(define-rtl-statement expression rtl: label) + +(define-rtl-statement interrupt-check:procedure rtl: + intrpt? heap? stack? label nregs) +(define-rtl-statement interrupt-check:continuation rtl: + intrpt? heap? stack? label nregs) +(define-rtl-statement interrupt-check:closure rtl: + intrpt? heap? stack? nregs) +(define-rtl-statement interrupt-check:simple-loop rtl: + intrpt? heap? stack? loop-label header-label nregs) + +(define-rtl-statement preserve rtl: register how) +(define-rtl-statement restore rtl: register value) + +(define-rtl-expression static-cell rtl: name) +(define-rtl-expression align-float rtl: expression) + +(define-rtl-expression coerce-value-class rtl: expression class) \ No newline at end of file diff --git a/v8/src/compiler/rtlbase/rtlty2.scm b/v8/src/compiler/rtlbase/rtlty2.scm new file mode 100644 index 000000000..0ffe73c6c --- /dev/null +++ b/v8/src/compiler/rtlbase/rtlty2.scm @@ -0,0 +1,252 @@ +#| -*-Scheme-*- + +$Id: rtlty2.scm,v 1.1 1994/11/19 02:05:54 adams Exp $ + +Copyright (c) 1988-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Register Transfer Language Type Definitions +;;; package: (compiler) + +(declare (usual-integrations)) + +;; clash with new rtl: +;;(define-integrable rtl:expression? pair?) + +(define-integrable rtl:expression-type car) +(define-integrable rtl:address-register cadr) +(define-integrable rtl:address-number caddr) +(define-integrable rtl:test-expression cadr) +(define-integrable rtl:invocation-pushed cadr) +(define-integrable rtl:invocation-continuation caddr) + +(define-integrable (rtl:set-invocation-continuation! rtl continuation) + (set-car! (cddr rtl) continuation)) + +;;;; Locatives + +;;; Locatives are used as an intermediate form by the code generator +;;; to build expressions. Later, when the expressions are inserted +;;; into statements, any locatives they contain are eliminated by +;;; "simplifying" them into sequential instructions using pseudo +;;; registers. + +(define-integrable register:environment + 'ENVIRONMENT) + +(define-integrable register:stack-pointer + 'STACK-POINTER) + +(define-integrable register:dynamic-link + 'DYNAMIC-LINK) + +(define-integrable register:value + 'VALUE) + +(define-integrable register:int-mask + 'INT-MASK) + +(define-integrable register:memory-top + 'MEMORY-TOP) + +(define-integrable register:free + 'FREE) + +(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:cache-unassigned?) + (rtl:make-fetch 'INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)) + +(define-integrable (rtl:interpreter-call-result:lookup) + (rtl:make-fetch 'INTERPRETER-CALL-RESULT:LOOKUP)) + +(define-integrable (rtl:interpreter-call-result:unassigned?) + (rtl:make-fetch 'INTERPRETER-CALL-RESULT:UNASSIGNED?)) + +(define-integrable (rtl:interpreter-call-result:unbound?) + (rtl:make-fetch 'INTERPRETER-CALL-RESULT:UNBOUND?)) + +;;; "Pre-simplification" locative offsets + +(define (rtl:locative-offset? locative) + (and (pair? locative) (eq? (car locative) 'OFFSET))) + +(define-integrable rtl:locative-offset-base cadr) +(define-integrable rtl:locative-offset-offset caddr) + +#| +(define (rtl:locative-offset-granularity locative) + ;; This is kludged up for backward compatibility + (if (rtl:locative-offset? locative) + (if (pair? (cdddr locative)) + (cadddr locative) + 'OBJECT) + (error "Not a locative offset" locative))) +|# +(define-integrable rtl:locative-offset-granularity cadddr) + +(define-integrable (rtl:locative-byte-offset? locative) + (eq? (rtl:locative-offset-granularity locative) 'BYTE)) + +(define-integrable (rtl:locative-float-offset? locative) + (eq? (rtl:locative-offset-granularity locative) 'FLOAT)) + +(define-integrable (rtl:locative-object-offset? locative) + (eq? (rtl:locative-offset-granularity locative) 'OBJECT)) + +(define-integrable (rtl:locative-offset locative offset) + (rtl:locative-object-offset locative offset)) + +(define (rtl:locative-byte-offset locative byte-offset) + (cond ((rtl:locative-offset? locative) + `(OFFSET ,(rtl:locative-offset-base locative) + ,(back-end:+ + byte-offset + (cond ((rtl:locative-byte-offset? locative) + (rtl:locative-offset-offset locative)) + ((rtl:locative-object-offset? locative) + (back-end:* + (rtl:locative-offset-offset locative) + address-units-per-object)) + (else + (back-end:* + (rtl:locative-offset-offset locative) + address-units-per-float)))) + BYTE)) + ((back-end:= byte-offset 0) + locative) + (else + `(OFFSET ,locative ,byte-offset BYTE)))) + +(define (rtl:locative-float-offset locative float-offset) + (let ((default + (lambda () + `(OFFSET ,locative ,float-offset FLOAT)))) + (cond ((rtl:locative-offset? locative) + (if (rtl:locative-float-offset? locative) + `(OFFSET ,(rtl:locative-offset-base locative) + ,(back-end:+ (rtl:locative-offset-offset locative) + float-offset) + FLOAT) + (default))) + (else + (default))))) + +(define (rtl:locative-object-offset locative offset) + (cond ((back-end:= offset 0) locative) + ((rtl:locative-offset? locative) + (if (not (rtl:locative-object-offset? locative)) + (error "Can't add object offset to non-object offset" + locative offset) + `(OFFSET ,(rtl:locative-offset-base locative) + ,(back-end:+ (rtl:locative-offset-offset locative) + offset) + OBJECT))) + (else + `(OFFSET ,locative ,offset OBJECT)))) + +(define (rtl:locative-index? locative) + (and (pair? locative) (eq? (car locative) 'INDEX))) + +(define-integrable rtl:locative-index-base cadr) +(define-integrable rtl:locative-index-offset caddr) +(define-integrable rtl:locative-index-granularity cadddr) + +(define-integrable (rtl:locative-byte-index? locative) + (eq? (rtl:locative-index-granularity locative) 'BYTE)) + +(define-integrable (rtl:locative-float-index? locative) + (eq? (rtl:locative-index-granularity locative) 'FLOAT)) + +(define-integrable (rtl:locative-object-index? locative) + (eq? (rtl:locative-index-granularity locative) 'OBJECT)) + +(define (rtl:locative-byte-index locative offset) + `(INDEX ,locative ,offset BYTE)) + +(define (rtl:locative-float-index locative offset) + `(INDEX ,locative ,offset FLOAT)) + +(define (rtl:locative-object-index locative offset) + `(INDEX ,locative ,offset OBJECT)) + +;;; Expressions that are used in the intermediate form. + +(define-integrable (rtl:make-address locative) + `(ADDRESS ,locative)) + +(define-integrable (rtl:make-environment locative) + `(ENVIRONMENT ,locative)) + +(define-integrable (rtl:make-cell-cons expression) + `(CELL-CONS ,expression)) + +(define-integrable (rtl:make-fetch locative) + `(FETCH ,locative)) + +(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)) + +(define-integrable (rtl:make-typed-cons:procedure entry) + `(TYPED-CONS:PROCEDURE ,entry)) + +;;; Linearizer Support + +(define-integrable (rtl:make-jump-statement label) + `(JUMP ,label)) + +(define-integrable (rtl:make-jumpc-statement predicate label) + `(JUMPC ,predicate ,label)) + +(define-integrable (rtl:make-label-statement label) + `(LABEL ,label)) + +(define-integrable (rtl:negate-predicate expression) + `(NOT ,expression)) + +;;; Stack + +(define-integrable (stack-locative-offset locative offset) + (rtl:locative-offset locative (stack->memory-offset offset))) + +(define-integrable (stack-push-address) + (rtl:make-pre-increment (interpreter-stack-pointer) + (stack->memory-offset -1))) + +(define-integrable (stack-pop-address) + (rtl:make-post-increment (interpreter-stack-pointer) + (stack->memory-offset 1))) \ No newline at end of file diff --git a/v8/src/compiler/rtlbase/valclass.scm b/v8/src/compiler/rtlbase/valclass.scm new file mode 100644 index 000000000..feac21205 --- /dev/null +++ b/v8/src/compiler/rtlbase/valclass.scm @@ -0,0 +1,128 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/rtlbase/valclass.scm,v 1.1 1994/11/19 02:05:54 adams Exp $ + +Copyright (c) 1989, 1990 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Value Classes + +(declare (usual-integrations)) + +(define-structure (value-class + (conc-name value-class/) + (constructor %make-value-class (name parent)) + (print-procedure + (unparser/standard-method 'VALUE-CLASS + (lambda (state class) + (unparse-object state (value-class/name class)))))) + (name false read-only true) + (parent false read-only true) + (children '()) + (properties (make-1d-table) read-only true)) + +(define (make-value-class name parent) + (let ((class (%make-value-class name parent))) + (if parent + (set-value-class/children! + parent + (cons class (value-class/children parent)))) + class)) + +(define (value-class/ancestor-or-self? class ancestor) + (or (eq? class ancestor) + (let loop ((class (value-class/parent class))) + (and class + (or (eq? class ancestor) + (loop (value-class/parent class))))))) + +(define (value-class/ancestry class) + (value-class/partial-ancestry class value-class=value)) + +(define (value-class/partial-ancestry class ancestor) + (let loop ((class* class) (ancestry '())) + (if (not class*) + (error "value-class not an ancestor" class ancestor)) + (let ((ancestry (cons class* ancestry))) + (if (eq? class* ancestor) + ancestry + (loop (value-class/parent class*) ancestry))))) + +(define (value-class/nearest-common-ancestor x y) + (let loop + ((join false) + (x (value-class/ancestry x)) + (y (value-class/ancestry y))) + (if (and (not (null? x)) + (not (null? y)) + (eq? (car x) (car y))) + (loop (car x) (cdr x) (cdr y)) + join))) + +(let-syntax + ((define-value-class + (lambda (name parent-name) + (let* ((name->variable + (lambda (name) (symbol-append 'VALUE-CLASS= name))) + (variable (name->variable name))) + `(BEGIN + (DEFINE ,variable + (MAKE-VALUE-CLASS ',name + ,(cond ((symbol? parent-name) + (name->variable parent-name)) + ((pair? parent-name) + parent-name) + (else `#F)))) + (DEFINE (,(symbol-append variable '?) CLASS) + (VALUE-CLASS/ANCESTOR-OR-SELF? CLASS ,variable)) + (DEFINE + (,(symbol-append 'REGISTER- variable '?) REGISTER) + (VALUE-CLASS/ANCESTOR-OR-SELF? (REGISTER-VALUE-CLASS REGISTER) + ,variable))))))) + + +(define-value-class value #f) +(define-value-class float value) +(define-value-class word value) +(define-value-class object word) +(define-value-class unboxed word) +(define-value-class address unboxed) + +;; If we are using tags 0000... and 1111... for fixnums then immedaite +;; values are valid objects. Otherwise they are unboxed values +(define-value-class immediate (if untagged-fixnums? + VALUE-CLASS=object + VALUE-CLASS=unboxed)) +(define-value-class ascii immediate) +(define-value-class datum immediate) +(define-value-class fixnum immediate) +(define-value-class type immediate) + +) \ No newline at end of file diff --git a/v8/src/compiler/rtlopt/ralloc.scm b/v8/src/compiler/rtlopt/ralloc.scm new file mode 100644 index 000000000..1660711f7 --- /dev/null +++ b/v8/src/compiler/rtlopt/ralloc.scm @@ -0,0 +1,148 @@ +#| -*-Scheme-*- + +$Id: ralloc.scm,v 1.1 1994/11/19 02:06:38 adams Exp $ + +Copyright (c) 1988-93 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Register Allocation +;;; Based on the GNU C Compiler + +(declare (usual-integrations)) + +(package (register-allocation) + +(define-export (register-allocation rgraphs) + (for-each (lambda (rgraph) + (let ((n-temporaries (walk-rgraph rgraph))) + (if (> n-temporaries number-of-temporary-registers) + (error "Too many temporary quantities" n-temporaries)))) + rgraphs)) + +(define (walk-rgraph rgraph) + (let ((n-registers (rgraph-n-registers rgraph))) + (set-rgraph-register-renumber! + rgraph + (make-vector n-registers false)) + (fluid-let ((*current-rgraph* rgraph)) + (walk-bblocks n-registers (rgraph-bblocks rgraph))))) + +(define (walk-bblocks n-registers bblocks) + ;; First, renumber all the registers remaining to be allocated. + (let ((next-renumber 0) + (register->renumber (make-vector n-registers false))) + (define (renumbered-registers n) + (if (< n n-registers) + (if (vector-ref register->renumber n) + (cons n (renumbered-registers (1+ n))) + (renumbered-registers (1+ n))) + '())) + (for-each-pseudo-register + (lambda (register) + (if (positive? (register-n-refs register)) + (begin (vector-set! register->renumber register next-renumber) + (set! next-renumber (1+ next-renumber)))))) + ;; Now create a conflict matrix for those registers and fill it. + (let ((conflict-matrix + (make-initialized-vector next-renumber + (lambda (i) + i + (make-regset next-renumber))))) + (for-each (lambda (bblock) + (let ((live (make-regset next-renumber))) + (for-each-regset-member (bblock-live-at-entry bblock) + (lambda (register) + (let ((renumber + (vector-ref register->renumber register))) + (if renumber + (regset-adjoin! live renumber))))) + (bblock-walk-forward bblock + (lambda (rinst) + (for-each-regset-member live + (lambda (renumber) + (regset-union! (vector-ref conflict-matrix + renumber) + live))) + (for-each (lambda (register) + (let ((renumber + (vector-ref register->renumber + register))) + (if renumber + (regset-delete! live renumber)))) + (rinst-dead-registers rinst)) + (mark-births! live + (rinst-rtl rinst) + register->renumber))))) + bblocks) + + ;; Finally, sort the renumbered registers into an allocation + ;; order, and then allocate them into registers one at a time. + ;; Return the number of required real registers as a value. + (let ((next-allocation 0) + (allocated (make-vector next-renumber 0))) + (for-each (lambda (register) + (let ((renumber (vector-ref register->renumber register))) + (define (loop allocation) + (if (< allocation next-allocation) + (if (regset-disjoint? + (vector-ref conflict-matrix renumber) + (vector-ref allocated allocation)) + allocation + (loop (1+ allocation))) + (let ((allocation next-allocation)) + (set! next-allocation (1+ next-allocation)) + (vector-set! allocated allocation + (make-regset next-renumber)) + allocation))) + (let ((allocation (loop 0))) + (set-register-renumber! register allocation) + (regset-adjoin! (vector-ref allocated allocation) + renumber)))) + (sort (renumbered-registers number-of-machine-registers) + allocaterenumber) + (if (rtl:assign? rtl) + (let ((address (rtl:assign-address rtl))) + (if (rtl:register? address) + (let ((register (rtl:register-number address))) + (if (pseudo-register? register) + (regset-adjoin! live + (vector-ref register->renumber + register)))))))) + +) \ No newline at end of file diff --git a/v8/src/compiler/rtlopt/rcompr.scm b/v8/src/compiler/rtlopt/rcompr.scm new file mode 100644 index 000000000..a2ead25d2 --- /dev/null +++ b/v8/src/compiler/rtlopt/rcompr.scm @@ -0,0 +1,299 @@ +#| -*-Scheme-*- + +$Id: rcompr.scm,v 1.1 1994/11/19 02:06:38 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Compression +;;; Based on the GNU C Compiler +;;; package: (compiler rtl-optimizer code-compression) + +(declare (usual-integrations)) + +(define (code-compression rgraphs) + (for-each (lambda (rgraph) + (fluid-let ((*current-rgraph* rgraph)) + (for-each walk-bblock (rgraph-bblocks rgraph)))) + rgraphs)) + +(define (walk-bblock bblock) + (if (rinst-next (bblock-instructions bblock)) + (begin + (let ((live (regset-copy (bblock-live-at-entry bblock))) + (births (make-regset (rgraph-n-registers *current-rgraph*)))) + (bblock-walk-forward bblock + (lambda (rinst) + (if (rinst-next rinst) + (let ((rtl (rinst-rtl rinst))) + (optimize-rtl bblock live rinst rtl) + (regset-clear! births) + (mark-set-registers! live births rtl false) + (for-each (lambda (register) + (regset-delete! live register)) + (rinst-dead-registers rinst)) + (regset-union! live births)))))) + (bblock-perform-deletions! bblock)))) + +(define (optimize-rtl bblock live rinst rtl) + ;; Look for assignments whose address is a pseudo register. If that + ;; register has exactly one reference that is known to be in this + ;; basic block, it is a candidate for expression folding. + (let ((register + (and (rtl:assign? rtl) + (let ((address (rtl:assign-address rtl))) + (and (rtl:register? address) + (rtl:register-number address)))))) + (if (and register + (pseudo-register? register) + (eq? (register-bblock register) bblock) + (= 2 (register-n-refs register))) + (let ((expression (rtl:assign-expression rtl))) + (if (not (or (rtl:expression-contains? expression + rtl:volatile-expression?) + (and (rtl:register? expression) + (machine-register? (rtl:register-number expression))))) + (with-values + (lambda () + (let ((next (rinst-next rinst))) + (if (rinst-dead-register? next register) + (values next expression) + (find-reference-instruction next + register + expression)))) + (lambda (next expression) + (if next + (fold-instructions! live + rinst + next + register + expression))))))))) + +(define (find-reference-instruction next register expression) + ;; Find the instruction that contains the single reference to + ;; `register', and determine if it is possible to fold `expression' + ;; into that instruction in `register's place. + (let loop ((expression expression)) + (let ((search-stopping-at + (lambda (expression predicate) + (define (phi-1 next) + (if (predicate (rinst-rtl next)) + (values false false) + (phi-2 (rinst-next next)))) + (define (phi-2 next) + (if (rinst-dead-register? next register) + (values next expression) + (phi-1 next))) + (phi-1 next))) + (recursion + (lambda (unwrap wrap) + (with-values + (lambda () + (loop (unwrap expression))) + (lambda (next expression) + (if next + (values next (wrap expression)) + (values false false))))))) + (let ((recurse-and-search + (lambda (unwrap wrap) + (with-values (lambda () + (recursion unwrap wrap)) + (lambda (next expression*) + (if next + (values next expression*) + (search-stopping-at expression + (lambda (rtl) + rtl ; ignored + false)))))))) + + (cond ((interpreter-value-register? expression) + (search-stopping-at expression + (lambda (rtl) + (and (rtl:assign? rtl) + (interpreter-value-register? + (rtl:assign-address rtl)))))) + ((and (rtl:offset? expression) + (interpreter-stack-pointer? (rtl:offset-base expression)) + (rtl:machine-constant? (rtl:offset-offset expression))) + (let () + (define (phi-1 next offset) + (let ((rtl (rinst-rtl next))) + (cond ((expression-is-stack-push? rtl) + (phi-2 (rinst-next next) (1+ offset))) + ((or (and (rtl:assign? rtl) + (rtl:expression=? (rtl:assign-address rtl) + expression)) + (expression-clobbers-stack-pointer? rtl)) + (values false false)) + (else + (phi-2 (rinst-next next) offset))))) + (define (phi-2 next offset) + (if (rinst-dead-register? next register) + (values next + (rtl:make-offset (rtl:offset-base expression) + (rtl:make-machine-constant + offset))) + (phi-1 next offset))) + (phi-1 next + (rtl:machine-constant-value + (rtl:offset-offset expression))))) + ((and (rtl:offset-address? expression) + (interpreter-stack-pointer? + (rtl:offset-address-base expression))) + (search-stopping-at expression + expression-clobbers-stack-pointer?)) + ((rtl:constant-expression? expression) + (let loop ((next (rinst-next next))) + (if (rinst-dead-register? next register) + (values next expression) + (loop (rinst-next next))))) + ((or (rtl:offset? expression) + (rtl:byte-offset? expression) + (rtl:float-offset? expression)) + (search-stopping-at + expression + (lambda (rtl) + (or (and (rtl:assign? rtl) + (memq (rtl:expression-type + (rtl:assign-address rtl)) + '(OFFSET POST-INCREMENT PRE-INCREMENT))) + (expression-clobbers-stack-pointer? rtl))))) + ((and (rtl:cons-pointer? expression) + (rtl:machine-constant? (rtl:cons-pointer-type expression))) + (recursion rtl:cons-pointer-datum + (lambda (datum) + (rtl:make-cons-pointer + (rtl:cons-pointer-type expression) + datum)))) + ((and (rtl:cons-non-pointer? expression) + (rtl:machine-constant? + (rtl:cons-non-pointer-type expression))) + (recursion rtl:cons-non-pointer-datum + (lambda (datum) + (rtl:make-cons-non-pointer + (rtl:cons-non-pointer-type expression) + datum)))) + ((rtl:object->address? expression) + (recursion rtl:object->address-expression + rtl:make-object->address)) + ((rtl:object->datum? expression) + (recurse-and-search rtl:object->datum-expression + rtl:make-object->datum)) + ((rtl:object->fixnum? expression) + (recurse-and-search rtl:object->fixnum-expression + rtl:make-object->fixnum)) + ((rtl:object->type? expression) + (recursion rtl:object->type-expression rtl:make-object->type)) + ((rtl:object->unsigned-fixnum? expression) + (recursion rtl:object->unsigned-fixnum-expression + rtl:make-object->unsigned-fixnum)) + (else + (values false false))))))) + +(define (expression-clobbers-stack-pointer? rtl) + (or (and (rtl:assign? rtl) + (rtl:register? (rtl:assign-address rtl)) + (interpreter-stack-pointer? (rtl:assign-address rtl))) + (rtl:invocation? rtl) + (rtl:invocation-prefix? rtl) + (let loop ((expression rtl)) + (rtl:any-subexpression? expression + (lambda (expression) + (cond ((rtl:pre-increment? expression) + (interpreter-stack-pointer? + (rtl:pre-increment-register expression))) + ((rtl:post-increment? expression) + (interpreter-stack-pointer? + (rtl:post-increment-register expression))) + (else + (loop expression)))))))) + +(define (expression-is-stack-push? rtl) + (and (rtl:assign? rtl) + (let ((address (rtl:assign-address rtl))) + (and (rtl:pre-increment? address) + (interpreter-stack-pointer? + (rtl:pre-increment-register address)) + (= -1 (rtl:pre-increment-number address)))))) + +(define (fold-instructions! live rinst next register expression) + ;; Attempt to fold `expression' into the place of `register' in the + ;; RTL instruction `next'. If the resulting instruction is + ;; reasonable (i.e. if the LAP generator informs us that it has a + ;; pattern for generating that instruction), the folding is + ;; performed. + (let ((rtl (rinst-rtl next))) + (if (rtl:refers-to-register? rtl register) + (let ((rtl (rtl:subst-register rtl register expression))) + (if (lap-generator/match-rtl-instruction rtl) + (begin + (set-rinst-rtl! rinst false) + (set-rinst-rtl! next rtl) + (for-each-regset-member live decrement-register-live-length!) + (let ((dead + (new-dead-registers + (rinst-next rinst) + next + (rinst-dead-registers rinst) + (rtl:expression-register-references expression)))) + (set-rinst-dead-registers! + next + (eqv-set-union dead + (delv! register + (rinst-dead-registers next))))) + (reset-register-n-refs! register) + (reset-register-n-deaths! register) + (reset-register-live-length! register) + (set-register-bblock! register false))))))) + +(define (new-dead-registers rinst next old-dead registers) + (let loop ((rinst rinst) (new-dead old-dead)) + (for-each increment-register-live-length! new-dead) + (if (eq? rinst next) + new-dead + (let* ((dead (rinst-dead-registers rinst)) + (dead* (eqv-set-intersection dead registers))) + (if (not (null? dead*)) + (begin + (set-rinst-dead-registers! + rinst + (eqv-set-difference dead dead*)) + (loop (rinst-next rinst) (eqv-set-union dead* new-dead))) + (loop (rinst-next rinst) new-dead)))))) + +(define (rtl:expression-register-references expression) + (let ((registers '())) + (let loop ((expression expression)) + (if (rtl:pseudo-register-expression? expression) + (let ((register (rtl:register-number expression))) + (if (not (memv register registers)) + (set! registers (cons register registers)))) + (rtl:for-each-subexpression expression loop))) + registers)) \ No newline at end of file diff --git a/v8/src/compiler/rtlopt/rcse1.scm b/v8/src/compiler/rtlopt/rcse1.scm new file mode 100644 index 000000000..95b8d924f --- /dev/null +++ b/v8/src/compiler/rtlopt/rcse1.scm @@ -0,0 +1,663 @@ +#| -*-Scheme-*- + +$Id: rcse1.scm,v 1.1 1994/11/19 02:06:38 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Common Subexpression Elimination: Codewalker +;;; Based on the GNU C Compiler +;;; package: (compiler rtl-cse) + +(declare (usual-integrations)) + +(define (common-subexpression-elimination rgraphs) + (with-new-node-marks (lambda () (for-each cse-rgraph rgraphs)))) + +(define-structure (state (type vector) (conc-name state/)) + (register-tables false read-only true) + (hash-table false read-only true) + (stack-offset false read-only true) + (stack-reference-quantities false read-only true)) + +#| +;;(define *initial-queue*) +;;(define *branch-queue*) +;; +;;(define (cse-rgraph rgraph) +;; (fluid-let ((*current-rgraph* rgraph) +;; (*next-quantity-number* 0) +;; (*initial-queue* (make-queue)) +;; (*branch-queue* '())) +;; (for-each (lambda (edge) +;; (enqueue!/unsafe *initial-queue* (edge-right-node edge))) +;; (rgraph-initial-edges rgraph)) +;; (fluid-let ((*register-tables* +;; (register-tables/make (rgraph-n-registers rgraph))) +;; (*hash-table*) +;; (*stack-offset*) +;; (*stack-reference-quantities*)) +;; (continue-walk)))) +;; +;;(define (continue-walk) +;; (cond ((not (null? *branch-queue*)) +;; (let ((entry (car *branch-queue*))) +;; (set! *branch-queue* (cdr *branch-queue*)) +;; (let ((state (car entry))) +;; (set! *register-tables* (state/register-tables state)) +;; (set! *hash-table* (state/hash-table state)) +;; (set! *stack-offset* (state/stack-offset state)) +;; (set! *stack-reference-quantities* +;; (state/stack-reference-quantities state))) +;; (walk-bblock (cdr entry)))) +;; ((not (queue-empty? *initial-queue*)) +;; (state/reset!) +;; (walk-bblock (dequeue!/unsafe *initial-queue*))))) +;; +;;(define (walk-bblock bblock) +;; (let loop ((rinst (bblock-instructions bblock))) +;; (let ((rtl (rinst-rtl rinst))) +;; ((if (eq? (rtl:expression-type rtl) 'ASSIGN) +;; cse/assign +;; (let ((entry (assq (rtl:expression-type rtl) cse-methods))) +;; (if (not entry) +;; (error "Missing CSE method" (rtl:expression-type rtl))) +;; (cdr entry))) +;; rtl)) +;; (if (rinst-next rinst) +;; (loop (rinst-next rinst)))) +;; (node-mark! bblock) +;; (if (sblock? bblock) +;; (let ((next (snode-next bblock))) +;; (if (walk-next? next) +;; (walk-next next) +;; (continue-walk))) +;; (let ((consequent (pnode-consequent bblock)) +;; (alternative (pnode-alternative bblock))) +;; (if (walk-next? consequent) +;; (if (walk-next? alternative) +;; (if (node-previous>1? consequent) +;; (begin (enqueue!/unsafe *initial-queue* consequent) +;; (walk-next alternative)) +;; (begin (if (node-previous>1? alternative) +;; (enqueue!/unsafe *initial-queue* alternative) +;; (set! *branch-queue* +;; (cons (cons (state/get) alternative) +;; *branch-queue*))) +;; (walk-bblock consequent))) +;; (walk-next consequent)) +;; (if (walk-next? alternative) +;; (walk-next alternative) +;; (continue-walk)))))) +;; +;;(define-integrable (walk-next? bblock) +;; (and bblock (not (node-marked? bblock)))) +;; +;;(define-integrable (walk-next bblock) +;; (if (node-previous>1? bblock) (state/reset!)) +;; (walk-bblock bblock)) +;; +;;(define (state/get) +;; (make-state (register-tables/copy *register-tables*) +;; (hash-table-copy *hash-table*) +;; *stack-offset* +;; (map (lambda (entry) +;; (cons (car entry) (quantity-copy (cdr entry)))) +;; *stack-reference-quantities*))) +;; +;;(define (state/reset!) +;; (register-tables/reset! *register-tables*) +;; (set! *hash-table* (make-hash-table)) +;; (set! *stack-offset* 0) +;; (set! *stack-reference-quantities* '()) +;; unspecific) +|# + +;;;; New rgraph walker + +(define *any-preserved?*) + +(define (cse-rgraph rgraph) + (fluid-let ((*current-rgraph* rgraph) + (*next-quantity-number* 0) + (*register-tables*) + (*hash-table*) + (*stack-offset*) + (*stack-reference-quantities*) + (*any-preserved?*)) + (state/set! (state/make-empty)) + (let loop ((bblocks (sort-bblocks-topologically (rgraph-bblocks rgraph))) + (bblock-info '())) + (if (not (null? bblocks)) + (let ((bblock (car bblocks))) + (restore-state! bblock bblock-info) + (walk-bblock bblock) + (loop (cdr bblocks) + (if (or (pblock? bblock) + (snode-next bblock)) + (cons (list bblock + (state/get) + *any-preserved?* + (not (pblock? bblock))) + bblock-info) + ;; No successors, let the state be GC'd + bblock-info))))))) + +(define (restore-state! bblock bblock-info) + (define (do-single-predecessor info) + (cond ((not info) ; loop in graph + (state/make-empty)) + ((or (sblock? (car info)) + (cadddr info)) + (cadr info)) + (else + ;; This branch copies the state. + ;; Remember that the other branch need not. + (set-car! (cdddr info) true) + (state/copy (cadr info))))) + + (define (try-to-restore bblock*) + (let ((info (assq bblock* bblock-info))) + (do-single-predecessor (and info + (caddr info) + info)))) + + (set! *any-preserved?* false) + (state/restore! + (let ((previous (node-previous-edges bblock))) + (cond ((null? previous) + (let ((state (state/make-empty))) + (state/set! state) + state)) + ((not (for-all? previous edge-left-node)) + (cond ((or (null? (cdr previous)) + (not (null? (cddr previous)))) + (state/make-empty)) + ((edge-left-node (car previous)) + => try-to-restore) + ((edge-left-node (cadr previous)) + => try-to-restore) + (else + (state/make-empty)))) + ((null? (cdr previous)) + (do-single-predecessor (assq (edge-left-node (car previous)) + bblock-info))) + (else + (state/merge* (map (lambda (edge) + (let ((bblock* (edge-left-node edge))) + (assq bblock* bblock-info))) + previous))))))) + +(define (preserve-register! regno) + (set! *any-preserved?* true) + (set-register-preserved?! regno true)) + +(define (walk-bblock bblock) + (let loop ((rinst (bblock-instructions bblock))) + (let ((rtl (rinst-rtl rinst))) + (case (rtl:expression-type rtl) + ((ASSIGN) + (cse/assign rtl)) + ((PRESERVE) + (preserve-register! + (rtl:register-number (rtl:preserve-register rtl)))) + ((RESTORE) + ;; ignore completely + unspecific) + (else + (let ((entry (assq (rtl:expression-type rtl) + cse-methods))) + (if (not entry) + (error "Missing CSE method" + (rtl:expression-type rtl))) + ((cdr entry) rtl))))) + (if (rinst-next rinst) + (loop (rinst-next rinst))))) + +(define (sort-bblocks-topologically bblocks) + (let ((pairs (map (lambda (bblock) + (cons bblock (topo-node/make bblock))) + bblocks))) + (for-each + (lambda (pair) + (let ((bblock (car pair)) + (node (cdr pair))) + (for-each (lambda (edge) + (let ((bblock* (edge-left-node edge))) + (if bblock* + (let ((node* (cdr (assq bblock* pairs)))) + (set-topo-node/before! + node + (cons node* (topo-node/before node))) + (set-topo-node/after! + node* + (cons node (topo-node/after node*))))))) + (node-previous-edges bblock)))) + pairs) + (map topo-node/contents (sort-topologically (map cdr pairs))))) + +(define (state/get) + (make-state *register-tables* + *hash-table* + *stack-offset* + *stack-reference-quantities*)) + +(define (state/copy state) + (make-state (register-tables/copy (state/register-tables state)) + (hash-table-copy (state/hash-table state)) + (state/stack-offset state) + (map (lambda (entry) + (cons (car entry) (quantity-copy (cdr entry)))) + (state/stack-reference-quantities state)))) + +(define (state/set! state) + (set! *register-tables* (state/register-tables state)) + (set! *hash-table* (state/hash-table state)) + (set! *stack-offset* (state/stack-offset state)) + (set! *stack-reference-quantities* (state/stack-reference-quantities state)) + unspecific) + +(define (state/restore! state) + (state/set! state) + (register-tables/restore! *register-tables*)) + +(define (state/make-empty) + (let ((reg-tables + (register-tables/make (rgraph-n-registers *current-rgraph*)))) + (register-tables/reset! reg-tables) + (make-state reg-tables + (make-hash-table) + 0 + '()))) + +(define (define-cse-method type method) + (let ((entry (assq type cse-methods))) + (if entry + (set-cdr! entry method) + (set! cse-methods (cons (cons type method) cse-methods)))) + type) + +(define cse-methods + '()) + +(define (cse/assign statement) + (expression-replace! rtl:assign-expression rtl:set-assign-expression! + statement + (lambda (volatile? insert-source!) + ((let ((address (rtl:assign-address statement))) + (if volatile? (notice-pop! (rtl:assign-expression statement))) + (cond ((rtl:register? address) cse/assign/register) + ((stack-reference? address) cse/assign/stack-reference) + ((and (rtl:pre-increment? address) + (interpreter-stack-pointer? + (rtl:address-register address))) + cse/assign/stack-push) + ((interpreter-register-reference? address) + cse/assign/interpreter-register) + (else + (let ((address (expression-canonicalize address))) + (rtl:set-assign-address! statement address) + cse/assign/general)))) + (rtl:assign-address statement) + (rtl:assign-expression statement) + volatile? + insert-source!)))) + +(define (cse/assign/register address expression volatile? insert-source!) + (if (interpreter-stack-pointer? address) + (if (and (rtl:offset? expression) + (interpreter-stack-pointer? (rtl:offset-base expression)) + (rtl:machine-constant? (rtl:offset-offset expression))) + (stack-pointer-adjust! + (rtl:machine-constant-value (rtl:offset-offset expression))) + (begin + (stack-invalidate!) + (stack-pointer-invalidate!))) + (register-expression-invalidate! address)) + (if (and (not volatile?) + (pseudo-register? (rtl:register-number address))) + (insert-register-destination! address (insert-source!)))) + +(define (cse/assign/stack-reference address expression volatile? + insert-source!) + expression + (stack-reference-invalidate! address) + (if (not volatile?) + (insert-stack-destination! address (insert-source!)))) + +(define (cse/assign/stack-push address expression volatile? insert-source!) + expression + (let ((adjust! + (lambda () + (stack-pointer-adjust! (rtl:address-number address))))) + (if (not volatile?) + (let ((element (insert-source!))) + (adjust!) + (insert-stack-destination! + (rtl:make-offset (interpreter-stack-pointer) + (rtl:make-machine-constant 0)) + element)) + (adjust!)))) + +(define (cse/assign/interpreter-register address expression volatile? + insert-source!) + expression + (let ((hash (expression-hash address))) + (let ((memory-invalidate! + (lambda () + (hash-table-delete! hash (hash-table-lookup hash address))))) + (if volatile? + (memory-invalidate!) + (assignment-memory-insertion address + hash + insert-source! + memory-invalidate!))))) + +(define (cse/assign/general address expression volatile? insert-source!) + expression + (full-expression-hash address + (lambda (hash volatile?* in-memory?) + in-memory? + (let ((memory-invalidate! + (cond ((stack-pop? address) + (lambda () unspecific)) + ((and (memq (rtl:expression-type address) + '(PRE-INCREMENT POST-INCREMENT)) + (interpreter-free-pointer? + (rtl:address-register address))) + (lambda () + (register-expression-invalidate! + (rtl:address-register address)))) + ((expression-address-varies? address) + (lambda () + (hash-table-delete-class! element-in-memory?))) + (else + (lambda () + (hash-table-delete! hash + (hash-table-lookup hash address)) + (varying-address-invalidate!)))))) + (if (or volatile? volatile?*) + (memory-invalidate!) + (assignment-memory-insertion address + hash + insert-source! + memory-invalidate!))))) + (notice-pop! address)) + +(define (notice-pop! expression) + ;; **** Kludge. Works only because stack-pointer + ;; gets used in very fixed way by code generator. + (if (stack-pop? expression) + (stack-pointer-adjust! (rtl:address-number expression)))) + +(define (assignment-memory-insertion address hash insert-source! + memory-invalidate!) + #| + ;; This does not cause bugs (false hash number passed to + ;; insert-memory-destination! fixed one), but does not do anything + ;; useful. The idea of doing optimization on the address of a + ;; memory assignment does not work since the RTL does not + ;; distinguish addresses from references. When the RTL is changed, + ;; we can do CSE on the memory address. + (let ((address (find-cheapest-expression address hash false))) + (let ((element (insert-source!))) + (memory-invalidate!) + (insert-memory-destination! address element false))) + |# + hash + (insert-source!) + (memory-invalidate!) + (mention-registers! address)) + +(define (trivial-action volatile? insert-source!) + (if (not volatile?) + (insert-source!))) + +(define (define-trivial-one-arg-method type get set) + (define-cse-method type + (lambda (statement) + (expression-replace! get set statement trivial-action)))) + +(define (define-trivial-two-arg-method type get-1 set-1 get-2 set-2) + (define-cse-method type + (lambda (statement) + (expression-replace! get-1 set-1 statement trivial-action) + (expression-replace! get-2 set-2 statement trivial-action)))) + +(define-trivial-two-arg-method 'EQ-TEST + rtl:eq-test-expression-1 rtl:set-eq-test-expression-1! + rtl:eq-test-expression-2 rtl:set-eq-test-expression-2!) + +(define-trivial-one-arg-method 'PRED-1-ARG + rtl:pred-1-arg-operand rtl:set-pred-1-arg-operand!) + +(define-trivial-two-arg-method 'PRED-2-ARGS + rtl:pred-2-args-operand-1 rtl:set-pred-2-args-operand-1! + rtl:pred-2-args-operand-2 rtl:set-pred-2-args-operand-2!) + +(define-trivial-one-arg-method 'FIXNUM-PRED-1-ARG + rtl:fixnum-pred-1-arg-operand rtl:set-fixnum-pred-1-arg-operand!) + +(define-trivial-two-arg-method 'FIXNUM-PRED-2-ARGS + rtl:fixnum-pred-2-args-operand-1 rtl:set-fixnum-pred-2-args-operand-1! + rtl:fixnum-pred-2-args-operand-2 rtl:set-fixnum-pred-2-args-operand-2!) + +(define-trivial-one-arg-method 'FLONUM-PRED-1-ARG + rtl:flonum-pred-1-arg-operand rtl:set-flonum-pred-1-arg-operand!) + +(define-trivial-two-arg-method 'FLONUM-PRED-2-ARGS + rtl:flonum-pred-2-args-operand-1 rtl:set-flonum-pred-2-args-operand-1! + rtl:flonum-pred-2-args-operand-2 rtl:set-flonum-pred-2-args-operand-2!) + +(define-trivial-one-arg-method 'TYPE-TEST + rtl:type-test-expression rtl:set-type-test-expression!) + +(define (method/noop statement) + statement + unspecific) + +(define-cse-method 'OVERFLOW-TEST method/noop) +(define-cse-method 'POP-RETURN method/noop) +(define-cse-method 'CONTINUATION-ENTRY method/noop) +(define-cse-method 'CONTINUATION-HEADER method/noop) +(define-cse-method 'IC-PROCEDURE-HEADER method/noop) +(define-cse-method 'OPEN-PROCEDURE-HEADER method/noop) +(define-cse-method 'PROCEDURE-HEADER method/noop) +(define-cse-method 'CLOSURE-HEADER method/noop) +(define-cse-method 'INVOCATION:JUMP method/noop) +(define-cse-method 'INVOCATION:LEXPR method/noop) + +(define (invalidate-pseudo-registers! n-pushed) + (for-each-pseudo-register + (lambda (register) + (if (not (register-preserved? register)) + (let ((expression (register-expression register))) + (if expression + (register-expression-invalidate! expression)))))) + (stack-pointer-adjust! (stack->memory-offset n-pushed)) + (expression-invalidate! (interpreter-value-register)) + (expression-invalidate! (interpreter-free-pointer))) + +(define (method/unknown-invocation statement) + (invalidate-pseudo-registers! (rtl:invocation-pushed statement))) + +(define-cse-method 'INVOCATION:APPLY method/unknown-invocation) +(define-cse-method 'INVOCATION:COMPUTED-JUMP method/unknown-invocation) +(define-cse-method 'INVOCATION:COMPUTED-LEXPR method/unknown-invocation) +(define-cse-method 'INVOCATION:UUO-LINK method/unknown-invocation) +(define-cse-method 'INVOCATION:GLOBAL-LINK method/unknown-invocation) +(define-cse-method 'INVOCATION:PRIMITIVE method/unknown-invocation) +(define-cse-method 'INVOCATION:SPECIAL-PRIMITIVE method/unknown-invocation) + +(define-cse-method 'INVOCATION:CACHE-REFERENCE + (lambda (statement) + (expression-replace! rtl:invocation:cache-reference-name + rtl:set-invocation:cache-reference-name! + statement + trivial-action) + (method/unknown-invocation statement))) + +(define-cse-method 'INVOCATION:LOOKUP + (lambda (statement) + (expression-replace! rtl:invocation:lookup-environment + rtl:set-invocation:lookup-environment! + statement + trivial-action) + (method/unknown-invocation statement))) + +(define-cse-method 'INVOCATION-PREFIX:MOVE-FRAME-UP + (lambda (statement) + (expression-replace! rtl:invocation-prefix:move-frame-up-locative + rtl:set-invocation-prefix:move-frame-up-locative! + statement + trivial-action) + (stack-invalidate!) + (stack-pointer-invalidate!))) + +(define-cse-method 'INVOCATION-PREFIX:DYNAMIC-LINK + (lambda (statement) + (expression-replace! rtl:invocation-prefix:dynamic-link-locative + rtl:set-invocation-prefix:dynamic-link-locative! + statement + trivial-action) + (expression-replace! rtl:invocation-prefix:dynamic-link-register + rtl:set-invocation-prefix:dynamic-link-register! + statement + trivial-action) + (stack-invalidate!) + (stack-pointer-invalidate!))) + +(define (define-lookup-method type get-environment set-environment! register) + (define-cse-method type + (lambda (statement) + (expression-replace! get-environment set-environment! statement + (lambda (volatile? insert-source!) + (expression-invalidate! (register)) + #| + (non-object-invalidate!) + |# + (invalidate-pseudo-registers! 0) + (if (not volatile?) (insert-source!))))))) + +(define-lookup-method 'INTERPRETER-CALL:ACCESS + rtl:interpreter-call:access-environment + rtl:set-interpreter-call:access-environment! + interpreter-register:access) + +(define-lookup-method 'INTERPRETER-CALL:CACHE-REFERENCE + rtl:interpreter-call:cache-reference-name + rtl:set-interpreter-call:cache-reference-name! + interpreter-register:cache-reference) + +(define-lookup-method 'INTERPRETER-CALL:CACHE-UNASSIGNED? + rtl:interpreter-call:cache-unassigned?-name + rtl:set-interpreter-call:cache-unassigned?-name! + interpreter-register:cache-unassigned?) + +(define-lookup-method 'INTERPRETER-CALL:LOOKUP + rtl:interpreter-call:lookup-environment + rtl:set-interpreter-call:lookup-environment! + interpreter-register:lookup) + +(define-lookup-method 'INTERPRETER-CALL:UNASSIGNED? + rtl:interpreter-call:unassigned?-environment + rtl:set-interpreter-call:unassigned?-environment! + interpreter-register:unassigned?) + +(define-lookup-method 'INTERPRETER-CALL:UNBOUND? + rtl:interpreter-call:unbound?-environment + rtl:set-interpreter-call:unbound?-environment! + interpreter-register:unbound?) + +(define (define-assignment-method type + get-environment set-environment! + get-value set-value!) + (define-cse-method type + (lambda (statement) + (expression-replace! get-value set-value! statement trivial-action) + (expression-replace! get-environment set-environment! statement + (lambda (volatile? insert-source!) + (varying-address-invalidate!) + (non-object-invalidate!) + (if (not volatile?) (insert-source!))))))) + +(define-assignment-method 'INTERPRETER-CALL:CACHE-ASSIGNMENT + rtl:interpreter-call:cache-assignment-name + rtl:set-interpreter-call:cache-assignment-name! + rtl:interpreter-call:cache-assignment-value + rtl:set-interpreter-call:cache-assignment-value!) + +(define-assignment-method 'INTERPRETER-CALL:DEFINE + rtl:interpreter-call:define-environment + rtl:set-interpreter-call:define-environment! + rtl:interpreter-call:define-value + rtl:set-interpreter-call:define-value!) + +(define-assignment-method 'INTERPRETER-CALL:SET! + rtl:interpreter-call:set!-environment + rtl:set-interpreter-call:set!-environment! + rtl:interpreter-call:set!-value + rtl:set-interpreter-call:set!-value!) + +;; New stuff + +(define-cse-method 'INVOCATION:PROCEDURE method/unknown-invocation) +(define-cse-method 'INTERRUPT-CHECK:PROCEDURE method/noop) +(define-cse-method 'INTERRUPT-CHECK:CONTINUATION method/noop) +(define-cse-method 'INTERRUPT-CHECK:CLOSURE method/noop) +(define-cse-method 'INTERRUPT-CHECK:SIMPLE-LOOP method/noop) +(define-cse-method 'PROCEDURE method/noop) +(define-cse-method 'TRIVIAL-CLOSURE method/noop) +(define-cse-method 'CLOSURE method/noop) +(define-cse-method 'EXPRESSION method/noop) +(define-cse-method 'RETURN-ADDRESS method/noop) +#| +;; Handled specially +(define-cse-method 'PRESERVE method/noop) +(define-cse-method 'RESTORE method/noop) +|# + +(define-cse-method 'INVOCATION:REGISTER + (lambda (statement) + (expression-replace! rtl:invocation:register-destination + rtl:set-invocation:register-destination! + statement + trivial-action) + (method/unknown-invocation statement))) + +(define-cse-method 'INVOCATION:NEW-APPLY + (lambda (statement) + (expression-replace! rtl:invocation:new-apply-destination + rtl:set-invocation:new-apply-destination! + statement + trivial-action) + (method/unknown-invocation statement))) + +;; End of new stuff \ No newline at end of file diff --git a/v8/src/compiler/rtlopt/rcse2.scm b/v8/src/compiler/rtlopt/rcse2.scm new file mode 100644 index 000000000..8b23ef775 --- /dev/null +++ b/v8/src/compiler/rtlopt/rcse2.scm @@ -0,0 +1,329 @@ +#| -*-Scheme-*- + +$Id: rcse2.scm,v 1.1 1994/11/19 02:06:38 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Common Subexpression Elimination +;;; Based on the GNU C Compiler +;; package: (compiler rtl-cse) + +(declare (usual-integrations)) + +;;;; Canonicalization + +(define (expression-replace! statement-expression set-statement-expression! + statement receiver) + ;; Replace the expression by its cheapest equivalent. Returns two + ;; values: (1) a flag which is true iff the expression is volatile; + ;; and (2) a thunk which, when called, will insert the expression in + ;; the hash table, returning the element. Do not call the thunk if + ;; the expression is volatile. + (let ((expression (statement-expression statement))) + (if (and (rtl:register? expression) + (machine-register? (rtl:register-number expression))) + (begin + (set-statement-expression! statement expression) + (receiver true (lambda () (error "Insert source invoked")))) + (expression-replace!/1 expression set-statement-expression! + statement receiver)))) + +(define (expression-replace!/1 expression* set-statement-expression! + statement receiver) + (let ((expression (expression-canonicalize expression*))) + (full-expression-hash expression + (lambda (hash volatile? in-memory?) + (let ((element + (find-cheapest-valid-element expression hash volatile?))) + (let ((finish + (lambda (expression hash volatile? in-memory?) + (set-statement-expression! statement expression) + (receiver volatile? + (expression-inserter expression + element + hash + in-memory?))))) + (if element + (let ((expression (element-expression element))) + (full-expression-hash expression + (lambda (hash volatile? in-memory?) + (finish expression hash volatile? in-memory?)))) + (finish expression hash volatile? in-memory?)))))))) + +(define ((expression-inserter expression element hash in-memory?)) + (or element + (begin + (if (rtl:register? expression) + (set-register-expression! (rtl:register-number expression) + expression) + (mention-registers! expression)) + (let ((element* (hash-table-insert! hash expression false))) + (set-element-in-memory?! element* in-memory?) + (element-first-value element*))))) + +(define (expression-canonicalize expression) + (cond ((rtl:register? expression) + (or (register-expression + (quantity-first-register + (get-register-quantity (rtl:register-number expression)))) + expression)) + ((stack-reference? expression) + (let ((register + (quantity-first-register + (stack-reference-quantity expression)))) + (or (and register (register-expression register)) + expression))) + (else + (rtl:map-subexpressions expression expression-canonicalize)))) + +;;;; Hash + +(define (expression-hash expression) + (full-expression-hash expression + (lambda (hash do-not-record? hash-arg-in-memory?) + do-not-record? hash-arg-in-memory? + hash))) + +(define (full-expression-hash expression receiver) + (let ((do-not-record? false) + (hash-arg-in-memory? false)) + (define (loop expression) + (let ((type (rtl:expression-type expression))) + (+ (symbol-hash type) + (case type + ((REGISTER) + (quantity-number + (get-register-quantity (rtl:register-number expression)))) + ((OFFSET) + ;; Note that stack-references do not get treated as + ;; memory for purposes of invalidation. This is because + ;; (supposedly) no one ever accesses the stack directly + ;; except the compiler's output, which is explicit. + (if (interpreter-stack-pointer? (rtl:offset-base expression)) + (quantity-number (stack-reference-quantity expression)) + (begin + (set! hash-arg-in-memory? true) + (continue expression)))) + ((BYTE-OFFSET FLOAT-OFFSET) + (set! hash-arg-in-memory? true) + (continue expression)) + ((PRE-INCREMENT POST-INCREMENT) + (set! hash-arg-in-memory? true) + (set! do-not-record? true) + 0) + (else + (continue expression)))))) + + (define (continue expression) + (rtl:reduce-subparts expression + 0 loop + (lambda (object) + (cond ((integer? object) (inexact->exact object)) + ((symbol? object) (symbol-hash object)) + ((string? object) (string-hash object)) + (else (hash object)))))) + + (let ((hash (loop expression))) + (receiver (modulo hash (hash-table-size)) + do-not-record? + hash-arg-in-memory?)))) + +;;;; Table Search + +(define (find-cheapest-expression expression hash volatile?) + ;; Find the cheapest equivalent expression for EXPRESSION. + (let ((element (find-cheapest-valid-element expression hash volatile?))) + (if element + (element-expression element) + expression))) + +(define (find-cheapest-valid-element expression hash volatile?) + ;; Find the cheapest valid hash table element for EXPRESSION. + ;; Returns false if no such element exists or if EXPRESSION is + ;; VOLATILE?. + (and (not volatile?) + (let ((element (hash-table-lookup hash expression))) + (and element + (let ((element* (element-first-value element))) + (if (eq? element element*) + element + (let loop ((element element*)) + (and element + (let ((expression (element-expression element))) + (if (or (rtl:register? expression) + (expression-valid? expression)) + element + (loop (element-next-value element)))))))))))) + +(define (expression-valid? expression) + ;; True iff all registers mentioned in EXPRESSION have valid values + ;; in the hash table. + (if (rtl:register? expression) + (let ((register (rtl:register-number expression))) + (= (register-in-table register) (register-tick register))) + (rtl:all-subexpressions? expression expression-valid?))) + +(define (element->class element) + ;; Return the cheapest element in the hash table which has the same + ;; value as `element'. This is necessary because `element' may have + ;; been deleted due to register or memory invalidation. + (and element + ;; If `element' has been deleted from the hash table, + ;; `element-first-value' will be false. [ref crock-1] + (or (element-first-value element) + (element->class (element-next-value element))))) + +;;;; Insertion + +(define (insert-register-destination! expression element) + ;; Insert EXPRESSION, which should be a register expression, into + ;; the hash table as the destination of an assignment. ELEMENT is + ;; the hash table element for the value being assigned to + ;; EXPRESSION. + (let ((register (rtl:register-number expression))) + (set-register-expression! register expression) + (let ((quantity (get-element-quantity element))) + (if quantity + (begin + (set-register-quantity! register quantity) + (let ((last (quantity-last-register quantity))) + (cond ((not last) + (set-quantity-first-register! quantity register) + (set-register-next-equivalent! register false)) + (else + (set-register-next-equivalent! last register) + (set-register-previous-equivalent! register last)))) + (set-quantity-last-register! quantity register))))) + (set-element-in-memory?! (hash-table-insert! (expression-hash expression) + expression + (element->class element)) + false)) + +(define (insert-stack-destination! expression element) + (let ((quantity (get-element-quantity element))) + (if quantity + (set-stack-reference-quantity! expression quantity))) + (set-element-in-memory?! (hash-table-insert! (expression-hash expression) + expression + (element->class element)) + false)) + +(define (get-element-quantity element) + (let loop ((element (element->class element))) + (and element + (let ((expression (element-expression element))) + (cond ((rtl:register? expression) + (get-register-quantity (rtl:register-number expression))) + ((stack-reference? expression) + (stack-reference-quantity expression)) + (else + (loop (element-next-value element)))))))) + +(define (insert-memory-destination! expression element hash) + (let ((class (element->class element))) + (mention-registers! expression) + ;; Optimization: if class and hash are both false, hash-table-insert! + ;; makes an element which is not connected to the rest of the table. + ;; In that case, there is no need to make an element at all. + (if (or class hash) + (set-element-in-memory?! (hash-table-insert! hash expression class) + true)))) + +(define (mention-registers! expression) + (if (rtl:register? expression) + (let ((register (rtl:register-number expression))) + (remove-invalid-references! register) + (set-register-in-table! register (register-tick register))) + (rtl:for-each-subexpression expression mention-registers!))) + +(define (remove-invalid-references! register) + ;; If REGISTER is invalid, delete from the hash table all + ;; expressions which refer to it. + (if (let ((in-table (register-in-table register))) + (and (not (negative? in-table)) + (not (= in-table (register-tick register))))) + (let ((expression (register-expression register))) + (hash-table-delete-class! + (lambda (element) + (let ((expression* (element-expression element))) + (and (not (rtl:register? expression*)) + (expression-refers-to? expression* expression))))))) + unspecific) + +;;;; Invalidation + +(define (non-object-invalidate!) + (hash-table-delete-class! + (lambda (element) + (not (rtl:object-valued-expression? (element-expression element)))))) + +(define (varying-address-invalidate!) + (hash-table-delete-class! + (lambda (element) + (and (element-in-memory? element) + (expression-address-varies? (element-expression element)))))) + +(define (expression-invalidate! expression) + ;; Delete from the table any expression which refers to this + ;; expression. + (if (rtl:register? expression) + (register-expression-invalidate! expression) + (hash-table-delete-class! + (lambda (element) + (expression-refers-to? (element-expression element) expression))))) + +(define (register-expression-invalidate! expression) + ;; Invalidate a register expression. These expressions are handled + ;; specially for efficiency -- the register is marked invalid but we + ;; delay searching the hash table for relevant expressions. + (let ((register (rtl:register-number expression)) + (hash (expression-hash expression))) + (register-invalidate! register) + ;; If we're invalidating the stack pointer, delete its entries + ;; immediately. + (if (interpreter-stack-pointer? expression) + (mention-registers! expression) + (hash-table-delete! hash (hash-table-lookup hash expression))))) + +(define (register-invalidate! register) + (let ((next (register-next-equivalent register)) + (previous (register-previous-equivalent register)) + (quantity (get-register-quantity register))) + (set-register-tick! register (1+ (register-tick register))) + (if next + (set-register-previous-equivalent! next previous) + (set-quantity-last-register! quantity previous)) + (if previous + (set-register-next-equivalent! previous next) + (set-quantity-first-register! quantity next)) + (set-register-quantity! register (new-quantity register)) + (set-register-next-equivalent! register false) + (set-register-previous-equivalent! register false)) + unspecific) \ No newline at end of file diff --git a/v8/src/compiler/rtlopt/rcseep.scm b/v8/src/compiler/rtlopt/rcseep.scm new file mode 100644 index 000000000..ad85fa551 --- /dev/null +++ b/v8/src/compiler/rtlopt/rcseep.scm @@ -0,0 +1,82 @@ +#| -*-Scheme-*- + +$Id: rcseep.scm,v 1.1 1994/11/19 02:06:38 adams Exp $ + +Copyright (c) 1987-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Common Subexpression Elimination: Expression Predicates +;;; Based on the GNU C Compiler + +(declare (usual-integrations)) + +(define (expression-equivalent? x y validate?) + ;; If VALIDATE? is true, assume that Y comes from the hash table and + ;; should have its register references validated. + (define (loop x y) + (let ((type (rtl:expression-type x))) + (and (eq? type (rtl:expression-type y)) + (cond ((eq? type 'REGISTER) + (register-equivalent? x y)) + ((and (memq type '(OFFSET BYTE-OFFSET)) + (interpreter-stack-pointer? (rtl:offset-base x))) + (and (interpreter-stack-pointer? (rtl:offset-base y)) + (eq? (stack-reference-quantity x) + (stack-reference-quantity y)))) + (else + (rtl:match-subexpressions x y loop)))))) + + (define (register-equivalent? x y) + (let ((x (rtl:register-number x)) + (y (rtl:register-number y))) + (and (eq? (get-register-quantity x) (get-register-quantity y)) + (or (not validate?) + (= (register-in-table y) (register-tick y)))))) + + (loop x y)) + +(define (expression-refers-to? x y) + ;; True iff any subexpression of X matches Y. + (define (loop x) + (or (eq? x y) + (if (eq? (rtl:expression-type x) (rtl:expression-type y)) + (expression-equivalent? x y false) + (rtl:any-subexpression? x loop)))) + (loop x)) + +(define (interpreter-register-reference? expression) + (and (rtl:offset? expression) + (interpreter-regs-pointer? (rtl:offset-base expression)))) + +(define (expression-address-varies? expression) + (and (not (interpreter-register-reference? expression)) + (or (memq (rtl:expression-type expression) + '(OFFSET BYTE-OFFSET PRE-INCREMENT POST-INCREMENT)) + (rtl:any-subexpression? expression expression-address-varies?)))) \ No newline at end of file diff --git a/v8/src/compiler/rtlopt/rcseht.scm b/v8/src/compiler/rtlopt/rcseht.scm new file mode 100644 index 000000000..db6db21ec --- /dev/null +++ b/v8/src/compiler/rtlopt/rcseht.scm @@ -0,0 +1,205 @@ +#| -*-Scheme-*- + +$Id: rcseht.scm,v 1.1 1994/11/19 02:06:38 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Common Subexpression Elimination: Hash Table Abstraction +;;; Based on the GNU C Compiler +;;; package: (compiler rtl-cse) + +(declare (usual-integrations)) + +(define (make-hash-table) + (make-vector 31 false)) + +(define *hash-table*) + +(define-integrable (hash-table-size) + (vector-length *hash-table*)) + +(define-integrable (hash-table-ref hash) + (vector-ref *hash-table* hash)) + +(define-integrable (hash-table-set! hash element) + (vector-set! *hash-table* hash element)) + +(define-structure (element + (constructor %make-element) + (constructor make-element (expression)) + (print-procedure + (standard-unparser (symbol->string 'ELEMENT) false))) + (expression false read-only true) + (cost false) + (in-memory? false) + (next-hash false) + (previous-hash false) + (next-value false) + (previous-value false) + (first-value false)) + +(define (hash-table-lookup hash expression) + (let loop ((element (hash-table-ref hash))) + (and element + (if (let ((expression* (element-expression element))) + (or (eq? expression expression*) + (expression-equivalent? expression expression* true))) + element + (loop (element-next-hash element)))))) + +(define (hash-table-insert! hash expression class) + (let ((element (make-element expression)) + (cost (rtl:expression-cost expression))) + (set-element-cost! element cost) + (if hash + (begin + (let ((next (hash-table-ref hash))) + (set-element-next-hash! element next) + (if next (set-element-previous-hash! next element))) + (hash-table-set! hash element))) + (cond ((not class) + (set-element-first-value! element element)) + ((or (< cost (element-cost class)) + (and (= cost (element-cost class)) + (rtl:register? expression) + (not (rtl:register? (element-expression class))))) + (set-element-next-value! element class) + (set-element-previous-value! class element) + (let loop ((x element)) + (if x + (begin + (set-element-first-value! x element) + (loop (element-next-value x)))))) + (else + (set-element-first-value! element class) + (let loop ((previous class) (next (element-next-value class))) + (cond ((not next) + (set-element-next-value! element false) + (set-element-next-value! previous element) + (set-element-previous-value! element previous)) + ((or (< cost (element-cost next)) + (and (= cost (element-cost next)) + (or (rtl:register? expression) + (not (rtl:register? + (element-expression next)))))) + (set-element-next-value! element next) + (set-element-previous-value! next element) + (set-element-next-value! previous element) + (set-element-previous-value! element previous)) + (else + (loop next (element-next-value next))))))) + element)) + +(define (hash-table-delete! hash element) + (if element + (begin + ;; **** Mark this element as removed. [ref crock-1] + (set-element-first-value! element false) + (let ((next (element-next-value element)) + (previous (element-previous-value element))) + (if next (set-element-previous-value! next previous)) + (if previous + (set-element-next-value! previous next) + (let loop ((element next)) + (if element + (begin + (set-element-first-value! element next) + (loop (element-next-value element))))))) + (let ((next (element-next-hash element)) + (previous (element-previous-hash element))) + (if next (set-element-previous-hash! next previous)) + (if previous + (set-element-next-hash! previous next) + (hash-table-set! hash next)))))) + +(define (hash-table-delete-class! predicate) + (let table-loop ((i 0)) + (if (< i (hash-table-size)) + (let bucket-loop ((element (hash-table-ref i))) + (if element + (begin + (if (predicate element) (hash-table-delete! i element)) + (bucket-loop (element-next-hash element))) + (table-loop (1+ i))))))) + +(define (hash-table-copy table) + ;; During this procedure, the `element-cost' slots of `table' are + ;; reused as "broken hearts". + (let ((elements (vector->list table))) + (let ((elements* + (map (lambda (element) + (let per-element ((element element) (previous false)) + (and element + (let ((element* + (%make-element + (element-expression element) + (element-cost element) + (element-in-memory? element) + false + previous + (element-next-value element) + (element-previous-value element) + (element-first-value element)))) + (set-element-cost! element element*) + (set-element-next-hash! + element* + (per-element (element-next-hash element) + element*)) + element*)))) + elements))) + (letrec ((per-element + (lambda (element) + (if element + (begin + (if (element-first-value element) + (set-element-first-value! + element + (element-cost (element-first-value element)))) + (if (element-previous-value element) + (set-element-previous-value! + element + (element-cost (element-previous-value element)))) + (if (element-next-value element) + (set-element-next-value! + element + (element-cost (element-next-value element)))) + (per-element (element-next-hash element))))))) + (for-each per-element elements*)) + (letrec ((per-element + (lambda (element) + (if element + (begin + (set-element-cost! + element + (element-cost (element-cost element))) + (per-element (element-next-hash element))))))) + (for-each per-element elements)) + (list->vector elements*)))) \ No newline at end of file diff --git a/v8/src/compiler/rtlopt/rcsemrg.scm b/v8/src/compiler/rtlopt/rcsemrg.scm new file mode 100644 index 000000000..6719b949e --- /dev/null +++ b/v8/src/compiler/rtlopt/rcsemrg.scm @@ -0,0 +1,113 @@ +#| -*-Scheme-*- + +$Id: rcsemrg.scm,v 1.1 1994/11/19 02:06:38 adams Exp $ + +Copyright (c) 1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL CSE merge +;;; package: (compiler rtl-cse) + +(declare (usual-integrations)) + +;;; For now, this is really dumb. +;;; It takes the intersection of the states. +;;; A better solution is to check whether a subexpression is redundant +;;; with one of the predecessors, and if so, insert it into the other +;;; predecessors. In order to avoid code blow-up a distinguished predecessor +;;; can be chosen, and the rest can be intersected in the usual way. +;;; Then there is no net code growth (except for perhaps one branch instr.) +;;; because the expression would have been computed anyway after the merge. + +(define (state/merge* infos) + ;; each info is either #F (predecessor not yet processed), + ;; or a list of a bblock a state, and a flag signalling whether + ;; there are preserved registers in the bblock. + ;; #F only occurs when a predecessor has not been processed, + ;; which can only occur when there is a loop in the flow graph. + (if (there-exists? infos (lambda (pair) (not (pair? pair)))) + ;; Loop in flow graph. For now, flush everything. + (state/make-empty) + (let ((states (map cadr infos))) + (state/set! (state/copy (car states))) + (let loop ((states (cdr states))) + (if (null? states) + (state/get) + (begin + (state/merge! (car states)) + (loop (cdr states)))))))) + +(define (state/merge! state) + (register-tables/merge! *register-tables* + (state/register-tables state)) + ;; For now, drop all stack references + (set! *stack-offset* 0) + (set! *stack-reference-quantities* '()) + unspecific) + +(define (register-tables/merge! tables tables*) + (define (%register-invalidate! reg) + (let ((expression (register-expression reg))) + (if expression + (register-expression-invalidate! expression)))) + + (define (quantity-registers tables quantity) + (let loop ((reg (quantity-first-register quantity)) + (all '())) + (if (not reg) + all + (loop (%register-next-equivalent tables reg) + (cons reg all))))) + + (let ((n-registers (vector-length (vector-ref tables 0))) + (quantities (vector-ref tables 0)) + (quantities* (vector-copy (vector-ref tables* 0)))) + (do ((reg 0 (+ reg 1))) + ((>= reg n-registers)) + (let ((quantity (vector-ref quantities reg)) + (quantity* (vector-ref quantities* reg))) + (cond ((or (not quantity) + ;; Already merged + (eq? quantity quantity*))) + ((or (not quantity*) + ;; This could check if the expressions happened + ;; to be the same! + (not (= (quantity-number quantity) + (quantity-number quantity*)))) + (%register-invalidate! reg)) + (else + ;; Merge the quantities + (let ((regs (quantity-registers tables quantity)) + (regs* (quantity-registers tables* quantity*))) + (for-each %register-invalidate! + (eq-set-difference regs regs*)) + (for-each (lambda (reg) + (vector-set! quantities* reg quantity)) + regs*)))))))) \ No newline at end of file diff --git a/v8/src/compiler/rtlopt/rcserq.scm b/v8/src/compiler/rtlopt/rcserq.scm new file mode 100644 index 000000000..d019ed4cc --- /dev/null +++ b/v8/src/compiler/rtlopt/rcserq.scm @@ -0,0 +1,193 @@ +#| -*-Scheme-*- + +$Id: rcserq.scm,v 1.1 1994/11/19 02:06:38 adams Exp $ + +Copyright (c) 1988-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Common Subexpression Elimination: Register/Quantity Abstractions +;;; Based on the GNU C Compiler +;;; package: (compiler rtl-cse) + +(declare (usual-integrations)) + +(define-structure (quantity + (copier quantity-copy) + (print-procedure + (standard-unparser (symbol->string 'QUANTITY) false))) + (number false read-only true) + (first-register false) + (last-register false)) + +(define (get-register-quantity register) + (or (register-quantity register) + (let ((quantity (new-quantity register))) + (set-register-quantity! register quantity) + quantity))) + +(define (new-quantity register) + (make-quantity (let ((n *next-quantity-number*)) + (set! *next-quantity-number* (1+ *next-quantity-number*)) + n) + register + register)) + +(define *next-quantity-number*) + +(define (register-tables/make n-registers) + (vector (make-vector n-registers) ; quantity + (make-vector n-registers) ; next equivalent + (make-vector n-registers) ; previous equivalent + (make-vector n-registers) ; expression + (make-vector n-registers) ; tick + (make-vector n-registers) ; in table + (make-vector n-registers) ; preserved? + )) + +(define (register-tables/reset! register-tables) + (vector-fill! (vector-ref register-tables 0) false) + (vector-fill! (vector-ref register-tables 1) false) + (vector-fill! (vector-ref register-tables 2) false) + (let ((expressions (vector-ref register-tables 3))) + (vector-fill! expressions false) + (for-each-machine-register + (lambda (register) + (vector-set! expressions + register + (rtl:make-machine-register register))))) + (vector-fill! (vector-ref register-tables 4) 0) + (vector-fill! (vector-ref register-tables 5) -1) + (vector-fill! (vector-ref register-tables 6) false)) + +(define (register-tables/copy register-tables) + (vector (vector-map (vector-ref register-tables 0) + (lambda (quantity) + (and quantity + (quantity-copy quantity)))) + (vector-copy (vector-ref register-tables 1)) + (vector-copy (vector-ref register-tables 2)) + (vector-copy (vector-ref register-tables 3)) + (vector-copy (vector-ref register-tables 4)) + (vector-copy (vector-ref register-tables 5)) + (vector-copy (vector-ref register-tables 6)))) + +(define (register-tables/restore! register-tables) + ;; Nothing is preserved. + (vector-fill! (vector-ref register-tables 6) false)) + +(define-integrable (%register-quantity tables register) + (vector-ref (vector-ref tables 0) register)) + +(define-integrable (%set-register-quantity! tables register quantity) + (vector-set! (vector-ref tables 0) register quantity)) + +(define-integrable (%register-next-equivalent tables register) + (vector-ref (vector-ref tables 1) register)) + +(define-integrable + (%set-register-next-equivalent! tables register next-equivalent) + (vector-set! (vector-ref tables 1) register next-equivalent)) + +(define-integrable (%register-previous-equivalent tables register) + (vector-ref (vector-ref tables 2) register)) + +(define-integrable + (%set-register-previous-equivalent! tables register previous-equivalent) + (vector-set! (vector-ref tables 2) register previous-equivalent)) + +(define-integrable (%register-expression tables register) + (vector-ref (vector-ref tables 3) register)) + +(define-integrable (%set-register-expression! tables register expression) + (vector-set! (vector-ref tables 3) register expression)) + +(define-integrable (%register-tick tables register) + (vector-ref (vector-ref tables 4) register)) + +(define-integrable (%set-register-tick! tables register tick) + (vector-set! (vector-ref tables 4) register tick)) + +(define-integrable (%register-in-table tables register) + (vector-ref (vector-ref tables 5) register)) + +(define-integrable (%set-register-in-table! tables register in-table) + (vector-set! (vector-ref tables 5) register in-table)) + +(define-integrable (%register-preserved? tables register) + (vector-ref (vector-ref tables 6) register)) + +(define-integrable (%set-register-preserved?! tables register state) + (vector-set! (vector-ref tables 6) register state)) + +(define *register-tables*) + +(define-integrable (register-quantity register) + (%register-quantity *register-tables* register)) + +(define-integrable (set-register-quantity! register quantity) + (%set-register-quantity! *register-tables* register quantity)) + +(define-integrable (register-next-equivalent register) + (%register-next-equivalent *register-tables* register)) + +(define-integrable (set-register-next-equivalent! register next-equivalent) + (%set-register-next-equivalent! *register-tables* register next-equivalent)) + +(define-integrable (register-previous-equivalent register) + (%register-previous-equivalent *register-tables* register)) + +(define-integrable + (set-register-previous-equivalent! register previous-equivalent) + (%set-register-previous-equivalent! *register-tables* + register previous-equivalent)) + +(define-integrable (register-expression register) + (%register-expression *register-tables* register)) + +(define-integrable (set-register-expression! register expression) + (%set-register-expression! *register-tables* register expression)) + +(define-integrable (register-tick register) + (%register-tick *register-tables* register)) + +(define-integrable (set-register-tick! register tick) + (%set-register-tick! *register-tables* register tick)) + +(define-integrable (register-in-table register) + (%register-in-table *register-tables* register)) + +(define-integrable (set-register-in-table! register in-table) + (%set-register-in-table! *register-tables* register in-table)) + +(define (register-preserved? register) + (%register-preserved? *register-tables* register)) + +(define (set-register-preserved?! register state) + (%set-register-preserved?! *register-tables* register state)) \ No newline at end of file diff --git a/v8/src/compiler/rtlopt/rcsesr.scm b/v8/src/compiler/rtlopt/rcsesr.scm new file mode 100644 index 000000000..b1f7cea64 --- /dev/null +++ b/v8/src/compiler/rtlopt/rcsesr.scm @@ -0,0 +1,113 @@ +#| -*-Scheme-*- + +$Id: rcsesr.scm,v 1.1 1994/11/19 02:06:38 adams Exp $ + +Copyright (c) 1987-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Common Subexpression Elimination: Stack References + +(declare (usual-integrations)) + +(define *stack-offset*) +(define *stack-reference-quantities*) + +(define-integrable (memory->stack-offset offset) + ;; Assume this operation is a self-inverse. + (stack->memory-offset offset)) + +(define (stack-push? expression) + (and (rtl:pre-increment? expression) + (interpreter-stack-pointer? (rtl:address-register expression)) + (= -1 (memory->stack-offset (rtl:address-number expression))))) + +(define (stack-pop? expression) + (and (rtl:post-increment? expression) + (interpreter-stack-pointer? (rtl:address-register expression)) + (= 1 (memory->stack-offset (rtl:address-number expression))))) + +(define (stack-reference? expression) + (and (rtl:offset? expression) + (interpreter-stack-pointer? (rtl:address-register expression)))) + +(define (stack-reference-quantity expression) + (let ((n (+ *stack-offset* + (rtl:machine-constant-value (rtl:offset-offset expression))))) + (let ((entry (ass= n *stack-reference-quantities*))) + (if entry + (cdr entry) + (let ((quantity (new-quantity false))) + (set! *stack-reference-quantities* + (cons (cons n quantity) + *stack-reference-quantities*)) + quantity))))) + +(define (set-stack-reference-quantity! expression quantity) + (let ((n (+ *stack-offset* + (rtl:machine-constant-value (rtl:offset-offset expression))))) + (let ((entry (ass= n *stack-reference-quantities*))) + (if entry + (set-cdr! entry quantity) + (set! *stack-reference-quantities* + (cons (cons n quantity) + *stack-reference-quantities*))))) + unspecific) + +(define (stack-pointer-adjust! offset) + (let ((offset (memory->stack-offset offset))) + (if (positive? offset) ;i.e. if a pop + (stack-region-invalidate! 0 offset))) + (set! *stack-offset* (+ *stack-offset* offset)) + (stack-pointer-invalidate!)) + +(define-integrable (stack-pointer-invalidate!) + (register-expression-invalidate! (interpreter-stack-pointer))) + +(define-integrable (stack-invalidate!) + (set! *stack-reference-quantities* '())) + +(define (stack-region-invalidate! start end) + (let loop ((i start) (quantities *stack-reference-quantities*)) + (if (< i end) + (loop (1+ i) + (del-ass=! (+ *stack-offset* (stack->memory-offset i)) + quantities)) + (set! *stack-reference-quantities* quantities)))) + +(define (stack-reference-invalidate! expression) + (expression-invalidate! expression) + (set! *stack-reference-quantities* + (del-ass=! (+ *stack-offset* + (rtl:machine-constant-value + (rtl:offset-offset expression))) + *stack-reference-quantities*))) + +(define ass= (association-procedure = car)) +(define del-ass=! (delete-association-procedure list-deletor! = car)) \ No newline at end of file diff --git a/v8/src/compiler/rtlopt/rdebug.scm b/v8/src/compiler/rtlopt/rdebug.scm new file mode 100644 index 000000000..9e06f04b3 --- /dev/null +++ b/v8/src/compiler/rtlopt/rdebug.scm @@ -0,0 +1,87 @@ +#| -*-Scheme-*- + +$Id: rdebug.scm,v 1.1 1994/11/19 02:06:38 adams Exp $ + +Copyright (c) 1987-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Optimizer Debugging Output + +(declare (usual-integrations)) + +(define (dump-register-info rgraph) + (fluid-let ((*current-rgraph* rgraph)) + (for-each-pseudo-register + (lambda (register) + (if (positive? (register-n-refs register)) + (begin (newline) + (write register) + (write-string ": renumber ") + (write (register-renumber register)) + (write-string "; nrefs ") + (write (register-n-refs register)) + (write-string "; length ") + (write (register-live-length register)) + (write-string "; ndeaths ") + (write (register-n-deaths register)) + (let ((bblock (register-bblock register))) + (cond ((eq? bblock 'NON-LOCAL) + (if (register-crosses-call? register) + (write-string "; crosses calls") + (write-string "; multiple blocks"))) + (bblock + (write-string "; block ") + (write (unhash bblock))) + (else + (write-string "; no block!")))))))))) + +(define (dump-block-info rgraph) + (fluid-let ((*current-rgraph* rgraph)) + (let ((machine-regs (make-regset (rgraph-n-registers rgraph)))) + (for-each-machine-register + (lambda (register) + (regset-adjoin! machine-regs register))) + (for-each (lambda (bblock) + (newline) + (newline) + (write bblock) + (bblock-walk-forward bblock + (lambda (rinst) + (pp (rinst-rtl rinst)))) + (let ((live-at-exit (bblock-live-at-exit bblock))) + (regset-difference! live-at-exit machine-regs) + (if (not (regset-null? live-at-exit)) + (begin (newline) + (write-string "Registers live at end:") + (for-each-regset-member live-at-exit + (lambda (register) + (write-string " ") + (write register))))))) + (rgraph-bblocks rgraph))))) \ No newline at end of file diff --git a/v8/src/compiler/rtlopt/rdflow.scm b/v8/src/compiler/rtlopt/rdflow.scm new file mode 100644 index 000000000..5abec38d0 --- /dev/null +++ b/v8/src/compiler/rtlopt/rdflow.scm @@ -0,0 +1,280 @@ +#| -*-Scheme-*- + +$Id: rdflow.scm,v 1.1 1994/11/19 02:06:38 adams Exp $ + +Copyright (c) 1990-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Dataflow Analysis +;;; package: (compiler rtl-optimizer rtl-dataflow-analysis) + +(declare (usual-integrations)) + +(define (rtl-dataflow-analysis rgraphs) + (for-each (lambda (rgraph) + (let ((rnodes (generate-dataflow-graph rgraph))) + (set-rgraph-register-value-classes! + rgraph + (vector-map rnodes + (lambda (rnode) + (and rnode + (rnode/value-class rnode))))) + (generate-known-values! rnodes) + (set-rgraph-register-known-values! + rgraph + (vector-map rnodes + (lambda (rnode) + (and rnode + (rnode/known-value rnode))))) + (set-rgraph-register-known-expressions! + rgraph + (vector-map rnodes + (lambda (rnode) + (and rnode + (rnode/values rnode) + (null? (cdr (rnode/values rnode))) + (car (rnode/values rnode)))))))) + rgraphs)) + +;; New stuff. *** Temporary kludge *** + +(define (argument-register-type value) + (and (rtl:register? value) + (let ((reg-number (rtl:register-number value))) + (and (machine-register? reg-number) + (memq reg-number *argument-registers*) + (let ((class (machine-register-value-class reg-number))) + (if (eq? class value-class=float) + class + value-class=object)))))) + +(define (rnode/value-class rnode) + (let ((union + (let ((values (rnode/values rnode))) + (or (and (not (null? values)) + (null? (cdr values)) + (argument-register-type (car values))) + (reduce value-class/nearest-common-ancestor + false + ;; Here we assume that no member of + ;; `rnode/values' is a register expression. + (map rtl:expression-value-class values)))))) + ;; Really this test should look for non-leaf value + ;; classes, except that the "immediate" class (which is + ;; the only other non-leaf class) is generated by the + ;; `machine-constant' expression. The `machine-constant' + ;; expression should be typed so that its class could be + ;; more precisely determined. + (if (and (pseudo-register? (rnode/register rnode)) + (or (eq? union value-class=value) + (eq? union value-class=word) + (eq? union value-class=unboxed))) + (error "mixed-class register" rnode union)) + union)) + +;; End of new stuff + +(define-structure (rnode + (conc-name rnode/) + (constructor make-rnode (register)) + (print-procedure + (unparser/standard-method 'RNODE + (lambda (state rnode) + (unparse-object state (rnode/register rnode)))))) + (register false read-only true) + (forward-links '()) + (backward-links '()) + (initial-values '()) + (values '()) + (known-value false) + (classified-values)) + +(define (generate-dataflow-graph rgraph) + (let ((rnodes (make-vector (rgraph-n-registers rgraph) false))) + (for-each (lambda (bblock) + (bblock-walk-forward bblock + (lambda (rinst) + (walk-rtl rnodes (rinst-rtl rinst))))) + (rgraph-bblocks rgraph)) + (for-each-rnode rnodes + (lambda (rnode) + (set-rnode/values! + rnode + (rtx-set/union* (rnode/initial-values rnode) + (map rnode/initial-values + (rnode/backward-links rnode)))))) + rnodes)) + +(define (for-each-rnode rnodes procedure) + (for-each-vector-element rnodes + (lambda (rnode) + (if rnode + (procedure rnode))))) + +(define (walk-rtl rnodes rtl) + (let ((get-rnode + (lambda (expression) + (let ((register (rtl:register-number expression))) + (or (vector-ref rnodes register) + (let ((rnode (make-rnode register))) + (vector-set! rnodes register rnode) + rnode)))))) + (if (rtl:assign? rtl) + (let ((address (rtl:assign-address rtl)) + (expression (rtl:assign-expression rtl))) + (if (rtl:pseudo-register-expression? address) + (let ((target (get-rnode address))) + (if (rtl:pseudo-register-expression? expression) + (rnode/connect! target (get-rnode expression)) + (add-rnode/initial-value! target expression)))))) + (let loop ((rtl rtl)) + (rtl:for-each-subexpression rtl + (lambda (expression) + (if (rtl:volatile-expression? expression) + (if (or (rtl:post-increment? expression) + (rtl:pre-increment? expression)) + (add-rnode/initial-value! + (get-rnode (rtl:address-register expression)) + expression) + (error "Unknown volatile expression" expression)) + (loop expression))))))) + +(define (add-rnode/initial-value! target expression) + (let ((values (rnode/initial-values target))) + (if (not (there-exists? values + (lambda (value) + (rtl:expression=? expression value)))) + (set-rnode/initial-values! target + (cons expression values))))) + +(define (rnode/connect! target source) + (if (not (memq source (rnode/backward-links target))) + (begin + (set-rnode/backward-links! target + (cons source (rnode/backward-links target))) + (set-rnode/forward-links! source + (cons target (rnode/forward-links source))) + (for-each (lambda (source) (rnode/connect! target source)) + (rnode/backward-links source)) + (for-each (lambda (target) (rnode/connect! target source)) + (rnode/forward-links target))))) + +(define (generate-known-values! rnodes) + (for-each-rnode rnodes + (lambda (rnode) + (set-rnode/classified-values! rnode + (map expression->classified-value + (rnode/values rnode))))) + (for-each-rnode rnodes + (lambda (rnode) + (let ((expression (initial-known-value (rnode/classified-values rnode)))) + (set-rnode/known-value! rnode expression) + (if (not (memq expression '(UNDETERMINED #F))) + (set-rnode/classified-values! rnode '()))))) + (let loop () + (let ((new-constant? false)) + (for-each-rnode rnodes + (lambda (rnode) + (if (eq? (rnode/known-value rnode) 'UNDETERMINED) + (let ((values + (values-substitution-step + rnodes + (rnode/classified-values rnode)))) + (if (there-exists? values + (lambda (value) + (eq? (car value) 'SUBSTITUTABLE-REGISTERS))) + (set-rnode/classified-values! rnode values) + (let ((expression (values-unique-expression values))) + (if expression (set! new-constant? true)) + (set-rnode/known-value! rnode expression) + (set-rnode/classified-values! rnode '()))))))) + (if new-constant? (loop)))) + (for-each-rnode rnodes + (lambda (rnode) + (if (eq? (rnode/known-value rnode) 'UNDETERMINED) + (begin + (set-rnode/known-value! + rnode + (values-unique-expression (rnode/classified-values rnode))) + (set-rnode/classified-values! rnode '())))))) + +(define (expression->classified-value expression) + (cons (cond ((rtl:constant-expression? expression) + 'CONSTANT) + ((rtl:contains-no-substitutable-registers? expression) + 'NO-SUBSTITUTABLE-REGISTERS) + (else + 'SUBSTITUTABLE-REGISTERS)) + expression)) + +(define (initial-known-value values) + (and (not (null? values)) + (not (there-exists? values + (lambda (value) + (rtl:volatile-expression? (cdr value))))) + (let loop ((value (car values)) (rest (cdr values))) + (cond ((eq? (car value) 'SUBSTITUTABLE-REGISTERS) 'UNDETERMINED) + ((null? rest) (values-unique-expression values)) + (else (loop (car rest) (cdr rest))))))) + +(define (values-unique-expression values) + (let ((class (caar values)) + (expression (cdar values))) + (and (for-all? (cdr values) + (lambda (value) + (and (eq? class (car value)) + (rtl:expression=? expression (cdr value))))) + expression))) + +(define (values-substitution-step rnodes values) + (map (lambda (value) + (if (eq? (car value) 'SUBSTITUTABLE-REGISTERS) + (let ((substitution? false)) + (let ((expression + (let loop ((expression (cdr value))) + (if (rtl:register? expression) + (let ((value + (register-known-value rnodes expression))) + (if value + (begin (set! substitution? true) value) + expression)) + (rtl:map-subexpressions expression loop))))) + (if substitution? + (expression->classified-value expression) + value))) + value)) + values)) + +(define (register-known-value rnodes expression) + (let ((rnode (vector-ref rnodes (rtl:register-number expression)))) + (and rnode + (let ((value (rnode/known-value rnode))) + (and (not (eq? value 'UNDETERMINED)) + value))))) \ No newline at end of file diff --git a/v8/src/compiler/rtlopt/rerite.scm b/v8/src/compiler/rtlopt/rerite.scm new file mode 100644 index 000000000..7d9eb1c32 --- /dev/null +++ b/v8/src/compiler/rtlopt/rerite.scm @@ -0,0 +1,198 @@ +#| -*-Scheme-*- + +$Id: rerite.scm,v 1.1 1994/11/19 02:06:38 adams Exp $ + +Copyright (c) 1990-1993 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Rewriting +;;; package: (compiler rtl-optimizer rtl-rewriting) + +(declare (usual-integrations)) + +(define-structure (rewriting-rules + (conc-name rewriting-rules/) + (constructor make-rewriting-rules ())) + (assignment '()) + (statement '()) + (register '()) + (expression '()) + (generic '())) + +(define rules:pre-cse (make-rewriting-rules)) +(define rules:post-cse (make-rewriting-rules)) + +(define (rtl-rewriting:pre-cse rgraphs) + (walk-rgraphs rules:pre-cse rgraphs)) + +(define (rtl-rewriting:post-cse rgraphs) + (walk-rgraphs rules:post-cse rgraphs)) + +(define (add-rewriting-rule! pattern result-procedure) + (new-rewriting-rule! rules:post-cse pattern result-procedure)) + +(define (add-pre-cse-rewriting-rule! pattern result-procedure) + (new-rewriting-rule! rules:pre-cse pattern result-procedure)) + +(define (walk-rgraphs rules rgraphs) + (if (not (and (null? (rewriting-rules/assignment rules)) + (null? (rewriting-rules/statement rules)) + (null? (rewriting-rules/register rules)) + (null? (rewriting-rules/expression rules)) + (null? (rewriting-rules/generic rules)))) + (for-each (lambda (rgraph) + (walk-rgraph rules rgraph)) + rgraphs))) + +(define (walk-rgraph rules rgraph) + (fluid-let ((*current-rgraph* rgraph)) + (for-each (lambda (bblock) (walk-bblock rules bblock)) + (rgraph-bblocks rgraph)))) + +(define (walk-bblock rules bblock) + (bblock-walk-forward bblock + (lambda (rinst) + (walk-rinst rules rinst)))) + +(define (walk-rinst rules rinst) + (let ((rtl (rinst-rtl rinst))) + ;; Typically there will be few rules, and few instructions that + ;; match, so it is worth checking before rewriting anything. + (if (or (match-rtl-statement rules rtl) + (rtl:any-subexpression? rtl + (letrec ((loop + (lambda (expression) + (or (match-rtl-expression rules expression) + (rtl:any-subexpression? expression loop))))) + loop))) + (set-rinst-rtl! + rinst + (let loop + ((rtl + (rtl:map-subexpressions rtl + (letrec ((loop + (lambda (expression) + (let ((match-result + (match-rtl-expression rules expression))) + (if match-result + (loop (match-result)) + expression))))) + loop)))) + (let ((match-result (match-rtl-statement rules rtl))) + (if match-result + (loop (match-result)) + rtl))))))) + +(define (match-rtl-statement rules rtl) + (or (if (rtl:assign? rtl) + (pattern-lookup (rewriting-rules/assignment rules) rtl) + (let ((entries + (assq (rtl:expression-type rtl) + (rewriting-rules/statement rules)))) + (and entries + (pattern-lookup (cdr entries) rtl)))) + (pattern-lookup (rewriting-rules/generic rules) rtl))) + +(define (match-rtl-expression rules expression) + (or (if (rtl:register? expression) + (pattern-lookup (rewriting-rules/register rules) expression) + (let ((entries + (assq (rtl:expression-type expression) + (rewriting-rules/expression rules)))) + (and entries + (pattern-lookup (cdr entries) expression)))) + (pattern-lookup (rewriting-rules/generic rules) expression))) + +(define (new-rewriting-rule! rules pattern result-procedure) + (let ((entry (cons pattern result-procedure))) + (if (not (and (pair? pattern) (symbol? (car pattern)))) + (set-rewriting-rules/generic! rules + (cons entry + (rewriting-rules/generic rules))) + (let ((keyword (car pattern))) + (cond ((eq? keyword 'ASSIGN) + (set-rewriting-rules/assignment! + rules + (cons entry (rewriting-rules/assignment rules)))) + ((eq? keyword 'REGISTER) + (set-rewriting-rules/register! + rules + (cons entry (rewriting-rules/register rules)))) + ((memq keyword rtl:expression-types) + (let ((entries + (assq keyword (rewriting-rules/expression rules)))) + (if entries + (set-cdr! entries (cons entry (cdr entries))) + (set-rewriting-rules/expression! + rules + (cons (list keyword entry) + (rewriting-rules/expression rules)))))) + ((or (memq keyword rtl:statement-types) + (memq keyword rtl:predicate-types)) + (let ((entries + (assq keyword (rewriting-rules/statement rules)))) + (if entries + (set-cdr! entries (cons entry (cdr entries))) + (set-rewriting-rules/statement! + rules + (cons (list keyword entry) + (rewriting-rules/statement rules)))))) + (else + (error "illegal RTL type" keyword)))))) + pattern) + +(define-rule add-pre-cse-rewriting-rule! + (OBJECT->ADDRESS (? source)) + (QUALIFIER (value-class=address? (rtl:expression-value-class source))) + source) + +;; KLUDGE! This is unsafe, but currently works. +;; Probably closure bumping should not use byte-offset-address, and use +;; a new rtl type, but... + +(define-rule add-pre-cse-rewriting-rule! + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (REGISTER (? datum register-known-value))) + (QUALIFIER + (and (= (ucode-type compiled-entry) type) + (rtl:byte-offset-address? datum) + (let ((v (let ((v (rtl:byte-offset-address-base datum))) + (if (rtl:register? v) + (register-known-value (rtl:register-number v)) + v)))) + (and v + (rtl:object->address? v))))) + (rtl:make-byte-offset-address + (rtl:object->address-expression + (let ((v (rtl:byte-offset-address-base datum))) + (if (rtl:register? v) + (register-known-value (rtl:register-number v)) + v))) + (rtl:byte-offset-address-offset datum))) diff --git a/v8/src/compiler/rtlopt/rinvex.scm b/v8/src/compiler/rtlopt/rinvex.scm new file mode 100644 index 000000000..b68a15638 --- /dev/null +++ b/v8/src/compiler/rtlopt/rinvex.scm @@ -0,0 +1,392 @@ +#| -*-Scheme-*- + +$Id: rinvex.scm,v 1.1 1994/11/19 02:06:38 adams Exp $ + +Copyright (c) 1989-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Invertible Expression Elimination +;;; package: (compiler rtl-optimizer invertible-expression-elimination) + +(declare (usual-integrations)) + +(define *initial-queue*) +(define *branch-queue*) +(define *register-values*) + +(define (invertible-expression-elimination rgraphs) + (with-new-node-marks (lambda () (for-each walk-rgraph rgraphs)))) + +(define (walk-rgraph rgraph) + (fluid-let ((*current-rgraph* rgraph) + (*initial-queue* (make-queue)) + (*branch-queue* '()) + (*register-values* + (make-vector (rgraph-n-registers rgraph) false))) + (for-each (lambda (edge) + (enqueue!/unsafe *initial-queue* (edge-right-node edge))) + (rgraph-initial-edges rgraph)) + (continue-walk))) + +(define (continue-walk) + (cond ((not (null? *branch-queue*)) + (let ((entry (car *branch-queue*))) + (set! *branch-queue* (cdr *branch-queue*)) + (set! *register-values* (car entry)) + (walk-bblock (cdr entry)))) + ((not (queue-empty? *initial-queue*)) + (vector-fill! *register-values* false) + (walk-bblock (dequeue!/unsafe *initial-queue*))))) + +(define (walk-bblock bblock) + (let loop ((rinst (bblock-instructions bblock))) + (let ((rtl (rinst-rtl rinst))) + ((lookup-method (rtl:expression-type rtl)) rtl)) + (if (rinst-next rinst) + (loop (rinst-next rinst)))) + (node-mark! bblock) + (if (sblock? bblock) + (let ((next (snode-next bblock))) + (if (walk-next? next) + (walk-next next) + (continue-walk))) + (let ((consequent (pnode-consequent bblock)) + (alternative (pnode-alternative bblock))) + (if (walk-next? consequent) + (if (walk-next? alternative) + (if (node-previous>1? consequent) + (begin + (enqueue!/unsafe *initial-queue* consequent) + (walk-next alternative)) + (begin + (if (node-previous>1? alternative) + (enqueue!/unsafe *initial-queue* alternative) + (set! *branch-queue* + (cons (cons (vector-copy *register-values*) + alternative) + *branch-queue*))) + (walk-bblock consequent))) + (walk-next consequent)) + (if (walk-next? alternative) + (walk-next alternative) + (continue-walk)))))) + +(define-integrable (walk-next? bblock) + (and bblock (not (node-marked? bblock)))) + +(define-integrable (walk-next bblock) + (if (node-previous>1? bblock) (vector-fill! *register-values* false)) + (walk-bblock bblock)) + +(define-integrable (register-value register) + (vector-ref *register-values* register)) + +(define-integrable (set-register-value! register value) + (vector-set! *register-values* register value) + unspecific) + +(define (expression-update! get-expression set-expression! object) + ;; Note: The following code may cause pseudo-register copies to be + ;; generated since it would have to propagate some of the + ;; simplifications, and then delete the now unused registers. This + ;; is not worthwhile since the previous register is likely to be + ;; dead at this point, so the lap-level register allocator will + ;; reuse the alias achieving the effect of the deletion. Ultimately + ;; the expression invertibility code should be integrated into the + ;; CSE and this register deletion would happen there. + (set-expression! + object + (let loop ((expression (get-expression object))) + (if (rtl:register? expression) + expression + (optimize-expression (rtl:map-subexpressions expression loop)))))) + +(define (optimize-expression expression) + (let loop + ((identities + (list-transform-positive identities + (let ((type (rtl:expression-type expression))) + (lambda (identity) + (eq? type (car (cadr identity)))))))) + (cond ((null? identities) + expression) + ((let ((identity (car identities))) + (let ((in-domain? (car identity)) + (matching-operation (cadr identity))) + (let loop + ((operations (cddr identity)) + (subexpression ((cadr matching-operation) expression))) + (if (null? operations) + (and (valid-subexpression? subexpression) + (in-domain? + (rtl:expression-value-class subexpression)) + subexpression) + (let ((subexpression + (canonicalize-subexpression subexpression))) + (and (eq? (caar operations) + (rtl:expression-type subexpression)) + (loop (cdr operations) + ((cadar operations) subexpression)))))))) + => optimize-expression) + (else + (loop (cdr identities)))))) + +(define identities + ;; Each entry is composed of a value class and a sequence of + ;; operations whose composition is the identity for that value + ;; class. Each operation is described by the operator and the + ;; selector for the relevant operand. + `( + (,value-class=value? (OBJECT->FIXNUM ,rtl:object->fixnum-expression) + (FIXNUM->OBJECT ,rtl:fixnum->object-expression)) + (,value-class=value? (FIXNUM->OBJECT ,rtl:fixnum->object-expression) + (OBJECT->FIXNUM ,rtl:object->fixnum-expression)) + (,value-class=value? (OBJECT->UNSIGNED-FIXNUM + ,rtl:object->unsigned-fixnum-expression) + (FIXNUM->OBJECT ,rtl:fixnum->object-expression)) + (,value-class=value? (FIXNUM->OBJECT ,rtl:fixnum->object-expression) + (OBJECT->UNSIGNED-FIXNUM + ,rtl:object->unsigned-fixnum-expression)) + (,value-class=value? (FIXNUM->ADDRESS ,rtl:fixnum->address-expression) + (ADDRESS->FIXNUM ,rtl:address->fixnum-expression)) + (,value-class=value? (ADDRESS->FIXNUM ,rtl:address->fixnum-expression) + (FIXNUM->ADDRESS ,rtl:fixnum->address-expression)) + (,value-class=value? (OBJECT->FLOAT ,rtl:object->float-expression) + (FLOAT->OBJECT ,rtl:float->object-expression)) + (,value-class=value? (FLOAT->OBJECT ,rtl:float->object-expression) + (OBJECT->FLOAT ,rtl:object->float-expression)) + (,value-class=address? (OBJECT->ADDRESS ,rtl:object->address-expression) + (CONS-POINTER ,rtl:cons-pointer-datum)) + ;; The following are not value-class=datum? and value-class=type? + ;; because they are slightly more general. + (,value-class=immediate? (OBJECT->DATUM ,rtl:object->datum-expression) + (CONS-NON-POINTER ,rtl:cons-non-pointer-datum)) + + (,value-class=ascii? (CHAR->ASCII ,rtl:char->ascii-expression) + (CONS-POINTER ,rtl:cons-pointer-datum)) + (,value-class=ascii? (CHAR->ASCII ,rtl:char->ascii-expression) + (CONS-NON-POINTER ,rtl:cons-non-pointer-datum)) + + (,value-class=immediate? (OBJECT->TYPE ,rtl:object->type-expression) + (CONS-POINTER ,rtl:cons-pointer-type)) + (,value-class=immediate? (OBJECT->TYPE ,rtl:object->type-expression) + (CONS-NON-POINTER ,rtl:cons-non-pointer-type)))) + +(define (valid-subexpression? expression) + ;; Machine registers not allowed because they are volatile. + ;; Ideally at this point we could introduce a copy to the + ;; value of the machine register required, but it is too late + ;; to do this. Perhaps always copying machine registers out + ;; before using them would make this win. + (or (not (rtl:register? expression)) + (rtl:pseudo-register-expression? expression))) + +(define (canonicalize-subexpression expression) + (or (and (rtl:pseudo-register-expression? expression) + (register-value (rtl:register-number expression))) + expression)) + +(define (define-method type method) + (let ((entry (assq type methods))) + (if entry + (set-cdr! entry method) + (set! methods (cons (cons type method) methods)))) + type) + +(define (lookup-method type) + (if (eq? type 'ASSIGN) + walk/assign + (let ((entry (assq type methods))) + (if (not entry) + (error "Missing method" type)) + (cdr entry)))) + +(define methods + '()) + +(define (walk/assign statement) + (expression-update! rtl:assign-expression + rtl:set-assign-expression! + statement) + (let ((address (rtl:assign-address statement))) + (if (rtl:pseudo-register-expression? address) + (set-register-value! (rtl:register-number address) + (rtl:assign-expression statement))))) + +(define-method 'INVOCATION:SPECIAL-PRIMITIVE + (lambda (statement) + statement + (for-each-pseudo-register + (lambda (register) + (set-register-value! register false))))) + +(for-each (lambda (type) + (define-method type (lambda (statement) statement unspecific))) + '(CLOSURE-HEADER + CONTINUATION-ENTRY + CONTINUATION-HEADER + IC-PROCEDURE-HEADER + INVOCATION:APPLY + INVOCATION:COMPUTED-JUMP + INVOCATION:COMPUTED-LEXPR + INVOCATION:JUMP + INVOCATION:LEXPR + INVOCATION:PRIMITIVE + INVOCATION:UUO-LINK + INVOCATION:GLOBAL-LINK + OPEN-PROCEDURE-HEADER + OVERFLOW-TEST + POP-RETURN + PROCEDURE-HEADER + INVOCATION:PROCEDURE + INVOCATION:REGISTER + INVOCATION:NEW-APPLY + RETURN-ADDRESS + PROCEDURE + TRIVIAL-CLOSURE + CLOSURE + EXPRESSION + INTERRUPT-CHECK:PROCEDURE + INTERRUPT-CHECK:CONTINUATION + INTERRUPT-CHECK:CLOSURE + INTERRUPT-CHECK:SIMPLE-LOOP + PRESERVE + RESTORE)) + +(define (define-one-arg-method type get set) + (define-method type + (lambda (statement) + (expression-update! get set statement)))) + +(define-one-arg-method 'FIXNUM-PRED-1-ARG + rtl:fixnum-pred-1-arg-operand + rtl:set-fixnum-pred-1-arg-operand!) + +(define-one-arg-method 'FLONUM-PRED-1-ARG + rtl:flonum-pred-1-arg-operand + rtl:set-flonum-pred-1-arg-operand!) + +(define-one-arg-method 'TYPE-TEST + rtl:type-test-expression + rtl:set-type-test-expression!) + +(define-one-arg-method 'PRED-1-ARG + rtl:pred-1-arg-operand + rtl:set-pred-1-arg-operand!) + +(define-one-arg-method 'INVOCATION:CACHE-REFERENCE + rtl:invocation:cache-reference-name + rtl:set-invocation:cache-reference-name!) + +(define-one-arg-method 'INVOCATION:LOOKUP + rtl:invocation:lookup-environment + rtl:set-invocation:lookup-environment!) + +(define-one-arg-method 'INVOCATION-PREFIX:MOVE-FRAME-UP + rtl:invocation-prefix:move-frame-up-locative + rtl:set-invocation-prefix:move-frame-up-locative!) + +(define-one-arg-method 'INTERPRETER-CALL:ACCESS + rtl:interpreter-call:access-environment + rtl:set-interpreter-call:access-environment!) + +(define-one-arg-method 'INTERPRETER-CALL:CACHE-REFERENCE + rtl:interpreter-call:cache-reference-name + rtl:set-interpreter-call:cache-reference-name!) + +(define-one-arg-method 'INTERPRETER-CALL:CACHE-UNASSIGNED? + rtl:interpreter-call:cache-unassigned?-name + rtl:set-interpreter-call:cache-unassigned?-name!) + +(define-one-arg-method 'INTERPRETER-CALL:LOOKUP + rtl:interpreter-call:lookup-environment + rtl:set-interpreter-call:lookup-environment!) + +(define-one-arg-method 'INTERPRETER-CALL:UNASSIGNED? + rtl:interpreter-call:unassigned?-environment + rtl:set-interpreter-call:unassigned?-environment!) + +(define-one-arg-method 'INTERPRETER-CALL:UNBOUND? + rtl:interpreter-call:unbound?-environment + rtl:set-interpreter-call:unbound?-environment!) + +(define (define-two-arg-method type get-1 set-1 get-2 set-2) + (define-method type + (lambda (statement) + (expression-update! get-1 set-1 statement) + (expression-update! get-2 set-2 statement)))) + +(define-two-arg-method 'EQ-TEST + rtl:eq-test-expression-1 + rtl:set-eq-test-expression-1! + rtl:eq-test-expression-2 + rtl:set-eq-test-expression-2!) + +(define-two-arg-method 'PRED-2-ARGS + rtl:pred-2-args-operand-1 + rtl:set-pred-2-args-operand-1! + rtl:pred-2-args-operand-2 + rtl:set-pred-2-args-operand-2!) + +(define-two-arg-method 'FIXNUM-PRED-2-ARGS + rtl:fixnum-pred-2-args-operand-1 + rtl:set-fixnum-pred-2-args-operand-1! + rtl:fixnum-pred-2-args-operand-2 + rtl:set-fixnum-pred-2-args-operand-2!) + +(define-two-arg-method 'FLONUM-PRED-2-ARGS + rtl:flonum-pred-2-args-operand-1 + rtl:set-flonum-pred-2-args-operand-1! + rtl:flonum-pred-2-args-operand-2 + rtl:set-flonum-pred-2-args-operand-2!) + +(define-two-arg-method 'INVOCATION-PREFIX:DYNAMIC-LINK + rtl:invocation-prefix:dynamic-link-locative + rtl:set-invocation-prefix:dynamic-link-locative! + rtl:invocation-prefix:dynamic-link-register + rtl:set-invocation-prefix:dynamic-link-register!) + +(define-two-arg-method 'INTERPRETER-CALL:CACHE-ASSIGNMENT + rtl:interpreter-call:cache-assignment-name + rtl:set-interpreter-call:cache-assignment-name! + rtl:interpreter-call:cache-assignment-value + rtl:set-interpreter-call:cache-assignment-value!) + +(define-two-arg-method 'INTERPRETER-CALL:DEFINE + rtl:interpreter-call:define-environment + rtl:set-interpreter-call:define-environment! + rtl:interpreter-call:define-value + rtl:set-interpreter-call:define-value!) + +(define-two-arg-method 'INTERPRETER-CALL:SET! + rtl:interpreter-call:set!-environment + rtl:set-interpreter-call:set!-environment! + rtl:interpreter-call:set!-value + rtl:set-interpreter-call:set!-value!) \ No newline at end of file diff --git a/v8/src/compiler/rtlopt/rlife.scm b/v8/src/compiler/rtlopt/rlife.scm new file mode 100644 index 000000000..143462c33 --- /dev/null +++ b/v8/src/compiler/rtlopt/rlife.scm @@ -0,0 +1,223 @@ +#| -*-Scheme-*- + +$Id: rlife.scm,v 1.1 1994/11/19 02:06:38 adams Exp $ + +Copyright (c) 1987-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Register Lifetime Analysis +;;; Based on the GNU C Compiler +;; package: (compiler rtl-optimizer lifetime-analysis) + +(declare (usual-integrations)) + +(define (lifetime-analysis rgraphs) + (for-each walk-rgraph rgraphs)) + +(define (walk-rgraph rgraph) + (let ((n-registers (rgraph-n-registers rgraph)) + (bblocks (rgraph-bblocks rgraph))) + (set-rgraph-register-bblock! rgraph (make-vector n-registers false)) + (set-rgraph-register-n-refs! rgraph (make-vector n-registers 0)) + (set-rgraph-register-n-deaths! rgraph (make-vector n-registers 0)) + (set-rgraph-register-live-length! rgraph (make-vector n-registers 0)) + (set-rgraph-register-crosses-call?! rgraph + (make-bit-string n-registers false)) + (for-each (lambda (bblock) + (set-bblock-live-at-entry! bblock (make-regset n-registers)) + (set-bblock-live-at-exit! bblock (make-regset n-registers)) + (set-bblock-new-live-at-exit! bblock + (make-regset n-registers))) + bblocks) + (fluid-let ((*current-rgraph* rgraph)) + (walk-bblocks bblocks)) + (for-each (lambda (bblock) + (set-bblock-new-live-at-exit! bblock false)) + (rgraph-bblocks rgraph)))) + +(define (walk-bblocks bblocks) + (let ((changed? false)) + (define (loop first-pass?) + (for-each (lambda (bblock) + (if (or first-pass? + (not (regset=? (bblock-live-at-exit bblock) + (bblock-new-live-at-exit bblock)))) + (begin (set! changed? true) + (regset-copy! (bblock-live-at-exit bblock) + (bblock-new-live-at-exit bblock)) + (regset-copy! (bblock-live-at-entry bblock) + (bblock-live-at-exit bblock)) + (propagate-block bblock) + (for-each-previous-node + bblock + (lambda (bblock*) + (regset-union! + (bblock-new-live-at-exit bblock*) + (bblock-live-at-entry bblock))))))) + bblocks) + (if changed? + (begin (set! changed? false) + (loop false)) + (for-each (lambda (bblock) + (regset-copy! (bblock-live-at-entry bblock) + (bblock-live-at-exit bblock)) + (propagate-block&delete! bblock)) + bblocks))) + (loop true))) + +(define (regset-population-count regset) + (let ((result 0)) + (for-each-regset-member regset + (lambda (index) + (set! result (+ result 1)) + index)) + result)) + +(define (propagate-block bblock) + (propagation-loop bblock + (lambda (dead live rinst) + (update-live-registers! (bblock-live-at-entry bblock) + dead + live + (rinst-rtl rinst) + false false)))) + +(define (propagate-block&delete! bblock) + (for-each-regset-member (bblock-live-at-entry bblock) + (lambda (register) + (set-register-bblock! register 'NON-LOCAL))) + (propagation-loop bblock + (lambda (dead live rinst) + (let ((rtl (rinst-rtl rinst)) + (old (bblock-live-at-entry bblock)) + (new (bblock-live-at-exit bblock))) + (if (rtl:invocation? rtl) + (for-each-regset-member old register-crosses-call!)) + (if (instruction-dead? rtl old new) + (set-rinst-rtl! rinst false) + (begin + (update-live-registers! old dead live rtl bblock rinst) + (for-each-regset-member old increment-register-live-length!)))))) + (bblock-perform-deletions! bblock)) + +(define (propagation-loop bblock procedure) + (let ((dead (regset-allocate (rgraph-n-registers *current-rgraph*))) + (live (regset-allocate (rgraph-n-registers *current-rgraph*)))) + (bblock-walk-backward bblock + (lambda (rinst) + (regset-clear! dead) + (regset-clear! live) + (procedure dead live rinst))))) + +(define (update-live-registers! old dead live rtl bblock rinst) + (mark-set-registers! old dead rtl bblock) + (mark-used-registers! old live rtl bblock rinst) + (regset-difference! old dead) + (regset-union! old live)) + +(define (mark-set-registers! needed dead rtl bblock) + ;; **** This code safely ignores PRE-INCREMENT and POST-INCREMENT + ;; modes, since they are only used on the stack pointer. + needed + (if (rtl:assign? rtl) + (let ((address (rtl:assign-address rtl))) + (if (interesting-register? address) + (let ((register (rtl:register-number address))) + (regset-adjoin! dead register) + (if bblock (record-register-reference register bblock))))))) + +(define (mark-used-registers! needed live rtl bblock rinst) + (define (loop expression) + (if (interesting-register? expression) + (let ((register (rtl:register-number expression))) + (regset-adjoin! live register) + (if bblock + (begin (record-register-reference register bblock) + (if (and (not (regset-member? needed register)) + (not (rinst-dead-register? rinst register))) + (begin (set-rinst-dead-registers! + rinst + (cons register + (rinst-dead-registers rinst))) + (increment-register-n-deaths! register)))))) + (rtl:for-each-subexpression expression loop))) + + (define (register-assignment register expr) + (if (let ((register-number (rtl:register-number register))) + (or (machine-register? register-number) + (regset-member? needed register-number))) + (and (not (rtl:restore? expr)) + (loop expr)))) + + (cond ((and (rtl:assign? rtl) + (rtl:register? (rtl:assign-address rtl))) + (register-assignment (rtl:assign-address rtl) + (rtl:assign-expression rtl))) + ((rtl:preserve? rtl) + ;; ignored at this stage + unspecific) + ((rtl:restore? rtl) + (if (not (rtl:register? (rtl:restore-value rtl))) + (register-assignment (rtl:restore-register rtl) + (rtl:restore-value rtl))) + unspecific) + (else + (rtl:for-each-subexpression rtl loop)))) + +(define (record-register-reference register bblock) + (let ((bblock* (register-bblock register))) + (cond ((not bblock*) + (set-register-bblock! register bblock)) + ((not (eq? bblock bblock*)) + (set-register-bblock! register 'NON-LOCAL))) + (increment-register-n-refs! register))) + +(define (instruction-dead? rtl needed computed) + (cond ((rtl:assign? rtl) + (and (let ((address (rtl:assign-address rtl))) + (and (rtl:register? address) + (let ((register (rtl:register-number address))) + (and (pseudo-register? register) + (not (regset-member? needed register)))))) + (not (rtl:expression-contains? (rtl:assign-expression rtl) + rtl:volatile-expression?)))) + ((rtl:preserve? rtl) + (let ((reg (rtl:register-number (rtl:preserve-register rtl)))) + (and (pseudo-register? reg) + (not (regset-member? computed reg))))) + ((rtl:restore? rtl) + (let ((reg (rtl:register-number (rtl:restore-register rtl)))) + (not (regset-member? needed reg)))) + (else + false))) + +(define (interesting-register? expression) + (and (rtl:register? expression) + (pseudo-register? (rtl:register-number expression)))) \ No newline at end of file diff --git a/v8/src/compiler/rtlopt/rtlcsm.scm b/v8/src/compiler/rtlopt/rtlcsm.scm new file mode 100644 index 000000000..f26be8752 --- /dev/null +++ b/v8/src/compiler/rtlopt/rtlcsm.scm @@ -0,0 +1,331 @@ +#| -*-Scheme-*- + +$Id: rtlcsm.scm,v 1.1 1994/11/19 02:06:38 adams Exp $ + +Copyright (c) 1989-1994 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Common Suffix Merging +;; Package: (compiler rtl-optimizer common-suffix-merging) + +(declare (usual-integrations)) + +(define (merge-common-suffixes! rgraphs) + (for-each merge-suffixes-of-rgraph! rgraphs)) + +(define (merge-suffixes-of-rgraph! rgraph) + (let loop () + (let ((suffix-classes (rgraph-matching-suffixes rgraph))) + (if (not (null? suffix-classes)) + (begin + ;; Because many of the original bblocks can be discarded + ;; by the merging process, processing of one suffix class + ;; can make the information in the subsequent suffix + ;; classes incorrect. However, reanalysis will still + ;; reproduce the remaining suffix classes. So, process + ;; one class and reanalyze before continuing. + (merge-suffixes! rgraph (car suffix-classes)) + (loop)))))) + +(define (merge-suffixes! rgraph suffixes) + (with-values + (lambda () + (discriminate-items suffixes + (lambda (suffix) + (eq? (cdr suffix) (bblock-instructions (car suffix)))))) + (lambda (total-suffixes partial-suffixes) + (if (not (null? total-suffixes)) + (let ((new-bblock (caar total-suffixes))) + (for-each (lambda (suffix) + (replace-suffix-block! rgraph suffix new-bblock)) + (cdr total-suffixes)) + (replace-suffixes! rgraph new-bblock partial-suffixes)) + (let ((suffix (car partial-suffixes))) + (split-suffix-block! rgraph suffix) + (replace-suffixes! rgraph (car suffix) (cdr partial-suffixes))))))) + +(define (replace-suffixes! rgraph new-bblock partial-suffixes) + (for-each (lambda (suffix) + (split-suffix-block! rgraph suffix) + (replace-suffix-block! rgraph suffix new-bblock)) + partial-suffixes)) + +(define (split-suffix-block! rgraph suffix) + (let ((old-bblock (car suffix)) + (instructions (cdr suffix))) + (rinst-disconnect-previous! old-bblock instructions) + (let ((sblock (make-sblock (bblock-instructions old-bblock)))) + (node-insert-snode! old-bblock sblock) + (add-rgraph-bblock! rgraph sblock)) + (set-bblock-instructions! old-bblock instructions))) + +(define (replace-suffix-block! rgraph suffix new-bblock) + (let ((old-bblock (car suffix))) + (node-replace-on-right! old-bblock new-bblock) + (node-disconnect-on-left! old-bblock) + (delete-rgraph-bblock! rgraph old-bblock))) + +(define (rgraph-matching-suffixes rgraph) + (append-map (lambda (bblock-class) + (suffix-classes (initial-bblock-matches bblock-class))) + (rgraph/bblock-classes rgraph))) + +(define (rgraph/bblock-classes rgraph) + (let ((sblock-classes (list false)) + (pblock-classes (list false))) + (for-each (lambda (bblock) + (if (sblock? bblock) + (add-sblock-to-classes! sblock-classes bblock) + (add-pblock-to-classes! pblock-classes bblock))) + (rgraph-bblocks rgraph)) + (let ((singleton? (lambda (x) (null? (cdr x))))) + (append! (list-transform-negative (cdr sblock-classes) singleton?) + (list-transform-negative (cdr pblock-classes) singleton?))))) + +(define (add-sblock-to-classes! classes sblock) + (let ((next (snode-next sblock))) + (let loop ((previous classes) (classes (cdr classes))) + (if (null? classes) + (set-cdr! previous (list (list sblock))) + (if (eq? next (snode-next (caar classes))) + (set-car! classes (cons sblock (car classes))) + (loop classes (cdr classes))))))) + +(define (add-pblock-to-classes! classes pblock) + (let ((consequent (pnode-consequent pblock)) + (alternative (pnode-alternative pblock))) + (let loop ((previous classes) (classes (cdr classes))) + (if (null? classes) + (set-cdr! previous (list (list pblock))) + (if (let ((pblock* (caar classes))) + (and (eq? consequent (pnode-consequent pblock*)) + (eq? alternative (pnode-alternative pblock*)))) + (set-car! classes (cons pblock (car classes))) + (loop classes (cdr classes))))))) + +(define (initial-bblock-matches bblocks) + (let loop ((bblocks bblocks)) + (if (null? bblocks) + '() + (let ((entries (find-matching-bblocks (car bblocks) (cdr bblocks)))) + (if (null? entries) + (loop (cdr bblocks)) + (append! entries (loop (cdr bblocks)))))))) + +(define (suffix-classes entries) + (let ((classes '()) + (class-member? + (lambda (class suffix) + (list-search-positive class + (lambda (suffix*) + (and (eq? (car suffix) (car suffix*)) + (eq? (cdr suffix) (cdr suffix*)))))))) + (for-each (lambda (entry) + (let ((class + (list-search-positive classes + (lambda (class) + (class-member? class (car entry)))))) + (if class + (if (not (class-member? class (cdr entry))) + (set-cdr! class (cons (cdr entry) (cdr class)))) + (let ((class + (list-search-positive classes + (lambda (class) + (class-member? class (cdr entry)))))) + (if class + (set-cdr! class (cons (car entry) (cdr class))) + (set! classes + (cons (list (car entry) (cdr entry)) + classes)))))) + unspecific) + entries) + (map cdr + (sort (map (lambda (class) (cons (rinst-length (cdar class)) class)) + classes) + (lambda (x y) + (< (car x) (car y))))))) + +;;;; Basic Block Matching + +(define (find-matching-bblocks bblock bblocks) + (let loop ((bblocks bblocks)) + (if (null? bblocks) + '() + (with-values (lambda () (matching-suffixes bblock (car bblocks))) + (lambda (sx sy adjustments) + (if (or (interesting-suffix? bblock sx) + (interesting-suffix? (car bblocks) sy)) + (begin + (for-each (lambda (adjustment) (adjustment)) adjustments) + (cons (cons (cons bblock sx) (cons (car bblocks) sy)) + (loop (cdr bblocks)))) + (loop (cdr bblocks)))))))) + +(define (interesting-suffix? bblock rinst) + (and rinst + (or (rinst-next rinst) + (eq? rinst (bblock-instructions bblock)) + (and (sblock? bblock) + (snode-next bblock)) + (let ((rtl (rinst-rtl rinst))) + (let ((type (rtl:expression-type rtl))) + (if (eq? type 'INVOCATION:PRIMITIVE) + (let ((procedure (rtl:invocation:primitive-procedure rtl))) + (and (not (eq? compiled-error-procedure procedure)) + (negative? (primitive-procedure-arity procedure)))) + (memq type + '(INTERPRETER-CALL:ACCESS + INTERPRETER-CALL:DEFINE + INTERPRETER-CALL:LOOKUP + INTERPRETER-CALL:SET! + INTERPRETER-CALL:UNASSIGNED? + INTERPRETER-CALL:UNBOUND + INTERPRETER-CALL:CACHE-ASSIGNMENT + INTERPRETER-CALL:CACHE-REFERENCE + INTERPRETER-CALL:CACHE-UNASSIGNED? + INVOCATION:COMPUTED-LEXPR + INVOCATION:CACHE-REFERENCE + INVOCATION:LOOKUP)))))))) + +(define (matching-suffixes x y) + (let loop + ((rx (bblock-reversed-instructions x)) + (ry (bblock-reversed-instructions y)) + (wx false) + (wy false) + (e '()) + (adjustments '())) + (if (or (null? rx) (null? ry)) + (values wx wy adjustments) + (with-values + (lambda () + (match-rtl (rinst-rtl (car rx)) (rinst-rtl (car ry)) e)) + (lambda (e adjustment) + (if (eq? e 'FAILURE) + (values wx wy adjustments) + (let ((adjustments + (if adjustment + (cons adjustment adjustments) + adjustments))) + (if (for-all? e (lambda (b) (eqv? (car b) (cdr b)))) + (loop (cdr rx) (cdr ry) + (car rx) (car ry) + e adjustments) + (loop (cdr rx) (cdr ry) + wx wy + e adjustments))))))))) + +;;;; RTL Instruction Matching + +(define (match-rtl x y e) + (cond ((not (eq? (rtl:expression-type x) (rtl:expression-type y))) + (values 'FAILURE false)) + ((rtl:assign? x) + (values + (let ((ax (rtl:assign-address x))) + (let ((e (match ax (rtl:assign-address y) e))) + (if (eq? e 'FAILURE) + 'FAILURE + (match (rtl:assign-expression x) + (rtl:assign-expression y) + (remove-from-environment! + e + (if (rtl:pseudo-register-expression? ax) + (list (rtl:register-number ax)) + '())))))) + false)) + ((and (rtl:invocation? x) + (rtl:invocation:continuation-unimportant? x) + (not (eqv? (rtl:invocation-continuation x) + (rtl:invocation-continuation y)))) + (let ((x* (rtl:map-subexpressions x identity-procedure)) + (y* (rtl:map-subexpressions y identity-procedure))) + (rtl:set-invocation-continuation! x* false) + (rtl:set-invocation-continuation! y* false) + (values (match x* y* e) + (lambda () + (rtl:set-invocation-continuation! x false) + (rtl:set-invocation-continuation! y false))))) + (else + (values (match x y e) false)))) + +(define (rtl:invocation:continuation-unimportant? expression) + ;; This should probably be in the back-end where we decide on a + ;; case-by-case basis whether or not to generate code referencing + ;; the continuation label. + (not (memq (rtl:expression-type expression) + '(INVOCATION:PROCEDURE + INVOCATION:NEW-APPLY + INVOCATION:UUO-LINK + INVOCATION:GLOBAL-LINK)))) + +(define (remove-from-environment! e keys) + (if (null? keys) + e + (remove-from-environment! (del-assv! (car keys) e) (cdr keys)))) + +(define (match x y e) + (cond ((pair? x) + (let ((type (car x))) + (if (and (pair? y) (eq? type (car y))) + (case type + ((CONSTANT) + (if (eqv? (cadr x) (cadr y)) + e + 'FAILURE)) + ((REGISTER) + (let ((rx (cadr x)) + (ry (cadr y))) + (if (pseudo-register? rx) + (if (pseudo-register? ry) + (let ((entry (assv rx e))) + (cond ((not entry) (cons (cons rx ry) e)) + ((eqv? (cdr entry) ry) e) + (else 'FAILURE))) + 'FAILURE) + (if (pseudo-register? ry) + 'FAILURE + (if (eqv? rx ry) + e + 'FAILURE))))) + (else + (let loop ((x (cdr x)) (y (cdr y)) (e e)) + (cond ((pair? x) + (if (pair? y) + (let ((e (match (car x) (car y) e))) + (if (eq? e 'FAILURE) + 'FAILURE + (loop (cdr x) (cdr y) e))) + 'FAILURE)) + ((eqv? x y) e) + (else 'FAILURE))))) + 'FAILURE))) + ((eqv? x y) e) + (else 'FAILURE))) \ No newline at end of file -- 2.25.1