--- /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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Assembler Machine Dependencies. Intel 386 version
+
+(declare (usual-integrations))
+\f
+(let-syntax
+ ((ucode-type
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (apply microcode-type (cdr form))))))
+
+(define-integrable maximum-padding-length
+ ;; Instructions can be any number of bytes long.
+ ;; Thus the maximum padding is 3 bytes.
+ 24)
+
+(define-integrable padding-string
+ ;; Pad with HLT instructions
+ (unsigned-integer->bit-string 8 #xf4))
+
+(define-integrable block-offset-width
+ ;; Block offsets are encoded words
+ 16)
+
+(define maximum-block-offset
+ (- (expt 2 (-1+ block-offset-width)) 1))
+
+(define-integrable (block-offset->bit-string offset start?)
+ (unsigned-integer->bit-string block-offset-width
+ (+ (* 2 offset)
+ (if start? 0 1))))
+
+
+(define-integrable nmv-type-string
+ (unsigned-integer->bit-string scheme-type-width
+ (ucode-type manifest-nm-vector)))
+
+(define (make-nmv-header n)
+ (bit-string-append (unsigned-integer->bit-string scheme-datum-width n)
+ nmv-type-string))
+
+;;; Machine dependent instruction order
+
+(define (instruction-insert! bits block position receiver)
+ (let ((l (bit-string-length bits)))
+ (bit-substring-move-right! bits 0 l block position)
+ (receiver (+ position l))))
+
+(define-integrable (instruction-initial-position block)
+ block ; ignored
+ 0)
+
+(define-integrable instruction-append bit-string-append)
+
+;;; end let-syntax
+)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$MC68020-Header: coerce.scm,v 1.10 88/08/31 05:56:37 GMT cph Exp $
+
+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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Intel i386 Specific Coercions
+
+(declare (usual-integrations))
+\f
+;; *** NOTE ***
+;; If you add coercions here, remember to also add them in "insmac.scm".
+
+(define make-coercion
+ (coercion-maker
+ `((UNSIGNED . ,coerce-unsigned-integer)
+ (SIGNED . ,coerce-signed-integer))))
+
+(define coerce-2-bit-unsigned (make-coercion 'UNSIGNED 2))
+(define coerce-3-bit-unsigned (make-coercion 'UNSIGNED 3))
+(define coerce-8-bit-unsigned (make-coercion 'UNSIGNED 8))
+(define coerce-16-bit-unsigned (make-coercion 'UNSIGNED 16))
+(define coerce-32-bit-unsigned (make-coercion 'UNSIGNED 32))
+
+(define coerce-8-bit-signed (make-coercion 'SIGNED 8))
+(define coerce-16-bit-signed (make-coercion 'SIGNED 16))
+(define coerce-32-bit-signed (make-coercion 'SIGNED 32))
\ 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Script to incrementally compile the compiler (from .bins)
+
+(fluid-let ((compiler:coalescing-constant-warnings? #f))
+ (for-each compile-directory
+ '("back"
+ "base"
+ "fggen"
+ "fgopt"
+ "machines/i386"
+ "rtlbase"
+ "rtlgen"
+ "rtlopt")))
\ 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Compiler Packaging
+\f
+(global-definitions "../runtime/runtime")
+(global-definitions "../sf/sf")
+
+(define-package (compiler)
+ (files "base/switch"
+ "base/object" ;tagged object support
+ "base/enumer" ;enumerations
+ "base/sets" ;set abstraction
+ "base/mvalue" ;multiple-value support
+ "base/scode" ;SCode abstraction
+ "machines/i386/machin" ;machine dependent stuff
+ "back/asutl" ;back-end odds and ends
+ "base/utils" ;odds and ends
+
+ "base/cfg1" ;control flow graph
+ "base/cfg2"
+ "base/cfg3"
+
+ "base/ctypes" ;CFG datatypes
+
+ "base/rvalue" ;Right hand values
+ "base/lvalue" ;Left hand values
+ "base/blocks" ;rvalue: blocks
+ "base/proced" ;rvalue: procedures
+ "base/contin" ;rvalue: continuations
+
+ "base/subprb" ;subproblem datatype
+
+ "rtlbase/rgraph" ;program graph abstraction
+ "rtlbase/rtlty1" ;RTL: type definitions
+ "rtlbase/rtlty2" ;RTL: type definitions
+ "rtlbase/rtlexp" ;RTL: expression operations
+ "rtlbase/rtlcon" ;RTL: complex constructors
+ "rtlbase/rtlreg" ;RTL: registers
+ "rtlbase/rtlcfg" ;RTL: CFG types
+ "rtlbase/rtlobj" ;RTL: CFG objects
+ "rtlbase/regset" ;RTL: register sets
+ "rtlbase/valclass" ;RTL: value classes
+
+ "back/insseq" ;LAP instruction sequences
+ )
+ (parent ())
+ (export ()
+ compiler:analyze-side-effects?
+ compiler:cache-free-variables?
+ compiler:coalescing-constant-warnings?
+ compiler:code-compression?
+ compiler:compile-by-procedures?
+ compiler:cross-compiling?
+ compiler:cse?
+ compiler:default-top-level-declarations
+ compiler:enable-integration-declarations?
+ compiler:generate-lap-files?
+ compiler:generate-range-checks?
+ compiler:generate-rtl-files?
+ compiler:generate-stack-checks?
+ compiler:generate-type-checks?
+ compiler:implicit-self-static?
+ compiler:intersperse-rtl-in-lap?
+ compiler:noisy?
+ compiler:open-code-floating-point-arithmetic?
+ compiler:open-code-flonum-checks?
+ compiler:open-code-primitives?
+ compiler:optimize-environments?
+ compiler:package-optimization-level
+ compiler:preserve-data-structures?
+ compiler:show-phases?
+ compiler:show-procedures?
+ compiler:show-subphases?
+ compiler:show-time-reports?
+ compiler:use-multiclosures?)
+ (import (runtime system-macros)
+ ucode-primitive
+ ucode-type)
+ (import ()
+ (scode/access-components access-components)
+ (scode/access-environment access-environment)
+ (scode/access-name access-name)
+ (scode/access? access?)
+ (scode/assignment-components assignment-components)
+ (scode/assignment-name assignment-name)
+ (scode/assignment-value assignment-value)
+ (scode/assignment? assignment?)
+ (scode/combination-components combination-components)
+ (scode/combination-operands combination-operands)
+ (scode/combination-operator combination-operator)
+ (scode/combination? combination?)
+ (scode/comment-components comment-components)
+ (scode/comment-expression comment-expression)
+ (scode/comment-text comment-text)
+ (scode/comment? comment?)
+ (scode/conditional-alternative conditional-alternative)
+ (scode/conditional-components conditional-components)
+ (scode/conditional-consequent conditional-consequent)
+ (scode/conditional-predicate conditional-predicate)
+ (scode/conditional? conditional?)
+ (scode/constant? scode-constant?)
+ (scode/declaration-components declaration-components)
+ (scode/declaration-expression declaration-expression)
+ (scode/declaration-text declaration-text)
+ (scode/declaration? declaration?)
+ (scode/definition-components definition-components)
+ (scode/definition-name definition-name)
+ (scode/definition-value definition-value)
+ (scode/definition? definition?)
+ (scode/delay-components delay-components)
+ (scode/delay-expression delay-expression)
+ (scode/delay? delay?)
+ (scode/disjunction-alternative disjunction-alternative)
+ (scode/disjunction-components disjunction-components)
+ (scode/disjunction-predicate disjunction-predicate)
+ (scode/disjunction? disjunction?)
+ (scode/lambda-components lambda-components)
+ (scode/lambda? lambda?)
+ (scode/make-access make-access)
+ (scode/make-assignment make-assignment)
+ (scode/make-combination make-combination)
+ (scode/make-comment make-comment)
+ (scode/make-conditional make-conditional)
+ (scode/make-declaration make-declaration)
+ (scode/make-definition make-definition)
+ (scode/make-delay make-delay)
+ (scode/make-disjunction make-disjunction)
+ (scode/make-lambda make-lambda)
+ (scode/make-open-block make-open-block)
+ (scode/make-quotation make-quotation)
+ (scode/make-sequence make-sequence)
+ (scode/make-the-environment make-the-environment)
+ (scode/make-unassigned? make-unassigned?)
+ (scode/make-variable make-variable)
+ (scode/open-block-components open-block-components)
+ (scode/open-block? open-block?)
+ (scode/primitive-procedure? primitive-procedure?)
+ (scode/procedure? procedure?)
+ (scode/quotation-expression quotation-expression)
+ (scode/quotation? quotation?)
+ (scode/sequence-actions sequence-actions)
+ (scode/sequence-components sequence-components)
+ (scode/sequence? sequence?)
+ (scode/symbol? symbol?)
+ (scode/the-environment? the-environment?)
+ (scode/unassigned?-name unassigned?-name)
+ (scode/unassigned?? unassigned??)
+ (scode/variable-components variable-components)
+ (scode/variable-name variable-name)
+ (scode/variable? variable?)))
+\f
+(define-package (compiler reference-contexts)
+ (files "base/refctx")
+ (parent (compiler))
+ (export (compiler)
+ add-reference-context/adjacent-parents!
+ initialize-reference-contexts!
+ make-reference-context
+ modify-reference-contexts!
+ reference-context/adjacent-parent?
+ reference-context/block
+ reference-context/offset
+ reference-context/procedure
+ reference-context?
+ set-reference-context/offset!))
+
+(define-package (compiler macros)
+ (files "base/macros")
+ (parent (compiler))
+ (export (compiler)
+ cfg-node-case
+ define-enumeration
+ define-export
+ define-lvalue
+ define-pnode
+ define-root-type
+ define-rtl-expression
+ define-rtl-predicate
+ define-rtl-statement
+ define-rule
+ define-rvalue
+ define-snode
+ define-vector-slots
+ descriptor-list
+ enumeration-case
+ inst-ea
+ lap
+ last-reference
+ make-lvalue
+ make-pnode
+ make-rvalue
+ make-snode
+ package
+ rule-matcher))
+
+(define-package (compiler declarations)
+ (files "machines/i386/decls")
+ (parent (compiler))
+ (export (compiler)
+ sc
+ syntax-files!)
+ (import (scode-optimizer top-level)
+ sf/internal)
+ (initialization (initialize-package!)))
+
+(define-package (compiler top-level)
+ (files "base/toplev"
+ "base/crstop"
+ "base/asstop")
+ (parent (compiler))
+ (export ()
+ cbf
+ cf
+ compile-bin-file
+ compile-file
+ compile-file:force?
+ compile-file:override-usual-integrations
+ compile-file:sf-only?
+ compile-procedure
+ compile-scode
+ compiler:compiled-code-pathname-type
+ compiler:reset!
+ lap->code)
+ (export (compiler)
+ canonicalize-label-name)
+ (export (compiler fg-generator)
+ compile-recursively)
+ (export (compiler rtl-generator)
+ *ic-procedure-headers*
+ *rtl-continuations*
+ *rtl-expression*
+ *rtl-graphs*
+ *rtl-procedures*)
+ (export (compiler lap-syntaxer)
+ *block-label*
+ *external-labels*
+ label->object)
+ (export (compiler debug)
+ *root-expression*
+ *rtl-procedures*
+ *rtl-graphs*)
+ (import (runtime compiler-info)
+ make-dbg-info-vector
+ split-inf-structure!)
+ (import (runtime unparser)
+ *unparse-uninterned-symbols-by-name?*))
+\f
+(define-package (compiler debug)
+ (files "base/debug")
+ (parent (compiler))
+ (export ()
+ debug/find-continuation
+ debug/find-entry-node
+ debug/find-procedure
+ debug/where
+ dump-rtl
+ po
+ show-bblock-rtl
+ show-fg
+ show-fg-node
+ show-rtl
+ write-rtl-instructions)
+ (import (runtime pretty-printer)
+ *pp-primitives-by-name*)
+ (import (runtime unparser)
+ *unparse-uninterned-symbols-by-name?*))
+
+(define-package (compiler pattern-matcher/lookup)
+ (files "base/pmlook")
+ (parent (compiler))
+ (export (compiler)
+ make-pattern-variable
+ pattern-lookup
+ pattern-lookup-1
+ pattern-variable-name
+ pattern-variable?
+ pattern-variables))
+
+(define-package (compiler pattern-matcher/parser)
+ (files "base/pmpars")
+ (parent (compiler))
+ (export (compiler)
+ make-rule-matcher
+ parse-rule
+ rule->matcher
+ rule-result-expression)
+ (export (compiler macros)
+ make-rule-matcher
+ parse-rule
+ rule->matcher
+ rule-result-expression))
+
+(define-package (compiler pattern-matcher/early)
+ (files "base/pmerly")
+ (parent (compiler))
+ (export (compiler)
+ early-parse-rule
+ early-pattern-lookup
+ early-make-rule
+ make-database-transformer
+ make-symbol-transformer
+ make-bit-mask-transformer))
+\f
+(define-package (compiler debugging-information)
+ (files "base/infnew")
+ (parent (compiler))
+ (export (compiler top-level)
+ info-generation-phase-1
+ info-generation-phase-2
+ info-generation-phase-3)
+ (export (compiler rtl-generator)
+ generated-dbg-continuation)
+ (import (runtime compiler-info)
+ make-dbg-info
+
+ make-dbg-expression
+ dbg-expression/block
+ dbg-expression/label
+ set-dbg-expression/label!
+
+ make-dbg-procedure
+ dbg-procedure/block
+ dbg-procedure/label
+ set-dbg-procedure/label!
+ dbg-procedure/name
+ dbg-procedure/required
+ dbg-procedure/optional
+ dbg-procedure/rest
+ dbg-procedure/auxiliary
+ dbg-procedure/external-label
+ set-dbg-procedure/external-label!
+ dbg-procedure<?
+
+ make-dbg-continuation
+ dbg-continuation/block
+ dbg-continuation/label
+ set-dbg-continuation/label!
+ dbg-continuation<?
+
+ make-dbg-block
+ dbg-block/parent
+ dbg-block/layout
+ dbg-block/stack-link
+ set-dbg-block/procedure!
+
+ make-dbg-variable
+ dbg-variable/value
+ set-dbg-variable/value!
+
+ dbg-block-name/dynamic-link
+ dbg-block-name/ic-parent
+ dbg-block-name/normal-closure
+ dbg-block-name/return-address
+ dbg-block-name/static-link
+
+ make-dbg-label-2
+ dbg-label/offset
+ set-dbg-label/external?!))
+
+(define-package (compiler constraints)
+ (files "base/constr")
+ (parent (compiler))
+ (export (compiler)
+ make-constraint
+ constraint/element
+ constraint/graph-head
+ constraint/afters
+ constraint/closed?
+ constraint-add!
+ add-constraint-element!
+ add-constraint-set!
+ make-constraint-graph
+ constraint-graph/entry-nodes
+ constraint-graph/closed?
+ close-constraint-graph!
+ close-constraint-node!
+ order-per-constraints
+ order-per-constraints/extracted
+ legal-ordering-per-constraints?
+ with-new-constraint-marks
+ constraint-marked?
+ constraint-mark!
+ transitively-close-dag!
+ reverse-postorder))
+\f
+(define-package (compiler fg-generator)
+ (files "fggen/canon" ;SCode canonicalizer
+ "fggen/fggen" ;SCode->flow-graph converter
+ "fggen/declar" ;Declaration handling
+ )
+ (parent (compiler))
+ (export (compiler top-level)
+ canonicalize/top-level
+ construct-graph)
+ (import (runtime scode-data)
+ &pair-car
+ &pair-cdr
+ &triple-first
+ &triple-second
+ &triple-third))
+
+(define-package (compiler fg-optimizer)
+ (files "fgopt/outer" ;outer analysis
+ "fgopt/sideff" ;side effect analysis
+ )
+ (parent (compiler))
+ (export (compiler top-level)
+ clear-call-graph!
+ compute-call-graph!
+ outer-analysis
+ side-effect-analysis))
+
+(define-package (compiler fg-optimizer fold-constants)
+ (files "fgopt/folcon")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) fold-constants))
+
+(define-package (compiler fg-optimizer operator-analysis)
+ (files "fgopt/operan")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) operator-analysis))
+
+(define-package (compiler fg-optimizer variable-indirection)
+ (files "fgopt/varind")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) initialize-variable-indirections!))
+
+(define-package (compiler fg-optimizer environment-optimization)
+ (files "fgopt/envopt")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) optimize-environments!))
+
+(define-package (compiler fg-optimizer closure-analysis)
+ (files "fgopt/closan")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) identify-closure-limits!))
+
+(define-package (compiler fg-optimizer continuation-analysis)
+ (files "fgopt/contan")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level)
+ continuation-analysis
+ setup-block-static-links!))
+
+(define-package (compiler fg-optimizer compute-node-offsets)
+ (files "fgopt/offset")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) compute-node-offsets))
+\f
+(define-package (compiler fg-optimizer connectivity-analysis)
+ (files "fgopt/conect")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) connectivity-analysis))
+
+(define-package (compiler fg-optimizer delete-integrated-parameters)
+ (files "fgopt/delint")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) delete-integrated-parameters))
+
+(define-package (compiler fg-optimizer design-environment-frames)
+ (files "fgopt/desenv")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) design-environment-frames!))
+
+(define-package (compiler fg-optimizer setup-block-types)
+ (files "fgopt/blktyp")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level)
+ setup-block-types!
+ setup-closure-contexts!)
+ (export (compiler)
+ indirection-block-procedure))
+
+(define-package (compiler fg-optimizer simplicity-analysis)
+ (files "fgopt/simple")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) simplicity-analysis)
+ (export (compiler fg-optimizer subproblem-ordering)
+ new-subproblem/compute-simplicity!))
+
+(define-package (compiler fg-optimizer simulate-application)
+ (files "fgopt/simapp")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) simulate-application))
+
+(define-package (compiler fg-optimizer subproblem-free-variables)
+ (files "fgopt/subfre")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) compute-subproblem-free-variables)
+ (export (compiler fg-optimizer) map-union)
+ (export (compiler fg-optimizer subproblem-ordering)
+ new-subproblem/compute-free-variables!))
+
+(define-package (compiler fg-optimizer subproblem-ordering)
+ (files "fgopt/order")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) subproblem-ordering))
+
+(define-package (compiler fg-optimizer subproblem-ordering reuse-frames)
+ (files "fgopt/reord" "fgopt/reuse")
+ (parent (compiler fg-optimizer subproblem-ordering))
+ (export (compiler top-level) setup-frame-adjustments)
+ (export (compiler fg-optimizer subproblem-ordering)
+ order-subproblems/maybe-overwrite-block))
+
+(define-package (compiler fg-optimizer subproblem-ordering parameter-analysis)
+ (files "fgopt/param")
+ (parent (compiler fg-optimizer subproblem-ordering))
+ (export (compiler fg-optimizer subproblem-ordering)
+ parameter-analysis))
+
+(define-package (compiler fg-optimizer return-equivalencing)
+ (files "fgopt/reteqv")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) find-equivalent-returns!))
+\f
+(define-package (compiler rtl-generator)
+ (files "rtlgen/rtlgen" ;RTL generator
+ "rtlgen/rgstmt" ;statements
+ "rtlgen/fndvar" ;find variables
+ "machines/i386/rgspcm" ;special close-coded primitives
+ "rtlbase/rtline" ;linearizer
+ )
+ (parent (compiler))
+ (export (compiler)
+ make-linearizer)
+ (export (compiler top-level)
+ generate/top-level
+ linearize-rtl
+ setup-bblock-continuations!)
+ (export (compiler debug)
+ linearize-rtl)
+ (import (compiler top-level)
+ label->object))
+
+(define-package (compiler rtl-generator generate/procedure-header)
+ (files "rtlgen/rgproc")
+ (parent (compiler rtl-generator))
+ (export (compiler rtl-generator) generate/procedure-header))
+
+(define-package (compiler rtl-generator combination/inline)
+ (files "rtlgen/opncod")
+ (parent (compiler rtl-generator))
+ (export (compiler rtl-generator) combination/inline)
+ (export (compiler top-level) open-coding-analysis))
+
+(define-package (compiler rtl-generator find-block)
+ (files "rtlgen/fndblk")
+ (parent (compiler rtl-generator))
+ (export (compiler rtl-generator) find-block))
+
+(define-package (compiler rtl-generator generate/rvalue)
+ (files "rtlgen/rgrval")
+ (parent (compiler rtl-generator))
+ (export (compiler rtl-generator)
+ generate/rvalue
+ load-closure-environment
+ make-cons-closure-indirection
+ make-cons-closure-redirection
+ make-closure-redirection
+ make-ic-cons
+ make-non-trivial-closure-cons
+ make-trivial-closure-cons
+ redirect-closure))
+
+(define-package (compiler rtl-generator generate/combination)
+ (files "rtlgen/rgcomb")
+ (parent (compiler rtl-generator))
+ (export (compiler rtl-generator)
+ generate/combination
+ rtl:bump-closure)
+ (export (compiler rtl-generator combination/inline)
+ generate/invocation-prefix))
+
+(define-package (compiler rtl-generator generate/return)
+ (files "rtlgen/rgretn")
+ (parent (compiler rtl-generator))
+ (export (compiler rtl-generator)
+ make-return-operand
+ generate/return
+ generate/return*
+ generate/trivial-return))
+\f
+(define-package (compiler rtl-cse)
+ (files "rtlopt/rcse1" ;RTL common subexpression eliminator
+ "rtlopt/rcse2"
+ "rtlopt/rcseep" ;CSE expression predicates
+ "rtlopt/rcseht" ;CSE hash table
+ "rtlopt/rcserq" ;CSE register/quantity abstractions
+ "rtlopt/rcsesr" ;CSE stack references
+ )
+ (parent (compiler))
+ (export (compiler top-level) common-subexpression-elimination))
+
+(define-package (compiler rtl-optimizer)
+ (files "rtlopt/rdebug")
+ (parent (compiler)))
+
+(define-package (compiler rtl-optimizer invertible-expression-elimination)
+ (files "rtlopt/rinvex")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) invertible-expression-elimination))
+
+(define-package (compiler rtl-optimizer common-suffix-merging)
+ (files "rtlopt/rtlcsm")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) merge-common-suffixes!))
+
+(define-package (compiler rtl-optimizer rtl-dataflow-analysis)
+ (files "rtlopt/rdflow")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) rtl-dataflow-analysis))
+
+(define-package (compiler rtl-optimizer rtl-rewriting)
+ (files "rtlopt/rerite")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level)
+ rtl-rewriting:post-cse
+ rtl-rewriting:pre-cse)
+ (export (compiler lap-syntaxer)
+ add-rewriting-rule!
+ add-pre-cse-rewriting-rule!))
+
+(define-package (compiler rtl-optimizer lifetime-analysis)
+ (files "rtlopt/rlife")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) lifetime-analysis)
+ (export (compiler rtl-optimizer code-compression) mark-set-registers!))
+
+(define-package (compiler rtl-optimizer code-compression)
+ (files "rtlopt/rcompr")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) code-compression))
+
+(define-package (compiler rtl-optimizer register-allocation)
+ (files "rtlopt/ralloc")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) register-allocation))
+\f
+(define-package (compiler lap-syntaxer)
+ (files "back/lapgn1" ;LAP generator
+ "back/lapgn2" ; " "
+ "back/lapgn3" ; " "
+ "back/regmap" ;Hardware register allocator
+ "machines/i386/lapgen" ;code generation rules
+ "machines/i386/rules1" ; " " "
+ "machines/i386/rules2" ; " " "
+ "machines/i386/rules3" ; " " "
+ "machines/i386/rules4" ; " " "
+ "machines/i386/rulfix" ; " " "
+ "machines/i386/rulflo" ; " " "
+ "machines/i386/rulrew" ;code rewriting rules
+ "back/syntax" ;Generic syntax phase
+ "back/syerly" ;Early binding version
+ "machines/i386/coerce" ;Coercions: integer -> bit string
+ "back/asmmac" ;Macros for hairy syntax
+ "machines/i386/insmac" ;Macros for hairy syntax
+ "machines/i386/insutl" ;i386 instruction utilities
+ "machines/i386/instr1" ;i386 instructions
+ "machines/i386/instr2" ; " "
+ "machines/i386/instrf" ;i387/i486 fp instructions
+ )
+ (parent (compiler))
+ (export (compiler)
+ available-machine-registers
+ lap-generator/match-rtl-instruction
+ lap:make-entry-point
+ lap:make-label-statement
+ lap:make-unconditional-branch
+ lap:syntax-instruction)
+ (export (compiler top-level)
+ *block-associations*
+ *interned-assignments*
+ *interned-constants*
+ *interned-global-links*
+ *interned-uuo-links*
+ *interned-static-variables*
+ *interned-variables*
+ *next-constant*
+ generate-lap)
+ (import (scode-optimizer expansion)
+ scode->scode-expander))
+
+(define-package (compiler lap-syntaxer map-merger)
+ (files "back/mermap")
+ (parent (compiler lap-syntaxer))
+ (export (compiler lap-syntaxer)
+ merge-register-maps))
+
+(define-package (compiler lap-syntaxer linearizer)
+ (files "back/linear")
+ (parent (compiler lap-syntaxer))
+ (export (compiler lap-syntaxer)
+ add-end-of-block-code!
+ add-extra-code!
+ bblock-linearize-lap
+ extra-code-block/xtra
+ declare-extra-code-block!
+ find-extra-code-block
+ linearize-lap
+ set-current-branches!
+ set-extra-code-block/xtra!)
+ (export (compiler top-level)
+ *end-of-block-code*
+ linearize-lap))
+
+(define-package (compiler lap-optimizer)
+ (files "machines/i386/lapopt")
+ (parent (compiler))
+ (export (compiler top-level)
+ optimize-linear-lap))
+
+(define-package (compiler assembler)
+ (files "machines/i386/assmd" ;Machine dependent
+ "back/symtab" ;Symbol tables
+ "back/bitutl" ;Assembly blocks
+ "back/bittop" ;Assembler top level
+ )
+ (parent (compiler))
+ (export (compiler)
+ instruction-append)
+ (export (compiler top-level)
+ assemble))
+
+(define-package (compiler disassembler)
+ (files "machines/i386/dassm1"
+ "machines/i386/dassm2"
+ "machines/i386/dassm3")
+ (parent (compiler))
+ (export ()
+ compiler:write-lap-file
+ compiler:disassemble)
+ (import (runtime compiler-info)
+ compiled-code-block/dbg-info
+ dbg-info-vector/blocks-vector
+ dbg-info-vector?
+ dbg-info/labels
+ dbg-label/external?
+ dbg-label/name
+ dbg-labels/find-offset))
--- /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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Script to incrementally syntax the compiler
+\f
+(load-option 'CREF)
+
+;; Guarantee that the compiler's package structure exists.
+(if (not (name->package '(COMPILER)))
+ (let ((package-set (package-set-pathname "compiler")))
+ (if (not (file-exists? package-set))
+ (cref/generate-trivial-constructor "compiler"))
+ (construct-packages-from-file (fasload package-set))))
+
+;; Guarantee that the necessary syntactic transforms and optimizers
+;; are loaded.
+(if (lexical-unreferenceable? (->environment '(COMPILER)) 'SYNTAX-FILES!)
+ (let ((sf-and-load
+ (lambda (files package)
+ (fluid-let ((sf/default-syntax-table (->environment package)))
+ (sf-conditionally files))
+ (for-each (lambda (file)
+ (load (string-append file ".bin") package))
+ files))))
+ (load-option 'HASH-TABLE)
+ (fresh-line)
+ (newline)
+ (write-string "---- Loading compile-time files ----")
+ (newline)
+ (sf-and-load '("base/switch") '(COMPILER))
+ (sf-and-load '("base/macros") '(COMPILER MACROS))
+ (sf-and-load '("machines/i386/decls") '(COMPILER DECLARATIONS))
+ (let ((environment (->environment '(COMPILER DECLARATIONS))))
+ (set! (access source-file-expression environment) "*.scm")
+ ((access initialize-package! environment)))
+ (sf-and-load '("base/pmlook") '(COMPILER PATTERN-MATCHER/LOOKUP))
+ (sf-and-load '("base/pmpars") '(COMPILER PATTERN-MATCHER/PARSER))
+ (sf-and-load '("machines/i386/machin") '(COMPILER))
+ (fluid-let ((sf/default-declarations
+ '((integrate-external "insseq")
+ (integrate-external "machin")
+ (usual-definition (set expt)))))
+ (sf-and-load '("machines/i386/assmd") '(COMPILER ASSEMBLER)))
+ (sf-and-load '("back/syntax") '(COMPILER LAP-SYNTAXER))
+ (sf-and-load '("machines/i386/coerce"
+ "back/asmmac"
+ "machines/i386/insmac")
+ '(COMPILER LAP-SYNTAXER))
+ (sf-and-load '("base/scode") '(COMPILER))
+ (sf-and-load '("base/pmerly") '(COMPILER PATTERN-MATCHER/EARLY))
+ (sf-and-load '("back/syerly") '(COMPILER LAP-SYNTAXER))))
+
+;; Resyntax any files that need it.
+((access syntax-files! (->environment '(COMPILER))))
+
+;; Rebuild the package constructors and cref.
+(cref/generate-constructors "compiler" 'ALL)
\ 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Disassembler: User Level
+;;; package: (compiler disassembler)
+
+(declare (usual-integrations))
+\f
+;;; Flags that control disassembler behavior
+
+(define disassembler/symbolize-output? #t)
+(define disassembler/compiled-code-heuristics? #t)
+(define disassembler/write-offsets? #t)
+(define disassembler/write-addresses? #f)
+
+;;;; Top level entries
+
+(define (compiler:write-lap-file filename #!optional symbol-table?)
+ (let ((pathname (->pathname filename))
+ (symbol-table?
+ (if (default-object? symbol-table?) #t symbol-table?)))
+ (with-output-to-file (pathname-new-type pathname "lap")
+ (lambda ()
+ (let ((com-file (pathname-new-type pathname "com")))
+ (let ((object (fasload com-file)))
+ (if (compiled-code-address? object)
+ (let ((block (compiled-code-address->block object)))
+ (disassembler/write-compiled-code-block
+ block
+ (compiled-code-block/dbg-info block symbol-table?)))
+ (begin
+ (if (not
+ (and (scode/comment? object)
+ (dbg-info-vector? (scode/comment-text object))))
+ (error "Not a compiled file" com-file))
+ (let ((blocks
+ (vector->list
+ (dbg-info-vector/blocks-vector
+ (scode/comment-text object)))))
+ (if (not (null? blocks))
+ (do ((blocks blocks (cdr blocks)))
+ ((null? blocks) unspecific)
+ (disassembler/write-compiled-code-block
+ (car blocks)
+ (compiled-code-block/dbg-info (car blocks)
+ symbol-table?))
+ (if (not (null? (cdr blocks)))
+ (begin
+ (write-char #\page)
+ (newline))))))))))))))
+
+(define disassembler/base-address)
+
+(define (compiler:disassemble entry)
+ (let ((block (compiled-entry/block entry)))
+ (let ((info (compiled-code-block/dbg-info block #t)))
+ (fluid-let ((disassembler/write-offsets? #t)
+ (disassembler/write-addresses? #t)
+ (disassembler/base-address (object-datum block)))
+ (newline)
+ (newline)
+ (disassembler/write-compiled-code-block block info)))))
+\f
+(define (disassembler/write-compiled-code-block block info)
+ (let ((symbol-table (and info (dbg-info/labels info))))
+ (write-string "Disassembly of ")
+ (write block)
+ (call-with-values
+ (lambda () (compiled-code-block/filename-and-index block))
+ (lambda (filename index)
+ (if filename
+ (begin
+ (write-string " (Block ")
+ (write index)
+ (write-string " in ")
+ (write-string filename)
+ (write-string ")")))))
+ (write-string ":\n")
+ (write-string "Code:\n\n")
+ (disassembler/write-instruction-stream
+ symbol-table
+ (disassembler/instructions/compiled-code-block block symbol-table))
+ (write-string "\nConstants:\n\n")
+ (disassembler/write-constants-block block symbol-table)
+ (newline)))
+
+(define (disassembler/instructions/compiled-code-block block symbol-table)
+ (disassembler/instructions block
+ (compiled-code-block/code-start block)
+ (compiled-code-block/code-end block)
+ symbol-table))
+
+(define (disassembler/instructions/address start-address end-address)
+ (disassembler/instructions #f start-address end-address #f))
+
+(define (disassembler/write-instruction-stream symbol-table instruction-stream)
+ (fluid-let ((*unparser-radix* 16))
+ (disassembler/for-each-instruction instruction-stream
+ (lambda (offset instruction comment)
+ (disassembler/write-instruction
+ symbol-table
+ offset
+ (lambda ()
+ (if comment
+ (let ((s (with-output-to-string
+ (lambda () (display instruction)))))
+ (if (< (string-length s) 40)
+ (write-string (string-pad-right s 40))
+ (write-string s))
+ (write-string "; ")
+ (display comment))
+ (write instruction))))))))
+
+(define (disassembler/for-each-instruction instruction-stream procedure)
+ (let loop ((instruction-stream instruction-stream))
+ (if (not (disassembler/instructions/null? instruction-stream))
+ (disassembler/instructions/read instruction-stream
+ (lambda (offset instruction comment instruction-stream)
+ (procedure offset instruction comment)
+ (loop (instruction-stream)))))))
+\f
+(define (disassembler/write-constants-block block symbol-table)
+ (fluid-let ((*unparser-radix* 16))
+ (let ((end (system-vector-length block)))
+ (let loop ((index (compiled-code-block/marked-start block)))
+ (cond ((not (< index end)) 'DONE)
+ ((object-type?
+ (let-syntax ((ucode-type
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (apply microcode-type (cdr form))))))
+ (ucode-type linkage-section))
+ (system-vector-ref block index))
+ (loop (disassembler/write-linkage-section block
+ symbol-table
+ index)))
+ (else
+ (disassembler/write-instruction
+ symbol-table
+ (compiled-code-block/index->offset index)
+ (lambda ()
+ (write-constant block
+ symbol-table
+ (system-vector-ref block index))))
+ (loop (1+ index))))))))
+
+(define (write-constant block symbol-table constant)
+ (write-string (cdr (write-to-string constant 60)))
+ (cond ((lambda? constant)
+ (let ((expression (lambda-body constant)))
+ (if (and (compiled-code-address? expression)
+ (eq? (compiled-code-address->block expression) block))
+ (begin
+ (write-string " (")
+ (let ((offset (compiled-code-address->offset expression)))
+ (let ((label
+ (disassembler/lookup-symbol symbol-table offset)))
+ (if label
+ (write-string label)
+ (write offset))))
+ (write-string ")")))))
+ ((compiled-code-address? constant)
+ (write-string " (offset ")
+ (write (compiled-code-address->offset constant))
+ (write-string " in ")
+ (write (compiled-code-address->block constant))
+ (write-string ")"))
+ (else #f)))
+\f
+(define (disassembler/write-linkage-section block symbol-table index)
+ (let* ((field (object-datum (system-vector-ref block index)))
+ (descriptor (integer-divide field #x10000)))
+ (let ((kind (integer-divide-quotient descriptor))
+ (length (integer-divide-remainder descriptor)))
+
+ (define (write-caches offset size writer)
+ (let loop ((index (1+ (+ offset index)))
+ (how-many (quotient (- length offset) size)))
+ (if (zero? how-many)
+ 'DONE
+ (begin
+ (disassembler/write-instruction
+ symbol-table
+ (compiled-code-block/index->offset index)
+ (lambda ()
+ (writer block index)))
+ (loop (+ size index) (-1+ how-many))))))
+
+ (disassembler/write-instruction
+ symbol-table
+ (compiled-code-block/index->offset index)
+ (lambda ()
+ (write-string "#[LINKAGE-SECTION ")
+ (write field)
+ (write-string "]")))
+ (case kind
+ ((0 3)
+ (write-caches
+ compiled-code-block/procedure-cache-offset
+ compiled-code-block/objects-per-procedure-cache
+ disassembler/write-procedure-cache))
+ ((1)
+ (write-caches
+ 0
+ compiled-code-block/objects-per-variable-cache
+ (lambda (block index)
+ (disassembler/write-variable-cache "Reference" block index))))
+ ((2)
+ (write-caches
+ 0
+ compiled-code-block/objects-per-variable-cache
+ (lambda (block index)
+ (disassembler/write-variable-cache "Assignment" block index))))
+ (else
+ (error "disassembler/write-linkage-section: Unknown section kind"
+ kind)))
+ (1+ (+ index length)))))
+\f
+(define-integrable (variable-cache-name cache)
+ ((ucode-primitive primitive-object-ref 2) cache 1))
+
+(define (disassembler/write-variable-cache kind block index)
+ (write-string kind)
+ (write-string " cache to ")
+ (write (variable-cache-name (disassembler/read-variable-cache block index))))
+
+(define (disassembler/write-procedure-cache block index)
+ (let ((result (disassembler/read-procedure-cache block index)))
+ (write (vector-ref result 2))
+ (write-string " argument procedure cache to ")
+ (case (vector-ref result 0)
+ ((COMPILED INTERPRETED)
+ (write (vector-ref result 1)))
+ ((VARIABLE)
+ (write-string "variable ")
+ (write (vector-ref result 1)))
+ (else
+ (error "disassembler/write-procedure-cache: Unknown cache kind"
+ (vector-ref result 0))))))
+
+(define (disassembler/write-instruction symbol-table offset write-instruction)
+ (if symbol-table
+ (let ((label (dbg-labels/find-offset symbol-table offset)))
+ (if label
+ (begin
+ (write-char #\Tab)
+ (write-string (dbg-label/name label))
+ (write-char #\:)
+ (newline)))))
+
+ (if disassembler/write-addresses?
+ (begin
+ (write-string
+ (number->string (+ offset disassembler/base-address) 16))
+ (write-char #\Tab)))
+
+ (if disassembler/write-offsets?
+ (begin
+ (write-string (number->string offset 16))
+ (write-char #\Tab)))
+
+ (if symbol-table
+ (write-string " "))
+ (write-instruction)
+ (newline))
\ 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Intel i386 Disassembler: Top Level
+;;; package: (compiler disassembler)
+
+(declare (usual-integrations))
+\f
+(define (disassembler/read-variable-cache block index)
+ (let-syntax ((ucode-type
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (apply microcode-type (cdr form)))))
+ (ucode-primitive
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (apply make-primitive-procedure (cdr form))))))
+ ((ucode-primitive primitive-object-set-type 2)
+ (ucode-type quad)
+ (system-vector-ref block index))))
+
+(define (disassembler/read-procedure-cache block index)
+ (fluid-let ((*block block))
+ (let* ((offset (compiled-code-block/index->offset index)))
+ (let ((opcode (read-unsigned-integer (+ offset 3) 8))
+ (arity (read-unsigned-integer offset 16)))
+ (case opcode
+ ((#xe9) ; (JMP (@PCR label))
+ ;; This should learn how to decode the new trampolines.
+ (vector 'COMPILED
+ (read-procedure (+ offset 4))
+ arity))
+ (else
+ (error "disassembler/read-procedure-cache: Unknown opcode"
+ opcode block index)))))))
+
+(define (disassembler/instructions block start-offset end-offset symbol-table)
+ (let loop ((offset start-offset) (state (disassembler/initial-state)))
+ (if (and end-offset (< offset end-offset))
+ (disassemble-one-instruction
+ block offset symbol-table state
+ (lambda (offset* instruction comment state)
+ (make-instruction offset
+ instruction
+ comment
+ (lambda () (loop offset* state)))))
+ '())))
+
+(define-integrable (disassembler/instructions/null? obj)
+ (null? obj))
+
+(define (disassembler/instructions/read instruction-stream receiver)
+ (receiver (instruction-offset instruction-stream)
+ (instruction-instruction instruction-stream)
+ (instruction-comment instruction-stream)
+ (instruction-next instruction-stream)))
+
+(define-structure (instruction (type vector))
+ (offset false read-only true)
+ (instruction false read-only true)
+ (comment false read-only true)
+ (next false read-only true))
+
+(define *block)
+(define *current-offset)
+(define *symbol-table)
+(define *valid?)
+
+(define (disassemble-one-instruction block offset symbol-table state receiver)
+ (fluid-let ((*block block)
+ (*current-offset offset)
+ (*symbol-table symbol-table)
+ (*valid? true))
+ (let ((start-offset *current-offset))
+ ;; External label markers come in two parts:
+ ;; An entry type descriptor, and a gc offset.
+ (cond ((eq? state 'EXTERNAL-LABEL-OFFSET)
+ (let* ((word (next-unsigned-16-bit-word))
+ (label (find-label *current-offset)))
+ (receiver *current-offset
+ (if label
+ `(BLOCK-OFFSET ,label)
+ `(WORD U ,word))
+ #F
+ 'INSTRUCTION)))
+ ((external-label-marker? symbol-table offset state)
+ (let ((word (next-unsigned-16-bit-word)))
+ (receiver *current-offset
+ `(WORD U ,word)
+ 'ENTRY
+ 'EXTERNAL-LABEL-OFFSET)))
+ ((eq? state 'PRIMITIVE-LONG-OFFSET)
+ (let ((offset (next-unsigned-32-bit-word)))
+ (receiver *current-offset
+ `(LONG U ,offset)
+ (+ offset *current-offset -4)
+ 'EXTERNAL-LABEL)))
+ (else
+ (let ((instruction (disassemble-next-instruction)))
+ (if (or *valid? (not (eq? 'BYTE (car instruction))))
+ (receiver *current-offset
+ instruction
+ (disassembler/guess-comment instruction state)
+ (disassembler/next-state instruction state))
+ (let ((inst `(BYTE U ,(caddr instruction))))
+ (receiver (1+ start-offset)
+ inst
+ #F
+ (disassembler/next-state inst state))))))))))
+\f
+(define (disassembler/initial-state)
+ 'INSTRUCTION-NEXT)
+
+(define (disassembler/next-state instruction state)
+ state ; ignored
+ (cond ((equal? instruction '(CALL (ENTRY SHORT-PRIMITIVE-APPLY)))
+ 'PRIMITIVE-LONG-OFFSET)
+ ((and disassembler/compiled-code-heuristics?
+ (or (memq (car instruction) '(JMP RET))
+ (and (eq? (car instruction) 'CALL)
+ (let ((operand (cadr instruction)))
+ (or (and (pair? operand)
+ (eq? (car operand) 'ENTRY))
+ (let ((entry
+ (interpreter-register? operand)))
+ (and entry
+ (eq? (car entry) 'ENTRY))))))))
+ 'EXTERNAL-LABEL)
+ (else
+ 'INSTRUCTION)))
+
+(define (disassembler/guess-comment instruction state)
+ state ; ignored
+ (let loop ((insn instruction))
+ (and (pair? insn)
+ (if (and (eq? (car insn) '@PCO)
+ (pair? (cdr insn))
+ (exact-integer? (cadr insn))
+ (not (zero? (cadr insn))))
+ (+ (cadr insn) *current-offset)
+ (or (loop (car insn))
+ (loop (cdr insn)))))))
+
+(define (disassembler/lookup-symbol symbol-table offset)
+ (and symbol-table
+ (let ((label (dbg-labels/find-offset symbol-table offset)))
+ (and label
+ (dbg-label/name label)))))
+
+(define (external-label-marker? symbol-table offset state)
+ (define-integrable (offset-word->offset word)
+ (fix:quotient (bit-string->unsigned-integer word) 2))
+
+ (if symbol-table
+ (let ((label (dbg-labels/find-offset symbol-table (+ offset 4))))
+ (and label
+ (dbg-label/external? label)))
+ (and *block
+ (not (eq? state 'INSTRUCTION))
+ (let loop ((offset (+ offset 4)))
+ (let ((contents (read-bits (- offset 2) 16)))
+ (if (bit-string-clear! contents 0)
+ (let ((offset (- offset (offset-word->offset contents))))
+ (and (positive? offset)
+ (loop offset)))
+ (= offset (offset-word->offset contents))))))))
+
+(define (read-procedure offset)
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (let-syntax ((ucode-type
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (apply microcode-type (cdr form)))))
+ (ucode-primitive
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (apply make-primitive-procedure (cdr form))))))
+ ((ucode-primitive primitive-object-set-type 2)
+ (ucode-type compiled-entry)
+ ((ucode-primitive make-non-pointer-object 1)
+ (+ (read-signed-integer offset 32)
+ (+ (if *block
+ (object-datum *block)
+ 0)
+ (+ offset 4)))))))))
+
+(define (read-unsigned-integer offset size)
+ (bit-string->unsigned-integer (read-bits offset size)))
+
+(define (read-signed-integer offset size)
+ (bit-string->signed-integer (read-bits offset size)))
+
+(define (read-bits offset size-in-bits)
+ (let ((word (bit-string-allocate size-in-bits))
+ (bit-offset (* offset addressing-granularity)))
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (if *block
+ (read-bits! *block bit-offset word)
+ (read-bits! offset 0 word))))
+ word))
+\f
+(define-integrable (make-unsigned-reader nbits)
+ (let ((nbytes (fix:quotient nbits 8)))
+ (lambda ()
+ (let ((offset *current-offset))
+ (let ((word (read-bits offset nbits)))
+ (set! *current-offset (+ offset nbytes))
+ (bit-string->unsigned-integer word))))))
+
+(define-integrable (make-signed-reader nbits)
+ (let ((nbytes (fix:quotient nbits 8)))
+ (lambda ()
+ (let ((offset *current-offset))
+ (let ((word (read-bits offset nbits)))
+ (set! *current-offset (+ offset nbytes))
+ (bit-string->signed-integer word))))))
+
+(define next-byte (make-signed-reader 8))
+(define next-unsigned-byte (make-unsigned-reader 8))
+(define next-16-bit-word (make-signed-reader 16))
+(define next-unsigned-16-bit-word (make-unsigned-reader 16))
+(define next-32-bit-word (make-signed-reader 32))
+(define next-unsigned-32-bit-word (make-unsigned-reader 32))
+
+(define (find-label offset)
+ (and disassembler/symbolize-output?
+ (disassembler/lookup-symbol *symbol-table offset)))
+
+(define (interpreter-register? operand)
+ (define (regs-pointer? reg)
+ (if (symbol? reg)
+ (eq? reg 'ESI)
+ (= reg 6)))
+
+ (define (offset->register offset)
+ (let ((place (assq offset interpreter-register-offsets)))
+ (and place
+ (cdr place))))
+
+ (and (pair? operand)
+ (or (and (eq? (car operand) '@R)
+ (regs-pointer? (cadr operand))
+ (offset->register 0))
+ (and (eq? (car operand) '@RO)
+ (regs-pointer? (caddr operand))
+ (offset->register (cadddr operand))))))
+
+(define interpreter-register-offsets
+ (letrec ((make-entries
+ (lambda (kind offset names)
+ (if (null? names)
+ '()
+ (cons (cons offset `(,kind ,(car names)))
+ (make-entries kind
+ (+ offset 4)
+ (cdr names)))))))
+ (append
+ (make-entries
+ 'REGISTER 0
+ '(memtop
+ stack-guard
+ val
+ env
+ compiler-temp
+ expr
+ return-code
+ lexpr-actuals
+ primitive
+ closure-free
+ closure-space))
+\f
+ (make-entries
+ 'ENTRY #x40 ; 16 * 4
+ '(scheme-to-interface
+ scheme-to-interface/call
+ trampoline-to-interface
+ interrupt-procedure
+ interrupt-continuation
+ interrupt-closure
+ interrupt-dlink
+ primitive-apply
+ primitive-lexpr-apply
+ assignment-trap
+ reference-trap
+ safe-reference-trap
+ link
+ error
+ primitive-error
+ short-primitive-apply))
+
+ (make-entries
+ 'ENTRY #x-80
+ '(&+
+ &-
+ &*
+ &/
+ &=
+ &<
+ &>
+ 1+
+ -1+
+ zero?
+ positive?
+ negative?
+ quotient
+ remainder
+ modulo
+ shortcircuit-apply ; Used by rules3, for speed.
+ shortcircuit-apply-size-1 ; Small frames, save time and space.
+ shortcircuit-apply-size-2
+ shortcircuit-apply-size-3
+ shortcircuit-apply-size-4
+ shortcircuit-apply-size-5
+ shortcircuit-apply-size-6
+ shortcircuit-apply-size-7
+ shortcircuit-apply-size-8)))))
+
+;; These are used by dassm1.scm
+
+(define compiled-code-block/procedure-cache-offset 1)
+(define compiled-code-block/objects-per-procedure-cache 2)
+(define compiled-code-block/objects-per-variable-cache 1)
+
+;; global variable used by runtime/udata.scm -- Moby yuck!
+
+(set! compiled-code-block/bytes-per-object 4)
\ No newline at end of file
--- /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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Intel i386 Disassembler: Internals
+;;; package: (compiler disassembler)
+
+(declare (usual-integrations))
+\f
+;; IMPORTANT: This disassembler currently does not handle
+;; operand size and address size modifiers.
+;; Thus it is "stuck" in 32-bit mode, just like the assembler.
+
+;; These really depend on the current operand size
+
+(define next-word next-32-bit-word)
+(define next-unsigned-word next-unsigned-32-bit-word)
+
+;; This really depends on the current address size
+
+(define next-offset next-word)
+
+
+(define-integrable (high-nibble byte)
+ (fix:lsh byte -4))
+
+(define-integrable (low-nibble byte)
+ (fix:and byte #xf))
+
+(define-integrable (low-three-bits byte)
+ (fix:and byte #x7))
+
+(define-integrable (modr/m-mod modr/m-byte)
+ (fix:and (fix:lsh modr/m-byte -6) #x3))
+
+(define-integrable (modr/m-reg modr/m-byte)
+ (fix:and (fix:lsh modr/m-byte -3) #x7))
+
+(define-integrable (modr/m-base modr/m-byte)
+ (fix:and modr/m-byte #x7))
+
+(define-integrable (sib-base sib-byte)
+ (fix:and sib-byte #x7))
+
+(define-integrable (sib-index sib-byte)
+ (fix:and (fix:lsh sib-byte -3) #x7))
+
+(define (sib-scale sib-byte)
+ (vector-ref '#(1 2 4 8) (fix:and (fix:lsh sib-byte -6) #x3)))
+
+(define (pc-relative prefix offset)
+ (cond ((find-label (+ *current-offset offset))
+ =>
+ (lambda (label)
+ `(,@prefix (@PCR ,label))))
+ (else
+ `(,@prefix (@PCO ,offset)))))
+
+(define (@R reg)
+ (let ((operand `(@R ,reg)))
+ (or (and disassembler/symbolize-output?
+ (interpreter-register? operand))
+ operand)))
+
+(define (@RO size reg offset)
+ (let ((operand `(@RO ,size ,reg ,offset)))
+ (or (and disassembler/symbolize-output?
+ (interpreter-register? operand))
+ operand)))
+\f
+(define (immediate-byte)
+ `(& ,(next-byte)))
+
+(define (immediate-word)
+ `(& ,(next-word)))
+
+(define (decode-r/m-32 byte)
+ (let ((base (modr/m-base byte)))
+ (define (ea size next-offset)
+ (cond ((fix:= base 4) ; esp
+ (let ((sib (next-unsigned-byte)))
+ (let ((base (sib-base sib))
+ (index (sib-index sib))
+ (scale (sib-scale sib)))
+ (if (fix:= index 4) ; esp
+ (cond ((and (fix:= base 5)
+ (fix:= scale 1))
+ (if (not size)
+ `(@ 0) ; ???
+ `(@ ,(next-offset))))
+ ((not size)
+ (@R base))
+ (else
+ (@RO size base (next-offset))))
+ (cond ((and (fix:= base 5)
+ (fix:= scale 1))
+ (if (not size)
+ (@R index)
+ (@RO size index (next-offset))))
+ ((not size)
+ `(@RI ,base ,index ,scale))
+ (else
+ `(@ROI ,size ,base ,(next-offset)
+ ,index ,scale)))))))
+ ((not size)
+ (@R base))
+ (else
+ (@RO size base (next-offset)))))
+
+ (case (modr/m-mod byte)
+ ((0)
+ (if (fix:= base 5) ; ebp
+ `(@ ,(next-32-bit-word))
+ (ea #f (lambda () 0))))
+ ((1)
+ (ea 'B next-byte))
+ ((2)
+ (ea 'W next-32-bit-word))
+ ((3)
+ `(R ,base))
+ (else
+ (error "decode-r/m: bad mode" byte)))))
+\f
+(define (decode-r/m-16 byte)
+ (let ((base (modr/m-base byte)))
+ (define (ea size offset)
+ (if (fix:< base 4)
+ (let ((base (if (fix:> base 1) 5 3))
+ (index (fix:+ 6 (fix:and base 1))))
+ (if size
+ `(@RI ,base ,index 1)
+ `(@ROI ,size ,base ,offset ,index 1)))
+ (let ((reg (vector-ref '#(6 7 5 3) (fix:- base 4))))
+ (if size
+ (@RO size reg offset)
+ (@R reg)))))
+
+ (case (modr/m-mod byte)
+ ((0)
+ (if (fix:= base 6)
+ `(@ ,(next-16-bit-word))
+ (ea #f 0)))
+
+ ((1)
+ (ea 'B (next-byte)))
+ ((2)
+ (ea 'W (next-16-bit-word)))
+ ((3)
+ `(R ,base))
+ (else
+ (error "decode-r/m: bad mode" byte)))))
+
+(define decode-r/m decode-r/m-32)
+
+(define (make-modr/m-decoder receiver)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ (let* ((modr/m-byte (next-unsigned-byte))
+ (ea (decode-r/m modr/m-byte)))
+ (receiver (modr/m-reg modr/m-byte) ea))))
+
+(define (decode-E prefix reg-value)
+ (lambda (opcode-byte)
+ (let ((modr/m-byte (next-unsigned-byte)))
+ (if (not (= (modr/m-reg modr/m-byte) reg-value))
+ (unknown-inst opcode-byte modr/m-byte)
+ `(,@prefix ,(decode-r/m modr/m-byte))))))
+
+(define (decode-E/G prefix)
+ (make-modr/m-decoder
+ (lambda (reg ea)
+ `(,@prefix ,ea (R ,reg)))))
+
+(define (decode-G/E prefix)
+ (make-modr/m-decoder
+ (lambda (reg ea)
+ `(,@prefix (R ,reg) ,ea))))
+
+(define (decode-E/I prefix next)
+ (make-modr/m-decoder
+ (lambda (reg ea)
+ reg ; ignored, should be checked
+ `(,@prefix ,ea (& ,(next))))))
+
+(define (decode-G/E/I prefix next)
+ (make-modr/m-decoder
+ (lambda (reg ea)
+ `(,@prefix (R ,reg) ,ea ,(next)))))
+\f
+(define (decode-E/G/I prefix next)
+ (make-modr/m-decoder
+ (lambda (reg ea)
+ `(,@prefix ,ea (R ,reg) ,(next)))))
+
+(define (decode-G/M prefix)
+ ;; This should check that we are dealing with a memory EA!
+ (make-modr/m-decoder
+ (lambda (reg ea)
+ `(,@prefix (R ,reg) ,ea))))
+
+(define (decode-E/X prefix reg-kind)
+ (make-modr/m-decoder
+ (lambda (reg ea)
+ `(,@prefix ,ea (,reg-kind ,reg)))))
+
+(define (decode-X/E prefix reg-kind)
+ (make-modr/m-decoder
+ (lambda (reg ea)
+ `(,@prefix (,reg-kind ,reg) ,ea))))
+
+(define (decode-@ prefix)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ (let ((offset (next-offset)))
+ `(,@prefix (@ ,offset)))))
+
+(define (decode-Ap prefix)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ (let ((offset (next-offset)))
+ `(,@prefix (SEGMENT ,(next-unsigned-16-bit-word))
+ (OFFSET ,offset)))))
+
+(define (decode-Ib prefix)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ `(,@prefix (& ,(next-byte)))))
+
+(define (decode-I16 prefix)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ `(,@prefix (& ,(next-16-bit-word)))))
+
+(define (decode-Iw prefix)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ `(,@prefix (& ,(next-word)))))
+
+(define (decode-ENTER opcode-byte)
+ opcode-byte ; ignored
+ (let ((first (next-unsigned-16-bit-word)))
+ `(ENTER (& ,first) (& ,(next-unsigned-byte)))))
+
+(define (decode-pcrb prefix)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ (pc-relative prefix (next-byte))))
+
+(define (decode-pcrw prefix)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ (pc-relative prefix (next-offset))))
+\f
+(define (unknown-inst opcode-byte . more-bytes)
+ (set! *valid? false) ; re-synch.
+ `(BYTE U ,opcode-byte ,@more-bytes))
+
+(define-integrable (simple-inst inst)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ inst))
+
+(define (backwards handler)
+ (lambda (opcode-byte)
+ (let ((result (handler opcode-byte)))
+ (let ((back (reverse result)))
+ (reverse (cons* (cadr back)
+ (cons (car back)
+ (cddr back))))))))
+
+(define-integrable (register-op prefix)
+ (lambda (opcode-byte)
+ `(,@prefix (R ,(fix:and opcode-byte #x7)))))
+
+(define jcc-opcodes
+ '#(
+ JO JNO JB JNB
+ JZ JNZ JBE JNBE
+ JS JNS JP JNP
+ JL JNL JLE JNLE))
+
+(define setcc-opcodes
+ '#(
+ SETO SETNO SETB SETNB
+ SETZ SETNZ SETBE SETNBE
+ SETS SETNS SETP SETNP
+ SETL SETNL SETLE SETNLE))
+
+(define (group-1&2 opcodes size get-operand)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ (let ((modr/m-byte (next-unsigned-byte)))
+ (let ((operand (decode-r/m modr/m-byte))
+ (opcode (vector-ref opcodes (modr/m-reg modr/m-byte))))
+ `(,opcode ,size ,operand ,(get-operand))))))
+
+(define (group-3 size read-operand)
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ (let* ((modr/m-byte (next-unsigned-byte))
+ (operand (decode-r/m modr/m-byte)))
+ (let ((dispatch (modr/m-reg modr/m-byte)))
+ (cond ((< dispatch 2)
+ `(TEST ,size ,operand (& ,(read-operand))))
+ ((< dispatch 4)
+ `(,(if (= dispatch 2) 'NOT 'NEG) ,size ,operand))
+ (else
+ `(,(vector-ref '#(MUL IMUL DIV IDIV) (- dispatch 4))
+ ,size
+ (R 0)
+ ,operand)))))))
+\f
+(define (group-4 size)
+ (lambda (opcode-byte)
+ (let* ((modr/m-byte (next-unsigned-byte))
+ (operand (lambda () (decode-r/m modr/m-byte))))
+ (case (modr/m-reg modr/m-byte)
+ ((0)
+ `(INC ,size ,(operand)))
+ ((1)
+ `(DEC ,size ,(operand)))
+ (else
+ (unknown-inst opcode-byte modr/m-byte))))))
+
+(define (group-5 size)
+ (lambda (opcode-byte)
+ (let* ((modr/m-byte (next-unsigned-byte))
+ (operand (lambda () (decode-r/m modr/m-byte))))
+ (case (modr/m-reg modr/m-byte)
+ ((0)
+ `(INC ,size ,(operand)))
+ ((1)
+ `(DEC ,size ,(operand)))
+ ((2)
+ `(CALL ,(operand)))
+ ((3)
+ `(CALL F ,(operand)))
+ ((4)
+ `(JMP ,(operand)))
+ ((5)
+ `(JMP F ,(operand)))
+ ((6)
+ `(PUSH ,(operand)))
+ (else
+ (unknown-inst opcode-byte modr/m-byte))))))
+
+(define (group-6&7 opcodes)
+ (lambda (second-byte)
+ (let* ((modr/m-byte (next-unsigned-byte))
+ (op (vector-ref opcodes (modr/m-reg modr/m-byte))))
+ (if (not op)
+ (unknown-inst #x0f second-byte modr/m-byte)
+ `(,op ,(decode-r/m modr/m-byte))))))
+
+(define group-8
+ (let ((opcodes '#(#f #f #f #f BT BTS BTR BTC)))
+ (lambda (second-byte)
+ (let* ((modr/m-byte (next-unsigned-byte))
+ (op (vector-ref opcodes (modr/m-reg modr/m-byte))))
+ (if (not op)
+ (unknown-inst #x0f second-byte modr/m-byte)
+ `(,op ,(decode-r/m modr/m-byte) (& ,(next-byte))))))))
+\f
+;;; Utilities for the main dispatchers
+
+(define (dispatch-on-bit low high)
+ (lambda (opcode-byte)
+ ((if (fix:= (fix:and opcode-byte #x8) 0) low high)
+ opcode-byte)))
+
+(define (dispatch-on-low-bits mask opcodes)
+ (lambda (opcode-byte)
+ ((vector-ref opcodes (fix:and opcode-byte mask))
+ opcode-byte)))
+
+(define (dispatch-on-low-nibble . cases)
+ (if (not (= (length cases) 16))
+ (error "dispatch-on-low-nibble: Wrong number of cases"
+ cases))
+ (dispatch-on-low-bits #xf (list->vector cases)))
+
+(define (dispatch-on-low-three-bits . cases)
+ (if (not (= (length cases) 8))
+ (error "dispatch-on-low-three-bits: Wrong number of cases"
+ cases))
+ (dispatch-on-low-bits #x7 (list->vector cases)))
+
+;;; Floating-point instructions
+
+(define (fp-table-maker fields->index)
+ (lambda (cases)
+ (let ((table (make-vector 64 #f)))
+ (for-each
+ (lambda (a-case)
+ (let ((opcode (car a-case))
+ (next (cadr a-case)))
+ (let ((index (fields->index opcode next)))
+ (cond ((not index)
+ (error "make-table-1-3: Bad fields" a-case))
+ ((vector-ref table index)
+ (error "make-table-1-3: Duplicate case"
+ (vector-ref table index) a-case)))
+ (vector-set! table index (cddr a-case)))))
+ cases)
+ table)))
+
+(define make-table-1-3
+ (fp-table-maker
+ (lambda (opcode next)
+ (and (fix:< opcode 8)
+ (fix:< next 8)
+ (fix:or (fix:lsh next 3) opcode)))))
+
+(define make-table-4&5
+ (fp-table-maker
+ (lambda (opcode next)
+ (and (or (fix:= opcode 1) (fix:= opcode 3))
+ (fix:< next #x20)
+ (fix:or (fix:lsh (fix:- opcode 1) 4)
+ next)))))
+\f
+(define decode-fp
+ (let-syntax
+ ((IN
+ (rsc-macro-transformer
+ (lambda (form environment)
+ `(,(close-syntax 'LET environment)
+ ,(cddr form)
+ ,(cadr form))))))
+ (IN
+ (lambda (opcode-byte)
+ (let* ((next (next-unsigned-byte))
+ (disc (fix:and opcode-byte #x7))
+ (index (fix:or (fix:and next #x38) disc)))
+
+ (cond ((not (fix:= (modr/m-mod next) 3)) ; register op
+ (let ((prefix (vector-ref table-1&2 index)))
+ (if (not prefix)
+ (maybe-special opcode-byte next)
+ `(,@prefix ,(decode-r/m next)))))
+ ((or (fix:= disc 3)
+ (and (fix:= disc 1)
+ (fix:= (fix:and next #x20) #x20)))
+ (let ((inst (vector-ref
+ table-4&5
+ (fix:or (fix:lsh (fix:- disc 1) 4)
+ (fix:and next #x1f)))))
+ (if (not inst)
+ (maybe-special opcode-byte next)
+ inst)))
+ (else
+ (let ((spec (vector-ref table-3 index))
+ (loc (fix:and next #x7)))
+ (cond ((not spec)
+ (maybe-special opcode-byte next))
+ ((null? (cdr spec))
+ `(,(car spec) (ST ,loc)))
+ ((cadr spec) ; reverse ops
+ `(,(car spec) (ST ,loc) (ST 0)))
+ (else
+ `(,(car spec) (ST 0) (ST ,loc)))))))))
+
+ (maybe-special
+ (let ((special '(
+ (#xe0df FNSTSW (R 0))
+ (#xd0d9 FNOP)
+ )))
+ (lambda (opcode-byte next)
+ (let* ((word (fix:or (fix:lsh next 8) opcode-byte))
+ (place (assq word special)))
+ (if place
+ (cdr place)
+ (unknown-inst opcode-byte next))))))
+
+\f
+ (table-4&5
+ (make-table-4&5
+ '(
+ (1 4 FTST)
+ (1 5 FXAM)
+ (1 #xe FLDZ)
+ (1 8 FLD1)
+ (1 #xb FLDPI)
+ (1 9 FLD2T)
+ (1 #xa FLD2E)
+ (1 #xc FLDG2)
+ (1 #xd FLDLN2)
+ (1 #x1a FSQRT)
+ (1 #x1d FSCALE)
+ (1 #x14 FXTRACT)
+ (1 #x18 FPREM)
+ (1 #x15 FPREM1)
+ (1 #x1c FRNDINT)
+ (1 1 FABS)
+ (1 0 FCHS)
+ (1 #x1f FCOS)
+ (1 #x12 FPTAN)
+ (1 #x13 FPATAN)
+ (1 #x1e FSIN)
+ (1 #x1b FSINCOS)
+ (1 #x10 F2XM1)
+ (1 #x11 FYL2X)
+ (1 #x19 FYL2XP1)
+ (3 3 FNINIT)
+ (3 2 FCLEX)
+ (1 #x17 FINCSTP)
+ (1 #x16 FDECSTP))))
+
+
+ (table-3
+ (make-table-1-3
+ '(
+ (1 0 FLD)
+ (5 2 FST)
+ (5 3 FSTP) ; i486 book has 5 1
+ (1 1 FXCH #f)
+ (0 2 FCOM #f)
+ (0 3 FCOMP #f)
+ (6 3 FCOMPP #f) ; really only with (ST 1)
+ (5 4 FUCOM #f)
+ (5 5 FUCOMP #f)
+ (2 5 FUCOMPP #f) ; really only with (ST 1)
+ (0 0 FADD #f)
+ (4 0 FADD #t)
+ (6 0 FADDP #t)
+ (0 5 FSUB #f)
+ (4 5 FSUB #t)
+ (6 5 FSUBP #t)
+ (0 4 FSUBR #f)
+ (4 4 FSUBR #t)
+ (6 4 FSUBRP #t)
+ (0 1 FMUL #f)
+ (4 1 FMUL #t)
+ (6 1 FMULP #t)
+ (0 7 FDIV #f)
+ (4 7 FDIV #t)
+ (6 7 FDIVP #t)
+ (0 6 FDIVR #f)
+ (4 6 FDIVR #t)
+ (6 6 FDIVRP #t)
+ (5 0 FFREE))))
+\f
+ (table-1&2
+ (make-table-1-3
+ '(
+ (1 0 FLD S)
+ (5 0 FLD D)
+ (3 5 FLD X)
+ (7 0 FILD H)
+ (3 0 FILD L)
+ (7 5 FILD Q)
+ (7 4 FBLD)
+ (1 2 FST S)
+ (5 2 FST D)
+ (1 3 FSTP S) ; i486 book has 3 3 like FISTP
+ (5 3 FSTP D)
+ (3 7 FSTP X)
+ (7 2 FIST H)
+ (3 2 FIST L)
+ (7 3 FISTP H)
+ (3 3 FISTP L)
+ (7 7 FISTP Q)
+ (7 6 FBSTP)
+ (0 2 FCOM S (ST 0))
+ (4 2 FCOM D (ST 0))
+ (0 3 FCOMP S (ST 0))
+ (4 3 FCOMP D (ST 0))
+ (6 2 FICOM H)
+ (2 2 FICOM L)
+ (6 3 FICOMP H)
+ (2 3 FICOMP L)
+ (0 0 FADD S)
+ (4 0 FADD D)
+ (0 4 FSUB S)
+ (4 4 FSUB D)
+ (0 5 FSUBR S)
+ (4 5 FSUBR D)
+ (0 1 FMUL S)
+ (4 1 FMUL D)
+ (0 6 FDIV S)
+ (4 6 FDIV D) ; i486 manual has 4 4 like FSUB
+ (0 7 FDIVR S)
+ (4 7 FDIVR D)
+ (6 0 FIADD H)
+ (2 0 FIADD L)
+ (6 4 FISUB H)
+ (2 4 FISUB L)
+ (6 5 FISUBR H)
+ (2 5 FISUBR L)
+ (6 1 FIMUL H)
+ (2 1 FIMUL L)
+ (6 6 FIDIV H)
+ (2 6 FIDIV L)
+ (6 7 FIDIVR H)
+ (2 7 FIDIVR L)
+ (5 7 FNSTSW)
+ (1 5 FLDCW)
+ (1 7 FNSTCW)
+ (1 6 FNSTENV)
+ (1 4 FLDENV)
+ (5 6 FNSAVE)
+ (5 4 FRSTOR)))))))
+\f
+(define dispatch/0f
+ (let* ((unknown-inst
+ (lambda (second-byte)
+ (unknown-inst #x0f second-byte)))
+ (table
+ (vector
+ (dispatch-on-low-nibble ; 0
+ (group-6&7 '#(SLDT STR LLDT LTR VERR VERW #f #f))
+ (group-6&7 '#(SGDT SIDT LGDT LIDT SMSW #f LMSW #f))
+ (decode-G/E '(LAR))
+ (decode-G/E '(LSL))
+ unknown-inst
+ unknown-inst
+ (simple-inst '(CLTS))
+ unknown-inst
+
+ (simple-inst '(INVD))
+ (simple-inst '(WBINVD))
+ unknown-inst
+ unknown-inst
+ unknown-inst
+ unknown-inst
+ unknown-inst
+ unknown-inst)
+
+ unknown-inst ; 1
+
+ (dispatch-on-bit ; 2
+ (dispatch-on-low-three-bits
+ (decode-X/E '(MOV) 'CR)
+ (decode-X/E '(MOV) 'DR)
+ (decode-E/X '(MOV) 'CR)
+ (decode-E/X '(MOV) 'DR)
+ (decode-X/E '(MOV) 'TR)
+ unknown-inst
+ (decode-E/X '(MOV) 'TR)
+ unknown-inst)
+ unknown-inst)
+
+ unknown-inst ; 3
+
+ unknown-inst ; 4
+
+ unknown-inst ; 5
+
+ unknown-inst ; 6
+
+ unknown-inst ; 7
+
+ (lambda (opcode-byte) ; 8
+ ((decode-pcrw
+ `(,(vector-ref jcc-opcodes (low-nibble opcode-byte))
+ W))
+ opcode-byte))
+
+ (lambda (opcode-byte) ; 9
+ ((decode-E
+ `(,(vector-ref setcc-opcodes (low-nibble opcode-byte))))
+ opcode-byte))
+\f
+ (dispatch-on-low-nibble ; A
+ (simple-inst '(PUSH FS))
+ (simple-inst '(POP FS))
+ (simple-inst '(CPUID))
+ (decode-E/G '(BT))
+ (decode-E/G/I '(SHLD) immediate-byte)
+ (decode-E/G/I '(SHLD) (lambda () '(R 1)))
+ (decode-E/G '(CMPXCHG B))
+ (decode-E/G '(CMPXCHG W))
+
+ (simple-inst '(PUSH GS))
+ (simple-inst '(POP GS))
+ unknown-inst
+ (decode-E/G '(BTS))
+ (decode-E/G/I '(SHRD) immediate-byte)
+ (decode-E/G/I '(SHRD) (lambda () '(R 1)))
+ unknown-inst
+ (decode-G/E '(IMUL W)))
+
+ (dispatch-on-low-nibble ; B
+ unknown-inst
+ unknown-inst
+ (decode-G/M '(LSS))
+ (decode-E/G '(BTR))
+ (decode-G/M '(LFS))
+ (decode-G/M '(LGS))
+ (decode-G/E '(MOVZX B))
+ (decode-G/E '(MOVZX W))
+
+ unknown-inst
+ unknown-inst
+ group-8
+ (decode-E/G '(BTC))
+ (decode-G/E '(BSF))
+ (decode-G/E '(BSR))
+ (decode-G/E '(MOVSX B))
+ (decode-G/E '(MOVSX W)))
+
+ (dispatch-on-bit ; C
+ (dispatch-on-low-three-bits
+ (decode-E/G '(XADD B))
+ (decode-E/G '(XADD W))
+ unknown-inst
+ unknown-inst
+ unknown-inst
+ unknown-inst
+ unknown-inst
+ unknown-inst)
+ (register-op '(BSWAP)))
+
+ unknown-inst ; D
+
+ unknown-inst ; E
+
+ unknown-inst))) ; F
+
+ (lambda (opcode-byte)
+ opcode-byte ; ignored
+ (let ((next (next-unsigned-byte)))
+ ((vector-ref table (high-nibble next))
+ next)))))
+\f
+(define disassemble-next-instruction
+ (let* ((arith-opcodes
+ '#(ADD OR ADC SBB AND SUB XOR CMP))
+ (shift-opcodes
+ '#(ROL ROR RCL RCR SHL SHR SAL SAR))
+ (table
+ (vector
+ (dispatch-on-low-nibble ; 0
+ (decode-E/G '(ADD B))
+ (decode-E/G '(ADD W))
+ (decode-G/E '(ADD B))
+ (decode-G/E '(ADD W))
+ (decode-Ib '(ADD B (R 0)))
+ (decode-Iw '(ADD W (R 0)))
+ (simple-inst '(PUSH ES))
+ (simple-inst '(POP ES))
+
+ (decode-E/G '(OR B))
+ (decode-E/G '(OR W))
+ (decode-G/E '(OR B))
+ (decode-G/E '(OR W))
+ (decode-Ib '(OR B (R 0)))
+ (decode-Iw '(OR W (R 0)))
+ (simple-inst '(PUSH CS))
+ dispatch/0f)
+
+ (dispatch-on-low-nibble ; 1
+ (decode-E/G '(ADC B))
+ (decode-E/G '(ADC W))
+ (decode-G/E '(ADC B))
+ (decode-G/E '(ADC W))
+ (decode-Ib '(ADC B (R 0)))
+ (decode-Iw '(ADC W (R 0)))
+ (simple-inst '(PUSH SS))
+ (simple-inst '(POP SS))
+
+ (decode-E/G '(SBB B))
+ (decode-E/G '(SBB W))
+ (decode-G/E '(SBB B))
+ (decode-G/E '(SBB W))
+ (decode-Ib '(SBB B (R 0)))
+ (decode-Iw '(SBB W (R 0)))
+ (simple-inst '(PUSH DS))
+ (simple-inst '(POP DS)))
+
+ (dispatch-on-low-nibble ; 2
+ (decode-E/G '(AND B))
+ (decode-E/G '(AND W))
+ (decode-G/E '(AND B))
+ (decode-G/E '(AND W))
+ (decode-Ib '(AND B (R 0)))
+ (decode-Iw '(AND W (R 0)))
+ (simple-inst '(ESSEG))
+ (simple-inst '(DAA))
+
+ (decode-E/G '(SUB B))
+ (decode-E/G '(SUB W))
+ (decode-G/E '(SUB B))
+ (decode-G/E '(SUB W))
+ (decode-Ib '(SUB B (R 0)))
+ (decode-Iw '(AND W (R 0)))
+ (simple-inst '(CSSEG))
+ (simple-inst '(DAS)))
+\f
+ (dispatch-on-low-nibble ; 3
+ (decode-E/G '(XOR B))
+ (decode-E/G '(XOR W))
+ (decode-G/E '(XOR B))
+ (decode-G/E '(XOR W))
+ (decode-Ib '(XOR B (R 0)))
+ (decode-Iw '(XOR W (R 0)))
+ (simple-inst '(SSSEG))
+ (simple-inst '(AAA))
+
+ (decode-E/G '(CMP B))
+ (decode-E/G '(CMP W))
+ (decode-G/E '(CMP B))
+ (decode-G/E '(CMP W))
+ (decode-Ib '(CMP B (R 0)))
+ (decode-Iw '(CMP W (R 0)))
+ (simple-inst '(DSSEG))
+ (simple-inst '(AAS)))
+
+ (dispatch-on-bit ; 4
+ (register-op '(INC))
+ (register-op '(DEC)))
+
+ (dispatch-on-bit ; 5
+ (register-op '(PUSH))
+ (register-op '(POP)))
+
+ (dispatch-on-low-nibble ; 6
+ (simple-inst '(PUSHA))
+ (simple-inst '(POPA))
+ (decode-G/M '(BOUND))
+ (decode-E/G '(ARPL))
+ (simple-inst '(FSSEG))
+ (simple-inst '(GSSEG))
+ (simple-inst '(OPSIZE))
+ (simple-inst '(ADSIZE))
+
+ (decode-Iw '(PUSH W))
+ (decode-G/E/I '(IMUL W) immediate-word)
+ (decode-Ib '(PUSH B))
+ (decode-G/E/I '(IMUL B) immediate-byte)
+ (simple-inst '(INS B))
+ (simple-inst '(INS W))
+ (simple-inst '(OUTS B))
+ (simple-inst '(OUTS W)))
+
+ (lambda (opcode-byte) ; 7
+ ((decode-pcrb
+ `(,(vector-ref jcc-opcodes (low-nibble opcode-byte))
+ B))
+ opcode-byte))
+\f
+ (dispatch-on-low-nibble ; 8
+ (group-1&2 arith-opcodes 'B immediate-byte)
+ (group-1&2 arith-opcodes 'W immediate-word)
+ (decode-Ib '(MOV B (R 0)))
+ (group-1&2 arith-opcodes 'W immediate-byte)
+ (decode-E/G '(TEST B))
+ (decode-E/G '(TEST W))
+ (decode-E/G '(XCHG B))
+ (decode-E/G '(XCHG W))
+
+ (decode-E/G '(MOV B))
+ (decode-E/G '(MOV W))
+ (decode-G/E '(MOV B))
+ (decode-G/E '(MOV W))
+ (decode-E/X '(MOV) 'SR)
+ (decode-G/M '(LEA))
+ (decode-X/E '(MOV) 'SR)
+ (decode-E '(POP) 0))
+
+ (dispatch-on-bit ; 9
+ (register-op '(XCHG W (R 0)))
+ (dispatch-on-low-three-bits
+ (simple-inst '(CBW))
+ (simple-inst '(CWDE))
+ (decode-Ap '(CALL F))
+ (simple-inst '(WAIT))
+ (simple-inst '(PUSHF))
+ (simple-inst '(POPF))
+ (simple-inst '(SAHF))
+ (simple-inst '(LAHF))))
+
+ (dispatch-on-low-nibble ; A
+ (decode-@ '(MOV B (R 0)))
+ (decode-@ '(MOV W (R 0)))
+ (backwards
+ (decode-@ '(MOV B (R 0))))
+ (backwards
+ (decode-@ '(MOV W (R 0))))
+ (simple-inst '(MOVSB))
+ (simple-inst '(MOVSW))
+ (simple-inst '(CMPSB))
+ (simple-inst '(CMPSW))
+
+ (decode-Ib '(TEST B (R 0)))
+ (decode-Iw '(TEST W (R 0)))
+ (simple-inst '(STOS B))
+ (simple-inst '(STOS W))
+ (simple-inst '(LODS B))
+ (simple-inst '(LODS W))
+ (simple-inst '(SCAS B))
+ (simple-inst '(SCAS W)))
+\f
+ (dispatch-on-bit ; B
+ (lambda (opcode)
+ ((decode-Ib
+ `(MOV B (R ,(fix:and opcode #x7))))
+ opcode))
+ (lambda (opcode)
+ ((decode-Iw
+ `(MOV W (R ,(fix:and opcode #x7))))
+ opcode)))
+
+ (dispatch-on-low-nibble ; C
+ (group-1&2 shift-opcodes 'B immediate-byte)
+ (group-1&2 shift-opcodes 'W immediate-byte)
+ (decode-I16 '(RET))
+ (simple-inst '(RET))
+ (decode-G/M '(LES))
+ (decode-G/M '(LDS))
+ (decode-E/I '(MOV B) next-byte)
+ (decode-E/I '(MOV W) next-word)
+
+ decode-ENTER
+ (simple-inst '(LEAVE))
+ (decode-I16 '(RET F))
+ (simple-inst '(RET F))
+ (simple-inst '(INT 3))
+ (decode-Ib '(INT))
+ (simple-inst '(INTO))
+ (simple-inst '(IRET)))
+
+ (dispatch-on-bit ; D
+ (dispatch-on-low-three-bits
+ (group-1&2 shift-opcodes 'B (lambda () '(& 1)))
+ (group-1&2 shift-opcodes 'W (lambda () '(& 1)))
+ (group-1&2 shift-opcodes 'B (lambda () '(R 1)))
+ (group-1&2 shift-opcodes 'W (lambda () '(R 1)))
+ (simple-inst '(AAM))
+ (simple-inst '(AAD))
+ unknown-inst
+ (simple-inst '(XLAT)))
+ decode-fp)
+
+ (dispatch-on-low-nibble ; E
+ (decode-pcrb '(LOOPNE))
+ (decode-pcrb '(LOOPE))
+ (decode-pcrb '(LOOP))
+ (decode-pcrb '(JCXZ))
+ (decode-Ib '(IN B (R 0)))
+ (decode-Iw '(IN W (R 0)))
+ (backwards (decode-Ib '(OUT B (R 0))))
+ (backwards (decode-IW '(OUT W (R 0))))
+\f
+ (decode-pcrw '(CALL))
+ (decode-pcrw '(JMP W))
+ (decode-ap '(JMP F))
+ (decode-pcrb '(JMP B))
+ (simple-inst '(IN B (R 0) (R 2)))
+ (simple-inst '(IN W (R 0) (R 2)))
+ (simple-inst '(OUT B (R 2) (R 0)))
+ (simple-inst '(OUT W (R 2) (R 0))))
+
+ (dispatch-on-low-nibble ; F
+ (simple-inst '(LOCK))
+ unknown-inst
+ (simple-inst '(REPNE))
+ (simple-inst '(REPE))
+ (simple-inst '(HLT))
+ (simple-inst '(CMC))
+ (group-3 'B next-byte)
+ (group-3 'W next-word)
+
+ (simple-inst '(CLC))
+ (simple-inst '(STC))
+ (simple-inst '(CLI))
+ (simple-inst '(STI))
+ (simple-inst '(CLD))
+ (simple-inst '(STD))
+ (group-4 'B)
+ (group-5 'W)))))
+
+ (lambda ()
+ (let ((opcode-byte (next-unsigned-byte)))
+ ((vector-ref table (high-nibble opcode-byte))
+ opcode-byte)))))
\ 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Compiler File Dependencies
+;;; package: (compiler declarations)
+
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (add-event-receiver! event:after-restore reset-source-nodes!)
+ (reset-source-nodes!))
+
+(define (reset-source-nodes!)
+ (set! source-filenames '())
+ (set! source-hash)
+ (set! source-nodes)
+ (set! source-nodes/by-rank)
+ unspecific)
+
+(define (maybe-setup-source-nodes!)
+ (if (null? source-filenames)
+ (setup-source-nodes!)))
+
+(define (setup-source-nodes!)
+ (let ((filenames
+ (append-map!
+ (lambda (subdirectory)
+ (map (lambda (pathname)
+ (string-append subdirectory
+ "/"
+ (pathname-name pathname)))
+ (directory-read
+ (string-append subdirectory
+ "/"
+ source-file-expression))))
+ '("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt"
+ "machines/i386"))))
+ (if (null? filenames)
+ (error "Can't find source files of compiler"))
+ (set! source-filenames filenames))
+ (set! source-hash (make-string-hash-table))
+ (set! source-nodes
+ (map (lambda (filename)
+ (let ((node (make/source-node filename)))
+ (hash-table/put! source-hash filename node)
+ node))
+ source-filenames))
+ (initialize/syntax-dependencies!)
+ (initialize/integration-dependencies!)
+ (source-nodes/rank!))
+
+(define source-file-expression "*.scm")
+(define source-filenames)
+(define source-hash)
+(define source-nodes)
+(define source-nodes/by-rank)
+
+(define (filename/append directory . names)
+ (map (lambda (name) (string-append directory "/" name)) names))
+\f
+(define-structure (source-node
+ (conc-name source-node/)
+ (constructor %make/source-node (filename pathname)))
+ (filename #f read-only #t)
+ (pathname #f read-only #t)
+ (forward-links '())
+ (backward-links '())
+ (forward-closure '())
+ (backward-closure '())
+ (dependencies '())
+ (dependents '())
+ (rank #f)
+ (syntax-table #f)
+ (declarations '())
+ (modification-time #f))
+
+(define (make/source-node filename)
+ (%make/source-node filename (->pathname filename)))
+
+(define (filename->source-node filename)
+ (let ((node (hash-table/get source-hash filename #f)))
+ (if (not node)
+ (error "Unknown source file:" filename))
+ node))
+
+(define (source-node/circular? node)
+ (memq node (source-node/backward-closure node)))
+
+(define (source-node/link! node dependency)
+ (if (not (memq dependency (source-node/backward-links node)))
+ (begin
+ (set-source-node/backward-links!
+ node
+ (cons dependency (source-node/backward-links node)))
+ (set-source-node/forward-links!
+ dependency
+ (cons node (source-node/forward-links dependency)))
+ (source-node/close! node dependency))))
+
+(define (source-node/close! node dependency)
+ (if (not (memq dependency (source-node/backward-closure node)))
+ (begin
+ (set-source-node/backward-closure!
+ node
+ (cons dependency (source-node/backward-closure node)))
+ (set-source-node/forward-closure!
+ dependency
+ (cons node (source-node/forward-closure dependency)))
+ (for-each (lambda (dependency)
+ (source-node/close! node dependency))
+ (source-node/backward-closure dependency))
+ (for-each (lambda (node)
+ (source-node/close! node dependency))
+ (source-node/forward-closure node)))))
+\f
+;;;; Rank
+
+(define (source-nodes/rank!)
+ (compute-dependencies! source-nodes)
+ (compute-ranks! source-nodes)
+ (set! source-nodes/by-rank (source-nodes/sort-by-rank source-nodes))
+ unspecific)
+
+(define (compute-dependencies! nodes)
+ (for-each (lambda (node)
+ (set-source-node/dependencies!
+ node
+ (list-transform-negative (source-node/backward-closure node)
+ (lambda (node*)
+ (memq node (source-node/backward-closure node*)))))
+ (set-source-node/dependents!
+ node
+ (list-transform-negative (source-node/forward-closure node)
+ (lambda (node*)
+ (memq node (source-node/forward-closure node*))))))
+ nodes))
+
+(define (compute-ranks! nodes)
+ (let loop ((nodes nodes) (unranked-nodes '()))
+ (if (null? nodes)
+ (if (not (null? unranked-nodes))
+ (loop unranked-nodes '()))
+ (loop (cdr nodes)
+ (let ((node (car nodes)))
+ (let ((rank (source-node/rank* node)))
+ (if rank
+ (begin
+ (set-source-node/rank! node rank)
+ unranked-nodes)
+ (cons node unranked-nodes))))))))
+
+(define (source-node/rank* node)
+ (let loop ((nodes (source-node/dependencies node)) (rank -1))
+ (if (null? nodes)
+ (1+ rank)
+ (let ((rank* (source-node/rank (car nodes))))
+ (and rank*
+ (loop (cdr nodes) (max rank rank*)))))))
+
+(define (source-nodes/sort-by-rank nodes)
+ (sort nodes (lambda (x y) (< (source-node/rank x) (source-node/rank y)))))
+\f
+;;;; File Syntaxer
+
+(define (syntax-files!)
+ (maybe-setup-source-nodes!)
+ (for-each
+ (lambda (node)
+ (let ((modification-time
+ (let ((source (modification-time node "scm"))
+ (binary (modification-time node "bin")))
+ (if (not source)
+ (error "Missing source file" (source-node/filename node)))
+ (and binary (< source binary) binary))))
+ (set-source-node/modification-time! node modification-time)
+ (if (not modification-time)
+ (write-notification-line
+ (lambda (port)
+ (write-string "Source file newer than binary: " port)
+ (write (source-node/filename node) port))))))
+ source-nodes)
+ (if compiler:enable-integration-declarations?
+ (begin
+ (for-each
+ (lambda (node)
+ (let ((time (source-node/modification-time node)))
+ (if (and time
+ (there-exists? (source-node/dependencies node)
+ (lambda (node*)
+ (let ((newer?
+ (let ((time*
+ (source-node/modification-time node*)))
+ (or (not time*)
+ (> time* time)))))
+ (if newer?
+ (write-notification-line
+ (lambda (port)
+ (write-string "Binary file " port)
+ (write (source-node/filename node) port)
+ (write-string " newer than dependency "
+ port)
+ (write (source-node/filename node*)
+ port))))
+ newer?))))
+ (set-source-node/modification-time! node #f))))
+ source-nodes)
+ (for-each
+ (lambda (node)
+ (if (not (source-node/modification-time node))
+ (for-each (lambda (node*)
+ (if (source-node/modification-time node*)
+ (write-notification-line
+ (lambda (port)
+ (write-string "Binary file " port)
+ (write (source-node/filename node*) port)
+ (write-string " depends on " port)
+ (write (source-node/filename node) port))))
+ (set-source-node/modification-time! node* #f))
+ (source-node/forward-closure node))))
+ source-nodes)))
+ (for-each (lambda (node)
+ (if (not (source-node/modification-time node))
+ (pathname-delete!
+ (pathname-new-type (source-node/pathname node) "ext"))))
+ source-nodes/by-rank)
+ (write-notification-line
+ (lambda (port)
+ (write-string "Begin pass 1:" port)))
+ (for-each (lambda (node)
+ (if (not (source-node/modification-time node))
+ (source-node/syntax! node)))
+ source-nodes/by-rank)
+ (if (there-exists? source-nodes/by-rank
+ (lambda (node)
+ (and (not (source-node/modification-time node))
+ (source-node/circular? node))))
+ (begin
+ (write-notification-line
+ (lambda (port)
+ (write-string "Begin pass 2:" port)))
+ (for-each (lambda (node)
+ (if (not (source-node/modification-time node))
+ (if (source-node/circular? node)
+ (source-node/syntax! node)
+ (source-node/touch! node))))
+ source-nodes/by-rank))))
+\f
+(define (source-node/touch! node)
+ (receive (input-pathname bin-pathname spec-pathname)
+ (sf/pathname-defaulting (source-node/pathname node) "" #f)
+ input-pathname
+ (pathname-touch! bin-pathname)
+ (pathname-touch! (pathname-new-type bin-pathname "ext"))
+ (if spec-pathname (pathname-touch! spec-pathname))))
+
+(define (pathname-touch! pathname)
+ (if (file-exists? pathname)
+ (begin
+ (write-notification-line
+ (lambda (port)
+ (write-string "Touch file: " port)
+ (write (enough-namestring pathname) port)))
+ (file-touch pathname))))
+
+(define (pathname-delete! pathname)
+ (if (file-exists? pathname)
+ (begin
+ (write-notification-line
+ (lambda (port)
+ (write-string "Delete file: " port)
+ (write (enough-namestring pathname) port)))
+ (delete-file pathname))))
+
+(define (sc filename)
+ (maybe-setup-source-nodes!)
+ (source-node/syntax! (filename->source-node filename)))
+
+(define (source-node/syntax! node)
+ (receive (input-pathname bin-pathname spec-pathname)
+ (sf/pathname-defaulting (source-node/pathname node) "" #f)
+ (sf/internal
+ input-pathname bin-pathname spec-pathname
+ (source-node/syntax-table node)
+ ((if compiler:enable-integration-declarations?
+ identity-procedure
+ (lambda (declarations)
+ (list-transform-negative declarations
+ integration-declaration?)))
+ (source-node/declarations node)))))
+
+(define (modification-time node type)
+ (file-modification-time
+ (pathname-new-type (source-node/pathname node) type)))
+\f
+;;;; Syntax dependencies
+
+(define (initialize/syntax-dependencies!)
+ (let ((file-dependency/syntax/join
+ (lambda (filenames syntax-table)
+ (for-each (lambda (filename)
+ (set-source-node/syntax-table!
+ (filename->source-node filename)
+ syntax-table))
+ filenames))))
+ (file-dependency/syntax/join
+ (append (filename/append "base"
+ "toplev" "asstop" "crstop"
+ "blocks" "cfg1" "cfg2" "cfg3" "constr"
+ "contin" "ctypes" "debug" "enumer"
+ "infnew" "lvalue" "object" "pmerly" "proced"
+ "refctx" "rvalue" "scode" "sets" "subprb"
+ "switch" "utils")
+ (filename/append "back"
+ "asmmac" "bittop" "bitutl" "insseq" "lapgn1"
+ "lapgn2" "lapgn3" "linear" "regmap" "symtab"
+ "syntax")
+ (filename/append "machines/i386"
+ "dassm1" "insmac" "lapopt" "machin" "rgspcm"
+ "rulrew")
+ (filename/append "fggen"
+ "declar" "fggen" "canon")
+ (filename/append "fgopt"
+ "blktyp" "closan" "conect" "contan" "delint"
+ "desenv" "envopt" "folcon" "offset" "operan"
+ "order" "outer" "param" "reord" "reteqv" "reuse"
+ "sideff" "simapp" "simple" "subfre" "varind")
+ (filename/append "rtlbase"
+ "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp"
+ "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2"
+ "valclass")
+ (filename/append "rtlgen"
+ "fndblk" "fndvar" "opncod" "rgcomb" "rgproc"
+ "rgretn" "rgrval" "rgstmt" "rtlgen")
+ (filename/append "rtlopt"
+ "ralloc" "rcompr" "rcse1" "rcse2" "rcseep"
+ "rcseht" "rcserq" "rcsesr" "rdebug" "rdflow"
+ "rerite" "rinvex" "rlife" "rtlcsm"))
+ (->environment '(COMPILER)))
+ (file-dependency/syntax/join
+ (filename/append "machines/i386"
+ "lapgen"
+ "rules1" "rules2" "rules3" "rules4" "rulfix" "rulflo"
+ "insutl" "instr1" "instr2" "instrf")
+ (->environment '(COMPILER LAP-SYNTAXER)))))
+\f
+;;;; Integration Dependencies
+
+(define (initialize/integration-dependencies!)
+
+ (define (add-declaration! declaration filenames)
+ (for-each (lambda (filenames)
+ (let ((node (filename->source-node filenames)))
+ (set-source-node/declarations!
+ node
+ (cons declaration
+ (source-node/declarations node)))))
+ filenames))
+
+ (let* ((front-end-base
+ (filename/append "base"
+ "blocks" "cfg1" "cfg2" "cfg3"
+ "contin" "ctypes" "enumer" "lvalue"
+ "object" "proced" "rvalue"
+ "scode" "subprb" "utils"))
+ (i386-base
+ (append (filename/append "machines/i386" "machin")
+ (filename/append "back" "asutl")))
+ (rtl-base
+ (filename/append "rtlbase"
+ "rgraph" "rtlcfg" "rtlobj" "rtlreg" "rtlty1"
+ "rtlty2"))
+ (cse-base
+ (filename/append "rtlopt"
+ "rcse1" "rcseht" "rcserq" "rcsesr"))
+ (cse-all
+ (append (filename/append "rtlopt"
+ "rcse2" "rcseep")
+ cse-base))
+ (instruction-base
+ (filename/append "machines/i386" "assmd" "machin"))
+ (lapgen-base
+ (append (filename/append "back" "linear" "regmap")
+ (filename/append "machines/i386" "lapgen")))
+ (assembler-base
+ (append (filename/append "back" "symtab")
+ (filename/append "machines/i386" "insutl")))
+ (lapgen-body
+ (append
+ (filename/append "back" "lapgn1" "lapgn2" "syntax")
+ (filename/append "machines/i386"
+ "rules1" "rules2" "rules3" "rules4"
+ "rulfix" "rulflo")))
+ (assembler-body
+ (append
+ (filename/append "back" "bittop")
+ (filename/append "machines/i386"
+ "instr1" "instr2" "instrf"))))
+
+ (define (file-dependency/integration/join filenames dependencies)
+ (for-each (lambda (filename)
+ (file-dependency/integration/make filename dependencies))
+ filenames))
+
+ (define (file-dependency/integration/make filename dependencies)
+ (let ((node (filename->source-node filename)))
+ (for-each (lambda (dependency)
+ (let ((node* (filename->source-node dependency)))
+ (if (not (eq? node node*))
+ (source-node/link! node node*))))
+ dependencies)))
+
+ (define (define-integration-dependencies directory name directory* . names)
+ (file-dependency/integration/make
+ (string-append directory "/" name)
+ (apply filename/append directory* names)))
+
+ (define-integration-dependencies "machines/i386" "machin" "back" "asutl")
+ (define-integration-dependencies "base" "object" "base" "enumer")
+ (define-integration-dependencies "base" "enumer" "base" "object")
+ (define-integration-dependencies "base" "cfg1" "base" "object")
+ (define-integration-dependencies "base" "cfg2" "base"
+ "cfg1" "cfg3" "object")
+ (define-integration-dependencies "base" "cfg3" "base" "cfg1" "cfg2")
+ (define-integration-dependencies "base" "ctypes" "base"
+ "blocks" "cfg1" "cfg2" "cfg3" "contin" "lvalue" "object" "subprb")
+ (define-integration-dependencies "base" "rvalue" "base"
+ "blocks" "cfg1" "cfg2" "cfg3" "enumer" "lvalue" "object" "utils")
+ (define-integration-dependencies "base" "lvalue" "base"
+ "blocks" "object" "proced" "rvalue" "utils")
+ (define-integration-dependencies "base" "blocks" "base"
+ "enumer" "lvalue" "object" "proced" "rvalue")
+ (define-integration-dependencies "base" "proced" "base"
+ "blocks" "cfg1" "cfg2" "cfg3" "contin" "enumer" "lvalue" "object"
+ "rvalue" "utils")
+ (define-integration-dependencies "base" "contin" "base"
+ "blocks" "cfg3" "ctypes")
+ (define-integration-dependencies "base" "subprb" "base"
+ "cfg3" "contin" "enumer" "object" "proced")
+
+ (define-integration-dependencies "machines/i386" "machin" "rtlbase"
+ "rtlreg" "rtlty1" "rtlty2")
+
+ (define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2")
+ (define-integration-dependencies "rtlbase" "rgraph" "machines/i386"
+ "machin")
+ (define-integration-dependencies "rtlbase" "rtlcfg" "base"
+ "cfg1" "cfg2" "cfg3")
+ (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils")
+ (define-integration-dependencies "rtlbase" "rtlcon" "machines/i386"
+ "machin")
+ (file-dependency/integration/join (filename/append "rtlbase" "rtlcon")
+ rtl-base)
+ (define-integration-dependencies "rtlbase" "rtlexp" "rtlbase"
+ "rtlreg" "rtlty1")
+ (define-integration-dependencies "rtlbase" "rtline" "base" "cfg1" "cfg2")
+ (define-integration-dependencies "rtlbase" "rtline" "rtlbase"
+ "rtlcfg" "rtlty2")
+ (define-integration-dependencies "rtlbase" "rtlobj" "base"
+ "cfg1" "object" "utils")
+ (define-integration-dependencies "rtlbase" "rtlreg" "machines/i386"
+ "machin")
+ (define-integration-dependencies "rtlbase" "rtlreg" "rtlbase"
+ "rgraph" "rtlty1")
+ (define-integration-dependencies "rtlbase" "rtlty1" "rtlbase" "rtlcfg")
+ (define-integration-dependencies "rtlbase" "rtlty2" "machines/i386"
+ "machin")
+ (define-integration-dependencies "rtlbase" "rtlty2" "rtlbase" "rtlty1")
+
+ (file-dependency/integration/join
+ (append
+ (filename/append "base" "refctx")
+ (filename/append "fggen"
+ "declar" "fggen") ; "canon" needs no integrations
+ (filename/append "fgopt"
+ "blktyp" "closan" "conect" "contan" "delint" "desenv"
+ "envopt" "folcon" "offset" "operan" "order" "param"
+ "outer" "reuse" "reteqv" "sideff" "simapp" "simple"
+ "subfre" "varind"))
+ (append i386-base front-end-base))
+
+ (define-integration-dependencies "fgopt" "reuse" "fgopt" "reord")
+
+ (file-dependency/integration/join
+ (filename/append "rtlgen"
+ "fndblk" "fndvar" "opncod" "rgcomb" "rgproc" "rgretn"
+ "rgrval" "rgstmt" "rtlgen")
+ (append i386-base front-end-base rtl-base))
+
+ (file-dependency/integration/join
+ (append cse-all
+ (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow"
+ "rerite" "rinvex" "rlife" "rtlcsm")
+ (filename/append "machines/i386" "rulrew"))
+ (append i386-base rtl-base))
+
+ (file-dependency/integration/join cse-all cse-base)
+
+ (file-dependency/integration/join
+ (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife")
+ (filename/append "rtlbase" "regset"))
+
+ (file-dependency/integration/join
+ (filename/append "rtlopt" "rcseht" "rcserq")
+ (filename/append "base" "object"))
+
+ (define-integration-dependencies "rtlopt" "rlife" "base" "cfg2")
+
+ (let ((dependents
+ (append instruction-base
+ lapgen-base
+ lapgen-body
+ assembler-base
+ assembler-body
+ (filename/append "back" "linear" "syerly"))))
+ (add-declaration! '(USUAL-DEFINITION (SET EXPT)) dependents)
+ (file-dependency/integration/join dependents instruction-base))
+
+ (file-dependency/integration/join (append lapgen-base lapgen-body)
+ lapgen-base)
+
+ (file-dependency/integration/join (append assembler-base assembler-body)
+ assembler-base)
+
+ (define-integration-dependencies "back" "lapgn1" "base"
+ "cfg1" "cfg2" "utils")
+ (define-integration-dependencies "back" "lapgn1" "rtlbase"
+ "rgraph" "rtlcfg")
+ (define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg")
+ (define-integration-dependencies "back" "linear" "base" "cfg1" "cfg2")
+ (define-integration-dependencies "back" "linear" "rtlbase" "rtlcfg")
+ (define-integration-dependencies "back" "mermap" "back" "regmap")
+ (define-integration-dependencies "back" "regmap" "base" "utils")
+ (define-integration-dependencies "back" "symtab" "base" "utils"))
+
+ (for-each (lambda (node)
+ (let ((links (source-node/backward-links node)))
+ (if (not (null? links))
+ (set-source-node/declarations!
+ node
+ (cons (make-integration-declaration
+ (source-node/pathname node)
+ (map source-node/pathname links))
+ (source-node/declarations node))))))
+ source-nodes))
+
+(define (make-integration-declaration pathname integration-dependencies)
+ `(INTEGRATE-EXTERNAL
+ ,@(map (let ((default
+ (make-pathname
+ #f
+ #f
+ (cons 'RELATIVE
+ (make-list
+ (length (cdr (pathname-directory pathname)))
+ 'UP))
+ #f
+ #f
+ #f)))
+ (lambda (pathname)
+ (merge-pathnames pathname default)))
+ integration-dependencies)))
+
+(define (integration-declaration? declaration)
+ (eq? (car declaration) 'INTEGRATE-EXTERNAL))
\ 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;; i386 Instruction Set Macros. Early version
+;;; NOPs for now.
+
+(declare (usual-integrations))
+
+(define-syntax define-instruction
+ (non-hygienic-macro-transformer
+ (lambda (opcode . patterns)
+ `(SET! EARLY-INSTRUCTIONS
+ (CONS
+ (LIST ',opcode
+ ,@(map (lambda (pattern)
+ `(early-parse-rule
+ ',(car pattern)
+ (lambda (pat vars)
+ (early-make-rule
+ pat
+ vars
+ (scode-quote
+ (instruction->instruction-sequence
+ ,(parse-instruction (cadr pattern)
+ (cddr pattern)
+ #t)))))))
+ patterns))
+ EARLY-INSTRUCTIONS)))))
\ 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Intel 386 Instruction Set Macros
+
+(declare (usual-integrations))
+\f
+(define-syntax define-trivial-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ (if (syntax-match? '(IDENTIFIER DATUM * DATUM) (cdr form))
+ `(DEFINE-INSTRUCTION ,(cadr form)
+ (()
+ (BYTE (8 ,(close-syntax (caddr form) environment)))
+ ,@(map (lambda (extra)
+ `(BYTE (8 ,(close-syntax extra environment))))
+ (cdddr form))))
+ (ill-formed-syntax form)))))
+
+;;;; Effective addressing
+
+(define ea-database-name
+ 'EA-DATABASE)
+
+(define-syntax define-ea-database
+ (rsc-macro-transformer
+ (lambda (form environment)
+ `(,(close-syntax 'DEFINE environment)
+ ,ea-database-name
+ ,(compile-database (cdr form) environment
+ (lambda (pattern actions)
+ (let ((keyword (car pattern))
+ (categories (car actions))
+ (mode (cadr actions))
+ (register (caddr actions))
+ (tail (cdddr actions)))
+ `(,(close-syntax 'MAKE-EFFECTIVE-ADDRESS environment)
+ ',keyword
+ ',categories
+ ,(integer-syntaxer mode environment 'UNSIGNED 2)
+ ,(integer-syntaxer register environment 'UNSIGNED 3)
+ ,(if (null? tail)
+ `()
+ (process-fields tail #f environment))))))))))
+
+;; This one is necessary to distinguish between r/mW mW, etc.
+
+(define-syntax define-ea-transformer
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (if (syntax-match? '(IDENTIFIER ? SYMBOL) (cdr form))
+ `(DEFINE (,(cadr form) EXPRESSION)
+ (LET ((MATCH-RESULT (PATTERN-LOOKUP ,ea-database-name EXPRESSION)))
+ (AND MATCH-RESULT
+ ,(if (pair? (cddr form))
+ `(LET ((EA (MATCH-RESULT)))
+ (AND (MEMQ ',(caddr form) (EA/CATEGORIES EA))
+ EA))
+ `(MATCH-RESULT)))))
+ (ill-formed-syntax form)))))
+\f
+;; *** We can't really handle switching these right now. ***
+
+(define-integrable *ADDRESS-SIZE* 32)
+(define-integrable *OPERAND-SIZE* 32)
+
+(define (parse-instruction opcode tail early? environment)
+ (process-fields (cons opcode tail) early? environment))
+
+(define (process-fields fields early? environment)
+ (if (and (null? (cdr fields))
+ (eq? (caar fields) 'VARIABLE-WIDTH))
+ (expand-variable-width (car fields) early? environment)
+ (call-with-values (lambda () (expand-fields fields early? environment))
+ (lambda (code size)
+ (if (not (zero? (remainder size 8)))
+ (error "Bad syllable size:" size))
+ code))))
+
+(define (expand-variable-width field early? environment)
+ (let ((binding (cadr field))
+ (clauses (cddr field)))
+ `(,(close-syntax 'LIST environment)
+ ,(variable-width-expression-syntaxer
+ (car binding)
+ (cadr binding)
+ environment
+ (map (lambda (clause)
+ (call-with-values
+ (lambda () (expand-fields (cdr clause) early? environment))
+ (lambda (code size)
+ (if (not (zero? (remainder size 8)))
+ (error "Bad clause size:" size))
+ `(,code ,size ,@(car clause)))))
+ clauses)))))
+\f
+(define (expand-fields fields early? environment)
+ (if (pair? fields)
+ (call-with-values
+ (lambda () (expand-fields (cdr fields) early? environment))
+ (lambda (tail tail-size)
+ (case (caar fields)
+ ;; For opcodes and fixed fields of the instruction
+ ((BYTE)
+ ;; (BYTE (8 #xff))
+ ;; (BYTE (16 (+ foo #x23) SIGNED))
+ (call-with-values
+ (lambda ()
+ (collect-byte (cdar fields) tail environment))
+ (lambda (code size)
+ (values code (+ size tail-size)))))
+ ((ModR/M)
+ ;; (ModR/M 2 source) = /2 r/m(source)
+ ;; (ModR/M r target) = /r r/m(target)
+ (if early?
+ (error "No early support for ModR/M -- Fix i386/insmac.scm"))
+ (let ((field (car fields)))
+ (let ((digit-or-reg (cadr field))
+ (r/m (caddr field)))
+ (values `(,(close-syntax 'CONS-SYNTAX environment)
+ (,(close-syntax 'EA/REGISTER environment) ,r/m)
+ (,(close-syntax 'CONS-SYNTAX environment)
+ ,(integer-syntaxer digit-or-reg environment
+ 'UNSIGNED 3)
+ (,(close-syntax 'CONS-SYNTAX environment)
+ (,(close-syntax 'EA/MODE environment) ,r/m)
+ (,(close-syntax 'APPEND-SYNTAX! environment)
+ (,(close-syntax 'EA/EXTRA environment) ,r/m)
+ ,tail))))
+ (+ 8 tail-size)))))
+ ;; For immediate operands whose size depends on the operand
+ ;; size for the instruction (halfword vs. longword)
+ ((IMMEDIATE)
+ (values
+ (let ((field (car fields)))
+ (let ((value (cadr field))
+ (mode (if (pair? (cddr field)) (caddr field) 'OPERAND))
+ (domain
+ (if (and (pair? (cddr field)) (pair? (cdddr field)))
+ (cadddr field)
+ 'SIGNED)))
+ `(,(close-syntax 'CONS-SYNTAX environment)
+ ,(integer-syntaxer
+ value
+ environment
+ domain
+ (case mode
+ ((OPERAND) *operand-size*)
+ ((ADDRESS) *address-size*)
+ (else (error "Unknown IMMEDIATE mode:" mode))))
+ ,tail)))
+ tail-size))
+ (else
+ (error "Unknown field kind:" (caar fields))))))
+ (values `'() 0)))
+
+(define (collect-byte components tail environment)
+ (let loop ((components components))
+ (if (pair? components)
+ (call-with-values (lambda () (loop (cdr components)))
+ (lambda (byte-tail byte-size)
+ (let ((size (caar components))
+ (expression (cadar components))
+ (type (if (pair? (cddar components))
+ (caddar components)
+ 'UNSIGNED)))
+ (values `(,(close-syntax 'CONS-SYNTAX environment)
+ ,(integer-syntaxer expression environment type size)
+ ,byte-tail)
+ (+ size byte-size)))))
+ (values tail 0))))
\ 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Intel i386 Instruction Set, part I
+;;; package: (compiler lap-syntaxer)
+
+;; Some of the instructions have their operands ill-specified in the
+;; i486 book. Check against the appendices or the i386 book.
+
+(declare (usual-integrations))
+\f
+;;;; Pseudo ops
+
+(define-instruction BYTE
+ ((S (? value))
+ (BYTE (8 value SIGNED)))
+ ((U (? value))
+ (BYTE (8 value UNSIGNED))))
+
+(define-instruction WORD
+ ((S (? value))
+ (BYTE (16 value SIGNED)))
+ ((U (? value))
+ (BYTE (16 value UNSIGNED))))
+
+(define-instruction LONG
+ ((S (? value))
+ (BYTE (32 value SIGNED)))
+ ((U (? value))
+ (BYTE (32 value UNSIGNED))))
+
+;;;; Actual instructions
+
+(define-trivial-instruction AAA #x37)
+(define-trivial-instruction AAD #xd5 #x0a)
+(define-trivial-instruction AAM #xd4 #x0a)
+(define-trivial-instruction AAS #x3f)
+\f
+(let-syntax
+ ((define-arithmetic-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (cadr form))
+ (opcode (caddr form))
+ (digit (cadddr form)))
+ `(define-instruction ,mnemonic
+ ((W (? target r/mW) (R (? source)))
+ (BYTE (8 ,(+ opcode 1)))
+ (ModR/M source target))
+
+ ((W (R (? target)) (? source r/mW))
+ (BYTE (8 ,(+ opcode 3)))
+ (ModR/M target source))
+
+ ((W (? target r/mW) (& (? value sign-extended-byte)))
+ (BYTE (8 #x83))
+ (ModR/M ,digit target)
+ (BYTE (8 value SIGNED)))
+
+ ((W (R 0) (& (? value))) ; AX/EAX
+ (BYTE (8 ,(+ opcode 5)))
+ (IMMEDIATE value))
+
+ ((W (? target r/mW) (& (? value)))
+ (BYTE (8 #x81))
+ (ModR/M ,digit target)
+ (IMMEDIATE value))
+
+ ((W (? target r/mW) (&U (? value zero-extended-byte)))
+ (BYTE (8 #x83))
+ (ModR/M ,digit target)
+ (BYTE (8 value UNSIGNED)))
+
+ ((W (R 0) (&U (? value))) ; AX/EAX
+ (BYTE (8 ,(+ opcode 5)))
+ (IMMEDIATE value OPERAND UNSIGNED))
+
+ ((W (? target r/mW) (&U (? value)))
+ (BYTE (8 #x81))
+ (ModR/M ,digit target)
+ (IMMEDIATE value OPERAND UNSIGNED))
+
+ ((B (? target r/mB) (R (? source)))
+ (BYTE (8 ,opcode))
+ (ModR/M source target))
+
+ ((B (R (? target)) (? source r/mB))
+ (BYTE (8 ,(+ opcode 2)))
+ (ModR/M target source))
+
+ ((B (R 0) (& (? value))) ; AL
+ (BYTE (8 ,(+ opcode 4))
+ (8 value SIGNED)))
+
+ ((B (R 0) (&U (? value))) ; AL
+ (BYTE (8 ,(+ opcode 4))
+ (8 value UNSIGNED)))
+
+ ((B (? target r/mB) (& (? value)))
+ (BYTE (8 #x80))
+ (ModR/M ,digit target)
+ (BYTE (8 value SIGNED)))
+
+ ((B (? target r/mB) (&U (? value)))
+ (BYTE (8 #x80))
+ (ModR/M ,digit target)
+ (BYTE (8 value UNSIGNED)))))))))
+
+ (define-arithmetic-instruction ADC #x10 2)
+ (define-arithmetic-instruction ADD #x00 0)
+ (define-arithmetic-instruction AND #x20 4)
+ (define-arithmetic-instruction CMP #x38 7)
+ (define-arithmetic-instruction OR #x08 1)
+ (define-arithmetic-instruction SBB #x18 3)
+ (define-arithmetic-instruction SUB #x28 5)
+ (define-arithmetic-instruction XOR #x30 6))
+\f
+(define-instruction ARPL
+ (((? target r/mW) (R (? source)))
+ (BYTE (8 #x63))
+ (ModR/M source target)))
+
+(define-instruction BOUND
+ (((R (? source)) (? bounds mW))
+ (BYTE (8 #x62))
+ (ModR/M source bounds)))
+
+(define-instruction BSF
+ (((R (? target)) (? source r/mW))
+ (BYTE (8 #x0f)
+ (8 #xbc))
+ (ModR/M target source)))
+
+(define-instruction BSR
+ (((R (? target)) (? source r/mW))
+ (BYTE (8 #x0f)
+ (8 #xbd))
+ (ModR/M target source)))
+
+(define-instruction BSWAP ; 486 only
+ (((R (? reg)))
+ (BYTE (8 #x0f)
+ (8 (+ #xc8 reg)))))
+
+(let-syntax
+ ((define-bit-test-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (cadr form))
+ (opcode (caddr form))
+ (digit (cadddr form)))
+ `(define-instruction ,mnemonic
+
+ (((? target r/mW) (& (? posn)))
+ (BYTE (8 #x0f)
+ (8 #xba))
+ (ModR/M ,digit target)
+ (BYTE (8 posn UNSIGNED)))
+
+ (((? target r/mW) (R (? posn)))
+ (BYTE (8 #x0f)
+ (8 ,opcode))
+ (ModR/M posn target))))))))
+
+ (define-bit-test-instruction BT #xa3 4)
+ (define-bit-test-instruction BTC #xbb 7)
+ (define-bit-test-instruction BTR #xb3 6)
+ (define-bit-test-instruction BTS #xab 5))
+\f
+(define-instruction CALL
+ (((@PCR (? dest)))
+ (BYTE (8 #xe8))
+ (IMMEDIATE `(- ,dest (+ *PC* 4)) ADDRESS)) ; fcn(*ADDRESS-SIZE*)
+
+ (((@PCRO (? dest) (? offset)))
+ (BYTE (8 #xe8))
+ (IMMEDIATE `(- (+ ,dest ,offset) (+ *PC* 4)) ADDRESS)); fcn(*ADDRESS-SIZE*)
+
+ (((@PCO (? displ)))
+ (BYTE (8 #xe8))
+ (IMMEDIATE displ ADDRESS))
+
+ (((? dest r/mW))
+ (BYTE (8 #xff))
+ (ModR/M 2 dest))
+
+ ((F (? dest mW))
+ (BYTE (8 #xff))
+ (ModR/M 3 dest))
+
+ ((F (SEGMENT (? seg)) (OFFSET (? off)))
+ (BYTE (8 #x9a))
+ (BYTE (16 seg))
+ (IMMEDIATE off ADDRESS)))
+
+(define-trivial-instruction CBW #x98)
+(define-trivial-instruction CWDE #x98)
+(define-trivial-instruction CLC #xf8)
+(define-trivial-instruction CLD #xfc)
+(define-trivial-instruction CLI #xfa)
+(define-trivial-instruction CLTS #x0f #x06)
+(define-trivial-instruction CMC #xf5)
+
+(let-syntax
+ ((define-string-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (cadr form))
+ (opcode (caddr form)))
+ `(define-instruction ,mnemonic
+
+ ((W)
+ (BYTE (8 ,(+ opcode 1))))
+
+ ((B)
+ (BYTE (8 ,opcode)))))))))
+
+ (define-string-instruction CMPS #xa6)
+ (define-string-instruction LODS #xac)
+ (define-string-instruction INS #x6c)
+ (define-string-instruction MOVS #xa4)
+ (define-string-instruction OUTS #x6e)
+ (define-string-instruction SCAS #xae)
+ (define-string-instruction STOS #xaa))
+
+(define-instruction CMPXCHG ; 486 only
+ ((W (? target r/mW) (R (? reg)))
+ (BYTE (8 #x0f)
+ (8 #xa7))
+ (ModR/M reg target))
+
+ ((B (? target r/mB) (R (? reg)))
+ (BYTE (8 #x0f)
+ (8 #xa6))
+ (ModR/M reg target)))
+
+(define-trivial-instruction CPUID #x0F #xA2)
+
+(define-trivial-instruction CWD #x99)
+(define-trivial-instruction CDQ #x99)
+(define-trivial-instruction DAA #x27)
+(define-trivial-instruction DAS #x2f)
+\f
+(let-syntax
+ ((define-inc/dec
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (cadr form))
+ (digit (caddr form))
+ (opcode (cadddr form)))
+ `(define-instruction ,mnemonic
+ ((W (R (? reg)))
+ (BYTE (8 (+ ,opcode reg))))
+
+ ((W (? target r/mW))
+ (BYTE (8 #xff))
+ (ModR/M ,digit target))
+
+ ((B (? target r/mB))
+ (BYTE (8 #xfe))
+ (ModR/M ,digit target))))))))
+
+ (define-inc/dec DEC 1 #x48)
+ (define-inc/dec INC 0 #x40))
+
+(let-syntax
+ ((define-mul/div
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (cadr form))
+ (digit (caddr form)))
+ `(define-instruction ,mnemonic
+ ((W (R 0) (? operand r/mW))
+ (BYTE (8 #xf7))
+ (ModR/M ,digit operand))
+
+ ((B (R 0) (? operand r/mB))
+ (BYTE (8 #xf6))
+ (ModR/M ,digit operand))))))))
+
+ (define-mul/div DIV 6)
+ (define-mul/div IDIV 7)
+ (define-mul/div MUL 4))
+
+(define-instruction ENTER
+ (((& (? frame-size)) (& (? lexical-level)))
+ (BYTE (8 #xc8)
+ (16 frame-size)
+ (8 lexical-level))))
+
+(define-trivial-instruction HLT #xf4)
+
+(define-instruction IMUL
+ ((W (R (? target)) (? source r/mW))
+ (BYTE (8 #x0f)
+ (8 #xaf))
+ (ModR/M target source))
+
+ ((W (R (? target)) (? source r/mW) (& (? value sign-extended-byte)))
+ (BYTE (8 #x6b))
+ (ModR/M target source)
+ (BYTE (8 value SIGNED)))
+
+ ((W (R (? target)) (? source r/mW) (& (? value)))
+ (BYTE (8 #x69))
+ (ModR/M target source)
+ (IMMEDIATE value))
+
+ ((W (R (? target)) (? source r/mW) (&U (? value zero-extended-byte)))
+ (BYTE (8 #x6b))
+ (ModR/M target source)
+ (BYTE (8 value UNSIGNED)))
+
+ ((W (R (? target)) (? source r/mW) (&U (? value)))
+ (BYTE (8 #x69))
+ (ModR/M target source)
+ (IMMEDIATE value OPERAND UNSIGNED))
+\f
+ ((W ((R 2) : (R 0)) (? source r/mW))
+ (BYTE (8 #xf7))
+ (ModR/M 5 source))
+
+ ((B (R 0) (? source r/mB))
+ (BYTE (8 #xf6))
+ (ModR/M 5 source)))
+
+(define-instruction IN
+ ((W (R 0) (& (? port)))
+ (BYTE (8 #xe5)
+ (8 port)))
+
+ ((W (R 0) (R 2))
+ (BYTE (8 #xed)))
+
+ ((B (R 0) (& (? port)))
+ (BYTE (8 #xe4)
+ (8 port)))
+
+ ((B (R 0) (R 2))
+ (BYTE (8 #xec))))
+
+(define-instruction INT
+ ((3)
+ (BYTE (8 #xcc)))
+
+ (((& (? vector)))
+ (BYTE (8 #xcd)
+ (8 vector))))
+
+(define-trivial-instruction INTO #xce)
+(define-trivial-instruction INVD #x0f #x08) ; 486 only
+(define-trivial-instruction IRET #xcf)
+\f
+(let-syntax
+ ((define-jump-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (cadr form))
+ (opcode1 (caddr form))
+ (opcode2 (cadddr form)))
+ `(define-instruction ,mnemonic
+ ;; This assumes that *ADDRESS-SIZE* is 4 (32-bit mode)
+ (((@PCR (? dest)))
+ (VARIABLE-WIDTH
+ (disp `(- ,dest (+ *PC* 2)))
+ ((-128 127)
+ (BYTE (8 ,opcode1)
+ (8 disp SIGNED)))
+ ((() ())
+ (BYTE (8 #x0f)
+ (8 ,opcode2)
+ (32 (- disp 4) SIGNED)))))
+
+ ((B (@PCR (? dest)))
+ (BYTE (8 ,opcode1)
+ (8 `(- ,dest (+ *PC* 1)) SIGNED)))
+
+ ((W (@PCR (? dest)))
+ (BYTE (8 #x0f)
+ (8 ,opcode2))
+ (IMMEDIATE `(- ,dest (+ *PC* 4)) ADDRESS)) ; fcn(*ADDRESS-SIZE*)
+
+ ((B (@PCO (? displ)))
+ (BYTE (8 ,opcode1)
+ (8 displ SIGNED)))
+
+ ((W (@PCO (? displ)))
+ (BYTE (8 #x0f)
+ (8 ,opcode2))
+ (IMMEDIATE displ ADDRESS))))))))
+
+ (define-jump-instruction JA #x77 #x87)
+ (define-jump-instruction JAE #x73 #x83)
+ (define-jump-instruction JB #x72 #x82)
+ (define-jump-instruction JBE #x76 #x86)
+ (define-jump-instruction JC #x72 #x82)
+ (define-jump-instruction JE #x74 #x84)
+ (define-jump-instruction JG #x7f #x8f)
+ (define-jump-instruction JGE #x7d #x8d)
+ (define-jump-instruction JL #x7c #x8c)
+ (define-jump-instruction JLE #x7e #x8e)
+ (define-jump-instruction JNA #x76 #x86)
+ (define-jump-instruction JNAE #x72 #x82)
+ (define-jump-instruction JNB #x73 #x83)
+ (define-jump-instruction JNBE #x77 #x87)
+ (define-jump-instruction JNC #x73 #x83)
+ (define-jump-instruction JNE #x75 #x85)
+ (define-jump-instruction JNG #x7e #x8e)
+ (define-jump-instruction JNGE #x7c #x8c)
+ (define-jump-instruction JNL #x7d #x8d)
+ (define-jump-instruction JNLE #x7f #x8f)
+ (define-jump-instruction JNO #x71 #x81)
+ (define-jump-instruction JNP #x7b #x8b)
+ (define-jump-instruction JNS #x79 #x89)
+ (define-jump-instruction JNZ #x75 #x85)
+ (define-jump-instruction JO #x70 #x80)
+ (define-jump-instruction JP #x7a #x8a)
+ (define-jump-instruction JPE #x7a #x8a)
+ (define-jump-instruction JPO #x7b #x8b)
+ (define-jump-instruction JS #x78 #x88)
+ (define-jump-instruction JZ #x74 #x84))
+\f
+(let-syntax
+ ((define-loop-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (cadr form))
+ (opcode (caddr form)))
+ `(define-instruction ,mnemonic
+ ((B (@PCR (? dest)))
+ (BYTE (8 ,opcode)
+ (8 `(- ,dest (+ *PC* 1)) SIGNED)))
+
+ ((B (@PCO (? displ)))
+ (BYTE (8 ,opcode)
+ (8 displ SIGNED)))))))))
+
+ (define-loop-instruction JCXZ #xe3)
+ (define-loop-instruction JECXZ #xe3)
+ (define-loop-instruction LOOP #xe2)
+ (define-loop-instruction LOOPE #xe1)
+ (define-loop-instruction LOOPZ #xe1)
+ (define-loop-instruction LOOPNE #xe0)
+ (define-loop-instruction LOOPNZ #xe0))
+
+(define-instruction JMP
+ ;; This assumes that *ADDRESS-SIZE* is 4 (32-bit mode)
+ (((@PCR (? dest)))
+ (VARIABLE-WIDTH
+ (disp `(- ,dest (+ *PC* 2)))
+ ((-128 127)
+ (BYTE (8 #xeb)
+ (8 disp SIGNED)))
+ ((() ())
+ (BYTE (8 #xe9)
+ (32 (- disp 3) SIGNED)))))
+
+ (((@PCRO (? dest) (? offset)))
+ (VARIABLE-WIDTH
+ (disp `(- (+ ,dest ,offset) (+ *PC* 2)))
+ ((-128 127)
+ (BYTE (8 #xeb)
+ (8 disp SIGNED)))
+ ((() ())
+ (BYTE (8 #xe9)
+ (32 (- disp 3) SIGNED)))))
+
+ (((? dest r/mW))
+ (BYTE (8 #xff))
+ (ModR/M 4 dest))
+
+ ((B (@PCR (? dest)))
+ (BYTE (8 #xeb)
+ (8 `(- ,dest (+ *PC* 1)) SIGNED)))
+
+ ((W (@PCR (? dest)))
+ (BYTE (8 #xe9))
+ (IMMEDIATE `(- ,dest (+ *PC* 4)) ADDRESS)) ; fcn(*ADDRESS-SIZE*)
+
+ ((B (@PCO (? displ)))
+ (BYTE (8 #xeb)
+ (8 displ SIGNED)))
+
+ ((W (@PCO (? displ)))
+ (BYTE (8 #xe9))
+ (IMMEDIATE displ ADDRESS))
+
+ ((F (? dest mW))
+ (BYTE (8 #xff))
+ (ModR/M 5 dest))
+
+ ((F (SEGMENT (? seg)) (OFFSET (? off)))
+ (BYTE (8 #xea))
+ (BYTE (16 seg))
+ (IMMEDIATE off ADDRESS)))
+\f
+(define-trivial-instruction LAHF #x9f)
+
+(define-instruction LAR
+ (((R (? target)) (? source r/mW))
+ (BYTE (8 #x0f)
+ (8 #x02))
+ (ModR/M target source)))
+
+(define-instruction LEA
+ (((R (? target)) (? source mW))
+ (BYTE (8 #x8d))
+ (ModR/M target source)))
+
+(define-trivial-instruction LEAVE #xc9)
+
+(let-syntax
+ ((define-load/store-state
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (cadr form))
+ (opcode (caddr form))
+ (digit (cadddr form)))
+ `(define-instruction ,mnemonic
+ (((? operand mW))
+ (BYTE (8 #x0f)
+ (8 ,opcode))
+ (ModR/M ,digit operand))))))))
+
+ (define-load/store-state INVLPG #x01 7) ; 486 only
+ (define-load/store-state LGDT #x01 2)
+ (define-load/store-state LIDT #x01 3)
+ (define-load/store-state LLDT #x00 2)
+ (define-load/store-state LMSW #x01 6)
+ (define-load/store-state LTR #x00 3)
+ (define-load/store-state SGDT #x01 0)
+ (define-load/store-state SIDT #x01 1)
+ (define-load/store-state SLDT #x00 0)
+ (define-load/store-state SMSW #x01 4)
+ (define-load/store-state STR #x00 1)
+ (define-load/store-state VERR #x00 4)
+ (define-load/store-state VERW #x00 5))
\ 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Intel i386 Instruction Set, part II
+;;; package: (compiler lap-syntaxer)
+
+;; Some of the instructions have their operands ill-specified in the
+;; i486 book. Check against the appendices or the i386 book.
+
+(declare (usual-integrations))
+\f
+;;;; Actual instructions
+
+(let-syntax
+ ((define-load-segment
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (cadr form))
+ (bytes (cddr form)))
+ `(define-instruction ,mnemonic
+ (((R (? reg)) (? pointer mW))
+ (BYTE ,@(map (lambda (byte)
+ `(8 ,byte))
+ bytes))
+ (ModR/M reg pointer))))))))
+
+ (define-load-segment LDS #xc5)
+ (define-load-segment LSS #x0f #xb2)
+ (define-load-segment LES #xc4)
+ (define-load-segment LFS #x0f #xb4)
+ (define-load-segment LGS #x0f #xb5))
+
+(define-instruction LSL
+ (((R (? reg)) (? source r/mW))
+ (BYTE (8 #x0f)
+ (8 #x03))
+ (ModR/M reg source)))
+
+(let-syntax
+ ((define-data-extension
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (cadr form))
+ (opcode (caddr form)))
+ `(define-instruction ,mnemonic
+ ((B (R (? target)) (? source r/mB))
+ (BYTE (8 #x0f)
+ (8 ,opcode))
+ (ModR/M target source))
+
+ ((H (R (? target)) (? source r/mW))
+ (BYTE (8 #x0f)
+ (8 ,(1+ opcode)))
+ (ModR/M target source))))))))
+
+ (define-data-extension MOVSX #xbe)
+ (define-data-extension MOVZX #xb6))
+
+(let-syntax
+ ((define-unary
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (cadr form))
+ (digit (caddr form)))
+ `(define-instruction ,mnemonic
+ ((W (? operand r/mW))
+ (BYTE (8 #xf7))
+ (ModR/M ,digit operand))
+
+ ((B (? operand r/mB))
+ (BYTE (8 #xf6))
+ (ModR/M ,digit operand))))))))
+
+ (define-unary NEG 3)
+ (define-unary NOT 2))
+\f
+(define-instruction MOV
+ ((W (R (? target)) (? source r/mW))
+ (BYTE (8 #x8b))
+ (ModR/M target source))
+
+ ((W (? target r/mW) (R (? source)))
+ (BYTE (8 #x89))
+ (ModR/M source target))
+
+ ((W (R (? reg)) (& (? value)))
+ (BYTE (8 (+ #xb8 reg)))
+ (IMMEDIATE value))
+
+ ((W (? target r/mW) (& (? value)))
+ (BYTE (8 #xc7))
+ (ModR/M 0 target)
+ (IMMEDIATE value))
+
+ ((W (R (? reg)) (&U (? value)))
+ (BYTE (8 (+ #xb8 reg)))
+ (IMMEDIATE value OPERAND UNSIGNED))
+
+ ((W (? target r/mW) (&U (? value)))
+ (BYTE (8 #xc7))
+ (ModR/M 0 target)
+ (IMMEDIATE value OPERAND UNSIGNED))
+
+ ((B (R (? target)) (? source r/mB))
+ (BYTE (8 #x8a))
+ (ModR/M target source))
+
+ ((B (? target r/mB) (R (? source)))
+ (BYTE (8 #x88))
+ (ModR/M source target))
+
+ ((B (R (? reg)) (& (? value)))
+ (BYTE (8 (+ #xb0 reg))
+ (8 value SIGNED)))
+
+ ((B (? target r/mB) (& (? value)))
+ (BYTE (8 #xc6))
+ (ModR/M 0 target)
+ (BYTE (8 value SIGNED)))
+
+ ((B (R (? reg)) (&U (? value)))
+ (BYTE (8 (+ #xb0 reg))
+ (8 value UNSIGNED)))
+
+ ((B (? target r/mB) (&U (? value)))
+ (BYTE (8 #xc6))
+ (ModR/M 0 target)
+ (BYTE (8 value UNSIGNED)))
+
+ ((W (R 0) (@ (? offset)))
+ (BYTE (8 #xa1))
+ (IMMEDIATE offset))
+
+ ((W (@ (? offset)) (R 0))
+ (BYTE (8 #xa3))
+ (IMMEDIATE offset))
+
+ ((B (R 0) (@ (? offset)))
+ (BYTE (8 #xa0)
+ (8 offset SIGNED)))
+
+ ((B (@ (? offset)) (R 0))
+ (BYTE (8 #xa2)
+ (8 offset SIGNED)))
+\f
+ (((? target r/mW) (SR (? source)))
+ (BYTE (8 #x8c))
+ (ModR/M source target))
+
+ (((SR (? target)) (? source r/mW))
+ (BYTE (8 #x8e))
+ (ModR/M target source))
+
+ (((CR (? creg)) (R (? reg)))
+ (BYTE (8 #x0f)
+ (8 #x22))
+ (ModR/M creg `(R ,reg)))
+
+ (((R (? reg)) (CR (? creg)))
+ (BYTE (8 #x0f)
+ (8 #x20))
+ (ModR/M creg `(R ,reg)))
+
+ (((DR (? dreg)) (R (? reg)))
+ (BYTE (8 #x0f)
+ (8 #x23))
+ (ModR/M dreg `(R ,reg)))
+
+ (((R (? reg)) (DR (? dreg)))
+ (BYTE (8 #x0f)
+ (8 #x21))
+ (ModR/M dreg `(R ,reg)))
+
+ (((TR (? treg)) (R (? reg)))
+ (BYTE (8 #x0f)
+ (8 #x26))
+ (ModR/M treg `(R ,reg)))
+
+ (((R (? reg)) (TR (? treg)))
+ (BYTE (8 #x0f)
+ (8 #x24))
+ (ModR/M treg `(R ,reg))))
+\f
+(define-trivial-instruction NOP #x90)
+
+(define-instruction OUT
+ ((W (& (? port)) (R 0))
+ (BYTE (8 #xe7)
+ (8 port)))
+
+ ((W (R 2) (R 0))
+ (BYTE (8 #xef)))
+
+ ((B (& (? port)) (R 0))
+ (BYTE (8 #xe6)
+ (8 port)))
+
+ ((B (R 2) (R 0))
+ (BYTE (8 #xee))))
+
+(define-instruction POP
+ (((R (? target)))
+ (BYTE (8 (+ #x58 target))))
+
+ (((? target mW))
+ (BYTE (8 #x8f))
+ (ModR/M 0 target))
+
+ ((ES)
+ (BYTE (8 #x07)))
+
+ ((SS)
+ (BYTE (8 #x17)))
+
+ ((DS)
+ (BYTE (8 #x1f)))
+
+ ((FS)
+ (BYTE (8 #x0f)
+ (8 #xa1)))
+
+ ((GS)
+ (BYTE (8 #x0f)
+ (8 #xa9)))
+
+ (((SR 0))
+ (BYTE (8 #x07)))
+
+ (((SR 2))
+ (BYTE (8 #x17)))
+
+ (((SR 3))
+ (BYTE (8 #x1f)))
+
+ (((SR 4))
+ (BYTE (8 #x0f)
+ (8 #xa1)))
+
+ (((SR 5))
+ (BYTE (8 #x0f)
+ (8 #xa9))))
+
+(define-trivial-instruction POPA #x61)
+(define-trivial-instruction POPAD #x61)
+(define-trivial-instruction POPF #x9d)
+(define-trivial-instruction POPFD #x9d)
+\f
+(define-instruction PUSH
+ (((R (? source)))
+ (BYTE (8 (+ #x50 source))))
+
+ (((? source mW))
+ (BYTE (8 #xff))
+ (ModR/M 6 source))
+
+ ((W (& (? value)))
+ (BYTE (8 #x68))
+ (IMMEDIATE value))
+
+ ((W (&U (? value)))
+ (BYTE (8 #x68))
+ (IMMEDIATE value OPERAND UNSIGNED))
+
+ ((B (& (? value)))
+ (BYTE (8 #x6a)
+ (8 value)))
+
+ ((B (&U (? value)))
+ (BYTE (8 #x6a)
+ (8 value UNSIGNED)))
+
+ ((ES)
+ (BYTE (8 #x06)))
+
+ ((CS)
+ (BYTE (8 #x0e)))
+
+ ((SS)
+ (BYTE (8 #x16)))
+
+ ((DS)
+ (BYTE (8 #x1e)))
+
+ ((FS)
+ (BYTE (8 #x0f)
+ (8 #xa0)))
+
+ ((GS)
+ (BYTE (8 #x0f)
+ (8 #xa8)))
+
+ (((SR 0))
+ (BYTE (8 #x06)))
+
+ (((SR 1))
+ (BYTE (8 #x0e)))
+
+ (((SR 2))
+ (BYTE (8 #x16)))
+
+ (((SR 3))
+ (BYTE (8 #x1e)))
+
+ (((SR 4))
+ (BYTE (8 #x0f)
+ (8 #xa0)))
+
+ (((SR 5))
+ (BYTE (8 #x0f)
+ (8 #xa8))))
+
+(define-trivial-instruction PUSHA #x60)
+(define-trivial-instruction PUSHAD #x60)
+(define-trivial-instruction PUSHF #x9c)
+(define-trivial-instruction PUSHFD #x9c)
+\f
+(let-syntax
+ ((define-rotate/shift
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (cadr form))
+ (digit (caddr form)))
+ `(define-instruction ,mnemonic
+ ((W (? operand r/mW) (& 1))
+ (BYTE (8 #xd1))
+ (ModR/M ,digit operand))
+
+ ((W (? operand r/mW) (& (? value)))
+ (BYTE (8 #xc1))
+ (ModR/M ,digit operand)
+ (BYTE (8 value)))
+
+ ((W (? operand r/mW) (R 1))
+ (BYTE (8 #xd3))
+ (ModR/M ,digit operand))
+
+ ((B (? operand r/mB) (& 1))
+ (BYTE (8 #xd0))
+ (ModR/M ,digit operand))
+
+ ((B (? operand r/mB) (& (? value)))
+ (BYTE (8 #xc0))
+ (ModR/M ,digit operand)
+ (BYTE (8 value)))
+
+ ((B (? operand r/mB) (R 1))
+ (BYTE (8 #xd2))
+ (ModR/M ,digit operand))))))))
+
+ (define-rotate/shift RCL 2)
+ (define-rotate/shift RCR 3)
+ (define-rotate/shift ROL 0)
+ (define-rotate/shift ROR 1)
+ (define-rotate/shift SAL 4)
+ (define-rotate/shift SAR 7)
+ (define-rotate/shift SHL 4)
+ (define-rotate/shift SHR 5))
+
+(let-syntax
+ ((define-double-shift
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((mnemonic (cadr form))
+ (opcode (caddr form)))
+ `(define-instruction ,mnemonic
+ ((W (? target r/mW) (R (? source)) (& (? count)))
+ (BYTE (8 #x0f)
+ (8 ,opcode))
+ (ModR/M target source)
+ (BYTE (8 count)))
+
+ ((W (? target r/mW) (R (? source)) (R 1))
+ (BYTE (8 #x0f)
+ (8 ,(1+ opcode)))
+ (ModR/M target source))))))))
+
+ (define-double-shift SHLD #xa4)
+ (define-double-shift SHRD #xac))
+\f
+(define-instruction RET
+ (()
+ (BYTE (8 #xc3)))
+
+ ((F)
+ (BYTE (8 #xcb)))
+
+ (((& (? frame-size)))
+ (BYTE (8 #xc2)
+ (16 frame-size)))
+
+ ((F (& (? frame-size)))
+ (BYTE (8 #xca)
+ (16 frame-size))))
+
+(define-trivial-instruction SAHF #x9e)
+
+(let-syntax
+ ((define-setcc-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (cadr form))
+ (opcode (caddr form)))
+ `(define-instruction ,mnemonic
+ (((? target r/mB))
+ (BYTE (8 #x0f)
+ (8 ,opcode))
+ (ModR/M 0 target)))))))) ; 0?
+
+ (define-setcc-instruction SETA #x97)
+ (define-setcc-instruction SETAE #x93)
+ (define-setcc-instruction SETB #x92)
+ (define-setcc-instruction SETBE #x96)
+ (define-setcc-instruction SETC #x92)
+ (define-setcc-instruction SETE #x94)
+ (define-setcc-instruction SETG #x9f)
+ (define-setcc-instruction SETGE #x9d)
+ (define-setcc-instruction SETL #x9c)
+ (define-setcc-instruction SETLE #x9e)
+ (define-setcc-instruction SETNA #x96)
+ (define-setcc-instruction SETNAE #x92)
+ (define-setcc-instruction SETNB #x93)
+ (define-setcc-instruction SETNBE #x97)
+ (define-setcc-instruction SETNC #x93)
+ (define-setcc-instruction SETNE #x95)
+ (define-setcc-instruction SETNG #x9e)
+ (define-setcc-instruction SETNGE #x9c)
+ (define-setcc-instruction SETNL #x9d)
+ (define-setcc-instruction SETNLE #x9f)
+ (define-setcc-instruction SETNO #x91)
+ (define-setcc-instruction SETNP #x9b)
+ (define-setcc-instruction SETNS #x99)
+ (define-setcc-instruction SETNZ #x95)
+ (define-setcc-instruction SETO #x90)
+ (define-setcc-instruction SETP #x9a)
+ (define-setcc-instruction SETPE #x9a)
+ (define-setcc-instruction SETPO #x9b)
+ (define-setcc-instruction SETS #x98)
+ (define-setcc-instruction SETZ #x94))
+\f
+(define-trivial-instruction STC #xf9)
+(define-trivial-instruction STD #xfd)
+(define-trivial-instruction STI #xfb)
+
+(define-instruction TEST
+ ((W (? op1 r/mW) (R (? op2)))
+ (BYTE (8 #x85))
+ (ModR/M op2 op1))
+
+ ((W (R 0) (& (? value)))
+ (BYTE (8 #xa9))
+ (IMMEDIATE value))
+
+ ((W (R 0) (&U (? value)))
+ (BYTE (8 #xa9))
+ (IMMEDIATE value OPERAND UNSIGNED))
+
+ ((W (? op1 r/mW) (& (? value)))
+ (BYTE (8 #xf7))
+ (ModR/M 0 op1)
+ (IMMEDIATE value))
+
+ ((W (? op1 r/mW) (&U (? value)))
+ (BYTE (8 #xf7))
+ (ModR/M 0 op1)
+ (IMMEDIATE value OPERAND UNSIGNED))
+
+ ((B (? op1 r/mB) (R (? op2)))
+ (BYTE (8 #x84))
+ (ModR/M op2 op1))
+
+ ((B (R 0) (& (? value)))
+ (BYTE (8 #xa8)
+ (8 value SIGNED)))
+
+ ((B (R 0) (&U (? value)))
+ (BYTE (8 #xa8)
+ (8 value UNSIGNED)))
+
+ ((B (? op1 r/mB) (& (? value)))
+ (BYTE (8 #xf6))
+ (ModR/M 0 op1)
+ (BYTE (8 value SIGNED)))
+
+ ((B (? op1 r/mB) (&U (? value)))
+ (BYTE (8 #xf6))
+ (ModR/M 0 op1)
+ (BYTE (8 value UNSIGNED))))
+\f
+(define-trivial-instruction WAIT #x9b) ; = (FWAIT)
+(define-trivial-instruction WBINVD #x0f #x09) ; 486 only
+
+(define-instruction XADD ; 486 only
+ ((W (? target r/mW) (R (? source)))
+ (BYTE (8 #x0f)
+ (8 #xc1))
+ (ModR/M source target))
+
+ ((B (? target r/mB) (R (? source)))
+ (BYTE (8 #x0f)
+ (8 #xc0))
+ (ModR/M source target)))
+
+(define-instruction XCHG
+ ((W (R 0) (R (? reg)))
+ (BYTE (8 (+ #x90 reg))))
+
+ ((W (R (? reg)) (R 0))
+ (BYTE (8 (+ #x90 reg))))
+
+ ((W (R (? reg)) (? op r/mW))
+ (BYTE (8 #x87))
+ (ModR/M reg op))
+
+ ((W (? op r/mW) (R (? reg)))
+ (BYTE (8 #x87))
+ (ModR/M reg op))
+
+ ((B (R (? reg)) (? op r/mB))
+ (BYTE (8 #x86))
+ (ModR/M reg op))
+
+ ((B (? op r/mB) (R (? reg)))
+ (BYTE (8 #x86))
+ (ModR/M reg op)))
+
+(define-trivial-instruction XLAT #xd7)
+\f
+;;;; Instruction prefixes. Treated as separate instructions.
+
+(define-trivial-instruction LOCK #xf0)
+
+(define-trivial-instruction REP #xf3) ; or #xf2 trust which appendix?
+(define-trivial-instruction REPE #xf3)
+(define-trivial-instruction REPNE #xf2)
+(define-trivial-instruction REPNZ #xf2)
+(define-trivial-instruction REPZ #xf3)
+
+(define-trivial-instruction CSSEG #x2e)
+(define-trivial-instruction SSSEG #x36)
+(define-trivial-instruction DSSEG #x3e)
+(define-trivial-instruction ESSEG #x26)
+(define-trivial-instruction FSSEG #x64)
+(define-trivial-instruction GSSEG #x65)
+
+;; **** These are broken. The assembler needs to change state, i.e.
+;; fluid-let *OPERAND-SIZE* or *ADDRESS-SIZE*. ****
+
+(define-trivial-instruction OPSIZE #x66)
+(define-trivial-instruction ADSIZE #x67)
+
+;; **** Missing MOV instruction to/from special registers. ****
\ 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Intel i387/i486 Instruction Set
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+(let-syntax
+ ((define-binary-flonum
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (list-ref form 1))
+ (pmnemonic (list-ref form 2))
+ (imnemonic (list-ref form 3))
+ (digit (list-ref form 4))
+ (opcode1 (list-ref form 5))
+ (opcode2 (list-ref form 6)))
+ `(begin
+ (define-instruction ,mnemonic
+ (((ST 0) (ST (? i)))
+ (BYTE (8 #xd8)
+ (8 (+ ,opcode1 i))))
+
+ (((ST (? i)) (ST 0))
+ (BYTE (8 #xdc)
+ (8 (+ ,opcode2 i))))
+
+ (()
+ (BYTE (8 #xde)
+ (8 (+ ,opcode2 1))))
+
+ ((D (? source mW))
+ (BYTE (8 #xdc))
+ (ModR/M ,digit source))
+
+ ((S (? source mW))
+ (BYTE (8 #xd8))
+ (ModR/M ,digit source)))
+
+ (define-instruction ,pmnemonic
+ (((ST (? i)) (ST 0))
+ (BYTE (8 #xde)
+ (8 (+ ,opcode2 i)))))
+
+ (define-instruction ,imnemonic
+ ((L (? source mW))
+ (BYTE (8 #xda))
+ (ModR/M ,digit source))
+
+ ((H (? source mW))
+ (BYTE (8 #xde))
+ (ModR/M ,digit source)))))))))
+
+ ;; The i486 book (and 387, etc.) has inconsistent instruction
+ ;; descriptions and opcode assignments for FSUB and siblings,
+ ;; and FDIV and siblings.
+ ;; FSUB ST(i),ST is described as replacing ST(i) with ST-ST(i)
+ ;; while the opcode described replaces ST(i) with ST(i)-ST.
+
+ ;; In the following, the F% forms follow the descriptions in the
+ ;; book, namely, F%SUB computes ST-ST(i) and F%SUBR computes
+ ;; ST(i)-ST, storing into their destination (first) argument.
+
+ ;; The %-less forms follow the opcodes and usual convention,
+ ;; namely FSUB computes destination (first) argument - source
+ ;; argument FSUBR computes source - destination.
+
+ (define-binary-flonum FADD FADDP FIADD 0 #xc0 #xc0)
+ (define-binary-flonum F%DIV F%DIVP F%IDIV 6 #xf0 #xf0)
+ (define-binary-flonum F%DIVR F%DIVPR F%IDIVR 7 #xf8 #xf8)
+ (define-binary-flonum FDIV FDIVP FIDIV 6 #xf0 #xf8)
+ (define-binary-flonum FDIVR FDIVPR FIDIVR 7 #xf8 #xf0)
+ (define-binary-flonum FMUL FMULP FIMUL 1 #xc8 #xc8)
+ (define-binary-flonum F%SUB F%SUBP F%ISUB 4 #xe0 #xe0)
+ (define-binary-flonum F%SUBR F%SUBPR F%ISUBR 5 #xe8 #xe8)
+ (define-binary-flonum FSUB FSUBP FISUB 4 #xe0 #xe8)
+ (define-binary-flonum FSUBR FSUBPR FISUBR 5 #xe8 #xe0))
+\f
+(define-trivial-instruction F2XM1 #xd9 #xf0)
+(define-trivial-instruction FABS #xd9 #xe1)
+
+(define-instruction FBLD
+ (((? source mW))
+ (BYTE (8 #xd8))
+ (ModR/M 4 source)))
+
+(define-instruction FBSTP
+ (((? target mW))
+ (BYTE (8 #xdf))
+ (ModR/M 6 target)))
+
+(define-trivial-instruction FCHS #xd9 #xe0)
+(define-trivial-instruction FCLEX #x9b #xdb #xe2) ; = (FWAIT) (FNCLEX)
+(define-trivial-instruction FNCLEX #xdb #xe2)
+
+(let-syntax
+ ((define-flonum-comparison
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (cadr form))
+ (digit (caddr form))
+ (opcode (cadddr form)))
+ `(define-instruction ,mnemonic
+ (((ST 0) (ST (? i)))
+ (BYTE (8 #xd8)
+ (8 (+ ,opcode i))))
+
+ (()
+ (BYTE (8 #xd8)
+ (8 (+ ,opcode 1))))
+
+ ((D (? source mW))
+ (BYTE (8 #xdc))
+ (ModR/M ,digit source))
+
+ ((S (? source mW))
+ (BYTE (8 #xd8))
+ (ModR/M ,digit source))))))))
+
+ (define-flonum-comparison FCOM 2 #xd0)
+ (define-flonum-comparison FCOMP 3 #xd8))
+
+(define-trivial-instruction FCOMPP #xde #xd9)
+(define-trivial-instruction FCOS #xd9 #xff)
+(define-trivial-instruction FDECSTP #xd9 #xf6)
+
+(define-instruction FFREE
+ (((ST (? i)))
+ (BYTE (8 #xdd)
+ (8 (+ #xc0 i)))))
+
+(let-syntax
+ ((define-flonum-integer-comparison
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (cadr form))
+ (digit (caddr form)))
+ `(define-instruction ,mnemonic
+ ((L (? source mW))
+ (BYTE (8 #xda))
+ (ModR/M ,digit source))
+
+ ((H (? source mW))
+ (BYTE (8 #xde))
+ (ModR/M ,digit source))))))))
+
+ (define-flonum-integer-comparison FICOM 2)
+ (define-flonum-integer-comparison FICOMP 3))
+\f
+(let-syntax
+ ((define-flonum-integer-memory
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (cadr form))
+ (digit1 (caddr form))
+ (digit2 (cadddr form)))
+ `(define-instruction ,mnemonic
+ ,@(if (not digit2)
+ `()
+ `(((Q (? source mW))
+ (BYTE (8 #xdf))
+ (ModR/M ,digit2 source))))
+
+ ((L (? source mW))
+ (BYTE (8 #xdb))
+ (ModR/M ,digit1 source))
+
+ ((H (? source mW))
+ (BYTE (8 #xdf))
+ (ModR/M ,digit1 source))))))))
+
+ (define-flonum-integer-memory FILD 0 5)
+ (define-flonum-integer-memory FIST 2 #f)
+ (define-flonum-integer-memory FISTP 3 7))
+
+(define-trivial-instruction FINCSTP #xd9 #xf7)
+(define-trivial-instruction FINIT #x9b #xdb #xe3) ; = (FWAIT) (FNINT)
+(define-trivial-instruction FNINIT #xdb #xe3)
+
+(let-syntax
+ ((define-flonum-memory
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (list-ref form 1))
+ (digit1 (list-ref form 2))
+ (digit2 (list-ref form 3))
+ (opcode1 (list-ref form 4))
+ (opcode2 (list-ref form 5)))
+ `(define-instruction ,mnemonic
+ (((ST (? i)))
+ (BYTE (8 ,opcode1)
+ (8 (+ ,opcode2 i))))
+
+ ((D (? operand mW))
+ (BYTE (8 #xdd))
+ (ModR/M ,digit1 operand))
+
+ ((S (? operand mW))
+ (BYTE (8 #xd9))
+ (ModR/M ,digit1 operand))
+
+ ,@(if (not digit2)
+ `()
+ `(((X (? operand mW))
+ (BYTE (8 #xdb))
+ (ModR/M ,digit2 operand))))))))))
+
+ (define-flonum-memory FLD 0 5 #xd9 #xc0)
+ (define-flonum-memory FST 2 #f #xdd #xd0)
+ (define-flonum-memory FSTP 3 7 #xdd #xd8))
+
+(define-trivial-instruction FLD1 #xd9 #xe8)
+(define-trivial-instruction FLDL2T #xd9 #xe9)
+(define-trivial-instruction FLDL2E #xd9 #xea)
+(define-trivial-instruction FLDPI #xd9 #xeb)
+(define-trivial-instruction FLDLG2 #xd9 #xec)
+(define-trivial-instruction FLDLN2 #xd9 #xed)
+(define-trivial-instruction FLDZ #xd9 #xee)
+\f
+(let-syntax
+ ((define-flonum-state
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (list-ref form 1))
+ (opcode (list-ref form 2))
+ (digit (list-ref form 3))
+ (mnemonic2 (list-ref form 4)))
+ `(begin
+ ,@(if (not mnemonic2)
+ `()
+ `((define-instruction ,mnemonic2
+ (((? source mW))
+ (BYTE (8 #x9b) ; (FWAIT)
+ (8 ,opcode))
+ (ModR/M ,digit source)))))
+
+ (define-instruction ,mnemonic
+ (((? source mW))
+ (BYTE (8 ,opcode))
+ (ModR/M ,digit source)))))))))
+
+ (define-flonum-state FNLDCW #xd9 5 FLDCW)
+ (define-flonum-state FLDENV #xd9 4 #f)
+ (define-flonum-state FNSTCW #xd9 7 FSTCW)
+ (define-flonum-state FNSTENV #xd9 6 FSTENV)
+ (define-flonum-state FRSTOR #xdb 4 #f)
+ (define-flonum-state FNSAVE #xdd 6 FSAVE))
+
+(define-trivial-instruction FNOP #xd9 #xd0)
+(define-trivial-instruction FPATAN #xd9 #xf3)
+(define-trivial-instruction FPREM #xd9 #xf8) ; truncating remainder
+(define-trivial-instruction FPREM1 #xd9 #xf5) ; IEEE remainder
+(define-trivial-instruction FPTAN #xd9 #xf2)
+(define-trivial-instruction FRNDINT #xd9 #xfc)
+(define-trivial-instruction FSCALE #xd9 #xfd)
+(define-trivial-instruction FSIN #xd9 #xfe)
+(define-trivial-instruction FSINCOS #xd9 #xfb)
+(define-trivial-instruction FSQRT #xd9 #xfa)
+
+(define-instruction FSTSW
+ (((? target mW))
+ (BYTE (8 #x9b) ; (FWAIT)
+ (8 #xdf))
+ (ModR/M 7 target))
+
+ (((R 0))
+ (BYTE (8 #x9b) ; (FWAIT)
+ (8 #xdf)
+ (8 #xe0))))
+
+(define-instruction FNSTSW
+ (((? target mW))
+ (BYTE (8 #xdf))
+ (ModR/M 7 target))
+
+ (((R 0))
+ (BYTE (8 #xdf)
+ (8 #xe0))))
+\f
+(define-trivial-instruction FTST #xd9 #xe4)
+
+(let-syntax
+ ((define-binary-flonum
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (cadr form))
+ (opcode1 (caddr form))
+ (opcode2 (cadddr form)))
+ `(define-instruction ,mnemonic
+ (((ST 0) (ST (? i)))
+ (BYTE (8 ,opcode1)
+ (8 (+ ,opcode2 i))))
+
+ (()
+ (BYTE (8 ,opcode1)
+ (8 (+ ,opcode2 1))))))))))
+
+ (define-binary-flonum FUCOM #xdd #xe0)
+ (define-binary-flonum FUCOMP #xdd #xe8)
+ (define-binary-flonum FXCH #xd9 #xc8))
+
+(define-trivial-instruction FUCOMPP #xda #xe9)
+(define-trivial-instruction FWAIT #x9b)
+(define-trivial-instruction FXAM #xd9 #xe5)
+(define-trivial-instruction FXTRACT #xd9 #xf4)
+(define-trivial-instruction FYL2X #xd9 #xf1)
+(define-trivial-instruction FYL2XP1 #xd9 #xf9)
\ 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Intel 386 Instruction Set, utilities
+
+(declare (usual-integrations))
+\f
+;;;; Addressing modes
+
+;; r/m part of ModR/M byte and SIB byte.
+;; These are valid only for 32-bit addressing.
+
+(define-ea-database
+ ((R (? r))
+ (REGISTER)
+ #b11 r)
+
+ ((@R (? r indirect-reg))
+ (MEMORY)
+ #b00 r)
+
+ ((@R 5) ; EBP
+ (MEMORY)
+ #b01 5
+ (BYTE (8 0)))
+
+ ((@R 4) ; ESP
+ (MEMORY)
+ #b00 4
+ (BYTE (3 4)
+ (3 4)
+ (2 0)))
+
+ ((@RO B (? r index-reg) (? offset))
+ (MEMORY)
+ #b01 r
+ (BYTE (8 offset SIGNED)))
+
+ ((@RO UB (? r index-reg) (? offset))
+ (MEMORY)
+ #b01 r
+ (BYTE (8 offset UNSIGNED)))
+
+ ((@RO B 4 (? offset))
+ (MEMORY)
+ #b01 4
+ (BYTE (3 4)
+ (3 4)
+ (2 0)
+ (8 offset SIGNED)))
+
+ ((@RO UB 4 (? offset))
+ (MEMORY)
+ #b01 4
+ (BYTE (3 4)
+ (3 4)
+ (2 0)
+ (8 offset UNSIGNED)))
+
+ ((@RO W (? r index-reg) (? offset))
+ (MEMORY)
+ #b10 r
+ (IMMEDIATE offset ADDRESS SIGNED))
+
+ ((@RO UW (? r index-reg) (? offset))
+ (MEMORY)
+ #b10 r
+ (IMMEDIATE offset ADDRESS UNSIGNED))
+\f
+ ((@RO W 4 (? offset)) ; ESP
+ (MEMORY)
+ #b10 #b100
+ (BYTE (3 4)
+ (3 4)
+ (2 0))
+ (IMMEDIATE offset ADDRESS SIGNED))
+
+ ((@RO UW 4 (? offset)) ; ESP
+ (MEMORY)
+ #b10 #b100
+ (BYTE (3 4)
+ (3 4)
+ (2 0))
+ (IMMEDIATE offset ADDRESS UNSIGNED))
+
+ ((@RI (? b base-reg) (? i index-reg) (? s index-scale))
+ (MEMORY)
+ #b00 #b100
+ (BYTE (3 b)
+ (3 i)
+ (2 s)))
+
+ ((@RI 5 (? i index-reg) (? s index-scale)) ; EBP
+ (MEMORY)
+ #b01 #b100
+ (BYTE (3 5)
+ (3 i)
+ (2 s)
+ (8 0)))
+
+ ((@ROI B (? b) (? offset) (? i index-reg) (? s index-scale))
+ (MEMORY)
+ #b01 #b100
+ (BYTE (3 b)
+ (3 i)
+ (2 s)
+ (8 offset SIGNED)))
+
+ ((@ROI UB (? b) (? offset) (? i index-reg) (? s index-scale))
+ (MEMORY)
+ #b01 #b100
+ (BYTE (3 b)
+ (3 i)
+ (2 s)
+ (8 offset UNSIGNED)))
+
+ ((@ROI W (? b) (? offset) (? i index-reg) (? s index-scale))
+ (MEMORY)
+ #b10 #b100
+ (BYTE (3 b)
+ (3 i)
+ (2 s))
+ (IMMEDIATE offset ADDRESS SIGNED))
+
+ ((@ROI UW (? b) (? offset) (? i index-reg) (? s index-scale))
+ (MEMORY)
+ #b10 #b100
+ (BYTE (3 b)
+ (3 i)
+ (2 s))
+ (IMMEDIATE offset ADDRESS UNSIGNED))
+
+ ((@ (? value))
+ (MEMORY)
+ #b00 #b101
+ (IMMEDIATE value ADDRESS)))
+\f
+(define-ea-transformer r/mW)
+(define-ea-transformer mW MEMORY)
+(define-ea-transformer r/mB)
+(define-ea-transformer mB MEMORY)
+
+(define-structure (effective-address
+ (conc-name ea/)
+ (constructor make-effective-address))
+ (keyword false read-only true)
+ (categories false read-only true)
+ (mode false read-only true)
+ (register false read-only true)
+ (extra '() read-only true))
+
+(define (sign-extended-byte value)
+ (and (fits-in-signed-byte? value)
+ value))
+
+(define (zero-extended-byte value)
+ (and (fits-in-unsigned-byte? value)
+ value))
+
+(define-integrable (indirect-reg r)
+ (and (not (= r esp))
+ (not (= r ebp))
+ r))
+
+(define-integrable (base-reg r)
+ (and (not (= r ebp))
+ r))
+
+(define-integrable (index-reg r)
+ (and (not (= r esp))
+ r))
+
+(define (index-scale scale-value)
+ (case scale-value
+ ((1) #b00)
+ ((2) #b01)
+ ((4) #b10)
+ ((8) #b11)
+ (else false)))
\ 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; RTL Rules utilities for i386 and family.
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Register-Allocator Interface
+
+(define available-machine-registers
+ ;; esp holds the the stack pointer
+ ;; ebp holds the pointer mask
+ ;; esi holds the register array pointer
+ ;; edi holds the free pointer
+ ;; fr7 is not used so that we can always push on the stack once.
+ (list eax ecx edx ebx fr0 fr1 fr2 fr3 fr4 fr5 fr6))
+
+(define (sort-machine-registers registers)
+ ;; FR0 is preferable to other FPU regs. We promote it to the front
+ ;; if we find another FPU reg in front of it.
+ (let loop ((regs registers))
+ (cond ((null? regs) registers) ; no float regs at all
+ ((general-register? (car regs)); ignore general regs
+ (loop (cdr regs)))
+ ((= (car regs) fr0) ; found FR0 first
+ registers)
+ ((memq fr0 regs) ; FR0 not first, is it present?
+ (cons fr0 (delq fr0 registers)) ; move to front
+ registers)
+ (else ; FR0 absent
+ registers))))
+
+(define (register-type register)
+ (cond ((machine-register? register)
+ (vector-ref
+ '#(GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
+ FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT)
+ register))
+ ((register-value-class=word? register)
+ 'GENERAL)
+ ((register-value-class=float? register)
+ 'FLOAT)
+ (else
+ (error "unable to determine register type" register))))
+
+(define register-reference
+ (let ((references (make-vector number-of-machine-registers)))
+ (let loop ((i 0))
+ (cond ((>= i number-of-machine-registers)
+ (lambda (register)
+ (vector-ref references register)))
+ ((< i 8)
+ (vector-set! references i (INST-EA (R ,i)))
+ (loop (1+ i)))
+ (else
+ (vector-set! references i (INST-EA (ST ,(floreg->sti i))))
+ (loop (1+ i)))))))
+
+(define (register->register-transfer source target)
+ (machine->machine-register source target))
+
+(define (reference->register-transfer source target)
+ (cond ((equal? (register-reference target) source)
+ (LAP))
+ ((float-register-reference? source)
+ ;; Assume target is a float register
+ (LAP (FLD ,source)))
+ (else
+ (memory->machine-register source target))))
+
+(define-integrable (pseudo-register-home register)
+ (offset-reference regnum:regs-pointer
+ (pseudo-register-offset register)))
+
+(define (home->register-transfer source target)
+ (pseudo->machine-register source target))
+
+(define (register->home-transfer source target)
+ (machine->pseudo-register source target))
+
+(define-integrable (float-register-reference? ea)
+ (and (pair? ea)
+ (eq? (car ea) 'ST)))
+\f
+;;;; Linearizer interface
+
+(define (lap:make-label-statement label)
+ (LAP (LABEL ,label)))
+
+(define (lap:make-unconditional-branch label)
+ (LAP (JMP (@PCR ,label))))
+
+(define (lap:make-entry-point label block-start-label)
+ block-start-label
+ (LAP (ENTRY-POINT ,label)
+ ,@(make-external-label expression-code-word label)))
+
+(define (make-external-label code label)
+ (set! *external-labels* (cons label *external-labels*))
+ (LAP (WORD U ,code)
+ (BLOCK-OFFSET ,label)
+ (LABEL ,label)))
+
+(define-integrable (make-code-word min max)
+ (+ (* #x100 min) max))
+
+(define expression-code-word
+ (make-code-word #xff #xff))
+\f
+;;;; Utilities for the register allocator interface
+
+(define-integrable (machine->machine-register source target)
+ (guarantee-registers-compatible source target)
+ (if (not (float-register? source))
+ (LAP (MOV W ,(register-reference target) ,(register-reference source)))
+ (let ((ssti (floreg->sti source))
+ (tsti (floreg->sti target)))
+ (if (zero? ssti)
+ (LAP (FST (ST ,tsti)))
+ (LAP (FLD (ST ,ssti))
+ (FSTP (ST ,(1+ tsti))))))))
+
+(define (machine-register->memory source target)
+ (if (not (float-register? source))
+ (LAP (MOV W ,target ,(register-reference source)))
+ (let ((ssti (floreg->sti source)))
+ (if (zero? ssti)
+ (LAP (FST D ,target))
+ (LAP (FLD (ST ,ssti))
+ (FSTP D ,target))))))
+
+(define (memory->machine-register source target)
+ (if (not (float-register? target))
+ (LAP (MOV W ,(register-reference target) ,source))
+ (LAP (FLD D ,source)
+ (FSTP (ST ,(1+ (floreg->sti target)))))))
+
+(define-integrable (offset-reference register offset)
+ (byte-offset-reference register (* 4 offset)))
+
+(define (byte-offset-reference register offset)
+ (cond ((zero? offset)
+ (INST-EA (@R ,register)))
+ ((fits-in-signed-byte? offset)
+ (INST-EA (@RO B ,register ,offset)))
+ (else
+ (INST-EA (@RO W ,register ,offset)))))
+
+(define (byte-unsigned-offset-reference register offset)
+ (cond ((zero? offset)
+ (INST-EA (@R ,register)))
+ ((fits-in-unsigned-byte? offset)
+ (INST-EA (@RO UB ,register ,offset)))
+ (else
+ (INST-EA (@RO UW ,register ,offset)))))
+
+(define-integrable (pseudo-register-offset register)
+ (+ (+ (* 16 4) (* 80 4))
+ (* 3 (register-renumber register))))
+
+(define-integrable (pseudo->machine-register source target)
+ (memory->machine-register (pseudo-register-home source) target))
+
+(define-integrable (machine->pseudo-register source target)
+ (machine-register->memory source (pseudo-register-home target)))
+
+(define-integrable (floreg->sti reg)
+ (- reg fr0))
+
+(define-integrable (general-register? register)
+ (< register fr0))
+
+(define-integrable (float-register? register)
+ (<= fr0 register fr7))
+\f
+;;;; Utilities for the rules
+
+(define (require-register! machine-reg)
+ (flush-register! machine-reg)
+ (need-register! machine-reg))
+
+(define-integrable (flush-register! machine-reg)
+ (prefix-instructions! (clear-registers! machine-reg)))
+
+(define (rtl-target:=machine-register! rtl-reg machine-reg)
+ (if (machine-register? rtl-reg)
+ (begin
+ (require-register! machine-reg)
+ (if (not (= rtl-reg machine-reg))
+ (suffix-instructions!
+ (register->register-transfer machine-reg rtl-reg))))
+ (begin
+ (delete-register! rtl-reg)
+ (flush-register! machine-reg)
+ (add-pseudo-register-alias! rtl-reg machine-reg))))
+
+(define (object->machine-register! object mreg)
+ ;; This funny ordering allows load-constant to use a pc value in mreg!
+ (let ((code (load-constant (INST-EA (R ,mreg)) object)))
+ (require-register! mreg)
+ code))
+
+(define (assign-register->register target source)
+ (move-to-alias-register! source (register-type target) target)
+ (LAP))
+
+(define (convert-object/constant->register target constant conversion)
+ (delete-dead-registers!)
+ (let ((target (target-register-reference target)))
+ (if (non-pointer-object? constant)
+ ;; Is this correct if conversion is object->address ?
+ (load-non-pointer target 0 (careful-object-datum constant))
+ (LAP ,@(load-constant target constant)
+ ,@(conversion target)))))
+
+(define (non-pointer->literal object)
+ (make-non-pointer-literal (object-type object)
+ (careful-object-datum object)))
+
+(define (load-immediate target value)
+ (if (zero? value)
+ (LAP (XOR W ,target ,target))
+ (LAP (MOV W ,target (& ,value)))))
+
+(define (load-non-pointer target type datum)
+ (let ((immediate-value (make-non-pointer-literal type datum)))
+ (if (zero? immediate-value)
+ (LAP (XOR W ,target ,target))
+ (LAP (MOV W ,target (&U ,immediate-value))))))
+
+(define (load-constant target obj)
+ (if (non-pointer-object? obj)
+ (load-non-pointer target (object-type obj) (careful-object-datum obj))
+ (load-pc-relative target (constant->label obj))))
+
+(define (load-pc-relative target label-expr)
+ (with-pc
+ (lambda (pc-label pc-register)
+ (LAP (MOV W ,target (@RO W ,pc-register (- ,label-expr ,pc-label)))))))
+
+(define (load-pc-relative-address target label-expr)
+ (with-pc
+ (lambda (pc-label pc-register)
+ (LAP (LEA ,target (@RO W ,pc-register (- ,label-expr ,pc-label)))))))
+\f
+(define (with-pc recvr)
+ (with-values (lambda () (get-cached-label))
+ (lambda (label reg)
+ (if label
+ (recvr label reg)
+ (let ((temporary (allocate-temporary-register! 'GENERAL)))
+ (pc->reg temporary
+ (lambda (label prefix)
+ (cache-label! label temporary)
+ (LAP ,@prefix
+ ,@(recvr label temporary)))))))))
+
+(define (pc->reg reg recvr)
+ (let ((label (generate-label 'GET-PC)))
+ (recvr label
+ (LAP (CALL (@PCR ,label))
+ (LABEL ,label)
+ (POP ,(register-reference reg))))))
+
+(define-integrable (get-cached-label)
+ (register-map-label *register-map* 'GENERAL))
+
+(define-integrable (cache-label! label temporary)
+ (set! *register-map*
+ (set-machine-register-label *register-map* temporary label))
+ unspecific)
+
+(define (compare/register*register reg1 reg2)
+ (cond ((register-alias reg1 'GENERAL)
+ =>
+ (lambda (alias)
+ (LAP (CMP W ,(register-reference alias) ,(any-reference reg2)))))
+ ((register-alias reg2 'GENERAL)
+ =>
+ (lambda (alias)
+ (LAP (CMP W ,(any-reference reg1) ,(register-reference alias)))))
+ (else
+ (LAP (CMP W ,(source-register-reference reg1)
+ ,(any-reference reg2))))))
+\f
+(define (target-register target)
+ (delete-dead-registers!)
+ (or (register-alias target 'GENERAL)
+ (allocate-alias-register! target 'GENERAL)))
+
+(define-integrable (target-register-reference target)
+ (register-reference (target-register target)))
+
+(define-integrable (temporary-register-reference)
+ (reference-temporary-register! 'GENERAL))
+
+(define (source-register source)
+ (or (register-alias source 'GENERAL)
+ (load-alias-register! source 'GENERAL)))
+
+(define-integrable (source-register-reference source)
+ (register-reference (source-register source)))
+
+(define-integrable (any-reference rtl-reg)
+ (standard-register-reference rtl-reg 'GENERAL true))
+
+(define (standard-move-to-temporary! source)
+ (register-reference (move-to-temporary-register! source 'GENERAL)))
+
+(define (standard-move-to-target! source target)
+ (register-reference (move-to-alias-register! source 'GENERAL target)))
+
+(define (indirect-reference! rtl-reg offset)
+ (offset-reference (allocate-indirection-register! rtl-reg)
+ offset))
+
+(define (indirect-byte-reference! register offset)
+ (byte-offset-reference (allocate-indirection-register! register) offset))
+
+(define-integrable (allocate-indirection-register! register)
+ (load-alias-register! register 'GENERAL))
+\f
+(define (with-indexed-address base* index* scale b-offset protect recvr)
+ (let* ((base (allocate-indirection-register! base*))
+ (index (source-register index*))
+ (with-address-temp
+ (lambda (temp)
+ (let ((tref (register-reference temp))
+ (ea (indexed-ea-mode base index scale b-offset)))
+ (LAP (LEA ,tref ,ea)
+ ,@(object->address tref)
+ ,@(recvr (INST-EA (@R ,temp)))))))
+ (with-reused-temp
+ (lambda (temp)
+ (need-register! temp)
+ (with-address-temp temp)))
+ (fail-index
+ (lambda ()
+ (with-address-temp
+ (allocate-temporary-register! 'GENERAL))))
+ (fail-base
+ (lambda ()
+ (if (and protect (= index* protect))
+ (fail-index)
+ (reuse-pseudo-register-alias! index*
+ 'GENERAL
+ with-reused-temp
+ fail-index)))))
+ (if (and protect (= base* protect))
+ (fail-base)
+ (reuse-pseudo-register-alias! base*
+ 'GENERAL
+ with-reused-temp
+ fail-base))))
+
+(define (indexed-ea base index scale offset)
+ (indexed-ea-mode (allocate-indirection-register! base)
+ (source-register index)
+ scale
+ offset))
+
+(define (indexed-ea-mode base index scale offset)
+ (cond ((zero? offset)
+ (INST-EA (@RI ,base ,index ,scale)))
+ ((<= -128 offset 127)
+ (INST-EA (@ROI B ,base ,offset ,index ,scale)))
+ (else
+ (INST-EA (@ROI W ,base ,offset ,index ,scale)))))
+\f
+(define (rtl:simple-offset? expression)
+ (and (rtl:offset? expression)
+ (let ((base (rtl:offset-base expression))
+ (offset (rtl:offset-offset expression)))
+ (if (rtl:register? base)
+ (or (rtl:machine-constant? offset)
+ (rtl:register? offset))
+ (and (rtl:offset-address? base)
+ (rtl:machine-constant? offset)
+ (rtl:register? (rtl:offset-address-base base))
+ (rtl:register? (rtl:offset-address-offset base)))))
+ expression))
+
+(define (offset->reference! offset)
+ ;; OFFSET must be a simple offset
+ (let ((base (rtl:offset-base offset))
+ (offset (rtl:offset-offset offset)))
+ (cond ((not (rtl:register? base))
+ (indexed-ea (rtl:register-number (rtl:offset-address-base base))
+ (rtl:register-number (rtl:offset-address-offset base))
+ 4
+ (* 4 (rtl:machine-constant-value offset))))
+ ((rtl:machine-constant? offset)
+ (indirect-reference! (rtl:register-number base)
+ (rtl:machine-constant-value offset)))
+ (else
+ (indexed-ea (rtl:register-number base)
+ (rtl:register-number offset)
+ 4
+ 0)))))
+
+(define (rtl:simple-byte-offset? expression)
+ (and (rtl:byte-offset? expression)
+ (let ((base (rtl:byte-offset-base expression))
+ (offset (rtl:byte-offset-offset expression)))
+ (if (rtl:register? base)
+ (or (rtl:machine-constant? offset)
+ (rtl:register? offset))
+ (and (rtl:byte-offset-address? base)
+ (rtl:machine-constant? offset)
+ (rtl:register? (rtl:byte-offset-address-base base))
+ (rtl:register? (rtl:byte-offset-address-offset base)))))
+ expression))
+
+(define (rtl:detagged-index? base offset)
+ (let ((o-ok? (and (rtl:object->datum? offset)
+ (rtl:register? (rtl:object->datum-expression offset)))))
+ (if (and (rtl:object->address? base)
+ (rtl:register? (rtl:object->address-expression base)))
+ (or o-ok? (rtl:register? offset))
+ (and o-ok? (rtl:register? base)))))
+\f
+(define (byte-offset->reference! offset)
+ ;; OFFSET must be a simple byte offset
+ (let ((base (rtl:byte-offset-base offset))
+ (offset (rtl:byte-offset-offset offset)))
+ (cond ((not (rtl:register? base))
+ (indexed-ea (rtl:register-number
+ (rtl:byte-offset-address-base base))
+ (rtl:register-number
+ (rtl:byte-offset-address-offset base))
+ 1
+ (rtl:machine-constant-value offset)))
+ ((rtl:machine-constant? offset)
+ (indirect-byte-reference! (rtl:register-number base)
+ (rtl:machine-constant-value offset)))
+ (else
+ (indexed-ea (rtl:register-number base)
+ (rtl:register-number offset)
+ 1
+ 0)))))
+
+(define (rtl:simple-float-offset? expression)
+ (and (rtl:float-offset? expression)
+ (let ((base (rtl:float-offset-base expression))
+ (offset (rtl:float-offset-offset expression)))
+ (and (or (rtl:machine-constant? offset)
+ (rtl:register? offset))
+ (or (rtl:register? base)
+ (and (rtl:offset-address? base)
+ (rtl:register? (rtl:offset-address-base base))
+ (rtl:machine-constant?
+ (rtl:offset-address-offset base))))))
+ expression))
+
+(define (float-offset->reference! offset)
+ ;; OFFSET must be a simple float offset
+ (let ((base (rtl:float-offset-base offset))
+ (offset (rtl:float-offset-offset offset)))
+ (cond ((not (rtl:register? base))
+ (let ((base*
+ (rtl:register-number (rtl:offset-address-base base)))
+ (w-offset
+ (rtl:machine-constant-value
+ (rtl:offset-address-offset base))))
+ (if (rtl:machine-constant? offset)
+ (indirect-reference!
+ base*
+ (+ (* 2 (rtl:machine-constant-value offset))
+ w-offset))
+ (indexed-ea base*
+ (rtl:register-number offset)
+ 8
+ (* 4 w-offset)))))
+ ((rtl:machine-constant? offset)
+ (indirect-reference! (rtl:register-number base)
+ (* 2 (rtl:machine-constant-value offset))))
+ (else
+ (indexed-ea (rtl:register-number base)
+ (rtl:register-number offset)
+ 8
+ 0)))))
+\f
+(define (object->type target)
+ (LAP (SHR W ,target (& ,scheme-datum-width))))
+
+(define (object->datum target)
+ (LAP (AND W ,target (R ,regnum:datum-mask))))
+
+(define (object->address target)
+ (declare (integrate-operator object->datum))
+ (object->datum target))
+
+(define (interpreter-call-argument? expression)
+ (or (rtl:register? expression)
+ (and (rtl:cons-pointer? expression)
+ (rtl:machine-constant? (rtl:cons-pointer-type expression))
+ (rtl:machine-constant? (rtl:cons-pointer-datum expression)))
+ (rtl:simple-offset? expression)))
+
+(define (interpreter-call-argument->machine-register! expression register)
+ (let ((target (register-reference register)))
+ (case (car expression)
+ ((REGISTER)
+ (load-machine-register! (rtl:register-number expression) register))
+ ((CONS-POINTER)
+ (LAP ,@(clear-registers! register)
+ ,@(load-non-pointer (rtl:machine-constant-value
+ (rtl:cons-pointer-type expression))
+ (rtl:machine-constant-value
+ (rtl:cons-pointer-datum expression))
+ target)))
+ ((OFFSET)
+ (let ((source-reference (offset->reference! expression)))
+ (LAP ,@(clear-registers! register)
+ (MOV W ,target ,source-reference))))
+ (else
+ (error "Unknown expression type" (car expression))))))
+\f
+;;;; Named registers, codes, and entries
+
+(define reg:compiled-memtop
+ (offset-reference regnum:regs-pointer
+ register-block/memtop-offset))
+
+(define reg:environment
+ (offset-reference regnum:regs-pointer
+ register-block/environment-offset))
+
+(define reg:dynamic-link
+ (offset-reference regnum:regs-pointer
+ register-block/dynamic-link-offset))
+
+(define reg:lexpr-primitive-arity
+ (offset-reference regnum:regs-pointer
+ register-block/lexpr-primitive-arity-offset))
+
+(define reg:utility-arg-4
+ (offset-reference regnum:regs-pointer
+ register-block/utility-arg4-offset))
+
+(define reg:stack-guard
+ (offset-reference regnum:regs-pointer
+ register-block/stack-guard-offset))
+
+
+(define-syntax define-codes
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ `(BEGIN
+ ,@(let loop ((names (cddr form)) (index (cadr form)))
+ (if (pair? names)
+ (cons `(DEFINE-INTEGRABLE
+ ,(symbol-append 'CODE:COMPILER-
+ (car names))
+ ,index)
+ (loop (cdr names) (+ index 1)))
+ '()))))))
+
+(define-codes #x012
+ primitive-apply primitive-lexpr-apply
+ apply error lexpr-apply link
+ interrupt-closure interrupt-dlink interrupt-procedure
+ interrupt-continuation interrupt-ic-procedure
+ assignment-trap cache-reference-apply
+ reference-trap safe-reference-trap unassigned?-trap
+ -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero?
+ access lookup safe-lookup unassigned? unbound?
+ set! define lookup-apply primitive-error
+ quotient remainder modulo)
+
+(define-integrable (invoke-hook entry)
+ (LAP (JMP ,entry)))
+
+(define-integrable (invoke-hook/call entry)
+ (LAP (CALL ,entry)))
+
+(define-integrable (invoke-interface code)
+ (LAP (MOV B (R ,eax) (& ,code))
+ ,@(invoke-hook entry:compiler-scheme-to-interface)))
+
+(define-integrable (invoke-interface/call code)
+ (LAP (MOV B (R ,eax) (& ,code))
+ ,@(invoke-hook/call entry:compiler-scheme-to-interface/call)))
+\f
+(define-syntax define-entries
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ `(BEGIN
+ ,@(let loop
+ ((names (cdddr form))
+ (index (cadr form))
+ (high (caddr form)))
+ (if (pair? names)
+ (if (< index high)
+ (cons `(DEFINE-INTEGRABLE
+ ,(symbol-append 'ENTRY:COMPILER-
+ (car names))
+ (byte-offset-reference regnum:regs-pointer
+ ,index))
+ (loop (cdr names) (+ index 4) high))
+ (begin
+ (warn "define-entries: Too many for byte offsets.")
+ (loop names index (+ high 32000))))
+ '()))))))
+
+(define-entries #x40 #x80 ; (* 16 4)
+ scheme-to-interface ; Main entry point (only one necessary)
+ scheme-to-interface/call ; Used by rules3&4, for convenience.
+ trampoline-to-interface ; Used by trampolines, for convenience.
+ interrupt-procedure
+ interrupt-continuation
+ interrupt-closure
+ interrupt-dlink
+ primitive-apply
+ primitive-lexpr-apply
+ assignment-trap
+ reference-trap
+ safe-reference-trap
+ link
+ error
+ primitive-error
+ short-primitive-apply)
+
+(define-entries #x-80 0
+ &+
+ &-
+ &*
+ &/
+ &=
+ &<
+ &>
+ 1+
+ -1+
+ zero?
+ positive?
+ negative?
+ quotient
+ remainder
+ modulo
+ shortcircuit-apply ; Used by rules3, for speed.
+ shortcircuit-apply-size-1 ; Small frames, save time and space.
+ shortcircuit-apply-size-2
+ shortcircuit-apply-size-3
+ shortcircuit-apply-size-4
+ shortcircuit-apply-size-5
+ shortcircuit-apply-size-6
+ shortcircuit-apply-size-7
+ shortcircuit-apply-size-8
+ interrupt-continuation-2
+ conditionally-serialize)
+\f
+;; Operation tables
+
+(define (define-arithmetic-method operator methods method)
+ (let ((entry (assq operator (cdr methods))))
+ (if entry
+ (set-cdr! entry method)
+ (set-cdr! methods (cons (cons operator method) (cdr methods)))))
+ operator)
+
+(define (lookup-arithmetic-method operator methods)
+ (cdr (or (assq operator (cdr methods))
+ (error "Unknown operator" operator))))
+
+(define (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
--- /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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; LAP Optimizer for Intel i386.
+;;; 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)) ; i.e. null
+ (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)
+ (& ,(careful-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
+ (careful-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)))))
--- /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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Machine Model for the Intel 386, i486, and successors
+;;; package: (compiler)
+
+(declare (usual-integrations))
+\f
+;;;; Architecture Parameters
+
+(define use-pre/post-increment? false)
+(define-integrable endianness 'LITTLE)
+(define-integrable addressing-granularity 8)
+(define-integrable scheme-object-width 32)
+(define-integrable scheme-type-width 6) ;or 8
+
+;; NOTE: expt is not being constant-folded now.
+;; For the time being, some of the parameters below are
+;; pre-computed and marked with ***
+;; There are similar parameters in lapgen.scm
+;; Change them if any of the parameters above change.
+
+(define-integrable scheme-datum-width
+ (- scheme-object-width scheme-type-width))
+
+(define-integrable float-width 64)
+(define-integrable float-alignment 32)
+
+(define-integrable address-units-per-float
+ (quotient float-width addressing-granularity))
+
+;;; It is currently required that both packed characters and objects
+;;; be integrable numbers of address units. Furthermore, the number
+;;; of address units per object must be an integral multiple of the
+;;; number of address units per character. This will cause problems
+;;; on a machine that is word addressed: we will have to rethink the
+;;; character addressing strategy.
+
+(define-integrable address-units-per-object
+ (quotient scheme-object-width addressing-granularity))
+
+(define-integrable address-units-per-packed-char 1)
+
+(define-integrable signed-fixnum/upper-limit
+ ;; (expt 2 (-1+ scheme-datum-width)) ***
+ 33554432)
+
+(define-integrable signed-fixnum/lower-limit
+ (- signed-fixnum/upper-limit))
+
+(define-integrable unsigned-fixnum/upper-limit
+ (* 2 signed-fixnum/upper-limit))
+
+(define-integrable (stack->memory-offset offset) offset)
+(define-integrable ic-block-first-parameter-offset 2)
+\f
+;;;; Closure format
+
+;; See microcode/cmpint-i386.h for a description of the layout.
+;; This must return a word based offset.
+;; On the i386, to save space, entries can be at 2 mod 4 addresses,
+;; which makes it impossible if the closure object used for
+;; referencing points to arbitrary entries. Instead, all closure
+;; entry points bump to the canonical entry point, which is always
+;; longword aligned.
+
+(define (closure-first-offset nentries entry)
+ entry ; ignored
+ (if (zero? nentries)
+ 1
+ (quotient (+ (+ 3 1) (* 5 (- nentries 1))) 2)))
+
+;; This is from the start of the complete closure object,
+;; viewed as a vector, and including the header word.
+
+(define (closure-object-first-offset nentries)
+ (case nentries
+ ((0) 1)
+ ((1) 4)
+ (else
+ (quotient (+ 5 (* 5 nentries)) 2))))
+
+;; Bump from one entry point to another.
+
+(define (closure-entry-distance nentries entry entry*)
+ nentries ; ignored
+ (* 10 (- entry* entry)))
+
+;; Bump to the canonical entry point.
+
+(define (closure-environment-adjustment nentries entry)
+ (declare (integrate-operator closure-entry-distance))
+ (closure-entry-distance nentries entry 0))
+\f
+;;;; Machine registers
+
+(define eax 0) ; acumulator
+(define ecx 1) ; counter register
+(define edx 2) ; multiplication high-half target
+(define ebx 3) ; distinguished useful register
+(define esp 4) ; stack pointer
+(define ebp 5) ; frame pointer
+(define esi 6) ; string source pointer
+(define edi 7) ; string destination pointer
+
+;; Virtual floating point registers:
+;; Floating point stack locations, allocated as if registers.
+;; One left free to allow room to push and operate.
+
+(define fr0 8)
+(define fr1 9)
+(define fr2 10)
+(define fr3 11)
+(define fr4 12)
+(define fr5 13)
+(define fr6 14)
+(define fr7 15)
+
+(define number-of-machine-registers 16)
+(define number-of-temporary-registers 256)
+
+(define-integrable regnum:stack-pointer esp)
+(define-integrable regnum:datum-mask ebp)
+(define-integrable regnum:regs-pointer esi)
+(define-integrable regnum:free-pointer edi)
+
+(define-integrable (machine-register-known-value register)
+ register ; ignored
+ false)
+
+(define (machine-register-value-class register)
+ (cond ((<= eax register ebx)
+ value-class=object)
+ ((= register regnum:datum-mask)
+ value-class=immediate)
+ ((or (= register regnum:stack-pointer)
+ (= register regnum:free-pointer)
+ (= register regnum:regs-pointer))
+ value-class=address)
+ ((<= fr0 register fr7)
+ value-class=float)
+ (else
+ (error "illegal machine register" register))))
+
+(define-integrable register-block/memtop-offset 0)
+(define-integrable register-block/int-mask-offset 1)
+(define-integrable register-block/value-offset 2)
+(define-integrable register-block/environment-offset 3)
+(define-integrable register-block/dynamic-link-offset 4) ; compiler temp
+(define-integrable register-block/lexpr-primitive-arity-offset 7)
+(define-integrable register-block/utility-arg4-offset 9) ; closure free
+(define-integrable register-block/stack-guard-offset 11)
+
+(define-integrable (fits-in-signed-byte? value)
+ (and (>= value -128) (< value 128)))
+
+(define-integrable (fits-in-unsigned-byte? value)
+ (and (>= value 0) (< value 128)))
+\f
+;;;; RTL Generator Interface
+
+(define (interpreter-register:access)
+ (rtl:make-machine-register eax))
+
+(define (interpreter-register:cache-reference)
+ (rtl:make-machine-register eax))
+
+(define (interpreter-register:cache-unassigned?)
+ (rtl:make-machine-register eax))
+
+(define (interpreter-register:lookup)
+ (rtl:make-machine-register eax))
+
+(define (interpreter-register:unassigned?)
+ (rtl:make-machine-register eax))
+
+(define (interpreter-register:unbound?)
+ (rtl:make-machine-register eax))
+
+(define-integrable (interpreter-block-register offset-value)
+ (rtl:make-offset (interpreter-regs-pointer)
+ (rtl:make-machine-constant offset-value)))
+
+(define-integrable (interpreter-block-register? expression offset-value)
+ (and (rtl:offset? expression)
+ (interpreter-regs-pointer? (rtl:offset-base expression))
+ (let ((offset (rtl:offset-offset expression)))
+ (and (rtl:machine-constant? offset)
+ (= (rtl:machine-constant-value offset)
+ offset-value)))))
+
+(define-integrable (interpreter-value-register)
+ (interpreter-block-register register-block/value-offset))
+
+(define (interpreter-value-register? expression)
+ (interpreter-block-register? expression register-block/value-offset))
+
+(define (interpreter-environment-register)
+ (interpreter-block-register register-block/environment-offset))
+
+(define (interpreter-environment-register? expression)
+ (interpreter-block-register? expression register-block/environment-offset))
+
+(define (interpreter-free-pointer)
+ (rtl:make-machine-register regnum:free-pointer))
+
+(define (interpreter-free-pointer? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:free-pointer)))
+
+(define (interpreter-regs-pointer)
+ (rtl:make-machine-register regnum:regs-pointer))
+
+(define (interpreter-regs-pointer? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:regs-pointer)))
+
+(define (interpreter-stack-pointer)
+ (rtl:make-machine-register regnum:stack-pointer))
+
+(define (interpreter-stack-pointer? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:stack-pointer)))
+
+(define (interpreter-dynamic-link)
+ (interpreter-block-register register-block/dynamic-link-offset))
+
+(define (interpreter-dynamic-link? expression)
+ (interpreter-block-register? expression register-block/dynamic-link-offset))
+\f
+(define (rtl:machine-register? rtl-register)
+ (case rtl-register
+ ((STACK-POINTER)
+ (interpreter-stack-pointer))
+ #|
+ ((VALUE)
+ (interpreter-value-register))
+ |#
+ ((FREE)
+ (interpreter-free-pointer))
+ ((INTERPRETER-CALL-RESULT:ACCESS)
+ (interpreter-register:access))
+ ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
+ (interpreter-register:cache-reference))
+ ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
+ (interpreter-register:cache-unassigned?))
+ ((INTERPRETER-CALL-RESULT:LOOKUP)
+ (interpreter-register:lookup))
+ ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
+ (interpreter-register:unassigned?))
+ ((INTERPRETER-CALL-RESULT:UNBOUND?)
+ (interpreter-register:unbound?))
+ (else
+ false)))
+
+(define (rtl:interpreter-register? rtl-register)
+ (case rtl-register
+ ((MEMORY-TOP)
+ register-block/memtop-offset)
+ ((INT-MASK)
+ register-block/int-mask-offset)
+ ((STACK-GUARD)
+ register-block/stack-guard-offset)
+ ((VALUE)
+ register-block/value-offset)
+ ((ENVIRONMENT)
+ register-block/environment-offset)
+ ((DYNAMIC-LINK TEMPORARY)
+ register-block/dynamic-link-offset)
+ (else
+ false)))
+
+(define (rtl:interpreter-register->offset locative)
+ (or (rtl:interpreter-register? locative)
+ (error "Unknown register type" locative)))
+\f
+(define (rtl:constant-cost expression)
+ ;; i486 clock count for instruction to construct/fetch into register.
+ (let ((if-integer
+ (lambda (value)
+ value ; ignored
+ ;; Can this be done in fewer bytes for suitably small values?
+ 1)) ; MOV immediate
+ (get-pc-cost
+ (+ 3 ; CALL
+ 4)) ; POP
+ (based-reference-cost
+ 1) ; MOV r/m
+ (address-offset-cost
+ 1)) ; LEA instruction
+
+ (define (if-synthesized-constant type datum)
+ (if-integer (make-non-pointer-literal type datum)))
+
+ (case (rtl:expression-type expression)
+ ((CONSTANT)
+ (let ((value (rtl:constant-value expression)))
+ (if (non-pointer-object? value)
+ (if-synthesized-constant (object-type value)
+ (careful-object-datum value))
+ (+ get-pc-cost based-reference-cost))))
+ ((MACHINE-CONSTANT)
+ (if-integer (rtl:machine-constant-value expression)))
+ ((ENTRY:PROCEDURE
+ ENTRY:CONTINUATION)
+ (+ get-pc-cost address-offset-cost))
+ ((ASSIGNMENT-CACHE
+ VARIABLE-CACHE)
+ (+ get-pc-cost based-reference-cost))
+ ((OFFSET-ADDRESS
+ BYTE-OFFSET-ADDRESS
+ FLOAT-OFFSET-ADDRESS)
+ address-offset-cost)
+ ((CONS-POINTER)
+ (and (rtl:machine-constant? (rtl:cons-pointer-type expression))
+ (rtl:machine-constant? (rtl:cons-pointer-datum expression))
+ (if-synthesized-constant
+ (rtl:machine-constant-value (rtl:cons-pointer-type expression))
+ (rtl:machine-constant-value
+ (rtl:cons-pointer-datum expression)))))
+ (else
+ false))))
+
+(define compiler:open-code-floating-point-arithmetic?
+ true)
+
+(define compiler:primitives-with-no-open-coding
+ '(DIVIDE-FIXNUM GCD-FIXNUM &/
+ ;; Disabled: trig instructions are limited to an
+ ;; input range of 0 <= |X| <= pi*2^62, and yield
+ ;; inaccurate answers for an input range of 0 <= |X|
+ ;; <= pi/4. Correct argument reduction requires a
+ ;; better approximation of pi than the i387 has.
+ FLONUM-SIN FLONUM-COS FLONUM-TAN
+ VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS))
\ 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Compiler: System Construction
+
+(declare (usual-integrations))
+
+(let ((value ((load "base/make") "i386")))
+ (set! (access compiler:compress-top-level? (->environment '(compiler))) #t)
+ value)
\ 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Compiler: System Construction
+
+(declare (usual-integrations))
+
+(begin
+ (load-option 'compress)
+ (load "machines/i386/make"))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$MC68020-Header: /scheme/compiler/bobcat/RCS/rgspcm.scm,v 4.2 1991/05/06 23:17:03 jinx Exp $
+
+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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; RTL Generation: Special primitive combinations. Intel i386 version.
+;;; package: (compiler rtl-generator)
+
+(declare (usual-integrations))
+\f
+(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
--- /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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; LAP Generation Rules: Data Transfers.
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Register Assignments
+
+;;; All assignments to pseudo registers are required to delete the
+;;; dead registers BEFORE performing the assignment. However, it is
+;;; necessary to derive the effective address of the source
+;;; expression(s) before deleting the dead registers. Otherwise any
+;;; source expression containing dead registers might refer to aliases
+;;; which have been reused.
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
+ (assign-register->register target source))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OFFSET-ADDRESS (REGISTER (? source))
+ (REGISTER (? index))))
+ (load-indexed-register target source index 4))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n))))
+ (load-displaced-register target source (* 4 n)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source))
+ (REGISTER (? index))))
+ (load-indexed-register target source index 1))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n))))
+ (load-displaced-register target source n))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLOAT-OFFSET-ADDRESS (REGISTER (? source))
+ (REGISTER (? index))))
+ (load-indexed-register target source index 8))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLOAT-OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n))))
+ (load-displaced-register target source (* 8 n)))
+
+(define-rule statement
+ ;; This is an intermediate rule -- not intended to produce code.
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n)))))
+ (load-displaced-register/typed target source type (* 4 n)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source))
+ (MACHINE-CONSTANT (? n)))))
+ (load-displaced-register/typed target source type n))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
+ (object->type (standard-move-to-target! source target)))
+\f
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum))))
+ (let ((temp (standard-move-to-temporary! type)))
+ (LAP (ROR W ,temp (&U ,scheme-type-width))
+ (OR W ,(standard-move-to-target! datum target) ,temp))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum))))
+ (if (zero? type)
+ (assign-register->register target datum)
+ (let ((literal (make-non-pointer-literal type 0)))
+ (define (three-arg source)
+ (let ((target (target-register-reference target)))
+ (LAP (LEA ,target (@RO UW ,source ,literal)))))
+
+ (define (two-arg target)
+ (LAP (OR W ,target (&U ,literal))))
+
+ (let ((alias (register-alias datum 'GENERAL)))
+ (cond ((not alias)
+ (two-arg (standard-move-to-target! datum target)))
+ ((register-copy-if-available datum 'GENERAL target)
+ =>
+ (lambda (get-tgt)
+ (two-arg (get-tgt))))
+ (else
+ (three-arg alias)))))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
+ (object->datum (standard-move-to-target! source target)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
+ (object->address (standard-move-to-target! source target)))
+\f
+;;;; Loading Constants
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
+ (load-constant (target-register-reference target) source))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? n)))
+ (load-immediate (target-register-reference target) n))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (load-non-pointer (target-register-reference target) type datum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label)))
+ (load-pc-relative-address
+ (target-register-reference target)
+ (rtl-procedure/external-label (label->object label))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label)))
+ (load-pc-relative-address (target-register-reference target) label))
+
+(define-rule statement
+ ;; This is an intermediate rule -- not intended to produce code.
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (ENTRY:PROCEDURE (? label))))
+ (load-pc-relative-address/typed (target-register-reference target)
+ type
+ (rtl-procedure/external-label
+ (label->object label))))
+
+(define-rule statement
+ ;; This is an intermediate rule -- not intended to produce code.
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (ENTRY:CONTINUATION (? label))))
+ (load-pc-relative-address/typed (target-register-reference target)
+ type label))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
+ (load-pc-relative (target-register-reference target)
+ (free-reference-label name)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name)))
+ (load-pc-relative (target-register-reference target)
+ (free-assignment-label name)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant))))
+ (convert-object/constant->register target constant object->datum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (CONSTANT (? constant))))
+ (convert-object/constant->register target constant object->address))
+\f
+;;;; Transfers from Memory
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (? expression rtl:simple-offset?))
+ (let ((source (offset->reference! expression)))
+ (LAP (MOV W ,(target-register-reference target) ,source))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 4) 1))
+ (LAP (POP ,(target-register-reference target))))
+
+;;;; Transfers to Memory
+
+(define-rule statement
+ (ASSIGN (? expression rtl:simple-offset?) (REGISTER (? r)))
+ (QUALIFIER (register-value-class=word? r))
+ (let ((source (source-register-reference r)))
+ (LAP (MOV W
+ ,(offset->reference! expression)
+ ,source))))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:simple-offset?) (CONSTANT (? value)))
+ (QUALIFIER (non-pointer-object? value))
+ (LAP (MOV W ,(offset->reference! expression)
+ (&U ,(non-pointer->literal value)))))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:simple-offset?)
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (LAP (MOV W ,(offset->reference! expression)
+ (&U ,(make-non-pointer-literal type datum)))))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:simple-offset?)
+ (BYTE-OFFSET-ADDRESS (? expression)
+ (MACHINE-CONSTANT (? n))))
+ (if (zero? n)
+ (LAP)
+ (LAP (ADD W ,(offset->reference! expression) (& ,n)))))
+\f
+;;;; Consing
+
+(define-rule statement
+ (ASSIGN (POST-INCREMENT (REGISTER 7) 1) (REGISTER (? r)))
+ (QUALIFIER (register-value-class=word? r))
+ (LAP (MOV W (@R 7) ,(source-register-reference r))
+ (ADD W (R 7) (& 4))))
+
+;;;; Pushes
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 4) -1) (REGISTER (? r)))
+ (QUALIFIER (register-value-class=word? r))
+ (LAP (PUSH ,(source-register-reference r))))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 4) -1) (CONSTANT (? value)))
+ (QUALIFIER (non-pointer-object? value))
+ (LAP (PUSH W (&U ,(non-pointer->literal value)))))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 4) -1)
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (LAP (PUSH W (&U ,(make-non-pointer-literal type datum)))))
+\f
+;;;; CHAR->ASCII/BYTE-OFFSET
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CHAR->ASCII (? expression rtl:simple-offset?)))
+ (load-char-into-register 0
+ (offset->reference! expression)
+ target))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CHAR->ASCII (REGISTER (? source))))
+ (load-char-into-register 0
+ (source-register-reference source)
+ target))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (? expression rtl:simple-byte-offset?))
+ (load-char-into-register 0
+ (byte-offset->reference! expression)
+ target))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (? expression rtl:simple-byte-offset?)))
+ (load-char-into-register type
+ (byte-offset->reference! expression)
+ target))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:simple-byte-offset?)
+ (CHAR->ASCII (CONSTANT (? character))))
+ (LAP (MOV B
+ ,(byte-offset->reference! expression)
+ (& ,(char->signed-8-bit-immediate character)))))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:simple-byte-offset?)
+ (REGISTER (? source)))
+ (let* ((source (source-register-reference source))
+ (target (byte-offset->reference! expression)))
+ (LAP (MOV B ,target ,source))))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:simple-byte-offset?)
+ (CHAR->ASCII (REGISTER (? source))))
+ (let ((source (source-register-reference source))
+ (target (byte-offset->reference! expression)))
+ (LAP (MOV B ,target ,source))))
+
+(define (char->signed-8-bit-immediate character)
+ (let ((ascii (char->ascii character)))
+ (if (< ascii 128) ascii (- ascii 256))))
+\f
+;;;; Utilities specific to rules1
+
+(define (load-displaced-register/internal target source n signed?)
+ (cond ((zero? n)
+ (assign-register->register target source))
+ ((and (= target source)
+ (= target esp))
+ (if signed?
+ (LAP (ADD W (R ,esp) (& ,n)))
+ (LAP (ADD W (R ,esp) (&U ,n)))))
+ (signed?
+ (let* ((source (indirect-byte-reference! source n))
+ (target (target-register-reference target)))
+ (LAP (LEA ,target ,source))))
+ (else
+ (let* ((source (indirect-unsigned-byte-reference! source n))
+ (target (target-register-reference target)))
+ (LAP (LEA ,target ,source))))))
+
+(define-integrable (load-displaced-register target source n)
+ (load-displaced-register/internal target source n true))
+
+(define-integrable (load-displaced-register/typed target source type n)
+ (load-displaced-register/internal target
+ source
+ (if (zero? type)
+ n
+ (+ (make-non-pointer-literal type 0)
+ n))
+ false))
+
+(define (load-indexed-register target source index scale)
+ (let* ((source (indexed-ea source index scale 0))
+ (target (target-register-reference target)))
+ (LAP (LEA ,target ,source))))
+
+(define (load-pc-relative-address/typed target type label)
+ (with-pc
+ (lambda (pc-label pc-register)
+ (LAP (LEA ,target (@RO UW
+ ,pc-register
+ (+ ,(make-non-pointer-literal type 0)
+ (- ,label ,pc-label))))))))
+
+(define (load-char-into-register type source target)
+ (let ((target (target-register-reference target)))
+ (cond ((zero? type)
+ ;; No faster, but smaller
+ (LAP (MOVZX B ,target ,source)))
+ (else
+ (LAP ,@(load-non-pointer target type 0)
+ (MOV B ,target ,source))))))
+
+(define (indirect-unsigned-byte-reference! register offset)
+ (byte-unsigned-offset-reference (allocate-indirection-register! register)
+ offset))
+\f
+;;;; Improved vector and string references
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (? expression rtl:detagged-offset?))
+ (with-detagged-vector-location expression false
+ (lambda (temp)
+ (LAP (MOV W ,(target-register-reference target) ,temp)))))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:detagged-offset?)
+ (REGISTER (? source)))
+ (QUALIFIER (register-value-class=word? source))
+ (with-detagged-vector-location expression source
+ (lambda (temp)
+ (LAP (MOV W ,temp ,(source-register-reference source))))))
+
+(define (with-detagged-vector-location rtl-expression protect recvr)
+ (with-decoded-detagged-offset rtl-expression
+ (lambda (base index offset)
+ (with-indexed-address base index 4 (* 4 offset) protect recvr))))
+
+(define (rtl:detagged-offset? expression)
+ (and (rtl:offset? expression)
+ (rtl:machine-constant? (rtl:offset-offset expression))
+ (let ((base (rtl:offset-base expression)))
+ (and (rtl:offset-address? base)
+ (rtl:detagged-index? (rtl:offset-address-base base)
+ (rtl:offset-address-offset base))))
+ expression))
+
+(define (with-decoded-detagged-offset expression recvr)
+ (let ((base (rtl:offset-base expression)))
+ (let ((base* (rtl:offset-address-base base))
+ (index (rtl:offset-address-offset base)))
+ (recvr (rtl:register-number (if (rtl:register? base*)
+ base*
+ (rtl:object->address-expression base*)))
+ (rtl:register-number (if (rtl:register? index)
+ index
+ (rtl:object->datum-expression index)))
+ (rtl:machine-constant-value (rtl:offset-offset expression))))))
+\f
+;;;; Improved string references
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (? expression rtl:detagged-byte-offset?))
+ (load-char-indexed/detag 0 target expression))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (? expression rtl:detagged-byte-offset?)))
+ (load-char-indexed/detag type target expression))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:detagged-byte-offset?)
+ (REGISTER (? source)))
+ (store-char-indexed/detag expression
+ source
+ (source-register-reference source)))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:detagged-byte-offset?)
+ (CHAR->ASCII (REGISTER (? source))))
+ (store-char-indexed/detag expression
+ source
+ (source-register-reference source)))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:detagged-byte-offset?)
+ (CHAR->ASCII (CONSTANT (? character))))
+ (store-char-indexed/detag expression
+ false
+ (INST-EA (& ,(char->signed-8-bit-immediate
+ character)))))
+
+(define (load-char-indexed/detag tag target rtl-source-expression)
+ (with-detagged-string-location rtl-source-expression false
+ (lambda (temp)
+ (load-char-into-register tag temp target))))
+
+(define (store-char-indexed/detag rtl-target-expression protect source)
+ (with-detagged-string-location rtl-target-expression protect
+ (lambda (temp)
+ (LAP (MOV B ,temp ,source)))))
+
+(define (with-detagged-string-location rtl-expression protect recvr)
+ (with-decoded-detagged-byte-offset rtl-expression
+ (lambda (base index offset)
+ (with-indexed-address base index 1 offset protect recvr))))
+
+(define (rtl:detagged-byte-offset? expression)
+ (and (rtl:byte-offset? expression)
+ (rtl:machine-constant? (rtl:byte-offset-offset expression))
+ (let ((base (rtl:byte-offset-base expression)))
+ (and (rtl:byte-offset-address? base)
+ (rtl:detagged-index? (rtl:byte-offset-address-base base)
+ (rtl:byte-offset-address-offset base))))
+ expression))
+
+(define (with-decoded-detagged-byte-offset expression recvr)
+ (let ((base (rtl:byte-offset-base expression)))
+ (let ((base* (rtl:byte-offset-address-base base))
+ (index (rtl:byte-offset-address-offset base)))
+ (recvr (rtl:register-number (if (rtl:register? base*)
+ base*
+ (rtl:object->address-expression base*)))
+ (rtl:register-number (if (rtl:register? index)
+ index
+ (rtl:object->datum-expression index)))
+ (rtl:machine-constant-value
+ (rtl:byte-offset-offset expression))))))
\ 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; LAP Generation Rules: Predicates
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+(define (set-equal-branches!)
+ (set-current-branches! (lambda (label)
+ (LAP (JE (@PCR ,label))))
+ (lambda (label)
+ (LAP (JNE (@PCR ,label))))))
+
+(define-rule predicate
+ (TYPE-TEST (REGISTER (? register)) (? type))
+ (set-equal-branches!)
+ (LAP (CMP B ,(reference-alias-register! register 'GENERAL) (&U ,type))))
+
+(define-rule predicate
+ (EQ-TEST (REGISTER (? register-1)) (REGISTER (? register-2)))
+ (set-equal-branches!)
+ (compare/register*register register-1 register-2))
+
+(define-rule predicate
+ (EQ-TEST (REGISTER (? register)) (? expression rtl:simple-offset?))
+ (set-equal-branches!)
+ (LAP (CMP W ,(source-register-reference register)
+ ,(offset->reference! expression))))
+
+(define-rule predicate
+ (EQ-TEST (? expression rtl:simple-offset?) (REGISTER (? register)))
+ (set-equal-branches!)
+ (LAP (CMP W ,(offset->reference! expression)
+ ,(source-register-reference register))))
+
+(define-rule predicate
+ (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register)))
+ (QUALIFIER (non-pointer-object? constant))
+ (set-equal-branches!)
+ (LAP (CMP W ,(any-reference register)
+ (&U ,(non-pointer->literal constant)))))
+
+(define-rule predicate
+ (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant)))
+ (QUALIFIER (non-pointer-object? constant))
+ (set-equal-branches!)
+ (LAP (CMP W ,(any-reference register)
+ (&U ,(non-pointer->literal constant)))))
+\f
+(define-rule predicate
+ (EQ-TEST (CONSTANT (? constant)) (? expression rtl:simple-offset?))
+ (QUALIFIER (non-pointer-object? constant))
+ (set-equal-branches!)
+ (LAP (CMP W ,(offset->reference! expression)
+ (&U ,(non-pointer->literal constant)))))
+
+(define-rule predicate
+ (EQ-TEST (? expression rtl:simple-offset?) (CONSTANT (? constant)))
+ (QUALIFIER (non-pointer-object? constant))
+ (set-equal-branches!)
+ (LAP (CMP W ,(offset->reference! expression)
+ (&U ,(non-pointer->literal constant)))))
+
+(define-rule predicate
+ (EQ-TEST (CONSTANT (? constant-1)) (CONSTANT (? constant-2)))
+ (let ((always-jump
+ (lambda (label)
+ (LAP (JMP (@PCR ,label)))))
+ (always-fall-through
+ (lambda (label)
+ label ; ignored
+ (LAP))))
+ (if (eq? constant-1 constant-2)
+ (set-current-branches! always-jump always-fall-through)
+ (set-current-branches! always-fall-through always-jump)))
+ (LAP))
+
+(define-rule predicate
+ (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum)))
+ (REGISTER (? register)))
+ (set-equal-branches!)
+ (LAP (CMP W ,(any-reference register)
+ (&U ,(make-non-pointer-literal type datum)))))
+
+(define-rule predicate
+ (EQ-TEST (REGISTER (? register))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (set-equal-branches!)
+ (LAP (CMP W ,(any-reference register)
+ (&U ,(make-non-pointer-literal type datum)))))
+
+(define-rule predicate
+ (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum)))
+ (? expression rtl:simple-offset?))
+ (set-equal-branches!)
+ (LAP (CMP W ,(offset->reference! expression)
+ (&U ,(make-non-pointer-literal type datum)))))
+
+(define-rule predicate
+ (EQ-TEST (? expression rtl:simple-offset?)
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (set-equal-branches!)
+ (LAP (CMP W ,(offset->reference! expression)
+ (&U ,(make-non-pointer-literal type datum)))))
+
+
+;; Combine tests for fixnum and non-negative by extracting the type
+;; bits and the sign bit.
+
+(define-rule predicate
+ (PRED-1-ARG INDEX-FIXNUM?
+ (REGISTER (? register)))
+ (let ((temp (standard-move-to-temporary! register)))
+ (set-equal-branches!)
+ (LAP (SHR W ,temp (& ,(- scheme-datum-width 1)))
+ (CMP B ,temp (&U ,(* 2 (ucode-type fixnum)))))))
--- /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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; LAP Generation Rules: Invocations and Entries
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Invocations
+
+(define-rule statement
+ (POP-RETURN)
+ ;; The continuation is on the stack.
+ ;; The type code needs to be cleared first.
+ (let ((checks (get-exit-interrupt-checks)))
+ (cond ((null? checks)
+ (let ((bblock
+ (make-new-sblock
+ (LAP (POP (R ,eax)) ; continuation
+ (AND W (R ,eax) (R ,regnum:datum-mask)) ; clear type
+ (JMP (R ,eax))))))
+ (current-bblock-continue! bblock)))
+ ((block-association 'POP-RETURN)
+ => current-bblock-continue!)
+ (else
+ (let ((bblock
+ (make-new-sblock
+ (let ((interrupt-label (generate-label 'INTERRUPT)))
+ (LAP (CMP W (R ,regnum:free-pointer) ,reg:compiled-memtop)
+ (JGE (@PCR ,interrupt-label))
+ (POP (R ,eax)) ; continuation
+ (AND W (R ,eax) (R ,regnum:datum-mask)) ; clear type
+ (JMP (R ,eax))
+ (LABEL ,interrupt-label)
+ ,@(invoke-hook
+ entry:compiler-interrupt-continuation-2))))))
+ (block-associate! 'POP-RETURN bblock)
+ (current-bblock-continue! bblock))))
+ (clear-map!)))
+
+(define-rule statement
+ (INVOCATION:APPLY (? frame-size) (? continuation))
+ continuation
+ (expect-no-exit-interrupt-checks)
+ (LAP ,@(clear-map!)
+ (POP (R ,ecx))
+ #|
+ (MOV W (R ,edx) (& ,frame-size))
+ ,@(invoke-interface code:compiler-apply)
+ |#
+ ,@(case frame-size
+ ((1) (invoke-hook entry:compiler-shortcircuit-apply-size-1))
+ ((2) (invoke-hook entry:compiler-shortcircuit-apply-size-2))
+ ((3) (invoke-hook entry:compiler-shortcircuit-apply-size-3))
+ ((4) (invoke-hook entry:compiler-shortcircuit-apply-size-4))
+ ((5) (invoke-hook entry:compiler-shortcircuit-apply-size-5))
+ ((6) (invoke-hook entry:compiler-shortcircuit-apply-size-6))
+ ((7) (invoke-hook entry:compiler-shortcircuit-apply-size-7))
+ ((8) (invoke-hook entry:compiler-shortcircuit-apply-size-8))
+ (else
+ (LAP (MOV W (R ,edx) (& ,frame-size))
+ ,@(invoke-hook entry:compiler-shortcircuit-apply))))))
+
+(define-rule statement
+ (INVOCATION:JUMP (? frame-size) (? continuation) (? label))
+ frame-size continuation
+ (expect-no-exit-interrupt-checks)
+ (LAP ,@(clear-map!)
+ (JMP (@PCR ,label))))
+
+(define-rule statement
+ (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation))
+ frame-size continuation
+ ;; It expects the procedure at the top of the stack
+ (expect-no-exit-interrupt-checks)
+ (LAP ,@(clear-map!)
+ (POP (R ,eax))
+ (AND W (R ,eax) (R ,regnum:datum-mask)) ;clear type code
+ (JMP (R ,eax))))
+\f
+(define-rule statement
+ (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
+ continuation
+ (expect-no-exit-interrupt-checks)
+ (with-pc
+ (lambda (pc-label pc-register)
+ (LAP ,@(clear-map!)
+ (LEA (R ,ecx) (@RO W ,pc-register (- ,label ,pc-label)))
+ (MOV W (R ,edx) (& ,number-pushed))
+ ,@(invoke-interface code:compiler-lexpr-apply)))))
+
+(define-rule statement
+ (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation))
+ continuation
+ ;; It expects the procedure at the top of the stack
+ (expect-no-exit-interrupt-checks)
+ (LAP ,@(clear-map!)
+ (POP (R ,ecx))
+ (AND W (R ,ecx) (R ,regnum:datum-mask)) ; clear type code
+ (MOV W (R ,edx) (& ,number-pushed))
+ ,@(invoke-interface code:compiler-lexpr-apply)))
+
+(define-rule statement
+ (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
+ continuation
+ (expect-no-exit-interrupt-checks)
+ (LAP ,@(clear-map!)
+ (JMP (@PCRO ,(free-uuo-link-label name frame-size) 3))))
+
+(define-rule statement
+ (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
+ continuation
+ (expect-no-exit-interrupt-checks)
+ (LAP ,@(clear-map!)
+ (JMP (@PCRO ,(global-uuo-link-label name frame-size) 3))))
+
+(define-rule statement
+ (INVOCATION:CACHE-REFERENCE (? frame-size) (? continuation) (? extension))
+ (QUALIFIER (interpreter-call-argument? extension))
+ continuation
+ (expect-no-exit-interrupt-checks)
+ (let* ((set-extension
+ (interpreter-call-argument->machine-register! extension ecx))
+ (set-address
+ (begin (require-register! edx)
+ (load-pc-relative-address (INST-EA (R ,edx))
+ *block-label*))))
+ (delete-dead-registers!)
+ (LAP ,@set-extension
+ ,@set-address
+ ,@(clear-map!)
+ (MOV W (R ,ebx) (& ,frame-size))
+ ,@(invoke-interface code:compiler-cache-reference-apply))))
+
+(define-rule statement
+ (INVOCATION:LOOKUP (? frame-size) (? continuation) (? environment) (? name))
+ (QUALIFIER (interpreter-call-argument? environment))
+ continuation
+ (expect-no-entry-interrupt-checks)
+ (let* ((set-environment
+ (interpreter-call-argument->machine-register! environment ecx))
+ (set-name (object->machine-register! name edx)))
+ (delete-dead-registers!)
+ (LAP ,@set-environment
+ ,@set-name
+ ,@(clear-map!)
+ (MOV W (R ,ebx) (& ,frame-size))
+ ,@(invoke-interface code:compiler-lookup-apply))))
+\f
+(define-rule statement
+ (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
+ continuation ; ignored
+ (if (eq? primitive compiled-error-procedure)
+ (LAP ,@(clear-map!)
+ (MOV W (R ,ecx) (& ,frame-size))
+ ,@(invoke-hook entry:compiler-error))
+ (let ((arity (primitive-procedure-arity primitive)))
+ (cond ((not (negative? arity))
+ (with-values (lambda () (get-cached-label))
+ (lambda (pc-label pc-reg)
+ pc-reg ; ignored
+ (if pc-label
+ (let ((get-code
+ (object->machine-register! primitive ecx)))
+ (LAP ,@get-code
+ ,@(clear-map!)
+ ,@(invoke-hook entry:compiler-primitive-apply)))
+ (let ((prim-label (constant->label primitive))
+ (offset-label (generate-label 'PRIMOFF)))
+ (LAP ,@(clear-map!)
+ ,@(invoke-hook/call
+ entry:compiler-short-primitive-apply)
+ (LABEL ,offset-label)
+ (LONG S (- ,prim-label ,offset-label))))))))
+ ((= arity -1)
+ (let ((get-code (object->machine-register! primitive ecx)))
+ (LAP ,@get-code
+ ,@(clear-map!)
+ (MOV W ,reg:lexpr-primitive-arity
+ (& ,(-1+ frame-size)))
+ ,@(invoke-hook entry:compiler-primitive-lexpr-apply))))
+ (else
+ ;; Unknown primitive arity. Go through apply.
+ (let ((get-code (object->machine-register! primitive ecx)))
+ (LAP ,@get-code
+ ,@(clear-map!)
+ (MOV W (R ,edx) (& ,frame-size))
+ ,@(invoke-interface code:compiler-apply))))))))
+\f
+(let-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)
+ #|
+ (special-primitive-invocation
+ ,(close-syntax (symbol-append 'CODE:COMPILER- name)
+ environment))
+ |#
+ (optimized-primitive-invocation
+ ,(close-syntax (symbol-append 'ENTRY:COMPILER- 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))
+
+(define (special-primitive-invocation code)
+ (LAP ,@(clear-map!)
+ ,@(invoke-interface code)))
+
+(define (optimized-primitive-invocation entry)
+ (LAP ,@(clear-map!)
+ ,@(invoke-hook entry)))
+\f
+;;; Invocation Prefixes
+
+(define-rule statement
+ (INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER 4))
+ (LAP))
+
+(define-rule statement
+ (INVOCATION-PREFIX:DYNAMIC-LINK 0 (REGISTER 4) (? any))
+ any ; ignored
+ (LAP))
+
+(define-rule statement
+ (INVOCATION-PREFIX:MOVE-FRAME-UP
+ (? frame-size)
+ (OFFSET-ADDRESS (REGISTER 4)
+ (MACHINE-CONSTANT (? offset))))
+ (QUALIFIER (or (zero? (- offset frame-size)) (< frame-size 3)))
+ (let ((how-far (- offset frame-size)))
+ (cond ((zero? how-far)
+ (LAP))
+ ((zero? frame-size)
+ (LAP (ADD W (R 4) (& ,(* 4 how-far)))))
+ ((= frame-size 1)
+ (let ((temp (temporary-register-reference)))
+ (LAP (MOV W ,temp (@R 4))
+ (ADD W (R 4) (& ,(* 4 offset)))
+ (PUSH W ,temp))))
+ ((= frame-size 2)
+ (let ((temp1 (temporary-register-reference))
+ (temp2 (temporary-register-reference)))
+ (LAP (MOV W ,temp2 (@RO B 4 4))
+ (MOV W ,temp1 (@R 4))
+ (ADD W (R 4) (& ,(* 4 offset)))
+ (PUSH W ,temp2)
+ (PUSH W ,temp1))))
+ (else
+ (error "INVOCATION-PREFIX:MOVE-FRAME-UP: Incorrectly invoked!")))))
+
+(define-rule statement
+ (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER (? reg)))
+ (generate/move-frame-up* frame-size
+ (move-to-temporary-register! reg 'GENERAL)
+ temporary-register-reference))
+
+(define-rule statement
+ (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
+ (REGISTER (? reg-1))
+ (REGISTER (? reg-2)))
+ (QUALIFIER (not (= reg-1 4)))
+ (let* ((label (generate-label 'DYN-CHOICE))
+ (temp1 (move-to-temporary-register! reg-1 'GENERAL))
+ (temp2 (standard-move-to-temporary! reg-2)))
+ (LAP (CMP W (R ,temp1) ,temp2)
+ (JLE (@PCR ,label))
+ (MOV W (R ,temp1) ,temp2)
+ (LABEL ,label)
+ ,@(generate/move-frame-up* frame-size temp1 (lambda () temp2)))))
+
+(define (generate/move-frame-up* frame-size reg get-temp)
+ (if (zero? frame-size)
+ (LAP (MOV W (R 4) (R ,reg)))
+ (let ((temp (get-temp))
+ (ctr (allocate-temporary-register! 'GENERAL))
+ (label (generate-label 'MOVE-LOOP)))
+ (LAP (LEA (R ,reg)
+ ,(byte-offset-reference reg (* -4 frame-size)))
+ (MOV W (R ,ctr) (& ,(-1+ frame-size)))
+ (LABEL ,label)
+ (MOV W ,temp (@RI 4 ,ctr 4))
+ (MOV W (@RI ,reg ,ctr 4) ,temp)
+ (DEC W (R ,ctr))
+ (JGE (@PCR ,label))
+ (MOV W (R 4) (R ,reg))))))
+\f
+;;;; External Labels
+
+;;; Entry point types
+
+(define (make-procedure-code-word min max)
+ ;; The "min" byte must be less than #x80; the "max" byte may not
+ ;; equal #x80 but can take on any other value.
+ (if (or (negative? min) (>= min #x80))
+ (error "MAKE-PROCEDURE-CODE-WORD: minimum out of range" min))
+ (if (>= (abs max) #x80)
+ (error "MAKE-PROCEDURE-CODE-WORD: maximum out of range" max))
+ (make-code-word min (if (negative? max) (+ #x100 max) max)))
+
+(define internal-entry-code-word
+ (make-code-word #xff #xfe))
+
+(define internal-continuation-code-word
+ (make-code-word #xff #xfc))
+
+(define (frame-size->code-word offset default)
+ (cond ((not offset)
+ default)
+ ((< offset #x2000)
+ ;; This uses up through (#xff #xdf).
+ (let ((qr (integer-divide offset #x80)))
+ (make-code-word (+ #x80 (integer-divide-remainder qr))
+ (+ #x80 (integer-divide-quotient qr)))))
+ (else
+ (error "Unable to encode continuation offset"
+ offset))))
+
+(define (continuation-code-word label)
+ (frame-size->code-word
+ (if label
+ (rtl-continuation/next-continuation-offset (label->object label))
+ 0)
+ internal-continuation-code-word))
+
+(define (internal-procedure-code-word rtl-proc)
+ (frame-size->code-word
+ (rtl-procedure/next-continuation-offset rtl-proc)
+ internal-entry-code-word))
+\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 interrupt-label checks)
+ ;; This always does interrupt checks in line.
+ (LAP ,@(if (or (memq 'INTERRUPT checks) (memq 'HEAP checks))
+ (LAP (CMP W (R ,regnum:free-pointer) ,reg:compiled-memtop)
+ (JGE (@PCR ,interrupt-label)))
+ (LAP))
+ ,@(if (memq 'STACK checks)
+ (LAP (CMP W (R ,regnum:stack-pointer) ,reg:stack-guard)
+ (JL (@PCR ,interrupt-label)))
+ (LAP))))
+
+(define (simple-procedure-header code-word label entry)
+ (let ((checks (get-entry-interrupt-checks)))
+ (if (null? checks)
+ (LAP ,@(make-external-label code-word label))
+ (let ((gc-label (generate-label)))
+ (LAP (LABEL ,gc-label)
+ ,@(invoke-hook/call entry)
+ ,@(make-external-label code-word label)
+ ,@(interrupt-check gc-label checks))))))
+
+(define-rule statement
+ (CONTINUATION-ENTRY (? internal-label))
+ (expect-no-entry-interrupt-checks)
+ (make-external-label (continuation-code-word internal-label)
+ internal-label))
+\f
+(define-rule statement
+ (CONTINUATION-HEADER (? internal-label))
+ #|
+ (simple-procedure-header (continuation-code-word internal-label)
+ internal-label
+ entry:compiler-interrupt-continuation)
+ |#
+ (expect-no-entry-interrupt-checks)
+ (make-external-label (continuation-code-word internal-label)
+ internal-label))
+
+(define-rule statement
+ (IC-PROCEDURE-HEADER (? internal-label))
+ (get-entry-interrupt-checks) ; force search
+ (let ((procedure (label->object internal-label)))
+ (let ((external-label (rtl-procedure/external-label procedure))
+ (gc-label (generate-label)))
+ (LAP (ENTRY-POINT ,external-label)
+ (EQUATE ,external-label ,internal-label)
+ (LABEL ,gc-label)
+ ,@(invoke-interface/call code:compiler-interrupt-ic-procedure)
+ ,@(make-external-label expression-code-word internal-label)
+ ,@(interrupt-check gc-label)))))
+
+(define-rule statement
+ (OPEN-PROCEDURE-HEADER (? internal-label))
+ (let ((rtl-proc (label->object internal-label)))
+ (LAP (EQUATE ,(rtl-procedure/external-label rtl-proc) ,internal-label)
+ ,@(simple-procedure-header (internal-procedure-code-word rtl-proc)
+ internal-label
+ (if (rtl-procedure/dynamic-link? rtl-proc)
+ entry:compiler-interrupt-dlink
+ entry:compiler-interrupt-procedure)))))
+
+(define-rule statement
+ (PROCEDURE-HEADER (? internal-label) (? min) (? max))
+ (LAP (EQUATE ,(rtl-procedure/external-label
+ (label->object internal-label))
+ ,internal-label)
+ ,@(simple-procedure-header (make-procedure-code-word min max)
+ internal-label
+ entry:compiler-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-interupt-checks 'ENTRY-INTERRUPT-CHECKS))
+
+(define (get-exit-interrupt-checks)
+ (get-interupt-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-interupt-checks kind)
+ (cond ((cfg-node-get *current-bblock* kind)
+ => cdr)
+ (else (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* ((mtarget (target-register target))
+ (target (register-reference mtarget))
+ (temp (temporary-register-reference)))
+ (LAP ,@(load-pc-relative-address
+ temp
+ `(- ,(rtl-procedure/external-label (label->object 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)
+ ,@(invoke-hook/call entry:compiler-conditionally-serialize))))
+
+(define (generate/cons-multiclosure target nentries size entries)
+ (let* ((mtarget (target-register target))
+ (target (register-reference mtarget))
+ (temp (temporary-register-reference)))
+ (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
+ (- ,(rtl-procedure/external-label
+ (label->object (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)
+ ,@(invoke-hook/call entry:compiler-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* ((rtl-proc (label->object internal-label))
+ (external-label (rtl-procedure/external-label rtl-proc))
+ (checks (get-entry-interrupt-checks)))
+ (if (zero? nentries)
+ (LAP (EQUATE ,external-label ,internal-label)
+ ,@(simple-procedure-header
+ (internal-procedure-code-word rtl-proc)
+ internal-label
+ entry:compiler-interrupt-procedure))
+ (let* ((prefix
+ (lambda (gc-label)
+ (LAP (LABEL ,gc-label)
+ ,@(if (zero? entry)
+ (LAP)
+ (LAP (ADD W (@R ,esp) (& ,(* 10 entry)))))
+ ,@(invoke-hook entry:compiler-interrupt-closure))))
+ (label+adjustment
+ (lambda ()
+ (LAP ,@(make-external-label internal-entry-code-word
+ 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 (target-register-reference 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)
+ (pc->reg eax
+ (lambda (pc-label prefix)
+ (LAP ,@prefix
+ (MOV W (R ,ecx) ,reg:environment)
+ (MOV W (@RO W ,eax (- ,environment-label ,pc-label))
+ (R ,ecx))
+ (LEA (R ,edx) (@RO W ,eax (- ,*block-label* ,pc-label)))
+ (LEA (R ,ebx) (@RO W ,eax (- ,free-ref-label ,pc-label)))
+ (MOV W ,reg:utility-arg-4 (& ,n-sections))
+ #|
+ ,@(invoke-interface/call code:compiler-link)
+ |#
+ ,@(invoke-hook/call entry:compiler-link)
+ ,@(make-external-label (continuation-code-word false)
+ (generate-label))))))
+
+(define (generate/remote-link code-block-label
+ environment-offset
+ free-ref-offset
+ n-sections)
+ (pc->reg eax
+ (lambda (pc-label prefix)
+ (LAP ,@prefix
+ (MOV W (R ,edx) (@RO W ,eax (- ,code-block-label ,pc-label)))
+ (AND W (R ,edx) (R ,regnum:datum-mask))
+ (LEA (R ,ebx) (@RO W ,edx ,free-ref-offset))
+ (MOV W (R ,ecx) ,reg:environment)
+ (MOV W (@RO W ,edx ,environment-offset) (R ,ecx))
+ (MOV W ,reg:utility-arg-4 (& ,n-sections))
+ #|
+ ,@(invoke-interface/call code:compiler-link)
+ |#
+ ,@(invoke-hook/call entry:compiler-link)
+ ,@(make-external-label (continuation-code-word false)
+ (generate-label))))))
+\f
+(define (generate/remote-links n-blocks vector-label nsects)
+ (if (zero? n-blocks)
+ (LAP)
+ (let ((loop (generate-label))
+ (bytes (generate-label))
+ (end (generate-label)))
+ (LAP
+ ;; Push counter
+ (PUSH W (& 0))
+ (LABEL ,loop)
+ ,@(pc->reg
+ eax
+ (lambda (pc-label prefix)
+ (LAP ,@prefix
+ ;; Get index
+ (MOV W (R ,ecx) (@R ,esp))
+ ;; Get vector
+ (MOV W (R ,edx) (@RO W ,eax (- ,vector-label ,pc-label)))
+ ;; Get n-sections for this cc-block
+ (XOR W (R ,ebx) (R ,ebx))
+ (MOV B (R ,ebx) (@ROI B ,eax (- ,bytes ,pc-label) ,ecx 1))
+ ;; address of vector
+ (AND W (R ,edx) (R ,regnum:datum-mask))
+ ;; Store n-sections in arg
+ (MOV W ,reg: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) ,reg: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
+ ,@(invoke-hook/call entry:compiler-link)
+ ,@(make-external-label (continuation-code-word false)
+ (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))))))
+\f
+(define (generate/constants-block constants references assignments
+ uuo-links global-links static-vars)
+ (let ((constant-info
+ (declare-constants 0 (transmogrifly uuo-links)
+ (declare-constants 1 references
+ (declare-constants 2 assignments
+ (declare-constants 3 (transmogrifly global-links)
+ (declare-constants false
+ (map (lambda (pair)
+ (cons false (cdr pair)))
+ static-vars)
+ (declare-constants false constants
+ (cons false (LAP))))))))))
+ (let ((free-ref-label (car constant-info))
+ (constants-code (cdr constant-info))
+ (debugging-information-label (allocate-constant-label))
+ (environment-label (allocate-constant-label))
+ (n-sections
+ (+ (if (null? uuo-links) 0 1)
+ (if (null? references) 0 1)
+ (if (null? assignments) 0 1)
+ (if (null? global-links) 0 1))))
+ (values
+ (LAP ,@constants-code
+ ;; Place holder for the debugging info filename
+ (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO)
+ ;; Place holder for the load time environment if needed
+ (SCHEME-OBJECT ,environment-label
+ ,(if (null? free-ref-label) 0 'ENVIRONMENT)))
+ environment-label
+ free-ref-label
+ n-sections))))
+
+(define (declare-constants tag constants info)
+ (define (inner constants)
+ (if (null? constants)
+ (cdr info)
+ (let ((entry (car constants)))
+ (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry))
+ ,@(inner (cdr constants))))))
+ (if (and tag (not (null? constants)))
+ (let ((label (allocate-constant-label)))
+ (cons label
+ (inner
+ `((,(let ((datum (length constants)))
+ (if (> datum #xffff)
+ (error "datum too large" datum))
+ (+ (* tag #x10000) datum))
+ . ,label)
+ ,@constants))))
+ (cons (car info) (inner constants))))
+\f
+;; IMPORTANT:
+;; frame-size and uuo-label are switched (with respect to the 68k
+;; version) in order to preserve the arity in a constant position (the
+;; i386 is little-endian). The invocation rule for uuo-links has been
+;; changed to take the extra 2 bytes into account.
+;;
+;; Like closures, execute caches use pc-relative JMP instructions,
+;; which can only be relocated if the old address is available.
+;; Thus execute-cache blocks are extended by a single word that
+;; contains its own address.
+
+(define (transmogrifly uuos)
+ (define (do-rest uuos)
+ (define (inner name assoc)
+ (if (null? assoc)
+ (do-rest (cdr uuos))
+ (cons (cons (caar assoc) ; frame-size
+ (cdar assoc)) ; uuo-label
+ (cons (cons name ; variable name
+ (allocate-constant-label)) ; dummy label
+ (inner name (cdr assoc))))))
+
+ (if (null? uuos)
+ '()
+ (inner (caar uuos) (cdar uuos))))
+
+ (if (null? uuos)
+ '()
+ (cons (cons false (allocate-constant-label)) ; relocation address
+ (do-rest uuos))))
+\f
+;;; Local Variables: ***
+;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
+;;; End: ***
--- /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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; LAP Generation Rules: Interpreter Calls
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\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!)
+ #|
+ ,@(invoke-interface/call
+ (if safe?
+ code:compiler-safe-reference-trap
+ code:compiler-reference-trap))
+ |#
+ ,@(invoke-hook/call (if safe?
+ entry:compiler-safe-reference-trap
+ entry:compiler-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!)
+ #|
+ ,@(invoke-interface/call code:compiler-assignment-trap)
+ |#
+ ,@(invoke-hook/call entry:compiler-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!)
+ ,@(invoke-interface/call code:compiler-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 code:compiler-access environment name))
+
+(define-rule statement
+ (INTERPRETER-CALL:LOOKUP (? cont) (? environment) (? name) (? safe?))
+ (QUALIFIER (interpreter-call-argument? environment))
+ cont ; ignored
+ (lookup-call (if safe? code:compiler-safe-lookup code:compiler-lookup)
+ environment name))
+
+(define-rule statement
+ (INTERPRETER-CALL:UNASSIGNED? (? cont) (? environment) (? name))
+ (QUALIFIER (interpreter-call-argument? environment))
+ cont ; ignored
+ (lookup-call code:compiler-unassigned? environment name))
+
+(define-rule statement
+ (INTERPRETER-CALL:UNBOUND? (? cont) (? environment) (? name))
+ (QUALIFIER (interpreter-call-argument? environment))
+ cont ; ignored
+ (lookup-call code:compiler-unbound? environment name))
+
+(define (lookup-call code environment name)
+ (let ((set-environment
+ (interpreter-call-argument->machine-register! environment edx)))
+ (LAP ,@set-environment
+ ,@(clear-map (clear-map!))
+ ,@(load-constant (INST-EA (R ,ebx)) name)
+ ,@(invoke-interface/call code))))
+\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 code:compiler-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 code:compiler-set! environment name value))
+
+(define (assignment-call code 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 ,reg:utility-arg-4 (R ,eax))
+ ,@(load-constant (INST-EA (R ,ebx)) name)
+ ,@(invoke-interface/call code))))
\ 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; LAP Generation Rules: Fixnum operations.
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Making and examining fixnums
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source)))))
+ (address->fixnum (standard-move-to-target! source target)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source))))
+ (object->fixnum (standard-move-to-target! source target)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source))))
+ (address->fixnum (standard-move-to-target! source target)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source))))
+ (fixnum->object (standard-move-to-target! source target)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source))))
+ (fixnum->address (standard-move-to-target! source target)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (ADDRESS->FIXNUM (OBJECT->ADDRESS (CONSTANT (? constant)))))
+ (convert-object/constant->register target constant address->fixnum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant))))
+ (load-fixnum-constant constant (target-register-reference target)))
+\f
+;;;; Fixnum Operations
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-1-ARG (? operator) (REGISTER (? source)) (? overflow?)))
+ overflow? ; ignored
+ (fixnum-1-arg target source (fixnum-1-arg/operate operator)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operator)
+ (REGISTER (? source1))
+ (REGISTER (? source2))
+ (? overflow?)))
+ ((fixnum-2-args/operate operator) target source1 source2 overflow?))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operator)
+ (REGISTER (? source))
+ (OBJECT->FIXNUM (CONSTANT (? constant)))
+ (? overflow?)))
+ (QUALIFIER (or (and (not (eq? operator 'FIXNUM-QUOTIENT))
+ (not (eq? operator 'FIXNUM-REMAINDER)))
+ (integer-power-of-2? (abs constant))))
+ (fixnum-2-args/register*constant operator target source constant overflow?))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operator)
+ (OBJECT->FIXNUM (CONSTANT (? constant)))
+ (REGISTER (? source))
+ (? overflow?)))
+ (QUALIFIER (fixnum-2-args/commutative? operator))
+ (fixnum-2-args/register*constant operator target source constant overflow?))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operator)
+ (OBJECT->FIXNUM (CONSTANT 0))
+ (REGISTER (? source))
+ (? overflow?)))
+ (QUALIFIER (not (fixnum-2-args/commutative? operator)))
+ overflow? ; ignored
+ (if (eq? operator 'MINUS-FIXNUM)
+ (fixnum-1-arg target source (fixnum-1-arg/operate 'FIXNUM-NEGATE))
+ (load-fixnum-constant 0 (target-register-reference target))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (OBJECT->FIXNUM (CONSTANT (? n)))
+ (OBJECT->FIXNUM (REGISTER (? source)))
+ #f))
+ (fixnum-1-arg target source
+ (lambda (target)
+ (multiply-fixnum-constant target (* n fixnum-1) #f))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (OBJECT->FIXNUM (REGISTER (? source)))
+ (OBJECT->FIXNUM (CONSTANT (? n)))
+ #f))
+ (fixnum-1-arg target source
+ (lambda (target)
+ (multiply-fixnum-constant target (* n fixnum-1) #f))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM->OBJECT
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (OBJECT->FIXNUM (REGISTER (? source)))
+ (OBJECT->FIXNUM (CONSTANT 2))
+ #f)))
+ (QUALIFIER (multiply-object-by-2?))
+ (multiply-object-by-2 target source))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM->OBJECT
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (OBJECT->FIXNUM (CONSTANT 2))
+ (OBJECT->FIXNUM (REGISTER (? source)))
+ #f)))
+ (QUALIFIER (multiply-object-by-2?))
+ (multiply-object-by-2 target source))
+\f
+;;;; Fixnum Predicates
+
+(define-rule predicate
+ (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? register)))
+ (fixnum-branch! (fixnum-predicate/unary->binary predicate))
+ (LAP (CMP W ,(source-register-reference register) (& 0))))
+
+(define-rule predicate
+ (FIXNUM-PRED-1-ARG (? predicate) (OBJECT->FIXNUM (REGISTER (? register))))
+ (QUALIFIER (or (eq? predicate 'NEGATIVE-FIXNUM?)
+ (eq? predicate 'ZERO-FIXNUM?)))
+ (fixnum-branch! predicate)
+ (object->fixnum (standard-move-to-temporary! register)))
+
+(define-rule predicate
+ (FIXNUM-PRED-1-ARG (? predicate) (? expression rtl:simple-offset?))
+ (fixnum-branch! (fixnum-predicate/unary->binary predicate))
+ (LAP (CMP W ,(offset->reference! expression) (& 0))))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? register-1))
+ (REGISTER (? register-2)))
+ (fixnum-branch! predicate)
+ (compare/register*register register-1 register-2))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? register))
+ (? expression rtl:simple-offset?))
+ (fixnum-branch! predicate)
+ (LAP (CMP W ,(source-register-reference register)
+ ,(offset->reference! expression))))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (? expression rtl:simple-offset?)
+ (REGISTER (? register)))
+ (fixnum-branch! predicate)
+ (LAP (CMP W ,(offset->reference! expression)
+ ,(source-register-reference register))))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? register))
+ (OBJECT->FIXNUM (CONSTANT (? constant))))
+ (fixnum-branch! predicate)
+ (LAP (CMP W ,(source-register-reference register)
+ (& ,(* constant fixnum-1)))))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (OBJECT->FIXNUM (CONSTANT (? constant)))
+ (REGISTER (? register)))
+ (fixnum-branch! (commute-fixnum-predicate predicate))
+ (LAP (CMP W ,(source-register-reference register)
+ (& ,(* constant fixnum-1)))))
+\f
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (? expression rtl:simple-offset?)
+ (OBJECT->FIXNUM (CONSTANT (? constant))))
+ (fixnum-branch! predicate)
+ (LAP (CMP W ,(offset->reference! expression)
+ (& ,(* constant fixnum-1)))))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (OBJECT->FIXNUM (CONSTANT (? constant)))
+ (? expression rtl:simple-offset?))
+ (fixnum-branch! (commute-fixnum-predicate predicate))
+ (LAP (CMP W ,(offset->reference! expression)
+ (& ,(* constant fixnum-1)))))
+
+;; This assumes that the immediately preceding instruction sets the
+;; condition code bits correctly.
+
+(define-rule predicate
+ (OVERFLOW-TEST)
+ (set-current-branches!
+ (lambda (label)
+ (LAP (JO (@PCR ,label))))
+ (lambda (label)
+ (LAP (JNO (@PCR ,label)))))
+ (LAP))
+\f
+;;;; Utilities
+
+(define (object->fixnum target)
+ (LAP (SAL W ,target (& ,scheme-type-width))))
+
+(define (fixnum->object target)
+ (LAP (OR W ,target (& ,(ucode-type fixnum)))
+ (ROR W ,target (& ,scheme-type-width))))
+
+(define (address->fixnum target)
+ (LAP (SAL W ,target (& ,scheme-type-width))))
+
+(define (fixnum->address target)
+ (LAP (SHR W ,target (& ,scheme-type-width))))
+
+(define-integrable fixnum-1 64) ; (expt 2 scheme-type-width) ***
+
+(define-integrable fixnum-bits-mask
+ (-1+ fixnum-1))
+
+(define (word->fixnum target)
+ (LAP (AND W ,target (& ,(fix:not fixnum-bits-mask)))))
+
+(define (integer-power-of-2? n)
+ (let loop ((power 1) (exponent 0))
+ (cond ((< n power) #f)
+ ((= n power) exponent)
+ (else
+ (loop (* 2 power) (1+ exponent))))))
+
+(define (load-fixnum-constant constant target)
+ (if (zero? constant)
+ (LAP (XOR W ,target ,target))
+ (LAP (MOV W ,target (& ,(* constant fixnum-1))))))
+
+(define (add-fixnum-constant target constant overflow?)
+ (let ((value (* constant fixnum-1)))
+ (cond ((and (zero? value) (not overflow?))
+ (LAP))
+ ((and (not (fits-in-signed-byte? value))
+ (fits-in-signed-byte? (- value)))
+ (LAP (SUB W ,target (& ,(- value)))))
+ (else
+ (LAP (ADD W ,target (& ,value)))))))
+
+(define (multiply-fixnum-constant target constant overflow?)
+ (cond ((zero? constant)
+ (load-fixnum-constant 0 target))
+ ((= constant 1)
+ (if (not overflow?)
+ (LAP)
+ (add-fixnum-constant target 0 overflow?)))
+ ((= constant -1)
+ (LAP (NEG W ,target)))
+ ((and (not overflow?)
+ (integer-power-of-2? (abs constant)))
+ =>
+ (lambda (expt-of-2)
+ (if (negative? constant)
+ (LAP (SAL W ,target (& ,expt-of-2))
+ (NEG W ,target))
+ (LAP (SAL W ,target (& ,expt-of-2))))))
+ (else
+ ;; target must be a register!
+ (LAP (IMUL W ,target ,target (& ,constant))))))
+\f
+;;;; Operation tables
+
+(define fixnum-methods/1-arg
+ (list 'FIXNUM-METHODS/1-ARG))
+
+(define-integrable (fixnum-1-arg/operate operator)
+ (lookup-arithmetic-method operator fixnum-methods/1-arg))
+
+(define-integrable (fixnum-1-arg target source operation)
+ (operation (standard-move-to-target! source target)))
+
+(define fixnum-methods/2-args
+ (list 'FIXNUM-METHODS/2-ARGS))
+
+(define-integrable (fixnum-2-args/operate operator)
+ (lookup-arithmetic-method operator fixnum-methods/2-args))
+
+(define fixnum-methods/2-args-constant
+ (list 'FIXNUM-METHODS/2-ARGS-CONSTANT))
+
+(define-integrable (fixnum-2-args/operate-constant operator)
+ (lookup-arithmetic-method operator fixnum-methods/2-args-constant))
+
+(define (fixnum-2-args/commutative? operator)
+ (memq operator '(PLUS-FIXNUM
+ MULTIPLY-FIXNUM
+ FIXNUM-AND
+ FIXNUM-OR
+ FIXNUM-XOR)))
+\f
+(define ((fixnum-2-args/standard commutative? operate) target source1
+ source2 overflow?)
+ overflow? ; ignored
+ (two-arg-register-operation operate
+ commutative?
+ target
+ source1
+ source2))
+
+(define (two-arg-register-operation operate commutative?
+ target source1 source2)
+ (let* ((worst-case
+ (lambda (target source1 source2)
+ (LAP (MOV W ,target ,source1)
+ ,@(operate target source2))))
+ (new-target-alias!
+ (lambda ()
+ (let ((source1 (any-reference source1))
+ (source2 (any-reference source2)))
+ (delete-dead-registers!)
+ (worst-case (target-register-reference target)
+ source1
+ source2)))))
+ (cond ((not (pseudo-register? target))
+ (if (not (eq? (register-type target) 'GENERAL))
+ (error "two-arg-register-operation: Wrong type register"
+ target 'GENERAL)
+ (worst-case (register-reference target)
+ (any-reference source1)
+ (any-reference source2))))
+ ((register-copy-if-available source1 'GENERAL target)
+ =>
+ (lambda (get-alias-ref)
+ (if (= source2 source1)
+ (let ((ref (get-alias-ref)))
+ (operate ref ref))
+ (let ((source2 (any-reference source2)))
+ (operate (get-alias-ref) source2)))))
+ ((not commutative?)
+ (new-target-alias!))
+ ((register-copy-if-available source2 'GENERAL target)
+ =>
+ (lambda (get-alias-ref)
+ (let ((source1 (any-reference source1)))
+ (operate (get-alias-ref) source1))))
+ (else
+ (new-target-alias!)))))
+
+(define (fixnum-2-args/register*constant operator target
+ source constant overflow?)
+ (fixnum-1-arg
+ target source
+ (lambda (target)
+ ((fixnum-2-args/operate-constant operator) target constant overflow?))))
+\f
+;;;; Arithmetic operations
+
+(define-arithmetic-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
+ (lambda (target)
+ (add-fixnum-constant target 1 #f)))
+
+(define-arithmetic-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg
+ (lambda (target)
+ (add-fixnum-constant target -1 #f)))
+
+(define-arithmetic-method 'FIXNUM-NOT fixnum-methods/1-arg
+ (lambda (target)
+ (LAP (NOT W ,target)
+ ,@(word->fixnum target))))
+
+(define-arithmetic-method 'FIXNUM-NEGATE fixnum-methods/1-arg
+ (lambda (target)
+ (LAP (NEG W ,target))))
+
+(let-syntax
+ ((binary-operation
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (list-ref form 1))
+ (instr (list-ref form 2))
+ (commutative? (list-ref form 3))
+ (idempotent? (list-ref form 4)))
+ `(define-arithmetic-method ',name fixnum-methods/2-args
+ (fixnum-2-args/standard
+ ,commutative?
+ (lambda (target source2)
+ (if (and ,idempotent? (equal? target source2))
+ (LAP)
+ (LAP (,instr W ,',target ,',source2)))))))))))
+
+ #| (binary-operation PLUS-FIXNUM ADD #t #f) |#
+ (binary-operation MINUS-FIXNUM SUB #f #f)
+ (binary-operation FIXNUM-AND AND #t #t)
+ (binary-operation FIXNUM-OR OR #t #t)
+ (binary-operation FIXNUM-XOR XOR #t #f))
+
+(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args
+ (let* ((operate
+ (lambda (target source2)
+ (LAP (ADD W ,target ,source2))))
+ (standard (fixnum-2-args/standard #t operate)))
+
+ (lambda (target source1 source2 overflow?)
+ (if overflow?
+ (standard target source1 source2 overflow?)
+ (let ((one (register-alias source1 'GENERAL))
+ (two (register-alias source2 'GENERAL)))
+ (cond ((not (and one two))
+ (standard target source1 source2 overflow?))
+ ((register-copy-if-available source1 'GENERAL target)
+ =>
+ (lambda (get-tgt)
+ (operate (get-tgt) (register-reference two))))
+ ((register-copy-if-available source2 'GENERAL target)
+ =>
+ (lambda (get-tgt)
+ (operate (get-tgt) (register-reference one))))
+ (else
+ (let ((target (target-register-reference target)))
+ (LAP (LEA ,target (@RI ,one ,two 1)))))))))))
+\f
+(define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args
+ (fixnum-2-args/standard
+ #f
+ (lambda (target source2)
+ (if (equal? target source2)
+ (load-fixnum-constant 0 target)
+ (let ((temp (temporary-register-reference)))
+ (LAP ,@(if (equal? temp source2)
+ (LAP)
+ (LAP (MOV W ,temp ,source2)))
+ (NOT W ,temp)
+ (AND W ,target ,temp)))))))
+
+(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args
+ (fixnum-2-args/standard
+ #f
+ (lambda (target source2)
+ (cond ((not (equal? target source2))
+ (LAP (SAR W ,target (& ,scheme-type-width))
+ (IMUL W ,target ,source2)))
+ ((even? scheme-type-width)
+ (LAP (SAR W ,target (& ,(quotient scheme-type-width 2)))
+ (IMUL W ,target ,target)))
+ (else
+ (let ((temp (temporary-register-reference)))
+ (LAP (MOV W ,temp ,target)
+ (SAR W ,target (& ,scheme-type-width))
+ (IMUL W ,target ,temp))))))))
+
+(define-arithmetic-method 'FIXNUM-LSH fixnum-methods/2-args
+ (let ((operate
+ (lambda (target source2)
+ ;; SOURCE2 is guaranteed not to be ECX because of the
+ ;; require-register! used below.
+ ;; TARGET can be ECX only if the rule has machine register
+ ;; ECX as the target, unlikely, but it must be handled!
+ (let ((with-target
+ (lambda (target)
+ (let ((jlabel (generate-label 'SHIFT-JOIN))
+ (slabel (generate-label 'SHIFT-NEGATIVE))
+ (zlabel (generate-label 'SHIFT-ZERO)))
+ (LAP (MOV W (R ,ecx) ,source2)
+ (SAR W (R ,ecx) (& ,scheme-type-width))
+ (JS B (@PCR ,slabel))
+ (CMP W (R ,ecx) (& ,scheme-datum-width))
+ (JGE B (@PCR ,zlabel))
+ (SHL W ,target (R ,ecx))
+ (JMP B (@PCR ,jlabel))
+ (LABEL ,zlabel)
+ (XOR W ,target ,target)
+ (JMP B (@PCR ,jlabel))
+ (LABEL ,slabel)
+ (NEG W (R ,ecx))
+ (CMP W (R ,ecx) (& ,scheme-datum-width))
+ (JGE W (@PCR ,zlabel))
+ (SHR W ,target (R ,ecx))
+ ,@(word->fixnum target)
+ (LABEL ,jlabel))))))
+
+ (if (not (equal? target (INST-EA (R ,ecx))))
+ (with-target target)
+ (let ((temp (temporary-register-reference)))
+ (LAP (MOV W ,temp ,target)
+ ,@(with-target temp)
+ (MOV W ,target ,temp))))))))
+ (lambda (target source1 source2 overflow?)
+ overflow? ; ignored
+ (require-register! ecx)
+ (two-arg-register-operation operate
+ #f
+ target
+ source1
+ source2))))
+\f
+(define (do-division target source1 source2 result-reg)
+ (prefix-instructions! (load-machine-register! source1 eax))
+ (need-register! eax)
+ (require-register! edx)
+ (rtl-target:=machine-register! target result-reg)
+ (let ((source2 (any-reference source2)))
+ (LAP (MOV W (R ,edx) (R ,eax))
+ (SAR W (R ,edx) (& 31))
+ (IDIV W (R ,eax) ,source2))))
+
+(define-arithmetic-method 'FIXNUM-QUOTIENT fixnum-methods/2-args
+ (lambda (target source1 source2 overflow?)
+ overflow? ; ignored
+ (if (= source2 source1)
+ (load-fixnum-constant 1 (target-register-reference target))
+ (LAP ,@(do-division target source1 source2 eax)
+ (SAL W (R ,eax) (& ,scheme-type-width))))))
+
+(define-arithmetic-method 'FIXNUM-REMAINDER fixnum-methods/2-args
+ (lambda (target source1 source2 overflow?)
+ overflow? ; ignored
+ (if (= source2 source1)
+ (load-fixnum-constant 0 (target-register-reference target))
+ (do-division target source1 source2 edx))))
+
+(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args-constant
+ (lambda (target n overflow?)
+ (add-fixnum-constant target n overflow?)))
+
+(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args-constant
+ (lambda (target n overflow?)
+ (add-fixnum-constant target (- 0 n) overflow?)))
+
+(define-arithmetic-method 'FIXNUM-OR fixnum-methods/2-args-constant
+ (lambda (target n overflow?)
+ overflow? ; ignored
+ (cond ((zero? n)
+ (LAP))
+ ((= n -1)
+ (load-fixnum-constant -1 target))
+ (else
+ (LAP (OR W ,target (& ,(* n fixnum-1))))))))
+
+(define-arithmetic-method 'FIXNUM-XOR fixnum-methods/2-args-constant
+ (lambda (target n overflow?)
+ overflow? ; ignored
+ (cond ((zero? n)
+ (LAP))
+ ((= n -1)
+ (LAP (NOT W ,target)
+ ,@(word->fixnum target)))
+ (else
+ (LAP (XOR W ,target (& ,(* n fixnum-1))))))))
+
+(define-arithmetic-method 'FIXNUM-AND fixnum-methods/2-args-constant
+ (lambda (target n overflow?)
+ overflow? ; ignored
+ (cond ((zero? n)
+ (load-fixnum-constant 0 target))
+ ((= n -1)
+ (LAP))
+ (else
+ (LAP (AND W ,target (& ,(* n fixnum-1))))))))
+
+(define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args-constant
+ (lambda (target n overflow?)
+ overflow? ; ignored
+ (cond ((zero? n)
+ (LAP))
+ ((= n -1)
+ (load-fixnum-constant 0 target))
+ (else
+ (LAP (AND W ,target (& ,(* (fix:not n) fixnum-1))))))))
+
+(define-arithmetic-method 'FIXNUM-LSH fixnum-methods/2-args-constant
+ (lambda (target n overflow?)
+ overflow? ; ignored
+ (cond ((zero? n)
+ (LAP))
+ ((not (<= (- 0 scheme-datum-width) n scheme-datum-width))
+ (load-fixnum-constant 0 target))
+ ((not (negative? n))
+ (LAP (SHL W ,target (& ,n))))
+ (else
+ (LAP (SHR W ,target (& ,(- 0 n)))
+ ,@(word->fixnum target))))))
+\f
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM->OBJECT
+ (FIXNUM-2-ARGS FIXNUM-LSH
+ (REGISTER (? source))
+ (OBJECT->FIXNUM (CONSTANT (? n)))
+ #f)))
+ (QUALIFIER (and (exact-integer? n) (< (- scheme-datum-width) n 0)))
+ (fixnum-1-arg target source
+ (lambda (target)
+ (LAP (SHR W ,target (& ,(- scheme-type-width n)))
+ (OR W ,target
+ (&U ,(make-non-pointer-literal (ucode-type fixnum) 0)))))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS FIXNUM-LSH
+ (OBJECT->FIXNUM (REGISTER (? source)))
+ (OBJECT->FIXNUM (CONSTANT (? n)))
+ #f))
+ (QUALIFIER (and (exact-integer? n) (< 0 n scheme-datum-width)))
+ (fixnum-1-arg target source
+ (lambda (target)
+ (LAP (SHL W ,target (& ,(+ scheme-type-width n)))))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM->OBJECT
+ (FIXNUM-2-ARGS FIXNUM-LSH
+ (OBJECT->FIXNUM (REGISTER (? source)))
+ (OBJECT->FIXNUM (CONSTANT 1))
+ #f)))
+ (QUALIFIER (multiply-object-by-2?))
+ (multiply-object-by-2 target source))
+
+;; Multiply by two by adding. This can be done directly on the object
+;; if the fixnum tag is even, since the tag lsb acts as a place where
+;; the carry can stop.
+
+(define-integrable (multiply-object-by-2?)
+ (even? (ucode-type fixnum)))
+
+(define (multiply-object-by-2 target source)
+ (let ((src (source-register source)))
+ (let ((tgt (target-register-reference target)))
+ (let ((subtract-one-typecode
+ (- #x100000000 (make-non-pointer-literal (ucode-type fixnum) 0)))
+ (mask-out-carry-into-typecode-lsb
+ (make-non-pointer-literal (ucode-type fixnum) (object-datum -1))))
+ (LAP (LEA ,tgt (@ROI UW ,src ,subtract-one-typecode ,src 1))
+ (AND W ,tgt (&U ,mask-out-carry-into-typecode-lsb)))))))
+
+(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args-constant
+ (lambda (target n overflow?)
+ (multiply-fixnum-constant target n overflow?)))
+
+(define-arithmetic-method 'FIXNUM-QUOTIENT fixnum-methods/2-args-constant
+ (lambda (target n overflow?)
+ overflow? ; ignored
+ (cond ((= n 1)
+ (LAP))
+ ((= n -1)
+ (LAP (NEG W ,target)))
+ ((integer-power-of-2? (if (negative? n) (- 0 n) n))
+ =>
+ (lambda (expt-of-2)
+ (let ((label (generate-label 'QUO-SHIFT))
+ (absn (if (negative? n) (- 0 n) n)))
+ (LAP (CMP W ,target (& 0))
+ (JGE B (@PCR ,label))
+ (ADD W ,target (& ,(* (-1+ absn) fixnum-1)))
+ (LABEL ,label)
+ (SAR W ,target (& ,expt-of-2))
+ ,@(word->fixnum target)
+ ,@(if (negative? n)
+ (LAP (NEG W ,target))
+ (LAP))))))
+ (else
+ (error "Fixnum-quotient/constant: Bad value" n)))))
+\f
+(define-arithmetic-method 'FIXNUM-REMAINDER fixnum-methods/2-args-constant
+ (lambda (target n overflow?)
+ ;; (remainder x y) is 0 or has the sign of x.
+ ;; Thus we can always "divide" by (abs y) to make things simpler.
+ overflow? ; ignored
+ (let ((n (if (negative? n) (- 0 n) n)))
+ (cond ((= n 1)
+ (load-fixnum-constant 0 target))
+ ((integer-power-of-2? n)
+ (let ((sign (temporary-register-reference))
+ (label (generate-label 'REM-MERGE)))
+ ;; This may produce a branch to a branch, but a
+ ;; peephole optimizer should be able to fix this.
+ (LAP (MOV W ,sign ,target)
+ (AND W ,target (& ,(* (-1+ n) fixnum-1)))
+ (JZ B (@PCR ,label))
+ (SAR W ,sign (& ,(-1+ scheme-object-width)))
+ (AND W ,sign (& ,(* n (- 0 fixnum-1))))
+ (OR W ,target ,sign)
+ (LABEL ,label))))
+ (else
+ (error "Fixnum-remainder/constant: Bad value" n))))))
+
+(define (fixnum-predicate/unary->binary predicate)
+ (case predicate
+ ((ZERO-FIXNUM?) 'EQUAL-FIXNUM?)
+ ((NEGATIVE-FIXNUM?) 'LESS-THAN-FIXNUM?)
+ ((POSITIVE-FIXNUM?) 'GREATER-THAN-FIXNUM?)
+ (else
+ (error "fixnum-predicate/unary->binary: Unknown unary predicate"
+ predicate))))
+
+(define (commute-fixnum-predicate predicate)
+ (case predicate
+ ((EQUAL-FIXNUM?) 'EQUAL-FIXNUM?)
+ ((LESS-THAN-FIXNUM?) 'GREATER-THAN-FIXNUM?)
+ ((GREATER-THAN-FIXNUM?) 'LESS-THAN-FIXNUM?)
+ ((UNSIGNED-LESS-THAN-FIXNUM?) 'UNSIGNED-GREATER-THAN-FIXNUM?)
+ ((UNSIGNED-GREATER-THAN-FIXNUM?) 'UNSIGNED-LESS-THAN-FIXNUM?)
+ (else
+ (error "commute-fixnum-predicate: Unknown predicate"
+ predicate))))
+
+(define (fixnum-branch! predicate)
+ (case predicate
+ ((EQUAL-FIXNUM? ZERO-FIXNUM?)
+ (set-equal-branches!))
+ ((LESS-THAN-FIXNUM?)
+ (set-current-branches! (lambda (label)
+ (LAP (JL (@PCR ,label))))
+ (lambda (label)
+ (LAP (JGE (@PCR ,label))))))
+ ((GREATER-THAN-FIXNUM?)
+ (set-current-branches! (lambda (label)
+ (LAP (JG (@PCR ,label))))
+ (lambda (label)
+ (LAP (JLE (@PCR ,label))))))
+ ((UNSIGNED-LESS-THAN-FIXNUM?)
+ (set-current-branches! (lambda (label)
+ (LAP (JB (@PCR ,label))))
+ (lambda (label)
+ (LAP (JAE (@PCR ,label))))))
+ ((UNSIGNED-GREATER-THAN-FIXNUM?)
+ (set-current-branches! (lambda (label)
+ (LAP (JA (@PCR ,label))))
+ (lambda (label)
+ (LAP (JBE (@PCR ,label))))))
+ ((NEGATIVE-FIXNUM?)
+ (set-current-branches! (lambda (label)
+ (LAP (JS (@PCR ,label))))
+ (lambda (label)
+ (LAP (JNS (@PCR ,label))))))
+ ((POSITIVE-FIXNUM?)
+ (error "fixnum-branch!: Cannot handle directly" predicate))
+ (else
+ (error "fixnum-branch!: Unknown predicate" predicate))))
\ 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; LAP Generation Rules: Flonum rules
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;; ****
+;; Missing: 2 argument operations and predicates with non-trivial
+;; constant arguments.
+;; Also missing with (OBJECT->FLOAT (REGISTER ...)) operands.
+;; ****
+
+(define (flonum-source! register)
+ (floreg->sti (load-alias-register! register 'FLOAT)))
+
+(define (flonum-target! pseudo-register)
+ (delete-dead-registers!)
+ (floreg->sti (allocate-alias-register! pseudo-register 'FLOAT)))
+
+(define (flonum-temporary!)
+ (allocate-temporary-register! 'FLOAT))
+
+(define-rule statement
+ ;; convert a floating-point number to a flonum object
+ (ASSIGN (REGISTER (? target))
+ (FLOAT->OBJECT (REGISTER (? source))))
+ (let* ((source (register-alias source 'FLOAT))
+ (target (target-register-reference target)))
+ (LAP (MOV W (@R ,regnum:free-pointer)
+ (&U ,(make-non-pointer-literal
+ (ucode-type manifest-nm-vector)
+ 2)))
+ ,@(if (not source)
+ ;; Value is in memory home
+ (let ((off (pseudo-register-offset source))
+ (temp (temporary-register-reference)))
+ (LAP (MOV W ,target
+ ,(offset-reference regnum:regs-pointer off))
+ (MOV W ,temp
+ ,(offset-reference regnum:regs-pointer (1+ off)))
+ (MOV W (@RO B ,regnum:free-pointer 4) ,target)
+ (MOV W (@RO B ,regnum:free-pointer 8) ,temp)))
+ (store-float (floreg->sti source)
+ (INST-EA (@RO B ,regnum:free-pointer 4))))
+ (LEA ,target
+ (@RO UW ,regnum:free-pointer
+ ,(make-non-pointer-literal (ucode-type flonum) 0)))
+ (ADD W (R ,regnum:free-pointer) (& 12)))))
+
+#|
+(define-rule statement
+ ;; convert a flonum object to a floating-point number
+ (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source))))
+ (let* ((source (move-to-temporary-register! source 'GENERAL))
+ (target (flonum-target! target)))
+ (LAP ,@(object->address (register-reference source))
+ ,@(load-float (INST-EA (@RO B ,source 4)) target))))
+|#
+
+(define-rule statement
+ ;; Convert a flonum object to a floating-point number. Unlike the
+ ;; version above which has an implicits OBJECT->ADDRESS, this one
+ ;; uses the addressing mode to remove the type-code. Saves a cycle
+ ;; and maybe a register spill if SOURCE is live after instruction.
+ (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source))))
+ (let* ((source (source-register source))
+ (target (flonum-target! target)))
+ (object->float source target)))
+
+(define (object->float source-register target)
+ (let ((untagging+offset
+ (- 4 (make-non-pointer-literal (ucode-type flonum) 0))))
+ (load-float (INST-EA (@RO W ,source-register ,untagging+offset)) target)))
+\f
+;;;; Floating-point vector support.
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (? expression rtl:simple-float-offset?))
+ (let* ((source (float-offset->reference! expression))
+ (target (flonum-target! target)))
+ (load-float source target)))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:simple-float-offset?) (REGISTER (? source)))
+ (let ((source (flonum-source! source))
+ (target (float-offset->reference! expression)))
+ (store-float source target)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (? expression rtl:detagged-float-offset?))
+ (with-detagged-float-location expression
+ (lambda (temp)
+ (load-float temp target))))
+
+(define-rule statement
+ (ASSIGN (? expression rtl:detagged-float-offset?)
+ (REGISTER (? source)))
+ (with-detagged-float-location expression
+ (lambda (temp)
+ (store-float (flonum-source! source) temp))))
+
+(define (with-detagged-float-location rtl-expression recvr)
+ ;; Never needs to protect a register because it is a float register!
+ (with-decoded-detagged-float-offset rtl-expression
+ (lambda (base index w-offset)
+ (with-indexed-address base index 8 (* 4 w-offset) false recvr))))
+
+(define (rtl:detagged-float-offset? expression)
+ (and (rtl:float-offset? expression)
+ (let ((base (rtl:float-offset-base expression))
+ (offset (rtl:float-offset-offset expression)))
+ (and (rtl:offset-address? base)
+ (rtl:machine-constant? (rtl:offset-address-offset base))
+ (rtl:detagged-index? (rtl:offset-address-base base)
+ offset)))
+ expression))
+
+(define (with-decoded-detagged-float-offset expression recvr)
+ (let ((base (rtl:float-offset-base expression))
+ (index (rtl:float-offset-offset expression)))
+ (let ((base* (rtl:offset-address-base base)))
+ (recvr (rtl:register-number (if (rtl:register? base*)
+ base*
+ (rtl:object->address-expression base*)))
+ (rtl:register-number (if (rtl:register? index)
+ index
+ (rtl:object->datum-expression index)))
+ (rtl:machine-constant-value (rtl:offset-address-offset base))))))
+
+(define (load-float ea sti)
+ (LAP (FLD D ,ea)
+ (FSTP (ST ,(1+ sti)))))
+
+(define (store-float sti ea)
+ (if (zero? sti)
+ (LAP (FST D ,ea))
+ (LAP (FLD (ST ,sti))
+ (FSTP D ,ea))))
+\f
+;;;; Flonum Arithmetic
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?)))
+ overflow? ;ignore
+ ((flonum-1-arg/operator operation) target source))
+
+(define ((flonum-unary-operation/general operate) target source)
+ (define (default)
+ (let* ((source (flonum-source! source))
+ (target (flonum-target! target)))
+ (operate target source)))
+ ;; Attempt to reuse source for target if it is in ST(0).
+ ;; Otherwise we will target ST(0) by sorting the machine registers.
+ (cond ((and (pseudo-register? target) (pseudo-register? source)
+ (eqv? fr0 (pseudo-register-alias *register-map* 'FLOAT source)))
+ (reuse-pseudo-register-alias
+ source 'FLOAT
+ (lambda (alias)
+ (let* ((sti (floreg->sti alias)))
+ (delete-register! alias)
+ (delete-dead-registers!)
+ (add-pseudo-register-alias! target alias)
+ (operate sti sti)))
+ default))
+ (else (default))))
+
+'(define ((flonum-unary-operation/general operate) target source)
+ (define (default)
+ (let* ((source (flonum-source! source))
+ (target (flonum-target! target)))
+ (operate target source)))
+ ;; Attempt to reuse source for target. This works well when the
+ ;; source is ST(0). We try to arrange this by sorting the registers
+ ;; to give allocation preference to ST(0).
+ (cond ((pseudo-register? target)
+ (reuse-pseudo-register-alias
+ source 'FLOAT
+ (lambda (alias)
+ (let* ((sti (floreg->sti alias)))
+ (delete-register! alias)
+ (delete-dead-registers!)
+ (add-pseudo-register-alias! target alias)
+ (operate sti sti)))
+ default))
+ (else (default))))
+
+'(define ((flonum-unary-operation/general operate) target source)
+ (define (default)
+ (let* ((source (flonum-source! source))
+ (target (flonum-target! target)))
+ (operate target source)))
+ ;; Attempt to reuse source for target. This works well when the
+ ;; source is ST(0). We try to arrange this by sorting the registers
+ ;; to give allocation preference to ST(0).
+ (cond ((pseudo-register? target)
+ (let ((alias
+ (and (dead-register? source)
+ (pseudo-register-alias *register-map* 'FLOAT source))))
+ (if alias
+ (default)))
+
+ (reuse-pseudo-register-alias
+ source 'FLOAT
+ (lambda (alias)
+ (let* ((sti (floreg->sti alias)))
+ (delete-register! alias)
+ (delete-dead-registers!)
+ (add-pseudo-register-alias! target alias)
+ (operate sti sti)))
+ default))
+ (else (default))))
+
+(define (flonum-1-arg/operator operation)
+ (lookup-arithmetic-method operation flonum-methods/1-arg))
+
+(define flonum-methods/1-arg
+ (list 'FLONUM-METHODS/1-ARG))
+\f
+;;; Notice the weird ,', syntax here.
+;;; If LAP changes, this may also have to change.
+
+(let-syntax
+ ((define-flonum-operation
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((primitive-name (cadr form))
+ (opcode (caddr form)))
+ `(define-arithmetic-method ',primitive-name flonum-methods/1-arg
+ (flonum-unary-operation/general
+ (lambda (target source)
+ (if (and (zero? target) (zero? source))
+ (LAP (,opcode))
+ (LAP (FLD (ST ,', source))
+ (,opcode)
+ (FSTP (ST ,',(1+ target)))))))))))))
+ (define-flonum-operation FLONUM-NEGATE FCHS)
+ (define-flonum-operation FLONUM-ABS FABS)
+ ;; Disabled: FSIN and FCOS limited to pi * 2^62.
+ ;;(define-flonum-operation FLONUM-SIN FSIN)
+ ;;(define-flonum-operation FLONUM-COS FCOS)
+ (define-flonum-operation FLONUM-SQRT FSQRT)
+ (define-flonum-operation FLONUM-ROUND FRNDINT))
+
+;; These (and FLONUM-ROUND above) presume that the default rounding mode
+;; is round-to-nearest/even
+
+(define (define-rounding prim-name mode)
+ (define-arithmetic-method prim-name flonum-methods/1-arg
+ (flonum-unary-operation/general
+ (lambda (target source)
+ (let ((temp (temporary-register-reference)))
+ (LAP (FSTCW (@R ,regnum:free-pointer))
+ ,@(if (and (zero? target) (zero? source))
+ (LAP)
+ (LAP (FLD (ST ,source))))
+ (MOV B ,temp (@RO B ,regnum:free-pointer 1))
+ (OR B (@RO B ,regnum:free-pointer 1) (&U ,mode))
+ (FNLDCW (@R ,regnum:free-pointer))
+ (FRNDINT)
+ (MOV B (@RO B ,regnum:free-pointer 1) ,temp)
+ ,@(if (and (zero? target) (zero? source))
+ (LAP)
+ (LAP (FSTP (ST ,(1+ target)))))
+ (FNLDCW (@R ,regnum:free-pointer))))))))
+
+(define-rounding 'FLONUM-CEILING #x08)
+(define-rounding 'FLONUM-FLOOR #x04)
+(define-rounding 'FLONUM-TRUNCATE #x0c)
+\f
+;; This is used in order to avoid using two stack locations for
+;; the remainder unary operations.
+
+(define ((flonum-unary-operation/stack-top operate) target source)
+ (define (finish source->top)
+ ;; Perhaps this can be improved?
+ (rtl-target:=machine-register! target fr0)
+ (LAP ,@source->top
+ ,@(operate)))
+
+ (if (or (machine-register? source)
+ (not (is-alias-for-register? fr0 source))
+ (not (dead-register? source)))
+ (finish (load-machine-register! source fr0))
+ (begin
+ (delete-dead-registers!)
+ (finish (LAP)))))
+
+(define-arithmetic-method 'FLONUM-LOG flonum-methods/1-arg
+ (flonum-unary-operation/stack-top
+ (lambda ()
+ (LAP (FLDLN2)
+ (FXCH (ST 0) (ST 1))
+ (FYL2X)))))
+
+(define-arithmetic-method 'FLONUM-EXP flonum-methods/1-arg
+ (flonum-unary-operation/stack-top
+ (lambda ()
+ ;; Hair to avoid arithmetic for non-finite inputs: exp(-inf) = 0,
+ ;; but exp(x) = x for any other non-finite x. We use the first
+ ;; free slot (1) to pick apart the double format to check for
+ ;; non-finite inputs, and (2) to avoid using two stack slots.
+ (let ((temp (temporary-register-reference))
+ (infinity-or-nan (generate-label 'INFINITY-OR-NAN))
+ (join (generate-label 'JOIN))
+ (temp-pointer regnum:free-pointer))
+ (LAP (FST D (@R ,temp-pointer))
+ (MOV W ,temp (@RO W ,temp-pointer 4))
+ (AND W ,temp (&U #x7FFFFFFF))
+ (CMP W ,temp (&U #x7FF00000))
+ (JAE B (@PCR ,infinity-or-nan))
+ ;; Compute 2^(x log_2 e) with F2XM1 and FSCALE.
+ (FLDL2E) ;st0 = lg e, st1 = x
+ (FMULP (ST 1) (ST 0)) ;st0 = x lg e
+ (FLD (ST 0)) ;st0 = x lg e, st1 = x lg e
+ (FRNDINT) ;st0 = I(x lg e), st1 = x lg e
+ (FSUB (ST 1) (ST 0)) ;st0 = I(x lg e), st1 = F(x lg e)
+ (FSTP D (@R ,temp-pointer)) ;st0 = F(x lg e), save I(x lg e)
+ (F2XM1) ;st0 = 2^F(x lg e) - 1
+ (FLD1) ;st0 = 1, st1 = 2^F(x lg e) - 1
+ (FADD) ;st0 = 2^F(x lg e)
+ (FLD D (@R ,temp-pointer)) ;st0 = I(x lg e), st1 = 2^F(x lg e)
+ (FXCH (ST 0) (ST 1)) ;st0 = 2^F(x lg e), st1 = I(x lg e)
+ (FSCALE) ;st0 = 2^F(x lg e) * 2^I(x lg e),
+ ;st1 = I(x lg e)
+ (FSTP (ST 1)) ;Drop st1, leaving in st0 the value
+ (JMP B (@PCR ,join)) ; 2^(F(x lg e) + I(x lg e)) = e^x.
+ (LABEL ,infinity-or-nan)
+ (CMP W (@RO W ,temp-pointer 4) (&U #xFFF00000))
+ (JNE B (@PCR ,join))
+ (CMP W (@RO W ,temp-pointer 0) (& 0))
+ (JNE B (@PCR ,join))
+ (FSTP (ST 0)) ;Pop argument.
+ (FLDZ) ;Return zero.
+ (LABEL ,join))))))
+\f
+#|
+;; Disabled: FPTAN limited to pi * 2^62.
+(define-arithmetic-method 'FLONUM-TAN flonum-methods/1-arg
+ (flonum-unary-operation/stack-top
+ (lambda ()
+ (LAP (FPTAN)
+ (FSTP (ST 0)) ; FPOP
+ ))))
+|#
+
+(define-arithmetic-method 'FLONUM-ATAN flonum-methods/1-arg
+ (flonum-unary-operation/stack-top
+ (lambda ()
+ (LAP (FLD1)
+ (FPATAN)))))
+
+;; For now, these preserve values in memory
+;; in order to avoid flushing a stack location.
+
+(define-arithmetic-method 'FLONUM-ACOS flonum-methods/1-arg
+ (flonum-unary-operation/stack-top
+ (lambda ()
+ (LAP (FST D (@R ,regnum:free-pointer))
+ (FMUL (ST 0) (ST 0))
+ (FLD1)
+ (F%SUBP (ST 1) (ST 0))
+ (FSQRT)
+ (FLD D (@R ,regnum:free-pointer))
+ (FPATAN)))))
+
+(define-arithmetic-method 'FLONUM-ASIN flonum-methods/1-arg
+ (flonum-unary-operation/stack-top
+ (lambda ()
+ (LAP (FST D (@R ,regnum:free-pointer))
+ (FMUL (ST 0) (ST 0))
+ (FLD1)
+ (F%SUBP (ST 1) (ST 0))
+ (FSQRT)
+ (FLD D (@R ,regnum:free-pointer))
+ (FXCH (ST 0) (ST 1))
+ (FPATAN)))))
+\f
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-2-ARGS (? operation)
+ (REGISTER (? source1))
+ (REGISTER (? source2))
+ (? overflow?)))
+ overflow? ;ignore
+ ((flonum-2-args/operator operation) target source1 source2))
+
+;; Binary instructions all use ST(0), and are of the forms
+;; Fop ST(0),ST(i)
+;; Fop ST(i),ST(0)
+;; FopP ST(i),ST(0)
+;; Fop ST(0),memory
+;;
+;; If possible, we like to target ST(0) since it is likely to be the
+;; source of a subsequent operation. Failing that, it is good to
+;; reuse one of the source aliases.
+
+(define ((flonum-binary-operation operate) target source1 source2)
+ (define (default)
+ (let* ((sti1 (flonum-source! source1))
+ (sti2 (flonum-source! source2)))
+ (operate (flonum-target! target) sti1 sti2)))
+ (define (try-reuse-1 if-cannot)
+ (reuse-pseudo-register-alias
+ source1 'FLOAT
+ (lambda (alias1)
+ (let* ((sti1 (floreg->sti alias1))
+ (sti2 (if (= source1 source2)
+ sti1
+ (flonum-source! source2))))
+ (delete-register! alias1)
+ (delete-dead-registers!)
+ (add-pseudo-register-alias! target alias1)
+ (operate sti1 sti1 sti2)))
+ if-cannot))
+ (define (try-reuse-2 if-cannot)
+ (reuse-pseudo-register-alias
+ source2 'FLOAT
+ (lambda (alias2)
+ (let* ((sti2 (floreg->sti alias2))
+ (sti1 (if (= source1 source2)
+ sti2
+ (flonum-source! source1))))
+ (delete-register! alias2)
+ (delete-dead-registers!)
+ (add-pseudo-register-alias! target alias2)
+ (operate sti2 sti1 sti2)))
+ if-cannot))
+ (cond ((pseudo-register? target)
+ (if (is-alias-for-register? fr0 source1)
+ (try-reuse-1 (lambda () (try-reuse-2 default)))
+ (try-reuse-2 (lambda () (try-reuse-1 default)))))
+ ((not (eq? (register-type target) 'FLOAT))
+ (error "flonum-2-args: Wrong type register" target 'FLOAT))
+ (else (default))))
+
+(define (flonum-2-args/operator operation)
+ (lookup-arithmetic-method operation flonum-methods/2-args))
+
+(define flonum-methods/2-args
+ (list 'FLONUM-METHODS/2-ARGS))
+
+(define (flonum-1-arg%1/operator operation)
+ (lookup-arithmetic-method operation flonum-methods/1-arg%1))
+
+(define flonum-methods/1-arg%1
+ (list 'FLONUM-METHODS/1-ARG%1))
+
+(define (flonum-1%1-arg/operator operation)
+ (lookup-arithmetic-method operation flonum-methods/1%1-arg))
+
+(define flonum-methods/1%1-arg
+ (list 'FLONUM-METHODS/1%1-ARG))
+
+(define (binary-flonum-arithmetic? operation)
+ (memq operation '(FLONUM-ADD FLONUM-SUBTRACT FLONUM-MULTIPLY FLONUM-DIVIDE)))
+\f
+(let-syntax
+ ((define-flonum-operation
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((primitive-name (list-ref form 1))
+ (op1%2 (list-ref form 2))
+ (op1%2p (list-ref form 3))
+ (op2%1 (list-ref form 4))
+ (op2%1p (list-ref form 5)))
+ `(begin
+ (define-arithmetic-method ',primitive-name flonum-methods/2-args
+ (flonum-binary-operation
+ (lambda (target source1 source2)
+ (cond ((= target source1)
+ (cond ((zero? target)
+ (LAP (,op1%2 (ST 0) (ST ,',source2))))
+ ((zero? source2)
+ (LAP (,op2%1 (ST ,',target) (ST 0))))
+ (else
+ (LAP (FLD (ST ,',source2))
+ (,op2%1p (ST ,',(1+ target)) (ST 0))))))
+ ((= target source2)
+ (cond ((zero? target)
+ (LAP (,op2%1 (ST 0) (ST ,',source1))))
+ ((zero? source1)
+ (LAP (,op1%2 (ST ,',target) (ST 0))))
+ (else
+ (LAP (FLD (ST ,',source1))
+ (,op1%2p (ST ,',(1+ target)) (ST 0))))))
+ (else
+ (LAP (FLD (ST ,',source1))
+ (,op1%2 (ST 0) (ST ,',(1+ source2)))
+ (FSTP (ST ,',(1+ target)))))))))
+
+ (define-arithmetic-method ',primitive-name
+ flonum-methods/1%1-arg
+ (flonum-unary-operation/general
+ (lambda (target source)
+ (if (= source target)
+ (LAP (FLD1)
+ (,op1%2p (ST ,',(1+ target)) (ST 0)))
+ (LAP (FLD1)
+ (,op1%2 (ST 0) (ST ,',(1+ source)))
+ (FSTP (ST ,',(1+ target))))))))
+
+ (define-arithmetic-method ',primitive-name
+ flonum-methods/1-arg%1
+ (flonum-unary-operation/general
+ (lambda (target source)
+ (if (= source target)
+ (LAP (FLD1)
+ (,op2%1p (ST ,',(1+ target)) (ST 0)))
+ (LAP (FLD1)
+ (,op2%1 (ST 0) (ST ,',(1+ source)))
+ (FSTP (ST ,',(1+ target))))))))))))))
+
+ (define-flonum-operation FLONUM-ADD FADD FADDP FADD FADDP)
+ (define-flonum-operation FLONUM-SUBTRACT F%SUB F%SUBP F%SUBR F%SUBPR)
+ (define-flonum-operation FLONUM-MULTIPLY FMUL FMULP FMUL FMULP)
+ (define-flonum-operation FLONUM-DIVIDE F%DIV F%DIVP F%DIVR F%DIVPR))
+\f
+(define-arithmetic-method 'FLONUM-ATAN2 flonum-methods/2-args
+ (lambda (target source1 source2)
+ (if (and (not (machine-register? source1))
+ (is-alias-for-register? fr0 source1)
+ (dead-register? source1))
+ (let ((source2 (flonum-source! source2)))
+ (delete-dead-registers!)
+ (rtl-target:=machine-register! target fr0)
+ (LAP (FLD (ST ,source2))
+ (FPATAN)))
+ (begin
+ (prefix-instructions! (load-machine-register! source1 fr0))
+ (need-register! fr0)
+ (let ((source2
+ (if (= source2 source1) fr0 (flonum-source! source2))))
+ (delete-dead-registers!)
+ (rtl-target:=machine-register! target fr0)
+ (LAP (FLD (ST ,source2))
+ (FPATAN)))))))
+
+(define-arithmetic-method 'FLONUM-REMAINDER flonum-methods/2-args
+ (flonum-binary-operation
+ (lambda (target source1 source2)
+ (if (zero? source2)
+ (LAP (FLD (ST ,source1))
+ (FPREM1)
+ (FSTP (ST ,(1+ target))))
+ #|
+ ;; This sequence is one cycle shorter than the one below,
+ ;; but needs two spare stack locations instead of one.
+ ;; Since FPREM1 is a variable, very slow instruction,
+ ;; the difference in time will hardly be noticeable
+ ;; but the availability of an extra "register" may be.
+ (LAP (FLD (ST ,source2))
+ (FLD (ST ,source1))
+ (FPREM1)
+ (FSTP (ST ,(+ target 2)))
+ (FSTP (ST 0))) ; FPOP
+ |#
+ (LAP (FXCH (ST 0) (ST ,source2))
+ (FLD (ST ,(if (zero? source1) source2 source1)))
+ (FPREM1)
+ (FSTP (ST ,(1+ (if (= target source2)
+ 0
+ target))))
+ (FXCH (ST 0) (ST ,source2)))))))
+\f
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-2-ARGS FLONUM-SUBTRACT
+ (OBJECT->FLOAT (CONSTANT 0.))
+ (REGISTER (? source))
+ (? overflow?)))
+ overflow? ;ignore
+ ((flonum-unary-operation/general
+ (lambda (target source)
+ (if (and (zero? target) (zero? source))
+ (LAP (FCHS))
+ (LAP (FLD (ST ,source))
+ (FCHS)
+ (FSTP (ST ,(1+ target)))))))
+ target source))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-2-ARGS (? operation)
+ (REGISTER (? source))
+ (OBJECT->FLOAT (CONSTANT 1.))
+ (? overflow?)))
+ (QUALIFIER (binary-flonum-arithmetic? operation))
+ overflow? ;ignore
+ ((flonum-1-arg%1/operator operation) target source))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-2-ARGS (? operation)
+ (OBJECT->FLOAT (CONSTANT 1.))
+ (REGISTER (? source))
+ (? overflow?)))
+ (QUALIFIER (binary-flonum-arithmetic? operation))
+ overflow? ;ignore
+ ((flonum-1%1-arg/operator operation) target source))
+\f
+;;;; Flonum Predicates
+
+(define-rule predicate
+ (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
+ (flonum-compare-zero predicate source))
+
+(define-rule predicate
+ (FLONUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? source1))
+ (REGISTER (? source2)))
+ (let* ((st1 (flonum-source! source1))
+ (st2 (flonum-source! source2)))
+ (cond ((zero? st1)
+ (flonum-branch! predicate
+ (LAP (FCOM (ST 0) (ST ,st2)))))
+ ((zero? st2)
+ (flonum-branch! (commute-flonum-predicate predicate)
+ (LAP (FCOM (ST 0) (ST ,st1)))))
+ (else
+ (flonum-branch! predicate
+ (LAP (FLD (ST ,st1))
+ (FCOMP (ST 0) (ST ,(1+ st2)))))))))
+
+(define-rule predicate
+ (FLONUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? source))
+ (OBJECT->FLOAT (CONSTANT 0.)))
+ (flonum-compare-zero predicate source))
+
+(define-rule predicate
+ (FLONUM-PRED-2-ARGS (? predicate)
+ (OBJECT->FLOAT (CONSTANT 0.))
+ (REGISTER (? source)))
+ (flonum-compare-zero (commute-flonum-predicate predicate) source))
+
+(define-rule predicate
+ (FLONUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? source))
+ (OBJECT->FLOAT (CONSTANT 1.)))
+ (flonum-compare-one predicate source))
+
+(define-rule predicate
+ (FLONUM-PRED-2-ARGS (? predicate)
+ (OBJECT->FLOAT (CONSTANT 1.))
+ (REGISTER (? source)))
+ (flonum-compare-one (commute-flonum-predicate predicate) source))
+\f
+(define (flonum-compare-zero predicate source)
+ (let ((sti (flonum-source! source)))
+ (if (zero? sti)
+ (flonum-branch! predicate
+ (LAP (FTST)))
+ (flonum-branch! (commute-flonum-predicate predicate)
+ (LAP (FLDZ)
+ (FCOMP (ST 0) (ST ,(1+ sti))))))))
+
+(define (flonum-compare-one predicate source)
+ (let ((sti (flonum-source! source)))
+ (flonum-branch! (commute-flonum-predicate predicate)
+ (LAP (FLD1)
+ (FCOMP (ST 0) (ST ,(1+ sti)))))))
+
+(define (commute-flonum-predicate pred)
+ (case pred
+ ((FLONUM-EQUAL? FLONUM-ZERO?) 'FLONUM-EQUAL?)
+ ((FLONUM-LESS? FLONUM-NEGATIVE?) 'FLONUM-GREATER?)
+ ((FLONUM-GREATER? FLONUM-POSITIVE?) 'FLONUM-LESS?)
+ (else
+ (error "commute-flonum-predicate: Unknown predicate" pred))))
+
+(define (flonum-branch! predicate prefix)
+ (case predicate
+ ((FLONUM-EQUAL? FLONUM-ZERO?)
+ (set-current-branches! (lambda (label)
+ (let ((unordered (generate-label 'UNORDERED)))
+ (LAP (JP (@PCR ,unordered))
+ (JE (@PCR ,label))
+ (LABEL ,unordered))))
+ (lambda (label)
+ (LAP (JNE (@PCR ,label))
+ (JP (@PCR ,label))))))
+ ((FLONUM-LESS? FLONUM-NEGATIVE?)
+ (set-current-branches! (lambda (label)
+ (let ((unordered (generate-label 'UNORDERED)))
+ (LAP (JP (@PCR ,unordered))
+ (JB (@PCR ,label))
+ (LABEL ,unordered))))
+ (lambda (label)
+ (LAP (JAE (@PCR ,label))
+ (JP (@PCR ,label))))))
+ ((FLONUM-GREATER? FLONUM-POSITIVE?)
+ (set-current-branches! (lambda (label)
+ (LAP (JA (@PCR ,label))))
+ (lambda (label)
+ (LAP (JBE (@PCR ,label))))))
+ (else
+ (error "flonum-branch!: Unknown predicate" predicate)))
+ (flush-register! eax)
+ (LAP ,@prefix
+ (FSTSW (R ,eax))
+ (SAHF)))
+\f
+;; This is endianness dependent!
+
+(define (flonum-value->data-decl value)
+ (let ((high (make-bit-string 32 false))
+ (low (make-bit-string 32 false)))
+ (read-bits! value 32 high)
+ (read-bits! value 64 low)
+ (LAP ,@(lap:comment `(FLOAT ,value))
+ (LONG U ,(bit-string->unsigned-integer high))
+ (LONG U ,(bit-string->unsigned-integer low)))))
+
+(define (flo:32-bit-representation-exact? value)
+ ;; Returns unsigned long representation if 32 bit representation
+ ;; exists, i.e. if all `1' significant mantissa bits fit in the 32
+ ;; bit format and the exponent is within range.
+ (let ((mant-diff (make-bit-string (- 52 23) false)))
+ (read-bits! value (+ 32 0) mant-diff)
+ (and (bit-string-zero? mant-diff)
+ (let ((expt64 (make-bit-string 11 false)))
+ (read-bits! value (+ 32 52) expt64)
+ (let ((expt (- (bit-string->unsigned-integer expt64) 1022)))
+ (and (<= -127 expt 127)
+ (let ((sign (make-bit-string 1 false))
+ (mant32 (make-bit-string 23 false)))
+ (read-bits! value (+ 32 52 11) sign)
+ (read-bits! value (+ 32 52 -23) mant32)
+ (bit-string->unsigned-integer
+ (bit-string-append
+ (bit-string-append
+ mant32
+ (unsigned-integer->bit-string 8 (+ 126 expt)))
+ sign)))))))))
+
+(define (flonum->label value block-name alignment offset data)
+ (let* ((block
+ (or (find-extra-code-block block-name)
+ (let ((block (declare-extra-code-block! block-name
+ 'ANYWHERE
+ '())))
+ (add-extra-code!
+ block
+ (LAP (PADDING ,offset ,alignment ,padding-string)))
+ block)))
+ (pairs (extra-code-block/xtra block))
+ (place (assoc value pairs)))
+ (if place
+ (cdr place)
+ (let ((label (generate-label block-name)))
+ (set-extra-code-block/xtra!
+ block
+ (cons (cons value label) pairs))
+ (add-extra-code! block
+ (LAP (LABEL ,label)
+ ,@data))
+ label))))
+
+(define (double-flonum->label fp-value)
+ (flonum->label fp-value 'DOUBLE-FLOATS 8 0
+ (flonum-value->data-decl fp-value)))
+
+(define (single-flonum->label fp-value)
+ (flonum->label fp-value 'SINGLE-FLOATS 4 0
+ (LAP ,@(lap:comment `(SINGLE-FLOAT ,fp-value))
+ (LONG U ,(flo:32-bit-representation-exact? fp-value)))))
+\f
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (CONSTANT (? fp-value))))
+ (cond ((not (flo:flonum? fp-value))
+ (error "OBJECT->FLOAT: Not a floating-point value" fp-value))
+ ((flo:= fp-value 0.0)
+ (let ((target (flonum-target! target)))
+ (LAP (FLDZ)
+ (FSTP (ST ,(1+ target))))))
+ ((flo:= fp-value 1.0)
+ (let ((target (flonum-target! target)))
+ (LAP (FLD1)
+ (FSTP (ST ,(1+ target))))))
+ (compiler:cross-compiling?
+ (let* ((temp (allocate-temporary-register! 'GENERAL))
+ (target (flonum-target! target)))
+ (LAP ,@(load-constant (register-reference temp) fp-value)
+ ,@(object->float temp target))))
+ (else
+ (let ((target (flonum-target! target)))
+ (with-pcr-float fp-value
+ (lambda (ea size)
+ (LAP (FLD ,size ,ea)
+ (FSTP (ST ,(1+ target))))))))))
+
+(define (with-pcr-float fp-value receiver)
+ (define (generate-ea label-expr size)
+ (with-pc
+ (lambda (pc-label pc-register)
+ (receiver (INST-EA (@RO W ,pc-register (- ,label-expr ,pc-label)))
+ size))))
+ (if (flo:32-bit-representation-exact? fp-value)
+ (generate-ea (single-flonum->label fp-value) 'S)
+ (generate-ea (double-flonum->label fp-value) 'D)))
--- /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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; RTL Rewrite Rules
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Synthesized Data
+
+(define-rule rewriting
+ (CONS-NON-POINTER (? type) (? datum))
+ ;; On i386, there's no difference between an address and a datum,
+ ;; so the rules for constructing non-pointer objects are the same as
+ ;; those for pointer objects.
+ (rtl:make-cons-pointer type datum))
+
+(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
+ (careful-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
+ (careful-object-datum (rtl:constant-value source))))
+
+(define (rtl:constant-non-pointer? expression)
+ (and (rtl:constant? expression)
+ (non-pointer-object? (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 (non-pointer-object? value)
+ (zero? (object-type value))
+ (zero? (careful-object-datum value)))))
+ ((rtl:cons-pointer? expression)
+ (and (let ((expression (rtl:cons-pointer-type expression)))
+ (and (rtl:machine-constant? expression)
+ (zero? (rtl:machine-constant-value expression))))
+ (let ((expression (rtl:cons-pointer-datum expression)))
+ (and (rtl:machine-constant? expression)
+ (zero? (rtl:machine-constant-value expression))))))
+ (else false)))
+\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 true)))
+ (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 true))))
+ (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 true))))
+ (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 false)
+ false)
+ false)
+ operand
+ false))
+
+;; 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 false)
+ false)
+ false)
+ false))
+
+|#
+
+(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)))
+ (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)))
+ (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 (zero? value)
+ (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))))
+
+(define-rule rewriting
+ (FLOAT-OFFSET (REGISTER (? base register-known-value))
+ (MACHINE-CONSTANT (? value)))
+ (QUALIFIER
+ (and (rtl:offset-address? base)
+ (rtl:simple-subexpressions? base)
+ (rtl:machine-constant? (rtl: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)))))
+
+
projects / mit-scheme.git / commitdiff