From: Taylor R Campbell Date: Wed, 7 Oct 2009 19:09:56 +0000 (-0400) Subject: Copy i386 back end to begin x86-64 back end for LIAR. X-Git-Tag: 20100708-Gtk~293 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=efa0a9e1556c7959688fae2a7d2ace2fe875ca40;p=mit-scheme.git Copy i386 back end to begin x86-64 back end for LIAR. Perhaps later we can merge the common parts to reduce the amount of duplication, but this is most convenient for now. --- diff --git a/src/compiler/machines/x86-64/assmd.scm b/src/compiler/machines/x86-64/assmd.scm new file mode 100644 index 000000000..3cc0c956f --- /dev/null +++ b/src/compiler/machines/x86-64/assmd.scm @@ -0,0 +1,81 @@ +#| -*-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)) + +(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 diff --git a/src/compiler/machines/x86-64/coerce.scm b/src/compiler/machines/x86-64/coerce.scm new file mode 100644 index 000000000..581c76e21 --- /dev/null +++ b/src/compiler/machines/x86-64/coerce.scm @@ -0,0 +1,48 @@ +#| -*-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)) + +;; *** 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 diff --git a/src/compiler/machines/x86-64/compiler.cbf b/src/compiler/machines/x86-64/compiler.cbf new file mode 100644 index 000000000..2fd6ec195 --- /dev/null +++ b/src/compiler/machines/x86-64/compiler.cbf @@ -0,0 +1,37 @@ +#| -*-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 diff --git a/src/compiler/machines/x86-64/compiler.pkg b/src/compiler/machines/x86-64/compiler.pkg new file mode 100644 index 000000000..572de333f --- /dev/null +++ b/src/compiler/machines/x86-64/compiler.pkg @@ -0,0 +1,763 @@ +#| -*-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 + +(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?))) + +(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?*)) + +(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)) + +(define-package (compiler debugging-information) + (files "base/infnew") + (parent (compiler)) + (export (compiler top-level) + info-generation-phase-1 + info-generation-phase-2 + info-generation-phase-3) + (export (compiler rtl-generator) + generated-dbg-continuation) + (import (runtime compiler-info) + make-dbg-info + + make-dbg-expression + dbg-expression/block + dbg-expression/label + set-dbg-expression/label! + + make-dbg-procedure + dbg-procedure/block + dbg-procedure/label + set-dbg-procedure/label! + dbg-procedure/name + dbg-procedure/required + dbg-procedure/optional + dbg-procedure/rest + dbg-procedure/auxiliary + dbg-procedure/external-label + set-dbg-procedure/external-label! + dbg-procedureflow-graph converter + "fggen/declar" ;Declaration handling + ) + (parent (compiler)) + (export (compiler top-level) + canonicalize/top-level + construct-graph) + (import (runtime scode-data) + &pair-car + &pair-cdr + &triple-first + &triple-second + &triple-third)) + +(define-package (compiler fg-optimizer) + (files "fgopt/outer" ;outer analysis + "fgopt/sideff" ;side effect analysis + ) + (parent (compiler)) + (export (compiler top-level) + clear-call-graph! + compute-call-graph! + outer-analysis + side-effect-analysis)) + +(define-package (compiler fg-optimizer fold-constants) + (files "fgopt/folcon") + (parent (compiler fg-optimizer)) + (export (compiler top-level) fold-constants)) + +(define-package (compiler fg-optimizer operator-analysis) + (files "fgopt/operan") + (parent (compiler fg-optimizer)) + (export (compiler top-level) operator-analysis)) + +(define-package (compiler fg-optimizer variable-indirection) + (files "fgopt/varind") + (parent (compiler fg-optimizer)) + (export (compiler top-level) initialize-variable-indirections!)) + +(define-package (compiler fg-optimizer environment-optimization) + (files "fgopt/envopt") + (parent (compiler fg-optimizer)) + (export (compiler top-level) optimize-environments!)) + +(define-package (compiler fg-optimizer closure-analysis) + (files "fgopt/closan") + (parent (compiler fg-optimizer)) + (export (compiler top-level) identify-closure-limits!)) + +(define-package (compiler fg-optimizer continuation-analysis) + (files "fgopt/contan") + (parent (compiler fg-optimizer)) + (export (compiler top-level) + continuation-analysis + setup-block-static-links!)) + +(define-package (compiler fg-optimizer compute-node-offsets) + (files "fgopt/offset") + (parent (compiler fg-optimizer)) + (export (compiler top-level) compute-node-offsets)) + +(define-package (compiler fg-optimizer connectivity-analysis) + (files "fgopt/conect") + (parent (compiler fg-optimizer)) + (export (compiler top-level) connectivity-analysis)) + +(define-package (compiler fg-optimizer delete-integrated-parameters) + (files "fgopt/delint") + (parent (compiler fg-optimizer)) + (export (compiler top-level) delete-integrated-parameters)) + +(define-package (compiler fg-optimizer design-environment-frames) + (files "fgopt/desenv") + (parent (compiler fg-optimizer)) + (export (compiler top-level) design-environment-frames!)) + +(define-package (compiler fg-optimizer setup-block-types) + (files "fgopt/blktyp") + (parent (compiler fg-optimizer)) + (export (compiler top-level) + setup-block-types! + setup-closure-contexts!) + (export (compiler) + indirection-block-procedure)) + +(define-package (compiler fg-optimizer simplicity-analysis) + (files "fgopt/simple") + (parent (compiler fg-optimizer)) + (export (compiler top-level) simplicity-analysis) + (export (compiler fg-optimizer subproblem-ordering) + new-subproblem/compute-simplicity!)) + +(define-package (compiler fg-optimizer simulate-application) + (files "fgopt/simapp") + (parent (compiler fg-optimizer)) + (export (compiler top-level) simulate-application)) + +(define-package (compiler fg-optimizer subproblem-free-variables) + (files "fgopt/subfre") + (parent (compiler fg-optimizer)) + (export (compiler top-level) compute-subproblem-free-variables) + (export (compiler fg-optimizer) map-union) + (export (compiler fg-optimizer subproblem-ordering) + new-subproblem/compute-free-variables!)) + +(define-package (compiler fg-optimizer subproblem-ordering) + (files "fgopt/order") + (parent (compiler fg-optimizer)) + (export (compiler top-level) subproblem-ordering)) + +(define-package (compiler fg-optimizer subproblem-ordering reuse-frames) + (files "fgopt/reord" "fgopt/reuse") + (parent (compiler fg-optimizer subproblem-ordering)) + (export (compiler top-level) setup-frame-adjustments) + (export (compiler fg-optimizer subproblem-ordering) + order-subproblems/maybe-overwrite-block)) + +(define-package (compiler fg-optimizer subproblem-ordering parameter-analysis) + (files "fgopt/param") + (parent (compiler fg-optimizer subproblem-ordering)) + (export (compiler fg-optimizer subproblem-ordering) + parameter-analysis)) + +(define-package (compiler fg-optimizer return-equivalencing) + (files "fgopt/reteqv") + (parent (compiler fg-optimizer)) + (export (compiler top-level) find-equivalent-returns!)) + +(define-package (compiler rtl-generator) + (files "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)) + +(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)) + +(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)) diff --git a/src/compiler/machines/x86-64/compiler.sf b/src/compiler/machines/x86-64/compiler.sf new file mode 100644 index 000000000..5380fa3ab --- /dev/null +++ b/src/compiler/machines/x86-64/compiler.sf @@ -0,0 +1,79 @@ +#| -*-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 + +(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 diff --git a/src/compiler/machines/x86-64/dassm1.scm b/src/compiler/machines/x86-64/dassm1.scm new file mode 100644 index 000000000..465b4a096 --- /dev/null +++ b/src/compiler/machines/x86-64/dassm1.scm @@ -0,0 +1,288 @@ +#| -*-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)) + +;;; 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))))) + +(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))))))) + +(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))) + +(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))))) + +(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 diff --git a/src/compiler/machines/x86-64/dassm2.scm b/src/compiler/machines/x86-64/dassm2.scm new file mode 100644 index 000000000..8a7f7951f --- /dev/null +++ b/src/compiler/machines/x86-64/dassm2.scm @@ -0,0 +1,354 @@ +#| -*-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)) + +(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)))))))))) + +(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)) + +(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)) + + (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 diff --git a/src/compiler/machines/x86-64/dassm3.scm b/src/compiler/machines/x86-64/dassm3.scm new file mode 100644 index 000000000..701bdb46e --- /dev/null +++ b/src/compiler/machines/x86-64/dassm3.scm @@ -0,0 +1,997 @@ +#| -*-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)) + +;; 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))) + +(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))))) + +(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))))) + +(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)))) + +(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))))))) + +(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)))))))) + +;;; 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))))) + +(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)))))) + + + (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)))) + + (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))))))) + +(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)) + + (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))))) + +(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))) + + (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)) + + (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))) + + (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)))) + + (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 diff --git a/src/compiler/machines/x86-64/decls.scm b/src/compiler/machines/x86-64/decls.scm new file mode 100644 index 000000000..333617ecd --- /dev/null +++ b/src/compiler/machines/x86-64/decls.scm @@ -0,0 +1,586 @@ +#| -*-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)) + +(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)) + +(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))))) + +;;;; Rank + +(define (source-nodes/rank!) + (compute-dependencies! source-nodes) + (compute-ranks! source-nodes) + (set! source-nodes/by-rank (source-nodes/sort-by-rank source-nodes)) + unspecific) + +(define (compute-dependencies! nodes) + (for-each (lambda (node) + (set-source-node/dependencies! + node + (list-transform-negative (source-node/backward-closure node) + (lambda (node*) + (memq node (source-node/backward-closure node*))))) + (set-source-node/dependents! + node + (list-transform-negative (source-node/forward-closure node) + (lambda (node*) + (memq node (source-node/forward-closure node*)))))) + nodes)) + +(define (compute-ranks! nodes) + (let loop ((nodes nodes) (unranked-nodes '())) + (if (null? nodes) + (if (not (null? unranked-nodes)) + (loop unranked-nodes '())) + (loop (cdr nodes) + (let ((node (car nodes))) + (let ((rank (source-node/rank* node))) + (if rank + (begin + (set-source-node/rank! node rank) + unranked-nodes) + (cons node unranked-nodes)))))))) + +(define (source-node/rank* node) + (let loop ((nodes (source-node/dependencies node)) (rank -1)) + (if (null? nodes) + (1+ rank) + (let ((rank* (source-node/rank (car nodes)))) + (and rank* + (loop (cdr nodes) (max rank rank*))))))) + +(define (source-nodes/sort-by-rank nodes) + (sort nodes (lambda (x y) (< (source-node/rank x) (source-node/rank y))))) + +;;;; File Syntaxer + +(define (syntax-files!) + (maybe-setup-source-nodes!) + (for-each + (lambda (node) + (let ((modification-time + (let ((source (modification-time node "scm")) + (binary (modification-time node "bin"))) + (if (not source) + (error "Missing source file" (source-node/filename node))) + (and binary (< source binary) binary)))) + (set-source-node/modification-time! node modification-time) + (if (not modification-time) + (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)))) + +(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))) + +;;;; 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))))) + +;;;; 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 diff --git a/src/compiler/machines/x86-64/inerly.scm b/src/compiler/machines/x86-64/inerly.scm new file mode 100644 index 000000000..f60c63fed --- /dev/null +++ b/src/compiler/machines/x86-64/inerly.scm @@ -0,0 +1,50 @@ +#| -*-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 diff --git a/src/compiler/machines/x86-64/insmac.scm b/src/compiler/machines/x86-64/insmac.scm new file mode 100644 index 000000000..55b129594 --- /dev/null +++ b/src/compiler/machines/x86-64/insmac.scm @@ -0,0 +1,194 @@ +#| -*-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)) + +(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))))) + +;; *** 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))))) + +(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 diff --git a/src/compiler/machines/x86-64/instr1.scm b/src/compiler/machines/x86-64/instr1.scm new file mode 100644 index 000000000..b9a9fb7c1 --- /dev/null +++ b/src/compiler/machines/x86-64/instr1.scm @@ -0,0 +1,567 @@ +#| -*-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)) + +;;;; 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) + +(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)) + +(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)) + +(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) + +(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)) + + ((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) + +(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)) + +(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))) + +(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 diff --git a/src/compiler/machines/x86-64/instr2.scm b/src/compiler/machines/x86-64/instr2.scm new file mode 100644 index 000000000..a2e19f6bf --- /dev/null +++ b/src/compiler/machines/x86-64/instr2.scm @@ -0,0 +1,578 @@ +#| -*-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)) + +;;;; 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)) + +(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))) + + (((? 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)))) + +(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) + +(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) + +(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)) + +(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)) + +(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)))) + +(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) + +;;;; 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 diff --git a/src/compiler/machines/x86-64/instrf.scm b/src/compiler/machines/x86-64/instrf.scm new file mode 100644 index 000000000..7c7284060 --- /dev/null +++ b/src/compiler/machines/x86-64/instrf.scm @@ -0,0 +1,337 @@ +#| -*-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)) + +(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)) + +(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)) + +(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) + +(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)))) + +(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 diff --git a/src/compiler/machines/x86-64/insutl.scm b/src/compiler/machines/x86-64/insutl.scm new file mode 100644 index 000000000..39a98ad51 --- /dev/null +++ b/src/compiler/machines/x86-64/insutl.scm @@ -0,0 +1,201 @@ +#| -*-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)) + +;;;; 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)) + + ((@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))) + +(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 diff --git a/src/compiler/machines/x86-64/lapgen.scm b/src/compiler/machines/x86-64/lapgen.scm new file mode 100644 index 000000000..988684439 --- /dev/null +++ b/src/compiler/machines/x86-64/lapgen.scm @@ -0,0 +1,695 @@ +#| -*-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)) + +;;;; 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))) + +;;;; 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)) + +;;;; 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)) + +;;;; 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))))))) + +(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)))))) + +(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)) + +(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))))) + +(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))))) + +(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))))) + +(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)))))) + +;;;; 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))) + +(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) + +;; 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 diff --git a/src/compiler/machines/x86-64/lapopt.scm b/src/compiler/machines/x86-64/lapopt.scm new file mode 100644 index 000000000..78c55acb7 --- /dev/null +++ b/src/compiler/machines/x86-64/lapopt.scm @@ -0,0 +1,378 @@ +#| -*-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)) + +(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)) + + +;; Rules are indexed by the last opcode in the pattern. + +(define (define-lapopt name pattern predicate constructor) + (let ((pattern (reverse pattern))) + (let ((rule (make-rule name + pattern + (if ((access procedure? system-global-environment) + predicate) + predicate + (lambda (dict) dict #T)) + constructor))) + (if (or (not (pair? pattern)) + (not (pair? (car pattern)))) + (error "Illegal LAPOPT pattern - must end with opcode" + (reverse pattern))) + (let ((key (caar pattern))) + (hash-table/put! *rules* key + (cons rule (hash-table/get *rules* key '())))))) + name) + +(define (find-rules instruction) + (hash-table/get *rules* (car instruction) '())) + +;; Rules are tried in the reverse order in which they are defined. +;; +;; Rules are matched against the LAP from the bottom up. +;; +;; Once a rule has been applied, the rewritten LAP is matched again, +;; so a rule must rewrite to something different to avoid a loop. +;; (One way to ensure this is to always rewrite to fewer instructions.) + +(define (rewrite-lap lap) + (let loop ((unseen (reverse lap)) (finished '())) + (if (null? unseen) + finished + (if (comment? (car unseen)) + (loop (cdr unseen) (cons (car unseen) finished)) + (let try-rules ((rules (find-rules (car unseen)))) + (if (null? rules) + (loop (cdr unseen) (cons (car unseen) finished)) + (let ((rule (car rules))) + (match-sequence + (rule-pattern rule) + unseen + '(("empty")) ; initial dict, distinct from #F and () + '() ; initial comments + (lambda (dict comments unseen*) + (let ((dict (alist->dict dict))) + (if ((rule-predicate rule) dict) + (let ((rewritten + (cons + `(COMMENT (LAP-OPT ,(rule-name rule))) + (append comments + ((rule-constructor rule) dict))))) + (loop (append (reverse rewritten) unseen*) + finished)) + (try-rules (cdr rules))))) + (lambda () + (try-rules (cdr rules))))))))))) + +;; The DICT passed to the rule predicate and action procedures is a +;; procedure mapping pattern names to their matched values. + +(define (alist->dict dict) + (lambda (symbol) + (cond ((assq symbol dict) => cdr) + (else (error "Undefined lapopt pattern symbol" symbol dict))))) + + +(define-lapopt 'PUSH-POP->MOVE + `((PUSH (? reg1)) + (POP (? reg2))) + #F + (lambda (dict) + `((MOV W ,(dict 'reg2) ,(dict 'reg1))))) + +(define-lapopt 'PUSH-POP->NOP + `((PUSH (? reg)) + (POP (? reg))) + #F + (lambda (dict) + dict + `())) + +;; The following rules must have the JMP else we don't know if the +;; register that we are avoiding loading is dead. + +(define-lapopt 'LOAD-PUSH-POP-JUMP->REGARGETTED-LOAD-JUMP + ;; Note that reg1 must match a register because of the PUSH insn. + `((MOV W (? reg1) (? ea/value)) + (PUSH (? reg1)) + (POP (R ,ecx)) + (JMP (@RO B 6 (? hook-offset)))) + #F + (lambda (dict) + `((MOV W (R ,ecx) ,(dict 'ea/value)) + (JMP (@RO B 6 ,(dict 'hook-offset)))))) + +(define-lapopt 'LOAD-STACKTOPWRITE-POP-JUMP->RETARGETTED-LOAD-JUMP + `((MOV W (? reg) (? ea/value)) + (MOV W (@r ,esp) (? reg)) + (POP (R ,ecx)) + (JMP (@RO B 6 (? hook-offset)))) + #F + (lambda (dict) + `((MOV W (R ,ecx) ,(dict 'ea/value)) + (ADD W (R ,esp) (& 4)) + (JMP (@RO B 6 ,(dict 'hook-offset)))))) + + +(define-lapopt 'STACKWRITE-POP-JUMP->RETARGETTED-LOAD-JUMP + `((MOV W (@RO B ,esp (? stack-offset)) (? ea/value)) + (ADD W (R ,esp) (& (? stack-offset))) + (POP (R ,ecx)) + (JMP (@RO B 6 (? hook-offset)))) + #F + (lambda (dict) + `((MOV W (R ,ecx) ,(dict 'ea/value)) + (ADD W (R ,esp) (& ,(+ 4 (dict 'stack-offset)))) + (JMP (@RO B 6 ,(dict 'hook-offset)))))) + + + +;; The following rules recognize arithmetic followed by tag injection, +;; and fold the tag-injection into the arithmetic. We can do this +;; because we know the bottom six bits of the fixnum are all 0. This +;; is particularly crafty in the generic arithmetic case, as it does +;; not mess up the overflow detection. +;; +;; These patterns match the code generated by subtractions too. + +(define fixnum-tag (object-type 1)) + +(define-lapopt 'FIXNUM-ADD-CONST-TAG + `((ADD W (R (? reg)) (& (? const))) + (OR W (R (? reg)) (& ,fixnum-tag)) + (ROR W (R (? reg)) (& 6))) + #F + (lambda (dict) + `((ADD W (R ,(dict 'reg)) (& ,(+ (dict 'const) fixnum-tag))) + (ROR W (R ,(dict 'reg)) (& 6))))) + +(define-lapopt 'FIXNUM-ADD-REG-TAG + `((ADD W (R (? reg)) (R (? reg-2))) + (OR W (R (? reg)) (& ,fixnum-tag)) + (ROR W (R (? reg)) (& 6))) + #F + (lambda (dict) + `((LEA (R ,(dict 'reg)) (@ROI B ,(dict 'reg) ,fixnum-tag ,(dict 'reg-2) 1)) + (ROR W (R ,(dict 'reg)) (& 6))))) + +(define-lapopt 'GENERIC-ADD-TAG + `((ADD W (R (? reg)) (& (? const))) + (JO (@PCR (? label))) + (OR W (R (? reg)) (& ,fixnum-tag)) + (ROR W (R (? reg)) (& 6))) + #F + (lambda (dict) + `((ADD W (R ,(dict 'reg)) (& ,(+ (dict 'const) fixnum-tag))) + (JO (@PCR ,(dict 'label))) + (ROR W (R ,(dict 'reg)) (& 6))))) + +;; If the fixnum tag is even, the zero LSB works as a place to hold +;; the overflow from addition which can be discarded by masking it +;; out. We must arrange that the constant is positive, so we don't +;; borrow from the tag bits. + +(if (even? fixnum-tag) + (define-lapopt 'FIXNUM-ADD-CONST-IN-PLACE + `((SAL W (? reg) (& ,scheme-type-width)) + (ADD W (? reg) (& (? const))) + (OR W (? reg) (& ,fixnum-tag)) + (ROR W (? reg) (& ,scheme-type-width))) + #F + (lambda (dict) + (let ((const (sar-32 (dict 'const) scheme-type-width)) + (mask (make-non-pointer-literal + fixnum-tag + (-1+ (expt 2 scheme-datum-width))))) + (let ((const + (if (negative? const) + (+ const (expt 2 scheme-datum-width)) + const))) + `(,(if (= const 1) + `(INC W ,(dict 'reg)) ; shorter instruction + `(ADD W ,(dict 'reg) (& ,const))) + (AND W ,(dict 'reg) (& ,mask)))))))) + +;; Similar tag-injection combining rule for fix:or is a little more +;; general. + +(define (or-32-signed x y) + (bit-string->signed-integer + (bit-string-or (signed-integer->bit-string 32 x) + (signed-integer->bit-string 32 y)))) + +(define (ror-32-signed w count) + (let ((bs (signed-integer->bit-string 32 w))) + (bit-string->signed-integer + (bit-string-append (bit-substring bs count 32) + (bit-substring bs 0 count))))) + +(define (sar-32 w count) + (let ((bs (signed-integer->bit-string 32 w))) + (bit-string->signed-integer (bit-substring bs count 32)))) + +(define-lapopt 'OR-OR + `((OR W (R (? reg)) (& (? const-1))) + (OR W (R (? reg)) (& (? const-2)))) + #F + (lambda (dict) + `((OR W (R ,(dict 'reg)) + (& ,(or-32-signed (dict 'const-1) (dict 'const-2))))))) + +;; These rules match a whole fixnum detag-AND/OR-retag operation. In +;; principle, these operations could be done in rulfix.scm, but the +;; instruction combiner wants all the intermediate steps. + +(define-lapopt 'FIXNUM-OR-CONST-IN-PLACE + `((SAL W (? reg) (& ,scheme-type-width)) + (OR W (? reg) (& (? const))) + (OR W (? reg) (& ,fixnum-tag)) + (ROR W (? reg) (& ,scheme-type-width))) + #F + (lambda (dict) + `((OR W ,(dict 'reg) + (& ,(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)))))))) + +;; 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))))) diff --git a/src/compiler/machines/x86-64/machin.scm b/src/compiler/machines/x86-64/machin.scm new file mode 100644 index 000000000..109fddfd4 --- /dev/null +++ b/src/compiler/machines/x86-64/machin.scm @@ -0,0 +1,357 @@ +#| -*-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)) + +;;;; 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) + +;;;; 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)) + +;;;; 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))) + +;;;; 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)) + +(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))) + +(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 diff --git a/src/compiler/machines/x86-64/make.scm b/src/compiler/machines/x86-64/make.scm new file mode 100644 index 000000000..8a934704c --- /dev/null +++ b/src/compiler/machines/x86-64/make.scm @@ -0,0 +1,32 @@ +#| -*-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 diff --git a/src/compiler/machines/x86-64/pc-make.scm b/src/compiler/machines/x86-64/pc-make.scm new file mode 100644 index 000000000..7f6a1e09f --- /dev/null +++ b/src/compiler/machines/x86-64/pc-make.scm @@ -0,0 +1,32 @@ +#| -*-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 diff --git a/src/compiler/machines/x86-64/rgspcm.scm b/src/compiler/machines/x86-64/rgspcm.scm new file mode 100644 index 000000000..e9796b29f --- /dev/null +++ b/src/compiler/machines/x86-64/rgspcm.scm @@ -0,0 +1,68 @@ +#| -*-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)) + +(define (define-special-primitive-handler name handler) + (let ((primitive (make-primitive-procedure name true))) + (let ((entry (assq primitive special-primitive-handlers))) + (if entry + (set-cdr! entry handler) + (set! special-primitive-handlers + (cons (cons primitive handler) + special-primitive-handlers))))) + name) + +(define (special-primitive-handler primitive) + (let ((entry (assq primitive special-primitive-handlers))) + (and entry + (cdr entry)))) + +(define special-primitive-handlers + '()) + +(define (define-special-primitive/standard primitive) + (define-special-primitive-handler primitive + rtl:make-invocation:special-primitive)) + +(define-special-primitive/standard '&+) +(define-special-primitive/standard '&-) +(define-special-primitive/standard '&*) +(define-special-primitive/standard '&/) +(define-special-primitive/standard '&=) +(define-special-primitive/standard '&<) +(define-special-primitive/standard '&>) +(define-special-primitive/standard '1+) +(define-special-primitive/standard '-1+) +(define-special-primitive/standard 'zero?) +(define-special-primitive/standard 'positive?) +(define-special-primitive/standard 'negative?) +(define-special-primitive/standard 'quotient) +(define-special-primitive/standard 'remainder) \ No newline at end of file diff --git a/src/compiler/machines/x86-64/rules1.scm b/src/compiler/machines/x86-64/rules1.scm new file mode 100644 index 000000000..9387275be --- /dev/null +++ b/src/compiler/machines/x86-64/rules1.scm @@ -0,0 +1,491 @@ +#| -*-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)) + +;;;; 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))) + +(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))) + +;;;; 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)) + +;;;; 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))))) + +;;;; 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))))) + +;;;; 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)))) + +;;;; 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)) + +;;;; 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)))))) + +;;;; 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 diff --git a/src/compiler/machines/x86-64/rules2.scm b/src/compiler/machines/x86-64/rules2.scm new file mode 100644 index 000000000..73585baac --- /dev/null +++ b/src/compiler/machines/x86-64/rules2.scm @@ -0,0 +1,143 @@ +#| -*-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)) + +(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))))) + +(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))))))) diff --git a/src/compiler/machines/x86-64/rules3.scm b/src/compiler/machines/x86-64/rules3.scm new file mode 100644 index 000000000..a14f7f281 --- /dev/null +++ b/src/compiler/machines/x86-64/rules3.scm @@ -0,0 +1,991 @@ +#| -*-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)) + +;;;; 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)))) + +(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)))) + +(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)))))))) + +(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))) + +;;; 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)))))) + +;;;; 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)) + +;;;; 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)) + +(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))) + +;; 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) + + )) + +;;;; 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 )) + (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)))))) + +(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)) + +(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))))) + +;;;; 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)))))) + +(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)))))) + +(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)))) + +;; 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)))) + +;;; Local Variables: *** +;;; eval: (put 'declare-constants 'scheme-indent-hook 2) *** +;;; End: *** diff --git a/src/compiler/machines/x86-64/rules4.scm b/src/compiler/machines/x86-64/rules4.scm new file mode 100644 index 000000000..776b3ae61 --- /dev/null +++ b/src/compiler/machines/x86-64/rules4.scm @@ -0,0 +1,139 @@ +#| -*-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)) + +;;;; 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)))) + +;;;; 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)))) + +(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 diff --git a/src/compiler/machines/x86-64/rulfix.scm b/src/compiler/machines/x86-64/rulfix.scm new file mode 100644 index 000000000..550d04c83 --- /dev/null +++ b/src/compiler/machines/x86-64/rulfix.scm @@ -0,0 +1,770 @@ +#| -*-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)) + +;;;; 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))) + +;;;; 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)) + +;;;; 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))))) + +(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)) + +;;;; 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)))))) + +;;;; 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))) + +(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?)))) + +;;;; 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))))))))))) + +(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)))) + +(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)))))) + +(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))))) + +(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 diff --git a/src/compiler/machines/x86-64/rulflo.scm b/src/compiler/machines/x86-64/rulflo.scm new file mode 100644 index 000000000..201a761e0 --- /dev/null +++ b/src/compiler/machines/x86-64/rulflo.scm @@ -0,0 +1,828 @@ +#| -*-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)) + +;; **** +;; 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))) + +;;;; 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)))) + +;;;; 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)) + +;;; 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) + +;; 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)))))) + +#| +;; 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))))) + +(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))) + +(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)) + +(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))))))) + +(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)) + +;;;; 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)) + +(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))) + +;; 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))))) + +(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))) diff --git a/src/compiler/machines/x86-64/rulrew.scm b/src/compiler/machines/x86-64/rulrew.scm new file mode 100644 index 000000000..c85f9f930 --- /dev/null +++ b/src/compiler/machines/x86-64/rulrew.scm @@ -0,0 +1,369 @@ +#| -*-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)) + +;;;; 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)))) + +;;; 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))) + +;;;; 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))))))) + +(define-rule rewriting + (OBJECT->FLOAT (REGISTER (? operand register-known-value))) + (QUALIFIER + (rtl:constant-flonum-test operand (lambda (v) v #T))) + (rtl:make-object->float operand)) + +(define-rule rewriting + (FLONUM-2-ARGS FLONUM-SUBTRACT + (REGISTER (? operand-1 register-known-value)) + (? operand-2) + (? overflow?)) + (QUALIFIER (rtl:constant-flonum-test operand-1 flo:zero?)) + (rtl:make-flonum-2-args 'FLONUM-SUBTRACT operand-1 operand-2 overflow?)) + +(define-rule rewriting + (FLONUM-2-ARGS (? operation) + (REGISTER (? operand-1 register-known-value)) + (? operand-2) + (? overflow?)) + (QUALIFIER + (and (memq operation + '(FLONUM-ADD FLONUM-SUBTRACT FLONUM-MULTIPLY FLONUM-DIVIDE)) + (rtl:constant-flonum-test operand-1 flo:one?))) + (rtl:make-flonum-2-args operation operand-1 operand-2 overflow?)) + +(define-rule rewriting + (FLONUM-2-ARGS (? operation) + (? operand-1) + (REGISTER (? operand-2 register-known-value)) + (? overflow?)) + (QUALIFIER + (and (memq operation + '(FLONUM-ADD FLONUM-SUBTRACT FLONUM-MULTIPLY FLONUM-DIVIDE)) + (rtl:constant-flonum-test operand-2 flo:one?))) + (rtl:make-flonum-2-args operation operand-1 operand-2 overflow?)) + +(define-rule rewriting + (FLONUM-PRED-2-ARGS (? predicate) + (? operand-1) + (REGISTER (? operand-2 register-known-value))) + (QUALIFIER (rtl:constant-flonum-test operand-2 flo:zero?)) + (list 'FLONUM-PRED-2-ARGS predicate operand-1 operand-2)) + +(define-rule rewriting + (FLONUM-PRED-2-ARGS (? predicate) + (REGISTER (? operand-1 register-known-value)) + (? operand-2)) + (QUALIFIER (rtl:constant-flonum-test operand-1 flo:zero?)) + (list 'FLONUM-PRED-2-ARGS predicate operand-1 operand-2)) + +#| +;; These don't work as written. They are not simplified and are +;; therefore passed whole to the back end, and there is no way to +;; construct the graph at this level. + +;; acos (x) = atan ((sqrt (1 - x^2)) / x) + +(define-rule pre-cse-rewriting + (FLONUM-1-ARG FLONUM-ACOS (? operand) #f) + (rtl:make-flonum-2-args + 'FLONUM-ATAN2 + (rtl:make-flonum-1-arg + 'FLONUM-SQRT + (rtl:make-flonum-2-args + 'FLONUM-SUBTRACT + (rtl:make-object->float (rtl:make-constant 1.)) + (rtl:make-flonum-2-args 'FLONUM-MULTIPLY operand operand 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.)) + +;;;; 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))))) + +