Nowhere near completion yet, long TODO list, not compile-tested, &c.
Not sure if I'll find any more copious spare time to work on this for
a while.
--- /dev/null
+((nil (indent-tabs-mode . nil)))
--- /dev/null
+- Make it work.
+ [ ] assmd
+ [ ] cmpauxmd
+ [ ] coerce
+ [ ] insmac
+ [ ] instr: branch tensioning, review it all, simd, float
+ [ ] insutl
+ [ ] logical immediate encoding
+- Confirm apply target/pc registers match in:
+ . rules3 (invocation:computed-jump)
+ . cmpauxmd
+ . uuo link code in aarch64.c (currently uses x0/x1, should use x16/x17)
+ . trampoline code, if necessary
+ . wherever else
+- Verify the branch condition codes.
+- Open-coded flonum arithmetic.
+- Better fixnum operations with constant operands.
+- Fast division by multiplication.
+- Fixnum multiply-add/sub/negate.
+- Consider NaN-tagging.
+- Write a disassembler.
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 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/aarch64"
+ "rtlbase"
+ "rtlgen"
+ "rtlopt")))
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Compiler Packaging
+\f
+(global-definitions "../runtime/runtime")
+(global-definitions "../sf/sf")
+
+(define-package (compiler)
+ (files "base/switch"
+ "base/object" ;tagged object support
+ "base/enumer" ;enumerations
+ "base/sets" ;set abstraction
+ "base/mvalue" ;multiple-value support
+ "base/scode" ;SCode abstraction
+ "machines/aarch64/machine" ;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-environment scode-access-environment)
+ (scode/access-name scode-access-name)
+ (scode/access? scode-access?)
+ (scode/assignment-name scode-assignment-name)
+ (scode/assignment-value scode-assignment-value)
+ (scode/assignment? scode-assignment?)
+ (scode/combination-operands scode-combination-operands)
+ (scode/combination-operator scode-combination-operator)
+ (scode/combination? scode-combination?)
+ (scode/comment-expression scode-comment-expression)
+ (scode/comment-text scode-comment-text)
+ (scode/comment? scode-comment?)
+ (scode/conditional-alternative scode-conditional-alternative)
+ (scode/conditional-consequent scode-conditional-consequent)
+ (scode/conditional-predicate scode-conditional-predicate)
+ (scode/conditional? scode-conditional?)
+ (scode/constant? scode-constant?)
+ (scode/declaration-expression scode-declaration-expression)
+ (scode/declaration-text scode-declaration-text)
+ (scode/declaration? scode-declaration?)
+ (scode/definition-name scode-definition-name)
+ (scode/definition-value scode-definition-value)
+ (scode/definition? scode-definition?)
+ (scode/delay-expression scode-delay-expression)
+ (scode/delay? scode-delay?)
+ (scode/disjunction-alternative scode-disjunction-alternative)
+ (scode/disjunction-predicate scode-disjunction-predicate)
+ (scode/disjunction? scode-disjunction?)
+ (scode/lambda-components scode-lambda-components)
+ (scode/lambda-body scode-lambda-body)
+ (scode/lambda-name scode-lambda-name)
+ (scode/lambda? scode-lambda?)
+ (scode/make-access make-scode-access)
+ (scode/make-assignment make-scode-assignment)
+ (scode/make-combination make-scode-combination)
+ (scode/make-comment make-scode-comment)
+ (scode/make-conditional make-scode-conditional)
+ (scode/make-declaration make-scode-declaration)
+ (scode/make-definition make-scode-definition)
+ (scode/make-delay make-scode-delay)
+ (scode/make-disjunction make-scode-disjunction)
+ (scode/make-lambda make-scode-lambda)
+ (scode/make-open-block make-scode-open-block)
+ (scode/make-quotation make-scode-quotation)
+ (scode/make-sequence make-scode-sequence)
+ (scode/make-the-environment make-scode-the-environment)
+ (scode/make-unassigned? make-scode-unassigned?)
+ (scode/make-variable make-scode-variable)
+ (scode/open-block-actions scode-open-block-actions)
+ (scode/open-block-declarations scode-open-block-declarations)
+ (scode/open-block-names scode-open-block-names)
+ (scode/open-block? scode-open-block?)
+ (scode/primitive-procedure? primitive-procedure?)
+ (scode/procedure? procedure?)
+ (scode/quotation-expression scode-quotation-expression)
+ (scode/quotation? scode-quotation?)
+ (scode/sequence-actions scode-sequence-actions)
+ (scode/sequence? scode-sequence?)
+ (scode/set-lambda-body! set-scode-lambda-body!)
+ (scode/symbol? symbol?)
+ (scode/the-environment? scode-the-environment?)
+ (scode/unassigned?-name scode-unassigned?-name)
+ (scode/unassigned?? scode-unassigned??)
+ (scode/variable-name scode-variable-name)
+ (scode/variable? scode-variable?)))
+\f
+(define-package (compiler reference-contexts)
+ (files "base/refctx")
+ (parent (compiler))
+ (export (compiler)
+ add-reference-context/adjacent-parents!
+ initialize-reference-contexts!
+ make-reference-context
+ modify-reference-contexts!
+ reference-context/adjacent-parent?
+ reference-context/block
+ reference-context/offset
+ reference-context/procedure
+ reference-context?
+ set-reference-context/offset!))
+
+(define-package (compiler macros)
+ (files "base/macros")
+ (parent (compiler))
+ (export (compiler)
+ cfg-node-case
+ define-enumeration
+ define-export
+ define-lvalue
+ define-pnode
+ define-root-type
+ define-rtl-expression
+ define-rtl-predicate
+ define-rtl-statement
+ define-rule
+ define-rvalue
+ define-snode
+ define-vector-slots
+ descriptor-list
+ enumeration-case
+ inst-ea
+ lap
+ last-reference
+ make-lvalue
+ make-pnode
+ make-rvalue
+ make-snode
+ package
+ rule-matcher))
+
+(define-package (compiler declarations)
+ (files "machines/aarch64/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-directory
+ compile-bin-file
+ compile-file
+ compile-file:force?
+ compile-file:override-usual-integrations
+ compile-file:sf-only?
+ compile-file:show-dependencies?
+ compile-procedure
+ compile-scode
+ compiler:compiled-code-pathname-type
+ compiler:reset!
+ lap->code)
+ (export (compiler)
+ canonicalize-label-name)
+ (export (compiler fg-generator)
+ *tl-metadata*
+ 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)
+ map-r7rs-scode-file
+ map-scode-library
+ r7rs-scode-file?
+ scode-library-name)
+ (import (scode-optimizer build-utilities)
+ directory-processor))
+\f
+(define-package (compiler debug)
+ (files "base/debug")
+ (parent (compiler))
+ (export ()
+ debug/find-continuation
+ debug/find-entry-node
+ debug/find-procedure
+ debug/where
+ dump-rtl
+ po
+ show-bblock-rtl
+ show-fg
+ show-fg-node
+ show-rtl
+ write-rtl-instructions))
+
+(define-package (compiler pattern-matcher/lookup)
+ (files "base/pmlook")
+ (parent (compiler))
+ (export (compiler)
+ generate-pattern-matcher
+ make-pattern-variable
+ pattern-contains-duplicates?
+ pattern-lookup
+ pattern-lookup-1
+ pattern-lookup-2
+ pattern-variable-name
+ pattern-variable?
+ pattern-variables))
+
+(define-package (compiler pattern-matcher/parser)
+ (files "base/pmpars")
+ (parent (compiler))
+ (export (compiler)
+ make-rule-matcher
+ parse-rule
+ rule->matcher
+ rule-result-expression)
+ (export (compiler macros)
+ make-rule-matcher
+ parse-rule
+ rule->matcher
+ rule-result-expression))
+
+(define-package (compiler pattern-matcher/early)
+ (files "base/pmerly")
+ (parent (compiler))
+ (export (compiler)
+ early-parse-rule
+ early-pattern-lookup
+ early-make-rule
+ make-database-transformer
+ make-symbol-transformer
+ make-bit-mask-transformer))
+\f
+(define-package (compiler debugging-information)
+ (files "base/infnew")
+ (parent (compiler))
+ (export (compiler top-level)
+ info-generation-phase-1
+ info-generation-phase-2
+ info-generation-phase-3)
+ (export (compiler rtl-generator)
+ generated-dbg-continuation)
+ (import (runtime compiler-info)
+ make-dbg-info
+
+ make-dbg-expression
+ dbg-expression/block
+ dbg-expression/label
+ set-dbg-expression/label!
+
+ make-dbg-procedure
+ dbg-procedure/block
+ dbg-procedure/label
+ set-dbg-procedure/label!
+ dbg-procedure/name
+ dbg-procedure/required
+ dbg-procedure/optional
+ dbg-procedure/rest
+ dbg-procedure/auxiliary
+ dbg-procedure/external-label
+ set-dbg-procedure/external-label!
+ dbg-procedure<?
+
+ make-dbg-continuation
+ dbg-continuation/block
+ dbg-continuation/label
+ set-dbg-continuation/label!
+ dbg-continuation<?
+
+ make-dbg-block
+ dbg-block/parent
+ dbg-block/layout
+ dbg-block/stack-link
+ set-dbg-block/procedure!
+
+ make-dbg-variable
+ dbg-variable/value
+ set-dbg-variable/value!
+
+ dbg-block-name/dynamic-link
+ dbg-block-name/ic-parent
+ dbg-block-name/normal-closure
+ dbg-block-name/return-address
+ dbg-block-name/static-link
+
+ make-dbg-label-2
+ dbg-label/offset
+ set-dbg-label/external?!))
+
+(define-package (compiler portable-fasdump)
+ (files "base/fasdump")
+ (parent ()) ;** This code should be portable.
+ (export ()
+ fasl-format:aarch64be
+ fasl-format:aarch64le
+ fasl-format:alpha
+ fasl-format:amd64
+ fasl-format:arm32be
+ fasl-format:arm32le
+ fasl-format:i386
+ fasl-format:mips32be
+ fasl-format:mips32le
+ fasl-format:ppc32
+ fasl-format:sparc32
+ fasl-format:svm1-32be
+ fasl-format:svm1-32le
+ fasl-format:svm1-64be
+ fasl-format:svm1-64le
+ portable-fasdump))
+
+(define-package (compiler constraints)
+ (files "base/constr")
+ (parent (compiler))
+ (export (compiler)
+ make-constraint
+ constraint/element
+ constraint/graph-head
+ constraint/afters
+ constraint/closed?
+ constraint-add!
+ add-constraint-element!
+ add-constraint-set!
+ make-constraint-graph
+ constraint-graph/entry-nodes
+ constraint-graph/closed?
+ close-constraint-graph!
+ close-constraint-node!
+ order-per-constraints
+ order-per-constraints/extracted
+ legal-ordering-per-constraints?
+ with-new-constraint-marks
+ constraint-marked?
+ constraint-mark!
+ transitively-close-dag!
+ reverse-postorder))
+\f
+(define-package (compiler fg-generator)
+ (files "fggen/canon" ;SCode canonicalizer
+ "fggen/fggen" ;SCode->flow-graph converter
+ "fggen/declar" ;Declaration handling
+ )
+ (parent (compiler))
+ (export (compiler top-level)
+ canonicalize/top-level
+ construct-graph)
+ (import (runtime scode-data)
+ &pair-car
+ &pair-cdr
+ &triple-first
+ &triple-second
+ &triple-third))
+
+(define-package (compiler fg-optimizer)
+ (files "fgopt/outer" ;outer analysis
+ "fgopt/sideff" ;side effect analysis
+ )
+ (parent (compiler))
+ (export (compiler top-level)
+ clear-call-graph!
+ compute-call-graph!
+ outer-analysis
+ side-effect-analysis))
+
+(define-package (compiler fg-optimizer fold-constants)
+ (files "fgopt/folcon")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) fold-constants))
+
+(define-package (compiler fg-optimizer operator-analysis)
+ (files "fgopt/operan")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) operator-analysis))
+
+(define-package (compiler fg-optimizer variable-indirection)
+ (files "fgopt/varind")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) initialize-variable-indirections!))
+
+(define-package (compiler fg-optimizer environment-optimization)
+ (files "fgopt/envopt")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) optimize-environments!))
+
+(define-package (compiler fg-optimizer closure-analysis)
+ (files "fgopt/closan")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) identify-closure-limits!))
+
+(define-package (compiler fg-optimizer continuation-analysis)
+ (files "fgopt/contan")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level)
+ continuation-analysis
+ setup-block-static-links!))
+
+(define-package (compiler fg-optimizer compute-node-offsets)
+ (files "fgopt/offset")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) compute-node-offsets))
+\f
+(define-package (compiler fg-optimizer connectivity-analysis)
+ (files "fgopt/conect")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) connectivity-analysis))
+
+(define-package (compiler fg-optimizer delete-integrated-parameters)
+ (files "fgopt/delint")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) delete-integrated-parameters))
+
+(define-package (compiler fg-optimizer design-environment-frames)
+ (files "fgopt/desenv")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) design-environment-frames!))
+
+(define-package (compiler fg-optimizer setup-block-types)
+ (files "fgopt/blktyp")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level)
+ setup-block-types!
+ setup-closure-contexts!)
+ (export (compiler)
+ indirection-block-procedure))
+
+(define-package (compiler fg-optimizer simplicity-analysis)
+ (files "fgopt/simple")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) simplicity-analysis)
+ (export (compiler fg-optimizer subproblem-ordering)
+ new-subproblem/compute-simplicity!))
+
+(define-package (compiler fg-optimizer simulate-application)
+ (files "fgopt/simapp")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) simulate-application))
+
+(define-package (compiler fg-optimizer subproblem-free-variables)
+ (files "fgopt/subfre")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) compute-subproblem-free-variables)
+ (export (compiler fg-optimizer) map-union)
+ (export (compiler fg-optimizer subproblem-ordering)
+ new-subproblem/compute-free-variables!))
+
+(define-package (compiler fg-optimizer subproblem-ordering)
+ (files "fgopt/order")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) subproblem-ordering))
+
+(define-package (compiler fg-optimizer subproblem-ordering reuse-frames)
+ (files "fgopt/reord" "fgopt/reuse")
+ (parent (compiler fg-optimizer subproblem-ordering))
+ (export (compiler top-level) setup-frame-adjustments)
+ (export (compiler fg-optimizer subproblem-ordering)
+ order-subproblems/maybe-overwrite-block))
+
+(define-package (compiler fg-optimizer subproblem-ordering parameter-analysis)
+ (files "fgopt/param")
+ (parent (compiler fg-optimizer subproblem-ordering))
+ (export (compiler fg-optimizer subproblem-ordering)
+ parameter-analysis))
+
+(define-package (compiler fg-optimizer return-equivalencing)
+ (files "fgopt/reteqv")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) find-equivalent-returns!))
+\f
+(define-package (compiler rtl-generator)
+ (files "rtlgen/rtlgen" ;RTL generator
+ "rtlgen/rgstmt" ;statements
+ "rtlgen/fndvar" ;find variables
+ "machines/aarch64/rgspcm" ;special close-coded primitives
+ "rtlbase/rtline" ;linearizer
+ )
+ (parent (compiler))
+ (export (compiler)
+ make-linearizer)
+ (export (compiler top-level)
+ generate/top-level
+ linearize-rtl
+ setup-bblock-continuations!)
+ (export (compiler debug)
+ linearize-rtl)
+ (import (compiler top-level)
+ label->object))
+
+(define-package (compiler rtl-generator generate/procedure-header)
+ (files "rtlgen/rgproc")
+ (parent (compiler rtl-generator))
+ (export (compiler rtl-generator) generate/procedure-header))
+
+(define-package (compiler rtl-generator combination/inline)
+ (files "rtlgen/opncod")
+ (parent (compiler rtl-generator))
+ (export (compiler rtl-generator) combination/inline)
+ (export (compiler top-level) open-coding-analysis))
+
+(define-package (compiler rtl-generator find-block)
+ (files "rtlgen/fndblk")
+ (parent (compiler rtl-generator))
+ (export (compiler rtl-generator) find-block))
+
+(define-package (compiler rtl-generator generate/rvalue)
+ (files "rtlgen/rgrval")
+ (parent (compiler rtl-generator))
+ (export (compiler rtl-generator)
+ generate/rvalue
+ load-closure-environment
+ make-cons-closure-indirection
+ make-cons-closure-redirection
+ make-closure-redirection
+ make-ic-cons
+ make-non-trivial-closure-cons
+ make-trivial-closure-cons
+ redirect-closure))
+
+(define-package (compiler rtl-generator generate/combination)
+ (files "rtlgen/rgcomb")
+ (parent (compiler rtl-generator))
+ (export (compiler rtl-generator)
+ generate/combination
+ rtl:bump-closure)
+ (export (compiler rtl-generator combination/inline)
+ generate/invocation-prefix))
+
+(define-package (compiler rtl-generator generate/return)
+ (files "rtlgen/rgretn")
+ (parent (compiler rtl-generator))
+ (export (compiler rtl-generator)
+ make-return-operand
+ generate/return
+ generate/return*
+ generate/trivial-return))
+\f
+(define-package (compiler rtl-cse)
+ (files "rtlopt/rcse1" ;RTL common subexpression eliminator
+ "rtlopt/rcse2"
+ "rtlopt/rcseep" ;CSE expression predicates
+ "rtlopt/rcseht" ;CSE hash table
+ "rtlopt/rcserq" ;CSE register/quantity abstractions
+ "rtlopt/rcsesr" ;CSE stack references
+ )
+ (parent (compiler))
+ (export (compiler top-level) common-subexpression-elimination))
+
+(define-package (compiler rtl-optimizer)
+ (files "rtlopt/rdebug")
+ (parent (compiler)))
+
+(define-package (compiler rtl-optimizer invertible-expression-elimination)
+ (files "rtlopt/rinvex")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) invertible-expression-elimination))
+
+(define-package (compiler rtl-optimizer common-suffix-merging)
+ (files "rtlopt/rtlcsm")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) merge-common-suffixes!))
+
+(define-package (compiler rtl-optimizer rtl-dataflow-analysis)
+ (files "rtlopt/rdflow")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) rtl-dataflow-analysis))
+
+(define-package (compiler rtl-optimizer rtl-rewriting)
+ (files "rtlopt/rerite")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level)
+ rtl-rewriting:post-cse
+ rtl-rewriting:pre-cse)
+ (export (compiler lap-syntaxer)
+ add-rewriting-rule!
+ add-pre-cse-rewriting-rule!))
+
+(define-package (compiler rtl-optimizer lifetime-analysis)
+ (files "rtlopt/rlife")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) lifetime-analysis)
+ (export (compiler rtl-optimizer code-compression) mark-set-registers!))
+
+(define-package (compiler rtl-optimizer code-compression)
+ (files "rtlopt/rcompr")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) code-compression))
+
+(define-package (compiler rtl-optimizer register-allocation)
+ (files "rtlopt/ralloc")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) register-allocation))
+\f
+(define-package (compiler lap-syntaxer)
+ (files "back/lapgn1" ;LAP generator
+ "back/lapgn2" ; " "
+ "back/lapgn3" ; " "
+ "back/regmap" ;Hardware register allocator
+ "back/checks" ;Interrupt checks
+ "machines/aarch64/lapgen" ;code generation rules
+ "machines/aarch64/rules1" ; " " "
+ "machines/aarch64/rules2" ; " " "
+ "machines/aarch64/rules3" ; " " "
+ "machines/aarch64/rules4" ; " " "
+ "machines/aarch64/rulfix" ; " " "
+ "machines/aarch64/rulflo" ; " " "
+ "machines/aarch64/rulrew" ;code rewriting rules
+ "back/syntax" ;Generic syntax phase
+ "back/syerly" ;Early binding version
+ "machines/aarch64/coerce" ;Coercions: integer -> bit string
+ "back/asmmac" ;Macros for hairy syntax
+ "machines/aarch64/insmac" ;Macros for hairy syntax
+ "machines/aarch64/insutl" ;aarch64 instruction utilities
+ "machines/aarch64/instr1" ;aarch64 instructions
+ "machines/aarch64/instr2" ; " "
+ "machines/aarch64/instrf" ; " " 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/aarch64/lapopt")
+ (parent (compiler))
+ (export (compiler top-level)
+ optimize-linear-lap))
+
+(define-package (compiler assembler)
+ (files "machines/aarch64/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/aarch64/dassm1"
+ "machines/aarch64/dassm2"
+ "machines/aarch64/dassm3")
+ (parent (compiler))
+ (export ()
+ compiler:write-lap-file
+ compiler:disassemble)
+ (import (runtime compiler-info)
+ compiled-code-block/dbg-info
+ dbg-info-vector/blocks-vector
+ dbg-info-vector?
+ dbg-info/labels
+ dbg-label/external?
+ dbg-label/name
+ dbg-labels/find-offset))
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Script to incrementally syntax the compiler
+\f
+(load-option 'cref)
+(load-option 'sf)
+
+;; Guarantee that the compiler's package structure exists.
+(if (not (name->package '(compiler)))
+ (let ((package-set
+ (merge-pathnames
+ (enough-pathname
+ (merge-pathnames (package-set-pathname "compiler"))
+ cref/source-root)
+ cref/object-root)))
+ (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)
+ (receive (scm bin spec)
+ (sf/pathname-defaulting file #f #f)
+ scm spec
+ (load 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/aarch64/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/aarch64/machine") '(compiler))
+ (fluid-let ((sf/default-declarations
+ '((integrate-external "insseq")
+ (integrate-external "machine")
+ (usual-definition (set expt)))))
+ (sf-and-load '("machines/aarch64/assmd") '(compiler assembler)))
+ (sf-and-load '("back/syntax") '(compiler lap-syntaxer))
+ (sf-and-load '("machines/aarch64/coerce"
+ "back/asmmac"
+ "machines/aarch64/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")
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Compiler File Dependencies
+;;; package: (compiler declarations)
+
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (add-event-receiver! event:after-restore reset-source-nodes!)
+ (reset-source-nodes!))
+
+(define (reset-source-nodes!)
+ (set! source-filenames '())
+ (set! source-hash)
+ (set! source-nodes)
+ (set! source-nodes/by-rank)
+ unspecific)
+
+(define (maybe-setup-source-nodes!)
+ (if (null? source-filenames)
+ (setup-source-nodes!)))
+
+(define (setup-source-nodes!)
+ (let ((filenames
+ (append-map!
+ (lambda (subdirectory)
+ (map (lambda (pathname)
+ (string-append subdirectory
+ "/"
+ (pathname-name pathname)))
+ (directory-read
+ (string-append subdirectory
+ "/"
+ source-file-expression))))
+ '("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt"
+ "machines/aarch64"))))
+ (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-set! source-hash filename node)
+ node))
+ source-filenames))
+ (initialize/syntax-dependencies!)
+ (initialize/integration-dependencies!)
+ (source-nodes/rank!))
+
+(define source-file-expression "*.scm")
+(define source-filenames)
+(define source-hash)
+(define source-nodes)
+(define source-nodes/by-rank)
+
+(define (filename/append directory . names)
+ (map (lambda (name) (string-append directory "/" name)) names))
+\f
+(define-structure (source-node
+ (conc-name source-node/)
+ (constructor %make/source-node (filename pathname)))
+ (filename #f read-only #t)
+ (pathname #f read-only #t)
+ (forward-links '())
+ (backward-links '())
+ (forward-closure '())
+ (backward-closure '())
+ (dependencies '())
+ (dependents '())
+ (rank #f)
+ (syntax-table #f)
+ (declarations '())
+ (modification-time #f))
+
+(define (make/source-node filename)
+ (%make/source-node filename (->pathname filename)))
+
+(define (filename->source-node filename)
+ (let ((node (hash-table-ref/default source-hash filename #f)))
+ (if (not node)
+ (error "Unknown source file:" filename))
+ node))
+
+(define (source-node/circular? node)
+ (memq node (source-node/backward-closure node)))
+
+(define (source-node/link! node dependency)
+ (if (not (memq dependency (source-node/backward-links node)))
+ (begin
+ (set-source-node/backward-links!
+ node
+ (cons dependency (source-node/backward-links node)))
+ (set-source-node/forward-links!
+ dependency
+ (cons node (source-node/forward-links dependency)))
+ (source-node/close! node dependency))))
+
+(define (source-node/close! node dependency)
+ (if (not (memq dependency (source-node/backward-closure node)))
+ (begin
+ (set-source-node/backward-closure!
+ node
+ (cons dependency (source-node/backward-closure node)))
+ (set-source-node/forward-closure!
+ dependency
+ (cons node (source-node/forward-closure dependency)))
+ (for-each (lambda (dependency)
+ (source-node/close! node dependency))
+ (source-node/backward-closure dependency))
+ (for-each (lambda (node)
+ (source-node/close! node dependency))
+ (source-node/forward-closure node)))))
+\f
+;;;; Rank
+
+(define (source-nodes/rank!)
+ (compute-dependencies! source-nodes)
+ (compute-ranks! source-nodes)
+ (set! source-nodes/by-rank (source-nodes/sort-by-rank source-nodes))
+ unspecific)
+
+(define (compute-dependencies! nodes)
+ (for-each (lambda (node)
+ (set-source-node/dependencies!
+ node
+ (remove (lambda (node*)
+ (memq node (source-node/backward-closure node*)))
+ (source-node/backward-closure node)))
+ (set-source-node/dependents!
+ node
+ (remove (lambda (node*)
+ (memq node (source-node/forward-closure node*)))
+ (source-node/forward-closure node))))
+ nodes))
+
+(define (compute-ranks! nodes)
+ (let loop ((nodes nodes) (unranked-nodes '()))
+ (if (null? nodes)
+ (if (not (null? unranked-nodes))
+ (loop unranked-nodes '()))
+ (loop (cdr nodes)
+ (let ((node (car nodes)))
+ (let ((rank (source-node/rank* node)))
+ (if rank
+ (begin
+ (set-source-node/rank! node rank)
+ unranked-nodes)
+ (cons node unranked-nodes))))))))
+
+(define (source-node/rank* node)
+ (let loop ((nodes (source-node/dependencies node)) (rank -1))
+ (if (null? nodes)
+ (1+ rank)
+ (let ((rank* (source-node/rank (car nodes))))
+ (and rank*
+ (loop (cdr nodes) (max rank rank*)))))))
+
+(define (source-nodes/sort-by-rank nodes)
+ (sort nodes (lambda (x y) (< (source-node/rank x) (source-node/rank y)))))
+\f
+;;;; File Syntaxer
+
+(define (syntax-files!)
+ (maybe-setup-source-nodes!)
+ (for-each
+ (lambda (node)
+ (let ((modification-time
+ (receive (scm bin spec)
+ (sf/pathname-defaulting (source-node/pathname node) #f #f)
+ spec
+ (let ((source (file-modification-time scm))
+ (binary (file-modification-time 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
+ (any (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?))
+ (source-node/dependencies node)))
+ (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)))
+ (bind-condition-handler (list condition-type:simple-warning)
+ (lambda (condition)
+ (if (string=? (access-condition condition 'MESSAGE)
+ "Missing externs file:")
+ (muffle-warning)))
+ (lambda ()
+ (for-each (lambda (node)
+ (if (not (source-node/modification-time node))
+ (source-node/syntax! node)))
+ source-nodes/by-rank)))
+ (if (any (lambda (node)
+ (and (not (source-node/modification-time node))
+ (source-node/circular? node)))
+ source-nodes/by-rank)
+ (begin
+ (write-notification-line
+ (lambda (port)
+ (write-string "Begin pass 2:" port)))
+ (for-each (lambda (node)
+ (if (not (source-node/modification-time node))
+ (if (source-node/circular? node)
+ (source-node/syntax! node)
+ (source-node/touch! node))))
+ source-nodes/by-rank))))
+\f
+(define (source-node/touch! node)
+ (receive (input-pathname bin-pathname spec-pathname)
+ (sf/pathname-defaulting (source-node/pathname node) "" #f)
+ input-pathname
+ (pathname-touch! bin-pathname)
+ (pathname-touch! (pathname-new-type bin-pathname "ext"))
+ (if spec-pathname (pathname-touch! spec-pathname))))
+
+(define (pathname-touch! pathname)
+ (if (file-exists? pathname)
+ (begin
+ (write-notification-line
+ (lambda (port)
+ (write-string "Touch file: " port)
+ (write (enough-namestring pathname) port)))
+ (file-touch pathname))))
+
+(define (pathname-delete! pathname)
+ (if (file-exists? pathname)
+ (begin
+ (write-notification-line
+ (lambda (port)
+ (write-string "Delete file: " port)
+ (write (enough-namestring pathname) port)))
+ (delete-file pathname))))
+
+(define (sc filename)
+ (maybe-setup-source-nodes!)
+ (source-node/syntax! (filename->source-node filename)))
+
+(define (source-node/syntax! node)
+ (receive (input-pathname bin-pathname spec-pathname)
+ (sf/pathname-defaulting (source-node/pathname node) "" #f)
+ (sf/internal
+ input-pathname bin-pathname spec-pathname
+ (source-node/syntax-table node)
+ ((if compiler:enable-integration-declarations?
+ identity-procedure
+ (lambda (declarations)
+ (remove integration-declaration? declarations)))
+ (source-node/declarations node)))))
+\f
+;;;; Syntax dependencies
+
+(define (initialize/syntax-dependencies!)
+ (let ((file-dependency/syntax/join
+ (lambda (filenames syntax-table)
+ (for-each (lambda (filename)
+ (set-source-node/syntax-table!
+ (filename->source-node filename)
+ syntax-table))
+ filenames))))
+ (file-dependency/syntax/join
+ (append (filename/append "base"
+ "toplev" "asstop" "crstop"
+ "blocks" "cfg1" "cfg2" "cfg3" "constr"
+ "contin" "ctypes" "debug" "enumer"
+ "infnew" "lvalue" "object" "pmerly" "proced"
+ "refctx" "rvalue" "scode" "sets" "subprb"
+ "switch" "utils")
+ (filename/append "back"
+ "asmmac" "bittop" "bitutl" "checks" "insseq"
+ "lapgn1" "lapgn2" "lapgn3" "linear" "regmap"
+ "symtab" "syntax")
+ (filename/append "machines/aarch64"
+ "dassm1" "insmac" "lapopt" "machine" "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/aarch64"
+ "lapgen"
+ "rules1" "rules2" "rules3" "rules4" "rulfix" "rulflo"
+ "insutl" "instr1" "instr2" "instrf")
+ (->environment '(COMPILER LAP-SYNTAXER)))))
+\f
+;;;; Integration Dependencies
+
+(define (initialize/integration-dependencies!)
+
+ (define (add-declaration! declaration filenames)
+ (for-each (lambda (filenames)
+ (let ((node (filename->source-node filenames)))
+ (set-source-node/declarations!
+ node
+ (cons declaration
+ (source-node/declarations node)))))
+ filenames))
+
+ (let* ((front-end-base
+ (filename/append "base"
+ "blocks" "cfg1" "cfg2" "cfg3"
+ "contin" "ctypes" "enumer" "lvalue"
+ "object" "proced" "rvalue"
+ "scode" "subprb" "utils"))
+ (aarch64-base
+ (append (filename/append "machines/aarch64" "machine")
+ (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/aarch64" "assmd" "machine"))
+ (lapgen-base
+ (append (filename/append "back" "linear" "regmap")
+ (filename/append "machines/aarch64" "lapgen")))
+ (assembler-base
+ (append (filename/append "back" "symtab")
+ (filename/append "machines/aarch64" "insutl")))
+ (lapgen-body
+ (append
+ (filename/append "back" "checks" "lapgn1" "lapgn2" "syntax")
+ (filename/append "machines/aarch64"
+ "rules1" "rules2" "rules3" "rules4"
+ "rulfix" "rulflo")))
+ (assembler-body
+ (append
+ (filename/append "back" "bittop")
+ (filename/append "machines/aarch64"
+ "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/aarch64"
+ "machine" "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/aarch64" "machine" "rtlbase"
+ "rtlreg" "rtlty1" "rtlty2")
+
+ (define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2")
+ (define-integration-dependencies "rtlbase" "rgraph" "machines/aarch64"
+ "machine")
+ (define-integration-dependencies "rtlbase" "rtlcfg" "base"
+ "cfg1" "cfg2" "cfg3")
+ (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils")
+ (define-integration-dependencies "rtlbase" "rtlcon" "machines/aarch64"
+ "machine")
+ (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/aarch64"
+ "machine")
+ (define-integration-dependencies "rtlbase" "rtlreg" "rtlbase"
+ "rgraph" "rtlty1")
+ (define-integration-dependencies "rtlbase" "rtlty1" "rtlbase" "rtlcfg")
+ (define-integration-dependencies "rtlbase" "rtlty2" "machines/aarch64"
+ "machine")
+ (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 aarch64-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 aarch64-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/aarch64" "rulrew"))
+ (append aarch64-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" "checks" "base" "cfg1" "cfg2")
+ (define-integration-dependencies "back" "checks" "rtlbase"
+ "rtlcfg" "rtlobj" "rtlty1")
+ (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))
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 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.
+
+|#
+
+;;;; AArch Instruction Set
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;; Idea for branch tensioning: in every @PCR, allow an optional
+;;; temporary register, like (@PCR <label> (T <temp>)); then assemble
+;;; into a two-instruction sequence that uses the temporary register.
+;;;
+;;; Not really necessary: x16 and x17 are for that purpose.
+;;;
+;;; Syntax notes:
+;;;
+;;; - Should shifted immediates be (* 8 (&U ...)), (&U (* 8 ...)), (LSL
+;;; (&U ...) 3), or (&U (LSL ... 3))?
+\f
+;;;; Helpers, for insutl.scm
+
+(define (sf-size size)
+ (case size
+ ((W) 0)
+ ((X) 1)
+ (else #f)))
+
+(define (vregister v)
+ (and (<= 0 v 31)
+ v))
+
+(define (register<31 r)
+ (and (<= 0 r 30)
+ r))
+
+(define (register-31=z r)
+ (cond ((eq? r 'Z) 31)
+ ((<= 0 r 30) r)
+ (else #f)))
+
+(define (register-31=sp r)
+ (cond ((<= 0 r 31) r)
+ (else #f)))
+
+(define (msr-pstatefield x)
+ (case x
+ ((SPSel) #b000101)
+ ((DAIFSet) #b011110)
+ ((DAIFClr) #b011111)
+ ((UAO) #b000011)
+ ((PAN) #b000100)
+ ((DIT) #b011010)
+ (else #f)))
+
+(define (load/store-pre/post-index op)
+ (case op
+ ((POST+) #b01)
+ ((PRE+) #b11)
+ (else #f)))
+
+(define (load/store-size sz)
+ (case sz
+ ((B) #b00)
+ ((H) #b01)
+ ((W) #b10)
+ ((X) #b11)
+ (else #f)))
+
+(define (load/store-simd/fp-size sz)
+ ;; Returns size(2) || opchi(1). opclo(1), omitted, is 1 for a load
+ ;; and 0 for a store.
+ (case sz
+ ((B) #b000)
+ ((H) #b010)
+ ((S) #b100)
+ ((D) #b110)
+ ((Q) #b001)
+ (else #f)))
+
+(define (ldr-simd/fp-size sz)
+ (case sz
+ ((S) #b00)
+ ((D) #b01)
+ ((Q) #b10)
+ (else #f)))
+
+(define (str-simd/fp-size sz)
+ (case sz
+ (())))
+
+(define (ldr-literal-size sz)
+ (case sz
+ ;; No byte or halfword, only word and extended word.
+ ((W) #b00)
+ ((X) #b01)
+ (else #f)))
+
+(define (load/store-extend-type t)
+ (case t
+ ((UTXW) #b010)
+ ((LSL) #b011)
+ ((SXTW) #b110)
+ ((SXTX) #b111)
+ (else #f)))
+
+(define (load/store8-extend-amount amount)
+ (case amount
+ ((#f) 0)
+ ((0) 1)
+ (else #f)))
+
+(define (load/store16-extend-amount amount)
+ (case amount
+ ((0) 0)
+ ((1) 1)
+ (else #f)))
+
+(define (load/store32-extend-amount amount)
+ (case amount
+ ((0) 0)
+ ((2) 1)
+ (else #f)))
+
+(define (load/store64-extend-amount amount)
+ (case amount
+ ((0) 0)
+ ((3) 1)
+ (else #f)))
+
+(define (load/store128-extend-amount amount)
+ (case amount
+ ((0) 0)
+ ((4) 1)
+ (else #f)))
+\f
+;;;; Instructions, ordered by sections in ARMv8-A ARM, C3
+
+;;; C3.1.1 Conditional branch
+
+(let-syntax
+ ((define-conditional-branch-instruction
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (list-ref form 1))
+ (o0 (list-ref form 2))
+ (o1 (list-ref form 3))
+ (condition (list-ref form 4)))
+ `(define-instruction ,mnemonic
+ (((@PCR (? target)))
+ (BITS (7 #b0101010)
+ (1 ,o1)
+ (19 `(- ,target *PC*) SIGNED)
+ (1 ,o0)
+ (4 ,condition))))))))
+ ;; PSTATE condition bits:
+ ;; .n = negative
+ ;; .z = zero
+ ;; .c = carry
+ ;; .v = overflow
+ ;; Branch if...
+ (define-conditional-branch-instruction B.EQ 0 0 #b0000) ;equal
+ (define-conditional-branch-instruction B.NE 0 0 #b0001) ;not equal
+ (define-conditional-branch-instruction B.CS 0 0 #b0010) ;carry set
+ (define-conditional-branch-instruction B.CC 0 0 #b0011) ;carry clear
+ (define-conditional-branch-instruction B.MI 0 0 #b0100) ;negative `minus'
+ (define-conditional-branch-instruction B.PL 0 0 #b0101) ;nonnegative `plus'
+ (define-conditional-branch-instruction B.VS 0 0 #b0110) ;overflow set
+ (define-conditional-branch-instruction B.VC 0 0 #b0111) ;overflow clear
+ (define-conditional-branch-instruction B.HI 0 0 #b1000) ;carry and nonzero
+ (define-conditional-branch-instruction B.LS 0 0 #b1001) ;!carry or zero
+ (define-conditional-branch-instruction B.GE 0 0 #b1010) ;greater or equal
+ ;n = v
+ (define-conditional-branch-instruction B.LT 0 0 #b1011) ;less
+ ;n != v
+ (define-conditional-branch-instruction B.GT 0 0 #b1100) ;greater
+ ;n = v and !z
+ (define-conditional-branch-instruction B.LE 0 0 #b1101) ;less or equal
+ ;n != v or z
+ (define-conditional-branch-instruction B.AL 0 0 #b1110) ;always
+ #; ;never?
+ (define-conditional-branch-instruction B.<never> 0 0 #b1111))
+
+(let-syntax
+ ((define-compare&branch-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (receive (mnemonic op) (apply values (cdr form))
+ `(define-instruction ,mnemonic
+ (((? sf sf-size) (? Rt register-31=z) (@PCR (? label)))
+ (BITS (1 sf)
+ (6 #b011010)
+ (1 ,op)
+ (19 `(QUOTIENT (- ,label *PC*) 4) SIGNED)
+ (5 Rt)))))))))
+ ;; Compare and branch on zero
+ (define-compare&branch-instruction CBZ 0)
+ ;; Compare and branch on nonzero
+ (define-compare&branch-instruction CBNZ 1))
+
+(let-syntax
+ ((define-test&branch-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (receive (mnemonic op) (apply values (cdr form))
+ `(define-instruction ,mnemonic
+ ((W (? Rt register-31=z)
+ (&U (? bit unsigned-5))
+ (@PCR (? label)))
+ (BITS (1 0) ;b5, fifth bit of bit index
+ (6 #b011011)
+ (1 ,op)
+ (5 bit)
+ (14 `(- ,label *PC*))
+ (5 Rt)))
+ ((X (? Rt register-31=z)
+ (&U (? bit unsigned-6))
+ (@PCR (? label)))
+ (BITS (1 bit B5)
+ (6 #b011011)
+ (5 bit B40)
+ (14 `(- ,label *PC*))
+ (5 Rt)))))))))
+ ;; Test and branch if zero
+ (define-test&branch-instruction TBZ 0)
+ ;; Test and branch if nonzero
+ (define-test&branch-instruction TBNZ 1))
+
+;;; C3.1.2 Unconditional branch (immediate)
+
+;; Branch unconditional to PC-relative. Probably no need for
+;; variable-width encoding here for a while since there's 26 bits to
+;; work with.
+
+(define-instruction B
+ (((@PCR (? label)))
+ (BITS (1 0) ;no link
+ (5 #b00101)
+ (26 `(- ,label *PC*) SIGNED))))
+
+;; Branch and link unconditional to PC-relative
+
+(define-instruction BL
+ (((@PCR (? label)))
+ (BITS (1 1) ;link
+ (5 #b00101)
+ (26 `(- ,label *PC*) SIGNED))))
+
+;;; C.3.1.3 Unconditional branch (register)
+
+;; Unconditional branch to register
+
+(let-syntax
+ ((define-branch-to-register-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (receive (mnemonic op) (apply values (cdr form))
+ `(define-instruction ,mnemonic
+ (((? Rn register-31=z))
+ (BITS (7 #b1101011)
+ (1 0) ;Z
+ (1 0)
+ (2 ,op)
+ (5 #b11111)
+ (4 #b0000)
+ (1 0) ;A
+ (1 0) ;M
+ (5 Rn)
+ (5 0)))))))))
+ (define-branch-to-register-instruction BR #b00)
+ (define-branch-to-register-instruction BLR #b01))
+
+;; Return (same as BR but with prediction hint and default R31, LR)
+
+(define-instruction RET
+ (()
+ (BITS (7 #b1101011)
+ (1 0) ;Z
+ (1 0)
+ (2 #b10) ;op
+ (5 #b11111)
+ (4 #b0000)
+ (1 0) ;A
+ (1 0) ;M
+ (5 30) ;Rn=30, link register
+ (5 0)))
+ (((? Rn register-31=z))
+ (BITS (7 #b1101011)
+ (1 0) ;Z
+ (1 0)
+ (2 #b10) ;op
+ (5 #b11111)
+ (4 #b0000)
+ (1 0) ;A
+ (1 0) ;M
+ (5 Rn)
+ (5 0))))
+
+;;; C3.1.4 Exception generation and return
+
+(let-syntax
+ ((define-exception-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (list-ref form 1))
+ (opc (list-ref form 2))
+ (op2 (list-ref form 3))
+ (LL (list-ref form 4)))
+ `(define-instruction ,mnemonic
+ (((&U (? imm unsigned-16)))
+ (BITS (8 #b11010100)
+ (3 ,opc)
+ (16 imm)
+ (3 ,op2)
+ (2 ,LL)))))))))
+ ;; Supervisor Call (-> EL1)
+ (define-exception-instruction SVC #b000 #b000 #b01)
+ ;; Hypervisor Call (non-secure EL1 -> EL2)
+ (define-exception-instruction HVC #b000 #b000 #b10)
+ ;; Secure Monitor Call (EL>=1 -> EL3)
+ (define-exception-instruction SMC #b000 #b000 #b11)
+ ;; Breakpoint
+ (define-exception-instruction BRK #b001 #b000 #b00)
+ ;; Halt
+ (define-exception-instruction HLT #b010 #b000 #b00))
+
+;; Exception return
+
+(define-instruction ERET
+ (()
+ (BITS (7 #b1101011)
+ (1 0)
+ (3 #b100)
+ (5 #b11111)
+ (4 #b0000)
+ (1 0) ;A
+ (1 0) ;M
+ (5 31) ;Rn
+ (5 0)))) ;op4
+
+;;; C3.1.5 System register instructions
+
+;; Move to special register
+
+(define-instruction MSR
+ ;; Immediate
+ (((? psf msr-pstatefield) (&U (? CRm unsigned-4)))
+ (BITS (8 #b11010101)
+ (5 #b00000)
+ (3 psf PSTATEFIELD-OP1)
+ (4 #b0100)
+ (4 CRm)
+ (3 psf PSTATEFIELD-OP2)
+ (5 31)))
+ ;; Register
+ ;; ... XXX
+ )
+
+;; XXX MRS
+
+;;; C3.1.6 System instructions
+
+;; XXX SYS, SYSL, IC, DC, AT, TLBI
+
+;;; C3.1.7 Hint instructions, C3.1.8 Barriers and CLREX instructions
+
+;; Generic HINT format.
+
+(define-instruction HINT
+ (((&U (? imm unsigned-7)))
+ (BITS (8 #b11010101)
+ (2 #b00)
+ (1 0)
+ (2 #b00)
+ (3 #b011)
+ (4 #b0010)
+ (7 imm)
+ (5 #b11111))))
+
+;; Common hint and barrier format.
+
+(let-syntax
+ ((define-hint/barrier-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (list-ref form 1))
+ (CRm (list-ref form 2))
+ (op2 (list-ref form 3)))
+ `(define-instruction ,mnemonic
+ (()
+ (BITS (8 #b11010101)
+ (2 #b00)
+ (1 0)
+ (2 #b00)
+ (3 #b011)
+ (4 #b0010)
+ (4 ,CRm)
+ (3 ,op2)
+ (5 #b11111)))))))))
+ ;; Hints: CRm=#b0000
+ ;;
+ ;; No-op
+ (define-hint/barrier-instruction NOP #b0000 #b000)
+ ;; Yield bus while spinning on spin lock
+ (define-hint/barrier-instruction YIELD #b0000 #b001)
+ ;; Wait for event, signalled by SEV on any CPU (`PE') or SEVL on this one
+ (define-hint/barrier-instruction WFE #b0000 #b010)
+ ;; Wait for interrupt
+ (define-hint/barrier-instruction WFI #b0000 #b011)
+ ;; Send event, waking WFE in all CPUs (`PE') in multiprocessor system
+ (define-hint/barrier-instruction SEV #b0000 #b100)
+ ;; Send event local, waking WFE on this CPU
+ (define-hint/barrier-instruction SEVL #b0000 #b101)
+ ;; Barriers: CRm=#b0010
+ ;;
+ ;; Error synchronization barrier
+ (define-hint/barrier-instruction ESB #b0010 #b000)
+ ;; Profiling synchronization barrier
+ (define-hint/barrier-instruction PSB-CSYNC #b0010 #b001)
+ ;; Trace synchronization barrier
+ (define-hint/barrier-instruction TSB-CSYNC #b0010 #b010)
+ ;; Consumption of speculative data barrier
+ (define-hint/barrier-instruction CSDB #b0010 #b100))
+
+;; Clear exclusive: clear local monitor of the executing PE.
+
+(define-instruction CLREX
+ (((&U (? CRm unsigned-4)))
+ (BITS (8 #b11010101)
+ (8 #b00000011)
+ (4 #b0011)
+ (4 CRm)
+ (3 #b010) ;op2
+ (5 31))))
+
+;; Data memory barrier
+
+(define (dmb-option o)
+ (case o
+ ((SY) #b1111)
+ ((ST) #b1110)
+ ((LD) #b1101)
+ ((ISH) #b1011)
+ ((ISHST) #b1010)
+ ((ISHLD) #b1001)
+ ((NSH) #b0111)
+ ((NSHST) #b0110)
+ ((NSHLD) #b0101)
+ ((OSH) #b0011)
+ ((OSHST) #b0010)
+ ((OSHLD) #b0001)
+ (else #f)))
+
+(define-instruction DMB
+ (((? CRm dmb-option))
+ (BITS (8 #b11010101)
+ (8 #b00000011)
+ (4 #b0011)
+ (4 CRm)
+ (3 #b010) ;op2
+ (5 31)))
+ (((&U (? CRm unsigned-4)))
+ (BITS (8 #b11010101)
+ (8 #b00000011)
+ (4 #b0011)
+ (4 CRm)
+ (3 #b010) ;op2
+ (5 31))))
+
+;; Speculative store bypass barrier (physical address), encoded like DMB.
+
+(define-instruction PSSBB
+ (()
+ (BITS (8 #b11010101)
+ (8 #b00000011)
+ (4 #b0011)
+ (4 #b0100)
+ (3 #b010) ;op2
+ (5 31))))
+
+(define (isb-option o)
+ (case o
+ ((SY) #b1111)
+ (else #f)))
+
+(define-instruction ISB
+ (()
+ (BITS (8 #b11010101)
+ (8 #b00000011)
+ (4 #b0011)
+ (4 #b1111) ;CRm, full system barrier
+ (3 #b110) ;op2
+ (5 31)))
+ (((? CRm isb-option))
+ (BITS (8 #b11010101)
+ (8 #b00000011)
+ (4 #b0011)
+ (4 CRm)
+ (3 #b110) ;op2
+ (5 31)))
+ (((&U (? CRm unsigned-4)))
+ (BITS (8 #b11010101)
+ (8 #b00000011)
+ (4 #b0011)
+ (4 CRm)
+ (3 #b110) ;op2
+ (5 31))))
+
+;; Data synchronization barrier
+
+(define (dsb-option o)
+ (case o
+ ((SY) #b1111)
+ ((ST) #b1110)
+ ((LD) #b1101)
+ ((ISH) #b1011)
+ ((ISHST) #b1010)
+ ((ISHLD) #b1001)
+ ((NSH) #b0111)
+ ((NSHST) #b0110)
+ ((NSHLD) #b0101)
+ ((OSH) #b0011)
+ ((OSHST) #b0010)
+ ((OSHLD) #b0001)
+ (else #f)))
+
+(define-instruction DSB
+ (((? CRm dsb-option))
+ (BITS (8 #b11010101)
+ (8 #b00000011)
+ (4 #b0011)
+ (4 CRm)
+ (3 #b100) ;op2
+ (5 31)))
+ (((&U (? CRm unsigned-4)))
+ (BITS (8 #b11010101)
+ (8 #b00000011)
+ (4 #b0011)
+ (4 CRm)
+ (3 #b100) ;op2
+ (5 31))))
+
+;; Speculative store bypass barrier (virtual address)
+
+(define-instruction SSBB
+ (()
+ (BITS (8 #b11010101)
+ (8 #b00000011)
+ (4 #b0011)
+ (4 #b0000)
+ (3 #b100) ;op2
+ (5 31))))
+
+;;; C3.1.9 Pointer authentication instructions
+
+;; XXX pointer authentication instructions
+
+;;; C3.2 Loads and stores
+
+;;; C3.2.1 Load/Store register
+
+(let-syntax
+ ((define-load/store-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (receive (mnemonic load/store . extra) (apply values (cdr form))
+ `(define-instruction ,mnemonic
+ ;; LDRB/LDRH/LDR immediate, pre/post-index with signed
+ ;; byte offset (C6.2.123, C6.2.125, C6.2.119)
+ ;; STRB/STRH/STR immediate, pre/post-index with signed
+ ;; byte offset (C6.2.259, C6.2.261, C6.2.257)
+ (((? size load/store-size)
+ (? Rt register-31=z)
+ ((? pre/post load/store-pre/post-index)
+ (? Rn register-31=sp)
+ (& (? offset signed-9))))
+ (BITS (2 size)
+ (3 #b111)
+ (1 0) ;general
+ (2 #b00)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (1 0)
+ (9 offset SIGNED)
+ (2 pre/post)
+ (5 Rn)
+ (5 Rt)))
+ ;; LDRB/LDRH/LDR immediate, zero offset
+ ;; (C6.2.123, C6.2.125, C6.2.119)
+ ;; STRB/STRH/STR immediate, zero offset
+ ;; (C6.2.259, C6.2.261, C6.2.257)
+ (((? size load/store-size)
+ (? Rt register-31=z)
+ (? Rn register-31=sp))
+ (BITS (2 size)
+ (3 #b111)
+ (1 0) ;general
+ (2 #b01)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (12 0) ;offset=0
+ (5 Rn)
+ (5 Rt)))
+ ;; LDRB immediate, unsigned byte offset (C6.2.123)
+ ;; STRB immediate, unsigned byte offset (C6.2.259)
+ ((B (? Rt register-31=z)
+ (+ (? Rn register-31=sp) (&U (? offset unsigned-12))))
+ (BITS (2 #b00) ;size=B, 8-bit
+ (3 #b111)
+ (1 0) ;general
+ (2 #b01)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (12 offset)
+ (5 Rn)
+ (5 Rt)))
+ ;; LDRB immediate, unsigned byte offset (C6.2.123)
+ ;; STRB immediate, unsigned byte offset (C6.2.259)
+ ;; [same as above]
+ ((B (? Rt register-31=z)
+ (+ (? Rn register-31=sp) (&U (* 1 (? offset unsigned-12)))))
+ (BITS (2 #b00) ;size=B, 8-bit
+ (3 #b111)
+ (1 0) ;general
+ (2 #b01)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (12 offset)
+ (5 Rn)
+ (5 Rt)))
+ ;; LDRH immediate, unsigned 2-byte offset (C6.2.125)
+ ;; STRH immediate, unsigned 2-byte offset (C6.2.259)
+ ((H (? Rt register-31=z)
+ (+ (? Rn register-31=sp) (&U (* 2 (? offset unsigned-12)))))
+ (BITS (2 #b01) ;size=H, 16-bit
+ (3 #b111)
+ (1 0) ;general
+ (2 #b00)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (12 offset)
+ (5 Rn)
+ (5 Rt)))
+ ;; LDR (W) immediate, unsigned 4-byte offset (C6.2.119)
+ ;; STR (W) immediate, unsigned 4-byte offset (C6.2.257)
+ ((W (? Rt register-31=z)
+ (+ (? Rn register-31=sp) (&U (* 4 (? offset unsigned-12)))))
+ (BITS (2 #b10) ;size=W, 32-bit
+ (3 #b111)
+ (1 0) ;general
+ (2 #b01)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (12 offset)
+ (5 Rn)
+ (5 Rt)))
+ ;; LDR (X) immediate, unsigned 8-byte offset (C6.2.119)
+ ;; STR (X) immediate, unsigned 8-byte offset (C6.2.257)
+ ((X (? Rt register-31=z)
+ (+ (? Rn register-31=sp) (&U (* 8 (? offset unsigned-12)))))
+ (BITS (2 #b11) ;size=X, 64-bit
+ (3 #b111)
+ (1 0) ;general
+ (2 #b01)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (12 offset)
+ (5 Rn)
+ (5 Rt)))
+ ;; LDRB/LDRH/LDR register, no extend
+ ;; (C6.2.124, C6.2.126, C6.2.121)
+ ;; STRB/STRH/STR register, no extend
+ ;; (C6.2.260, C6.2.262, C6.2.258)
+ (((? size load/store-size)
+ (? Rt register-31=z)
+ (+ (? Rn register-31=sp)
+ (? Rm register-31=z)))
+ (BITS (2 size)
+ (3 #b111)
+ (1 0) ;general
+ (2 #b00)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (1 1)
+ (5 Rm)
+ (3 #b011) ;option=LSL
+ (1 0) ;shift=0
+ (2 #b10)
+ (5 Rn)
+ (5 Rt)))
+ ;; LDRB extended register, 8-bit operand size (C6.2.124)
+ ;; STRB extended register, 8-bit operand size (C6.2.260)
+ ((B (? Rt register-31=z)
+ (+ (? Rn register-31=sp)
+ ((? option load/store-extend-type)
+ (? Rm register-31=z)
+ (? S load/store8-extend-amount))))
+ (BITS (2 #b00) ;size=B, 8-bit
+ (3 #b111)
+ (1 0) ;general
+ (2 #b00)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (1 1)
+ (5 Rm)
+ (3 option)
+ (1 S)
+ (2 #b10)
+ (5 Rn)
+ (5 Rt)))
+ ;; LDRH extended register, 16-bit operand size (C6.2.126)
+ ;; STRH extended register, 16-bit operand size (C6.2.262)
+ ((H (? Rt register-31=z)
+ (+ (? Rn register-31=sp)
+ ((? option load/store-extend-type)
+ (? Rm register-31=z)
+ (? S load/store16-extend-amount))))
+ (BITS (2 #b01) ;size=H, 16-bit
+ (3 #b111)
+ (1 0) ;general
+ (2 #b00)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (1 1)
+ (5 Rm)
+ (3 option)
+ (1 S)
+ (2 #b10)
+ (5 Rn)
+ (5 Rt)))
+ ;; LDR (W) extended register, 32-bit operand size (C6.2.121)
+ ;; STR (W) extended register, 32-bit operand size (C6.2.258)
+ ((W (? Rt register-31=z)
+ (+ (? Rn register-31=sp)
+ ((? option load/store-extend-type)
+ (? Rm register-31=z)
+ (? S load/store32-extend-amount))))
+ (BITS (2 #b10) ;size=W, 32-bit
+ (3 #b111)
+ (1 0) ;general
+ (2 #b00)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (1 1)
+ (5 Rm)
+ (3 option)
+ (1 S)
+ (2 #b10)
+ (5 Rn)
+ (5 Rt)))
+ ;; LDR (X) extended register, 64-bit operand size (C6.2.121)
+ ;; STR (X) extended register, 64-bit operand size (C6.2.258)
+ ((X (? Rt register-31=z)
+ (+ (? Rn register-31=sp)
+ ((? option load/store-extend-type)
+ (? Rm register-31=z)
+ (? S load/store64-extend-amount))))
+ (BITS (2 #b11) ;size=X, 64-bit
+ (3 #b111)
+ (1 0) ;general
+ (2 #b00)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (1 1)
+ (5 Rm)
+ (3 option)
+ (1 S)
+ (2 #b10)
+ (5 Rn)
+ (5 Rt)))
+ ,@extra))))))
+ (define-load/store-instruction STR 0)
+ (define-load/store-instruction LDR 1
+ ;; LDR PC-relative literal (C6.2.120).
+ (((? opc ldr-literal-size) (? Rt register-31=z) (@PCR (? label)))
+ (BITS (2 opc)
+ (3 #b011)
+ (1 0) ;general
+ (2 #b00)
+ (19 `(QUOTIENT (- ,label *PC*) 4))
+ (5 Rt)))))
+
+;;; C3.2.9 Load/Store scalar SIMD and floating-point
+
+(let-syntax
+ ((define-simd/fp-load/store-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (receive (mnemonic load/store . extra) (apply values (cdr form))
+ `(define-instruction ,mnemonic
+ ;; LDR immediate, SIMD&FP, pre/post-index with signed
+ ;; byte offset (C7.2.176)
+ ;; STR immediate, SIMD&FP, pre/post-index with signed
+ ;; byte offset (C7.2.315)
+ (((? sz load/store-simd/fp-size)
+ (? Vt vregister)
+ ((? pre/post load/store-pre/post-index)
+ (? Rn register-31=sp)
+ (& (? offset signed-9))))
+ (BITS (2 sz LOAD/STORE-SIMD/FP-SIZE)
+ (3 #b111)
+ (1 1) ;SIMD/FP
+ (2 #b00)
+ (1 sz LOAD/STORE-SIMD/FP-OPCHI)
+ (1 ,load/store) ;opc[0]
+ (1 0)
+ (9 offset SIGNED)
+ (2 pre/post)
+ (5 Rn)
+ (5 Vt)))
+ ;; LDR immediate, SIMD&FP, zero offset (C7.2.176)
+ ;; STR immediate, SIMD&FP, zero offset (C7.2.315)
+ (((? sz load/store-simd/fp-size)
+ (? Vt vregister)
+ (? Rn register-31=sp))
+ (BITS (2 sz LOAD/STORE-SIMD/FP-SIZE)
+ (3 #b111)
+ (1 1) ;SIMD/FP
+ (2 #b01)
+ (1 sz LOAD/STORE-SIMD/FP-OPCHI)
+ (1 ,load/store) ;opc[0]
+ (12 0) ;offset=0
+ (5 Rn)
+ (5 Vt)))
+ ;; LDR immediate, SIMD&FP (B), unsigned byte offset (C7.2.176)
+ ;; STR immediate, SIMD&FP (B), unsigned byte offset (C7.2.315)
+ ((B (? Vt vregister)
+ (+ (? Rn register-31=sp)
+ (&U (? offset unsigned-12))))
+ (BITS (2 #b00) ;size=B, 8-bit
+ (3 #b111)
+ (1 1) ;SIMD/FP
+ (2 #b01)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (12 offset)
+ (5 Rn)
+ (5 Vt)))
+ ;; LDR immediate, SIMD&FP (B), unsigned byte offset (C7.2.176)
+ ;; STR immediate, SIMD&FP (B), unsigned byte offset (C7.2.315)
+ ;; [same as above]
+ ((B (? Vt vregister)
+ (+ (? Rn register-31=sp)
+ (&U (* 1 (? offset unsigned-12)))))
+ (BITS (2 #b00) ;size=B, 8-bit
+ (3 #b111)
+ (1 1) ;SIMD/FP
+ (2 #b01)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (12 offset)
+ (5 Rn)
+ (5 Vt)))
+ ;; LDR immediate, SIMD&FP (H), unsigned 2-byte offset (C7.2.176)
+ ;; STR immediate, SIMD&FP (H), unsigned 2-byte offset (C7.2.315)
+ ((H (? Vt vregister)
+ (+ (? Rn register-31=sp)
+ (&U (* 2 (? offset unsigned-12)))))
+ (BITS (2 #b01) ;size=H, 16-bit
+ (3 #b111)
+ (1 1) ;SIMD/FP
+ (2 #b01)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (12 offset)
+ (5 Rn)
+ (5 Vt)))
+ ;; LDR immediate, SIMD&FP (S), unsigned 4-byte offset (C7.2.176)
+ ;; STR immediate, SIMD&FP (S), unsigned 4-byte offset (C7.2.315)
+ ((S (? Vt vregister)
+ (+ (? Rn register-31=sp)
+ (&U (* 4 (? offset unsigned-12)))))
+ (BITS (2 #b10) ;size=S, 32-bit
+ (3 #b111)
+ (1 1) ;SIMD/FP
+ (2 #b01)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (12 offset)
+ (5 Rn)
+ (5 Vt)))
+ ;; LDR immediate, SIMD&FP (D), unsigned 8-byte offset (C7.2.176)
+ ;; STR immediate, SIMD&FP (D), unsigned 8-byte offset (C7.2.315)
+ ((D (? Vt vregister)
+ (+ (? Rn register-31=sp)
+ (&U (* 8 (? offset unsigned-12)))))
+ (BITS (2 #b11) ;size=D, 64-bit
+ (3 #b111)
+ (1 1) ;SIMD/FP
+ (2 #b01)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (12 offset)
+ (5 Rn)
+ (5 Vt)))
+ ;; LDR immediate, SIMD&FP (Q), unsigned 16-byte offset (C7.2.176)
+ ;; STR immediate, SIMD&FP (Q), unsigned 16-byte offset (C7.2.315)
+ ((Q (? Vt vregister)
+ (+ (? Rn register-31=sp)
+ (&U (* 16 (? offset unsigned-12)))))
+ (BITS (2 #b00) ;`size'
+ (3 #b111)
+ (1 1) ;SIMD/FP
+ (2 #b01)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (12 offset)
+ (5 Rn)
+ (5 Vt)))
+ ;; LDR register, SIMD&FP, no extend (C7.2.178)
+ ;; STR register, SIMD&FP, no extend (C7.3.316)
+ (((? sz load/store-simd/fp-size)
+ (? Vt vregister)
+ (+ (? Rn register-31=sp)
+ (? Rm register-31=z)))
+ (BITS (2 sz LOAD/STORE-SIMD/FP-SIZE)
+ (3 #b111)
+ (1 1) ;SIMD/FP
+ (2 #b00)
+ (1 sz LOAD/STORE-SIMD/FP-OPCHI)
+ (1 ,load/store) ;opc[0]
+ (5 Rm)
+ (3 #b011) ;option=LSL
+ (1 0) ;shift=0
+ (5 Rn)
+ (5 Vt)))
+ ;; LDR register, SIMD&FP (B), (C7.2.178)
+ ;; STR register, SIMD&FP (B), (C7.2.316)
+ ((B (? Vt vregister)
+ (+ (? Rn register-31=sp)
+ ((? option load/store-extend-type)
+ (? Rm register-31=z)
+ (? S load/store8-extend-amount))))
+ (BITS (2 #b00) ;size=B
+ (3 #b111)
+ (1 1) ;SIMD/FP
+ (2 #b00)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (1 1)
+ (5 Rm)
+ (3 option)
+ (1 S)
+ (2 #b10)
+ (5 Rn)
+ (5 Vt)))
+ ;; LDR register, SIMD&FP (H), (C7.2.178)
+ ;; STR register, SIMD&FP (H), (C7.2.316)
+ ((H (? Vt vregister)
+ (+ (? Rn register-31=sp)
+ ((? option load/store-extend-type)
+ (? Rm register-31=z)
+ (? S load/store16-extend-amount))))
+ (BITS (2 #b01) ;size=H
+ (3 #b111)
+ (1 1) ;SIMD/FP
+ (2 #b00)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (1 1)
+ (5 Rm)
+ (3 option)
+ (1 S)
+ (2 #b10)
+ (5 Rn)
+ (5 Vt)))
+ ;; LDR register, SIMD&FP (S), (C7.2.178)
+ ;; STR register, SIMD&FP (S), (C7.2.316)
+ ((S (? Vt vregister)
+ (+ (? Rn register-31=sp)
+ ((? option load/store-extend-type)
+ (? Rm register-31=z)
+ (? S load/store32-extend-amount))))
+ (BITS (2 #b10) ;size=H
+ (3 #b111)
+ (1 1) ;SIMD/FP
+ (2 #b00)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (1 1)
+ (5 Rm)
+ (3 option)
+ (1 S)
+ (2 #b10)
+ (5 Rn)
+ (5 Vt)))
+ ;; LDR register, SIMD&FP (D), (C7.2.178)
+ ;; STR register, SIMD&FP (D), (C7.2.316)
+ ((D (? Vt vregister)
+ (+ (? Rn register-31=sp)
+ ((? option load/store-extend-type)
+ (? Rm register-31=z)
+ (? S load/store64-extend-amount))))
+ (BITS (2 #b11) ;size=D
+ (3 #b111)
+ (1 1) ;SIMD/FP
+ (2 #b00)
+ (1 0) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (1 1)
+ (5 Rm)
+ (3 option)
+ (1 S)
+ (2 #b10)
+ (5 Rn)
+ (5 Vt)))
+ ;; LDR register, SIMD&FP (Q), (C7.2.178)
+ ;; STR register, SIMD&FP (Q), (C7.2.316)
+ ((Q (? Vt vregister)
+ (+ (? Rn register-31=sp)
+ ((? option load/store-extend-type)
+ (? Rm register-31=z)
+ (? S load/store128-extend-amount))))
+ (BITS (2 #b00) ;size=Q
+ (3 #b111)
+ (1 1) ;SIMD/FP
+ (2 #b00)
+ (1 1) ;opc[1]
+ (1 ,load/store) ;opc[0]
+ (1 1)
+ (5 Rm)
+ (3 option)
+ (1 S)
+ (2 #b10)
+ (5 Rn)
+ (5 Vt)))
+ ,@extra))))))
+ ;; The ARM assembler has `LDRB w13,...' for byte-sized load into
+ ;; general register 13, and `LDR b13,...' for byte-sized load into
+ ;; vector register 13. We use a separate mnemonic for general
+ ;; registers and vector registers.
+ (define-simd/fp-load/store-instruction STR.V 0)
+ (define-simd/fp-load/store-instruction LDR.V 1
+ ;; LDR PC-relative literal, SIMD&FP (C7.2.177)
+ (((? opc ldr-literal-simd/fp-size) (? Vt vregister) (@PCR (? label)))
+ (BITS (2 opc)
+ (3 #b011)
+ (1 1) ;SIMD/FP
+ (2 #b00)
+ (19 `(QUOTIENT (- ,label *PC*) 4))
+ (5 Vt)))))
+
+;; Load register signed
+
+(define-instruction LDRS
+ ;; Immediate, zero unsigned offset
+ (((? Rt register-31=z) (? Rn register-31=sp))
+ (BITS (2 #b10) ;size
+ (3 #b111)
+ (1 0)
+ (2 #b01)
+ (2 #b10) ;opc
+ (12 0) ;imm12
+ (5 Rn)
+ (5 Rt)))
+ ;; Immediate, unsigned offset
+ (((? Rt register-31=z)
+ (+ (? Rn register-31=sp) (&U (? offset unsigned-12))))
+ (BITS (2 #b10) ;size
+ (3 #b111)
+ (1 0)
+ (2 #b01)
+ (2 #b10) ;opc
+ (12 offset) ;imm12
+ (5 Rn)
+ (5 Rt)))
+ ;; Post-indexed signed offset
+ (((? Rt register-31=z)
+ (POST+ (? Rn register-31=sp) (& (? offset signed-9))))
+ (BITS (2 #b10) ;size
+ (3 #b111)
+ (1 0)
+ (2 #b00)
+ (2 #b10) ;opc
+ (1 0)
+ (9 offset SIGNED)
+ (2 #b01) ;post-index
+ (5 Rn)
+ (5 Rt)))
+ ;; Pre-indexed signed offset
+ (((? Rt register-31=z)
+ (POST+ (? Rn register-31=sp) (& (? offset signed-9))))
+ (BITS (2 #b10) ;size
+ (3 #b111)
+ (1 0)
+ (2 #b00)
+ (2 #b10) ;opc
+ (1 0)
+ (9 offset SIGNED)
+ (2 #b11) ;pre-index
+ (5 Rn)
+ (5 Rt)))
+ ;; Literal
+ (((? Rt register-31=z) (@PCR (? label)))
+ (BITS (2 #b10) ;opc
+ (3 #b011)
+ (1 0) ;general
+ (2 #b00)
+ (19 `(QUOTIENT (- ,label *PC*) 4))
+ (5 Rt)))
+ ;; Register, no extend
+ (((? Rt register-31=z) (? Rn register-31=sp) (? Rm register-31=z))
+ (BITS (2 #b10) ;size
+ (3 #b111)
+ (1 0)
+ (2 #b00)
+ (2 #b10) ;opc
+ (1 1)
+ (5 Rm)
+ (3 #b011) ;option=LSL
+ (1 0) ;shift=0
+ (5 Rn)
+ (5 Rt)))
+ ;; Extended register
+ (((? Rt register-31=z)
+ (? Rn register-31=sp)
+ (? Rm register-31=z)
+ (? option ldrsw-extend-type)
+ (? S ldrsw-extend-amount))
+ (BITS (2 #b10) ;size
+ (3 #b111)
+ (1 0)
+ (2 #b00)
+ (2 #b10) ;opc
+ (1 1)
+ (5 Rm)
+ (3 option)
+ (1 S)
+ (2 #b10)
+ (5 Rn)
+ (5 Rt))))
+\f
+;;; XXX not yet converted to section ordering, need to review syntax
+
+(let-syntax
+ ((define-adr-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (receive (mnemonic op divisor) (apply values (cdr form))
+ `(define-instruction ,mnemonic
+ ((X (? Rd register-31=z) (@PCR ,label))
+ (BITS (1 ,op)
+ (2 `(QUOTIENT (- ,label *PC*) ,',divisor) IMMLO)
+ (1 1)
+ (4 #b0000)
+ (19 `(QUOTIENT (- ,label *PC*) ,',divisor) IMMHI)
+ (5 Rd)))))))))
+ ;; PC-relative byte address
+ (define-adr-instruction ADR 0 1)
+ ;; PC-relative page address
+ (define-adr-instruction ADRP 1 4096))
+
+(define (extend-type t)
+ (case t
+ ((UXTB) #b000)
+ ((UXTH) #b001)
+ ((UXTW) #b010)
+ ((UXTX) #b011)
+ ((SXTB) #b100)
+ ((SXTH) #b101)
+ ((SXTW) #b110)
+ ((SXTX) #b111)
+ (else #f)))
+
+(define (shift-type t)
+ (case t
+ ((LSL) #b00)
+ ((LSR) #b01)
+ ((ASR) #b10)
+ (else #f)))
+
+(let-syntax
+ ((define-addsub-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (receive (mnemonic op S register-31=dst Rd) (apply values (cdr form))
+ `(define-instruction ,mnemonic
+ ;; Extended register
+ (((? sf sf-size)
+ ,@(if Rd '() `((? Rd ,register-31=dst)))
+ (? Rn register-31=sp)
+ (? Rm register-31=z)
+ (? option extend-type)
+ (&U (? amount unsigned-2)))
+ (BITS (1 sf)
+ (1 ,op)
+ (1 ,S)
+ (1 0)
+ (4 #b1011)
+ (2 #b00)
+ (1 1)
+ (5 Rm)
+ (3 option)
+ (3 amount)
+ (5 Rn)
+ (5 ,(or Rd 'Rd))))
+ ;; Immediate, shift=0
+ (((? sf sf-size)
+ ,@(if Rd '() '((? Rd register-31=sp)))
+ (? Rn register-31=sp)
+ (&U (? imm unsigned-12)))
+ (BITS (1 sf)
+ (1 ,op)
+ (1 ,S)
+ (1 1)
+ (4 #b0001)
+ (2 #b00)
+ (12 imm)
+ (5 Rn)
+ (5 ,(or Rd 'Rd))))
+ ;; Immediate, shift=12
+ (((? sf sf-size)
+ ,@(if Rd '() '((? Rd register-31=sp)))
+ (? Rn register-31=sp)
+ (LSL (&U (? imm unsigned-12)) 12))
+ (BITS (1 sf)
+ (1 ,op)
+ (1 ,S)
+ (1 1)
+ (4 #b0001)
+ (2 #b01)
+ (12 imm)
+ (5 Rn)
+ (5 ,(or Rd 'Rd))))
+ ;; Shifted register, no shift amount. Could also be
+ ;; encoded by extended register as long as Rm is not the
+ ;; zero register.
+ (((? sf sf-size)
+ ,@(if Rd '() '((? Rd register-31=z)))
+ (? Rn register-31=z)
+ (? Rm register-31=z))
+ (BITS (1 sf)
+ (1 ,op)
+ (1 ,S)
+ (1 0)
+ (4 #b1011)
+ (2 #b00) ;shift type=LSL
+ (1 0)
+ (5 Rm)
+ (6 0) ;shift amount=0
+ (5 Rn)
+ (5 ,(or Rd 'Rd))))
+ ;; Shifted register, 32-bit
+ ((W ,@(if Rd '() '((? Rd register-31=z)))
+ (? Rn register-31=z)
+ (? Rm register-31=z)
+ (? type shift-type)
+ (? amount unsigned-5))
+ (BITS (1 0) ;sf=0, 32-bit operand size
+ (1 ,op)
+ (1 ,S)
+ (1 0)
+ (4 #b1011)
+ (2 type)
+ (1 0)
+ (5 Rm)
+ (6 amount)
+ (5 Rn)
+ (5 ,(or Rd 'Rd))))
+ ;; Shifted register, 64-bit
+ ((X ,@(if Rd '() '((? Rd register-31=z)))
+ (? Rn register-31=z)
+ (? Rm register-31=z)
+ (? type shift-type)
+ (? amount unsigned-6))
+ (BITS (1 1) ;sf=1, 64-bit operand size
+ (1 ,op)
+ (1 ,S)
+ (1 0)
+ (4 #b1011)
+ (2 type)
+ (1 0)
+ (5 Rm)
+ (6 amount)
+ (5 Rn)
+ (5 ,(or Rd 'Rd))))))))))
+ ;; Add
+ (define-addsub-instruction ADD 0 0 register-31=sp #f)
+ ;; Add and set flags
+ (define-addsub-instruction ADDS 0 1 register-31=z #f)
+ ;; Compare negation: ADDS(Rd=z)
+ (define-addsub-instruction CMN 0 1 #f 31)
+ ;; Subtract
+ (define-addsub-instruction SUB 1 0 register-31=sp #f)
+ ;; Subtract and set flags
+ (define-addsub-instruction SUBS 1 1 register-31=z #f)
+ ;; Compare: SUBS(Rd=z)
+ (define-addsub-instruction CMP 1 1 #f 31))
+
+;;; XXX wacky logical bit pattern encoding for immediates
+
+(define (shiftror-type t)
+ (case t
+ ((LSL) #b00)
+ ((LSR) #b01)
+ ((ASR) #b10)
+ ((ROR) #b11)
+ (else #f)))
+
+(let-syntax
+ ((define-logical-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (receive (mnemonic opc register-31=dst Rd) (apply values (cdr form))
+ `(define-instruction ,mnemonic
+ ;; Immediate, 32-bit operand size
+ ((W ,@(if Rd '() `((? Rd ,register-31=dst)))
+ (? Rn register-31=z)
+ (&U (? imm logical-imm-32)))
+ (BITS (1 0) ;sf=0, 32-bit operand size
+ (2 ,opc)
+ (1 1)
+ (4 #b0010)
+ (1 0)
+ (1 0) ;N=0
+ (6 imm BITMASK32-IMMR)
+ (6 imm BITMASK32-IMMS)
+ (5 Rn)
+ (5 ,(or Rd 'Rd))))
+ ;; Immediate, 64-bit operand size
+ ((X ,@(if Rd '() '((? Rd register-31=sp)))
+ (? Rn register-31=z)
+ (&U (? imm logical-imm-64)))
+ (BITS (1 1) ;sf=1, 64-bit operand size
+ (2 ,opc)
+ (1 1)
+ (4 #b0010)
+ (1 0)
+ (1 imm BITMASK64-N)
+ (6 imm BITMASK64-IMMR)
+ (6 imm BITMASK64-IMMS)
+ (5 Rn)
+ (5 ,(or Rd 'Rd))))
+ ;; Shifted register, no shift amount.
+ (((? sf sf-size)
+ ,@(if Rd '() '((? Rd register-31=z)))
+ (? Rn register-31=z)
+ (? Rm register-31=z))
+ (BITS (1 sf)
+ (2 ,opc)
+ (1 0)
+ (4 #b1010)
+ (2 #b00) ;shift type=LSL
+ (1 0) ;N=0
+ (5 Rm)
+ (6 0) ;shift amount=0
+ (5 Rn)
+ (5 ,(or Rd 'Rd))))
+ ;; Shifted register, 32-bit operand size.
+ ((W ,@(if Rd '() '((? Rd register-31=z)))
+ (? Rn register-31=z)
+ (? Rm register-31=z)
+ (? type shiftror-type)
+ (? amount unsigned-5))
+ (BITS (1 sf)
+ (2 ,opc)
+ (1 0)
+ (4 #b1010)
+ (2 type)
+ (1 0) ;N=0
+ (5 Rm)
+ (6 amount)
+ (5 Rn)
+ (5 ,(or Rd 'Rd))))
+ ;; Shifted register, 64-bit operand size.
+ ((X ,@(if Rd '() '((? Rd register-31=z)))
+ (? Rn register-31=z)
+ (? Rm register-31=z)
+ (? type shiftror-type)
+ (? amount unsigned-6))
+ (BITS (1 sf)
+ (2 ,opc)
+ (1 0)
+ (4 #b1010)
+ (2 type)
+ (1 0) ;N=0
+ (5 Rm)
+ (6 amount)
+ (5 Rn)
+ (5 ,(or Rd 'Rd))))))))))
+ ;; Logical AND
+ (define-logical-instruction AND #b00 register-31=sp #f)
+ ;; Logical inclusive OR
+ (define-logical-instruction ORR #b01 register-31=sp #f)
+ ;; Logical exclusive OR
+ (define-logical-instruction EOR #b10 register-31=sp #f)
+ ;; Logical AND and set flags
+ (define-logical-instruction ANDS #b11 register-31=z #f)
+ ;; Test: ANDS(Rd=z)
+ (define-logical-instruction TST #b11 register-31=z 31))
+
+(define (hw-shift32 shift)
+ (and (exact-nonnegative-integer? shift)
+ (let ((q (quotient shift 16))
+ (r (remainder shift 16)))
+ (and (zero? r)
+ (< q 2)
+ q))))
+
+(define (hw-shift64 shift)
+ (and (exact-nonnegative-integer? shift)
+ (let ((q (quotient shift 16))
+ (r (remainder shift 16)))
+ (and (zero? r)
+ (< q 4)
+ q))))
+
+(let-syntax
+ ((define-move-wide-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (receive (mnemonic opc) (apply values (cdr form))
+ `(define-instruction ,mnemonic
+ (((? sf sf-size)
+ (? Rd register-31=z)
+ (&U (? imm unsigned-16)))
+ (BITS (1 sf)
+ (2 ,opc)
+ (1 1)
+ (4 #b0010)
+ (1 1)
+ (2 0) ;hw shift=0
+ (16 imm)
+ (5 Rd)))
+ ((W (? Rd register-31=z)
+ (LSL (&U (? imm unsigned-16)) (? hw hw-shift32)))
+ (BITS (1 0) ;sf=0, 32-bit operand size
+ (2 ,opc)
+ (1 1)
+ (4 #b0010)
+ (1 1)
+ (2 hw)
+ (16 imm)
+ (5 Rd)))
+ ((X (? Rd register-31=z)
+ (LSL (&U (? imm unsigned-16)) (? hw hw-shift64)))
+ (BITS (1 1) ;sf=1, 64-bit operand size
+ (2 ,opc)
+ (1 1)
+ (4 #b0010)
+ (1 1)
+ (2 hw)
+ (16 imm)
+ (5 Rd)))))))))
+ ;; Move wide with NOT
+ (define-move-wide-instruction MOVN #b00)
+ ;; Move wide with zero
+ (define-move-wide-instruction MOVZ #b10)
+ ;; Move wide with keep
+ (define-move-wide-instruction MOVK #b11))
+
+(let-syntax
+ ((define-bitfield-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (receive (mnemonic opc) (apply values (cdr form))
+ `(define-instruction ,mnemonic
+ ((W (? Rd register-31=z)
+ (? Rn register-31=z)
+ (&U (? r unsigned-5))
+ (&U (? s unsigned-5)))
+ (BITS (1 0) ;sf=0, 32-bit operand size
+ (2 ,opc)
+ (1 1)
+ (4 #b0011)
+ (1 0)
+ (1 0) ;N, must match sf
+ (1 0) ;high bit of r
+ (6 r)
+ (1 0) ;high bit of s
+ (5 s)
+ (5 Rn)
+ (5 Rd)))
+ ((X (? Rd register-31=z)
+ (? Rn register-31=z)
+ (&U (? r unsigned-6))
+ (&U (? s unsigned-6)))
+ (BITS (1 0) ;sf=1, 64-bit operand size
+ (2 ,opc)
+ (1 1)
+ (4 #b0011)
+ (1 0)
+ (1 1) ;N, must match sf
+ (6 r)
+ (6 s)
+ (5 Rn)
+ (5 Rd)))))))))
+ ;; Signed bitfield move
+ (define-bitfield-instruction SBFM #b00)
+ ;; Bitfield move
+ (define-bitfield-instruction BFM #b01)
+ ;; Unsigned bitfield move
+ (define-bitfield-instruction UBFM #b10))
+
+(let-syntax
+ ((define-shift-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (receive (mnemonic opc op2) (apply values (cdr form))
+ `(define-instruction ,mnemonic
+ (((? sf sf-size)
+ (? Rd register-31=z)
+ (? Rn register-31=z)
+ (? Rm register-31=z))
+ (BITS (1 sf)
+ (1 0)
+ (1 0)
+ (1 1)
+ (4 #b1010)
+ (3 #b110)
+ (5 Rm)
+ (4 #b0010)
+ (2 ,op2)
+ (5 Rn)
+ (5 Rd)))
+ ;; Alias for SBFM/UBFM, 32-bit operand size.
+ ((W (? Rd register-31=z)
+ (? Rn register-31=z)
+ (&U (? shift unsigned-5)))
+ (BITS (1 0) ;sf=0, 32-bit operand size
+ (2 ,opc)
+ (1 1)
+ (4 #b0011)
+ (1 0)
+ (1 0) ;N, must match sf
+ (1 0) ;high bit of r
+ (5 `(REMAINDER (- ,shift) 32))
+ (1 0) ;high bit of s
+ (5 `(- 31 ,shift))
+ (5 Rn)
+ (5 Rd)))
+ ;; Alias for SBFM/UBFM, 64-bit operand size.
+ ((X (? Rd register-31=z)
+ (? Rn register-31=z)
+ (&U (? shift unsigned-6)))
+ (BITS (1 1) ;sf=1, 64-bit operand size
+ (2 ,opc)
+ (1 1)
+ (4 #b0011)
+ (1 0)
+ (1 1) ;N, must match sf
+ (6 `(REMAINDER (- ,shift) 64))
+ (6 `(- 63 ,shift))
+ (5 Rn)
+ (5 Rd)))))))))
+ ;; Arithmetic shift right (replicate sign bit), alias for SBFM
+ (define-shift-instruction ASR #b00 #b10)
+ ;; Logical shift left, alias for UBFM
+ (define-shift-instruction LSL #b10 #b00)
+ ;; Logical shift right (fill with zeros), alias for UBFM
+ (define-shift-instruction LSR #b10 #b01))
+
+(let-syntax
+ ((define-signed-extend-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (receive (mnemonic opc r s) (apply values (cdr form))
+ `(define-instruction ,mnemonic
+ ;; Alias for SBFM with fixed r and s.
+ (((? sf sf-size)
+ (? Rd register-31=z)
+ (? Rn register-31=z))
+ (BITS (1 sf)
+ (2 ,opc)
+ (1 1)
+ (4 #b0011)
+ (1 0)
+ (1 sf) ;N, must match sf
+ (6 ,r)
+ (6 ,s)
+ (5 Rn)
+ (5 Rd)))))))))
+ ;; Sign-extend byte (8-bit), alias for SBFM
+ (define-signed-extend-instruction SXTB #b00 0 7)
+ ;; Sign-extend halfword (16-bit), alias for SBFM
+ (define-signed-extend-instruction SXTH #b00 0 15)
+ ;; Sign-extend word (32-bit), alias for SBFM
+ (define-signed-extend-instruction SXTW #b00 0 31))
+
+(let-syntax
+ ((define-unsigned-extend-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (receive (mnemonic opc r s) (apply values (cdr form))
+ `(define-instruction ,mnemonic
+ ;; Alias for UBFM with fixed r and s.
+ ;;
+ ;; Limited to 32-bit because the top 32 bits are always
+ ;; zero'd anyway. Not that it would be a problem to
+ ;; support this, since the instruction encoding is there,
+ ;; but the official assembler syntax doesn't support it
+ ;; and maybe it's a mistake if you try to use it.
+ ((W (? Rd register-31=z)
+ (? Rn register-31=z))
+ (BITS (1 0) ;sf=0, 32-bit operand size
+ (2 ,opc)
+ (1 1)
+ (4 #b0011)
+ (1 0)
+ (1 0) ;N, must match sf
+ (6 ,r)
+ (6 ,s)
+ (5 Rn)
+ (5 Rd)))))))))
+ ;; Unsigned zero-extend byte (8-bit), alias for UBFM
+ (define-unsigned-extend-instruction UXTB #b00 0 7)
+ ;; Unsigned zero-extend halfword (16-bit), alias for UBFM
+ (define-unsigned-extend-instruction UXTH #b00 0 15)
+ ;; Unsigned zero-extend word (32-bit), nonexistent because any
+ ;; word-sized write to a destination register will zero the high 32
+ ;; bits.
+ #;
+ (define-unsigned-extend-instruction UXTW #b00 0 31))
+
+(let-syntax
+ ((define-bitfield-insert/extract-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (receive (mnemonic opc r32 r64 s #!optional register-31=src Rn)
+ (apply values (cdr form))
+ (define (default def x) (if (default-object? x) def x))
+ (let ((register-31=src (default register-31=z register-31=src))
+ (Rn (default #f Rn)))
+ `(define-instruction ,mnemonic
+ ((W (R (? Rd register-31=z))
+ ,@(if Rn '() `((? Rn ,register-31=src)))
+ (&U (? lsb unsigned-5))
+ (&U (? width unsigned-5+1)))
+ (BITS (1 0) ;sf=0, 32-bit operand size
+ (2 ,opc)
+ (1 1)
+ (4 #b0011)
+ (1 0)
+ (1 0) ;N, must match sf
+ (6 ,r32)
+ (6 ,s)
+ (5 ,(or Rn 'Rn))
+ (5 Rd)))
+ ((X (? Rd register-31=z)
+ ,@(if Rn '() `((? Rn ,register-31=src)))
+ (&U (? lsb unsigned-5))
+ (&U (? width unsigned-5+1)))
+ (BITS (1 1) ;sf=1, 32-bit operand size
+ (2 ,opc)
+ (1 1)
+ (4 #b0011)
+ (1 0)
+ (1 1) ;N, must match sf
+ (6 ,r64)
+ (6 ,s)
+ (5 ,(or Rn 'Rn))
+ (5 Rd))))))))))
+ ;; Signed bitfield extract, alias for SBFM
+ (define-bitfield-insert/extract-instruction SBFX #b00
+ lsb ;r32
+ lsb ;r64
+ `(- (+ ,lsb ,width) 1)) ;s
+ ;; Unsigned bitfield extract, alias for UBFM
+ (define-bitfield-insert/extract-instruction UBFX #b10
+ lsb ;r32
+ lsb ;r64
+ `(- (+ ,lsb ,width) 1)) ;s
+ ;; Signed bitfield insert in zeros, alias for SBFM
+ (define-bitfield-insert/extract-instruction SFBIZ #b00
+ `(REMAINDER (- ,lsb) 32) ;r32
+ `(REMAINDER (- ,lsb) 64) ;r64
+ `(- ,width 1)) ;s
+ ;; Bitfield extract and insert low copies
+ (define-bitfield-insert/extract-instruction BFXIL #b01
+ `(REMAINDER (- ,lsb) 32) ;r32
+ `(REMAINDER (- ,lsb) 64) ;r64
+ (- width 1)) ;s
+ ;; Bitfield insert: copy <width> bits at <lsb> from source
+ (define-bitfield-insert/extract-instruction BFI #b01
+ `(REMAINDER (- ,lsb) 32) ;r32
+ `(REMAINDER (- ,lsb) 64) ;r64
+ `(- ,width 1) ;s
+ register<31) ;Rn must not be 31
+ ;; Bitfield clear: clear <width> bit positions at <lsb>
+ (define-bitfield-insert/extract-instruction BFC #b01
+ `(REMAINDER (- ,lsb) 32) ;r32
+ `(REMAINDER (- ,lsb) 64) ;r64
+ `(- ,width 1) ;s
+ #f 31) ;Rn is 31
+ (define-bitfield-insert/extract-instruction UFBIZ #b10
+ `(REMAINDER (- ,lsb) 32) ;r32
+ `(REMAINDER (- ,lsb) 64) ;r64
+ `(- ,width 1))) ;s
+
+(let-syntax
+ ((define-extract-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((mnemonic (cadr form))
+ (op21 (caddr form))
+ (o0 (cadddr form))
+ (m=n? (and (pair? (cddddr form)) (car (cddddr form)))))
+ `(define-instruction ,mnemonic
+ ((W (? Rd)
+ (? Rn)
+ ,@(if m=n? '() '((? Rm)))
+ (&U (? s unsigned-5)))
+ (BITS (1 0) ;sf=0
+ (2 ,op21)
+ (1 1)
+ (4 #b0011)
+ (1 1)
+ (1 sf) ;N, must match sf
+ (1 ,o0)
+ (5 ,(if m=n? 'Rn 'Rm))
+ (1 0) ;high bit of lsb index, 0 for 32-bit
+ (5 s)
+ (5 Rn)
+ (5 Rd)))
+ ((X (? Rd)
+ (? Rn)
+ ,@(if m=n? '() '((? Rm)))
+ (&U (? s unsigned-6)))
+ (BITS (1 0) ;sf=0
+ (2 ,op21)
+ (1 1)
+ (4 #b0011)
+ (1 1)
+ (1 sf) ;N, must match sf
+ (1 ,o0)
+ (5 ,(if m=n? 'Rn 'Rm))
+ (6 s)
+ (5 Rn)
+ (5 Rd)))))))))
+ ;; Extract register from pair of registers at bit offset
+ (define-extract-instruction EXTR #b00 0)
+ ;; Rotate right
+ (define-extract-instruction ROR #b00 0 #t))
+
+;; Carry flag invert
+
+(define-instruction CFINV
+ (()
+ (BITS (8 #b11010101)
+ (8 #b00000000)
+ (8 #b01000000)
+ (8 #b00011111))))
+
+;; XXX advanced SIMD load/store multiple
+
+(define (signed-7*4 x)
+ (and (<= -256 x 252)
+ (zero? (remainder x 4))
+ (quotient x 4)))
+
+(let-syntax
+ ((define-load/store-pair-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (receive (mnemonic L) (apply values (cdr form))
+ `(define-instruction ,mnemonic
+ ;; No write-back, no increment.
+ (((? sf sf-size)
+ (? Rt1 register-31=z)
+ (? Rt2 register-31=z)
+ (? Rn register-31=sp))
+ (BITS (1 sf)
+ (1 0) ;opc[1]
+ (3 #b101)
+ (1 0)
+ (3 #b010)
+ (1 ,L)
+ (7 0)
+ (5 Rt2)
+ (5 Rn)
+ (5 Rt1)))
+ ;; No write back, signed increment.
+ (((? sf sf-size)
+ (? Rt1 register-31=z)
+ (? Rt2 register-31=z)
+ (+ (? Rn register-31=sp)) (& (? imm signed-7*4)))
+ (BITS (1 sf)
+ (1 0) ;opc[1]
+ (3 #b101)
+ (1 0)
+ (3 #b010)
+ (1 ,L)
+ (7 imm SIGNED)
+ (5 Rt2)
+ (5 Rn)
+ (5 Rt1)))
+ ;; Pre-index signed offset.
+ (((? sf sf-size)
+ (? Rt1 register-31=z)
+ (? Rt2 register-31=z)
+ (PRE+ (? Rn register-31=sp) (& (? imm signed-7*4))))
+ (BITS (1 sf)
+ (1 0) ;opc[1]
+ (3 #b101)
+ (1 0)
+ (3 #b011)
+ (1 ,L)
+ (7 imm SIGNED)
+ (5 Rt2)
+ (5 Rn)
+ (5 Rt)))
+ ;; Post-index signed offset.
+ (((? sf sf-size)
+ (? Rt1 register-31=z)
+ (? Rt2 register-31=z)
+ (POST+ (? Rn register-31=sp) (& (? imm signed-7*4))))
+ (BITS (1 sf)
+ (1 0) ;opc[1]
+ (3 #b101)
+ (1 0)
+ (3 #b001)
+ (1 ,L)
+ (7 imm SIGNED)
+ (5 Rt2)
+ (5 Rn)
+ (5 Rt)))))))))
+ (define-load/store-pair-instruction LDP 1)
+ (define-load/store-pair-instruction STP 1))
+
+(define (load/store-size sz)
+ (case sz
+ ((B) #b00)
+ ((H) #b01)
+ ((W) #b10)
+ ((X) #b11)
+ (else #f)))
+
+(let-syntax
+ ((define-load/store-exclusive-instruction
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (receive (mnemonic L o2 o1 o0) (apply values (cdr form))
+ `(define-instruction ,mnemonic
+ (((? sz load/store-size)
+ (? Rs register-31=z)
+ (? Rt register-31=z)
+ (? Rn register-31=sp))
+ (BITS (2 size)
+ (2 #b00)
+ (4 #b1000)
+ (1 ,o2)
+ (1 ,L)
+ (1 ,o1)
+ (5 Rs)
+ (1 ,o0)
+ (5 31)
+ (5 Rn)
+ (5 Rt)))))))))
+ ;; Store exclusive register
+ (define-load/store-exclusive-instruction STXR 0 0 0 0)
+ ;; Store-release exclusive register
+ (define-load/store-exclusive-instruction STLXR 0 0 0 1)
+ ;; Load exclusive register
+ (define-load/store-exclusive-instruction LDXR 1 0 0 0)
+ ;; Load-acquire exclusive register
+ (define-load/store-exclusive-instruction LDLXR 1 0 0 1)
+ ;; Store LORelease register
+ (define-load/store-exclusive-instruction STLLR 0 1 0 0)
+ ;; Store-release register
+ (define-load/store-exclusive-instruction STLR 0 1 0 1)
+ ;; Load LOAcquire register
+ (define-load/store-exclusive-instruction LDLAR 1 1 0 0)
+ ;; Load-acquire register
+ (define-load/store-exclusive-instruction LDAR 1 1 0 1))
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 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 for AArch64
+;;; package: (compiler)
+
+(declare (usual-integrations))
+\f
+;;;; Register-Allocator Interface
+
+(define available-machine-registers
+ (list
+ r0
+ r1
+ r2
+ r3
+ r4
+ r5
+ r6
+ r7
+ r8
+ r9
+ r10
+ r11
+ r12
+ r13
+ r14
+ r15
+ ;r16 - PLT scratch; we'll use for branch tensioning
+ ;r17 - PLT scratch; we'll use for branch tensioning
+ ;r18 - platform ABI register
+ ;r19 - interpreter register block
+ ;r20 - free pointer
+ ;r21 - dynamic link
+ ;r22 - memtop
+ r23
+ r24
+ r25
+ r26
+ r27
+ r28
+ ;r29 - C frame pointer, callee-saved and left alone by Scheme
+ ;r30 - link register (could maybe allocate)
+ ;r31 - stack pointer or zero register, depending on instruction
+ ;; Vector registers, always available.
+ v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15
+ v16 v17 v18 v19 v20 v21 v22 v23 v24 v25 v26 v27 v28 v29 v30 v31))
+
+(define (sort-machine-registers registers)
+ registers)
+
+(define (register-type register)
+ (cond ((machine-register? register)
+ (if (< register 32) 'GENERAL 'FLOAT))
+ ((register-value-class=word? register) 'GENERAL)
+ ((register-value-class=float? register) 'FLOAT)
+ (else (error "Unknown register type:" register))))
+
+(define register-reference
+ (let ((references (make-vector number-of-machine-registers)))
+ (do ((register 0 (+ register 1)))
+ ((>= register 32))
+ (vector-set! references register (INST-EA (R ,register))))
+ (do ((register 32 (+ register 1)))
+ ((>= register 64))
+ (vector-set! references register (INST-EA (V ,(- register 32)))))
+ (named-lambda (register-reference register)
+ (vector-ref references register))))
+\f
+(define (register=? a b)
+ (= a b))
+
+(define (register->register-transfer source target)
+ (guarantee-registers-compatible source target)
+ (if (register=? source target)
+ (LAP)
+ (case (register-type source)
+ ((GENERAL)
+ (if (or (= source rsp) (= target rsp))
+ (let ((target (register-or-sp target))
+ (source (register-or-sp source)))
+ (LAP (ADD X ,target ,source (&U 0))))
+ (LAP (ORR X ,target ,source (&U 0)))))
+ ((FLOAT)
+ (LAP (FMOV D ,target ,source)))
+ (else
+ (error "Unknown register type:" source target)))))
+
+(define (pseudo-register-home register)
+ (INST-EA (OFFSET ,regnum:regs-pointer ,(register-renumber register))))
+
+(define (home->register-transfer source target)
+ (memory->register-transfer regnum:regs-pointer
+ (pseudo-register-byte-offset source)
+ target))
+
+(define (register->home-transfer source target)
+ (register->memory-transfer source
+ regnum:regs-pointer
+ (pseudo-register-byte-offset target)))
+
+(define (reference->register-transfer source target)
+ (case (ea/mode source)
+ ((R) (register->register-transfer (register-ea/register source) target))
+ ((V) (register->register-transfer (vector-ea/register source) target))
+ ((OFFSET)
+ (memory->register-transfer (offset-ea/offset source)
+ (offset-ea/register source)
+ target))
+ (else
+ (error "Unknown effective address mode:" source target))))
+
+(define (memory->register-transfer offset base target)
+ (case (register-type target)
+ ((GENERAL)
+ (LAP (LDR X ,target (OFFSET ,base ,offset))))
+ ((FLOAT)
+ (LAP (LDR D ,target (OFFSET ,base ,offset))))
+ (else
+ (error "Unknown register type:" target))))
+
+(define (register->memory-transfer source offset base)
+ (case (register-type target)
+ ((GENERAL)
+ (LAP (STR X ,target (OFFSET ,base ,offset))))
+ ((FLOAT)
+ (LAP (STR D ,target (OFFSET ,base ,offset))))
+ (else
+ (error "Unknown register type:" target))))
+\f
+;;; Utilities
+
+(define (standard-source! register)
+ (if (eq? register 'Z)
+ register
+ (load-alias-register! register (register-type register))))
+
+(define (standard-target! register)
+ (assert (not (eq? register 'Z)))
+ (delete-dead-registers!)
+ (allocate-alias-register! register (register-type register)))
+
+(define (standard-move-to-temporary! source)
+ (if (eq? source 'Z)
+ (let ((temp (standard-temporary!)))
+ (prefix-instructions! (LAP (MOVZ X ,temp (&U 0))))
+ temp)
+ (move-to-temporary-register! source (register-type source))))
+
+(define (register-expression expression)
+ (case (rtl:expression-type expression)
+ ((REGISTER)
+ (rtl:register-number expression))
+ ((CONSTANT)
+ (let ((object (rtl:constant-value expression)))
+ (and (zero? (back-end:object-type object))
+ (zero? (back-end:object-datum object))
+ 'Z)))
+ ((MACHINE-CONSTANT)
+ (and (zero? (rtl:machine-constant-value expression))
+ 'Z))
+ ((CONS-POINTER)
+ (let ((type (rtl:cons-pointer-type expression))
+ (datum (rtl:cons-pointer-datum expression)))
+ (cond ((rtl:machine-constant? type)
+ (and (zero? (rtl:machine-constant-value type))
+ (register-expression datum)))
+ ((rtl:machine-constant? datum)
+ (and (zero? (rtl:machine-constant-value datum))
+ (register-expression type)))
+ (else #f))))
+ (else #f)))
+
+(define (standard-unary target source operate)
+ (let* ((source (standard-source! source))
+ (target (standard-target! target)))
+ (operate target source)))
+
+(define (standard-binary target source1 source2 operate)
+ (let* ((source1 (standard-source! source1))
+ (source2 (standard-source! source2))
+ (target (standard-target! target)))
+ (operate target source1 source2)))
+
+(define (standard-binary-effect source1 source2 operate)
+ (let* ((source1 (standard-source! source1))
+ (source2 (standard-source! source2)))
+ (operate source1 source2)))
+
+(define (standard-ternary-effect source1 source2 source3 operate)
+ (let* ((source1 (standard-source! source1))
+ (source2 (standard-source! source2))
+ (source3 (standard-source! source3)))
+ (operate source1 source2 source3)))
+\f
+(define (pop register)
+ (LAP (LDR X ,register
+ (POST+ ,regnum:stack-pointer ,addressing-units-per-object))))
+
+(define (push register)
+ (LAP (STR X ,register
+ (PRE- ,regnum:stack-pointer ,addressing-units-per-object))))
+
+(define (pop2 reg1 reg2)
+ ;; (LAP ,@(pop reg1) ,@(pop reg2))
+ (LAP (LDRP X ,reg1 ,reg2
+ (POST+ ,regnum:stack-pointer
+ ,(* 2 addressing-units-per-object)))))
+
+(define (push2 reg1 reg2)
+ ;; (LAP ,@(push reg2) ,@(push reg1))
+ (LAP (STRP X ,reg2 ,reg1
+ (PRE- ,regnum:stack-pointer ,(* 2 addressing-units-per-object)))))
+
+(define (scale->shift scale)
+ (case scale
+ ((1) 0)
+ ((2) 1)
+ ((4) 2)
+ ((8) 4)
+ (else (error "Invalid scale:" scale))))
+
+(define (load-displaced-address target base offset scale)
+ (standard-unary target base
+ (lambda (target base)
+ (add-immediate target base (* offset scale)))))
+
+(define (load-indexed-address target base offset scale)
+ (standard-binary target base offset
+ (lambda (target base offset)
+ (LAP (ADD X ,target ,base (LSL ,offset ,(scale->shift scale)))))))
+
+(define (load-signed-immediate target imm)
+ (load-unsigned-immediate target (bitwise-and imm #xffffffffffffffff)))
+
+(define (load-unsigned-immediate target imm)
+ (define (try-shift shift)
+ (and (zero? (bitwise-and imm (bit-mask shift 0)))
+ (fits-in-unsigned-16? (shift-right imm shift))
+ shift))
+ (define (find-shift imm)
+ (or (try-shift imm 0)
+ (try-shift imm 16)
+ (try-shift imm 32)
+ (try-shift imm 48)))
+ (cond ((find-shift imm)
+ => (lambda (shift)
+ (LAP (MOVZ X ,target (LSL (&U ,imm) ,shift)))))
+ ((find-shift (bitwise-not imm))
+ => (lambda (shift)
+ (LAP (MOVN X ,target (LSL (&U ,(bitwise-not imm)) ,shift)))))
+ ((logical-immediate? imm)
+ (LAP (ORR X ,target Z (&U ,imm))))
+ ;; XXX try splitting in halves, quarters
+ ((let ((lo (extract-bit-field 32 0 imm))
+ (hi (extract-bit-field 32 32 imm)))
+ (let ((lo-shift (find-shift lo))
+ (hi-shift (find-shift hi)))
+ (and lo-shift hi-shift (cons lo-shift hi-shift))))
+ => (lambda))
+ ((fits-in-unsigned-16? (bitwise-not imm))
+ (LAP (MOVN X ,target (&U ,(bitwise-not imm)))))
+ ...))
+
+(define (load-pc-relative-address target label)
+ ;; XXX What happens if label is >1 MB away?
+ (LAP (ADR X ,target (@PCR ,label))))
+
+(define (load-pc-relative target label)
+ (LAP ,@(load-pc-relative-address target label)
+ (LDR X ,target ,target)))
+
+(define (load-tagged-immediate target type datum)
+ (load-unsigned-immediate (make-non-pointer-literal type datum)))
+
+(define (load-constant target object)
+ (if (non-pointer-object? object)
+ (load-unsigned-immediate target (non-pointer->literal object))
+ (load-pc-relative target (constant->label object))))
+
+(define (add-immediate target source imm)
+ (define (add addend) (LAP (ADD X ,target ,source ,addend)))
+ (define (sub addend) (LAP (SUB X ,target ,source ,addend)))
+ (immediate-addition imm add sub))
+
+(define (add-immediate-with-flags target source imm)
+ (define (adds addend) (LAP (ADDS X ,target ,source ,addend)))
+ (define (subs addend) (LAP (SUBS X ,target ,source ,addend)))
+ (immediate-addition imm adds subs))
+
+(define (cmp-immediate source imm)
+ ;; Same as above but with zero destination.
+ (define (cmp operand) (LAP (CMP X ,source ,operand)))
+ (define (cmn operand) (LAP (CMN X ,source ,operand)))
+ (immediate-addition imm cmp cmn))
+
+(define (immediate-addition imm add sub)
+ ;; XXX Use INST-EA instead of quasiquote? Dunno...
+ (cond ((fits-in-unsigned-12? imm)
+ (add `(&U ,imm)))
+ ((and (zero? (bitwise-and imm (bit-mask 12 0)))
+ (fits-in-unsigned-12? (shift-right immediate 12)))
+ (add `(&U ,imm LSL 12)))
+ ((fits-in-unsigned-12? (- immediate))
+ (sub `(&U ,(- immediate))))
+ ((and (zero? (bitwise-and imm (bit-mask 12 0)))
+ (fits-in-unsigned-12? (shift-right (- immediate) 12)))
+ (sub `(&U ,(- immediate) LSL 12)))
+ (else
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(load-unsigned-immediate temp immediate)
+ ,@(add temp))))))
+\f
+(define (affix-type target type datum)
+ ;; Note: This must NOT use regnum:scratch-0 or regnum:scratch-1!
+ ;; This is used by closure headers to tag the incoming entry.
+ (assert (<= scheme-type-width 16))
+ (assert (<= 48 scheme-datum-width))
+ (cond ((zero? type)
+ (assign-register->register target datum))
+ ((logical-immediate? (make-non-pointer-literal type 0))
+ ;; Works for tags with only contiguous one bits, including
+ ;; tags with only one bit set.
+ (LAP (ORR ,target ,datum (&U ,(make-non-pointer-literal type 0)))))
+ ((fits-in-unsigned-12?
+ (shift-left type (- scheme-datum-width 48)))
+ ;; Works for 2-bit tags.
+ (let ((imm (shift-left type (- scheme-datum-width 48)))
+ (shift 48))
+ (LAP (ADD ,target ,datum (LSL (&U ,imm) ,shift)))))
+ (else
+ ;; Works for all tags up to 16 bits, but costs two
+ ;; instructions.
+ ;;
+ ;; XXX If we know the top few bits of the datum are zero, we
+ ;; could use a single MOVK instruction.
+ (let ((imm (shift-left type (- 16 scheme-type-width)))
+ (shift 48))
+ (LAP (MOVZ ,target (LSL (&U ,imm) ,shift))
+ (ORR ,target ,target ,datum))))))
+
+(define (object->type target source)
+ (let ((lsb scheme-datum-width)
+ (width scheme-type-width))
+ (LAP (UBFX X ,target ,source (&U ,lsb) (&U ,width)))))
+
+(define (object->datum target source)
+ (let ((lsb 0)
+ (width scheme-datum-width))
+ ;; Alternatively, use BFC to clear the top scheme-type-width bits.
+ (LAP (UBFX X ,target ,source (&U ,lsb) (&U ,width)))))
+
+(define (object->address target source)
+ (object->datum target source))
+\f
+(define (lap:make-label-statement label)
+ (LAP (LABEL ,label)))
+
+(define (lap:make-unconditional-branch label)
+ (LAP (B (@PCR ,label))))
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 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 AArch64
+;;; package: (compiler lap-optimizer)
+
+(declare (usual-integrations))
+\f
+(define (optimize-linear-lap instructions)
+ instructions)
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 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 AArch64
+;;; package: (compiler)
+
+(declare (usual-integrations))
+\f
+;;;; Architecture Parameters
+
+(define (target-fasl-format)
+ (case endianness
+ ((BIG) fasl-format:aarch64be)
+ ((LITTLE) fasl-format:aarch64le)
+ (else (error "Unknown endianness:" endianness))))
+
+(define use-pre/post-increment? #t)
+(define-integrable addressing-granularity 8)
+(define-integrable scheme-object-width 64)
+(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 64)
+
+(define-integrable address-units-per-float
+ (quotient float-width addressing-granularity))
+
+;;; It is currently required that both packed characters and objects
+;;; be integrable numbers of address units. Furthermore, the number
+;;; of address units per object must be an integral multiple of the
+;;; number of address units per character. This will cause problems
+;;; on a machine that is word addressed: we will have to rethink the
+;;; character addressing strategy.
+
+(define-integrable address-units-per-object
+ (quotient scheme-object-width addressing-granularity))
+
+(define-integrable address-units-per-packed-char 1)
+
+(define-integrable signed-fixnum/upper-limit
+ ;; (expt 2 (-1+ scheme-datum-width)) ***
+ #x0200000000000000)
+
+(define-integrable signed-fixnum/lower-limit
+ (- signed-fixnum/upper-limit))
+
+(define-integrable unsigned-fixnum/upper-limit
+ (* 2 signed-fixnum/upper-limit))
+
+(define-integrable (stack->memory-offset offset) offset)
+(define-integrable ic-block-first-parameter-offset 2)
+\f
+;;;; Closure format
+
+;;; See microcode/cmpintmd/aarch64.h for a description of the layout.
+
+(define-integrable closure-entry-size 2) ;units of objects
+
+(define-integrable address-units-per-closure-manifest address-units-per-object)
+(define-integrable address-units-per-entry-format-code 4)
+(define-integrable address-units-per-closure-entry-count 4)
+(define-integrable address-units-per-closure-padding -4)
+
+(define-integrable address-units-per-closure-pc-offset 8)
+(define-integrable address-units-per-closure-entry-padding 4)
+
+(define-integrable address-units-per-closure-entry
+ (+ address-units-per-entry-format-code
+ address-units-per-closure-pc-offset
+ address-units-per-closure-entry-padding))
+
+;;; Note:
+;;;
+;;; (= address-units-per-closure-entry #| 16 |#
+;;; (* closure-entry-size #| 2 |# address-units-per-object #| 8 |#))
+
+;;; Given the number of entries in a closure, and the index of an
+;;; entry, return the number of words from that entry's closure
+;;; pointer to the location of the storage for the closure's first
+;;; free variable. In this case, the closure pointer is the same as
+;;; the compiled entry pointer into the entry instructions. This is
+;;; different from the i386, where the entry instructions are not all
+;;; object-aligned, and thus the closure pointer is adjusted to point
+;;; to the first entry in the closure block, which is always aligned.
+;;;
+;;; When there are zero entries, the `closure' is just a vector, and
+;;; represented by a tagged pointer to a manifest, following which are
+;;; the free variables. In this case, the first offset is one object
+;;; past the manifest's address.
+
+(define (closure-first-offset nentries entry)
+ (if (zero? nentries)
+ 1
+ (* (- nentries entry 1) closure-entry-size)))
+
+;;; Given the number of entry points in a closure, return the distance
+;;; in objects from the address of the manifest closure to the address
+;;; of the first free variable.
+
+(define (closure-object-first-offset nentries)
+ (if (zero? nentries)
+ 1 ;One vector manifest.
+ ;; One object for the closure manifest, half an object for the
+ ;; leading entry count, and minus half an object for the trailing
+ ;; non-padding.
+ (+ 1 (* nentries closure-entry-size))))
+
+;;; Given the number of entries in a closure, and the indices of two
+;;; entries, return the number of bytes separating the two entries.
+
+(define (closure-entry-distance nentries entry entry*)
+ nentries ;ignore
+ (* (- entry* entry) address-units-per-closure-entry))
+
+;;; Given the number of entries in a closure, and the index of an
+;;; entry, return the number of bytes to add to a possibly misaligned
+;;; closure pointer to obtain a `canonical' entry point, which is
+;;; aligned on an object boundary. Since all closure entry points are
+;;; aligned thus on this machine, we need adjust nothing.
+
+(define (closure-environment-adjustment nentries entry)
+ nentries entry ;ignore
+ 0)
+\f
+;;;; Machine registers
+
+;;; 64-bit general purpose registers, variously named Wn or Xn in the
+;;; ARM assembler depending on the operand size, 32-bit or 64-bit.
+;;; We'll name the operand size separately.
+;;;
+;;; XXX To allocate: regnum:apply-pc, regnum:apply-target
+
+;; register Scheme purpose C purpose
+(define-integrable r0 0) ;result, temporary first argument, result
+(define-integrable r1 1) ;temporary, utilarg0 second argument
+(define-integrable r2 2) ;temporary, utilarg1 third argument
+(define-integrable r3 3) ;temporary, utilarg2 fourth argument
+(define-integrable r4 4) ;temporary, utilarg3 fifth argument
+(define-integrable r5 5) ;temporary, utilarg4 sixth argument
+(define-integrable r6 6) ;temporary, utilarg6 seventh argument
+(define-integrable r7 7) ;temporary, utilarg6 eighth argument
+(define-integrable r8 8) ;temporary indirect result location
+(define-integrable r9 9) ;temporary temporary
+(define-integrable r10 10) ;temporary temporary
+(define-integrable r11 11) ;temporary temporary
+(define-integrable r12 12) ;temporary temporary
+(define-integrable r13 13) ;temporary temporary
+(define-integrable r14 14) ;temporary temporary
+(define-integrable r15 15) ;temporary temporary
+(define-integrable r16 16) ;temporary, first PLT scratch register
+ ; indirect jump callee,
+ ; scheme-to-interface code
+(define-integrable r17 17) ;temporary, second PLT scratch register
+ ; indirect jump pc
+(define-integrable r18 18) ;reserved platform ABI register
+(define-integrable r19 19) ;interpreter regs callee-saved
+(define-integrable r20 20) ;free pointer callee-saved
+(define-integrable r21 21) ;dynamic link callee-saved
+(define-integrable r22 22) ;memtop (XXX why?) callee-saved
+(define-integrable r23 23) ;temporary callee-saved
+(define-integrable r24 24) ;temporary callee-saved
+(define-integrable r25 25) ;temporary callee-saved
+(define-integrable r26 26) ;temporary callee-saved
+(define-integrable r27 27) ;temporary callee-saved
+(define-integrable r28 28) ;temporary callee-saved
+(define-integrable r29 29) ;C frame pointer frame pointer
+(define-integrable rlr 30) ;link register link register
+(define-integrable rsp 31) ;stack pointer stack pointer
+
+;; Note: Register 31 is alternately the stack pointer or the zero
+;; register, depending on instruction.
+\f
+;;; 128-bit vector registers for SIMD or floating-point instructions,
+;;; variously called Bn, Hn, Sn, Dn, Qn, Vn.8B, Vn.16B, Vn.4H, Vn.8H,
+;;; Vn.2S in the ARM assembler depending on how they are being used.
+;;; No special purpose.
+
+(define-integrable v0 32)
+(define-integrable v1 33)
+(define-integrable v2 34)
+(define-integrable v3 35)
+(define-integrable v4 36)
+(define-integrable v5 37)
+(define-integrable v6 38)
+(define-integrable v7 39)
+(define-integrable v8 40)
+(define-integrable v9 41)
+(define-integrable v10 42)
+(define-integrable v11 43)
+(define-integrable v12 44)
+(define-integrable v13 45)
+(define-integrable v14 46)
+(define-integrable v15 47)
+(define-integrable v16 48)
+(define-integrable v17 49)
+(define-integrable v18 50)
+(define-integrable v19 51)
+(define-integrable v20 52)
+(define-integrable v21 53)
+(define-integrable v22 54)
+(define-integrable v23 55)
+(define-integrable v24 56)
+(define-integrable v25 57)
+(define-integrable v26 58)
+(define-integrable v27 59)
+(define-integrable v28 60)
+(define-integrable v29 61)
+(define-integrable v30 62)
+(define-integrable v31 63)
+
+(define-integrable number-of-machine-registers 64)
+(define-integrable number-of-temporary-registers 256)
+\f
+;; Draw various fixed-function registers from the callee-saved section,
+;; so we don't have to worry about saving and restoring them ourselves
+;; in the transition to and from C.
+
+(define-integrable regnum:value-register r0)
+(define-integrable regnum:utility-arg0 r1)
+(define-integrable regnum:utility-arg1 r2)
+(define-integrable regnum:utility-arg2 r3)
+(define-integrable regnum:utility-arg3 r4)
+(define-integrable regnum:utility-arg4 r5)
+(define-integrable regnum:utility-arg5 r6)
+(define-integrable regnum:utility-arg6 r7)
+(define-integrable regnum:scratch-0 r16)
+(define-integrable regnum:scratch-1 r17)
+(define-integrable regnum:regs-pointer r19)
+(define-integrable regnum:free-pointer r20)
+(define-integrable regnum:dynamic-link r21) ;Pointer to parent stack frame.
+(define-integrable regnum:memtop r22)
+(define-integrable regnum:c-frame-pointer r29)
+(define-integrable regnum:link-register rlr) ;Return address.
+(define-integrable regnum:stack-pointer rsp)
+
+;; XXX Maybe we're playing a dangerous game to use the scratch registers for
+;; these.
+(define-integrable regnum:apply-target regnum:scratch-0)
+(define-integrable regnum:apply-pc regnum:scratch-1)
+
+(define-integrable (machine-register-known-value register)
+ register ;ignore
+ #f)
+
+(define machine-register-value-class
+ (let ((classes (make-vector 64)))
+ ;; Fill in defaults.
+ (do ((i 0 (+ i 1)))
+ ((>= i 32))
+ (vector-set! classes i value-class=object))
+ (do ((i 32 (+ i 1)))
+ ((>= i 64))
+ (vector-set! classes i value-class=float))
+ (vector-set! classes regnum:scratch-0 value-class=unboxed)
+ (vector-set! classes regnum:scratch-1 value-class=unboxed)
+ (vector-set! classes regnum:regs-pointer value-class=address)
+ (vector-set! classes regnum:free-pointer value-class=address)
+ (vector-set! classes regnum:dynamic-link value-class=address)
+ (vector-set! classes regnum:memtop value-class=address)
+ (vector-set! classes regnum:c-frame-pointer value-class=address)
+ (vector-set! classes regnum:stack-pointer value-class=address)
+ (named-lambda (machine-register-value-class register)
+ (assert (<= 0 register))
+ (assert (< register number-of-machine-registers))
+ (vector-ref classes 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/stack-guard-offset 11)
+(define-integrable register-block/int-code-offset 12)
+(define-integrable register-block/reflect-to-interface-offset 13)
+\f
+(define-integrable (interpreter-value-register)
+ (rtl:make-machine-register regnum:value-register))
+
+(define (interpreter-value-register? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:value-register)))
+
+(define-integrable (interpreter-regs-pointer)
+ (rtl:make-machine-register regnum:regs-pointer))
+
+(define (interpreter-regs-pointer? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:regs-pointer)))
+
+(define-integrable (interpreter-free-pointer)
+ (rtl:make-machine-register regnum:free-pointer))
+
+(define (interpreter-free-pointer? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:free-pointer)))
+
+(define-integrable (interpreter-dynamic-link)
+ (rtl:make-machine-register regnum:dynamic-link))
+
+(define (interpreter-dynamic-link? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:dynamic-link)))
+
+(define-integrable (interpreter-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)))
+\f
+(define (interpreter-register:access)
+ (rtl:make-machine-register r0))
+
+(define (interpreter-register:cache-reference)
+ (rtl:make-machine-register r0))
+
+(define (interpreter-register:cache-unassigned?)
+ (rtl:make-machine-register r0))
+
+(define (interpreter-register:lookup)
+ (rtl:make-machine-register r0))
+
+(define (interpreter-register:unassigned?)
+ (rtl:make-machine-register r0))
+
+(define (interpreter-register:unbound?)
+ (rtl:make-machine-register r0))
+
+(define (rtl:machine-register? register-name)
+ (case register-name
+ ((DYNAMIC-LINK) (interpreter-dynamic-link))
+ ((FREE) (interpreter-free-pointer))
+ ((MEMORY-TOP) (rtl:make-machine-register regnum:memtop))
+ ((STACK-POINTER) (interpreter-stack-pointer))
+ ((VALUE) (interpreter-value-register))
+ ((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 #f)))
+
+(define (rtl:interpreter-register? rtl-register)
+ (case rtl-register
+ ((INT-MASK) register-block/int-mask-offset)
+ ((ENVIRONMENT) register-block/environment-offset)
+ ((DYNAMIC-LINK) register-block/dynamic-link-offset)
+ (else #f)))
+
+(define (rtl:interpreter-register->offset locative)
+ (or (rtl:interpreter-register? locative)
+ (error "Unknown interpreter register:" locative)))
+
+(define (rtl:constant-cost expression)
+ ;; XXX Justify this by reference to cycle counts, &c. This really
+ ;; depends on which instruction we're talking about -- sometimes
+ ;; immediates are cheaper.
+ (let ((cost:zero 0)
+ (cost:imm16 1) ;MOVZ/MOVN
+ (cost:imm32 2) ;MOVZ/MOVN + 1*MOVK
+ (cost:imm48 3) ;MOVZ/MOVN + 2*MOVK
+ (cost:imm64 4) ;MOVZ/MOVN + 3*MOVK
+ (cost:adr 1)
+ (cost:ldr 10)
+ (cost:bl 2))
+ (define (immediate-cost immediate)
+ (cond ((zero? immediate)
+ cost:zero)
+ ((or (fits-in-unsigned-16? immediate)
+ (fits-in-unsigned-16? (- immediate)))
+ cost:imm16)
+ ((or (fits-in-unsigned-32? immediate)
+ (fits-in-unsigned-32? (- immediate)))
+ cost:imm32)
+ ((or (fits-in-unsigned-48? immediate)
+ (fits-in-unsigned-48? (- immediate)))
+ cost:imm48)
+ (else
+ cost:imm64)))
+ (define (tagged-immediate-cost tag datum)
+ (immediate-cost (make-non-pointer-literal tag datum)))
+ (define (load-pc-relative-address-cost)
+ cost:adr)
+ (define (load-pc-relative-cost)
+ (+ (load-pc-relative-address-cost) cost:ldr))
+ (define (branch-and-link-cost)
+ cost:bl)
+ (define (offset-cost base offset scale)
+ scale
+ (let ((base-cost (rtl:expression-cost base)))
+ (and base-cost
+ (+ base-cost
+ (if (rtl:machine-constant? offset)
+ (let ((offset
+ (abs
+ (* scale (rtl:machine-constant-value offset)))))
+ (cond ((or (fits-in-unsigned-12? (abs offset))
+ (and (zero?
+ (remainder (abs offset) (expt 2 12)))
+ (fits-in-unsigned-12?
+ (quotient (abs offset) (expt 2 12)))))
+ cost:add)
+ (else
+ (+ (immediate-cost offset)
+ cost:add))))
+ cost:add)))))
+ (case (rtl:expression-type expression)
+ ((MACHINE-CONSTANT)
+ (immediate-cost (rtl:machine-constant-value expression)))
+ ((CONSTANT)
+ (let ((value (rtl:constant-value expression)))
+ (if (non-pointer-object? value)
+ (immediate-cost (non-pointer->literal value))
+ (load-pc-relative-cost))))
+ ((ENTRY:PROCEDURE)
+ (load-pc-relative-address-cost))
+ ((ENTRY:CONTINUATION)
+ (branch-and-link-cost))
+ ((VARIABLE-CACHE ASSIGNMENT-CACHE)
+ (load-pc-relative-cost))
+ ((OFFSET-ADDRESS)
+ (offset-cost (rtl:offset-address-base expression)
+ (rtl:offset-address-offset expression)
+ address-units-per-object))
+ ((BYTE-OFFSET-ADDRESS)
+ (offset-cost (rtl:byte-offset-address-base expression)
+ (rtl:byte-offset-address-offset expression)
+ 1))
+ ((FLOAT-OFFSET-ADDRESS)
+ (offset-cost (rtl:float-offset-address-base expression)
+ (rtl:float-offset-address-offset expression)
+ address-units-per-float))
+ ((CONS-POINTER)
+ (let ((type (rtl:cons-pointer-type expression))
+ (datum (rtl:cons-pointer-datum expression)))
+ (and (rtl:machine-constant? type)
+ (rtl:machine-constant? datum)
+ (let ((type (rtl:machine-constant-value type))
+ (datum (rtl:machine-constant-value datum)))
+ (tagged-immediate-cost type datum)))))
+ (else #f))))
+
+(define compiler:open-code-floating-point-arithmetic?
+ ;; XXX not yet
+ #f)
+
+(define compiler:primitives-with-no-open-coding
+ ;; XXX Should really make this a whitelist, not a blacklist.
+ '(
+ &/ ;nobody open-codes this
+ DIVIDE-FIXNUM ;nobody open-codes this
+ FIXNUM-LSH ;open-coding not useful without constant operands
+ FLOATING-VECTOR-CONS;nobody open-codes this
+ FLONUM-ABS ;no flonum arithmetic yet
+ FLONUM-ACOS ;not useful to open-code hairy math
+ FLONUM-ADD ;no flonum arithmetic yet
+ FLONUM-ASIN ;not useful to open-code hairy math
+ FLONUM-ATAN ;not useful to open-code hairy math
+ FLONUM-ATAN2 ;not useful to open-code hairy math
+ FLONUM-CEILING ;no flonum arithmetic yet
+ FLONUM-COS ;not useful to open-code hairy math
+ FLONUM-DIVIDE ;no flonum arithmetic yet
+ FLONUM-EXP ;not useful to open-code hairy math
+ FLONUM-EXPM1 ;not useful to open-code hairy math
+ FLONUM-FLOOR ;no flonum arithmetic yet
+ FLONUM-LOG ;not useful to open-code hairy math
+ FLONUM-LOG1P ;not useful to open-code hairy math
+ FLONUM-MULTIPLY ;no flonum arithmetic yet
+ FLONUM-NEGATE ;no flonum arithmetic yet
+ FLONUM-ROUND ;no flonum arithmetic yet
+ FLONUM-SIN ;not useful to open-code hairy math
+ FLONUM-SQRT ;no flonum arithmetic yet
+ FLONUM-SUBTRACT ;no flonum arithmetic yet
+ FLONUM-TAN ;not useful to open-code hairy math
+ FLONUM-TRUNCATE ;no flonum arithmetic yet
+ GCD-FIXNUM ;nobody open-codes this
+ VECTOR-CONS ;nobody open-codes this
+ ))
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 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") "AArch64")))
+ (set! (access compiler:compress-top-level? (->environment '(compiler))) #t)
+ value)
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 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 AArch64: Byte Order
+;;; package: (compiler)
+
+(declare (usual-integrations))
+\f
+(define-integrable endianness 'BIG)
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 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 AArch64: Byte Order
+;;; package: (compiler)
+
+(declare (usual-integrations))
+\f
+(define-integrable endianness 'LITTLE)
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 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. AArch64 version.
+;;; package: (compiler rtl-generator)
+
+(declare (usual-integrations))
+\f
+(define (define-special-primitive-handler name handler)
+ (let ((primitive (make-primitive-procedure name true)))
+ (let ((entry (assq primitive special-primitive-handlers)))
+ (if entry
+ (set-cdr! entry handler)
+ (set! special-primitive-handlers
+ (cons (cons primitive handler)
+ special-primitive-handlers)))))
+ name)
+
+(define (special-primitive-handler primitive)
+ (let ((entry (assq primitive special-primitive-handlers)))
+ (and entry
+ (cdr entry))))
+
+(define special-primitive-handlers
+ '())
+
+(define (define-special-primitive/standard primitive)
+ (define-special-primitive-handler primitive
+ rtl:make-invocation:special-primitive))
+
+(define-special-primitive/standard '&+)
+(define-special-primitive/standard '&-)
+(define-special-primitive/standard '&*)
+(define-special-primitive/standard '&/)
+(define-special-primitive/standard '&=)
+(define-special-primitive/standard '&<)
+(define-special-primitive/standard '&>)
+(define-special-primitive/standard '1+)
+(define-special-primitive/standard '-1+)
+(define-special-primitive/standard 'zero?)
+(define-special-primitive/standard 'positive?)
+(define-special-primitive/standard 'negative?)
+(define-special-primitive/standard 'quotient)
+(define-special-primitive/standard 'remainder)
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; LAP Generation Rules: Data Transfers.
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Register Assignments
+
+(assert (zero? (remainder address-units-per-object 4)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
+ (assign-register->register target source))
+
+;;;; Tagging and detagging
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (REGISTER (? type))
+ (REGISTER (? datum))))
+ (cond ((let ((type (register-known-value type)))
+ (and type (zero? type)))
+ (assign-register->register target datum))
+ ((register-copy-if-available datum 'GENERAL target)
+ => (lambda (get-target!)
+ ;; If we already have a suitable register for the target,
+ ;; use bit field insertion to set the type.
+ (let* ((type (standard-source! type))
+ (target (get-target!))
+ (lsb scheme-datum-width)
+ (width scheme-type-width))
+ (LAP (BFI X ,target ,type (&U ,lsb) (&U ,width))))))
+ (else
+ ;; Otherwise, no advantage to using bit field insertion since
+ ;; we'd need two instructions anyway, so just shift and or.
+ (standard-binary target type datum
+ (lambda (target type datum)
+ (LAP (LSL X ,target ,type (&U ,scheme-datum-width))
+ (ORR X ,target ,target ,datum)))))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (REGISTER (? datum))))
+ (standard-unary target datum
+ (lambda (target datum)
+ (affix-type target type datum))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
+ (standard-unary target source object->type))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
+ (standard-unary target source object->datum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
+ (standard-unary target source object->address))
+\f
+;;;; Loading constants
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? n)))
+ (load-signed-immediate (standard-target! target) n))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (CONSTANT (? object)))
+ (load-constant (standard-target! target) object))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (load-tagged-immediate (standard-target! target) type datum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label)))
+ (load-pc-relative-address
+ (standard-target! target)
+ (rtl-procedure/external-label (label->object label))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label)))
+ (rtl-target:=machine-register! target regnum:link-register)
+ (let ((linked (generate-label 'LINKED)))
+ (LAP (BL (@PCR ,linked))
+ (B (@PCR ,label))
+ (LABEL ,linked))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
+ (load-pc-relative (standard-target! target) (free-reference-label name)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name)))
+ (load-pc-relative (standard-target! target) (free-assignment-label name)))
+\f
+;;;; Address arithmetic
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? base))
+ (REGISTER (? offset))))
+ (load-indexed-address target base offset 1))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? base))
+ (MACHINE-CONSTANT (? offset))))
+ (load-displaced-address target base offset 1))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OFFSET-ADDRESS (REGISTER (? base))
+ (REGISTER (? offset))))
+ (load-indexed-address target base offset address-units-per-object))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OFFSET-ADDRESS (REGISTER (? base))
+ (MACHINE-CONSTANT (? offset))))
+ (load-displaced-address target base offset address-units-per-object))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLOAT-OFFSET-ADDRESS (REGISTER (? base))
+ (REGISTER (? offset))))
+ (load-indexed-address target base offset address-units-per-float))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLOAT-OFFSET-ADDRESS (REGISTER (? base))
+ (MACHINE-CONSTANT (? offset))))
+ (load-displaced-address target base offset address-units-per-float))
+\f
+;;;; Loads and stores
+
+;;; Load indexed
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OFFSET (REGISTER (? base)) (REGISTER (? offset))))
+ (QUALIFIER (not (= offset rsp)))
+ (standard-binary target base offset
+ (lambda (target base offset)
+ (LAP (LDR X ,target (+ ,base (LSL ,offset 3)))))))
+
+;;; Store indexed
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? base)) (REGISTER (? offset)))
+ (? source register-expression))
+ (QUALIFIER (not (= offset rsp)))
+ (standard-ternary-effect base offset source
+ (lambda (base offset source)
+ (LAP (STR X ,source (+ ,base (LSL ,offset 3)))))))
+
+;;; Load with displacement
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset))))
+ (QUALIFIER (fits-in-unsigned-12? offset))
+ (standard-unary target base
+ (lambda (target base)
+ (LAP (LDR X ,target (+ ,base (&U (* 8 ,offset))))))))
+
+;;; Store with displacement
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
+ (? source register-expression))
+ (QUALIFIER (fits-in-unsigned-12? offset))
+ (standard-binary-effect base source
+ (lambda (base source)
+ (LAP (STR X ,source (+ ,base (&U (* 8 ,offset))))))))
+\f
+;;;; Loads and stores with pre/post-increment
+
+;;; Load with pre-increment: *++x
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (PRE-INCREMENT (REGISTER (? sp)) (? offset)))
+ (QUALIFIER (<= -64 (* offset (quotient address-units-per-object 4)) 63))
+ (standard-unary target sp
+ (lambda (target sp)
+ (LAP (LDR X ,target (PRE+ ,sp (& ,offset)))))))
+
+;;; Load with post-increment: *x++
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER (? sp)) (? offset)))
+ (QUALIFIER (<= -64 (* offset (quotient address-units-per-object 4)) 63))
+ (standard-unary target sp
+ (lambda (target sp)
+ (LAP (LDR X ,target (POST+ ,sp (& ,offset)))))))
+
+;;; Store with pre-increment: *++x = y
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER (? sp)) (? offset))
+ (? source register-expression))
+ (QUALIFIER (<= -64 (* offset (quotient address-units-per-object 4)) 63))
+ (standard-binary-effect sp source
+ (lambda (sp source)
+ (let ((offset (* offset (quotient address-units-per-object 4))))
+ (LAP (STR X ,source (PRE+ ,sp (& ,offset))))))))
+
+;;; Store with post-increment: *x++ = y
+
+(define-rule statement
+ (ASSIGN (POST-INCREMENT (REGISTER (? sp)) (? offset))
+ (? source register-expression))
+ (QUALIFIER (<= -64 (* offset (quotient address-units-per-object 4)) 63))
+ (standard-binary-effect sp source
+ (lambda (sp source)
+ (let ((offset (* offset (quotient address-units-per-object 4))))
+ (LAP (STR X ,source (POST+ ,sp (& ,offset))))))))
+\f
+;;;; Byte access
+
+;;; Detagging a character -- no ASCII->CHAR because that's just
+;;; CONS-NON-POINTER = CONS-POINTER.
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (CHAR->ASCII (REGISTER (? source))))
+ (standard-unary target source
+ (lambda (target source)
+ (LAP (AND X ,target ,source (&U #xff))))))
+
+;;; Load byte indexed
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET (REGISTER (? base)) (REGISTER (? offset))))
+ (QUALIFIER (not (= offset rsp)))
+ (standard-binary target base offset
+ (lambda (target base offset)
+ (LAP (LDR B ,target (+ ,base ,offset))))))
+
+;;; Store byte indexed
+
+(define-rule statement
+ (ASSIGN (BYTE-OFFSET (REGISTER (? base)) (REGISTER (? offset)))
+ (? source register-expression))
+ (standard-ternary-effect base offset source
+ (lambda (base offset source)
+ (LAP (STR B ,source (+ ,base ,offset))))))
+
+;;; Detag and store byte indexed
+
+(define-rule statement
+ (ASSIGN (BYTE-OFFSET (REGISTER (? base)) (REGISTER (? offset)))
+ (CHAR->ASCII (? source register-expression)))
+ (standard-ternary-effect base offset source
+ (lambda (base offset source)
+ (LAP (STR B ,source (+ ,base ,offset))))))
+
+;;; Load byte with displacement
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET (REGISTER (? base))
+ (MACHINE-CONSTANT (? offset))))
+ (QUALIFIER (not (= offset rsp)))
+ (standard-binary target base offset
+ (lambda (target base offset)
+ (LAP (LDR B ,target (+ ,base (&U ,offset)))))))
+
+;;; Store byte with displacement
+
+(define-rule statement
+ (ASSIGN (BYTE-OFFSET (REGISTER (? base))
+ (MACHINE-CONSTANT (? offset)))
+ (? source register-expression))
+ (QUALIFIER (not (= offset rsp)))
+ (standard-binary-effect source base
+ (lambda (source base)
+ (LAP (STR B ,target (+ ,base (&U ,offset)))))))
+
+;;; Detag and store byte with displacement
+
+(define-rule statement
+ (ASSIGN (BYTE-OFFSET (REGISTER (? base))
+ (MACHINE-CONSTANT (? offset)))
+ (CHAR->ASCII (? source register-expression)))
+ (QUALIFIER (not (= offset rsp)))
+ (standard-binary-effect source base
+ (lambda (source base)
+ (LAP (STR B ,target (+ ,base (&U ,offset)))))))
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; LAP Generation Rules: Predicates
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+(define-rule predicate
+ (EQ-TEST (REGISTER (? source1)) (REGISTER (? source2)))
+ (set-equal-branches!)
+ (standard-binary-effect source1 source2
+ (lambda (source1 source2)
+ (LAP (CMP X ,source1 ,source2)))))
+
+(define-rule predicate
+ (EQ-TEST (REGISTER (? source)) (MACHINE-CONSTANT (? immediate)))
+ (eq-test/register*immediate! (standard-source! source) immediate))
+
+(define-rule predicate
+ (EQ-TEST (MACHINE-CONSTANT (? immediate)) (REGISTER (? source)))
+ (eq-test/register*immediate! (standard-source! source) immediate))
+
+(define-rule predicate
+ (EQ-TEST (REGISTER (? source))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (eq-test/register*tagged-immediate! (standard-source! source) type datum))
+
+(define-rule predicate
+ (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum)))
+ (REGISTER (? source)))
+ (eq-test/register*tagged-immediate! (standard-source! source) type datum))
+
+(define-rule predicate
+ (EQ-TEST (REGISTER (? source)) (CONSTANT (? constant)))
+ (QUALIFIER
+ ;; Worth it only if we can confirm it's zero.
+ (and (non-pointer-object? constant)
+ (= 0 (non-pointer->literal constant))))
+ (zero-test! (standard-source! source)))
+
+(define-rule predicate
+ (EQ-TEST (CONSTANT (? constant)) (REGISTER (? source)))
+ (QUALIFIER
+ ;; Worth it only if we can confirm it's zero.
+ (and (non-pointer-object? constant)
+ (= 0 (non-pointer->literal constant))))
+ (zero-test! (standard-source! source)))
+
+(define-rule predicate
+ (TYPE-TEST (REGISTER (? register)) (? type))
+ (immediate-equal-test! (standard-source! register) type))
+
+;; Test tag and sign in one swell foop.
+
+(define-rule predicate
+ (PRED-1-ARG INDEX-FIXNUM? (REGISTER (? register)))
+ (let ((temp (standard-move-to-temporary! register)))
+ (set-equal-branches!)
+ (LAP (LSR X ,temp (&U ,(- scheme-datum-width 1)))
+ (CMP X ,temp (&U ,(* 2 type-code:fixnum))))))
+
+(define (set-equal-branches!)
+ (set-current-branches! (lambda (label) (LAP (B.EQ (@PCR ,label))))
+ (lambda (label) (LAP (B.NE (@PCR ,label))))))
+
+(define (set-not-equal-branches!)
+ (set-current-branches! (lambda (label) (LAP (B.NE (@PCR ,label))))
+ (lambda (label) (LAP (B.EQ (@PCR ,label))))))
+
+(define (set-equal-zero-branches! source)
+ (set-current-branches! (lambda (label) (LAP (CBZ ,source (@PCR ,label))))
+ (lambda (label) (LAP (CBNZ ,source (@PCR ,label))))))
+
+(define (zero-test! register)
+ (set-equal-zero-branches! register)
+ (LAP))
+
+(define (eq-test/register*tagged-immediate! register type datum)
+ (eq-test/register*immediate! register (make-non-pointer-literal type datum)))
+
+(define (eq-test/register*immediate! register immediate)
+ (if (= immediate 0)
+ (zero-test! register)
+ (begin
+ (set-equal-branches!)
+ (cmp-immediate register immediate))))
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; LAP Generation Rules: Invocations and Entries
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Invocations
+
+(define-rule statement
+ (POP-RETURN)
+ (let* ((checks (get-interrupt-checks))
+ (prefix (clear-map!))
+ (suffix
+ (if (pair? checks)
+ (pop-return/interrupt-check)
+ (pop-return))))
+ (LAP ,@prefix
+ ,@suffix)))
+
+(define (pop-return)
+ (LAP ,@(pop rlr)
+ ,@(object->address rlr rlr)
+ (RET)))
+
+(define (pop-return/interrupt-check)
+ (share-instruction-sequence! 'POP-RETURN
+ (lambda (shared-label) (LAP (B (@PCR ,shared-label))))
+ (lambda (shared-label)
+ (let ((interrupt-label (generate-label 'INTERRUPT)))
+ (LAP (LABEL ,shared-label)
+ ,@(interrupt-check '(HEAP) label)
+ ,@(pop-return)
+ (LABEL ,interrupt-label)
+ ,@(invoke-hook entry:compiler-interrupt-continuation-2))))))
+
+(define-rule statement
+ (INVOCATION:APPLY (? frame-size) (? continuation))
+ continuation
+ (let* ((prefix (clear-map!))
+ (setup (apply-setup frame-size)))
+ (LAP ,@prefix
+ ,@(pop ,regnum:apply-target)
+ ,@setup
+ (BR ,regnum:apply-pc))))
+
+(define (apply-setup frame-size)
+ (case frame-size
+ ((1) (invoke-hook/subroutine entry:compiler-apply-setup-size-1))
+ ((2) (invoke-hook/subroutine entry:compiler-apply-setup-size-2))
+ ((3) (invoke-hook/subroutine entry:compiler-apply-setup-size-3))
+ ((4) (invoke-hook/subroutine entry:compiler-apply-setup-size-4))
+ ((5) (invoke-hook/subroutine entry:compiler-apply-setup-size-5))
+ ((6) (invoke-hook/subroutine entry:compiler-apply-setup-size-6))
+ ((7) (invoke-hook/subroutine entry:compiler-apply-setup-size-7))
+ ((8) (invoke-hook/subroutine entry:compiler-apply-setup-size-8))
+ (else
+ (LAP ,@(load-unsigned-immediate regnum:utility-arg0 frame-size)
+ ,@(invoke-hook/subroutine entry:compiler-apply-setup)))))
+\f
+(define-rule statement
+ (INVOCATION:JUMP (? frame-size) (? continuation) (? label))
+ frame-size continuation
+ (expect-no-exit-interrupt-checks)
+ (LAP ,@(clear-map!)
+ (B (@PCR ,label))))
+
+(define (entry->pc pc entry)
+ ;; XXX Would be nice to skip the SUB, but LDR doesn't have a signed
+ ;; offset without pre/post-increment.
+ (LAP (SUB X ,pc ,entry (&U 8))
+ (LDR X ,pc ,pc)
+ (ADD X ,pc ,pc ,entry)))
+
+(define-rule statement
+ (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation))
+ frame-size continuation
+ (expect-no-exit-interrupt-checks)
+ ;; Tagged entry is on top of stack.
+ (LAP ,@(clear-map!)
+ ,@(pop regnum:apply-target)
+ ,@(object->address regnum:apply-target regnum:apply-target)
+ ,@(entry->pc regnum:apply-pc regnum:apply-target)
+ (BR ,regnum:apply-pc)))
+
+(define-rule statement
+ (INVOCATION:LEXPR (? number-pushed) (? continuation) (? labe))
+ (LAP ,@(clear-map!)
+ ,@(load-pc-relative-address regnum:utility-arg0 label)
+ ,@(load-unsigned-immediate regnum:utility-arg1 number-pushed)
+ ,@(invoke-interface code:compiler-lexpr-apply)))
+
+(define-rule statement
+ (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation) (? labe))
+ (LAP ,@(clear-map!)
+ ,@(pop regnum:utility-arg0)
+ ,@(object->address regnum:utility-arg0 regnum:utility-arg0)
+ ,@(load-unsigned-immediate regnum:utility-arg1 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!)
+ (B (@PCRO ,(free-uuo-link-label name frame-size)
+ ,(uuo-link-label-offset)))))
+
+(define-rule statement
+ (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
+ continuation
+ (expect-no-exit-interrupt-checks)
+ (LAP ,@(clear-map!)
+ (B (@PCRO ,(global-uuo-link-label name frame-size)
+ ,(uuo-link-label-offset)))))
+\f
+(define-rule statement
+ (INVOCATION:CACHE-REFERENCE (? frame-size) (? continuation) (? extension))
+ (error "Unsupported RTL:"
+ `(INVOCATION:CACHE-REFERENCE ,frame-size ,continuation ,extension)))
+
+(define-rule statement
+ (INVOCATION:LOOKUP (? frame-size) (? continuation) (? extension))
+ (error "Unsupported RTL:"
+ `(INVOCATION:CACHE-REFERENCE ,frame-size ,continuation ,extension)))
+
+(define-rule statement
+ (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
+ continuation
+ (cond ((eq? primitive compiled-error-procedure)
+ (generate/compiled-error frame-size))
+ ;; ((eq? primitive (ucode-primitive set-interrupt-enables!)) ...)
+ ;; ((eq? primitive (ucode-primitive with-interrupt-mask)) ...)
+ ;; ((eq? primitive (ucode-primitive with-interrupts-reduced)) ...)
+ ;; ((eq? primitive (ucode-primitive with-stack-marker)) ...)
+ (else
+ (generate/generic-primitive frame-size primitive))))
+
+(define (generate/compiled-error frame-size)
+ (let* ((prefix (clear-map!))
+ (arg0 (load-unsigned-immediate regnum:utility-arg0 frame-size))
+ (invocation (invoke-hook entry:compiler-error)))
+ (LAP ,@prefix
+ ,@arg0
+ ,@invocation)))
+
+(define (generate/generic-primitive frame-size primitive)
+ (let* ((prefix (clear-map!))
+ (arg0 (load-constant primitive regnum:utility-arg0)))
+ (LAP ,@prefix
+ ,@arg0
+ ,@(let ((arity (primitive-procedure-arity primitive)))
+ (cond ((not (negative? arity))
+ (generate/primitive-apply))
+ ((= arity -1)
+ (generate/primitive-lexpr-apply frame-size))
+ (else
+ (generate/generic-apply frame-size)))))))
+
+(define (generate/primitive-apply)
+ (invoke-hook entry:compiler-primitive-apply))
+
+(define (generate/primitive-lexpr-apply frame-size)
+ (let* ((load-nargs
+ (load-unsigned-immediate regnum:scratch-0 (- frame-size 1)))
+ (invocation (invoke-hook entry:compiler-primitive-lexpr-apply)))
+ (LAP ,@load-nargs
+ (STR X ,regnum:scratch-0 ,reg:lexpr-primitive-apply)
+ ,@invocation)))
+
+(define (generate/generic-apply frame-size)
+ (let* ((arg1 (load-unsigned-immediate regnum:utility-arg1 frame-size))
+ (invocation (invoke-interface code:compiler-apply)))
+ (LAP ,@arg1
+ ,@invocation)))
+\f
+(let-syntax
+ ((define-primitive-invocation
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form)))
+ `(define-rule statement
+ (INVOCATION:SPECIAL-PRIMITIVE
+ (? frame-size)
+ (? continuation)
+ ,(make-primitive-procedure name #t))
+ frame-size continuation
+ (expect-no-exit-interrupt-checks)
+ #|
+ (special-primitive-invocation
+ ,(close-syntax (symbol 'CODE:COMPILER- name)
+ environment))
+ |#
+ (optimized-primitive-invocation
+ ,(close-syntax (symbol '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)
+ (let* ((prefix (clear-map!))
+ (invocation (invoke-interface code)))
+ (LAP ,@prefix
+ ,@invocation)))
+
+(define (optimized-primitive-invocation entry)
+ (let* ((prefix (clear-map!))
+ (invocation (invoke-hook entry)))
+ (LAP ,@prefix
+ ,@invocation)))
+\f
+;;;; Invocation Prefixes
+
+;;; (INVOCATION-PREFIX:MOVE-FRAME-UP <nwords> <address>)
+;;;
+;;; Pop <nwords> off the stack, set the stack to <address>, and
+;;; push them back on the stack.
+;;;
+;;; (INVOCATION-PREFIX:DYNAMIC-LINK <nwords> <address> <dynamic-link>)
+;;;
+;;; Pop <nwords> off the stack, set the stack pointer to the larger
+;;; (i.e., more items on the stack, or lower addresses) of
+;;; <address> or <dynamic-link>, and push them back on the stack.
+
+(define-rule statement
+ (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER (? address)))
+ (let ((address (standard-source! address)))
+ (assert (not (= register regnum:stack-pointer)))
+ (generate/move-frame-up frame-size address)))
+
+(define-rule statement
+ (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
+ (REGISTER (? address))
+ (REGISTER (? dynamic-link)))
+ ;; Could try to get a temporary out of the dynamic link, but we have
+ ;; lots of temporaries and this is probably the dedicated dynamic
+ ;; link machine register anyway.
+ (let* ((dynamic-link (standard-source! dynamic-link))
+ (address (standard-move-to-temporary! address)))
+ (assert (not (= address regnum:stack-pointer)))
+ (assert (not (= dynamic-link regnum:stack-pointer)))
+ (LAP (CMP X ,address ,dynamic-link)
+ (CSEL.GT ,address ,address ,dynamic-link)
+ ,@(generate/move-frame-up frame-size address))))
+
+(define (generate/move-frame-up frame-size address)
+ (assert (not (= register regnum:stack-pointer)))
+ (if (<= frame-size 6) ;Covers vast majority of cases.
+ (generate/move-frame-up/unrolled frame-size register)
+ (generate/move-frame-up/loop frame-size register)))
+\f
+(define (generate/move-frame-up/loop frame-size address)
+ (assert (not (= register regnum:stack-pointer)))
+ (assert (>= frame-size 2))
+ (assert (fits-in-unsigned-12? (* 8 frame-size))) ;XXX
+ (assert (= 8 address-units-per-object))
+ (let* ((temp1 (allocate-temporary-register! 'GENERAL))
+ (temp2 (allocate-temporary-register! 'GENERAL))
+ (index (allocate-temporary-register! 'GENERAL))
+ (label (generate-label 'MOVE-LOOP))
+ ;; Unroll an odd element if there is one; then do an even
+ ;; number of iterations.
+ (loop-count (- frame-size (remainder frame-size 2))))
+ (assert (= loop-count (* (quotient frame-size 2) 2)))
+ (LAP (ADD X ,regnum:stack-pointer ,regnum:stack-pointer
+ (&U ,(* 8 frame-size)))
+ ,@(if (odd? frame-size)
+ (LAP (LDR X ,temp (PRE- ,regnum:stack-pointer (&U 8)))
+ (STR X ,temp (PRE- ,address (&U 8))))
+ (LAP))
+ ,@(load-unsigned-immediate index loop-count)
+ (LABEL ,label)
+ (SUB X ,index (&U #x10))
+ (LDRP X ,temp1 ,temp2 (PRE- ,regnum:stack-pointer (&U #x10)))
+ (STRP X ,temp1 ,temp2 (PRE- ,address (&U #x10)))
+ (CBNZ X ,index (@PCR ,label))
+ ,@(register->register-transfer address regnum:stack-pointer))))
+
+(define (generate/move-frame-up/unrolled frame-size address)
+ (assert (not (= address regnum:stack-pointer)))
+ (assert (< frame-size 24)) ;Only 24 temporaries, incl. address.
+ (assert (= 8 address-units-per-object))
+ (let ((temps
+ ;; Allocate in order to get reproducible results.
+ (let loop ((n frame-size) (temps '()))
+ (if (zero? n)
+ temps
+ (let ((temp (allocate-temporary-register! 'GENERAL)))
+ (loop (- n 1) (cons temp temps)))))))
+ (LAP ,@(let loop ((temps temps))
+ ;; (pop2 r1 r2) (pop2 r3 r4) (pop r5)
+ (if (pair? temps)
+ (if (pair (cdr? temps))
+ (LAP ,@(pop2 (car temps) (cadr temps))
+ ,@(loop (cddr temps)))
+ (pop (car temps)))
+ (LAP)))
+ ,@(register->register-transfer address regnum:stack-pointer)
+ ,@(let loop ((temps temps))
+ ;; (push r5) (push r3 r4) (push r1 r2)
+ (if (pair? temps)
+ (if (pair? (cdr temps))
+ (LAP ,@(loop (cddr temps))
+ ,@(push2 (car temps) (cadr temps)))
+ (push (car temps)))
+ (LAP))))))
+\f
+;;;; External Labels
+
+;;; Entry point types
+
+(define (make-procedure-code-word min max)
+ ;; The "min" byte must be less than #x80; the "max" byte may not
+ ;; equal #x80 but can take on any other value.
+ (if (or (negative? min) (>= min #x80))
+ (error "MAKE-PROCEDURE-CODE-WORD: minimum out of range" min))
+ (if (>= (abs max) #x80)
+ (error "MAKE-PROCEDURE-CODE-WORD: maximum out of range" max))
+ (make-code-word min (if (negative? max) (+ #x100 max) max)))
+
+(define internal-entry-code-word
+ (make-code-word #xff #xfe))
+
+(define internal-continuation-code-word
+ (make-code-word #xff #xfc))
+
+(define (frame-size->code-word offset default)
+ (cond ((not offset)
+ default)
+ ((< offset #x2000)
+ ;; This uses up through (#xff #xdf).
+ (let ((qr (integer-divide offset #x80)))
+ (make-code-word (+ #x80 (integer-divide-remainder qr))
+ (+ #x80 (integer-divide-quotient qr)))))
+ (else
+ (error "Unable to encode continuation offset"
+ offset))))
+
+(define (continuation-code-word label)
+ (frame-size->code-word
+ (if label
+ (rtl-continuation/next-continuation-offset (label->object label))
+ 0)
+ internal-continuation-code-word))
+
+(define (internal-procedure-code-word rtl-proc)
+ (frame-size->code-word
+ (rtl-procedure/next-continuation-offset rtl-proc)
+ internal-entry-code-word))
+\f
+;;;; Procedure headers
+
+;;; The following calls MUST appear as the first thing at the entry
+;;; point of a procedure. They assume that the register map is clear
+;;; and that no register contains anything of value.
+;;;
+;;; The only reason that this is true is that no register is live
+;;; across calls. If that were not true, then we would have to save
+;;; any such registers on the stack so that they would be GC'ed
+;;; appropriately.
+;;;
+;;; The only exception is the dynamic link register, handled
+;;; specially. Procedures that require a dynamic link use a different
+;;; interrupt handler that saves and restores the dynamic link
+;;; register.
+
+(define (interrupt-check checks label)
+ (LAP ,@(if (or (memq 'INTERRUPT checks) (memq 'HEAP checks))
+ (LAP (LDR X ,regnum:scratch-0 ,reg:memtop)
+ (CMP X ,regnum:free-pointer ,regnum:scratch-0)
+ (B.GE (@PCR ,label)))
+ (LAP))
+ ,@(if (memq 'STACK checks)
+ (LAP (LDR X ,regnum:scratch-0 ,reg:stack-guard)
+ (CMP X ,regnum:stack-pointer ,regnum:scratch-0)
+ (B.LT (@PCR ,label)))
+ (LAP))))
+
+(define (simple-procedure-header code-word label entry)
+ (let ((checks (get-entry-interrupt-checks))
+ (interrupt-label (generate-label 'INTERRUPT)))
+ ;; Put the interrupt check branch target after the branch so that
+ ;; it is a forward branch, which CPUs will predict not taken by
+ ;; default, in the absence of dynamic branch prediction profile
+ ;; data.
+ (if (pair? checks)
+ (add-end-of-block-code!
+ (lambda ()
+ (LAP (LABEL ,interrupt-label)
+ ,@(invoke-hook/reentry entry label)))))
+ (LAP ,@(make-external-label code-word label)
+ ,@(interrupt-check checks interrupt-label))))
+\f
+(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))
+ (error "IC procedures not supported:"
+ `(IC-PROCEDURE-HEADER ,internal-label)))
+
+(define-rule statement
+ (OPEN-PROCEDURE-HEADER (? internal-label))
+ (let ((rtl-proc (label->object internal-label)))
+ (LAP (EQUATE ,(rtl-procedure/external-label rtl-proc) ,internal-label)
+ ,@(simple-procedure-header (internal-procedure-code-word rtl-proc)
+ internal-label
+ (if (rtl-procedure/dynamic-link? rtl-proc)
+ entry:compiler-interrupt-dlink
+ entry:compiler-interrupt-procedure)))))
+
+(define-rule statement
+ (PROCEDURE-HEADER (? internal-label) (? min) (? max))
+ (LAP (EQUATE ,(rtl-procedure/external-label (label->object internal-label))
+ ,internal-label)
+ ,@(simple-procedure-header (make-procedure-code-word min max)
+ internal-label
+ entry:compiler-interrupt-procedure)))
+\f
+;;;; Closures
+
+(define-rule statement
+ (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
+ entry ;ignore
+ (let* ((rtl-proc (label->object internal-label))
+ (external-label (rtl-procedure/external-label rtl-proc))
+ (checks (get-entry-interrupt-checks))
+ (type type-code:compiled-entry))
+ (define (label+adjustment)
+ (LAP ,@(make-external-label internal-entry-code-word external-label)
+ ;; regnum:apply-target holds the untagged entry address.
+ ;; Push and tag it.
+ ,@(affix-type regnum:apply-target type regnum:apply-target)
+ ,@(push regnum:apply-target)
+ (LABEL ,internal-label)))
+ (cond ((zero? nentries)
+ (LAP (EQUATE ,external-label ,internal-label)
+ ,@(simple-procedure-header
+ (internal-procedure-code-word rtl-proc)
+ internal-label
+ entry:compiler-interrupt-procedure)))
+ ((pair? checks)
+ (LAP ,@(label+adjustment)
+ ,@(interrupt-check checks (closure-interrupt-label))))
+ (else
+ (label+adjustment)))))
+
+(define (closure-interrupt-label)
+ (or (block-association 'INTERRUPT-CLOSURE)
+ (let ((label (generate-label 'INTERRUPT-CLOSURE)))
+ (add-end-of-block-code!
+ (lambda ()
+ (LAP (LABEL ,label)
+ ,@(invoke-hook entry:compiler-interrupt-closure))))
+ (block-associate! 'INTERRUPT-CLOSURE label)
+ label)))
+
+(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)
+ ;; Allocate a vector, initialized with garbage -- caller must
+ ;; initialize it before we can GC.
+ (let* ((target (standard-target! target))
+ (Free regnum:free-pointer))
+ (LAP ,@(load-tagged-immediate type-code:manifest-vector size target)
+ (STR X ,target ,Free)
+ ,@(register->register-transfer Free target)
+ ,@(add-immediate Free Free
+ (* address-units-per-object (+ 1 size))))))
+ ((1)
+ (let ((entry (vector-ref entries 0)))
+ (generate/cons-closure target
+ (car entry) (cadr entry) (caddr entry)
+ size)))
+ (else
+ (generate/cons-multiclosure target nentries size
+ (vector->list entries)))))
+\f
+(define (generate/cons-closure target label min max size)
+ (let* ((target (standard-target! target))
+ (temp (allocate-temporary-register! 'GENERAL))
+ (manifest-type type-code:closure-manifest)
+ (manifest-size (closure-manifest-size size))
+ (Free Free))
+ (LAP ,@(load-tagged-immediate manifest-type manifest-size temp)
+ (STR X ,temp (POST+ ,Free (& 8)))
+ ,@(generate-closure-entry label min max 1 temp)
+ ;; Free now points at the entry. Save it in target.
+ ,@(register->register-transfer Free target)
+ ;; Bump Free to point at the last component, one word before
+ ;; the next object. We do this because we need to set the
+ ;; last component here, but we do not have negative load/store
+ ;; offsets without pre/post-increment.
+ ,@(with-immediate-unsigned-12 (* 8 size)
+ (lambda (addend)
+ (LAP (ADD X ,Free ,Free ,addend))))
+ ;; Set the last component to be the relocation reference point.
+ ,@(affix-type temp type-code:compiled-entry target)
+ (STR X ,temp (POST+ ,Free (& 8))))))
+
+(define (generate/cons-multiclosure target nentries size entries)
+ (let* ((target (standard-target! target))
+ (temp (allocate-temporary-register! 'GENERAL))
+ (manifest-type type-code:closure-manifest)
+ (manifest-size (multiclosure-manifest-size nentries size))
+ ;; 8 for manifest, 8 for padding & format word, 8 for PC offset.
+ (offset0 #x18)
+ (Free regnum:free-pointer))
+ (define (generate-primary-entry entry)
+ (let ((label (car entry)) (min (cadr entry)) (max (caddr entry)))
+ (generate-closure-entry label nentries min max offset0 temp)))
+ (define (generate-subsidiary-entry entry n)
+ (let ((label (car entry))
+ (min (cadr entry))
+ (max (caddr entry))
+ (offset (+ offset0 (* n address-units-per-closure-entry))))
+ (generate-closure-entry label 0 min max offset temp)))
+ (define generate-subsidiary-entries entries
+ (assert (pair? entries))
+ (LAP ,@(generate-subsidiary-entry (car entries))
+ ,@(if (pair? (cdr entries))
+ (generate-subsidiary-entries (cdr entries))
+ (LAP))))
+ (LAP ,@(load-tagged-immediate manifest-type manifest-size temp)
+ (STR X ,temp (POST+ ,Free (& 8)))
+ ,@(generate-primary-entry (car entries))
+ ,@(register->register-transfer Free target)
+ ,@(generate-subsidiary-entries (cdr entries))
+ ;; Bump Free to point at the last component, one word before
+ ;; the next object. We do this because we need to set the
+ ;; last component here, but we do not have negative load/store
+ ;; offsets without pre/post-increment.
+ ,@(with-immediate-unsigned-12 (* 8 size)
+ (lambda (addend)
+ (LAP ADD X ,Free ,Free ,addend)))
+ ;; Set the last component to be the relocation reference point.
+ ,@(affix-type temp type-code:compiled-entry target)
+ (STR X ,temp (POST+ ,Free (& 8))))))
+\f
+(define (generate-closure-entry label padding min max offset temp)
+ (let* ((label* (rtl-procedure/external-label (label->object label)))
+ (code-word (make-procedure-code-word min max))
+ (Free regnum:free-pointer))
+ ;; Could avoid zeroing the padding if we don't need it, but there's
+ ;; no advantage.
+ (define (padded-word)
+ ;; padding(32) || code-word(16) || offset(16)
+ (case endianness
+ ((BIG)
+ (bitwise-ior (shift-left padding 32)
+ (bitwise-ior (shift-left code-word 16)
+ offset)))
+ ((LITTLE)
+ (bitwise-ior padding
+ (bitwise-ior (shift-left code-word 32)
+ (shift-left offset 48))))
+ (else
+ (error "Unknown endianness:" endianness))))
+ (LAP ,@(load-unsigned-immediate temp (padded-word))
+ (STR X ,temp (POST+ ,Free (& 8)))
+ ;; Set temp := label - 8.
+ (ADR X ,temp (@PCR (- ,label* 8)))
+ ;; Set temp := label - 8 - free = label - (free + 8).
+ (SUB X ,temp ,temp ,Free)
+ ;; Store the PC offset.
+ (STR X ,temp (POST+ ,Free (& 8))))))
+
+(define (closure-manifest-size size)
+ (multiclosure-manifest-size 1 size))
+
+(define (multiclosure-manifest-size nentries size)
+ ;; Each entry occupies two object-sized units.
+ (+ (* 2 nentries)
+ ;; Add one for the relocation reference point.
+ (+ size 1)))
+\f
+;;;; Entry Header
+
+(define (generate/quotation-header environment-label free-ref-label n-sections)
+ (let ((continuation-label (generate-label /LINKED)))
+ (LAP (LDR X ,r0 ,reg:environment)
+ (ADR X ,r1 (@PCR ,environment-label))
+ (STR X ,r0 ,r1)
+ (ADR X ,regnum:utility-arg0 (@PCR ,*block-label*))
+ (ADR X ,regnum:utility-arg1 (@PCR ,free-ref-label))
+ ,@(load-unsigned-immediate regnum:utility-arg2 n-sections)
+ ,@(invoke-hook/call entry:compiler-link continuation-label)
+ ,@(make-external-label (continuation-code-word #f)
+ continuation-label))))
+
+;;; XXX Why is this hand-coded assembly and not a C function?
+
+(define (generate/remote-links n-blocks vector-label nsects)
+ (if (zero? n-blocks)
+ (LAP)
+ ...))
+\f
+(define (generate/constants-block constants references assignments
+ uuo-links global-links static-vars)
+ (let ((constant-info
+ (declare-constants 0 (transmogrifly uuo-links)
+ (declare-constants 1 references
+ (declare-constants 2 assignments
+ (declare-constants 3 (transmogrifly global-links)
+ (declare-constants false
+ (map (lambda (pair)
+ (cons false (cdr pair)))
+ static-vars)
+ (declare-constants false constants
+ (cons false (LAP))))))))))
+ (let ((free-ref-label (car constant-info))
+ (constants-code (cdr constant-info))
+ (debugging-information-label (allocate-constant-label))
+ (environment-label (allocate-constant-label))
+ (n-sections
+ (+ (if (null? uuo-links) 0 1)
+ (if (null? references) 0 1)
+ (if (null? assignments) 0 1)
+ (if (null? global-links) 0 1))))
+ (values
+ (LAP ,@constants-code
+ ;; Place holder for the debugging info filename
+ (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO)
+ ;; Place holder for the load time environment if needed
+ (SCHEME-OBJECT ,environment-label
+ ,(if (null? free-ref-label) 0 'ENVIRONMENT)))
+ environment-label
+ free-ref-label
+ n-sections))))
+
+(define (declare-constants tag constants info)
+ (define (inner constants)
+ (if (null? constants)
+ (cdr info)
+ (let ((entry (car constants)))
+ (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry))
+ ,@(inner (cdr constants))))))
+ (if (and tag (not (null? constants)))
+ (let ((label (allocate-constant-label)))
+ (cons label
+ (inner
+ `((,(let ((datum (length constants)))
+ (if (> datum #xffff)
+ (error "datum too large" datum))
+ (+ (* tag #x10000) datum))
+ . ,label)
+ ,@constants))))
+ (cons (car info) (inner constants))))
+
+(define (transmogrifly variable.caches-list)
+ (append-map
+ (lambda (variable.caches)
+ (append-map (let ((variable (car variable.caches)))
+ (lambda (cache)
+ (let ((frame-size (car cache))
+ (label (cdr cache)))
+ ;; Must match UUO_LINK_SIZE in cmpintmd/aarch64.h.
+ (case endianness
+ ((BIG)
+ `((,variable . ,(allocate-constant-label))
+ (#f . ,label)
+ (#f . ,(allocate-constant-label))
+ (,frame-size . ,(allocate-constant-label))))
+ ((LITTLE)
+ `((,variable . ,(allocate-constant-label))
+ (,frame-size . ,label)
+ (#f . ,(allocate-constant-label))
+ (#f . ,(allocate-constant-label))))
+ (else
+ (error "Unknown endianness:" endianness))))))
+ (cdr variable.caches)))
+ variable.caches-list))
+
+(define (uuo-link-label-offset)
+ (case endianness
+ ;; On big-endian systems, the label points exactly at the code,
+ ;; aligned on an object boundary.
+ ((BIG) 0)
+ ;; On little-endian systems, the code starts halfway in the middle
+ ;; of the frame size object, clobbering the fixnum tag but leaving
+ ;; the 16-bit value intact.
+ ((LITTLE) 4)
+ (else (error "Unknown endianness:" endianness))))
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; LAP Generation Rules: Interpreter Calls
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Variable cache trap handling.
+
+(define-rule statement
+ (INTERPRETER-CALL:CACHE-REFERENCE (? cont) (? extension) (? safe?))
+ (QUALIFIER (interpreter-call-argument? extension))
+ (define (get-argument value register)
+ (interpreter-call-argument->machine-register! value register))
+ (let ((set-extension (get-argument extension regnum:utility-arg1)))
+ (LAP ,@set-extension
+ ,@(clear-map!)
+ #|
+ ,@(invoke-interface/call
+ (if safe?
+ code:compiler-safe-reference-trap
+ code:compiler-reference-trap)
+ cont)
+ |#
+ ,@(invoke-hook/call
+ (if safe?
+ entry:compiler-safe-reference-trap
+ entry:compiler-reference-trap)
+ cont))))
+
+(define-rule statement
+ (INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont) (? extension) (? value))
+ (QUALIFIER (and (interpreter-call-argument? extension)
+ (interpreter-call-argument? value)))
+ (define (get-argument value register)
+ (interpreter-call-argument->machine-register! value register))
+ (let* ((set-extension (get-argument extension regnum:utility-arg1))
+ (set-value (get-argument extension regnum:utility-arg2)))
+ (LAP ,@set-extension
+ ,@set-value
+ ,@(clear-map!)
+ #|
+ ,@(invoke-interface/call code:compiler-assignment-trap cont)
+ |#
+ ,@(invoke-hook/call entry:compiler-assignment-trap cont))))
+
+(define-rule statement
+ (INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont) (? extension))
+ (QUALIFIER (interpreter-call-argument? extension))
+ (define (get-argument value register)
+ (interpreter-call-argument->machine-register! value register))
+ (let ((set-extension (get-argument extension regnum:utility-arg1)))
+ (LAP ,@set-extension
+ ,@(clear-map!)
+ ,@(invoke-interface/call code:compiler-unassigned?-trap cont))))
+\f
+;;; Obsolete interpreter calls, should be flushed.
+
+(define-rule statement
+ (INTERPRETER-CALL:ACCESS (? cont) (? environment) (? name))
+ (error "Unsupported interpreter call:"
+ `(INTERPRETER-CALL:ACCESS ,cont ,environment ,name)))
+
+(define-rule statement
+ (INTERPRETER-CALL:LOOKUP (? cont) (? environment) (? name) (? safe?))
+ (error "Unsupported interpreter call:"
+ `(INTERPRETER-CALL:LOOKUP ,cont ,environment ,name ,safe?)))
+
+(define-rule statement
+ (INTERPRETER-CALL:UNASSIGNED? (? cont) (? environment) (? name))
+ (error "Unsupported interpreter call:"
+ `(INTERPRETER-CALL:UNASSIGNED? ,cont ,environment ,name)))
+
+(define-rule statement
+ (INTERPRETER-CALL:UNBOUND? (? cont) (? environment) (? name))
+ (error "Unsupported interpreter call:"
+ `(INTERPRETER-CALL:UNBOUND? ,cont ,environment ,name)))
+
+(define-rule statement
+ (INTERPRETER-CALL:DEFINE (? cont) (? environment) (? name) (? value))
+ (error "Unsupported interpreter call:"
+ `(INTERPRETER-CALL:DEFINE ,cont ,environment ,name ,value)))
+
+(define-rule statement
+ (INTERPRETER-CALL:SET! (? cont) (? environment) (? name) (? value))
+ (error "Unsupported interpreter call:"
+ `(INTERPRETER-CALL:SET! ,cont ,environment ,name ,value)))
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; LAP Generation Rules: Fixnum operations.
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source))))
+ (standard-unary target source object->fixnum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant))))
+ (load-immediate (standard-target! target) (* constant fixnum-1) #t))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source))))
+ (standard-unary target source fixnum->object))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source))))
+ (standard-unary target source address->fixnum))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source))))
+ (standard-unary target source fixnum->address))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source)))))
+ ;; Works out the same.
+ (standard-unary target source object->fixnum))
+
+(define (object->fixnum target source)
+ (LAP (LSL X ,target ,source (&U ,scheme-type-width))))
+
+(define (fixnum->object target source)
+ (LAP (ORR X ,target ,source (&U ,type-code:fixnum))
+ (ROR X ,target ,target (&U ,scheme-type-width))))
+
+(define (address->fixnum target source)
+ (LAP (LSL X ,target ,source (&U ,scheme-type-width))))
+
+(define (fixnum->address target source)
+ (LAP (LSR X ,target ,source (&U ,scheme-type-width))))
+
+(define (word->fixnum target source)
+ (LAP (AND X ,target ,source (&U ,(- (expt 2 scheme-type-width) 1)))))
+\f
+;;;; Unary Fixnum Operations
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-1-ARG (? operator) (REGISTER (? source)) (? overflow?)))
+ (standard-unary target source
+ (lambda (target source)
+ ((fixnum-1-arg/operator operator) target source overflow?))))
+
+(define (fixnum-1-arg/operator operator)
+ (lookup-arithmetic-method operator fixnum-methods/1-arg))
+
+(define fixnum-methods/1-arg
+ (list 'FIXNUM-METHODS/1-ARG))
+
+(define-arithmetic-method 'FIXNUM-NOT fixnum-methods/1-arg
+ (lambda (target source overflow?)
+ (assert (not overflow?))
+ (LAP (MVN X ,target ,source))))
+
+(define-arithmetic-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
+ (lambda (target source overflow?)
+ (fixnum-add-constant target source +1 overflow?)))
+
+(define-arithmetic-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg
+ (lambda (target source overflow?)
+ (fixnum-add-constant target source -1 overflow?)))
+
+(define (set-always-branches!)
+ (set-current-branches! (lambda (label) (LAP (B (@PCR ,label))))
+ (lambda (label) label (LAP))))
+
+(define (set-never-branches!)
+ (set-current-branches! (lambda (label) label (LAP))
+ (lambda (label) (LAP (B (@PCR ,label))))))
+
+(define (set-carry-branches!)
+ (set-current-branches! (lambda (label) (LAP (B.CS (@PCR ,label))))
+ (lambda (label) (LAP (B.CC (@PCR ,label))))))
+
+(define (fixnum-add-constant target source n overflow?)
+ (let ((imm (* fixnum-1 n)))
+ (cond ((not overflow?)
+ (add-immediate target source imm))
+ ((zero? n)
+ (set-never-branches!)
+ (register->register-transfer source target))
+ (else
+ (set-carry-branches!)
+ (add-immediate-with-flags target source imm)))))
+
+(define (load-fixnum-constant target n)
+ (load-signed-immediate target (* n fixnum-1)))
+\f
+;;;; Binary Fixnum Operations
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operator)
+ (REGISTER (? source1))
+ (REGISTER (? source2))
+ (? overflow?)))
+ (standard-binary target source1 source2
+ (lambda (target source1 source2)
+ ((fixnum-2-args/operator operator) target source1 source2 overflow?))))
+
+(define (fixnum-2-args/operator operator)
+ (lookup-arithmetic-method operator fixnum-methods/2-args))
+
+(define fixnum-methods/2-args
+ (list 'FIXNUM-METHODS/2-ARGS))
+
+(define ((fixnum-2-args/additive flags no-flags)
+ target source1 source2 overflow?)
+ (if overflow?
+ (begin
+ (set-carry-branches!)
+ (LAP (,flags ,target ,source1 ,source2)))
+ (LAP (,no-flags ,target ,source1 ,source2))))
+
+(define ((fixnum-2-args/bitwise op) target source1 source2 overflow?)
+ (assert (not overflow?))
+ (LAP (,op ,target ,source1 ,source2)))
+
+(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args
+ (fixnum-2-args/additive 'ADDS 'ADD))
+
+(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args
+ (fixnum-2-args/additive 'SUBS 'SUB))
+
+(define-arithmetic-method 'FIXNUM-AND fixnum-methods/2-args
+ (fixnum-2-args/bitwise 'AND))
+
+(define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args
+ (fixnum-2-args/bitwise 'BIC)) ;Bitwise Bit Clear
+
+(define-arithmetic-method 'FIXNUM-OR fixnum-methods/2-args
+ (fixnum-2-args/bitwise 'ORR))
+
+(define-arithmetic-method 'FIXNUM-XOR fixnum-methods/2-args
+ (fixnum-2-args/bitwise 'EOR)) ;fans of Winnie the Pooh
+\f
+(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args
+ (lambda (target source1 source2 overflow?)
+ ;; We have x 2^t and y 2^t, and we want x y 2^t, so divide one of
+ ;; them first by 2^t.
+ (if (not overflow?)
+ (LAP (ASR ,regnum:scratch-0 ,source1 (&U ,scheme-type-width))
+ (MUL ,target ,regnum:scratch-0 ,source2))
+ (let* ((mask (allocate-temporary-register! 'GENERAL))
+ (hi (allocate-temporary-register! 'GENERAL)))
+ ;; We're going to test whether the high 64-bits is equal to
+ ;; the -1 or 0 we expect it to be. Overflow if not equal, no
+ ;; overflow if equal.
+ (set-not-equal-branches!)
+ ;; Set mask to -1 if same sign, 0 if different sign. The
+ ;; mask is equal to the high 64 bits of a non-overflowing
+ ;; multiply, so its xor with the high 64 bits is zero iff no
+ ;; overflow.
+ (LAP (MOVZ X ,mask (&U 0))
+ (CMP X ,source1 (&U 0))
+ (CINV.LT X ,mask ,mask)
+ (CMP X ,source2 (&U 0))
+ (CINV.LT X ,mask ,mask)
+ (ASR X ,regnum:scratch-0 ,source1 (&U ,scheme-type-width))
+ (SMULH ,hi ,regnum:scratch-0 ,source2)
+ (MUL X ,target ,regnum:scratch-0 ,source2)
+ (CMP X ,mask ,hi))))))
+
+(define-arithmetic-method 'FIXNUM-QUOTIENT fixnum-methods/2-args
+ (lambda (target source1 source2 overflow?)
+ (assert (not overflow?))
+ (if (= source1 source2) ;XXX Avoid this earlier on.
+ (load-fixnum-constant target 1)
+ (LAP (SDIV X ,target ,source1 ,source2)
+ (LSL X ,target ,target (&U ,scheme-type-width))))))
+
+(define-arithmetic-method 'FIXNUM-REMAINDER fixnum-methods/2-args
+ (lambda (target source1 source2 overflow?)
+ (assert (not overflow?))
+ (if (= source1 source2) ;XXX Avoid this earlier on.
+ (load-fixnum-constant target 0)
+ (LAP (SDIV X ,target ,source1 ,source2)
+ ;; source1 = n, source2 = d, target = q
+ ;; target := n - d*q
+ (MSUB X ,target ,source1 ,source2 ,target)
+ (LSL X ,target ,target (&U ,scheme-type-width))))))
+
+;; XXX Constant operands.
+;; XXX Fast division by multiplication.
+\f
+;;;; Fixnum Predicates
+
+(define-rule predicate
+ (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? register)))
+ (fixnum-branch! (fixnum-predicate/unary->binary predicate))
+ (LAP (CMP X ,(standard-source! register) (& 0))))
+
+(define-rule predicate
+ (FIXNUM-PRED-1-ARG FIXNUM-ZERO? (REGISTER (? register)))
+ (zero-test! (standard-source! register)))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? source1))
+ (REGISTER (? source2)))
+ (fixnum-branch! predicate)
+ (standard-unary-effect source1 source2
+ (lambda ()
+ (LAP (CMP X ,source1 ,source2)))))
+
+(define (fixnum-predicate/unary->binary predicate)
+ (case predicate
+ ((ZERO-FIXNUM?) 'EQUAL-FIXNUM?)
+ ((NEGATIVE-FIXNUM?) 'LESS-THAN-FIXNUM?)
+ ((POSITIVE-FIXNUM?) 'GREATER-THAN-FIXNUM?)
+ (else (error "Unknown unary predicate:" predicate))))
+
+(define (fixnum-branch! predicate)
+ (case predicate
+ ((EQUAL-FIXNUM?)
+ (set-equal-branches!))
+ ((LESS-THAN-FIXNUM?)
+ (set-current-branches! (lambda (label) (LAP (B.LT (@PCR ,label))))
+ (lambda (label) (LAP (B.GE (@PCR ,label))))))
+ ((GREATER-THAN-THAN-FIXNUM?)
+ (set-current-branches! (lambda (label) (LAP (B.GT (@PCR ,label))))
+ (lambda (label) (LAP (B.LE (@PCR ,label))))))
+ ((UNSIGNED-LESS-THAN-FIXNUM?)
+ (set-current-branches! (lambda (label) (LAP (B.MI (@PCR ,label))))
+ (lambda (label) (LAP (B.PL (@PCR ,label))))))
+ ((UNSIGNED-LESS-THAN-FIXNUM?)
+ (set-current-branches! (lambda (label) (LAP (B.PL (@PCR ,label))))
+ (lambda (label) (LAP (B.MI (@PCR ,label))))))
+ (else
+ (error "Unknown fixnum predicate:" predicate))))
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; RTL Rewrite Rules
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+(define-rule rewriting
+ (CONS-NON-POINTER (? type) (? datum))
+ ;; On aarch64, 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
+ (back-end: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
+ (back-end: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
+ (back-end: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
+ (back-end:object-datum (rtl:constant-value source))))
+
+(define (rtl:constant-non-pointer? expression)
+ (and (rtl:constant? expression)
+ (non-pointer-object? (rtl:constant-value expression))))
+\f
+;;; These rules are losers because there's no abstract way to cons a
+;;; statement or a predicate without also getting some CFG structure.
+
+(define-rule rewriting
+ (ASSIGN (? target) (REGISTER (? comparand register-known-value)))
+ (QUALIFIER (rtl:immediate-zero-constant? comparand))
+ (list 'ASSIGN target comparand))
+
+(define-rule rewriting
+ (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? (back-end:object-type value))
+ (zero? (back-end:object-datum value)))))
+ ((rtl:cons-pointer? expression)
+ (and (let ((expression (rtl:cons-pointer-type expression)))
+ (and (rtl:machine-constant? expression)
+ (zero? (rtl:machine-constant-value expression))))
+ (let ((expression (rtl:cons-pointer-datum expression)))
+ (and (rtl:machine-constant? expression)
+ (zero? (rtl:machine-constant-value expression))))))
+ (else #f)))
+\f
+;;;; Fixnums
+
+(define-rule rewriting
+ (OBJECT->FIXNUM (REGISTER (? source register-known-value)))
+ (QUALIFIER (rtl:constant-fixnum? source))
+ (rtl:make-object->fixnum source))
+
+(define-rule rewriting
+ (OBJECT->FIXNUM (REGISTER (? source register-known-value)))
+ (QUALIFIER (rtl:cons-non-pointer? source))
+ (rtl:make-address->fixnum (rtl:cons-non-pointer-datum source)))
+
+(define-rule rewriting
+ (ADDRESS->FIXNUM (REGISTER (? source register-known-value)))
+ (QUALIFIER (rtl:object->datum? source))
+ ;; Pun: ADDRESS->FIXNUM has the same effect as OBJECT->FIXNUM even on
+ ;; tagged objects. If we ever changed the representation of
+ ;; addresses (which is unlikely -- there's no temptation to disable
+ ;; HEAP_IN_LOW_MEMORY because we have 58 bits for addresses) we would
+ ;; have to change this.
+ (rtl:make-address->fixnum (rtl:object->datum-expression source)))
+
+#|
+;;; Disabled until we have fixnum rules with constant operands.
+
+(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 (value)
+ (not (zero? value))))))
+ (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)))))))
+|#
--- /dev/null
+/* -*-C-*-
+
+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, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 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.
+
+*/
+
+/* Compiled code interface for AArch64. */
+
+#include "cmpint.h"
+
+extern void * tospace_to_newspace (void *);
+extern void * newspace_to_tospace (void *);
+\f
+bool
+read_cc_entry_type (cc_entry_type_t * cet, insn_t * address)
+{
+ return
+ (decode_old_style_format_word (cet, (((const uint16_t *) address) [-6])));
+}
+
+bool
+write_cc_entry_type (cc_entry_type_t * cet, insn_t * address)
+{
+ return (encode_old_style_format_word (cet, (((uint16_t *) address) - 6)));
+}
+
+bool
+read_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address)
+{
+ uint16_t n = (((const uint16_t *) address) [-5]);
+ (ceo->offset) = (n >> 1);
+ (ceo->continued_p) = ((n & 1) != 0);
+ return (false);
+}
+
+bool
+write_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address)
+{
+ if (! ((ceo->offset) < 0x4000))
+ return (true);
+ (((uint16_t *) address) [-5])
+ = (((ceo->offset) << 1) | ((ceo->continued_p) ? 1 : 0));
+ return (false);
+}
+
+insn_t *
+cc_return_address_to_entry_address (insn_t * pc)
+{
+ insn_t insn = (pc[0]);
+ if ((insn & 0xfc000000UL) == 0x14000000UL) /* B */
+ return (pc + (insn & 0x3fffffff));
+ else
+ /* XXX What if it got branch-tensioned? */
+ error_external_return ();
+}
+\f
+/* Compiled closures */
+
+/* start_closure_reloation (scan, ref)
+
+ `scan' points at the manifest of a compiled closure. Initialize
+ `ref' with whatever we need to relocate the entries in it. */
+
+void
+start_closure_relocation (SCHEME_OBJECT * scan, reloc_ref_t * ref)
+{
+ /* The last element of the block is always the tagged first entry of
+ the closure, which tells us where the closure was in oldspace. */
+ (ref->old_addr) = (CC_ENTRY_ADDRESS (* ((CC_BLOCK_ADDR_END (scan)) - 1)));
+ /* Find the address of the first entry in newspace. */
+ (ref->new_addr)
+ = (tospace_to_newspace
+ (compiled_closure_entry (compiled_closure_start (scan + 1))));
+}
+
+/* read_compiled_closure_target (start, ref)
+
+ `start' points to the start of a closure entry in tospace, beginning
+ with the format word and block offset. `ref' was initialized with
+ `start_closure_relocation'. Return the untagged compiled entry
+ address in oldspace that the closure entry points to. */
+
+insn_t *
+read_compiled_closure_target (insn_t * start, reloc_ref_t * ref)
+{
+ insn_t * addr = (start + CC_ENTRY_HEADER_SIZE);
+ insn_t * base = (tospace_to_newspace (addr));
+ /* If we're relocating, find where base was in the oldspace. */
+ if (ref)
+ base += (ref->old_addr - ref->new_addr);
+ return (base + (((int64_t *) addr)[-1]));
+}
+
+/* write_compiled_closure_target(target, start)
+
+ `target' is an untagged compiled entry address in newspace. `start'
+ points to the start of a closure entry in tospace, beginning with
+ the format word and block offset. Set the closure entry at `start'
+ to go to `target'. */
+
+void
+write_compiled_closure_target (insn_t * target, insn_t * start)
+{
+ insn_t * addr = (start + CC_ENTRY_HEADER_SIZE);
+ (((int64_t *) addr)[-1]) =
+ (target - ((insn_t *) (tospace_to_newspace (addr))));
+}
+
+unsigned long
+compiled_closure_count (SCHEME_OBJECT * block)
+{
+ /* `block' is a pointer to the first object after the manifest. The
+ first object following it is the entry count. */
+ return ((unsigned long) (* ((uint32_t *) block)));
+}
+
+insn_t *
+compiled_closure_start (SCHEME_OBJECT * block)
+{
+ return ((insn_t *) block);
+}
+
+insn_t *
+compiled_closure_entry (insn_t * start)
+{
+ return (start + CC_ENTRY_PADDING_SIZE + CC_ENTRY_HEADER_SIZE);
+}
+
+insn_t *
+compiled_closure_next (insn_t * start)
+{
+ return (start + CC_ENTRY_PADDING_SIZE + CC_ENTRY_HEADER_SIZE);
+}
+
+SCHEME_OBJECT *
+skip_compiled_closure_padding (insn_t * start)
+{
+ return ((SCHEME_OBJECT *) start);
+}
+
+SCHEME_OBJECT
+compiled_closure_entry_to_target (insn_t * entry)
+{
+ return (MAKE_CC_ENTRY (entry + (((int64_t *) entry)[-1])));
+}
+\f
+/* Execution caches (UUO links)
+
+ An execution cache is a region of memory that lives in the
+ constants section of a compiled-code block. It is an indirection
+ for calling external procedures that allows the linker to control
+ the calling process without having to find and change all the
+ places in the compiled code that refer to it.
+
+ Prior to linking, the execution cache has two pieces of
+ information: (1) the name of the procedure being called (a symbol),
+ and (2) the number of arguments that will be passed to the
+ procedure. `saddr' points to the arity at the beginning of the
+ execution cache. */
+
+SCHEME_OBJECT
+read_uuo_symbol (SCHEME_OBJECT * saddr)
+{
+ return (saddr[0]);
+}
+
+unsigned int
+read_uuo_frame_size (SCHEME_OBJECT * saddr)
+{
+#ifdef WORDS_BIGENDIAN
+ return ((saddr[1]) & 0xffff);
+#else
+ return ((saddr[2]) & 0xffff);
+#endif
+}
+
+insn_t *
+read_uuo_target (SCHEME_OBJECT * saddr)
+{
+ return ((insn_t *) (saddr[0]));
+}
+
+insn_t *
+read_uuo_target_no_reloc (SCHEME_OBJECT * saddr)
+{
+ return (read_uuo_target (saddr));
+}
+
+static void
+write_uuo_insns (const insn_t * target, insn_t * iaddr, int pcrel)
+{
+ /* ldr x0, pc-pcrel */
+ (iaddr[0]) = (0x58000000UL | ((((unsigned) pcrel) & 0x7ffff) << 5));
+
+ /* If the target PC is right after the target offset, then the PC
+ requires no further relocation and we can jump to a fixed address.
+ But if the target is a compiled closure pointing into a block
+ somewhere else, the block may not have been relocated yet and so
+ we don't know where the PC will be in the newspace. */
+ if ((((const int64_t *) (newspace_to_tospace (target)))[-1]) == 0)
+ {
+ ptrdiff_t offset = (target - (&iaddr[1]));
+ if ((-0x40000 <= offset) && (offset <= 0x3ffff))
+ {
+ uint32_t immlo = (offset & 3);
+ uint32_t immhi = ((((uint32_t) offset) & 0x7fffc) >> 2);
+ /* adr x1, target */
+ (addr[1]) = (0x10000001UL | (immlo << 29) | (immhi << 5));
+ /* br x1 */
+ (addr[2]) = 0xd61f0020UL;
+ }
+ else
+ {
+ uintptr_t target_page = (((uintptr_t) target) >> 12);
+ uintptr_t iaddr_page = (((uintptr_t) (&iaddr[1])) >> 12);
+ ptrdiff_t offset_page = (target_page - iaddr_page);
+ if ((-0x40000 <= offset_page) && (offset_page <= 0x3ffff))
+ {
+ uint32_t immlo = (offset_page & 3);
+ uint32_t immhi = ((((uint32_t) offset_page) & 0x7fffc) >> 2);
+ uint32_t imm12 = (((uintptr_t) target) - target_page);
+ /* adrp x1, target */
+ (iaddr[1]) = (0x90000001UL | (immlo << 29) | (immhi << 5));
+ /* add x1, x1, #off */
+ (iaddr[2]) = (0x91000021UL | (imm12 << 10));
+ /* br x1 */
+ (iaddr[3]) = 0xd61f0020UL;
+ }
+ else
+ /* You have too much memory. */
+ error_external_return ();
+ }
+ }
+ else
+ {
+ (iaddr[1]) = 0xd1002001UL; /* sub x1, x0, #8 */
+ (iaddr[2]) = 0xf9400021UL; /* ldr x1, [x1] */
+ (iaddr[3]) = 0x8b000021UL; /* add x1, x1, x0 */
+ (iaddr[4]) = 0xd61f0020UL; /* br x1 */
+ }
+}
+
+void
+write_uuo_target (insn_t * target, SCHEME_OBJECT * saddr)
+{
+ insn_t * iaddr;
+ int ioff;
+
+#ifdef WORDS_BIGENDIAN
+ ioff = 2;
+#else
+ ioff = 3;
+#endif
+
+ (saddr[0]) = ((SCHEME_OBJECT) target);
+ iaddr = (((insn_t *) saddr) + ioff);
+ write_uuo_insns (target, iaddr, -ioff);
+}
+\f
+#define TRAMPOLINE_ENTRY_PADDING_SIZE 1
+#define OBJECTS_PER_TRAMPOLINE_ENTRY 4
+
+unsigned long
+trampoline_entry_size (unsigned long n_entries)
+{
+ return (n_entries * OBJECTS_PER_TRAMPOLINE_ENTRY);
+}
+
+insn_t *
+trampoline_entry_addr (SCHEME_OBJECT * block, unsigned long index)
+{
+ return (((insn_t *) (block + 2 + (index * OBJECTS_PER_TRAMPOLINE_ENTRY)))
+ + TRAMPOLINE_ENTRY_PADDING_SIZE + CC_ENTRY_HEADER_SIZE);
+}
+
+insn_t *
+trampoline_return_addr (SCHEME_OBJECT * block, unsigned long index)
+{
+ return (trampoline_entry_addr (block, index));
+}
+
+#define REGNUM_REGS_POINTER 19
+#define REGBLOCK_SCHEME_TO_INTERFACE 0
+
+bool
+store_trampoline_insns (insn_t * entry, uint8_t code)
+{
+ (entry[-2]) = 0; /* PC offset, first half */
+ (entry[-1]) = 0; /* PC offset, other half */
+ /* movz x16, #code */
+ (entry[0]) = (0xd2800010UL | (((unsigned) code) << 5));
+ /* adr x1, storage */
+ (entry[1]) = 0x10000061UL;
+ /* ldr x17, [x19, #<scheme_to_interface>] */
+ {
+ unsigned Rn = REGNUM_REGS_POINTER;
+ unsigned imm12 = REGBLOCK_SCHEME_TO_INTERFACE;
+ (entry[2]) = (0xf9400011UL | (imm12 << 10) | (Rn << 5));
+ }
+ /* br x17 */
+ (entry[3]) = 0xd61f0220UL;
+}
+\f
+#define SETUP_REGISTER(hook) do \
+{ \
+ Registers[offset++] = ((unsigned long) hook); \
+ declare_builtin (((unsigned long) hook), #hook);
+} while (0)
+
+void
+aarch64_reset_hook (void)
+{
+ unsigned offset = COMPILER_REGBLOCK_N_FIXED;
+
+ /* Must agree with compiler/machines/aarch64/lapgen.scm. */
+ SETUP_REGISTER (asm_scheme_to_interface); /* 0 */
+ ...
+
+ /* XXX Make sure we're mapped write and execute. (Such is the state...) */
+}
--- /dev/null
+/* -*-C-*-
+
+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, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 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.
+
+*/
+
+/* Compiled code interface macros for AArch64. */
+
+#ifndef SCM_CMPINTMD_H_INCLUDED
+#define SCM_CMPINTMD_H_INCLUDED 1
+\f
+/*
+
+- Execute cache, little-endian:
+
+ (before linking)
+ 0x00 8 [symbol: <name>]
+ 0x08 8 [fixnum: <frame size>]
+ 0x10 16 (padding)
+ 0x20 end
+
+ (after linking, pointing to near open procedure)
+target 0x00 8 <entry address>
+ 0x08 4 <frame size>
+uuo 0x0c 4 ldr x0, target ; Load entry address.
+ 0x10 4 adr x1, target_pc ; Load PC-relative address.
+ 0x14 4 br x1
+ 0x18 8 (padding)
+ 0x20
+
+ (after linking, pointing to far open procedure)
+target 0x00 8 <entry address>
+ 0x08 4 <frame size>
+uuo 0x0c 4 ldr x0, target ; Load entry address.
+ 0x10 4 adrp x1, target_pc ; Load PC-relative page addr.
+ 0x14 4 add x1, x1, #page_offset : Add page offset.
+ 0x18 4 br x1
+ 0x1c 4 (padding)
+ 0x20
+
+ (after linking, pointing to closure)
+target 0x00 8 <entry address>
+ 0x08 4 <frame size>
+uuo 0x0c 4 ldr x0, target ; Load entry address.
+ 0x10 4 sub x1, x0, #8 ; Get address of PC offset.
+ 0x14 4 ldr x1, [x1] ; Load PC offset.
+ 0x18 4 add x1, x1, x0 ; Compute PC = entry + offset.
+ 0x1c 4 br x1
+ 0x20
+
+- Execute cache, big-endian:
+
+ (before linking)
+ 0x00 8 [symbol: <name>]
+ 0x08 16 (padding)
+ 0x18 8 [fixnum: <frame size>]
+ 0x20
+
+ (after linking, pointing to near open procedure)
+target 0x00 8 <entry address>
+uuo 0x08 4 ldr x0, target ; Load entry address.
+ 0x0c 4 adr x1, target_pc ; Load PC-relative address.
+ 0x10 4 br x1
+ 0x14 8 (padding)
+ 0x1c 4 <frame size>
+ 0x20
+
+ (after linking, pointing to far open procedure)
+target 0x00 8 <entry address>
+uuo 0x08 4 ldr x0, target ; Load entry address.
+ 0x0c 4 adrp x1, target_pc ; Load PC-relative page addr.
+ 0x10 4 add x1, x1, #page_offset ; Add page offset.
+ 0x14 4 br x1
+ 0x18 4 (padding)
+ 0x1c 4 <frame size>
+ 0x20
+
+ (after linking, pointing to closure)
+target 0x00 8 <entry address>
+uuo 0x08 4 ldr x0, target ; Load entry address.
+ 0x0c 4 sub x1, x0, #8 ; Get address of PC offset.
+ 0x10 4 ldr x1, [x1] ; Load PC offset.
+ 0x14 4 add x1, x1, x0 ; Compute PC = entry + offset.
+ 0x18 4 br x1
+ 0x1c 4 <frame size>
+ 0x20
+
+- Closure format:
+
+start 0x00 8 [manifest-closure: <nwords>]
+ 0x08 4 <entry count>
+ 0x0c 2 <type/arity for entry0>
+ 0x0e 2 <block offset for entry0: 2*(entry0 - start)>
+ 0x10 8 <PC offset for entry0: pc0 - entry0>
+entry0 0x18 4 (padding)
+ 0x1c 2 <type/arity for entry1>
+ 0x1e 2 <block offset for entry1: 2*(entry1 - start)>
+ 0x20 8 <PC offset for entry1: pc1 - entry1>
+entry1 0x28 4 (padding)
+ 0x2c 2 <type/arity for entry2>
+ 0x2e 2 <block offset for entry2: 2*(entry2 - start)>
+ 0x30 8 <PC offset for entry2: pc2 - entry2>
+entry2
+slots 0x38 8 [tag: first object]
+ 0x40 8 [tag: second object]
+ ...
+
+ Note the block offsets are all multiplied by two. The low bit
+ specifies whether the offset is from the start of the block, or from
+ another offset, which is relevant to large compiled blocks but not
+ relevant to closures unless you use gargantuan multiclosures, and we
+ don't even generate multiclosures, so.
+
+- Trampoline encoding:
+
+ -0x10 4 (padding)
+ -0x0c 2 <type/arity info>
+ -0x0a 2 <block offset>
+ -0x08 8 <PC offset = 0> 00 00 00 00 00 00 00 00
+entry 0x00 4 movz x16, #<code> ; Set utility number.
+ 0x04 4 adr x1, storage ; Set x1 to storage pointer.
+ 0x08 4 ldr x17, [x19, #<scheme_to_interface>]
+ 0x0c 4 br x17
+storage 0x10 8 [tag: first trampoline datum]
+ 0x18 8 [tag: second trampoline datum]
+ ...
+
+*/
+\f
+#define ASM_RESET_HOOK aarch64_reset_hook
+
+void aarch64_reset_hook (void);
+
+#define CMPINT_USE_STRUCS 1
+
+/* Must agree with cmpauxmd/aarch64.s. */
+#define COMPILER_REGBLOCK_N_FIXED ...
+#define COMPILER_TEMP_SIZE 1 /* size in objects of largest RTL registers */
+#define COMPILER_REGBLOCK_N_TEMPS 256
+#define COMPILER_REGBLOCK_N_HOOKS ...
+#define COMPILER_HOOK_SIZE 1
+
+#define COMPILER_REGBLOCK_EXTRA_SIZE ...
+
+/* All aarch64 instructions are 32-bit-aligned. */
+typedef uint32_t insn_t;
+
+/* Number of insn_t units for padding before entry. */
+#define CC_ENTRY_PADDING_SIZE 1
+
+/* Number of insn_t units for type/arity, block offset, and PC offset. */
+#define CC_ENTRY_HEADER_SIZE 3
+
+/* Use of this struct no doubt constitutes a strict-aliasing violation,
+ but it is a well-known fact that if you write a comment about the
+ undefined behaviour you're invoking, the C compiler is obligated to
+ do what you meant. */
+struct cc_entry
+{
+ uint32_t padding;
+ uint16_t type_arity;
+ uint16_t block_offset;
+ int64_t pc_offset;
+};
+
+/* We don't put GC trap code before an entry any more. */
+#define CC_ENTRY_GC_TRAP_SIZE 0
+
+/* A compiled entry address points to _after_ the PC offset that, when
+ added to the entry address, gives the address of instructions for
+ the CPU to execute.
+
+ XXX This is suboptimal because aarch64 does not have immediate
+ negative load offsets, but putting the offset after the label causes
+ other annoying issues. */
+
+#define CC_ENTRY_ADDRESS_PTR(e) (e)
+#define CC_ENTRY_ADDRESS_PC(e) ((e) + (((const int64_t *) (e))[-1]))
+
+/* A compiled return address points to a jump instruction that jumps to
+ the continuation's body. */
+
+#define CC_RETURN_ADDRESS_PTR(r) (r)
+#define CC_RETURN_ADDRESS_PC(r) ((insn_t *) interface_to_scheme_return)
+
+insn_t * cc_return_address_to_entry_address (insn_t *);
+
+#define CC_RETURN_ADDRESS_TO_ENTRY_ADDRESS cc_return_address_to_entry_address
+\f
+#define EMBEDDED_CLOSURE_ADDRS_P 1
+
+typedef struct
+{
+ insn_t * old_addr;
+ insn_t * new_addr;
+} reloc_ref_t;
+
+#define DECLARE_RELOCATION_REFERENCE(name) reloc_ref_t name
+
+#define START_CLOSURE_RELOCATION(scan, ref) \
+ start_closure_relocation ((scan), (&ref))
+
+#define START_OPERATOR_RELOCATION(scan, ref) do {(void)ref;} while (0)
+
+#define OPERATOR_RELOCATION_OFFSET 0
+
+#define READ_COMPILED_CLOSURE_TARGET(a, r) \
+ read_compiled_closure_target ((a), (&r))
+
+void start_closure_relocation (SCHEME_OBJECT *, reloc_ref_t *);
+insn_t * read_compiled_closure_target (insn_t *, reloc_ref_t *);
+
+/* Number of objects in an execute cache. Must match aarch64/rules3.scm. */
+#define UUO_LINK_SIZE 4
+
+#define UUO_WORDS_TO_COUNT(nw) ((nw) / UUO_LINK_SIZE)
+#define UUO_COUNT_TO_WORDS(nc) ((nc) * UUO_LINK_SIZE)
+
+#define READ_UUO_TARGET(a, r) read_uuo_target (a)
+
+insn_t * read_uuo_target (SCHEME_OBJECT *);
+
+#endif /* SCM_CMPINTMD_H_INCLUDED */
projects / mit-scheme.git / commitdiff