--- /dev/null
+#| -*-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))
+\f
+(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))
+\f
+;; 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)))))))))))
+\f
+;; 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))))))
+\f
+;; 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))))))))
+\f
+;; 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))))))))
+\f
+;; 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
--- /dev/null
+#| -*-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))
+\f
+(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))))
+\f
+(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)))
+\f
+(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))
+\f
+;;;; 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))
+\f
+(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))
+\f
+;;;; 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))
+\f
+(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))
+\f
+;;;; 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)
+\f
+;;; 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)))))
+\f
+;;;; 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)))
+\f
+;; 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)
+
+ ))
+\f
+;;;; 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 <entry>))
+ (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))))))
+\f
+(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))
+\f
+(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)))))
+\f
+;;;; 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)))
+\f
+(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)))
+\f
+;;;; 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))))
+\f
+;;;; 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))))
+\f
+(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))))
+\f
+;;;; 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))))
+\f
+;;; 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)))
+\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)))))))
+\f
+(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))
+\f
+#|
+;; 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.))
+\f
+;;;; 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
projects / mit-scheme.git / commitdiff