From 91e6f2a25fbce31b6021547a1e72afd302a2525d Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 24 Aug 2009 21:51:27 -0700 Subject: [PATCH] Initial check-in. --- src/compiler/machines/svm/lapgen.scm | 292 +++++ src/compiler/machines/svm/lapopt.scm | 373 ++++++ src/compiler/machines/svm/rgspcm.scm | 66 ++ src/compiler/machines/svm/rules.scm | 1650 ++++++++++++++++++++++++++ 4 files changed, 2381 insertions(+) create mode 100644 src/compiler/machines/svm/lapgen.scm create mode 100644 src/compiler/machines/svm/lapopt.scm create mode 100644 src/compiler/machines/svm/rgspcm.scm create mode 100644 src/compiler/machines/svm/rules.scm diff --git a/src/compiler/machines/svm/lapgen.scm b/src/compiler/machines/svm/lapgen.scm new file mode 100644 index 000000000..bd4736132 --- /dev/null +++ b/src/compiler/machines/svm/lapgen.scm @@ -0,0 +1,292 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. + +|# + +;;;; RTL rule utilities for SVM +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +;;;; Register-allocator interface + +(define (sort-machine-registers registers) + registers) + +(define (register-type register) + (cond ((register-value-class=word? register) 'WORD) + ((register-value-class=float? register) 'FLOAT) + (else (error:bad-range-argument register 'REGISTER-TYPE)))) + +(define-syntax define-fixed-register-references + (sc-macro-transformer + (lambda (form environment) + environment + (if (syntax-match? '(* symbol) (cdr form)) + `(BEGIN + ,@(map (lambda (name) + `(DEFINE-INTEGRABLE ,(symbol-append 'RREF: name) + (REGISTER-REFERENCE ,(symbol-append 'REGNUM: name)))) + (cdr form))) + (ill-formed-syntax form))))) + +(define-fixed-register-references + stack-pointer + dynamic-link + free-pointer + value + environment) + +(define (pseudo-register-home register) + (error "Attempt to access temporary register:" register)) + +(define (register->register-transfer source target) + (if (= source target) + (LAP) + (begin + (guarantee-registers-compatible source target) + (inst:copy (register-reference target) + (register-reference source))))) + +(define (reference->register-transfer source target) + (cond ((register-reference? source) + (register->register-transfer (reference->register source) target)) + ((memory-reference? source) + (inst:load 'WORD (register-reference target) source)) + (else + (error:bad-range-argument source #f)))) + +(define (home->register-transfer source target) + (inst:load 'WORD (register-reference target) (pseudo-register-home source))) + +(define (register->home-transfer source target) + (inst:store 'WORD (register-reference target) (pseudo-register-home target))) + +;;;; Linearizer interface + +(define lap:make-label-statement + inst:label) + +(define (lap:make-unconditional-branch label) + (inst:jump (ea:address label))) + +(define (lap:make-entry-point label block-start-label) + block-start-label + (LAP ,@(inst:entry-point label) + ,@(make-expression-label label))) + +(define (make-expression-label label) + (make-external-label label 'EXPRESSION)) + +(define (make-external-label label type-code) + (set! *external-labels* (cons label *external-labels*)) + (LAP ,@(inst:datum-u16 type-code) + ,@(inst:datum-u16 `(- ,label *START*)) + ,@(inst:label label))) + +(define (make-expression-label label) + (make-external-label label #xFFFF)) + +(define (make-internal-entry-label label) + (make-external-label label #xFFFE)) + +(define (make-internal-continuation-label label) + (make-external-label label #xFFFD)) + +(define (make-procedure-label n-required n-optional rest? label) + (make-external-label label + (encode-procedure-type n-required n-optional rest?))) + +(define (make-internal-procedure-label label) + (make-external-label label (encode-continuation-offset label #xFFFE))) + +(define (make-continuation-label entry-label label) + (make-external-label label (encode-continuation-offset label #xFFFD))) + +(define (encode-procedure-type n-required n-optional rest?) + (guarantee-exact-nonnegative-integer n-required) + (guarantee-exact-nonnegative-integer n-optional) + (if (not (and (< n-required #x80) (< n-optional #x80))) + (error "Can't encode procedure arity:" n-required n-optional)) + (fix:or n-required + (fix:or (fix:lsh n-optional 7) + (if rest? #x4000 0)))) + +(define (encode-continuation-offset label default) + (let ((offset + (rtl-procedure/next-continuation-offset (label->object label)))) + (if offset + (begin + (guarantee-exact-nonnegative-integer offset) + (if (not (< offset #x7FF8)) + (error "Can't encode next-continuation offset:" offset)) + (+ offset #x8000)) + default))) + +;;;; Utilities for the rules + +(define (load-constant target object) + (cond ((object-pointer? object) + (inst:load 'WORD + target + (ea:address (constant->label object)))) + ((object-non-pointer? object) + (inst:load-non-pointer target + (object-type object) + (object-datum object))) + (else + (error:bad-range-argument object 'LOAD-CONSTANT)))) + +(define (simple-branches! condition source1 #!default source2) + (if (default-object? source2) + (set-current-branches! + (lambda (label) + (inst:conditional-jump condition source1 (ea:address label))) + (lambda (label) + (inst:conditional-jump (invert-condition condition) + source1 (ea:address label)))) + (set-current-branches! + (lambda (label) + (inst:conditional-jump condition source1 source2 (ea:address label))) + (lambda (label) + (inst:conditional-jump (invert-condition condition) + source1 source2 (ea:address label)))))) + +(define (invert-condition condition) + (let loop + ((conditions + '((EQ NEQ) + (LT GE) + (GT LE) + (SLT SGE) + (SGT SLE) + (CMP NCMP) + (FIX NFIX) + (IFIX NIFIX)))) + (if (not (pair? conditions)) + (error:bad-range-argument condition 'INVERT-CONDITION)) + (cond ((eq? (caar conditions) condition) (cdar conditions)) + ((eq? (cdar conditions) condition) (caar conditions)) + (else (loop (cdr conditions)))))) + +(define (internal->external-label label) + (rtl-procedure/external-label (label->object label))) + +(define (word-source source) + (register-reference (load-alias-register! source 'WORD))) + +(define (word-target target) + (delete-dead-registers!) + (register-reference (or (register-alias target 'WORD) + (allocate-alias-register! target 'WORD)))) + +(define (word-temporary) + (register-reference (allocate-temporary-register! 'WORD))) + +(define (float-source source) + (register-reference (load-alias-register! source 'FLOAT))) + +(define (float-target target) + (delete-dead-registers!) + (register-reference (or (register-alias target 'FLOAT) + (allocate-alias-register! target 'FLOAT)))) + +(define (float-temporary) + (register-reference (allocate-temporary-register! 'FLOAT))) + +(define (parse-memory-ref expression) + (pattern-lookup memory-ref-rules expression)) + +(define (parse-memory-address expression) + (receive (scale ea) (pattern-lookup memory-address-rules expression) + scale + ea)) + +(define (make-memory-rules offset-operator?) + (list (rule-matcher ((? scale offset-operator?) + (REGISTER (? base)) + (REGISTER (? index))) + (values scale + (ea:indexed (word-source base) + 0 scale + (word-source index) scale))) + (rule-matcher ((? scale offset-operator?) + (REGISTER (? base)) + (MACHINE-CONSTANT (? offset))) + (values scale + (ea:offset (word-source base) offset scale))) + (rule-matcher ((? scale offset-operator?) + ((? scale* offset-address-operator?) + (REGISTER (? base)) + (REGISTER (? index))) + (MACHINE-CONSTANT (? offset))) + (values scale + (ea:indexed (word-source base) + offset scale + (word-source index) scale*))) + (rule-matcher ((? scale offset-operator?) + ((? scale* offset-address-operator?) + (REGISTER (? base)) + (MACHINE-CONSTANT (? offset))) + (REGISTER (? index))) + (values scale + (ea:indexed (word-source base) + offset scale* + (word-source index) scale))) + (rule-matcher (POST-INCREMENT (REGISTER (? base)) 1) + (values 'WORD + (ea:post-increment (word-source base) 'WORD))) + (rule-matcher (PRE-INCREMENT (REGISTER (? base)) -1) + (values 'WORD + (ea:pre-decrement (word-source base) 'WORD))))) + +(define memory-ref-rules + (make-memory-rules + (lambda (expression) + (offset-operator? expression)))) + +(define memory-address-rules + (make-memory-rules + (lambda (expression) + (offset-address-operator? expression)))) + +(define (offset-operator? expression) + (case expression + ((OFFSET) 'WORD) + ((BYTE-OFFSET) 'BYTE) + ((FLOAT-OFFSET) 'FLOAT) + (else #f))) + +(define (offset-address-operator? expression) + (case expression + ((OFFSET-ADDRESS) 'WORD) + ((BYTE-OFFSET-ADDRESS) 'BYTE) + ((FLOAT-OFFSET-ADDRESS) 'FLOAT) + (else #f))) + +(define (pre-lapgen-analysis rgraphs) + (for-each (lambda (rgraph) + (for-each (lambda (edge) + (determine-interrupt-checks (edge-right-node edge))) + (rgraph-entry-edges rgraph))) + rgraphs)) \ No newline at end of file diff --git a/src/compiler/machines/svm/lapopt.scm b/src/compiler/machines/svm/lapopt.scm new file mode 100644 index 000000000..f5cf7e12f --- /dev/null +++ b/src/compiler/machines/svm/lapopt.scm @@ -0,0 +1,373 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. + +|# + +;;;; LAP Optimizer for SVM +;;; package: (compiler lap-optimizer) + +(declare (usual-integrations)) + +(define (optimize-linear-lap instructions) + (rewrite-lap instructions)) + +;; i386 LAPOPT uses its own pattern matcher because we want to match +;; patterns while ignoring comments. + +(define (comment? thing) + (and (pair? thing) + (eq? (car thing) 'COMMENT))) + +(define (match pat thing dict) ; -> #F or dictionary (alist) + (if (pair? pat) + (if (eq? (car pat) '?) + (cond ((assq (cadr pat) dict) + => (lambda (pair) + (and (equal? (cdr pair) thing) + dict))) + (else (cons (cons (cadr pat) thing) dict))) + (and (pair? thing) + (let ((dict* (match (car pat) (car thing) dict))) + (and dict* + (match (cdr pat) (cdr thing) dict*))))) + (and (eqv? pat thing) + dict))) + +(define (match-sequence pats things dict comments success fail) + ;; SUCCESS = (lambda (dict* comments* things-tail) ...) + ;; FAIL = (lambda () ...) + + (define (eat-comment) + (match-sequence pats (cdr things) dict (cons (car things) comments) + success fail)) + + (cond ((not (pair? pats)) + (if (and (pair? things) + (comment? (car things))) + (eat-comment) + (success dict comments things))) + ((not (pair? things)) + (fail)) + ((comment? (car things)) + (eat-comment)) + ((match (car pats) (car things) dict) + => (lambda (dict*) + (match-sequence (cdr pats) (cdr things) dict* comments + success fail))) + (else (fail)))) + +(define-structure (rule) + name ; used only for information + pattern ; INSNs (in reverse order) + predicate ; (lambda (dict) ...) -> bool + constructor) ; (lambda (dict) ...) -> lap + +(define *rules* + (make-eq-hash-table)) + +;; Rules are indexed by the last opcode in the pattern. + +(define (define-lapopt name pattern predicate constructor) + (let ((pattern (reverse pattern))) + (let ((rule (make-rule name + pattern + (if ((access procedure? system-global-environment) + predicate) + predicate + (lambda (dict) dict #T)) + constructor))) + (if (or (not (pair? pattern)) + (not (pair? (car pattern)))) + (error "Illegal LAPOPT pattern - must end with opcode" + (reverse pattern))) + (let ((key (caar pattern))) + (hash-table/put! *rules* key + (cons rule (hash-table/get *rules* key '())))))) + name) + +(define (find-rules instruction) + (hash-table/get *rules* (car instruction) '())) + +;; Rules are tried in the reverse order in which they are defined. +;; +;; Rules are matched against the LAP from the bottom up. +;; +;; Once a rule has been applied, the rewritten LAP is matched again, +;; so a rule must rewrite to something different to avoid a loop. +;; (One way to ensure this is to always rewrite to fewer instructions.) + +(define (rewrite-lap lap) + (let loop ((unseen (reverse lap)) (finished '())) + (if (null? unseen) + finished + (if (comment? (car unseen)) + (loop (cdr unseen) (cons (car unseen) finished)) + (let try-rules ((rules (find-rules (car unseen)))) + (if (null? rules) + (loop (cdr unseen) (cons (car unseen) finished)) + (let ((rule (car rules))) + (match-sequence + (rule-pattern rule) + unseen + '(("empty")) ; initial dict, distinct from #F and () + '() ; initial comments + (lambda (dict comments unseen*) + (let ((dict (alist->dict dict))) + (if ((rule-predicate rule) dict) + (let ((rewritten + (cons + `(COMMENT (LAP-OPT ,(rule-name rule))) + (append comments + ((rule-constructor rule) dict))))) + (loop (append (reverse rewritten) unseen*) + finished)) + (try-rules (cdr rules))))) + (lambda () + (try-rules (cdr rules))))))))))) + +;; The DICT passed to the rule predicate and action procedures is a +;; procedure mapping pattern names to their matched values. + +(define (alist->dict dict) + (lambda (symbol) + (cond ((assq symbol dict) => cdr) + (else (error "Undefined lapopt pattern symbol" symbol dict))))) + + +(define-lapopt 'PUSH-POP->MOVE + `((PUSH (? reg1)) + (POP (? reg2))) + #F + (lambda (dict) + `((MOV W ,(dict 'reg2) ,(dict 'reg1))))) + +(define-lapopt 'PUSH-POP->NOP + `((PUSH (? reg)) + (POP (? reg))) + #F + (lambda (dict) + dict + `())) + +;; The following rules must have the JMP else we don't know if the +;; register that we are avoiding loading is dead. + +(define-lapopt 'LOAD-PUSH-POP-JUMP->REGARGETTED-LOAD-JUMP + ;; Note that reg1 must match a register because of the PUSH insn. + `((MOV W (? reg1) (? ea/value)) + (PUSH (? reg1)) + (POP (R ,ecx)) + (JMP (@RO B 6 (? hook-offset)))) + #F + (lambda (dict) + `((MOV W (R ,ecx) ,(dict 'ea/value)) + (JMP (@RO B 6 ,(dict 'hook-offset)))))) + +(define-lapopt 'LOAD-STACKTOPWRITE-POP-JUMP->RETARGETTED-LOAD-JUMP + `((MOV W (? reg) (? ea/value)) + (MOV W (@r ,esp) (? reg)) + (POP (R ,ecx)) + (JMP (@RO B 6 (? hook-offset)))) + #F + (lambda (dict) + `((MOV W (R ,ecx) ,(dict 'ea/value)) + (ADD W (R ,esp) (& 4)) + (JMP (@RO B 6 ,(dict 'hook-offset)))))) + + +(define-lapopt 'STACKWRITE-POP-JUMP->RETARGETTED-LOAD-JUMP + `((MOV W (@RO B ,esp (? stack-offset)) (? ea/value)) + (ADD W (R ,esp) (& (? stack-offset))) + (POP (R ,ecx)) + (JMP (@RO B 6 (? hook-offset)))) + #F + (lambda (dict) + `((MOV W (R ,ecx) ,(dict 'ea/value)) + (ADD W (R ,esp) (& ,(+ 4 (dict 'stack-offset)))) + (JMP (@RO B 6 ,(dict 'hook-offset)))))) + +;; The following rules recognize arithmetic followed by tag injection, +;; and fold the tag-injection into the arithmetic. We can do this +;; because we know the bottom six bits of the fixnum are all 0. This +;; is particularly crafty in the generic arithmetic case, as it does +;; not mess up the overflow detection. +;; +;; These patterns match the code generated by subtractions too. + +(define fixnum-tag (object-type 1)) + +(define-lapopt 'FIXNUM-ADD-CONST-TAG + `((ADD W (R (? reg)) (& (? const))) + (OR W (R (? reg)) (& ,fixnum-tag)) + (ROR W (R (? reg)) (& 6))) + #F + (lambda (dict) + `((ADD W (R ,(dict 'reg)) (& ,(+ (dict 'const) fixnum-tag))) + (ROR W (R ,(dict 'reg)) (& 6))))) + +(define-lapopt 'FIXNUM-ADD-REG-TAG + `((ADD W (R (? reg)) (R (? reg-2))) + (OR W (R (? reg)) (& ,fixnum-tag)) + (ROR W (R (? reg)) (& 6))) + #F + (lambda (dict) + `((LEA (R ,(dict 'reg)) (@ROI B ,(dict 'reg) ,fixnum-tag ,(dict 'reg-2) 1)) + (ROR W (R ,(dict 'reg)) (& 6))))) + +(define-lapopt 'GENERIC-ADD-TAG + `((ADD W (R (? reg)) (& (? const))) + (JO (@PCR (? label))) + (OR W (R (? reg)) (& ,fixnum-tag)) + (ROR W (R (? reg)) (& 6))) + #F + (lambda (dict) + `((ADD W (R ,(dict 'reg)) (& ,(+ (dict 'const) fixnum-tag))) + (JO (@PCR ,(dict 'label))) + (ROR W (R ,(dict 'reg)) (& 6))))) + +;; If the fixnum tag is even, the zero LSB works as a place to hold +;; the overflow from addition which can be discarded by masking it +;; out. We must arrange that the constant is positive, so we don't +;; borrow from the tag bits. + +(if (even? fixnum-tag) + (define-lapopt 'FIXNUM-ADD-CONST-IN-PLACE + `((SAL W (? reg) (& ,scheme-type-width)) + (ADD W (? reg) (& (? const))) + (OR W (? reg) (& ,fixnum-tag)) + (ROR W (? reg) (& ,scheme-type-width))) + #F + (lambda (dict) + (let ((const (sar-32 (dict 'const) scheme-type-width)) + (mask (make-non-pointer-literal + fixnum-tag + (-1+ (expt 2 scheme-datum-width))))) + (let ((const + (if (negative? const) + (+ const (expt 2 scheme-datum-width)) + const))) + `(,(if (= const 1) + `(INC W ,(dict 'reg)) ; shorter instruction + `(ADD W ,(dict 'reg) (& ,const))) + (AND W ,(dict 'reg) (& ,mask)))))))) + +;; Similar tag-injection combining rule for fix:or is a little more +;; general. + +(define (or-32-signed x y) + (bit-string->signed-integer + (bit-string-or (signed-integer->bit-string 32 x) + (signed-integer->bit-string 32 y)))) + +(define (ror-32-signed w count) + (let ((bs (signed-integer->bit-string 32 w))) + (bit-string->signed-integer + (bit-string-append (bit-substring bs count 32) + (bit-substring bs 0 count))))) + +(define (sar-32 w count) + (let ((bs (signed-integer->bit-string 32 w))) + (bit-string->signed-integer (bit-substring bs count 32)))) + +(define-lapopt 'OR-OR + `((OR W (R (? reg)) (& (? const-1))) + (OR W (R (? reg)) (& (? const-2)))) + #F + (lambda (dict) + `((OR W (R ,(dict 'reg)) + (& ,(or-32-signed (dict 'const-1) (dict 'const-2))))))) + +;; These rules match a whole fixnum detag-AND/OR-retag operation. In +;; principle, these operations could be done in rulfix.scm, but the +;; instruction combiner wants all the intermediate steps. + +(define-lapopt 'FIXNUM-OR-CONST-IN-PLACE + `((SAL W (? reg) (& ,scheme-type-width)) + (OR W (? reg) (& (? const))) + (OR W (? reg) (& ,fixnum-tag)) + (ROR W (? reg) (& ,scheme-type-width))) + #F + (lambda (dict) + `((OR W ,(dict 'reg) + (& ,(object-datum (sar-32 (dict 'const) scheme-type-width))))))) + +(define-lapopt 'FIXNUM-AND-CONST-IN-PLACE + `((SAL W (? reg) (& ,scheme-type-width)) + (AND W (? reg) (& (? const))) + (OR W (? reg) (& ,fixnum-tag)) + (ROR W (? reg) (& ,scheme-type-width))) + #F + (lambda (dict) + `((AND W ,(dict 'reg) + (& ,(make-non-pointer-literal + fixnum-tag + (object-datum (sar-32 (dict 'const) scheme-type-width)))))))) + +;; FIXNUM-NOT. The first (partial) pattern uses the XOR operation to +;; put the tag bits in the low part of the result. This pattern +;; occurs in the hash table hash functions, where the OBJECT->FIXNUM +;; has been shared by CSE. + +(define-lapopt 'FIXNUM-NOT-TAG + `((NOT W (? reg)) + (AND W (? reg) (& #x-40)) + (OR W (? reg) (& ,fixnum-tag)) + (ROR W (? reg) (& ,scheme-type-width))) + #F + (lambda (dict) + (let ((magic-bits (+ (* -1 (expt 2 scheme-type-width)) fixnum-tag))) + `((XOR W ,(dict 'reg) (& ,magic-bits)) + (ROR W ,(dict 'reg) (& ,scheme-type-width)))))) + +(define-lapopt 'FIXNUM-NOT-IN-PLACE + `((SAL W (? reg) (& ,scheme-type-width)) + (NOT W (? reg)) + (AND W (? reg) (& #x-40)) + (OR W (? reg) (& ,fixnum-tag)) + (ROR W (? reg) (& ,scheme-type-width))) + #F + (lambda (dict) + `((XOR W ,(dict 'reg) (& ,(-1+ (expt 2 scheme-datum-width))))))) + +;; CLOSURES +;; +;; This rule recognizes code duplicated at the end of the CONS-CLOSURE +;; and CONS-MULTICLOSURE and the following CONS-POINTER. (This happens +;; because of the hack of storing the entry point as a tagged object +;; in the closure to allow GC to work correctly with relative jumps in +;; the closure code. A better fix would be to alter the GC to make +;; absolute the addresses during closure transport.) +;; +;; The rule relies on the fact the REG-TEMP is a temporary for the +;; expansions of CONS-CLOSURE and CONS-MULTICLOSURE, so it is dead +;; afterwards, and is specific in matching because it is the only code +;; that stores an entry at a negative offset from the free pointer. + +(define-lapopt 'CONS-CLOSURE-FIXUP + `((LEA (? reg-temp) (@RO UW (? regno-closure) #xA0000000)) + (MOV W (@RO B ,regnum:free-pointer -4) (? regno-temp)) + (LEA (? reg-object) (@RO UW (? regno-closure) #xA0000000))) + #F + (lambda (dict) + `((LEA ,(dict 'reg-object) (@RO UW ,(dict 'regno-closure) #xA0000000)) + (MOV W (@RO B ,regnum:free-pointer -4) ,(dict 'reg-object))))) \ No newline at end of file diff --git a/src/compiler/machines/svm/rgspcm.scm b/src/compiler/machines/svm/rgspcm.scm new file mode 100644 index 000000000..246d32a1d --- /dev/null +++ b/src/compiler/machines/svm/rgspcm.scm @@ -0,0 +1,66 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. + +|# + +;;;; RTL Generation: Special primitive combinations. Intel i386 version. +;;; package: (compiler rtl-generator) + +(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 + 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) \ No newline at end of file diff --git a/src/compiler/machines/svm/rules.scm b/src/compiler/machines/svm/rules.scm new file mode 100644 index 000000000..29649db7e --- /dev/null +++ b/src/compiler/machines/svm/rules.scm @@ -0,0 +1,1650 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. + +|# + +;;;; LAP Generation Rules +;;; package: (compiler lap-syntaxer) + +(declare (usual-integrations)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (REGISTER (? source))) + (move-to-alias-register! source (register-type target) target) + (LAP)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (? thunk parse-memory-ref)) + (receive (scale source) (thunk) + (inst:load scale (word-target target) source))) + +(define-rule statement + (ASSIGN (? thunk parse-memory-ref) + (REGISTER (? target))) + (receive (scale target) (thunk) + (inst:store scale (word-source source) target))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (? thunk parse-memory-address)) + (let ((source (thunk))) + (inst:load-address (word-target target) source))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONSTANT (? object))) + (load-constant (word-target target) object)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (MACHINE-CONSTANT (? n))) + (inst:load-immediate (word-target target) n)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (ENTRY:PROCEDURE (? label))) + (inst:load-address (word-target target) + (ea:address (internal->external-label label)))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (ENTRY:CONTINUATION (? label))) + (inst:load-address (word-target target) (ea:address label))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (VARIABLE-CACHE (? name))) + (inst:load 'WORD + (word-target target) + (ea:address (free-reference-label name)))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (ASSIGNMENT-CACHE (? name))) + (inst:load 'WORD + (word-target target) + (ea:address (free-assignment-label name)))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-NON-POINTER (REGISTER (? type)) + (REGISTER (? datum)))) + (let ((type (word-source type)) + (datum (word-source datum))) + (inst:load-non-pointer (word-target target) + type + datum))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) + (REGISTER (? datum)))) + (let ((datum (word-source datum))) + (inst:load-non-pointer (word-target target) + type + datum))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) + (MACHINE-CONSTANT (? datum)))) + (inst:load-non-pointer (word-target target) + type + datum)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (REGISTER (? type)) + (REGISTER (? datum)))) + (let ((type (word-source type)) + (datum (word-source datum))) + (inst:load-pointer (word-target target) + type + datum))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (REGISTER (? datum)))) + (let ((datum (word-source datum))) + (inst:load-pointer (word-target target) + type + datum))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (OBJECT->TYPE (REGISTER (? source)))) + (let ((source (word-source source))) + (inst:object-type (word-target target) + source))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (OBJECT->TYPE (CONSTANT (? object)))) + (inst:load-immediate (word-target target) + (object-type object))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (OBJECT->DATUM (REGISTER (? source)))) + (let ((source (word-source source))) + (inst:object-datum (word-target target) + source))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (OBJECT->DATUM (CONSTANT (? object)))) + (QUALIFIER (and (object-non-pointer? object) + (load-immediate-operand? (object-datum object)))) + (inst:load-immediate (word-target target) + (object-datum object))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (OBJECT->ADDRESS (REGISTER (? source)))) + (let ((source (word-source source))) + (inst:object-address (word-target target) + source))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CHAR->ASCII (REGISTER (? source)))) + (let ((source (word-source source))) + (inst:object-datum (word-target target) + source))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CHAR->ASCII (CONSTANT (? char)))) + (QUALIFIER (and (char? char) (char-ascii? char))) + (inst:load-immediate (word-target target) + (object-datum char))) + +(define-rule predicate + (TYPE-TEST (REGISTER (? source)) (? type)) + (let ((temp (word-temporary))) + (simple-branches! 'EQ (word-source source) temp) + (inst:load-immediate temp type))) + +(define-rule predicate + (EQ-TEST (REGISTER (? source1)) + (REGISTER (? source2))) + (simple-branches! 'EQ + (word-source source1) + (word-source source2)) + (LAP)) + +(define-rule predicate + (PRED-1-ARG INDEX-FIXNUM? + (REGISTER (? source))) + (simple-branches! 'IFIX (word-source source)) + (LAP)) + +;;;; Fixnums + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (OBJECT->FIXNUM (REGISTER (? source)))) + (let ((source (word-source source))) + (inst:fixnum->integer (word-target target) + source))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FIXNUM->OBJECT (REGISTER (? source)))) + (let ((source (word-source source))) + (inst:integer->fixnum (word-target target) + source))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (OBJECT->FIXNUM (CONSTANT (? value)))) + (QUALIFIER (and (fix:fixnum? value) (load-immediate-operand? value))) + (inst:load-immediate (word-target target) + value)) + +;; The next two are no-ops on this architecture. + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (ADDRESS->FIXNUM (REGISTER (? source)))) + (move-to-alias-register! source (register-type target) target) + (LAP)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FIXNUM->ADDRESS (REGISTER (? source)))) + (move-to-alias-register! source (register-type target) target) + (LAP)) + +(define-rule predicate + (FIXNUM-PRED-1-ARG (? predicate) + (REGISTER (? source))) + (simple-branches! (case predicate + ((ZERO-FIXNUM?) 'EQ) + ((NEGATIVE-FIXNUM?) 'LT) + ((POSITIVE-FIXNUM?) 'GT) + (else (error "Unknown fixnum predicate:" predicate))) + (word-source source)) + (LAP)) + +(define-rule predicate + (FIXNUM-PRED-2-ARGS (? predicate) + (REGISTER (? source1)) + (REGISTER (? source2))) + (simple-branches! (case predicate + ((EQUAL-FIXNUM?) 'EQ) + ((LESS-THAN-FIXNUM?) 'SLT) + ((GREATER-THAN-FIXNUM?) 'SGT) + ((UNSIGNED-LESS-THAN-FIXNUM?) 'LT) + ((UNSIGNED-GREATER-THAN-FIXNUM?) 'GT) + (else (error "Unknown fixnum predicate:" predicate))) + (word-source source1) + (word-source source2)) + (LAP)) + +(define-rule predicate + (OVERFLOW-TEST (REGISTER (? source))) + (simple-branches! 'NFIX source) + (LAP)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FIXNUM-1-ARG (? operation) + (REGISTER (? source)) + (? overflow?))) + (let ((source (word-source source))) + ((or (1d-table/get fixnum-1-arg-methods operation #f) + (error "Unknown fixnum operation:" operation)) + (word-target target) + source + overflow?))) + +(define fixnum-1-arg-methods + (make-1d-table)) + +(define (define-fixnum-1-arg-method name method) + (1d-table/put! fixnum-1-arg-methods name method)) + +(let ((standard + (lambda (name inst) + (define-fixnum-1-arg-method name + (lambda (target source overflow?) + overflow? + (inst target source)))))) + (standard 'ONE-PLUS-FIXNUM inst:increment) + (standard 'MINUS-ONE-PLUS-FIXNUM inst:decrement) + (standard 'FIXNUM-NEGATE inst:negate) + (standard 'FIXNUM-NOT inst:not)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FIXNUM-2-ARGS (? operation) + (REGISTER (? source1)) + (REGISTER (? source2)) + (? overflow?))) + (let ((source1 (word-source source1)) + (source2 (word-source source2))) + ((or (1d-table/get fixnum-2-args-methods operation #f) + (error "Unknown fixnum operation:" operation)) + (word-target target) + source1 + source2 + overflow?))) + +(define fixnum-2-args-methods + (make-1d-table)) + +(define (define-fixnum-2-args-method name method) + (1d-table/put! fixnum-2-args-methods name method)) + +(let ((standard + (lambda (name inst) + (define-fixnum-2-args-method name + (lambda (target source1 source2 overflow?) + overflow? + (inst target source1 source2)))))) + (standard 'PLUS-FIXNUM inst:+) + (standard 'MINUS-FIXNUM inst:-) + (standard 'MULTIPLY-FIXNUM inst:*) + (standard 'FIXNUM-QUOTIENT inst:quotient) + (standard 'FIXNUM-REMAINDER inst:remainder) + (standard 'FIXNUM-LSH inst:lsh) + (standard 'FIXNUM-AND inst:and) + (standard 'FIXNUM-ANDC inst:andc) + (standard 'FIXNUM-OR inst:or) + (standard 'FIXNUM-XOR inst:xor)) + +;;;; Flonums + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLOAT->OBJECT (REGISTER (? source)))) + (let ((source (float-source source)) + (temp (word-temporary))) + (LAP ,@(inst:flonum-align rref:free-pointer rref:free-pointer) + ,@(inst:load-pointer (word-target target) + (ucode-type flonum) + rref:free-pointer) + ,@(inst:flonum-header temp 1) + ,@(inst:store 'WORD temp (ea:alloc-word)) + ,@(inst:store 'FLOAT source (ea:alloc-float))))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (OBJECT->FLOAT (REGISTER (? source)))) + (let ((source (word-source source)) + (temp (word-temporary))) + (LAP ,@(inst:object-address temp source) + ,@(inst:load 'FLOAT + (float-target target) + (ea:offset temp 1 'WORD))))) + +(define-rule predicate + (FLONUM-PRED-1-ARG (? predicate) + (REGISTER (? source))) + (simple-branches! (case predicate + ((FLONUM-ZERO?) 'EQ) + ((FLONUM-NEGATIVE?) 'LT) + ((FLONUM-POSITIVE?) 'GT) + (else (error "Unknown flonum predicate:" predicate))) + (float-source source)) + (LAP)) + +(define-rule predicate + (FLONUM-PRED-2-ARGS (? predicate) + (REGISTER (? source1)) + (REGISTER (? source2))) + (simple-branches! (case predicate + ((FLONUM-EQUAL?) 'EQ) + ((FLONUM-LESS?) 'LT) + ((FLONUM-GREATER?) 'GT) + (else (error "Unknown flonum predicate:" predicate))) + (float-source source1) + (float-source source2)) + (LAP)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLONUM-1-ARG (? operation) + (REGISTER (? source)) + (? overflow?))) + (let ((source (word-source source))) + ((or (1d-table/get flonum-1-arg-methods operation #f) + (error "Unknown flonum operation:" operation)) + (word-target target) + source + overflow?))) + +(define flonum-1-arg-methods + (make-1d-table)) + +(define (define-flonum-1-arg-method name method) + (1d-table/put! flonum-1-arg-methods name method)) + +(let ((standard + (lambda (name inst) + (define-flonum-1-arg-method name + (lambda (target source overflow?) + overflow? + (inst target target source)))))) + (standard 'FLONUM-NEGATE inst:negate) + (standard 'FLONUM-ABS inst:abs) + (standard 'FLONUM-SQRT inst:sqrt) + (standard 'FLONUM-ROUND inst:round) + (standard 'FLONUM-CEILING inst:ceiling) + (standard 'FLONUM-FLOOR inst:floor) + (standard 'FLONUM-TRUNCATE inst:truncate) + (standard 'FLONUM-LOG inst:log) + (standard 'FLONUM-EXP inst:exp) + (standard 'FLONUM-COS inst:cos) + (standard 'FLONUM-SIN inst:sin) + (standard 'FLONUM-TAN inst:tan) + (standard 'FLONUM-ACOS inst:acos) + (standard 'FLONUM-ASIN inst:asin) + (standard 'FLONUM-ATAN inst:atan)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLONUM-2-ARGS (? operation) + (REGISTER (? source1)) + (REGISTER (? source2)) + (? overflow?))) + (let ((source1 (word-source source1)) + (source2 (word-source source2))) + ((or (1d-table/get flonum-2-args-methods operation #f) + (error "Unknown flonum operation:" operation)) + (word-target target) + source1 + source2 + overflow?))) + +(define flonum-2-args-methods + (make-1d-table)) + +(define (define-flonum-2-args-method name method) + (1d-table/put! flonum-2-args-methods name method)) + +(let ((standard + (lambda (name inst) + (define-flonum-2-args-method name + (lambda (target source1 source2 overflow?) + overflow? + (inst target source1 source2)))))) + (standard 'FLONUM-ADD inst:+) + (standard 'FLONUM-SUBTRACT inst:-) + (standard 'FLONUM-MULTIPLY inst:*) + (standard 'FLONUM-DIVIDE inst:/) + (standard 'FLONUM-ATAN2 inst:atan2)) + +;;;; Invocations + +(define-rule statement + (POP-RETURN) + ;; The continuation is on the stack. + ;; The type code needs to be cleared first. + (current-bblock-continue! + (let ((pop-return + (lambda () + (let ((temp (word-temporary))) + (LAP ,@(inst:load 'WORD temp (ea:stack-pop)) + ,@(inst:object-address temp temp) + ,@(inst:jump (ea:indirect temp))))))) + (let ((checks (get-exit-interrupt-checks))) + (if (null? checks) + (make-new-sblock (pop-return)) + (memoize-associated-bblock 'POP-RETURN + (lambda () + (make-new-sblock + (let ((label (generate-label 'INTERRUPT))) + (LAP ,@(interrupt-check label checks) + ,@(pop-return) + ,@(inst:label label) + ,@(trap:interrupt-continuation))))))))))) + +(define (memoize-associated-bblock name generator) + (or (block-association name) + (let ((bblock (generator))) + (block-associate! name bblock) + bblock))) + +(define-rule statement + (INVOCATION:APPLY (? frame-size) (? continuation)) + continuation + (expect-no-exit-interrupt-checks) + (LAP ,@(clear-map!) + ,@(inst:load 'WORD rref:word-0 (ea:stack-pop)) + ,@(inst:load-immediate rref:word-1 frame-size) + ,@(trap:apply))) + +(define-rule statement + (INVOCATION:JUMP (? frame-size) (? continuation) (? label)) + frame-size continuation + (expect-no-exit-interrupt-checks) + (LAP ,@(clear-map!) + ,@(inst:jump (ea:address label)))) + +(define-rule statement + (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation)) + frame-size continuation + (expect-no-exit-interrupt-checks) + (LAP ,@(clear-map!) + ,@(inst:load 'WORD rref:word-0 (ea:stack-pop)) + ,@(inst:object-address rref:word-0 rref:word-0) + ,@(inst:jump (ea:indirect rref:word-0)))) + +(define-rule statement + (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label)) + continuation + (expect-no-exit-interrupt-checks) + (LAP ,@(clear-map!) + ,@(inst:load-address rref:word-0 (ea:address label)) + ,@(inst:load-immediate rref:word-1 number-pushed) + ,@(trap:compiler-lexpr-apply))) + +(define-rule statement + (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation)) + continuation + (expect-no-exit-interrupt-checks) + (LAP ,@(clear-map!) + ,@(inst:load 'WORD rref:word-0 (ea:stack-pop)) + ,@(inst:object-address rref:word-0 rref:word-0) + ,@(inst:load-immediate rref:word-1 number-pushed) + ,@(trap:compiler-lexpr-apply))) + +(define-rule statement + (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name)) + continuation + (expect-no-exit-interrupt-checks) + (LAP ,@(clear-map!) + ,@(inst:jump (ea:address (free-uuo-link-label name frame-size))))) + +(define-rule statement + (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name)) + continuation + (expect-no-exit-interrupt-checks) + (LAP ,@(clear-map!) + ,@(inst:jump (ea:address (global-uuo-link-label name frame-size))))) + +(define-rule statement + (INVOCATION:CACHE-REFERENCE (? frame-size) + (? continuation) + (REGISTER (? extension))) + continuation + (expect-no-exit-interrupt-checks) + (let ((set-extension (load-machine-register! extension regnum:word-2))) + (LAP ,@set-extension + ,@(clear-map!) + ,@(inst:load-immediate rref:word-0 frame-size) + ,@(inst:load-address rref:word-2 (ea:address *block-label*)) + ,@(trap:cache-reference-apply)))) + +(define-rule statement + (INVOCATION:LOOKUP (? frame-size) + (? continuation) + (REGISTER (? environment)) + (? name)) + continuation + (expect-no-entry-interrupt-checks) + (let ((set-environment (load-machine-register! environment regnum:word-2))) + (LAP ,@set-environment + ,@(clear-map!) + ,@(inst:load-immediate rref:word-0 frame-size) + ,@(load-constant rref:word-1 name) + ,@(trap:lookup-apply)))) + +(define-rule statement + (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive)) + continuation ; ignored + (LAP ,@(clear-map!) + (if (eq? primitive compiled-error-procedure) + (LAP ,@(inst:load-immediate rref:word-0 frame-size) + ,@(trap:error)) + (LAP ,@(load-constant rref:word-0 primitive) + ,@(let ((arity (primitive-procedure-arity primitive))) + (if (>= arity 0) + (trap:primitive-apply) + (LAP ,@(inst:load-immediate rref:word-1 frame-size) + ,@(if (= arity -1) + (trap:primitive-lexpr-apply) + (trap:apply))))))))) + +(define-syntax define-primitive-invocation + (sc-macro-transformer + (lambda (form environment) + (let ((name (cadr form))) + `(define-rule statement + (INVOCATION:SPECIAL-PRIMITIVE (? frame-size) + (? continuation) + ,(make-primitive-procedure name #t)) + frame-size continuation + (expect-no-exit-interrupt-checks) + (,(close-syntax (symbol-append 'TRAP: name) environment))))))) + +(define-primitive-invocation &+) +(define-primitive-invocation &-) +(define-primitive-invocation &*) +(define-primitive-invocation &/) +(define-primitive-invocation &=) +(define-primitive-invocation &<) +(define-primitive-invocation &>) +(define-primitive-invocation 1+) +(define-primitive-invocation -1+) +(define-primitive-invocation zero?) +(define-primitive-invocation positive?) +(define-primitive-invocation negative?) +(define-primitive-invocation quotient) +(define-primitive-invocation remainder) + +;;; Invocation Prefixes + +(define-rule statement + (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER (? register))) + (move-frame-up frame-size (word-source register))) + +(define-rule statement + (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size) + (REGISTER (? r1)) + (REGISTER (? r2))) + (if (and (= frame-size 0) + (= r1 regnum:stack-pointer)) + (LAP) + (let ((temp (word-temporary))) + (LAP ,@(inst:min-unsigned temp (word-source r1) (word-source r2)) + ,@(move-frame-up frame-size temp))))) + +(define (move-frame-up frame-size register) + (if (= frame-size 0) + (if (= register rref:stack-pointer) + (LAP) + (inst:copy rref:stack-pointer register)) + (let ((temp (word-temporary))) + (LAP ,@(inst:load-address temp + (ea:offset register (- frame-size) 'WORD)) + ,@(inst:copy-block frame-size 'WORD rref:stack-pointer temp) + ,@(inst:copy rref:stack-pointer temp))))) + +;;;; 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 (interrupt-check label checks) + ;; This always does interrupt checks in line. + (LAP ,@(if (or (memq 'INTERRUPT checks) (memq 'HEAP checks)) + (LAP ,@(inst:compare 'WORD + rref:free-pointer + rref:memtop-pointer) + ,@(inst:conditional-jump 'UGE (ea:address label))) + (LAP)) + ,@(if (memq 'STACK checks) + (LAP ,@(inst:compare 'WORD + rref:stack-pointer + rref:stack-guard) + ,@(inst:conditional-jump 'ULT (ea:address label))) + (LAP)))) + +(define (simple-procedure-header label trap) + (let ((checks (get-entry-interrupt-checks))) + (if (null? checks) + label + (let ((gc-label (generate-label))) + (LAP (LABEL ,gc-label) + ,@(trap) + ,@label + ,@(interrupt-check gc-label checks)))))) + +(define-rule statement + (CONTINUATION-ENTRY (? label)) + (expect-no-entry-interrupt-checks) + (make-continuation-label label label)) + +(define-rule statement + (CONTINUATION-HEADER (? label)) + (expect-no-entry-interrupt-checks) + (make-continuation-label label label)) + +(define-rule statement + (IC-PROCEDURE-HEADER (? internal-label)) + (get-entry-interrupt-checks) ; force search + (let ((external-label (internal->external-label internal-label)) + (gc-label (generate-label))) + (LAP (ENTRY-POINT ,external-label) + (EQUATE ,external-label ,internal-label) + (LABEL ,gc-label) + ,@(trap:interrupt-ic-procedure) + ,@(make-expression-label internal-label) + ,@(interrupt-check gc-label)))) + +(define-rule statement + (OPEN-PROCEDURE-HEADER (? internal-label)) + (let ((rtl-proc (label->object internal-label))) + (LAP (EQUATE ,(internal->external-label internal-label) ,internal-label) + ,@(simple-procedure-header + (make-internal-procedure-label internal-label) + (if (rtl-procedure/dynamic-link? rtl-proc) + trap:interrupt-dlink + trap:interrupt-procedure))))) + +(define-rule statement + (PROCEDURE-HEADER (? internal-label) (? min) (? max)) + (LAP (EQUATE ,(internal->external-label internal-label) ,internal-label) + ,@(simple-procedure-header + (make-procedure-label min (- (abs max) min) (< max 0) internal-label) + trap:interrupt-procedure))) + +;; Interrupt check placement +;; +;; The first two procedures are the interface. +;; GET-EXIT-INTERRUPT-CHECKS and GET-ENTRY-INTERRUPT-CHECKS get a list +;; of kinds interrupt check. An empty list implies no check is +;; required. The list can contain these symbols: +;; +;; STACK stack check required here +;; HEAP heap check required here +;; INTERRUPT check required here to avoid loops without checks. +;; +;; The traversal and decision making is done immediately prior to LAP +;; generation (from PRE-LAPGEN-ANALYSIS.) + +(define (get-entry-interrupt-checks) + (get-interrupt-checks 'ENTRY-INTERRUPT-CHECKS)) + +(define (get-exit-interrupt-checks) + (get-interrupt-checks 'EXIT-INTERRUPT-CHECKS)) + +(define (expect-no-entry-interrupt-checks) + (if (not (null? (get-entry-interrupt-checks))) + (error "No entry interrupt checks expected here:" *current-bblock*))) + +(define (expect-no-exit-interrupt-checks) + (if (not (null? (get-exit-interrupt-checks))) + (error "No exit interrupt checks expected here:" *current-bblock*))) + +(define (get-interrupt-checks kind) + (cdr (or (cfg-node-get *current-bblock* kind) + (error "DETERMINE-INTERRUPT-CHECKS failed:" kind)))) + +;; This algorithm finds leaf-procedure-like paths in the rtl control +;; flow graph. If a procedure entry point can only reach a return, it +;; is leaf-like. If a return can only be reached from a procedure +;; entry, it too is leaf-like. +;; +;; If a procedure reaches a procedure call, that could be a loop, so +;; it is not leaf-like. Similarly, if a continuation entry reaches +;; return, that could be a long unwinding of recursion, so a check is +;; needed in case the unwinding does allocation. +;; +;; Typically, true leaf procedures avoid both checks, and trivial +;; cases (like MAP returning '()) avoid the exit check. +;; +;; This could be a lot smarter. For example, a procedure entry does +;; not need to check for interrupts if it reaches call sites of +;; strictly lesser arity; or it could analyze the cycles in the CFG +;; and select good places to break them +;; +;; The algorithm has three phases: (1) explore the CFG to find all +;; entry and exit points, (2) propagate entry (exit) information so +;; that each potential interrupt check point knows what kinds of exits +;; (entrys) it reaches (is reached from), and (3) decide on the kinds +;; of interrupt check that are required at each entry and exit. +;; +;; [TOFU is just a header node for the list of interrupt checks, to +;; distingish () and #F] + +(define (determine-interrupt-checks bblock) + (let ((entries '()) + (exits '())) + + (define (explore bblock) + (or (cfg-node-get bblock 'INTERRUPT-CHECK-EXPLORE) + (begin + (cfg-node-put! bblock 'INTERRUPT-CHECK-EXPLORE #T) + (if (node-previous=0? bblock) + (set! entries (cons bblock entries)) + (if (rtl:continuation-entry? + (rinst-rtl (bblock-instructions bblock))) + ;; previous block is invocation:special-primitive + ;; so it is just an out of line instruction + (cfg-node-put! bblock 'ENTRY-INTERRUPT-CHECKS '(TOFU)))) + + (for-each-previous-node bblock explore) + (for-each-subsequent-node bblock explore) + (if (and (snode? bblock) + (or (not (snode-next bblock)) + (let ((last (last-insn bblock))) + (or (rtl:invocation:special-primitive? last) + (rtl:invocation:primitive? last))))) + (set! exits (cons bblock exits)))))) + + (define (for-each-subsequent-node node procedure) + (if (snode? node) + (if (snode-next node) + (procedure (snode-next node))) + (begin + (procedure (pnode-consequent node)) + (procedure (pnode-alternative node))))) + + (define (propagator for-each-link) + (lambda (node update place) + (let propagate ((node node)) + (let ((old (cfg-node-get node place))) + (let ((new (update old))) + (if (not (equal? old new)) + (begin + (cfg-node-put! node place new) + (for-each-link node propagate)))))))) + + (define upward (propagator for-each-previous-node)) + (define downward (propagator for-each-subsequent-node)) + + (define (setting-flag old) old #T) + + (define (propagate-entry-info bblock) + (let ((insn (rinst-rtl (bblock-instructions bblock)))) + (cond ((or (rtl:continuation-entry? insn) + (rtl:continuation-header? insn)) + (downward bblock setting-flag 'REACHED-FROM-CONTINUATION)) + ((or (rtl:closure-header? insn) + (rtl:ic-procedure-header? insn) + (rtl:open-procedure-header? insn) + (rtl:procedure-header? insn)) + (downward bblock setting-flag 'REACHED-FROM-PROCEDURE)) + (else unspecific)))) + + (define (propagate-exit-info exit-bblock) + (let ((insn (last-insn exit-bblock))) + (cond ((rtl:pop-return? insn) + (upward exit-bblock setting-flag 'REACHES-POP-RETURN)) + (else + (upward exit-bblock setting-flag 'REACHES-INVOCATION))))) + + (define (decide-entry-checks bblock) + (define (checks! types) + (cfg-node-put! bblock 'ENTRY-INTERRUPT-CHECKS (cons 'TOFU types))) + (define (decide-label internal-label) + (let ((object (label->object internal-label))) + (let ((stack? + (if (and (rtl-procedure? object) + (not (rtl-procedure/stack-leaf? object)) + compiler:generate-stack-checks?) + '(STACK) + '()))) + (if (or (cfg-node-get bblock 'REACHES-INVOCATION) + (pair? stack?)) + (checks! (cons* 'HEAP 'INTERRUPT stack?)) + (checks! '()))))) + + (let ((insn (rinst-rtl (bblock-instructions bblock)))) + (cond ((rtl:continuation-entry? insn) (checks! '())) + ((rtl:continuation-header? insn) (checks! '())) + ((rtl:closure-header? insn) + (decide-label (rtl:closure-header-procedure insn))) + ((rtl:ic-procedure-header? insn) + (decide-label (rtl:ic-procedure-header-procedure insn))) + ((rtl:open-procedure-header? insn) + (decide-label (rtl:open-procedure-header-procedure insn))) + ((rtl:procedure-header? insn) + (decide-label (rtl:procedure-header-procedure insn))) + (else + (checks! '(INTERRUPT)))))) + + (define (last-insn bblock) + (rinst-rtl (rinst-last (bblock-instructions bblock)))) + + (define (decide-exit-checks bblock) + (define (checks! types) + (cfg-node-put! bblock 'EXIT-INTERRUPT-CHECKS (cons 'TOFU types))) + (if (rtl:pop-return? (last-insn bblock)) + (if (cfg-node-get bblock 'REACHED-FROM-CONTINUATION) + (checks! '(INTERRUPT)) + (checks! '())) + (checks! '()))) + + (explore bblock) + + (for-each propagate-entry-info entries) + (for-each propagate-exit-info exits) + (for-each decide-entry-checks entries) + (for-each decide-exit-checks exits) + + )) + +;;;; Closures: + +;; Since i386 instructions are pc-relative, the GC can't relocate them unless +;; there is a way to find where the closure was in old space before being +;; transported. The first entry point (tagged as an object) is always +;; the last component of closures with any entry points. + +(define (generate/cons-closure target procedure-label min max size) + (let ((target (word-target target)) + (temp (word-temporary))) + (LAP ,@(inst:load-address + temp + (ea:address `(- ,(internal->external-label procedure-label) 5))) + (MOV W (@R ,regnum:free-pointer) + (&U ,(make-non-pointer-literal (ucode-type manifest-closure) + (+ 4 size)))) + (MOV W (@RO B ,regnum:free-pointer 4) + (&U ,(make-closure-code-longword min max 8))) + (LEA ,target (@RO B ,regnum:free-pointer 8)) + ;; (CALL (@PCR )) + (MOV B (@RO B ,regnum:free-pointer 8) (&U #xe8)) + (SUB W ,temp ,target) + (MOV W (@RO B ,regnum:free-pointer 9) ,temp) ; displacement + (ADD W (R ,regnum:free-pointer) (& ,(* 4 (+ 5 size)))) + (LEA ,temp (@RO UW + ,mtarget + ,(make-non-pointer-literal (ucode-type compiled-entry) + 0))) + (MOV W (@RO B ,regnum:free-pointer -4) ,temp) + ,@(trap:conditionally-serialize)))) + +(define (generate/cons-multiclosure target nentries size entries) + (let ((target (word-target target)) + (temp (word-temporary))) + (with-pc + (lambda (pc-label pc-reg) + (define (generate-entries entries offset) + (let ((entry (car entries)) + (rest (cdr entries))) + (LAP (MOV W (@RO B ,regnum:free-pointer -9) + (&U ,(make-closure-code-longword (cadr entry) + (caddr entry) + offset))) + (MOV B (@RO B ,regnum:free-pointer -5) (&U #xe8)) + (LEA ,temp (@RO W + ,pc-reg + (- ,(internal->external-label (car entry)) + ,pc-label))) + (SUB W ,temp (R ,regnum:free-pointer)) + (MOV W (@RO B ,regnum:free-pointer -4) ,temp) + ,@(if (null? rest) + (LAP) + (LAP (ADD W (R ,regnum:free-pointer) (& 10)) + ,@(generate-entries rest (+ 10 offset))))))) + + (LAP (MOV W (@R ,regnum:free-pointer) + (&U ,(make-non-pointer-literal + (ucode-type manifest-closure) + (+ size (quotient (* 5 (1+ nentries)) 2))))) + (MOV W (@RO B ,regnum:free-pointer 4) + (&U ,(make-closure-longword nentries 0))) + (LEA ,target (@RO B ,regnum:free-pointer 12)) + (ADD W (R ,regnum:free-pointer) (& 17)) + ,@(generate-entries entries 12) + (ADD W (R ,regnum:free-pointer) + (& ,(+ (* 4 size) (if (odd? nentries) 7 5)))) + (LEA ,temp + (@RO UW + ,mtarget + ,(make-non-pointer-literal (ucode-type compiled-entry) + 0))) + (MOV W (@RO B ,regnum:free-pointer -4) ,temp) + ,@(trap:conditionally-serialize)))))) + +(define closure-share-names + '#(closure-0-interrupt closure-1-interrupt closure-2-interrupt + closure-3-interrupt closure-4-interrupt closure-5-interrupt + closure-6-interrupt closure-7-interrupt)) + +(define (generate/closure-header internal-label nentries entry) + nentries ; ignored + (let ((external-label (internal->external-label internal-label)) + (checks (get-entry-interrupt-checks))) + (if (zero? nentries) + (LAP (EQUATE ,external-label ,internal-label) + ,@(simple-procedure-header + (make-internal-procedure-label internal-label) + trap:interrupt-procedure)) + (let* ((prefix + (lambda (gc-label) + (LAP (LABEL ,gc-label) + ,@(if (zero? entry) + (LAP) + (LAP (ADD W (@R ,esp) (& ,(* 10 entry))))) + ,@(trap:interrupt-closure)))) + (label+adjustment + (lambda () + (LAP ,@(make-internal-entry-label external-label) + (ADD W (@R ,esp) + (&U ,(generate/make-magic-closure-constant entry))) + (LABEL ,internal-label)))) + (suffix + (lambda (gc-label) + (LAP ,@(label+adjustment) + ,@(interrupt-check gc-label checks))))) + (if (null? checks) + (LAP ,@(label+adjustment)) + (if (>= entry (vector-length closure-share-names)) + (let ((gc-label (generate-label))) + (LAP ,@(prefix gc-label) + ,@(suffix gc-label))) + (share-instruction-sequence! + (vector-ref closure-share-names entry) + suffix + (lambda (gc-label) + (LAP ,@(prefix gc-label) + ,@(suffix gc-label)))))))))) + +(define (generate/make-magic-closure-constant entry) + (- (make-non-pointer-literal (ucode-type compiled-entry) 0) + (+ (* entry 10) 5))) + +(define (make-closure-longword code-word pc-offset) + (+ code-word (* #x20000 pc-offset))) + +(define (make-closure-code-longword frame/min frame/max pc-offset) + (make-closure-longword (make-procedure-code-word frame/min frame/max) + pc-offset)) + +(define-rule statement + (CLOSURE-HEADER (? internal-label) (? nentries) (? entry)) + (generate/closure-header internal-label nentries entry)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label)) + (? min) (? max) (? size))) + (generate/cons-closure target procedure-label min max size)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-MULTICLOSURE (? nentries) (? size) (? entries))) + (case nentries + ((0) + (let ((target (word-target target))) + (LAP (MOV W ,target (R ,regnum:free-pointer)) + (MOV W (@R ,regnum:free-pointer) + (&U ,(make-non-pointer-literal (ucode-type manifest-vector) + size))) + (ADD W (R ,regnum:free-pointer) (& ,(* 4 (1+ size))))))) + ((1) + (let ((entry (vector-ref entries 0))) + (generate/cons-closure target + (car entry) (cadr entry) (caddr entry) + size))) + (else + (generate/cons-multiclosure target nentries size + (vector->list entries))))) + +;;;; Entry Header +;;; This is invoked by the top level of the LAP generator. + +(define (generate/quotation-header environment-label free-ref-label n-sections) + (let ((t1 (word-temporary)) + (t2 (word-temporary)) + (t3 (word-temporary))) + (LAP ,@(inst:store 'WORD regnum:environment (ea:address environment-label)) + ,@(inst:load-address t1 (ea:address *block-label*)) + ,@(inst:load-address t2 (ea:address free-ref-label)) + ,@(inst:load-immediate t3 n-sections) + ,@(trap:link t1 t2 t3) + ,@(make-internal-continuation-label (generate-label))))) + +(define (generate/remote-link code-block-label + environment-offset + free-ref-offset + n-sections) + (let ((t1 (word-temporary)) + (t2 (word-temporary)) + (t3 (word-temporary))) + (LAP ,@(inst:load-address t1 (ea:address code-block-label)) + ,@(inst:load-address t2 (ea:offset t1 environment-offset 'WORD)) + ,@(inst:store 'WORD regnum:environment (ea:indirect t2)) + ,@(inst:load-address t2 (ea:offset t1 free-ref-offset 'WORD)) + ,@(inst:load-immediate t3 n-sections) + ,@(trap:link t1 t2 t3) + ,@(make-internal-continuation-label (generate-label))))) + +(define (generate/remote-links n-blocks vector-label nsects) + (if (> n-blocks 0) + (let ((loop (generate-label)) + (bytes (generate-label)) + (end (generate-label))) + (LAP ,@(inst:load-immediate regnum:word-0 0) + ,@(inst:store 'WORD regnum:word-0 (ea:stack-push)) + ,@(inst:label loop) + ;; Get index + ,@(inst:load 'WORD regnum:word-0 (ea:stack-ref 0)) + ;; Get vector + ,@(inst:load 'WORD regnum:word-1 (ea:address vector-label)) + ;; Get n-sections for this cc-block + ,@(inst:load-immediate regnum:word-2 0) + ,@(inst:load-address regnum:word-3 (ea:address bytes)) + ,@(inst:load 'BYTE regnum:word-3 + (ea:indexed regnum:word-3 + 1 'BYTE + regnum:word-0 'BYTE)) + ;; address of vector + ,@(object-address regnum:word-1 regnum:word-1) + + + + ;; Store n-sections in arg + (MOV W ,regnum:utility-arg-4 (R ,ebx)) + ;; vector-ref -> cc block + (MOV W (R ,edx) (@ROI B ,edx 4 ,ecx 4)) + ;; address of cc-block + (AND W (R ,edx) (R ,regnum:datum-mask)) + ;; cc-block length + (MOV W (R ,ebx) (@R ,edx)) + ;; Get environment + (MOV W (R ,ecx) ,regnum:environment) + ;; Eliminate length tags + (AND W (R ,ebx) (R ,regnum:datum-mask)) + ;; Store environment + (MOV W (@RI ,edx ,ebx 4) (R ,ecx)) + ;; Get NMV header + (MOV W (R ,ecx) (@RO B ,edx 4)) + ;; Eliminate NMV tag + (AND W (R ,ecx) (R ,regnum:datum-mask)) + ;; Address of first free reference + (LEA (R ,ebx) (@ROI B ,edx 8 ,ecx 4)) + ;; Invoke linker + ,@(trap:link) + ,@(make-internal-continuation-label (generate-label)) + ;; Increment counter and loop + (INC W (@R ,esp)) + (CMP W (@R ,esp) (& ,n-blocks)) + (JL (@PCR ,loop)) + (JMP (@PCR ,end)) + (LABEL ,bytes) + ,@(let walk ((bytes (vector->list nsects))) + (if (null? bytes) + (LAP) + (LAP (BYTE U ,(car bytes)) + ,@(walk (cdr bytes))))) + (LABEL ,end) + ;; Pop counter + (POP (R ,eax)))) + (LAP))) + +(define (generate/constants-block constants references assignments + uuo-links global-links static-vars) + (receive (labels code) + (???3 linkage-type:operator (???4 uuo-links) + linkage-type:reference references + linkage-type:assignment assignments + linkage-type:global-operator (???4 global-links)) + (let ((environment-label (allocate-constant-label))) + (values (LAP ,@code + ,@(???2 (map (lambda (pair) + (cons #f (cdr pair))) + static-vars)) + ,@(???2 constants) + ;; Placeholder for the debugging info filename + (SCHEME-OBJECT ,(allocate-constant-label) DEBUGGING-INFO) + ;; Placeholder for the load time environment if needed + (SCHEME-OBJECT ,environment-label + ,(if (pair? labels) + 'ENVIRONMENT + 0))) + environment-label + (if (pair? labels) (car labels) #f) + (length labels))))) + +(define (???3 . groups) + (let loop ((groups groups)) + (if (pair? groups) + (let ((linkage-type (car groups)) + (entries (cadr groups))) + (if (pair? entries) + (receive (labels code) (loop (cddr groups)) + (receive (label code*) (???1 linkage-type entries) + (values (cons label labels) + (LAP ,@code* ,@code)))) + (loop (cddr groups)))) + (values '() (LAP))))) + +(define (???1 linkage-type entries) + (if (pair? entries) + (let ((label (allocate-constant-label))) + (values label + (LAP (SCHEME-OBJECT + ,label + ,(make-linkage-type-marker linkage-type + (length entries))) + ,@(???2 entries)))) + (values #f (LAP)))) + +(define (???2 entries) + (let loop ((entries entries)) + (if (pair? entries) + (LAP (SCHEME-OBJECT ,(cdar entries) ,(caar entries)) + ,@(loop (cdr entries))) + (LAP)))) + +(define (???4 links) + (append-map (lambda (entry) + (append-map (let ((name (car entry))) + (lambda (p) + (list p + (cons name (allocate-constant-label))))) + (cdr entry))) + links)) + +(define (make-linkage-type-marker linkage-type n-entries) + (let ((type-offset #x10000)) + (if (not (< n-entries type-offset)) + (error "Linkage section too large:" n-entries)) + (+ (* linkage-type type-offset) n-entries))) + +;;;; Variable cache trap handling. + +(define-rule statement + (INTERPRETER-CALL:CACHE-REFERENCE (? cont) (? extension) (? safe?)) + (QUALIFIER (interpreter-call-argument? extension)) + cont ; ignored + (let ((set-extension + (interpreter-call-argument->machine-register! extension edx))) + (LAP ,@set-extension + ,@(clear-map!) + ,@(if safe? + (trap:safe-reference-trap) + (trap:reference-trap))))) + +(define-rule statement + (INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont) (? extension) (? value)) + (QUALIFIER (and (interpreter-call-argument? extension) + (interpreter-call-argument? value))) + cont ; ignored + (let* ((set-extension + (interpreter-call-argument->machine-register! extension edx)) + (set-value (interpreter-call-argument->machine-register! value ebx))) + (LAP ,@set-extension + ,@set-value + ,@(clear-map!) + ,@(trap:assignment-trap)))) + +(define-rule statement + (INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont) (? extension)) + (QUALIFIER (interpreter-call-argument? extension)) + cont ; ignored + (let ((set-extension + (interpreter-call-argument->machine-register! extension edx))) + (LAP ,@set-extension + ,@(clear-map!) + ,@(trap:unassigned?-trap)))) + +;;;; 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) (? name)) + (QUALIFIER (interpreter-call-argument? environment)) + cont ; ignored + (lookup-call trap:access environment name)) + +(define-rule statement + (INTERPRETER-CALL:LOOKUP (? cont) (? environment) (? name) (? safe?)) + (QUALIFIER (interpreter-call-argument? environment)) + cont ; ignored + (lookup-call (if safe? trap:safe-lookup trap:lookup) environment name)) + +(define-rule statement + (INTERPRETER-CALL:UNASSIGNED? (? cont) (? environment) (? name)) + (QUALIFIER (interpreter-call-argument? environment)) + cont ; ignored + (lookup-call trap:unassigned? environment name)) + +(define-rule statement + (INTERPRETER-CALL:UNBOUND? (? cont) (? environment) (? name)) + (QUALIFIER (interpreter-call-argument? environment)) + cont ; ignored + (lookup-call trap:unbound? environment name)) + +(define (lookup-call trap environment name) + (let ((set-environment + (interpreter-call-argument->machine-register! environment edx))) + (LAP ,@set-environment + ,@(clear-map (clear-map!)) + ,@(load-constant regnum:word-1 name) + ,@(trap)))) + +(define-rule statement + (INTERPRETER-CALL:DEFINE (? cont) (? environment) (? name) (? value)) + (QUALIFIER (and (interpreter-call-argument? environment) + (interpreter-call-argument? value))) + cont ; ignored + (assignment-call trap:define environment name value)) + +(define-rule statement + (INTERPRETER-CALL:SET! (? cont) (? environment) (? name) (? value)) + (QUALIFIER (and (interpreter-call-argument? environment) + (interpreter-call-argument? value))) + cont ; ignored + (assignment-call trap:set! environment name value)) + +(define (assignment-call trap environment name value) + (let* ((set-environment + (interpreter-call-argument->machine-register! environment edx)) + (set-value (interpreter-call-argument->machine-register! value eax))) + (LAP ,@set-environment + ,@set-value + ,@(clear-map!) + (MOV W ,regnum:utility-arg-4 (R ,eax)) + ,@(load-constant (INST-EA (R ,ebx)) name) + ,@(trap)))) + +;;;; Synthesized Data + +(define-rule rewriting + (CONS-POINTER (REGISTER (? type register-known-value)) (? datum)) + (QUALIFIER (rtl:machine-constant? type)) + (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 + (object-type (rtl:constant-value (rtl:object->type-expression datum)))) + datum)) + +(define-rule rewriting + (CONS-POINTER (? type) (REGISTER (? datum register-known-value))) + (QUALIFIER (rtl:machine-constant? datum)) + (rtl:make-cons-pointer type datum)) + +(define-rule rewriting + (CONS-POINTER (? type) (REGISTER (? datum register-known-value))) + (QUALIFIER + (and (rtl:object->datum? datum) + (rtl:constant-non-pointer? (rtl:object->datum-expression datum)))) + (rtl:make-cons-pointer + type + (rtl:make-machine-constant + (object-datum (rtl:constant-value (rtl:object->datum-expression datum)))))) + +(define-rule rewriting + (OBJECT->TYPE (REGISTER (? source register-known-value))) + (QUALIFIER (rtl:constant? source)) + (rtl:make-machine-constant (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 (object-datum (rtl:constant-value source)))) + +(define (rtl:constant-non-pointer? expression) + (and (rtl:constant? expression) + (object-non-pointer? (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 + (ASSIGN (? target) (REGISTER (? comparand register-known-value))) + (QUALIFIER (rtl:immediate-zero-constant? comparand)) + (list 'ASSIGN target comparand)) + +(define-rule rewriting + (ASSIGN (OFFSET (REGISTER (? address)) (MACHINE-CONSTANT (? offset))) + (REGISTER (? source register-known-value))) + (QUALIFIER + (and (rtl:byte-offset-address? source) + (rtl:machine-constant? (rtl:byte-offset-address-offset source)) + (let ((base (let ((base (rtl:byte-offset-address-base source))) + (if (rtl:register? base) + (register-known-value (rtl:register-number base)) + base)))) + (and base + (rtl:offset? base) + (let ((base* (rtl:offset-base base)) + (offset* (rtl:offset-offset base))) + (and (rtl:machine-constant? offset*) + (= (rtl:register-number base*) address) + (= (rtl:machine-constant-value offset*) offset))))))) + (let ((target (let ((base (rtl:byte-offset-address-base source))) + (if (rtl:register? base) + (register-known-value (rtl:register-number base)) + base)))) + (list 'ASSIGN + target + (rtl:make-byte-offset-address + target + (rtl:byte-offset-address-offset source))))) + +(define-rule rewriting + (EQ-TEST (? source) (REGISTER (? comparand register-known-value))) + (QUALIFIER (rtl:immediate-zero-constant? comparand)) + (list 'EQ-TEST source comparand)) + +(define-rule rewriting + (EQ-TEST (REGISTER (? comparand register-known-value)) (? source)) + (QUALIFIER (rtl:immediate-zero-constant? comparand)) + (list 'EQ-TEST source comparand)) + +(define (rtl:immediate-zero-constant? expression) + (cond ((rtl:constant? expression) + (let ((value (rtl:constant-value expression))) + (and (object-non-pointer? value) + (zero? (object-type value)) + (zero? (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 #f))) + +;;;; Fixnums + +(define-rule rewriting + (OBJECT->FIXNUM (REGISTER (? source register-known-value))) + (QUALIFIER (rtl:constant-fixnum? source)) + (rtl:make-object->fixnum source)) + +(define-rule rewriting + (FIXNUM-2-ARGS MULTIPLY-FIXNUM + (REGISTER (? operand-1 register-known-value)) + (? operand-2) + (? overflow?)) + (QUALIFIER (rtl:constant-fixnum-test operand-1 (lambda (n) n #t))) + (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 overflow?)) + +(define-rule rewriting + (FIXNUM-2-ARGS MULTIPLY-FIXNUM + (? operand-1) + (REGISTER (? operand-2 register-known-value)) + (? overflow?)) + (QUALIFIER + (and (rtl:constant-fixnum-test operand-2 (lambda (n) n #t)))) + (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 overflow?)) + +(define-rule rewriting + (FIXNUM-2-ARGS (? operator) + (? operand-1) + (REGISTER (? operand-2 register-known-value)) + (? overflow?)) + (QUALIFIER + (and (memq operator '(PLUS-FIXNUM MINUS-FIXNUM)) + (rtl:register? operand-1) + (rtl:constant-fixnum-test operand-2 zero?))) + (rtl:make-fixnum-2-args operator operand-1 operand-2 overflow?)) + +(define-rule rewriting + (FIXNUM-2-ARGS (? operator) + (? operand-1) + (REGISTER (? operand-2 register-known-value)) + (? overflow?)) + (QUALIFIER + (and (memq operator '(FIXNUM-QUOTIENT FIXNUM-REMAINDER)) + (rtl:register? operand-1) + (rtl:constant-fixnum-test operand-2 + (lambda (n) + (integer-power-of-2? (abs n)))))) + (rtl:make-fixnum-2-args operator operand-1 operand-2 overflow?)) + +(define-rule rewriting + (FIXNUM-2-ARGS FIXNUM-LSH + (? operand-1) + (REGISTER (? operand-2 register-known-value)) + #F) + (QUALIFIER (and (rtl:register? operand-1) + (rtl:constant-fixnum-test operand-2 (lambda (n) n #t)))) + (rtl:make-fixnum-2-args 'FIXNUM-LSH operand-1 operand-2 #F)) + +(define (rtl:constant-fixnum? expression) + (and (rtl:constant? expression) + (fix:fixnum? (rtl:constant-value expression)) + (rtl:constant-value expression))) + +(define (rtl:constant-fixnum-test expression predicate) + (and (rtl:object->fixnum? expression) + (let ((expression (rtl:object->fixnum-expression expression))) + (and (rtl:constant? expression) + (let ((n (rtl:constant-value expression))) + (and (fix:fixnum? n) + (predicate n))))))) + +(define-rule rewriting + (OBJECT->FLOAT (REGISTER (? operand register-known-value))) + (QUALIFIER + (rtl:constant-flonum-test operand (lambda (v) v #T))) + (rtl:make-object->float operand)) + +(define-rule rewriting + (FLONUM-2-ARGS FLONUM-SUBTRACT + (REGISTER (? operand-1 register-known-value)) + (? operand-2) + (? overflow?)) + (QUALIFIER (rtl:constant-flonum-test operand-1 flo:zero?)) + (rtl:make-flonum-2-args 'FLONUM-SUBTRACT operand-1 operand-2 overflow?)) + +(define-rule rewriting + (FLONUM-2-ARGS (? operation) + (REGISTER (? operand-1 register-known-value)) + (? operand-2) + (? overflow?)) + (QUALIFIER + (and (memq operation + '(FLONUM-ADD FLONUM-SUBTRACT FLONUM-MULTIPLY FLONUM-DIVIDE)) + (rtl:constant-flonum-test operand-1 flo:one?))) + (rtl:make-flonum-2-args operation operand-1 operand-2 overflow?)) + +(define-rule rewriting + (FLONUM-2-ARGS (? operation) + (? operand-1) + (REGISTER (? operand-2 register-known-value)) + (? overflow?)) + (QUALIFIER + (and (memq operation + '(FLONUM-ADD FLONUM-SUBTRACT FLONUM-MULTIPLY FLONUM-DIVIDE)) + (rtl:constant-flonum-test operand-2 flo:one?))) + (rtl:make-flonum-2-args operation operand-1 operand-2 overflow?)) + +(define-rule rewriting + (FLONUM-PRED-2-ARGS (? predicate) + (? operand-1) + (REGISTER (? operand-2 register-known-value))) + (QUALIFIER (rtl:constant-flonum-test operand-2 flo:zero?)) + (list 'FLONUM-PRED-2-ARGS predicate operand-1 operand-2)) + +(define-rule rewriting + (FLONUM-PRED-2-ARGS (? predicate) + (REGISTER (? operand-1 register-known-value)) + (? operand-2)) + (QUALIFIER (rtl:constant-flonum-test operand-1 flo:zero?)) + (list 'FLONUM-PRED-2-ARGS predicate operand-1 operand-2)) + +#| +;; These don't work as written. They are not simplified and are +;; therefore passed whole to the back end, and there is no way to +;; construct the graph at this level. + +;; acos (x) = atan ((sqrt (1 - x^2)) / x) + +(define-rule pre-cse-rewriting + (FLONUM-1-ARG FLONUM-ACOS (? operand) #f) + (rtl:make-flonum-2-args + 'FLONUM-ATAN2 + (rtl:make-flonum-1-arg + 'FLONUM-SQRT + (rtl:make-flonum-2-args + 'FLONUM-SUBTRACT + (rtl:make-object->float (rtl:make-constant 1.)) + (rtl:make-flonum-2-args 'FLONUM-MULTIPLY operand operand #f) + #f) + #f) + operand + #f)) + +;; asin (x) = atan (x / (sqrt (1 - x^2))) + +(define-rule pre-cse-rewriting + (FLONUM-1-ARG FLONUM-ASIN (? operand) #f) + (rtl:make-flonum-2-args + 'FLONUM-ATAN2 + operand + (rtl:make-flonum-1-arg + 'FLONUM-SQRT + (rtl:make-flonum-2-args + 'FLONUM-SUBTRACT + (rtl:make-object->float (rtl:make-constant 1.)) + (rtl:make-flonum-2-args 'FLONUM-MULTIPLY operand operand #f) + #f) + #f) + #f)) + +|# + +(define (rtl:constant-flonum-test expression predicate) + (and (rtl:object->float? expression) + (let ((expression (rtl:object->float-expression expression))) + (and (rtl:constant? expression) + (let ((n (rtl:constant-value expression))) + (and (flo:flonum? n) + (predicate n))))))) + +(define (flo:one? value) + (flo:= value 1.)) + +;;;; Indexed addressing modes + +(define-rule rewriting + (OFFSET (REGISTER (? base register-known-value)) + (MACHINE-CONSTANT (? value))) + (QUALIFIER (and (rtl:offset-address? base) + (rtl:simple-subexpressions? base))) + (if (= value 0) + (rtl:make-offset (rtl:offset-address-base base) + (rtl:offset-address-offset base)) + (rtl:make-offset base (rtl:make-machine-constant value)))) + +(define-rule rewriting + (BYTE-OFFSET (REGISTER (? base register-known-value)) + (MACHINE-CONSTANT (? value))) + (QUALIFIER (and (rtl:byte-offset-address? base) + (rtl:simple-subexpressions? base))) + (if (= value 0) + (rtl:make-byte-offset (rtl:byte-offset-address-base base) + (rtl:byte-offset-address-offset base)) + (rtl:make-byte-offset base (rtl:make-machine-constant value)))) + +(define-rule rewriting + (FLOAT-OFFSET (REGISTER (? base register-known-value)) + (MACHINE-CONSTANT (? value))) + (QUALIFIER (and (rtl:float-offset-address? base) + (rtl:simple-subexpressions? base))) + (if (= value 0) + (rtl:make-float-offset (rtl:float-offset-address-base base) + (rtl:float-offset-address-offset base)) + (rtl:make-float-offset base (rtl:make-machine-constant value)))) + +;; This is here to avoid generating things like +;; +;; (offset (offset-address (object->address (constant #(foo bar baz gack))) +;; (register 29)) +;; (machine-constant 1)) +;; +;; since the offset-address subexpression is constant, and therefore +;; known! + +(define (rtl:simple-subexpressions? expr) + (for-all? (cdr expr) + (lambda (sub) + (or (rtl:machine-constant? sub) + (rtl:register? sub))))) \ No newline at end of file -- 2.25.1