OSDN Git Service

Initial revision
authorbje <bje>
Fri, 28 Jul 2000 04:11:52 +0000 (04:11 +0000)
committerbje <bje>
Fri, 28 Jul 2000 04:11:52 +0000 (04:11 +0000)
100 files changed:
cgen/AUTHORS [new file with mode: 0644]
cgen/COPYING.CGEN [new file with mode: 0644]
cgen/ChangeLog [new file with mode: 0644]
cgen/INSTALL [new file with mode: 0644]
cgen/Makefile.am [new file with mode: 0644]
cgen/Makefile.in [new file with mode: 0644]
cgen/NEWS [new file with mode: 0644]
cgen/README [new file with mode: 0644]
cgen/aclocal.m4 [new file with mode: 0644]
cgen/arm.cpu [new file with mode: 0644]
cgen/arm.sim [new file with mode: 0644]
cgen/arm7.cpu [new file with mode: 0644]
cgen/attr.scm [new file with mode: 0644]
cgen/cgen-gas.scm [new file with mode: 0644]
cgen/cgen-opc.scm [new file with mode: 0644]
cgen/cgen-sim.scm [new file with mode: 0644]
cgen/cgen-stest.scm [new file with mode: 0644]
cgen/configure [new file with mode: 0755]
cgen/configure.in [new file with mode: 0644]
cgen/cos.scm [new file with mode: 0644]
cgen/decode.scm [new file with mode: 0644]
cgen/desc-cpu.scm [new file with mode: 0644]
cgen/desc.scm [new file with mode: 0644]
cgen/dev.scm [new file with mode: 0644]
cgen/doc/Makefile.am [new file with mode: 0644]
cgen/doc/Makefile.in [new file with mode: 0644]
cgen/doc/app.texi [new file with mode: 0644]
cgen/doc/cgen.texi [new file with mode: 0644]
cgen/doc/credits.texi [new file with mode: 0644]
cgen/doc/glossary.texi [new file with mode: 0644]
cgen/doc/internals.texi [new file with mode: 0644]
cgen/doc/intro.texi [new file with mode: 0644]
cgen/doc/notes.texi [new file with mode: 0644]
cgen/doc/opcodes.texi [new file with mode: 0644]
cgen/doc/pmacros.texi [new file with mode: 0644]
cgen/doc/porting.texi [new file with mode: 0644]
cgen/doc/rtl.texi [new file with mode: 0644]
cgen/doc/running.texi [new file with mode: 0644]
cgen/doc/sim.texi [new file with mode: 0644]
cgen/doc/stamp-vti [new file with mode: 0644]
cgen/doc/version.texi [new file with mode: 0644]
cgen/enum.scm [new file with mode: 0644]
cgen/fixup.scm [new file with mode: 0644]
cgen/fr30.cpu [new file with mode: 0644]
cgen/fr30.opc [new file with mode: 0644]
cgen/gas-test.scm [new file with mode: 0644]
cgen/hardware.scm [new file with mode: 0644]
cgen/i960.cpu [new file with mode: 0644]
cgen/i960.opc [new file with mode: 0644]
cgen/ia32.cpu [new file with mode: 0644]
cgen/ia64.cpu [new file with mode: 0644]
cgen/ifield.scm [new file with mode: 0644]
cgen/iformat.scm [new file with mode: 0644]
cgen/insn.scm [new file with mode: 0644]
cgen/m32r.cpu [new file with mode: 0644]
cgen/m32r.opc [new file with mode: 0644]
cgen/m68k.cpu [new file with mode: 0644]
cgen/mach.scm [new file with mode: 0644]
cgen/minsn.scm [new file with mode: 0644]
cgen/mode.scm [new file with mode: 0644]
cgen/model.scm [new file with mode: 0644]
cgen/opc-asmdis.scm [new file with mode: 0644]
cgen/opc-ibld.scm [new file with mode: 0644]
cgen/opc-itab.scm [new file with mode: 0644]
cgen/opc-opinst.scm [new file with mode: 0644]
cgen/opcodes.scm [new file with mode: 0644]
cgen/operand.scm [new file with mode: 0644]
cgen/pgmr-tools.scm [new file with mode: 0644]
cgen/play.cpu [new file with mode: 0644]
cgen/pmacros.scm [new file with mode: 0644]
cgen/profile.scm [new file with mode: 0644]
cgen/read.scm [new file with mode: 0644]
cgen/rtl-c.scm [new file with mode: 0644]
cgen/rtl.scm [new file with mode: 0644]
cgen/rtx-funcs.scm [new file with mode: 0644]
cgen/sem-frags.scm [new file with mode: 0644]
cgen/semantics.scm [new file with mode: 0644]
cgen/sim-arch.scm [new file with mode: 0644]
cgen/sim-cpu.scm [new file with mode: 0644]
cgen/sim-decode.scm [new file with mode: 0644]
cgen/sim-model.scm [new file with mode: 0644]
cgen/sim-test.scm [new file with mode: 0644]
cgen/sim.scm [new file with mode: 0644]
cgen/simplify.inc [new file with mode: 0644]
cgen/slib/genwrite.scm [new file with mode: 0644]
cgen/slib/pp.scm [new file with mode: 0644]
cgen/slib/sort.scm [new file with mode: 0644]
cgen/sparc.cpu [new file with mode: 0644]
cgen/sparc.opc [new file with mode: 0644]
cgen/sparc32.cpu [new file with mode: 0644]
cgen/sparc64.cpu [new file with mode: 0644]
cgen/sparccom.cpu [new file with mode: 0644]
cgen/sparcfpu.cpu [new file with mode: 0644]
cgen/stamp-h.in [new file with mode: 0644]
cgen/thumb.cpu [new file with mode: 0644]
cgen/types.scm [new file with mode: 0644]
cgen/utils-cgen.scm [new file with mode: 0644]
cgen/utils-gen.scm [new file with mode: 0644]
cgen/utils-sim.scm [new file with mode: 0644]
cgen/utils.scm [new file with mode: 0644]

diff --git a/cgen/AUTHORS b/cgen/AUTHORS
new file mode 100644 (file)
index 0000000..c0b497b
--- /dev/null
@@ -0,0 +1 @@
+CGEN was originally written by Doug Evans <devans@cygnus.com>.
diff --git a/cgen/COPYING.CGEN b/cgen/COPYING.CGEN
new file mode 100644 (file)
index 0000000..b64876f
--- /dev/null
@@ -0,0 +1,44 @@
+CGEN - a Cpu tools GENerator
+Copyright 2000 Red Hat, Inc.
+
+This program 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, or (at your option)
+any later version.
+
+This program 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 this software; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA
+
+As a special exception, Red Hat gives unlimited permission to copy,
+distribute and modify the code that is the output of CGEN.  You need
+not follow the terms of the GNU General Public License when using or
+distributing such code, even though portions of the text of CGEN
+appear in them.  The GNU General Public License (GPL) does govern all
+other use of the material that constitutes the CGEN program.
+
+Certain portions of the CGEN source text are designed to be copied (in
+certain cases, depending on the input) into the output of CGEN.  We
+call these the "data" portions.  CPU description files are, for the
+purposes of this copyright, deemed "data".  The rest of the CGEN
+source text consists of comments plus executable code that decides
+which of the data portions to output in any given case.  We call these
+comments and executable code the "non-data" portions.  CGEN never
+copies any of the non-data portions into its output.
+
+This special exception to the GPL applies to versions of CGEN released
+by Red Hat.  When you make and distribute a modified version of CGEN,
+you may extend this special exception to the GPL to apply to your
+modified version as well, *unless* your modified version has the
+potential to copy into its output some of the text that was the
+non-data portion of the version that you started with.  (In other
+words, unless your change moves or copies text from the non-data
+portions to the data portions.)  If your modification has such
+potential, you must delete any notice of this special exception to the
+GPL from your modified version.
diff --git a/cgen/ChangeLog b/cgen/ChangeLog
new file mode 100644 (file)
index 0000000..8f7c944
--- /dev/null
@@ -0,0 +1,4263 @@
+2000-07-25  Ben Elliston  <bje@redhat.com>
+
+       * doc/credits.texi (Credits): Add Frank Eigler.
+
+2000-07-24  Dave Brolley  <brolley@redhat.com>
+
+       * opc-itab.scm (gen-insn-opcode-table): Initialize the first element
+       fully.
+       * desc.scm (gen-attr-table-defn): Initialize all elements fully.
+       (<keyword>): Initialize all elements fully.
+       * desc-cpu.scm (-gen-isa-table-defns): Initialize the last element
+       fully.
+       (-gen-mach-table-defns): Ditto.
+       (-gen-ifld-defns): Ditto.
+       (-gen-operand-table): Ditto.
+       (-gen-insn-table): Ditto.
+       (-gen-cpu-open): Nothing to do for the mach table.
+
+2000-07-13  Ben Elliston  <bje@redhat.com>
+
+       * doc/version.texi (UPDATED): Update.
+
+2000-07-05  Ben Elliston  <bje@redhat.com>
+
+       * configure.in (AC_PATH_PROG): Remove.
+       * configure: Regenerate.
+       * Makefile.am (GUILE): Locate guile dynamically.
+       * Makefile.in: Regenerate.
+       * doc/Makefile.in: Likewise.
+
+2000-07-03  Ben Elliston  <bje@redhat.com>
+
+       * desc-cpu.scm (cgen-desc.c): Include "libiberty.h".
+       * opc-itab.scm (cgen-opc.c): Likewise.
+
+2000-06-28  Frank Ch. Eigler  <fche@redhat.com>
+
+       * rtl.scm (-rtx-traverse-locals): Correct call to `symbol?' for
+       guile 1.4 compatibility.
+       (rtx-env-dump): Comment out buggy display calls.
+
+2000-06-15  matthew green  <mrg@redhat.com>
+
+       * opc-itab.scm (-gen-ifmt-table-1): Add extra braces to pacify GCC.
+
+2000-06-14  Frank Ch. Eigler  <fche@redhat.com>
+
+       * Makefile.in: Regenerated.
+
+       * desc-cpu.scm (gen-ifld-decls): Exclude derived ifields.
+       (gen-ifld-defns): Ditto.
+       * pgmr-tools.scm (pgmr-pretty-print-insn-format): Ditto.
+       * rtl.c (rtl-finish!): Ditto.
+       * opc-itab.scm (-gen-ifield-decls): Ditto.
+       * opcodes.scm (gen-switch): Exclude derived operands.
+       * operand.scm (op-iflds-used): Expand derived operands.
+       (hw-index-derived): New dummy function to create dummy object.
+       (-derived-operand-parse): Fix mode arg passed to <derived-operand>
+       constructor.  Set object's hw-name and index fields.
+       (-anyof-merge-subchoices): Set instance object's index also.
+       (-anyof-name): New helper function.
+       (anyof-merge-semantics): Correct replacement of operand names in
+       anyof instance.
+       (op-ifield): Tolerate derived-operands and their funny indices better.
+       * ifield.scm (ifld-known-values): Expand derived ifields.
+       (non-multi-ifields, non-derived-ifields): New utility functions.
+       (ifld-decode-mode): Tolerate objects with unbound decode field.
+       * iformat.scm (compute-insn-length): Expand derived ifields.
+       (compute-insn-base-mask): Ditto.
+       * insn.scm (insn-base-ifields): Remove.
+       (<insn>): Add iflds-values entry to cache ifld-base-ifields values.
+       (insn-value): Call ifld-base-ifields and ifld-constant? instead.
+       * mach.scm (arch-analyze-insns!): Exclude multi-insns.
+       * sem-frags.scm (sim-sfrag-analyze-insns!): Ditto.
+       (-frag-test-data): Ditto.
+       * sim-decode.scm (cgen-decode.h, cgen-decode.cxx): Ditto.
+       * utils-sim.scm (op-extract?): Handle derived operands.
+       
+       * gas-test.scm (cgen-build.sh): Quote '*' chars printed by objdump.
+       * semantics.scm (-build-operand!): Handle 'DFLT case during parsing.
+       * hardware.scm (hardware-for-mode): New function.
+
+       * insn.scm (filter-harmlessly-ambiguous-insns): New function for
+       cleaning up decode tables.
+       (mask-superset?): Little helper function for above.
+       * decode.scm (-build-decode-table-entry): Call it.
+       (-opcode-slots): Add some more tracing.
+       * arm.cpu: Disable decode-splits construct due to implementation
+       conflict with `filter-harmlessly-ambiguous-insns'
+
+       * decode.scm (-population-top-few): New function for better decode
+       bit generation.  Includes minor helper functions.
+       (decode-get-best-bits): Call it instead.
+       (OLDdecode-get-best-bits): Renamed previous version of above.
+
+
+2000-06-13  Ben Elliston  <bje@redhat.com>
+
+       * configure.in: Use AC_EXEEXT with Cygnus mode. Remove AC_ARG_WITH
+       for the Guile library directory.
+       * configure: Regenerate.
+       * Makefile.in, doc/Makefile.in: Regenerate.
+
+       * Makefile.in, doc/Makefile.in: Regenerate.
+       * configure.in: Remove unnecessary tests. Move to version 1.0.
+       * acconfig.h, config.in: Remove.
+       * configure, aclocal.m4: Regenerate.
+       * doc/stamp-vti, doc/version.texi: Likewise.
+       * AUTHORS: New file.
+
+2000-06-07 Ben Elliston  <bje@redhat.com>
+
+       * fixup.scm (symbol-bound?): Reduce debugging output.
+
+2000-06-02  matthew green  <mrg@redhat.com>
+
+       * insn.scm (insn-base-ifields): Returns all the instruction fields for
+       a given instruction, replacing derived fields with their subfields.
+       (insn-value): Use `insn-base-ifields' to find all constant values.
+       (multi-insn-instantiate!): Comment some debug messages.
+
+2000-06-01  Ben Elliston  <bje@redhat.com>
+
+       * doc/rtl.texi (Expressions): Document a hazard with the choice of
+       symbol names used in a (c-call ..) rtx.
+
+       * sim-test.scm (build-test-set): Return (()) for an instruction
+       with no operands, so it too is included in the generated test set.
+
+2000-05-31  Ben Elliston  <bje@redhat.com>
+
+       * Makefile.am (gas-test): Ensure $(ISA) is not empty.
+       (sim-test): Likewise.
+       * Makefile.in: Regenerate.
+
+2000-05-30  Frank Ch. Eigler  <fche@redhat.com>
+
+       * read.scm (-cgen): In debugging mode (-b), ask guile for untruncated
+       stack traceback, in an order that resembles gdb's `bt'.
+
+2000-05-24  Frank Ch. Eigler  <fche@redhat.com>
+
+       * desc-cpu.scm (-gen-hash-defines): Use ifmt-ifields again.
+       * opc-itab.scm (-gen-ifmt-table-1): Ditto.
+       * gas-test.scm (gas-test-analyze!, cgen-build.sh): Filter out
+       multi insns.
+       * ifield.scm (multi-ifield): Define workable field-mask and field-value
+       virtual functions.
+       (ifld-base-ifields): New routine to replace ifmt-expanded-ifields.
+       * iformat.scm (ifmt-expanded-ifields): Gone.
+       (ifields-base-ifields): New function.  Call ifld-base-ifields for real
+       work.
+       (-ifmt-lookup-ifmt!): Use it to expand derived/multi combos in new
+       ifmt entries.
+
+       * opcodes.scm (multi-ifield gen-extract): Correct spacing in generated
+       code.
+
+2000-05-19  Frank Ch. Eigler  <fche@redhat.com>
+
+       * utils-gen.scm (gen-multi-ifld-extract): Fix decode hook for sim.
+
+2000-05-18  Frank Ch. Eigler  <fche@redhat.com>
+
+       * ifield.scm (-multi-ifield-parse): Add encode/decode args.
+       (-multi-ifield-read): Parse them.
+       (define-full-multi-ifield): Pass #f/#f as defaults for them.
+       * opcodes.scm (multi-ifield gen-insert): Add encode hook.
+       (multi-ifield gen-extract): Add decode hook.
+       * utils-gen.scm (gen-multi-ifld-extract): Add decode hook for sim.
+
+       * insn.scm (syntax-break-out): More correctly handle \-escaped
+       syntax characters.
+       (syntax-make-elements): Ditto.
+       * opc-itab.scm (compute-syntax): Ditto.
+
+
+2000-05-17  Ben Elliston  <bje@redhat.com>
+
+       * gas-test.scm (cgen-build.sh): Log the correct script filename.
+
+2000-05-15  Frank Ch. Eigler  <fche@redhat.com>
+
+       * gas-test.scm (build-test-set): Return (()) for an instruction
+       with no operands, so it too is included in the generated test set.
+
+2000-05-15  Frank Ch. Eigler  <fche@redhat.com>
+
+       * desc-cpu.scm (-gen-hash-defines): Define CGEN_ACTUAL_MAX values for
+       IFMT_OPERANDS and SYNTAX_BYTES.
+
+
+2000-05-15  Frank Ch. Eigler  <fche@redhat.com>
+
+       * sim.scm (with-any-profile?): New function.
+       * utils-sim.scm (-sfmt-contents): Use above instead of `with-profile?'
+       to decide whether or not to include profiling counters.
+
+2000-05-10  Frank Ch. Eigler  <fche@redhat.com>
+
+       Fuller derived-operand support for opcodes.
+       * insn.scm (non-multi-insns): New filter to oppose `multi-insns'.
+       * desc-cpu.scm (-define-hash-defines): Compute CGEN_MAX_SYNTAX_BYTES.
+       Correctly compute ..._IFMT_OPERANDS.  Omit useless ..._INSN_OPERANDS.
+       (gen-operand-table): Omit derived- and anyof- operands from table.
+       (gen-insn-table): Omit multi-insns from table.
+       * iformat.scm (ifmt-expanded-fields): New function to expand
+       subfields of derived-ifields.
+       (ifmt-compute!): Ignore remaining multi-insns.
+       * mach.scm (isa-min-insn-bitsize, isa-max-insn-bitsize): Ignore
+       multi-insns.
+       * opc-itab.scm (-gen-ifmt-table-1): Use ifmt-expanded-ifields.
+       (-gen-insn-enum, -gen-insn-opcode-table): Ignore multi-insns.
+       * opcodes.scm (derived-operand): Define abort()ing gen-insert,
+       gen-extract, gen-fget, gen-fset, gen-parse, gen-print functions.
+       (gen-switch): Omit anyof-operands.
+       * operand.scm (-anyof-syntax): New function.
+       (-anyof-merge-syntax): Call it.
+       * utils.scm (collect): New idiomatic function.
+
+2000-05-10  Ben Elliston  <bje@redhat.com>
+
+       * m68k.cpu: New file (work in progress).
+
+2000-05-05  Frank Ch. Eigler  <fche@redhat.com>
+
+       * Makefile.am (all-local): New target.  Create stamp-cgen.
+       * Makefile.in: Regenerated.
+       * doc/Makefile.in: Regenerated.
+
+2000-04-26  Frank Ch. Eigler  <fche@redhat.com>
+
+       * operand.scm (-operand-g/setter-syntax): Correct off-by-one error.
+       (-operand-parse-setter): Ditto.
+       * utils-sim.scm (needed-iflds): Store ifield (index) in argbuf, even
+       for CACHE-ADDR operands.
+
+
+2000-04-23  matthew green  <mrg@redhat.com>
+
+       * m32r.cpu: Fix a typo.
+
+Fri Apr 21 22:18:48 2000  Jim Wilson  <wilson@cygnus.com>
+
+       * ia64.cpu (define-model): Change merced to Itanium.
+       (f-qp): Change quilifying to qualifying.
+       (movbr_ph, movbr_pvec): Delete.
+       (I-I21): Delete uses of movbr_ph and movbr_pvec.
+
+2000-04-07  Ben Elliston  <bje@redhat.com>
+
+       * doc/porting.texi (Building a simulator test suite): Clarify
+       where generated test cases are placed.
+
+2000-04-07  Ben Elliston  <bje@redhat.com>
+
+       * Makefile.am (gas-test): Remove dependency on `cgen'.
+       (sim-test): Ditto.
+       * Makefile.in: Regenerate.
+
+2000-04-04  Frank Ch. Eigler  <fche@redhat.com>
+
+       * hardware.scm (<hw-pc> parse): Allow user to set type for pc register.
+       * mode.scm (mode-finish!): Add placeholder code for mach-dependent
+       type reconfiguration.
+       * utils-sim.scm (-sfmt-contents): Add profile-counters only if
+       with-profile?.
+
+2000-03-30  Ben Elliston  <bje@redhat.com>
+
+       * doc/rtl.texi (Enumerated constants): Add concept index entries.
+
+2000-03-24  Ben Elliston  <bje@redhat.com>
+
+       * Makefile.am (stamp-cgen): Reinstate target.
+       * Makefile.in: Regenerate.
+
+2000-03-22  Ben Elliston  <bje@redhat.com>
+
+       * slib/ppfile.scm: Remove; unused.
+       * slib/defmacex.scm: Likewise.
+
+2000-03-21  Ben Elliston  <bje@redhat.com>
+
+       * doc/internals.texi (Source file overview): Document.
+
+       * Makefile.am (GUILEDIR): Remove.
+       (CGEN): Ditto. Callers use $(GUILE) instead.
+       (GUILEFLAGS): Ditto.
+       (CGENFILES): Ditto.
+       (APPDESCFILES): Ditto.
+       (OPCODESFILES): Ditto.
+       (SIMFILES): Ditto.
+       (pkgdata_SCRIPTS): Ditto.
+       (stamp-cgen): Remove target.
+       * Makefile.in: Regenerate.
+
+       * configure.in: Remove header and library tests.
+       * configure: Regenerate.
+       * config.in: Likewise.
+
+2000-03-20  Ben Elliston  <bje@redhat.com>
+
+       * read.scm: Cease loading "hob-sup.scm".
+       * utils.scm: Inherit the fastcall family of procedures (for now).
+       * hob-sup.scm: Remove.
+
+2000-03-20  Ben Elliston  <bje@redhat.com>
+
+       * configure.in (AC_OUTPUT): Do not emit .gdbinit.
+       * configure: Regenerate.
+       * gdbinit.in: Remove.
+
+2000-03-17  Ben Elliston  <bje@redhat.com>
+
+       * Makefile.am (CGEN): Use guile, not cgen.
+       (CGENCFLAGS, LIBIBERTY, INCLUDES): Remove.
+       (bin_PROGRAMS, cgen_SOURCES): Likewise.
+       (CGENFILES): Fold CGEN_HOB_INPUT_FILES and CGEN_NOHOB_FILES.
+       (HOBBIT_INPUT_FILES, HOBBIT_OUTPUT_FILE): Remove.
+       (HOB_OBJS): Likewise.
+       (CGEN_HOB_SRC, CGEN_HOB_OBJ): Likewise.
+       (CGENOBJS): Likewise.
+       (cgen_DEPENDENCIES, cgen_LDFLAGS, cgen_LDADD): Likewise.
+       (hobbit, hobbit.o, hobbit.c): Remove targets.
+       (cos.o, cgen.o, cgen-gh.o, hob-sup.o): Likewise.
+       (CLEANFILES): Update.
+       * acconfig.h (WITH_HOBBIT): Remove.
+       * configure.in: Do not test for 3 arg scm_make_vector. Remove
+       option --with-cgen-hobbit.
+       * cos.h, cos.c, hob-main.c, hob-sup.c, hob-sup.h, hob.sh: Remove.
+       * cgen-gh.h, cgen-gh.c, cgen-hob.scm, cgen.c: Likewise.
+       * hobbit.c, hobbit.h, hobbit.scm: Likewise.
+       * hobscmif.h, hobslib.scm, scmhob.h: Likewise.
+       * Makefile.in: Regenerate.
+       * config.in: Likewise.
+       * aclocal.m4: Likewise.
+       * configure: Likewise.
+       * README (Hobbit support): Remove.
+       * doc/internals.texi (Conventions): Do not mention Hobbit.
+       * doc/porting.texi (Supported Guile versions): Likewise.
+
+2000-03-16  Frank Ch. Eigler  <fche@redhat.com>
+
+       * mipscom.cpu (break, syscall, define-trap): Make these non-cti
+       insns.
+       * sid-cpu.scm (-gen-sem-switch-engine): Adjust calling &
+       callback convention to new sid sidutil::basic_cpu code.
+       (-gen-sfrag-engine-fn): Ditto.
+       * sid.scm (-create-virtual-insns!): Ditto.
+       (-hw-gen-set-quiet-pc): Mark delay slot execution specially in pbb
+       mode.
+       (cxmake-skip): Implement properly for pbb mode.
+
+2000-03-03  Ben Elliston  <bje@redhat.com>
+
+       * doc/internals.texi: New file.
+
+2000-02-29  Ben Elliston  <bje@redhat.com>
+
+       * doc/rtl.texi (Derived operands): Remove unnecessary footnote.
+       * doc/porting.texi: Formatting tweaks.
+
+2000-02-25  Nick Clifton  <nickc@cygnus.com>
+
+       * desc-cpu.scm (*_cgen_cpu_open): Initialise signed_overflow_ok_p
+       field. 
+
+Thu Feb 24 14:09:01 2000  Doug Evans  <devans@seba.cygnus.com>
+
+       * operand.scm (<anyof-operand>,make!): Initialize mode-name, not
+       mode.
+
+2000-02-23  Andrew Haley  <aph@cygnus.com>
+
+       * m32r.cpu (pcmpbz): Make pcmpbz a special (i.e. hidden) 
+       instruction.
+
+2000-02-24  Ben Elliston  <bje@redhat.com>
+
+       * doc/rtl.texi (Derived operands): Add some cindex entries.
+
+2000-02-23  Ben Elliston  <bje@redhat.com>
+
+       * ia32.cpu (dndo): Move general purpose macro from here ..
+       * simplify.inc (dndo): .. to here.
+
+2000-02-18  Frank Ch. Eigler  <fche@redhat.com>
+
+       * arm.cpu (h-tbit): Add c-call setter function.
+       (h-mbits): Ditto.
+
+2000-02-17  Frank Ch. Eigler  <fche@redhat.com>
+
+       * sem-frags.scm (-frag-hash-compute!): Add appstuff arg for traversal.
+       (-frag-cost-compute!): Ditto.
+       * utils.scm (copyright-cygnus): Add Y2K.
+       * sid-cpu.scm (@prefix@_pbb_run): Add unsigned& argument.
+
+2000-01-25  Nick Clifton  <nickc@cygnus.com>
+
+       * desc-cpu.scm (@arch@_cgen_cpu_open): Add code to initialise
+       flags field of the CGEN_CPU_TABLE structure.
+
+Sun Dec 12 14:20:36 1999  Doug Evans  <devans@seba.cygnus.com>
+
+       * operand.scm (<anyof-instance>): Renamed from <anyof-value>.
+       All references updated.
+
+Tue Nov 30 11:06:22 1999  Doug Evans  <devans@seba.cygnus.com>
+
+       * ia32.cpu: Rewrite addressing mode support.
+
+       * ifield.scm (<ifield>): New member `follows'.
+       (ifld-known-values): New proc.
+       (<ifield>): New method set-word-offset!.
+       (ifld-set-word-offset!): New proc.
+       (ifld-new-word-offset): New proc.
+       (<ifield>): New method next-word.
+       (<multi-ifield>): New method next-word.
+       (ifld-next-word): New proc.
+       (ifld-precedes?): New proc.
+       (-ifield-parse): New args word-offset,word-length,follows.
+       All callers updated.  Handle CISC-style vs RISC-style ifields.
+       (-ifield-read): Recognize word-offset,word-length,follows specs.
+       (-ifld-parse-follows): New proc.
+       (-multi-ifield-make-default-insert): New proc.
+       (-multi-ifield-make-default-extract): New proc.
+       (-multi-ifield-parse): Provide default values for insert,extract
+       handlers if not specified.
+       (<derived-ifield>): New class.
+       (derived-ifield?): New predicate.
+       (ifld-derived-operand?): New predicate.
+       (f-anyof): New global.
+       (ifld-anyof?,ifld-anyof-operand?): New predicates.
+       (f-derived,ifld-derived?): Delete.
+       (ifield-builtin!): Delete init of f-derived.  Init f-anyof.
+       * insn.scm (-sub-insn-ifields): New proc.
+       (-sub-insn-make!): New proc.
+       (multi-insn-instantiate!): Provide initial implementation.
+       (-insn-parse): If insn contains "anyof" operands, create a
+       <multi-insn> object instead of a plain <insn>.
+       (-parse-insn-format-symbol): Rewrite derived operand handling.
+       Add anyof operand handling.
+       (-parse-insn-format-ifield-spec): Rewrite.
+       (-parse-insn-format-operand-spec): Delete.
+       (-parse-insn-format-list): Delete support for `(operand value)'.
+       (anyof-operand-format?): Replaces derived-operand-format?.
+       * operand.scm (-operand-parse-getter): Improve error messages.
+       (-operand-parse-setter): Ditto.
+       (<derived-operand>): New members args,syntax,base-ifield,encoding,
+       ifield-assertion.
+       (<anyof-operand>): Change baseclass from <derived-operand> to
+       <operand>.  Delete member values.  New members base-ifield,choices.
+       (anyof-operand?): New predicate.
+       (-derived-parse-encoding,-derived-parse-ifield-assertion): New procs.
+       (-derived-operand-parse): Rewrite.
+       (-derived-operand-read): Rewrite.
+       (-anyof-parse-choice): New proc.
+       (-anyof-operand-parse): Rewrite.
+       (-anyof-operand-read,define-anyof-operand): New procs.
+       (<anyof-value>): Rewrite.
+       (-anyof-initial-known): New proc.
+       (anyof-satisfies-assertions?): New proc.
+       (-anyof-merge-syntax,-anyof-merge-encoding): New procs.
+       (-anyof-merge-getter,-anyof-merge-setter): New procs.
+       (-anyof-merge-semantics,-anyof-merge-ifield-assertion): New procs.
+       (-anyof-merge-subchoices,-anyof-all-subchoices): New procs.
+       (-anyof-value-from-derived): New proc.
+       (-anyof-all-choices-1,anyof-all-choices): New procs.
+       (operand-init!): Create define-anyof-operand reader command.
+
+       * insn (syntax-break-out): Take syntax as argument instead of insn.
+       All callers updated.
+       (syntax-make): Move here, from ???.
+
+       * types.scm (<bitrange>): Rename accessors from bitrange:foo to
+       bitrange-foo. All uses updated.
+       (bitrange-next-word): New proc.
+
+       * semantics.scm (-solve-expr-fn,rtx-solve): New procs.
+
+       * rtl.scm (rtx-canonicalize): Provide initial implementation.
+       (rtx-make-const,rtx-make-enum): New procs.
+       (rtx-arg1,rtx-arg2): Renamed from -rtx-arg[12].  All callers updated.
+       (rtx-mem-addr,rtx-mem-sel): New procs.
+       (rtx-change-address): New proc.
+       (rtx-make-ifield,rtx-make-operand,rtx-make-local): New proc.
+       (rtx-make-set,rtx-single-set?): New procs.
+       (rtx-combine): New proc.
+
+       * rtl.scm (rtx-traverse): New arg `appstuff'.  All callers updated.
+       (rtx-traverse-with-locals): Ditto.
+       (-rtx-traverse,-rtx-traverse-*): Ditto.
+
+       * rtl.scm (define-subr): New proc.
+       (rtl-init!): Create reader command `define-subr'.
+
+       * cos.c (_object_mi_p): Ensure argument is an object.
+       (indent): New function.
+       (_object_print_elms): Add pretty-printing support.
+       (_object_print): Ditto.
+
+       * hobbit.scm (*reckless-s->c-fun-table*): Add fastcall7.
+       (*floats-s->c-fun-table*): Ditto.
+       * hobbit.c,hobbit.h: Rebuild.
+       * hob-sup.c (fastcall7): New proc.
+       * hob-sup.h (fastcall7): Declare.
+       * hob-sup.scm (fastcall7): New macro.
+
+       * mach.scm (<arch>): New member subr-list.
+       (current-subr-list,current-subr-add!,current-subr-lookup): New procs.
+       (arch-finish!): Reverse recorded subr list.
+
+       * read.scm (debug-env): New global.
+       (debug-var-names,debug-var,debug-repl-env): New procs.
+       (debug-repl): Rewrite.  New arg `env-list'.  All callers updated.
+       (debug-quit): Renamed from `continue'.
+
+       * simplify.inc (dsmf): New pmacro.
+
+       * utils.scm (plus-scan): New proc.
+       (split-bits): Rewrite.
+       (split-value): New proc.
+
+1999-10-13  Doug Evans  <devans@casey.cygnus.com>
+
+       * doc/Makefile.am (DOCFILES): Add notes.texi.
+       * doc/Makefile.in: Rebuild.
+
+1999-10-11  Doug Evans  <devans@casey.cygnus.com>
+
+       * ifield.scm (ifld-derived?): New proc.
+       (f-derived): New global.
+       (ifield-builtin!): Create ifield f-derived.
+       (<multi-insn>): New class.
+       (multi-insn?): New predicate.
+       (multi-insn-instantiate!): New proc.
+       (-insn-parse): Create <multi-insn> objects for insns with derived
+       ifields.
+       (-parse-insn-format-symbol): Handle derived ifields.
+       (-parse-insn-format-ifield-spec): New proc.
+       (-parse-insn-format-operand-spec): New proc.
+       (-parse-insn-format-list): Simplify.
+       (-parse-insn-format): No longer allow (ifield-object value) spec.
+       (derived-operand-format?): New proc.
+       (insn-alias?): New proc.
+       (non-alias-insns): Rewrite.
+       (insn-real?): Renamed from real-insn?, all callers updated.
+       (virutal-insns): Rewrite.
+       (multi-insns): New proc.
+       * mach.scm (arch-analyze-insns!): Instantiate multi-insns if present.
+       * operand.scm (op-ifield): Renamed from op:ifield, all callers updated.
+       Return #f if operand doesn't have an index or if index is not an
+       ifield.
+       (hw-index-anyof): New proc.
+       (-operand-parse): Allow integer indices.
+       (<derived-operand>): New class.
+       (derived-operand?): New predicate.
+       (<anyof-operand>): New class.
+       (<anyof-value>): New class.
+       (-anyof-parse-value,-anyof-operand-parse): New procs.
+       (-derived-operand-parse,-derived-operand-read): New procs.
+       (define-derived-operand,define-full-derived-operand): New procs.
+       (operand-init!): New reader command define-derived-operand.
+
+       * utils.scm (list-take): Handle negative amount.
+       (element?): Rewrite.
+
+1999-10-10  Doug Evans  <devans@casey.cygnus.com>
+
+       * dev.scm: quick-utils.scm renamed to ~/.cgenrc.
+
+1999-10-04  Richard Henderson  <rth@cygnus.com>
+
+       * ia64.cpu: Checkpoint.
+
+1999-09-29  Doug Evans  <devans@casey.cygnus.com>
+
+       * sim-cpu.scm (-gen-semantic-fn-table): Virtual insns are always valid.
+
+       * sim.scm (sim-finish!,x-invalid): Always set pc.  Set vpc based on
+       default-insn-bitsize.  Pass vpc to sim_engine_invalid_insn.
+
+Wed Sep 29 14:39:39 1999  Dave Brolley  <brolley@cygnus.com>
+
+       * sim.scm (sim-finish!): Don't call sim_io_error for invalid insn. Use
+       PC returned by sim_engine_invalid_insn.
+
+1999-09-28  Doug Evans  <devans@casey.cygnus.com>
+
+       * ia32.cpu: New file.
+       
+1999-09-25  Doug Evans  <devans@casey.cygnus.com>
+
+       * utils.scm (bit-set?): Fix off by one error.
+
+       * rtl-c.scm (s-sequence): Fix non-void-mode result output.
+
+       * rtl.scm (hw): Check for valid hardware element before trying to
+       get its mode.
+
+       * arm.cpu (arm7f cpu): Renamed from arm.  All users updated.
+       * arm7.cpu (bx): Fix name of target address operand in assembler spec.
+       (*): arm_compute_operand2_foo renamed to compute_operand2_foo.
+       * thumb.cpu (*): arm_compute_operand2_foo renamed to
+       compute_operand2_foo.
+
+       
+       * rtl-c.scm (<rtl-c-eval-state>): New member output-language.
+       (estate-output-language-c?,estate-output-language-c++?): New procs.
+       (<rtl-c-eval-state>,vmake!): Handle #:output-language.
+       (estate-make-for-normal-rtl-c++): New proc.
+       (rtl-c++-parsed,rtl-c++): New proc.
+       (s-c-call): Invoke cpu class method if c++.
+       (join): Use s-c-raw-call.
+
+       * rtl-c.scm (subword): Don't pass current_cpu to SUBWORD.
+       (nop): Rewrite.
+
+       * rtl-c.scm (delay): Mark the sequence as #:delay'd.
+       * rtl.scm (<eval-state>): New member `modifiers'.
+       (<eval-state>,vmake!): Handle #:modifiers.
+       (estate-with-modifiers): New proc.
+
+       * rtl.scm (rtx-side-effects?): New proc.
+       (rtx-canonical-bool): Don't change expr if it has side effects.
+       * semantics.scm (-simplify-expr-fn): Handle exprs with side-effects
+       better.
+
+1999-09-23  Doug Evans  <devans@casey.cygnus.com>
+
+       * sim.scm (gen-scache-type): Fix typo in last patch.
+
+Tue Sep 21 17:12:55 1999  Dave Brolley  <brolley@cygnus.com>
+
+       * sim.scm (gen-scache-type): Add last_insn_p flag for parallel support.
+
+1999-09-05  Doug Evans  <devans@casey.cygnus.com>
+
+       
+       * decode.scm (decode-build-table): Delete args startbit,index-list.
+       All callers updated.
+       * utils-sim.scm (gen-decoder): Delete args startbit,index-list.
+       All callers updated.
+       * sim-decode.scm (-gen-decode-fn): Always pass 0 for startbit
+       to decode-get-best-bits.
+       
+       * hardware.scm (hw-bits): New proc.
+       (-hw-parse): New arg layout.  All callers updated.
+       (define-full-hardware): New arg layout.  All callers updated.
+       (-hw-validate-layout): New proc.
+       (-hw-create-[gs]etter-from-layout): New procs.
+       (<hw-register>,parse!): Handle layout spec.
+       * types.scm (type-bits): New proc.
+
+       * sem-frags.scm (-frag-cost-compute!): Fix calculation of
+       UNARY, BINARY, TRINARY rtxs.
+
+       * attr.scm (<enum-attribute>,parse-value): Allow strings.
+       * enum.scm (parse-enum-vals): Use reverse! instead of reverse.
+       Support '- as "unused spot" indicator.
+
+1999-09-03  Doug Evans  <devans@casey.cygnus.com>
+
+       * pgmr-tools.scm (pgmr-pretty-print-insn-format): Fix typo.
+
+1999-09-02  Doug Evans  <devans@casey.cygnus.com>
+
+       * rtx-funcs.scm (subword): Fix mode spec of `value'.
+
+       * rtl.scm (-rtx-traverse-operands): Fix debugging message
+       construction.
+       (tstate-make): New arg `depth'.  All callers updated.
+       (tstate-depth,tstate-set-depth!): New procs.
+       (tstate-incr-depth!,tstate-decr-depth!): New procs.
+       (-rtx-traverse-operands): Indent debugging output by traversal depth.
+       (-rtx-traverse): Ditto.  Keep track of traversal depth.
+
+1999-09-01  Doug Evans  <devans@casey.cygnus.com>
+
+       * sim-decode.scm (-gen-decoder+supporting cast): Move to utils-sim.scm.
+       * utils-sim.scm: Decoder generator support moved here.
+       (-decode-equiv-entries?,-decode-sort-entries): New procs.
+       (-gen-decoder-switch): Sort entries for more fall-throughs.
+
+       * Makefile.am (gas-test,sim-test): Specify ISA when invoking cgen.
+       * Makefile.in: Rebuild.
+       * sim-test.scm (build-sim-testcase): Add logging message.
+       * dev.scm (cload): Recognize SIM-TEST application.
+       (load-stest): Set APPLICATION to SIM-TEST.
+
+       * desc-cpu.scm (-gen-hash-defines): Add \n to output.
+
+       * ifield.scm (-ifield-parse): Allow bit numbers up to 127.
+       * mach.scm (-isa-parse): Allow insn bitsizes from 8 to 128.
+       * mode.scm (mode-make-int,mode-make-uint): Allow values up to 64 bits.
+
+       * insn.scm (syntax-break-out): Handle ${foo}.
+
+Sun Aug 29 11:11:15 1999  Doug Evans  <devans@canuck.cygnus.com>
+
+       * Makefile.am (noinst_PROGRAMS,noinst_LIBRARIES): Delete.
+       (bin_PROGRAMS): Define.
+       (CGEN_HOB_INPUT_FILES): Remove $(srcdir)/.
+       (cgen-hob.c): Prepend $(srcdir)/ here.
+       (APPDESCFILES,OPCODESFILES,SIMFILES,pkgdata_SCRIPTS): Define.
+       (libcpu_a_SOURCES): Delete.
+       (cgen_DEPENDENCIES,cgen_LDADD): Rewrite.
+       (CGEN_HOB_OBJ,CGENOBJS): New variables.
+       * configure.in (LIBS): Replace -Wl,-rpath with -R.
+       Add AC_CHECK_LIB(guile,main).
+       * Makefile.in: Rebuild.
+       * doc/Makefile.in: Rebuild.
+       * aclocal.m4: Rebuild.
+       * config.in: Rebuild.
+       * configure: Rebuild.
+
+1999-08-28  Doug Evans  <devans@casey.cygnus.com>
+
+       Rename rtx functions from name: to name, accept optional leading
+       modifier and mode.
+       VM -> VOID, DM -> DFLT, use DFLT instead of VM for default mode.
+       * attr.scm (-attr-eval): Update.
+       * hardware.scm (hw-mode-ok?): Rename arg mode to new-mode-name.
+       (<hw-register>,mode-ok?): Disallow VOID.
+       (<hw-immediate>,mode-ok?): Disallow VOID.
+       (<hw-address>,mode-ok?): Disallow VOID.
+       * mode.scm (mode-name?): New proc.
+       (VOID): Renamed from VM.
+       (DFLT): Renamed from DM.
+       (mode-builtin!): Update.
+       * opcodes.scm (<ifield>,gen-insert): Update.
+       (<ifield>,gen-extract): Update.
+       (<multi-ifield>,gen-insert,gen-extract): Update.
+       * operand.scm (op:mode): Update.
+       (<pc>,make!): Update.
+       (op:new-mode): Update.
+       (-operand-read): Update.
+       * rtl.scm (-rtx-valid-types): Add OPTIONS, EXPLNUMMODE,
+       NONVOIDMODE, DFLTMODE.  Rename VMMODE to VOIDMODE.
+       (def-rtx-dual-mode,define-rtx-dual-mode): Delete.
+       (-rtx-lazy-sem-mode): Renamed from -rtx-mode.  All callers updated.
+       (rtx-make): Call -rtx-munge-mode&options.
+       (rtx accessors): Rewrite.
+       (rtx-pretty-name): Update.
+       (-rtx-traverse-*): Update.
+       (-rtx-traverse-explnummode,-rtx-traverse-nonvoidmode): New procs.
+       (-rtx-traverse-voidmode,-rtx-traverse-dfltmode): New procs.
+       (-rtx-make-traverse-table): Update.
+       (-rtx-traverse-operands): Update.
+       (-rtx-option?,-rtx-option-list?): New procs.
+       (-rtx-munge-mode&options): New proc.
+       (-rtx-traverse-expr): Call -rtx-munge-mode&options.
+       (-rtx-traverse): Update.
+       (rtx-traverse,rtx-traverse-with-locals,rtx-compile): Update.
+       (rtx-compile-time-constant?): Update.
+       (rtx-true?,rtx-false?,rtx-true,rtx-false): Update.
+       (rtx-value): Update.
+       (hw,reg,mem): Renamed from foo:.  Update.  All callers updated.
+       * rtx-funcs.scm (*): Update.
+       * rtl-c.scm (rtl-c-get): Update.
+       (rtl-c-set-quiet,rtl-c-set-trace): Update.
+       (s-c-call,s-c-raw-call): Update.
+       (s-boolifop,s-convop,s-if,s-cond): Update.
+       (s-case-vm,-gen-non-vm-case-test,s-case): Update.
+       (-par-replace-set-dests,-par-replace-set-srcs): Update.
+       (s-parallel,s-sequence): Update.
+       (rtl-c-build-table): Update.
+       * sem-frags.scm (-frag-hash-compute!): Update.
+       (-frag-cost-compute!): Improperly handle unary,binary,trinary ops
+       for temporary bug compatibility with previous version.
+       (-frag-expr-locals,-frag-expr-stmts): Update.
+       (-frag-compute-desired-frags,-frag-pick-best): Update.
+       * semantics.scm (-simplify-expr-fn): Update.
+       (rtx-simplify): Update.
+       (-rtx-ref-type): Update.  Account for modifiers.
+       (-build-operand!,-build-reg-operand!,-build-mem-operand!): Update.
+       (-build-ifield-operand!): Update.
+       (-build-known-values): Update.
+       (semantic-compile): Update.
+       (-gen-reg-access-defns): Update.
+       (gen-semantic-code,-gen-sem-case): Update.
+       (-gen-sfrag-code,-gen-sfrag-case): Update.
+       * sim-cpu (gen-semantic-code): Update.
+       * sim.scm (<hw-pc>,gen-write,cxmake-skip): Update.
+       (<hw-register>,gen-write,gen-set-macro,cxmake-get-raw): Update.
+       (-hw-cxmake-get): Update.
+       (<hw-memory>,cxmake-get,gen-set-quiet,gen-write): Update.
+       (<hw-index>,cxmake-get): Update.
+       (<operand>,gen-type,gen-read,cxmake-get): Update.
+       (<operand>,gen-set-quiet,gen-set-trace): Update.
+       (<pc>,cxmake-get): Update.
+       (sim-finish!): Update.
+       * utils-gen.scm (-gen-ifld-extract-base): Update.
+       (-gen-ifld-extract-beyond): Update.
+       (gen-multi-ifld-extract): Update.
+       * *.cpu: Update.
+       * simplify.inc: Update.
+
+1999-08-20  Doug Evans  <devans@casey.cygnus.com>
+
+       * sim.scm (-op-gen-queued-write): Fix memory address calculation.
+       Prefix queue function name with sim_ instead of @cpu@_.
+
+       * sim.scm (-with-parallel-only?): New global.
+       (option-init!): Initialize it.
+       (option-set!): Set it.
+       (with-parallel-only?): New proc.
+       * sim-decode.scm (-gen-decode-insn-globals): Don't include parallel
+       and writeback markers if with-parallel-only.
+       (-gen-idesc-init-fn): Update.
+       * sim-cpu.scm (cgen-cpu.h): Don't generate struct parexec if
+       with-generic-write.
+
+Wed Aug 18 15:04:30 1999  Doug Evans  <devans@canuck.cygnus.com>
+
+       * sim-cpu.scm (-gen-semantic-fn-table): Handle unsupported insns
+       with the invalid insn handler.
+
+       * utils.scm (list-maybe-ref): New proc.
+
+       * mach.scm (-isa-parse): Signal error if isa wasn't specified in
+       define-arch.
+       (-mach-parse): Signal error if mach wasn't specified in define-arch.
+
+       * i960.cpu (test*-*): Delete `expr' arg.
+       (test-op,branch-op): Update.
+
+1999-08-09  Doug Evans  <devans@casey.cygnus.com>
+
+       * sim.scm (gen-reg-getter-fn,gen-reg-setter-fn): New procs.
+       (gen-reg-access-decl): Replace `name' arg with `hw'.  All callers
+       updated.
+       (gen-reg-access-defn): Ditto.
+       (-gen-hw-addr): Rewrite.
+       (-op-gen-queued-write): Rewrite.
+       * sim-cpu.scm (-gen-cpu-reg-access-decls): 
+       (-gen-scache-semantic-fn): Handle with-generic-write.
+       (-gen-no-scache-semantic-fn): Ditto.
+
+1999-08-08  Doug Evans  <devans@casey.cygnus.com>
+
+       * utils-gen.scm (gen-define-ifmt-ifields): Tweak output.
+
+       * sim.scm (-with-generic-write?): New global.
+       (option-init!): Initialize it.
+       (option-set!): Set it.
+       (with-generic-write?): New proc.
+       (-gen-hw-addr): New proc.
+       (-op-gen-queued-write): New proc.
+       (-op-gen-set-{quiet,trace}-parallel): Use it if with-generic-write?.
+
+       * sim-cpu.scm (-gen-hardware-types): Output code with parallel support
+       turned off.
+       (-gen-sem-switch): Preserve existing with-parallel? value.
+       (-gen-sem-parallel-switch): Ditto.
+       (-gen-write-case): Add /indent support.
+       (cgen-write.c): Rewrite.
+
+       * utils.scm (-current-print-state): New global.
+       (make-print-state): New proc.
+       (pstate-indent,pstate-set-indent!): New procs.
+       (pstate-cmd?,pstate-cmd-do): New procs.
+       (/indent): New global.
+       (/indent-set,/indent-add): New procs.
+       (string-write): Set -current-print-state.
+       (-string-write): New arg pstate, all callers updated.
+       Handle print-state commands.
+       (-string-list-flatten): New proc.
+       (string-list->string): Use it.
+
+       * sim-cpu.scm (-gen-sem-fn-name): Move here from sim-decode.scm.
+       (-gen-sem-fn-table-entry): New proc.
+       (-gen-semantic-fn-table): New proc.
+       (-gen-scache-semantic-fn): Make fn static.
+       (-gen-no-scache-semantic-fn): Ditto.
+       (cgen-semantics.c): Define macro SEM_FN_NAME.
+       * sim-decode.scm (-gen-decode-insn-globals): Delete FMT,TYPE,IDX,
+       FAST,FULL.  Update @cpu@_insn_sem contents.
+       (-gen-semf-fn-name): Delete.
+       (-gen-sem-fn-decls): Delete.
+       (-gen-idesc-decls): Output prototypes of @cpu@_sem_init_idesc_table,
+       @cpu@_semf_init_idesc_table.
+       (-gen-idesc-init-fn): Update.  Don't initialize pointers to semantic
+       handlers here.
+       (cgen-decode.h): Print sfmt enum.
+       * utils-gen.scm (gen-sfmt-enum-decl): New proc.
+
+       * iformat.scm (sfmt-build): Rename sformats from fmt-foo to sfmt-foo.
+       (ifmt-compute!): Ditto.
+       * sim-decode.scm (-gen-decoder-switch): Ditto.
+       
+       * insn.scm (insn-virtual?): New proc.
+
+       * enum.scm (gen-enum-decl): Speed up, build string as list and then
+       convert to string.
+       * mach.scm (<arch>): attr-list is now a pair of lists.
+       (current-attr-list): Rewrite.
+       (current-attr-add!,current-attr-lookup): Rewrite.
+       * sim.scm (gen-cpu-insn-enum-decl): Replace append with append!.
+
+1999-08-06  Richard Henderson  <rth@cygnus.com>
+
+       * ia64.cpu: Initial checkpoint.
+
+1999-08-06  Doug Evans  <devans@casey.cygnus.com>
+
+       * pmacros.scm (-pmacro-apply): Fix definition, takes only 1 arg.
+       (pmacros-init!): Update .apply help string.
+
+1999-08-03  Doug Evans  <devans@casey.cygnus.com>
+
+       * sim.scm (-hw-gen-set-quiet-pc): Update call to SEM_BRANCH_VIA_CACHE.
+       (<hw-pc>,cxmake-skip): New method.
+       (<pc>,cxmake-skip): New method.
+       (-gen-argbuf-fields-union): Add branch_target to `chain' member.
+       (gen-argbuf-type): New member `skip_count'.
+       (sim-finish!): Update calls to @cpu@_pbb_cti_chain.
+       * utils-cgen.scm (atlist-cti?): Don't include SKIP-CTI insns.
+
+       * utils-sim.scm: New file.
+       * dev.scm (load-sim): Load it.
+       (load-sid): Load it.
+       * cgen-sid.scm: Load it.
+       * cgen-sim.scm: Load it.
+       * iformat.scm (<sformat>): New member sbuf, not initialized by
+       default make.
+       * rtx-funcs.scm (skip): Rewrite.
+       * rtl-c.scm (skip): Rewrite.
+       * m32r.cpu (sc,snc): Update `skip' usage.
+       * mode.scm (mode-real-mode): New proc.
+       * sem-frags.scm (-frag-split-by-sbuf): Rename from -frag-split-by-sfmt.
+       Distinguish fragments by the <sformat-abuf> they use.
+       * sim.scm (gen-profile-index-type): Delete.
+       (ifield argbuf support): Move to utils-sim.scm and sim-decode.scm.
+       (-gen-ifld-decoded-val): Delete, use gen-extracted-ifld-value instead.
+       (hardware argbuf support): Move to utils-sim.scm and sim-decode.scm.
+       (operand argbuf support): Move to utils-sim.scm and sim-decode.scm.
+       (-gen-argbuf-elm): Rewrite.
+       (-gen-argbuf-hw-elm): Delete.
+       (-gen-argbuf-fields-union): Generate structs for each sbuf instead
+       of each sfmt.
+       (-sim-sformat-argbuf-list,-sim-insns-analyzed?): New globals.
+       (sim-init!): Initialize them.
+       (sim-analyze-insns!): Set them.
+       (current-sbuf-list): New proc.
+       * sim-cpu.scm (-gen-no-scache-semantic-fn): Update calls to
+       gen-sfmt-op-argbuf-defns,gen-sfmt-op-argbuf-assigns.
+       * sim-model.scm (-gen-model-insn-fn): Ditto.
+       * sim-decode.scm (-gen-extract-decls): Delete.
+       (-gen-record-argbuf-ifld,-gen-trace-argbuf-ifld): New procs.
+       (<hardware-base>,gen-extract,gen-trace-extract): Move here from
+       sim.scm.
+       (<hw-register,gen-extract,gen-trace-extract): Ditto.
+       (<hw-address,gen-extract,gen-trace-extract): Ditto.
+       (-gen-op-extract,-gen-op-trace-extract): New procs.
+       (gen-sfmt-op-argbuf-defns,gen-sfmt-op-argbuf-assigns): Rename from
+       gen-sfmt-argvars-foo and rewrite.
+       (-gen-record-args): Rewrite.
+       (-gen-extract-case): Tweak.
+       
+       * cgen-gh.c (gh_putc,gh_puts): New functions.
+       * cgen-gh.h (gh_putc,gh_puts): Declare them.
+       * cos.c (_object_print_elms,_object_print): Use them.
+       * hob-sup.c (fastcall_print): Use them.
+       * configure.in: Check for scm_gen_puts, scm_puts.
+       * config.in: Rebuild.
+       * configure: Rebuild.
+       * aclocal.m4: Rebuild.
+       * Makefile.in: Rebuild.
+
+       * dev.scm (load-opc): Use load instead of maybe-load.
+       (load-gtest,load-sim,load-stest): Ditto.
+       (load-sid): Ditto.
+
+1999-07-23  Doug Evans  <devans@casey.cygnus.com>
+
+       
+1999-07-22  Doug Evans  <devans@casey.cygnus.com>
+
+       * cos.c (cos_init): Protect _make_x_symbol from garbage collection.
+
+       * read.scm: Load sem-frags.scm.
+       * sem-frags.scm (*): Lots rewritten.
+       * arm.cpu (arm isa): Enable decode-splits.
+       * arm7.cpu (multiply insns): Rename result to mul-result.
+
+       Rename decode-specialize to decode-split.
+       * decode.scm (*): Update.
+       * insn.scm (*): Update.
+       * mach.scm (*): Update.
+       
+1999-07-19  Doug Evans  <devans@casey.cygnus.com>
+
+       Record objects as a smob.
+       * cos.c (scm_tc16_object): New static global.
+       (cos_init): Initialize it.
+       (OBJECT_P,OBJECT_ELEMENTS,OBJECT_CLASS_DESC): Update macros.
+       (OBJECT_CLASS,OBJECT_ELEMENT_OFFSET): Update.
+       (_object_tag): Delete.
+       (_object_make_smob): New function.
+       (_object_make_x,_object_make_with_values_x): Rewrite.
+       (_object_elements,_object_class_desc): Rewrite.
+       (_object_copy,object_p): Rewrite.
+       (_object_specialize): Rewrite.
+       (_object_print_elms,_object_print): New functions.
+       (object_smob): New static global.
+       (default_make_x): Use OBJECT_ELEMENT_OFFSET instead of magic number.
+
+       * cos.c (_make_x_symbol): New static global.
+       (object_make): Use it.
+       (cos_init): Initialize it.
+
+1999-07-16  Doug Evans  <devans@casey.cygnus.com>
+
+       * frv.opc (CGEN_DIS_HASH_SIZE): Change to 128.
+       (CGEN_DIS_HASH): Hash on f-op ifield value.
+
+1999-07-15  Doug Evans  <devans@casey.cygnus.com>
+
+       * rtl-c.scm (ifield): Back out last patch, use estate-ifield-var?
+       instead to determine whether to use FLD macro.
+       (<rtl-c-eval-state>): New member ifield-var?.
+       (<rtl-c-eval-state>,vmake!): Recognize #:ifield-var?.
+       * utils-gen.scm (-gen-ifld-extract-base): Specify #:ifield-var? #f.
+       (-gen-ifld-extract-beyond,gen-multi-ifld-extract): Ditto.
+
+       * rtl.scm (rtx-sequence-assq-locals): New proc.
+
+       * cos.scm (-object-error): Don't crash on non-objects.
+
+       * Makefile.am (CLEANFILES): Add hobbit.
+       * Makefile.in: Rebuild.
+
+       * rtl-c.scm (s-c-call): Delete unnecessary code.
+
+1999-07-14  Doug Evans  <devans@casey.cygnus.com>
+
+       * rtl-c.scm (ifield): Always reference value via `FLD'.
+
+       * cos.c (elm_bound_p): Return problem SCM boolean values.
+
+       * utils-cgen.scm (display-argv): New proc.
+       * cgen-opc.scm (cgen): Call it.
+       * cgen-sim.scm (cgen): Ditto.
+       * cgen-gas.scm (cgen): Ditto.
+       * cgen-stest.scm (cgen): Ditto.
+       
+1999-07-05  Doug Evans  <devans@casey.cygnus.com>
+
+       * opc-asmdis.scm (-gen-parse-switch): New local var `junk'.
+       * opc-ibld.scm (-gen-insert-switch): Initialize result to NULL.
+       (-gen-extract-switch): Initialize result to 1.
+       * opcodes.scm (gen-ifield-default-type): New proc.
+       (gen-ifield-value-decl): Renamed from gen-ifield-type.  All callers
+       updated.
+       (<hw-index>,gen-insert): Handle non-ifield indices.
+       (<hw-index>,gen-extract): Ditto.
+       (<hw-asm>,gen-parse): Ditto.
+       (<hw-asm>,gen-print): Ditto.
+       (<keyword>,gen-parse): Ditto.
+       (<keyword>,gen-print): Ditto.
+       (<operand>,gen-fget): Ditto.
+       (<operand>,gen-fset): Ditto.
+
+       * sim.scm (-gen-hw-index-raw): Handle scalar indices.
+       (-gen-hw-index): Ditto.
+       
+       * sem-frags.scm: New file.
+
+       * attr.scm (attr-parse): Add better checking of input.
+
+       * hardware.scm (-hw-parse-getter): Renamed from -hw-parse-get.
+       All uses updated.
+       (-hw-parse-setter): Renamed from -hw-parse-set.  All uses updated.
+
+       * ifield.scm (ifld-nil?): New proc.
+
+       * operand.scm (<operand>): New members getter,setter.
+       (<operand>,make!): New args getter,setter.  All uses updated.
+       (op:getter,op:setter): New procs.
+       (<hw-index>,field-start): Return 0 for non-ifield indices.
+       (<hw-index>,field-length): Return 0 for non-ifield indices.
+       (-operand-parse-getter,-operand-parse-setter): New procs.
+       (-operand-parse): New args getter,setter.  All callers updated.
+       Always use hw-index-scalar for scalar operands.
+       (-operand-read): Handle getter,setter.
+       (define-full-operand): New args getter,setter.  All uses updated.
+       * semantics.scm (-build-ifield-operand!): Update.
+       (-build-index-of-operand!): Update.
+       * sim.scm (<operand>,cxmake-get): If operand has getter, use it.
+       * simplify.inc (define-normal-operand): Update.
+
+       * rtl.scm (abs,sqrt,cos,sin,min,max,umin,umax): New rtx fns.
+       * rtl-c.scm (s-unop): Indirect fp ops through fpu op vector.
+       (s-binop,s-cmpop,s-convop): Ditto.
+       (abs,sqrt,cos,sin,min,max,umin,umax): New rtx fns.
+       * sparc.cpu (insn-fmt2): Add FPOPS1,FPOPS2.
+       (fcc-tests): New insn-enum.
+       (fcc-value): Rename from fcc-type.
+       * sparcfpu.cpu: New file.  All fp support moved here.
+
+       * rtl.scm (<rtx-func>): New member class.
+       (rtx-class-*?): New procs.
+       (def-rtx-node): New arg class.  All callers updated.
+       (def-rtx-syntax-node,def-rtx-operand-node,def-rtx-dual-node): Ditto.
+       * rtx-funcs.scm (*): Specify class.
+
+       * utils-cgen.scm (context-make-reader): New proc.
+
+       * utils.scm (assert-fail-msg): New variable.
+       (assert): Use it.
+       (list-drop,list-tail-drop): New procs.
+
+1999-06-22  Doug Evans  <devans@casey.cygnus.com>
+
+       * desc-cpu.scm (-gen-hash-defines): Restore generation of
+       CGEN_MIN_INSN_SIZE deleted on March 22.
+
+       * ifield.scm (<ifield>,needed-iflds): New method.
+       (<multi-ifield>,needed-iflds): New method.
+       (ifld-needed-iflds): New proc.
+       (multi-ifield?): New proc.
+       * iformat.scm (<sfmt>): Delete member ifmt.  New members length,iflds.
+       (-sfmt-search-key): Include insn length in key.
+       (-sfmt-order-iflds,-sfmt-used-iflds): New procs.
+       (<fmt-desc>): Delete members ifmt-key,sfmt-key.  New member used-iflds.
+       (-ifmt-lookup-ifmt!): Compute key here.
+       (-ifmt-lookup-sfmt!): Compute key here.  Delete arg ifmt.
+       All callers updated.
+       (ifmt-build): Delete arg desc.  New args search-key,iflds.
+       All callers updated.
+       (sfmt-build): Delete args desc,ifmt.  New args search-key,cti?,
+       in-ops,out-ops,sorted-used-iflds.  All callers updated.
+       * minsn.scm (minsn-make-alias): Use insn-set-ifmt!.  Update call
+       to ifmt-build.
+       * operand.scm (op-iflds-used): New proc.
+       * utils-gen.scm (gen-ifld-type): Move here from sim.scm
+       and sim-cpu.scm.
+       (gen-ifld-extract-decl,-gen-ifld-extract-base): Ditto.
+       (-gen-extract-word,-gen-ifld-extract-beyond): Ditto.
+       (gen-ifld-extract,gen-multi-ifld-extract): Ditto.
+       (gen-extracted-ifld-value): Ditto.
+       (-extract-chunk-specs): Ditto.
+       (gen-define-ifields,gen-define-ifmt-ifields): Ditto.
+       (-extract-chunk,-gen-extract-beyond-var-list): Ditto.
+       (gen-extract-ifields,gen-extract-ifmt-ifields): Ditto.
+       (-extract-insert-subfields): New function.
+       * sim.scm (gen-record-argbuf-ifld): Renamed from gen-ifld-extract.
+       (gen-record-argvar-ifld): Renamed from gen-ifld-extract-argvar.
+       * sim-cpu.scm (-gen-extract-ifmt-macro): Replace calls to
+       gen-define-ifields with gen-define-ifmt-ifields.  Ditto for
+       gen-extract-foo.
+       (-gen-no-scache-semantic-fn): Ditto.
+       (-gen-sem-case): Ditto.
+       (-gen-read-case): Update calls to gen-define-ifields,
+       gen-extract-ifields.
+       * sim-decode.scm (-gen-record-args): Update.
+       (-gen-sfmt-argvars-assigns): Update.
+       (-gen-extract-case): Update.
+       * sim-model.scm (-gen-model-insn-fn): Replace calls to
+       gen-define-ifields with gen-define-ifmt-ifields.  Ditto for
+       gen-extract-foo.
+       
+1999-06-18  Doug Evans  <devans@casey.cygnus.com>
+
+       
+       * rtl.scm (-rtx-traverse): Output symbol shortcuts in source form,
+       (operand name) not (operand object), (local name) not (local object).
+       (rtx-traverse-with-locals): New proc.
+       (-compile-expr-fn): New proc.
+       (rtx-compile): Rewrite.
+       * rtl-c.scm (rtl-c-get): Handle operand/local names for src arg.
+       (rtl-c-set-quiet): Don't accept operand/local names for dest arg.
+       (rtl-c-set-trace): Ditto.
+       (operand define-fn): Recognize operand name argument.
+       (local define-fn): Recognize sequence temp name argument.
+       * rtx-funcs.scm (operand): Argument is operand name, not object,
+       so call current-op-lookup.
+       (local): Similarily, so call rtx-temp-lookup.
+
+       * rtl.scm (rtx-field?): Use rtx-name instead of car.
+       (rtx-operand?): Ditto.
+       (rtx-pretty-name): Ditto.
+       (rtx-local-obj): Flag symbol argument as an error.
+       (rtx-local-name): New proc.
+       (rtx-sequence-locals,rtx-sequence-exprs): New procs.
+
+       * rtl.scm (-rtx-traverse-operands): Fix debugging output of arg-types.
+
+       * read.scm (debug-repl): Renamed from -debug-repl.  All callers
+       updated.
+
+       * arm7.cpu (do-word/byte-store): Use (trunc: QI rd) rather than
+       (and: QI rd #xff).
+
+       * hobbit.scm (*reckless-s->c-fun-table*): Add fastcall4, fastcall6.
+       (*floats-s->c-fun-table*): Ditto.
+       * hobbit.c,hobbit.h: Rebuild.
+       * rtl.scm (-rtx-traverse-expr): Use fastcall6.
+       * semantics.scm (rtx-simplify): Use /fastcall-make.
+
+       * iformat.scm (-sfmt-search-key): Don't include memory modes.
+
+       * insn.scm (<insn>): Delete members condition, compiled-condition.
+       (<insn>,make!): Update
+       (<insn> getters,setters): Update.
+       (-insn-parse,insn-read,define-full-insn): Update.
+       * minsn.scm (minsn-make-alias): Update.
+       * iformat.scm (ifmt-analyze): Delete insn-condition reference.
+       (ifmt-compute!): Ditto.
+       * sim.scm (sim-finish!): Update.
+       * simplify.inc: (define-normal-insn): Update.
+       
+       * iformat.scm (-ifmt-lookup-ifmt!): Use insn-set-ifmt!.
+       (-ifmt-lookup-sfmt!): Use insn-set-sfmt!.
+       (ifmt-compute!): Ditto.
+
+1999-06-16  Doug Evans  <devans@casey.cygnus.com>
+
+       * minsn.scm (minsn-compute-iflds): Print better error message for
+       missing ifields.
+
+1999-06-12  Doug Evans  <devans@casey.cygnus.com>
+
+       * rtl.scm (tstate->estate): Don't copy over expr-fn.
+
+       * Makefile.am (HOBFLAGS): New variable.
+       (cgen-hob.c): Use it.
+       (hobbit.c): Use it.
+       (libcpu_a_SOURCES): Add hob-sup.c.
+       (hob-sup.o): New rule.
+       * Makefile.in: Rebuild.
+       * cgen.c: #include hob-sup.h.
+       (cgen_init_c): Call hobbit_init_support.
+       * hobbit.scm (*fastcall-make*,*c-symbol*): New variables.
+       (*special-scm->c-functions*): Add them.
+       (display-c-expression): Handle *c-symbol*.
+       (*reckless-s->c-fun-table*): Add *fastcall-make*, fastcall5.
+       (*floats-s->c-fun-table*): Ditto.
+       (normalize): Recognize /fastcall-make.
+       (normalize-fastcall-make): New proc.
+       * hobbit.c,hobbit.h: Rebuild.
+       * hob-sup.scm: New file.
+       * hob-sup.c: New file.
+       * hob-sup.h: New file.
+       * read.scm: Load hob-sup.scm.
+       * rtl.scm (-rtx-name-list): New variable.
+       (rtx-name-list): New proc.
+       (rtx-lookup): Try symbol first.
+       (def-rtx-node): Add name to -rtx-name-list.
+       (def-rtx-syntax-node,def-rtx-operand-node,def-rtx-macro-node): Ditto.
+       (-rtx-traverse-anymode): New proc.
+       (-rtx-traverse-{emode,intmode,floatmode,nummode,vmmode}): New procs.
+       (-rtx-traverse-{rtx,setrtx,testrtx,condrtx,casertx}): New procs.
+       (-rtx-traverse-{locals,env,attrs,symbol,string,number}): New procs.
+       (-rtx-traverse-{symornum,object}): New procs.
+       (-rtx-make-traverse-table): Rewrite.
+       (-rtx-traverse-operands): Rewrite arg-types handling.
+       Handle #f result of traverser.
+       (-rtx-traverse): Renamed from -rtx-traverse-normal.
+       Move debug handling here.
+       (-rtx-traverse-debug): Delete.
+       (rtl-finish!): Change -rtx-traverse-table into list of handlers
+       for each rtx.
+       * semantics.scm (semantic-compile:process-expr!): Fix call to
+       -rtx-traverse.
+       * utils.scm (map1-improper): New proc.
+
+1999-06-08  Doug Evans  <devans@casey.cygnus.com>
+
+       * arm.sim (h-tbit): Replace FUN-ACCESS with FUN-SET.
+       (h-mbits): Ditto.
+       
+1999-06-07  Doug Evans  <devans@casey.cygnus.com>
+
+       * thumb.cpu (dnti): Delete timing spec.
+       (all insn): Update.
+
+       * arm.cpu (arm isa): New fields condition, setup-semantics.
+       (thumb isa): New field setup-semantics.
+       (h-gr): Add attribute CACHE-ADDR.
+       * arm7.cpu (dnai): Delete condition.
+       (eval-cond): Delete.
+
+       * mach.scm (<isa>): New member setup-semantics.
+       (-isa-parse-setup-semantics): New proc.
+       (-isa-parse): New arg setup-semantics.
+       (-isa-read): Recognize setup-semantics.
+
+       * utils-cgen.scm (obj-set-name!): New proc.
+
+       * attr.scm (-attr-eval): Rewrite calls to rtx-simplify/rtx-compile.
+       * iformat.scm (ifmt-analyze): Pass `insn' to semantic-compile,
+       semantic-attrs.
+       (ifmt-compute!): Delete arg `arch'.  Result is list of iformats,
+       sformats.
+       * mach.scm (arch-analyze-insns!): Update call to ifmt-compute!.
+       * rtl-c.scm (rtl-c-get): Use DM for default mode instead of VM.
+       Avoid infinite loop when rtx-eval-with-estate leaves expr alone.
+       (attr): Rewrite test for insn owner.
+       (member): New rtx function.
+       * rtl.scm (rtx-* accessors): Define as cxr directly rather than
+       as separate function.
+       (rtx-ifield?,rtx-ifield-name): New procs.
+       (rtx-operand-obj): Rewrite.
+       (rtx-operand-name): New proc.
+       (rtx-cmp-op-mode,rtx-cmp-op-arg): New procs.
+       (rtx-number-list-values,rtx-member-value,rtx-member-set): New procs.
+       (tstate-make): New args owner, known.  All callers updated.
+       (tstate-known-lookup): New proc.
+       (rtx-traverse): New arg owner.  All callers updated.
+       (rtx-make-bool): New proc.
+       (rtl-find-ifields): Rewrite.
+       (rtx-simplify,rtx-simplify-eq-attr-{insn,mach}): Moved to ...
+       * semantics.scm: ... here.
+       (rtx-const-equal,rtx-const-list-equal): New procs.
+       (-build-known-values): New proc.
+       (semantic-compile): New arg `insn'.  Call rtx-simplify.
+       (semantic-attrs): Ditto.
+       * rtx-funcs.scm (member,number-list): New rtx functions.
+
+       * attr.scm (attr-remove-meta-attrs-alist): Delete leading '-' in name.
+       Rewrite.  Delete arg `all-attrs'. All callers updated.
+       (attr-remove-meta-attrs): Delete leading '-' in name.  All callers
+       updated.
+       * utils-cgen.scm (gen-bool-attrs): Remove meta attrs.
+
+       * decode.scm (subdtable-add): Handle `expr' entries.
+       (exprtable-entry-make): Use vector.  Record ifields refered to by expr.
+       (exprtable-entry-*): Update.
+       (exprtable-entry-iflds): New proc.
+       (exprentry-cost): New proc.
+       (exprtable-sort,-gen-exprtable-name): New procs.
+       (exprtable-make): New arg `name'.  All callers updated.  use vector.
+       (exprtable-*): Update.
+       (-build-decode-table-entry): Don't issue collision warning if all are
+       specialized insns.  Sort exprtable entries before building table.
+
+       * read.scm (-reader-process-expanded-1): Move pretty printing of
+       input to logging level 4.
+
+       * utils.scm (string-list->string): New proc.
+
+       * insn.scm (<insn>): Define setters for ifield-assertion, condition,
+       semantics.
+       (insn-read): Delete leading '-' in name.  All callers updated.
+       (real-insn?): New proc.
+       (real-insns): Rewrite.
+       (insn-has-ifield?): New proc.
+       (insn-builtin!): Create insn attribute SPECIALIZED.
+
+       * mach.scm (<arch>): Delete member app-data.
+       (current-raw-insn-list): New proc.
+       (insn-list-car,insn-list-splice!): New procs.
+       (<decode-specialize>): New class.
+       (-isa-parse-decode-specialize): New proc.
+       (-isa-parse-decode-specializes): New proc.
+       (<isa>): New members `condition', `decode-specializes'.
+       (-isa-parse-condition): New proc.
+       (-isa-parse): New args condition, decode-specializes.
+       (-isa-read): Recognize condition, decode-specializes.
+       (-isa-add-decode-specialize!): New proc.
+       (modify-isa): New proc.
+       (isa-conditional-exec?,state-conditional-exec?): New procs.
+       (arch-init!): New reader command `modify-isa'.
+
+       * mode.scm (mode-class-signed?,mode-class-unsigned?): New procs.
+       (mode-signed,mode-unsigned?): New procs.
+
+Thu Jun  3 16:00:40 1999  Doug Evans  <devans@canuck.cygnus.com>
+
+       * types.scm (<array>): New method get-shape.
+       * hardware.scm (<hardware-base>): Forward get-shape,get-num-elms
+       onto type.
+       (hw-shape,hw-num-elms): New procs.
+       * sim.scm (<hw-register>,gen-profile-index-type): Use "unsigned short"
+       if there's more than 255 registers.
+       
+       * hardware.scm (-hw-parse): Flag as error CACHE-ADDR specified
+       with get/set specs.
+
+1999-05-10  Ben Elliston  <bje@cygnus.com>
+
+       * arm7.cpu: Remove coprocessor related fields, operands and insn
+       definitions for now. Take the undefined instruction trap instead.
+       (ldmda-wb): New instruction.
+       (ldmib-wb): Likewise.
+       (ldmdb-wb): Likewise.
+       (stmdb-wb): Likewise.
+       (stmib-wb): Likewise.
+       (stmda-wb): Likewise.
+
+1999-05-08  Doug Evans  <devans@casey.cygnus.com>
+
+       
+       * utils-cgen.scm (keyword-list->arg-list): Fix call to substring,
+       hobbit can't handle optional third arg.
+
+1999-05-07  Doug Evans  <devans@casey.cygnus.com>
+
+       * arm.cpu (h-tbit): Delete set spec.
+       (h-mbits): Don't call arm_mbits_set in set spec.
+       * arm.sim: New file.
+       * hardware.scm (modify-hardware): New proc.
+       (hardware-init!): Add modify-hardware command.
+       * utils-cgen.scm (keyword-list?): New proc.
+       (keyword-list->arg-list,arg-list-validate-name): New procs.
+       (arg-list-check-no-args,arg-list-symbol-arg): New procs.
+
+       * arm7.cpu (eval-cond): Pass pc to @cpu@_eval_cond handler.
+
+       
+       * attr.scm (obj-prepend-atlist!): New proc.
+
+       * opc-opinst.scm (cgen-opinst.c): Analyze instructions if necessary.
+
+       * sim.scm (<operand>,profilable?): Use op:type.
+
+1999-05-04  Doug Evans  <devans@casey.cygnus.com>
+
+       * utils.scm (find-index,find): Be more stack friendly.
+
+       * arm7.cpu (arith-imm-op): Compute pc before setting cpsr.
+       (bic-imm): Ditto.
+
+1999-05-01  Doug Evans  <devans@casey.cygnus.com>
+
+       * arm.cpu (h-gr-usr): New hardware element.
+       (h-gr-fiq,h-gr-svc,h-gr-abt,h-gr-irq,h-gr-und): New hardware elements.
+       (arm-mode): New keyword.
+       (h-mbits): Add set spec.
+       (h-spsr): Implement get/set specs.
+
+       * read.scm: Load slib/pp.scm, slib/genwrite.scm.
+       (-reader-process-expanded-1): Pretty print logging output.
+
+       
+       * utils-cgen.scm (context-error): Accept variable number of
+       trailing args.
+
+       * rtx-funcs.scm (error:): New rtx function.
+       * rtl-c.scm (s-case-vm): New proc.
+       (-gen-non-vm-case-get,s-case-non-vm): New procs.
+       (s-case): Simplify, handle non-VM result.
+       (error:): New rtx function.
+
+1999-04-30  Doug Evans  <devans@casey.cygnus.com>
+
+       * arm.cpu (h-pc): Add set spec to zero bottom bits.
+       (test-hi,test-ls): Fix cbit handling.
+       (shift-type,h-operand2-shifttype): Move here ...
+       * arm7.cpu: ... from here.
+       (set-cond,set-cond-maybe,dnix): Delete, unused.
+       (set-zn-flags,set-logical-cc,set-add-flags,set-sub-flags): Move ...
+       * arm.cpu: ... to here.
+       * thumb.cpu (cmp,alu-cmp): Use set-sub-flags.
+       (alu-cmn): Use set-add-flags.
+       (alu-tst): Use set-zn-flags.
+       (alu-cmp): Use set-sub-flags.
+       (lsl,lsr,asr): Set condition codes.
+       (add,addi,sub,subi,mov,addi8,subi8): Ditto.
+       (alu-op): Split into three: alu-logical-op,alu-arith-op,
+       alu-shift-op.
+       (hireg-op): Split sem-fn into lo-dest-sem-fn,hi-dest-sem-fn.
+       All callers updated.
+       (sub-sp): Rename from add-sp-neg.
+       (f-lbwl-offset): Delete.
+       (f-lbwl-hi,f-lbwl-lo): New ifields.
+       (lbwl-hi,lbwl-lo): Update.
+       (bl-hi): Add 4 to pc.
+       (push-reg,pop-reg): Simplify.
+       (push,push-lr): Push registers in correct order.
+       (pop,pop-pc): Pop registers in correct order.
+       (save-reg-inc,load-reg-inc): Simplify.
+       (ldmia): Save registers in correct order.
+
+1999-04-30  Ben Elliston  <bje@cygnus.com>
+
+       * arm7.cpu (f-op-hdt): Remove; unused.
+       (f-ror-imm8-value,f-ror-imm-rotate): New fields.
+       (f-ror-imm8): New multi-ifield.
+       (f-operand2-bit7): Remove; use the generic `f-bit7' instead. All
+       callers updated.
+       (f-uimm12): New field.
+       (ror-imm8): New operand.
+       (uimm12): Likewise.
+       (hdt-offset8): Reinstate operand.
+       (offset4-hi,offset4-lo): Remove.
+       (set-cond): Remove macro; unused.
+       (set-cond-maybe): Likewise.
+       (load-word/byte): Use uimm12 operand for a true 12-bit immediate.
+       (store-word/byte): Likewise.
+       (load-halfword): Use hdt-offset8 multifield operand instead of two
+       4-bit operands that are explicitly combined by semantic code.
+       (do-halfword-store): Bug fix. Set address when not preindexing.
+       (store-halfword): Also use hdt-offset8 operand.
+       (arith-op): Avoid clobbering source registers when one of them is
+       the destination register.
+       (arith-imm-op): Likewise.
+       (tst-imm): Use ror-imm8 operand. Handle special case of rot 0.
+       (teq-imm): Likewise.
+       (ldm-p): Rename to ldmdb.
+       (stm-pw): Rename to stmdb-wb.
+       (multi-action): New macro; test reg-list bits and execute a
+       semantic fn if the bit is set.
+       (ldmda,ldmib,ldmia,ldmia-wb,ldmdb): New multiple load insns.
+       (stmdb,stmib,stmia,stmia-wb,stmda,stmdb-wb): Store insns.
+       (all insns): Use dnai entries for simplicity rather than dni.
+       (*): Use short-form of (const ..).
+
+1999-04-29  Doug Evans  <devans@casey.cygnus.com>
+
+       * rtl.scm (<rtx-func>): Rename member type to style.  Rename
+       member eval to evaluator.
+       (rtx-foo accessors): Rename from rtx:foo.  All callers updated.
+       (tstate-make): Delete arg op-fn.  All callers updated.
+       (tstate-op-fn,tstate-set-op-fn!): Delete.
+       (rtx-traverse): Delete op-fn arg.  All callers updated.
+       * semantics.scm (-simplify-for-compilation-process-expr): New proc,
+       split out of -simplify-for-compilation.
+
+       * Makefile.am (CGEN_NONHOB_FILES,CGENFILES): New variables.
+       (cgen_DEPENDENCIES): Add stamp-cgen.
+       (stamp-cgen): New rule.
+       * Makefile.in: Rebuild.
+
+       * rtl-c.scm (enum:): Define emitter for.
+       * rtl.scm (rtx-constant?): Rename from rtx-const? and check for
+       enums as well.
+       (rtx-constant-value,rtx-enum-value): New procs.
+       (-rtx-traverse-normal): Expand enum-value to (enum enum-value).
+       (rtx-compile-time-constant?): Return #t for enums.
+       (rtx-true?,rtx-false?): Handle enums.
+       (rtx-simplify-eq-attr-mach): Use rtx-true,rtx-false instead of
+       building result by hand.
+       (rtx-simplify-eq-attr-insn): Ditto.
+       * rtx-funcs.scm (enum:,enum): New rtx functions.
+
+       * mach.scm (<arch>): New members insns-analyzed?, semantics-analyzed?,
+       aliases-analyzed?.
+       (arch-analyze-insns!): New proc.
+       * opcodes.scm (opcodes-analyze!): Call arch-analyze-insns! instead
+       of calling ifmt-compute! directly.
+       * sim.scm (-sim-insns-analyzed?): Delete.
+       (sim-analyze!): Call arch-analyze-insns! instead of calling
+       ifmt-compute! directly.
+
+       * utils.scm (string-take-with-filler): New proc.
+       (string-take): Use it.
+
+       * pgmr-tools.scm: New file.
+       * read.scm: Load it.
+       * insn.scm (pretty-print-insn-format): Move to pgmr.scm.
+
+       * insn.scm (insn-base-mask): Renamed from insn:mask.
+       All callers updated.
+       (insn-base-mask-length): Renamed from insn:mask-length.
+       All callers updated.
+       (insn-foo): Renamed from insn:foo.  All callers updated.
+       * minsn.scm (minsn-foo): Renamed from minsn:foo.  All callers updated.
+       * iformat.scm (compute-insn-base-mask-length): Renamed from
+       compute-insn-mask-length.  All callers updated.
+       (compute-insn-base-mask): Renamed from compute-insn-mask.
+       All callers updated.
+
+       * enum.scm (-enum-parse-prefix): New proc.
+       (<enum>,make!): Don't parse enum values here.
+       (-enum-parse): Do it here.  Call -enum-parse-prefix.
+       (define-full-insn-enum): Ditto.
+       (enum-vals-upcase): New proc.
+       * hardware.scm (define-keyword): Make enum prefix uppercase.
+       * hobscmif.h (CHAR_LOWERP,CHAR_UPPERP,CHAR_WHITEP): New macros.
+
+       * ifield.scm (<ifield>,field-mask): Allow container to be #f.
+       (<ifield>,field-extract): New method.
+       (<multi-ifield>,field-extract): New method.
+       (ifld-extract): New proc.
+       * opcodes.scm (ifld-insert-fn-name): Renamed from ifld-insert.
+       (ifld-extract-fn-name): Renamed from ifld-extract.
+
+       * ifield.scm (ifld-new-value): Renamed from ifield-make.
+       All callers updated.
+
+       * ifield.scm (ifld-lsb0?): New proc.
+       (sort-ifield-list): New arg up?.  All callers updated.
+       * iformat.scm (compute-insn-mask): Get lsb0? flag from argument,
+       rather than global state.
+
+1999-04-27  Doug Evans  <devans@casey.cygnus.com>
+
+       * insn.scm (pretty-print-insn-format): New proc.
+
+       * Makefile.in: Rebuild.
+       * aclocal.m4: Rebuild
+       * configure: Rebuild.
+
+Mon Apr 26 10:30:18 1999  Doug Evans  <devans@canuck.cygnus.com>
+
+       * configure.in (AM_INIT_AUTOMAKE): Update version to 0.7.2.
+       * configure: Rebuild.
+       * aclocal.m4: Rebuild.
+       * Makefile.in: Rebuild.
+       * doc/Makefile.in: Rebuild.
+       * doc/version.texi: Rebuild.
+
+1999-04-25  Doug Evans  <devans@casey.cygnus.com>
+
+       * utils.scm (bits->bools): New proc.
+
+1999-04-23  Ben Elliston  <bje@cygnus.com>
+
+       * arm7.cpu (ldrsh-pu): Remove.
+       (do-halfword-load): New pmacro.
+       (load-halfword): Likewise.
+       (do-halfword-store): Likewise.
+       (store-halfword): Likewise.
+       (strh-*): New instructions.
+       (ldrsb-*): Likewise.
+       (ldrh-*): Likewise.
+       (ldrsh-*): Likewise.
+
+1999-04-22  Doug Evans  <devans@casey.cygnus.com>
+
+       * ifield.scm (ifld-constant?): Delete special handling of RESERVED
+       fields.
+
+       * arm7.cpu (do-word/byte-store): Fix typo.
+
+1999-04-22  Ben Elliston  <bje@cygnus.com>
+
+       * arm7.cpu (do-word/byte-load): Handle cases where the destination
+       register is the program counter (R15).
+
+       * arm7.cpu (do-word/byte-store,store-word/byte): New pmacros.
+       (str-*): Implement using store-word-byte. Remove older versions.
+       (bic): Use the `inv' rtx for obtaining bitwise complements.
+       (bic-imm): Likewise.
+       (mvn): Likewise.
+       (mvn-imm): Likewise.
+       (store-indev-reg): Remove crufty pmacro.
+       (load-indiv-reg): Likewise.
+       (ldm-p): Reverse the order of register processing for decrement.
+       (stm-p): Likewise.
+       (stbi): Remove; handled by the str-* insns.
+       
+1999-04-21  Doug Evans  <devans@casey.cygnus.com>
+
+       * thumb.cpu (cmp): Fix carry bit computation.
+       (alu-cmp): Ditto.
+
+1999-04-20  Doug Evans  <devans@casey.cygnus.com>
+
+       * arm.cpu (h-tbit): Specify set spec.
+       (h-cpsr): Ditto.
+       * arm7.cpu (bx): Don't call C routine, just set h-tbit.
+       (set-sub-flags): Interpret "carry bit" as a borrow.
+       (all sub/cmp insns): Carry bit is actually a borrow bit.
+       * thumb.cpu (bx-rs,bx-hs): Don't call C routine, just set h-tbit.
+       (add-carry,sub-carry,thumb-neg,thumb-bic,thumb-inv): Delete.  Use
+       .pmacro instead.
+       (hireg-add,hireg-cmp,hireg-move): Ditto.
+
+       * read.scm (-CGEN-VERSION): Change version to 0.7.2.
+       (-CGEN-LANG-VERSION): Ditto.
+
+1999-04-18  Doug Evans  <devans@casey.cygnus.com>
+
+       * pmacros.scm (-pmacro-make): New arg `default-values',
+       all callers updated.
+       (-pmacro-default-values): New proc.
+       (-pmacro-process-keyworded-args): New proc.
+       (-pmacro-process-args): New proc.
+       (-pmacro-invoke): Process arguments before expanding macro.
+       (-pmacro-get-arg-spec,-pmacro-get-default-values): New procs.
+       (define-pmacro): Handle default values specified in arg list.
+       * rtl.scm (rtx-alu-op-mode,rtx-alu-op-arg): New procs.
+       (rtx-boolif-op-arg[01]): New procs.
+       (rtx-true,rtx-false,rtx-canonical-bool): New procs.
+       (rtx-simplify): Handle not,orif,andif.
+       * semantics.scm (-simplify-for-compilation): Simplify not,orif,andif.
+       * utils.scm (alist-copy): New proc.
+       * arm7.cpu (do-word/byte-load,load-word/byte): New pmacros.
+       (ldr*): Rewrite.
+       (swi): Explicitly set pc.
+
+       * thumb.cpu (bx-rs,bx-hs): Reverse test for switch to arm mode.
+
+1999-04-17  Ben Elliston  <bje@cygnus.com>
+
+       * arm7.cpu (ldr-pu): Do not add 8 to R15; the step() method
+       correctly adjusts the program counter now.
+
+       * arm7.cpu (f-halfword?): Rename from `f-hdt-halfword?'.
+       (f-signed?): Rename from `f-hdt-signed?'.
+       (f-offset4-hi): Rename from `h-hdt-off4-ms'.
+       (f-offset4-lo): Rename from `h-hdt-off4-ls'.
+       (f-hdt-offset8): Use new field names.
+       (ldr): Use `imm12' field, not `offset12', since we do our own
+       address arithmetic.
+       (str, str-*): Likewise.
+       (ldu-*): Remove most; better not implemented than broken.
+       (ldrh*): Likewise.
+       (ldrsh-pu): New insn.
+       (stri): Likewise.
+       (stri-p): Likewise.
+       (stbi): Likewise.
+       (ldm-p): Likewise; replace (load-indiv-reg) version.
+
+1999-04-15  Doug Evans  <devans@casey.cygnus.com>
+
+       * arm.cpu (h-pc): Delete VIRTUAL attribute, get/set specs.
+       * arm7.cpu (*): Fix mode of result of arm_compute_carry_out_*.
+       (*): Explicitly specify mode in c-call.
+       (logical-op): Recognize sets of h-gr[15] as sets of pc.
+       (arith-op): Ditto.
+       (and-imm,orr-imm,xor-imm,mov-imm,bic-imm,mvn-imm): Ditto.
+       (arith-imm-op): New pmacro.
+       (add-imm,adc-imm,sub-imm,sbc-imm,rsb-imm,rsc-imm): Use it.
+       * thumb.cpu (bx-rs,bx-hs): Rewrite.
+
+1999-04-14  Doug Evans  <devans@casey.cygnus.com>
+
+       * rtl.scm (rtx-simplify-eq-attr-insn): Fix call to context-error.
+
+       * rtl.scm (rtl-find-ifields): Implement.
+
+       * utils-gen.scm: New file.
+       * read.scm: Load it.
+       * desc.scm: Move generic attribute code to utils-gen.scm.
+       * Makefile.am (CGEN_HOB_INPUT_FILES): Add it.
+       * Makefile.in: Rebuild.
+
+       * arm7.cpu (R15-OFFSET): New attribute.
+       (dnai): New pmacro.
+       (logical-op): Delete arg `result?'.  All callers updated.  Use dnai.
+       Delete use of eval-cond (dnai specifies it).  Specify R15-OFFSET of 12
+       for reg-shift version.
+       (arith-op): Ditto.
+       (data processing insns): Reorganize.  Use dnai.
+
+       * attr.scm (attr-kind): New proc.
+       (attr-list-enum-list): Rewrite.
+       (-attr-sort): Split result into two lists, bools and non-bools.
+       (current-attr-list-for): Update.
+
+       * thumb.cpu (bx-rs): Rename @cpu@_do_bx to @prefix@_do_bx.
+       (bx-hs): Ditto.
+       (swi): Rename @cpu@_swi to @prefix@_swi.
+
+       * decode.scm (-build-decode-table-entry): Remove heuristic for
+       distinguishing insns, and use insn ifield-assertion specs.
+
+       * desc-cpu.scm (gen-A-attr-mask): Simplify.
+       (gen-ifld-defns): Boolean attributes begin at number 0 now.
+       (gen-hw-table-defns,gen-operand-table,gen-insn-table): Ditto.
+       * opc-itab.scm (-gen-macro-insn-table): Ditto.
+       * utils-cgen.scm (gen-attr-enum-decl): Change type arg to prefix,
+       all callers updated.
+       (gen-attr-name): New proc
+       (gen-attr-mask): Use it.  Boolean attributes start at 0 now.
+       (gen-obj-attr-defn): Delete num_nonbools count.
+
+       * iformat.scm (ifmt-analyze): Handle insn-condition.
+       (ifmt-compute!): Ditto.
+       * insn.scm (<insn>): Specify default value for condition,
+       post-cond-trap,compiled-condition,compiled-semantics.
+       (<insn>,make!): New arg condition.
+       (<insn>): Add getters for condition,compiled-condition.
+       (-insn-parse): New arg condition, all callers updated.
+       (-insn-read): Recognize condition spec.
+       (define-full-insn): New arg condition.
+       * minsn.scm (minsn-make-alias): Update call to (make <insn> ...).
+       * semantics.scm (semantic-compile): Change arg sem-code to
+       sem-code-list.
+       (semantic-attrs): Ditto.
+       * sim.scm (sim-finish!): Update calls to define-full-insn.
+       * simplify.inc (define-normal-insn): Update call to define-full-insn.
+       
+Tue Apr 13 17:04:34 1999  Doug Evans  <devans@canuck.cygnus.com>
+
+       * Makefile.am (sim-cpu): Allow specification of ISA.
+       * Makefile.in: Rebuild.
+
+Sun Apr 11 00:37:56 1999  Jim Wilson  <wilson@cygnus.com>
+
+       * i960.cpu (sll-expr, srl-expr, sra-expr): Handle large shift counts.
+
+1999-04-10  Doug Evans  <devans@casey.cygnus.com>
+
+       * sparccom.cpu (check-fp-enable): Wrap TRAP32_FP_DIS in c-code.
+
+       * arm.cpu (gr-names): Put pc first so it gets prefered in disassembly.
+
+       * attr.scm (atlist?): New proc.
+       (-attr-eval): Rewrite.
+       (attr-parse): New proc.
+       (atlist-parse): Use it.
+
+       * decode.scm (exprtable-entry-make): New proc.
+       (exprtable-entry-insn,exprtable-entry-expr): New procs.
+       (exprtable-make,exprtable-insns): New procs.
+
+       * hardware.scm (hw-mode-ok?): Delete argument `set?'.
+       All uses updated.
+       (hardware-builtin!): Make h-memory a vector.
+
+       * iformat.scm (ifmt-ifields): Renamed from ifmt-fields.
+       All callers updated.
+       (ifmt-analyze): Use csem-* accessors on result of semantic-compile.
+
+       * insn.scm (<insn>). Rename ifld-assertions to ifield-assertion.
+       All uses updated.
+       (-insn-parse): Set semantics to #f if not specified.
+       (define-insn,define-full-insn): Take out code that ignores ALIAS's
+       if simulator.
+       (-parse-insn-format): Recognize `=' iformat spec.
+
+       * mach.scm (isa-min-insn-bitsize): Ignore ALIAS's.
+       (isa-max-insn-bitsize): Ditto.
+
+       * opcodes.scm (<ifield>,gen-insert): Call rtl-c instead of
+       rtl-c-with-alist.
+       (<ifield>,gen-extract): Ditto.
+       (<multi-ifield>,gen-insert,gen-extract): Ditto.
+       * sim-cpu.scm (gen-semantic-code): Rewrite.
+       * sim.scm (-gen-ifld-extract-base): Call rtl-c instead of
+       rtl-c-with-alist.
+       (-gen-ifld-extract-beyond): Ditto.
+       (<multi-ifield>,gen-ifld-extract): Ditto.
+       (<hw-register>,gen-get-macro,gen-set-macro): Ditto.
+       (<*>,cxmake-get,gen-set-quiet,gen-set-trace,gen-write): Update to new
+       rtl evaluation code.
+       (op:read): Build an <eval-state> to pass to gen-read.
+       (op:write): Build an <eval-state> to pass to gen-write.
+       (op:record-profile): Build an <eval-state> to pass to
+       gen-record-profile.
+
+       * operand.scm (<operand>): Give `selector' default value of #f.
+       Give `num' default value of -1.  Give `cond?' default value of #f.
+       (op:new-mode): Delete arg `set?', all uses updated.
+
+       * read.scm (reader-error): Handle #f return from port-filename.
+       (-init-parse-cpu!): Call rtl-c-init!.
+       (reader-install-builtin!): Call rtl-builtin!.
+
+       * rtl-c.scm: New file.
+       * semantics.scm: New file.
+       * read.scm: Load them.
+       * rtl.scm: C generation moved to rtl-c.scm.  Semantic analysis moved
+       to semantics.scm.
+       (<rtx-func>): Delete members syntax?,macro,c,expr.  New members
+       type,eval,num.
+       (rtx-lookup): Renamed from -rtx-func-lookup.  All callers updated.
+       (-rtx-num-text,-rtx-max-num): New globals.
+       (def-rtx-operand-node,define-rtx-operand-node): New procs.
+       (-rtx-macro-lookup): New proc.
+       (rtx-lvalue-mode-name): Renamed from rtx-expr-mode-name.
+       (rtx-env-stack-empty?,rtx-env-stack-head): New procs.
+       (rtx-env-var-list,rtx-env-empty-stack,rtx-env-init-stack1): New procs.
+       (rtx-env-make,rtx-env-empty?,rtx-env-make-locals): New procs.
+       (rtx-env-push,rtx-temp-lookup,-rtx-closure-make): New procs.
+       (rtx-make,rtx-kind?,rtx-const?,rtx-const-value,rtx-symbol-name,
+       rtx-operand?,rtx-operand-obj,rtx-local?,rtx-local-obj, rtx-xop-obj,
+       rtx-index-of-value,rtx-if-mode,rtx-if-test,rtx-if-then,rtx-if-else,
+       rtx-eq-attr-owner,rtx-eq-attr-attr,rtx-eq-attr-value): New procs.
+       (rtx-pretty-name): New proc.
+       (-rtx-traverser-table,-rtx-make-traverse-table): New procs.
+       (rtx-traverse-*): Rewrite rtx traversing.
+       (rtx-eval-*): Rewrite rtx evaluation.
+       (rtx-compile): New proc.
+       (rtx-simplify): New proc.
+       (rtx-simply-eq-attr-mach,rtx-simplify-eq-attr-insn): New procs.
+       * rtx-funcs.scm: C generation moved to rtl-c.scm.
+       (ifield,index-of): Rewrite.
+       (name): Renamed from `operand:'.
+       (operand,xop,local): New rtx's.
+       (current-insn): Rewrite.
+       * Makefile.am (CGEN_HOB_INPUT_FILES): Add rtl-c.scm, semantics.scm.
+       (cgen-hob.h): Remove rule for.
+       (cgen-hob.o): Depend on cgen-hob.c only.
+       * Makefile.in: Rebuild.
+
+       * utils-cgen.scm (vmake): New proc.
+       (<context>): New class.
+       (context-make-prefix,context-error): New procs.
+
+Fri Apr  9 19:26:28 1999  Jim Wilson  <wilson@cygnus.com>
+
+       * i960.cpu: Add some ??? comments.
+       (xnor, ornot): New instructions.
+       (*): Delete obsolete COND-CTI and UNCOND-CTI attributes.
+
+1999-04-08  Doug Evans  <devans@casey.cygnus.com>
+
+       * cos.scm (-object-error): Print better error message.
+
+       * pmacros.scm (-pmacro-env-make): Renamed from -env-make.
+       (-pmacro-env-ref): Renamed from -env-ref.
+
+1999-03-31  Doug Evans  <devans@casey.cygnus.com>
+
+       * hardware.scm (<hw-pc>,parse!): Allow get/set specs.
+       (h-pc): Delete.
+       (hardware-builtin!): Delete h-pc builtin.
+       * arm.cpu (h-pc): Define.
+       (h-gr): Delete get,set specs.  Make array of 16 regs again.
+       * arm7.cpu (set-logical-cc-maybe): Delete.
+       (set-zn-flags,set-add-flags,set-sub-flags): New macros.
+       (data processing insns): Rewrite.
+       * m32r.cpu (h-pc): Define.
+       * fr30.cpu (h-pc): Define.
+       * i960.cpu (h-pc): Define.
+       * sparc.cpu (h-pc): Define.
+
+       * rtl.scm (-rtx-traverse-operands): Add some error checking to LOCALS.
+       (s-parallel): Replace do {...} while (0) with {...}.
+       (s-sequence): Ditto.
+
+       
+1999-03-30  Doug Evans  <devans@casey.cygnus.com>
+
+       * sparccom.cpu (arith-cc-binop): New args s32-set-flags,s64-set-flags.
+       All callers updated.
+       (arith-carry-cc-binop): New arg set-flags.  All callers updated.
+
+       
+       * read.scm (-reader-process-expanded-1): New proc.
+       (-reader-process-expanded): Call it to catch nested begin's.
+       (reader-process): Move `begin' handling to -reader-process-expanded.
+
+       * insn.scm (-insn-read): Fix name of `format' spec.
+
+       * pmacros.scm (.pmacro): New builtin.
+       (scan-symbol): If procedure macro, return macro rather than its symbol.
+       (check-macro): Don't do lookup, instead check if (car expr) is
+       macro object.
+       (scan-list): Handle .pmacro.
+       (scan): No longer re-examine text for another macro invocation.
+       (-pmacro-build-lambda): New proc.
+       (define-pmacro): Rewrite.  If defining one pmacro to be an alias of
+       another, fetch the other's value (rather than doing it during
+       expansion).
+
+1999-03-27  Doug Evans  <devans@casey.cygnus.com>
+
+       * Makefile.am (CGEN_HOB_INPUT_FILES): Add decode.scm.
+       * Makefile.in: Rebuild.
+
+       * decode.scm (decode-get-best-bits): Use memq instead of element?.
+       (-fill-slot!): Simplify.
+       (-build-slots): Simplify.
+
+       * sim-decode.scm: Replace computed goto decoder/extractor with plain
+       switch's.
+
+1999-03-26  Doug Evans  <devans@casey.cygnus.com>
+
+       * sim-decode.scm: Clean up pass.  Move decoder computation into ...
+       * decode.scm: ... here.  New file.
+       * read.scm: Load decode.scm.
+
+       * arm.cpu (arm710 model): Add u-exec function unit.
+       (h-gr): Delete CACHE-ADDR for now.  Make array of 15, not 16 regs.
+       Add get/set specs to redirect reg 15 to h-pc.
+       (h-*): Indicate for both ARM and THUMB isas.
+       (cbit,nbit,vbit,zbit): Ditto.
+       (h-ibit,h-fbit,h-tbit,h-mbits): New hardware elements.
+       (h-cpsr): Make virtual.  Add get/set specs.
+       (h-spsr-fiq,h-spsr-svc,h-spsr-abt,h-spsr-irq,h-spsr-und): New hw.
+       (h-spsr): New virtual reg.
+       * arm7.cpu (shift-type): New explicitly defined keyword.
+       (h-operand2-shifttype): Use it.
+       (set-logical-cc-maybe): Delete carry-out arg.  New args arg1,arg2.
+       All callers updated.  Don't set cbit.
+       (logical-op): Add rm to ifield list.  Change case to case:.  Use
+       shift-type enum as case choices.  Set cbit.
+       (and,orr,eor,add-imm): Uncomment out.
+       (undefined): Temporarily comment out.
+       * thumb.scm (mov,cmp,addi8,subi8,str-sprel,ldr-sprel): s/rd/bit10-rd/.
+       (lda-pc,lda-sp): Ditto.
+       (ldr-pc): Rename from ldr.
+       (cbranch): Mark insns as being thumb insns.
+
+       * attr.scm (<bitset-attribute>,parse-value): Recognize strings.
+
+       
+       * insn.scm (<insn>,iflds): Renamed from flds.  All uses updated.
+       (<insn>,ifld-assertions): New member.
+       (<insn>,make!): New arg ifld-assertions, all callers updated.
+       (<insn> accessors): Change insn:foo to insn-foo.  All callers updated.
+       (insn:fields): Delete.
+       (-insn-parse): New arg ifld-assertions.  All callers updated.
+       (-insn-read,define-insn): New procs.
+       (define-full-insn): New arg ifld-assertions.  All callers updated.
+       (insn-init!): New comment define-insn.
+
+       * model.scm (-model-parse): Ensure at least one unit specified.
+
+       * rtl.scm (-rtx-traverse-operands): Recognize environments.
+       (<c-expr-temp>,get-name): New method.
+       (-rtx-make-current-closure,s-closure): New proc.
+       (hw:): Wrap rtx indices in a closure.
+       (-gen-case-prefix): New proc.
+       (s-case): Simplify.
+       * rtx-funcs.scm (case:): Fix call to s-case.
+       (closure): New rtx func.
+
+       * hardware.scm (<hardware-base>): New member isas-cache.
+       (<hardware-base>,get-isas): New method.
+       (hardware-builtin): Indicate for all isas.
+       * ifield.scm (-ifield-parse): Only keep if isa+mach are kept.
+       * mach.scm (current-arch-mach-name-list): Return list of names.
+       (current-isa-mach-name-list): Ditto.
+       (define-arch): Install builtin objects here.
+       * read.scm (keep-atlist?): Only keep if both mach and isa are
+       being kept.
+       (keep-mach-atlist?): New proc.
+       (keep-isa-multiple?,current-keep-isa-name-list): New proc.
+       (reader-install-builtin!): Renamed from -install-builtin!.
+       * sim.scm (sim-finish!): Specify isa of added x-* virtual insns.
+
+1999-03-22  Doug Evans  <devans@casey.cygnus.com>
+
+       * thumb.cpu (cpu,mach,model): Delete.
+       (dntf): New pmacro.  Use it for all field definitions.
+       (dntop): New pmacro.  Use it for all operand definitions.
+       (asr): Correct field list.
+       (add,addi,sub,subi,add-sp,add-sp-neg): Ditto.
+
+       * utils-cgen.scm (define-getters): New macro to simplify
+       writing class accessors.
+       (define-setters): Ditto.
+       (sanitize): Recognize isa elements.
+
+       * sim-decode.scm (-gen-decode-switch): Ditto.
+
+       * sim-arch.scm (-regs-for-access-fns): Delete.
+       (-biggest-reg-mode,-gen-arch-reg-access-decls): Delete.
+       (-gen-arch-reg-access-defns): Delete.
+
+       * sim-cpu.scm (*): Replace cpu:liw-insns with state-liw-insns,
+       cpu:parallel-insns with state-parallel-insns, cpu:parallel-exec?
+       with state-parallel=exec?.
+       (cgen-*): Call sim-analyze-insns! here.
+       * sim-decode.scm (cgen-*): Ditto.
+       * sim-model.scm (cgen-*): Ditto.
+       * sim.scm (-sim-insns-analyzed): New global variable.
+       (sim-init!): Reset it.
+       (sim-analyze-insns!): Renamed from sim-analyze!.  Keep track if we've
+       already done the analysis.
+
+       * sim-model.scm (-gen-mach-defns): Add mach attribute number to
+       MACH struct.
+
+       * arm.cpu: Only include arm7.cpu,thumb.cpu if necessary.
+       (arm arch): Update isa spec.
+       (arm,thumb isas): Define.
+       (arm7 cpu): default-insn-bitsize,base-insn-bitsize moved to isas.
+       (arm7tdmi mach): Add isa spec.
+       * arm7.cpu (*): Replace subreg: with subword:.  Remove unnecessary
+       `const' on word number.
+       * fr30.cpu (fr30 arch): Update isa spec.
+       (fr30 isa): Define.
+       (fr30bf cpu): default-insn-bitsize,base-insn-bitsize,decode-assist,
+       moved to isa spec.
+       * i960.cpu (i960 arch): Update isa spec.
+       (i960 isa): Define.
+       (i960base cpu): default-insn-bitsize,base-insn-bitsize,decode-assist,
+       liw-insns,parallel-insns moved to isas spec.
+       * m32r.cpu (m32r arch): Update isas spec.
+       (m32r isa): Define.
+       (m32rbf cpu): default-insn-bitsize,base-insn-bitsize,decode-assist,
+       liw-insns,parallel-insns moved to isa spec.
+       * sparc.cpu (sparc arch): Update isas spec.
+       (sparc isa): Define.
+       * sparc32.cpu (sparc32 cpu): default-insn-bitsize,base-insn-bitsize,
+       decode-assist moved to isa spec.
+       * sparc64.cpu (sparc64 cpu): Ditto.
+       * sparccom.cpu (trap insns): Correct mode of result of c-call:.
+       * desc-cpu.scm (-gen-isa-table-defns): New proc.
+       (-gen-mach-table-defns): Output mach table.
+       (-gen-hash-defines): Delete insn size macros, except for
+       CGEN_MAX_INSN_SIZE.
+       (-cgen-cpu-open): Rewrite cpu_open handling.  Take stdarg list of args.
+       (cgen-desc.h): Define MAX_ISAS.
+       (cgen-desc.c): Include stdarg.h.  Call -gen-isa-table-defns.
+       * mach.scm (<arch>): Rename arch-data to data.  New member isa-list.
+       (arch-* accessors): Renamed from arch:*.  All callers updated.
+       (current-arch-isa-name-list): New proc.
+       (-arch-parse-isas): Renamed from -arch-parse-isa.
+       (def-isa-attr!): Rewrite.
+       (<iframe>): New class.
+       (<itype>): New class.
+       (<isa>): Rewrite.
+       (isa-min-insn-bitsize,isa-max-insn-bitsize): New procs.
+       (isa-integral-insn?,isa-parallel-exec?): New procs.
+       (-isa-parse,-isa-read,define-isa): New proc.
+       (<cpu>): Members default-insn-bitsize,base-insn-bitsize,decode-assist,
+       liw-insns moved to <isa>.
+       (cpu-* accessors): Renamed from cpu:*.  All callers updated.
+       (-cpu-parse,-cpu-read): Update.
+       (state-*): Renamed from state:*.  All callers updated.
+       (state-default-insn-bitsize,state-base-insn-bitsize): Use isa spec,
+       not cpu.
+       (state-parallel-insns,state-parallel-exec?,state-liw-insns): New procs.
+       (state-decode-assist): New proc.
+       (<derived-arch-data>): Delete min-insn-bitsize,max-insn-bitsize.
+       (-adata-set-derived!): Rewrite.
+       (adata-integral-insn?): Renamed from adata:integral-insn?.  All
+       callers updated.
+       (arch-init!): Add define-isa command.
+       * read.scm (<reader>): Default keep-isa member to (all).
+       (reader-* accessors): Renamed from reader:*.  All callers updated.
+       (-keep-isa-set!): Call string->symbol on isa name list.
+       (keep-isa-validate!): Rewrite.
+       (current-isa): New proc.
+       (keep-isa?): Recognize "all".
+       (-init-parse-cpu!): New arg keep-isa.  All callers updated.
+       Call -keep-isa-set!.
+       (cmd-if): Recognize keep-isa?.
+       (cpu-load): New arg keep-isa.  All callers updated.
+       (-opt-spec-update): New proc.
+       (common-arguments): First arg is string, not symbol.
+       (-cgen): Call -opt-spec-update.  Rewrite argument parsing.
+       
+       * rtl.scm (rtx-get): Default mode of string arg is INT.
+
+       * rtl.scm (s-subword): Renamed from s-subreg.  All uses updated.
+
+       * rtx-funcs.scm (join:): Pass cpu to handler.
+
+       * configure.in (guile_include_dir): Delete.
+       * configure: Rebuild.
+       * Makefile.in: Rebuild.
+       * doc/Makefile.in: Rebuild.
+
+       
+1999-03-22  Ben Elliston  <bje@cygnus.com>
+
+       * arm7.cpu (ldri-p): New instruction.
+       (swi): Do not vector through 0x8 yet--there is nothing there.
+       (addi): Reinstate.
+       (movi): Likewise.
+       (all): Use (const x) in subreg expressions.
+                       
+1999-03-19  Ben Elliston  <bje@cygnus.com>
+
+       * arm7.cpu (smull): Use operand field `rs', not `mul-rn'. Thinko.
+       (smlal): Likewise.
+
+1999-03-17  Doug Evans  <devans@casey.cygnus.com>
+
+       * fr30.cpu (define-arch): Specify "forced" default-alignment.
+       * mach.scm (-parse-alignment): Recognize "forced" alignment.
+       * sim-cpu.scm (-extract-chunk-specs): New proc.
+       (gen-define-fields): Use it.
+       (-extract-chunk): New proc.
+       (-gen-extract-beyond-var-list): Use it.
+       (gen-extract-fields): Simplify.
+
+       Port to guile 1.3.1.
+       * Makefile.am (GUILEINCDIR,GUILELDFLAGS,GUILELDADD): Delete.
+       (LIBIBERTY): New var.
+       (HOB_OBJS): Add cgen-gh.o.
+       (hobbit): Delete $(CFLAGS) from link, add $(LIBS) $(LIBIBERTY).
+       * Makefile.in: Rebuild.
+       * acconfig.h: Add HAVE_3_ARG_SCM_MAKE_VECTOR.
+       * config.in: Rebuild.
+       * configure.in: Add checks for libdl, libreadline, libnsl, libsocket,
+       libncurses, libtermcap.
+       Add checks for needed functions in guile 1.2 not in guile 1.3,
+       and vice versa.  Add test for 3 argument scm_make_vector.
+       * configure: Rebuild.
+       * cgen-gh.c (scm_list_length,scm_list_append,scm_list_reverse): Provide
+       definitions if guile doesn't have them.
+       (gh_make_vector,gh_length,gh_vector_set_x,gh_vector_ref):
+       (cgh_vector): Replace gh_vector with gh_make_vector.  Replace gh_vset
+       with gh_vector_set_x.
+       (cgh_qsort): Replace gh_list_length with gh_length.
+       * cgen-gh.h: Add decls for added functions.
+       (cgh_qsort): Don't declare if IN_HOBBIT.
+       * cos.c: Include config.h.  Replace gh_vref with gh_vector_ref,
+       gh_vset with gh_vector_set_x, gh_list_length with gh_length,
+       scm_make_vector with gh_make_vector.
+       * cos.scm: Use vector-length instead of length on vectors.
+       * dev.scm (cload): Make varargs proc with keyword/value args.
+       * hobscmif.h: Include config.h, cgen-gh.h.  Undef make_vector and
+       provide version that works with guile 1.2 or 1.3.
+       Include private copy of scmhob.h.
+       * scmhob.h: New file.  Keep our own copy for now.
+
+Tue Mar 16 13:22:01 1999  Doug Evans  <devans@canuck.cygnus.com>
+
+       * rtl.scm (-rtx-traverse-error): Ensure expression is output in
+       plain text.
+       (-rtx-traverse-operands): Dump cx temp stack if debugging.
+       (-cx-temp-dump-stack): Pretty up output.
+
+       * arm.cpu: comment out thumb.cpu until isa support ready.
+       * arm7.cpu (bl): Replace lr with (reg h-gr 14).
+       (f-imm12,f-offset24,swi,undef): Fix thinko, add `const'.
+       * thumb.cpu (h-gr-t,h-lr-t,h-sp-t,dnti,h-hiregs): s/MACH/ISA/.
+
+       
+1999-03-11  Doug Evans  <devans@casey.cygnus.com>
+
+       * hardware.scm (<hw-immediate>,mode-ok?): Ensure result is boolean.
+       (<hw-address>,mode-ok?): unsigned/signed are compatible.
+
+       * operand (op:new-mode): Improve error message.
+
+       * arm.cpu: Move arm isa into arm7.cpu.  Include arm7.cpu, thumb.cpu.
+       * arm7.cpu: New file.
+
+1999-03-12  Ben Elliston  <bje@cygnus.com>
+
+       * arm.cpu: Lots of minor fixes after desk checking.
+
+1999-03-11  Doug Evans  <devans@casey.cygnus.com>
+
+       * thumb.cpu: snapshot of current work
+
+       * rtl.scm (rtx-get): Tweak error message.
+
+1999-03-10  Doug Evans  <devans@casey.cygnus.com>
+
+       * Makefile.am (cos.o,cgen.o,cgen-gh.o): Fix dependencies.
+       * Makefile.in: Rebuild.
+
+       * cos.c (cos_vector_copy): New function.
+       (_object_copy): Use it.
+
+       * mode.scm (mode:eq?): Clean up.
+       * rtl.scm (cx-new-mode): Copy attributes.
+       (rtx-get): Don't make copy if <c-expr> with identical mode.
+
+       * fr30.cpu (define-arch): Delete default-insn-word-bitsize,
+       add new isas spec.
+       (gr-names): h-gr register names moved here.
+       (h-gr): Update.
+       (cr-names): h-cr register names moved here.
+       (h-cr): update.
+       (dr-names): h-dr register names moved here.
+       (h-dr): update.
+       (h-ps): Replace FUN-ACCESS attribute with get/set specs.
+       (h-sbit,h-ccr,h-scr,h-ilm): Ditto.
+       * i960.cpu (define-arch): Delete default-insn-word-bitsize,
+       add new isas spec.
+       * m32r.cpu (define-arch): Delete default-insn-word-bitsize,
+       add new isas spec.
+       (gr-names): h-gr register names moved here.
+       (h-gr): Update.
+       (cr-names): h-cr register names moved here.
+       (h-cr): update.
+       (h-accum): Replace FUN-ACCESS attribute with get/set specs.
+       (h-accums,h-psw): Ditto.
+       * sparc.cpu (define-arch): Delete default-insn-word-bitsize,
+       add new isas spec.
+       (gr-names): h-gr register names moved here.
+       (h-gr-indices): Delete.
+       (sparc32 h-gr): Update.  Replace FUN-ACCESS with get/set specs.
+       (sparc64 h-gr): Ditto.
+       (h-y): Add get/set specs.
+       (fp regs): Rewrite.
+       (fp operands): Rewrite.
+       * sparc32.cpu (h-psr): Replace FUN-ACCESS with get/set specs.
+       (h-tbr,h-cwp,h-wim): Ditto.
+       * sparc64.cpu (h-fpsr): Add get/set specs.
+       * sparccom.cpu (ldd-reg+reg): Load value all at once.
+       (fp-ld-op): New arg `dest', all callers updated.
+       (*): Replace `make-di' with `join'.
+
+       
+       * sim-arch.scm (-regs-for-access-fns): New proc.
+       (-biggest-reg-mode): New proc.
+       (-gen-arch-reg-access-decls,-gen-arch-reg-access-defns): Rewrite.
+       * sim-cpu.scm (-gen-hardware-types): Output get/set handlers for
+       virtual regs separately.
+       (-gen-cpu-reg-access-defns): Replace fun-access? with new
+       get/set specs.
+       (gen-semantic-code): Save/restore rtl generator state.
+       (cgen-cpu.h): Call rtl-gen-init!.
+       (cgen-cpu.c): Ditto.  #include cgen-ops.h.
+       * sim-model.scm: mach:cpu renamed to mach-cpu.  mach:bfd-name
+       renamed to mach-bfd-name.
+       * sim.scm (-gen-ifld-extract-base): Update call to rtx-c-with-alist.
+       (-gen-ifld-extract-beyond): Ditto.
+       (<multi-ifield>,gen-ifld-extract): Ditto.
+       (<scalar>,gen-sym-get-macro): Update call to gen-get-macro.
+       (<scalar>,gen-sym-set-macro): Update call to gen-set-macro.
+       (all gen-read,gen-write,cxmake-get,gen-set-* methods): New arg
+       `gstate'.
+       (hw-fun-access?): Delete.
+       (-hw-gen-set-quiet-pc): New arg `gstate'.
+       (<hw-register>,gen-get-macro): Rewrite.
+       (<hw-register>,gen-set-macro): Rewrite.
+       (-hw-gen-fun-get,-hw-gen-fun-set): Delete.
+       (-hw-cxmake-get): New arg `gstate'.  Rewrite.
+       (<hw-register>,cxmake-get-raw): New method.
+       (-hw-gen-set-quiet): New arg `gstate'.  Rewrite.
+       (<hw-register>,gen-set-quiet-raw): New method.
+       (-gen-hw-index-raw): Update call to rtx-c.  Update cxmake-get
+       invocation.
+       (-gen-hw-index): Ditto.
+       (<hw-index>): New arg `gstate'.
+       (-gen-hw-selector): Update call to rtx-c.
+       (<pc>): New arg `gstate'.
+       (op:read): Update gen-read invocation.
+       (op:write): Update gen-write invocation.
+       (<operand>,cxmake-get): Handle raw-reg.
+       (-op-gen-set-quiet,-op-gen-set-quiet-parallel): New arg `gstate'.
+       (-op-gen-set-trace,-op-gen-set-trace-parallel): Ditto.
+       (<operand>,gen-set-quiet): Handle raw-reg.
+       (<operand>,gen-set-trace): Handle raw-reg.
+       (-gen-mach-data): mach:cpu renamed to mach-cpu.
+
+       * desc-cpu.scm (gen-operand-decls): Take nub of operands for
+       cgen_operand_type enum.
+       (gen-operand-table): Add operand type enum.  Replace pointer to
+       hardware element with its enum.  Null terminate table.
+       (-gen-cpu-open): Add new `isa' argument to @arch@_cgen_cpu_open.
+       Build operand table.
+       * ifield.scm (-ifield-parse): Recognize ISA attribute.
+       * mach.scm (<arch-data>): New member `isas'.
+       (adata-isas): New accessor.
+       (<isa>): New class.
+       (isa-default-insn-word-bitsize): New accessor.
+       (isa-enum): New proc.
+       (current-arch-default-insn-word-bitsize): Delete.
+       (current-isa-list,current-isa-lookup): New procs.
+       (-arch-parse-isa): New proc.
+       (-arch-parse): Rewrite.
+       (-arch-read): Recognize `isas'.  Delete `default-insn-word-bitsize'.
+       (define-arch): Define ISA attribute.
+       (def-isa-attr!,isa-supports?): New procs.
+       (<mach>): New member `isas'.
+       (mach-isas): New accessor.
+       (-mach-parse): New arg `isas', all callers updated.
+       (-mach-read): Recognize `isas'.
+       (arch-finish!): Rewrite.
+       * opc-ibld.scm (-gen-fget-switch): Add `cd' arg to
+       @arch@_cgen_get_{int,vma}_operand.
+       (-gen-fset-switch): Add `cd' arg to @arch@_cgen_set_{int,vma}_operand.
+       * opc-opinst.scm (-gen-operand-instance): Output operand enum instead
+       of pointer to table entry.
+       * opcodes.scm (gen-switch): Handle multiply defined operands.
+       * operand.scm (op-sort): New proc.
+
+       * hardware.scm (<hardware-base>): Rename getters/setters to get/set.
+       (hw-getter,hw-setter): Renamed from hw-getters,hw-setter.
+       (hw-enum): Accept symbol argument.
+       (hardware-builtin!): Delete attribute FUN-ACCESS.
+       * ifield.scm (ifld-encode-mode,ifld-decode-mode): New procs.
+
+       * attr.scm (atlist-source-form): New proc.
+       (attr-builtin!): New attr `PRIVATE'.
+       * desc.scm (<keyword>,gen-defn): Make keyword entry table static.
+       * desc-cpu.scm (-gen-hw-defn): Only output index and value tables
+       if they have `PRIVATE' attribute.
+       (gen-hw-table-defns): Output definitions of explicitly defined
+       keyword tables.
+       * hardware.scm (<keyword>): New member print-name.  Rename member
+       `value' to `values', all uses updated.
+       (kw-mode,kw-print-name,kw-prefix,kw-values): New procs.
+       (keyword-parse): Rewrite.
+       (-keyword-read): New proc.
+       (define-keyword): New proc.
+       (-hw-parse-keyword): New proc.
+       (-hw-parse-indices): Rewrite keyword handling, support new index spec
+       `extern-keyword'.
+       (-hw-parse-values): Ditto.
+       (-hw-parse-get,-hw-parse-set): Rewrite.
+       (hardware-init!): Add new comment define-keyword.
+       * mach.scm (<arch>): New member `kw-list'.
+       (arch:kw-list,arch_set-kw-list!): New accessors.
+       (current-kw-list,current-kw-add!,current-kw-lookup): New procs.
+
+       * hardware.scm (<hw-register>,mode-ok?): Rewrite.
+       * mode.scm (mode-class-integral?): New proc.
+       (mode-class-float?,mode-class-numeric?): New procs.
+       (mode-integral?,mode-float?,mode-numeric?): New procs.
+       (mode-compatible?): New proc.
+       * opcodes.scm (<ifield>,gen-insert): Update alist arg to
+       rtx-c-with-alist.
+       (<ifield>,gen-extract): Ditto.
+       * rtl.scm (-rtl-simulator?,-rtx-current-obj): Delete.
+       (<gstate>): New class.
+       (gstate-simulator?,gstate-set-simulator?!): New accessors.
+       (gstate-context,gstate-set-context!): New accessors.
+       (gstate-macro?,gstate-set-macro?!): New accessors.
+       (gstate-make,gstate-copy): New procs.
+       (-rtl-current-gstate): New global.
+       (current-gstate-simulator?): New proc.
+       (current-gstate-context,current-gstate-macro?): New procs.
+       (current-gstate,current-gstate-set!): New procs.
+       (rtl-gen-init!): Rewrite.
+       (-rtx-valid-types): Add INTMODE, FLOATMODE, NUMMODE.
+       (tstate-make): New arg `gstate', all callers updated.
+       (tstate-set-expr-fn!,tstate-set-op-fn!): New accessors.
+       (tstate-set-cond?!,tstate-set?,tstate-set-set?!): New accessors.
+       (tstate-gstate,tstate-set-gstate!): New accessors.
+       (tstate-copy): New proc.
+       (tstate-new-cond?,tstate-new-set?): Rewrite.
+       (-rtx-traverse-operands): Handle INTMODE, FLOATMODE, NUMMODE.
+       (rtx-traverse): New arg `gstate', all callers updated.
+       (rtx-strdump): New proc.
+       (-simplify-for-compilation): New arg `gstate', all callers updated.
+       (semantic-in-out-operands): Ditto.
+       (semantic-attrs): Ditto.
+       (rtx-eval): Rewrite.  New arg `gstate', all callers updated.
+       (rtx-eval-with-temps,rtx-eval-with-alist): Ditto.
+       (rtx-value): Rewrite.
+       (<c-expr>,gen-name): New method.
+       (<c-expr>,gen-set-quiet): New arg `gstate', all callers updated.
+       (<c-expr>,gen-set-trace): New arg `gstate', all callers updated.
+       (cx-new-mode): New proc.
+       (-rtx-c-with-tstate): New proc.
+       (rtx-c,rtx-c-with-temps,rtx-c-with-alist): New arg `gstate', all
+       callers updated.
+       (-rtx-mode): Rewrite.
+       (-rtx-mode-compatible?): New proc.
+       (<c-expr-temp>): New member `value'.
+       (cx-temp:value): New accessor.
+       (<c-expr-temp>,make!): Override default method.
+       (<c-expr-temp>,cxmake-get): Rewrite.
+       (<c-expr-temp>,gen-set-quiet): Rewrite.
+       (<c-expr-temp>,gen-set-trace): Rewrite.
+       (gen-temp-defs): Use cx-temp:value.
+       (record-temp!): New arg value, all callers updated.
+       (cx-temp:cx:make): Delete.
+       (-cx-temp-dump-stack): New proc.
+       (rtx-get): New arg `gstate', all callers updated.  Do mode
+       compatibility checks.  Ensure result has specified mode.
+       (rtx-set-quiet): New arg `gstate', all callers updated.
+       (rtx-set-trace): Ditto.
+       (s-c-call): New arg `tstate', all callers updated.
+       (s-c-raw-call): Ditto.
+       (s-unop,s-binop,s-binop-with-with,s-shop,s-boolifop,s-convop): Ditto.
+       (s-cmpop,s-if,e-if): Ditto.
+       (s-subreg): New proc.
+       (-par-new-temp!): New proc.
+       (-par-next-temp!): Rewrite.
+       (-par-replace-set-dests): Use -par-new-temp!.
+       (s-parallel): Rewrite temp handling.  Use -rtx-c-with-state.
+       (s-sequence): Use -rtx-c-with-state.
+       * rtx-funcs.scm (*): Update.
+       (raw-reg:): New rtx function.
+       (make-di): Delete.
+       (join:,subreg:): New rtx functions.
+
+       * insn.scm (<insn>): New members pre-cond-trap, condition,
+       post-cond-trap, compiled-condition.
+
+       * insn.scm (syntax-break-out): Replace eval with current-op-lookup.
+
+       * opcodes.scm (<pc>,cxmake-get): New arg `selector'.
+
+       * utils-cgen.scm (parse-symbol): New proc.
+       (parse-string): New proc.
+       (gen-get-macro,gen-set-macro): New arg `index-args'.
+       (gen-set-macro2): Ditto.  Enclose code in do { } while (0).
+       Prepend \ to newlines.
+
+       * utils.scm (alist-remove-duplicates): Delete.
+
+       
+1999-03-05  Ben Elliston  <bje@cygnus.com>
+
+       * arm.cpu: New file.
+
+1999-03-03  Doug Evans  <devans@casey.cygnus.com>
+
+       * Makefile.am (CGEN_HOB_INPUT_FILES): Add hardware.scm.
+       * Makefile.in: Rebuild.
+
+       * attr.scm (<integer-attribute>,parse-value-def): Tweak.
+       (-attr-parse): Validate default value.
+
+       * read.scm (-CGEN-VERSION): Change to 0.7.1.
+       (-CGEN-LANG-VERSION): Ditto.
+       (-keep-all-machs): Renamed from -keep-all, all uses updated.
+       (<reader>): New member keep-isa plus accessors.
+       (-keep-isa-set!,keep-isa-validate!): New procs.
+       (keep-isa?,keep-isa-atlist?,keep-isa-obj?): New procs.
+       (common-arguments): New variable.
+       (cgen-usage,getarg,catch-with-backtrace,option-arg): New procs.
+       (-debug-repl,continue): New procs.
+       (-cgen,cgen): New procs.
+       * cgen-gas.scm: Rewrite.
+       * cgen-opc.scm: Rewrite.
+       * cgen-sim.scm: Rewrite.
+       * cgen-stest.scm: Rewrite.
+
+       * gas-test.scm (gas-test-init!): Call opcodes-init!.
+       (gas-test-finish!): Call opcodes-finish!.
+       (gas-test-analyze!): Call opcodes-analyze!.
+       (<hw-asm>): New method test-data.
+       (<operand>,testdata): Rewrite.
+       * sim-test.scm (sim-test-init!): Call opcodes-init!.
+       (sim-test-finish!): Call opcodes-finish!.
+       (sim-test-analyze!): Call opcodes-analyze!.
+       (<hw-asm>): New method test-data.
+       (<operand>,testdata): Rewrite.
+
+1999-03-01  Doug Evans  <devans@casey.cygnus.com>
+
+       * fixup.scm (reverse!): Define if missing.
+       * *.scm: Use reverse! instead of list-reverse!.
+
+       * utils.scm (leading-id-char?): New proc.
+       (id-char?): Rewrite.
+       (chars-until-delimiter): New proc.
+       * opc-itab.scm (extract-syntax-operands): Rewrite.
+       (strip-mnemonic): Rewrite.
+       (compute-syntax): Rewrite.
+
+       * pmacros.scm (-pmacro-substr): New proc.
+       (pmacros-init!): Add builtin .substr.
+
+1999-02-26  Doug Evans  <devans@casey.cygnus.com>
+
+       * thumb.cpu: New file.
+
+1999-02-24  Doug Evans  <devans@casey.cygnus.com>
+
+       * Makefile.am (CGENCFLAGS): New variable.
+       (WITH_HOBBIT): Use automake conditional.
+       (CGEN_HOB_SRC): New variable.
+       (libcpu_a_SOURCES): Use $(CGEN_HOB_SRC).
+       (*.o): Compile with CGENCFLAGS.
+       (cgen-hob.c): Simplify.
+       (cgen-nohob.c): New rule.
+       (hobbit): Renamed from hob.x.
+       (CLEANFILES): Add cgen-nohob.c.
+       * Makefile.in: Rebuild.
+       * doc/Makefile.in: Rebuild.
+       * configure.in (AM_INIT_AUTOMAKE): Update CGEN version to 0.7.1.
+       (WITH_HOBBIT): Use AM_CONDITIONAL.
+       * configure: Rebuild.
+       * aclocal.m4: Rebuild.
+
+       * sim-arch.scm (-gen-arch-reg-access-defns): Replace string-map
+       with string-write-map.
+
+       * sim-cpu.scm (hw-need-storage?): New proc.
+       (-gen-hardware-types): Use it.
+       (gen-parallel-exec-elm): Call op-save-index?.
+
+       * sim-decode.scm (cgen-decode.c): Call rtl-gen-init!.
+
+       * sim.scm (-gen-ifld-extract-base): Use mode:class instead of
+       UNSIGNED attribute.
+       (-gen-ifld-extract-beyond): Ditto.
+       (<integer>): Delete all references.
+       (<sim-hardware>): Delete.
+       (hw-profilable?): New proc.
+       (<hardware-base>): New methods gen-get-macro,gen-set-macro.
+       (<hw-register>): Rename method get-index-mode to save-index?.
+       (<hw-register>): New methods gen-get-macro,gen-set-macro.
+       (<hw-register>,gen-sym-decl): Make virtual.
+       (<hw-memory>,gen-sym-decl): Make virtual.
+       (<hw-memory>): Rename method get-index-mode to save-index?.
+       (<hw-address>,gen-sym-decl): Make virtual.
+       (<operand>): New method save-index?.
+       (sim-init!): Delete calls to sim-hw-init!,sim-hw-init-parsers!.
+
+       * opc-itab.scm (opc-{parse,insert,extract,print}-handlers): opc-
+       prefix added.  All uses updated.
+
+       * opc-opinst.scm (-gen-operand-instance): Output hw enum value
+       rather than pointer to table entry.
+
+       * opcodes.scm: Remove all attribute support, lives in desc.scm.
+       Remove all hw-asm,op-asm support.
+       (-gen-parse-number,-gen-parse-address): New procs.
+       (<keyword>,gen-parse): Redo function name computation.
+       (<keyword>,gen-print): Ditto.
+       (<operand>,gen-function-name): Rewrite.
+       (<operand>,gen-fget,gen-fset,gen-parse,gen-print): Ditto.
+       (opcodes-init!): Delete call to add-parser!.
+
+       * desc-cpu.scm (gen-hw-decls): Rename enum hw_type to cgen_hw_type.
+       Define enum using hardware semantic name.
+       (-gen-hw-decl,-gen-hw-defn): New procs.
+       (gen-hw-table-decls): Use -gen-hw-decl.
+       (gen-hw-table-defns): Use -gen-hw-defn.  Rewrite generation of
+       CGEN_HW_ENTRY structs.
+       (gen-operand-table): Output hw's enum, not pointer to table entry.
+       (-gen-cpu-open): Build table of selected hardware elements.
+
+       * desc.scm (-hw-asm-specs,-parse-hw-asm): Delete.
+       (<hardware> support): Delete.
+       (<hw-asm>): Delete, moved to hardware.scm.
+       (normal-hw-asm,hw-asm:parse,hw-asm:print): Delete.
+       (<hw-asm>,gen-table-entry): New method.
+       (<hw-asm>,parse!): Delete.
+       (<keyword>,gen-table-entry): New method.
+       (<keyword>,parse!): Delete.
+       (<hw-{register,memory,immediate,address}>): Delete forwarding methods
+       for gen-decl,gen-defn,gen-ref,gen-init.
+       (desc-init!): Don't create parser for operand asm specs.
+
+       * attr.scm (attr-builtin!): Delete UNSIGNED attribute.
+       * ifield.scm (<ifield>): New member `mode'.
+       (<ifield>,make!): New arg `mode'.
+       (ifld-mode): Rewrite.
+       (ifld-hw-type): Rewrite.
+       (<ifield>,min-value): Rewrite.
+       (<ifield>,max-value): Rewrite.
+       (-ifield-parse): New arg `mode'.
+       (-ifield-read): Update.
+       (define-full-ifield): New arg `mode'.
+       (define-full-multi-ifield): Ditto.
+       (-multi-ifield-parse): Ditto.
+       (-multi-ifield-read): Update.
+       (define-full-multi-ifield): New arg `mode'.
+       (ifield-builtin!): Update definition of f-nil.
+       * simplify.inc (define-normal-ifield): Update call to
+       define-full-ifield.
+       (define-normal-multi-ifield): Update call to define-full-multi-ifield.
+       (define-normal-hardware): Delete arg asm.  New args indices, values,
+       handlers.  Update call to define-full-hardware.
+       (define-simple-hardware,dsh): New pmacros.
+       (define-normal-operand): Update call to define-full-operand.
+       * fr30.cpu (f-*): Delete UNSIGNED attribute.  Default is now UNSIGNED.
+       Specify INT/UINT mode instead.
+       (h-gr,h-cr): Use "indices" instead of "asm".
+       (h-dr,h-ps): Update keyword syntax.
+       (h-r13,h-r14,h-r15): Ditto.
+       (h-nbit,h-zbit,h-vbit,h-cbit): Use dsh instead of dnh.
+       (h-d0bit,h-d1bit,h-ibit,h-sbit,h-tbit,h-ccr,h-scr,h-ilm): Ditto.
+       (m4): Fix typo on HASH-PREFIX.  Use "handlers" instead of "asm".
+       (reglist_low_ld,reglist_hi_ld,reglist_low_st,reglist_hi_st): Ditto.
+       * i960.cpu (f-*): Delete UNSIGNED attribute.  Default is now UNSIGNED.
+       Specify INT/UINT mode instead.
+       (h-gr): Use "indices" instead of "asm".
+       (h-cc): Update keyword syntax.
+       * m32r.cpu (f-*): Delete UNSIGNED attribute.  Default is now UNSIGNED.
+       Specify INT/UINT mode instead.
+       (h-hi16,h-slo16,h-ulo16): Update.
+       (h-gr,h-cr): Use "indices" instead of "asm".
+       (h-accum,h-cond,h-psw,h-bpsw,h-bbpsw,h-lock): Use dsh instead of dnh.
+       (h-accums): Update keyword syntax.
+       (hash,hi16,slo16,ulo16): Use "indices" instead of "asm".
+       * sparc.cpu (f-*): Delete UNSIGNED attribute.  Default is now UNSIGNED.
+       Specify INT/UINT mode instead.
+       (h-gr-indices): New pmacro.
+       (h-gr32,h-gr64): Split up from h-gr.
+       (h-a): Update type spec.  Use values instead of asm spec.
+       (h-icc-[cnvz],h-xcc-[cnvz]): Use dsh instead of dnh.
+       (h-y,h-annul-p): Ditto.
+       (h-asr): Update keyword spec.
+       (h-lo10,h-lo13,h-hi22): Update.
+       (get-freg-spec,set-freg-spec): New pmacros.
+       (h-fr32,h-fr64): Split up from h-fr.
+       (rdd): Comment out get/set specs.
+       (lo10,lo13,hi22): Use "handlers" instead of "asm".
+       * sparc32.cpu (h-psr): Use dsh instead of dnh.
+       (h-s,h-ps,h-pil,h-et,h-tbr,h-cwp,h-ag,h-ec,h-ef,h-fsr): Ditto.
+       * sparc64.cpu (f-*): Delete UNSIGNED attribute.  Default is now
+       UNSIGNED.  Specify INT/UINT mode instead.
+       (h-*): Use dsh instead of dnh where appropriate.
+       (h-ixcc): Update type spec.  Use "values" instead of "asm".
+       (h-p,h-membarmask): Ditto.
+       (membarmask): Use "handlers" instead of "asm".
+
+       * hardware.scm (<hardware-base>): New member sem-name,type,indices,
+       values,handlers,getters,setters plus accessors.
+       (hw-mode-ok?,hw-default-mode): New procs.
+       (<hardware-base>): Rename method new-mode to mode-ok?
+       (<hardware-base>): New method get-index-mode.
+       (hw-index-mode): New proc.
+       (pc?): Delete, moved to operand.scm.
+       (address?): New proc.
+       (<hardware>): Delete.
+       (<hw-asm>): Definition moved here from desc.scm.
+       (keyword-parse): New proc.
+       (hardware-parsers): Delete.
+       (-parse-hw-type,-parse-hw-asm,-parse-hw-profile): Delete.
+       (-hw-parse-indices,-hw-parse-values,-hw-parse-handlers): New procs.
+       (-hw-parse-get,-hw-parse-set): New procs.
+       (-hw-parse): Delete args aasm,profile,extra.  New args semantic-name,
+       indices,values,handlers,get,set.  Rewrite.
+       (-hw-read-extra): Delete.
+       (-hw-read): Update.
+       (define-hardware): Don't add object if not selected.
+       (define-full-hardware): Ditto.
+       (current-hw-sem-lookup,current-hw-sem-lookup-1): New procs.
+       (<hw-register>): Member `type' moved to baseclass.  Delete member
+       hw-asm.
+       (<hw-register>,parse!): Rewrite.
+       (<hw-register>): Delete methods get-rank,get-mode.
+       (<hw-register>): Method new-mode renamed to mode-ok?
+       (<hw-register>): New method get-index-mode.
+       (<hw-pc>,parse!): Rewrite.
+       (<hw-memory>): Member `type' moved to baseclass.  Delete member hw-asm.
+       (<hw-memory>,parse!): Rewrite.
+       (<hw-memory>): Delete methods get-rank,get-mode.
+       (<hw-memory>): Method new-mode renamed to mode-ok?
+       (<hw-memory>): New method get-index-mode.
+       (<hw-immediate>): Member `type' moved to baseclass.  Delete member
+       hw-asm.
+       (<hw-immediate>,parse!): Rewrite.
+       (<hw-immediate>): Delete methods get-rank,get-mode.
+       (<hw-immediate>): Method new-mode renamed to mode-ok?
+       (<hw-address>): Delete member hw-asm.
+       (<hw-address>,parse!): Rewrite.
+       (<hw-address>): Delete methods get-rank,get-mode.
+       (<hw-address>): Method new-mode renamed to mode-ok?
+       (hw-profilable?): Delete.
+       (hardware-init!): Delete hardware-parsers reference.
+       Update argument specs of command define-full-hardware.
+       (hardware-builtin!): Update definitions of hardware builtins.
+       * operand.scm (<operand>): New members hw-name,mode-name.
+       Delete member op-asm.  New member handlers.
+       (<operand>,make!): Update.
+       (op:hw-name,op:mode-name,op:handlers): New procs.
+       (op:type): Rewrite.
+       (op:mode): Rewrite.
+       (<operand>): New method get-index-mode.
+       (<pc>,make!): Update.
+       (op:new-mode): Rewrite.
+       (operand-parsers): Delete.
+       (-operand-parse): Rewrite.  Return #f if insn not selected.
+       (-op-read-extra): Delete.
+       (-operand-read): Update.
+       (define-operand,define-full-operand): Update.
+       (operand-init!): Delete operand-parsers reference.
+       Update syntax of define-full-operand command.
+
+       * insn.scm (-insn-parse): Rewrite.  Return #f if insn not selected.
+       (define-full-insn): Update.
+       * minsn.scm (-minsn-parse): Rewrite.  Return #f if insn not selected.
+       (define-full-minsn): Update.
+
+       * mode.scm (<mode>): New member class.
+       (mode:class): New proc.
+       (mode?): Rewrite.
+       (-mode-parse): New arg class.
+       (define-full-mode): Update.
+       (mode-find): Rewrite.
+       (mode-make-int,mode-make-uint): New procs.
+       (mode-init!): Update syntax of define-full-mode command.
+       (mode-builtin!): Update definitions of builtin modes.
+
+       * model.scm (<profile>): Delete.
+
+       * read.scm (keep-atlist?): New proc.
+       (keep-multiple?): New proc.
+       (<parser-list>): Delete.
+       (add-parser!,parse-spec!): Delete.
+
+       * rtl.scm (def-rtx-node): Prepend arg *tstate* to all handlers.
+       (def-rtx-syntax-node): Ditto.
+       (-rtx-traverse-debug?): New variable.
+       (tstate-make): New proc.
+       (tstate-expr-fn,tstate-op-fn,tstate-cond?,tstate-set?): New procs.
+       (tstate-new-cond?,tstate-new-set?): New procs.
+       (-rtx-traverse-normal): Delete args cond?,expr-fn,op-fn.  New arg
+       tstate.  All callers updated.
+       (-rtx-traverse-expr,-rtx-traverse-debug): Ditto.
+       (-rtx-traverse-list,-rtx-traverse-operands): Ditto.
+       (-build-operand!): Replace arg cond? with tstate.
+       (-build-reg-operand!,-build-mem-operand!): Ditto.
+       (-build-index-of-operand!): Update making of <operand> object.
+       (s-ifield): New arg tstate.  All callers updated.
+       (hw:): New arg tstate.  All callers updated.  Replace call to
+       current-hw-lookup with current-hw-sem-lookup-1.
+       (s-index-of): New arg tstate.  All callers updated.
+       (reg:,mem:): Ditto.
+       (-rtx-use-sem-fn?): New proc.
+       (s-unop,s-binop,s-shop): Use it.  Only use semantic mode when using
+       semantic cover fns.
+       (s-convop): Only use semantic mode when using semantic cover fns.
+       (s-cmpop): Call -rtx-use-sem-fn?.
+       (s-cond,s-case): New arg tstate.  All callers updated.
+       (s-parallel,s-sequence): Ditto.
+
+       * rtx-funcs.scm (set,set-quiet:): Use SETRTX to mark the set dest.
+
+       * types.scm (<scalar>): Rewrite implementation.
+       (<integer>): Delete.
+       (parse-type): Rewrite.
+
+       * utils-cgen.scm (parse-handlers): New proc.
+
+       * utils.scm (!=): New proc.
+
+Tue Feb 23 12:10:29 1999  Doug Evans  <devans@canuck.cygnus.com>
+
+       * pmacros.scm (-pmacro-expand): Fix typo.
+
+1999-02-12  Doug Evans  <devans@casey.cygnus.com>
+
+       * pmacros.scm (-pmacro-hex,-pmacro-upcase,-pmacro-downcase): New procs.
+       (pmacros-init!): Install builtins .hex, .upcase, .downcase.
+       * i960.cpu (build-hex2): New pmacro.
+       (insn-opcode): Simplify.
+       (insn-opcode2): Ditto.
+
+       * cgen-sim.scm (catch-with-backtrace): Comment out debugging printf.
+       * cgen-stest.scm (catch-with-backtrace): Ditto.
+
+1999-02-11  Doug Evans  <devans@casey.cygnus.com>
+
+       * pmacros.scm (-pmacro-lookup): Renamed from -pmacro-ref.
+       All callers updated.
+       (-pmacro-invoke): New proc.
+       (-pmacro-sym,-pmacro-str): New procs.
+       (-pmacro-iota,-pmacro-map,-pmacro-apply): New procs.
+       (pmacros-init!): Install builtins .iota, .map, .apply.
+       * sparc.cpu (cc-tests): Add CC_NZ,CC_Z,CC_GEU,CC_LU aliases.
+       (h-fr): Simplify register name spec.
+       * sparc64.cpu (cond-move-1): New arg mnemonic.  All callers updated.
+       * utils.scm (num-args-ok?): New proc.
+
+1999-02-10  Doug Evans  <devans@casey.cygnus.com>
+
+       * pmacros.scm (-pmacro-error): New proc.
+       (-pmacro-expand): Use it.
+       (-pmacro-splice): New proc.
+       (pmacros-init!): Install new builtin .splice.
+
+       * sparc.cpu: Include sparc64.cpu when appropriate.
+       (f-mmask,f-simm11): Moved to sparc64.cpu.
+       (insn-fmt2): Add FLUSH,FLUSHW,IMPDEP1,IMPDEP2,MEMBAR,MOVCC.
+       (ANNUL attribute): Delete.
+       (test-* pmacros): New arg cc, all callers updated.
+       (uncond-br-sem,cond-br-sem): New arg cc, all callers updated.
+       * sparc32.cpu (atom-op): Moved to sparccom.cpu and renamed to
+       atomic-opc.
+       (ldstub,swap): Moved to sparccom.cpu.
+       * sparc64.cpu: Add more insns.
+
+1999-02-09  Doug Evans  <devans@casey.cygnus.com>
+
+       * sim-cpu.scm (cgen-semantics.c): Replace CGEN_INSN_ATTR with
+       CGEN_ATTR_VALUE.
+       (cgen-sem-switch.c): Ditto.
+       * sim-decode.scm (-gen-idesc-decls): struct idesc definition
+       moved to cgen-engine.h.
+       (-gen-insn-sem-type): Delete, struct insn_sem mvoed to cgen-engine.h.
+       (-gen-idesc-init-fn,init_idesc): Lookup insn table via descriptor, not
+       global.  Cache attributes and insn length in IDESC.
+       * sim-model.scm (-gen-cpu-defns): Generate new func @cpu@_prepare_run.
+       @cpu@_opcode renamed to @cpu@_get_idata.
+       (-gen-mach-defns,@mach@_init_cpu): Don't initialize IDESC table here,
+       done later underneath sim_resume.
+       (@mach@_mach): Record @cpu@_prepare_run.
+       * sim.scm (<hardware-base>,cxmake-get): New arg selector, all callers
+       updated.
+       (-hw-gen-set-quiet-pc): Ditto.
+       (-hw-cxmake-get,-hw-gen-set-quiet): Ditto.
+       (<hw-memory>,cxmake-get,gen-set-quiet): Ditto.
+       (<hw-addr>,cxmake-get): Ditto.
+       (<hw-iaddr>,cxmake-get): Ditto.
+       (<pc>,cxmake-get): Ditto.
+       (<operand>,cxmake-get,gen-set-quiet,gen-set-trace): Ditto.
+       (-op-gen-set-quiet,-op-gen-set-quiet-parallel): Ditto.
+       (-op-gen-set-trace,-op-gen-set-trace-parallel): Ditto.
+       (<hw-pc>,gen-write): Use hw-selector-default.
+       (<hw-register>,gen-write): Ditto.
+       (<hw-memory>,gen-write): Ditto.
+       (-gen-hw-index-raw,-gen-hw-index): Handle selector.
+       (-gen-hw-selector): New proc.
+
+       * desc.scm: New file.
+       * desc-cpu.scm: New file.
+       * opcodes.scm: Split up into several smaller files.
+       * opc-asmdis.scm: New file.
+       * opc-ibld.scm: New file.
+       * opc-itab.scm: New file.
+       * opc-opinst.scm: New file.
+       * Makefile.am (desc): New target.
+       (opcodes): Update args to cgen-opc.scm.
+       * Makefile.in: Rebuild.
+       * aclocal.m4: Rebuild.
+       * config.in: Rebuild.
+       * configure.in: Update arg to AC_INIT.
+       Update version number to 0.7.0.  Change AM_EXEEXT to AC_EXEEXT.
+       Update AC_PREREG arg to 2.13.  Change AM_PROG_INSTALL to
+       AC_PROG_INSTALL.
+       * configure: Rebuild.
+       * cgen-gas.scm: Update files to load.
+       * cgen-opc.scm: Ditto.  Reorganize option letters.
+       * cgen-sim.scm: Update files to load.
+       * cgen-stest.scm: Ditto.
+       * dev.scm (cload): New app "DESC".
+       (load-opc): Update files to load.
+       (load-gtest,load-sim,load-stest): Ditto.
+
+       * attr.scm (bool-attr?): New proc.
+       (attr-list-enum-list): New proc.
+       (-attr-sort): Rewrite.
+       (attr-builtin!): Give ALIAS attribute a fixed index.
+       * utils-cgen.scm (gen-attr-enum-decl): Call attr-list-enum-list to
+       calculate attribute enum list.
+       (gen-attr-mask): Subtract CGEN_ATTR_BOOL_OFFSET from attribute's enum.
+
+       * insn.scm (-insn-parse): Renamed from parse-insn.
+
+       * hardware.scm (-hw-parse): New arg errtxt, all callers updated.
+       (-hw-read): Ditto.
+
+       * mode.scm (-mode-parse): Renamed from parse-mode.
+
+       * operand.scm (<operand>): New member `selector'.
+       (<operand>,make!): Use default selector.
+       (hw-selector-default): New variable.
+       (hw-selector-default?): New proc.
+
+       * pmacros.scm (pmacros-init!): New proc.
+       (-pmacro-{make,name,arg-spec,transformer,comment}): New procs.
+       (-env-set!): Delete.
+       (-pmacro-expand): New proc apply-macro.
+       Use it in scan-list,scan.  Scan list first, then see if macro
+       invocation.
+       (define-pmacro): Rewrite.
+       * read.scm (-init-parse-cpu!): Call utils-init!,parse-init!.
+
+       * rtl.scm (-simplify-for-compilation): Ensure at least one mach
+       selected if (current-mach) seen.
+       (rtx?): Renamed from rtx-uneval?, all callers updated.
+       (<c-expr>,gen-set-quiet,gen-set-trace): New arg selector, all callers
+       updated.
+       (<c-expr-temp>,cxmake-get,gen-set-quiet,gen-set-trace): New arg
+       selector, all callers updated.
+       (hw:): New arg selector, all callers updated.  Delete old comments
+       and code.
+       (reg:,mem:): Handle selectors
+       * rtx-funcs.scm (reg:): Handle selectors.
+
+       * read.scm: Renamed from cpu.scm.
+       (<command>): New class.
+       (<reader>): New member commands.
+       (reader-add-command!): New proc.
+       (reader-lookup-command): New proc.
+       (reader-error,-reader-process-expanded,reader-process): New procs.
+       (reader-read-file!): New proc.
+       (include): Call reader-read-file!.
+       (cmd-if): New proc.
+       (cpu-load): Call reader-read-file!.
+       * utils.scm (num-args): New proc.
+       * simplify.inc: New file.
+       * *.scm: Delete def-foo procs.  Rewrite define-foo/define-full-foo
+       procs.  Move define-normal-foo procs (and abbreviated forms) to
+       simplify.inc.  Install define-foo/define-full-foo commands in foo-init!
+       routines.
+       * fr30.cpu: Include simplify.inc.
+       * fr30.opc: CGEN_OPCODE_DESC renamed to CGEN_CPU_DESC.
+       * i960.cpu: Include simplify.inc.
+       * m32r.cpu: Include simplify.inc.
+       * m32r.opc: CGEN_OPCODE_DESC renamed to CGEN_CPU_DESC.
+       (CGEN_PRINT_NORMAL): Use CGEN_BOOL_ATTR.
+       * sparc.cpu: Include simplify.inc.
+       * sparc.opc: CGEN_OPCODE_DESC renamed to CGEN_CPU_DESC.
+       * utils-cgen.scm (parse-error): Moved to read.scm.
+       (sanitize): Rewrite.
+       (utils-init!): New proc.
+
+1999-02-02  Doug Evans  <devans@casey.cygnus.com>
+
+       * sparc.cpu: New file.
+       * sparc32.cpu: New file.
+       * sparc64.cpu: New file.
+       * sparccom.cpu: New file.
+       * sparc.opc: New file.
+
+1999-01-27  Frank Eigler  <fche@cygnus.com>
+
+       * utils.scm (gen-copyright): New proc.
+
+1999-01-27  Doug Evans  <devans@casey.cygnus.com>
+
+       Parameterize rtl parsing, rather than having lots of little handlers.
+       * rtl.scm (<rtx-func>): New members arg-types,arg-modes.
+       Delete member traverse.
+       (rtx:set-traverse!): Delete.
+       (-rtx-valid-types,-rtx-valid-matches): New variables.
+       (-rtx-func-lookup): Take symbol or <rtx-func> object as argument
+       instead of expression.  All callers updated.
+       (def-rtx-node): New args arg-types,arg-modes.
+       (def-rtx-syntax-node): Ditto.
+       (def-rtx-dual-mode): Ditto.
+       (-rtx-macro-expand-list): Renamed from -rtx-macro-maybe-expand-list.
+       All callers updated.
+       (-rtx-macro-expand): Renamed from -rtx-macro-maybe-expand.
+       All callers updated.
+       (rtx-macro-expand): New proc.
+       (-rtx-traverse-check-args): Delete.
+       (-rtx-traverse-normal): Call -rtx-traverse-expr rather than calling
+       an rtx specific traverser.
+       (-rtx-any-mode?,-rtx-symornum?): New procs.
+       (-rtx-traverse-rtx-list,-rtx-traverse-error): New proc.
+       (-rtx-traverse-no-mode): Delete.
+       (-rtx-traverse-syntax-expr,-rtx-traverse-syntax-no-mode): Delete.
+       (-rtx-traverse-operands): Rewrite.
+       (-rtx-traverse-expr): Rewrite.
+       (rtx-traverse): Don't expand macros here, leave for caller to do.
+       (rtx-simplify): Delete.
+       (rtx-compile-time-constant?): Rewrite.  Handle FALSE/TRUE for boolean
+       attributes.
+       (rtx-true?,rtx-false?): Ditto.
+       (-rtx-ref-type): Set dest is operand 1 now.
+       (-simplify-for-compilation): New proc.
+       (semantic-in-out-operands): Recognize regno as an alias for index-of.
+       Expand macros before calling rtx-traverse.  Sort operands by name
+       to avoid unnecessary semantic formats.
+       (semantic-attrs): New proc.
+       (rtx-uneval?): Handle (<rtx-func> ...).
+       (s-boolifop): Delete arg mode.  All callers updated.
+       * rtx-funcs.scm (all non-macros): Add arg-type and arg-mode specs.
+       (eq-attr): New arg obj.
+       (eq-attr:): Delete.
+       * m32r.cpu (rach): Update calls to andif.
+
+       * minsn.scm (-minsn-parse-expansion): Renamed from
+       parse-minsn-expansion.
+       (-minsn-parse): Renamed from parse-minsn.
+       (-minsn-read): Renamed from read-minsn.
+       (def-minsn): Don't check APPLICATION here.
+       (def-full-minsn): New proc.
+       (define-macro-insn): Check APPLICATION here.  Expand macros.
+       (define-normal-macro-insn): Ditto.
+
+       * utils.scm (word-value): New arg start-lsb?.
+       (word-mask,word-extract): Ditto.
+       (split-bits,powers-of-2): Use integer-expt instead of expt.
+       (bit-set?): Handle 32 bit values (which are bignums).
+       (cg-logand,cg-logxor): New functions.
+       * ifield.scm (<ifield>,field-mask): Update call to word-mask.
+       (<ifield>,field-value): Update call to word-value.
+       (<ifield>,min-value): Use integer-expt instead of expt.
+       (<ifield>,max-value): Ditto.
+
+       * hardware.scm (<hw-register>,new-mode): Rename local mode to cur-mode.
+
+       * insn.scm (def-full-insn): Discard ALIAS insns if simulator.
+
+       Compute raw instruction format in addition to semantic based format.
+       * iformat.scm: Delete members cti?,sem-in-ops,sem-out-ops.
+       (<iformat> accessors): Rename accessors to ifmt-*.
+       (<sformat>): New class.
+       (fmt-enum): Renamed from fmt:enum.
+       (-ifmt-search-key): Rewrite.
+       (-sfmt-search-key): New proc.
+       (ifmt-analyze): Rename arg include-sem-operands? to compute-sformat?
+       Compute iformat and sformat search keys.
+       (ifmt-build): Update.
+       (sfmt-build): New proc.
+       (-ifmt-lookup-ifmt!,-ifmt-lookup-sfmt!): New procs.
+       (ifmt-compute!): Compute instruction format <iformat> based on
+       instruction fields alone.  Compute new semantic format <sformat>
+       based on instruction fields and semantic information.
+       (ifmt:lookup): Delete.
+       * mach.scm (<arch>): New member sfmt-list, plus accessors.
+       (current-sfmt-list): New proc.
+       * insn.scm (<insn>): Rename member fmt-tmp to tmp.
+       Rename member fmt to ifmt.  New members fmt-desc, sfmt.
+       (insn-length,insn-length-bytes): Update.
+       (insn:mask-length,insn:mask): Update.
+       (insn-lookup-op): Update.
+       * gas-test.scm (gas-test-analyze!): Update.
+       (gen-gas-test): Ditto.
+       * sim-test.scm (sim-test-analyze!): Update.
+       (gen-sim-test): Ditto.
+       * opcodes.scm (gen-operand-instance-table): Update.
+       (gen-operand-instance-ref): Ditto.
+       (max-operand-instances): Use heuristic if semantics not parsed.
+       (ifmt-opcode-operands): Renamed from fmt-opcode-operands.
+       (opcodes-analyze!): Only scan semantics of building operand instance
+       tables.
+       * sim-cpu.scm (*) Update calls to <iformat>/<sformat> accessors.
+       (-gen-extract-ifmt-macro): Renamed from -gen-extract-fmt-macro.
+       * sim-decode.scm (*) Update calls to <iformat>/<sformat> accessors.
+       (gen-sfmt-argvars-defns): Renamed from gen-ifmt-argvars-defns.
+       (gen-sfmt-argvars-assigns): Renamed from gen-ifmt-argvars-assigns.
+       * sim-model.scm (*) Update calls to <iformat>/<sformat> accessors.
+       * sim.scm (*) Update calls to <iformat>/<sformat> accessors.
+
+       * sim-decode.scm (usable-decode-bit?): Rename from decode-bit?
+       New arg lsb0?  All callers updated.
+       (decode-bits): New arg lsb0?.  All callers updated.
+       (opcode-slots): Update call to bit-set?.  Call integer-expt instead
+       of expt.
+       (-gen-decode-bits): New arg lsb0?.  All callers updated.
+       (build-slots): Call integer-expt instead of expt.
+       (build-decode-table-entry): Handle crossing word boundaries better.
+       (-gen-decode-switch): New arg lsb0?.  All callers updated.
+       (-gen-extract-decls): Rename decode format entry from ifmt to sfmt.
+
+       * enum.scm (define-enum): Rewrite.
+       (define-normal-enum): Ditto.
+       (def-full-insn-enum): New proc.
+       (define-normal-insn-enum): Rewrite.
+
+       * attr.scm (<bitset-attribute>,gen-value-for-defn): Ensure result is
+       valid C.
+       (<{integer,enum}-attribute>,gen-value-for-defn): Ditto.
+
+       
+       * Makefile.am (opcodes,sim-arch,sim-cpu): New targets.
+       (CLEANFILES): Add tmp-*.
+       * Makefile.in: Rebuild.
+
+       * doc/Makefile.am: New file.
+       * doc/Makefile.in: New file.
+       * doc/cgen.texi: New file.
+       * Makefile.am (SUBDIRS): Define.
+       * Makefile.in: Rebuild.
+       * configure.in: Create doc/Makefile.
+       * configure: Rebuild.
+
+1999-01-18  Doug Evans  <devans@casey.cygnus.com>
+
+       * insn.scm (insn:syn): Delete.
+
+1999-01-15  Doug Evans  <devans@casey.cygnus.com>
+
+       * fr30.cpu (model fr30-1): Add state variables load-regs,
+       load-regs-pending.  Delete h-gr.  Clean up operand names of all units.
+       * m32r.cpu (model m32r/d): Clean up operand names of u-exec.
+       (model m32rx): Ditto.
+       (addi): Simplify function unit usage spec.
+       (ld-plus): Rewrite operand names in function unit usage spec.
+       (mvtachi,mvtachi-a,mvtaclo,mvtaclo-a,st-plus,st-minus): Ditto.
+       * sim.scm (<unit>,gen-profile-code): Redo how operand names are
+       overridden.  Allow operand to appear in input and output spec.
+       (<insn>,gen-profile-code): string-append -> string-list.
+
+       * ifield.scm (define-ifield): Call pmacro-expand.
+       (define-full-ifield,define-normal-ifield): Ditto.
+       (define-multi-ifield,define-normal-multi-ifield): Ditto.
+
+       * sim.scm (gen-argbuf-type): Keep leading part of ARGBUF same for
+       with-scache and without-scache cases.
+
+1999-01-14  Doug Evans  <devans@casey.cygnus.com>
+
+       * fr30.cpu (fr30-1): Add state variable h-gr.
+       Add units u-cti, u-load, u-store, u-ldm, u-stm.
+       (all insns): First pass at providing cycle counts.
+       * sim.scm (<unit>,gen-profile-code): Only check for output operands
+       when initializing unit output operands, ditto for input operands.
+
+       * insn.scm (insn-length,insn-length-bytes): New procs.
+       * mach.scm (-adata-set-derived!): Use them.
+       * sim-cpu.scm (-gen-sem-case): Ditto.
+
+       * sim-cpu.scm (-gen-trace-record-type): PCADDR->IADDR.
+       (-gen-write-case): Ditto.
+       (gen-semantic-fn): Ditto.  Split into two:
+       -gen-scache-semantic-fn and -gen-no-scache-semantic-fn.  Fix bitrot
+       in non-scache case.
+       (-gen-all-semantic-fns): Renamed from -gen-all-semantics.  Handle
+       scache/no-scache appropriately.  All callers updated.
+       (-gen-sem-case): PCADDR->IADDR.
+       * sim.scm (gen-argbuf-type): PCADDR->IADDR.
+
+       * sim-decode.scm (*): Replace string-append,string-map with
+       string-list,string-list-map where the result is sufficiently large.
+       (-gen-decode-insn-table): Go back to simple version for non-scache
+       case: just record IDESC in decoder tables and leave field extraction
+       to the caller.
+       (-gen-decode-switch): Ditto.
+       (-gen-decode-fn): Ditto.
+       (-gen-extract-decls): Only emit format enum if with-scache?.
+       * sim-model.scm (-gen-model-insn-fn): Extract ifields here in
+       non-scache case.
+       (-gen-model-insn-fns): Don't emit model fns for virtual insns.
+       (-gen-insn-timing): Ditto.
+       * sim.scm (gen-argbuf-type): Only output sem_fields union in
+       with-scache case.
+
+       * sim.scm (-hw-gen-fun-get): Use GET_<H-NAME> macro.
+       (-hw-gen-fun-set): Use SET_<H-NAME> macro.
+
+1999-01-12  Doug Evans  <devans@casey.cygnus.com>
+
+       * cpu.scm (keep-mach-validate!): New proc.
+       (include): New proc.
+
+       * mach.scm (current-arch-mach-name-list): New proc.
+       (-parse-arch-machs): Always return canonical form.
+       (def-arch): Validate user specified machs to be kept.
+       (def-mach-attr!): Simplify.
+
+       * opcodes.scm (-opcodes-build-operand-instance-table?): New global.
+       (option-init!): Initialize it.
+       (option-set!): Set it.
+       (gen-insn-table-entry): Emit 0 for operand instance ref if not
+       output operand instance tables.
+       (cgen-opc.in): Only output operand instance tables if asked to.
+
+       * sim.scm (option-init!,option-set!): Clarify returned value.
+
+       * sim.scm (gen-mach-bfd-name): Move from here.
+       * utils-cgen.scm: To here.
+
+1999-01-11  Doug Evans  <devans@casey.cygnus.com>
+
+       * fr30.cpu (ilm): Fix comment field.
+       (cond-branch): Remove explicit setting of COND-CTI, let cgen
+       compute it.
+
+       * rtl.scm (rtx-simplify,rtx-compile-time-constant?): New procs.
+       (rtx-true?, rtx-false?): New procs.
+       * rtx-funcs.scm (annul): Rename vpc to pc.
+       (-rtx-traverse-if): Improve determination of whether then/else parts
+       are conditionally executed.
+
+       * sim.scm (-gen-argbuf-fields-union): Move definition of union to
+       outer level.
+       (gen-argbuf-type): Simplify generated definition (big sem_fields
+       union moved outside).
+
+1999-01-11  Ben Elliston  <bje@cygnus.com>
+
+       * doc/porting.texi: New file.
+
+       * doc/intro.texi: New file.
+       (Layout): Use @example to insert preformatted ASCII text (such as
+       diagrams). @code is inappropriate here.
+
+1999-01-06  Doug Evans  <devans@casey.cygnus.com>
+
+       * ifield.scm (-multi-ifield-read): Fix handling of insert/extract.
+
+       * m32r.opc (print_hash): Cast dis_info.
+
+       * sim-cpu.scm (-gen-hardware-types): Sanitize get/set macros.
+       * sim.scm (<sim-hardware>,make!): Emit a comment for user-written
+       get/set macros.
+
+1999-01-05  Doug Evans  <devans@casey.cygnus.com>
+
+       * i960.cpu (f-br-disp): Remove RELOC attribute.
+       (f-ctrl-disp): Ditto.
+       (callx-disp): set-quiet -> set for (reg h-gr 2).
+       (callx-indirect,callx-indirect-offset): Ditto.
+
+       * Makefile.am (gas-test): Fix dependencies.
+       * Makefile.in: Rebuild.
+       * cgen-gas.asm: File creation args are -<uppercase-letter>.
+       * gas-test.scm (break-out-syntax,make-file-name): Delete.
+       (gas-test-analyze!): Use syntax-break-out.
+       * sim-test.scm (break-out-syntax,make-file-name): Delete.
+       (sim-test-analyze!): Use syntax-break-out.
+       (cgen-build.sh): Use gen-file-name.
+       (cgen-allinsn.exp): Compute and pass all machs to run_sim_test.
+       * insn.scm (syntax-break-out): New proc.
+       * utils.scm (gen-file-name): New proc.
+
+       * fixup.scm (nil,<?,<=?,>?): Delete.
+
+       * utils.scm (count-true): Rewrite.
+
+       * slib/sort.scm: Move sort.scm to slib directory.
+       * cpu.scm: Update.
+
+       * iformat.scm (ifmt-compute!): Record empty format.
+
+       * rtl.scm (semantic-in-out-operands): Simplify by moving several
+       internal procs outside.  Handle expression register numbers.
+       Handle index-of.
+
+       * rtx-funcs.scm (annul): Rename new_pc to vpc.
+
+       * sim-cpu.scm (-gen-cpu-reg-access-defns): Define access fns for
+       every register.
+       (-gen-write-case): Pass vpc to SEM_BRANCH_FINI.
+       (gen-semantic-fn,-gen-sem-case): Ditto.
+       (cgen-cpu.c): Define WANT_CPU to @cpu@.
+       (cgen-semantics.c): Ditto.
+       * sim-decode.scm (-gen-extract-decls): Handle non-with-scache case.
+       (gen-ifmt-argvars-defns): New proc.
+       (gen-ifmt-argvars-assigns): New proc.
+       (-gen-all-extractors): Delete FMT_EMPTY case, now handled like others.
+       (-gen-decode-fn): Handle non-with-scache case.
+       (cgen-decode.c): Define WANT_CPU to @cpu@.
+       * sim-models.scm (-gen-mach-defns): Emit bfd name.
+       (cgen-model.c): Define WANT_CPU to @cpu@.
+       * sim.scm (gen-ifld-extract-argvar): New proc.
+       (<sim-hardware>,make!): Don't emit [GS]ET_H_FOO macros for elements
+       with FUN-ACCESS specified.
+       (hw-fun-access?): New proc, as <hardware-base>:fun-access? method.
+       (<hw-register>,gen-extract): New arg local?.
+       (<hw-address>,gen-extract): Ditto.
+       (-hw-cxmake-get): Handle non-with-scache case.
+       (-hw-gen-set-quiet): Ditto.
+       (<hw-address>,cxmake-get): Handle non-with-scache case.
+       (gen-op-extract-argvar): New proc.
+       (<operand>,gen-record-profile): Rewrite.
+       (<operand>,gen-profile-code): Rewrite.
+       (<unit>,gen-profile-code): Use -gen-argfld-ref.
+       (gen-argbuf-fields-union): New proc.
+       (gen-argbuf-type): Use it.  Handle non-scache case.
+
+       * *.scm: class:foo procs renamed to class-foo.
+       * attr.scm (<attribute>): New member `for'.
+       (-attr-parse): New first value in list for default if
+       none specified.
+       (non-bool-attr-list,attr:add!): Delete.
+       (def-attr): Use current-attr-add!.
+       (atlist-attr-value-no-default): New proc.
+       (attr-lookup-default): Handle boolean attributes.
+       (gen-attr-enum): New proc.
+       (-attr-remove-meta-attrs-alist): New proc.
+       (attr-nub): New proc.
+       (current-attr-list-for): New proc.
+       (current-{ifld,hw,op,insn}-attr-list): New procs.
+       (attr-builtin!): New proc.
+       * cpu.scm (keep-obj?): Rewrite.
+       (-init-parse-cpu!): Call arch-init!.
+       (-install-builtin!): Call {attr,mode,ifield,insn}-builtin!.
+       (-finish-parse-cpu!): Call arch-finish!.
+       * enum.scm (enum-list,enum:add,enum:lookup): Delete.
+       (def-enum,def-full-enum): Use current-enum-add!.
+       (gen-obj-list-enums): New proc.
+       * hardware.scm (hw:add!,hw:lookup): Delete.
+       (def-hardware,def-hardware-ext): Use current-hw-add!.
+       (hw:std-attrs,hw:attr-list): Delete.
+       (hardware-builtin!): Define builtin hardware attributes.
+       * ifield.scm (ifld:add!,ifld:lookup): Delete.
+       (def-ifield,def-full-ifield): Use current-ifld-add!.
+       (ifld:std-attrs,ifld:attr-list): Delete.
+       (ifield-builtin!): New proc.
+       * insn.scm (insn:add!,insn:lookup): Delete.
+       (def-full-insn): Use current-insn-add!.
+       (insn:std-attrs): Delete.
+       (insn-builtin!): New proc.
+       * mach.scm (<arch>): New members attr-list,enum-list,op-list,
+       minsn-list.
+       (<arch-data>): New member machs.
+       (current-attr-list,current-enum-list): New procs.
+       (current-op-list,current-minsn-list): New procs.
+       (current-{attr,enum,ifld,op,hw,insn,minsn,cpu,mach,model}-add!): Ditto.
+       (current-{attr,enum,ifld,op,hw,insn,minsn,cpu,mach,model}-lookup):
+       Ditto.
+       (-parse-arch-machs): New proc.
+       (-arch-parse): New arg machs, all callers updated.
+       (-arch-read): Handle machs spec.
+       (def-arch): Define MACH attribute here.
+       (mach-init!,mach-finish!): Not here.
+       (cpu:add!,cpu:lookup): Delete.
+       (def-cpu): Use current-cpu-add!.
+       (<mach>): New member bfd-name.
+       (-mach-parse): New arg bfd-name, all callers updated.
+       (-mach-read): Handle bfd-name spec.
+       (mach:add!,mach:lookup): Delete.
+       (def-mach): Use current-mach-add!.
+       (def-mach-attr!): New proc.
+       (arch-init!): New proc.
+       (arch-finish!): New proc.  Reverse all object lists here.
+       * minsn.scm (minsn-list,minsn-add!,minsn:lookup): Delete.
+       (def-minsn): Use current-minsn-add!.  Ignore minsn if mach not kept.
+       (define-normal-macro-insn): Ignore minsn if mach not kept.
+       * mode.scm (mode-builtin!): New proc.
+       * model.scm (model:add!,model:lookup): Delete.
+       (def-model): Use current-model-add!.
+       * opcodes.scm (insn:attr-list): Delete.
+       (attr-bool-gen-decl,attr-bool-gen-defn): New procs.
+       (gen-attr-table-defn): Emit value for default.
+       (gen-attr-table-defns): Emit bool_attr.  Emit ifield attr table.
+       (op:attr-list): Delete.
+       (gen-operand-decls,gen-insn-decls): New proc.
+       (compute-insn-attr-list): Delete.
+       (cgen-opc.h): Reorganize and simplify.
+       * operand.scm (-operand-list,operand-list,op:add,op:lookup): Delete.
+       (def-operand,def-full-operand): Use current-op-add!.
+       (op:std-attrs): Delete.
+       (operand-enum): Delete.
+       (operand-builtin!): Define builtin operand attrs.
+       * utils-cgen.scm (sanitize): Update calls to lookup procs.
+       (gen-attr-enum-decl): Use gen-obj-list-enums.
+       (gen-obj-attr-defn): Renamed from gen-attr-defn, all callers updated.
+       Rewrite.
+       * fr30.cpu (define-arch): Add machs spec.
+       (f-i4): SIGNED attribute -> !UNSIGNED.
+       (f-disp8,f-disp9,f-disp10,f-s10,f-rel9,f-rel12): Ditto.
+       (HASH-PREFIX): Define operand attribute.
+       (NOT-IN-DELAY-SLOT): Define insn attribute.
+       * i960.cpu (define-arch): Add machs spec.
+       * m32r.cpu (define-arch): Add machs spec.
+       (h-hi16): Remove UNSIGNED,SIGN-OPT attributes.
+       (HASH-PREFIX): Define operand attribute.
+       (FILL-SLOT): Define insn attribute.
+
+Thu Dec 17 17:15:06 1998  Dave Brolley  <brolley@cygnus.com>
+
+       * fr30.cpu (stilm): Correct mask for and operation.
+
+1998-12-17  Doug Evans  <devans@casey.cygnus.com>
+
+       * sim-test.scm (cgen-build.sh): Use `mach' to specify machs, not `cpu'.
+       Replace START/EXIT with start/pass.
+       (gen-sim-test): Delete ".text".
+
+Wed Dec 16 16:16:39 1998  Dave Brolley  <brolley@cygnus.com>
+
+       * fr30.cpu (cond-branch): Conditional branches not allowed in delay slots.
+
+Tue Dec 15 17:30:01 1998  Dave Brolley  <brolley@cygnus.com>
+
+       * fr30.cpu: Add NOT-IN-DELAY-SLOT as appropriate.
+       (h-sbit): Make it FUN-ACCESS.
+       (h-gr): Reorder so that general regs are always printed by number.
+
+1998-12-14  James E Wilson  <wilson@wilson-pc.cygnus.com>
+
+       * i960.cpu (flushreg): Use nop.
+
+1998-12-14  Doug Evans  <devans@casey.cygnus.com>
+
+       * m32r.cpu (default-alignment): Specify.
+       * mach.scm (<arch-data>): New member default-alignment.
+       (adata:default-alignment): New proc.
+       (current-arch-default-alignment): New proc.
+       (-arch-parse): New arg default-alignment.
+       (parse-alignment): New proc.
+       (-arch-read): Handle default-alignment spec.
+
+       * rtx-funcs.scm (attr:): Pass attr-name through gen-c-symbol.
+
+       * insn.scm (f-%): Delete.
+       * sim-cpu.scm (gen-define-fields): Delete support for f-%.  Can
+       be readded if proved useful.
+       (gen-extract-fields): Ditto.  Use gen-ifetch.
+       * sim.scm (<hw-memory>,cxmake-get): Pass pc to GETMEM*.
+       (<hw-memory>,gen-set-quiet): Pass pc to SETMEM*.
+
+Mon Dec 14 16:20:59 1998  Dave Brolley  <brolley@cygnus.com>
+
+       * fr30.cpu (div2): Set zbit properly when remainder not zero.
+
+1998-12-14  Dave Brolley  <brolley@cygnus.com>
+
+       * fr30.cpu: Remove stub macros.
+       (div1): Shift bits from mdl into mdh. Don't use addc/subc.
+       (div2): Don't use addc/subc.
+
+1998-12-11  Doug Evans  <devans@casey.cygnus.com>
+
+       * utils-cgen.scm (gen-obj-sanitize): Only catch spelling errors
+       if opcodes.
+
+Thu Dec 10 18:37:34 1998  Dave Brolley  <brolley@cygnus.com>
+
+       * fr30.cpu (div0s,div0u,div1,div2,div3,div4s): Implemented.
+
+Thu Dec 10 12:28:53 1998  Doug Evans  <devans@canuck.cygnus.com>
+
+       * cpu.scm (keep-all?): New proc.
+       (assert-keep-all): Use it.
+       * opcodes.scm (gen-ifmt-table-1): Use gen-obj-sanitize.
+       * utils-cgen.scm (gen-obj-sanitize): Handle macro-insns.
+       Check for spelling errors.
+
+1998-12-09  Doug Evans  <devans@casey.cygnus.com>
+
+       * rtl.scm (s-convop): Call -rtx-sem-mode.
+
+Tue Dec  8 10:58:38 1998  Doug Evans  <devans@canuck.cygnus.com>
+
+       * hardware.scm (-parse-hw-type): parse! no longer returns a result.
+       (-parse-hw-profile): Ditto.
+       (<hw-register>, parse!): Return `void' result.
+       (<hw-pc>, parse!): Ditto.
+       (<hw-memory>, parse!): Ditto.
+       (<hw-immediate>, parse!): Ditto.
+       (<hw-address>, parse!): Ditto.
+
+       * ifield.scm (-ifield-parse): Validate encode/decode fields.
+       (-ifld-parse-encode-decode): New proc.
+       (-ifld-parse-encode,-ifld-parse-decode): New proc.
+       (-multi-ifield-parse): Set encode/decode to #f.
+       (ifld:decode-mode): New proc.
+       * utils.scm (nub): Rewrite.
+       * operand.scm (op-nub): Rewrite.
+       * sim.scm (<ifield>, gen-type): Rewrite.
+       (-gen-ifld-argbuf-defn): New proc.
+       (gen-ifld-extract,gen-ifld-trace-extract): New procs.
+       (<sim-hardware>): Forward gen-trace-extract onto `type'.
+       Ditto for needed-iflds.  gen-argbuf-defn renamed from gen-argbuf-elm.
+       (<hardware-base>): New method needed-iflds.  gen-argbuf-defn
+       renamed from gen-argbuf-elm, return "".  Rewrite gen-extract.
+       New method gen-trace-extract.
+       (<hw-register>): New method needed-iflds.  gen-argbuf-defn renamed
+       from gen-argbuf-elm, return "" if not caching register address.
+       Rewrite gen-extract.  New method gen-trace-extract.
+       (<hw-address>): New methods needed-iflds, gen-argbuf-defn,
+       gen-extract, gen-trace-extract, cxmake-get.
+       (<hw-iaddress>): New method cxmake-get.
+       (op-needed-iflds): New proc.
+       (<operand>): Delete methods gen-argbuf-elm, gen-extract.
+       (-gen-op-argbuf-defn): New proc.
+       (gen-op-extract): Renamed from op:extract.
+       (gen-op-trace-extract): Renamed from op:trace-extract.
+       (fmt-extractable-operands): Renamed from fmt-semantic-operands
+       and rewritten.
+       (gen-argbuf-elm): Rewrite.
+       * sim-decode.scm (-gen-record-args): Update.
+
+       * sim.scm (c-cpu-macro): Renamed from cpu-deref.  All uses changed.
+
+       * pmacros.scm (-pmacro-expand): Handle procedural macros in
+       argument position.  Flag symbolic macros in function position as
+       an error.
+       (define-pmacro): Handle quoting in definition of symbolic macros.
+       (pmacro-trace): Call -pmacro-expand, not -pmacro-ref.
+
+Tue Dec  8 13:06:44 1998  Dave Brolley  <brolley@cygnus.com>
+
+       * fr30.opc (parse_register_list): Account for reverse masks
+       for load and store.
+       (print_register_list): Ditto.
+       (parse_low_register_list_ld): New function.
+       (parse_hi_register_list_ld): New function.
+       (parse_low_register_list_st): New function.
+       (parse_hi_register_list_st): New function.
+       (print_hi_register_list_ld): New function.
+       (print_hi_register_list_st): New function.
+       (print_low_register_list_ld): New function.
+       (print_low_register_list_st): New function.
+       * fr30.cpu (ldr15dr): Implement workaround.
+       (ldm0,ldm1,stm0,stm1): Implemented.
+
+1998-12-08  Doug Evans  <devans@casey.cygnus.com>
+
+       * configure.in: Rename --with-hobbit to --with-cgen-hobbit.
+       * configure: Regenerate.
+       * Makefile.am (WITH_HOBBIT): Update.
+       (cgen-hob.c): Remove Makefile dependency.
+       (cgen.o): Depend on cgen-gh.h, config.h.
+       * Makefile.in: Regenerate.
+       * aclocal.m4: Regenerate.
+
+1998-12-07  James E Wilson  <wilson@wilson-pc.cygnus.com>
+
+       * i960.cpu, i960.opc: New files.
+
+Mon Dec  7 14:30:24 1998  Dave Brolley  <brolley@cygnus.com>
+
+       * fr30.opc (parse_register_number): New function.
+       (parse_register_list): New function.
+       (parse_low_register_list): Use parse_register_list.
+       (parse_hi_register_list): Use parse_register_list.
+       * fr30.cpu (sth): Fix assembler syntax. Implement more
+       insns.
+
+Fri Dec  4 16:07:13 1998  Doug Evans  <devans@canuck.cygnus.com>
+
+       * sim-cpu.scm (cgen-sem-switch.c): Update definition of TRACE_RESULT.
+       * sim-decode.scm (-gen-record-args): Update call to TRACE_EXTRACT.
+       * sim.scm (-op-gen-set-trace): Update call to TRACE_RESULT.
+       (-op-gen-set-trace-parallel): Ditto.
+       (gen-argbuf-type): New ARGBUF members trace_p,profile_p;
+
+       * fr30.cpu (call,calld): Fix setting of pc.
+       (f-op5): Fix start bit number.
+
+Fri Dec  4 17:06:28 1998  Dave Brolley  <brolley@cygnus.com>
+
+       * fr30.cpu (st): Fix operand ordering. Implement more
+       insns.
+
+Thu Dec  3 23:59:40 1998  Doug Evans  <devans@canuck.cygnus.com>
+
+       * ifield.scm (ifld:mode,ifld:hw-type): New procs.
+       * iformat.scm (fmt-opcode-operands): Move to opcodes.scm.
+       (fmt-semantic-operands): Move to sim.scm.
+       * opcodes.scm (fmt-opcode-operands): Moved here from iformat.scm.
+       * operand.scm (<hw-index>): New member `name'.  All builders updated.
+       (<hw-index>): New method get-name.
+       (op-profilable?): Moved to sim.scm.
+       (op-nub): New proc.
+       * sim.scm (fmt-semantic-operands): Moved here from iformat.scm.
+       (op-profilable?): Moved here from operand.scm.
+       (gen-extract-type): Delete.
+       (c-argfld-macro): Renamed from c-ifield-macro.  All uses updated.
+       (-gen-argfld-ref): New proc.
+       (-gen-ifld-argfld-name): New proc.
+       (gen-ifld-argfld-ref): Renamed from -gen-ifld-ref.  All uses updated.
+       (-gen-ifld-decoded-val): Renamed from -gen-ifld-raw-val.
+       (-gen-hw-index-argfld-name,-gen-hw-index-argfld-ref): New procs.
+       (<hardware-base>): Delete method gen-extract-type.  New method
+       gen-argbuf-elm.
+       (<hw-register): Ditto.  Update method gen-extract.
+       (<operand>, method gen-argbuf-elm): Rewrite.
+       * rtl.scm (semantic-in-out-operands): Handle (ifield f-name).
+       (s-cmpop): Fix handling of eq,ne for unsigned modes.
+       * rtx-funcs.scm (eq,ne,lt,le,gt,ge,ltu,leu,gtu,geu): Update.
+
+       * sim-decode.scm (-gen-record-args): Tweak.
+
+       * sim.scm (gen-argbuf-elm): Handle case of all constant opcode fields.
+
+Thu Dec  3 14:23:27 1998  Dave Brolley  <brolley@cygnus.com>
+
+       * doc/porting: Fix typo: gas->sim.
+       * fr30.opc (print_m4): New function.
+       * fr30.cpu: Implemented many insns.
+
+Thu Dec  3 00:03:16 1998  Doug Evans  <devans@canuck.cygnus.com>
+
+       * rtl.scm (build-reg-operand!): Remove redundant setting of hw-name.
+
+       * fr30.cpu (f-rel9): Delete RELOC attribute.
+       (f-rel12): Add PCREL-ADDR attribute.
+       (label9): Make an h-iaddr, not h-uint.  Delete asm print spec.
+       (label12): Delete PCREL-ADDR attribute.  Make an h-iaddr, not h-sint.
+       * fr30.opc (print_label9): Delete.
+
+       * iformat.scm (ifmt-analyze): Check attributes derived from semantic
+       code for CTI indicators.
+       * insn.scm (insn-cti?): Simplify.
+       * utils-cgen.scm (atlist:cti?): New proc.
+
+1998-11-30  Doug Evans  <devans@casey.cygnus.com>
+
+       * fr30.cpu (arch): default-insn-bitsize -> default-insn-word-bitsize.
+       (f-i20-4,f-i20-16,f-i20): New fields.
+       (i20): New operand.
+       (ldi8): Implement.
+       (ldi20): New insn.
+       (ldi32m): Delete.
+       (jmpd): Implement.
+       * fr30.opc (CGEN_DIS_HASH_SIZE,CGEN_DIS_HASH): Define in opc.h.
+       * m32r.cpu (arch): default-insn-bitsize -> default-insn-word-bitsize.
+       * mach.scm (arch-data): Ditto.
+       (current-arch-default-insn-word-bitsize): Renamed from
+       current-arch-default-insn-bitsize [ya, that's a pretty long name].
+       (-arch-read): Update.
+
+       * hardware.scm (hw:attr-list): Move here ...
+       * opcodes.scm: ... from here.
+
+       * ifield.scm (fld:bitrange): Delete.
+       (fld:word-offset,fld:word-length): New procs.
+       (ifield?): Use class-instance.
+       (<ifield>, method field-start): Rewrite.
+       (ifld:enum): New proc.
+       (<ifield>, methods field-mask,field-value): Rewrite.
+       (-ifield-parse): Rewrite.
+       (<multi-ifield> support): Rewrite.
+       (ifld-beyond-base?): Rewrite.
+       (ifld:std-attrs): New variable.
+       (ifld:attr-list): New proc.
+       * iformat.scm (-compute-insn-mask): Rewrite.
+       * insn.scm (-parse-insn-format): New arg errtxt, all callers updated.
+       Simplify.
+       (-parse-insn-format-symbol,-parse-insn-format-list): New procs.
+       * opcodes.scm (<hardware>): No longer forward gen-insert,gen-extract
+       onto type.
+       (<operand>): Ditto.  Forward onto index instead.
+       (gen-ifld-decls,gen-ifld-defns): New procs.
+       (ifld:insert,ifld:extract): New procs.
+       (<ifield>): New methods gen-insert, gen-extract.
+       (<multi-ifield>): Ditto.
+       (<hw-index>): Forward gen-insert,gen-extract onto value.
+       (<hw-asm>): Delete insert/extract support.
+       (<hw-register,hw-memory,hw-immediate>): Ditto.
+       (gen-hash-defines): Use string-list.
+       Define CGEN_MAX_IFMT_OPERANDS.
+       (gen-switch): Use string-list,string-list-map.
+       (gen-fget-switch,gen-fset-switch): Use string-list.
+       (gen-parse-switch,gen-insert-switch): Ditto.
+       (gen-extract-switch,gen-print-switch): Ditto.
+       (gen-insert-switch,gen-extract-switch): New local `total_length'.
+       (gen-ifmt-table-1,gen-ifmt-table): New procs.
+       (gen-ifmt-entry): Renamed from gen-iformat-entry, rewrite.
+       (gen-ivalue-entry): New proc.
+       (gen-insn-table-entry): Use string-list.  Update iformat,ivalue
+       computation.  Use 0 for operand ref table if ALIAS insn.
+       (gen-minsn-table-entry): Use string-list.
+       (gen-macro-insn-table): Temporarily emit format tables for ALIAS insns.
+       (gen-opcode-open): Record address of ifield table.
+       (cgen-opc.h): Call gen-ifld-decls.
+       (cgen-opc.in): Call gen-ifld-defns, gen-ifmt-table.
+       * types.scm (<bitrange>): New members word-offset,word-length.
+       Delete member total-length.  Delete methods start,mask,value.
+       (bitrange:word-offset,bitrange:word-length): New procs.
+       * sim-cpu.scm (gen-define-fields): Simplify.
+       (gen-extract-fields): Simplify.
+       * sim.scm (<ifield>, gen-ifld-extract): Rewrite.
+       (<ifield>): New methods gen-ifld-extract-decl.
+       Delete method gen-ifld-extract-beyond.
+       (<multi-ifield>): New methods gen-ifld-extract-decl.
+       (<multi-ifield>, method gen-ifld-extract): Implement.
+       (-gen-ifld-extract-base,-gen-ifld-extract-beyond): New procs.
+       (gen-ifld-exttact,gen-ifld-extract-beyond): Delete.
+
+       * rtl.scm (-rtx-traverse-no-mode): Process operands.
+       (-rtx-traverse-syntax-no-mode): New proc.
+       (semantic-in-out-operands): Watch for `delay' and add DELAY-SLOT attr.
+       (s-ifield): New proc.
+       (s-shop): Don't prepend `unsigned' for unsigned modes.
+       * rtx-funcs.scm (ifield): New rtx function.
+       (ref,symbol): Use standard -rtx-traverse-syntax-no-mode.
+       (delay): New rtx function.
+       * insn.scm (insn:std-attrs): Add DELAY-SLOT.
+
+       * cos.scm (-elm-make-method-getter): Fix typo.
+
+       * utils.scm (backslash): Handle lists of strings.
+
+Thu Nov 26 11:47:29 1998  Dave Brolley  <brolley@cygnus.com>
+
+       * fr30.cpu (f-rel9): Correct for pc+2.
+       (label9): Use print_label9.
+       * fr30.opc (print_label9): New function.
+
+Tue Nov 24 11:19:35 1998  Dave Brolley  <brolley@cygnus.com>
+
+       * fr30.cpu: Change $r13,$r14,$r15 to uppercase.
+       * fr30.opc (parse_low_register_list): Renamed.
+       (parse_hi_register_list): Renamed.
+       (print_hi_register_list): Renamed.
+       (print_low_register_list): Renamed.
+
+Mon Nov 23 18:26:36 1998  Dave Brolley  <brolley@cygnus.com>
+
+       * fr30.cpu (f-rel9): Now a pc relative offset.
+
+1998-11-23  Doug Evans  <devans@casey.cygnus.com>
+
+       * opcodes.scm (op-asm): Move to here, from operands.scm.
+       (<op-asm>, method parse!): Validate arguments.
+       (<operand>, method gen-function-name): Fix thinko.
+       * operand.scm (<operand>, method make!): Don't set op-asm here.
+       * utils.scm (list-elements-ok?): New proc.
+
+       * opcodes.scm: Clean up pass.
+
+1998-11-20  Doug Evans  <devans@tobor.to.cygnus.com>
+
+       * fr30.cpu (int): Defer saving of ps,pc and setting ibit,sbit to
+       the fr30_int function.
+       (h-cr): Remove PROFILE,CACHE-ADDR attributes.
+       (h-dr): Add FUN-ACCESS attribute.
+
+1998-11-20  James E Wilson  <wilson@wilson-pc.cygnus.com>
+
+       * sim-model.scm (-gen-mach-defns): Use gen-sym instead of obj:name
+       for C symbol for models array.
+
+Thu Nov 19 15:57:45 1998  Dave Brolley  <brolley@cygnus.com>
+
+       * fr30.opc (parse_reglist_low): New function.
+       (parse_reglist_hi): New function.
+       (print_reglist_low): New function.
+       (print_reglist_hi): New function.
+       * fr30.cpu: Finish remaining insn stubs.
+
+1998-11-19  Doug Evans  <devans@tobor.to.cygnus.com>
+
+       * sim.scm (-gen-extract-word): Handle fields shorter than entire word.
+
+       * fr30.cpu (ldi32m): Don't use for disassembly.
+
+Wed Nov 18 21:34:41 1998  Dave Brolley  <brolley@cygnus.com>
+
+       * fr30.cpu (int): Implement it.
+
+1998-11-18  Doug Evans  <devans@casey.cygnus.com>
+
+       * rtx-funcs.scm (nop): Fix C code.
+
+       * rtl.scm (semantic-in-out-operands): Fix setting of sem-attrs.
+
+       * fr30.cpu (f-i32): New ifield.
+       (i32): New operand.
+       (ldi32): New insn.
+       (ldi32m): New macro insn.
+       (inte): Provide simple version for now.
+
+       * sim-arch.scm: New file.
+       * sim.scm: Move architecture support generation to sim-arch.scm.
+       * cgen-sim.scm: Load sim-arch.scm.
+       * dev.scm: Ditto.
+
+       * hardware.scm (pc?) New proc.
+       (class <hardware-base>): Rewrite method 'pc?.
+       (class <hardware>): Forward 'pc? to the hardware type.
+       (class <hw-pc>): New method 'pc?.
+
+       Add support for variable length ISAs.
+       * ifield.scm (ifld-beyond-base?): New proc.
+       * m32r.cpu: Remove integral-insn? spec.
+       * mach.scm (arch:derived,arch:set-derived!): New procs.
+       (arch:app-data,arch:set-app-data!): New procs.
+       (class <arch>): New members derived, app-data.
+       (class <cpu>): Delete member integral-insn?.
+       (cpu:integral-insn?): Delete.
+       (-cpu-parse): Delete arg integral-insn?.  All callers updated.
+       (-cpu-read): Delete integral-insn? support.
+       (state:decode-assist): Delete.
+       (state:int-insn?): Delete.
+       (<derived-arch-data>): New class.
+       (-adata-set-derived!): New proc.
+       (mach-finish!): Call it.
+       * opcodes.scm (<hw-asm>, method gen-extract): Pass pc to C handler.
+       (gen-operand-instance): Add COND_REF support.
+       (gen-operand-instance-table): Ditto.
+       (gen-hash-defines): Update.
+       (gen-extract-switch): Update type of `insn_value' arg.
+       (gen-opcode-open): Update type of `value' arg of dis_hash_insn.
+       * rtl.scm (-rtx-ref-type): Renamed from -rtx-set?.  All callers
+       updated.
+       (semantic-in-out-operands): Compute UNCOND-CTI,COND-CTI from rtl.
+       * sim-cpu.scm (gen-define-fields): Create vars to hold insn value
+       beyond the base insn (for large insns).
+       (-gen-extract-beyond-var-list): New proc.
+       (gen-extract-fields): Handle large insns.
+       (-gen-write-case): Update sem_arg computation.
+       Update initial vpc computation.
+       (gen-semantic-fn): Ditto.  Update type of `insn'.
+       (-gen-sem-case): Update sem_arg computation.
+       Update initial vpc computation.
+       * sim.scm (<ifield>, gen-ifld-extract): Renamed from `extract'.
+       (-gen-extract-word): New proc.
+       (<ifield>): New method gen-ifld-extract-beyond.
+       (gen-ifld-extract-beyond): New proc.
+       * types.scm (bitrange-overlap?): New proc.
+
+       * utils.scm (bits->bytes): New proc.
+       (bytes->bits): New proc.
+
+       Move extraction support into decoder.
+       * sim-cpu.scm (-gen-record-args,-gen-record-profile-args,
+       -gen-extractor,-gen-all-extractors,cgen-extract.c): Move extraction
+       support to sim-decode.scm.
+       * sim-decode.scm (-gen-decode-insn-table): Change decoder data to
+       be array of IDESC,FMT entries.  Make the array const.
+       (-gen-gcc-label-table): Make array const.
+       (-gen-decode-switch): Branch to extraction code after insn has been
+       identified.
+       (-gen-decode-insn-globals): Delete extract handler from
+       @cpu@_insn_sem.
+       (gen-decode-fn): Add extraction support.
+       (-gen-sem-fn-decls): Delete extraction fn decls.
+       (-gen-idesc-decls): Update @cpu@_decode decl.
+       (-gen-idesc-init-fn): Delete extraction support.
+       (-gen-extract-decls): New proc.
+
+       * sim-cpu.scm (cgen-sem-switch.c): Update switch test.
+       (sim-finish!): Surround pbb only code with #if WITH_SCACHE_PBB.
+
+       * sim-decode.scm (build-decode-table-entry): New arg invalid insn.
+       All callers updated.
+       (table-entry:make): Record insn value as insn object, not name.
+       All uses updated.
+
+       * hobbit.scm (path_basename): Renamed from `basename' to avoid
+       collision with C function.
+       (path_dirname): Similarily.
+       * hobbit.c,hobbit.h: Rebuild.
+
+Wed Nov 18 11:26:17 1998  Dave Brolley  <brolley@cygnus.com>
+
+       * fr30.cpu (dir2r15-predec-stub): Reference to R15 must be indirect.
+
+Mon Nov 16 19:19:50 1998  Dave Brolley  <brolley@cygnus.com>
+
+       * fr30.cpu: Implement more instruction stubs.
+
+Thu Nov 12 19:20:28 1998  Dave Brolley  <brolley@cygnus.com>
+
+       * fr30.cpu: Implement more instruction stubs.
+
+Tue Nov 10 10:53:55 1998  Doug Evans  <devans@canuck.cygnus.com>
+
+       * rtl.scm (-rtx-expr-mode-name): Handle sequence locals.
+
+       * rtx-funcs.scm (zflag:,zflag,nflag:,nflag): New rtx fns.
+
+       * operand.scm (<pc>, method make!): FAKE renamed to SEM-ONLY.
+       (op:std-attrs): Ditto.
+       * opcodes.scm (gen-operand-instance): Ditto.
+       (gen-switch): Ditto.
+       * m32r.cpu (condbit,accum): Update.
+       * fr30.cpu (nbit,vbit,zbit,cbit): Update.
+
+Mon Nov  9 14:30:51 1998  Doug Evans  <devans@seba.cygnus.com>
+
+       * enum.scm (-enum-read): Fix typo.
+
+       * iformat.scm (-ifmt-search-key): Simplify a little.
+
+Mon Nov  9 12:07:56 1998  Dave Brolley  <brolley@cygnus.com>
+
+       * doc/porting: semantics.c -> sem.c.
+       * Makefile.in: Regenerate.
+       * fr30.cpu (add): Change ADD to add. Add more registers and set
+       status bits on 'add' instruction.
+       
+Fri Nov  6 18:15:05 1998  James E Wilson  <wilson@wilson-pc.cygnus.com>
+
+       * sim.scm (-gen-arch-model-decls):  Default MAX_UNITS to 1 instead
+       of 0.
+
+Fri Nov  6 17:43:16 1998  Doug Evans  <devans@seba.cygnus.com>
+
+       * minsn.scm (minsn:enum): Update, call current-arch-name.
+
+       * pmacros.scm (-pmacro-expand): Make `cep' a variable.
+
+       * Makefile.am (CGEN_HOB_INPUT_FILES): Add pmacros.scm,enum.scm,
+       mach.scm,model.scm,types.scm,ifield.scm,minsn.scm.
+       (ARCH,CGEN,CGENFLAGS): New variables.
+       (gas-test,sim-test): New rules.
+       * Makefile.in: Rebuild.
+       * configure.in (arch): Define.
+       * configure: Rebuild.
+
+       * cgen-hob.scm (*UNSPECIFIED*): Renamed from UNSPECIFIED.
+       * All .scm files: Ditto.
+
+       * dev.scm: Fix gas-test call to cpu-load.
+       * gas-test.scm: Clean up pass to remove bit-rot.
+       * sim-test.scm: Ditto.
+
+       * enum.scm (read-enum): Fix typo in `vals' handling.
+
+       * hardware.scm (-parse-hw-type): Fix typo.
+       (parse-hardware): Rename `asm' to `aasm' to avoid GCC reserved word.
+       (def-hardware,define-normal-hardware): Ditto.
+
+       * hobbit.scm (*case-sensitive-flag*): New configuration variable.
+       (display-var): Use it.
+       * hobbit.c: Rebuild.
+       * hobbit.h: Rebuild.
+
+       * ifield.scm (-ifield-read): Rename local `length' to `length-' to
+       avoid hobbit problem.
+       * mach.scm (-cpu-read): Rename local `parallel-insns' to
+       `parallel-insns-' to avoid hobbit problem.
+
+Fri Nov  6 17:19:12 1998  Doug Evans  <devans@canuck.cygnus.com>
+
+       * m32r.opc (parse_hi16): Fix call to cgen_parse_address.
+       (parse_slo16,parse_ulo16): Ditto.
+       * opcodes.scm (<hw-address>, method gen-parse): Ditto.
+
+Thu Nov  5 13:04:53 1998  Doug Evans  <devans@canuck.cygnus.com>
+
+       * Makefile.am (GUILELDFLAGS,GUILELDADD): New variables.
+       (cgen_LDFLAGS,cgen_LDADD,hob.x): Use them.
+       * Makefile.in: Rebuild.
+       * insn.scm (define-normal-insn): Expand pmacros.
+       * mode.scm (<mode>): New member `host?'.  All uses updated.
+       (mode:host?): New proc.
+       * rtl.scm (define-rtx-node): Make a syntax proc, not a macro.
+       (define-rtx-syntax-node,define-rtx-macro-node): Ditto.
+       (define-rtx-dual-mode): Ditto.
+       (s-index-of): New proc.
+       (s-unop): Use plain C for host mode operations.
+       (s-binop,s-shop,s-boolifop,s-cmpop): Ditto.
+       * rtx-funcs.scm (index-of): New rtx function.
+       * sim.scm (<hw-index>): New method cxmake-get.
+
+Wed Nov  4 23:58:08 1998  Doug Evans  <devans@seba.cygnus.com>
+
+       * sim-cpu.scm (-gen-engine-decls): Delete.
+
+Wed Nov  4 18:40:47 1998  Dave Brolley  <brolley@cygnus.com>
+
+       * doc/rtl (Example): Correct Typo.
+       * doc/porting: Add 'make dep' step to opcodes port instructions.
+       * fr30.opc: New file.
+       * fr30.cpu: New file.
+
+Wed Oct 28 13:36:15 1998  Doug Evans  <devans@canuck.cygnus.com>
+
+       * configure.in: Handle guile $exec_prefix = $prefix/foo.
+       * Makefile.am (GUILEINCDIR): New variable.
+       (INCLUDES): Use it.
+       * configure: Regenerate.
+       * Makefile.in: Ditto.
+       * aclocal.m4: Ditto.
+
+Mon Oct 19 13:19:34 1998  Doug Evans  <devans@seba.cygnus.com>
+
+       * sim-cpu.scm (cgen-extract.c): Delete #include cpu-sim.h
+       (cgen-semantics.c): Ditto.
+       * sim-decode.scm (cgen-decode.c): Delete #include cpu-sim.h,cpu-opc.h.
+       * sim-model.scm (cgen-model.c): Ditto.
+       * sim.scm (cgen-arch.h): Delete #include @arch@-opc.h.
+       (cgen-arch.c): Delete #include cpu-sim.h,cpu-opc.h.
+
+       * opcodes.scm (read-cpu.opc): Handle empty file.
+
+       * cos.scm (-elm-make-method-setter): Fix typo.
+
+       * cpu.scm (-init-parse-cpu!): Call types-init!.
+       (-finish-parse-cpu!): Call types-finish!.
+       * ifield.scm (<ifield>): Delete members start,length.
+       New member bitrange.
+       (<ifield>, methods field-start,field-length): Update.
+       (fld:start): New arg insn-len.  All callers updated.
+       (<ifield>, methods field-mask,field-value): Update.
+       (-ifield-parse): Update.
+       (ifield-init!): Update.
+       * iformat.scm (compute-insn-length): Simplify.
+       (compute-insn-mask): Update.
+       * insn.scm (insn:value): Update.
+       * mach.scm (<arch-data>): New members default-insn-bitsize,insn-lsb0?.
+       (current-arch-default-insn-bitsize): New proc.
+       (current-arch-insn-lsb0?): New proc.
+       (-arch-parse,-arch-read): Update.
+       (<cpu>): New member file-transform.
+       (-cpu-parse,-cpu-read): Update.
+       * opcodes.scm (<hw-asm>, method gen-extract): Pass ex_info to handler.
+       (gen-hash-defines): Define CGEN_INSN_LSB0_P.
+       (CGEN_INT_INSN_P): Renamed from CGEN_INT_INSN.
+       (gen-insert-switch): Update args of @arch@_cgen_insert_operand.
+       (gen-extract-switch): Update args of @arch@_cgen_extract_operand.
+       (gen-opcode-open): Set CGEN_OPCODE_INSN_ENDIAN.
+       * operand.scm (op:start): Update call to field-start method.
+       * sim-decode.scm (opcode-slots): New arg lsb0?.
+       (fill-slot!,build-slots): Ditto.
+       (build-decode-table-entry,build-decode-table-guts): Ditto.
+       (gen-decoder-table,gen-decoder-switch,gen-decoder): Ditto.
+       (gen-decode-fn): Ditto.
+       (cgen-decode.c): Update call to gen-decode-fn.
+       * sim.scm (gen-argbuf-type): Move `semantic' to cpu specific part.
+       (-gen-cpu-header,-gen-cpuall-includes): New procs.
+       (cgen-cpuall.h): Call -gen-cpuall-includes.
+       * types.scm (<bitrange>): New class.
+       (types-init!,types-finish!): New procs.
+       * utils-cgen.scm (parse-number): New proc.
+       (parse-boolean): New proc.
+       * utils.scm (word-value): Renamed from shift-bits, rewrite.
+       (word-mask): Rewrite.
+       * m32r.cpu (define-arch): New fields default-insn-bitsize,insn-lsb0?.
+       (m32rxf): New field `file-transform'.
+       * m32r.opc (my_print_insn): print_int_insn -> print_insn.
+
+       * hobbit.h: Fix include file name.
+
+Fri Oct  9 16:58:10 1998  Doug Evans  <devans@seba.cygnus.com>
+
+       * slib: New directory of slib files used by cgen/hobbit.
+       * hobbit.scm: New file.
+       * hobbit.c: New file.
+       * hobbit.h: New file.
+       * hobscmif.h: New file.
+       * hob-main.c: New file.
+       * hobslib.scm: New file.
+       * hob.sh: New file.
+       * Makefile.am: Add support for compiling hobbit, and using compiled
+       version of hobbit to compile cgen.
+       * Makefile.in: Regenerate.
+       * configure.in: Support --with-hobbit.
+       * configure: Regenerate.
+       * acconfig.h (WITH_HOBBIT): Add.
+       * config.in: Regenerate.
+
+       * rtl.scm: New file, was cdl-c.scm.
+       Definition of rtx funcs moved to rtx-funcs.scm.
+       (semantic-in-out-operands): Rewrite to compute object form of
+       semantic code.
+       * rtx-funcs.scm: New file.
+
+       * cgen-gh.c: #include "config.h".
+       (gh_cadddr,gh_cddddr): New fns.
+       (cgh_vector_to_list): New fn.
+       (cgh_map1,cgh_map2,cgh_map1_fn2): Rewrite.
+       (cgh_init): Prefix qsort procs with "cgh-".
+       * cgen-gh.h (gh_cadddr,gh_cddddr,cgh_vector_to_list): Declare.
+       * cgen.c: #include "config.h".
+
+       * attr.scm (bitset-attr?): New proc.
+       (<bitset-attribute>, method parse-value): Value syntax changed from
+       (val1 val2 ...) to val1,val2,....
+       (<bitset-attribute>): New method gen-value.
+       (<integer-attribute>): New method gen-value.
+       (<enum-attribute>): New method gen-value.
+       * cpu.scm: Disable debugging evaluator if (not (defined? 'DEBUG-EVAL)).
+       (<reader>): New class.
+       (CURRENT-ARCH,CURRENT-READER): New globals.
+       (keep-mach?): Move here from mach.scm.
+       * mach.scm (arch,arch-comment,arch-default-mach): Delete.
+       (<arch>): New class.
+       (<arch-data>): New class.
+       (<cpu>): Make subclass of <ident>.
+       (*ENDIAN* variables): Delete.
+       (process-state-vars): Delete.
+       (mach-finish!): Add `base' value to MACH attribute.
+       * hardware.scm (<hardware>): Make subclass of <ident>.
+       (hw:std-attrs): New global.
+       (hw-profilable?): New proc.
+       * ifield.scm (<ifield>): Make subclass of <ident>.
+       (sort-ifield-list): Move here from iformat.scm.
+       * iformat.scm (<iformat>): Renamed from <insn-format>.
+       Make subclass of <ident>.
+       (-ifmt-search-key): Include cti? in categorization of formats.
+       (ifmt-analyze): Compile semantics (turn to object form).
+       * insn.scm (<insn>): Make subclass of <ident>.
+       New member compiled-semantics.
+       (insn:std-attrs): Add SKIP-CTI, VIRTUAL.
+       * mode.scm (<mode>): Make subclass of <ident>.
+       (UBI): Delete.
+       * model.scm (<unit>): Make subclass of <ident>.
+       New members inputs,outputs.
+       (<model>): Make subclass of <ident>.  New member state.
+       (-unit-parse): Parse inputs,outputs.
+       (<iunit>): New class.
+       (-insn-timing-parse-model): New proc.
+       (parse-insn-timing): Function unit spec rewritten.
+       * operand.scm (<operand>): Make subclass of <ident>.
+       New members sem-name,num,cond?  New method gen-pretty-name.
+       (hw-index-scalar): New global.
+       (op-nub-hw): Move here from rtl.scm.
+       (op:lookup-sem-name,op-profilable?): New procs.
+       * pmacros.scm: Rewrite to pass through hobbit.
+       * utils-cgen.scm (gen-attr-defn): Simplify using new gen-value method.
+       * utils.scm (logit): Make a macro.
+       (bit-set?): Rewrite.
+       (high-part): Rewrite.
+
+       * m32r.cpu (define-arch): Move to top of file.
+       (cpu family m32rbf): Renamed from m32rb.
+       (model m32r/d): Function unit spec rewritten.
+       (all insns): Ditto.  Replace UBI with BI.
+
+       * opcodes.scm (gen-attr-table-decls): Declare
+       @arch@_cgen_hw_attr_table.
+       (gen-attr-table-defns): Generate hw attribute table.
+
+       * sim-cpu.scm (-gen-engine-decls): New proc.
+       (-gen-model-decls): New proc.
+       (gen-parallel-exec-type): Add new member `written' to struct parexec.
+       (-gen-record-args): Add SEM_BRANCH_INIT_EXTRACT if cti insn.
+       (-gen-record-profile-args): Simplify.
+       (-gen-parallel-sem-case): Delete.
+       (gen-semantic-fn): Emit SEM_BRANCH_{INIT,FINI} if cti insn.
+       New local `written'.  Delete profiling code.
+       (-gen-sem-case): Ditto.
+       (-uncond-written-mask,-any-cond-written?): New procs.
+       (cgen-sem-switch.c): Include duplicates of insns that can be executed
+       parallelly or serially, and write-back handlers for all parallel insns.
+       * sim-decode.scm (-gen-decode-insn-globals): Add parallel write-back
+       support to initialization of struct insn_sem.
+       (-gen-idesc-decls): Add parallel write-back support to struct idesc.
+       (-gen-insn-sem-type): Add parallel write-back support to struct
+       insn_sem.
+       (-gen-idesc-init-fn): Add support for virtual insns.
+       Add parallel write-back support.
+       * sim-model.scm (gen-model-profile-fn): Delete
+       (-gen-model-fn-decls): New proc.
+       (-gen-model-insn-fn,-gen-model-insn-fns): New procs.
+       (-gen-model-init-fn): New proc.
+       (-gen-mach-defns): Initialize insn-name lookup and fast/full engine_fn
+       members in @mach@_init_cpu.
+       (cgen-model.c): Generate model handlers for each insn.
+       * sim.scm (gen-define-field-macro): Cti insns handled differently.
+       (<hw-pc>): New method gen-write.
+       (<hw-register>, method gen-write): New arg `mode'.
+       (<hw-register>): Delete method gen-record-profile!.
+       New method gen-profile-index-type.
+       (<hw-memory>, method gen-write): New arg `mode'.
+       (<hw-address>, method gen-extract): Delete.
+       (<hw-address>, method gen-write): New arg `mode'.
+       (<hw-index>, method get-write-index): Rewrite.
+       (<pc>, method cxmake-get-direct): Delete.
+       (<pc>): New method cxmake-get.  Comment out methods
+       gen-set-quiet,gen-set-trace.
+       (<operand>): New methods gen-argbuf-elm,gen-profile-argbuf-elm,
+       gen-profile-index-type,gen-profile-code.
+       Delete method gen-pretty-name.  Rewrite method gen-write.
+       Delete method cxmake-get-direct.
+       (-op-gen-set-trace): Update `written'.
+       (-op-gen-set-trace-parallel): Ditto.
+       (-gen-hw-index-raw,-gen-hw-index): Handle strings.
+       (gen-cpu-insn-enum-decl): Add extra entries for parallel
+       insns and their write-back handlers.
+       (insn-op-lookup): New proc.
+       (<unit>): New method gen-profile-code.
+       (<iunit>): New method gen-profile-code.
+       (gen-argbuf-elm): Add profiling elements.
+       (gen-argbuf-type): Define cti insns separately in their own struct.
+       Add member `addr_cache' to this struct.  Add entries for pbb virtual
+       insns.  Move semantic entries here from struct scache.
+       Delete everything from struct scache except argbuf.
+       (<insn>, method gen-profile-locals): Rewrite.
+       (<insn>, method gen-profile-code): Rewrite.
+       (sim-finish!): Create virtual pbb insns.
+
+Tue Sep 15 15:22:02 1998  Doug Evans  <devans@canuck.cygnus.com>
+
+       * m32r.cpu (h-cr): Add bbpc,bbpsw.
+       (h-sm,h-bsm,h-ie,h-bie,h-bcond,h-bpc): Delete.
+       (h-psw,h-bpsw,h-bbpsw): Define.
+       (rte,trap): Handle bbpc,bbpsw.
+       * opcodes.scm (max-operand-instances): Fix typo.
+       * sim.scm (<hardware-base>, method 'fun-access?): Don't force virtual
+       hardware elements to be fun-access.
+       (-hw-gen-fun-get,-hw-gen-fun-set): Fix handling of scalars.
+
+Wed Sep  9 15:28:55 1998  Doug Evans  <devans@canuck.cygnus.com>
+
+       * m32r.cpu (trap): Pass `pc' to m32r_trap.
+
+Mon Aug 10 14:29:33 1998  Doug Evans  <devans@canuck.cygnus.com>
+
+       * opcodes.scm (gen-insn-table-entry): Comment out generation of cdx.
+
+Mon Aug  3 11:51:04 1998  Doug Evans  <devans@seba.cygnus.com>
+
+       * m32r.cpu (cpu m32rb): Renamed from m32r to distinguish from
+       architecture name.
+       (mach m32r): Update.
+
+       * mach.scm (mach:supports?): New proc.
+       * sim-cpu.scm (gen-cpu-reg-access-{decls,defns}): Renamed from
+       gen-reg-access-{decls,defns}.
+       * sim.scm (gen-reg-access-{decl,defn}): New procs.
+       (gen-mach-bfd-name): New proc.
+       (gen-arch-reg-access-{decls,defns}): New procs.
+       (cgen-arch.[ch]): Output register access cover fns.
+
+       * hardware.scm (hardware-builtin!): Set print handlers for
+       h-addr,h-iaddr.
+       * m32r.opc (parse_hash,parse_hi16,parse_slo16,parse_ulo16): New arg
+       `od'.
+       (CGEN_PRINT_NORMAL,print_hash): Ditto.
+       (my_print_insn): Ditto.  Delete args buf, buflen.
+       * opcodes.scm: Pass `od' (opcode-descriptor) to all C handlers.
+       (-hw-asm-specs): Add `handlers' spec.
+       (-parse-hw-asm): Lookup class at runtime.  If no asm-spec, use
+       `normal-hw-asm'.
+       (<hw-asm>): Renamed from <opval>.  New elements parse,insert,extract,
+       print.
+       (<hw-asm>, gen-insert,gen-extract,gen-print): Use them.
+       (<hw-asm>, parse!): New method.
+       (gen-insn-table-entry): Print semantics.
+       (gen-opcode-open): Renamed from gen-opcode-table.
+
+       * utils.scm (string-write): No longer a macro.
+       (-string-write): Handle procedure args.
+       * opcodes.scm: Update all calls to string-write.
+       * sim-cpu.scm: Ditto.
+       * sim-decode.scm: Ditto.
+       * sim-model.scm: Ditto.
+       * sim.scm: Ditto.
+
+Fri Jul 31 14:40:38 1998  Doug Evans  <devans@seba.cygnus.com>
+
+       * opcodes.scm (cgen-ibd.h,gen-extra-ibd.h): New procs.
+       (-gen-insn-builders,-gen-insn-builder): New procs.
+
+Fri Jul 24 11:38:59 1998  Doug Evans  <devans@canuck.cygnus.com>
+
+       * opcodes.scm (gen-syntax-entry): Fix bracketing for -Wall.
+       (gen-opcode-table): Properly terminate comment.
+
+Tue Jul 21 10:51:42 1998  Doug Evans  <devans@seba.cygnus.com>
+
+       * Version 0.6.0.
+       Clean up pass over everything, so starting fresh.
diff --git a/cgen/INSTALL b/cgen/INSTALL
new file mode 100644 (file)
index 0000000..b42a17a
--- /dev/null
@@ -0,0 +1,182 @@
+Basic Installation
+==================
+
+   These are generic installation instructions.
+
+   The `configure' shell script attempts to guess correct values for
+various system-dependent variables used during compilation.  It uses
+those values to create a `Makefile' in each directory of the package.
+It may also create one or more `.h' files containing system-dependent
+definitions.  Finally, it creates a shell script `config.status' that
+you can run in the future to recreate the current configuration, a file
+`config.cache' that saves the results of its tests to speed up
+reconfiguring, and a file `config.log' containing compiler output
+(useful mainly for debugging `configure').
+
+   If you need to do unusual things to compile the package, please try
+to figure out how `configure' could check whether to do them, and mail
+diffs or instructions to the address given in the `README' so they can
+be considered for the next release.  If at some point `config.cache'
+contains results you don't want to keep, you may remove or edit it.
+
+   The file `configure.in' is used to create `configure' by a program
+called `autoconf'.  You only need `configure.in' if you want to change
+it or regenerate `configure' using a newer version of `autoconf'.
+
+The simplest way to compile this package is:
+
+  1. `cd' to the directory containing the package's source code and type
+     `./configure' to configure the package for your system.  If you're
+     using `csh' on an old version of System V, you might need to type
+     `sh ./configure' instead to prevent `csh' from trying to execute
+     `configure' itself.
+
+     Running `configure' takes awhile.  While running, it prints some
+     messages telling which features it is checking for.
+
+  2. Type `make' to compile the package.
+
+  3. Optionally, type `make check' to run any self-tests that come with
+     the package.
+
+  4. Type `make install' to install the programs and any data files and
+     documentation.
+
+  5. You can remove the program binaries and object files from the
+     source code directory by typing `make clean'.  To also remove the
+     files that `configure' created (so you can compile the package for
+     a different kind of computer), type `make distclean'.  There is
+     also a `make maintainer-clean' target, but that is intended mainly
+     for the package's developers.  If you use it, you may have to get
+     all sorts of other programs in order to regenerate files that came
+     with the distribution.
+
+Compilers and Options
+=====================
+
+   Some systems require unusual options for compilation or linking that
+the `configure' script does not know about.  You can give `configure'
+initial values for variables by setting them in the environment.  Using
+a Bourne-compatible shell, you can do that on the command line like
+this:
+     CC=c89 CFLAGS=-O2 LIBS=-lposix ./configure
+
+Or on systems that have the `env' program, you can do it like this:
+     env CPPFLAGS=-I/usr/local/include LDFLAGS=-s ./configure
+
+Compiling For Multiple Architectures
+====================================
+
+   You can compile the package for more than one kind of computer at the
+same time, by placing the object files for each architecture in their
+own directory.  To do this, you must use a version of `make' that
+supports the `VPATH' variable, such as GNU `make'.  `cd' to the
+directory where you want the object files and executables to go and run
+the `configure' script.  `configure' automatically checks for the
+source code in the directory that `configure' is in and in `..'.
+
+   If you have to use a `make' that does not supports the `VPATH'
+variable, you have to compile the package for one architecture at a time
+in the source code directory.  After you have installed the package for
+one architecture, use `make distclean' before reconfiguring for another
+architecture.
+
+Installation Names
+==================
+
+   By default, `make install' will install the package's files in
+`/usr/local/bin', `/usr/local/man', etc.  You can specify an
+installation prefix other than `/usr/local' by giving `configure' the
+option `--prefix=PATH'.
+
+   You can specify separate installation prefixes for
+architecture-specific files and architecture-independent files.  If you
+give `configure' the option `--exec-prefix=PATH', the package will use
+PATH as the prefix for installing programs and libraries.
+Documentation and other data files will still use the regular prefix.
+
+   In addition, if you use an unusual directory layout you can give
+options like `--bindir=PATH' to specify different values for particular
+kinds of files.  Run `configure --help' for a list of the directories
+you can set and what kinds of files go in them.
+
+   If the package supports it, you can cause programs to be installed
+with an extra prefix or suffix on their names by giving `configure' the
+option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'.
+
+Optional Features
+=================
+
+   Some packages pay attention to `--enable-FEATURE' options to
+`configure', where FEATURE indicates an optional part of the package.
+They may also pay attention to `--with-PACKAGE' options, where PACKAGE
+is something like `gnu-as' or `x' (for the X Window System).  The
+`README' should mention any `--enable-' and `--with-' options that the
+package recognizes.
+
+   For packages that use the X Window System, `configure' can usually
+find the X include and library files automatically, but if it doesn't,
+you can use the `configure' options `--x-includes=DIR' and
+`--x-libraries=DIR' to specify their locations.
+
+Specifying the System Type
+==========================
+
+   There may be some features `configure' can not figure out
+automatically, but needs to determine by the type of host the package
+will run on.  Usually `configure' can figure that out, but if it prints
+a message saying it can not guess the host type, give it the
+`--host=TYPE' option.  TYPE can either be a short name for the system
+type, such as `sun4', or a canonical name with three fields:
+     CPU-COMPANY-SYSTEM
+
+See the file `config.sub' for the possible values of each field.  If
+`config.sub' isn't included in this package, then this package doesn't
+need to know the host type.
+
+   If you are building compiler tools for cross-compiling, you can also
+use the `--target=TYPE' option to select the type of system they will
+produce code for and the `--build=TYPE' option to select the type of
+system on which you are compiling the package.
+
+Sharing Defaults
+================
+
+   If you want to set default values for `configure' scripts to share,
+you can create a site shell script called `config.site' that gives
+default values for variables like `CC', `cache_file', and `prefix'.
+`configure' looks for `PREFIX/share/config.site' if it exists, then
+`PREFIX/etc/config.site' if it exists.  Or, you can set the
+`CONFIG_SITE' environment variable to the location of the site script.
+A warning: not all `configure' scripts look for a site script.
+
+Operation Controls
+==================
+
+   `configure' recognizes the following options to control how it
+operates.
+
+`--cache-file=FILE'
+     Use and save the results of the tests in FILE instead of
+     `./config.cache'.  Set FILE to `/dev/null' to disable caching, for
+     debugging `configure'.
+
+`--help'
+     Print a summary of the options to `configure', and exit.
+
+`--quiet'
+`--silent'
+`-q'
+     Do not print messages saying which checks are being made.  To
+     suppress all normal output, redirect it to `/dev/null' (any error
+     messages will still be shown).
+
+`--srcdir=DIR'
+     Look for the package's source code in directory DIR.  Usually
+     `configure' can determine that directory automatically.
+
+`--version'
+     Print the version of Autoconf used to generate the `configure'
+     script, and exit.
+
+`configure' also accepts some other, not widely useful, options.
diff --git a/cgen/Makefile.am b/cgen/Makefile.am
new file mode 100644 (file)
index 0000000..53f3fea
--- /dev/null
@@ -0,0 +1,124 @@
+# Process this file with "automake --cygnus Makefile" to generate Makefile.in
+
+AUTOMAKE_OPTIONS = cygnus
+
+SUBDIRS = doc
+
+GUILE = `if test -f ../guile/libguile/guile ; then echo ../guile/libguile/guile; else echo guile ; fi`
+CGENFLAGS = -v
+ARCH = @arch@
+
+# Applications depend on stamp-cgen to tell them when .scm files have
+# been changed (so files need to be regenerated).
+# ??? Application specific files are kept with cgen for now, but may
+# eventually go with the app.  stamp-cgen might still be useful to track
+# app-independent files.
+
+all-local: stamp-cgen
+
+stamp-cgen: $(CGENFILES)
+       rm -f stamp-cgen
+       echo timestamp > stamp-cgen
+
+# Phony targets to run each of the applications,
+# though most of these are for development purposes only.
+# When actually building the toolchain, the Makefile in the appropriate
+# directory will run cgen.
+
+# Build the basic description support.
+# We just stuff them in tmp-* files.
+# Usage: make desc ARCH=<arch> OPTIONS="<option list>"
+
+.PHONY: desc
+# FIXME: needs more dependencies
+desc: desc.scm
+       rm -f tmp-desc.h tmp-desc.c tmp-opinst.c
+       $(GUILE) -s $(srcdir)/cgen-opc.scm \
+               -s $(srcdir) \
+               $(CGENFLAGS) \
+               -f "$(OPTIONS)" \
+               -m all -a $(ARCH) \
+               -H tmp-desc.h -C tmp-desc.c
+
+# Build the opcodes files.
+# We just stuff them in tmp-* files.
+# Usage: make opcodes ARCH=<arch> OPTIONS="<option list>"
+
+.PHONY: opcodes
+# FIXME: needs more dependencies
+opcodes: opcodes.scm
+       rm -f tmp-opc.h tmp-itab.c
+       rm -f tmp-asm.in tmp-dis.in tmp-ibld.h tmp-ibld.in
+       $(GUILE) -s $(srcdir)/cgen-opc.scm \
+               -s $(srcdir) \
+               $(CGENFLAGS) \
+               -f "$(OPTIONS) opinst" \
+               -m all -a $(ARCH) \
+               -O tmp-opc.h -P tmp-opc.c -Q tmp-opinst.c \
+               -B tmp-ibld.h -L tmp-ibld.in \
+               -A tmp-asm.in -D tmp-dis.in
+
+# Build the simulator files.
+# We just stuff them in tmp-* files.
+# Usage: make sim-arch ARCH=<arch> OPTIONS="<option list>"
+#        make sim-cpu ARCH=<arch> ISA="<isa>" MACHS="<mach list>" \
+#          OPTIONS="<option list>"
+
+.PHONY: sim-arch sim-cpu
+# FIXME: needs more dependencies
+sim-arch: sim.scm
+       rm -f tmp-arch.h tmp-arch.c tmp-cpuall.h
+       $(GUILE) -s $(srcdir)/cgen-sim.scm \
+               -s $(srcdir) \
+               $(CGENFLAGS) \
+               -f "$(OPTIONS)" \
+               -m all -a $(ARCH) \
+               -A tmp-arch.h -B tmp-arch.c -N tmp-cpuall.h
+sim-cpu: sim.scm
+       rm -f tmp-cpu.h tmp-cpu.c tmp-decode.h tmp-decode.c
+       rm -f tmp-model.c tmp-sem.c tmp-sem-switch.c
+       $(GUILE) -s $(srcdir)/cgen-sim.scm \
+               -s $(srcdir) \
+               $(CGENFLAGS) \
+               -f "$(OPTIONS)" \
+               -i "$(ISA)" -m "$(MACHS)" -a $(ARCH) \
+               -C tmp-cpu.h -U tmp-cpu.c \
+               -T tmp-decode.h -D tmp-decode.c \
+               -M tmp-model.c \
+               -S tmp-semantics.c -X tmp-sem-switch.c
+
+# Build GAS testcase generator.
+
+.PHONY: gas-test
+gas-test: gas-test.scm cgen-gas.scm
+       @if test -z "$(ISA)" ; then \
+         echo "ISA not specified!" ;\
+         exit 1 ;\
+       fi
+       $(GUILE) -s $(srcdir)/cgen-gas.scm \
+               -s $(srcdir) \
+               $(CGENFLAGS) \
+               -m all \
+               -i $(ISA) \
+               -a $(ARCH) \
+               -B gas-build.sh \
+               -E gas-allinsn.exp
+
+# Build simulator testcase generator.
+
+.PHONY: sim-test
+sim-test: sim-test.scm cgen-stest.scm
+       @if test -z "$(ISA)" ; then \
+         echo "ISA not specified!" ;\
+         exit 1 ;\
+       fi
+       $(GUILE) -s $(srcdir)/cgen-stest.scm \
+               -s $(srcdir) \
+               $(CGENFLAGS) \
+               -m all \
+               -i $(ISA) \
+               -a $(ARCH) \
+               -B sim-build.sh \
+               -E sim-allinsn.exp
+
+CLEANFILES = tmp-*
diff --git a/cgen/Makefile.in b/cgen/Makefile.in
new file mode 100644 (file)
index 0000000..e42cf2e
--- /dev/null
@@ -0,0 +1,449 @@
+# Makefile.in generated automatically by automake 1.4 from Makefile.am
+
+# Copyright (C) 1994, 1995-8, 1999 Free Software Foundation, Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+# Process this file with "automake --cygnus Makefile" to generate Makefile.in
+
+
+SHELL = @SHELL@
+
+srcdir = @srcdir@
+top_srcdir = @top_srcdir@
+VPATH = @srcdir@
+prefix = @prefix@
+exec_prefix = @exec_prefix@
+
+bindir = @bindir@
+sbindir = @sbindir@
+libexecdir = @libexecdir@
+datadir = @datadir@
+sysconfdir = @sysconfdir@
+sharedstatedir = @sharedstatedir@
+localstatedir = @localstatedir@
+libdir = @libdir@
+infodir = @infodir@
+mandir = @mandir@
+includedir = @includedir@
+oldincludedir = /usr/include
+
+DESTDIR =
+
+pkgdatadir = $(datadir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+
+top_builddir = .
+
+ACLOCAL = @ACLOCAL@
+AUTOCONF = @AUTOCONF@
+AUTOMAKE = @AUTOMAKE@
+AUTOHEADER = @AUTOHEADER@
+
+INSTALL = @INSTALL@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@ $(AM_INSTALL_PROGRAM_FLAGS)
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+transform = @program_transform_name@
+
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_alias = @build_alias@
+build_triplet = @build@
+host_alias = @host_alias@
+host_triplet = @host@
+target_alias = @target_alias@
+target_triplet = @target@
+EXEEXT = @EXEEXT@
+MAINT = @MAINT@
+MAKEINFO = @MAKEINFO@
+PACKAGE = @PACKAGE@
+VERSION = @VERSION@
+arch = @arch@
+
+AUTOMAKE_OPTIONS = cygnus
+
+SUBDIRS = doc
+
+GUILE = `if test -f ../guile/libguile/guile ; then echo ../guile/libguile/guile; else echo guile ; fi`
+CGENFLAGS = -v
+ARCH = @arch@
+
+CLEANFILES = tmp-*
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+mkinstalldirs = $(SHELL) $(top_srcdir)/../mkinstalldirs
+CONFIG_CLEAN_FILES = 
+DIST_COMMON =  README AUTHORS COPYING ChangeLog INSTALL Makefile.am \
+Makefile.in NEWS aclocal.m4 configure configure.in
+
+
+DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) $(TEXINFOS) $(EXTRA_DIST)
+
+TAR = gtar
+GZIP_ENV = --best
+all: all-redirect
+.SUFFIXES:
+$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ Makefile.am $(top_srcdir)/configure.in $(ACLOCAL_M4) 
+       cd $(top_srcdir) && $(AUTOMAKE) --cygnus Makefile
+
+Makefile: $(srcdir)/Makefile.in  $(top_builddir)/config.status
+       cd $(top_builddir) \
+         && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status
+
+$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ configure.in 
+       cd $(srcdir) && $(ACLOCAL)
+
+config.status: $(srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+       $(SHELL) ./config.status --recheck
+$(srcdir)/configure: @MAINTAINER_MODE_TRUE@$(srcdir)/configure.in $(ACLOCAL_M4) $(CONFIGURE_DEPENDENCIES)
+       cd $(srcdir) && $(AUTOCONF)
+
+# This directory's subdirectories are mostly independent; you can cd
+# into them and run `make' without going through this Makefile.
+# To change the values of `make' variables: instead of editing Makefiles,
+# (1) if the variable is set in `config.status', edit `config.status'
+#     (which will cause the Makefiles to be regenerated when you run `make');
+# (2) otherwise, pass the desired values on the `make' command line.
+
+@SET_MAKE@
+
+all-recursive install-data-recursive install-exec-recursive \
+installdirs-recursive install-recursive uninstall-recursive install-info-recursive \
+check-recursive installcheck-recursive info-recursive dvi-recursive:
+       @set fnord $(MAKEFLAGS); amf=$$2; \
+       dot_seen=no; \
+       target=`echo $@ | sed s/-recursive//`; \
+       list='$(SUBDIRS)'; for subdir in $$list; do \
+         echo "Making $$target in $$subdir"; \
+         if test "$$subdir" = "."; then \
+           dot_seen=yes; \
+           local_target="$$target-am"; \
+         else \
+           local_target="$$target"; \
+         fi; \
+         (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \
+          || case "$$amf" in *=*) exit 1;; *k*) fail=yes;; *) exit 1;; esac; \
+       done; \
+       if test "$$dot_seen" = "no"; then \
+         $(MAKE) $(AM_MAKEFLAGS) "$$target-am" || exit 1; \
+       fi; test -z "$$fail"
+
+mostlyclean-recursive clean-recursive distclean-recursive \
+maintainer-clean-recursive:
+       @set fnord $(MAKEFLAGS); amf=$$2; \
+       dot_seen=no; \
+       rev=''; list='$(SUBDIRS)'; for subdir in $$list; do \
+         rev="$$subdir $$rev"; \
+         test "$$subdir" = "." && dot_seen=yes; \
+       done; \
+       test "$$dot_seen" = "no" && rev=". $$rev"; \
+       target=`echo $@ | sed s/-recursive//`; \
+       for subdir in $$rev; do \
+         echo "Making $$target in $$subdir"; \
+         if test "$$subdir" = "."; then \
+           local_target="$$target-am"; \
+         else \
+           local_target="$$target"; \
+         fi; \
+         (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \
+          || case "$$amf" in *=*) exit 1;; *k*) fail=yes;; *) exit 1;; esac; \
+       done && test -z "$$fail"
+tags-recursive:
+       list='$(SUBDIRS)'; for subdir in $$list; do \
+         test "$$subdir" = . || (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) tags); \
+       done
+
+tags: TAGS
+
+ID: $(HEADERS) $(SOURCES) $(LISP)
+       list='$(SOURCES) $(HEADERS)'; \
+       unique=`for i in $$list; do echo $$i; done | \
+         awk '    { files[$$0] = 1; } \
+              END { for (i in files) print i; }'`; \
+       here=`pwd` && cd $(srcdir) \
+         && mkid -f$$here/ID $$unique $(LISP)
+
+TAGS: tags-recursive $(HEADERS) $(SOURCES)  $(TAGS_DEPENDENCIES) $(LISP)
+       tags=; \
+       here=`pwd`; \
+       list='$(SUBDIRS)'; for subdir in $$list; do \
+   if test "$$subdir" = .; then :; else \
+           test -f $$subdir/TAGS && tags="$$tags -i $$here/$$subdir/TAGS"; \
+   fi; \
+       done; \
+       list='$(SOURCES) $(HEADERS)'; \
+       unique=`for i in $$list; do echo $$i; done | \
+         awk '    { files[$$0] = 1; } \
+              END { for (i in files) print i; }'`; \
+       test -z "$(ETAGS_ARGS)$$unique$(LISP)$$tags" \
+         || (cd $(srcdir) && etags $(ETAGS_ARGS) $$tags  $$unique $(LISP) -o $$here/TAGS)
+
+mostlyclean-tags:
+
+clean-tags:
+
+distclean-tags:
+       -rm -f TAGS ID
+
+maintainer-clean-tags:
+
+distdir = $(PACKAGE)-$(VERSION)
+top_distdir = $(distdir)
+
+# This target untars the dist file and tries a VPATH configuration.  Then
+# it guarantees that the distribution is self-contained by making another
+# tarfile.
+distcheck: dist
+       -rm -rf $(distdir)
+       GZIP=$(GZIP_ENV) $(TAR) zxf $(distdir).tar.gz
+       mkdir $(distdir)/=build
+       mkdir $(distdir)/=inst
+       dc_install_base=`cd $(distdir)/=inst && pwd`; \
+       cd $(distdir)/=build \
+         && ../configure --srcdir=.. --prefix=$$dc_install_base \
+         && $(MAKE) $(AM_MAKEFLAGS) \
+         && $(MAKE) $(AM_MAKEFLAGS) dvi \
+         && $(MAKE) $(AM_MAKEFLAGS) check \
+         && $(MAKE) $(AM_MAKEFLAGS) install \
+         && $(MAKE) $(AM_MAKEFLAGS) installcheck \
+         && $(MAKE) $(AM_MAKEFLAGS) dist
+       -rm -rf $(distdir)
+       @banner="$(distdir).tar.gz is ready for distribution"; \
+       dashes=`echo "$$banner" | sed s/./=/g`; \
+       echo "$$dashes"; \
+       echo "$$banner"; \
+       echo "$$dashes"
+dist: distdir
+       -chmod -R a+r $(distdir)
+       GZIP=$(GZIP_ENV) $(TAR) chozf $(distdir).tar.gz $(distdir)
+       -rm -rf $(distdir)
+dist-all: distdir
+       -chmod -R a+r $(distdir)
+       GZIP=$(GZIP_ENV) $(TAR) chozf $(distdir).tar.gz $(distdir)
+       -rm -rf $(distdir)
+distdir: $(DISTFILES)
+       -rm -rf $(distdir)
+       mkdir $(distdir)
+       -chmod 777 $(distdir)
+       @for file in $(DISTFILES); do \
+         if test -f $$file; then d=.; else d=$(srcdir); fi; \
+         if test -d $$d/$$file; then \
+           cp -pr $$d/$$file $(distdir)/$$file; \
+         else \
+           test -f $(distdir)/$$file \
+           || ln $$d/$$file $(distdir)/$$file 2> /dev/null \
+           || cp -p $$d/$$file $(distdir)/$$file || :; \
+         fi; \
+       done
+       for subdir in $(SUBDIRS); do \
+         if test "$$subdir" = .; then :; else \
+           test -d $(distdir)/$$subdir \
+           || mkdir $(distdir)/$$subdir \
+           || exit 1; \
+           chmod 777 $(distdir)/$$subdir; \
+           (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) top_distdir=../$(distdir) distdir=../$(distdir)/$$subdir distdir) \
+             || exit 1; \
+         fi; \
+       done
+info-am:
+info: info-recursive
+dvi-am:
+dvi: dvi-recursive
+check-am:
+check: check-recursive
+installcheck-am:
+installcheck: installcheck-recursive
+install-info-am: 
+install-info: install-info-recursive
+install-exec-am:
+install-exec: install-exec-recursive
+
+install-data-am:
+install-data: install-data-recursive
+
+install-am: all-am
+       @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+install: install-recursive
+uninstall-am:
+uninstall: uninstall-recursive
+all-am: Makefile all-local
+all-redirect: all-recursive
+install-strip:
+       $(MAKE) $(AM_MAKEFLAGS) AM_INSTALL_PROGRAM_FLAGS=-s install
+installdirs: installdirs-recursive
+installdirs-am:
+
+
+mostlyclean-generic:
+
+clean-generic:
+       -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+       -rm -f Makefile $(CONFIG_CLEAN_FILES)
+       -rm -f config.cache config.log stamp-h stamp-h[0-9]*
+
+maintainer-clean-generic:
+mostlyclean-am:  mostlyclean-tags mostlyclean-generic
+
+mostlyclean: mostlyclean-recursive
+
+clean-am:  clean-tags clean-generic mostlyclean-am
+
+clean: clean-recursive
+
+distclean-am:  distclean-tags distclean-generic clean-am
+
+distclean: distclean-recursive
+       -rm -f config.status
+
+maintainer-clean-am:  maintainer-clean-tags maintainer-clean-generic \
+               distclean-am
+       @echo "This command is intended for maintainers to use;"
+       @echo "it deletes files that may require special tools to rebuild."
+
+maintainer-clean: maintainer-clean-recursive
+       -rm -f config.status
+
+.PHONY: install-data-recursive uninstall-data-recursive \
+install-exec-recursive uninstall-exec-recursive installdirs-recursive \
+uninstalldirs-recursive all-recursive check-recursive \
+installcheck-recursive info-recursive dvi-recursive \
+mostlyclean-recursive distclean-recursive clean-recursive \
+maintainer-clean-recursive tags tags-recursive mostlyclean-tags \
+distclean-tags clean-tags maintainer-clean-tags distdir info-am info \
+dvi-am dvi check check-am installcheck-am installcheck install-info-am \
+install-info install-exec-am install-exec install-data-am install-data \
+install-am install uninstall-am uninstall all-local all-redirect all-am \
+all installdirs-am installdirs mostlyclean-generic distclean-generic \
+clean-generic maintainer-clean-generic clean mostlyclean distclean \
+maintainer-clean
+
+
+# Applications depend on stamp-cgen to tell them when .scm files have
+# been changed (so files need to be regenerated).
+# ??? Application specific files are kept with cgen for now, but may
+# eventually go with the app.  stamp-cgen might still be useful to track
+# app-independent files.
+
+all-local: stamp-cgen
+
+stamp-cgen: $(CGENFILES)
+       rm -f stamp-cgen
+       echo timestamp > stamp-cgen
+
+# Phony targets to run each of the applications,
+# though most of these are for development purposes only.
+# When actually building the toolchain, the Makefile in the appropriate
+# directory will run cgen.
+
+# Build the basic description support.
+# We just stuff them in tmp-* files.
+# Usage: make desc ARCH=<arch> OPTIONS="<option list>"
+
+.PHONY: desc
+# FIXME: needs more dependencies
+desc: desc.scm
+       rm -f tmp-desc.h tmp-desc.c tmp-opinst.c
+       $(GUILE) -s $(srcdir)/cgen-opc.scm \
+               -s $(srcdir) \
+               $(CGENFLAGS) \
+               -f "$(OPTIONS)" \
+               -m all -a $(ARCH) \
+               -H tmp-desc.h -C tmp-desc.c
+
+# Build the opcodes files.
+# We just stuff them in tmp-* files.
+# Usage: make opcodes ARCH=<arch> OPTIONS="<option list>"
+
+.PHONY: opcodes
+# FIXME: needs more dependencies
+opcodes: opcodes.scm
+       rm -f tmp-opc.h tmp-itab.c
+       rm -f tmp-asm.in tmp-dis.in tmp-ibld.h tmp-ibld.in
+       $(GUILE) -s $(srcdir)/cgen-opc.scm \
+               -s $(srcdir) \
+               $(CGENFLAGS) \
+               -f "$(OPTIONS) opinst" \
+               -m all -a $(ARCH) \
+               -O tmp-opc.h -P tmp-opc.c -Q tmp-opinst.c \
+               -B tmp-ibld.h -L tmp-ibld.in \
+               -A tmp-asm.in -D tmp-dis.in
+
+# Build the simulator files.
+# We just stuff them in tmp-* files.
+# Usage: make sim-arch ARCH=<arch> OPTIONS="<option list>"
+#        make sim-cpu ARCH=<arch> ISA="<isa>" MACHS="<mach list>" \
+#          OPTIONS="<option list>"
+
+.PHONY: sim-arch sim-cpu
+# FIXME: needs more dependencies
+sim-arch: sim.scm
+       rm -f tmp-arch.h tmp-arch.c tmp-cpuall.h
+       $(GUILE) -s $(srcdir)/cgen-sim.scm \
+               -s $(srcdir) \
+               $(CGENFLAGS) \
+               -f "$(OPTIONS)" \
+               -m all -a $(ARCH) \
+               -A tmp-arch.h -B tmp-arch.c -N tmp-cpuall.h
+sim-cpu: sim.scm
+       rm -f tmp-cpu.h tmp-cpu.c tmp-decode.h tmp-decode.c
+       rm -f tmp-model.c tmp-sem.c tmp-sem-switch.c
+       $(GUILE) -s $(srcdir)/cgen-sim.scm \
+               -s $(srcdir) \
+               $(CGENFLAGS) \
+               -f "$(OPTIONS)" \
+               -i "$(ISA)" -m "$(MACHS)" -a $(ARCH) \
+               -C tmp-cpu.h -U tmp-cpu.c \
+               -T tmp-decode.h -D tmp-decode.c \
+               -M tmp-model.c \
+               -S tmp-semantics.c -X tmp-sem-switch.c
+
+# Build GAS testcase generator.
+
+.PHONY: gas-test
+gas-test: gas-test.scm cgen-gas.scm
+       @if test -z "$(ISA)" ; then \
+         echo "ISA not specified!" ;\
+         exit 1 ;\
+       fi
+       $(GUILE) -s $(srcdir)/cgen-gas.scm \
+               -s $(srcdir) \
+               $(CGENFLAGS) \
+               -m all \
+               -i $(ISA) \
+               -a $(ARCH) \
+               -B gas-build.sh \
+               -E gas-allinsn.exp
+
+# Build simulator testcase generator.
+
+.PHONY: sim-test
+sim-test: sim-test.scm cgen-stest.scm
+       @if test -z "$(ISA)" ; then \
+         echo "ISA not specified!" ;\
+         exit 1 ;\
+       fi
+       $(GUILE) -s $(srcdir)/cgen-stest.scm \
+               -s $(srcdir) \
+               $(CGENFLAGS) \
+               -m all \
+               -i $(ISA) \
+               -a $(ARCH) \
+               -B sim-build.sh \
+               -E sim-allinsn.exp
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/cgen/NEWS b/cgen/NEWS
new file mode 100644 (file)
index 0000000..f9c9060
--- /dev/null
+++ b/cgen/NEWS
@@ -0,0 +1,3 @@
+News for CGEN Version 0.7.3
+
+Prepping for public release.
diff --git a/cgen/README b/cgen/README
new file mode 100644 (file)
index 0000000..d826225
--- /dev/null
@@ -0,0 +1,191 @@
+This is the README for CGEN 0.7.1
+
+If you just want to read up on cgen, I suggest going directly to the
+doc directory, and in particular doc/intro.texi.
+\f
+What is it?
+===========
+
+In a nutshell, CGEN is a project to provide a uniform framework for doing
+binutils and simulator ports without explicitly closing any doors on anything
+else one might want to do with the cpu description (i.e. application
+independence).  The "cpu description" as defined here includes anything useful.
+To this end CGEN is a very open-ended and ambitious project.
+
+The core of CGEN is a cpu description file and code to slurp it in and
+build a database describing the cpu.  From this the Binutils opcodes table
+can be generated for example, as well as an ISA simulator decoder/executor.
+
+CGEN is not a new idea.  Other GNU ports have done this (e.g. `sh' in its
+early days).  However, the idea never really "caught on".  CGEN was started
+because I think it should be.
+
+CGEN is short for "Cpu tools GENerator".  It's not a very good name.
+I'm not very good at picking names.  An early version of the name was
+"GENCPU"!  So give me a better one.
+\f
+Copyright
+=========
+
+CGEN is Copyright 2000 Red Hat, Inc.
+
+The full text of the copyright for CGEN is contained in the file
+COPYING.CGEN.  The copyright of CGEN uses the Autoconf copyright
+as a guide.  The intent is to have CGEN under a GNU-style copyright but
+place no restrictions on the output of CGEN.
+\f
+Installation
+============
+
+CGEN 0.7.1 can be used with GNU Binutils snapshots as of ??????
+and GNU GDB snapshots as of ??????.
+GNU Binutils/GDB users will never "use" CGEN.  The generated sources
+are shipped with GNU Binutils/GDB releases.
+Binutils/GDB developers wishing to use CGEN must configure Binutils/GDB with
+--enable-cgen-maint.  This will add the necessary dependencies to
+opcodes/Makefile and sim/<arch>/Makefile for the supported processors, which
+at this point is M32R and FR30.
+
+CGEN uses Guile so Guile must be installed.
+Guile 1.2 and 1.3 are supported.
+2) 
+\f
+Source Layout
+=============
+
+CGEN sources are divided into several categories:
+
+- documentation
+- code to read .cpu files
+- opcode table generator
+- gas testsuite generator
+- simulator generator
+- misc support scripts
+- cpu specific files
+- C support code
+
+File naming rules:
+
+1) The top level script for each application shall be named cgen-<appl>.scm.
+   No other files shall be named cgen-*.scm.
+2) Files implementing a particular class (or related collection of classes)
+   shall be named <class-name>.scm, or a reasonable abbreviation thereof.
+3) CPU description files shall be named <arch>.cpu.
+   [it should go without saying that no other files shall be named <arch>.cpu]
+4) CPU opcode support files shall be named <arch>.opc.
+   [it should go without saying that no other files shall be named <arch>.opc]
+
+??? May wish to change (1) to <appl>-cgen.scm so that each application's
+files will be collected together in `ls' output by the <appl>- prefix.
+
+documentation
+-------------
+
+doc/cgen.texi - top level .texi file, includes the others
+doc/rtl.texi - cpu description language (based on GCC's RTL)
+doc/intro.texi - global overview of cgen
+doc/opcodes.texi - opcode table usage of cgen
+doc/porting.texi - porting guide for new ports
+doc/sim.texi - simulator usage of cgen
+doc/credits.texi - inspiration and contributors
+
+code to read .cpu files
+-----------------------
+
+These files provide the basic support for reading in .cpu files.  They contain
+no application specific code (and ideally as little C generating code as
+possible too), they are intended to be application independent.  Applications
+(e.g. the opcode table generator and the simulator support generator) are
+built on top of these files.
+
+attr.scm - attribute support
+read.scm - top level script for .cpu file reading
+enum.scm - enum support
+hardware.scm - hardware description reader
+ifield.scm - instruction field reader
+iformat.scm - computes instruction formats
+insn.scm - instruction description reader
+mach.scm - architecture/cpu/machine reader
+minsn.scm - macro-instruction description reader
+mode.scm - mode support
+model.scm - model reader
+operand.scm - instruction operand reader
+rtl.scm - basic rtl support
+rtx-funcs.scm - defines all standard rtx functions
+types.scm - type system
+
+opcode table generator
+---------------------
+
+cgen-opc.scm - top level script to generate the opcode table + support
+opcodes.scm - opcode table generator
+opc-asmdis.scm
+opc-ibld.scm
+opc-itab.scm
+opc-opinst.scm
+
+Additional support lives in the opcodes directory.
+
+opcodes/cgen-ibld.in - input file for <arch>-ibld.c
+opcodes/cgen-asm.in - input file for <arch>-asm.c
+opcodes/cgen-dis.in - input file for <arch>-dis.c
+opcodes/cgen-opc.c - architecture independent opcode table support
+opcodes/cgen-asm.c - architecture independent assembler support
+opcodes/cgen-dis.c - architecture independent disassembler support
+opcodes/cgen.sh - shell script invoked by opcodes/Makefile to build
+                  <arch>-opc.h, <arch>-opc.c, <arch>-asm.c, <arch>-dis.c.
+
+The header file that defines the interface to the opcodes table is
+include/opcode/cgen.h.
+
+gas testsuite generator
+-----------------------
+
+cgen-gas.scm - top level script to generate gas testcases
+gas-test.scm - generate gas testcases
+
+simulator generator
+-------------------
+
+cgen-sim.scm - top level script to generate simulator files
+sim-arch.scm - generator for architecture-wide support files
+sim-cpu.scm - generator for cpu specific simulator files
+sim-decode.scm - decoder generator
+sim-model.scm - generates model support
+sim.scm - interface between simulator generator and cpu database
+
+Additional support lives in sim/common/cgen-*.[ch].
+Architectures specific files live in sim/<arch>.
+
+misc. support scripts
+---------------------
+
+dev.scm - top level script for doing interactive development
+fixup.scm - munges the Scheme environment to make it suit us
+       [Guile is/was still in flux]
+cos.scm - OOP implementation
+pmacros.scm - preprocessor-style macro package
+profile.scm - Guile profiling tool [eventually wish to move this to
+       Guile distribution when finished]
+sort.scm - sort routine, from slib
+utils-cgen.scm - various utilities specific to cgen
+utils.scm - generic Scheme utilities [non cgen specific]
+
+cpu specific files
+------------------
+
+<arch>.cpu - <arch> description file
+<arch>.opc - <arch> opcode support
+
+null.cpu - minimal .cpu file for debugging purposes
+
+C version of cgen
+-----------------
+
+Makefile.am, Makefile.in - automake stuff
+acconfig.h,aclocal.m4,config.in,stamp-h.in - autoconf stuff
+configure.in,configure - autoconf stuff
+gdbinit.in - source for .gdbinit file
+cgen.c - main()
+cgen-gh.[ch] - additional functionality to Guile's gh interface
+cos.[ch] - C implementation of cgen object system
diff --git a/cgen/aclocal.m4 b/cgen/aclocal.m4
new file mode 100644 (file)
index 0000000..f5379a5
--- /dev/null
@@ -0,0 +1,137 @@
+dnl aclocal.m4 generated automatically by aclocal 1.4
+
+dnl Copyright (C) 1994, 1995-8, 1999 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+dnl This program is distributed in the hope that it will be useful,
+dnl but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+dnl even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+dnl PARTICULAR PURPOSE.
+
+# Do all the work for Automake.  This macro actually does too much --
+# some checks are only needed if your package does certain things.
+# But this isn't really a big deal.
+
+# serial 1
+
+dnl Usage:
+dnl AM_INIT_AUTOMAKE(package,version, [no-define])
+
+AC_DEFUN(AM_INIT_AUTOMAKE,
+[AC_REQUIRE([AC_PROG_INSTALL])
+PACKAGE=[$1]
+AC_SUBST(PACKAGE)
+VERSION=[$2]
+AC_SUBST(VERSION)
+dnl test to see if srcdir already configured
+if test "`cd $srcdir && pwd`" != "`pwd`" && test -f $srcdir/config.status; then
+  AC_MSG_ERROR([source directory already configured; run "make distclean" there first])
+fi
+ifelse([$3],,
+AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE", [Name of package])
+AC_DEFINE_UNQUOTED(VERSION, "$VERSION", [Version number of package]))
+AC_REQUIRE([AM_SANITY_CHECK])
+AC_REQUIRE([AC_ARG_PROGRAM])
+dnl FIXME This is truly gross.
+missing_dir=`cd $ac_aux_dir && pwd`
+AM_MISSING_PROG(ACLOCAL, aclocal, $missing_dir)
+AM_MISSING_PROG(AUTOCONF, autoconf, $missing_dir)
+AM_MISSING_PROG(AUTOMAKE, automake, $missing_dir)
+AM_MISSING_PROG(AUTOHEADER, autoheader, $missing_dir)
+AM_MISSING_PROG(MAKEINFO, makeinfo, $missing_dir)
+AC_REQUIRE([AC_PROG_MAKE_SET])])
+
+#
+# Check to make sure that the build environment is sane.
+#
+
+AC_DEFUN(AM_SANITY_CHECK,
+[AC_MSG_CHECKING([whether build environment is sane])
+# Just in case
+sleep 1
+echo timestamp > conftestfile
+# Do `set' in a subshell so we don't clobber the current shell's
+# arguments.  Must try -L first in case configure is actually a
+# symlink; some systems play weird games with the mod time of symlinks
+# (eg FreeBSD returns the mod time of the symlink's containing
+# directory).
+if (
+   set X `ls -Lt $srcdir/configure conftestfile 2> /dev/null`
+   if test "[$]*" = "X"; then
+      # -L didn't work.
+      set X `ls -t $srcdir/configure conftestfile`
+   fi
+   if test "[$]*" != "X $srcdir/configure conftestfile" \
+      && test "[$]*" != "X conftestfile $srcdir/configure"; then
+
+      # If neither matched, then we have a broken ls.  This can happen
+      # if, for instance, CONFIG_SHELL is bash and it inherits a
+      # broken ls alias from the environment.  This has actually
+      # happened.  Such a system could not be considered "sane".
+      AC_MSG_ERROR([ls -t appears to fail.  Make sure there is not a broken
+alias in your environment])
+   fi
+
+   test "[$]2" = conftestfile
+   )
+then
+   # Ok.
+   :
+else
+   AC_MSG_ERROR([newly created file is older than distributed files!
+Check your system clock])
+fi
+rm -f conftest*
+AC_MSG_RESULT(yes)])
+
+dnl AM_MISSING_PROG(NAME, PROGRAM, DIRECTORY)
+dnl The program must properly implement --version.
+AC_DEFUN(AM_MISSING_PROG,
+[AC_MSG_CHECKING(for working $2)
+# Run test in a subshell; some versions of sh will print an error if
+# an executable is not found, even if stderr is redirected.
+# Redirect stdin to placate older versions of autoconf.  Sigh.
+if ($2 --version) < /dev/null > /dev/null 2>&1; then
+   $1=$2
+   AC_MSG_RESULT(found)
+else
+   $1="$3/missing $2"
+   AC_MSG_RESULT(missing)
+fi
+AC_SUBST($1)])
+
+# Add --enable-maintainer-mode option to configure.
+# From Jim Meyering
+
+# serial 1
+
+AC_DEFUN(AM_MAINTAINER_MODE,
+[AC_MSG_CHECKING([whether to enable maintainer-specific portions of Makefiles])
+  dnl maintainer-mode is disabled by default
+  AC_ARG_ENABLE(maintainer-mode,
+[  --enable-maintainer-mode enable make rules and dependencies not useful
+                          (and sometimes confusing) to the casual installer],
+      USE_MAINTAINER_MODE=$enableval,
+      USE_MAINTAINER_MODE=no)
+  AC_MSG_RESULT($USE_MAINTAINER_MODE)
+  AM_CONDITIONAL(MAINTAINER_MODE, test $USE_MAINTAINER_MODE = yes)
+  MAINT=$MAINTAINER_MODE_TRUE
+  AC_SUBST(MAINT)dnl
+]
+)
+
+# Define a conditional.
+
+AC_DEFUN(AM_CONDITIONAL,
+[AC_SUBST($1_TRUE)
+AC_SUBST($1_FALSE)
+if $2; then
+  $1_TRUE=
+  $1_FALSE='#'
+else
+  $1_TRUE='#'
+  $1_FALSE=
+fi])
+
diff --git a/cgen/arm.cpu b/cgen/arm.cpu
new file mode 100644 (file)
index 0000000..9d1344a
--- /dev/null
@@ -0,0 +1,404 @@
+; ARM CPU description.  -*- Scheme -*-
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+(include "simplify.inc")
+
+(define-arch
+  (name arm)
+  (comment "Advanced RISC Machines (ARM)")
+  (insn-lsb0? #t)
+  (machs arm7tdmi)
+  (isas arm thumb)
+)
+
+; ??? There should be an official rtx to do this.  Until then.
+(define-pmacro (invalid-insn)
+  (c-call BI "invalid_insn" pc) ; FIXME: Not VOID to workaround codegen bug.
+)
+
+(define-isa
+  (name arm)
+  (comment "ARM instruction set (32 bit insns)")
+  (base-insn-bitsize 32)
+  ; FIXME: wip. `f-cond' is currently defined in arm7.cpu.
+  (condition f-cond
+            ; `cond-code' is the extracted value of `f-cond'
+            ; FIXME: wip
+;           (case BI cond-code
+;                 ((COND_EQ) (reg h-zbit))
+;                 ((COND_NE) (not (reg h-zbit)))
+;                 ((COND_CS) (reg h-cbit))
+;                 ((COND_CC) (not (reg h-cbit)))
+;                 ((COND_MI) (reg h-nbit))
+;                 ((COND_PL) (not (reg h-zbit)))
+;                 ((COND_VS) (reg h-vbit))
+;                 ((COND_VC) (not (reg h-vbit)))
+;                 ((COND_HI) (and (reg h-cbit) (not (reg h-zbit))))
+;                 ((COND_LS) (not (or (reg h-cbit) (reg h-zbit))))
+;                 ((COND_GE) (eq (reg h-zbit) (reg h-vbit)))
+;                 ((COND_LT) (ne (reg h-nbit) (reg h-vbit)))
+;                 ((COND_GT) (and (not (reg h-zbit))
+;                                 (eq (reg h-nbit) (reg h-vbit))))
+;                 ((COND_LE) (or (reg h-zbit)
+;                                (ne (reg h-nbit) (reg h-vbit))))
+;                 ((COND_AL) 1)
+;                 (else (sequence BI () (invalid-insn) 1))))
+            (c-call BI "eval_cond" cond-code pc))
+  (decode-assist (27 26 25 24 23 22 21))
+  ; We can lengthen pbb's by breaking insns that set h-gr into those that set
+  ; h-gr[15] (the pc), and those that don't.
+  ; Other analysis of the isa will benefit from this, so this is recorded here
+  ; rather than in a simulator specific file.
+;;   (decode-splits
+;;   ; split insns with field f-rd into f-rd == 15, f-rd != 15
+;;   ; ??? To be made more general in time.
+;;   (f-rd ; split on values of this field
+;;    ()   ; no extra constraints
+;;    ((no-pc-dest (.iota 15)) (pc-dest 15)) ; list of splits
+;;    )
+;;   )
+  (setup-semantics (set-quiet (reg h-gr 15) (add pc (attr (current-insn) R15-OFFSET))))
+)
+
+(define-isa
+  (name thumb)
+  (comment "ARM Thumb instruction set (16 bit insns)")
+  (base-insn-bitsize 16)
+  (decode-assist (15 14 13 12 11 10 9 8))
+  (setup-semantics (set-quiet (reg h-gr 15) (add pc 4)))
+)
+
+(define-cpu
+  (name arm7f)
+  (comment "ARM7")
+  (endian either)
+  (word-bitsize 32)
+)
+
+(define-mach
+  (name arm7tdmi)
+  (comment "ARM 7TDMI core")
+  (cpu arm7f)
+  (isas arm thumb)
+)
+
+(define-model
+  (name arm710)
+  (comment "ARM 710 microprocessor")
+  (mach arm7tdmi)
+  (unit u-exec "Execution Unit" ()
+       1 1 ; issue done
+       () () () ())
+)
+\f
+; Hardware.
+
+; The program counter is actually reg 15.
+; But ... [there's always a "But ..." :-(] when referenced in instructions
+; the value is either 8 or 12 beyond the address of the instruction in
+; ARM mode and 4 beyond in Thumb mode.
+; To handle this the program counter is treated as a separate register
+; and r15 is set to the appropriate offset before executing each instruction.
+; This seems like the simplest and most efficient way to handle this.
+
+(define-hardware
+  (name h-pc)
+  (comment "ARM program counter (h-gr reg 15)")
+  (attrs PC (ISA arm,thumb))
+  (type pc)
+  ; In ARM mode the bottom two bits read as zero.
+  ; In Thumb mode the bottom bit reads as zero.
+  ; This can be handled during gets, sets, or both.
+  ; Handling this in sets seems best ('tis handled in only one place and the
+  ; stored value is always correct - assuming all out-of-band sets are ok).
+  ; ??? Might be possible to optimize out the test of tbit.  Later.
+  (set (newval)
+       (if (reg h-tbit)
+          (set (raw-reg SI h-pc) (and newval -2))
+          (set (raw-reg SI h-pc) (and newval -4))))
+)
+
+(define-keyword
+  (name gr-names)
+  (print-name h-gr)
+  (values (pc 15) ; put this first so it is prefered over r15
+         (r0 0) (r1 1) (r2 2) (r3 3) (r4 4) (r5 5) (r6 6) (r7 7) 
+         (r8 8) (r9 9) (r10 10) (r11 11) (r12 12) (r13 13) (r14 14) (r15 15)
+         (sp 13) (lr 14))
+)
+
+(define-hardware 
+  (name h-gr)
+  (comment "General purpose registers")
+  (attrs (ISA arm,thumb) CACHE-ADDR)
+  (type register SI (16))
+  (indices extern-keyword gr-names)
+)
+
+; Banked versions of h-gr.
+; h-gr is always "active".  When a mode switch happens, the copies in h-gr
+; are copied to their holding buffers, and new values are switched in.
+; ??? The non-user-mode versions of these registers have special names which
+; are just(?) aliases for the normal names.
+
+(define-hardware
+  (name h-gr-usr)
+  (comment "user/system mode r8-r14 holding buffer")
+  (attrs (ISA arm,thumb))
+  (type register SI (7))
+)
+(define-hardware
+  (name h-gr-fiq)
+  (comment "fiq mode r8-r14 regs")
+  (attrs (ISA arm,thumb))
+  (type register SI (7))
+)
+(define-hardware
+  (name h-gr-svc)
+  (comment "supervisor mode r13-r14 regs")
+  (attrs (ISA arm,thumb))
+  (type register SI (2))
+)
+(define-hardware
+  (name h-gr-abt)
+  (comment "abort mode r13-r14 regs")
+  (attrs (ISA arm,thumb))
+  (type register SI (2))
+)
+(define-hardware
+  (name h-gr-irq)
+  (comment "irq mode r13-r14 regs")
+  (attrs (ISA arm,thumb))
+  (type register SI (2))
+)
+(define-hardware
+  (name h-gr-und)
+  (comment "undefined mode r13-r14 regs")
+  (attrs (ISA arm,thumb))
+  (type register SI (2))
+)
+
+; The condition code bits.
+
+(dsh h-cbit "carry bit"    ((ISA arm,thumb)) (register BI))
+(dsh h-nbit "negative bit" ((ISA arm,thumb)) (register BI))
+(dsh h-vbit "overflow bit" ((ISA arm,thumb)) (register BI))
+(dsh h-zbit "zerobit"      ((ISA arm,thumb)) (register BI))
+
+(dnop cbit "carry bit"     ((ISA arm,thumb)) h-cbit f-nil)
+(dnop nbit "negative bit"  ((ISA arm,thumb)) h-nbit f-nil)
+(dnop vbit "overflow bit"  ((ISA arm,thumb)) h-vbit f-nil)
+(dnop zbit "zero bit"      ((ISA arm,thumb)) h-zbit f-nil)
+
+; The CPSR (current program status register).
+
+(dsh h-ibit  "irq disable bit" ((ISA arm,thumb)) (register BI))
+(dsh h-fbit  "fiq disable bit" ((ISA arm,thumb)) (register BI))
+
+(define-hardware
+  (name h-tbit)
+  (comment "thumb bit")
+  (attrs (ISA arm,thumb))
+  (type register BI)
+  (set (newval)
+       (sequence ()
+                (c-call VOID "arm_tbit_set" newval)))
+)
+
+(define-keyword
+  (name arm-mode)
+  (comment "arm cpu states")
+  (values (User #x10)
+         (FIQ  #x11)
+         (IRQ  #x12)
+         (Supervisor #x13)
+         (Abort #x17)
+         (Undefined #x1b)
+         (System #x1f)
+         )
+)
+
+(define-hardware
+  (name h-mbits)
+  (comment "m4,m3,m2,m1,m0")
+  (attrs (ISA arm,thumb))
+  (type register (UINT 5))
+  (set (newval)
+       (sequence ()
+                ; processor goes into an undefined state if bad value,
+                ; so do something similar
+                (case VOID newval
+                       ((ARM-MODE-User ARM-MODE-FIQ ARM-MODE-IRQ
+                         ARM-MODE-Supervisor ARM-MODE-Abort
+                         ARM-MODE-Undefined ARM-MODE-System)
+                        (nop))
+                       (else (error VOID "bad value for M4-M0")))
+                (c-call VOID "arm_mbits_set" newval)))
+)
+
+(define-hardware
+  (name h-cpsr)
+  (comment "Current Program Status Register")
+  (attrs VIRTUAL (ISA arm,thumb))
+  (type register SI) ; One CPSR register.
+  (get ()
+       ; ??? 'twould be nice if one `or' would do
+       (or SI (sll (zext SI (reg BI h-nbit)) (const 31))
+           (or SI (sll (zext SI (reg BI h-zbit)) (const 30))
+                (or SI (sll (zext SI (reg BI h-cbit)) (const 29))
+                     (or SI (sll (zext SI (reg BI h-vbit)) (const 28))
+                          (or SI (sll (zext SI (reg BI h-ibit)) (const 7))
+                               (or SI (sll (zext SI (reg BI h-fbit)) (const 6))
+                                    (or SI (sll (zext SI (reg BI h-tbit)) (const 5))
+                                         (reg UINT h-mbits)))))))))
+  (set (newval)
+       (sequence ()
+                ; FIXME: Processor enters undefined state if software changes
+                ; tbit, so we should do something similar.
+                (set (reg h-nbit) (ne (and newval #x80000000) 0))
+                (set (reg h-zbit) (ne (and newval #x40000000) 0))
+                (set (reg h-cbit) (ne (and newval #x20000000) 0))
+                (set (reg h-vbit) (ne (and newval #x10000000) 0))
+                ; FIXME: user mode is not permitted to change ibit/fbit!
+                (set (reg h-ibit) (ne (and newval #x00000080) 0))
+                (set (reg h-fbit) (ne (and newval #x00000040) 0))
+                (set (reg h-tbit) (ne (and newval #x00000020) 0))
+                (set (reg h-mbits) (and newval #x1f))))
+)
+
+(define-hardware
+  (name h-spsr-fiq)
+  (comment "Saved Process Status Register during FIQ")
+  (attrs (ISA arm,thumb))
+  (type register SI)
+)
+(define-hardware
+  (name h-spsr-svc)
+  (comment "Saved Process Status Register during SVC")
+  (attrs (ISA arm,thumb))
+  (type register SI)
+)
+(define-hardware
+  (name h-spsr-abt)
+  (comment "Saved Process Status Register during Abort")
+  (attrs (ISA arm,thumb))
+  (type register SI)
+)
+(define-hardware
+  (name h-spsr-irq)
+  (comment "Saved Process Status Register during IRQ")
+  (attrs (ISA arm,thumb))
+  (type register SI)
+)
+(define-hardware
+  (name h-spsr-und)
+  (comment "Saved Process Status Register during Undefined")
+  (attrs (ISA arm,thumb))
+  (type register SI)
+)
+
+; Virtual version of spsr to access real one based on current mode.
+
+(define-hardware
+  (name h-spsr)
+  (comment "virtual spsr")
+  (attrs VIRTUAL (ISA arm,thumb))
+  (type register SI)
+  (get ()
+       (case SI (reg h-mbits)
+             ((ARM-MODE-User)       (error SI "can't read spsr in user mode"))
+             ((ARM-MODE-FIQ)        (reg h-spsr-fiq))
+             ((ARM-MODE-IRQ)        (reg h-spsr-irq))
+             ((ARM-MODE-Supervisor) (reg h-spsr-svc))
+             ((ARM-MODE-Abort)      (reg h-spsr-abt))
+             ((ARM-MODE-Undefined)  (reg h-spsr-und))
+             ((ARM-MODE-System)     (error SI "can't read spsr in system mode"))
+             (else (error SI "can't read spsr, invalid mode"))))
+  (set (newval)
+       (case VOID (reg h-mbits)
+             ((ARM-MODE-User)       (error VOID "can't set spsr in user mode"))
+             ((ARM-MODE-FIQ)        (set (reg h-spsr-fiq) newval))
+             ((ARM-MODE-IRQ)        (set (reg h-spsr-irq) newval))
+             ((ARM-MODE-Supervisor) (set (reg h-spsr-svc) newval))
+             ((ARM-MODE-Abort)      (set (reg h-spsr-abt) newval))
+             ((ARM-MODE-Undefined)  (set (reg h-spsr-und) newval))
+             ((ARM-MODE-System)     (error VOID "can't set spsr in system mode"))
+             (else (error VOID "can't set spsr, invalid mode"))))
+)
+
+; Explicitly define the shift types so they can be used in semantics
+; (enums are created for them).
+
+(define-keyword
+  (name shift-type)
+  (comment "operand 2 shift type")
+  (prefix "")
+  (values (lsl 0) (asl 0) (lsr 1) (asr 2) (ror 3))
+)
+
+(define-hardware
+  (name h-operand2-shifttype)
+  (comment "operand2 shift type")
+  (type immediate (UINT 2))
+  (values extern-keyword shift-type)
+)
+\f
+; Utility macros for setting the condition codes.
+
+(define-pmacro (set-zn-flags result)
+  (sequence ()
+           (set zbit (zflag WI result))
+           (set nbit (nflag WI result)))
+)
+
+; Logical operation flag handling:
+; cbit is set to the carry out of a shift operation if present
+; nbit is set to the sign bit
+; vbit is not affected
+; zflag is set to indicate whether the result was zero or not
+
+(define-pmacro (set-logical-cc result carry-out)
+  (sequence ()
+           (set-zn-flags result)
+           (set cbit carry-out))
+)
+
+(define-pmacro (set-add-flags arg1 arg2 carry)
+  (sequence ((SI result))
+           (set result (addc arg1 arg2 carry))
+           (set-zn-flags result)
+           (set cbit (add-cflag arg1 arg2 carry))
+           (set vbit (add-oflag arg1 arg2 carry)))
+)
+
+(define-pmacro (set-sub-flags arg1 arg2 borrow)
+  (sequence ((SI result))
+           (set result (subc arg1 arg2 (not borrow)))
+           (set-zn-flags result)
+           (set cbit (not (sub-cflag arg1 arg2 (not borrow))))
+           (set vbit (sub-oflag arg1 arg2 (not borrow))))
+)
+
+; Utility macros for testing the condition codes.
+
+(define-pmacro (test-ne)  (not zbit))
+(define-pmacro (test-eq)  zbit)
+(define-pmacro (test-gt)  (not (or zbit (xor nbit vbit))))
+(define-pmacro (test-le)  (or zbit (xor nbit vbit)))
+(define-pmacro (test-ge)  (not (xor nbit vbit)))
+(define-pmacro (test-lt)  (xor nbit vbit))
+(define-pmacro (test-hi)  (and cbit (not zbit)))
+(define-pmacro (test-ls)  (or (not cbit) zbit))
+(define-pmacro (test-cc)  (not cbit))
+(define-pmacro (test-cs)  cbit)
+(define-pmacro (test-pl)  (not nbit))
+(define-pmacro (test-mi)  nbit)
+(define-pmacro (test-vc)  (not vbit))
+(define-pmacro (test-vs)  vbit)
+\f
+(if (keep-isa? (arm))
+    (include "arm7.cpu"))
+(if (keep-isa? (thumb))
+    (include "thumb.cpu"))
diff --git a/cgen/arm.sim b/cgen/arm.sim
new file mode 100644 (file)
index 0000000..673e8e1
--- /dev/null
@@ -0,0 +1,39 @@
+; ARM CPU simulator support.  -*- Scheme -*-
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; N.B.
+; - The format of this file is *extremely* wip!
+; - This isn't intended to be simulator independent, it is an application
+;   specific file and not all simulator apps are equivalent.
+; - This file is loaded after all the .cpu files are loaded.
+\f
+; ??? The application (e.g. simulator) may wish to do further processing when
+; the tbit is set.  For a C++ simulator what one would want to do is override
+; the "set" method.  That presumes there's a "set" method to override and
+; that all affected code uses it.  There are several to accomplish this.
+; The first way to accomplish this is to have all code always
+; access hardware elements through their get/set methods.  Perhaps ok,
+; but also maybe overkill.  The second is to specify those that use get/set
+; methods.  One could do this for elements that have get/set specs, but this
+; requires the .cpu file to get it right (and to change when it isn't).
+; A variant of the second is to move this info to an application specific
+; file (much like what .opc files are although even they have the problem of
+; requiring collaboration with the .cpu file. -- to be fixed!).
+; The solution taken here is the latter.
+
+; The h-tbit and h-mbits registers need extra processing when they are set.
+; This is done by specifying the FUN-SET attribute, which causes all machine
+; generated references to go through the `set' access method.
+; Oh no, not FUN-ACCESS again! :-)
+
+(modify-hardware
+ (name h-tbit)
+ (add-attrs FUN-SET)
+)
+
+(modify-hardware
+ (name h-mbits)
+ (add-attrs FUN-SET)
+)
diff --git a/cgen/arm7.cpu b/cgen/arm7.cpu
new file mode 100644 (file)
index 0000000..19b8d5f
--- /dev/null
@@ -0,0 +1,1995 @@
+; ARM7 CPU description.  -*- Scheme -*-
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+;
+; This file is included by arm.cpu.
+;
+; ??? The name of this file may be confusing.
+;
+; Every entry in this file belongs to the "arm" isa.
+; Things are simple since that is the default, but it is something to
+; keep in mind.
+
+(define-attr
+  (type integer)
+  (name R15-OFFSET)
+  (comment "offset in pc value at time of use")
+  (default 8)
+)
+
+(dnf f-cond          "Condition code"       () 31  4)
+
+(dnf f-op2           "Opcode (2 bits)"      () 27  2)
+(dnf f-op3           "Opcode (3 bits)"      () 27  3)
+(dnf f-op4           "Opcode (4 bits)"      () 27  4)
+(dnf f-op5           "Opcode (5 bits)"      () 27  5)
+(dnf f-op6           "Opcode (6 bits)"      () 27  6)
+(dnf f-op24          "Opcode (24 bits)"     () 27 24)
+
+(dnf f-op-alu        "Arith/logic opcode"   () 24  4)
+(dnf f-op-mul        "Sub-opcode for MUL"   ()  7  4)
+(dnf f-op-swap1      "Sub-opcode for SWP"   () 21  2)
+(dnf f-op-swap2      "Sub-opcode for SWP"   () 11  8)
+(dnf f-op-mrs1       "Sub-opcode for MRS"   () 21  6)
+(dnf f-op-mrs2       "Sub-opcode for MRS"   () 11 12)
+(dnf f-op-msr1       "Sub-opcode for MSR"   () 21 10)
+(dnf f-op-msr2       "Sub-opcode for MSR"   () 11  8)
+
+(dnf f-rn            "Rn"                   () 19 4)
+(dnf f-rd           "Rd"                   () 15 4)
+(dnf f-rm            "Rm"                   ()  3 4)
+(dnf f-preindex?     "Pre/post indexing"    () 24 1)
+(dnf f-set-cc?       "Set condition codes?" () 20 1)
+(dnf f-imm?          "Immediate?"           () 25 1)
+(dnf f-byte-qty?     "Byte sized transfer?" () 22 1) 
+
+; Extra fields needed for the Data Processing/PSR Transfer class.
+
+(dnf f-ror-imm8-value   "8 bit value to be rotated"  ()  7 8)
+(dnf f-ror-imm8-rotate  "Rotate amount"              () 11 4)
+
+(dnmf f-ror-imm8 "8 bit rotated immediate" () UINT
+      (f-ror-imm8-value f-ror-imm8-rotate)
+      ; insert
+      (c-call SI "arm_encode_imm12" (ifield f-ror-imm8))
+      ; extract
+      (sequence ()
+               (set (ifield f-ror-imm8)
+                    (ror WI (ifield f-ror-imm8-value)
+                          (mul 2 (ifield f-ror-imm8-rotate))))
+               )
+)
+
+(df  f-imm12         "Immediate (12 bit)"   () 11 12 UINT
+     ((value pc) (c-call SI "arm_encode_imm12" value))
+     ((value pc) 
+      (ror WI (and WI value #xFF)
+           (mul 2 (srl WI (and WI value #xF00) 8))))
+)
+
+; These two are for a register operand2 (i=0).
+(dnf f-operand2-reg?      "Operand2 reg indicator"      () 4  1)
+(dnf f-operand2-shifttype "Operand2 shift type"         () 6  2)
+
+(dnf f-operand2-shiftimm  "Operand2 shift amount (imm)" () 11 5)
+(dnf f-operand2-shiftreg  "Operand2 shift amount (reg)" () 11 4)
+
+; Extra fields needed for the Transfer instruction classes.
+
+(dnf f-up-down       "Base register direction" () 23 1)
+(dnf f-write-back?   "Write back?"             () 21 1)
+(dnf f-load?         "Load or store?"          () 20 1)
+
+; Extra fields needed for the Single Data Transfer instruction class.
+
+(df f-offset12       "Offset"                  (PCREL-ADDR) 11 12 INT
+    ((value pc) (sra WI (sub WI value 2)))
+    ((value pc) (add WI (sll WI value 2) pc)))
+
+(dnf f-uimm12         "Unsigned immediate (12 bit)" () 11 12)
+
+; Extra fields needed for the Branch and Exchange instruction class.
+
+(dnf f-bx-rn         "Rn for branch/exchg"  ()  3 4)
+
+; Extra fields needed for the Halfword Data Transfer instruction class.
+
+(dnf f-halfword?     "Halfword transfer?"    () 5  1)
+(dnf f-signed?       "Signed transfer?"      () 6  1)
+(dnf f-offset4-hi    "High nybble"           () 11 4)
+(dnf f-offset4-lo    "Low nybble"            ()  3 4)
+
+; Extra fields needed for the PSR Transfer instructions.
+
+(dnf f-psr           "PSR selector"          () 22 1)
+
+; Miscellaneous single bit fields.
+
+(dnf f-bit4          "Bit 4"                ()  4 1)
+(dnf f-bit7          "Bit 7"                ()  7 1)
+(dnf f-bit22         "Bit 22"               () 22 1)
+
+(define-multi-ifield
+  (name f-hdt-offset8)
+  (comment "Immediate offset for halfword and signed data transfers")
+  (attrs)
+  (mode UINT)
+  (subfields f-offset4-hi f-offset4-lo)
+  (insert (sequence ()
+                   (set (ifield f-offset4-hi)
+                        (and (srl (ifield f-hdt-offset8) 4) #xF))
+                   (set (ifield f-offset4-lo)
+                        (and (ifield f-hdt-offset8) #xF))))
+  (extract (set (ifield f-hdt-offset8)
+               (or (sll (ifield f-offset4-hi) 4) 
+                   (ifield f-offset4-lo))))
+)
+
+; Extra fields needed for the Multiply instruction class.
+
+(dnf f-acc?          "Accumulate?"          () 21 1)
+(dnf f-mul-rd        "Rd for multiply"      () 19 4)
+(dnf f-mul-rn        "Rn for multiply"      () 15 4)
+(dnf f-rs            "Rs"                   () 11 4)
+(dnf f-unsigned?     "Unsigned multiply?"   () 22 1)
+
+; Extra fields needed for the Multiply Long instruction class.
+
+(dnf f-rdhi          "Rd (high)"            () 19 4)
+(dnf f-rdlo          "Rd (low)"             () 15 4)
+(dnf f-mull-rn       "Rn for long multiply" () 11 4)
+
+; Extra fields needed for the Branch instruction class.
+
+(dnf f-branch-link?  "Branch and link?"     () 24 1)
+(df  f-offset24      "Branch offset"        (PCREL-ADDR) 23 24 INT
+     ((value pc) (sra WI (sub WI value (add pc 8)) 2))
+     ((value pc) (add WI (sll WI value 2) (add pc 8)))
+)
+
+; Extra fields needed for the Block Data Transfer instruction class.
+
+(dnf f-reg-list      "Register list"        () 15 16)
+(dnf f-load-psr?     "Load PSR?"            () 22  1)
+
+; Extra fields needed for the SWI instruction.
+
+(dnf f-swi-comment   "User-defined operand" () 23 24)
+
+; Extra fields needed for the undefined instruction.
+
+(dnf f-undef-dont1  "Don't care"           (RESERVED) 24 20)
+(dnf f-undef-dont2  "Don't care"           (RESERVED)  3  4)
+\f
+; Enumerated constants.
+
+(define-normal-insn-enum cond-codes "condition codes" () COND_ f-cond
+  ("EQ" "NE" "CS" "CC" "MI" "PL" "VS" "VC" "HI" "LS" "GE" "LT" "GT" "LE" "AL")
+)
+
+(define-normal-insn-enum al-opcode "Arith/logic opcode enums" () OP_ f-op-alu
+  ("AND" "EOR" "SUB" "RSB" "ADD" "ADC" "SBC" "RSC" "TST" "TEQ" "CMP" "CMN"
+   "ORR" "MOV" "BIC" "MVN")
+)
+
+(define-normal-insn-enum psr-dests "PSR transfer destinations" () PSR_
+  f-psr ("CURRENT" "SAVED")
+)
+\f
+; Instruction operands.
+
+(dnop cond          "Condition code"                    () h-uint  f-cond)
+(dnop rn            "Rn"                                () h-gr    f-rn)
+(dnop rd           "Rd"                                () h-gr    f-rd)
+(dnop rm            "Rm"                                () h-gr    f-rm)
+(dnop rs            "Rs"                                () h-gr    f-rs)
+(dnop imm?         "Immediate constant?"               () h-uint  f-imm?)
+(dnop set-cc?       "Set condition codes"               () h-uint  f-set-cc?)
+
+(dnop ror-imm8      "Rotated immediate (8 bits)"        () h-uint  f-ror-imm8)
+(dnop imm12         "Immediate"                         () h-uint  f-imm12)
+(dnop uimm12        "Unsigned immediate (12 bits)"      () h-uint  f-uimm12)
+
+(dnop operand2-shifttype "Operand 2 shift type"         ()
+      h-operand2-shifttype f-operand2-shifttype)
+(dnop operand2-shiftimm  "Operand 2 shift immediate"    ()
+      h-uint f-operand2-shiftimm)
+(dnop operand2-shiftreg  "Operand 2 shift reg"          ()
+      h-gr f-operand2-shiftreg)
+
+(dnop reglist       "Register list"                     () h-uint  f-reg-list)
+(dnop bx-rn         "Source register (BX insn)"         () h-gr    f-bx-rn)
+(dnop mul-rd        "Destination register (MUL insns)"  () h-gr    f-mul-rd)
+(dnop mul-rn        "Source register (MUL insns)"       () h-gr    f-mul-rn)
+(dnop rdhi          "Rd (high) for long multiply"       () h-gr    f-rdhi)
+(dnop rdlo          "Rd (low) for long multiply"        () h-gr    f-rdlo)
+
+(dnop offset12      "Offset (12 bits)"                  () h-addr  f-offset12)
+(dnop offset24      "Branch offset (24 bits)"           () h-iaddr f-offset24)
+(dnop hdt-offset8   "Split offset (8 bits)"             () h-addr  f-hdt-offset8)
+
+(dnop swi-comment   "Argument to swi"                   () h-uint  f-swi-comment)
+
+(dnop undef-dont1   "Don't care"                       () h-uint  f-undef-dont1)
+(dnop undef-dont2   "Don't care"                        () h-uint  f-undef-dont2)
+\f
+; Useful macros.
+
+; Same as dni but leave out timing.
+; dnai - define-normal-arm-insn
+
+(define-pmacro (dnai xname xcomment xattrs xsyntax xformat xsemantics)
+  (define-insn
+    (name xname)
+    (comment xcomment)
+    (.splice attrs (.unsplice xattrs))
+    (syntax xsyntax)
+    (format xformat)
+    (semantics xsemantics)
+    )
+)
+\f
+; Branch insns.
+
+(dnai b "Branch"
+     ()
+     "b$cond $offset24"
+     (+ cond (f-op3 5) (f-branch-link? 0) offset24)
+     (set pc offset24)
+)
+
+(dnai bl "Branch and link"
+     ()
+     "bl$cond $offset24"
+     (+ cond (f-op3 5) (f-branch-link? 1) offset24)
+     (sequence ()
+              (set (reg h-gr 14) (and (add pc 4) -4))
+              (set pc offset24))
+)
+
+(dnai bx "Branch and exchange"
+     ()
+     "bx$cond ${bx-rn}"
+     (+ cond (f-op24 #x12FFF1) bx-rn)
+     (sequence ()
+              (set pc (and bx-rn #xfffffffe))
+              (if (and bx-rn 1)
+                  (set (reg h-tbit) 1)))
+)
+\f
+; Load word/byte insns.
+
+(define-pmacro (do-word/byte-load byte? preindex? writeback? up? offset-expr)
+  (sequence ((SI addr) (SI offset))
+           (set offset offset-expr)
+           (if preindex?
+               (if up?
+                   (set addr (add rn offset))
+                   (set addr (sub rn offset)))
+               (set addr rn))
+           ; If writeback in postindexing case -> do transfer
+           ; in non-priviledged mode.
+           ; FIXME: still need to handle non-word-aligned addresses
+           (if (andif (not preindex?) writeback?)
+               (if byte?
+                   ; FIXME: specify "non-priviledged mode" `selector'
+                   (if (eq f-rd 15)
+                       (set pc (zext SI (mem QI addr)))
+                       (set rd (zext SI (mem QI addr))))
+                   ; !byte
+                   (if (eq f-rd 15)
+                       (set pc (mem SI addr))
+                       (set rd (mem SI addr))))
+               ; else
+               (if byte?
+                   (if (eq f-rd 15)
+                       (set pc (zext SI (mem QI addr)))
+                       (set rd (zext SI (mem QI addr))))
+                   ; !byte
+                   (if (eq f-rd 15)
+                       (set pc (mem SI addr))
+                       (set rd (mem SI addr)))))
+           (if (not preindex?)
+               (if up?
+                   (set addr (add rn offset))
+                   (set addr (sub rn offset))))
+           (if (orif (not preindex?)
+                     (andif preindex? writeback?))
+               (set rn addr))
+           )
+)
+
+(define-pmacro (load-word/byte name comment size-char t-char
+                              byte? preindex? writeback? up?)
+  (begin
+    (dnai (.sym name -imm-offset)
+         (.str comment ", immediate offset")
+         ()
+         ; ??? Enhancement to compute offset syntax based on args?
+         (.str "ldr${cond}" size-char t-char " $rd,???")
+         (+ cond (f-op2 1)
+            (f-imm? 0) (f-preindex? preindex?) (f-up-down up?)
+            (f-byte-qty? byte?) (f-write-back? writeback?)
+            (f-load? 1) rn rd uimm12)
+         (do-word/byte-load byte? preindex? writeback? up? uimm12)
+         )
+    (dnai (.sym name -reg-offset)
+         (.str comment ", register offset")
+         ()
+         (.str "ldr${cond}" size-char t-char " $rd,???")
+         (+ cond (f-op2 1)
+            (f-imm? 1) (f-preindex? preindex?) (f-up-down up?)
+            (f-byte-qty? byte?) (f-write-back? writeback?)
+            (f-load? 1) rn rd rm
+            (f-operand2-reg? 0) operand2-shifttype operand2-shiftimm)
+         (do-word/byte-load byte? preindex? writeback? up?
+                            (c-call SI "compute_operand2_immshift" rm
+                                     operand2-shifttype operand2-shiftimm))
+         )
+    )
+)
+
+(load-word/byte #:name ldr-post-dec
+               #:comment "Load word (postindex, decrement)"
+               #:size-char "" #:t-char ""
+               #:byte? 0 #:preindex? 0 #:writeback? 0 #:up? 0)
+
+(load-word/byte #:name ldr-post-inc
+               #:comment "Load word (postindex, increment)"
+               #:size-char "" #:t-char ""
+               #:byte? 0 #:preindex? 0 #:writeback? 0 #:up? 1)
+
+(load-word/byte #:name ldr-post-dec-nonpriv
+               #:comment "Load word (postindex, decrement, nonpriv)"
+               #:size-char "" #:t-char "t"
+               #:byte? 0 #:preindex? 0 #:writeback? 1 #:up? 0)
+
+(load-word/byte #:name ldr-post-inc-nonpriv
+               #:comment "Load word (postindex, increment, nonpriv)"
+               #:size-char "" #:t-char "t"
+               #:byte? 0 #:preindex? 0 #:writeback? 1 #:up? 1)
+
+(load-word/byte #:name ldr-pre-dec
+               #:comment "Load word (preindex, decrement)"
+               #:size-char "" #:t-char ""
+               #:byte? 0 #:preindex? 1 #:writeback? 0 #:up? 0)
+
+(load-word/byte #:name ldr-pre-inc
+               #:comment "Load word (preindex, increment)"
+               #:size-char "" #:t-char ""
+               #:byte? 0 #:preindex? 1 #:writeback? 0 #:up? 1)
+
+(load-word/byte #:name ldr-pre-dec-wb
+               #:comment "Load word (preindex, decrement, writeback)"
+               #:size-char "" #:t-char ""
+               #:byte? 0 #:preindex? 1 #:writeback? 1 #:up? 0)
+
+(load-word/byte #:name ldr-pre-inc-wb
+               #:comment "Load word (preindex, increment, writeback)"
+               #:size-char "" #:t-char ""
+               #:byte? 0 #:preindex? 1 #:writeback? 1 #:up? 1)
+
+(load-word/byte #:name ldrb-post-dec
+               #:comment "Load byte (postindex, decrement)"
+               #:size-char "b" #:t-char ""
+               #:byte? 1 #:preindex? 0 #:writeback? 0 #:up? 0)
+
+(load-word/byte #:name ldrb-post-inc
+               #:comment "Load byte (postindex, increment)"
+               #:size-char "b" #:t-char ""
+               #:byte? 1 #:preindex? 0 #:writeback? 0 #:up? 1)
+
+(load-word/byte #:name ldrb-post-dec-nonpriv
+               #:comment "Load byte (postindex, decrement, nonpriv)"
+               #:size-char "b" #:t-char "t"
+               #:byte? 1 #:preindex? 0 #:writeback? 1 #:up? 0)
+
+(load-word/byte #:name ldrb-post-inc-nonpriv
+               #:comment "Load byte (postindex, increment, nonpriv)"
+               #:size-char "b" #:t-char "t"
+               #:byte? 1 #:preindex? 0 #:writeback? 1 #:up? 1)
+
+(load-word/byte #:name ldrb-pre-dec
+               #:comment "Load byte (preindex, decrement)"
+               #:size-char "b" #:t-char ""
+               #:byte? 1 #:preindex? 1 #:writeback? 0 #:up? 0)
+
+(load-word/byte #:name ldrb-pre-inc
+               #:comment "Load byte (preindex, increment)"
+               #:size-char "b" #:t-char ""
+               #:byte? 1 #:preindex? 1 #:writeback? 0 #:up? 1)
+
+(load-word/byte #:name ldrb-pre-dec-wb
+               #:comment "Load byte (preindex, decrement, writeback)"
+               #:size-char "b" #:t-char ""
+               #:byte? 1 #:preindex? 1 #:writeback? 1 #:up? 0)
+
+(load-word/byte #:name ldrb-pre-inc-wb
+               #:comment "Load byte (preindex, increment, writeback)"
+               #:size-char "b" #:t-char ""
+               #:byte? 1 #:preindex? 1 #:writeback? 1 #:up? 1)
+\f
+; Store word/byte insns.
+
+(define-pmacro (do-word/byte-store byte? preindex? writeback? up? offset-expr)
+  (sequence ((SI addr) (SI offset))
+           (set offset offset-expr)
+           (if preindex?
+               (if up?
+                   (set addr (add rn offset))
+                   (set addr (sub rn offset)))
+               (set addr rn))
+            ; If writeback in postindexing case -> do transfer
+            ; in non-priviledged mode.
+            ; FIXME: still need to handle non-word-aligned addresses
+            (if (andif (not preindex?) writeback?)
+               (if byte?
+                   ; FIXME: specify "non-priviliged mode" `selector'
+                   (set (mem QI addr) (trunc QI rd))
+                   (set (mem SI addr) rd))
+               (if byte?
+                   (set (mem QI addr) (trunc QI rd))
+                   (set (mem SI addr) rd)))
+           (if (not preindex?)
+               (if up?
+                   (set addr (add rn offset))
+                   (set addr (sub rn offset))))
+           (if (orif (not preindex?)
+                     (andif preindex? writeback?))
+               (set rn addr))
+           )
+)
+
+(define-pmacro (store-word/byte name comment size-char t-char 
+                              byte? preindex? writeback? up?)
+  (begin
+    (dnai (.sym name -imm-offset)
+         (.str comment ", immediate offset")
+         ()
+         (.str "ldr${cond}" size-char t-char " $rd,???")
+         (+ cond (f-op2 1)
+            (f-imm? 0) (f-preindex? preindex?) (f-up-down up?)
+            (f-byte-qty? byte?) (f-write-back? writeback?)
+            (f-load? 0) rn rd uimm12)
+         (do-word/byte-store byte? preindex? writeback? up? uimm12)
+         )
+
+    (dnai (.sym name -reg-offset)
+         (.str comment ", register offset")
+         ()
+         (.str "str${cond}" size-char t-char " $rd,???")
+         (+ cond (f-op2 1)
+            (f-imm? 1) (f-preindex? preindex?) (f-up-down up?)
+            (f-byte-qty? byte?) (f-write-back? writeback?)
+            (f-load? 0) rn rd rm
+            (f-operand2-reg? 0) operand2-shifttype operand2-shiftimm)
+         (do-word/byte-store byte? preindex? writeback? up?
+                            (c-call SI "compute_operand2_immshift" rm
+                                     operand2-shifttype operand2-shiftimm))
+         )
+    )
+)
+
+(store-word/byte #:name str-post-dec
+                #:comment "Store word (postindex, decrement)"
+                #:size-char "" #:t-char ""
+                #:byte? 0 #:preindex? 0 #:writeback? 0 #:up? 0)
+
+(store-word/byte #:name str-post-inc
+                #:comment "Store word (postindex, increment)"
+                #:size-char "" #:t-char ""
+                #:byte? 0 #:preindex? 0 #:writeback? 0 #:up? 1)
+
+(store-word/byte #:name str-post-dec-nonpriv
+                #:comment "Store word (postindex, decrement, nonpriv)"
+                #:size-char "" #:t-char "t"
+                #:byte? 0 #:preindex? 0 #:writeback? 1 #:up? 0)
+
+(store-word/byte #:name str-post-inc-nonpriv
+                #:comment "Store word (postindex, increment, nonpriv)"
+                #:size-char "" #:t-char "t"
+                #:byte? 0 #:preindex? 0 #:writeback? 1 #:up? 1)
+
+(store-word/byte #:name str-pre-dec
+                #:comment "Store word (preindex, decrement)"
+                #:size-char "" #:t-char ""
+                #:byte? 0 #:preindex? 1 #:writeback? 0 #:up? 0)
+
+(store-word/byte #:name str-pre-inc
+                #:comment "Store word (preindex, increment)"
+                #:size-char "" #:t-char ""
+                #:byte? 0 #:preindex? 1 #:writeback? 0 #:up? 1)
+
+(store-word/byte #:name str-pre-dec-wb
+                #:comment "Store word (preindex, decrement, writeback)"
+                #:size-char "" #:t-char ""
+                #:byte? 0 #:preindex? 1 #:writeback? 1 #:up? 0)
+
+(store-word/byte #:name str-pre-inc-wb
+                #:comment "Store word (preindex, increment, writeback)"
+                #:size-char "" #:t-char ""
+                #:byte? 0 #:preindex? 1 #:writeback? 1 #:up? 1)
+
+(store-word/byte #:name strb-post-dec
+                #:comment "Store byte (postindex, decrement)"
+                #:size-char "b" #:t-char ""
+                #:byte? 1 #:preindex? 0 #:writeback? 0 #:up? 0)
+
+(store-word/byte #:name strb-post-inc
+                #:comment "Store byte (postindex, increment)"
+                #:size-char "" #:t-char ""
+                #:byte? 1 #:preindex? 0 #:writeback? 0 #:up? 1)
+
+(store-word/byte #:name strb-post-dec-nonpriv
+                #:comment "Store byte (postindex, decrement, nonpriv)"
+                #:size-char "" #:t-char "t"
+                #:byte? 1 #:preindex? 0 #:writeback? 1 #:up? 0)
+
+(store-word/byte #:name strb-post-inc-nonpriv
+                #:comment "Store byte (postindex, increment, nonpriv)"
+                #:size-char "" #:t-char "t"
+                #:byte? 1 #:preindex? 0 #:writeback? 1 #:up? 1)
+
+(store-word/byte #:name strb-pre-dec
+                #:comment "Store byte (preindex, decrement)"
+                #:size-char "" #:t-char ""
+                #:byte? 1 #:preindex? 1 #:writeback? 0 #:up? 0)
+
+(store-word/byte #:name strb-pre-inc
+                #:comment "Store byte (preindex, increment)"
+                #:size-char "" #:t-char ""
+                #:byte? 1 #:preindex? 1 #:writeback? 0 #:up? 1)
+
+(store-word/byte #:name strb-pre-dec-wb
+                #:comment "Store byte (preindex, decrement, writeback)"
+                #:size-char "" #:t-char ""
+                #:byte? 1 #:preindex? 1 #:writeback? 1 #:up? 0)
+
+(store-word/byte #:name strb-pre-inc-wb
+                #:comment "Store byte (preindex, increment, writeback)"
+                #:size-char "" #:t-char ""
+                #:byte? 1 #:preindex? 1 #:writeback? 1 #:up? 1)
+
+; Halfword and signed load insns.
+
+(define-pmacro (do-halfword-load preindex? up? writeback? signed?
+                                halfword? offset-expr)
+  (sequence ((SI addr) (SI offset))
+           (set offset offset-expr)
+
+           ; Handle pre-increment.
+           (if preindex?
+               (if up?
+                   (set addr (add rn offset))
+                   (set addr (sub rn offset)))
+               (set addr rn))
+
+           ; Do the transfer; sign extend the result.
+           (if halfword?
+               (if signed?
+                   (if (eq f-rd 15)
+                       (set pc (ext SI (mem HI addr)))
+                       (set rd (ext SI (mem HI addr))))
+                   (if (eq f-rd 15)
+                       (set pc (zext SI (mem HI addr)))
+                       (set rd (zext SI (mem HI addr)))))
+               (if (eq f-rd 15)
+                   (set pc (ext SI (mem QI addr)))
+                   (set rd (ext SI (mem QI addr)))))
+
+           (if (not preindex?)
+               (if up?
+                   (set addr (add rn offset))
+                   (set addr (sub rn offset))))
+           
+           ; Write back the modified base register.
+           (if (orif (not preindex?)
+                     (andif preindex? writeback?))
+               (set rn addr))
+           )
+)
+
+(define-pmacro (load-halfword name comment preindex? up? writeback?
+                             signed? halfword?)
+  (begin
+    (dnai (.sym name -imm-offset)
+         (.str comment ", immediate offset")
+         ()
+         (.str "FIXME")
+         (+ cond (f-op3 0) (f-preindex? preindex?) (f-up-down up?)
+            (f-bit22 1) (f-write-back? writeback?) (f-load? 1)
+            rn rd (f-bit7 1) (f-signed? signed?) (f-halfword? halfword?) 
+            (f-bit4 1) hdt-offset8)
+         (do-halfword-load preindex? up? writeback? signed? halfword? hdt-offset8)
+         )
+    (dnai (.sym name -reg-offset)
+         (.str comment ", register offset")
+         ()
+         (.str "FIXME")
+         (+ cond (f-op3 0) (f-preindex? preindex?) (f-up-down up?)
+            (f-bit22 0) (f-write-back? writeback?) (f-load? 1)
+            rn rd (f-offset4-hi 0) (f-bit7 1) (f-signed? signed?)
+            (f-halfword? halfword?) (f-bit4 1) rm)
+         (do-halfword-load preindex? up? writeback? signed? halfword? rm)
+         )
+    )
+)
+
+(define-pmacro (do-halfword-store preindex? up? writeback? offset-expr)
+  (sequence ((SI addr) (SI offset))
+           (set offset offset-expr)
+
+           ; Handle pre-increment.
+           (if preindex?
+               (if up?
+                   (set addr (add rn offset))
+                   (set addr (sub rn offset)))
+               (set addr rn))
+
+           ; Do the transfer; unsigned halfwords only.
+           (set (mem HI addr) (trunc HI rd))
+           
+           (if (not preindex?)
+               (if up?
+                   (set addr (add rn offset))
+                   (set addr (sub rn offset))))
+
+           (if (orif (not preindex?)
+                     (andif preindex? writeback?))
+               (set rn addr))
+           )
+)
+
+(define-pmacro (store-halfword name comment preindex? up? writeback?)
+  (begin
+    (dnai (.sym name -imm-offset)
+         (.str comment ", immediate offset")
+         ()
+         (.str "FIXME")
+         (+ cond (f-op3 0) (f-preindex? preindex?) (f-up-down up?)
+            (f-bit22 1) (f-write-back? writeback?) (f-load? 0)
+            rn rd (f-bit7 1) (f-signed? 0) (f-halfword? 1)
+            (f-bit4 1) hdt-offset8)
+         (do-halfword-store preindex? up? writeback? hdt-offset8)
+         )
+    (dnai (.sym name -reg-offset)
+         (.str comment ", register offset")
+         ()
+         (.str "FIXME")
+         (+ cond (f-op3 0) (f-preindex? preindex?) (f-up-down up?)
+            (f-bit22 0) (f-write-back? writeback?) (f-load? 0)
+            rn rd (f-offset4-hi 0) (f-bit7 1) (f-signed? 0)
+            (f-halfword? 1) (f-bit4 1) rm)
+         (do-halfword-store preindex? up? writeback? rm)
+         )
+    )
+)
+
+(store-halfword #:name strh-pre-dec
+               #:comment "Store halfword (predecrement)"
+               #:preindex? 1 #:up? 0 #:writeback? 0)
+
+(store-halfword #:name strh-pre-inc
+               #:comment "Store halfword (preincrement)"
+               #:preindex? 1 #:up? 1 #:writeback? 0)
+
+(store-halfword #:name strh-pre-dec-wb
+               #:comment "Store halfword (predec, writeback)"
+               #:preindex? 1 #:up? 0 #:writeback? 1)
+
+(store-halfword #:name strh-pre-inc-wb
+               #:comment "Store halfword (preinc, writeback)"
+               #:preindex? 1 #:up? 1 #:writeback? 1)
+
+(store-halfword #:name strh-post-dec
+               #:comment "Store halfword (postdecrement)"
+               #:preindex? 0 #:up? 0 #:writeback? 0)
+
+(store-halfword #:name strh-post-inc
+               #:comment "Store halfword (postindex, increment)"
+               #:preindex? 0 #:up? 1 #:writeback? 0)
+
+
+(load-halfword #:name ldrsb-pre-dec
+              #:comment "Load signed byte (predecrement)"
+              #:preindex? 1 #:up? 0 #:writeback? 0
+              #:signed? 1 #:halfword? 0)
+
+(load-halfword #:name ldrsb-pre-inc
+              #:comment "Load signed byte (preincrement)"
+              #:preindex? 1 #:up? 1 #:writeback? 0
+              #:signed? 1 #:halfword? 0)
+
+(load-halfword #:name ldrsb-pre-dec-wb
+              #:comment "Load signed byte (predec, writeback)"
+              #:preindex? 1 #:up? 0 #:writeback? 1
+              #:signed? 1 #:halfword? 0)
+
+(load-halfword #:name ldrsb-pre-inc-wb
+              #:comment "Load signed byte (preinc, writeback)"
+              #:preindex? 1 #:up? 1 #:writeback? 1
+              #:signed? 1 #:halfword? 0)
+
+(load-halfword #:name ldrsb-post-dec
+              #:comment "Load signed byte (postdecrement)"
+              #:preindex? 0 #:up? 0 #:writeback? 0
+              #:signed? 1 #:halfword? 0)
+
+(load-halfword #:name ldrsb-post-inc
+              #:comment "Load signed byte (postindex, increment)"
+              #:preindex? 0 #:up? 1 #:writeback? 0
+              #:signed? 1 #:halfword? 0)
+
+(load-halfword #:name ldrh-pre-dec
+              #:comment "Load halfword (predecrement)"
+              #:preindex? 1 #:up? 0 #:writeback? 0
+              #:signed? 0 #:halfword? 1)
+
+(load-halfword #:name ldrh-pre-inc
+              #:comment "Load halfword (preincrement)"
+              #:preindex? 1 #:up? 1 #:writeback? 0
+              #:signed? 0 #:halfword? 1)
+
+(load-halfword #:name ldrh-pre-dec-wb
+              #:comment "Load halfword (predec, writeback)"
+              #:preindex? 1 #:up? 0 #:writeback? 1
+              #:signed? 0 #:halfword? 1)
+
+(load-halfword #:name ldrh-pre-inc-wb
+              #:comment "Load halfword (preinc, writeback)"
+              #:preindex? 1 #:up? 1 #:writeback? 1
+              #:signed? 0 #:halfword? 1)
+
+(load-halfword #:name ldrh-post-dec
+              #:comment "Load halfword (postdecrement)"
+              #:preindex? 0 #:up? 0 #:writeback? 0
+              #:signed? 0 #:halfword? 1)
+
+(load-halfword #:name ldrh-post-inc
+              #:comment "Load halfword (postincrement)"
+              #:preindex? 0 #:up? 1 #:writeback? 0
+              #:signed? 0 #:halfword? 1)
+
+(load-halfword #:name ldrsh-pre-dec
+              #:comment "Load signed halfword (predecrement)"
+              #:preindex? 1 #:up? 0 #:writeback? 0
+              #:signed? 1 #:halfword? 1)
+
+(load-halfword #:name ldrsh-pre-inc
+              #:comment "Load signed halfword (preincrement)"
+              #:preindex? 1 #:up? 1 #:writeback? 0
+              #:signed? 1 #:halfword? 1)
+
+(load-halfword #:name ldrsh-pre-dec-wb
+              #:comment "Load signed halfword (predec, writeback)"
+              #:preindex? 1 #:up? 0 #:writeback? 1
+              #:signed? 1 #:halfword? 1)
+
+(load-halfword #:name ldrsh-pre-inc-wb
+              #:comment "Load signed halfword (preinc, writeback)"
+              #:preindex? 1 #:up? 1 #:writeback? 1
+              #:signed? 1 #:halfword? 1)
+
+(load-halfword #:name ldrsh-post-dec
+              #:comment "Load signed halfword (postdecrement)"
+              #:preindex? 0 #:up? 0 #:writeback? 0
+              #:signed? 1 #:halfword? 1)
+
+(load-halfword #:name ldrsh-post-inc
+              #:comment "Load signed halfword (postincrement)"
+              #:preindex? 0 #:up? 1 #:writeback? 0
+              #:signed? 1 #:halfword? 1)
+\f
+; Multiply instructions.
+
+(define-pmacro (set-mul-cond-maybe result)
+  (if set-cc?
+      (sequence ()
+               ; vbit is not affected
+               ; cbit is set to a meaningless value, we just ignore it
+               (set zbit (zflag WI result))
+               (set nbit (nflag WI result))))
+)
+
+(define-pmacro (set-muldi-cond-maybe result)
+  (if set-cc?
+      (sequence ()
+               ; vbit,cbit are set to meaningless values, we just ignore them
+               (set zbit (zflag DI result))
+               (set nbit (nflag DI result))))
+)
+
+(dnai mul "Multiply"
+     ()
+     "mul$cond${set-cc?} ${mul-rd},$rm,$rs"
+     (+ cond (f-op6 0) (f-acc? 0) set-cc? mul-rd mul-rn rs (f-op-mul 9) rm)
+     (sequence ((WI result))
+              (set result (mul rm rs))
+              (set mul-rd result)
+              (set-mul-cond-maybe result))
+)
+
+(dnai mla "Multiply and accumulate"
+     ()
+     "mla$cond${set-cc?} ${mul-rd},$rm,$rs,${mul-rn}"
+     (+ cond (f-op6 0) (f-acc? 1) set-cc? mul-rd mul-rn rs (f-op-mul 9) rm)
+     (sequence ((WI result))
+              (set mul-rd (add (mul rm rs) mul-rn))
+              (set-mul-cond-maybe result))
+)
+
+(dnai umull "Multiply long (unsigned)"
+     ()
+     "umull$cond${set-cc?} $rdlo,$rdhi,$rm,$rs"
+     (+ cond (f-op5 1) (f-unsigned? 0) (f-acc? 0) set-cc? rdhi rdlo rs (f-op-mul 9) rm)
+     (sequence ((DI mul-result) (SI hi) (SI lo))
+              (set mul-result (mul (zext DI rs) (zext DI rm)))
+              (set rdhi (subword SI mul-result 0))
+              (set rdlo (subword SI mul-result 1))
+              (set-muldi-cond-maybe mul-result))
+)
+
+(dnai umlal "Multiply long and accumulate (unsigned)"
+     ()
+     "umlal$cond${set-cc?} $rdlo,$rdhi,$rm,$rs"
+     (+ cond (f-op5 1) (f-unsigned? 0) (f-acc? 1) set-cc? rdhi rdlo rs (f-op-mul 9) rm)
+     (sequence ((DI mul-result) (SI hi) (SI lo))
+              (set mul-result (join DI SI rdhi rdlo))
+              (set mul-result
+                   (add (mul (zext DI rs) (zext DI rm)) mul-result))
+              (set rdhi (subword SI mul-result 0))
+              (set rdlo (subword SI mul-result 1))
+              (set-muldi-cond-maybe mul-result))
+)
+
+(dnai smull "Multiply long (signed)"
+     ()
+     "smull$cond${set-cc?} $rdlo,$rdhi,$rm,$rs"
+     (+ cond (f-op5 1) (f-unsigned? 1) (f-acc? 0) set-cc? rdhi rdlo rs 
+       (f-op-mul 9) rm)
+     (sequence ((DI mul-result) (SI hi) (SI lo))
+              (set mul-result (mul (ext DI rs) (ext DI rm)))
+              (set rdhi (subword SI mul-result 0))
+              (set rdlo (subword SI mul-result 1))
+              (set-muldi-cond-maybe mul-result))
+)
+
+(dnai smlal "Multiply long and accumulate (signed)"
+     ()
+     "smlal$cond${set-cc?} $rdlo,$rdhi,$rm,$rs"
+     (+ cond (f-op5 1) (f-unsigned? 1) (f-acc? 1) set-cc? rdhi rdlo rs
+       (f-op-mul 9) rm)
+     (sequence ((DI mul-result) (SI hi) (SI lo))
+              (set mul-result (join DI SI rdhi rdlo))
+              (set mul-result
+                   (add (mul (ext DI rs) (ext DI rm)) mul-result))
+              (set rdhi (subword SI mul-result 0))
+              (set rdlo (subword SI mul-result 1))
+              (set-muldi-cond-maybe mul-result))
+)
+\f
+(dnai swp "Swap word"
+     ()
+     "swp$cond $rd,$rm,[$rn]"
+     (+ cond (f-op5 2) (f-byte-qty? 0) (f-op-swap1 #b00) rn rd
+       (f-op-swap2 9) rm)
+     (sequence ((WI temp))
+              (set temp (mem WI rn)) ; read contents of swap address
+              (set (mem WI rn) rm)   ; write rm to the swap address
+              (set rd temp))          ; store old swap contents in rd
+)
+
+(dnai swpb "Swap byte"
+     ()
+     "swpb${cond}b $rd,$rm,[$rn]"
+     (+ cond (f-op5 2) (f-byte-qty? 1) (f-op-swap1 #b00) rn rd
+       (f-op-swap2 #b00001001) rm)
+     (sequence ((WI temp))
+              (set temp (mem QI rn)) ; read contents of swap address
+              (set (mem QI rn) rm)   ; write rm to the swap address
+              (set rd temp))         ; store old swap contents in rd
+)
+
+(dnai swi "Software interrupt"
+     ()
+     "swi$cond ${swi-comment}"
+     (+ cond (f-op4 #xF) swi-comment)
+         ; Take the software trap. Jump to the vector held in
+         ; 0x8. User code retrieves the comment field itself (see the
+         ; SWI instruction description in the ARM 7TDMI data sheet).
+         ; FIXME: more state change than this occurs
+         ;(set pc (mem WI 8)))
+     (set pc (c-call SI "arm_swi" pc swi-comment))
+)
+\f
+; Data processing [sic] instructions with a register for operand2.
+; The immediate operand2 case is handled separately.
+;
+; FIXME: 'twould be nice to split up each semantic element into
+; shifttype, set-cc/no-set-cc, set-pc,no-set-pc cases.
+; This is something that could be done as an optimization or extension,
+; without having to change this code [which would have general utility].
+;
+; FIXME: assembler syntaxes don't take into account unary vs binary vs
+; no-result.  Later.
+
+; Logical operation semantic code.
+;
+; Flag handling if rd != pc:
+; cbit is set to the carry out of a shift operation if present
+; nbit is set to the sign bit
+; vbit is not affected
+; zflag is set to indicate whether the result was zero or not
+;
+; Flag handling if rd = pc:
+; cpsr is set from spsr
+; N.B. The pc must be set before setting cpsr as the registers that go into
+; computing the new value of pc may change when cpsr is set (new register
+; bank may get installed).
+
+; Logical operation, with a result.
+
+(define-pmacro (logical-op mnemonic comment-text opcode semantic-fn)
+  (begin
+    (dnai
+     (.sym mnemonic -reg/imm-shift)
+     (.str comment-text " immediate shift")
+     ()
+     (.str mnemonic "$cond${set-cc?} $rd,$rn,$rm,${operand2-shifttype} ${operand2-shiftimm}")
+     (+ cond (f-op2 0) (f-imm? 0) opcode set-cc? rn rd rm
+       (f-operand2-reg? 0) operand2-shifttype operand2-shiftimm)
+     (sequence ((SI operand2) (BI carry-out) (SI result))
+              (set operand2
+                   (c-call SI "compute_operand2_immshift" rm
+                           operand2-shifttype operand2-shiftimm))
+              (set carry-out
+                   (c-call BI "compute_carry_out_immshift" rm
+                           operand2-shifttype operand2-shiftimm cbit))
+              (set result (semantic-fn rn operand2))
+              (if (eq f-rd 15)
+                  (sequence ()
+                            (set pc result)
+                            (if set-cc?
+                                (set (reg h-cpsr) (reg h-spsr))))
+                  (sequence ()
+                            (set rd result)
+                            (if set-cc?
+                                (set-logical-cc result carry-out)))))
+     )
+    (dnai
+     (.sym mnemonic -reg/reg-shift)
+     (.str comment-text " register shift")
+     ((R15-OFFSET 12))
+     (.str mnemonic "$cond${set-cc?} $rd,$rn,$rm,${operand2-shifttype} ${operand2-shiftreg}")
+     (+ cond (f-op2 0) (f-imm? 0) opcode set-cc? rn rd rm
+       (f-operand2-reg? 1) (f-bit7 0)
+       operand2-shifttype operand2-shiftreg)
+     (sequence ((SI operand2) (BI carry-out) (SI result))
+              (set operand2
+                   (c-call SI "compute_operand2_regshift" rm
+                           operand2-shifttype operand2-shiftreg))
+              (set carry-out
+                   (c-call BI "compute_carry_out_regshift" rm
+                           operand2-shifttype operand2-shiftreg cbit))
+              (set result (semantic-fn rn operand2))
+              (if (eq f-rd 15)
+                  (sequence ()
+                            (set pc result)
+                            (if set-cc?
+                                (set (reg h-cpsr) (reg h-spsr))))
+                  (sequence ()
+                            (set rd result)
+                            (if set-cc?
+                                (set-logical-cc result carry-out)))))
+     )
+    )
+)
+
+; Arithmetic operation semantic code.
+;
+; Flag handling if rd != pc:
+; cbit is set to the carry out of the ALU
+; N.B. For subtraction, the "carry" bit is actually a "borrow" bit.
+; nbit is set to the sign bit
+; vbit is set to indicate if an overflow occured
+; zbit is set to indicate whether the result was zero or not
+;
+; Flag handling if rd = pc:
+; cpsr is set from spsr
+
+; Arithmetic operation, with a result.
+
+(define-pmacro (arith-op mnemonic comment-text opcode semantic-fn set-flags)
+  (begin
+    (dnai
+     (.sym mnemonic -reg/imm-shift)
+     (.str comment-text " immediate shift")
+     ()
+     (.str mnemonic "$cond${set-cc?} $rd,$rn,$rm,${operand2-shifttype} ${operand2-shiftimm}")
+     (+ cond (f-op2 0) (f-imm? 0) opcode set-cc? rn rd rm
+       (f-operand2-reg? 0) operand2-shifttype operand2-shiftimm)
+     (sequence ((SI operand2) (SI result) (SI temp-op1) (SI temp-op2))
+              (set operand2
+                   (c-call SI "compute_operand2_immshift" rm
+                            operand2-shifttype operand2-shiftimm))
+              (set temp-op1 rn)
+              (set temp-op2 operand2)
+              (set result (semantic-fn rn operand2 cbit))
+              (if (eq f-rd 15)
+                  (sequence ()
+                            (set pc result)
+                            (if set-cc?
+                                (set (reg h-cpsr) (reg h-spsr))))
+                  (sequence ()
+                            (set rd result)
+                            (if set-cc?
+                                (set-flags temp-op1 temp-op2 cbit)))))
+     )
+    (dnai
+     (.sym mnemonic -reg/reg-shift)
+     (.str comment-text " register shift")
+     ((R15-OFFSET 12))
+     (.str mnemonic "$cond${set-cc?} $rd,$rn,$rm,${operand2-shifttype} ${operand2-shiftreg}")
+     (+ cond (f-op2 0) (f-imm? 0) opcode set-cc? rn rd rm
+       (f-operand2-reg? 1) (f-bit7 0)
+       operand2-shifttype operand2-shiftreg)
+     (sequence ((SI operand2) (SI result) (SI temp-op1) (SI temp-op2))
+              (set operand2
+                   (c-call SI "compute_operand2_regshift" rm
+                            operand2-shifttype operand2-shiftreg))
+              (set temp-op1 rn)
+              (set temp-op2 operand2)
+              (set result (semantic-fn rn operand2 cbit))
+              (if (eq f-rd 15)
+                  (sequence ()
+                            (set pc result)
+                            (if set-cc?
+                                (set (reg h-cpsr) (reg h-spsr))))
+                  (sequence ()
+                            (set rd result)
+                            (if set-cc?
+                                (set-flags temp-op1 temp-op2 cbit)))))
+     )
+    )
+)
+
+; Arithmetic operation, with a result and immediate operand.
+
+(define-pmacro (arith-imm-op mnemonic comment-text opcode semantic-fn set-flags)
+  (dnai (.sym mnemonic -imm)
+       (.str comment-text " immediate")
+       ()
+       (.str mnemonic "$cond${set-cc?} $rd,$rn,$imm12")
+       (+ cond (f-op2 0) (f-imm? 1) opcode set-cc? rn rd imm12)
+       (sequence ((SI result))
+                 (set result (semantic-fn rn imm12 cbit))
+                 (if (eq f-rd 15)
+                     (sequence ()
+                               (if set-cc?
+                                   (set (reg h-cpsr) (reg h-spsr)))
+                               (set pc result))
+                     (sequence ()
+                               (if set-cc?
+                                   (set-flags rn imm12 cbit))
+                               (set rd result))))
+       )
+)
+\f
+; Logical data processing insns.
+
+(logical-op and "Bitwise AND" OP_AND and)
+
+(dnai and-imm "Bitwise AND immediate" ()
+      "and$cond${set-cc?} $rd,$rn,$imm12"
+      (+ cond (f-op2 0) (f-imm? 1) OP_AND set-cc? rn rd imm12)
+      (sequence ((SI result))
+               (set result (and rn imm12))
+               (if (eq f-rd 15)
+                   (sequence ()
+                             (set pc result)
+                             (if set-cc?
+                                 (set (reg h-cpsr) (reg h-spsr))))
+                   (sequence ()
+                             (set rd result)
+                             (if set-cc?
+                                 (set-zn-flags result)))))
+)
+
+(logical-op orr "Bitwise OR" OP_ORR or)
+
+(dnai orr-imm "Bitwise OR immediate" ()
+      "orr$cond${set-cc?} $rd,$rn,$imm12"
+      (+ cond (f-op2 0) (f-imm? 1) OP_ORR set-cc? rn rd imm12)
+      (sequence ((SI result))
+               (set result (or rn imm12))
+               (if (eq f-rd 15)
+                   (sequence ()
+                             (set pc result)
+                             (if set-cc?
+                                 (set (reg h-cpsr) (reg h-spsr))))
+                   (sequence ()
+                             (set rd result)
+                             (if set-cc?
+                                 (set-zn-flags result)))))
+)
+
+(logical-op eor "Exclusive OR" OP_EOR xor)
+
+(dnai eor-imm "Exclusive OR immediate" ()
+      "eor$cond${set-cc?} $rd,$rn,$imm12"
+      (+ cond (f-op2 0) (f-imm? 1) OP_EOR set-cc? rn rd imm12)
+      (sequence ((SI result))
+               (set result (xor rn imm12))
+               (if (eq f-rd 15)
+                   (sequence ()
+                             (set pc result)
+                             (if set-cc?
+                                 (set (reg h-cpsr) (reg h-spsr))))
+                   (sequence ()
+                             (set rd result)
+                             (if set-cc?
+                                 (set-zn-flags result)))))
+)
+
+(logical-op mov "Move" OP_MOV (.pmacro (arg1 arg2) arg2))
+
+(dnai mov-imm "Move immediate" ()
+      "mov$cond${set-cc?} $rd,$imm12"
+      ; rn is ignored
+      (+ cond (f-op2 0) (f-imm? 1) OP_MOV set-cc? rn rd imm12)
+      (sequence ((SI result))
+               (set result imm12)
+               (if (eq f-rd 15)
+                   (sequence ()
+                             (set pc result)
+                             (if set-cc?
+                                 (set (reg h-cpsr) (reg h-spsr))))
+                   (sequence ()
+                             (set rd result)
+                             (if set-cc?
+                                 (set-zn-flags result)))))
+)
+
+(logical-op bic "Bit clear" OP_BIC (.pmacro (arg1 arg2) (and arg1 (inv arg2))))
+
+(dnai bic-imm "Bit clear immediate" ()
+      "bic$cond${set-cc?} $rd,$rn,$imm12"
+      (+ cond (f-op2 0) (f-imm? 1) OP_BIC set-cc? rn rd imm12)
+      (sequence ((SI result))
+               (set result (and rn (inv imm12)))
+               (if (eq f-rd 15)
+                   (sequence ()
+                             (set pc result)
+                             (if set-cc?
+                                 (set (reg h-cpsr) (reg h-spsr))))
+                   (sequence ()
+                             (set rd result)
+                             (if set-cc?
+                                 (set-zn-flags result)))))
+)
+
+(logical-op mvn "Move negate" OP_MVN (.pmacro (arg1 arg2) (inv arg2)))
+
+(dnai mvn-imm "Move (logical) negate immediate" ()
+      "mvn$cond${set-cc?} $rd,$imm12"
+      ; rn is ignored
+      (+ cond (f-op2 0) (f-imm? 1) OP_MVN set-cc? rn rd imm12)
+      (sequence ((SI result))
+               (set result (inv imm12))
+               (if (eq f-rd 15)
+                   (sequence ()
+                             (set pc result)
+                             (if set-cc?
+                                 (set (reg h-cpsr) (reg h-spsr))))
+                   (sequence ()
+                             (set rd result)
+                             (if set-cc?
+                                 (set-zn-flags result)))))
+)
+\f
+; Arithmetic data processing insns.
+
+(arith-op add "Add" OP_ADD
+         (.pmacro (arg1 arg2 carry) (add arg1 arg2))
+         (.pmacro (arg1 arg2 carry) (set-add-flags arg1 arg2 0))
+)
+
+(arith-imm-op add "Add" OP_ADD
+         (.pmacro (arg1 arg2 carry) (add arg1 arg2))
+         (.pmacro (arg1 arg2 carry) (set-add-flags arg1 arg2 0))
+)
+
+(arith-op adc "Add with carry" OP_ADC
+         (.pmacro (arg1 arg2 carry) (addc arg1 arg2 carry))
+         (.pmacro (arg1 arg2 carry) (set-add-flags arg1 arg2 carry))
+)
+
+(arith-imm-op adc "Add with carry" OP_ADC
+         (.pmacro (arg1 arg2 carry) (addc arg1 arg2 carry))
+         (.pmacro (arg1 arg2 carry) (set-add-flags arg1 arg2 carry))
+)
+
+(arith-op sub "Subtract" OP_SUB
+         (.pmacro (arg1 arg2 borrow) (sub arg1 arg2))
+         (.pmacro (arg1 arg2 borrow) (set-sub-flags arg1 arg2 1))
+)
+
+(arith-imm-op sub "Subtract" OP_SUB
+         (.pmacro (arg1 arg2 borrow) (sub arg1 arg2))
+         (.pmacro (arg1 arg2 borrow) (set-sub-flags arg1 arg2 1))
+)
+
+(arith-op sbc "Subtract with carry" OP_SBC
+         (.pmacro (arg1 arg2 borrow) (subc arg1 arg2 (not borrow)))
+         (.pmacro (arg1 arg2 borrow) (set-sub-flags arg1 arg2 borrow))
+)
+
+(arith-imm-op sbc "Subtract with carry" OP_SBC
+         (.pmacro (arg1 arg2 borrow) (subc arg1 arg2 (not borrow)))
+         (.pmacro (arg1 arg2 borrow) (set-sub-flags arg1 arg2 borrow))
+)
+
+(arith-op rsb "Reverse subtract" OP_RSB
+         (.pmacro (arg1 arg2 borrow) (sub arg2 arg1))
+         (.pmacro (arg1 arg2 borrow) (set-sub-flags arg2 arg1 1))
+)
+
+(arith-imm-op rsb "Reverse subtract" OP_RSB
+         (.pmacro (arg1 arg2 borrow) (sub arg2 arg1))
+         (.pmacro (arg1 arg2 borrow) (set-sub-flags arg2 arg1 1))
+)
+
+(arith-op rsc "Reverse subtract with carry" OP_RSC
+         (.pmacro (arg1 arg2 borrow) (subc arg2 arg1 (not borrow)))
+         (.pmacro (arg1 arg2 borrow) (set-sub-flags arg2 arg1 borrow))
+)
+
+(arith-imm-op rsc "Reverse subtract with carry" OP_RSC
+         (.pmacro (arg1 arg2 borrow) (subc arg2 arg1 (not borrow)))
+         (.pmacro (arg1 arg2 borrow) (set-sub-flags arg2 arg1 borrow))
+)
+\f
+; Comparison instructions.
+;
+; For the following data processing insns, the `S' mnemonic suffix is
+; redundant, but can be specified.  The `S' bit is forced to 1 by the
+; assembler.  rd is not used.  rn is tested only.  
+; `S' bit = 0 -> mrs,msr insns.
+
+(dnai tst-reg/imm-shift
+      "Test immediate shift"
+      ()
+      "tst$cond${set-cc?} $rd,$rn,$rm,${operand2-shifttype} ${operand2-shiftimm}"
+      (+ cond (f-op2 0) (f-imm? 0) OP_TST (f-set-cc? 1) rn rd rm
+        (f-operand2-reg? 0) operand2-shifttype operand2-shiftimm)
+      (sequence ((SI operand2) (BI carry-out) (SI result))
+               (set operand2
+                    (c-call SI "compute_operand2_immshift" rm
+                            operand2-shifttype operand2-shiftimm))
+               (set carry-out
+                    (c-call BI "compute_carry_out_immshift" rm
+                            operand2-shifttype operand2-shiftimm cbit))
+               (set result (and rn operand2))
+               (if (eq f-rd 15)
+                   (set (reg h-cpsr) (reg h-spsr))
+                   (set-logical-cc result carry-out)))
+)
+
+(dnai tst-reg/reg-shift
+      "Test register shift"
+      ((R15-OFFSET 12))
+      "tst$cond${set-cc?} $rd,$rn,$rm,${operand2-shifttype} ${operand2-shiftreg}"
+      (+ cond (f-op2 0) (f-imm? 0) OP_TST (f-set-cc? 1) rn rd rm
+        (f-operand2-reg? 1) (f-bit7 0)
+        operand2-shifttype operand2-shiftreg)
+      (sequence ((SI operand2) (BI carry-out) (SI result))
+               (set operand2
+                    (c-call SI "compute_operand2_regshift" rm
+                            operand2-shifttype operand2-shiftreg))
+               (set carry-out
+                    (c-call BI "compute_carry_out_regshift" rm
+                            operand2-shifttype operand2-shiftreg cbit))
+               (set result (and rn operand2))
+               (if (eq f-rd 15)
+                   (set (reg h-cpsr) (reg h-spsr))
+                   (set-logical-cc result carry-out)))
+)
+
+(dnai tst-imm "Test immediate" ()
+      "tst${cond}${set-cc?} $rn,$imm12"
+      (+ cond (f-op2 0) (f-imm? 1) OP_TST (f-set-cc? 1) rn rd ror-imm8)
+      (sequence ((BI carry-out))
+               (if (eq f-ror-imm8-rotate 0)
+                   (set carry-out cbit)
+                   ; FIXME: nflag BI?
+                   (set carry-out (nflag BI ror-imm8)))
+               (set-logical-cc (and rn ror-imm8) carry-out))
+)
+
+(dnai teq-reg/imm-shift
+      "Test equal immediate shift"
+      ()
+      "teq$cond${set-cc?} $rd,$rn,$rm,${operand2-shifttype} ${operand2-shiftimm}"
+      (+ cond (f-op2 0) (f-imm? 0) OP_TEQ (f-set-cc? 1) rn rd rm
+        (f-operand2-reg? 0) operand2-shifttype operand2-shiftimm)
+      (sequence ((SI operand2) (BI carry-out) (SI result))
+               (set operand2
+                    (c-call SI "compute_operand2_immshift" rm
+                            operand2-shifttype operand2-shiftimm))
+               (set carry-out
+                    (c-call BI "compute_carry_out_immshift" rm
+                            operand2-shifttype operand2-shiftimm cbit))
+               (set result (xor rn operand2))
+               (if (eq f-rd 15)
+                   (set (reg h-cpsr) (reg h-spsr))
+                   (set-logical-cc result carry-out)))
+)
+
+(dnai teq-reg/reg-shift
+      "Test equal register shift"
+      ((R15-OFFSET 12))
+      "teq$cond${set-cc?} $rd,$rn,$rm,${operand2-shifttype} ${operand2-shiftreg}"
+      (+ cond (f-op2 0) (f-imm? 0) OP_TEQ (f-set-cc? 1) rn rd rm
+        (f-operand2-reg? 1) (f-bit7 0)
+        operand2-shifttype operand2-shiftreg)
+      (sequence ((SI operand2) (BI carry-out) (SI result))
+               (set operand2
+                    (c-call SI "compute_operand2_regshift" rm
+                            operand2-shifttype operand2-shiftreg))
+               (set carry-out
+                    (c-call BI "compute_carry_out_regshift" rm
+                            operand2-shifttype operand2-shiftreg cbit))
+               (set result (xor rn operand2))
+               (if (eq f-rd 15)
+                   (set (reg h-cpsr) (reg h-spsr))
+                   (set-logical-cc result carry-out)))
+)
+
+(dnai teq-imm "Test equal immediate" ()
+      "teq${cond}${set-cc?} $rn,$imm12"
+      (+ cond (f-op2 0) (f-imm? 1) OP_TEQ (f-set-cc? 1) rn rd ror-imm8)
+      ; The carry bit is preserved for the immediate form of this
+      ; insn.  ??? Though semantic analysis will believe it's read/written.
+      (sequence ((BI carry-out))
+               (if (eq f-ror-imm8-rotate 0)
+                   (set carry-out cbit)
+                   ; FIXME: nflag BI?
+                   (set carry-out (nflag BI ror-imm8)))
+               (set-logical-cc (xor rn ror-imm8) carry-out))
+)
+
+(dnai cmp-reg/imm-shift
+      "Compare immediate shift "
+      ()
+      "cmp$cond${set-cc?} $rd,$rn,$rm,${operand2-shifttype} ${operand2-shiftimm}"
+      (+ cond (f-op2 0) (f-imm? 0) OP_CMP (f-set-cc? 1) rn rd rm
+        (f-operand2-reg? 0) operand2-shifttype operand2-shiftimm)
+      (sequence ((SI operand2))
+               (set operand2
+                    (c-call SI "compute_operand2_immshift" rm
+                             operand2-shifttype operand2-shiftimm))
+               (if (eq f-rd 15)
+                   (set (reg h-cpsr) (reg h-spsr))
+                   (set-sub-flags rn operand2 1)))
+)
+
+(dnai cmp-reg/reg-shift
+      "Compare register shift"
+      ((R15-OFFSET 12))
+      "cmp$cond${set-cc?} $rd,$rn,$rm,${operand2-shifttype} ${operand2-shiftreg}"
+      (+ cond (f-op2 0) (f-imm? 0) OP_CMP (f-set-cc? 1) rn rd rm
+        (f-operand2-reg? 1) (f-bit7 0)
+        operand2-shifttype operand2-shiftreg)
+      (sequence ((SI operand2))
+               (set operand2
+                    (c-call SI "compute_operand2_regshift" rm
+                             operand2-shifttype operand2-shiftreg))
+               (if (eq f-rd 15)
+                   (set (reg h-cpsr) (reg h-spsr))
+                   (set-sub-flags rn operand2 1)))
+)
+
+(dnai cmp-imm "Compare immediate" ()
+      "cmp${cond}${set-cc?} $rn,$imm12"
+      (+ cond (f-op2 0) (f-imm? 1) OP_CMP (f-set-cc? 1) rn rd imm12)
+      (set-sub-flags rn imm12 1)
+)
+
+(dnai cmn-reg/imm-shift
+      "Compare negative immediate shift "
+      ()
+      "cmn$cond${set-cc?} $rd,$rn,$rm,${operand2-shifttype} ${operand2-shiftimm}"
+      (+ cond (f-op2 0) (f-imm? 0) OP_CMN (f-set-cc? 1) rn rd rm
+        (f-operand2-reg? 0) operand2-shifttype operand2-shiftimm)
+      (sequence ((SI operand2))
+               (set operand2
+                    (c-call SI "compute_operand2_immshift" rm
+                             operand2-shifttype operand2-shiftimm))
+               (if (eq f-rd 15)
+                   (set (reg h-cpsr) (reg h-spsr))
+                   (set-add-flags rn operand2 0)))
+)
+
+(dnai cmn-reg/reg-shift
+      "Compare negative register shift"
+      ((R15-OFFSET 12))
+      "cmn$cond${set-cc?} $rd,$rn,$rm,${operand2-shifttype} ${operand2-shiftreg}"
+      (+ cond (f-op2 0) (f-imm? 0) OP_CMN (f-set-cc? 1) rn rd rm
+        (f-operand2-reg? 1) (f-bit7 0)
+        operand2-shifttype operand2-shiftreg)
+      (sequence ((SI operand2))
+               (set operand2
+                    (c-call SI "compute_operand2_regshift" rm
+                             operand2-shifttype operand2-shiftreg))
+               (if (eq f-rd 15)
+                   (set (reg h-cpsr) (reg h-spsr))
+                   (set-add-flags rn operand2 0)))
+)
+
+(dnai cmn-imm "Compare negative immediate" ()
+      "cmn${cond}${set-cc?} $rn,$imm12"
+      (+ cond (f-op2 0) (f-imm? 1) OP_CMN (f-set-cc? 1) rn rd imm12)
+      ; ??? Is this right?
+      (set-add-flags rn imm12 0)
+)
+\f
+; Multiple load and store insns.
+
+(define-pmacro (multi-action bit-num semantic-fn)
+  (if (and reglist (sll 1 bit-num))
+      (semantic-fn bit-num))
+)
+
+(define-pmacro (ldmda-action bit-num)
+  (sequence ()
+           (set (reg WI h-gr bit-num) (mem WI addr))
+           (set addr (sub addr 4)))
+)
+
+(define-pmacro (ldmda-action-r15 ignored)
+  (sequence ()
+           (set pc (mem WI addr))
+           (set addr (sub addr 4)))
+)
+
+(dnai ldmda "Load multiple registers (postindex, decrement)"
+     ()
+     "FIXME"
+     (+ cond (f-op3 4) (f-preindex? 0) (f-up-down 0) (f-load-psr? 0)
+       (f-write-back? 0) (f-load? 1) rn reglist)
+     (sequence ((WI addr))
+              (set addr rn)
+              (multi-action 15 ldmda-action-r15)
+              (multi-action 14 ldmda-action)
+              (multi-action 13 ldmda-action)
+              (multi-action 12 ldmda-action)
+              (multi-action 11 ldmda-action)
+              (multi-action 10 ldmda-action)
+              (multi-action  9 ldmda-action)
+              (multi-action  8 ldmda-action)
+              (multi-action  7 ldmda-action)
+              (multi-action  6 ldmda-action)
+              (multi-action  5 ldmda-action)
+              (multi-action  4 ldmda-action)
+              (multi-action  3 ldmda-action)
+              (multi-action  2 ldmda-action)
+              (multi-action  1 ldmda-action)
+              (multi-action  0 ldmda-action)
+     )
+)
+
+(dnai ldmda-wb "Load multiple registers (postindex, decrement, writeback)"
+      ()
+      "FIXME"
+      (+ cond (f-op3 4) (f-preindex? 0) (f-up-down 0) (f-load-psr? 0)
+        (f-write-back? 1) (f-load? 1) rn reglist)
+      (sequence ((WI addr))
+               (set addr rn)
+               (multi-action 15 ldmda-action-r15)
+               (multi-action 14 ldmda-action)
+               (multi-action 13 ldmda-action)
+               (multi-action 12 ldmda-action)
+               (multi-action 11 ldmda-action)
+               (multi-action 10 ldmda-action)
+               (multi-action  9 ldmda-action)
+               (multi-action  8 ldmda-action)
+               (multi-action  7 ldmda-action)
+               (multi-action  6 ldmda-action)
+               (multi-action  5 ldmda-action)
+               (multi-action  4 ldmda-action)
+               (multi-action  3 ldmda-action)
+               (multi-action  2 ldmda-action)
+               (multi-action  1 ldmda-action)
+               (multi-action  0 ldmda-action)
+               (set rn addr))
+)
+
+(define-pmacro (ldmib-action bit-num)
+  (sequence ()
+           (set addr (add addr 4))
+           (set (reg WI h-gr bit-num) (mem WI addr)))
+)
+
+(define-pmacro (ldmib-action-r15 ignored)
+  (sequence ()
+           (set addr (add addr 4))
+           (set pc (mem WI addr)))
+)
+
+(dnai ldmib "Load multiple register (preindex, increment)"
+     ()
+     "FIXME"
+     (+ cond (f-op3 4) (f-preindex? 1) (f-up-down 1) (f-load-psr? 0)
+       (f-write-back? 0) (f-load? 1) rn reglist)
+     (sequence ((WI addr))
+              (set addr rn)
+              (multi-action  0 ldmib-action)
+              (multi-action  1 ldmib-action)
+              (multi-action  2 ldmib-action)
+              (multi-action  3 ldmib-action)
+              (multi-action  4 ldmib-action)
+              (multi-action  5 ldmib-action)
+              (multi-action  6 ldmib-action)
+              (multi-action  7 ldmib-action)
+              (multi-action  8 ldmib-action)
+              (multi-action  9 ldmib-action)
+              (multi-action 10 ldmib-action)
+              (multi-action 11 ldmib-action)
+              (multi-action 12 ldmib-action)
+              (multi-action 13 ldmib-action)
+              (multi-action 14 ldmib-action)
+              (multi-action 15 ldmib-action-r15))
+)
+
+(dnai ldmib-wb "Load multiple registers (preindex, increment, writeback)"
+      ()
+      "FIXME"
+      (+ cond (f-op3 4) (f-preindex? 1) (f-up-down 1) (f-load-psr? 0)
+        (f-write-back? 1) (f-load? 1) rn reglist)
+      (sequence ((WI addr))
+               (set addr rn)
+               (multi-action  0 ldmib-action)
+               (multi-action  1 ldmib-action)
+               (multi-action  2 ldmib-action)
+               (multi-action  3 ldmib-action)
+               (multi-action  4 ldmib-action)
+               (multi-action  5 ldmib-action)
+               (multi-action  6 ldmib-action)
+               (multi-action  7 ldmib-action)
+               (multi-action  8 ldmib-action)
+               (multi-action  9 ldmib-action)
+               (multi-action 10 ldmib-action)
+               (multi-action 11 ldmib-action)
+               (multi-action 12 ldmib-action)
+               (multi-action 13 ldmib-action)
+               (multi-action 14 ldmib-action)
+               (multi-action 15 ldmib-action-r15)
+               (set rn addr))
+)
+
+(define-pmacro (ldmia-action bit-num)
+  (sequence ()
+           (set (reg WI h-gr bit-num) (mem WI addr))
+           (set addr (add addr 4)))
+)
+
+(define-pmacro (ldmia-action-r15 ignored)
+  (sequence ()
+           (set pc (mem WI addr))
+           (set addr (add addr 4)))
+)
+
+(dnai ldmia "Load multiple registers (postindex, increment)"
+     ()
+     "FIXME"
+     (+ cond (f-op3 4) (f-preindex? 0) (f-up-down 1) (f-load-psr? 0)
+       (f-write-back? 0) (f-load? 1) rn reglist)
+     (sequence ((WI addr))
+              (set addr rn)
+              (multi-action  0 ldmia-action)
+              (multi-action  1 ldmia-action)
+              (multi-action  2 ldmia-action)
+              (multi-action  3 ldmia-action)
+              (multi-action  4 ldmia-action)
+              (multi-action  5 ldmia-action)
+              (multi-action  6 ldmia-action)
+              (multi-action  7 ldmia-action)
+              (multi-action  8 ldmia-action)
+              (multi-action  9 ldmia-action)
+              (multi-action 10 ldmia-action)
+              (multi-action 11 ldmia-action)
+              (multi-action 12 ldmia-action)
+              (multi-action 13 ldmia-action)
+              (multi-action 14 ldmia-action)
+              (multi-action 15 ldmia-action-r15))
+)
+
+(dnai ldmia-wb "Load multiple registers (postindex, increment, writeback)"
+     ()
+     "FIXME"
+     (+ cond (f-op3 4) (f-preindex? 0) (f-up-down 1) (f-load-psr? 0)
+       (f-write-back? 1) (f-load? 1) rn reglist)
+     (sequence ((WI addr))
+              (set addr rn)
+              (multi-action  0 ldmia-action)
+              (multi-action  1 ldmia-action)
+              (multi-action  2 ldmia-action)
+              (multi-action  3 ldmia-action)
+              (multi-action  4 ldmia-action)
+              (multi-action  5 ldmia-action)
+              (multi-action  6 ldmia-action)
+              (multi-action  7 ldmia-action)
+              (multi-action  8 ldmia-action)
+              (multi-action  9 ldmia-action)
+              (multi-action 10 ldmia-action)
+              (multi-action 11 ldmia-action)
+              (multi-action 12 ldmia-action)
+              (multi-action 13 ldmia-action)
+              (multi-action 14 ldmia-action)
+              (multi-action 15 ldmia-action-r15)
+              (set rn addr))
+)
+
+(define-pmacro (ldmdb-action bit-num)
+  (sequence ()
+           (set addr (sub addr 4))
+           (set (reg WI h-gr bit-num) (mem WI addr)))
+)
+
+(define-pmacro (ldmdb-action-r15 bit-num)
+  (sequence ()
+           (set addr (sub addr 4))
+           (set pc (mem WI addr)))
+)
+
+(dnai ldmdb "Load multiple registers (preindex, decrement)" 
+     ()
+     "ldm$cond .."
+     (+ cond (f-op3 4) (f-preindex? 1) (f-up-down 0) (f-load-psr? 0)
+       (f-write-back? 0) (f-load? 1) rn reglist)
+     (sequence ((WI addr))
+              (set addr rn)
+              (multi-action 15 ldmdb-action-r15)
+              (multi-action 14 ldmdb-action)
+              (multi-action 13 ldmdb-action)
+              (multi-action 12 ldmdb-action)
+              (multi-action 11 ldmdb-action)
+              (multi-action 10 ldmdb-action)
+              (multi-action  9 ldmdb-action)
+              (multi-action  8 ldmdb-action)
+              (multi-action  7 ldmdb-action)
+              (multi-action  6 ldmdb-action)
+              (multi-action  5 ldmdb-action)
+              (multi-action  4 ldmdb-action)
+              (multi-action  3 ldmdb-action)
+              (multi-action  2 ldmdb-action)
+              (multi-action  1 ldmdb-action)
+              (multi-action  0 ldmdb-action))
+)
+
+(dnai ldmdb-wb "Load multiple registers (preindex, decrement, writeback)"
+      ()
+      "FIXME"
+      (+ cond (f-op3 4) (f-preindex? 1) (f-up-down 0) (f-load-psr? 0)
+        (f-write-back? 1) (f-load? 1) rn reglist)
+      (sequence ((WI addr))
+               (set addr rn)
+               (multi-action 15 ldmdb-action-r15)
+               (multi-action 14 ldmdb-action)
+               (multi-action 13 ldmdb-action)
+               (multi-action 12 ldmdb-action)
+               (multi-action 11 ldmdb-action)
+               (multi-action 10 ldmdb-action)
+               (multi-action  9 ldmdb-action)
+               (multi-action  8 ldmdb-action)
+               (multi-action  7 ldmdb-action)
+               (multi-action  6 ldmdb-action)
+               (multi-action  5 ldmdb-action)
+               (multi-action  4 ldmdb-action)
+               (multi-action  3 ldmdb-action)
+               (multi-action  2 ldmdb-action)
+               (multi-action  1 ldmdb-action)
+               (multi-action  0 ldmdb-action)
+               (set rn addr))
+)
+
+(define-pmacro (stmdb-action bit-num)
+  (sequence ()
+           (set addr (sub addr 4))
+           (set (mem WI addr) (reg WI h-gr bit-num)))
+)
+
+(define-pmacro (stmdb-action-r15 ignore)
+  (sequence ()
+           (set addr (sub addr 4))
+           (set (mem WI addr) (add (reg WI h-gr 15) 4)))
+)
+
+(dnai stmdb "Store multiple registers (preindex, decrement)"
+     ()
+     "FIXME"
+     (+ cond (f-op3 4) (f-preindex? 1) (f-up-down 0) (f-load-psr? 0)
+       (f-write-back? 0) (f-load? 0) rn reglist)
+     (sequence ((WI addr))
+              (set addr rn)
+              (multi-action 15 stmdb-action-r15)
+              (multi-action 14 stmdb-action)
+              (multi-action 13 stmdb-action)
+              (multi-action 12 stmdb-action)
+              (multi-action 11 stmdb-action)
+              (multi-action 10 stmdb-action)
+              (multi-action  9 stmdb-action)
+              (multi-action  8 stmdb-action)
+              (multi-action  7 stmdb-action)
+              (multi-action  6 stmdb-action)
+              (multi-action  5 stmdb-action)
+              (multi-action  4 stmdb-action)
+              (multi-action  3 stmdb-action)
+              (multi-action  2 stmdb-action)
+              (multi-action  1 stmdb-action)
+              (multi-action  0 stmdb-action))
+)
+
+(dnai stmdb-wb "Store multiple registers (preindex, decrement, writeback)"
+      ()
+      "FIXME"
+      (+ cond (f-op3 4) (f-preindex? 1) (f-up-down 0) (f-load-psr? 0)
+        (f-write-back? 1) (f-load? 0) rn reglist)
+      (sequence ((WI addr))
+               (set addr rn)
+               (multi-action 15 stmdb-action-r15)
+               (multi-action 14 stmdb-action)
+               (multi-action 13 stmdb-action)
+               (multi-action 12 stmdb-action)
+               (multi-action 11 stmdb-action)
+               (multi-action 10 stmdb-action)
+               (multi-action  9 stmdb-action)
+               (multi-action  8 stmdb-action)
+               (multi-action  7 stmdb-action)
+               (multi-action  6 stmdb-action)
+               (multi-action  5 stmdb-action)
+               (multi-action  4 stmdb-action)
+               (multi-action  3 stmdb-action)
+               (multi-action  2 stmdb-action)
+               (multi-action  1 stmdb-action)
+               (multi-action  0 stmdb-action)
+               (set rn addr))
+)
+
+(define-pmacro (stmib-action bit-num)
+  (sequence ()
+           (set addr (add addr 4))
+           (set (mem WI addr) (reg WI h-gr bit-num)))
+)
+
+(define-pmacro (stmib-action-r15 ignore)
+  (sequence ()
+           (set addr (add addr 4))
+           (set (mem WI addr) (add (reg WI h-gr 15) 4)))
+)
+
+(dnai stmib "Store multiple registers (preindex, increment)"
+     ()
+     "FIXME"
+     (+ cond (f-op3 4) (f-preindex? 1) (f-up-down 1) (f-load-psr? 0)
+       (f-write-back? 0) (f-load? 0) rn reglist)
+     (sequence ((WI addr))
+              (set addr rn)
+              (multi-action  0 stmib-action)
+              (multi-action  1 stmib-action)
+              (multi-action  2 stmib-action)
+              (multi-action  3 stmib-action)
+              (multi-action  4 stmib-action)
+              (multi-action  5 stmib-action)
+              (multi-action  6 stmib-action)
+              (multi-action  7 stmib-action)
+              (multi-action  8 stmib-action)
+              (multi-action  9 stmib-action)
+              (multi-action 10 stmib-action)
+              (multi-action 11 stmib-action)
+              (multi-action 12 stmib-action)
+              (multi-action 13 stmib-action)
+              (multi-action 14 stmib-action)
+              (multi-action 15 stmib-action-r15))
+)
+
+(dnai stmib-wb "Store multiple registers (preindex, increment, writeback)"
+      ()
+      "FIXME"
+      (+ cond (f-op3 4) (f-preindex? 1) (f-up-down 1) (f-load-psr? 0)
+        (f-write-back? 1) (f-load? 0) rn reglist)
+      (sequence ((WI addr))
+               (set addr rn)
+               (multi-action  0 stmib-action)
+               (multi-action  1 stmib-action)
+               (multi-action  2 stmib-action)
+               (multi-action  3 stmib-action)
+               (multi-action  4 stmib-action)
+               (multi-action  5 stmib-action)
+               (multi-action  6 stmib-action)
+               (multi-action  7 stmib-action)
+               (multi-action  8 stmib-action)
+               (multi-action  9 stmib-action)
+               (multi-action 10 stmib-action)
+               (multi-action 11 stmib-action)
+               (multi-action 12 stmib-action)
+               (multi-action 13 stmib-action)
+               (multi-action 14 stmib-action)
+               (multi-action 15 stmib-action-r15)
+               (set rn addr))
+)
+
+(define-pmacro (stmia-action bit-num)
+  (sequence ()
+           (set (mem WI addr) (reg WI h-gr bit-num))
+           (set addr (add addr 4)))
+)
+
+(define-pmacro (stmia-action-r15 ignore)
+  (sequence ()
+           (set (mem WI addr) (add (reg WI h-gr 15) 4))
+           (set addr (add addr 4)))
+)
+
+(dnai stmia "Store multiple registers (postindex, increment)"
+      ()
+      "FIXME"
+      (+ cond (f-op3 4) (f-preindex? 0) (f-up-down 1) (f-load-psr? 0)
+        (f-write-back? 0) (f-load? 0) rn reglist)
+      (sequence ((WI addr))
+               (set addr rn)
+               (multi-action  0 stmia-action)
+               (multi-action  1 stmia-action)
+               (multi-action  2 stmia-action)
+               (multi-action  3 stmia-action)
+               (multi-action  4 stmia-action)
+               (multi-action  5 stmia-action)
+               (multi-action  6 stmia-action)
+               (multi-action  7 stmia-action)
+               (multi-action  8 stmia-action)
+               (multi-action  9 stmia-action)
+               (multi-action 10 stmia-action)
+               (multi-action 11 stmia-action)
+               (multi-action 12 stmia-action)
+               (multi-action 13 stmia-action)
+               (multi-action 14 stmia-action)
+               (multi-action 15 stmia-action-r15))
+)
+
+(dnai stmia-wb "Store multiple registers (postindex, increment, writeback)"
+      ()
+      "FIXME"
+      (+ cond (f-op3 4) (f-preindex? 0) (f-up-down 1) (f-load-psr? 0)
+        (f-write-back? 1) (f-load? 0) rn reglist)
+      (sequence ((WI addr))
+               (set addr rn)
+               (multi-action  0 stmia-action)
+               (multi-action  1 stmia-action)
+               (multi-action  2 stmia-action)
+               (multi-action  3 stmia-action)
+               (multi-action  4 stmia-action)
+               (multi-action  5 stmia-action)
+               (multi-action  6 stmia-action)
+               (multi-action  7 stmia-action)
+               (multi-action  8 stmia-action)
+               (multi-action  9 stmia-action)
+               (multi-action 10 stmia-action)
+               (multi-action 11 stmia-action)
+               (multi-action 12 stmia-action)
+               (multi-action 13 stmia-action)
+               (multi-action 14 stmia-action)
+               (multi-action 15 stmia-action-r15)
+               (set rn addr))
+)
+
+(define-pmacro (stmda-action-r15 ignore)
+  (sequence ()
+           (set (mem WI addr) (add (reg WI h-gr 15) 4))
+           (set addr (sub addr 4)))
+)
+
+(define-pmacro (stmda-action bit-num)
+  (sequence ()
+           (set (mem WI addr) (reg WI h-gr bit-num))
+           (set addr (sub addr 4)))
+)
+
+(dnai stmda "Store multiple registers (postindex, decrement)"
+      ()
+      "FIXME"
+      (+ cond (f-op3 4) (f-preindex? 0) (f-up-down 0) (f-load-psr? 0)
+        (f-write-back? 0) (f-load? 0) rn reglist)
+      (sequence ((WI addr))
+               (set addr rn)
+               (multi-action 15 stmda-action-r15)
+               (multi-action 14 stmda-action)
+               (multi-action 13 stmda-action)
+               (multi-action 12 stmda-action)
+               (multi-action 11 stmda-action)
+               (multi-action 10 stmda-action)
+               (multi-action  9 stmda-action)
+               (multi-action  8 stmda-action)
+               (multi-action  7 stmda-action)
+               (multi-action  6 stmda-action)
+               (multi-action  5 stmda-action)
+               (multi-action  4 stmda-action)
+               (multi-action  3 stmda-action)
+               (multi-action  2 stmda-action)
+               (multi-action  1 stmda-action)
+               (multi-action  0 stmda-action))
+)
+
+(dnai stmda-wb "Store multiple registers (postindex, decrement, writeback)"
+      ()
+      "FIXME"
+      (+ cond (f-op3 4) (f-preindex? 0) (f-up-down 0) (f-load-psr? 0)
+        (f-write-back? 1) (f-load? 0) rn reglist)
+      (sequence ((WI addr))
+               (set addr rn)
+               (multi-action 15 stmda-action-r15)
+               (multi-action 14 stmda-action)
+               (multi-action 13 stmda-action)
+               (multi-action 12 stmda-action)
+               (multi-action 11 stmda-action)
+               (multi-action 10 stmda-action)
+               (multi-action  9 stmda-action)
+               (multi-action  8 stmda-action)
+               (multi-action  7 stmda-action)
+               (multi-action  6 stmda-action)
+               (multi-action  5 stmda-action)
+               (multi-action  4 stmda-action)
+               (multi-action  3 stmda-action)
+               (multi-action  2 stmda-action)
+               (multi-action  1 stmda-action)
+               (multi-action  0 stmda-action)
+               (set rn addr))
+)
+
+\f
+; Coprocessor instructions.
+; Currently not implemented, so omit these, such that we take the
+; undefined instruction trap as specified by the ARM documentation.
+\f
+(dnai mrs-c "Transfer CPSR contents to a register"
+     ()
+     "mrs$cond $rd,cpsr"
+     (+ cond (f-op5 2) PSR_CURRENT (f-op-mrs1 #xF) rd (f-op-mrs2 0))
+     (set rd (reg h-cpsr))
+)
+
+(dnai mrs-s "Transfer SPSR contents to a register"
+     ()
+     "mrs$cond $rd,spsr"
+     (+ cond (f-op5 2) PSR_SAVED (f-op-mrs1 #xF) rd (f-op-mrs2 0))
+     (set rd (reg h-spsr))
+)
+
+(dnai msr-c "Transfer register contents to CPSR"
+     ()
+     "msr$cond cpsr,$rm"
+     (+ cond (f-op5 2) PSR_CURRENT (f-op-msr1 #x29F) (f-op-msr2 0) rm)
+     (set (reg h-cpsr) rm)
+)
+
+(dnai msr-s "Transfer register contents to SPSR"
+     ()
+     "msr$cond spsr,$rm"
+     (+ cond (f-op5 2) PSR_SAVED (f-op-msr1 #x29F) (f-op-msr2 0) rm)
+     (set (reg h-spsr) rm)
+)
+
+; TODO: msr to flag bits only
+\f
+; Commented out until ifield assertions added, collides with str/ldr.
+; ??? It's possible to rewrite str,ldr, but assertions are wanted anyway.
+
+;(dnai undefined "Undefined instruction"
+;     ()
+;     "undef"
+;     (+ cond (f-op3 3) undef-dont1 (f-bit4 1) undef-dont2)
+;     ; Generate an undefined exception. 
+;     ; Jump to the vector held in 0x4.
+;     ; FIXME: More state change than this occurs.
+;     (set pc (mem WI #x4))
+;)
diff --git a/cgen/attr.scm b/cgen/attr.scm
new file mode 100644 (file)
index 0000000..1d8cd7c
--- /dev/null
@@ -0,0 +1,910 @@
+; Attributes.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; There are 4 kinds of attributes: boolean, integer, enum, and bitset.  Boolean
+; attributes are really enum attributes with two possible values, but they
+; occur frequently enough that they are special cased.
+;
+; All objects that use attributes must have two methods:
+; - 'get-atlist - returns the object's attr-list
+; - 'set-atlist! - set the object's attr-list
+;
+; In .cpu files, attribute lists are associative lists of (NAME VALUE).
+; Boolean attributes are specified as (NAME #t) or (NAME #f),
+; but for convenience ATTR and !ATTR are also supported.
+; integer/enum attrs are specified as (ATTR value).
+; Bitset attrs are specified as (ATTR val1,val2,val3).
+; In all cases the value needn't be constant, and can be an expression,
+; though expressions are currently only supported for META-attributes
+; (attributes that don't appear in any generated code).
+;
+; Example:
+; (FOO1 !FOO2 (BAR 3) (FOO3 X) (MACH sparc,sparclite))
+;
+; ??? Implementation of expressions is being postponed as long
+; as possible, avoiding adding complications for complication's sake, and
+; because I'm not completely sure how I want to do them.
+; The syntax for an expression value is (ATTR (rtx-func ...)).
+;
+; ??? May wish to allow a bitset attribute like (ATTR val1,!val2), where `!'
+; means to turn off that particular bit (or bits if val2 refers to several).
+;
+; ??? May wish to allow specifying enum attributes by only having to
+; specify the value (move names into "enum space" or some such).
+\f
+; An attr-list (or "atlist") is a collection of attributes.
+; Attributes are stored as an associative list.
+; There is possible confusion between "alist" (associative-list) and
+; "atlist" (attribute-list) but in practice I haven't had a problem.
+; ??? May wish to change this to a list of objects, as the alist doesn't carry
+; enough info.  However the alist is simple and fast.
+
+(define <attr-list> (class-make '<attr-list> nil '(prefix attrs) nil))
+
+(define atlist-prefix (elm-make-getter <attr-list> 'prefix))
+(define atlist-attrs (elm-make-getter <attr-list> 'attrs))
+
+(define (atlist? x) (class-instance? <attr-list> x))
+
+; An empty attribute-list.
+
+(define atlist-empty (make <attr-list> "" nil))
+
+; The attribute baseclass.
+; The attributes of <ident> are the set of attributes for this attribute
+; [meaning attributes themselves can have attributes].
+; [Ya, that's clumsily written.  I left it that way for fun.]
+; An odd notion that is of some use.  It's current raison d'etre is to
+; support sanitization of attributes [which is implemented with the
+; `sanitize' attribute].
+
+(define <attribute>
+  (class-make '<attribute>
+             '(<ident>)
+             '(
+               ; List of object types this attribute is for.
+               ; Possible element values are:
+               ; attr, enum, cpu, mach, model, ifield, hardware, operand,
+               ; insn
+               ; A value of #f means the attribute is for everything.
+               for
+               )
+             nil)
+)
+
+; Accessors.
+
+(define atlist-for (elm-make-getter <attribute> 'for))
+
+; A class for each type of attribute.
+
+; `values' exists for boolean-attribute to simplify the code, it's ignored.
+; Ditto for `default'.  The default for boolean-attribute is always #f.
+
+(define <boolean-attribute>
+  (class-make '<boolean-attribute>
+             '(<attribute>)
+             '(default values)
+             nil)
+)
+
+; For bitset attributes, VALUES is a list of symbols, one for each bit.
+; Int's are used to record the bitset in the generated code so there's a limit
+; of 32 elements, though there's nothing inherent in the description language
+; that precludes removing the limit.
+
+(define <bitset-attribute>
+  (class-make '<bitset-attribute>
+             '(<attribute>)
+             '(default values)
+             nil)
+)
+
+; For integer attributes, VALUES is a list of ints, one for each possible
+; value, or the empty list of all values are permissible.
+
+(define <integer-attribute>
+  (class-make '<integer-attribute>
+             '(<attribute>)
+             '(default values)
+             nil)
+)
+
+; For enum attributes, VALUES is a list of symbols, one for each possible
+; value.
+
+(define <enum-attribute>
+  (class-make '<enum-attribute>
+             '(<attribute>)
+             '(default values)
+             nil)
+)
+
+; Return a boolean indicating if X is a <boolean-attribute> object.
+
+(define (bool-attr? x) (class-instance? <boolean-attribute> x))
+
+; Return a boolean indicating if X is a <bitset-attribute> object.
+
+(define (bitset-attr? x) (class-instance? <bitset-attribute> x))
+
+; Return a symbol indicating the kind of attribute ATTR is.
+; The result is one of boolean,integer,enum,bitset.
+
+(define (attr-kind attr)
+  (case (object-class-name attr)
+    ((<boolean-attribute>) 'boolean)
+    ((<integer-attribute>) 'integer)
+    ((<enum-attribute>)    'enum)
+    ((<bitset-attribute>)  'bitset)
+    (else (error "attr-kind: internal error, not an attribute class"
+                (object-class-name attr))))
+)
+
+; Accessors.
+
+(define (attr-default attr) (elm-xget attr 'default))
+(define (attr-values attr) (elm-xget attr 'values))
+
+; Create an attribute.
+; Attributes are stored in attribute lists using the actual value
+; rather than an object containing the value, so we only have to cons
+; NAME and VALUE rather than building some object.  This is for simplicity
+; and speed.  We try to incrementally complicate things, only as necessary.
+
+; VALUE must be #f or #t.
+
+(define (bool-attr-make name value) (cons name value))
+
+; VALUES must be a comma separated list of symbols
+; (e.g. val1,val2 not (val1 val2)).
+
+(define (bitset-attr-make name values) (cons name values))
+
+; VALUE must be a number (or maybe a symbol).
+
+(define (int-attr-make name value) (cons name value))
+
+; VALUE must be a symbol.
+
+(define (enum-attr-make name value) (cons name value))
+
+; A boolean attribute's value is either #t or #f.
+
+(method-make!
+ <boolean-attribute> 'parse-value
+ (lambda (self errtxt val)
+   (if (and (not (null? val))
+           (boolean? (car val)))
+       (cons (obj:name self) (car val))
+       (parse-error errtxt "boolean attribute not one of #f/#t"
+                   (cons (obj:name self) val))))
+)
+
+; A bitset attribute's value is a comma separated list of elements.
+; We don't validate the values.  In the case of the MACH attribute,
+; there's no current mechanism to create it after all define-mach's have
+; been read in.
+; ??? Need to decide whether all define-mach's must appear before any
+; define-insn's.  It would be nice to be able to spread an architecture's
+; description over several .cpu files.
+; ??? On the other hand, all machs are specified in define-arch.
+; Perhaps creation of builtins could be defered until then.
+
+(method-make!
+ <bitset-attribute> 'parse-value
+ (lambda (self errtxt val)
+   (if (and (not (null? val))
+           (or (symbol? (car val))
+               (string? (car val)))
+           (null? (cdr val)))
+       (cons (obj:name self) (car val))
+       (parse-error errtxt "improper bitset attribute"
+                   (cons (obj:name self) val))))
+)
+
+; An integer attribute's value is a number
+; (or maybe a symbol representing that value).
+
+(method-make!
+ <integer-attribute> 'parse-value
+ (lambda (self errtxt val)
+   (if (and (not (null? val))
+           (or (number? (car val)) (symbol? (car val)))
+           (null? (cdr val)))
+       (cons (obj:name self) (car val))
+       (parse-error errtxt "improper integer attribute"
+                   (cons (obj:name self) val))))
+)
+
+; An enum attribute's value is a symbol representing that value.
+
+(method-make!
+ <enum-attribute> 'parse-value
+ (lambda (self errtxt val)
+   (if (and (not (null? val))
+           (or (symbol? (car val)) (string? (car val)))
+           (null? (cdr val)))
+       (cons (obj:name self) (car val))
+       (parse-error errtxt "improper enum attribute"
+                   (cons (obj:name self) val))))
+)
+
+; Parse a boolean attribute's value definition.
+
+(method-make!
+ <boolean-attribute> 'parse-value-def
+ (lambda (self errtxt values)
+   (if (equal? values '(#f #t))
+       values
+       (parse-error errtxt "boolean value list must be (#f #t)" values)))
+)
+
+; Parse a bitset attribute's value definition.
+; FIXME: treated as enum?
+
+(method-make!
+ <bitset-attribute> 'parse-value-def
+ (lambda (self errtxt values)
+   (parse-enum-vals "" values))
+)
+
+; Parse an integer attribute's value definition.
+; FIXME: Unfinished.
+
+(method-make!
+ <integer-attribute> 'parse-value-def
+ (lambda (self errtxt values) values)
+)
+
+; Parse an enum attribute's value definition.
+; See parse-enum-vals for more info.
+
+(method-make!
+ <enum-attribute> 'parse-value-def
+ (lambda (self errtxt values)
+   (parse-enum-vals "" values))
+)
+
+; Make an attribute list object from a list of name/value pairs.
+
+(define (atlist-make prefix . attrs) (make <attr-list> prefix attrs))
+\f
+; Parse an attribute definition.
+; This is the main routine for building an attribute object from a
+; description in the .cpu file.
+; All arguments are in raw (non-evaluated) form.
+; TYPE-CLASS is the class of the object to create.
+; i.e. one of <{boolean,bitset,integer,enum}-attribute>.
+; If DEFAULT is #f, use the first value.
+; ??? Allowable values for integer attributes is wip.
+
+(define (-attr-parse errtxt type-class name comment attrs for default values)
+  (logit 2 "Processing attribute " name " ...\n")
+  (let* ((name (parse-name name errtxt))
+        (errtxt (string-append errtxt ":" name))
+        (result (new type-class))
+        (parsed-values (send result 'parse-value-def errtxt values)))
+    (elm-xset! result 'name name)
+    (elm-xset! result 'comment (parse-comment comment errtxt))
+    (elm-xset! result 'attrs (atlist-parse attrs "" errtxt))
+    (elm-xset! result 'for for)
+    ; Set the default.
+    (case (class-name type-class)
+      ((<boolean-attribute>)
+       (if (and (not (memq default '(#f #t)))
+               (not (rtx? default)))
+          (parse-error errtxt "invalid default" default))
+       (elm-xset! result 'default default))
+      ((<integer-attribute>)
+       (let ((default (if default default (if (null? values) 0 (car values)))))
+        (if (and (not (integer? default))
+                 (not (rtx? default)))
+            (parse-error errtxt "invalid default" default))
+        (elm-xset! result 'default default)))
+      ((<bitset-attribute> <enum-attribute>)
+       (let ((default (if default default (caar parsed-values))))
+        (if (and (not (assq default parsed-values))
+                 (not (rtx? default)))
+            (parse-error errtxt "invalid default" default))
+        (elm-xset! result 'default default))))
+    (elm-xset! result 'values parsed-values)
+    result)
+)
+
+; Read an attribute description
+; This is the main routine for analyzing attributes in the .cpu file.
+; ERRTXT is prepended to error messages to provide context.
+; ARG-LIST is an associative list of field name and field value.
+; -attr-parse is invoked to create the attribute object.
+
+(define (-attr-read errtxt . arg-list)
+  (let (; Current attribute elements:
+       (type-class 'not-set) ; attribute type
+       (name nil)
+       (comment "")
+       (attrs nil)
+       (for #f) ; assume for everything
+       (default #f) ; assume boolean
+       (values '(#f #t)) ; assume boolean
+       )
+    ; Loop over each element in ARG-LIST, recording what's found.
+    (let loop ((arg-list arg-list))
+      (if (null? arg-list)
+         nil
+         (let ((arg (car arg-list))
+               (elm-name (caar arg-list)))
+           (case elm-name
+             ((type) (set! type-class (case (cadr arg)
+                                       ((boolean) <boolean-attribute>)
+                                       ((bitset) <bitset-attribute>)
+                                       ((integer) <integer-attribute>)
+                                       ((enum) <enum-attribute>)
+                                       (else (parse-error
+                                              errtxt
+                                              "invalid attribute type"
+                                              (cadr arg))))))
+             ((name) (set! name (cadr arg)))
+             ((comment) (set! comment (cadr arg)))
+             ((attrs) (set! attrs (cdr arg)))
+             ((for) (set! for (cdr arg)))
+             ((default) (set! default (cadr arg)))
+             ((values) (set! values (cdr arg)))
+             (else (parse-error errtxt "invalid attribute arg" arg)))
+           (loop (cdr arg-list)))))
+    ; Now that we've identified the elements, build the object.
+    (-attr-parse errtxt type-class name comment attrs for default values)
+    )
+)
+
+; Main routine for defining attributes in .cpu files.
+
+(define define-attr
+  (lambda arg-list
+    (let ((a (apply -attr-read (cons "define-attr" arg-list))))
+      (current-attr-add! a)
+      a))
+)
+\f
+; Query routines.
+
+; Lookup ATTR-NAME in ATTR-LIST.
+; The result is the object or #f if not found.
+
+(define (attr-lookup attr-name attr-list)
+  (object-assq attr-name attr-list)
+)
+
+; Return a boolean indicating if boolean attribute ATTR is "true" in
+; attribute alist ALIST.
+; Note that if the attribute isn't present, it is defined to be #f.
+
+(define (attr-has-attr? alist attr)
+  (let ((a (assq attr alist)))
+    (cond ((not a) a)
+         ((boolean? (cdr a)) (cdr a))
+         (else (error "Not a boolean attribute:" attr))))
+)
+
+(method-make! <attr-list> 'has-attr?
+             (lambda (self attr) (attr-has-attr? (elm-get self 'attrs) attr))
+)
+
+(define (atlist-has-attr? atlist attr)
+  (send atlist 'has-attr? attr)
+)
+
+; Expand attribute value ATVAL, which is an rtx expression.
+; OWNER is the containing object or #f if there is none.
+; OWNER is needed if an attribute is defined in terms of other attributes.
+; If it's #f obviously ATVAL can't be defined in terms of others.
+
+(define (-attr-eval atval owner)
+  (let* ((estate (estate-make-for-eval #f owner))
+        (expr (rtx-compile #f (rtx-simplify #f owner atval nil) nil))
+        (value (rtx-eval-with-estate expr 'DFLT estate)))
+    (cond ((symbol? value) value)
+         ((number? value) value)
+         (error "-attr-eval: internal error, unsupported result:" value)))
+)
+
+; Return value of ATTR in attribute alist ALIST.
+; If not present, return the default value.
+; OWNER is the containing object or #f if there is none.
+
+(define (attr-value alist attr owner)
+  (let ((a (assq-ref alist attr)))
+    (if a
+       (if (pair? a) ; pair? -> cheap non-null-list?
+           (-attr-eval a owner)
+           a)
+       (attr-lookup-default attr owner)))
+)
+
+; Return the value of ATTR in ATLIST.
+; OWNER is the containing object or #f if there is none.
+
+(define (atlist-attr-value atlist attr owner)
+  (attr-value (atlist-attrs atlist) attr owner)
+)
+
+; Same as atlist-attr-value but return nil if attribute not present.
+
+(define (atlist-attr-value-no-default atlist attr owner)
+  (let ((a (assq-ref (atlist-attrs atlist) attr)))
+    (if a
+       (if (pair? a) ; pair? -> cheap non-null-list?
+           (-attr-eval a owner)
+           a)
+       nil))
+)
+
+; Return the default for attribute A.
+; If A isn't a non-boolean attribute, we assume it's a boolean one, and
+; return #f (??? for backward's compatibility, to be removed in time).
+; OWNER is the containing object or #f if there is none.
+
+(define (attr-lookup-default a owner)
+  (let ((at (current-attr-lookup a)))
+    (if at
+       (if (bool-attr? at)
+           #f
+           (let ((deflt (attr-default at)))
+             (if deflt
+                 (if (pair? deflt) ; pair? -> cheap non-null-list?
+                     (-attr-eval deflt owner)
+                     deflt)
+                 ; If no default was provided, use the first value.
+                 (caar (attr-values at)))))
+       #f))
+)
+
+; Return a boolean indicating if X is present in BITSET.
+; Bitset values are recorded as val1,val2,....
+
+(define (bitset-attr-member? x bitset)
+  (->bool (memq x (bitset-attr->list bitset)))
+)
+\f
+; Routines for accessing attributes in objects.
+
+; Get/set attributes of OBJ.
+; OBJ is any object which supports the get-atlist message.
+
+(define (obj-atlist obj)
+  (let ((result (send obj 'get-atlist)))
+    ; As a speed up, we allow objects to specify an empty attribute list
+    ; with #f or (), rather than creating an attr-list object.
+    ; ??? There is atlist-empty now which should be used directly.
+    (if (or (null? result) (not result))
+       atlist-empty
+       result))
+)
+(define (obj-set-atlist! obj attrs) (send obj 'set-atlist! attrs))
+
+; Add attribute ATTR to OBJ.
+; The attribute is prepended to the front so it overrides any existing
+; definition.
+
+(define (obj-cons-attr! obj attr)
+  (obj-set-atlist! obj (atlist-cons attr (obj-atlist obj)))
+)
+
+; Add attribute list ATLIST to OBJ.
+; Attributes in ATLIST override existing values, so ATLIST is "prepended".
+
+(define (obj-prepend-atlist! obj atlist)
+  ; Must have same prefix.
+  (assert (equal? (atlist-prefix (obj-atlist obj))
+                 (atlist-prefix atlist)))
+  (obj-set-atlist! obj (atlist-append atlist (obj-atlist obj)))
+)
+
+; Return boolean of whether OBJ has boolean attribute ATTR or not.
+; OBJ is any object.
+
+(define (obj-has-attr? obj attr)
+  (atlist-has-attr? (obj-atlist obj) attr)
+)
+
+; FIXME: for backward compatibility.  Delete in time.
+(define has-attr? obj-has-attr?)
+
+; Return value of attribute ATTR in OBJ.
+; If the attribute isn't present, the default is returned.
+; OBJ is any object that supports the get-atlist method.
+
+(define (obj-attr-value obj attr)
+  (let ((atlist (obj-atlist obj)))
+    (atlist-attr-value atlist attr obj))
+)
+\f
+; Utilities.
+
+; Convert a bitset value "a,b,c" into a list (a b c).
+
+(define (bitset-attr->list x)
+  (map string->symbol (string-cut x #\,))
+)
+
+; Return the enum of ATTR-NAME for type TYPE.
+; TYPE is one of 'ifld, 'hw, 'operand, 'insn.
+
+(define (gen-attr-enum type attr-name)
+  (string-upcase (string-append "CGEN_" type "_" (gen-sym attr-name)))
+)
+
+; Return a list of enum value definitions for gen-enum-decl.
+; Attributes numbers are organized as follows: booleans are numbered 0-31.
+; The range is because that's what fits in a portable int.  Unused numbers
+; are left unused.  Non-booleans are numbered starting at 32.
+; An alternative is start numbering the booleans at 32.  The generated code
+; is simpler with the current way (the "- 32" to get back the bit number or
+; array index number occurs less often).
+;
+; Three special values are created:
+; END-BOOLS - mark end of boolean attributes
+; END-NBOOLS - mark end of non-boolean attributes
+; START-NBOOLS - marks the start of the non-boolean attributes
+; (needed in case first non-bool is sanytized out).
+;
+; ATTR-OBJ-LIST is a list of <attribute> objects (always subclassed of course).
+
+(define (attr-list-enum-list attr-obj-list)
+  (let ((sorted-attrs (-attr-sort (attr-remove-meta-attrs attr-obj-list))))
+    (assert (<= (length (car sorted-attrs)) 32))
+    (append!
+     (map (lambda (bool-attr)
+           (list (obj:name bool-attr) '-
+                 (atlist-attrs (obj-atlist bool-attr))))
+         (car sorted-attrs))
+     (list '(END-BOOLS))
+     (list '(START-NBOOLS 31))
+     (map (lambda (nbool-attr)
+           (list (obj:name nbool-attr) '-
+                 (atlist-attrs (obj-atlist nbool-attr))))
+         (cdr sorted-attrs))
+     (list '(END-NBOOLS))
+     ))
+)
+
+; Sort an alist of attributes so non-boolean attributes are at the front.
+; This is used to sort a particular object's attributes.
+; This is required by the C support code (cgen.h:CGEN_ATTR_VALUE).
+; Boolean attributes appear as (NAME . #t/#f), non-boolean ones appear as
+; (NAME . VALUE).  Attributes of the same type are sorted by name.
+
+(define (-attr-sort-alist alist)
+  (sort alist
+       (lambda (a b)
+         ;(display (list a b "\n"))
+         (cond ((and (boolean? (cdr a)) (boolean? (cdr b)))
+                (string<? (symbol->string (car a)) (symbol->string (car b))))
+               ((boolean? (cdr a)) #f) ; we know b is non-bool here
+               ((boolean? (cdr b)) #t) ; we know a is non-bool here
+               (else (string<? (symbol->string (car a))
+                               (symbol->string (car b)))))))
+)
+
+; Sort ATTR-LIST into two lists: bools and non-bools.
+; The car of the result is the bools, the cdr is the non-bools.
+; Attributes requiring a fixed index have the INDEX attribute,
+; and used for the few special attributes that are refered to by
+; architecture independent code.
+; For each of non-bools and bools, put attributes with the INDEX attribute
+; first.  This is used to sort a list of attributes for output (e.g. define
+; the attr enum).
+;
+; ??? Record index number with the INDEX attribute?
+; At present it's just a boolean.
+
+(define (-attr-sort attr-list)
+  (let loop ((fixed-non-bools nil)
+            (non-fixed-non-bools nil)
+            (fixed-bools nil)
+            (non-fixed-bools nil)
+            (attr-list attr-list))
+    (cond ((null? attr-list)
+          (cons (append! (reverse! fixed-bools)
+                         (reverse! non-fixed-bools))
+                (append! (reverse! fixed-non-bools)
+                         (reverse! non-fixed-non-bools))))
+         ((bool-attr? (car attr-list))
+          (if (obj-has-attr? (car attr-list) 'INDEX)
+              (loop fixed-non-bools non-fixed-non-bools
+                    (cons (car attr-list) fixed-bools) non-fixed-bools
+                    (cdr attr-list))
+              (loop fixed-non-bools non-fixed-non-bools
+                    fixed-bools (cons (car attr-list) non-fixed-bools)
+                    (cdr attr-list))))
+         (else
+          (if (obj-has-attr? (car attr-list) 'INDEX)
+              (loop (cons (car attr-list) fixed-non-bools) non-fixed-non-bools
+                    fixed-bools non-fixed-bools
+                    (cdr attr-list))
+              (loop fixed-non-bools (cons (car attr-list) non-fixed-non-bools)
+                    fixed-bools non-fixed-bools
+                    (cdr attr-list))))))
+)
+
+; Return number of non-bools in attributes ATLIST.
+
+(define (attr-count-non-bools atlist)
+  (count-true (map (lambda (a) (not (bool-attr? a)))
+                  atlist))
+)
+
+; Given an alist of attributes, return the non-bools.
+
+(define (attr-non-bool-attrs alist)
+  (let loop ((result nil) (alist alist))
+    (cond ((null? alist) (reverse! result))
+         ((boolean? (cdar alist)) (loop result (cdr alist)))
+         (else (loop (cons (car alist) result) (cdr alist)))))
+)
+
+; Given an alist of attributes, return the bools.
+
+(define (attr-bool-attrs alist)
+  (let loop ((result nil) (alist alist))
+    (cond ((null? alist) (reverse! result))
+         ((boolean? (cdar alist))
+          (loop (cons (car alist) result) (cdr alist)))
+         (else (loop result (cdr alist)))))
+)
+
+; Parse an attribute spec.
+; CONTEXT is a <context> object or #f if there is none.
+; ATTRS is a list of attribute specs (e.g. (FOO !BAR (BAZ 3))).
+; The result is the attribute alist.
+
+(define (attr-parse context attrs)
+  (if (not (list? attrs))
+      (context-error context "improper attribute list" attrs))
+  (let ((alist nil))
+    (for-each (lambda (elm)
+               (cond ((symbol? elm)
+                      ; boolean attribute
+                      (if (char=? (string-ref elm 0) #\!)
+                          (set! alist (acons (string->symbol (string-drop1 elm)) #f alist))
+                          (set! alist (acons elm #t alist)))
+                      (if (not (current-attr-lookup (caar alist)))
+                          (context-error context "unknown attribute" (caar alist))))
+                     ((and (list? elm) (pair? elm) (symbol? (car elm)))
+                      (let ((a (current-attr-lookup (car elm))))
+                        (if (not a)
+                            (context-error context "unknown attribute" elm))
+                        (set! alist (cons (send a 'parse-value
+                                                (context-prefix context);FIXME
+                                                (cdr elm)) alist))))
+                     (else (context-error context "improper attribute" elm))))
+             attrs)
+    alist)
+)
+
+; Parse an object attribute spec.
+; ATTRS is a list of attribute specs (e.g. (FOO !BAR (BAZ 3))).
+; The result is an <attr-list> object.
+
+(define (atlist-parse attrs prefix errtxt)
+  (make <attr-list> prefix (attr-parse (context-make-prefix errtxt) attrs))
+)
+
+; Return the source form of an atlist's values.
+; Externally attributes are ((name1 value1) (name2 value2) ...).
+; Internally they are ((name1 . value1) (name2 . value2) ...).
+
+(define (atlist-source-form atlist)
+  (map (lambda (attr)
+        (list (car attr) (cdr attr)))
+       (atlist-attrs atlist))
+)
+
+; cons an attribute to an attribute list to create a new attribute list
+; ATLIST is either an attr-list object or #f or () (both of the latter two
+; signify an empty attribute list, in which case we make the prefix of the
+; result "").
+
+(define (atlist-cons attr atlist)
+  (if (or (not atlist) (null? atlist))
+      (make <attr-list> "" (cons attr nil))
+      (make <attr-list> (atlist-prefix atlist) (cons attr (atlist-attrs atlist))))
+)
+
+; Append one attribute list to another.
+; The prefix for the new atlist is taken from the first one.
+
+(define (atlist-append attr-list1 attr-list2)
+  (make <attr-list>
+       (atlist-prefix attr-list1)
+       (append (atlist-attrs attr-list1) (atlist-attrs attr-list2)))
+)
+
+; Remove meta-attributes from ALIST.
+; "meta" may be the wrong adjective to use here.
+; The attributes in question are not intended to appear in generated files.
+; They started out being attributes of attributes, hence the name "meta".
+
+(define (attr-remove-meta-attrs-alist alist)
+  (let ((all-attrs (current-attr-list)))
+    ; FIXME: Why not use find?
+    (let loop ((result nil) (alist alist))
+      (if (null? alist)
+         (reverse! result)
+         (let ((attr (attr-lookup (caar alist) all-attrs)))
+           (if (and attr (has-attr? attr 'META))
+               (loop result (cdr alist))
+               (loop (cons (car alist) result) (cdr alist)))))))
+)
+
+; Remove meta-attributes from ATTR-LIST.
+; "meta" may be the wrong adjective to use here.
+; The attributes in question are not intended to appear in generated files.
+; They started out being attributes of attributes, hence the name "meta".
+
+(define (attr-remove-meta-attrs attr-list)
+  ; FIXME: Why not use find?
+  (let loop ((result nil) (attr-list attr-list))
+    (cond ((null? attr-list)
+          (reverse! result))
+         ((has-attr? (car attr-list) 'META)
+          (loop result (cdr attr-list)))
+         (else
+          (loop (cons (car attr-list) result) (cdr attr-list)))))
+)
+
+; Remove duplicates from ATTRS, a list of attributes.
+; Attribute lists are typically small so we use a simple O^2 algorithm.
+; The leading entry of an attribute overrides subsequent ones so this is
+; defined to pick the first entry of each attribute.
+
+(define (attr-nub attrs)
+  (let loop ((result nil) (attrs attrs))
+    (cond ((null? attrs) (reverse! result))
+         ((assq (caar attrs) result) (loop result (cdr attrs)))
+         (else (loop (cons (car attrs) result) (cdr attrs)))))
+)
+
+; Return a list of all attrs in TABLE-LIST, a list of lists of arbitrary
+; elements.   A list of lists is passed to simplify computation of insn
+; attributes where the insns and macro-insns are on separate lists and
+; appending them into one list would be unnecessarily expensive.
+; ACCESSOR is a function to access the attrs field from TABLE-LIST.
+; Duplicates are eliminated and the list is sorted so non-boolean attributes
+; are at the front (required by the C code that fetches attribute values).
+; STD-ATTRS is an `attr-list' object of attrs that are always available.
+; The actual values returned are random (e.g. #t vs #f).  We could
+; canonicalize them.
+; The result is an alist of all the attributes that are used in TABLE-LIST.
+; ??? The cdr of each element is some random value.  Perhaps it should be
+; the default value or perhaps we should just return a list of names.
+; ??? No longer used.
+
+(define (attr-compute-all table-list accessor std-attrs)
+  (let ((accessor (lambda (elm) (atlist-attrs (accessor elm)))))
+    (attr-remove-meta-attrs-alist
+     (attr-nub
+      (-attr-sort-alist
+       (append
+       (apply append
+              (map (lambda (table-elm)
+                     (apply append
+                            (find-apply accessor
+                                        (lambda (e)
+                                          (let ((attrs (accessor e)))
+                                            (not (null? attrs))))
+                                        table-elm)))
+                   table-list))
+       (atlist-attrs std-attrs))))))
+)
+
+; Return lists of attributes for particular object types.
+; FIXME: The output shouldn't be required to be sorted.
+
+(define (current-attr-list-for type)
+  (let ((sorted (-attr-sort (find (lambda (a)
+                                   (if (atlist-for a)
+                                       (memq type (atlist-for a))
+                                       #t))
+                                 (attr-remove-meta-attrs
+                                  (current-attr-list))))))
+    ; Current behaviour puts the non-bools at the front.
+    (append! (cdr sorted) (car sorted)))
+)
+(define (current-ifld-attr-list)
+  (current-attr-list-for 'ifield)
+)
+(define (current-hw-attr-list)
+  (current-attr-list-for 'hardware)
+)
+(define (current-op-attr-list)
+  (current-attr-list-for 'operand)
+)
+(define (current-insn-attr-list)
+  (current-attr-list-for 'insn)
+)
+\f
+; Methods to emit the C value of an attribute.
+; These don't _really_ belong here (C code doesn't belong in the appl'n
+; independent part of CGEN), but there isn't a better place for them
+; (maybe utils-cgen.scm?) and there's only a few of them.
+
+(method-make!
+ <boolean-attribute> 'gen-value-for-defn
+ (lambda (self value)
+   (if (not value)
+       "0"
+       "1"))
+ ;(string-upcase (string-append (obj:name self) "_" value)))
+)
+
+(method-make!
+ <bitset-attribute> 'gen-value-for-defn
+ (lambda (self value)
+   (string-drop1
+    (string-upcase
+     (string-map (lambda (x)
+                  (string-append "|(1<<"
+                                 (gen-sym self)
+                                 "_" (gen-c-symbol x) ")"))
+                (bitset-attr->list value)))))
+)
+
+(method-make!
+ <integer-attribute> 'gen-value-for-defn
+ (lambda (self value)
+   (number->string value))
+)
+
+(method-make!
+ <enum-attribute> 'gen-value-for-defn
+ (lambda (self value)
+   (string-upcase (gen-c-symbol (string-append (obj:name self) "_" value))))
+)
+\f
+; Called before loading a .cpu file to initialize.
+
+(define (attr-init!)
+
+  (reader-add-command! 'define-attr
+                      "\
+Define an attribute, name/value pair list version.
+"
+                      nil 'arg-list define-attr)
+
+  *UNSPECIFIED*
+)
+
+; Called before a . cpu file is read in to install any builtins.
+; One thing this does is define all attributes requiring a fixed index,
+; keeping them all in one place.
+; ??? Perhaps it would make sense to define all predefined attributes here.
+
+(define (attr-builtin!)
+  (define-attr '(type boolean) '(name VIRTUAL) '(comment "virtual object"))
+
+  ; The meta attribute is used for attributes that aren't to appear in
+  ; generated output (need a better name).
+  (define-attr '(for attr) '(type boolean) '(name META))
+
+  ; Objects to keep local to a generated file.
+  (define-attr '(for keyword) '(type boolean) '(name PRIVATE))
+
+  ; Attributes requiring fixed indices.
+  ; ALIAS is used for instructions that are aliases of more general insns.
+  ; ALIAS insns are ignored by the simulator.
+  (define-attr '(for attr) '(type boolean) '(name INDEX) '(attrs META))
+  (define-attr '(for insn) '(type boolean) '(name ALIAS)
+    '(comment "insn is an alias of another")
+    '(attrs INDEX))
+
+  *UNSPECIFIED*
+)
+
+; Called after loading a .cpu file to perform any post-processing required.
+
+(define (attr-finish!)
+  *UNSPECIFIED*
+)
diff --git a/cgen/cgen-gas.scm b/cgen/cgen-gas.scm
new file mode 100644 (file)
index 0000000..c6d3b94
--- /dev/null
@@ -0,0 +1,80 @@
+; CPU description file generator for the GAS testsuite.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+
+; This is invoked to build several .s files and a script to run to
+; generate the .d files and .exp file.
+; This is invoked to build: tmp-build.sh cpu-cpu.exp
+
+; Load the various support routines.
+
+(define (load-files srcdir)
+  ; Fix up Scheme to be what we use (guile is always in flux).
+  (primitive-load-path (string-append srcdir "/fixup.scm"))
+
+  (load (string-append srcdir "/read.scm"))
+  (load (string-append srcdir "/desc.scm"))
+  (load (string-append srcdir "/desc-cpu.scm"))
+  (load (string-append srcdir "/opcodes.scm"))
+  (load (string-append srcdir "/opc-asmdis.scm"))
+  (load (string-append srcdir "/opc-ibld.scm"))
+  (load (string-append srcdir "/opc-itab.scm"))
+  (load (string-append srcdir "/opc-opinst.scm"))
+  (load (string-append srcdir "/gas-test.scm"))
+)
+
+(define gas-arguments
+  (list
+   (list '-B "file" "generate build.sh in <file>"
+        (lambda (arg) (file-write arg cgen-build.sh)))
+   (list '-E "file" "generate allinsn.exp in <file>"
+        (lambda (arg) (file-write arg cgen-allinsn.exp)))
+   )
+)
+
+; Kept global so it's available to the other .scm files.
+(define srcdir ".")
+
+; Scan argv for -s srcdir.
+; We can't process any other args until we find the cgen source dir.
+; The result is srcdir.
+; We assume "-s" isn't the argument to another option.  Unwise, yes.
+; Alternatives are to require it to be the first argument or at least preceed
+; any option with a "-s" argument, or to put knowledge of the common argument
+; set and common argument parsing code in every top level file.
+
+(define (find-srcdir argv)
+  (let loop ((argv argv))
+    (if (null? argv)
+       (error "`-s srcdir' not present, can't load cgen"))
+    (if (string=? "-s" (car argv))
+       (begin
+         (if (null? (cdr argv))
+             (error "missing srcdir arg to `-s'"))
+         (cadr argv))
+       (loop (cdr argv))))     
+)
+
+; Main routine, parses options and calls generators.
+
+(define (cgen-gas argv)
+  (let ()
+
+    ; Find and set srcdir, then load all Scheme code.
+    ; Drop the first argument, it is the script name (i.e. argv[0]).
+    (set! srcdir (find-srcdir (cdr argv)))
+    (set! %load-path (cons srcdir %load-path))
+    (load-files srcdir)
+
+    (display-argv argv)
+
+    (cgen #:argv argv
+         #:app-name "gas-test"
+         #:arg-spec gas-arguments
+         #:init gas-test-init!
+         #:finish gas-test-finish!
+         #:analyze gas-test-analyze!)
+    )
+)
+
+(cgen-gas (program-arguments))
diff --git a/cgen/cgen-opc.scm b/cgen/cgen-opc.scm
new file mode 100644 (file)
index 0000000..cd98fe0
--- /dev/null
@@ -0,0 +1,99 @@
+; CPU description file generator for the GNU Binutils.
+; This is invoked to build: $arch-desc.[ch], $arch-opinst.c,
+; $arch-opc.h, $arch-opc.c, $arch-asm.in, $arch-dis.in, and $arch-ibld.[ch].
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+;
+; This is a standalone script, we don't load anything until we parse the
+; -s argument (keeps reliance off of environment variables, etc.).
+
+; Load the various support routines.
+
+(define (load-files srcdir)
+  ; Fix up Scheme to be what we use (guile is always in flux).
+  (primitive-load-path (string-append srcdir "/fixup.scm"))
+
+  (load (string-append srcdir "/read.scm"))
+  (load (string-append srcdir "/desc.scm"))
+  (load (string-append srcdir "/desc-cpu.scm"))
+  (load (string-append srcdir "/opcodes.scm"))
+  (load (string-append srcdir "/opc-asmdis.scm"))
+  (load (string-append srcdir "/opc-ibld.scm"))
+  (load (string-append srcdir "/opc-itab.scm"))
+  (load (string-append srcdir "/opc-opinst.scm"))
+)
+
+(define opc-arguments
+  (list
+   (list '-H "file" "generate $arch-desc.h in <file>"
+        (lambda (arg) (file-write arg cgen-desc.h)))
+   (list '-C "file" "generate $arch-desc.c in <file>"
+        (lambda (arg) (file-write arg cgen-desc.c)))
+   (list '-O "file" "generate $arch-opc.h in <file>"
+        (lambda (arg) (file-write arg cgen-opc.h)))
+   (list '-P "file" "generate $arch-opc.c in <file>"
+        (lambda (arg) (file-write arg cgen-opc.c)))
+   (list '-Q "file" "generate $arch-opinst.c in <file>"
+        (lambda (arg) (file-write arg cgen-opinst.c)))
+   (list '-B "file" "generate $arch-ibld.h in <file>"
+        (lambda (arg) (file-write arg cgen-ibld.h)))
+   (list '-L "file" "generate $arch-ibld.in in <file>"
+        (lambda (arg) (file-write arg cgen-ibld.in)))
+   (list '-A "file" "generate $arch-asm.in in <file>"
+        (lambda (arg) (file-write arg cgen-asm.in)))
+   (list '-D "file" "generate $arch-dis.in in <file>"
+        (lambda (arg) (file-write arg cgen-dis.in)))
+   )
+)
+
+; (-R "file" "generate $cpu-reloc.h") ; FIXME: wip (rename to -abi.h?)
+; (-S "file" "generate cpu-$cpu.c") ; FIXME: wip (bfd's cpu-$cpu.c)
+; ((-R) (file-write *arg* cgen-reloc.c))
+; ((-S) (file-write *arg* cgen-bfdcpu.c))
+
+; Kept global so it's available to the other .scm files.
+(define srcdir ".")
+
+; Scan argv for -s srcdir.
+; We can't process any other args until we find the cgen source dir.
+; The result is srcdir.
+; We assume "-s" isn't the argument to another option.  Unwise, yes.
+; Alternatives are to require it to be the first argument or at least preceed
+; any option with a "-s" argument, or to put knowledge of the common argument
+; set and common argument parsing code in every top level file.
+
+(define (find-srcdir argv)
+  (let loop ((argv argv))
+    (if (null? argv)
+       (error "`-s srcdir' not present, can't load cgen"))
+    (if (string=? "-s" (car argv))
+       (begin
+         (if (null? (cdr argv))
+             (error "missing srcdir arg to `-s'"))
+         (cadr argv))
+       (loop (cdr argv))))     
+)
+
+; Main routine, parses options and calls generators.
+
+(define (cgen-opc argv)
+  (let ()
+
+    ; Find and set srcdir, then load all Scheme code.
+    ; Drop the first argument, it is the script name (i.e. argv[0]).
+    (set! srcdir (find-srcdir (cdr argv)))
+    (set! %load-path (cons srcdir %load-path))
+    (load-files srcdir)
+
+    (display-argv argv)
+
+    (cgen #:argv argv
+         #:app-name "opcodes"
+         #:arg-spec opc-arguments
+         #:init opcodes-init!
+         #:finish opcodes-finish!
+         #:analyze opcodes-analyze!)
+    )
+)
+
+(cgen-opc (program-arguments))
diff --git a/cgen/cgen-sim.scm b/cgen/cgen-sim.scm
new file mode 100644 (file)
index 0000000..766153a
--- /dev/null
@@ -0,0 +1,112 @@
+; Simulator generator entry point.
+; This is invoked to build: arch.h, cpu-<cpu>.h, memops.h, semops.h, decode.h,
+; decode.c, extract.c, semantics.c, ops.c, model.c, mainloop.in.
+;
+; memops.h, semops.h, ops.c, mainloop.in are either deprecated or wip.
+;
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+;
+; This is a standalone script, we don't load anything until we parse the
+; -s argument (keeps reliance off of environment variables, etc.).
+
+; Load the various support routines.
+
+(define (load-files srcdir)
+  ; Fix up Scheme to be what we use (guile is always in flux).
+  (primitive-load-path (string-append srcdir "/fixup.scm"))
+
+  (load (string-append srcdir "/read.scm"))
+  (load (string-append srcdir "/utils-sim.scm"))
+  (load (string-append srcdir "/sim.scm"))
+  (load (string-append srcdir "/sim-arch.scm"))
+  (load (string-append srcdir "/sim-cpu.scm"))
+  (load (string-append srcdir "/sim-model.scm"))
+  (load (string-append srcdir "/sim-decode.scm"))
+)
+
+(define sim-arguments
+  (list
+   (list '-A "file" "generate arch.h in <file>"
+        (lambda (arg) (file-write arg cgen-arch.h)))
+   (list '-B "file" "generate arch.c in <file>"
+        (lambda (arg) (file-write arg cgen-arch.c)))
+   (list '-C "file" "generate cpu-<cpu>.h in <file>"
+        (lambda (arg) (file-write arg cgen-cpu.h)))
+   (list '-U "file" "generate cpu-<cpu>.c in <file>"
+        (lambda (arg) (file-write arg cgen-cpu.c)))
+   (list '-N "file" "generate cpu-all.h in <file>"
+        (lambda (arg) (file-write arg cgen-cpuall.h)))
+   (list '-F "file" "generate memops.h in <file>"
+        (lambda (arg) (file-write arg cgen-mem-ops.h)))
+   (list '-P "file" "generate semops.h in <file>"
+        (lambda (arg) (file-write arg cgen-sem-ops.h)))
+   (list '-T "file" "generate decode.h in <file>"
+        (lambda (arg) (file-write arg cgen-decode.h)))
+   (list '-D "file" "generate decode.c in <file>"
+        (lambda (arg) (file-write arg cgen-decode.c)))
+   (list '-E "file" "generate extract.c in <file>"
+        (lambda (arg) (file-write arg cgen-extract.c)))
+   (list '-R "file" "generate read.c in <file>"
+        (lambda (arg) (file-write arg cgen-read.c)))
+   (list '-W "file" "generate write.c in <file>"
+        (lambda (arg) (file-write arg cgen-write.c)))
+   (list '-S "file" "generate semantics.c in <file>"
+        (lambda (arg) (file-write arg cgen-semantics.c)))
+   (list '-X "file" "generate sem-switch.c in <file>"
+        (lambda (arg) (file-write arg cgen-sem-switch.c)))
+   (list '-O "file" "generate ops.c in <file>"
+        (lambda (arg) (file-write arg cgen-ops.c)))
+   (list '-M "file" "generate model.c in <file>"
+        (lambda (arg) (file-write arg cgen-model.c)))
+   (list '-L "file" "generate mainloop.in in <file>"
+        (lambda (arg) (file-write arg cgen-mainloop.in)))
+   )
+)
+
+; Kept global so it's available to the other .scm files.
+(define srcdir ".")
+
+; Scan argv for -s srcdir.
+; We can't process any other args until we find the cgen source dir.
+; The result is srcdir.
+; We assume "-s" isn't the argument to another option.  Unwise, yes.
+; Alternatives are to require it to be the first argument or at least preceed
+; any option with a "-s" argument, or to put knowledge of the common argument
+; set and common argument parsing code in every top level file.
+
+(define (find-srcdir argv)
+  (let loop ((argv argv))
+    (if (null? argv)
+       (error "`-s srcdir' not present, can't load cgen"))
+    (if (string=? "-s" (car argv))
+       (begin
+         (if (null? (cdr argv))
+             (error "missing srcdir arg to `-s'"))
+         (cadr argv))
+       (loop (cdr argv))))     
+)
+
+; Main routine, parses options and calls generators.
+
+(define (cgen-sim argv)
+  (let ()
+
+    ; Find and set srcdir, then load all Scheme code.
+    ; Drop the first argument, it is the script name (i.e. argv[0]).
+    (set! srcdir (find-srcdir (cdr argv)))
+    (set! %load-path (cons srcdir %load-path))
+    (load-files srcdir)
+
+    (display-argv argv)
+
+    (cgen #:argv argv
+         #:app-name "sim"
+         #:arg-spec sim-arguments
+         #:init sim-init!
+         #:finish sim-finish!
+         #:analyze sim-analyze!)
+    )
+)
+
+(cgen-sim (program-arguments))
diff --git a/cgen/cgen-stest.scm b/cgen/cgen-stest.scm
new file mode 100644 (file)
index 0000000..ed1edec
--- /dev/null
@@ -0,0 +1,79 @@
+; CPU description file generator for the simulator testsuite.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+
+; This is invoked to build several .s files and a script to run to
+; generate the .d files and .exp file.
+; This is invoked to build: tmp-build.sh cpu-cpu.exp
+\f
+; Load the various support routines
+(define (load-files srcdir)
+  ; Fix up Scheme to be what we use (guile is always in flux).
+  (primitive-load-path (string-append srcdir "/fixup.scm"))
+
+  (load (string-append srcdir "/read.scm"))
+  (load (string-append srcdir "/desc.scm"))
+  (load (string-append srcdir "/desc-cpu.scm"))
+  (load (string-append srcdir "/opcodes.scm"))
+  (load (string-append srcdir "/opc-asmdis.scm"))
+  (load (string-append srcdir "/opc-ibld.scm"))
+  (load (string-append srcdir "/opc-itab.scm"))
+  (load (string-append srcdir "/opc-opinst.scm"))
+  (load (string-append srcdir "/sim-test.scm"))
+)
+
+(define stest-arguments
+  (list
+   (list '-B "file" "generate build.sh"
+        (lambda (arg) (file-write arg cgen-build.sh)))
+   (list '-E "file" "generate the testsuite .exp"
+        (lambda (arg) (file-write arg cgen-allinsn.exp)))
+   )
+)
+
+; Kept global so it's available to the other .scm files.
+(define srcdir ".")
+
+; Scan argv for -s srcdir.
+; We can't process any other args until we find the cgen source dir.
+; The result is srcdir.
+; We assume "-s" isn't the argument to another option.  Unwise, yes.
+; Alternatives are to require it to be the first argument or at least preceed
+; any option with a "-s" argument, or to put knowledge of the common argument
+; set and common argument parsing code in every top level file.
+
+(define (find-srcdir argv)
+  (let loop ((argv argv))
+    (if (null? argv)
+       (error "`-s srcdir' not present, can't load cgen"))
+    (if (string=? "-s" (car argv))
+       (begin
+         (if (null? (cdr argv))
+             (error "missing srcdir arg to `-s'"))
+         (cadr argv))
+       (loop (cdr argv))))     
+)
+
+; Main routine, parses options and calls generators.
+
+(define (cgen-stest argv)
+  (let ()
+
+    ; Find and set srcdir, then load all Scheme code.
+    ; Drop the first argument, it is the script name (i.e. argv[0]).
+    (set! srcdir (find-srcdir (cdr argv)))
+    (set! %load-path (cons srcdir %load-path))
+    (load-files srcdir)
+
+    (display-argv argv)
+
+    (cgen #:argv argv
+         #:app-name "sim-test"
+         #:arg-spec stest-arguments
+         #:init sim-test-init!
+         #:finish sim-test-finish!
+         #:analyze sim-test-analyze!)
+    )
+)
+
+(cgen-stest (program-arguments))
diff --git a/cgen/configure b/cgen/configure
new file mode 100755 (executable)
index 0000000..0e48be6
--- /dev/null
@@ -0,0 +1,1374 @@
+#! /bin/sh
+
+# Guess values for system-dependent variables and create Makefiles.
+# Generated automatically using autoconf version 2.13 
+# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc.
+#
+# This configure script is free software; the Free Software Foundation
+# gives unlimited permission to copy, distribute and modify it.
+
+# Defaults:
+ac_help=
+ac_default_prefix=/usr/local
+# Any additions from configure.in:
+ac_help="$ac_help
+  --enable-maintainer-mode enable make rules and dependencies not useful
+                          (and sometimes confusing) to the casual installer"
+
+# Initialize some variables set by options.
+# The variables have the same names as the options, with
+# dashes changed to underlines.
+build=NONE
+cache_file=./config.cache
+exec_prefix=NONE
+host=NONE
+no_create=
+nonopt=NONE
+no_recursion=
+prefix=NONE
+program_prefix=NONE
+program_suffix=NONE
+program_transform_name=s,x,x,
+silent=
+site=
+sitefile=
+srcdir=
+target=NONE
+verbose=
+x_includes=NONE
+x_libraries=NONE
+bindir='${exec_prefix}/bin'
+sbindir='${exec_prefix}/sbin'
+libexecdir='${exec_prefix}/libexec'
+datadir='${prefix}/share'
+sysconfdir='${prefix}/etc'
+sharedstatedir='${prefix}/com'
+localstatedir='${prefix}/var'
+libdir='${exec_prefix}/lib'
+includedir='${prefix}/include'
+oldincludedir='/usr/include'
+infodir='${prefix}/info'
+mandir='${prefix}/man'
+
+# Initialize some other variables.
+subdirs=
+MFLAGS= MAKEFLAGS=
+SHELL=${CONFIG_SHELL-/bin/sh}
+# Maximum number of lines to put in a shell here document.
+ac_max_here_lines=12
+
+ac_prev=
+for ac_option
+do
+
+  # If the previous option needs an argument, assign it.
+  if test -n "$ac_prev"; then
+    eval "$ac_prev=\$ac_option"
+    ac_prev=
+    continue
+  fi
+
+  case "$ac_option" in
+  -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;;
+  *) ac_optarg= ;;
+  esac
+
+  # Accept the important Cygnus configure options, so we can diagnose typos.
+
+  case "$ac_option" in
+
+  -bindir | --bindir | --bindi | --bind | --bin | --bi)
+    ac_prev=bindir ;;
+  -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)
+    bindir="$ac_optarg" ;;
+
+  -build | --build | --buil | --bui | --bu)
+    ac_prev=build ;;
+  -build=* | --build=* | --buil=* | --bui=* | --bu=*)
+    build="$ac_optarg" ;;
+
+  -cache-file | --cache-file | --cache-fil | --cache-fi \
+  | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c)
+    ac_prev=cache_file ;;
+  -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \
+  | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)
+    cache_file="$ac_optarg" ;;
+
+  -datadir | --datadir | --datadi | --datad | --data | --dat | --da)
+    ac_prev=datadir ;;
+  -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \
+  | --da=*)
+    datadir="$ac_optarg" ;;
+
+  -disable-* | --disable-*)
+    ac_feature=`echo $ac_option|sed -e 's/-*disable-//'`
+    # Reject names that are not valid shell variable names.
+    if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then
+      { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; }
+    fi
+    ac_feature=`echo $ac_feature| sed 's/-/_/g'`
+    eval "enable_${ac_feature}=no" ;;
+
+  -enable-* | --enable-*)
+    ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'`
+    # Reject names that are not valid shell variable names.
+    if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then
+      { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; }
+    fi
+    ac_feature=`echo $ac_feature| sed 's/-/_/g'`
+    case "$ac_option" in
+      *=*) ;;
+      *) ac_optarg=yes ;;
+    esac
+    eval "enable_${ac_feature}='$ac_optarg'" ;;
+
+  -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \
+  | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \
+  | --exec | --exe | --ex)
+    ac_prev=exec_prefix ;;
+  -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \
+  | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \
+  | --exec=* | --exe=* | --ex=*)
+    exec_prefix="$ac_optarg" ;;
+
+  -gas | --gas | --ga | --g)
+    # Obsolete; use --with-gas.
+    with_gas=yes ;;
+
+  -help | --help | --hel | --he)
+    # Omit some internal or obsolete options to make the list less imposing.
+    # This message is too long to be a string in the A/UX 3.1 sh.
+    cat << EOF
+Usage: configure [options] [host]
+Options: [defaults in brackets after descriptions]
+Configuration:
+  --cache-file=FILE       cache test results in FILE
+  --help                  print this message
+  --no-create             do not create output files
+  --quiet, --silent       do not print \`checking...' messages
+  --site-file=FILE        use FILE as the site file
+  --version               print the version of autoconf that created configure
+Directory and file names:
+  --prefix=PREFIX         install architecture-independent files in PREFIX
+                          [$ac_default_prefix]
+  --exec-prefix=EPREFIX   install architecture-dependent files in EPREFIX
+                          [same as prefix]
+  --bindir=DIR            user executables in DIR [EPREFIX/bin]
+  --sbindir=DIR           system admin executables in DIR [EPREFIX/sbin]
+  --libexecdir=DIR        program executables in DIR [EPREFIX/libexec]
+  --datadir=DIR           read-only architecture-independent data in DIR
+                          [PREFIX/share]
+  --sysconfdir=DIR        read-only single-machine data in DIR [PREFIX/etc]
+  --sharedstatedir=DIR    modifiable architecture-independent data in DIR
+                          [PREFIX/com]
+  --localstatedir=DIR     modifiable single-machine data in DIR [PREFIX/var]
+  --libdir=DIR            object code libraries in DIR [EPREFIX/lib]
+  --includedir=DIR        C header files in DIR [PREFIX/include]
+  --oldincludedir=DIR     C header files for non-gcc in DIR [/usr/include]
+  --infodir=DIR           info documentation in DIR [PREFIX/info]
+  --mandir=DIR            man documentation in DIR [PREFIX/man]
+  --srcdir=DIR            find the sources in DIR [configure dir or ..]
+  --program-prefix=PREFIX prepend PREFIX to installed program names
+  --program-suffix=SUFFIX append SUFFIX to installed program names
+  --program-transform-name=PROGRAM
+                          run sed PROGRAM on installed program names
+EOF
+    cat << EOF
+Host type:
+  --build=BUILD           configure for building on BUILD [BUILD=HOST]
+  --host=HOST             configure for HOST [guessed]
+  --target=TARGET         configure for TARGET [TARGET=HOST]
+Features and packages:
+  --disable-FEATURE       do not include FEATURE (same as --enable-FEATURE=no)
+  --enable-FEATURE[=ARG]  include FEATURE [ARG=yes]
+  --with-PACKAGE[=ARG]    use PACKAGE [ARG=yes]
+  --without-PACKAGE       do not use PACKAGE (same as --with-PACKAGE=no)
+  --x-includes=DIR        X include files are in DIR
+  --x-libraries=DIR       X library files are in DIR
+EOF
+    if test -n "$ac_help"; then
+      echo "--enable and --with options recognized:$ac_help"
+    fi
+    exit 0 ;;
+
+  -host | --host | --hos | --ho)
+    ac_prev=host ;;
+  -host=* | --host=* | --hos=* | --ho=*)
+    host="$ac_optarg" ;;
+
+  -includedir | --includedir | --includedi | --included | --include \
+  | --includ | --inclu | --incl | --inc)
+    ac_prev=includedir ;;
+  -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \
+  | --includ=* | --inclu=* | --incl=* | --inc=*)
+    includedir="$ac_optarg" ;;
+
+  -infodir | --infodir | --infodi | --infod | --info | --inf)
+    ac_prev=infodir ;;
+  -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*)
+    infodir="$ac_optarg" ;;
+
+  -libdir | --libdir | --libdi | --libd)
+    ac_prev=libdir ;;
+  -libdir=* | --libdir=* | --libdi=* | --libd=*)
+    libdir="$ac_optarg" ;;
+
+  -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \
+  | --libexe | --libex | --libe)
+    ac_prev=libexecdir ;;
+  -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \
+  | --libexe=* | --libex=* | --libe=*)
+    libexecdir="$ac_optarg" ;;
+
+  -localstatedir | --localstatedir | --localstatedi | --localstated \
+  | --localstate | --localstat | --localsta | --localst \
+  | --locals | --local | --loca | --loc | --lo)
+    ac_prev=localstatedir ;;
+  -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \
+  | --localstate=* | --localstat=* | --localsta=* | --localst=* \
+  | --locals=* | --local=* | --loca=* | --loc=* | --lo=*)
+    localstatedir="$ac_optarg" ;;
+
+  -mandir | --mandir | --mandi | --mand | --man | --ma | --m)
+    ac_prev=mandir ;;
+  -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)
+    mandir="$ac_optarg" ;;
+
+  -nfp | --nfp | --nf)
+    # Obsolete; use --without-fp.
+    with_fp=no ;;
+
+  -no-create | --no-create | --no-creat | --no-crea | --no-cre \
+  | --no-cr | --no-c)
+    no_create=yes ;;
+
+  -no-recursion | --no-recursion | --no-recursio | --no-recursi \
+  | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r)
+    no_recursion=yes ;;
+
+  -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \
+  | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \
+  | --oldin | --oldi | --old | --ol | --o)
+    ac_prev=oldincludedir ;;
+  -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \
+  | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \
+  | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*)
+    oldincludedir="$ac_optarg" ;;
+
+  -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)
+    ac_prev=prefix ;;
+  -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)
+    prefix="$ac_optarg" ;;
+
+  -program-prefix | --program-prefix | --program-prefi | --program-pref \
+  | --program-pre | --program-pr | --program-p)
+    ac_prev=program_prefix ;;
+  -program-prefix=* | --program-prefix=* | --program-prefi=* \
+  | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*)
+    program_prefix="$ac_optarg" ;;
+
+  -program-suffix | --program-suffix | --program-suffi | --program-suff \
+  | --program-suf | --program-su | --program-s)
+    ac_prev=program_suffix ;;
+  -program-suffix=* | --program-suffix=* | --program-suffi=* \
+  | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*)
+    program_suffix="$ac_optarg" ;;
+
+  -program-transform-name | --program-transform-name \
+  | --program-transform-nam | --program-transform-na \
+  | --program-transform-n | --program-transform- \
+  | --program-transform | --program-transfor \
+  | --program-transfo | --program-transf \
+  | --program-trans | --program-tran \
+  | --progr-tra | --program-tr | --program-t)
+    ac_prev=program_transform_name ;;
+  -program-transform-name=* | --program-transform-name=* \
+  | --program-transform-nam=* | --program-transform-na=* \
+  | --program-transform-n=* | --program-transform-=* \
+  | --program-transform=* | --program-transfor=* \
+  | --program-transfo=* | --program-transf=* \
+  | --program-trans=* | --program-tran=* \
+  | --progr-tra=* | --program-tr=* | --program-t=*)
+    program_transform_name="$ac_optarg" ;;
+
+  -q | -quiet | --quiet | --quie | --qui | --qu | --q \
+  | -silent | --silent | --silen | --sile | --sil)
+    silent=yes ;;
+
+  -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
+    ac_prev=sbindir ;;
+  -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
+  | --sbi=* | --sb=*)
+    sbindir="$ac_optarg" ;;
+
+  -sharedstatedir | --sharedstatedir | --sharedstatedi \
+  | --sharedstated | --sharedstate | --sharedstat | --sharedsta \
+  | --sharedst | --shareds | --shared | --share | --shar \
+  | --sha | --sh)
+    ac_prev=sharedstatedir ;;
+  -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \
+  | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \
+  | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \
+  | --sha=* | --sh=*)
+    sharedstatedir="$ac_optarg" ;;
+
+  -site | --site | --sit)
+    ac_prev=site ;;
+  -site=* | --site=* | --sit=*)
+    site="$ac_optarg" ;;
+
+  -site-file | --site-file | --site-fil | --site-fi | --site-f)
+    ac_prev=sitefile ;;
+  -site-file=* | --site-file=* | --site-fil=* | --site-fi=* | --site-f=*)
+    sitefile="$ac_optarg" ;;
+
+  -srcdir | --srcdir | --srcdi | --srcd | --src | --sr)
+    ac_prev=srcdir ;;
+  -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)
+    srcdir="$ac_optarg" ;;
+
+  -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \
+  | --syscon | --sysco | --sysc | --sys | --sy)
+    ac_prev=sysconfdir ;;
+  -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \
+  | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*)
+    sysconfdir="$ac_optarg" ;;
+
+  -target | --target | --targe | --targ | --tar | --ta | --t)
+    ac_prev=target ;;
+  -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)
+    target="$ac_optarg" ;;
+
+  -v | -verbose | --verbose | --verbos | --verbo | --verb)
+    verbose=yes ;;
+
+  -version | --version | --versio | --versi | --vers)
+    echo "configure generated by autoconf version 2.13"
+    exit 0 ;;
+
+  -with-* | --with-*)
+    ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'`
+    # Reject names that are not valid shell variable names.
+    if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then
+      { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; }
+    fi
+    ac_package=`echo $ac_package| sed 's/-/_/g'`
+    case "$ac_option" in
+      *=*) ;;
+      *) ac_optarg=yes ;;
+    esac
+    eval "with_${ac_package}='$ac_optarg'" ;;
+
+  -without-* | --without-*)
+    ac_package=`echo $ac_option|sed -e 's/-*without-//'`
+    # Reject names that are not valid shell variable names.
+    if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then
+      { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; }
+    fi
+    ac_package=`echo $ac_package| sed 's/-/_/g'`
+    eval "with_${ac_package}=no" ;;
+
+  --x)
+    # Obsolete; use --with-x.
+    with_x=yes ;;
+
+  -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \
+  | --x-incl | --x-inc | --x-in | --x-i)
+    ac_prev=x_includes ;;
+  -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \
+  | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*)
+    x_includes="$ac_optarg" ;;
+
+  -x-libraries | --x-libraries | --x-librarie | --x-librari \
+  | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l)
+    ac_prev=x_libraries ;;
+  -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \
+  | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*)
+    x_libraries="$ac_optarg" ;;
+
+  -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; }
+    ;;
+
+  *)
+    if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then
+      echo "configure: warning: $ac_option: invalid host type" 1>&2
+    fi
+    if test "x$nonopt" != xNONE; then
+      { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; }
+    fi
+    nonopt="$ac_option"
+    ;;
+
+  esac
+done
+
+if test -n "$ac_prev"; then
+  { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; }
+fi
+
+trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15
+
+# File descriptor usage:
+# 0 standard input
+# 1 file creation
+# 2 errors and warnings
+# 3 some systems may open it to /dev/tty
+# 4 used on the Kubota Titan
+# 6 checking for... messages and results
+# 5 compiler messages saved in config.log
+if test "$silent" = yes; then
+  exec 6>/dev/null
+else
+  exec 6>&1
+fi
+exec 5>./config.log
+
+echo "\
+This file contains any messages produced by compilers while
+running configure, to aid debugging if configure makes a mistake.
+" 1>&5
+
+# Strip out --no-create and --no-recursion so they do not pile up.
+# Also quote any args containing shell metacharacters.
+ac_configure_args=
+for ac_arg
+do
+  case "$ac_arg" in
+  -no-create | --no-create | --no-creat | --no-crea | --no-cre \
+  | --no-cr | --no-c) ;;
+  -no-recursion | --no-recursion | --no-recursio | --no-recursi \
+  | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;;
+  *" "*|*"     "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*)
+  ac_configure_args="$ac_configure_args '$ac_arg'" ;;
+  *) ac_configure_args="$ac_configure_args $ac_arg" ;;
+  esac
+done
+
+# NLS nuisances.
+# Only set these to C if already set.  These must not be set unconditionally
+# because not all systems understand e.g. LANG=C (notably SCO).
+# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'!
+# Non-C LC_CTYPE values break the ctype check.
+if test "${LANG+set}"   = set; then LANG=C;   export LANG;   fi
+if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi
+if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi
+if test "${LC_CTYPE+set}"    = set; then LC_CTYPE=C;    export LC_CTYPE;    fi
+
+# confdefs.h avoids OS command line length limits that DEFS can exceed.
+rm -rf conftest* confdefs.h
+# AIX cpp loses on an empty file, so make sure it contains at least a newline.
+echo > confdefs.h
+
+# A filename unique to this package, relative to the directory that
+# configure is in, which we can look for to find out if srcdir is correct.
+ac_unique_file=read.scm
+
+# Find the source files, if location was not specified.
+if test -z "$srcdir"; then
+  ac_srcdir_defaulted=yes
+  # Try the directory containing this script, then its parent.
+  ac_prog=$0
+  ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'`
+  test "x$ac_confdir" = "x$ac_prog" && ac_confdir=.
+  srcdir=$ac_confdir
+  if test ! -r $srcdir/$ac_unique_file; then
+    srcdir=..
+  fi
+else
+  ac_srcdir_defaulted=no
+fi
+if test ! -r $srcdir/$ac_unique_file; then
+  if test "$ac_srcdir_defaulted" = yes; then
+    { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; }
+  else
+    { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; }
+  fi
+fi
+srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'`
+
+# Prefer explicitly selected file to automatically selected ones.
+if test -z "$sitefile"; then
+  if test -z "$CONFIG_SITE"; then
+    if test "x$prefix" != xNONE; then
+      CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site"
+    else
+      CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site"
+    fi
+  fi
+else
+  CONFIG_SITE="$sitefile"
+fi
+for ac_site_file in $CONFIG_SITE; do
+  if test -r "$ac_site_file"; then
+    echo "loading site script $ac_site_file"
+    . "$ac_site_file"
+  fi
+done
+
+if test -r "$cache_file"; then
+  echo "loading cache $cache_file"
+  . $cache_file
+else
+  echo "creating cache $cache_file"
+  > $cache_file
+fi
+
+ac_ext=c
+# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
+ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
+cross_compiling=$ac_cv_prog_cc_cross
+
+ac_exeext=
+ac_objext=o
+if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then
+  # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu.
+  if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then
+    ac_n= ac_c='
+' ac_t='       '
+  else
+    ac_n=-n ac_c= ac_t=
+  fi
+else
+  ac_n= ac_c='\c' ac_t=
+fi
+
+
+ac_aux_dir=
+for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do
+  if test -f $ac_dir/install-sh; then
+    ac_aux_dir=$ac_dir
+    ac_install_sh="$ac_aux_dir/install-sh -c"
+    break
+  elif test -f $ac_dir/install.sh; then
+    ac_aux_dir=$ac_dir
+    ac_install_sh="$ac_aux_dir/install.sh -c"
+    break
+  fi
+done
+if test -z "$ac_aux_dir"; then
+  { echo "configure: error: can not find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." 1>&2; exit 1; }
+fi
+ac_config_guess=$ac_aux_dir/config.guess
+ac_config_sub=$ac_aux_dir/config.sub
+ac_configure=$ac_aux_dir/configure # This should be Cygnus configure.
+
+
+# Do some error checking and defaulting for the host and target type.
+# The inputs are:
+#    configure --host=HOST --target=TARGET --build=BUILD NONOPT
+#
+# The rules are:
+# 1. You are not allowed to specify --host, --target, and nonopt at the
+#    same time.
+# 2. Host defaults to nonopt.
+# 3. If nonopt is not specified, then host defaults to the current host,
+#    as determined by config.guess.
+# 4. Target and build default to nonopt.
+# 5. If nonopt is not specified, then target and build default to host.
+
+# The aliases save the names the user supplied, while $host etc.
+# will get canonicalized.
+case $host---$target---$nonopt in
+NONE---*---* | *---NONE---* | *---*---NONE) ;;
+*) { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } ;;
+esac
+
+
+# Make sure we can run config.sub.
+if ${CONFIG_SHELL-/bin/sh} $ac_config_sub sun4 >/dev/null 2>&1; then :
+else { echo "configure: error: can not run $ac_config_sub" 1>&2; exit 1; }
+fi
+
+echo $ac_n "checking host system type""... $ac_c" 1>&6
+echo "configure:586: checking host system type" >&5
+
+host_alias=$host
+case "$host_alias" in
+NONE)
+  case $nonopt in
+  NONE)
+    if host_alias=`${CONFIG_SHELL-/bin/sh} $ac_config_guess`; then :
+    else { echo "configure: error: can not guess host type; you must specify one" 1>&2; exit 1; }
+    fi ;;
+  *) host_alias=$nonopt ;;
+  esac ;;
+esac
+
+host=`${CONFIG_SHELL-/bin/sh} $ac_config_sub $host_alias`
+host_cpu=`echo $host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'`
+host_vendor=`echo $host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'`
+host_os=`echo $host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'`
+echo "$ac_t""$host" 1>&6
+
+echo $ac_n "checking target system type""... $ac_c" 1>&6
+echo "configure:607: checking target system type" >&5
+
+target_alias=$target
+case "$target_alias" in
+NONE)
+  case $nonopt in
+  NONE) target_alias=$host_alias ;;
+  *) target_alias=$nonopt ;;
+  esac ;;
+esac
+
+target=`${CONFIG_SHELL-/bin/sh} $ac_config_sub $target_alias`
+target_cpu=`echo $target | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'`
+target_vendor=`echo $target | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'`
+target_os=`echo $target | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'`
+echo "$ac_t""$target" 1>&6
+
+echo $ac_n "checking build system type""... $ac_c" 1>&6
+echo "configure:625: checking build system type" >&5
+
+build_alias=$build
+case "$build_alias" in
+NONE)
+  case $nonopt in
+  NONE) build_alias=$host_alias ;;
+  *) build_alias=$nonopt ;;
+  esac ;;
+esac
+
+build=`${CONFIG_SHELL-/bin/sh} $ac_config_sub $build_alias`
+build_cpu=`echo $build | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'`
+build_vendor=`echo $build | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'`
+build_os=`echo $build | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'`
+echo "$ac_t""$build" 1>&6
+
+test "$host_alias" != "$target_alias" &&
+  test "$program_prefix$program_suffix$program_transform_name" = \
+    NONENONEs,x,x, &&
+  program_prefix=${target_alias}-
+
+# Find a good install program.  We prefer a C program (faster),
+# so one script is as good as another.  But avoid the broken or
+# incompatible versions:
+# SysV /etc/install, /usr/sbin/install
+# SunOS /usr/etc/install
+# IRIX /sbin/install
+# AIX /bin/install
+# AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag
+# AFS /usr/afsws/bin/install, which mishandles nonexistent args
+# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff"
+# ./install, which can be erroneously created by make from ./install.sh.
+echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6
+echo "configure:659: checking for a BSD compatible install" >&5
+if test -z "$INSTALL"; then
+if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+    IFS="${IFS=        }"; ac_save_IFS="$IFS"; IFS=":"
+  for ac_dir in $PATH; do
+    # Account for people who put trailing slashes in PATH elements.
+    case "$ac_dir/" in
+    /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;;
+    *)
+      # OSF1 and SCO ODT 3.0 have their own names for install.
+      # Don't use installbsd from OSF since it installs stuff as root
+      # by default.
+      for ac_prog in ginstall scoinst install; do
+        if test -f $ac_dir/$ac_prog; then
+         if test $ac_prog = install &&
+            grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then
+           # AIX install.  It has an incompatible calling convention.
+           :
+         else
+           ac_cv_path_install="$ac_dir/$ac_prog -c"
+           break 2
+         fi
+       fi
+      done
+      ;;
+    esac
+  done
+  IFS="$ac_save_IFS"
+
+fi
+  if test "${ac_cv_path_install+set}" = set; then
+    INSTALL="$ac_cv_path_install"
+  else
+    # As a last resort, use the slow shell script.  We don't cache a
+    # path for INSTALL within a source directory, because that will
+    # break other packages using the cache if that directory is
+    # removed, or if the path is relative.
+    INSTALL="$ac_install_sh"
+  fi
+fi
+echo "$ac_t""$INSTALL" 1>&6
+
+# Use test -z because SunOS4 sh mishandles braces in ${var-val}.
+# It thinks the first close brace ends the variable substitution.
+test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}'
+
+test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}'
+
+test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644'
+
+echo $ac_n "checking whether build environment is sane""... $ac_c" 1>&6
+echo "configure:712: checking whether build environment is sane" >&5
+# Just in case
+sleep 1
+echo timestamp > conftestfile
+# Do `set' in a subshell so we don't clobber the current shell's
+# arguments.  Must try -L first in case configure is actually a
+# symlink; some systems play weird games with the mod time of symlinks
+# (eg FreeBSD returns the mod time of the symlink's containing
+# directory).
+if (
+   set X `ls -Lt $srcdir/configure conftestfile 2> /dev/null`
+   if test "$*" = "X"; then
+      # -L didn't work.
+      set X `ls -t $srcdir/configure conftestfile`
+   fi
+   if test "$*" != "X $srcdir/configure conftestfile" \
+      && test "$*" != "X conftestfile $srcdir/configure"; then
+
+      # If neither matched, then we have a broken ls.  This can happen
+      # if, for instance, CONFIG_SHELL is bash and it inherits a
+      # broken ls alias from the environment.  This has actually
+      # happened.  Such a system could not be considered "sane".
+      { echo "configure: error: ls -t appears to fail.  Make sure there is not a broken
+alias in your environment" 1>&2; exit 1; }
+   fi
+
+   test "$2" = conftestfile
+   )
+then
+   # Ok.
+   :
+else
+   { echo "configure: error: newly created file is older than distributed files!
+Check your system clock" 1>&2; exit 1; }
+fi
+rm -f conftest*
+echo "$ac_t""yes" 1>&6
+if test "$program_transform_name" = s,x,x,; then
+  program_transform_name=
+else
+  # Double any \ or $.  echo might interpret backslashes.
+  cat <<\EOF_SED > conftestsed
+s,\\,\\\\,g; s,\$,$$,g
+EOF_SED
+  program_transform_name="`echo $program_transform_name|sed -f conftestsed`"
+  rm -f conftestsed
+fi
+test "$program_prefix" != NONE &&
+  program_transform_name="s,^,${program_prefix},; $program_transform_name"
+# Use a double $ so make ignores it.
+test "$program_suffix" != NONE &&
+  program_transform_name="s,\$\$,${program_suffix},; $program_transform_name"
+
+# sed with no file args requires a program.
+test "$program_transform_name" = "" && program_transform_name="s,x,x,"
+
+echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6
+echo "configure:769: checking whether ${MAKE-make} sets \${MAKE}" >&5
+set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  cat > conftestmake <<\EOF
+all:
+       @echo 'ac_maketemp="${MAKE}"'
+EOF
+# GNU make sometimes prints "make[1]: Entering...", which would confuse us.
+eval `${MAKE-make} -f conftestmake 2>/dev/null | grep temp=`
+if test -n "$ac_maketemp"; then
+  eval ac_cv_prog_make_${ac_make}_set=yes
+else
+  eval ac_cv_prog_make_${ac_make}_set=no
+fi
+rm -f conftestmake
+fi
+if eval "test \"`echo '$ac_cv_prog_make_'${ac_make}_set`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+  SET_MAKE=
+else
+  echo "$ac_t""no" 1>&6
+  SET_MAKE="MAKE=${MAKE-make}"
+fi
+
+
+PACKAGE=cgen
+
+VERSION=1.0
+
+if test "`cd $srcdir && pwd`" != "`pwd`" && test -f $srcdir/config.status; then
+  { echo "configure: error: source directory already configured; run "make distclean" there first" 1>&2; exit 1; }
+fi
+cat >> confdefs.h <<EOF
+#define PACKAGE "$PACKAGE"
+EOF
+
+cat >> confdefs.h <<EOF
+#define VERSION "$VERSION"
+EOF
+
+
+
+missing_dir=`cd $ac_aux_dir && pwd`
+echo $ac_n "checking for working aclocal""... $ac_c" 1>&6
+echo "configure:815: checking for working aclocal" >&5
+# Run test in a subshell; some versions of sh will print an error if
+# an executable is not found, even if stderr is redirected.
+# Redirect stdin to placate older versions of autoconf.  Sigh.
+if (aclocal --version) < /dev/null > /dev/null 2>&1; then
+   ACLOCAL=aclocal
+   echo "$ac_t""found" 1>&6
+else
+   ACLOCAL="$missing_dir/missing aclocal"
+   echo "$ac_t""missing" 1>&6
+fi
+
+echo $ac_n "checking for working autoconf""... $ac_c" 1>&6
+echo "configure:828: checking for working autoconf" >&5
+# Run test in a subshell; some versions of sh will print an error if
+# an executable is not found, even if stderr is redirected.
+# Redirect stdin to placate older versions of autoconf.  Sigh.
+if (autoconf --version) < /dev/null > /dev/null 2>&1; then
+   AUTOCONF=autoconf
+   echo "$ac_t""found" 1>&6
+else
+   AUTOCONF="$missing_dir/missing autoconf"
+   echo "$ac_t""missing" 1>&6
+fi
+
+echo $ac_n "checking for working automake""... $ac_c" 1>&6
+echo "configure:841: checking for working automake" >&5
+# Run test in a subshell; some versions of sh will print an error if
+# an executable is not found, even if stderr is redirected.
+# Redirect stdin to placate older versions of autoconf.  Sigh.
+if (automake --version) < /dev/null > /dev/null 2>&1; then
+   AUTOMAKE=automake
+   echo "$ac_t""found" 1>&6
+else
+   AUTOMAKE="$missing_dir/missing automake"
+   echo "$ac_t""missing" 1>&6
+fi
+
+echo $ac_n "checking for working autoheader""... $ac_c" 1>&6
+echo "configure:854: checking for working autoheader" >&5
+# Run test in a subshell; some versions of sh will print an error if
+# an executable is not found, even if stderr is redirected.
+# Redirect stdin to placate older versions of autoconf.  Sigh.
+if (autoheader --version) < /dev/null > /dev/null 2>&1; then
+   AUTOHEADER=autoheader
+   echo "$ac_t""found" 1>&6
+else
+   AUTOHEADER="$missing_dir/missing autoheader"
+   echo "$ac_t""missing" 1>&6
+fi
+
+echo $ac_n "checking for working makeinfo""... $ac_c" 1>&6
+echo "configure:867: checking for working makeinfo" >&5
+# Run test in a subshell; some versions of sh will print an error if
+# an executable is not found, even if stderr is redirected.
+# Redirect stdin to placate older versions of autoconf.  Sigh.
+if (makeinfo --version) < /dev/null > /dev/null 2>&1; then
+   MAKEINFO=makeinfo
+   echo "$ac_t""found" 1>&6
+else
+   MAKEINFO="$missing_dir/missing makeinfo"
+   echo "$ac_t""missing" 1>&6
+fi
+
+
+
+# Find a good install program.  We prefer a C program (faster),
+# so one script is as good as another.  But avoid the broken or
+# incompatible versions:
+# SysV /etc/install, /usr/sbin/install
+# SunOS /usr/etc/install
+# IRIX /sbin/install
+# AIX /bin/install
+# AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag
+# AFS /usr/afsws/bin/install, which mishandles nonexistent args
+# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff"
+# ./install, which can be erroneously created by make from ./install.sh.
+echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6
+echo "configure:893: checking for a BSD compatible install" >&5
+if test -z "$INSTALL"; then
+if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+    IFS="${IFS=        }"; ac_save_IFS="$IFS"; IFS=":"
+  for ac_dir in $PATH; do
+    # Account for people who put trailing slashes in PATH elements.
+    case "$ac_dir/" in
+    /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;;
+    *)
+      # OSF1 and SCO ODT 3.0 have their own names for install.
+      # Don't use installbsd from OSF since it installs stuff as root
+      # by default.
+      for ac_prog in ginstall scoinst install; do
+        if test -f $ac_dir/$ac_prog; then
+         if test $ac_prog = install &&
+            grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then
+           # AIX install.  It has an incompatible calling convention.
+           :
+         else
+           ac_cv_path_install="$ac_dir/$ac_prog -c"
+           break 2
+         fi
+       fi
+      done
+      ;;
+    esac
+  done
+  IFS="$ac_save_IFS"
+
+fi
+  if test "${ac_cv_path_install+set}" = set; then
+    INSTALL="$ac_cv_path_install"
+  else
+    # As a last resort, use the slow shell script.  We don't cache a
+    # path for INSTALL within a source directory, because that will
+    # break other packages using the cache if that directory is
+    # removed, or if the path is relative.
+    INSTALL="$ac_install_sh"
+  fi
+fi
+echo "$ac_t""$INSTALL" 1>&6
+
+# Use test -z because SunOS4 sh mishandles braces in ${var-val}.
+# It thinks the first close brace ends the variable substitution.
+test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}'
+
+test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}'
+
+test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644'
+
+echo $ac_n "checking for Cygwin environment""... $ac_c" 1>&6
+echo "configure:946: checking for Cygwin environment" >&5
+if eval "test \"`echo '$''{'ac_cv_cygwin'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  cat > conftest.$ac_ext <<EOF
+#line 951 "configure"
+#include "confdefs.h"
+
+int main() {
+
+#ifndef __CYGWIN__
+#define __CYGWIN__ __CYGWIN32__
+#endif
+return __CYGWIN__;
+; return 0; }
+EOF
+if { (eval echo configure:962: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+  rm -rf conftest*
+  ac_cv_cygwin=yes
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  ac_cv_cygwin=no
+fi
+rm -f conftest*
+rm -f conftest*
+fi
+
+echo "$ac_t""$ac_cv_cygwin" 1>&6
+CYGWIN=
+test "$ac_cv_cygwin" = yes && CYGWIN=yes
+echo $ac_n "checking for mingw32 environment""... $ac_c" 1>&6
+echo "configure:979: checking for mingw32 environment" >&5
+if eval "test \"`echo '$''{'ac_cv_mingw32'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  cat > conftest.$ac_ext <<EOF
+#line 984 "configure"
+#include "confdefs.h"
+
+int main() {
+return __MINGW32__;
+; return 0; }
+EOF
+if { (eval echo configure:991: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+  rm -rf conftest*
+  ac_cv_mingw32=yes
+else
+  echo "configure: failed program was:" >&5
+  cat conftest.$ac_ext >&5
+  rm -rf conftest*
+  ac_cv_mingw32=no
+fi
+rm -f conftest*
+rm -f conftest*
+fi
+
+echo "$ac_t""$ac_cv_mingw32" 1>&6
+MINGW32=
+test "$ac_cv_mingw32" = yes && MINGW32=yes
+
+
+echo $ac_n "checking for executable suffix""... $ac_c" 1>&6
+echo "configure:1010: checking for executable suffix" >&5
+if eval "test \"`echo '$''{'ac_cv_exeext'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  if test "$CYGWIN" = yes || test "$MINGW32" = yes; then
+  ac_cv_exeext=.exe
+else
+  rm -f conftest*
+  echo 'int main () { return 0; }' > conftest.$ac_ext
+  ac_cv_exeext=
+  if { (eval echo configure:1020: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+    for file in conftest.*; do
+      case $file in
+      *.c | *.o | *.obj | *.ilk | *.pdb) ;;
+      *) ac_cv_exeext=`echo $file | sed -e s/conftest//` ;;
+      esac
+    done
+  else
+    { echo "configure: error: installation or configuration problem: compiler cannot create executables." 1>&2; exit 1; }
+  fi
+  rm -f conftest*
+  test x"${ac_cv_exeext}" = x && ac_cv_exeext=no
+fi
+fi
+
+EXEEXT=""
+test x"${ac_cv_exeext}" != xno && EXEEXT=${ac_cv_exeext}
+echo "$ac_t""${ac_cv_exeext}" 1>&6
+ac_exeext=$EXEEXT
+
+
+# Set target cpu.
+arch=${target_cpu}
+
+
+echo $ac_n "checking whether to enable maintainer-specific portions of Makefiles""... $ac_c" 1>&6
+echo "configure:1046: checking whether to enable maintainer-specific portions of Makefiles" >&5
+    # Check whether --enable-maintainer-mode or --disable-maintainer-mode was given.
+if test "${enable_maintainer_mode+set}" = set; then
+  enableval="$enable_maintainer_mode"
+  USE_MAINTAINER_MODE=$enableval
+else
+  USE_MAINTAINER_MODE=no
+fi
+
+  echo "$ac_t""$USE_MAINTAINER_MODE" 1>&6
+  
+
+if test $USE_MAINTAINER_MODE = yes; then
+  MAINTAINER_MODE_TRUE=
+  MAINTAINER_MODE_FALSE='#'
+else
+  MAINTAINER_MODE_TRUE='#'
+  MAINTAINER_MODE_FALSE=
+fi
+  MAINT=$MAINTAINER_MODE_TRUE
+  
+
+if test "$program_transform_name" = s,x,x,; then
+  program_transform_name=
+else
+  # Double any \ or $.  echo might interpret backslashes.
+  cat <<\EOF_SED > conftestsed
+s,\\,\\\\,g; s,\$,$$,g
+EOF_SED
+  program_transform_name="`echo $program_transform_name|sed -f conftestsed`"
+  rm -f conftestsed
+fi
+test "$program_prefix" != NONE &&
+  program_transform_name="s,^,${program_prefix},; $program_transform_name"
+# Use a double $ so make ignores it.
+test "$program_suffix" != NONE &&
+  program_transform_name="s,\$\$,${program_suffix},; $program_transform_name"
+
+# sed with no file args requires a program.
+test "$program_transform_name" = "" && program_transform_name="s,x,x,"
+
+
+trap '' 1 2 15
+cat > confcache <<\EOF
+# This file is a shell script that caches the results of configure
+# tests run on this system so they can be shared between configure
+# scripts and configure runs.  It is not useful on other systems.
+# If it contains results you don't want to keep, you may remove or edit it.
+#
+# By default, configure uses ./config.cache as the cache file,
+# creating it if it does not exist already.  You can give configure
+# the --cache-file=FILE option to use a different cache file; that is
+# what configure does when it calls configure scripts in
+# subdirectories, so they share the cache.
+# Giving --cache-file=/dev/null disables caching, for debugging configure.
+# config.status only pays attention to the cache file if you give it the
+# --recheck option to rerun configure.
+#
+EOF
+# The following way of writing the cache mishandles newlines in values,
+# but we know of no workaround that is simple, portable, and efficient.
+# So, don't put newlines in cache variables' values.
+# Ultrix sh set writes to stderr and can't be redirected directly,
+# and sets the high bit in the cache file unless we assign to the vars.
+(set) 2>&1 |
+  case `(ac_space=' '; set | grep ac_space) 2>&1` in
+  *ac_space=\ *)
+    # `set' does not quote correctly, so add quotes (double-quote substitution
+    # turns \\\\ into \\, and sed turns \\ into \).
+    sed -n \
+      -e "s/'/'\\\\''/g" \
+      -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p"
+    ;;
+  *)
+    # `set' quotes correctly as required by POSIX, so do not add quotes.
+    sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p'
+    ;;
+  esac >> confcache
+if cmp -s $cache_file confcache; then
+  :
+else
+  if test -w $cache_file; then
+    echo "updating cache $cache_file"
+    cat confcache > $cache_file
+  else
+    echo "not updating unwritable cache $cache_file"
+  fi
+fi
+rm -f confcache
+
+trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15
+
+test "x$prefix" = xNONE && prefix=$ac_default_prefix
+# Let make expand exec_prefix.
+test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'
+
+# Any assignment to VPATH causes Sun make to only execute
+# the first set of double-colon rules, so remove it if not needed.
+# If there is a colon in the path, we need to keep it.
+if test "x$srcdir" = x.; then
+  ac_vpsub='/^[        ]*VPATH[        ]*=[^:]*$/d'
+fi
+
+trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15
+
+# Transform confdefs.h into DEFS.
+# Protect against shell expansion while executing Makefile rules.
+# Protect against Makefile macro expansion.
+cat > conftest.defs <<\EOF
+s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g
+s%[    `~#$^&*(){}\\|;'"<>?]%\\&%g
+s%\[%\\&%g
+s%\]%\\&%g
+s%\$%$$%g
+EOF
+DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '`
+rm -f conftest.defs
+
+
+# Without the "./", some shells look in PATH for config.status.
+: ${CONFIG_STATUS=./config.status}
+
+echo creating $CONFIG_STATUS
+rm -f $CONFIG_STATUS
+cat > $CONFIG_STATUS <<EOF
+#! /bin/sh
+# Generated automatically by configure.
+# Run this file to recreate the current configuration.
+# This directory was configured as follows,
+# on host `(hostname || uname -n) 2>/dev/null | sed 1q`:
+#
+# $0 $ac_configure_args
+#
+# Compiler output produced by configure, useful for debugging
+# configure, is in ./config.log if it exists.
+
+ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]"
+for ac_option
+do
+  case "\$ac_option" in
+  -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
+    echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion"
+    exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;;
+  -version | --version | --versio | --versi | --vers | --ver | --ve | --v)
+    echo "$CONFIG_STATUS generated by autoconf version 2.13"
+    exit 0 ;;
+  -help | --help | --hel | --he | --h)
+    echo "\$ac_cs_usage"; exit 0 ;;
+  *) echo "\$ac_cs_usage"; exit 1 ;;
+  esac
+done
+
+ac_given_srcdir=$srcdir
+ac_given_INSTALL="$INSTALL"
+
+trap 'rm -fr `echo "Makefile doc/Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
+EOF
+cat >> $CONFIG_STATUS <<EOF
+
+# Protect against being on the right side of a sed subst in config.status.
+sed 's/%@/@@/; s/@%/@@/; s/%g\$/@g/; /@g\$/s/[\\\\&%]/\\\\&/g;
+ s/@@/%@/; s/@@/@%/; s/@g\$/%g/' > conftest.subs <<\\CEOF
+$ac_vpsub
+$extrasub
+s%@SHELL@%$SHELL%g
+s%@CFLAGS@%$CFLAGS%g
+s%@CPPFLAGS@%$CPPFLAGS%g
+s%@CXXFLAGS@%$CXXFLAGS%g
+s%@FFLAGS@%$FFLAGS%g
+s%@DEFS@%$DEFS%g
+s%@LDFLAGS@%$LDFLAGS%g
+s%@LIBS@%$LIBS%g
+s%@exec_prefix@%$exec_prefix%g
+s%@prefix@%$prefix%g
+s%@program_transform_name@%$program_transform_name%g
+s%@bindir@%$bindir%g
+s%@sbindir@%$sbindir%g
+s%@libexecdir@%$libexecdir%g
+s%@datadir@%$datadir%g
+s%@sysconfdir@%$sysconfdir%g
+s%@sharedstatedir@%$sharedstatedir%g
+s%@localstatedir@%$localstatedir%g
+s%@libdir@%$libdir%g
+s%@includedir@%$includedir%g
+s%@oldincludedir@%$oldincludedir%g
+s%@infodir@%$infodir%g
+s%@mandir@%$mandir%g
+s%@host@%$host%g
+s%@host_alias@%$host_alias%g
+s%@host_cpu@%$host_cpu%g
+s%@host_vendor@%$host_vendor%g
+s%@host_os@%$host_os%g
+s%@target@%$target%g
+s%@target_alias@%$target_alias%g
+s%@target_cpu@%$target_cpu%g
+s%@target_vendor@%$target_vendor%g
+s%@target_os@%$target_os%g
+s%@build@%$build%g
+s%@build_alias@%$build_alias%g
+s%@build_cpu@%$build_cpu%g
+s%@build_vendor@%$build_vendor%g
+s%@build_os@%$build_os%g
+s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g
+s%@INSTALL_SCRIPT@%$INSTALL_SCRIPT%g
+s%@INSTALL_DATA@%$INSTALL_DATA%g
+s%@PACKAGE@%$PACKAGE%g
+s%@VERSION@%$VERSION%g
+s%@ACLOCAL@%$ACLOCAL%g
+s%@AUTOCONF@%$AUTOCONF%g
+s%@AUTOMAKE@%$AUTOMAKE%g
+s%@AUTOHEADER@%$AUTOHEADER%g
+s%@MAKEINFO@%$MAKEINFO%g
+s%@SET_MAKE@%$SET_MAKE%g
+s%@EXEEXT@%$EXEEXT%g
+s%@arch@%$arch%g
+s%@MAINTAINER_MODE_TRUE@%$MAINTAINER_MODE_TRUE%g
+s%@MAINTAINER_MODE_FALSE@%$MAINTAINER_MODE_FALSE%g
+s%@MAINT@%$MAINT%g
+
+CEOF
+EOF
+
+cat >> $CONFIG_STATUS <<\EOF
+
+# Split the substitutions into bite-sized pieces for seds with
+# small command number limits, like on Digital OSF/1 and HP-UX.
+ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script.
+ac_file=1 # Number of current file.
+ac_beg=1 # First line for current file.
+ac_end=$ac_max_sed_cmds # Line after last line for current file.
+ac_more_lines=:
+ac_sed_cmds=""
+while $ac_more_lines; do
+  if test $ac_beg -gt 1; then
+    sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file
+  else
+    sed "${ac_end}q" conftest.subs > conftest.s$ac_file
+  fi
+  if test ! -s conftest.s$ac_file; then
+    ac_more_lines=false
+    rm -f conftest.s$ac_file
+  else
+    if test -z "$ac_sed_cmds"; then
+      ac_sed_cmds="sed -f conftest.s$ac_file"
+    else
+      ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file"
+    fi
+    ac_file=`expr $ac_file + 1`
+    ac_beg=$ac_end
+    ac_end=`expr $ac_end + $ac_max_sed_cmds`
+  fi
+done
+if test -z "$ac_sed_cmds"; then
+  ac_sed_cmds=cat
+fi
+EOF
+
+cat >> $CONFIG_STATUS <<EOF
+
+CONFIG_FILES=\${CONFIG_FILES-"Makefile doc/Makefile"}
+EOF
+cat >> $CONFIG_STATUS <<\EOF
+for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then
+  # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in".
+  case "$ac_file" in
+  *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'`
+       ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;;
+  *) ac_file_in="${ac_file}.in" ;;
+  esac
+
+  # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories.
+
+  # Remove last slash and all that follows it.  Not all systems have dirname.
+  ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'`
+  if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then
+    # The file is in a subdirectory.
+    test ! -d "$ac_dir" && mkdir "$ac_dir"
+    ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`"
+    # A "../" for each directory in $ac_dir_suffix.
+    ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'`
+  else
+    ac_dir_suffix= ac_dots=
+  fi
+
+  case "$ac_given_srcdir" in
+  .)  srcdir=.
+      if test -z "$ac_dots"; then top_srcdir=.
+      else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;;
+  /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;;
+  *) # Relative path.
+    srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix"
+    top_srcdir="$ac_dots$ac_given_srcdir" ;;
+  esac
+
+  case "$ac_given_INSTALL" in
+  [/$]*) INSTALL="$ac_given_INSTALL" ;;
+  *) INSTALL="$ac_dots$ac_given_INSTALL" ;;
+  esac
+
+  echo creating "$ac_file"
+  rm -f "$ac_file"
+  configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure."
+  case "$ac_file" in
+  *Makefile*) ac_comsub="1i\\
+# $configure_input" ;;
+  *) ac_comsub= ;;
+  esac
+
+  ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"`
+  sed -e "$ac_comsub
+s%@configure_input@%$configure_input%g
+s%@srcdir@%$srcdir%g
+s%@top_srcdir@%$top_srcdir%g
+s%@INSTALL@%$INSTALL%g
+" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file
+fi; done
+rm -f conftest.s*
+
+EOF
+cat >> $CONFIG_STATUS <<EOF
+
+EOF
+cat >> $CONFIG_STATUS <<\EOF
+
+exit 0
+EOF
+chmod +x $CONFIG_STATUS
+rm -fr confdefs* $ac_clean_files
+test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1
+
diff --git a/cgen/configure.in b/cgen/configure.in
new file mode 100644 (file)
index 0000000..c229bd8
--- /dev/null
@@ -0,0 +1,18 @@
+dnl Process this file with autoconf to produce a configure script.
+
+AC_PREREQ(2.13)
+AC_INIT(read.scm)
+AC_CANONICAL_SYSTEM
+AM_INIT_AUTOMAKE(cgen, 1.0)
+
+AC_PROG_INSTALL
+AC_EXEEXT
+
+# Set target cpu.
+arch=${target_cpu}
+AC_SUBST(arch)
+
+AM_MAINTAINER_MODE
+AC_ARG_PROGRAM
+
+AC_OUTPUT([Makefile doc/Makefile])
diff --git a/cgen/cos.scm b/cgen/cos.scm
new file mode 100644 (file)
index 0000000..7bb2a6e
--- /dev/null
@@ -0,0 +1,1336 @@
+; Cgen's Object System.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+;
+; When Guile has an official object implementation that is stable, things will
+; be switched over then.  Until such time, there's no point in getting hyper
+; (although doing so is certainly fun, but only to a point).
+; If the Guile team decides there won't be any official object system
+; (which isn't unreasonable) then we'll pick the final object system then.
+; Until such time, there are better things to do than trying to build a
+; better object system.  If this is important enough to you, help the Guile
+; team finish the module(/object?) system.
+;
+; Classes look like:
+;
+; #(class-tag
+;   class-name
+;   parent-name-list
+;   elm-alist
+;   method-alist
+;   full-elm-initial-list
+;   full-method-alist ; ??? not currently used
+;   class-descriptor)
+;
+; PARENT-NAME-LIST is a list of the names of parent classes (the inheritance
+; tree).
+;
+; ELM-ALIST is an alist of (symbol private? vector-index . initial-value)
+; for this class only.
+; Values can be looked up by name, via elm-make-[gs]etter routines, or
+; methods can use elm-get/set! for speed.
+; Various Lisp (or Lisp-like) OOP systems (e.g. CLOS, Dylan) call these
+; "slots".  Maybe for consistency "slot" would be a better name.  Some might
+; confuse that with intentions at directions.  Given that something better
+; will eventually happen, being deliberately different is useful.
+;
+; METHOD-ALIST is an alist of (symbol . (virtual? . procedure)) for this
+; class only.
+;
+; FULL-ELM-INITIAL-LIST is the elements of the flattened inheritance tree.
+; Initially it is #f meaning it hasn't been computed yet.
+; It is computed when the class is first instantiated.  During development,
+; it can be reset to #f after some module has been reloaded (requires all
+; object instantiation happens later of course).
+;
+; FULL-METHOD-ALIST is an alist of the methods of the flattened inheritance
+; tree.  Each element is (symbol . (parent-list-entry . method)).
+; Initially it is #f meaning it hasn't been computed yet.
+; It is computed when the class is first instantiated.  During development,
+; it can be reset to #f after some module has been reloaded (requires all
+; object instantiation happens later of course).
+;
+; CLASS-DESCRIPTOR is the processed form of parent-name-list.
+; There is an entry for the class and one for each parent (recursively):
+; (class mi? (base-offset . delta) child-backpointer (parent1-entry) ...).
+; mi? is #t if the class or any parent class has multiple inheritance.
+; This is used by the element access routines.
+; base-offset is the offset in the element vector of the baseclass (or first
+; baseclass in the mi case).
+; delta is the offset from base-offset of the class's own elements
+; (as opposed to elements in any parent class).
+; child-backpointer is #f in the top level object.
+; ??? child->subclass, parent->superclass?
+; Initially the class-descriptor is #f meaning it hasn't been computed yet.
+; It is computed when the class is first instantiated.  During development,
+; it can be reset to #f after some module has been reloaded (requires all
+; object instantiation to happen later of course).
+;
+; An object is a vector of 2 elements: #(object-elements class-descriptor).
+; ??? Things would be simpler if objects were a pair but that makes eval'ing
+; them trickier.  Vectors are nice in that they're self-evaluating, though
+; due to the self-referencing, which Guile 1.2 can't handle, apps have to
+; be careful.
+; ??? We could use smobs/records/whatever but the difference isn't big enough
+; for me to care at this point in time.
+;
+; `object-elements' looks like:
+;
+; #(object-tag
+;   class
+;   element1
+;   element2
+;   ...)
+;
+; CLASS is the class the object is an instance of.
+;
+; User visible procs:
+;
+; (class-make name parents elements methods) -> class
+;
+; Create a class.  The result is then passed back by procedures requiring
+; a class argument.  Note however that PARENTS is a list of class names,
+; not the class data type.  This allows reloading the definition of a
+; parent class without having to reload any subclasses.  To implement this
+; classes are recorded internally, and `object-init!' must be called if any
+; class has been redefined.
+;
+; (class-list) -> list of all defined classes
+;
+; (class-name class) -> name of CLASS
+;
+; (class-lookup class-name) -> class
+;
+; (class-instance? class object) -> #t if OBJECT is an instance of CLASS
+;
+; (object-class object) -> class of OBJECT
+;
+; (object-class-name object) -> class name of OBJECT
+;
+; (send object method-name . args) -> result of invoking METHOD-NAME
+;
+; (send-next object method-name . args) -> result of invoking next METHOD-NAME
+;
+; (new class) -> instantiate CLASS
+;
+; The object is initialized with values specified when CLASS
+; (and its parent classes) was defined.
+;
+; (vmake class . args) -> instantiate class and initialize it with 'vmake!
+;
+; This is shorthand for (send (new class) 'vmake! args).
+; ARGS is a list of option names and arguments (a la CLOS).
+; ??? Not implemented yet.
+;
+; (method-vmake! object . args) -> modify OBJECT from ARGS
+;
+; This is the standard 'vmake! method, available for use by user-written
+; 'vmake! methods.
+; ??? Not implemented yet.
+;
+; (make class . args) -> instantiate CLASS and initialize it with 'make!
+;
+; This is shorthand for (send (new class) 'make! arg1 ...).
+; This is a positional form of `new'.
+;
+; (method-make-make! class elm1-name elm2-name ...) -> unspecified
+;
+; Create a 'make! method that sets the specified elements.
+;
+; (object-copy object) -> copy of OBJ
+;
+; ??? Whether to discard the parent or keep it and retain specialization
+; is undecided.
+;
+; (object-copy-top object) -> copy of OBJECT with spec'n discarded
+;
+; (object-parent object parent-path) -> parent object in OBJECT via PARENT-PATH
+;
+; (class? foo) -> return #t if FOO is a class
+;
+; (object? foo) -> return #t if FOO is an object
+;
+; (method-make! class name lambda) -> unspecified
+;
+; Add method NAME to CLASS.
+;
+; (method-make-virtual! class name lambda) -> unspecified
+;
+; Add virtual method NAME to CLASS.
+;
+; (method-make-forward! class elm-name methods) -> unspecified
+;
+; Add METHODS to CLASS that pass the "message" onto the object in element
+; ELM-NAME.
+;                                 
+; (method-make-virtual-forward! class elm-name methods) -> unspecified
+;
+; Add virtual METHODS to CLASS that pass the "message" onto the object in
+; element ELM-NAME.
+;
+; (elm-get object elm-name) -> value of element ELM-NAME in OBJ
+;
+; Can only be used in methods.
+;
+; (elm-set! object elm-name new-value) -> unspecified
+;
+; Set element ELM-NAME in OBJECT to NEW-VALUE.
+; Can only be used in methods.
+;
+; (elm-make-getter class elm-name) -> lambda
+;
+; Return lambda to get the value of ELM-NAME in CLASS.
+;
+; (elm-make-setter class elm-name) -> lambda
+;
+; Return lambda to set the value of ELM-NAME in CLASS.
+;
+; Conventions used in this file:
+; - procs/vars internal to this file are prefixed with "-"
+;   [Of course this could all be put in a module; later if ever since
+;   once Guile has its own official object system we'll convert.  Note that
+;   it currently does not.]
+; - except for a few exceptions, public procs begin with one of
+;   class-, object-, elm-, method-.
+;   The exceptions are make, new, parent, send.
+\f
+(define -class-tag "class")
+(define -object-tag "object")
+
+; List of all classes.
+
+(define -class-list ())
+
+; ??? Were written as a procedures for Hobbit's sake (I think).
+(define -object-unspecified #:unspecified)
+(define -object-unbound #:unbound)
+
+; Associative list of classes to be traced.
+
+(define -object-debug-classes #f)
+
+; Associative list of elements to be traced.
+
+(define -object-debug-elements #f)
+
+; Associative list of messages to be traced.
+
+(define -object-debug-methods #f)
+
+; True if error messages are verbose and debugging messages are printed.
+
+(define -object-verbose? #f)
+
+; Cover fn to set verbosity.
+
+(define (object-set-verbose! verbose?)
+  (set! -object-verbose? verbose?)
+)
+
+; Signal error if not class/object.
+
+(define (-class-check maybe-class proc-name . extra-text)
+  (if (not (class? maybe-class))
+      (apply -object-error
+            (append! (list proc-name maybe-class "not a class")
+                     extra-text)))
+  -object-unspecified
+)
+(define (-object-check-name maybe-name proc-name . extra-text)
+  (if (not (symbol? maybe-name))
+      (apply -object-error
+            (append! (list proc-name maybe-name) extra-text)))
+  -object-unspecified
+)
+(define (-object-check maybe-object proc-name . extra-text)
+  (if (not (object? maybe-object))
+      (apply -object-error
+            (append! (list proc-name maybe-object "not an object")
+                     extra-text)))
+  -object-unspecified
+)
+
+; X is any arbitrary Scheme data.
+(define (-object-error proc-name x . text)
+  (error (string-append proc-name ": " (apply string-append text)
+                       (if (object? x)
+                           (string-append
+                            " (class: " (-object-class-name x)
+                            (if (method-present? x 'get-name)
+                                (string-append ", name: "
+                                               (send x 'get-name))
+                                "")
+                            ")")
+                           "")
+                       "")
+        x)
+)
+\f
+; Low level class operations.
+
+; Return boolean indicating if X is a class.
+
+(define (class? class)
+  (and (vector? class) (eq? -class-tag (vector-ref class 0)))
+)
+
+; Accessors.
+
+(define (-class-name class) (vector-ref class 1))
+(define (-class-parents class) (vector-ref class 2))
+(define (-class-elements class) (vector-ref class 3))
+(define (-class-methods class) (vector-ref class 4))
+(define (-class-all-initial-values class) (vector-ref class 5))
+(define (-class-all-methods class) (vector-ref class 6))
+(define (-class-class-desc class) (vector-ref class 7))
+
+(define (-class-set-parents! class parents)
+  (vector-set! class 2 parents)
+)
+
+(define (-class-set-elements! class elm-alist)
+  (vector-set! class 3 elm-alist)
+)
+
+(define (-class-set-methods! class method-alist)
+  (vector-set! class 4 method-alist)
+)
+
+(define (-class-set-all-initial-values! class init-list)
+  (vector-set! class 5 init-list)
+)
+
+(define (-class-set-all-methods! class all-meth-list)
+  (vector-set! class 6 all-meth-list)
+)
+
+(define (-class-set-class-desc! class parent-list)
+  (vector-set! class 7 parent-list)
+)
+
+; Make a class.
+; The new definition overrides any existing definition.
+
+(define (-class-make! name parents elements methods)
+  (let ((class (vector -class-tag name parents elements methods #f #f #f))
+       (list-entry (assq name -class-list)))
+    (if list-entry
+       (set-cdr! list-entry class)
+       (set! -class-list (acons name class -class-list)))
+    class)
+)
+
+; Lookup a class given its name.
+; The result is the class or #f if not found.
+
+(define (class-lookup name) (assq-ref -class-list name))
+
+; Return a list of all direct parent classes of CLASS.
+
+(define (-class-parent-classes class)
+  ; -class-parents returns the names, we want the actual classes.
+  (let loop ((parents (-class-parents class))
+            (result ()))
+    (if (null? parents)
+       (reverse! result)
+       (let ((parent (class-lookup (car parents))))
+         (if (not parent)
+             ; The proc name we pass here is made up as we don't
+             ; want it to be the name of an internal proc.
+             (-object-error "class" (car parents) "not a class"))
+         (loop (cdr parents) (cons parent result)))))
+)
+
+; Cover proc of -class-name for the outside world to use.
+; The result is the name of the class or #f if CLASS is not a class.
+; We could issue an error here, but to be consistent with object-class-name
+; we don't.
+
+(define (class-name class)
+  (if (class? class)
+      (-class-name class)
+      #f)
+)
+
+; Return a boolean indicating if CLASS or any parent class has
+; multiple inheritance.
+
+(define (-class-mi? class)
+  (-class-desc-mi? (-class-class-desc class))
+)
+\f
+; Class descriptor utilities.
+; A class-descriptor is:
+; (class mi? (base-offset . delta) child-backpointer (parent1-entry) ...)
+
+;(define (-class-desc-make class offset bkptr parents)
+;   (append (list class offset bkptr) parents)
+;)
+(define (-class-desc? maybe-class-desc)
+  (and (pair? maybe-class-desc)
+       (class? (car maybe-class-desc)))
+)
+(define -class-desc-class car)
+(define -class-desc-mi? cadr)
+(define -class-desc-offset caddr)
+(define -class-desc-offset-base caaddr)
+(define -class-desc-offset-delta cdaddr)
+(define -class-desc-child cadddr)
+(define -class-desc-parents cddddr)
+; Note that this is an assq on the classes themselves, not their names.
+; The result is the parent's class-descriptor.
+(define -class-desc-lookup-parent assq)
+
+; Compute the class descriptor of CLASS.
+; OFFSET is the beginning offset in the element vector.
+; We can assume the parents of CLASS have already been initialized.
+;
+; A class-descriptor is:
+; (class mi? (base-offset . delta) child-backpointer (parent1-entry) ...)
+; MI? is a boolean indicating if multiple inheritance is present.
+; BASE-OFFSET is the offset into the object vector of the baseclass's elements
+; (or first baseclass in the mi case).
+; DELTA is the offset from BASE-OFFSET of the class's own elements.
+; CHILD is the backlink to the direct child class or #f for the top class.
+; ??? Is the use of `top' backwards from traditional usage?
+
+(define (-class-compute-class-desc class offset child)
+
+  ; OFFSET must be global to the calculation because it is continually
+  ; incremented as we recurse down through the hierarchy (actually, as we
+  ; traverse back up).  At any point in time it is the offset from the start
+  ; of the element vector of the next class's elements.
+  ; Object elements are laid out using a depth first traversal of the
+  ; inheritance tree.
+
+  (define (compute1 class child base-offset)
+
+    ; Build the result first, then build our parents so that our parents have
+    ; the right value for the CHILD-BACKPOINTER field.
+    ; Use a bogus value for mi? and offset for the moment.
+    ; The correct values are set later.
+
+    (let ((result (list class #f (cons 999 999) child))
+         (mi? (> (length (-class-parents class)) 1)))
+
+      ; Recurse on the parents.
+      ; We use `append!' here as the location of `result' is now fixed so
+      ; that our parent's child-backpointer remains stable.
+
+      (append! result
+              (let loop ((parents (-class-parents class))
+                         (parent-descs ())
+                         (base-offset base-offset))
+                (if (null? parents)
+                    (reverse! parent-descs)
+                    (let ((parent (class-lookup (car parents))))
+                      (if (not parent)
+                          ; The proc name we pass here is made up as we don't
+                          ; want it to be the name of an internal proc.
+                          (-object-error "class" (car parents) "not a class"))
+                      (if (and (not mi?)
+                               (-class-mi? parent))
+                          (set! mi? #t))
+                      (let ((parent-desc (compute1 parent result base-offset)))
+                        (loop (cdr parents)
+                              (cons parent-desc parent-descs)
+                              offset))))))
+
+      (list-set! result 1 mi?)
+      (list-set! result 2 (cons base-offset (- offset base-offset)))
+      (set! offset (+ offset (length (-class-elements class))))
+      result))
+
+  (compute1 class child offset)
+)
+
+; Return the top level class-descriptor of CLASS-DESC.
+
+(define (-class-desc-top class-desc)
+  (if (-class-desc-child class-desc)
+      (-class-desc-top (-class-desc-child class-desc))
+      class-desc)
+)
+
+; Pretty print a class descriptor.
+
+(define (class-desc-dump class-desc)
+  (let* ((cep (current-error-port))
+        (top-desc (-class-desc-top class-desc))
+        (spaces (lambda (n port)
+                  (display (make-string n #\space) port)))
+        (writeln (lambda (indent port . args)
+                   (spaces indent port)
+                   (for-each (lambda (arg) (display arg port))
+                             args)
+                   (newline port)))
+        )
+    (letrec ((dump (lambda (cd indent)
+                    (writeln indent cep "Class: "
+                             (-class-name (-class-desc-class cd)))
+                    (writeln indent cep "  mi?:         "
+                             (-class-desc-mi? cd))
+                    (writeln indent cep "  base offset: "
+                             (-class-desc-offset-base cd))
+                    (writeln indent cep "  delta:       "
+                             (-class-desc-offset-delta cd))
+                    (writeln indent cep "  child:       "
+                             (if (-class-desc-child cd)
+                                 (-class-name (-class-desc-class
+                                               (-class-desc-child cd)))
+                                 "-top-"))
+                    (for-each (lambda (parent-cd) (dump parent-cd (+ indent 4)))
+                              (-class-desc-parents cd))
+                    )))
+      (display "Top level class: " cep)
+      (display (-class-name (-class-desc-class top-desc)) cep)
+      (newline cep)
+      (dump class-desc 0)
+      ))
+)
+\f
+; Low level object utilities.
+
+; Make an object.
+; All elements get initial (or unbound) values.
+
+(define (-object-make! class)
+  (-class-check-init! class)
+  (vector (apply vector (append! (list -object-tag class)
+                                (-class-all-initial-values class)))
+         (-class-class-desc class))
+)
+
+; Make an object using VALUES.
+; VALUES must specify all elements in the class (and parent classes).
+
+(define (-object-make-with-values! class class-desc values)
+  (-class-check-init! class)
+  (vector (apply vector (append! (list -object-tag class) values))
+         class-desc)
+)
+
+; Copy an object.
+; If TOP?, the copy is of the top level object with any specialization
+; discarded.
+; WARNING: A shallow copy is currently done on the elements!
+
+(define (-object-copy obj top?)
+  (if top?
+      (vector (-object-vector-copy (-object-elements obj))
+             (-class-class-desc (-object-top-class obj)))
+      (vector (-object-vector-copy (-object-elements obj))
+             (-object-class-desc obj)))
+)
+
+; Specialize an object to be one from a parent class.
+; The result is the same object, but with a different view (confined to
+; a particular parent class).
+
+(define (-object-specialize obj class-desc)
+  (vector (-object-elements obj) class-desc)
+)
+
+; Accessors.
+
+(define (-object-elements obj) (vector-ref obj 0))
+(define (-object-class-desc obj) (vector-ref obj 1))
+(define (-object-class obj) (-class-desc-class (-object-class-desc obj)))
+(define (-object-class-name obj) (-class-name (-object-class obj)))
+(define (-object-top-class obj) (vector-ref (-object-elements obj) 1))
+
+(define (-object-elm-get obj class-desc elm-base-offset)
+  (vector-ref (-object-elements obj)
+             (+ (-class-desc-offset-base class-desc) elm-base-offset))
+)
+
+(define (-object-elm-set! obj class-desc elm-base-offset new-val)
+  (vector-set! (-object-elements obj)
+              (+ (-class-desc-offset-base class-desc) elm-base-offset)
+              new-val)
+  -object-unspecified
+)
+
+; Return a boolean indicating of OBJ has multiple-inheritance.
+
+(define (-object-mi? obj)
+  (-class-mi? (-object-top-class obj))
+)
+
+; Return boolean indicating if X is an object.
+
+(define (object? obj)
+  (and (vector? obj)
+       (= (vector-length obj) 2)
+       (vector? (vector-ref obj 0))
+       (eq? -object-tag (vector-ref (vector-ref obj 0) 0))
+       (-class-desc? (vector-ref obj 1)))
+)
+
+; Return the class of an object.
+
+(define (object-class obj)
+  (-object-check obj "object-class")
+  (-object-class obj)
+)
+
+; Cover proc of -object-class-name for the outside world to use.
+; The result is the name of the class or #f if OBJ is not an object.
+
+(define (object-class-name obj)
+  (if (object? obj)
+      (-object-class-name obj)
+      #f)
+)
+\f
+; Class operations.
+
+; Return the list of initial values for CLASS.
+; The result does not include parent classes.
+
+(define (-class-my-initial-values class)
+  (map cadr (-class-elements class))
+)
+
+; Initialize class if not already done.
+; FIXME: Need circularity check.  Later.
+
+(define (-class-check-init! class)
+  ; This should be fast the second time through, so don't do any
+  ; computation until we know it's necessary.
+
+  (if (not (-class-all-initial-values class))
+
+      (begin
+
+       ; First pass ensures all parents are initialized.
+       (for-each -class-check-init!
+                 (-class-parent-classes class))
+
+       ; Next pass initializes the initial value list.
+       (letrec ((get-inits
+                 (lambda (class)
+                   (let ((parents (-class-parent-classes class)))
+                     (append (apply append (map get-inits parents))
+                             (-class-my-initial-values class))))))
+
+         (let* ((parents (-class-parent-classes class))
+                (inits (append (apply append (map get-inits parents))
+                               (-class-my-initial-values class))))
+           (-class-set-all-initial-values! class inits)))
+
+       ; Next pass initializes the class's class-descriptor.
+       ; Object elements begin at offset 2 in the element vector.
+       (-class-set-class-desc! class
+                               (-class-compute-class-desc class 2 #f))
+       ))
+
+  -object-unspecified
+)
+
+; Make a class.
+;
+; PARENTS is a list of names of parent classes.  The parents need not
+; exist yet, though they must exist when the class is first instantiated.
+; ELMS is a either a list of either element names or name/value pairs.
+; Elements without initial values are marked as "unbound".
+; METHODS is an initial alist of methods.  More methods can be added with
+; method-make!.
+
+(define (class-make name parents elms methods)
+  (let ((elm-list #f))
+
+    ; Mark elements without initial values as unbound, and
+    ; compute indices into the element vector (relative to the class's
+    ; offset).
+    ; Elements are recorded as (symbol initial-value private? . vector-index)
+    ; FIXME: For now all elements are marked as "public".
+    (let loop ((elm-list-tmp ()) (index 0) (elms elms))
+      (if (null? elms)
+         (set! elm-list (reverse! elm-list-tmp)) ; done
+         (if (pair? (car elms))
+             (loop (acons (caar elms)
+                          (cons (cdar elms) (cons #f index))
+                          elm-list-tmp)
+                   (+ index 1)
+                   (cdr elms))
+             (loop (acons (car elms)
+                          (cons -object-unbound (cons #f index))
+                          elm-list-tmp)
+                   (+ index 1)
+                   (cdr elms)))))
+
+    (let ((result (-class-make! name parents elm-list methods)))
+
+      ; Create the standard `make!' method.
+      ; The caller can override afterwards if desired.
+      ; Note that if there are any parent classes then we don't know the names
+      ; of all of the elements yet, that is only known after the class has been
+      ; initialized which only happens when the class is first instantiated.
+      ; This method won't be called until that happens though so we're safe.
+      ; This is written without knowledge of the names, it just initializes
+      ; all elements.
+      (method-make! result 'make!
+                   (lambda args
+                     (let ((self (car args)))
+                       ; Ensure exactly all of the elements are provided.
+                       (if (not (= (length args)
+                                   (- (vector-length (-object-elements self)) 1)))
+                           (-object-error "make!" "" "wrong number of arguments to method `make!'"))
+                       (-object-make-with-values! (-object-top-class self)
+                                                  (-object-class-desc self)
+                                                  (cdr args)))))
+
+      result))
+)
+
+; Create an object of a class CLASS.
+
+(define (new class)
+  (-class-check class "new")
+
+  (if -object-verbose?
+      (display (string-append "Instantiating class " (-class-name class) ".\n")
+              (current-error-port)))
+
+  (-object-make! class)
+)
+
+; Make a copy of OBJ.
+; WARNING: A shallow copy is done on the elements!
+
+(define (object-copy obj)
+  (-object-check obj "object-copy")
+  (-object-copy obj #f)
+)
+
+; Make a copy of OBJ.
+; This makes a copy of top level object, with any specialization discarded.
+; WARNING: A shallow copy is done on the elements!
+
+(define (object-copy-top obj)
+  (-object-check obj "object-copy-top")
+  (-object-copy obj #t)
+)
+
+; Utility to define a standard `make!' method.
+; A standard make! method is one in which all it does is initialize
+; fields from args.
+
+(define (method-make-make! class args)
+  (let ((lambda-expr
+        (append (list 'lambda (cons 'self args))
+                (map (lambda (elm) (list 'elm-set! 'self
+                                         (list 'quote elm) elm))
+                     args)
+                '(self))))
+    (method-make! class 'make! (eval lambda-expr))
+    )
+)
+
+; The "standard" way to invoke `make!' is (send (new class) 'make! ...).
+; This puts all that in a cover function.
+
+(define (make class . operands)
+  (apply send (append (cons (new class) ()) '(make!) operands))
+)
+
+; Return #t if class X is a subclass of BASE-NAME.
+
+(define (-class-subclass? base-name x)
+  (if (eq? base-name (-class-name x))
+      #t
+      (let loop ((parents (-class-parents x)))
+       (if (null? parents)
+           #f
+           (if (-class-subclass? base-name (class-lookup (car parents)))
+               #t
+               (loop (cdr parents))))))
+)
+
+; Return #t if OBJECT is an instance of CLASS.
+; This does not signal an error if OBJECT is not an object as this is
+; intended to be used in class predicates.
+
+(define (class-instance? class object)
+  (-class-check class "class-instance?")
+  (if (object? object)
+      (-class-subclass? (-class-name class) (-object-class object))
+      #f)
+)
+\f
+; Element operations.
+
+; Lookup an element in a class-desc.
+; The result is (class-desc . (private? . elm-offset)) or #f if not found.
+; ??? We could define accessors of the result but knowledge of its format
+; is restricted to this section of the source.
+
+(define (-class-lookup-element class-desc elm-name)
+  (let* ((class (-class-desc-class class-desc))
+        (elm (assq elm-name (-class-elements class))))
+    (if elm
+       (cons class-desc (cddr elm))
+       (let loop ((parents (-class-desc-parents class-desc)))
+         (if (null? parents)
+             #f
+             (let ((elm (-class-lookup-element (car parents) elm-name)))
+               (if elm
+                   elm
+                   (loop (cdr parents)))))
+         ))
+    )
+)
+
+; Given the result of -class-lookup-element, return the element's delta
+; from base-offset.
+
+(define (-elm-delta index)
+  (+ (-class-desc-offset-delta (car index))
+     (cddr index))
+)
+
+; Return a boolean indicating if ELM is bound in OBJ.
+
+(define (elm-bound? obj elm)
+  (-object-check obj "elm-bound?")
+  (let* ((index (-class-lookup-element (-object-class-desc obj) elm))
+        (val (-object-elm-get obj (car index) (-elm-delta index))))
+    (not (eq? val -object-unbound)))
+)
+
+; Subroutine of elm-get.
+
+(define (-elm-make-method-getter self name)
+  (-object-check self "elm-get")
+  (let ((index (-class-lookup-element (-object-class-desc self) name)))
+    (if index
+       (procedure->memoizing-macro
+        (lambda (exp env)
+          `(lambda (obj)
+             (-object-elm-get obj (-object-class-desc obj)
+                              ,(-elm-delta index)))))
+       (-object-error "elm-get" self "element not present: " name)))
+)
+
+; Get an element from an object.
+; If OBJ is `self' then the caller is required to be a method and we emit
+; memoized code.  Otherwise we do things the slow way.
+; ??? There must be a better way.
+; What this does is turn
+; (elm-get self 'foo)
+; into
+; ((-elm-make-method-get self 'foo) self)
+; Note the extra set of parens.  -elm-make-method-get then does the lookup of
+; foo and returns a memoizing macro that returns the code to perform the
+; operation with O(1).  Cute, but I'm hoping there's an easier/better way.
+
+(defmacro elm-get (self name)
+  (if (eq? self 'self)
+      `(((-elm-make-method-getter ,self ,name)) ,self)
+      `(elm-xget ,self ,name))
+)
+
+; Subroutine of elm-set!.
+
+(define (-elm-make-method-setter self name)
+  (-object-check self "elm-set!")
+  (let ((index (-class-lookup-element (-object-class-desc self) name)))
+    (if index
+       (procedure->memoizing-macro
+        (lambda (exp env)
+          `(lambda (obj new-val)
+             (-object-elm-set! obj (-object-class-desc obj)
+                               ,(-elm-delta index) new-val))))
+       (-object-error "elm-set!" self "element not present: " name)))
+)
+
+; Set an element in an object.
+; This can only be used by methods.
+; See the comments for `elm-get'!
+
+(defmacro elm-set! (self name new-val)
+  (if (eq? self 'self)
+      `(((-elm-make-method-setter ,self ,name)) ,self ,new-val)
+      `(elm-xset! ,self ,name ,new-val))
+)
+
+; Get an element from an object.
+; This is for invoking from outside a method, and without having to
+; use elm-make-getter.  It should be used sparingly.
+
+(define (elm-xget obj name)
+  (-object-check obj "elm-xget")
+  (let ((index (-class-lookup-element (-object-class-desc obj) name)))
+    ; FIXME: check private?
+    (if index
+       (-object-elm-get obj (car index) (-elm-delta index))
+       (-object-error "elm-xget" obj "element not present: " name)))
+)
+
+; Set an element in an object.
+; This is for invoking from outside a method, and without having to
+; use elm-make-setter.  It should be used sparingly.
+
+(define (elm-xset! obj name new-val)
+  (-object-check obj "elm-xset!")
+  (let ((index (-class-lookup-element (-object-class-desc obj) name)))
+    ; FIXME: check private?
+    (if index
+       (-object-elm-set! obj (car index) (-elm-delta index) new-val)
+       (-object-error "elm-xset!" obj "element not present: " name)))
+)
+
+; Return a boolean indicating if object OBJ has element NAME.
+
+(define (elm-present? obj name)
+  (-object-check obj "elm-present?")
+  (->bool (-class-lookup-element (-object-class-desc obj) name))
+)
+
+; Return lambda to get element NAME in CLASS.
+; FIXME: validate name.
+
+(define (elm-make-getter class name)
+  (-class-check class "elm-make-getter")
+  ; We use delay here as we can't assume parent classes have been
+  ; initialized yet.
+  (let ((fast-index (delay (-class-lookup-element
+                           (-class-class-desc class) name))))
+    (lambda (obj)
+      ; ??? Should be able to use fast-index in mi case.
+      ; ??? Need to involve CLASS in lookup.
+      (let ((index (if (-object-mi? obj)
+                      (-class-lookup-element (-object-class-desc obj) name)
+                      (force fast-index))))
+      (-object-elm-get obj (car index) (-elm-delta index)))))
+)
+
+; Return lambda to set element NAME in CLASS.
+; FIXME: validate name.
+
+(define (elm-make-setter class name)
+  (-class-check class "elm-make-setter")
+  ; We use delay here as we can't assume parent classes have been
+  ; initialized yet.
+  (let ((fast-index (delay (-class-lookup-element
+                           (-class-class-desc class) name))))
+    (lambda (obj newval)
+      ; ??? Should be able to use fast-index in mi case.
+      ; ??? Need to involve CLASS in lookup.
+      (let ((index (if (-object-mi? obj)
+                      (-class-lookup-element (-object-class-desc obj) name)
+                      (force fast-index))))
+       (-object-elm-set! obj (car index) (-elm-delta index) newval))))
+)
+
+; Return a list of all elements in OBJ.
+
+(define (elm-list obj)
+  (cddr (vector->list (-object-elements obj)))
+)
+\f
+; Method operations.
+
+; Lookup the next method in a class.
+; This means begin the search in the parents.
+; ??? What should this do for virtual methods.  At present we treat them as
+; non-virtual.
+
+(define (-method-lookup-next class-desc method-name)
+  (let loop ((parents (-class-desc-parents class-desc)))
+    (if (null? parents)
+       #f
+       (let ((meth (-method-lookup (car parents) method-name #f)))
+         (if meth
+             meth
+             (loop (cdr parents))))))
+)
+
+; Lookup a method in a class.
+; The result is (class-desc . method).  If the method is found in a parent
+; class, the associated parent class descriptor is returned.  If the method is
+; a virtual method, the appropriate subclass's class descriptor is returned.
+; VIRTUAL? is #t if virtual methods are to be treated as such.
+; Otherwise they're treated as normal methods.
+;
+; FIXME: We don't yet implement the method cache.
+
+(define (-method-lookup class-desc method-name virtual?)
+  (if -object-verbose?
+      (display (string-append "Looking up method " method-name " in "
+                             (-class-name (-class-desc-class class-desc)) ".\n")
+              (current-error-port)))
+
+  (let ((meth (assq method-name (-class-methods (-class-desc-class class-desc)))))
+    (if meth
+       (if (and virtual? (cadr meth)) ; virtual?
+           ; Traverse back up the inheritance chain looking for overriding
+           ; methods.  The closest one to the top is the one to use.
+           (let loop ((child (-class-desc-child class-desc))
+                      (goal-class-desc class-desc)
+                      (goal-meth meth))
+             (if child
+                 (begin
+                   (if -object-verbose?
+                       (display (string-append "Looking up virtual method "
+                                               method-name " in "
+                                               (-class-name (-class-desc-class child))
+                                               ".\n")
+                                (current-error-port)))
+                   (let ((meth (assq method-name (-class-methods (-class-desc-class child)))))
+                     (if meth
+                         ; Method found, update goal object and method.
+                         (loop (-class-desc-child child) child meth)
+                         ; Method not found at this level.
+                         (loop (-class-desc-child child) goal-class-desc goal-meth))))
+                 ; Went all the way up to the top.
+                 (cons goal-class-desc (cddr goal-meth))))
+           ; Non-virtual, done.
+           (cons class-desc (cddr meth)))
+       ; Method not found, search parents.
+       (-method-lookup-next class-desc method-name)))
+)
+
+; Return a boolean indicating if object OBJ has method NAME.
+
+(define (method-present? obj name)
+  (-object-check obj "method-present?")
+  (->bool (-method-lookup (-object-class-desc obj) name #f))
+)
+
+; Return method NAME of CLASS or #f if not present.
+; ??? Assumes CLASS has been initialized.
+
+(define (method-proc class name)
+  (-class-check class "method-proc")
+  (let ((meth (-method-lookup (-class-class-desc class) name #t)))
+    (if meth
+       (cdr meth)
+       #f))
+)
+
+; Add a method to a class.
+; FIXME: ensure method-name is a symbol
+
+(define (method-make! class method-name method)
+  (-class-check class "method-make!")
+  (if (not (procedure? method))
+      (-object-error "method-make!" method "method must be a procedure"))
+  (-class-set-methods! class (acons method-name
+                                   (cons #f method)
+                                   (-class-methods class)))
+  -object-unspecified
+)
+
+; Add a virtual method to a class.
+; FIXME: ensure method-name is a symbol
+
+(define (method-make-virtual! class method-name method)
+  (-class-check class "method-make-virtual!")
+  (if (not (procedure? method))
+      (-object-error "method-make-virtual!" method "method must be a procedure"))
+  (-class-set-methods! class (acons method-name
+                                   (cons #t method)
+                                   (-class-methods class)))
+  -object-unspecified
+)
+
+; Utility to create "forwarding" methods.
+; METHODS are forwarded to class member ELM-NAME, assumed to be an object.
+; The created methods take a variable number of arguments.
+; Argument length checking will be done by the receiving method.
+; FIXME: ensure elm-name is a symbol
+
+(define (method-make-forward! class elm-name methods)
+  (for-each (lambda (method-name)
+             (method-make!
+              class method-name
+              (eval `(lambda args
+                       (apply send
+                              (cons (elm-get (car args)
+                                             (quote ,elm-name))
+                                    (cons (quote ,method-name)
+                                          (cdr args))))))))
+           methods)
+  -object-unspecified
+)
+
+; Same as method-make-forward! but creates virtual methods.
+; FIXME: ensure elm-name is a symbol
+
+(define (method-make-virtual-forward! class elm-name methods)
+  (for-each (lambda (method-name)
+             (method-make-virtual!
+              class method-name
+              (eval `(lambda args
+                       (apply send
+                              (cons (elm-get (car args)
+                                             (quote ,elm-name))
+                                    (cons (quote ,method-name)
+                                          (cdr args))))))))
+           methods)
+  -object-unspecified
+)
+
+; Utility of send, send-next.
+
+(define (-object-method-notify obj method-name maybe-next)
+  (set! -object-verbose? #f)
+  (display (string-append "Sending " maybe-next method-name " to"
+                         (if (method-present? obj 'get-name)
+                             (let ((name (send obj 'get-name)))
+                               (if (or (symbol? name) (string? name))
+                                   (string-append " object " name)
+                                   ""))
+                             "")
+                         " class " (object-class-name obj) ".\n")
+          (current-error-port))
+  (set! -object-verbose? #t)
+)
+
+; Invoke a method in an object.
+; When the method is invoked, the (possible parent class) object in which the
+; method is found is passed to the method.
+; ??? The word `send' comes from "sending messages".  Perhaps should pick
+; a better name for this operation.
+
+(define (send obj method-name . args)
+  (-object-check obj "send")
+  (-object-check-name method-name "send" "not a method name")
+  (if -object-verbose? (-object-method-notify obj method-name ""))
+
+  (let ((class-desc.meth (-method-lookup (-object-class-desc obj)
+                                        method-name #t)))
+    (if class-desc.meth
+       (apply (cdr class-desc.meth)
+              (cons (-object-specialize obj (car class-desc.meth))
+                    args))
+       (-object-error "send" obj "method not supported: " method-name)))
+)
+
+; Invoke the next method named METHOD-NAME in the heirarchy of OBJ.
+; i.e. the method that would have been invoked if the calling method
+; didn't exist.
+; This may only be called by a method.
+; ??? Ideally we shouldn't need the METHOD-NAME argument.  It could be
+; removed with a bit of effort, but is it worth it?
+
+(define (send-next obj method-name . args)
+  (-object-check obj "send-next")
+  (-object-check-name method-name "send-next" "not a method name")
+  (if -object-verbose? (-object-method-notify obj method-name "next "))
+
+  (let ((class-desc.meth (-method-lookup-next (-object-class-desc obj)
+                                             method-name)))
+    (if class-desc.meth
+       (apply (cdr class-desc.meth)
+              (cons (-object-specialize obj (car class-desc.meth))
+                    args))
+       (-object-error "send-next" obj "method not supported: " method-name)))
+)
+\f
+; Parent operations.
+
+; Subroutine of `parent' to lookup a (potentially nested) parent class.
+; The result is the parent's class-descriptor or #f if not found.
+
+(define (-class-parent class-desc parent)
+  (let* ((parent-descs (-class-desc-parents class-desc))
+        (desc (-class-desc-lookup-parent parent parent-descs)))
+    (if desc
+       desc
+       (let loop ((parents parent-descs))
+         (if (null? parents)
+             #f
+             (let ((desc (-class-parent (car parents) parent)))
+               (if desc
+                   desc
+                   (loop (cdr parents))))))))
+)
+
+; Subroutine of `parent' to lookup a parent via a path.
+; PARENT-PATH, a list, is the exact path to the parent class.
+; The result is the parent's class-descriptor or #f if not found.
+; For completeness' sake, if PARENT-PATH is empty, CLASS-DESC is returned.
+
+(define (-class-parent-via-path class-desc parent-path)
+  (if (null? parent-path)
+      class-desc
+      (let ((desc (-class-desc-lookup-parent (car parent-path)
+                                            (-class-desc-parents class-desc))))
+       (if desc
+           (if (null? (cdr parent-path))
+               desc
+               (-class-parent-via-path (car desc) (cdr parent-path)))
+           #f)))
+)
+
+; Lookup a parent class of object OBJ.
+; CLASS is either a class or a list of classes.
+; If CLASS is a list, it is a (possibly empty) "path" to the parent.
+; Otherwise it is any parent and is searched for breadth-first.
+; ??? Methinks this should be depth-first.
+; The result is OBJ, specialized to the found parent.
+
+(define (object-parent obj class)
+  (-object-check obj "object-parent")
+  (cond ((class? class) #t)
+       ((list? class) (for-each (lambda (class) (-class-check class
+                                                              "object-parent"))
+                                class))
+       (else (-object-error "object-parent" class "invalid parent path")))
+               
+  ; Hobbit generates C code that passes the function
+  ; -class-parent-via-path or -class-parent, not the appropriate
+  ; SCM object.
+; (let ((result ((if (or (null? class) (pair? class))
+;                   -class-parent-via-path
+;                   -class-parent)
+;                 obj class)))
+  ; So it's rewritten like this.
+  (let ((result (if (class? class)
+                   (-class-parent (-object-class-desc obj) class)
+                   (-class-parent-via-path (-object-class-desc obj) class))))
+    (if result
+       (-object-specialize obj result)
+       (-object-error "object-parent" obj "parent not present")))
+  ; FIXME: should print path in error message.
+)
+
+; Make PARENT-NAME a parent of CLASS, cons'd unto the front of the search
+; order.  This is used to add a parent class to a class after it has already
+; been created.  Obviously this isn't something one does willy-nilly.
+; The parent is added to the front of the current parent list (affects
+; method lookup).
+
+(define (class-cons-parent! class parent-name)
+  (-class-check class "class-cons-parent!")
+  (-object-check-name parent-name "class-cons-parent!" "not a class name")
+  (-class-set-parents! class (cons parent-name (-class-parents class)))
+  -object-unspecified
+)
+
+; Make PARENT-NAME a parent of CLASS, cons'd unto the end of the search order.
+; This is used to add a parent class to a class after it has already been
+; created.  Obviously this isn't something one does willy-nilly.
+; The parent is added to the end of the current parent list (affects
+; method lookup).
+
+(define (class-append-parent! class parent-name)
+  (-class-check class "class-append-parent!")
+  (-object-check-name parent-name "class-append-parent!" "not a class name")
+  (-class-set-parents! obj (append (-class-parents obj) (list parent-name)))
+  -object-unspecified
+)
+\f
+; Miscellaneous publically accessible utilities.
+
+; Reset the object system (delete all classes).
+
+(define (object-reset!)
+  (set! -class-list ())
+  -object-unspecified
+)
+
+; Call once to initialize the object system.
+; Only necessary if classes have been modified after objects have been
+; instantiated.  This usually happens during development only.
+
+(define (object-init!)
+  (for-each (lambda (class)
+             (-class-set-all-initial-values! class #f)
+             (-class-set-all-methods! class #f)
+             (-class-set-class-desc! class #f))
+           (class-list))
+  (for-each (lambda (class)
+             (-class-check-init! class))
+           (class-list))
+  -object-unspecified
+)
+
+; Return list of all classes.
+
+(define (class-list) (map cdr -class-list))
+
+; Utility to map over a class and all its parent classes, recursively.
+
+(define (class-map-over-class proc class)
+  (cons (proc class)
+       (map (lambda (class) (class-map-over-class proc class))
+            (-class-parent-classes class)))
+)
+
+; Return class tree of a class or object.
+
+(define (class-tree class-or-object)
+  (cond ((class? class-or-object)
+        (class-map-over-class class-name class-or-object))
+       ((object? class-or-object)
+        (class-map-over-class class-name (-object-class class-or-object)))
+       (else (-object-error "class-tree" class-or-object
+                            "not a class or object")))
+)
+
+; Return names of each alist.
+
+(define (-class-alist-names class)
+  (list (-class-name class)
+       (map car (-class-elements class))
+       (map car (-class-methods class)))
+)
+
+; Return complete layout of class-or-object.
+
+(define (class-layout class-or-object)
+  (cond ((class? class-or-object)
+        (class-map-over-class -class-alist-names class-or-object))
+       ((object? class-or-object)
+        (class-map-over-class -class-alist-names (-object-class class-or-object)))
+       (else (-object-error "class-layout" class-or-object
+                            "not a class or object")))
+)
+
+; Like assq but based on the `name' element.
+; WARNING: Slow.
+
+(define (object-assq name obj-list)
+  (find-first (lambda (o) (eq? (elm-xget o 'name) name))
+             obj-list)
+)
+
+; Like memq but based on the `name' element.
+; WARNING: Slow.
+
+(define (object-memq name obj-list)
+  (let loop ((r obj-list))
+    (cond ((null? r) #f)
+         ((eq? name (elm-xget (car r) 'name)) r)
+         (else (loop (cdr r)))))
+)
+\f
+; Misc. internal utilities.
+
+; We need a fast vector copy operation.
+; If `vector-copy' doesn't exist (which is assumed to be the fast one),
+; provide a simple version.
+; FIXME: Need deep copier instead.
+
+(if (defined? 'vector-copy)
+    (define -object-vector-copy vector-copy)
+    (define (-object-vector-copy v) (list->vector (vector->list v)))
+)
+\f
+; Profiling support
+
+(if (and #f (defined? 'proc-profile))
+    (begin
+      (proc-profile elm-get)
+      (proc-profile elm-set!)
+      (proc-profile elm-present?)
+      (proc-profile -method-lookup)
+      (proc-profile send)
+      (proc-profile new)
+      (proc-profile make)
+      ))
diff --git a/cgen/decode.scm b/cgen/decode.scm
new file mode 100644 (file)
index 0000000..3fbda21
--- /dev/null
@@ -0,0 +1,640 @@
+; Application independent decoder support.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+;
+; This file provides utilities for building instruction set decoders.
+; At present its rather limited, and is geared towards the simulator
+; where the goal is hyper-efficiency [not that there isn't room for much
+; improvement, but rather that that's what the current focus is].
+;
+; The CPU description file provides the first pass's bit mask with the
+; `decode-assist' spec.  This gives the decoder a head start on how to
+; efficiently decode the instruction set.  The rest of the decoder is
+; determined algorithmically.
+; ??? Need to say more here.
+;
+; The main entry point is decode-build-table.
+;
+; Main procedure call tree:
+; decode-build-table
+;     -build-slots
+;     -build-decode-table-guts
+;         -build-decode-table-entry
+;             -build-slots
+;             -build-decode-table-guts
+;
+; -build-slots/-build-decode-table-guts are recursively called to construct a
+; tree of "table-guts" elements, and then the application recurses on the
+; result.  For example see sim-decode.scm.
+;
+; FIXME: Don't create more than 3 shifts (i.e. no more than 3 groups).
+; FIXME: Exits when insns are unambiguously determined, even if there are more
+; opcode bits to examine.
+\f
+; Decoder data structures and accessors.
+; The set of instruction is internally recorded as a tree of two data
+; structures: "table-guts" and "table-entry".
+; [The choice of "table-guts" is historical, a better name will come to mind
+; eventually.]
+
+; Decoded tables data structure, termed "table guts".
+; A simple data structure of 4 elements:
+; bitnums:  list of bits that have been used thus far to decode the insn
+; startbit: bit offset in instruction of value in C local variable `insn'
+; bitsize:  size of value in C local variable `insn', the number
+;           of bits of the instruction read thus far
+; entries:  list of insns that match the decoding thus far,
+;           each entry in the list is a `dtable-entry' record
+
+(define (dtable-guts-make bitnums startbit bitsize entries)
+  (vector bitnums startbit bitsize entries)
+)
+
+; Accessors.
+(define (dtable-guts-bitnums tg) (vector-ref tg 0))
+(define (dtable-guts-startbit tg) (vector-ref tg 1))
+(define (dtable-guts-bitsize tg) (vector-ref tg 2))
+(define (dtable-guts-entries tg) (vector-ref tg 3))
+
+; A decoded subtable.
+; A simple data structure of 3 elements:
+; key: name to distinguish this subtable from others, used for lookup
+; table: a table-guts element
+; name: name of C variable containing the table
+;
+; The implementation uses a list so the lookup can use assv.
+
+(define (subdtable-make key table name)
+  (list key table name)
+)
+
+; Accessors.
+(define (subdtable-key st) (car st))
+(define (subdtable-table st) (cadr st))
+(define (subdtable-name st) (caddr st))
+
+; List of decode subtables.
+(define -decode-subtables nil)
+
+(define (subdtable-lookup key) (assv key -decode-subtables))
+
+; Add SUBTABLE-GUTS to the subtables list if not already present.
+; Result is the subtable entry already present, or new entry.
+; The key is computed so as to make comparisons possible with assv.
+
+(define (subdtable-add subtable-guts name)
+  (let* ((key (string->symbol
+              (string-append
+               (numbers->string (dtable-guts-bitnums subtable-guts) " ")
+               " " (number->string (dtable-guts-bitsize subtable-guts))
+               (string-map
+                (lambda (elm)
+                  (case (dtable-entry-type elm)
+                    ((insn)
+                     (string-append " " (obj:name (dtable-entry-value elm))))
+                    ((table)
+                     (string-append " " (subdtable-name (dtable-entry-value elm))))
+                    ((expr)
+                     (string-append " " (exprtable-name (dtable-entry-value elm))))
+                    (else (error "bad dtable entry type:"
+                                 (dtable-entry-type elm)))))
+                (dtable-guts-entries subtable-guts)))))
+        (entry (subdtable-lookup key)))
+    (if (not entry)
+       (begin
+         (set! -decode-subtables (cons (subdtable-make key subtable-guts name)
+                                       -decode-subtables))
+         (car -decode-subtables))
+       entry))
+)
+
+; An instruction and predicate for final matching.
+
+(define (exprtable-entry-make insn expr)
+  (vector insn expr (rtl-find-ifields expr))
+)
+
+; Accessors.
+
+(define (exprtable-entry-insn entry) (vector-ref entry 0))
+(define (exprtable-entry-expr entry) (vector-ref entry 1))
+(define (exprtable-entry-iflds entry) (vector-ref entry 2))
+
+; Return a pseudo-cost of processing exprentry X.
+
+(define (exprentry-cost x)
+  (let ((expr (exprtable-entry-expr x)))
+    (case (rtx-name expr)
+      ((member) (length (rtx-member-set expr)))
+      (else 4)))
+)
+
+; Sort an exprtable, optimum choices first.
+; Basically an optimum choice is a cheaper choice.
+
+(define (exprtable-sort expr-list)
+  (sort expr-list
+       (lambda (a b)
+         (let ((costa (exprentry-cost a))
+               (costb (exprentry-cost b)))
+           (< costa costb))))
+)
+
+; Return the name of the expr table for INSN-EXPRS,
+; which is a list of exprtable-entry elements.
+
+(define (-gen-exprtable-name insn-exprs)
+  (string-map (lambda (x)
+               (string-append (obj:name (exprtable-entry-insn x))
+                              "-"
+                              (rtx-strdump (exprtable-entry-expr x))))
+             insn-exprs)
+)
+
+; A set of instructions that need expressions to distinguish.
+; Typically the expressions are ifield-assertion specs.
+; INSN-EXPRS is a sorted list of exprtable-entry elements.
+; The list is considered sorted in the sense that the first insn to satisfy
+; its predicate is chosen.
+
+(define (exprtable-make name insn-exprs)
+  (vector name insn-exprs)
+)
+
+; Accessors.
+
+(define (exprtable-name etable) (vector-ref etable 0))
+(define (exprtable-insns etable) (vector-ref etable 1))
+
+; Decoded table entry data structure.
+; A simple data structure of 3 elements:
+; index: index in the parent table
+; entry type indicator: 'insn or 'table or 'expr
+; value: the insn or subtable or exprtable
+
+(define (dtable-entry-make index type value)
+  (assert value)
+  (vector index type value)
+)
+
+; Accessors.
+(define (dtable-entry-index te) (vector-ref te 0))
+(define (dtable-entry-type te) (vector-ref te 1))
+(define (dtable-entry-value te) (vector-ref te 2))
+\f
+; Return #t if BITNUM is a good bit to use for decoding.
+; MASKS is a list of opcode masks.
+; MASK-LENS is a list of lengths of each value in MASKS.
+; BITNUM is the number of the bit to test.  It's value depends on LSB0?.
+; It can be no larger than the smallest element in MASKS.
+; E.g. If MASK-LENS consists of 16 and 32 and LSB0? is #f, BITNUM must
+; be from 0 to 15.
+; FIXME: This isn't quite right.  What if LSB0? = #t?  Need decode-bitsize.
+; LSB0? is non-#f if bit number 0 is the least significant bit.
+;
+; FIXME: This is just a first cut, but the governing intent is to not require
+; targets to specify decode tables, hints, or algorithms.
+; Certainly as it becomes useful they can supply such information.
+; The point is to avoid having to as much as possible.
+;
+; FIXME: Bit numbers shouldn't be considered in isolation.
+; It would be better to compute use counts of all of them and then see
+; if there's a cluster of high use counts.
+
+(define (-usable-decode-bit? masks mask-lens bitnum lsb0?)
+  (let* ((has-bit (map (lambda (msk len)
+                        (bit-set? msk (if lsb0? bitnum (- len bitnum 1))))
+                      masks mask-lens)))
+    (or (all-true? has-bit)
+       ; If half or more insns use the bit, it's a good one.
+       ; FIXME: An empirical guess at best.
+       (>= (count-true has-bit) (quotient (length has-bit) 2))
+       ))
+)
+
+
+; Compute population counts for each bit.  Return it as a vector indexed by bit number.
+(define (-mask-bit-population masks mask-lens lsb0?)
+  (let* ((max-length (apply max mask-lens))
+        (population (make-vector max-length 0)))
+    (for-each (lambda (mask len)
+               (logit 5 " population count mask=" (number->hex mask) " len=" len "\n")
+               (for-each (lambda (bitno)
+                           (if (bit-set? mask (if lsb0? bitno (- len bitno 1)))
+                               (vector-set! population bitno 
+                                            (+ 1 (vector-ref population bitno)))))
+                         (-range len)))
+             masks mask-lens)
+    population)
+)
+
+
+; Return a list (0 ... limit-1)
+(define (-range limit)
+  (let loop ((i 0)
+            (indices (list)))
+    (if (= i limit) (reverse indices) (loop (+ i 1) (cons i indices))))
+)
+
+; Return a list (base ... base+size-1)
+(define (-range2 base size)
+  (let loop ((i base)
+            (indices (list)))
+    (if (= i (+ base size)) (reverse indices) (loop (+ i 1) (cons i indices))))
+)
+
+
+; Return a copy of given vector, with all entries with given indices set to `value'
+(define (-vector-copy-set-all vector indices value)
+  (let ((new-vector (make-vector (vector-length vector))))
+    (for-each (lambda (index)
+               (vector-set! new-vector index (if (memq index indices)
+                                                 value
+                                                 (vector-ref vector index))))
+             (-range (vector-length vector)))
+    new-vector)
+)
+
+
+; Return a list of indices whose counts in the given vector exceed the given threshold.
+(define (-population-above-threshold population threshold)
+  (find (lambda (index) (if (vector-ref population index) 
+                           (>= (vector-ref population index) threshold)
+                           #f))
+       (-range (vector-length population)))
+)
+
+
+; Return the top few most popular indices in the population vector, ignoring any
+; that are already used (marked by negative count).  Don't exceed `size' unless
+; the clustering is just too good to pass up.
+(define (-population-top-few population size)
+  (let loop ((old-picks (list))
+            (remaining-population population)
+            (count-threshold (apply max (map (lambda (value) (if value value 0))
+                                             (vector->list population)))))
+      (let* ((new-picks (-population-above-threshold remaining-population count-threshold)))
+       (logit 4 "-population-top-few"
+              " picks=(" old-picks ") pop=(" remaining-population ")"
+              " threshold=" count-threshold " new-picks=(" new-picks ")\n")
+       (cond 
+        ; No new matches?
+        ((null? new-picks)
+         (begin (assert (not (null? old-picks)))
+                old-picks))
+        ; Way too many matches?
+        ((> (+ (length new-picks) (length old-picks)) (+ 2 size))
+         (list-take (+ 2 size) (append new-picks old-picks)))
+        ; About right number of matches?
+        ((> (+ (length new-picks) (length old-picks)) (- 1 size))
+         (append old-picks new-picks))
+        ; Not enough?  Lower the threshold a bit and try to add some more.
+        (else
+         (loop (append old-picks new-picks)
+               (-vector-copy-set-all remaining-population new-picks #f)
+               (truncate (* 0.8 count-threshold)))))))
+)
+
+
+
+; Given list of insns, return list of bit numbers of constant bits in opcode
+; that they all share (or mostly share), up to MAX elements.
+; ALREADY-USED is a list of bitnums we can't use.
+; STARTBIT is the bit offset of the instruction value that C variable `insn'
+; holds (note that this is independent of LSB0?).
+; DECODE-BITSIZE is the number of bits of the insn that `insn' holds.
+; LSB0? is non-#f if bit number 0 is the least significant bit.
+;
+; Nil is returned if there are none, meaning that there is an ambiguity in
+; the specification up to the current word.
+;
+; We assume INSN-LIST matches all opcode bits before STARTBIT.
+; FIXME: Revisit, as a more optimal decoder is sometimes achieved by doing
+; a cluster of opcode bits that appear later in the insn, and then coming
+; back to earlier ones.
+;
+; All insns are assumed to start at the same address so we handle insns of
+; varying lengths - we only analyze the common bits in all of them.
+;
+; Note that if we get called again to compute further opcode bits, we
+; start looking at STARTBIT again (rather than keeping track of how far in
+; the insn word we've progressed).  We could do this as an optimization, but
+; we also have to handle the case where the initial set of decode bits misses
+; some and thus we have to go back and look at them.  It may also turn out
+; that an opcode bit is skipped over because it doesn't contribute much
+; information to the decoding process (see -usable-decode-bit?).  As the
+; possible insn list gets wittled down, the bit will become significant.  Thus
+; the optimization is left for later.  Also, see preceding FIXME.
+
+(define (decode-get-best-bits insn-list already-used startbit max decode-bitsize lsb0?)
+  (let* ((raw-population (-mask-bit-population (map insn-base-mask insn-list)
+                                              (map insn-base-mask-length insn-list)
+                                              lsb0?))
+        ; (undecoded (if lsb0?
+       ;               (-range2 startbit (+ startbit decode-bitsize))
+               ;       (-range2 (- startbit decode-bitsize) startbit)))
+        (used+undecoded already-used) ; (append already-used undecoded))
+        (filtered-population (-vector-copy-set-all raw-population used+undecoded #f))
+        (favorite-indices (-population-top-few filtered-population max))
+        (sorted-indices (sort favorite-indices (lambda (a b) 
+                                                 (if lsb0? (> a b) (< a b))))))
+    (logit 3 
+          "Best decode bits (prev=" already-used " start=" startbit " decode=" decode-bitsize ")"
+          "=>"
+          "(" sorted-indices ")\n")
+    sorted-indices)
+)
+
+
+(define (OLDdecode-get-best-bits insn-list already-used startbit max decode-bitsize lsb0?)
+  (let ((masks (map insn-base-mask insn-list))
+       ; ??? We assume mask lengths are repeatedly used for insns longer
+       ; than the base insn size.
+       (mask-lens (map insn-base-mask-length insn-list))
+       (endbit (if lsb0?
+                   -1 ; FIXME: for now (gets sparc port going)
+                   (+ startbit decode-bitsize)))
+       (incr (if lsb0? -1 1)))
+    (let loop ((result nil)
+              (bitnum (if lsb0?
+                          (+ startbit (- decode-bitsize 1))
+                          startbit)))
+      (if (or (= (length result) max) (= bitnum endbit))
+         (reverse! result)
+         (if (and (not (memq bitnum already-used))
+                  (-usable-decode-bit? masks mask-lens bitnum lsb0?))
+             (loop (cons bitnum result) (+ bitnum incr))
+             (loop result (+ bitnum incr))))
+      ))
+)
+
+; Return list of decode table entry numbers for INSN's opcode bits BITNUMS.
+; This is the indices into the decode table that match the instruction.
+; LSB0? is non-#f if bit number 0 is the least significant bit.
+;
+; Example: If BITNUMS is (0 1 2 3 4 5), and the constant (i.e. opcode) part of
+; the those bits of INSN is #b1100xx (where 'x' indicates a non-constant
+; part), then the result is (#b110000 #b110001 #b110010 #b110011).
+
+(define (-opcode-slots insn bitnums lsb0?)
+  (letrec ((opcode (insn-value insn))
+          (insn-len (insn-base-mask-length insn))
+          (decode-len (length bitnums))
+          (compute (lambda (val insn-len decode-len bl)
+                     ;(display (list val insn-len decode-len bl)) (newline)
+                     ; Oh My God.  This isn't tail recursive.
+                     (if (null? bl)
+                         0
+                         (+ (if (bit-set? val
+                                          (if lsb0?
+                                              (car bl)
+                                              (- insn-len (car bl) 1)))
+                                (integer-expt 2 (- (length bl) 1))
+                                0)
+                            (compute val insn-len decode-len (cdr bl)))))))
+    (let* ((opcode (compute (insn-value insn) insn-len decode-len bitnums))
+          (opcode-mask (compute (insn-base-mask insn) insn-len decode-len bitnums))
+          (indices (missing-bit-indices opcode-mask (- (integer-expt 2 decode-len) 1))))
+      (logit 3 "insn =" (obj:name insn) " opcode=" opcode " indices=" indices "\n")
+      (map (lambda (index) (+ opcode index)) indices)))
+)
+
+; Subroutine of -build-slots.
+; Fill slot in INSN-VEC that INSN goes into.
+; BITNUMS is the list of opcode bits.
+; LSB0? is non-#f if bit number 0 is the least significant bit.
+;
+; Example: If BITNUMS is (0 1 2 3 4 5) and the constant (i.e. opcode) part of
+; the first six bits of INSN is #b1100xx (where 'x' indicates a non-constant
+; part), then elements 48 49 50 51 of INSN-VEC are cons'd with INSN.
+; Each "slot" is a list of matching instructions.
+
+(define (-fill-slot! insn-vec insn bitnums lsb0?)
+  ;(display (string-append "fill-slot!: " (obj:name insn) " ")) (display bitnums) (newline)
+  (let ((slot-nums (-opcode-slots insn bitnums lsb0?)))
+    ;(display (list "Filling slot(s)" slot-nums "...")) (newline)
+    (for-each (lambda (slot-num)
+               (vector-set! insn-vec slot-num
+                            (cons insn (vector-ref insn-vec slot-num))))
+             slot-nums)
+    *UNSPECIFIED*
+    )
+)
+
+; Given a list of constant bitnums (ones that are predominantly, though perhaps
+; not always, in the opcode), record each insn in INSN-LIST in the proper slot.
+; LSB0? is non-#f if bit number 0 is the least significant bit.
+; The result is a vector of insn lists.  Each slot is a list of insns
+; that go in that slot.
+
+(define (-build-slots insn-list bitnums lsb0?)
+  (let ((result (make-vector (integer-expt 2 (length bitnums)) nil)))
+    ; Loop over each element, filling RESULT.
+    (for-each (lambda (insn)
+               (-fill-slot! result insn bitnums lsb0?))
+             insn-list)
+    result)
+)
+\f
+; Compute the name of a decode table, prefixed with PREFIX.
+; INDEX-LIST is a list of pairs: list of bitnums, table entry number,
+; in reverse order of traversal (since they're built with cons).
+; INDEX-LIST may be empty.
+
+(define (-gen-decode-table-name prefix index-list)
+  (set! index-list (reverse index-list))
+  (string-append
+   prefix
+   "table"
+   (string-map (lambda (elm) (string-append "_" (number->string elm)))
+               ; CDR of each element is the table index.
+              (map cdr index-list)))
+)
+
+; Generate one decode table entry for INSN-VEC at INDEX.
+; INSN-VEC is a vector of slots where each slot is a list of instructions that
+; map to that slot (opcode value).  If a slot is nil, no insn has that opcode
+; value so the decoder marks it as being invalid.
+; STARTBIT is the bit offset of the instruction value that C variable `insn'
+; holds (note that this is independent of LSB0?).
+; DECODE-BITSIZE is the number of bits of the insn that `insn' holds.
+; INDEX-LIST is a list of pairs: list of bitnums, table entry number.
+; LSB0? is non-#f if bit number 0 is the least significant bit.
+; INVALID-INSN is an <insn> object to use for invalid insns.
+; The result is a dtable-entry element (or "slot").
+
+; ??? For debugging.
+(define -build-decode-table-entry-args #f)
+
+(define (-build-decode-table-entry insn-vec startbit decode-bitsize index index-list lsb0? invalid-insn)
+  (let ((slot (filter-harmlessly-ambiguous-insns (vector-ref insn-vec index))))
+    (logit 2 "Processing decode entry "
+          (number->string index)
+          " in "
+          (-gen-decode-table-name "decode_" index-list)
+          ", "
+          (cond ((null? slot) "invalid")
+                ((= 1 (length slot)) (insn-syntax (car slot)))
+                (else "subtable"))
+          " ...\n")
+
+    (cond
+     ; If no insns map to this value, mark it as invalid.
+     ((null? slot) (dtable-entry-make index 'insn invalid-insn))
+
+     ; If only one insn maps to this value, that's it for this insn.
+     ((= 1 (length slot))
+      ; FIXME: Incomplete: need to check further opcode bits.
+      (dtable-entry-make index 'insn (car slot)))
+
+     ; Otherwise more than one insn maps to this value and we need to look at
+     ; further opcode bits.
+     (else
+      (logit 3 "Building subtable at index " (number->string index)
+            ", decode-bitsize = " (number->string decode-bitsize)
+            ", indices used thus far:"
+            (string-map (lambda (i) (string-append " " (number->string i)))
+                        (apply append (map car index-list)))
+            "\n")
+
+      (let ((bitnums (decode-get-best-bits slot
+                                          (apply append (map car index-list))
+                                          startbit 4
+                                          decode-bitsize lsb0?)))
+
+       ; If bitnums is nil, either there is an ambiguity or we need to read
+       ; more of the instruction in order to distinguish insns in SLOT.
+       (if (and (null? bitnums)
+                (< startbit (apply min (map insn-length slot))))
+           (begin
+             ; We might be able to resolve the ambiguity by reading more bits.
+             ; We know from the < test that there are, indeed, more bits to
+             ; be read.
+             (set! startbit (+ startbit decode-bitsize))
+             ; FIXME: The calculation of the new decode-bitsize will
+             ; undoubtedly need refinement.
+             (set! decode-bitsize
+                   (min decode-bitsize
+                        (- (apply min (map insn-length slot))
+                           startbit)))
+             (set! bitnums (decode-get-best-bits slot
+                                                 ;nil ; FIXME: what to put here?
+                                                 (apply append (map car index-list))
+                                                 startbit 4
+                                                 decode-bitsize lsb0?))))
+
+       ; If bitnums is still nil there is an ambiguity.
+       (if (null? bitnums)
+
+           (begin
+             ; If all insns are marked as DECODE-SPLIT, don't warn.
+             (if (not (all-true? (map (lambda (insn)
+                                        (obj-has-attr? insn 'DECODE-SPLIT))
+                                      slot)))
+                 (message "WARNING: Decoder ambiguity detected: "
+                          (string-drop1 ; drop leading comma
+                           (string-map (lambda (insn)
+                                         (string-append ", " (obj:name insn)))
+                                       slot))
+                          "\n"))
+             ; Things aren't entirely hopeless.  See if any ifield-assertion
+             ; specs are present.
+             ; FIXME: For now we assume that if they all have an
+             ; ifield-assertion spec, then there is no ambiguity (it's left
+             ; to the programmer to get it right).  This can be made more
+             ; clever later.
+             ; FIXME: May need to back up startbit if we've tried to read
+             ; more of the instruction.
+             (let ((assertions (map insn-ifield-assertion slot)))
+               (if (not (all-true? assertions))
+                   (begin
+                     ; Save arguments for debugging purposes.
+                     (set! -build-decode-table-entry-args
+                           (list insn-vec startbit decode-bitsize index index-list lsb0? invalid-insn))
+                     (error "Unable to resolve ambiguity (maybe need some ifield-assertion specs?)")))
+               ; FIXME: Punt on even simple cleverness for now.
+               (let ((exprtable-entries
+                      (exprtable-sort (map exprtable-entry-make
+                                           slot
+                                           assertions))))
+                 (dtable-entry-make index 'expr
+                                    (exprtable-make
+                                     (-gen-exprtable-name exprtable-entries)
+                                     exprtable-entries)))))
+
+           ; There is no ambiguity so generate the subtable.
+           ; Need to build `subtable' separately because we
+           ; may be appending to -decode-subtables recursively.
+           (let* ((insn-vec (-build-slots slot bitnums lsb0?))
+                  (subtable
+                   (-build-decode-table-guts insn-vec bitnums startbit
+                                             decode-bitsize index-list lsb0?
+                                             invalid-insn)))
+             (dtable-entry-make index 'table
+                                (subdtable-add subtable
+                                               (-gen-decode-table-name "" index-list)))))))
+     )
+    )
+)
+
+; Given vector of insn slots, generate the guts of the decode table, recorded
+; as a list of 3 elements: bitnums, decode-bitsize, and list of entries.
+; Bitnums is recorded with the guts so that tables whose contents are
+; identical but are accessed by different bitnums are treated as separate in
+; -decode-subtables.  Not sure this will ever happen, but play it safe.
+;
+; BITNUMS is the list of bit numbers used to build the slot table.
+; STARTBIT is the bit offset of the instruction value that C variable `insn'
+; holds (note that this is independent of LSB0?).
+; For example, it is initially zero.  If DECODE-BITSIZE is 16 and after
+; scanning the first fetched piece of the instruction, more decoding is
+; needed, another piece will be fetched and STARTBIT will then be 16.
+; DECODE-BITSIZE is the number of bits of the insn that `insn' holds.
+; INDEX-LIST is a list of pairs: list of bitnums, table entry number.
+; Decode tables consist of entries of two types: actual insns and
+; pointers to other tables.
+; LSB0? is non-#f if bit number 0 is the least significant bit.
+; INVALID-INSN is an <insn> object representing invalid insns.
+
+(define (-build-decode-table-guts insn-vec bitnums startbit decode-bitsize index-list lsb0? invalid-insn)
+  (logit 2 "Processing decoder for bits"
+        (numbers->string bitnums " ")
+        " ...\n")
+
+  (dtable-guts-make
+   bitnums startbit decode-bitsize
+   (map (lambda (index)
+         (-build-decode-table-entry insn-vec startbit decode-bitsize index
+                                    (cons (cons bitnums index)
+                                          index-list)
+                                    lsb0? invalid-insn))
+       (iota (vector-length insn-vec))))
+)
+
+; Entry point.
+; Return a table that efficiently decodes INSN-LIST.
+; BITNUMS is the set of bits to initially key off of.
+; DECODE-BITSIZE is the number of bits of the instruction that `insn' holds.
+; LSB0? is non-#f if bit number 0 is the least significant bit.
+; INVALID-INSN is an <insn> object representing the `invalid' insn (for
+; instructions values that don't decode to any entry in INSN-LIST).
+
+(define (decode-build-table insn-list bitnums decode-bitsize lsb0? invalid-insn)
+  ; Initialize the list of subtables computed.
+  (set! -decode-subtables nil)
+
+  ; ??? Another way to handle simple forms of ifield-assertions (like those
+  ; created by insn specialization) is to record a copy of the insn for each
+  ; possible value of the ifield and modify its ifield list with the ifield's
+  ; value.  This would then let the decoder table builder handle it normally.
+  ; I wouldn't create N insns, but would rather create an intermediary record
+  ; that recorded the necessary bits (insn, ifield-list, remaining
+  ; ifield-assertions).
+
+  (let ((insn-vec (-build-slots insn-list bitnums lsb0?)))
+    (let ((table-guts (-build-decode-table-guts insn-vec bitnums
+                                               0 decode-bitsize
+                                               nil lsb0?
+                                               invalid-insn)))
+      table-guts))
+)
diff --git a/cgen/desc-cpu.scm b/cgen/desc-cpu.scm
new file mode 100644 (file)
index 0000000..1e3799c
--- /dev/null
@@ -0,0 +1,954 @@
+; Generate .c/.h versions of main elements of cpu description file.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+
+; ISA support code.
+
+(define (-gen-isa-table-defns)
+  (logit 2 "Generating isa table defns ...\n")
+
+  (string-list
+   "\
+/* Instruction set variants.  */
+
+static const CGEN_ISA @arch@_cgen_isa_table[] = {
+"
+   (string-list-map (lambda (isa)
+                     (gen-obj-sanitize
+                      isa
+                      (string-append "  { "
+                                     "\"" (obj:name isa) "\", "
+                                     (number->string
+                                      (isa-default-insn-bitsize isa))
+                                     ", "
+                                     (number->string
+                                      (isa-base-insn-bitsize isa))
+                                     ", "
+                                     (number->string
+                                      (isa-min-insn-bitsize isa))
+                                     ", "
+                                     (number->string
+                                      (isa-max-insn-bitsize isa))
+                                     " },\n")))
+                   (current-isa-list))
+   "\
+  { 0, 0, 0, 0, 0 }
+};
+\n"
+   )
+)
+
+; Mach support code.
+
+; Return C code to describe the various cpu variants.
+; Currently this is quite simple, the various cpu names and their mach numbers
+; are recorded in a "keyword" table.
+; ??? No longer used as there is the mach attribute.
+;
+;(set! mach-table (make <keyword> 'mach "machine list"
+;                      (make <attr-list> "" nil) ; FIXME: sanitization?
+;                      (map (lambda (elm) (list (obj:name elm) (mach-number elm)))
+;                           (current-mach-list))))
+
+(define (-gen-mach-table-decls)
+  (logit 2 "Generating machine table decls ...\n")
+  "" ; (gen-decl mach-table)
+)
+
+(define (-gen-mach-table-defns)
+  (logit 2 "Generating machine table defns ...\n")
+
+  (string-list
+   "\
+/* Machine variants.  */
+
+static const CGEN_MACH @arch@_cgen_mach_table[] = {
+"
+   (string-list-map (lambda (mach)
+                     (gen-obj-sanitize
+                      mach
+                      (string-append "  { "
+                                     "\"" (obj:name mach) "\", "
+                                     "\"" (mach-bfd-name mach) "\", "
+                                     (mach-enum mach)
+                                     " },\n")))
+                   (current-mach-list))
+   "\
+  { 0, 0, 0 }
+};
+\n"
+   )
+)
+\f
+; Attribute support code.
+
+; Return C code to describe the various attributes.
+
+(define (-gen-attr-table-decls)
+  (logit 2 "Generating attribute table decls ...\n")
+  (string-append
+   "/* Attributes.  */\n"
+   "extern const CGEN_ATTR_TABLE @arch@_cgen_hardware_attr_table[];\n"
+   "extern const CGEN_ATTR_TABLE @arch@_cgen_ifield_attr_table[];\n"
+   "extern const CGEN_ATTR_TABLE @arch@_cgen_operand_attr_table[];\n"
+   "extern const CGEN_ATTR_TABLE @arch@_cgen_insn_attr_table[];\n"
+   "\n"
+   )
+)
+
+; Alternative GEN-MASK argument to gen-bool-attrs.
+; This uses the `A' macro to abbreviate the attribute definition.
+
+(define (gen-A-attr-mask prefix name)
+  (string-append "A(" (string-upcase (gen-c-symbol name)) ")")
+)
+\f
+; Instruction fields support code.
+
+; Return C code to declare various ifield bits.
+
+(define (gen-ifld-decls)
+  (logit 2 "Generating instruction field decls ...\n")
+  (string-list
+   "/* Ifield support.  */\n\n"
+   "extern const struct cgen_ifld @arch@_cgen_ifld_table[];\n\n"
+   "/* Ifield attribute indices.  */\n\n"
+   (gen-attr-enum-decl "cgen_ifld" (current-ifld-attr-list))
+   (gen-enum-decl 'ifield_type "@arch@ ifield types"
+                 "@ARCH@_"
+                 (append (gen-obj-list-enums (non-derived-ifields (current-ifld-list)))
+                         '((f-max))))
+   "#define MAX_IFLD ((int) @ARCH@_F_MAX)\n\n"
+   )
+)
+
+; Return C code to define the instruction field table,
+; and any other ifield related definitions.
+
+(define (gen-ifld-defns)
+  (logit 2 "Generating ifield table ...\n")
+  (let* ((ifld-list (find (lambda (f) (not (has-attr? f 'VIRTUAL)))
+                         (non-derived-ifields (current-ifld-list))))
+        (all-attrs (current-ifld-attr-list))
+        (num-non-bools (attr-count-non-bools all-attrs)))
+    (string-list
+     "\
+/* The instruction field table.  */
+
+#define A(a) (1 << CONCAT2 (CGEN_IFLD_,a))
+
+const CGEN_IFLD @arch@_cgen_ifld_table[] =
+{
+"
+     (string-list-map
+      (lambda (ifld)
+       (gen-obj-sanitize ifld
+                         (string-append
+                          "  { "
+                          (ifld-enum ifld) ", "
+                          "\"" (obj:name ifld) "\", "
+                          (number->string (ifld-word-offset ifld)) ", "
+                          (number->string (ifld-word-length ifld)) ", "
+                          (number->string (ifld-start ifld #f)) ", "
+                          (number->string (ifld-length ifld)) ", "
+                          (gen-obj-attr-defn 'ifld ifld all-attrs
+                                             num-non-bools gen-A-attr-mask)
+                          "  },\n")))
+      ifld-list)
+     "\
+  { 0, 0, 0, 0, 0, 0, {0, {0}} }
+};
+
+#undef A
+
+"
+     ))
+)
+\f
+; Hardware support.
+
+; Return C code to declare the various hardware bits
+; that can be (or must be) defined before including opcode/cgen.h.
+
+(define (gen-hw-decls)
+  (logit 2 "Generating hardware decls ...\n")
+  (string-list
+   "/* Hardware attribute indices.  */\n\n"
+   (gen-attr-enum-decl "cgen_hw" (current-hw-attr-list))
+   (gen-enum-decl 'cgen_hw_type "@arch@ hardware types"
+                 "HW_" ; FIXME: @ARCH@_
+                 (append (nub (map (lambda (hw)
+                                     (cons (hw-sem-name hw)
+                                           (cons '-
+                                                 (atlist-attrs
+                                                  (obj-atlist hw)))))
+                                   (current-hw-list))
+                              (lambda (elm) (car elm)))
+                         '((max))))
+   "#define MAX_HW ((int) HW_MAX)\n\n"
+   )
+)
+
+; Return declarations of variables tables used by HW.
+
+(define (-gen-hw-decl hw)
+  (string-append
+   (if (and (hw-indices hw)
+           ; ??? Commented out as opcode changes are needed
+           ) ; (not (obj-has-attr? (hw-indices hw) 'PRIVATE)))
+       (gen-decl (hw-indices hw))
+       "")
+   (if (and (hw-values hw)
+           ; ??? Commented out as opcode changes are needed
+           ) ; (not (obj-has-attr? (hw-values hw) 'PRIVATE)))
+       (gen-decl (hw-values hw))
+       "")
+   )
+)
+
+; Return C code to declare the various hardware bits
+; that must be defined after including opcode/cgen.h.
+
+(define (gen-hw-table-decls)
+  (logit 2 "Generating hardware table decls ...\n")
+  (string-list
+   "/* Hardware decls.  */\n\n"
+   (string-map -gen-hw-decl (current-hw-list))
+   "\n"
+   )
+)
+
+; Return definitions of variables tables used by HW.
+; Only do this for `PRIVATE' elements.  Public ones are emitted elsewhere.
+
+(define (-gen-hw-defn hw)
+  (string-append
+   (if (and (hw-indices hw)
+           (obj-has-attr? (hw-indices hw) 'PRIVATE))
+       (gen-defn (hw-indices hw))
+       "")
+   (if (and (hw-values hw)
+           (obj-has-attr? (hw-values hw) 'PRIVATE))
+       (gen-defn (hw-values hw))
+       "")
+   )
+)
+
+; Generate the tables for the various hardware bits (register names, etc.).
+; A table is generated for each element, and then another table is generated
+; which collects them all together.
+; Uses include looking up a particular register set so that a new reg
+; can be added to it [at runtime].
+
+(define (gen-hw-table-defns)
+  (logit 2 "Generating hardware table ...\n")
+  (let* ((all-attrs (current-hw-attr-list))
+        (num-non-bools (attr-count-non-bools all-attrs)))
+    (string-list
+     (string-list-map gen-defn (current-kw-list))
+     (string-list-map -gen-hw-defn (current-hw-list))
+     "
+
+/* The hardware table.  */
+
+#define A(a) (1 << CONCAT2 (CGEN_HW_,a))
+
+const CGEN_HW_ENTRY @arch@_cgen_hw_table[] =
+{
+"
+     (string-list-map
+      (lambda (hw)
+       (gen-obj-sanitize hw
+                         (string-list
+                          "  { "
+                          "\"" (obj:name hw) "\", "
+                          (hw-enum hw) ", "
+                          ; ??? No element currently requires both indices and
+                          ; values specs so we only output the needed one.
+                          (or (and (hw-indices hw)
+                                   (send (hw-indices hw) 'gen-table-entry))
+                              (and (hw-values hw)
+                                   (send (hw-values hw) 'gen-table-entry))
+                              "CGEN_ASM_NONE, 0, ")
+                          (gen-obj-attr-defn 'hw hw all-attrs
+                                             num-non-bools gen-A-attr-mask)
+                          " },\n")))
+      (current-hw-list))
+     "\
+  { 0, 0, CGEN_ASM_NONE, 0, {0, {0}} }
+};
+
+#undef A
+
+"
+     ))
+)
+\f
+; Utilities of cgen-opc.h.
+
+; Return #define's of several constants.
+; FIXME: Some of these to be moved into table of structs, one per cpu family.
+
+(define (-gen-hash-defines)
+  (logit 2 "Generating #define's ...\n")
+  (string-list
+   "#define CGEN_ARCH @arch@\n\n"
+   "/* Given symbol S, return @arch@_cgen_<S>.  */\n"
+   "#define CGEN_SYM(s) CONCAT3 (@arch@,_cgen_,s)\n\n"
+   "/* Selected cpu families.  */\n"
+   ; FIXME: Move to sim's arch.h.
+   (string-map (lambda (cpu)
+                (gen-obj-sanitize cpu
+                                  (string-append "#define HAVE_CPU_"
+                                                 (string-upcase (gen-sym cpu))
+                                                 "\n")))
+              (current-cpu-list))
+   "\n"
+   "#define CGEN_INSN_LSB0_P " (if (current-arch-insn-lsb0?) "1" "0")
+   "\n\n"
+   "/* Minimum size of any insn (in bytes).  */\n"
+   "#define CGEN_MIN_INSN_SIZE "
+   (number->string (bits->bytes
+                   (apply min (map isa-min-insn-bitsize (current-isa-list)))))
+   "\n\n"
+   "/* Maximum size of any insn (in bytes).  */\n"
+   "#define CGEN_MAX_INSN_SIZE "
+   (number->string (bits->bytes
+                   (apply max (map isa-max-insn-bitsize (current-isa-list)))))
+   "\n\n"
+   ; This tells the assembler/disassembler whether or not it can use an int to
+   ; record insns, which is faster.  Since this controls the typedef of the
+   ; insn buffer, only enable this if all isas support it.
+   "#define CGEN_INT_INSN_P "
+   (if (all-true? (map isa-integral-insn? (current-isa-list))) "1" "0")
+   "\n"
+   "\n"
+   "/* Maximum nymber of syntax bytes in an instruction.  */\n"
+   "#define CGEN_ACTUAL_MAX_SYNTAX_BYTES "
+   ; The +2 account for the leading "MNEM" and trailing 0.
+   (number->string (+ 2 (apply max (map (lambda (insn) 
+                                         (length (syntax-break-out (insn-syntax insn))))
+                                       (current-insn-list)))))
+   "\n"
+   "\n"
+   "/* CGEN_MNEMONIC_OPERANDS is defined if mnemonics have operands.\n"
+   "   e.g. In \"b,a foo\" the \",a\" is an operand.  If mnemonics have operands\n"
+   "   we can't hash on everything up to the space.  */\n"
+   (if strip-mnemonic?
+       "/*#define CGEN_MNEMONIC_OPERANDS*/\n"
+       "#define CGEN_MNEMONIC_OPERANDS\n")
+   "\n"
+   ; "/* Maximum number of operands any insn or macro-insn has.  */\n"
+   ; FIXME: Should compute.
+   ; "#define CGEN_MAX_INSN_OPERANDS 16\n"
+   ; "\n"
+   "/* Maximum number of fields in an instruction.  */\n"
+   "#define CGEN_ACTUAL_MAX_IFMT_OPERANDS "
+   (number->string (apply max (map (lambda (f) (length (ifmt-ifields f)))
+                                  (current-ifmt-list))))
+   "\n\n"
+  )
+)
+\f
+; Operand support.
+
+; Return C code to declare various operand bits.
+
+(define (gen-operand-decls)
+  (logit 2 "Generating operand decls ...\n")
+  (string-list
+   "/* Operand attribute indices.  */\n\n"
+   (gen-attr-enum-decl "cgen_operand" (current-op-attr-list))
+   (gen-enum-decl 'cgen_operand_type "@arch@ operand types"
+                 "@ARCH@_OPERAND_"
+                 (nub (append (gen-obj-list-enums (current-op-list))
+                              '((max)))
+                      car))
+   "/* Number of operands types.  */\n"
+   "#define MAX_OPERANDS ((int) @ARCH@_OPERAND_MAX)\n\n"
+   "/* Maximum number of operands referenced by any insn.  */\n"
+   "#define MAX_OPERAND_INSTANCES "
+   (number->string (max-operand-instances))
+   "\n\n"
+   )
+)
+
+; Generate C code to define the operand table.
+
+(define (gen-operand-table)
+  (logit 2 "Generating operand table ...\n")
+  (let* ((all-attrs (current-op-attr-list))
+        (num-non-bools (attr-count-non-bools all-attrs)))
+    (string-list
+     "\
+/* The operand table.  */
+
+#define A(a) (1 << CONCAT2 (CGEN_OPERAND_,a))
+#define OPERAND(op) CONCAT2 (@ARCH@_OPERAND_,op)
+
+const CGEN_OPERAND @arch@_cgen_operand_table[] =
+{
+"
+     (string-list-map
+      (lambda (op)
+       (gen-obj-sanitize op
+                         (string-append
+                          "/* " (obj:name op) ": " (obj:comment op) " */\n"
+                          (if (or (derived-operand? op)
+                                  (anyof-operand? op))
+                              ""
+                              (string-append 
+                                "  { "
+                                "\"" (obj:name op) "\", "
+                                (op-enum op) ", "
+                                (hw-enum (op:hw-name op)) ", "
+                                (number->string (op:start op)) ", "
+                                (number->string (op:length op)) ",\n"
+                                "    "
+                                (gen-obj-attr-defn 'operand op all-attrs
+                                                   num-non-bools gen-A-attr-mask)
+                                "  },\n"
+                             )))))
+      (current-op-list))
+     "\
+  { 0, 0, 0, 0, 0, {0, {0}} }
+};
+
+#undef A
+
+"
+     )
+    )
+)
+\f
+; Instruction table support.
+
+; Return C code to declare various insn bits.
+
+(define (gen-insn-decls)
+  (logit 2 "Generating instruction decls ...\n")
+  (string-list
+   "/* Insn attribute indices.  */\n\n"
+   (gen-attr-enum-decl "cgen_insn" (current-insn-attr-list))
+   )
+)
+
+; Generate an insn table entry for INSN.
+; ALL-ATTRS is a list of all instruction attributes.
+; NUM-NON-BOOLS is the number of non-boolean insn attributes.
+
+(define (gen-insn-table-entry insn all-attrs num-non-bools)
+  (gen-obj-sanitize
+   insn
+   (string-list
+    "/* " (insn-syntax insn) " */\n"
+    "  {\n"
+    "    "
+    (if (has-attr? insn 'ALIAS) "-1" (insn-enum insn)) ", "
+    "\"" (obj:name insn) "\", "
+    "\"" (insn-mnemonic insn) "\", "
+    ;(if (has-attr? insn 'ALIAS) "0" (number->string (insn-length insn))) ",\n"
+    (number->string (insn-length insn)) ",\n"
+; ??? There is currently a problem with embedded newlines, and this might
+; best be put in another file [the table is already pretty big].
+; Might also wish to output bytecodes instead.
+;    "    "
+;    (if (insn-semantics insn)
+;      (string-append "\""
+;                     (with-output-to-string
+;                       ; ??? Should we do macro expansion here?
+;                       (lambda () (display (insn-semantics insn))))
+;                     "\"")
+;      "0")
+;    ",\n"
+    ; ??? Might wish to output the raw format spec here instead
+    ; (either as plain text or bytecodes).
+    ; Values could be lazily computed and cached.
+    "    "
+    (gen-obj-attr-defn 'insn insn all-attrs num-non-bools gen-A-attr-mask)
+    "\n  },\n"))
+)
+
+; Generate insn table.
+
+(define (gen-insn-table)
+  (logit 2 "Generating instruction table ...\n")
+  (let* ((all-attrs (current-insn-attr-list))
+        (num-non-bools (attr-count-non-bools all-attrs)))
+    (string-write
+     "\
+#define A(a) (1 << CONCAT2 (CGEN_INSN_,a))
+#define OP(field) CGEN_SYNTAX_MAKE_FIELD (OPERAND (field))
+
+/* The instruction table.  */
+
+static const CGEN_IBASE @arch@_cgen_insn_table[MAX_INSNS] =
+{
+  /* Special null first entry.
+     A `num' value of zero is thus invalid.
+     Also, the special `invalid' insn resides here.  */
+  { 0, 0, 0, 0, {0, {0}} },\n"
+
+     (lambda ()
+       (string-write-map (lambda (insn)
+                           (logit 3 "Generating insn table entry for " (obj:name insn) " ...\n")
+                           (gen-insn-table-entry insn all-attrs num-non-bools))
+                         (non-multi-insns (current-insn-list))))
+
+     "\
+};
+
+#undef A
+#undef MNEM
+#undef OP
+
+"
+     )
+    )
+)
+\f
+; Cpu table handling support.
+;
+; ??? A lot of this can live in a machine independent file, but there's
+; currently no place to put this file (there's no libcgen).  libopcodes is the
+; wrong place as some simulator ports use this but they don't use libopcodes.
+
+; Return C routines to open/close a cpu description table.
+; This is defined here and not in cgen-opc.in because it refers to
+; CGEN_{ASM,DIS}_HASH and insn_table/macro_insn_table which is defined
+; earlier in the file.  ??? Things can certainly be rearranged though
+; and opcodes/cgen.sh modified to insert the generated part into the middle
+; of the file like is done for assembler/disassembler support.
+
+(define (-gen-cpu-open)
+  (string-append
+   "\
+/* Subroutine of @arch@_cgen_cpu_open to look up a mach via its bfd name.  */
+
+static const CGEN_MACH *
+lookup_mach_via_bfd_name (table, name)
+     const CGEN_MACH *table;
+     const char *name;
+{
+  while (table->name)
+    {
+      if (strcmp (name, table->bfd_name) == 0)
+       return table;
+      ++table;
+    }
+  abort ();
+}
+
+/* Subroutine of @arch@_cgen_cpu_open to build the hardware table.  */
+
+static void
+build_hw_table (cd)
+     CGEN_CPU_TABLE *cd;
+{
+  int i;
+  int machs = cd->machs;
+  const CGEN_HW_ENTRY *init = & @arch@_cgen_hw_table[0];
+  /* MAX_HW is only an upper bound on the number of selected entries.
+     However each entry is indexed by it's enum so there can be holes in
+     the table.  */
+  const CGEN_HW_ENTRY **selected =
+    (const CGEN_HW_ENTRY **) xmalloc (MAX_HW * sizeof (CGEN_HW_ENTRY *));
+
+  cd->hw_table.init_entries = init;
+  cd->hw_table.entry_size = sizeof (CGEN_HW_ENTRY);
+  memset (selected, 0, MAX_HW * sizeof (CGEN_HW_ENTRY *));
+  /* ??? For now we just use machs to determine which ones we want.  */
+  for (i = 0; init[i].name != NULL; ++i)
+    if (CGEN_HW_ATTR_VALUE (&init[i], CGEN_HW_MACH)
+       & machs)
+      selected[init[i].type] = &init[i];
+  cd->hw_table.entries = selected;
+  cd->hw_table.num_entries = MAX_HW;
+}
+
+/* Subroutine of @arch@_cgen_cpu_open to build the hardware table.  */
+
+static void
+build_ifield_table (cd)
+     CGEN_CPU_TABLE *cd;
+{
+  cd->ifld_table = & @arch@_cgen_ifld_table[0];
+}
+
+/* Subroutine of @arch@_cgen_cpu_open to build the hardware table.  */
+
+static void
+build_operand_table (cd)
+     CGEN_CPU_TABLE *cd;
+{
+  int i;
+  int machs = cd->machs;
+  const CGEN_OPERAND *init = & @arch@_cgen_operand_table[0];
+  /* MAX_OPERANDS is only an upper bound on the number of selected entries.
+     However each entry is indexed by it's enum so there can be holes in
+     the table.  */
+  const CGEN_OPERAND **selected =
+    (const CGEN_OPERAND **) xmalloc (MAX_OPERANDS * sizeof (CGEN_OPERAND *));
+
+  cd->operand_table.init_entries = init;
+  cd->operand_table.entry_size = sizeof (CGEN_OPERAND);
+  memset (selected, 0, MAX_OPERANDS * sizeof (CGEN_OPERAND *));
+  /* ??? For now we just use mach to determine which ones we want.  */
+  for (i = 0; init[i].name != NULL; ++i)
+    if (CGEN_OPERAND_ATTR_VALUE (&init[i], CGEN_OPERAND_MACH)
+       & machs)
+      selected[init[i].type] = &init[i];
+  cd->operand_table.entries = selected;
+  cd->operand_table.num_entries = MAX_OPERANDS;
+}
+
+/* Subroutine of @arch@_cgen_cpu_open to build the hardware table.
+   ??? This could leave out insns not supported by the specified mach/isa,
+   but that would cause errors like \"foo only supported by bar\" to become
+   \"unknown insn\", so for now we include all insns and require the app to
+   do the checking later.
+   ??? On the other hand, parsing of such insns may require their hardware or
+   operand elements to be in the table [which they mightn't be].  */
+
+static void
+build_insn_table (cd)
+     CGEN_CPU_TABLE *cd;
+{
+  int i;
+  const CGEN_IBASE *ib = & @arch@_cgen_insn_table[0];
+  CGEN_INSN *insns = (CGEN_INSN *) xmalloc (MAX_INSNS * sizeof (CGEN_INSN));
+
+  memset (insns, 0, MAX_INSNS * sizeof (CGEN_INSN));
+  for (i = 0; i < MAX_INSNS; ++i)
+    insns[i].base = &ib[i];
+  cd->insn_table.init_entries = insns;
+  cd->insn_table.entry_size = sizeof (CGEN_IBASE);
+  cd->insn_table.num_init_entries = MAX_INSNS;
+}
+
+/* Subroutine of @arch@_cgen_cpu_open to rebuild the tables.  */
+
+static void
+@arch@_cgen_rebuild_tables (cd)
+     CGEN_CPU_TABLE *cd;
+{
+  int i,n_isas;
+  unsigned int isas = cd->isas;
+#if 0
+  unsigned int machs = cd->machs;
+#endif
+
+  cd->int_insn_p = CGEN_INT_INSN_P;
+
+  /* Data derived from the isa spec.  */
+#define UNSET (CGEN_SIZE_UNKNOWN + 1)
+  cd->default_insn_bitsize = UNSET;
+  cd->base_insn_bitsize = UNSET;
+  cd->min_insn_bitsize = 65535; /* some ridiculously big number */
+  cd->max_insn_bitsize = 0;
+  for (i = 0; i < MAX_ISAS; ++i)
+    if (((1 << i) & isas) != 0)
+      {
+       const CGEN_ISA *isa = & @arch@_cgen_isa_table[i];
+
+       /* Default insn sizes of all selected isas must be equal or we set
+          the result to 0, meaning \"unknown\".  */
+       if (cd->default_insn_bitsize == UNSET)
+         cd->default_insn_bitsize = isa->default_insn_bitsize;
+       else if (isa->default_insn_bitsize == cd->default_insn_bitsize)
+         ; /* this is ok */
+       else
+         cd->default_insn_bitsize = CGEN_SIZE_UNKNOWN;
+
+       /* Base insn sizes of all selected isas must be equal or we set
+          the result to 0, meaning \"unknown\".  */
+       if (cd->base_insn_bitsize == UNSET)
+         cd->base_insn_bitsize = isa->base_insn_bitsize;
+       else if (isa->base_insn_bitsize == cd->base_insn_bitsize)
+         ; /* this is ok */
+       else
+         cd->base_insn_bitsize = CGEN_SIZE_UNKNOWN;
+
+       /* Set min,max insn sizes.  */
+       if (isa->min_insn_bitsize < cd->min_insn_bitsize)
+         cd->min_insn_bitsize = isa->min_insn_bitsize;
+       if (isa->max_insn_bitsize > cd->max_insn_bitsize)
+         cd->max_insn_bitsize = isa->max_insn_bitsize;
+
+       ++n_isas;
+      }
+
+#if 0 /* Does nothing?? */
+  /* Data derived from the mach spec.  */
+  for (i = 0; i < MAX_MACHS; ++i)
+    if (((1 << i) & machs) != 0)
+      {
+       const CGEN_MACH *mach = & @arch@_cgen_mach_table[i];
+
+       ++n_machs;
+      }
+#endif
+
+  /* Determine which hw elements are used by MACH.  */
+  build_hw_table (cd);
+
+  /* Build the ifield table.  */
+  build_ifield_table (cd);
+
+  /* Determine which operands are used by MACH/ISA.  */
+  build_operand_table (cd);
+
+  /* Build the instruction table.  */
+  build_insn_table (cd);
+}
+
+/* Initialize a cpu table and return a descriptor.
+   It's much like opening a file, and must be the first function called.
+   The arguments are a set of (type/value) pairs, terminated with
+   CGEN_CPU_OPEN_END.
+
+   Currently supported values:
+   CGEN_CPU_OPEN_ISAS:    bitmap of values in enum isa_attr
+   CGEN_CPU_OPEN_MACHS:   bitmap of values in enum mach_attr
+   CGEN_CPU_OPEN_BFDMACH: specify 1 mach using bfd name
+   CGEN_CPU_OPEN_ENDIAN:  specify endian choice
+   CGEN_CPU_OPEN_END:     terminates arguments
+
+   ??? Simultaneous multiple isas might not make sense, but it's not (yet)
+   precluded.
+
+   ??? We only support ISO C stdargs here, not K&R.
+   Laziness, plus experiment to see if anything requires K&R - eventually
+   K&R will no longer be supported - e.g. GDB is currently trying this.  */
+
+CGEN_CPU_DESC
+@arch@_cgen_cpu_open (enum cgen_cpu_open_arg arg_type, ...)
+{
+  CGEN_CPU_TABLE *cd = (CGEN_CPU_TABLE *) xmalloc (sizeof (CGEN_CPU_TABLE));
+  static int init_p;
+  unsigned int isas = 0;  /* 0 = \"unspecified\" */
+  unsigned int machs = 0; /* 0 = \"unspecified\" */
+  enum cgen_endian endian = CGEN_ENDIAN_UNKNOWN;
+  va_list ap;
+
+  if (! init_p)
+    {
+      init_tables ();
+      init_p = 1;
+    }
+
+  memset (cd, 0, sizeof (*cd));
+
+  va_start (ap, arg_type);
+  while (arg_type != CGEN_CPU_OPEN_END)
+    {
+      switch (arg_type)
+       {
+       case CGEN_CPU_OPEN_ISAS :
+         isas = va_arg (ap, unsigned int);
+         break;
+       case CGEN_CPU_OPEN_MACHS :
+         machs = va_arg (ap, unsigned int);
+         break;
+       case CGEN_CPU_OPEN_BFDMACH :
+         {
+           const char *name = va_arg (ap, const char *);
+           const CGEN_MACH *mach =
+             lookup_mach_via_bfd_name (@arch@_cgen_mach_table, name);
+
+           machs |= mach->num << 1;
+           break;
+         }
+       case CGEN_CPU_OPEN_ENDIAN :
+         endian = va_arg (ap, enum cgen_endian);
+         break;
+       default :
+         fprintf (stderr, \"@arch@_cgen_cpu_open: unsupported argument `%d'\\n\",
+                  arg_type);
+         abort (); /* ??? return NULL? */
+       }
+      arg_type = va_arg (ap, enum cgen_cpu_open_arg);
+    }
+  va_end (ap);
+
+  /* mach unspecified means \"all\" */
+  if (machs == 0)
+    machs = (1 << MAX_MACHS) - 1;
+  /* base mach is always selected */
+  machs |= 1;
+  /* isa unspecified means \"all\" */
+  if (isas == 0)
+    isas = (1 << MAX_ISAS) - 1;
+  if (endian == CGEN_ENDIAN_UNKNOWN)
+    {
+      /* ??? If target has only one, could have a default.  */
+      fprintf (stderr, \"@arch@_cgen_cpu_open: no endianness specified\\n\");
+      abort ();
+    }
+
+  cd->isas = isas;
+  cd->machs = machs;
+  cd->endian = endian;
+  /* FIXME: for the sparc case we can determine insn-endianness statically.
+     The worry here is where both data and insn endian can be independently
+     chosen, in which case this function will need another argument.
+     Actually, will want to allow for more arguments in the future anyway.  */
+  cd->insn_endian = endian;
+
+  /* Table (re)builder.  */
+  cd->rebuild_tables = @arch@_cgen_rebuild_tables;
+  @arch@_cgen_rebuild_tables (cd);
+
+  /* Default to not allowing signed overflow.  */
+  cd->signed_overflow_ok_p = 0;
+  
+  return (CGEN_CPU_DESC) cd;
+}
+
+/* Cover fn to @arch@_cgen_cpu_open to handle the simple case of 1 isa, 1 mach.
+   MACH_NAME is the bfd name of the mach.  */
+
+CGEN_CPU_DESC
+@arch@_cgen_cpu_open_1 (mach_name, endian)
+     const char *mach_name;
+     enum cgen_endian endian;
+{
+  return @arch@_cgen_cpu_open (CGEN_CPU_OPEN_BFDMACH, mach_name,
+                              CGEN_CPU_OPEN_ENDIAN, endian,
+                              CGEN_CPU_OPEN_END);
+}
+
+/* Close a cpu table.
+   ??? This can live in a machine independent file, but there's currently
+   no place to put this file (there's no libcgen).  libopcodes is the wrong
+   place as some simulator ports use this but they don't use libopcodes.  */
+
+void
+@arch@_cgen_cpu_close (cd)
+     CGEN_CPU_DESC cd;
+{
+  if (cd->insn_table.init_entries)
+    free ((CGEN_INSN *) cd->insn_table.init_entries);
+  if (cd->hw_table.entries)
+    free ((CGEN_HW_ENTRY *) cd->hw_table.entries);
+  free (cd);
+}
+
+")
+)
+
+; General initialization C code
+; Code is appended during processing.
+
+(define -cputab-init-code "")
+(define (cputab-add-init! code)
+  (set! -cputab-init-code (string-append -cputab-init-code code))
+)
+
+; Return the C code to define the various initialization functions.
+; This does not include assembler/disassembler specific stuff.
+; Generally, this function doesn't do anything.
+; It exists to allow a global-static-constructor kind of thing should
+; one ever be necessary.
+
+(define (gen-init-fns)
+  (logit 2 "Generating init fns ...\n")
+  (string-append
+   "\
+/* Initialize anything needed to be done once, before any cpu_open call.  */
+
+static void
+init_tables ()
+{\n"
+   -cputab-init-code
+   "}\n\n"
+  )
+)
+\f
+; Top level C code generators
+
+; FIXME: Create enum objects for all the enums we explicitly declare here.
+; Then they'd be usable and we wouldn't have to special case them here.
+
+(define (cgen-desc.h)
+  (logit 1 "Generating " (current-arch-name) "-desc.h ...\n")
+  (string-write
+   (gen-copyright "CPU data header for @arch@."
+                 CURRENT-COPYRIGHT CURRENT-PACKAGE)
+   "\
+#ifndef @ARCH@_CPU_H
+#define @ARCH@_CPU_H
+
+"
+   -gen-hash-defines
+   ; This is defined in arch.h.  It's not defined here as there is yet to
+   ; be a need for it in the assembler/disassembler.
+   ;(gen-enum-decl 'model_type "model types"
+   ;             "MODEL_"
+   ;             (append (map list (map obj:name (current-model-list))) '((max))))
+   ;"#define MAX_MODELS ((int) MODEL_MAX)\n\n"
+   "/* Enums.  */\n\n"
+   (string-map gen-decl (current-enum-list))
+   "/* Attributes.  */\n\n"
+   (string-map gen-decl (current-attr-list))
+   "/* Number of architecture variants.  */\n"
+   ; If there is only 1 isa, leave out special handling.  */
+   (if (= (length (current-isa-list)) 1)
+       "#define MAX_ISAS  1\n"
+       "#define MAX_ISAS  ((int) ISA_MAX)\n")
+   "#define MAX_MACHS ((int) MACH_MAX)\n\n"
+   gen-ifld-decls
+   gen-hw-decls
+   gen-operand-decls
+   gen-insn-decls
+   "/* cgen.h uses things we just defined.  */\n"
+   "#include \"opcode/cgen.h\"\n\n"
+   -gen-attr-table-decls
+   -gen-mach-table-decls
+   gen-hw-table-decls
+   "\n"
+   (lambda () (gen-extra-cpu.h srcdir (current-arch-name))) ; from <arch>.opc
+   "
+
+#endif /* @ARCH@_CPU_H */
+"
+   )
+)
+
+; This file contains the "top level" definitions of the cpu.
+; This includes various elements of the description file, expressed in C.
+;
+; ??? A lot of this file can go in a machine-independent file!  However,
+; some simulators don't use the cgen opcodes support so there is currently
+; no place to put this file.  To be revisited when we do have such a place.
+
+(define (cgen-desc.c)
+  (logit 1 "Generating " (current-arch-name) "-desc.c ...\n")
+  (string-write
+   (gen-copyright "CPU data for @arch@."
+                 CURRENT-COPYRIGHT CURRENT-PACKAGE)
+   "\
+#include \"sysdep.h\"
+#include <ctype.h>
+#include <stdio.h>
+#include <stdarg.h>
+#include \"ansidecl.h\"
+#include \"bfd.h\"
+#include \"symcat.h\"
+#include \"@prefix@-desc.h\"
+#include \"@prefix@-opc.h\"
+#include \"opintl.h\"
+#include \"libiberty.h\"
+\n"
+   (lambda () (gen-extra-cpu.c srcdir (current-arch-name))) ; from <arch>.opc
+   gen-attr-table-defns
+   -gen-isa-table-defns
+   -gen-mach-table-defns
+   gen-hw-table-defns
+   gen-ifld-defns
+   gen-operand-table
+   gen-insn-table
+   gen-init-fns
+   -gen-cpu-open
+   )
+)
diff --git a/cgen/desc.scm b/cgen/desc.scm
new file mode 100644 (file)
index 0000000..d5ba752
--- /dev/null
@@ -0,0 +1,238 @@
+; General cpu info generator support.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+;
+; This file generates C versions of the more salient parts of the description
+; file.  It's currently part of opcodes or simulator support,
+; and doesn't exist as its own "application" (i.e. user of cgen),
+; though that's not precluded.
+
+; strip-mnemonic?: If each mnemonic is constant, the insn table doesn't need
+; to record them in the syntax field as the mnemonic field also contains it.
+; Furthermore, the insn table can be hashed on complete mnemonic.
+; ??? Should live in <derived-arch-data> or some such.
+
+(define strip-mnemonic? #f)
+\f
+; Attribute support code.
+
+(define (gen-attr-table-defn type attr-list)
+  (string-append
+   "const CGEN_ATTR_TABLE "
+   "@arch@_cgen_" type "_attr_table[] =\n{\n"
+   (string-map (lambda (attr)
+                (gen-obj-sanitize
+                 attr
+                 (string-append "  { "
+                                "\""
+                                (string-upcase (obj:name attr))
+                                "\", "
+                                (if (class-instance? <boolean-attribute> attr)
+                                    "&bool_attr[0], &bool_attr[0]"
+                                    (string-append "& " (gen-sym attr)
+                                                   "_attr[0], & "
+                                                   (gen-sym attr)
+                                                   "_attr[0]"))
+                                " },\n")))
+              attr-list)
+   "  { 0, 0, 0 }\n"
+   "};\n\n")
+)
+
+(define (gen-attr-table-defns)
+  (logit 2 "Generating attribute table defns ...\n")
+  (string-append
+   "\
+/* Attributes.  */
+
+static const CGEN_ATTR_ENTRY bool_attr[] =
+{
+  { \"#f\", 0 },
+  { \"#t\", 1 },
+  { 0, 0 }
+};
+
+"
+   ; Generate tables mapping names to values for all the non-boolean attrs.
+   (string-map gen-defn (current-attr-list))
+   ; Generate tables for each domain (ifld, insn, etc.) mapping attribute type
+   ; to index.
+   (gen-attr-table-defn "ifield" (current-ifld-attr-list))
+   (gen-attr-table-defn "hardware" (current-hw-attr-list))
+   (gen-attr-table-defn "operand" (current-op-attr-list))
+   (gen-attr-table-defn "insn" (current-insn-attr-list))
+   )
+)
+\f
+; HW-ASM is the base class for supporting hardware elements in the opcode table
+; (aka assembler/disassembler).
+
+; Return the C declaration.
+; It is up to a derived class to redefine this as necessary.
+
+(method-make! <hw-asm> 'gen-decl (lambda (self) ""))
+
+; Return the C definition.
+; It is up to a derived class to redefine this as necessary.
+
+(method-make! <hw-asm> 'gen-defn (lambda (self) ""))
+
+(method-make! <hw-asm> 'gen-ref (lambda (self) "0"))
+
+(method-make! <hw-asm> 'gen-init (lambda (self) ""))
+
+(method-make! <hw-asm> 'gen-table-entry (lambda (self) "CGEN_ASM_NONE, 0, "))
+
+; Prefix of global variables describing operand values.
+
+(define hw-asm-prefix "@arch@_cgen_opval_")
+
+; Emit a C reference to a value operand.
+; Usually the operand's details are stored in a struct so in the default
+; case return that struct (?correct?).  The caller must add the "&" if desired.
+
+(define (gen-hw-asm-ref name)
+  (string-append hw-asm-prefix (gen-c-symbol name))
+)
+\f
+; Keyword support.
+
+; Keyword operands.
+; Return the C declaration of a keyword list.
+
+(method-make!
+ <keyword> 'gen-decl
+ (lambda (self)
+   (string-append
+    "extern CGEN_KEYWORD "
+    (gen-hw-asm-ref (elm-get self 'name))
+    ";\n"))
+)
+
+; Return the C definition of a keyword list.
+
+(method-make!
+ <keyword> 'gen-defn
+ (lambda (self)
+   (string-append
+    "static CGEN_KEYWORD_ENTRY "
+    (gen-hw-asm-ref (elm-get self 'name)) "_entries"
+    "[] =\n{\n"
+    (string-drop -2 ; Delete trailing ",\n" [don't want the ,]
+                (string-map (lambda (e)
+                              (string-append
+                               "  { "
+                               "\"" (car e) "\", " ; operand name
+                               (if (string? (cadr e))
+                                   (cadr e)
+                                   (number->string (cadr e))) ; value
+                               ", {0, {0}}, 0, 0"
+                               " },\n"
+                               ))
+                            (elm-get self 'values)))
+    "\n};\n\n"
+    "CGEN_KEYWORD "
+    (gen-hw-asm-ref (elm-get self 'name))
+    " =\n{\n"
+    "  & " (gen-hw-asm-ref (elm-get self 'name)) "_entries[0],\n"
+    "  " (number->string (length (elm-get self 'values))) ",\n"
+    "  0, 0, 0, 0\n"
+    "};\n\n"
+    )
+   )
+)
+
+; Return a reference to a keyword table.
+
+(method-make!
+ <keyword> 'gen-ref
+ (lambda (self) (string-append "& " (gen-hw-asm-ref (elm-get self 'name))))
+)
+
+(method-make!
+ <keyword> 'gen-table-entry
+ (lambda (self)
+   (string-append "CGEN_ASM_KEYWORD, (PTR) " (send self 'gen-ref) ", "))
+)
+
+; Return the C code to initialize a keyword.
+; If the `hash' attr is present, the values are hashed.  Currently this is
+; done by calling back to GAS to have it add the registers to its symbol table.
+; FIXME: Currently unused.  Should be done either in the open routine or
+; lazily upon lookup.
+
+(method-make!
+ <keyword> 'gen-init
+ (lambda (self)
+   (cond ((has-attr? self 'HASH)
+         (string-append
+          "  @arch@_cgen_asm_hash_keywords ("
+          (send self 'gen-ref)
+          ");\n"
+          ))
+        (else ""))
+   )
+)
+\f
+; Operand support.
+
+; Return a reference to the operand's attributes.
+
+(method-make!
+ <operand> 'gen-attr-ref
+ (lambda (self)
+   (string-append "& CGEN_OPERAND_ATTRS (CGEN_SYM (operand_table)) "
+                 "[" (op-enum self) "]"))
+)
+
+; Name of C variable that is a pointer to the fields struct.
+
+(define ifields-var "fields")
+
+; Given FIELD, an `ifield' object, return an lvalue for the operand in
+; IFIELDS-VAR.
+
+(define (gen-operand-result-var field)
+  (string-append ifields-var "->" (gen-sym field))
+)
+\f
+; Basic description init,finish,analyzer support.
+
+; Return a boolean indicating if all insns have a constant mnemonic
+; (ie: no $'s in insn's name in `syntax' field).
+; If constant, one can build the assembler hash table using the entire
+; mnemonic.
+
+(define (constant-mnemonics?)
+  #f ; FIXME
+)
+
+; Initialize any "desc" specific things before loading the .cpu file.
+; N.B. Since "desc" is always a part of another application, that
+; application's init! routine must call this one.
+
+(define (desc-init!)
+  *UNSPECIFIED*
+)
+
+; Finish any "desc" specific things after loading the .cpu file.
+; This is separate from analyze-data! as cpu-load performs some
+; consistency checks in between.
+; N.B. Since "desc" is always a part of another application, that
+; application's finish! routine must call this one.
+
+(define (desc-finish!)
+  *UNSPECIFIED*
+)
+
+; Compute various needed globals and assign any computed fields of
+; the various objects.  This is the standard routine that is called after
+; a .cpu file is loaded.
+; N.B. Since "desc" is always a part of another application, that
+; application's analyze! routine must call this one.
+
+(define (desc-analyze!)
+  (set! strip-mnemonic? (constant-mnemonics?))
+
+  *UNSPECIFIED*
+)
diff --git a/cgen/dev.scm b/cgen/dev.scm
new file mode 100644 (file)
index 0000000..66d1562
--- /dev/null
@@ -0,0 +1,179 @@
+; CGEN Debugging support.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; This file is loaded in during an interactive guile session to
+; develop and debug CGEN.  The user visible procs are:
+;
+; (use-c)
+; (load-opc)
+; (load-sim)
+; (cload #:arch arch #:machs "mach-list" #:isas "isa-list" #:options "options")
+\f
+; First load fixup.scm to coerce guile into something we've been using.
+; Guile is always in flux.
+(load "fixup.scm")
+
+(define srcdir ".")
+
+; Utility to enable/disable compiled-in C code.
+
+(define (use-c) (set! CHECK-LOADED? #t))
+(define (no-c) (set! CHECK-LOADED? #f))
+
+; Also defined in read.scm, but we need it earlier.
+(define APPLICATION 'UNKNOWN)
+
+; Supply the path name and suffic for the .cpu file and delete the analyzer
+; arg from cpu-load to lessen the typing.
+(define (cload . args)
+  (let ((arch #f)
+       (keep-mach "all")
+       (keep-isa "all")
+       (options ""))
+
+    ; Doesn't check if (cadr args) exists or if #:arch was specified, but
+    ; this is a debugging tool!
+    (let loop ((args args))
+      (if (null? args)
+         #f ; done
+         (begin
+           (case (car args)
+             ((#:arch) (set! arch (cadr args)))
+             ((#:machs) (set! keep-mach (cadr args)))
+             ((#:isas) (set! keep-isa (cadr args)))
+             ((#:options) (set! options (cadr args)))
+             (else (error "unknown option:" (car args))))
+           (loop (cddr args)))))
+
+    (case APPLICATION
+      ((UNKNOWN) (error "application not loaded"))
+      ((DESC) (cpu-load (string-append arch ".cpu")
+                       keep-mach keep-isa options
+                       desc-init!
+                       desc-finish!
+                       desc-analyze!))
+      ((OPCODES) (cpu-load (string-append arch ".cpu")
+                          keep-mach keep-isa options
+                          opcodes-init!
+                          opcodes-finish!
+                          opcodes-analyze!))
+      ((GAS-TEST) (cpu-load (string-append arch ".cpu")
+                           keep-mach keep-isa options
+                           gas-test-init!
+                           gas-test-finish!
+                           gas-test-analyze!))
+      ((SIMULATOR) (cpu-load (string-append arch ".cpu")
+                            keep-mach keep-isa options
+                            sim-init!
+                            sim-finish!
+                            sim-analyze!))
+      ((SIM-TEST) (cpu-load (string-append arch ".cpu")
+                           keep-mach keep-isa options
+                           sim-test-init!
+                           sim-test-finish!
+                           sim-test-analyze!))
+      (else (error "unknown application:" APPLICATION))))
+)
+
+; Use the debugging evaluator.
+(if (not (defined? 'DEBUG-EVAL))
+    (define DEBUG-EVAL #t))
+
+; Tell maybe-load to always load the file.
+(if (not (defined? 'CHECK-LOADED?))
+    (define CHECK-LOADED? #f))
+
+(define (load-opc)
+  (load "read")
+  (load "desc")
+  (load "desc-cpu")
+  (load "opcodes")
+  (load "opc-asmdis")
+  (load "opc-ibld")
+  (load "opc-itab")
+  (load "opc-opinst")
+  (set! verbose-level 3)
+  (set! APPLICATION 'OPCODES)
+)
+
+(define (load-gtest)
+  (load-opc)
+  (load "gas-test")
+  (set! verbose-level 3)
+  (set! APPLICATION 'GAS-TEST)
+)
+
+
+(define (load-sim)
+  (load "read")
+  (load "desc")
+  (load "desc-cpu")
+  (load "utils-sim")
+  (load "sim")
+  (load "sim-arch")
+  (load "sim-cpu")
+  (load "sim-model")
+  (load "sim-decode")
+  (set! verbose-level 3)
+  (set! APPLICATION 'SIMULATOR)
+)
+
+(define (load-stest)
+  (load-opc)
+  (load "sim-test")
+  (set! verbose-level 3)
+  (set! APPLICATION 'SIM-TEST)
+)
+
+(display "
+First enable compiled in C code if desired.
+
+(use-c)
+
+Then choose the application via one of:
+
+(load-opc)
+(load-gtest)
+(load-sim)
+(load-stest)
+")
+
+(display "(load-sid)\n")
+
+(display "\
+
+Then load the .cpu file with:
+
+(cload #:arch \"arch\" #:machs \"keep-mach\" #:isas \"keep-isa\" #:options \"options\")
+
+keep-mach:
+comma separated list of machs to keep or `all'
+
+keep-isa:
+comma separated list of isas to keep or `all'
+
+opcode options:
+[none yet]
+
+gas test options:
+[none yet]
+\n")
+
+(display "\
+sim options:
+with-scache
+with-profile=fn
+
+sim test options:
+[none yet]
+\n")
+
+
+; If ~/.cgenrc exists, load it.
+
+(let ((cgenrc (string-append (getenv 'HOME) "/.cgenrc")))
+  (if (file-exists? cgenrc)
+      (load cgenrc))
+)
diff --git a/cgen/doc/Makefile.am b/cgen/doc/Makefile.am
new file mode 100644 (file)
index 0000000..6cfcc78
--- /dev/null
@@ -0,0 +1,17 @@
+## Process this file with automake to generate Makefile.in
+
+AUTOMAKE_OPTIONS = cygnus
+
+info_TEXINFOS = cgen.texi
+
+DOCFILES = app.texi cgen.texi intro.texi notes.texi opcodes.texi \
+       pmacros.texi porting.texi \
+       rtl.texi sim.texi
+
+# version.texi is handled by autoconf/automake
+cgen.info: $(DOCFILES) version.texi
+cgen.dvi: $(DOCFILES) version.texi
+
+# This one isn't ready for prime time yet.  Not even a little bit.
+
+noinst_TEXINFOS = cgen.texi
diff --git a/cgen/doc/Makefile.in b/cgen/doc/Makefile.in
new file mode 100644 (file)
index 0000000..370b224
--- /dev/null
@@ -0,0 +1,335 @@
+# Makefile.in generated automatically by automake 1.4 from Makefile.am
+
+# Copyright (C) 1994, 1995-8, 1999 Free Software Foundation, Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+
+SHELL = @SHELL@
+
+srcdir = @srcdir@
+top_srcdir = @top_srcdir@
+VPATH = @srcdir@
+prefix = @prefix@
+exec_prefix = @exec_prefix@
+
+bindir = @bindir@
+sbindir = @sbindir@
+libexecdir = @libexecdir@
+datadir = @datadir@
+sysconfdir = @sysconfdir@
+sharedstatedir = @sharedstatedir@
+localstatedir = @localstatedir@
+libdir = @libdir@
+infodir = @infodir@
+mandir = @mandir@
+includedir = @includedir@
+oldincludedir = /usr/include
+
+DESTDIR =
+
+pkgdatadir = $(datadir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+
+top_builddir = ..
+
+ACLOCAL = @ACLOCAL@
+AUTOCONF = @AUTOCONF@
+AUTOMAKE = @AUTOMAKE@
+AUTOHEADER = @AUTOHEADER@
+
+INSTALL = @INSTALL@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@ $(AM_INSTALL_PROGRAM_FLAGS)
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+transform = @program_transform_name@
+
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_alias = @build_alias@
+build_triplet = @build@
+host_alias = @host_alias@
+host_triplet = @host@
+target_alias = @target_alias@
+target_triplet = @target@
+EXEEXT = @EXEEXT@
+MAINT = @MAINT@
+MAKEINFO = @MAKEINFO@
+PACKAGE = @PACKAGE@
+VERSION = @VERSION@
+arch = @arch@
+
+AUTOMAKE_OPTIONS = cygnus
+
+info_TEXINFOS = cgen.texi
+
+DOCFILES = app.texi cgen.texi intro.texi notes.texi opcodes.texi \
+       pmacros.texi porting.texi \
+       rtl.texi sim.texi
+
+
+# This one isn't ready for prime time yet.  Not even a little bit.
+
+noinst_TEXINFOS = cgen.texi
+mkinstalldirs = $(SHELL) $(top_srcdir)/../mkinstalldirs
+CONFIG_CLEAN_FILES = 
+TEXI2DVI = `if test -f $(top_srcdir)/../texinfo/util/texi2dvi; then echo $(top_srcdir)/../texinfo/util/texi2dvi; else echo texi2dvi; fi`
+TEXINFO_TEX = $(top_srcdir)/../texinfo/texinfo.tex
+INFO_DEPS = cgen.info
+DVIS = cgen.dvi
+TEXINFOS = cgen.texi
+DIST_COMMON =  Makefile.am Makefile.in stamp-vti version.texi
+
+
+DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) $(TEXINFOS) $(EXTRA_DIST)
+
+TAR = gtar
+GZIP_ENV = --best
+all: all-redirect
+.SUFFIXES:
+.SUFFIXES: .dvi .info .ps .texi .texinfo .txi
+$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ Makefile.am $(top_srcdir)/configure.in $(ACLOCAL_M4) 
+       cd $(top_srcdir) && $(AUTOMAKE) --cygnus doc/Makefile
+
+Makefile: $(srcdir)/Makefile.in  $(top_builddir)/config.status
+       cd $(top_builddir) \
+         && CONFIG_FILES=$(subdir)/$@ CONFIG_HEADERS= $(SHELL) ./config.status
+
+
+$(srcdir)/version.texi: @MAINTAINER_MODE_TRUE@stamp-vti
+       @:
+
+$(srcdir)/stamp-vti: cgen.texi $(top_srcdir)/configure.in
+       @echo "@set UPDATED `$(SHELL) $(top_srcdir)/../mdate-sh $(srcdir)/cgen.texi`" > vti.tmp
+       @echo "@set EDITION $(VERSION)" >> vti.tmp
+       @echo "@set VERSION $(VERSION)" >> vti.tmp
+       @cmp -s vti.tmp $(srcdir)/version.texi \
+         || (echo "Updating $(srcdir)/version.texi"; \
+             cp vti.tmp $(srcdir)/version.texi)
+       -@rm -f vti.tmp
+       @cp $(srcdir)/version.texi $@
+
+mostlyclean-vti:
+       -rm -f vti.tmp
+
+clean-vti:
+
+distclean-vti:
+
+maintainer-clean-vti:
+       -@MAINTAINER_MODE_TRUE@rm -f $(srcdir)/stamp-vti $(srcdir)/version.texi
+
+cgen.info: cgen.texi version.texi
+cgen.dvi: cgen.texi version.texi
+
+
+DVIPS = dvips
+
+.texi.info:
+       @rm -f $@ $@-[0-9] $@-[0-9][0-9]
+       $(MAKEINFO) -I $(srcdir) $<
+
+.texi.dvi:
+       TEXINPUTS=$(top_srcdir)/../texinfo/texinfo.tex:$$TEXINPUTS \
+         MAKEINFO='$(MAKEINFO) -I $(srcdir)' $(TEXI2DVI) $<
+
+.texi:
+       @rm -f $@ $@-[0-9] $@-[0-9][0-9]
+       $(MAKEINFO) -I $(srcdir) $<
+
+.texinfo.info:
+       @rm -f $@ $@-[0-9] $@-[0-9][0-9]
+       $(MAKEINFO) -I $(srcdir) $<
+
+.texinfo:
+       @rm -f $@ $@-[0-9] $@-[0-9][0-9]
+       $(MAKEINFO) -I $(srcdir) $<
+
+.texinfo.dvi:
+       TEXINPUTS=$(top_srcdir)/../texinfo/texinfo.tex:$$TEXINPUTS \
+         MAKEINFO='$(MAKEINFO) -I $(srcdir)' $(TEXI2DVI) $<
+
+.txi.info:
+       @rm -f $@ $@-[0-9] $@-[0-9][0-9]
+       $(MAKEINFO) -I $(srcdir) $<
+
+.txi.dvi:
+       TEXINPUTS=$(top_srcdir)/../texinfo/texinfo.tex:$$TEXINPUTS \
+         MAKEINFO='$(MAKEINFO) -I $(srcdir)' $(TEXI2DVI) $<
+
+.txi:
+       @rm -f $@ $@-[0-9] $@-[0-9][0-9]
+       $(MAKEINFO) -I $(srcdir) $<
+.dvi.ps:
+       $(DVIPS) $< -o $@
+
+install-info-am: $(INFO_DEPS)
+       @$(NORMAL_INSTALL)
+       $(mkinstalldirs) $(DESTDIR)$(infodir)
+       @list='$(INFO_DEPS)'; \
+       for file in $$list; do \
+         if test -f $$file; then d=.; else d=$(srcdir); fi; \
+         for ifile in `cd $$d && echo $$file $$file-[0-9] $$file-[0-9][0-9]`; do \
+           if test -f $$d/$$ifile; then \
+             echo " $(INSTALL_DATA) $$d/$$ifile $(DESTDIR)$(infodir)/$$ifile"; \
+             $(INSTALL_DATA) $$d/$$ifile $(DESTDIR)$(infodir)/$$ifile; \
+           else : ; fi; \
+         done; \
+       done
+       @$(POST_INSTALL)
+       @if $(SHELL) -c 'install-info --version | sed 1q | fgrep -s -v -i debian' >/dev/null 2>&1; then \
+         list='$(INFO_DEPS)'; \
+         for file in $$list; do \
+           echo " install-info --info-dir=$(DESTDIR)$(infodir) $(DESTDIR)$(infodir)/$$file";\
+           install-info --info-dir=$(DESTDIR)$(infodir) $(DESTDIR)$(infodir)/$$file || :;\
+         done; \
+       else : ; fi
+
+uninstall-info:
+       $(PRE_UNINSTALL)
+       @if $(SHELL) -c 'install-info --version | sed 1q | fgrep -s -v -i debian' >/dev/null 2>&1; then \
+         ii=yes; \
+       else ii=; fi; \
+       list='$(INFO_DEPS)'; \
+       for file in $$list; do \
+         test -z "$ii" \
+           || install-info --info-dir=$(DESTDIR)$(infodir) --remove $$file; \
+       done
+       @$(NORMAL_UNINSTALL)
+       list='$(INFO_DEPS)'; \
+       for file in $$list; do \
+         (cd $(DESTDIR)$(infodir) && rm -f $$file $$file-[0-9] $$file-[0-9][0-9]); \
+       done
+
+dist-info: $(INFO_DEPS)
+       list='$(INFO_DEPS)'; \
+       for base in $$list; do \
+         if test -f $$base; then d=.; else d=$(srcdir); fi; \
+         for file in `cd $$d && eval echo $$base*`; do \
+           test -f $(distdir)/$$file \
+           || ln $$d/$$file $(distdir)/$$file 2> /dev/null \
+           || cp -p $$d/$$file $(distdir)/$$file; \
+         done; \
+       done
+
+mostlyclean-aminfo:
+       -rm -f cgen.aux cgen.cp cgen.cps cgen.dvi cgen.fn cgen.fns cgen.ky \
+         cgen.kys cgen.ps cgen.log cgen.pg cgen.toc cgen.tp cgen.tps \
+         cgen.vr cgen.vrs cgen.op cgen.tr cgen.cv cgen.cn
+
+clean-aminfo:
+
+distclean-aminfo:
+
+maintainer-clean-aminfo:
+       for i in $(INFO_DEPS); do \
+         rm -f $$i; \
+         if test "`echo $$i-[0-9]*`" != "$$i-[0-9]*"; then \
+           rm -f $$i-[0-9]*; \
+         fi; \
+       done
+clean-info: mostlyclean-aminfo
+tags: TAGS
+TAGS:
+
+
+distdir = $(top_builddir)/$(PACKAGE)-$(VERSION)/$(subdir)
+
+subdir = doc
+
+distdir: $(DISTFILES)
+       @for file in $(DISTFILES); do \
+         if test -f $$file; then d=.; else d=$(srcdir); fi; \
+         if test -d $$d/$$file; then \
+           cp -pr $$d/$$file $(distdir)/$$file; \
+         else \
+           test -f $(distdir)/$$file \
+           || ln $$d/$$file $(distdir)/$$file 2> /dev/null \
+           || cp -p $$d/$$file $(distdir)/$$file || :; \
+         fi; \
+       done
+       $(MAKE) $(AM_MAKEFLAGS) top_distdir="$(top_distdir)" distdir="$(distdir)" dist-info
+info-am: $(INFO_DEPS)
+info: info-am
+dvi-am: $(DVIS)
+dvi: dvi-am
+check-am:
+check: check-am
+installcheck-am:
+installcheck: installcheck-am
+install-info-am: 
+install-info: install-info-am
+install-exec-am:
+install-exec: install-exec-am
+
+install-data-am:
+install-data: install-data-am
+
+install-am: all-am
+       @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+install: install-am
+uninstall-am:
+uninstall: uninstall-am
+all-am: Makefile
+all-redirect: all-am
+install-strip:
+       $(MAKE) $(AM_MAKEFLAGS) AM_INSTALL_PROGRAM_FLAGS=-s install
+installdirs:
+
+
+mostlyclean-generic:
+
+clean-generic:
+
+distclean-generic:
+       -rm -f Makefile $(CONFIG_CLEAN_FILES)
+       -rm -f config.cache config.log stamp-h stamp-h[0-9]*
+
+maintainer-clean-generic:
+mostlyclean-am:  mostlyclean-vti mostlyclean-aminfo mostlyclean-generic
+
+mostlyclean: mostlyclean-am
+
+clean-am:  clean-vti clean-aminfo clean-generic mostlyclean-am
+
+clean: clean-am
+
+distclean-am:  distclean-vti distclean-aminfo distclean-generic clean-am
+
+distclean: distclean-am
+
+maintainer-clean-am:  maintainer-clean-vti maintainer-clean-aminfo \
+               maintainer-clean-generic distclean-am
+       @echo "This command is intended for maintainers to use;"
+       @echo "it deletes files that may require special tools to rebuild."
+
+maintainer-clean: maintainer-clean-am
+
+.PHONY: mostlyclean-vti distclean-vti clean-vti maintainer-clean-vti \
+install-info-am uninstall-info mostlyclean-aminfo distclean-aminfo \
+clean-aminfo maintainer-clean-aminfo tags distdir info-am info dvi-am \
+dvi check check-am installcheck-am installcheck install-info-am \
+install-info install-exec-am install-exec install-data-am install-data \
+install-am install uninstall-am uninstall all-redirect all-am all \
+installdirs mostlyclean-generic distclean-generic clean-generic \
+maintainer-clean-generic clean mostlyclean distclean maintainer-clean
+
+
+# version.texi is handled by autoconf/automake
+cgen.info: $(DOCFILES) version.texi
+cgen.dvi: $(DOCFILES) version.texi
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/cgen/doc/app.texi b/cgen/doc/app.texi
new file mode 100644 (file)
index 0000000..27142e3
--- /dev/null
@@ -0,0 +1,430 @@
+@c Copyright (C) 2000 Red Hat, Inc.
+@c This file is part of the CGEN manual.
+@c For copying conditions, see the file cgen.texi.
+
+@node Writing an application
+@chapter Writing an application
+@cindex Writing an application
+
+This chapter contains information for those wishing to write their own
+CGEN application.
+
+@menu
+* File Layout::                 Organization of source files
+* File Generation Process::     Workflow in cgen
+* Coding Conventions::          Coding conventions
+* Accessing Loaded Data::       Reading data from loaded .cpu files
+* Name References::             Architecture names in generated code
+* String Building::             Building long strings and writing them out
+* COS::                         Cgen's Object System
+@end menu
+
+@node File Layout
+@section File Layout
+
+Source files in cgen are organized in a very specific way.@footnote{As the
+number of source files grows the entire layout may be changed, but until then
+this is how things are.}  It makes it easy to find things.
+
+@itemize @bullet
+@item top level file is cgen-<app>.scm
+The best way to create this file is to copy an existing application's file
+(e.g. cgen-opc.scm) and modify to suit.
+@item file <app>.scm contains general app-specific utilities
+@item other files are <app>-foo.scm
+@item add entry to dev.scm (load-<app>)
+@end itemize
+
+@node File Generation Process
+@section File Generation Process
+
+This is an overview of cgen workflow.
+
+@itemize @bullet
+
+@item cgen is started with list of files to generate and code generation
+options
+
+@item source code is loaded
+
+@itemize @minus
+@item application independent code is loaded if not compiled in
+@item application specific code is loaded
+
+Currently app-specific code is never compiled in.
+@itemize @minus
+@item doesn't affect speed as much as application independent stuff
+@item subject to more frequent changes
+@item makes it easier to do application development if changes to .scm
+files are "ready to use"
+@end itemize
+@end itemize
+
+@item ultimately procedure `cpu-load' is called which is the main driver for
+loading .cpu files
+
+@item various data structures are initialized
+
+@item data files are loaded
+
+@itemize @minus
+@item main <arch>.cpu file is loaded
+
+There is a #include-like mechanism for loading other files so big
+architectures can be broken up into several files.
+
+While the architecture description is being loaded, entries not requested
+are discarded.  This happens, for example, when building a simulator:
+there's no point in keeping instructions specific to a machine that is
+not being generated.  What to keep is based on the MACH and ISA attributes.
+
+@item application specific data files are loaded
+
+e.g. <arch>.sim
+@end itemize
+
+@item builtin elements are created
+
+@item each requested file is generated by calling cgen-<file> generator
+
+The output is written to the output file with @code{with-output-to-file} so
+the code must write to @code{(current-output-port)}.
+
+Some files require heavy duty processing of the cpu description.
+For example the simulator computes the instruction formats from the
+instruction field lists of each instruction.  This computation is defered
+to each cgen-<file> procedure that needs it and must be explicitly requested
+by them.  The results are cached so this is only done once of course.
+
+@item additional processing for some opcodes files
+
+Several opcodes files are built from three sources.
+
+@itemize @minus
+@item generated code
+
+@item section in <arch>.opc file
+
+It's not appropriate to put large amounts of C (or perhaps any C) in
+cgen description files, yet some things are best expressed in some
+other language (e.g. assembler/disassembler operand parsing/printing).
+
+@item foo.in file
+
+It seems cleaner to put large amounts of non-machine-generated C
+in separate files from code generator.
+@end itemize
+
+@end itemize
+
+@node Coding Conventions
+@section Coding Conventions
+
+@itemize @bullet
+@item unless definition occupies one line, final trailing parenthesis is on
+a line by itself beginning in column one
+@item definitions internal to a source file begin with '-'
+@item global state variables are named *foo-bar*
+[FIXME: current code needs updating]
+@item avoid uppercase (except for ???)
+@item procedures that return a boolean result end in '?'
+@item procedures that modify something end in '!'
+@item classes are named <name>
+@end itemize
+
+@node Accessing Loaded Data
+@section Accessing Loaded Data
+
+Each kind of description file entry (defined with `define-foo') is recorded
+in an object of class <foo>.@footnote{not true for <arch> but will be RSN}
+All the data is collected together in an object of class
+<system>.@footnote{got a better name?}
+@footnote{modes aren't recorded here, should they be?}
+
+Data for the currently selected architecture is obtained with several
+access functions.
+
+@smallexample
+  (current-arch-name)
+  - return symbol that is the name of the arch
+  - this is the name specified with `define-arch'
+
+  (current-arch-comment)
+  - return the comment specified with `define-arch'
+
+  (current-arch-atlist)
+  - return the attributes specified with `define-arch'
+
+  (current-arch-default-alignment)
+  - return a symbol indicated the default aligment
+    - one of aligned, unaligned, forced
+
+  (current-arch-insn-lsb0?)
+  - return a #t if the least significant bit in a word is numbered 0
+  - return a #f if the most significant bit in a word is numbered 0
+
+  (current-arch-mach-name-list)
+  - return a list of names (as symbols) of all machs in the architecture
+
+  (current-arch-isa-name-list)
+  - return a list of names (as symbols) of all isas in the architecture
+
+  - for most of the remaining elements, there are three main accessors
+    [foo is sometimes abbreviated]
+    - current-foo-list - returns list of <foo> objects in the architecture
+    - current-foo-add! - add a <foo> object to the architecture
+    - current-foo-lookup - lookup the <foo> object based on its name
+
+  <atlist>
+  (current-attr-list)
+  (current-attr-add!)
+  (current-attr-lookup)
+
+  <enum>
+  (current-enum-list)
+  (current-enum-add!)
+  (current-enum-lookup)
+
+  <keyword>
+  (current-kw-list)
+  (current-kw-add!)
+  (current-kw-lookup)
+
+  <isa>
+  (current-isa-list)
+  (current-isa-add!)
+  (current-isa-lookup)
+
+  <cpu>
+  (current-cpu-list)
+  (current-cpu-add!)
+  (current-cpu-lookup)
+
+  <mach>
+  (current-mach-list)
+  (current-mach-add!)
+  (current-mach-lookup)
+
+  <model>
+  (current-model-list)
+  (current-model-add!)
+  (current-model-lookup)
+
+  <hardware>
+  (current-hw-list)
+  (current-hw-add!)
+  (current-hw-lookup)
+
+  <ifield>
+  (current-ifld-list)
+  (current-ifld-add!)
+  (current-ifld-lookup)
+
+  <operand>
+  (current-op-list)
+  (current-op-add!)
+  (current-op-lookup)
+
+  <insn>
+  (current-insn-list)
+  (current-insn-add!)
+  (current-insn-lookup)
+
+  <macro-insn>
+  (current-minsn-list)
+  (current-minsn-add!)
+  (current-minsn-lookup)
+
+  (current-ifmt-list)
+  - return list of computed <iformat> objects
+
+  (current-sfmt-list)
+  - return list of computed <sformat> objects
+
+  [there are a few more to be documented, not sure they'll remain as is]
+@end smallexample
+
+@node Name References
+@section Name References
+
+To simplify writing code generators, system names can be
+specified with fixed strings rather than having to compute them.
+The output is post-processed to convert the strings to the actual names.
+Upper and lower case names are supported.
+
+@itemize @bullet
+@item For the architecture name use @@arch@@, @@ARCH@@.
+@item For the cpu family name use @@cpu@@, @@CPU@@.
+@item For the prefix use @@prefix@@, @@PREFIX@@.
+@end itemize
+
+The @samp{prefix} notion is to segregate different code for the same
+cpu family.  For example, this is used to segregate the ARM ISA from the
+Thumb ISA.
+
+@node String Building
+@section String Building
+
+Output generation uses a combination of writing text out as it is computed
+and building text for later writing out.
+
+The top level file generator uses @code{string-write}.  It takes string-lists
+and thunks as arguments and writes each argument in turn to stdout.
+String-lists are lists of strings (nested arbitrarily deep).  It's cheaper
+to @code{cons} long strings together than to use @code{string-append}.
+Thunks return string-lists to write out, but isn't computed until all
+preceeding arguments to `string-write' have been written out.  This allows
+defering building up of large amounts of text until it needs to be.
+
+The main procedures for building strings and writing them out are:
+
+@itemize @bullet
+
+@item (string-write string-list-or-thunk1 string-list-or-thunk2 ...)
+
+Loops over arguments writing them out in turn.
+
+@item (string-write-map proc string-list-or-thunk-list)
+
+Apply proc to each element in string-list-or-thunk-list and write out
+the result.
+
+@item (string-list arg1 arg2 ...)
+
+Return list of arguments.  This is identical to @code{list} except it
+is intended to take string-lists as arguments.
+
+@item (string-list-map proc arg-list)
+
+Return list of @code{proc} applied to each element of @code{arg-list}.
+This is identical to @code{map} except it is intended to take strings
+as arguments.
+
+@item (string-append string1 string2 ...)
+
+For small arguments it's just as well to use @code{string-append}.
+This is a standard Scheme procedure.  The output is also easier to read
+when developing interactively.  And some subroutines are used in multiple
+contexts including some where strings are required.
+
+@end itemize
+
+@node COS
+@section COS
+
+COS is Cgen's Object System.  It's a simple OO system for Guile that
+was written to provide something useful until Guile had its own.
+COS will be replaced with GOOPs if the Scheme implementation of cgen is kept.
+
+The pure Scheme implementation of COS uses vectors to record objects and
+classes.  The C implementation uses smobs (though classes are still
+implemented with vectors).
+
+A complete list of user-visible functions is at the top of @file{cos.scm}.
+
+Here is a list of the frequently used ones.
+
+@itemize @bullet
+
+@item (class-make name parent-name-list element-list method-list)
+
+Use @code{class-make} to define a class.
+
+@smallexample
+name: symbol, <name-of-class>
+parent-name-list: list of symbols, names of each parent class
+element-list: list of either symbols or (symbol . initial-value)
+method-list: list of (symbol . lambda)
+@end smallexample
+
+The result is the class's definition.  It is usually assigned to a global
+variable with same name as class's name.  Current cgen code always does
+this.  It's not a requirement but it is convention.
+
+@item (new <class-name>)
+
+Create a new object with @code{new}.
+@code{<class-name>} is typically the global variable that recorded
+the results of @code{class-make}.  The result is a new object of the
+requested class.  Class elements have either an "undefined" value
+or an initial value if one was specified when the class was defined.
+
+@item (define-getters class-name prefix element-list)
+
+Elements (aka members) are read/written with "accessors".
+Read accessors are defined with @code{define-getters}, which
+creates one procedure for each element, each defined as
+@code{(prefix-element-name object)}.
+
+This is a macro so don't quote anything.
+
+@item (define-setters class-name prefix element-list)
+
+Write accessors are defined with @code{define-setters}, which
+creates one procedure for each element, each defined as
+@code{(prefix-set-element-name! object new-value)}.
+
+This is a macro so don't quote anything.
+
+@item (elm-get object elm-name)
+
+This can only be used in method definitions (blech, blah blah blah).
+
+@item (elm-set! object elm-name new-value)
+
+This can only be used in method definitions (blech, blah blah blah).
+
+@item (send object method-name arg1 arg2)
+
+Invoke method @code{method-name} on @code{object}.
+
+The convention is to put this in a cover fn:
+@code{(class-name-method-name object arg1 arg2)}.
+
+@item (send-next object method-name arg1 arg2)
+
+Same as @code{send} except only usable in methods and is used to invoke
+the method in the parent class.
+
+@item (make object . args)
+
+One standard way to create a new object is with @code{make}.
+It is a wrapper, defined as
+
+@smallexample
+(define (make object . args)
+  (apply send (cons (new object) (cons 'make! args)))
+)
+@end smallexample
+
+@item (vmake class . args)
+
+The other standard way to create objects is with @code{vmake}.
+
+@code{args} is a list of option names and arguments.
+
+??? Not completely implemented yet.
+
+@item (method-make! class method-name lambda)
+
+The normal way of creating methods is to use @code{method-make!}, not define
+them with the class.  It's just easier to define them separately.
+
+@item (method-make-virtual! class method-name lambda)
+
+Create virtual methods created with @code{method-make-virtual!}.
+
+@item (method-make-forward! class elm-name methods) -> unspecified
+
+Forwarding a method invocation on one object to another is extremely
+useful so some utilities have been created to simplify creating forwarding
+methods.
+
+@code{methods} is a list of method names.  A method is created for each one
+that forwards the method onto the object contained in element ELM-NAME.
+
+@item (method-make-virtual-forward!)
+
+Same as method-make-forward! except that it creates virtual methods.
+
+@end itemize
diff --git a/cgen/doc/cgen.texi b/cgen/doc/cgen.texi
new file mode 100644 (file)
index 0000000..5b6b54d
--- /dev/null
@@ -0,0 +1,118 @@
+\input texinfo       @c                    -*- Texinfo -*-
+@setfilename cgen.info
+
+@include version.texi
+
+@ifinfo
+@format
+START-INFO-DIR-ENTRY
+* Cgen: (cgen).                 The Cpu tools GENerator.
+END-INFO-DIR-ENTRY
+@end format
+@end ifinfo
+
+@ifinfo
+Copyright @copyright{} 2000 Red Hat, Inc.
+
+Permission is granted to make and distribute verbatim copies of
+this manual provided the copyright notice and this permission notice
+are preserved on all copies.
+
+@ignore
+Permission is granted to process this file through TeX and print the
+results, provided the printed document carries a copying permission
+notice identical to this one except for the removal of this paragraph
+(this paragraph not being relevant to the printed manual).
+
+@end ignore
+
+Permission is granted to copy and distribute modified versions of this
+manual under the conditions for verbatim copying, provided also that
+the entire resulting derived work is distributed under the terms of a
+permission notice identical to this one.
+
+Permission is granted to copy and distribute translations of this manual
+into another language, under the above conditions for modified versions.
+@end ifinfo
+
+@synindex ky cp
+@c
+@c This file documents the Cpu tools GENerator, CGEN.
+@c
+@c Copyright (C) 2000 Red Hat, Inc.
+@c
+
+@setchapternewpage odd
+@settitle CGEN
+@titlepage
+@finalout
+@title The Cpu tools GENerator, CGEN.
+@subtitle Version @value{VERSION}
+@sp 1
+@subtitle @value{UPDATED}
+@author Douglas J. Evans
+@author Red Hat, Inc.
+@page
+
+@tex
+{\parskip=0pt \hfill Red Hat\par \hfill
+\TeX{}info \texinfoversion\par }
+@end tex
+
+@vskip 0pt plus 1filll
+Copyright @copyright{} 2000 Red Hat, Inc.
+
+Permission is granted to make and distribute verbatim copies of
+this manual provided the copyright notice and this permission notice
+are preserved on all copies.
+
+Permission is granted to copy and distribute modified versions of this
+manual under the conditions for verbatim copying, provided also that
+the entire resulting derived work is distributed under the terms of a
+permission notice identical to this one.
+
+Permission is granted to copy and distribute translations of this manual
+into another language, under the above conditions for modified versions.
+@end titlepage
+
+@node Top
+@top Introduction
+
+@cindex version
+This brief manual contains preliminary documentation for the CGEN program,
+version @value{VERSION}.
+
+@menu
+* Introduction::                Introduction
+* Running CGEN::               How to run CGEN
+* RTL::                         The Register Transfer Language CGEN uses
+* Preprocessor macros::         Macros to simplify description file writing
+* Porting::                     Porting
+* Opcodes::                     Assembler/disassembler support
+* Simulation::                  Simulation support
+* Writing an application::      Writing your own CGEN application
+* Glossary::                    Glossary
+* Miscellaneous notes::         Notes needing a better home
+* Credits::                    Credits
+* Index::                       Index
+@end menu
+
+@include intro.texi
+@include running.texi
+@include rtl.texi
+@include pmacros.texi
+@include porting.texi
+@include opcodes.texi
+@include sim.texi
+@include app.texi
+@include glossary.texi
+@include notes.texi
+@include credits.texi
+
+@node Index
+@unnumbered Index
+
+@printindex cp
+
+@contents
+@bye
diff --git a/cgen/doc/credits.texi b/cgen/doc/credits.texi
new file mode 100644 (file)
index 0000000..91d6e31
--- /dev/null
@@ -0,0 +1,27 @@
+@c Copyright (C) 2000 Red Hat, Inc.
+@c This file is part of the CGEN manual.
+@c For copying conditions, see the file cgen.texi.
+
+@node Credits
+@chapter Credits
+
+The following people, listed in alphabetical order, have helped in their own
+way.  Thanks!
+
+@itemize @minus
+@item Dave Brolley
+@item Andrew Cagney
+@item Steve Chamberlain
+@item Nick Clifton
+@item Bob Cmelik
+@item Frank Ch. Eigler
+@item Ben Elliston
+@item Kim Knuttila
+@item Ken Raeburn
+@item Jim Wilson
+@end itemize
+
+There's a TV program I watched growing up called ``The Hilarious House
+Of Frightenstein''.  The credits at the end had a twist in that Billy
+Van, who played most of the characters, appeared in them again and
+again.  I would do the same here for Ian Lance Taylor.
diff --git a/cgen/doc/glossary.texi b/cgen/doc/glossary.texi
new file mode 100644 (file)
index 0000000..932efec
--- /dev/null
@@ -0,0 +1,29 @@
+@c Copyright (C) 2000 Red Hat, Inc.
+@c This file is part of the CGEN manual.
+@c For copying conditions, see the file cgen.texi.
+
+@node Glossary
+@chapter Glossary
+
+@table @asis
+@item arch
+This is the overall architecture.  It is the same as BFD's use of
+@emph{arch}.
+
+@item isa
+Acronym for Instruction Set Architecture.
+
+@item mach
+This is a variant of the architecture, short for machine. It is
+essentially the same as BFD's use of @emph{mach}.
+
+@item CPU family
+A group of related mach's.  Simulator support is organized along ``CPU
+family'' lines to keep related mach's together under one roof to
+simplify things.  The organization is semi-arbitrary and is up to the
+programmer.
+
+@item model
+An implementation of a mach.  It is essentially akin to the argument
+to @code{-mtune=} in SPARC GCC (and other GCC ports).
+@end table
diff --git a/cgen/doc/internals.texi b/cgen/doc/internals.texi
new file mode 100644 (file)
index 0000000..381c41d
--- /dev/null
@@ -0,0 +1,377 @@
+\input texinfo       @c                    -*- Texinfo -*-
+
+@c This file is work in progress.
+@c Don't expect it to go through texinfo just yet. --bje
+
+@include version.texi
+
+@ifinfo
+Copyright @copyright{} 2000 Red Hat, Inc.
+
+Permission is granted to make and distribute verbatim copies of
+this manual provided the copyright notice and this permission notice
+are preserved on all copies.
+
+@ignore
+Permission is granted to process this file through TeX and print the
+results, provided the printed document carries a copying permission
+notice identical to this one except for the removal of this paragraph
+(this paragraph not being relevant to the printed manual).
+
+@end ignore
+
+Permission is granted to copy and distribute modified versions of this
+manual under the conditions for verbatim copying, provided also that
+the entire resulting derived work is distributed under the terms of a
+permission notice identical to this one.
+
+Permission is granted to copy and distribute translations of this manual
+into another language, under the above conditions for modified versions.
+@end ifinfo
+
+@synindex ky cp
+@c
+@c This file documents the internals of the Cpu tools GENerator, CGEN.
+@c
+@c Copyright (C) 2000 Red Hat, Inc.
+@c
+
+@setchapternewpage odd
+@settitle CGEN
+@titlepage
+@finalout
+@title The Cpu tools GENerator, CGEN.
+@subtitle Version @value{VERSION}
+@sp 1
+@subtitle @value{UPDATED}
+@author Ben Elliston
+@author Red Hat, Inc.
+@page
+
+@tex
+{\parskip=0pt \hfill Red Hat, Inc.\par \hfill
+\TeX{}info \texinfoversion\par }
+@end tex
+
+@vskip 0pt plus 1filll
+Copyright @copyright{} 2000 Red Hat, Inc.
+
+Permission is granted to make and distribute verbatim copies of
+this manual provided the copyright notice and this permission notice
+are preserved on all copies.
+
+Permission is granted to copy and distribute modified versions of this
+manual under the conditions for verbatim copying, provided also that
+the entire resulting derived work is distributed under the terms of a
+permission notice identical to this one.
+
+Permission is granted to copy and distribute translations of this manual
+into another language, under the above conditions for modified versions.
+@end titlepage
+
+@node Top
+@top Introduction
+
+@cindex version
+This manual documents the internals of CGEN, version @value{VERSION}.
+
+@menu
+* Introduction::                Introduction
+* Guile::
+* Conventions::                 Coding conventions
+* Applications::
+* Source file overview::
+* Option processing::
+* Parsing::
+* Version numbering::
+* Glossary::                    Glossary
+* Index::                       Index
+@end menu
+
+@node Introduction
+@chapter Introduction
+
+This document details the implementation and internals of CGEN, the
+``Cpu tools GENerator''.  It focuses on theory of operation and concepts
+rather than extensive details of the implementation--these details
+date too quickly.
+
+@node Conventions
+@chapter Conventions
+
+There are a number of conventions used in the cgen source code.  If you
+take the time to absorb these now, the code will be much easier to
+understand.
+
+@itemize @bullet
+@item Procedures and variables local to a file are named @code{-foo}.
+@item Only routines that emit application code begin with @code{gen-}.
+@item Symbols beginning with @code{c-} are either variables containing C code
+      or procedures that generate C code, similarily for C++ and @code{c++-}.
+@item Variables containing C code begin with @code{c-}.
+@item Only routines that emit an entire file begin with @code{cgen-}.
+@item All @file{.cpu} file elements shall have @code{-foo-parse} and
+      @code{-foo-read} procedures.
+@item Global variables containing class definitions shall be named
+      @code{<class-name>}.
+@item Procedures related to a particular class shall be named
+      @code{class-name-proc-name}, where @code{class-name} may be abbreviated.
+@item Procedures that test whether something is an object of a
+      particular class shall be named @code{class-name?}.
+@item In keeping with Scheme conventions, predicates shall have a
+      @code{?} suffix.
+@item In keeping with Scheme conventions, methods and procedures that
+      modify an argument or have other side effects shall have a
+      @code{!} suffix, usually these procs return @code{*UNSPECIFIED*}.
+@item All @code{-foo-parse}, @code{parse-foo} procs shall have @code{context}
+      as the first argument. [FIXME: not all such procs have been
+      converted]
+@end itemize
+
+@node Applications
+@chapter Applications
+
+One of the most importance concepts to grasp with CGEN is that it is not
+a simulator generator.  It's a generic tool generator--it can be used to
+generate a simulator, an assembler, a disassembler and so on.  These
+``applications'' can then produce different outputs from the same CPU
+description.
+
+When you want to run the cgen framework, an application-specific source
+file is loaded into the Guile interpreter to get cgen running.  This
+source file loads in any other source files it needs and then, for
+example, calls:
+
+@example
+    (cgen #:argv argv
+         #:app-name "sim"
+         #:arg-spec sim-arguments
+         #:init sim-init!
+         #:finish sim-finish!
+         #:analyze sim-analyze!)
+    )
+@end example
+
+This gets the whole framework started, in an application-specific way.
+
+node Source file overview
+@chapter Source file overview
+
+@table @file
+
+@item *.cpu, *.opc, *.sim
+Files belonging to each CPU description.  .sim files are automatically
+included if they are defined for the given architecture.
+
+@item doc/*.texi
+Texinfo documentation for cgen.
+
+@item slib/*.scm
+Third-party libraries written in Scheme.  For example, sort.scm is a
+collection of procedures to sort lists.
+
+@item Makefile.am
+automake Makefile for cgen.
+
+@item NEWS
+News about cgen.
+
+@item README
+Notes to read abot cgen.
+
+@item attr.scm
+Handling of cgen attributes.
+
+@item cgen-gas.scm
+Top-level for GAS testsuite generation.
+
+@item cgen-opc.scm
+Top-level for opcodes generation.
+
+@item cgen-sid.scm
+Top-level for SID simulator generation.
+@item cgen-sim.scm
+Top-level for older simulator generation.
+
+@item cgen-stest.scm
+Top-level for simulator testsuite generation.
+
+@item configure.in
+Template for `configure'--process with autoconf.
+
+@item cos.scm
+cgen object system.  Adds object oriented features to the Scheme
+language.  See the top of @file{cos.scm} for the user-visible
+procedures.
+
+@item decode.scm
+Generic decoder routines.
+
+@item desc-cpu.scm
+???
+
+@item desc.scm
+???
+
+@item dev.scm
+Debugging support.
+
+@item enum.scm
+Enumerations.
+
+@item fixup.scm
+Some procedure definitions to patch up possible differences between
+older and newer versions of Guile:
+
+  * define a (load..) procedure that uses
+    primitive-load-path if load-from-path is not known.
+
+  * define =? and >=? if they aren't already known.
+
+  * define %stat, reverse! and debug-enable in terms of
+    older equivalent procedures, if they aren't already
+    known.
+
+@item gas-test.scm
+GAS testsuite generator.
+
+@item hardware.scm
+Hardware description routines.
+
+@item ifield.scm
+Instruction fields.
+
+@item insn.scm
+Instruction defintions.
+
+@item mach.scm
+Architecture description routines.
+
+@item minsn.scm
+Macro instructions.
+
+@item mode.scm
+Modes.
+
+@item model.scm
+Model specification.
+
+@item opc-asmdis.scm
+For the opcodes applications.
+
+@item opc-ibld.scm
+Ditto.
+
+@item opc-itab.scm
+Ditto.
+
+@item opc-opinst.scm
+Ditto.
+
+@item opcodes.scm
+Ditto.
+
+@item operand.scm
+Operands.
+
+@item pgmr-tools.scm
+Programmer tools--debugging tools, mainly.
+
+@item pmacros.scm
+Preprocessor macros.
+
+@item profile.scm
+Unused?
+
+@item read.scm
+Read and parse .cpu files.  @code{maybe_load} is used to load in files
+for required symbols if they are not already present in the environment
+(say, because it was compiled).
+
+@item rtl-c.scm
+RTL to C translation.
+
+@item rtl.scm
+RTL support.
+
+@item rtx-funcs.scm
+RTXs.
+
+@item sem-frags.scm
+Semantic fragments.
+
+@item semantics.scm
+Semantic analysis for the CPU descriptions.
+
+@item sid-cpu.scm
+For the SID application.
+
+@item sid-decode.scm
+Ditto.
+
+@item sid-model.scm
+Ditto.
+
+@item sid.scm
+Ditto.
+
+@item sim-arch.scm
+For the simulator application.
+
+@item sim-cpu.scm
+Ditto.
+
+@item sim-decode.scm
+Ditto.
+
+@item sim-model.scm
+Ditto.
+
+@item sim-test.scm
+For the simulator testsuite application.
+
+@item sim.scm
+For the simulator application.
+
+@item simplify.inc
+Preprocessor macros to simplify CPU description files.  This file is not
+loaded by the Scheme interpreter, but is instead included by the .cpu
+file.
+
+@item types.scm
+Low-level types.
+
+@item utils-cgen.scm
+cgen-specific utilities.
+
+@item utils-gen.scm
+Code generation specific utilities.
+
+@item utils-sim.scm
+Simulator specific utilities.
+
+@item utils.scm
+Miscellaneous utilities.
+
+@end table
+
+@code{cgen} is the main entry point called by application file
+generators. It just calls @code{-cgen}, but it does so wrapped inside a
+@code{catch-with-backtrace} procedure to make debugging easier.
+
+@node Version numbering
+@chapter Version numbering
+
+There are two version numbers: the version number of cgen itself and a
+version number for the description language it accepts.  These are kept
+in the symbols @code{-CGEN-VERSION} and @code{-CGEN-LANG-VERSION} in
+@file{read.scm}.
+
+@node Index
+@unnumbered Index
+
+@printindex cp
+
+@contents
+@bye
diff --git a/cgen/doc/intro.texi b/cgen/doc/intro.texi
new file mode 100644 (file)
index 0000000..76b6851
--- /dev/null
@@ -0,0 +1,759 @@
+@c Copyright (C) 2000 Red Hat, Inc.
+@c This file is part of the CGEN manual.
+@c For copying conditions, see the file cgen.texi.
+
+@node Introduction
+@comment  node-name,  next,  previous,  up
+@chapter Introduction to CGEN
+
+@menu
+* Overview::
+* CPU description language::
+* Opcodes support::
+* Simulator support::
+* Testing support::
+* Implementation language::
+@end menu
+
+@node Overview
+@section Overview
+
+CGEN is a project to provide a framework and toolkit for writing cpu tools.
+
+@menu
+* Goal::                        What CGEN tries to achieve.
+* Why do it?::
+* Maybe it should not be done?::
+* How ambitious is CGEN?::
+* What is missing that should be there soon?::
+@end menu
+
+@node Goal
+@subsection Goal
+
+The goal of CGEN (pronounced @emph{seejen}, and short for
+"Cpu tools GENerator") is to provide a uniform framework and toolkit
+for writing programs like assemblers, disassemblers, and
+simulators without explicitly closing any doors on future things one
+might wish to do.  In the end, its scope is the things the software developer
+cares about when writing software for the cpu (compilation, assembly,
+linking, simulation, profiling, debugging, ???).
+
+Achieving the goal is centered around having an application independent
+description of a CPU (plus environment, like ABI) that applications can then
+make use of.  In the end that's a lot to ask for from one language.  What
+applications can or should be able to use CGEN is left to evolve over time.
+The description language itself is thus also left to evolve over time!
+
+Achieving the goal also involves having a toolkit, libcgen, that contains
+a compiled form of the cpu description plus a suite of routines for working
+with the data.
+
+CGEN is not a new idea.  Some GNU ports have done something like this --
+for example, the SH port in its early days.  However, the idea never really
+``caught on''.  CGEN was started because I think it should.
+
+Since CGEN is a very ambitious project, there are currently lots of
+things that aren't written down, let alone implemented.  It will take
+some time to flush all the details out, but in and of itself that doesn't
+necessarily mean they can't be flushed out, or that they haven't been
+considered.
+
+@node Why do it?
+@subsection Why do it?
+
+I think it is important that GNU assembler/disassembler/simulator ports
+be done from a common framework.  On some level it's fun doing things
+from scratch, which was and still is to a large extent current
+practice, but this is not the place for that.
+
+@itemize @bullet
+@item the more ports of something one has, the more important it is that they
+be the same.
+
+@item the more complex each of them become, the more important it is
+that they be the same.
+
+@item if they all are the same, a feature added to one is added to all
+of them--within the context of their similarity, of course.
+
+@item with a common framework in place the planning of how to architect
+a port is taken care of, the main part of what's left is simply writing
+the CPU description.
+
+@item the more applications that use the common framework, the fewer
+places the data needs to be typed in and maintained.
+
+@item new applications can take advantage of data and utilities that
+already exist.
+
+@item a common framework provides a better launching point for bigger things.
+@end itemize
+
+@node Maybe it should not be done?
+@subsection Maybe it should not be done?
+
+However, no one has yet succeeded in pushing for such an extensive common
+framework.@footnote{I'm just trying to solicit input here.  Maybe these
+questions will help get that input.}
+
+@itemize @bullet
+@item maybe people think it's not worth it?
+
+@item maybe they just haven't had the inclination to see it through?
+(where ``inclination'' includes everything from the time it would take
+to the dealing with the various parties whose turf you would tread on)
+
+@item maybe in the case of assemblers and simulators they're not complex
+enough to see much benefit?
+
+@item maybe the resulting tight coupling among the various applications
+will cause problems that offset any gains?
+
+@item maybe there's too much variance to try to achieve a common
+framework, so that all attempts are doomed to become overly complex?
+
+@item as a corollary of the previous item, maybe in the end trying to
+combine ISA syntax (the assembly language), with ISA semantics (simulation),
+with architecture implementation (performance), would become overly complex?
+@end itemize
+
+@node How ambitious is CGEN?
+@subsection How ambitious is CGEN?
+
+CGEN is a very ambitious project, as future projects can be:
+
+@menu
+* More complicated simulators::
+* Profiling tools::
+* Program analysis tools::
+* ABI description::
+* Machine generated architecture reference material::
+* Tools like what NJMCT provides::
+* Input to a compiler's backend::
+* Hardware/software codesign::
+@end menu
+
+@node More complicated simulators
+@subsubsection More complicated simulators
+
+Current CGEN-based simulators achieve their speed by using GCC's
+"computed goto" facility to implement a threaded interpreter.
+The "main loop" of the cpu engine is contained within one function
+and the administrivia of running the program is reduced to about three
+host instructions per target instruction (one to increment a "virtual pc",
+one to fetch the address of code that implements that next target instruction,
+and one to branch to it).  Target instructions can be simulated with as few as
+seven@footnote{Actually, this can be reduced even more by creating copies of
+an instruction specialized for all the various inputs.} instructions for an
+"add" (load address of src1, load src1, load address of src2, load src2, add,
+load address of result, store result).  So ignoring overhead (which
+is minimal for frequently executed code) that's ten host instructions per
+"typical" target instruction.  Pretty good.@footnote{The actual results
+depend, of course, on the exact mix of target instructions in the application,
+what instructions the host cpu has, and how efficiently the rest of the
+simulator is (e.g. floating point and memory operations can require a hundred
+or more host instructions).}
+
+However, things can still be better.  There is still some implementation
+related overhead that can be removed.  The two instructions to branch
+to the next instruction would be unnecessary if instruction executors
+were concatenated together.  The fetching and storing of target registers
+can be reduced if target registers were kept in host registers across
+instruction boundaries (and the longer one can keep them in host registers
+the better).  A consequence of both of these improvements is the number
+of memory operations is drastically reduced.  There isn't a lot of ILP
+in the simulation of target instructions to hide memory latencies.
+Another consequence of these improvements is the opportunity to perform
+inter-target-instruction scheduling of the host instructions and other
+optimizations.
+
+There are two ways to achieve these improvements.  Both involve converting
+basic blocks (or superblocks) in the target application into the host
+instruction set and compiling that.  The first way involves doing this
+"offline".  The target program is analyzed and each instruction is converted
+into, for example, C code that implements the instruction.  The result is
+compiled and then the new version of the target program is run.
+
+The second way is to do the translation from target instruction set to
+host instruction set while the target program is running.  This is often
+refered to as JIT (Just In Time) simulation (FIXME: proper phrasing here?).
+One way to implement this is to simulate instructions the way existing
+CGEN simulators do, but keep track of how frequently a basic block is
+executed.  If a block gets executed often enough, then compile a translation
+of it to the host instruction set and switch to using that.  This avoids
+the overhead of doing the compilation on code that is rarely executed.
+Note that here is one place where a dual cpu system can be put to good use.
+One cpu handles the simulation and the other handles compilation (translating
+target instructions to host instructions).
+CGEN can@footnote{This hasn't actually been implemented so there is
+some hand waving here.} handle a large part of building the JIT compiler
+because both host and target architectures are recorded in a way that is
+amenable to program manipulation.
+
+A hybrid of these two ways is to translate target basic blocks to
+C code, compile it, and dynamically load the result into the running
+simulation.  Problems with this are that one must invoke an external program
+(though one could dynamically load a special form of C compiler I suppose)
+and there's a lot of overhead parsing and optimizing the C code.  On the
+other hand one gets to take full advantage of the compiler's optimization
+technology.  And if the application takes a long time to simulate, the
+extra cost may be worthwhile.  A dual cpu system is of benefit here too.
+
+@node Profiling tools
+@subsubsection Profiling tools
+
+It is useful to know how well an architecture is being utilized.
+For one, this helps build better architectures.  It also helps determine
+how well a compilation system is using an architecture.
+
+CGEN-based simulators already compute instruction frequency counts.
+It's straightforward to add register frequency counts.
+Monitoring other aspects of the ISA is also possible.  The description
+file provides all the necessary data, all that's needed is to write a
+generator for an application that then performs the desired analysis.
+
+Function unit, pipeline, and other architecture implementation related items
+requires a lot more effort but it is doable.  The guideline for this effort
+is again coming up with an application-independent specification of these
+things.
+
+CGEN does not currently support memory or cache profiling.
+Obviously they're important, and support may be added in the future.
+One thing that would be straightforward to add is the building of
+trace data for usage by cache and memory analysis tools.
+The point though is that these tools won't benefit much from CGEN's
+existence.
+
+Another kind of profiling tool is one that takes the program to
+be profiled as input, inserts profiling code into it, and then generates
+a new version of the program which is then run.@footnote{Note that there
+are other uses for such a program modification tool besides profiling.}
+Recorded in CGEN's description files should be all the necessary ISA related
+data to do this.  One thing that's missing is code to handle the file format
+and relocations.@xref{ABI description}.
+
+@node Program analysis tools
+@subsubsection Program analysis tools
+
+Related to profiling tools are static program analysis tools.
+By this I mean taking machine code as input and analyzing it in some way.
+Except for symbolic information (which could come from BFD or elsewhere),
+CGEN provides enough information to analyze machine code, both the
+the raw instructions *and* their semantics.  Libcgen should contain
+all the basic tools for doing this.
+
+@node ABI description
+@subsubsection ABI description
+
+Several tools need knowledge of not only a cpu's ISA but also of the ABI
+in use.  I believe it makes sense to apply the same goals that went into
+CGEN's architecture description language to an ABI description language:
+specify the ABI in an application independent way and then have a basic
+toolkit/library that uses that data and allow the writing of program
+generators for applications that want more than what the toolkit/library
+provides.
+
+Part of what an ABI defines is the file format and relocations.
+This is something that BFD is built for.  I think a BFD rewrite
+should happen and should be based, at least in part, on a CGEN-style
+ABI description.  This rewrite would be one user of the ABI description,
+but certainly not the only user.
+One problem with this approach is that BFD requires a lot of file format
+specific C code.  I doubt all of this code is amenable to being described
+in an application independent way.  Careful separation of such things
+will be necessary.  It may even be useful to ignore old file formats
+and limit such a BFD rewrite to ELF (not that ELF is free from such
+warts, of course).
+
+@node Machine generated architecture reference material
+@subsubsection Machine generated architecture reference material
+
+Engineers often need to refer to architecture documentation.
+One problem is that there's often only so many hardcopy manuals
+to go around.  Since the CPU description contains a lot of the information
+engineers need to find it makes sense to convert that information back
+into a readable form.  The manual can then be online available to everyone.
+Furthermore, each architecture will be documented using the same style
+making it easier to move from architecture to architecture.
+
+@node Tools like what NJMCT provides
+@subsubsection Tools like what NJMCT provides
+
+NJMCT is the New Jersey Machine Code Toolkit.
+It focuses exclusively on the encoding and decoding of instructions.
+[FIXME: wip, need to say more].
+
+@node Input to a compiler's backend
+@subsubsection Input to a compiler's backend
+
+One can define a GCC port to include these four things:
+
+@itemize @bullet
+@item cpu architecture description
+@item cpu implementation description
+@item ABI description
+@item miscellaneous
+@end itemize
+
+The CGEN description provides all of the cpu architecture description
+that the compiler needs.
+However, the current design of the CPU description language is geared
+towards going from machine instructions to semantic content, whereas
+what a compiler wants is to do is go from semantic content to machine
+instructions, so in the end this might not be a reasonable thing to
+pursue.  On the other hand, that problem can be solved in part by
+specifying two sets of semantics for each instruction: one for the 
+compiler side of things, and one for the simulator side of things.
+Frequently they will be the same thing and thus need only be specified once.
+Though specifying them twice, for the two different contexts, is reasonable
+I think.  If the two versions of the semantics are used by multiple applications
+this makes even more sense.
+
+The planned rewrite of model support in CGEN will support whatever the
+compiler needs for the implementation description.
+
+Compiler's also need to know the target's ABI, which isn't relevant
+for an architecture description.  On the other hand, more than just
+the compiler needs knowledge of the ABI.  Thus it makes sense to think
+about how many tools there are that need this knowledge and whether one
+can come up with a unifying description of the ABI.  Hence one future
+project is to add the ABI description to CGEN.  This would encompass
+in essence most of what is contained in the System V ABI documentation.
+
+That leaves the "miscellaneous" part.  Essentially this is a catchall
+for whatever else is needed.  This would include things like
+include file directory locations, ???.  There's probably no need to
+add these to the CGEN description language.
+
+One can even envision a day when GCC emits object files directly.
+The instruction description contains enough information to build
+the instructions and the ABI support would provide enough
+information on relocations and object file formats.
+Debugging information should be treated as an orthogonal concept.
+At present it is outside the scope of CGEN, though clearly the same
+reasoning behind CGEN applies to debugging support as well.
+
+@node Hardware/software codesign
+@subsubsection Hardware/software codesign
+
+This section isn't very well thought out -- not much time has been put
+into it.  The thought is that some interface with VHDL/Verilog could
+be created that would assist hw/sw codesign.
+
+Another related application is to have a feedback mechanism from the
+compilation system that helps improve the architecture description
+(both CGEN and HDL).
+For example, the compiler could determine what instructions would have
+made a significant benefit for a particular application.  CGEN descriptions
+for these instructions could be generated, resulting in a new set of
+compilation tools from which the hypothesis of adding the new instructions
+could then be validated.  Note that adding these new instructions only
+required writing CGEN descriptions of them (setting aside HDL concerns).
+Once done, all relevant tools would be automagically updated to support
+the new instructions.
+
+@node What is missing that should be there soon?
+@subsection What's missing that should be there soon?
+
+@itemize @bullet
+@item Support for complex ISA's (i386, m68k).
+
+Early versions had the framework of the support, but it's all bit-rotten.
+
+@item ABI description
+
+As discussed elsewhere, one thing that many tools need knowledge of besides
+the ISA is the ABI.  Clearly ABI's are orthogonal to ISA's and one cpu
+may have multiple ABI's running on it.  Thus the ABI description needs to
+be independent of the architecture description.  It would still be useful
+for the ABI to refer to things in the architecture description.
+
+@item Model description
+
+The current design is enough to get reasonable cycle counts from
+the simulator but it doesn't take into account all the uses one would
+want to make of this data.
+
+@item File organization
+
+I believe a lot of what is in libopcodes should be moved to libcgen.
+Libcgen will contain the bulk of the cpu description in processed form.
+It will also contain a suite of utilities for accessing the data.
+
+ABI support could either live in libcgen or separately in libcgenabi.
+libbfd would be a user of this library.
+
+Instruction semantics should also be recorded in libcgen, probably
+in bytecode form.  Operand usage tables, needed for example by the
+m32r assembler, can be lazily computed at runtime.
+
+Applications can either make use of libcgen or given the application
+independence of the description language they can write their won code
+generators to tailor the output as needed.
+
+@end itemize
+
+@node CPU description language
+@section CPU description language
+
+The goal of CGEN is to provide a uniform and extensible framework for
+doing assemblers/disassemblers and simulators, as well as allowing
+further tools to be developed as necessary.
+
+With that in mind I think the place to start is in defining a CPU
+description language that is sufficiently powerful for all the current
+and perceived future needs: an application independent description of
+the CPU.  From the CPU description, tables and code can be generated
+that an application framework can then use (e.g. opcode table for
+assembly/disassembly, decoder/executor for simulation).
+
+By "application independence" I mean the data is recorded in a way that
+doesn't intentionally close any doors on uses of the data.  One example of
+this is using RTL to describe instruction semantics rather than, say, C.
+The assembler can also make use of the instruction semantics.  It doesn't
+make use of the semantics, per se, but what it does use is the input and
+output operand information that is machine generated from the semantics.
+Groking operand usage from C is possible I guess, but a lot harder.
+So by writing the semantics in RTL multiple applications can make use if it.
+One can also generate from the RTL code in languages other than C.
+
+@menu
+* Language requirements::
+* Layout::
+* Language problems::
+@end menu
+
+@node Language requirements
+@subsection Language requirements
+
+The CPU description file needs to provide at least the following:
+
+@itemize @bullet
+@item elements of the CPU's architecture (registers, etc.)
+@item elements of a CPU's implementation (e.g. pipeline)
+@item how the bits of an instruction word map to the instruction's semantics
+@item semantic specification in a way that is amenable to being
+understood and manipulated
+@item performance measurement parameters
+@item support for multiple ISA variants
+@item assembler syntax of the instruction set
+@item how that syntax maps to the bits of the instruction word, and back
+@item support for generating test files
+@item ???
+@end itemize
+
+In addition to this, elements of the particular ABI in use is also needed.
+These things will obviously need to be defined separately from the cpu
+for obvious reasons.
+
+@itemize @bullet
+@item file format
+@item relocations
+@item function calling conventions
+@item ???
+@end itemize
+
+Some architectures require knowledge of the pipeline in order to do
+accurate simulation (because, for example, some registers don't have
+interlocks) so that will be required as well, as opposed to being solely
+for performance measurement.  Pipeline knowledge is also needed in order
+to achieve accurate profiling information.  However, I haven't spent
+much time on this yet.  The current design/implementation is a first
+pass in order to get something working, and will be revisited.
+
+Support for generating test files is not complete.  Currently the GAS
+test suite generator gets by (barely) without them.  The simulator test
+suite generator just generates templates and leaves the programmer to
+fill in the details.  But I think this information should be present,
+meaning that for situations where test vectors can't be derived from the
+existing specs, new specs should be added as part of the description
+language.  This would make writing testcases an integral part of writing
+the .cpu file.  Clearly there is a risk in having machine generated
+testcases - but there are ways to eliminate or control the risk.
+
+The syntax of a suitable description language needs to have these
+properties:
+
+@itemize @bullet
+@item simple
+@item expressive
+@item easily parsed
+@item easy to learn
+@item understandable by program generators
+@item extensible
+@end itemize
+
+It would also help to not start over completely from scratch.  GCC's RTL
+satisfies all these goals, and is used as the basis for the description
+language used by CGEN.
+
+Extensibility is achieved by specifying everything as name/value pairs.
+This allows new elements to be added and even CPU specific elements to
+be added without complicating the language or requiring a new element in
+a @code{define_insn} type entry to be added to each existing port.
+Macros can be used to eliminate the verbosity of repetitively specifying
+the ``name'' part, so one can have it both ways.  Imagine GCC's
+@file{.md} file elements specified as name/value pairs with macro's
+called @code{define_expand}, @code{define_insn}, etc.  that handle the
+common cases and expand the entry to the full @code{(define_full_expand
+(name addsi3) (template ...) (condition ...) ...)}.
+
+Scheme also uses @code{(foo :keyword1 value1 :keyword2 value2 ...)},
+though that isn't implemented yet (or maybe @code{#:keyword} depending
+upon what is enabled in Guile).
+
+@node Layout
+@subsection Layout
+
+Here is a graphical layout of the hierarchy of elements of a @file{.cpu} file.
+               
+@example
+                           architecture
+                           /          \
+                      cpu-family1   cpu-family2  ...
+                      /         \
+                  machine1    machine2  ...
+                   /   \
+              model1  model2  ...
+@end example
+
+Each of these elements is explained in more detail in @ref{RTL}.  The
+@emph{architecture} is one of @samp{sparc}, @samp{m32r}, etc.  Within
+the @samp{sparc} architecture, the @emph{cpu-family} might be
+@samp{sparc32} or @samp{sparc64}.  Within the @samp{sparc32} CPU family,
+the @emph{machine} might be @samp{sparc-v8}, @samp{sparclite}, etc.
+Within the @samp{sparc-v8} machine classificiation, the @emph{model}
+might be @samp{hypersparc} or @samp{supersparc}.
+
+Instructions form their own hierarchy as each instruction may be supported
+by more than one machine.  Also, some architectures can handle more than
+one instruction set on one chip (e.g. ARM).
+
+@example
+                     isa
+                      |
+                  instruction
+                    /   \         
+             operand1  operand2  ... 
+                |         |
+         hw1+ifield1   hw2+ifield2  ...
+@end example
+
+Each of these elements is explained in more detail in @ref{RTL}.
+
+@node Language problems
+@subsection Language problems
+
+There are at least two potential problem areas in the language's design.
+
+The first problem is variation in assembly language syntax.  Examples of
+this are Intel vs AT&T i386 syntax, and Motorola vs MIT M68k syntax.
+I think there isn't a sufficient number of important cases to warrant
+handling this efficiently.  One could either ignore the issue for
+situations where divergence is sufficient to dissuade one from handling
+it in the existing design, or one could provide a front end or
+use/extend the existing macro mechanism.
+
+One can certainly argue that description of assembler syntax should be
+separated from the hardware description.  Doing so would prevent
+complications in supporting multiple or even difficult assembler
+syntaxes from complicating the hardware description.  On the other hand,
+there is a lot of duplication, and in the end for the intended uses of
+CGEN I think the benefits of combining assembler support with hardware
+description outweigh the disadvantages.  Note that the assembler
+portions of the description aren't used by the simulator @footnote{The
+simulator currently uses elements of the opcode table since the opcode
+table is a nice central repository for such things.  However, the
+assembler/disassembler isn't part of the simulator, and the
+portions of the opcode table can be generated and recorded elsewhere
+should it prove reasonable to do so.  The CPU description file won't
+change, which is the important thing.}, so if one wanted to implement
+the disassembler/assembler via other means one can.
+
+The other potential problem area is relocations.  Clearly part of
+processing assembly code is dealing with the relocations involved
+(e.g. GOT table specification).  Relocation support necessarily requires
+BFD and GAS support, both of which need cleanup in this area.  Rewriting
+BFD to provide a better interface so reloc handling in GAS can be
+cleaned up is believed to be something this project can and should take
+advantage of, and that any attempt at adding relocation support should
+be done by first cleaning up GAS/BFD.  That can be left for another day
+though. :-)
+
+One can certainly argue trying to combine an ABI description with a
+hardware description is problematic as there can be more than one ABI.
+However, there often isn't and in the cases where there isn't the
+simplified porting and maintenance is worth it, in the author's opinion.
+Furthermore, the current language doesn't embed ABI elements
+with hardware description elements.  Careful segregation of such things
+might ameliorate any problems.
+
+@node Opcodes support
+@section Opcodes support
+
+Opcodes support comes in the form of machine generated opcode tables as
+well as supporting routines.
+
+@node Simulator support
+@section Simulator support
+
+Simulator support comes in the form of machine generated the decoder/executer
+as well as the structure that records CPU state information (ie. registers).
+
+@node Testing support
+@section Testing support
+
+@menu
+* Assembler/disassembler testing::
+* Simulator testing::
+@end menu
+
+Inherent in the design is the ability to machine generate test cases both
+for the assembler/disassembler and for the simulator.  Furthermore, it
+is not unreasonable to add to the description file data specifically
+intended to assist or guide the testing process.  What kinds of
+additions that will be needed is unknown at present.
+
+@node Assembler/disassembler testing
+@subsection Assembler/disassembler testing
+
+The description of instructions and their fields contains to some extent
+not only the syntax but the possible values for each field.  For
+example, in the specification of an immediate field, it is known what
+the allowable range of values is.  Thus it is possible to machine
+generate test cases for such instructions.  Obviously one wouldn't want
+to test for each number that a number field can contain, however one can
+generate a representative set of any size.  Likewise with register
+fields, mnemonic fields, etc.  A good starting point would be the edge
+cases, the values at either end of the range of allowable values.
+
+When I first raised the possibility of machine generated test cases the
+first response I got was that this wouldn't be useful because the same
+data was being used to generate both the program and the test cases.  An
+error might be propagated to both and thus nullify the test.  For
+example if an opcode field was supposed to have the value 1 and the
+description file had the value 2, then this error wouldn't be caught.
+However, this assumes test cases are generated during the testing run!
+And it ignores the profound amount of typing that is saved by machine
+generating test cases!  (I discount the argument that this kind of
+exhaustive testing is unnecessary).
+
+One solution to the above problem is to not generate the test cases
+during the testing run (which was implicit in the proposal, but perhaps
+should have been explicit).  Another solution is to generate the
+test cases during the test run but first verify them by some external
+means before actually using them in any test.  The latter solution is
+only mentioned for completeness sake; its implementation is problematic
+as any external means would necessarily be computer driven and the level
+of confidence in the result isn't 100%.
+
+So how are machine generated test cases verified?  By machine, by hand,
+and by time.  The test cases are checked into CVS and are not regenerated
+without care.  Every time the test cases are regenerated, the diffs are
+examined to ensure the bug triggering the regeneration has been fixed
+and that no new bugs have been introduced.  In all likelihood once a
+port is more or less done, regeneration of test cases would stop anyway,
+and all further changes would be done manually.
+
+``By machine'' means that for example in the case of ports with a native
+assembler one can run the test case through the native assembler and use
+that as a good first pass.
+
+``By hand'' means one can go through each test case and verifying them
+manually.  This is what is done in the case of non-machine generated
+test cases, the only difference is the perceived difference in quantity.
+And in the case of machine generated test cases comments can be added to
+each test to help with the manual verification (e.g. a comment can be
+added that splits the instruction into its fields and shows their names
+and values).
+
+``By time'' means that this process needn't be done instantaneously.
+This is no different than the non-machine generated case again except in
+the perceived difference in quantity of test cases.
+
+Note that no claim is made that manually generated test cases aren't
+needed.  Clearly there will be some cases that the description file
+doesn't describe and thus can't machine generate.
+
+@node Simulator testing
+@subsection Simulator testing
+
+Machine generation of simulator test cases is possible because the
+semantics of each instruction is written in a way that is understandable
+to the generator.  At the very least, knowledge of what the instructions
+are is present!  Obviously there will be some instructions that can't
+be adequately expressed in RTL and are thus not amenable to having a
+test case being machine generated.  There may even be some RTL'd
+semantics that fall into this category.  It is believed, however, that
+there will still be a large percentage of instructions amenable to
+having test cases machine generated for them.  Such test cases can
+certainly be hand generated, but it is believed that this is a large
+amount of unnecessary typing that typically won't be done due to the
+amount.  Again, I discount the argument that this kind of exhaustive
+testing isn't necessary.
+
+An example is the simple arithmetic instructions.  These take zero, one,
+or more arguments and produce a result.  The description file contains
+sufficient data to generate such an instruction, the hard part is in
+providing the environment to set up the required inputs (e.g. loading
+values into registers) and retrieve the output (e.g. retrieve a value
+from a register).
+
+Certainly at the very least all the administrivia for each test case can
+be machine generated (i.e. a template file can be generated for each
+instruction, leaving the programmer to fill in the details).
+
+The strategy used for assembler/disassembler test cases is also used here.
+Test cases are kept in CVS and are not regenerated without care.
+
+@node Implementation language
+@section Implementation language
+
+The chosen implementation language is Scheme.  The reasons for this are:
+
+@itemize @bullet
+@item Parsing RTL in Scheme is real easy, though I did make some albeit
+minor changes to make it easier.  While it doesn't take more than a few
+dozen lines of C to parse RTL, it doesn't take any lines of Scheme -
+the parser is built into the interpreter.
+
+@item An interactive environment is a better environment to work in,
+especially in the early stages of an ambitious project like this.
+
+@item Guile is developing as an embeddable interpreter.
+I wanted room for growth in many dimensions, and having the implementation
+language be an embeddable interpreter supports this.
+
+@item I wanted to learn Scheme (Yes, not a technical reason, blah blah blah).
+
+@item Numbers in Scheme can have arbitrary precision so representing 64
+bit (or higher) numbers on a 32 bit host is well defined.
+
+@item It seemed useful to have an implementation language similar to the 
+CPU description language.  The Scheme implementation seems simpler
+than a C implementation would be.
+@end itemize
+
+One issue that arises with the use of Scheme as the implementation
+language is whether to generate files in the source tree, with the
+issues that involves, or generate the files in the build tree (and thus
+require Guile to build Binutils and the issues that involves).  Trying
+to develop something like this is easier in an interactive environment,
+so Scheme as the first implementation language is, to me, a better
+choice than C or C++.  In such a big project it also helps to have a
+more expressive language so relatively complex code and be written with
+fewer lines of code.
+
+One consequence is maintenance is more difficult in that the
+generated files (e.g. @file{opcodes/m32r-*.[ch]}) are checked into CVS
+at Red Hat, and a change to a CPU description requires rebuilding the
+generated files and checking them in as well.  And a change that affects
+each port requires each port to be regenerated and checked in.
+This is more palatable for maintainer tools such as @code{bison},
+@code{flex}, @code{autoconf} and @code{automake}, as their input files
+don't change as often.
+
+
+Whether to continue with Scheme, convert the code to a compiled
+language, or have both is an important, open issue.
diff --git a/cgen/doc/notes.texi b/cgen/doc/notes.texi
new file mode 100644 (file)
index 0000000..b21a59b
--- /dev/null
@@ -0,0 +1,237 @@
+@c Copyright (C) 2000 Red Hat, Inc.
+@c This file is part of the CGEN manual.
+@c For copying conditions, see the file cgen.texi.
+
+@node Miscellaneous notes
+@chapter Miscellaneous notes
+@cindex Miscellaneous notes
+
+This chapter is a repository of miscellaneous notes that belong elsewhere
+or nowhere.  They're here because I want them written down, for now anyway,
+and I'm not sure where else to put them.  There may be duplication here
+with things elsewhere in the docs.  I'm not bothering to ensure there isn't.
+It's better to have things written down twice than not at all.  If there
+is a conflict between notes here and elsewhere, check the chronology.
+I may have changed my mind.  If not, the situation may be complicated and I
+don't have a strong opinion on what's right.  No claim is made that these
+notes represent my complete opinion.  (Hmmm... lessee what other caveats
+I can throw in here ... :-)
+
+@c ??? Shouldn't have to append " notes" to every menu entry.
+@c It's done because some entries collide with menu entries in other
+@c chapters and texinfo doesn't like that (complains or crashes).
+
+@menu
+* Description language notes::
+* CGEN architecture notes::
+* COS notes::
+* RTL notes::
+* Guile implementation notes::
+* Code generation notes::
+* Machine generated files notes::
+* Implementation language notes::
+@end menu
+
+@node Description language notes
+@section Description language notes
+
+@itemize @minus
+
+@item timing support
+
+The current implementation of timing (aka pipeline, function units, etc.)
+support is a quick hack in order to achieve useful numbers out of the
+simulator.  It is intended to be replaced with something a lot more
+sophisticated.  Remember to keep in mind cgen's goal of application
+independence when designing the new version.  For example, it must handle
+things like code scheduling in a compiler (where speed of analysis is not
+critical) to scheduling in a dynamic compiler (where speed of analysis is
+critical).  It must also handle semi-accurate to fully-accurate cycle
+counting in simulators (where the former might trade off accuracy for speed
+which one wouldn't do in the latter, assuming there is a trade-off to be
+made).  It must also handle the representation and handling of pipelines
+with program visible hazards.
+
+@item organization of cpu description
+
+One thing that may not be apparent is that the description language
+doesn't preclude one item (say an insn) from having its definition
+spread over several files.  One example would be to leave the timing
+elements unspecified in the "main" entry of an insn, and then have
+a machine-specific file providing timing characteristics, etc.
+
+One can even leave the semantics to be defined elsewhere.
+The `=' insn format prefix is not currently used very much (no need).
+It might also need better documentation.
+
+A possible break-up of an item's description into several files should be
+generally supported (where reasonable).
+
+@end itemize
+
+@node CGEN architecture notes
+@section CGEN architecture notes
+
+@itemize @minus
+
+@item compiled form of description in libcgen
+
+The current compiled form of the cpu description has been focused on
+two applications: opcodes and simulator.  No doubt there are things present
+that will present problems to future applications.
+One thing on the todo list has been to record semantics with the compiled
+form, probably as bytecode.  Maybe it would make sense to record the
+entire cpu description as a kind of bytecode.  This would allow apps to
+instantiate it for the task at hand as they please.
+
+@item function-style attributes
+
+Attributes currently only support static (compile-time computed) notions.
+They should also support run-time computed values.  The way to do this is
+to record such attributes as bytecode and lazily (or not lazily) evaluate
+them at runtime, perhaps caching the results.  It might make sense to
+record all attributes this way (though I currently don't think so).
+
+@item importance of description language
+
+When hacking on cgen, the description language takes priority over
+implementation.  That cannot be stressed enough.  When faced with
+choices of what to do, put the elegance, maintainability, and application
+independence of the description language first.  Implementation will almost
+always take shortcuts due to application specific requirements.  Theoretically
+the description language won't have to; at least that's where the effort
+in application independence should be put.
+
+@end itemize
+
+@node COS notes
+@section COS notes
+
+@itemize @minus
+
+@item elm-xget, elm-xset
+
+These procedures are quick hacks and should be avoided.
+Existing uses should be replaced.
+Where they're used it's either because of laziness or because
+I wasn't sure whether I wanted to allow global access to the element,
+so using an easily grep-able hack let's me find them and revisit them.
+
+@end itemize
+
+@node RTL notes
+@section RTL notes
+
+@itemize @minus
+
+@item Where's strict_lowpart?  Where's foo?
+
+Elements of gcc's rtl like strict_lowpart, pre_inc, etc. aren't in
+cgen's rtl only because thus far there hasn't been a compelling need
+for them.  When there is a compelling need they'll be added.
+
+@item boolean values
+
+Sometimes #f/#t is used for boolean values.
+However the "boolean" mode @code{BI} has values 0 and 1.
+Which one is in use is context dependent.
+Not sure there is a problem but it should be revisited.
+
+@item #f to denote "unspecified" values
+
+Sometimes () is used to specify "unspecified" values.
+Other times #f is used.  Should standardize in #f.
+
+@item ifield assertions
+
+Perhaps these should be renamed to "constraints".
+"ifield-assertion" sounds clumsy.
+
+@end itemize
+
+@node Guile implementation notes
+@section Guile implementation notes
+
+@itemize @minus
+
+@item
+Remaining todo is to complete switchover from "errtxt" (a string)
+in .cpu file reader support to "context" (a <context> object).
+
+@item
+Remaining todo is to complete switchover of naming functions from
+"prefix:function" to "prefix-function".  One reasonable naming style
+is "prefix-verb-noun".  I like it.
+
+@item
+Slib uses "prefix:foo" for "internal" routines.  Maybe that would be
+a better choice than the current "-prefix-foo" style.
+
+@end itemize
+
+@node Code generation notes
+@section Code generation notes
+
+@itemize @minus
+
+@item foo
+
+@end itemize
+
+@node Machine generated files notes
+@section Machine generated files notes
+
+@itemize @minus
+
+@item
+In the end I think the best thing is to build the machine generated files
+when the tools themselves are built (same as gcc's gen* -> insn* files).
+
+@end itemize
+
+@node Implementation language notes
+@section Implementation language notes
+
+In the end I think the implementation language (or the Guile
+implementation) will have to change.
+If one compares the speed of gcc's gen* file generators vs cgen's,
+and one envisions the day when machine generated files are
+built at build time, then I think the user community will require
+similar speed in file generation.  Guile isn't fast enough.
+And while Guile+Hobbit may be, for the one-time builder the time
+taken to compile Hobbit, run it, and compile the result, will appear
+to swamp any gains.  There is also the additional burden of
+building Guile first (though with my prefered Guile implementation
+I'm _hoping_ that wouldn't be a problem).
+
+The pragmatic choice is C.  Blech.
+
+A better choice would be C++ but then that would obviously place a
+requirement on having a C++ compiler available in order to build binutils,
+for example (assuming machine generated files are built at build time).
+
+Java would also be a better implementation language than C
+[an interesting experiment would be Kawa].  But it's worse as a pragmatic
+choice than C++.
+
+My prefered choice is a small-and-fast subset of Guile that gets
+distributed with binutils, gdb, etc.  IMO Guile is too bloated
+and unmaintainable for the casual maintainer (hacking on its innards
+requires too steep a learning curve, and is one that is easily slipped back
+down should one step away from it for too long).  If those can be fixed and
+the speed of cgen's file generation can be made acceptable, then that
+is the path I would choose.
+
+In making the choice people need to look forward rather than look backward.
+We're finally switching the GNU tools to ANSI C.  If the host doesn't provide
+an ANSI C compiler the user is expected to get one (GCC).
+Well, G++ is available on most if not all hosts of concern, so
+in this day and age requiring C++ in order to build binutils isn't
+as much of a burden as it use to be.  Cgen is a forward looking design.
+At its heart is a goal to close no doors on future uses.  That's a
+pretty lofty goal.  Forcing people to achieve that goal with C because
+of pragmatic concerns is unjustifiable, IMO.
+
+Note that changing the "implementation language" does _not_ mean
+Guile cannot or will not be used for various things!  I think Guile
+should continue to be used for prototyping as well as certain applications.
diff --git a/cgen/doc/opcodes.texi b/cgen/doc/opcodes.texi
new file mode 100644 (file)
index 0000000..4085aa2
--- /dev/null
@@ -0,0 +1,186 @@
+@c Copyright (C) 2000 Red Hat, Inc.
+@c This file is part of the CGEN manual.
+@c For copying conditions, see the file cgen.texi.
+
+@node Opcodes
+@chapter Opcodes support
+@cindex Opcodes support
+
+Opcodes support comes in the form of machine generated opcode tables as
+well as supporting routines.
+
+@menu
+* Generated files::                 List of generated files
+* The .opc file::                   Target specific C code
+* Special assembler parsing needs::
+@end menu
+
+@node Generated files
+@section Generated files
+
+The basic interface is defined by
+@file{include/opcode/cgen.h} which is included by the machine generated
+@file{<arch>-desc.h}.  @file{opcode/cgen.h} can stand on its own for the
+target independent stuff, but to get target specific parts of the
+interface use @file{<arch>-desc.h}.
+
+The generated files are:
+
+@table @file
+@item <arch>-desc.h
+Defines macros, enums, and types used to describe the chip.
+@item <arch>-desc.c
+Tables of various things describing the chip.
+This does not include assembler syntax nor semantic information.
+@item <arch>-ibld.c
+Routines for constructing and deconstructing instructions.
+@item <arch>-opc.h
+Declarations necessary for assembly/disassembly that aren't used
+elsewhere and thus left out of @file{<arch>-desc.h}.
+@item <arch>-opc.c
+Assembler syntax tables.
+@item <arch>-asm.c
+Assembler support routines.
+@item <arch>-dis.c
+Disassembler support routines.
+@item <arch>-opinst.c
+Operand instance tables.
+These describe which hardware elements are read and which are written
+for each instruction.  This file isn't generated for all architectures,
+only ones that can make use of the data.  For example the M32R uses them
+to emit warnings if the output of one parallel instruction is the input
+of another, and to control creating parallel instructions during optimizing
+assembly.
+@end table
+
+@node The .opc file
+@section The .opc file
+
+Files with suffix @file{.opc} (e.g. @file{m32r.opc}) contain target
+specific C code that accompanies the cpu description file.
+The @file{.opc} file is split into 4 sections:
+
+@itemize @minus
+@item opc.h
+
+This section contains additions to the generated @file{$target-opc.h} file.
+
+Typically defined here are these macros:
+
+@itemize @bullet
+@item #define CGEN_DIS_HASH_SIZE N
+
+Specifies the size of the hash table to use during disassembly.
+A hash table is built of the selected mach's instructions in order to
+speed up disassembly.
+@item #define CGEN_DIS_HASH(buffer, value)
+
+Given BUFFER, a pointer to the instruction being disassembled and
+VALUE, the value of the instruction as a host integer, return an
+index into the hash chain for the instruction.  The result must be
+in the range 0 to CGEN_DIS_HASH_SIZE-1.
+
+VALUE is only usable if all instructions fit in a portable integer (32 bits).
+
+N.B. The result must depend on opcode portions of the instruction only.
+Normally one wants to use between 6 and 8 bits of opcode info for the hash
+table.  However, some instruction sets don't use the same set of bits
+for all insns.  Certainly they'll have at least one opcode bit in common
+with all insns, but beyond that it can vary.  Here's a possible definition
+for sparc.
+
+@example
+#undef CGEN_DIS_HASH_SIZE
+#define CGEN_DIS_HASH_SIZE 256
+#undef CGEN_DIS_HASH
+extern const unsigned int sparc_cgen_opcode_bits[];
+#define CGEN_DIS_HASH(buffer, insn) \
+((((insn) >> 24) & 0xc0) \
+ | (((insn) & sparc_cgen_opcode_bits[((insn) >> 30) & 3]) >> 19))
+@end example
+
+@code{sparc_cgen_opcode_bits} would be defined in the @samp{asm.c} section as
+
+@example
+/* It is important that we only look at insn code bits
+   as that is how the opcode table is hashed.
+   OPCODE_BITS is a table of valid bits for each of the
+   main types (0,1,2,3).  */
+const unsigned int sparc_cgen_opcode_bits[4] = @{
+  0x01c00000, 0x0, 0x01f80000, 0x01f80000
+@};
+@end example
+@end itemize
+
+@item opc.c
+
+@item asm.c
+
+This section contains additions to the generated @file{$target-asm.c} file.
+Typically defined here are functions used by operands with a @code{parse}
+define-operand handler spec.
+
+@item dis.c
+
+This section contains additions to the generated @file{$target-dis.c} file.
+
+Typically defined here these macros:
+
+@itemize @bullet
+@item #define CGEN_PRINT_NORMAL(cd, info, value, attrs, pc, length)
+@item #define CGEN_PRINT_ADDRESS(cd, info, value, attrs, pc, length)
+@item #define CGEN_PRINT_INSN function_name
+@c FIXME: should be CGEN_PRINT_INSN(cd, pc, info)
+@item #define CGEN_BFD_ARCH bfd_arch_<name>
+@item #define CGEN_COMPUTE_ISA(info)
+@end itemize
+
+@end itemize
+
+@node Special assembler parsing needs
+@section Special assembler parsing needs
+
+Often parsing of assembly instructions requires more than what
+a program-generated assembler can handle.  For example one version
+of an instruction may only accept certain registers, rather than
+the entire set.
+
+Here's an example taken from the @samp{m32r} architecture.
+
+32 bit addresses are built up with a two instruction sequence: one to
+load the high 16 bits of a register, and another to @code{or}-in the
+lower 16 bits.
+
+@example
+seth r0,high(some_symbol)
+or3  r0,r0,low(some_symbol)
+@end example
+
+When assembling, special code must be called to recognize the
+@code{high} and @code{low} pseudo-ops and generate the appropriate
+relocations.  This is indicated by specifying a "parse handler" for
+the operand in question.  Here is the @code{define-operand}
+for the lower 16 bit operand.
+
+@example
+(define-operand
+  (name ulo16)
+  (comment "16 bit unsigned immediate, for low()")
+  (attrs)
+  (type h-ulo16)
+  (index f-uimm16)
+  (handlers (parse "ulo16"))
+)
+@end example
+
+The generated parser will call a function named @code{parse_ulo16}
+for the immediate operand of the @code{or3} instruction.
+The name of the function is constructed by prepended "parse_" to the
+argument of the @code{parse} spec.
+
+@example
+errmsg = parse_ulo16 (cd, strp, M32R_OPERAND_ULO16, &fields->f_uimm16);
+@end example
+
+But where does one put the @code{parse_ulo16} function?
+Answer: in the @samp{asm.c} section of @file{m32r.opc}.
diff --git a/cgen/doc/pmacros.texi b/cgen/doc/pmacros.texi
new file mode 100644 (file)
index 0000000..cc41dd4
--- /dev/null
@@ -0,0 +1,457 @@
+@c Copyright (C) 2000 Red Hat, Inc.
+@c This file is part of the CGEN manual.
+@c For copying conditions, see the file cgen.texi.
+
+@node Preprocessor macros
+@chapter Preprocessor macros
+@cindex Preprocessor macros
+@cindex pmacros
+
+Preprocessor macros provide a way of simplifying the writing of
+@file{.cpu} files and serve the same purpose that macros do in C.
+
+@menu
+* Defining a preprocessor macro:: @code{define-pmacro}
+* Using preprocessor macros::
+* Macro expansion::               The @code{pmacro-expand} procedure
+* Default argument values::       Specifying default values of arguments
+* Multiple output expressions::   Using @code{begin}
+* Symbol concatenation::          The @code{.sym} builtin
+* String concatenation::          The @code{.str} builtin
+* Convert a number to a hex::     The @code{.hex} builtin
+* Convert a string to uppercase:: The @code{.upcase} builtin
+* Convert a string to lowercase:: The @code{.downcase} builtin
+* Getting part of a string::      The @code{.substr} builtin
+* List splicing::                 The @code{.splice} builtin
+* Number generation::             The @code{.iota} builtin
+* Mapping a macro over a list::   The @code{.map} builtin
+* Applying a macro to a list::    The @code{.apply} builtin
+* Defining a macro inline::       The @code{.pmacro} builtin
+* Passing macros as arguments::   Passing a macro to another macro
+@end menu
+
+@node Defining a preprocessor macro
+@section Defining a preprocessor macro
+@cindex define-pmacro
+
+Preprocessor macros are defined with:
+
+@smallexample
+(define-pmacro (name parm1 parm2 ... parmN)
+  expansion
+)
+@end smallexample
+
+The result is @samp{expansion} with parameters replaced with the actual
+arguments of the macro invocation.  Free variables are left unchanged.
+[A "free variable", as defined here, is one that doesn't appear in the
+parameter list.]
+
+@c ??? This used to be true, but currently isn't.
+@c If the result is another macro invocation, it is expanded in turn.  
+
+@samp{expansion} must be exactly one expression.
+
+@node Using preprocessor macros
+@section Using preprocessor macros
+
+Preprocessor macros are invoked in either of two ways: positional arguments
+and arguments by name.
+@c Rather lame wording.
+
+@smallexample
+(define-pmacro (foo arg1 arg2) (bar arg1 arg2))
+
+; Invoke by positional arguments.
+
+(foo abc def) ==> (bar abc def)
+
+; Invoke by naming arguments.
+
+(foo #:arg1 ghi #:arg2 jkl) ==> (bar ghi jkl)
+@end smallexample
+
+@c If you think more should be said here, I agree.
+@c Please think of something.
+
+@node Macro expansion
+@section Macro expansion
+
+At the implementation level, pmacros are expand with the
+@code{pmacro-expand} Scheme procedure.
+
+The following is executed from a Guile shell, as opposed to 
+appearing in a cpu description file, hence the extra quoting.
+
+@smallexample
+guile> (define-pmacro '(foo a b) '(+ a b))
+guile> (pmacro-expand '(foo 3 4))
+(+ 3 4)
+@end smallexample
+
+@node Default argument values
+@section Default argument values
+
+Invoking pmacros by specifying argument names allows some, or all,
+arguments to be elided and thus allows for arguments to have default values.
+
+Specify default values with the following syntax.
+
+@smallexample
+(define-pmacro (macro-name (arg1 . default-value)
+                           (arg2 . default value) ...)
+  ...
+)
+@end smallexample
+
+Example:
+
+@smallexample
+(define-pmacro (foo (arg1 . 1) (arg2 . 2))
+  (bar arg1 arg2)
+)
+
+(foo #:arg2 33) ==> (bar 1 33)
+@end smallexample
+
+@node Multiple output expressions
+@section Multiple output expressions
+@cindex begin
+
+The result of a preprocessor macro is exactly one expression.
+It is often useful, however, to return multiple expressions, say for
+example when you want one macro to define several instructions.
+
+The way to do this is to enclose all the expressions with @code{begin}.
+@code{begin} is only valid at the top [definition] level.
+
+??? It's moderately clumsy to restrict @code{begin} like this.
+Using @code{sequence} for this purpose might be cleaner except that
+sequence locals don't make sense in this context (though perhaps that's
+a lesser evil).  In the end, @code{begin} can be shorthand for a void-mode
+sequence with no locals so I haven't been in a rush to resolve this.
+
+@node Symbol concatenation
+@section Symbol concatenation
+@cindex .sym
+
+Symbol and string concatenation are supported. Symbol concatenation is
+done with:
+
+@code{(.sym arg1 arg2 ...)}
+
+Acceptable arguments are symbols, strings, and numbers.
+The result is a symbol with the arguments concatenated together.
+Numbers are converted to a string, base 10, and then to a symbol.
+The result must be a valid Scheme symbol with the additional restriction
+that the first character must be a letter.
+
+@node String concatenation
+@section String concatenation
+@cindex .str
+
+String concatenation is done with
+
+@code{(.str arg1 arg2 ...)}
+
+Acceptable arguments are symbols, strings, and numbers.  The result is a
+string with the arguments concatenated together.
+Numbers are converted base 10.
+
+Example:
+
+@smallexample
+(define-pmacro (bin-op mnemonic op2-op sem-op)
+  (dni mnemonic
+       (.str mnemonic " reg/reg")
+       ()
+       (.str mnemonic " $dr,$sr")
+       (+ OP1_0 op2-op dr sr)
+       (set dr (sem-op dr sr))
+       ())
+)
+(bin-op and OP2_12 and)
+(bin-op or OP2_14 or)
+(bin-op xor OP2_13 xor)
+@end smallexample
+
+@node Convert a number to a hex
+@section Convert a number to a hex
+
+Convert a number to a lowercase hex string with @code{.hex}.  If
+@code{width} is present, the result is that many characters beginning
+with the least significant digit.  Zeros are prepended as necessary.
+
+Syntax: @code{(.hex number [width])}
+
+Examples:
+
+@smallexample
+(.hex 42)   --> "2a"
+(.hex 42 1) --> "a"
+(.hex 42 4) --> "002a"
+@end smallexample
+
+@node Convert a string to uppercase
+@section Convert a string to uppercase
+
+Convert a string to uppercase with @code{.upcase}.
+
+Syntax: @code{(.upcase string)}
+
+Example:
+
+@smallexample
+(.upcase "foo!") --> "FOO!"
+@end smallexample
+
+@node Convert a string to lowercase
+@section Convert a string to lowercase
+
+Convert a string to lowercase with @code{.downcase}.
+
+Syntax: @code{(.downcase string)}
+
+Example:
+
+@smallexample
+(.downcase "BAR?") --> "bar?"
+@end smallexample
+
+@node Getting part of a string
+@section Getting part of a string
+
+Extract a part of a string with @code{.substr}.
+
+Syntax: @code{(.substr string start end)}
+
+where @samp{start} is the starting character, and @samp{end} is one past
+the ending character.  Character numbering begins at position 0.
+If @samp{start} and @samp{end} are the same, and both valid, the empty
+string is returned.
+
+Example:
+
+@smallexample
+(.substr "howzitgoineh?" 2 6) --> "wzit"
+@end smallexample
+
+@node List splicing
+@section List splicing
+@cindex .splice
+
+It is often useful to splice a list into a "parent" list.
+This is best explained with an example.
+
+@smallexample
+(define-pmacro (splice-test a b c)
+               (.splice a (.unsplice b) c))
+(pmacro-expand (splice-test (1 (2) 3)))
+
+--> (1 2 3)
+@end smallexample
+
+Note that a level of parentheses around @code{2} has been removed.
+
+This is useful, for example, when one wants to pass a list of fields to
+a macro that defines an instruction.  For example:
+
+@smallexample
+(define-pmacro (cond-move-1 name comment mnemonic cc-prefix cc-name cc-opcode
+                           src-name src-opcode cond test)
+  (dni name
+       (.str "move %" cc-name " " comment ", v9 page 191")
+       ((MACH64))
+       (.str mnemonic " " cc-prefix cc-name ",$" src-name ",$rd")
+       (.splice + OP_2 rd OP3_MOVCC cond
+               (.unsplice cc-opcode) (.unsplice src-opcode))
+       (if (test cc-name)
+          (set rd src-name))
+       ())
+)
+@end smallexample
+
+This macro, taken from @file{sparc64.cpu}, defines a conditional move
+instruction. Arguments @code{cc-opcode} and @code{src-opcode} are lists
+of fields. The macro is invoked with (simplified from @file{sparc64.cpu}):
+
+@smallexample
+(cond-move-1 mova-icc "blah ..." mova
+             "%" icc ((f-fmt4-cc2 1) (f-fmt4-cc1-0 0))
+             rs2 ((f-i 0) (f-fmt4-res10-6 0) rs2)
+             CC_A test-always)
+(cond-move-1 mova-imm-icc "blah ..." mova
+             "%" icc ((f-fmt4-cc2 1) (f-fmt4-cc1-0 0))
+             simm11 ((f-i 1) simm11)
+             CC_A test-always)
+@end smallexample
+
+Macro @code{cond-move-1} is being used here to define both the register
+and the immediate value case.  Each case has a slightly different list
+of opcode fields.  Without the use of @code{.splice}/@code{.unsplice},
+the resulting formats would be:
+
+@smallexample
+(+ OP_2 rd OP3_MOVCC CC_A ((f-fmt4-cc2-1) (f-fmt4-cc1-0 0))
+   ((f-i 0) (f-fmt4-res10-6 0) rs2))
+
+and
+
+(+ OP_2 rd OP3_MOVCC CC_A ((f-fmt4-cc2-1) (f-fmt4-cc1-0 0))
+   ((f-i 1) simm11))
+@end smallexample
+
+respectively.  This is not what is wanted.  What is wanted is
+
+@smallexample
+(+ OP_2 rd OP3_MOVCC CC_A (f-fmt4-cc2-1) (f-fmt4-cc1-0 0)
+   (f-i 0) (f-fmt4-res10-6 0) rs2)
+
+and
+
+(+ OP_2 rd OP3_MOVCC CC_A (f-fmt4-cc2-1) (f-fmt4-cc1-0 0)
+   (f-i 1) simm11)
+@end smallexample
+
+respectively, which is what @code{.splice} achieves.
+
+@code{.unsplice} is a special reserved symbol that is only recognized inside
+@code{.splice}.
+
+@node Number generation
+@section Number generation
+@cindex .iota
+@cindex Number generation
+
+Machine descriptions often require a list of sequential numbers.
+Generate a list of numbers with the @code{.iota} builtin macro.
+
+The syntax is @samp{(.iota count [start [incr]])}.
+
+Examples:
+
+@smallexample
+(.iota 5)      --> 0 1 2 3 4
+(.iota 5 4)    --> 4 5 6 7 8
+(.iota 5 5 -1) --> 5 4 3 2 1
+@end smallexample
+
+@node Mapping a macro over a list
+@section Mapping a macro over a list
+@cindex .map
+
+Apply a macro to each element of a list, or set of lists, with @code{.map}.
+
+The syntax is @samp{(.map macro-name list1 [list2 ...])}.
+
+The result is a list with @samp{macro-name} applied to each element of
+@samp{listN}.  @samp{macro-name} should take as many arguments as there
+are lists.  This is often useful in constructing enum and register name lists.
+
+Example:
+
+@smallexample
+(define-pmacro (foo name number) ((.sym X name) number))
+(.map foo (A B C D E) (.iota 5))
+
+-->
+
+((XA 0) (XB 1) (XC 2) (XD 3) (XE 4))
+@end smallexample
+
+@node Applying a macro to a list
+@section Applying a macro to a list
+
+Invoke a macro with each argument coming from an element of a list,
+with @code{.apply}.
+
+The syntax is @samp{(.apply macro-name list)}.
+
+The result is the result of invoking macro @samp{macro-name}.
+@samp{macro-name} should take as many arguments as there elements in
+@samp{list}.  If @samp{macro-name} takes a variable number of trailing
+arguments, there must be at least as many list elements as there are
+fixed arguments.
+@c clumsily worded or what
+
+Example:
+@c need a more useful example
+
+@smallexample
+(.apply .str (.iota 5))
+
+-->
+
+"01234"
+@end smallexample
+
+Note that @code{(.str (.iota 5))} is an error.  Here the list
+@samp{(0 1 2 3 4)} is passed as the first argument of @code{.str},
+which is wrong.
+
+@node Defining a macro inline
+@section Defining a macro inline
+
+Define a macro inline with @code{.pmacro}.
+This is only supported when passing macros as arguments to other macros.
+
+@smallexample
+(define-pmacro (load-op suffix op2-op mode ext-op)
+  (begin
+    (dni (.sym ld suffix) (.str "ld" suffix)
+        ()
+        (.str "ld" suffix " $dr,@@$sr")
+        (+ OP1_2 op2-op dr sr)
+        (set dr (ext-op WI (mem: mode sr)))
+        ())
+  )
+)
+
+(load-op "" OP2_12 WI (.pmacro (mode expr) expr))
+(load-op b OP2_8 QI (.pmacro (mode expr) (ext: mode expr)))
+(load-op h OP2_10 HI (.pmacro (mode expr) (ext: mode expr)))
+(load-op ub OP2_9 QI (.pmacro (mode expr) (zext: mode expr)))
+(load-op uh OP2_11 HI (.pmacro (mode expr) (zext: mode expr)))
+@end smallexample
+
+Currently, .pmacro's don't bind the way Scheme lambda expressions do.
+For example, arg2 in the second pmacro is not bound to the arg2 argument
+of the first pmacro.
+
+@smallexample
+(define-pmacro (foo arg1 arg2) ((.pmacro (bar) (+ arg2 bar)) arg1))
+(foo 3 4) ==> (+ arg2 3)
+@end smallexample
+
+One can make an argument either way.  I'm not sure what the right thing
+to do here is (leave things as is, or have lexical binding like Scheme).
+
+@node Passing macros as arguments
+@section Passing macros as arguments
+
+Macros may be passed to other macros.
+
+Example:
+
+@smallexample
+(define-pmacro (no-ext-expr mode expr) expr)
+(define-pmacro (ext-expr mode expr) (ext: mode expr))
+(define-pmacro (zext-expr mode expr) (zext: mode expr))
+
+(define-pmacro (load-op suffix op2-op mode ext-op)
+  (begin
+    (dni (.sym ld suffix) (.str "ld" suffix)
+        ()
+        (.str "ld" suffix " $dr,@@$sr")
+        (+ OP1_2 op2-op dr sr)
+        (set dr (ext-op WI (mem: mode sr)))
+        ())
+  )
+)
+
+(load-op "" OP2_12 WI no-ext-expr)
+(load-op b OP2_8 QI ext-expr)
+(load-op h OP2_10 HI ext-expr)
+(load-op ub OP2_9 QI zext-expr)
+(load-op uh OP2_11 HI zext-expr)
+@end smallexample
diff --git a/cgen/doc/porting.texi b/cgen/doc/porting.texi
new file mode 100644 (file)
index 0000000..551953e
--- /dev/null
@@ -0,0 +1,863 @@
+@c Copyright (C) 2000 Red Hat, Inc.
+@c This file is part of the CGEN manual.
+@c For copying conditions, see the file cgen.texi.
+
+@node Porting
+@chapter Porting
+@cindex Porting
+
+This chapter describes how to do a CGEN port.
+It focuses on doing binutils and simulator ports, but the general
+procedure should be generally applicable.
+
+@menu
+* Introduction to porting::
+* Supported Guile versions::
+* Running configure::
+* Writing a CPU description file::
+* Doing an opcodes port::
+* Doing a GAS port::
+* Building a GAS test suite::
+* Doing a simulator port::
+* Building a simulator test suite::
+@end menu
+
+@node Introduction to porting
+@section Introduction to porting
+
+Doing a GNU tools port for a new processor basically consists of porting the
+following components more or less in order.  The order can be changed,
+of course, but the following order is reasonable.  Certainly things like
+BFD and opcodes need to be finished earlier than others.  Bugs in
+earlier pieces are often not found until testing later pieces so each
+piece isn't necessarily finished until they all are.
+
+@itemize @bullet
+@item DejaGNU
+@item BFD
+@item CGEN
+@item Opcodes
+@item GAS
+@item Binutils
+@item Linker (@code{ld})
+@item newlib
+@item libgloss
+@item simulator
+@item GCC
+@item GDB
+@end itemize
+
+The use of CGEN affects the opcodes, GAS, and simulator portions only.
+As always, the M32R port is a good reference base.
+
+One goal of CGEN is to describe the CPU in an application independent manner
+so that program generators can do all the repetitive work of generating
+code and tables for each CPU that is ported.
+
+For opcodes, several files are generated.  No additional code need be
+written in the opcodes directory although as an escape hatch the user
+can add target specific code to file <arch>.opc in the CGEN source
+directory.  These functions will be included in the relevant generated
+files.  An example of when you need to create an <arch>.opc file is when
+there are special pseudo-ops that need to be parsed, for example the
+high/shigh pseudo-ops of the M32R.
+@xref{Doing an opcodes port}.
+
+For GAS, no files are generated (except test cases!) so the port is done
+more or less like the other GAS ports except that the assembler uses the
+CGEN-built opcode table plus @file{devo/gas/cgen.[ch]}.
+
+For the simulator, several files are built, and other support files need
+to be written.  @xref{Doing a simulator port}.
+
+@node Supported Guile versions
+@section Supported Guile versions
+
+In order to avoid suffering from the bug of the day when using
+snapshots, CGEN development has been confined to Guile releases only.
+As of this writing (1999-04-26) only Guile 1.2 and 1.3 are supported.
+At some point in the future older versions of Guile will no longer be
+supported.
+
+If using Guile 1.2, configure it with @code{--enable-guile-debug
+--enable-dynamic-linking} to work around an unknown bug in this version
+of Guile.  I ran into this on Solaris 2.6.
+
+@node Running configure
+@section Running @code{configure}
+
+When doing porting or maintenance activity with CGEN, the build tree
+must be configured with the @code{--enable-cgen-maint} option.  This
+adds the necessary dependencies to the @file{devo/opcodes} and
+@file{devo/sim} directories.
+
+CGEN uses Guile so it must be installed.  At present the CGEN configury
+requires that if Guile isn't installed in @file{/usr/local} then the 
+@code{--with-guile=/guile/install/dir} option must be passed to
+@file{configure} to specify where Guile is installed.
+
+@node Writing a CPU description file
+@section Writing a CPU description file
+
+The first step in doing a CGEN port is writing a CPU description file.
+The best way to do that is to take an existing file (such as the M32R)
+and use it as a template.
+
+Writing a CPU description file generally involves writing each of the
+following types of entries, in order.  @xref{RTL} for detailed
+descriptions of each type of entry that appears in the description file.
+
+@menu
+* Conventions::                      Programming style conventions 
+* Writing define-arch::              Architecture wide specs
+* Writing define-isa::               Instruction set characteristics
+* Writing define-cpu::               CPU families
+* Writing define-mach::              Machine variants
+* Writing define-model::             Models of each machine variant
+* Writing define-hardware::          Hardware elements
+* Writing define-ifield::            Instruction fields
+* Writing define-normal-insn-enum::  Instruction enums
+* Writing define-operand::           Instruction operands
+* Writing define-insn::              Instructions
+* Writing define-macro-insn::        Macro instructions
+* Using define-pmacro::              Preprocessor macros
+* Interactive development::          Useful things to do in a Guile shell
+@end menu
+
+@node Conventions
+@subsection Conventions
+
+First a digression on conventions and programming style.
+
+@enumerate 1
+@item @code{define-foo} vs. @code{define-normal-foo}
+
+Each CPU description @code{define-} entry generally provides two forms:
+the normal form and the general form.  The normal form has a simple,
+fixed-argument syntax that allows one to specify the most popular
+elements.  When one needs to specify more obscure elements of the
+entry one uses the long form which is a list of name/value pairs.  The
+naming convention is to call the normal form @code{define-normal-foo}
+and the general form @code{define-foo}.
+
+@item Parentheses placement
+
+Consider:
+
+@example
+(define-normal-insn-enum
+  insn-op1 "insn format enums" () f-op1 OP1_
+  (ADD ADDC SUB SUBC
+   AND OR   XOR INV)
+)
+@end example
+
+All Lisp/Scheme code I've read puts the trailing parenthesis on the
+previous line.  CGEN programming style says the last trailing
+parenthesis goes on a line by itself.  If someone wants to put forth an
+argument of why this should change, please do.  I like putting the
+very last parenthesis on a line by itself in column 1 because it makes
+it easier to traverse the file with a parenthesis matching keystroke.
+
+@item @code{StudlyCaps} vs. @code{_} vs. @code{-}
+
+The convention is to have most things lowercase with words separated by
+@samp{-}.  Things that are uppercase are fixed and well defined: enum
+values and mode names.
+@c FIXME: Seems to me there's a few others.
+This convention must be followed.
+@end enumerate
+
+@node Writing define-arch
+@subsection Writing define-arch
+
+Various simple and architecture-wide common things like the name of the
+processor must be defined somewhere, so all of this stuff is put under
+@code{define-arch}.
+
+This must be the first entry in the description file.
+
+@node Writing define-isa
+@subsection Writing define-isa
+
+There are two purposes to @code{define-isa}.
+The first is to specify parameters needed to decode instructions.
+
+The second is to give the instruction set a name.  This is important for
+architectures like the ARM where one CPU can execute multiple
+instruction sets.
+
+@node Writing define-cpu
+@subsection Writing define-cpu
+
+CPU families are an internal and artificial classification designed to
+collect processor variants that are sufficiently similar together under
+one roof for the simulator.  What is ``sufficiently similar'' is up to
+the programmer.  For example, if the only difference between two
+processor variants is that one has a few extra instructions, there's no
+point in treating them separately in the simulator.
+
+When simulating the variant without the extra instructions, said
+instructions are marked as ``invalid''.  On the other hand, putting 32
+and 64 bit variants of an architecture under one roof is problematic
+since the word size is different.  What ``under one roof'' means is left
+fuzzy for now, but basically the simulator engine has a collection of
+structures defining internal state, and ``CPU families'' minimize the
+number of copies of generated code that manipulate this state.
+
+@node Writing define-mach
+@subsection Writing define-mach
+
+CGEN uses ``mach'' in the same sense that BFD uses ``mach''.
+``Mach'', which is short for `machine', defines a variant of
+the architecture. 
+
+@c There may be a need for a many-to-one correspondence between CGEN
+@c machs and BFD machs.
+
+@node Writing define-model
+@subsection Writing define-model
+
+When describing a CPU, in any context, there is ``architecture'' and
+there is ``implementation''.  In CGEN parlance a ``model'' is an
+implementation of a ``mach''.  Models specify pipeline and other
+performance related characteristics of the implementation.
+
+Some architectures bring pipeline details up into the architecture
+(rather than making them an implementation detail).  It's not clear
+yet how to handle all the various possibilities so at present this is
+done on a case-by-case basis.  Maybe a straightforward solution will
+emerge.
+
+@node Writing define-hardware
+@subsection Writing define-hardware
+
+The registers of the processor are specified with
+@code{define-hardware}.  Also, immediate constants and addresses are
+defined to be ``hardware''.  By convention, all hardware elements names
+are prefaced with @samp{h-}.  This convention must be followed.
+
+Pre-defined hardware elements are:
+
+@table @code
+@item h-memory
+Normal CPU memory@footnote{A temporary simplifying assumption is to treat all
+memory identically.  Being able to specify various kinds of memory
+(e.g. on-chip RAM,ROM) is work-in-progress.}
+@item h-sint
+signed integer
+@item h-uint
+unsigned integer
+@item h-addr
+an address
+@item h-iaddr
+an instruction address
+@end table
+
+Where are floats you ask?  They'll be defined when the need arises.
+
+The program counter is named @samp{h-pc} and must be specified.
+It is not a builtin element as sometimes architectures need to
+modify its behaviour (in the get/set specs).
+
+@node Writing define-ifield
+@subsection Writing define-ifield
+
+Writing instruction field entries involves analyzing the instruction set
+and creating an entry for each field.  If a field has multiple purposes,
+one can create separate entries for each intended purpose.  The names
+should generally follow the names used by the architecture reference
+manual.
+
+By convention, all instruction field names are prefaced with @samp{f-}.  This
+convention must be followed.
+
+@node Writing define-normal-insn-enum
+@subsection Writing define-normal-insn-enum
+
+Writing instruction enum entries involves analyzing the instruction set
+and attaching names to the opcode fields.  For example, if a field named
+@samp{op1} is used to select which of add, addc, sub, subc, and, or,
+xor, and inv instructions, one would write something like the following:
+
+@example
+(define-normal-insn-enum
+  insn-op1 "insn format enums" () f-op1 OP1_
+  (ADD ADDC SUB SUBC
+   AND OR   XOR INV)
+)
+@end example
+
+These entries simplify instruction definitions by giving a name to a
+particular value for a particular instruction field.  By convention,
+enum names are uppercase.  This convention must be followed.
+
+@node Writing define-operand
+@subsection Writing define-operand
+
+Operands are what instruction semantics use to refer to hardware
+elements.  The typical use of an operand is to map instruction fields to
+hardware.  For example, if field @samp{f-r2} is used to specify one of
+the registers defined by the @code{h-gr} hardware entry, one would
+write:
+
+@code{(dnop sr "source register" () h-gr f-r2)}
+
+@code{dnop} is short for ``define normal operand'' @footnote{A profound
+aversion to typing causes me to often provide brief names of things that
+get typed a lot.}.  @xref{RTL} for more information.
+
+@node Writing define-insn
+@subsection Writing define-insn
+
+This involves going through the CPU manual and writing an entry for each
+instruction.  Instructions specific to a particular machine variant are
+indicated so with the `MACH' attribute.  Example:
+
+@example
+(define-normal-insn
+  add "add instruction
+  ((MACH mach1)) ; or (MACH mach1,mach2,...) for multiple variants
+  ...
+)
+@end example
+
+The `base' machine is a predefined machine variant that includes
+instructions available to all variants, and is the default if no
+`MACH' attribute is specified.
+
+When the @file{.cpu} file is processed, CGEN will analyze the semantics
+to determine:
+
+@itemize @bullet
+@item input operands
+
+The list of hardware elements read by the instruction.
+
+@item output operands
+
+The list of hardware elements written by the instruction.
+
+@item attributes
+
+Instruction attributes that can be computed from the semantics.
+
+CTI: control transfer instruction, generally a branch.
+
+@itemize @bullet
+@item UNCOND-CTI
+
+The instruction unconditionally sets pc.
+
+@item COND-CTI
+
+The instruction conditionally sets pc.
+
+@item SKIP-CTI
+
+NB. This is an expermental attribute.  Its usage needs to evolve.
+
+@item DELAY-SLOT
+
+NB. This is an expermental attribute.  Its usage needs to evolve.
+@end itemize
+
+@end itemize
+
+CGEN will also try to simplify the semantics as much as possible:
+
+@itemize @bullet
+@item Constant folding
+
+Expressions involving constants are simplified and any resulting
+non-taken paths of conditional expressions are discarded.
+@end itemize
+
+@node Writing define-macro-insn
+@subsection Writing define-macro-insn
+
+Some instructions are really aliases for other instructions, maybe even
+a sequence of them.  For example, an architecture that has a general
+decrement-then-store instruction might have a specialized version of
+this instruction called @code{push} supported by the assembler.  These
+are handled with ``macro instructions''.  Macro instructions are used by
+the assembler/disassembler only.  They are not used by the simulator.
+
+@node Using define-pmacro
+@subsection Using define-pmacro
+
+When a group of entries, say instructions, share similar information, a
+macro (in the C preprocessor sense) can be used to simplify the
+description.  This can be used to save a lot of typing, which also
+improves readability since often 1 page of code is easier to understand
+than 4.
+
+Here is an example from the M32R port.
+
+@example
+(define-pmacro (bin-op mnemonic op2-op sem-op imm-prefix imm)
+  (begin
+     (dni mnemonic
+         (.str mnemonic " reg/reg")
+         ()
+         (.str mnemonic " $dr,$sr")
+         (+ OP1_0 op2-op dr sr)
+         (set dr (sem-op dr sr))
+         ()
+     )
+     (dni (.sym mnemonic "3")
+         (.str mnemonic " reg/" imm)
+         ()
+         (.str mnemonic "3 $dr,$sr," imm-prefix "$" imm)
+         (+ OP1_8 op2-op dr sr imm)
+         (set dr (sem-op sr imm))
+         ()
+     )
+   )
+)
+(bin-op add OP2_10 add "$hash" slo16)
+(bin-op and OP2_12 and ""      uimm16)
+(bin-op or  OP2_14 or  "$hash" ulo16)
+(bin-op xor OP2_13 xor ""      uimm16)
+@end example
+
+@code{.sym/.str} are short for Scheme's @code{symbol-append} and
+@code{string-append} operations and are conceptually the same as the C
+preprocessor's @code{##} concatenation operator.  @xref{Symbol
+concatenation} and @xref{String concatenation} for details.
+
+@node Interactive development
+@subsection Interactive development
+
+The normal way@footnote{Normal for me anyway, certainly each person will have
+their own preference} of writing a CPU description file involves starting Guile
+and developing the .CPU file interactively.  The basic steps are
+
+@enumerate 1
+@item Run @code{guile}.
+@item @code{(load "dev.scm")}
+@item Load application, e.g. @code{(load-opc)} or @code{(load-sim)}
+@item Load CPU description file, e.g. @code{(cload #:arch "m32r")}
+@item Run generators until output looks reasonable, e.g. @code{(cgen-opc.c)}
+@end enumerate
+
+To assist in the development process and to cut down on some typing,
+@file{dev.scm} looks for @file{$HOME/.cgenrc} and, if present, loads it.
+Typical things that @file{.cgenrc} contains are definitions of procedures
+that combine steps 3 and 4 above.
+
+Example:
+
+@example
+(define (m32r-opc)
+  (load-opc)
+  (cload #:arch "m32r")
+)
+(define (m32r-sim)
+  (load-sim)
+  (cload #:arch "m32r" #:options "with-scache with-profile=fn")
+)
+(define (m32rbf-sim)
+  (load-sim)
+  (cload #:arch "m32r" #:machs "m32r" #:options "with-scache with-profile=fn")
+)
+(define (m32rxf-sim)
+  (load-sim)
+  (cload #:arch "m32r" #:machs "m32rx" #:options "with-scache with-profile=fn")
+)
+@end example
+
+CPU description files are loaded into an interactive guile session with
+@code{cload}.  The syntax is:
+
+@example
+(cload #:arch arch
+       [#:machs "mach-list"]
+       [#:isas "isa-list"]
+       [#:options "option-list"])
+@end example
+
+Only the @code{#:arch} argument is mandatory.
+
+@samp{mach-list} is a comma separated string of machines to keep.
+
+@samp{isa-list} is a comma separated string of isas to keep.
+
+@samp{options} is a space separated string of options for the application.
+
+@node Doing an opcodes port
+@section Doing an opcodes port
+
+The best way to begin a port is to take an existing one (preferably one
+that is similar to the new port) and use it as a template.
+
+@enumerate 1
+@item Run @code{guile}.
+@item @code{(load "dev.scm")}. This loads in a set of interactive
+development routines.
+@item @code{(load-opc)}. Load the opcodes support.
+@item Edit your @file{<arch>.cpu} and @file{<arch>.opc} files.
+        @itemize @bullet
+        @item The @file{.cpu} file is the main description file.
+       @item The @file{.opc} file provides additional C support code.
+        @end itemize
+@item @code{(cload #:arch "<arch>")}
+@item Run each of:
+        @itemize @bullet
+        @item @code{(cgen-desc.h)}
+        @item @code{(cgen-desc.c)}
+        @item @code{(cgen-opc.h)}
+       @item @code{(cgen-opc.c)}
+       @item @code{(cgen-ibld.in)}
+       @item @code{(cgen-asm.in)}
+       @item @code{(cgen-dis.in)}
+       @item @code{(cgen-opinst.c)} -- [optional]
+        @end itemize
+@item Repeat steps 4, 5 and 6 until the output looks reasonable.
+@item Add dependencies to @file{opcodes/Makefile.am} to generate the
+eight opcodes files (use the M32R port as an example).
+@item Run @code{make dep} from the @file{opcodes} build directory.
+@item Run @code{make all-opcodes} from the top level build directory.
+@end enumerate
+
+Note that Guile is not currently shipped with Binutils, etc.  Until
+Guile is shipped with Binutils, etc. or a C implementation of CGEN is
+done, the generated files are installed in the source directory and
+checked into CVS.
+
+@node Doing a GAS port
+@section Doing a GAS port
+
+A GAS CGEN port is essentially no different than a normal port except
+that the CGEN opcode table is used, and there are extra supporting
+routines available in @file{gas/cgen.[ch]}.  As always, a good way to
+get started is to take the M32R port as a template and go from there.
+
+The important CGEN-specific things to keep in mind are:
+@c to be expanded on as time permits
+
+@itemize @bullet
+@item Several support routines are provided by @file{gas/cgen.c}.  Some
+must be used, others are available to use if you want to (in general
+they should be used unless it's not possible).
+
+        @itemize @bullet
+        @item @code{gas_cgen_init_parse}
+                @itemize @minus
+                @item Call from @code{md_assemble} before doing anything 
+                        else.
+                @item Must be used.
+                @end itemize
+        @item @code{gas_cgen_record_fixup}
+                @itemize @minus
+                @item Cover function to @code{fix_new}.
+                @end itemize
+        @item @code{gas_cgen_record_fixup_exp}
+                @itemize @minus
+                @item Cover function to @code{fix_new_exp}.
+                @end itemize
+        @item @code{gas_cgen_parse_operand}
+                @itemize @minus 
+                @item Callback for opcode table based parser, set in
+                        @code{md_begin}.
+                @end itemize
+        @item @code{gas_cgen_finish_insn}
+                @itemize @minus
+                @item After parsing an instruction, call this to add the 
+                        instruction to the frag and queue any fixups.
+                @end itemize
+        @item @code{gas_cgen_md_apply_fix3}
+                @itemize @minus
+                @item Provides basic @code{md_apply_fix3} support.
+                @item @code{#define md_apply_fix3
+                        gas_cgen_md_apply_fix3} if you're able to use
+                        it.
+                @end itemize
+        @item @code{gas_cgen_tc_gen_reloc}
+                @itemize @minus
+                       @item Provides basic @code{tc_gen_reloc} support in function.
+                @item @code{#define tc_gen_reloc gas_cgen_tc_gen_reloc}
+                        if you're able to use it.
+                @end itemize
+        @end itemize
+
+@item @code{md_begin} should contain the following (plus anything else you
+want of course):
+
+@example
+  /* Set the machine number and endianness.  */
+  gas_cgen_opcode_desc =
+    <arch>_cgen_opcode_open (CGEN_CPU_OPEN_MACHS,
+                             0 /* mach number */,
+                             CGEN_CPU_OPEN_ENDIAN,
+                             (target_big_endian
+                              ? CGEN_ENDIAN_BIG
+                              : CGEN_ENDIAN_LITTLE),
+                             CGEN_CPU_OPEN_END);
+
+  <arch>_cgen_init_asm (gas_cgen_opcode_desc);
+
+  /* This is a callback from cgen to gas to parse operands.  */
+  cgen_set_parse_operand_fn (gas_cgen_opcode_desc, gas_cgen_parse_operand);
+@end example
+
+@item @code{md_assemble} should contain the following basic framework:
+
+@example
+@{
+  const CGEN_INSN *insn;
+  char *errmsg;
+  CGEN_FIELDS fields;
+#if CGEN_INT_INSN_P
+  cgen_insn_t buffer[CGEN_MAX_INSN_SIZE / sizeof (CGEN_INSN_INT)];
+#else
+  char buffer[CGEN_MAX_INSN_SIZE];
+#endif
+
+  gas_cgen_init_parse ();
+
+  insn = m32r_cgen_assemble_insn (gas_cgen_opcode_desc, str, 
+                                  &fields, buffer, &errmsg);
+  
+  if (! insn)
+    @{
+      as_bad (errmsg);
+      return;
+    @}
+
+  gas_cgen_finish_insn (insn, buffer, CGEN_FIELDS_BITSIZE (&fields),
+     relax_p, /* non-zero to allow relaxable insns */
+     result); /* non-null if results needed for later */
+@}
+@end example
+
+@end itemize
+
+@node Building a GAS test suite
+@section Building a GAS test suite
+
+CGEN can also build the template for test cases for all instructions.  In
+some cases it can also generate the actual instructions.  The result is
+then assembled, disassembled, verified, and checked into CVS.  Further
+changes are usually done by hand as it's easier.  The goal here is to
+save the enormous amount of initial typing that is required.
+
+@enumerate 1
+@item @code{cd} to the CGEN build directory
+@item @code{make gas-test}
+
+At this point two files have been created in the CGEN build directory:
+@file{gas-allinsn.exp} and @file{gas-build.sh}.
+
+@item Copy @file{gas-allinsn.exp} to @file{devo/gas/testsuite/gas/<arch>/allinsn.exp}.
+@item @code{sh gas-build.sh $build/gas}
+
+At this point directory tmpdir contains two files: @file{allinsn.s} and
+@file{allinsn.d}.  File @file{allinsn.d} usually needs a bit of massaging.
+
+@item Copy @file{tmpdir/allinsn.[sd]} to @file{devo/gas/testsuite/gas/<arch>}
+@item Run @code{make check} in the @file{gas} build directory and
+massage things until you're satisfied the files are correct.
+@item Check files into CVS.
+@end enumerate
+
+At this point further additions/modifications are usually done by hand.
+
+@node Doing a simulator port
+@section Doing a simulator port
+
+The same basic procedure for opcodes porting applies here.
+
+@enumerate 1
+@item Run @code{guile}.
+@item @code{(load "dev.scm")}
+@item @code{(load-sim)}
+@item Edit your @file{<arch>.cpu} file.
+@item @code{(cload #:arch "<arch>")}
+@item Run each of:
+        @itemize @bullet
+       @item @code{(cgen-arch.h)}
+       @item @code{(cgen-arch.c)}
+       @item @code{(cgen-cpuall.h)}
+        @end itemize
+@item Repeat steps 4,5,6 until the output looks reasonable.
+@item Edit your <arch>.cpu file.
+@item @code{(cload #:arch "<arch>" #:machs "mach1[,mach2[,...]]")}
+@item Run each of:
+        @itemize @bullet
+       @item @code{(cgen-cpu.h)}
+       @item @code{(cgen-cpu.c)}
+       @item @code{(cgen-decode.h)}
+       @item @code{(cgen-decode.c)}
+       @item @code{(cgen-semantics.c)}
+       @item @code{(cgen-sem-switch.c)} -- only if using a switch()
+                version of semantics.
+       @item @code{(cgen-model.c)}
+        @end itemize
+@item Repeat steps 8, 9 and 10 until the output looks reasonable.
+@end enumerate
+
+The following additional files are also needed. These live in the
+@file{sim/<arch>} directory. Administrivia files like
+@file{configure.in} and @file{Makefile.in} are omitted.
+
+@itemize @bullet
+@item @file{sim-main.h}
+
+Main include file required by the ``common'' (@file{sim/common})
+support, and by each target's @file{.c} file.
+This file includes the relevant other headers.
+The order is fairly important.
+@file{m32r/sim-main.h} is a good starting point.
+
+@file{sim-main.h} also defines several types:
+
+@itemize @minus
+@item @code{_sim_cpu} -- a struct containing all state for a
+particular CPU.
+@item @code{sim_state} -- contains all state of the simulator.
+A @code{SIM_DESC} (which is the result of sim_open and is akin
+to a file descriptor) points to one of these.
+@item @code{sim_cia} -- type of an instruction address.  For
+CGEN this is generally ``word mode'', in GCC parlance.
+@end itemize
+
+@file{sim-main.h} also defines several macros:
+
+@itemize @minus
+@item @code{CIA_GET(cpu)} -- return ``cia'' of the CPU
+@item @code{CIA_SET(cpu,cia)} -- set the ``cia'' of the CPU
+@end itemize
+
+``cia'' is short for "current instruction address".
+
+The definition of @code{sim_state} is fairly simple.  Just copy the M32R
+case.  The definition of @code{_sim_cpu} is not simple, so pay
+attention.  The complexity comes from trying to create a ``derived
+class'' of @code{sim_cpu} for each CPU family.  What is done is define a
+different version of @code{sim_cpu} in each CPU family's set of files,
+with a common ``base class'' structure ``leading part'' for each
+@code{sim_cpu} definition used by non-CPU-family specific files.  The
+way this is done is by defining @code{WANT_CPU_<CPU-FAMILY-NAME>} at the
+top of CPU family specific files. The definition of @code{_sim_cpu} is
+then:
+
+@example
+       struct _sim_cpu @{
+         /* sim/common CPU base */
+         sim_cpu_base base;
+         /* Static parts of CGEN.  */
+         CGEN_CPU cgen_CPU;
+       #if defined (WANT_CPU_CPUFAM1)
+         CPUFAM1_CPU_DATA CPU_data;
+       #elif defined (WANT_CPU_CPUFAM2)
+         CPUFAM2_CPU_DATA CPU_data;
+       #endif
+       @};
+@end example
+
+@item @file{tconfig.in}
+
+This file predates @file{sim-main.h} and was/is intended to contain
+macros that configure the simulator sources.
+
+@itemize @bullet
+@item @code{SIM_HAVE_MODEL} -- enable @file{common/sim-model.[ch]}
+support.
+@item @code{SIM_HANDLES_LMA} -- makes @file{sim-hload.c} do the right
+thing.
+@item @code{WITH_SCACHE_PBB} -- define this to 1 if using pbb scaching.
+@end itemize
+
+@item @file{<arch>-sim.h}
+
+This file predates @file{sim-main.h} and contains miscellaneous macros
+and definitions used by the simulator.
+
+@item @file{mloop.in}
+
+This file contains code to implement the fetch/execute process.  There
+are various ways to do this, and several are supported.  Which one to
+choose depends on the environment in which the CPU will be used.  For
+example when executing a program in a single-CPU environment without
+devices, most or all available cycles can be devoted to simulation of the
+atarget CPU.  However, in an environment with devices or multiple cpus, one
+may wish the CPU to execute one instruction then relinquish control so a
+device operation may be done or an instruction can be simulated on a
+second cpu.  Efficient techniques for the former aren't necessarily the best
+for the latter.
+
+Three versions are currently supported:
+
+@enumerate 1
+@item simple -- fetch/decode/execute one insn
+@item scache -- same as simple but results of decoding are cached 
+@item pbb -- same as scache but several insns are handled each iteration
+pbb stands for pseudo basic block.
+@end enumerate
+
+This file is processed by @file{common/genmloop.sh} at build time. The
+result is two files: @file{mloop.c} and @file{eng.h}.
+
+@item @file{sim-if.c}
+
+By convention this file contains @code{sim_open}, @code{sim_close},
+@code{sim_create_inferior}, @code{sim_do_command}.  These functions can
+live in any file of course.  They're here because they're the parts of
+the @code{remote-sim.h} interface that aren't provided by the common
+directory.
+
+@item @file{<cpufam>.c}
+
+By convention this file contains register access and model support
+functions for a CPU family (the name of this file is misnamed in the
+M32R case).  The register access functions implement the
+@code{sim_fetch_register} and @code{sim_store_register} interface
+functions (named @code{<cpufam>_@{fetch,store@}_register}), and support
+code for register get/set rtl.  The model support functions implement the
+before/after handlers (functions that handle tracing/profiling) and
+timing for each function unit.
+
+@item Other files
+       
+The M32R port has two other handwritten files: @file{devices.c} and
+@file{traps.c}.  How you wish to organize this is up to you.
+@end itemize
+
+@node Building a simulator test suite
+@section Building a simulator test suite
+
+CGEN can also build the template for test cases for all instructions.  In
+some cases it can also generate the actual instructions
+@footnote{Although this hasn't been implemented yet.}.  The result is
+then verified and checked into CVS.  Further changes are usually done by
+hand as it's easier.  The goal here is to save the enormous amount of
+initial typing that is required.
+
+@enumerate 1
+@item @code{cd} to the CGEN build directory
+@item @code{make sim-test}
+
+At this point two files have been created in the CGEN build directory:
+@file{sim-allinsn.exp} and @file{sim-build.sh}.
+
+@item Copy @file{sim-allinsn.exp} to
+@file{devo/sim/testsuite/sim/<arch>/allinsn.exp}.
+@item @code{sh sim-build.sh}
+
+At this point a new subdirectory called @file{tmpdir} will be created
+and will contain one test case for each instruction.  The framework has
+been filled in but not the actual test case.  It's handy to write an
+``include file'' containing assembler macros that simplify writing test
+cases.  See @file{devo/sim/testsuite/sim/m32r/testutils.inc} for an
+example.
+
+@item write testutils.inc
+@item finish each test case
+@item copy @file{tmpdir/*.cgs} to @file{devo/sim/testsuite/sim/<arch>}
+@item run @code{make check} in the sim build directory and massage things until you're satisfied the files are correct
+@item Check files into CVS.
+@end enumerate
+
+@noindent At this point further additions/modifications are usually done 
+by hand.
diff --git a/cgen/doc/rtl.texi b/cgen/doc/rtl.texi
new file mode 100644 (file)
index 0000000..3e740db
--- /dev/null
@@ -0,0 +1,2276 @@
+@c Copyright (C) 2000 Red Hat, Inc.
+@c This file is part of the CGEN manual.
+@c For copying conditions, see the file cgen.texi.
+
+@node RTL
+@chapter CGEN's Register Transfer Language
+@cindex RTL
+@cindex Register Transfer Language
+
+CGEN uses a variant of GCC's Register Transfer Language as the basis for
+its CPU description language.
+
+@menu
+* RTL Introduction::            Introduction to CGEN's RTL
+* Trade-offs::                  Various trade-offs in the design
+* Rules and notes::             Rules and notes common to all entries
+* Definitions::                 Definitions in the description file
+* Attributes::                  Random data associated with any entry
+* Architecture variants::       Specifying variations of a CPU
+* Model variants::              Specifying variations of a CPU's implementation
+* Hardware elements::           Elements of a CPU
+* Instruction fields::          Fields of an instruction
+* Enumerated constants::        Assigning useful names to important numbers
+* Instruction operands::
+* Derived operands::            Operands for CISC-like architectures
+* Instructions::
+* Macro-instructions::
+* Modes::
+* Expressions::
+* Macro-expressions::
+@end menu
+
+@node RTL Introduction
+@section RTL Introduction
+
+The description language, or RTL
+@footnote{While RTL stands for Register Transfer Language, it is also used
+to denote the CPU description language as a whole.}, needs to support the
+definition of all the
+architectural and implementation features of a CPU, as well as enough
+information for all intended applications.  At present this is just the
+opcodes table and an ISA level simulator, but it is not intended that
+applications be restricted to these two areas.  The goal is having an
+application independent description of the CPU.  In the end that's a lot to
+ask for from one language.  Certainly gate level specification of a CPU
+is not attempted!
+
+The syntax of the language is inspired by GCC's RTL and by the Scheme
+programming language, theoretically taking the best of both.  To what
+extent that is true, and to what extent that is sufficient inspiration
+is certainly open to discussion.  In actuality, there isn't much difference
+here from GCC's RTL that is attributable to being Scheme-ish.  One
+important Scheme-derived concept is arbitrary precision of constants.
+Sign or zero extension of constants in GCC has always been a source of
+problems.  In CGEN'S RTL constants have modes and there are both signed
+and unsigned modes.
+
+Here is a graphical layout of the hierarchy of elements of a @file{.cpu}
+file.
+
+@example
+                           architecture
+                          /            \
+                    cpu-family1        cpu-family2  ...
+                      /     \            /      \
+                machine1   machine2  machine3   ...
+                 /   \
+             model1  model2  ...
+@end example
+
+Each of these elements is explained in more detail below.  The
+@emph{architecture} is one of @samp{sparc}, @samp{m32r}, etc.  Within
+the @samp{sparc} architecture, @emph{cpu-family} might be
+@samp{sparc32}, @samp{sparc64}, etc.  Within the @samp{sparc32} CPU
+family, the @emph{machine} might be @samp{sparc-v8}, @samp{sparclite},
+etc.  Within the @samp{sparc-v8} machine classification, @emph{model}
+might be @samp{hypersparc}, @samp{supersparc}, etc.
+
+Instructions form their own hierarchy as each instruction may be supported
+by more than one machine.  Also, some architectures can handle more than
+one instruction set on one chip (e.g. ARM).
+
+@example
+                     isa
+                      |
+                 instruction
+                    /   \         
+             operand1  operand2  ... 
+                |         |
+         hw1+ifield1   hw2+ifield2  ...
+@end example
+
+Each of these elements is explained in more detail below.
+
+@node Trade-offs
+@section Trade-offs
+
+While CGEN is written in Scheme, this is not a requirement.  The
+description language should be considered absent of any particular
+implementation, though certainly some things were done to simplify
+reading @file{.cpu} files with Scheme.  Scheme related choices have been
+made in areas that have no serious impact on the usefulness of the CPU
+description language.  Places where that is not the case need to be
+revisited, though there currently are no known ones.
+
+One place where the Scheme implementation influenced the design of
+CGEN's RTL is in the handling of modes.  The Scheme implementation was
+simplified by treating modes as an explicit argument, rather than as an
+optional suffix of the operation name.  For example, compare @code{(add
+SI dr sr)} in CGEN versus @code{(add:SI dr sr)} in GCC RTL.  The mode is
+treated as optional so a shorthand form of @code{(add dr sr)} works.
+
+@node Rules and notes
+@section Rules and notes
+
+A few basic guidelines for all entries:
+
+@itemize @bullet
+@item names must be valid Scheme symbols.
+@item comments are used, for example, to comment the generated C code
+@footnote{It is possible to produce a reference manual from
+@file{.cpu} files and such an application wouldn't be a bad idea.}.
+@item comments may be any number of lines, though generally succinct comments
+are preferable@footnote{It would be reasonable to have a short form
+and a long form of comment. Either as two entries are as one entry with
+the short form separated from the long form via some delimiter (say the
+first newline).}.
+@item everything is case sensitive.@footnote{??? This is true in RTL,
+though some apps add symbols and convert case that can cause collisions.}
+@item while "_" is a valid character to use in symbols, "-" is preferred
+@item except for the @samp{comment} and @samp{attrs} fields and unless
+otherwise specified all fields must be present.
+@end itemize
+
+Symbols and strings
+
+Symbols in CGEN are the same as in Scheme.
+Symbols can be used anywhere a string can be used.
+The reverse is not true, and in general strings can't be used in place
+of symbols.
+
+@node Definitions
+@section Definitions
+@cindex Definitions
+
+Each entry has the same format: @code{(define-foo arg1 arg2 ...)}, where
+@samp{foo} designates the type of entry (e.g. @code{define-insn}).  In
+the general case each argument is a name/value pair expressed as
+@code{(name value)}.
+(*note: Another style in common use is `:name value' and doesn't require
+parentheses.  Maybe that would be a better way to go here.  The current
+style is easier to construct from macros though.)
+
+While the general case is flexible, it also is excessively verbose in
+the normal case.  To reduce this verbosity, a second version of most
+define-foo's exists that takes positional arguments.  To further reduce
+this verbosity, preprocessor macros can be written to simplify things
+further for the normal case.  See sections titled ``Simplification
+macros'' below.
+
+@node Attributes
+@section Attributes
+@cindex Attributes
+
+Attributes are used throughout for specifying various properties.
+For portability reasons attributes can only have 32 bit integral values
+(signed or unsigned).
+@c How about an example?
+
+There are four kinds of attributes: boolean, integer, enumerated, and bitset.
+Boolean attributes can be achieved via others, but they occur frequently
+enough that they are special cased (and one bit can be used to record them).
+Bitset attributes are a useful simplification when one wants to indicate an
+object can be in one of many states (e.g. an instruction may be supported by
+multiple machines).
+
+String attributes might be a useful addition.
+Another useful addition might be functional attributes (the attribute
+is computed at run-time - currently all attributes are computed at
+compile time).  One way to implement functional attributes would be to
+record the attributes as byte-code and lazily evaluate them, caching the
+results as appropriate.  The syntax has been carefully done to not
+preclude either as an upward compatible extension.
+
+Attributes must be defined before they can be used.
+There are several predefined attributes for entry types that need them
+(instruction field, hardware, operand, and instruction).  Predefined
+attributes are documented in each relevant section below.
+
+In C applications an enum is created that defines all the attributes.
+Applications that wish to be architecture independent need the attribute
+to have the same value across all architectures.  This is achieved by
+giving the attribute the INDEX attribute, which specifies the enum value
+must be fixed across all architectures.
+@c FIXME: Give an example here.
+@c FIXME: Need a better name than `INDEX'.
+
+Convention requires attribute names consist of uppercase letters, numbers,
+"-", and "_", and must begin with a letter.
+To be consistent with Scheme, "-" is preferred over "_".
+
+@subsection Boolean Attributes
+@cindex Attributes, boolean
+
+Boolean attributes are defined with:
+
+@example
+(define-attribute
+  (type boolean)
+  (for user-list)
+  (name attribute-name)
+  (comment "attribute comment")
+  (attrs attribute-attributes)
+)
+@end example
+
+The default value of boolean attributes is always false.  This can be
+relaxed, but it's one extra complication that is currently unnecessary.
+Boolean attributes are specified in either of two forms: (NAME expr),
+and NAME, !NAME.  The first form is the canonical form.  The latter two
+are shorthand versions.  `NAME' means "true" and `!NAME' means "false".
+@samp{expr} is an expression that evaluates to 0 for false and non-zero
+for true @footnote{The details of @code{expr} is still undecided.}.
+
+@code{user-list} is a space separated list of entry types that will use
+the attribute.  Possible values are: @samp{attr}, @samp{enum},
+@samp{cpu}, @samp{mach}, @samp{model}, @samp{ifield}, @samp{hardware},
+@samp{operand}, @samp{insn} and @samp{macro-insn}.  If omitted all are
+considered users of the attribute.
+
+@subsection Integer Attributes
+@cindex Attributes, integer
+
+Integer attributes are defined with:
+
+@example
+(define-attribute
+  (type integer)
+  (for user-list)
+  (name attribute-name)
+  (comment "attribute comment")
+  (attrs attribute-attributes)
+  (default expr)
+)
+@end example
+
+If omitted, the default is 0.
+
+(*note: The details of `expr' is still undecided.  For now it must be
+an integer.)
+
+Integer attributes are specified with (NAME expr).
+
+@subsection Enumerated Attributes
+@cindex Attributes, enumerated
+
+Enumerated attributes are the same as integer attributes except the
+range of possible values is restricted and each value has a name.
+Enumerated attributes are defined with
+
+@example
+(define-attribute
+  (type enum)
+  (for user-list)
+  (name attribute-name)
+  (comment "attribute comment")
+  (attrs attribute-attributes)
+  (values enum-value1 enum-value2 ...)
+  (default expr)
+)
+@end example
+
+If omitted, the default is the first specified value.
+
+(*note: The details of `expr' is still undecided.  For now it must be the
+name of one of the specified values.)
+
+Enum attributes are specified with (NAME expr).
+
+@subsection Bitset Attributes
+@cindex Attributes, bitset
+
+Bitset attributes are for situations where you want to indicate something
+is a subset of a small set of possibilities.  The MACH attribute uses this
+for example to allow specifying which of the various machines support a
+particular insn.
+(*note: At present the maximum number of possibilities is 32.
+This is an implementation restriction which can be relaxed, but there's
+currently no rush.)
+
+Bitset attributes are defined with:
+
+@example
+(define-attribute
+  (type bitset)
+  (for user-list)
+  (name attribute-name)
+  (comment "attribute comment")
+  (attrs attribute-attributes)
+  (values enum-value1 enum-value2 ...)
+  (default default-name)
+)
+@end example
+
+@samp{default-name} must be the name of one of the specified values.  If
+omitted, it is the first value.
+
+Bitset attributes are specified with @code{(NAME val1,val2,...)}.  There
+must be no spaces in ``@code{val1,val2,...}'' and each value must be a
+valid Scheme symbol.
+
+(*note: it's not clear whether allowing arbitrary expressions will be
+useful here, but doing so is not precluded.  For now each value must be
+the name of one of the specified values.)
+
+@node Architecture variants
+@section Architecture Variants
+@cindex Architecture variants
+
+The base architecture and its variants are described in four parts:
+@code{define-arch}, @code{define-isa}, @code{define-cpu}, and
+@code{define-mach}.
+
+@menu
+* define-arch::
+* define-isa::
+* define-cpu::
+* define-mach::
+@end menu
+
+@node define-arch
+@subsection define-arch
+@cindex define-arch
+
+@code{define-arch} describes the overall architecture, and must be
+present.
+
+The syntax of @code{define-arch} is:
+
+@example
+(define-arch
+  (name architecture-name) ; e.g. m32r
+  (comment "description")  ; e.g. "Mitsubishi M32R"
+  (attrs attribute-list)
+  (default-alignment aligned|unaligned|forced)
+  (insn-lsb0? #f|#t)
+  (machs mach-name-list)
+  (isas isa-name-list)
+)
+@end example
+
+@subsubsection default-alignment
+
+Specify the default alignment to use when fetching data (and
+instructions) from memory.  At present this can't be overridden, but
+support can be added if necessary.  The default is @code{aligned}.
+
+@subsubsection insn-lsb0?
+@cindex insn-lsb0?
+
+Specifies whether the most significant or least significant bit in a
+word is bit number 0.  Generally this should conform to the convention
+in the architecture manual.  This is independent of endianness and is an
+architecture wide specification.  There is no support for using
+different bit numbering conventions within an architecture.
+@c Not that such support can't be added of course.
+
+Instruction fields are always numbered beginning with the most
+significant bit.  That is, the `start' of a field is always its most
+significant bit.  For example, a 4 bit field in the uppermost bits of a
+32 bit instruction would have a start/length of (31 4) when insn-lsb0? =
+@code{#t}, and (0 4) when insn-lsb0? = @code{#f}.
+
+@subsubsection mach-name-list
+
+The list of names of machines in the architecture.
+There should be one entry for each @code{define-mach}.
+
+@subsubsection isa-name-list
+
+The list of names of instruction sets in the architecture.
+There must be one for each @code{define-isa}.
+An example of an architecture with more than one is the ARM which
+has a 32 bit instruction set and a 16 bit "Thumb" instruction set
+(the sizes here refer to instruction size).
+
+@node define-isa
+@subsection define-isa
+@cindex define-isa
+
+@code{define-isa} describes aspects of the instruction set.
+A minimum of one ISA must be defined.
+
+The syntax of @code{define-isa} is:
+
+@example
+(define-isa
+  (name isa-name)
+  (comment "description")
+  (attrs attribute-list)
+  (default-insn-word-bitsize n)
+  (default-insn-bitsize n)
+  (base-insn-bitsize n)
+  (decode-assist (b0 b1 b2 ...))
+  (liw-insns n)
+  (parallel-insns n)
+  (condition ifield-name expr)
+  (setup-semantics expr)
+  (decode-splits decode-split-list)
+  ; ??? missing here are fetch/execute specs
+)
+@end example
+
+@subsubsection default-insn-word-bitsize
+
+Specifies the default size of an instruction word in bits.
+This affects the numbering of field bits in words beyond the
+base instruction.
+@xref{Instruction fields} for more information.
+
+??? There is currently no explicit way to specify a different instruction
+word bitsize for particular instructions, it is derived from the instruction
+field specs.
+
+@subsubsection default-insn-bitsize
+
+The default size of an instruction in bits. It is generally the size of
+the smallest instruction. It is used when parsing instruction fields.
+It is also used by the disassembler to know how many bytes to skip for
+unrecognized instructions.
+
+@subsubsection base-insn-bitsize
+
+The minimum size of an instruction, in bits, to fetch during execution.
+If the architecture has a variable length instruction set, this is the
+size of the initial word to fetch.  There is no need to specify the
+maximum length of an instruction, that can be computed from the
+instructions.  Examples:
+
+@table @asis
+@item i386
+8
+@item M68k
+16
+@item SPARC
+32
+@item M32R
+32
+@end table
+
+The M32R case is interesting because instructions can be 16 or 32 bits.
+However instructions on 32 bit boundaries can always be fetched 32 bits
+at a time as 16 bit instructions always come in pairs.
+
+@subsubsection decode-assist
+@cindex decode-assist
+
+Which bits to initially use to decode the instruction.
+For example on the SPARC these are bits: 31 30 24 23 22 21 20 19.
+The rest of the decoder is machine generated.
+The intent of @code{decode-assist} is to give the machine generated
+code a head start.
+
+??? It might be useful to provide greater control, but this is sufficient
+for now.
+
+It is okay if the opcode bits are over-specified for some instructions.
+It is also okay if the opcode bits are under-specified for some instructions.
+The machine generated decoder will properly handle both these situations.
+Just pick a useful number of bits that distinguishes most instructions.
+It is usually best to not pick more than 8 bits to keep the size of the
+initial decode table down.
+
+Bit numbering is defined by the @code{insn-lsb0?} field.
+
+@subsubsection liw-insns
+@cindex liw-insns
+
+The number of instructions the CPU always fetches at once.  This is
+intended for architectures like the M32R, and does not refer to a CPU's
+ability to pre-fetch instructions.  The default is 1.
+
+@subsubsection parallel-insns
+@cindex parallel-insns
+
+The maximum number of instructions the CPU can execute in parallel.  The
+default is 1.
+
+??? Rename this to @code{max-parallel-insns}?
+
+@subsubsection condition
+
+Some architectures like ARM and ARC conditionally execute every instruction
+based on the condition specified by one instruction field.
+The @code{condition} spec exists to support these architectures.
+@code{ifield-name} is the name of the instruction field denoting the
+condition and @code{expression} is an RTL expressions that returns
+the value of the condition (false=zero, true=non-zero).
+
+@subsubsection setup-semantics
+
+Specify a statement to be performed prior to executing particular instructions.
+This is used, for example, on the ARM where the value of the program counter
+(general register 15) is a function of the instruction (it is either
+pc+8 or pc+12, depending on the instruction).
+
+@subsubsection decode-splits
+
+Specify a list of field names and values to split instructions up by.
+This is used, for example, on the ARM where the behavior of some instructions
+is quite different when the destination register is r15 (the pc).
+
+The syntax is:
+
+@example
+(decode-splits
+  (ifield1-name
+   constraints
+   ((split1-name (value1 value2 ...)) (split2-name ...)))
+  (ifield2-name
+   ...)
+)
+@end example
+
+@code{constraints} is work-in-progress and should be @code{()} for now.
+
+One copy of each instruction satisfying @code{constraint} is made
+for each specified split.  The semantics of each copy are then
+simplified based on the known values of the specified instruction field.
+
+@node define-cpu
+@subsection define-cpu
+@cindex define-cpu
+
+@code{define-cpu} defines a ``CPU family'' which is a programmer
+specified collection of related machines.  What constitutes a family is
+work-in-progress however it is intended to distinguish things like
+sparc32 vs sparc64.  Machines in a family are sufficiently similar that
+the simulator semantic code can handle any differences at run time.  At
+least that's the current idea.  A minimum of one CPU family must be
+defined.
+@footnote{FIXME: Using "cpu" in "cpu-family" here is confusing.
+Need a better name.  Maybe just "family"?}
+
+The syntax of @code{define-cpu} is:
+
+@example
+(define-cpu
+  (name cpu-name)
+  (comment "description")
+  (attrs attribute-list)
+  (endian big|little|either)
+  (insn-endian big|little|either)
+  (data-endian big|little|either)
+  (float-endian big|little|either)
+  (word-bitsize n)
+  (parallel-insns n)
+  (file-transform transformation)
+)
+@end example
+
+@subsubsection endian
+
+The endianness of the architecture is one of three values: @code{big},
+@code{little} and @code{either}.
+
+An architecture may have multiple endiannesses, including one for each
+of: instructions, integers, and floats (not that that's intended to be the
+complete list).  These are specified with @code{insn-endian},
+@code{data-endian}, and @code{float-endian} respectively.
+
+Possible values for @code{insn-endian} are: @code{big}, @code{little},
+and @code{either}.  If missing, the value is taken from @code{endian}.
+
+Possible values for @code{data-endian} and @code{float-endian} are: @code{big},
+@code{big-words}, @code{little}, @code{little-words} and @code{either}.
+If @code{big-words} then each word is little-endian.
+If @code{little-words} then each word is big-endian.
+If missing, the value is taken from @code{endian}.
+
+??? Support for these is work-in-progress.  All forms are recognized
+by the @file{.cpu} file reader, but not all are supported internally.
+
+@subsubsection word-bitsize
+
+The number of bits in a word.  In GCC, this is @code{BITS_PER_WORD}.
+
+@subsubsection parallel-insns
+
+This is the same as the @code{parallel-insns} spec of @code{define-isa}.
+It allows a CPU family to override the value.
+
+@subsubsection file-transform
+
+Specify the file name transformation of generated code.
+
+Each generated file has a named related to the ISA or CPU family.
+Sometimes generated code needs to know the name of another generated
+file (e.g. #include's).
+At present @code{file-transform} specifies the suffix.
+
+For example, M32R/x generated files have an `x' suffix, as in @file{cpux.h}
+for the @file{cpu.h} header.  This is indicated with
+@code{(file-transform "x")}.
+
+??? Ideally generated code wouldn't need to know anything about file names.
+This breaks down for #include's.  It can be fixed with symlinks or other
+means.
+
+@node define-mach
+@subsection define-mach
+@cindex define-mach
+
+@code{define-mach} defines a distinct variant of a CPU.  It currently
+has a one-to-one correspondence with BFD's "mach number".  A minimum of
+one mach must be defined.
+
+The syntax of @code{define-mach} is:
+
+@example
+(define-mach
+  (name mach-name)
+  (comment "description")
+  (attrs attribute-list)
+  (cpu cpu-family-name)
+  (bfd-name "bfd-name")
+  (isas isa-name-list)
+)
+@end example
+
+@subsubsection bfd-name
+@cindex bfd-name
+
+The name of the mach as used by BFD.  If not specified the name of the
+mach is used.
+
+@subsubsection isas
+
+List of names of ISA's the machine supports.
+
+@node Model variants
+@section Model Variants
+
+For each `machine', as defined here, there is one or more `models'.
+There must be at least one model for each machine.
+(*note: There could be a default, but requiring one doesn't involve that much
+extra typing and forces the programmer to at least think about such things.)
+
+@example
+(define-model
+  (name model-name)
+  (comment "description")
+  (attrs attribute-list)
+  (mach machine-name)
+  (state (variable-name-1 variable-mode-1) ...)
+  (unit name "comment" (attributes)
+       issue done state inputs outputs profile)
+)
+@end example
+
+@subsection mach
+
+The name of the machine the model is an implementation of.
+
+@subsection state
+
+A list of variable-name/mode pairs for recording global function unit
+state.  For example on the M32R the value is @code{(state (h-gr UINT))}
+and is a bitmask of which register(s) are the targets of loads and thus
+subject to load stalls.
+
+@subsection unit
+
+Specifies a function unit.  Any number of function units may be specified.
+The @code{u-exec} unit must be specified as it is the default.
+
+The syntax is:
+
+@example
+  (unit name "comment" (attributes)
+     issue done state inputs outputs profile)
+@end example
+
+@samp{issue} is the number of operations that may be in progress.
+It originates from GCC function unit specification.  In general the
+value should be 1.
+
+@samp{done} is the latency of the unit.  The value is the number of cycles
+until the result is ready.
+
+@samp{state} has the same syntax as the global model `state' and is a list of
+variable-name/mode pairs.
+
+@samp{inputs} is a list of inputs to the function unit.
+Each element is @code{(operand-name mode default-value)}.
+
+@samp{outputs} is a list of outputs of the function unit.
+Each element is @code{(operand-name mode default-value)}.
+
+@samp{profile} is an rtl-code sequence that performs function unit
+modeling.  At present the only possible value is @code{()} meaning
+invoke a user supplied function named @code{<cpu>_model_<mach>_<unit>}.
+
+The current function unit specification is a first pass in order to
+achieve something that moderately works for the intended purpose (cycle
+counting on the simulator).  Something more elaborate is on the todo list
+but there is currently no schedule for it.  The new specification must
+try to be application independent.  Some known applications are:
+cycle counting in the simulator, code scheduling in a compiler, and code
+scheduling in a JIT simulator (where speed of analysis can be more
+important than getting an optimum schedule).
+
+The inputs/outputs fields are how elements in the semantic code are mapped
+to function units.  Each input and output has a name that corresponds
+with the name of the operand in the semantics.  Where there is no
+correspondence, a mapping can be made in the unit specification of the
+instruction (see the subsection titled ``Timing'').
+
+Another way to achieve the correspondence is to create separate function
+units that contain the desired input/output names.  For example on the
+M32R the u-exec unit is defined as:
+
+@example
+(unit u-exec "Execution Unit" ()
+   1 1 ; issue done
+   () ; state
+   ((sr INT -1) (sr2 INT -1)) ; inputs
+   ((dr INT -1)) ; outputs
+   () ; profile action (default)
+)
+@end example
+
+This handles instructions that use sr, sr2 and dr as operands.  A second
+function unit called @samp{u-cmp} is defined as:
+
+@example
+(unit u-cmp "Compare Unit" ()
+   1 1 ; issue done
+   () ; state
+   ((src1 INT -1) (src2 INT -1)) ; inputs
+   () ; outputs
+   () ; profile action (default)
+)
+@end example
+
+This handles instructions that use src1 and src2 as operands.  The
+organization of units is arbitrary.  On the M32R, src1/src2 instructions
+are typically compare instructions so a separate function unit was
+created for them.
+
+@node Hardware elements
+@section Hardware Elements
+
+The elements of hardware that make up a CPU are defined with
+@code{define-hardware}.  Examples of hardware elements include
+registers, condition bits, immediate constants and memory.
+
+Instruction fields that provide numerical values (``immediate
+constants'') aren't really elements of the hardware, but it simplifies
+things to think of them this way.  Think of them as @emph{constant
+generators}@footnote{A term borrowed from the book on the Bulldog
+compiler and perhaps other sources.}.
+
+Hardware elements are defined with:
+
+@example
+(define-hardware
+  (name hardware-name)
+  (comment "description")
+  (attrs attribute-list)
+  (semantic-name hardware-semantic-name)
+  (type type-name type-arg1 type-arg2 ...)
+  (indices index-type index-arg1 index-arg2 ...)
+  (values values-type values-arg1 values-arg2 ...)
+  (handlers handler1 handler2 ...)
+  (get (args) (expression))
+  (set (args) (expression))
+)
+@end example
+
+The only required members are @samp{name} and @samp{type}. Convention
+requires @samp{hardware-name} begin with @samp{h-}.
+
+@subsection attrs
+
+List of attributes. There are several predefined hardware attributes:
+
+@itemize @minus
+@item MACH
+
+A bitset attribute used to specify which machines have this hardware element.
+Do not specify the MACH attribute if the value is "all machs".
+
+Usage: @code{(MACH mach1,mach2,...)}
+There must be no spaces in ``@code{mach1,mach2,...}''.
+
+@item CACHE-ADDR
+
+A hint to the simulator semantic code generator to tell it it can record the
+address of a selected register in an array of registers.  This speeds up
+simulation by moving the array computation to extraction time.
+This attribute is only useful to register arrays and cannot be specified
+with @code{VIRTUAL} (??? revisit).
+
+@item PROFILE
+
+Ignore.  This is a work-in-progress to define how to profile references
+to hardware elements.
+
+@item VIRTUAL
+
+The hardware element doesn't require any storage.
+This is used when you want a value that is derived from some other value.
+If @code{VIRTUAL} is specified, @code{get} and @code{set} specs must be
+provided.
+@end itemize
+
+@subsection type
+
+This is the type of hardware.  Current values are: @samp{register},
+@samp{memory}, and @samp{immediate}.
+
+For registers the syntax is one of:
+
+@example
+@code{(register mode [(number)])}
+@code{(register (mode bits) [(number)])}
+@end example
+
+where @samp{(number)} is the number of registers and is optional. If
+omitted, the default is @samp{(1)}.
+The second form is useful for describing registers with an odd (as in
+unusual) number of bits.
+@code{mode} for the second form must be one of @samp{INT} or @samp{UINT}.
+Since these two modes don't have an implicit size, they cannot be used for
+the first form.
+
+@c ??? Might wish to remove the mode here and just specify number of bits.
+
+For memory the syntax is:
+
+@example
+@code{(memory mode (size))}
+@end example
+
+where @samp{(size)} is the size of the memory in @samp{mode} units.
+In general @samp{mode} should be @code{QI}.
+
+For immediates the syntax is one of
+
+@example
+@code{(immediate mode)}
+@code{(immediate (mode bits))}
+@end example
+
+The second form is for values for which a mode of that size doesn't exist.
+@samp{mode} for the second form must be one of @code{INT} or @code{UINT}.
+Since these two modes don't have an implicit size, they cannot be used
+for the first form.
+
+??? There's no real reason why a mode like SI can't be used
+for odd-sized immediate values.  The @samp{bits} field indicates the size
+and the @samp{mode} field indicates the mode in which the value will be used,
+as well as its signedness.  This would allow removing INT/UINT for this
+purpose.  On the other hand, a non-width specific mode allows applications
+to choose one (a simulator might prefer to store immediates in an `int'
+rather than, say, char if the specified mode was @code{QI}).
+
+@subsection indices
+
+Specify names for individual elements with the @code{indices} spec.
+It is only valid for registers with more than one element.
+
+The syntax is:
+
+@example
+@code{(indices index-type arg1 arg2 ...)}
+@end example
+
+where @samp{index-type} specifies the kind of index and @samp{arg1 arg2 ...}
+are arguments to @samp{index-type}.
+
+The are two supported values for @samp{index-type}: @code{keyword}
+and @code{extern-keyword}.  The difference is that indices defined with
+@code{keyword} are kept internal to the hardware element's definition
+and are not usable elsewhere, whereas @code{extern-keyword} specifies
+a set of indices defined elsewhere.
+
+@subsubsection keyword
+
+@example
+@code{(indices keyword "prefix" ((name1 value1) (name2 value2) ...))}
+@end example
+
+@samp{prefix} is the common prefix for each of the index names.
+For example, SPARC registers usually begin with @samp{"%"}.
+
+Each @samp{(name value)} pair maps a name with an index number.
+An index can be specified multiple times, for example, when a register
+has multiple names.
+
+Example from Thumb:
+
+@example
+(define-hardware 
+  (name h-gr-t)
+  (comment "Thumb's general purpose registers")
+  (attrs (ISA thumb) VIRTUAL) ; ??? CACHE-ADDR should be doable
+  (type register WI (8))
+  (indices keyword ""
+          ((r0 0) (r1 1) (r2 2) (r3 3) (r4 4) (r5 5) (r6 6) (r7 7)))
+  (get (regno) (reg h-gr regno))
+  (set (regno newval) (set (reg h-gr regno) newval))
+)
+@end example
+
+@subsubsection extern-keyword
+
+@example
+@code{(indices extern-keyword keyword-name)}
+@end example
+
+Example from M32R:
+
+@example
+(define-keyword
+  (name gr-names)
+  (print-name h-gr)
+  (prefix "")
+  (values (fp 13) (lr 14) (sp 15)
+         (r0 0) (r1 1) (r2 2) (r3 3) (r4 4) (r5 5) (r6 6) (r7 7)
+         (r8 8) (r9 9) (r10 10) (r11 11) (r12 12) (r13 13) (r14 14) (r15 15))
+)
+
+(define-hardware
+  (name h-gr)
+  (comment "general registers")
+  (attrs PROFILE CACHE-ADDR)
+  (type register WI (16))
+  (indices extern-keyword gr-names)
+)
+@end example
+
+@subsection values
+
+Specify a list of valid values with the @code{values} spec.
+@c Clumsy wording.
+
+The syntax is identical to the syntax for @code{indices}.
+It is only valid for immediates.
+
+Example from sparc64:
+
+@example
+(define-hardware
+  (name h-p)
+  (comment "prediction bit")
+  (attrs (MACH64))
+  (type immediate (UINT 1))
+  (values keyword "" (("" 0) (",pf" 0) (",pt" 1)))
+)
+@end example
+
+@subsection handlers
+
+The @code{handlers} spec is an escape hatch for indicating when a
+programmer supplied routine must be called to perform a function.
+
+The syntax is:
+
+@example
+@samp{(handlers (handler-name1 "function_name1")
+                (handler-name2 "function_name2")
+                ...)}
+@end example
+
+@samp{handler-name} must be one of @code{parse} or @code{print}.
+How @samp{function_name} is used is application specific, but in
+general it is the name of a function to call.  The only application
+that uses this at present is Opcodes.  See the Opcodes documentation for
+a description of each function's expected prototype.
+
+@subsection get
+
+Specify special processing to be performed when a value is read
+with the @code{get} spec.
+
+The syntax for scalar registers is:
+
+@example
+@samp{(get () (expression))}
+@end example
+
+The syntax for vector registers is:
+
+@example
+@samp{(get (index) (expression))}
+@end example
+
+@code{expression} is an RTL expression that computes the value to return.
+The mode of the result must be the mode of the register.
+
+@code{index} is the name of the index as it appears in @code{expression}.
+
+At present, @code{sequence}, @code{parallel}, and @code{case} expressions
+are not allowed here.
+
+@subsection set
+
+Specify special processing to be performed when a value is written
+with the @code{set} spec.
+
+The syntax for scalar registers is:
+
+@example
+@samp{(set (newval) (expression))}
+@end example
+
+The syntax for vector registers is:
+
+@example
+@samp{(set (index newval) (expression))}
+@end example
+
+@code{expression} is an RTL expression that stores @code{newval}
+in the register.  This may involve storing values in other registers as well.
+@code{expression} must be one of @code{set}, @code{if}, @code{sequence}, or
+@code{case}.
+
+@code{index} is the name of the index as it appears in @code{expression}.
+
+@subsection Predefined hardware elements
+
+Several hardware types are predefined:
+
+@table @code
+@item h-uint
+unsigned integer
+@item h-sint
+signed integer
+@item h-memory
+main memory, where ``main'' is loosely defined
+@item h-addr
+data address (data only)
+@item h-iaddr
+instruction address (instructions only)
+@end table
+
+@subsection Program counter
+
+The program counter must be defined and is not a builtin.
+If get/set specs are not required, define it as:
+
+@example
+(dnh h-pc "program counter" (PC) (pc) () () ())
+@end example
+
+If get/set specs are required, define it as:
+
+@example
+(define-hardware
+  (name h-pc)
+  (comment "<ARCH> program counter")
+  (attrs PC)
+  (type pc)
+  (get () <insert get code here>)
+  (set (newval) <insert set code here>)
+)
+@end example
+
+If the architecture has multiple instruction sets, all must be specified.
+If they're not, the default is the first one which is not what you want.
+Here's an example from @file{arm.cpu}:
+
+@example
+(define-hardware
+  (name h-pc)
+  (comment "ARM program counter (h-gr reg 15)")
+  (attrs PC (ISA arm,thumb))
+  (type pc)
+  (set (newval)
+       (if (reg h-tbit)
+          (set (raw-reg SI h-pc) (and newval -2))
+          (set (raw-reg SI h-pc) (and newval -4))))
+)
+@end example
+
+@subsection Simplification macros
+
+To simplify @file{.cpu} files, the @code{dnh}
+(@code{define-normal-hardware}) macro exists that takes a fixed set of
+positional arguments for the typical hardware element.  The syntax of
+@code{dnh} is:
+
+@code{(dnh name comment attributes type indices values handlers)}
+
+Example:
+
+@example
+(dnh h-gr "general registers"
+     () ; attributes
+     (register WI (16))
+     (keyword "" ((fp 13) (sp 15) (lr 14)
+                  (r0 0) (r1 1) (r2 2) (r3 3)
+                  (r4 4) (r5 5) (r6 6) (r7 7)
+                  (r8 8) (r9 9) (r10 10) (r11 11)
+                  (r12 12) (r13 13) (r14 14) (r15 15)))
+     () ()
+)
+@end example
+
+This defines an array of 16 registers of mode @code{WI} ("word int").
+The names of the registers are @code{r0...r15}, and registers 13, 14 and 
+15 also have the names @code{fp}, @code{lr} and @code{sp} respectively.
+
+Scalar registers with no special requirements occur frequently.
+Macro @code{dsh} (@code{define-simple-hardware}) is identical to
+@code{dnh} except does not include the @code{indices}, @code{values},
+or @code{handlers} specs.
+
+@example
+(dsh h-ibit "interrupt enable bit" () (register BI))
+@end example
+
+@node Instruction fields
+@section Instruction Fields
+@cindex Fields, instruction
+
+Instruction fields define the raw bitfields of each instruction.
+Minimal semantic meaning is attributed to them.  Support is provided for
+mapping to and from the raw bit pattern and the usable contents, and
+other simple manipulations.
+
+The syntax for defining instruction fields is:
+
+@example
+(define-ifield
+  (name field-name)
+  (comment "description")
+  (attrs attribute-list)
+  (start starting-bit-number)
+  (length number-of-bits)
+  (follows ifield-name)
+  (mode mode-name)
+  (encode (value pc) (rtx to describe encoding))
+  (decode (value pc) (rtx to describe decoding))
+)
+@end example
+
+(*note: Whether to also provide a way to specify instruction formats is not yet
+clear.  Currently they are computed from the instructions, so there's no
+current *need* to provided them.  However, providing the ability as an
+option may simplify other tools CGEN is used to generate.  This
+simplification would come in the form of giving known names to the formats
+which CPU reference manuals often do.  Pre-specified instruction formats
+may also simplify expression of more complicated instruction sets.)
+
+(*note: Positional specification simplifies instruction description somewhat
+in that there is no required order of fields, and a disjunct set of fields can
+be referred to as one.  On the other hand it can require knowledge of the length
+of the instruction which is inappropriate in cases like the M32R where
+the main fields have the same name and "position" regardless of the length
+of the instruction.  Moving positional specification into instruction formats,
+whether machine generated or programmer specified, may be done.)
+
+Convention requires @samp{field-name} begin with @samp{f-}.
+
+@subsection attrs
+
+There are several predefined instruction field attributes:
+
+@table @code
+@item PCREL-ADDR
+The field contains a PC relative address.  Various CPUs have various
+offsets from the PC from which the address is calculated.  This is
+specified in the encode and decode sections.
+
+@item ABS-ADDR
+The field contains an absolute address.
+
+@item SIGN-OPT
+The field has an optional sign.  It is sign-extended during
+extraction. Allowable values are -2^(n-1) to (2^n)-1.
+
+@item RESERVED
+The field is marked as ``reserved'' by the architecture.
+This is an informational attribute.  Tools may use it
+to validate programs, either statically or dynamically.
+
+@item VIRTUAL
+The field does not directly contribute to the instruction's value.  This
+is used to simplify semantic or assembler descriptions where a fields
+value is based on other values.  Multi-ifields are always virtual.
+@end table
+
+@subsection start
+The bit number of the field's most significant bit in the instruction.
+Bit numbering is determined by the @code{insn-lsb0?} field of
+@code{define-arch}.
+
+@subsection length
+The number of bits in the field.
+The field must be contiguous.
+For non-contiguous instruction fields use "multi-ifields".
+(*xref: Non-contiguous fields).
+
+@subsection follows
+Optional.  Experimental.
+This should not be used for the specification of RISC-like architectures.
+It is an experiment in supporting CISC-like architectures.
+The argument is the name of the ifield or operand that immediately precedes
+this one.  In general the argument is an "anyof" operand.  The @code{follows}
+spec allows subsequent ifields to "float".
+
+@subsection mode
+The mode the value is to be interpreted in.
+Usually this is @code{INT} or @code{UINT}.
+
+@c ??? There's no real reason why modes like SI can't be used here.
+The @samp{length} field specifies the number of bits in the field,
+and the @samp{mode} field indicates the mode in which the value will be used,
+as well as its signedness.  This would allow removing INT/UINT for this
+purpose.  On the other hand, a non-width specific mode allows applications
+to choose one (a simulator might prefer to store immediates in an `int'
+rather than, say, char if the specified mode was @code{QI}).
+
+@subsection encode
+An expression to apply to convert from usable values to raw field
+values.  The syntax is @code{(encode (value pc) expression)} or more
+specifically @code{(encode ((<mode1> value) (IAI pc)) <expression>)},
+where @code{<mode1>} is the mode of the the ``incoming'' value, and
+@code{<expression>} is an rtx to convert @code{value} to something that
+can be stored in the field.
+
+Example:
+
+@example
+(encode ((SF value) (IAI pc))
+       (cond WI
+             ((eq value (const SF 1.0)) (const 0))
+             ((eq value (const SF 0.5)) (const 1))
+             ((eq value (const SF -1.0)) (const 2))
+             ((eq value (const SF 2.0)) (const 3))
+             (else (error "invalid floating point value for field foo"))))
+@end example
+
+In this example four floating point immediate values are represented in a
+field of two bits.  The above might be expanded to a series of `if' statements
+or the generator could determine a `switch' statement is more appropriate.
+
+@subsection decode
+
+An expression to apply to convert from raw field values to usable
+values.  The syntax is @code{(decode (value pc) expression)} or more
+specifically @code{(decode ((WI value) (IAI pc)) <expression>)}, where
+@code{<expression>} is an rtx to convert @code{value} to something
+usable.
+
+Example:
+
+@example
+(decode ((WI value) (IAI pc))
+       (cond SF
+             ((eq value 0) (const SF 1.0))
+             ((eq value 1) (const SF 0.5))
+             ((eq value 2) (const SF -1.0))
+             ((eq value 3) (const SF 2.0))))
+@end example
+
+There's no need to provide an error case as presumably @code{value}
+would never have an invalid value, though certainly one could provide an
+error case if one wanted to.
+
+@subsection Non-contiguous fields
+@cindex Fields, non-contiguous
+
+Non-contiguous fields (e.g. sparc64's 16 bit displacement field) are
+built on top of support for contiguous fields.  The syntax for defining
+such fields is:
+
+@example
+(define-multi-ifield
+  (name field-name)
+  (comment "description")
+  (attrs attribute-list)
+  (mode mode-name)
+  (subfields field1-name field2-name ...)
+  (insert (code to set each subfield))
+  (extract (code to set field from subfields))
+)
+@end example
+
+(*note: insert/extract are analogous to encode/decode so maybe these
+fields are misnamed.  The operations are subtly different though.)
+
+Example:
+
+@example
+(define-multi-ifield
+  (name f-i20)
+  (comment "20 bit unsigned")
+  (attrs)
+  (mode UINT)
+  (subfields f-i20-4 f-i20-16)
+  (insert (sequence ()
+                    (set (ifield f-i20-4)  (srl (ifield f-i20) (const 16)))
+                    (set (ifield f-i20-16) (and (ifield f-i20) (const #xffff)))
+                    ))
+  (extract (sequence ()
+                     (set (ifield f-i20) (or (sll (ifield f-i20-4) (const 16))
+                                             (ifield f-i20-16)))
+                     ))
+)
+@end example
+
+@subsection subfields
+The names of the already defined fields that make up the multi-ifield.
+
+@subsection insert
+Code to set the subfields from the multi-ifield. All fields are referred
+to with @code{(ifield <name>)}.
+
+@subsection extract
+Code to set the multi-ifield from the subfields. All fields are referred
+to with @code{(ifield <name>)}.
+
+@subsection Simplification macros
+To simplify @file{.cpu} files, the @code{dnf}, @code{df} and @code{dnmf}
+macros have been created. Each takes a fixed set of positional arguments
+for the typical instruction field.  @code{dnf} is short for
+@code{define-normal-field}, @code{df} is short for @code{define-field},
+and @code{dnmf} is short for @code{define-normal-multi-ifield}.
+
+The syntax of @code{dnf} is:
+
+@code{(dnf name comment attributes start length)}
+
+Example:
+
+@code{(dnf f-r1 "register r1" () 4 4)}
+
+This defines a field called @samp{f-r1} that is an unsigned field of 4
+bits beginning at bit 4.  All fields defined with @code{dnf} are unsigned.
+
+The syntax of @code{df} is:
+
+@code{(df name comment attributes type start length mode encode decode)}
+
+Example:
+
+@example
+(df f-disp8
+    "disp8, slot unknown" (PCREL-ADDR)
+    INT 8 8
+    ((value pc) (sra WI (sub WI value (and WI pc (const -4))) (const 2)))
+    ((value pc) (add WI (sll WI value (const 2)) (and WI pc (const -4)))))
+@end example
+
+This defines a field called @samp{f-disp8} that is a signed PC-relative
+address beginning at bit 8 of size 8 bits that is left shifted by 2.
+
+The syntax of @code{dnmf} is:
+
+@code{(dnmf name comment attributes mode subfields insert extract)}
+
+@node Enumerated constants
+@section Enumerated constants
+@cindex Enumerated constants
+@cindex Enumerations
+
+Enumerated constants (@emph{enums}) are important enough in instruction
+set descriptions that they are given special treatment. Enums are
+defined with:
+
+@example
+(define-enum
+  (name enum-name)
+  (comment "description")
+  (attrs attribute-list)
+  (prefix prefix)
+  (values val1 val2 ...)
+)
+@end example
+
+Enums in opcode fields are further enhanced by specifying the opcode
+field they are used in.  This allows the enum's name to be specified
+in an instruction's @code{format} entry.
+
+@example
+(define-insn-enum
+  (name enum-name)
+  (comment "description")
+  (attrs (attribute list))
+  (prefix prefix)
+  (ifield instruction-field-name)
+  (values val1 val2 ...)
+)
+@end example
+
+(*note: @code{define-insn-enum} isn't implemented yet: use
+@code{define-normal-insn-enum})
+
+Example:
+
+@example
+(define-insn-enum
+  (name insn-op1)
+  (comment "op1 field values")
+  (prefix OP1_)
+  (ifield f-op1)
+  (values "0" "1" "2" "3" "4" "5" "6" "7"
+          "8" "9" "10" "11" "12" "13" "14" "15")
+)
+@end example
+
+@subsection prefix
+Convention requires each enum value to be prefixed with the same text.
+Rather than specifying the prefix in each entry, it is specified once, here.
+Convention requires @samp{prefix} not contain any lowercase characters.
+
+@subsection ifield
+The name of the instruction field that the enum is intended for.
+
+@subsection values
+A list of possible values.  Each element has one of the following forms:
+
+@itemize @bullet
+@item @code{name}
+@item @code{(name)}
+@item @code{(name value)}
+@item @code{(name - (attribute-list))}
+@item @code{(name value (attribute-list))}
+@end itemize
+
+The syntax for numbers is Scheme's, so hex numbers are @code{#xnnnn}.
+A value of @code{-} means use the next value (previous value plus 1).
+
+Example:
+
+@example
+(values "a" ("b") ("c" #x12)
+       ("d" - (sanitize foo)) ("e" #x1234 (sanitize bar)))
+@end example
+
+@subsection Simplification macros
+
+@code{(define-normal-enum name comment attrs prefix vals)}
+
+@code{(define-normal-insn-enum name comment attrs prefix ifield vals)}
+
+@node Instruction operands
+@section Instruction Operands
+@cindex Operands, instruction
+
+Instruction operands provide:
+
+@itemize @bullet
+@item a layer between the assembler and the raw hardware description
+@item the main means of manipulating instruction fields in the semantic code
+@c More?
+@end itemize
+
+The syntax is:
+
+@example
+(define-operand
+  (name operand-name)
+  (comment "description")
+  (attrs attribute-list)
+  (type hardware-element)
+  (index instruction-field)
+  (asm asm-spec)
+)
+@end example
+
+@subsection name
+
+This is the name of the operand as a Scheme symbol.
+The name choice is fairly important as it is used in instruction
+syntax entries, instruction format entries, and semantic expressions.
+It can't collide with symbols used in semantic expressions
+(e.g. @code{and}, @code{set}, etc).
+
+The convention is that operands have no prefix (whereas ifields begin
+with @samp{f-} and hardware elements begin with @samp{h-}).  A prefix
+like @samp{o-} would avoid collisions with other semantic elements, but
+operands are used often enough that any prefix is a hassle.
+
+@subsection attrs
+
+A list of attributes. In addition to attributes defined for the operand,
+an operand inherits the attributes of its instruction field. There are
+several predefined operand attributes:
+
+@table @code
+@item NEGATIVE
+The operand contains negative values (not used yet so definition is
+still nebulous.
+
+@item RELAX
+This operand contains the changeable field (usually a branch address) of
+a relaxable instruction.
+
+@item SEM-ONLY
+Use the SEM-ONLY attribute for cases where the operand will only be used
+in semantic specification, and not assembly code specification.  A
+typical example is condition codes.
+@end table
+
+To refer to a hardware element in semantic code one must either use an
+operand or one of reg/mem/const.  Operands generally exist to map
+instruction fields to the selected hardware element and are easier to
+use in semantic code than referring to the hardware element directly
+(e.g. @code{sr} is easier to type and read than @code{(reg h-gr
+<index>)}). Example:
+
+@example
+  (dnop condbit "condition bit" (SEM-ONLY) h-cond f-nil)
+@end example
+
+@code{f-nil} is the value to use when there is no instruction field
+
+@c There might be some language cleanup to be done here regarding f-nil.
+@c It is kind of extraneous.
+
+@subsection type
+The hardware element this operand applies to. This must be the name of a
+hardware element.
+
+@subsection index
+The index of the hardware element. This is used to mate the hardware
+element with the instruction field that selects it, and must be the name
+of an ifield entry. (*note: The index may be other things besides
+ifields in the future.)
+
+@subsection asm
+Sometimes it's necessary to escape to C to parse assembler, or print
+a value.  This field is an escape hatch to implement this.
+The current syntax is:
+
+@code{(asm asm-spec)}
+
+where @code{asm-spec} is one or more of:
+
+@code{(parse "function_suffix")} -- a call to function
+@code{parse_<function_suffix>} is generated.
+
+@code{(print "function_suffix")} -- a call to function
+@code{print_<function_suffix>} is generated.
+
+These functions are intended to be provided in a separate @file{.opc}
+file.  The prototype of a parse function depends on the hardware type.
+See @file{cgen/*.opc} for examples.
+
+@c FIXME: The following needs review.
+
+For integer it is:
+
+@example
+static const char *
+parse_foo (CGEN_CPU_DESC cd,
+          const char **strp,
+          int opindex,
+          unsigned long *valuep);
+@end example
+
+@code{cd} is the result of @code{<arch>_cgen_opcode_open}.
+@code{strp} is a pointer to a pointer to the assembler and is updated by
+the function.
+@c FIXME
+@code{opindex} is ???.
+@code{valuep} is a pointer to where to record the parsed value.
+@c FIXME
+If a relocation is needed, it is queued with a call to ???. Queued
+relocations are processed after the instruction has been parsed.
+
+The result is an error message or NULL if successful.
+
+The prototype of a print function depends on the hardware type.  See
+@file{cgen/*.opc} for examples. For integers it is:
+
+@example
+void print_foo (CGEN_CPU_DESC cd,
+                PTR dis_info,
+                long value,
+                unsigned int attrs,
+                bfd_vma pc,
+                int length);
+@end example
+
+@samp{cd} is the result of @code{<arch>_cgen_opcode_open}.
+@samp{ptr} is the `info' argument to print_insn_<arch>.
+@samp{value} is the value to be printed.
+@samp{attrs} is the set of boolean attributes.
+@samp{pc} is the PC value of the instruction.
+@samp{length} is the length of the instruction.
+
+Actual printing is done by calling @code{((disassemble_info *)
+dis_info)->fprintf_func}.
+
+@node Derived operands
+@section Derived Operands
+@cindex Derived operands
+@cindex Operands, instruction
+@cindex Operands, derived
+
+Derived operands are an experiment in supporting the addressing modes of
+CISC-like architectures.  Addressing modes are difficult to support as
+they essentially increase the number of instructions in the architecture
+by an order of magnitude.  Defining all the variants requires something
+in addition to the RISC-like architecture support.  The theory is that
+since CISC-like instructions are basically "normal" instructions with
+complex operands the place to add the necessary support is in the
+operands.
+
+Two kinds of operands exist to support CISC-like cpus, and they work
+together.  "derived-operands" describe one variant of a complex
+argument, and "anyof" operands group them together.
+
+The syntax for defining derived operands is:
+
+@example
+(define-derived-operand
+  (name operand-name)
+  (comment "description")
+  (attrs attribute-list)
+  (mode mode-name)
+  (args arg1-operand-name arg2-operand-name ...)
+  (syntax "syntax")
+  (base-ifield ifield-name)
+  (encoding (+ arg1-operand-name arg2-operand-name ...))
+  (ifield-assertion expression)
+  (getter expression)
+  (setter expression)
+)
+@end example
+
+@cindex anyof operands
+@cindex Operands, anyof
+
+The syntax for defining anyof operands is:
+
+@example
+(define-anyof-operand
+  (name operand-name)
+  (comment "description")
+  (attrs attribute-list)
+  (mode mode-name)
+  (base-ifield ifield-name)
+  (choices derived-operand1-name derived-operand2-name ...)
+)
+@end example
+
+@subsection mode
+
+The name of the mode of the operand.
+
+@subsection args
+
+List of names of operands the derived operand uses.
+The operands must already be defined.
+The argument operands can be any kind of operand: normal, derived, anyof.
+
+@subsection syntax
+
+Assembler syntax of the operand.
+
+??? This part needs more work.  Addressing mode specification in assembler
+needn't be localized to the vicinity of the operand.
+
+@subsection base-ifield
+
+The name of the instruction field common to all related derived operands.
+Here related means "used by the same `anyof' operand".
+
+@subsection encoding
+
+The machine encoding of the operand.
+
+@subsection ifield-assertion
+
+An assertion of what values any instruction fields will or will not have
+in the containing instruction.
+
+??? A better name for this might be "constraint".
+
+@subsection getter
+
+RTL expression to get the value of the operand.
+All operands refered to must be specified in @code{args}.
+
+@subsection setter
+
+RTL expression to set the value of the operand.
+All operands refered to must be specified in @code{args}.
+Use @code{newval} to refer to the value to be set.
+
+@subsection choices
+
+For anyof operands, the names of the derived operands.
+The operand may be "any of" the specified choices.
+
+@node Instructions
+@section Instructions
+@cindex Instructions
+
+Each instruction in the instruction set has an entry in the description
+file.  For complicated instruction sets this is a lot of typing.  However,
+macros can reduce a lot of that typing.  The real question is given the
+amount of information that must be expressed, how succinct can one express
+it and still be clean and usable?  I'm open to opinions on how to improve
+this, but such improvements must take everything CGEN wishes to be into
+account.
+(*note: Of course no claim is made that the current design is the
+be-all and end-all or that there is one be-all and end-all.)
+
+The syntax for defining an instruction is:
+
+@example
+(define-insn
+  (name insn-name)
+  (comment "description")
+  (attrs attribute-list)
+  (syntax "assembler syntax")
+  (format (+ field-list))
+  (semantics (semantic-expression))
+  (timing timing-data)
+)
+@end example
+
+Instructions specific to a particular cpu variant are denoted as such with
+the MACH attribute.
+
+Possible additions for the future:
+
+@itemize @bullet
+@item a field to describe a final constraint for determining a match
+@item choosing the output from a set of choices
+@end itemize
+
+@subsection attrs
+
+A list of attributes, for which there are several predefined instruction
+attributes:
+
+@table @code
+@item MACH
+A bitset attribute used to specify which machines have this hardware
+element. Do not specify the MACH attribute if the value is for all
+machines.
+
+Usage: @code{(MACH mach1,mach2,...)}  
+
+There must be no spaces in ``@code{mach1,mach2,...}''.
+
+@item UNCOND-CTI
+The instruction is an unconditional ``control transfer instruction''.
+
+(*note: This attribute is derived from the semantic code. However if the
+computed value is wrong (dunno if it ever will be) the value can be
+overridden by explicitly mentioning it.)
+
+@item COND-CTI
+The instruction is an conditional "control transfer instruction".
+
+(*note: This attribute is derived from the semantic code. However if the
+computed value is wrong (dunno if it ever will be) the value can be
+overridden by explicitly mentioning it.)
+
+@item SKIP-CTI
+The instruction can cause one or more insns to be skipped. This is
+derived from the semantic code.
+
+@item DELAY-SLOT
+The instruction has one or more delay slots. This is derived from the
+semantic code.
+
+@item RELAXABLE
+The instruction has one or more identical variants.  The assembler tries
+this one first and then the relaxation phases switches to larger ones as
+necessary.
+
+@item RELAX
+The instruction is a non-minimal variant of a relaxable instruction.  It
+is avoided by the assembler in the first pass.
+
+@item ALIAS
+Internal attribute set for macro-instructions that are an alias for one
+real insn.
+
+@item NO-DIS
+For macro-instructions, don't use during disassembly.
+@end table
+
+@subsection syntax
+
+This is a character string consisting of raw characters and operands.
+Fields are denoted by @code{$operand} or
+@code{$@{operand@}}@footnote{Support for @code{$@{operand@}} is
+work-in-progress.}.  If a @samp{$} is required in the syntax, it is
+specified with @samp{\$}.  At most one white-space character may be
+present and it must be a blank separating the instruction mnemonic from
+the operands.  This doesn't restrict the user's assembler, this is
+@c Is this reasonable?
+just a description file restriction to separate the mnemonic from the
+operands@footnote{The restriction can be relaxed by saying the first
+blank is the one that separates the mnemonic from its operands.}.
+The assembly language accepted by the generated assembler does not
+have to take exactly the same form as the syntax described in this
+field--additional whitespace may be present in the input file.
+
+Operands can refer to registers, constants, and whatever else is necessary.
+
+Instruction mnemonics can take operands.  For example, on the SPARC a
+branch instruction can take @code{,a} as an argument to indicate the
+instruction is being annulled (e.g. @code{bge$a $disp22}).
+
+@subsection format
+
+This is a complete list of fields that specify the instruction.  At
+present it must be prefaced with @code{+} to allow for future additions.
+Reserved bits must also be specified, gaps are not allowed.  
+@c Well, actually I think they are and it could certainly be allowed.
+@c Question: should they be allowed?
+The ordering of the fields is not important.
+
+Format elements can be any of:
+
+@itemize @bullet
+@item instruction field specifiers with a value (e.g. @code{(f-r1 14)})
+@item an instruction field enum, as in @code{OP1_4}
+@item an operand
+@end itemize
+
+@subsection semantics
+@cindex Semantics
+
+This field provides a mathematical description of what the instruction
+does.  Its syntax is GCC-RTL-like on purpose since GCC's RTL is well known
+by the intended audience.  However, it is not intended that it be precisely
+GCC-RTL.
+
+Obviously there are some instructions that are difficult if not
+impossible to provide a description for (e.g. I/O instructions).  Rather
+than create a new semantic function for each quirky operation, escape
+hatches to C are provided to handle all such cases.  The @code{c-code},
+@code{c-call} and @code{c-raw-call} semantic functions provide an
+escape-hatch to invoke C code to perform the operation.  (*xref:
+Expressions)
+
+@subsection timing
+@cindex Timing
+
+A list of entries for each function unit the instruction uses on each machine
+that supports the instruction.  The default function unit is the u-exec unit.
+
+The syntax is:
+
+@example
+(mach-name (unit name (unit-var-name1 insn-operand-name1)
+                      (unit-var-name2 insn-operand-name2)
+                      ...
+                      (cycles cycle-count))
+@end example
+
+unit-var-name/insn-operand-name mappings are optional.
+They map unit inputs/outputs to semantic elements.
+
+@code{cycles} overrides the @code{done} value (latency) of the function
+unit and is optional.
+
+@subsection Simplification macros
+
+To simplify @file{.cpu} files, the @code{dni} macro has been created.
+It takes a fixed set of positional arguments for the typical instruction
+field.  @code{dni} is short for @code{define-normal-insn}.
+
+The syntax of @code{dni} is:
+
+@code{(dni name comment attrs syntax format semantics timing)}
+
+Example:
+
+@example
+(dni addi "add 8 bit signed immediate"
+     ()
+     "addi $dr,$simm8"
+     (+ OP1_4 dr simm8)
+     (set dr (add dr simm8))
+     ()
+)
+@end example
+
+@node Macro-instructions
+@section Macro-instructions
+@cindex Macro-instructions
+@cindex Instructions, macro
+
+Macro-instructions are for the assembler side of things and are not used
+by the simulator. The syntax for defining a macro-instruction is:
+
+@example
+(define-macro-insn
+  (name macro-insn-name)
+  (comment "description")
+  (attrs attribute-list)
+  (syntax "assembler syntax")
+  (expansions expansion-spec)
+)
+@end example
+
+@subsection syntax
+
+Syntax of the macro-instruction. This has the same value as the
+@code{syntax} field in @code{define-insn}.
+
+@subsection expansions
+
+An expression to emit code for the instruction.  This is intended to be
+general in nature, allowing tests to be done at runtime that choose the
+form of the expansion.  Currently the only supported form is:
+
+@code{(emit insn arg1 arg2 ...)}
+
+where @code{insn} is the name of an instruction defined with
+@code{define-insn} and @emph{argn} is the set of operands to
+@code{insn}'s syntax.  Each argument is mapped in order to one operand
+in @code{insn}'s syntax and may be any of:
+
+@itemize @bullet
+@item operand specified in @code{syntax}
+@item @code{(operand value)}
+@end itemize
+
+Example:
+
+@example
+(dni st-minus "st-" ()
+     "st $src1,@-$src2"
+     (+ OP1_2 OP2_7 src1 src2)
+     (sequence ((WI new-src2))
+              (set new-src2 (sub src2 (const 4)))
+              (set (mem WI new-src2) src1)
+              (set src2 new-src2))
+     ()
+)
+@end example
+
+@example
+(dnmi push "push" ()
+  "push $src1"
+  (emit st-minus src1 (src2 15)) ; "st %0,@-sp"
+)
+@end example
+
+In this example, the @code{st-minus} instruction is a general
+store-and-decrement instruction and @code{push} is a specialized version
+of it that uses the stack pointer.
+
+@node Modes
+@section Modes
+@cindex Modes
+
+Modes provide a simple and succinct way of specifying data types.
+
+(*note: Should more complex types will be needed (e.g. structs? unions?),
+these can be handled by extending the definition of a mode to encompass them.)
+
+Modes are similar to their usage in GCC, but there are some differences:
+
+@itemize @bullet
+@item modes for boolean values (i.e. bits) are also supported as they are
+useful
+@item integer modes exist in signed and unsigned versions
+@item constants have modes
+@end itemize
+
+Currently supported modes are:
+
+@table @code
+@item VOID
+VOIDmode in GCC.
+
+@item DFLT
+Indicate the default mode is wanted, the value of which depends on context.
+This is a pseudo-mode and never appears in generated code.
+
+@item BI
+Boolean zero/one
+
+@item QI,HI,SI,DI
+Same as GCC.
+
+QI is an 8 bit quantity ("quarter int").
+HI is a 16 bit quantity ("half int").
+SI is a 32 bit quantity ("single int").
+DI is a 64 bit quantity ("double int").
+
+In cases where signedness matters, these modes are signed.
+
+@item UQI,UHI,USI,UDI
+Unsigned versions of QI,HI,SI,DI.
+
+These modes do not appear in semantic RTL.  Instead, the RTL function
+specifies the signedness of its operands where necessary.
+
+??? I'm not entirely sure these unsigned modes are needed.
+They are useful in removing any ambiguity in how to sign extend constants
+which has been a source of problems in GCC.
+
+??? Some existing ports use these modes.
+
+@item WI,UWI
+word int, unsigned word int (word_mode in gcc).
+These are aliases for the real mode, typically either @code{SI} or @code{DI}.
+
+@item SF,DF,XF,TF
+Same as GCC.
+
+SF is a 32 bit IEEE float ("single float").
+DF is a 64 bit IEEE float ("double float").
+XF is either an 80 or 96 bit IEEE float ("extended float").
+(*note: XF values on m68k and i386 are different so may
+wish to give them different names).
+TF is a 128 bit IEEE float ("??? float").
+
+@item AI
+Address integer
+
+@item IAI
+Instruction address integer
+
+@item INT,UINT
+Varying width int/unsigned-int.  The width is specified by context,
+usually in an instruction field definition.
+
+@end table
+
+@node Expressions
+@section Expressions
+@cindex Expressions
+
+The syntax of CGEN's RTL expressions (or @emph{rtx}) basically follows that of 
+GCC's RTL.
+
+The handling of modes is different to simplify the implementation.
+Implementation shouldn't necessarily drive design, but it was a useful
+simplification.  Still, it needs to be reviewed.  The difference is that
+in GCC @code{(function:MODE arg1 ...)} is written in CGEN as
+@code{(function MODE arg1 ...)}.  Note the space after @samp{function}.
+
+GCC RTL allows flags to be recorded with RTL (e.g. MEM_VOLATILE_P).
+This is supported in CGEN RTL by prefixing each RTL function's arguments
+with an optional list of modifiers:
+@code{(function (:mod1 :mod2) MODE arg1 ...)}.
+The list is a set of modifier names prefixed with ':'.  They can take
+arguments.
+??? Modifiers are supported by the RTL traversing code, but no use is
+made of them yet.
+
+The currently defined semantic functions are:
+
+@table @code
+@item (set mode destination source)
+Assign @samp{source} to @samp{destination} reference in mode @samp{mode}.
+
+@item (set-quiet mode destination source)
+Assign @samp{source} to @samp{destination} referenced in mode
+@samp{mode}, but do not print any tracing message.
+
+@item (reg mode hw-name [index])
+Return an `operand' of hardware element @samp{hw-name} in mode @samp{mode}.
+If @samp{hw-name} is an array, @samp{index} selects which register.
+
+@item (raw-reg mode hw-name [index])
+Return an `operand' of hardware element @samp{hw-name} in mode @samp{mode},
+bypassing any @code{get} or @code{set} specs of the register.
+If @samp{hw-name} is an array, @samp{index} selects which register.
+This cannot be used with virtual registers (those specified with the
+@samp{VIRTUAL} attribute).
+
+@code{raw-reg} is most often used in @code{get} and @code{set} specs
+of a register: if it weren't read and write operations would infinitely
+recurse.
+
+@item (mem mode address)
+Return an `operand' of memory referenced at @samp{address} in mode
+@samp{mode}.
+
+@item (const mode value)
+Return an `operand' of constant @samp{value} in mode @samp{mode}.
+
+@item (enum mode value-name)
+Return an `operand' of constant @samp{value-name} in mode @samp{mode}.
+The value must be from a previously defined enum.
+
+@item (subword mode value word-num)
+Return part of @samp{value}.  Which part is determined by @samp{mode} and
+@samp{word-num}.  There are three cases.
+
+If @samp{mode} is the same size as the mode of @samp{value}, @samp{word-num}
+must be @samp{0} and the result is @samp{value} recast in the new mode.
+There is no change in the bits of @samp{value}, they're just interpreted in a
+possibly different mode.  This is most often used to interpret an integer
+value as a float and vice versa.
+
+If @samp{mode} is smaller, @samp{value} is divided into N pieces and
+@samp{word-num} picks which piece.  All pieces have the size of @samp{mode}
+except possibly the last.  If the last piece has a different size,
+it cannot be referenced.
+This follows GCC and is byte order dependent.@footnote{To be
+revisited}.
+Word number 0 is the most significant word if big-endian-words.
+Word number 0 is the least significant word if little-endian-words.
+
+If @samp{mode} is larger, @samp{value} is interpreted in the larger mode
+with the upper most significant bits treated as garbage (their value is
+assumed to be unimportant to the context in which the value will be used).
+@samp{word-num} must be @samp{0}.
+This case is byte order independent.
+
+@item (join out-mode in-mode arg1 . arg-rest)
+Concatenate @samp{arg1[,arg2[,...]]} to create a value of mode @samp{out-mode}.
+@samp{arg1} becomes the most significant part of the result.
+Each argument is interpreted in mode @samp{in-mode}.
+@samp{in-mode} must evenly divide @samp{out-mode}.
+??? Endianness issues have yet to be decided.
+
+@item (sequence mode ((mode1 local1) ...) expr1 expr2 ...)
+Execute @samp{expr1}, @samp{expr2}, etc. sequentially. @samp{mode} is the
+mode of the result, which is defined to be that of the last expression.
+`@code{((mode1 local1) ...)}' is a set of local variables.
+
+@item (parallel mode empty expr1 ...)
+Execute @samp{expr1}, @samp{expr2}, etc. in parallel. All inputs are
+read before any output is written.  @samp{empty} must be @samp{()} and
+is present for consistency with @samp{sequence}. @samp{mode} must be
+@samp{VOID} (void mode). @samp{((mode1 local1) ...)} is a set of local
+variables.
+
+@item (unop mode operand)
+Perform a unary arithmetic operation. @samp{unop} is one of @code{neg},
+@code{abs}, @code{inv}, @code{not}, @code{zflag}, @code{nflag}.
+@code{zflag} returns a bit indicating if @samp{operand} is
+zero. @code{nflag} returns a bit indicating if @samp{operand} is
+negative. @code{inv} returns the bitwise complement of @samp{operand},
+whereas @code{not} returns its logical negation.
+
+@item (binop mode operand1 operand2)
+Perform a binary arithmetic operation. @samp{binop} is one of
+@code{add}, @code{sub}, @code{and}, @code{or}, @code{xor}, @code{mul},
+@code{div}, @code{udiv}, @code{mod}, @code{umod}.
+
+@item (binop-with-bit mode operand1 operand2 operand3)
+Same as @samp{binop}, except taking 3 operands. The third operand is
+always a single bit. @samp{binop-with-bit} is one of @code{addc},
+@code{add-cflag}, @code{add-oflag}, @code{subc}, @code{sub-cflag},
+@code{sub-oflag}.
+
+@item (shiftop mode operand1 operand2)
+Perform a shift operation. @samp{shiftop} is one of @code{sll},
+@code{srl}, @code{sra}, @code{ror}, @code{rol}.
+
+@item (boolifop mode operand1 operand2)
+Perform a sequential boolean operation. @samp{operand2} is not processed
+if @samp{operand1} ``fails''. @samp{boolifop} is one of @code{andif},
+@code{orif}.
+
+@item (convop mode operand)
+Perform a mode->mode conversion operation. @samp{convop} is one of
+@code{ext}, @code{zext}, @code{trunc}, @code{float}, @code{ufloat},
+@code{fix}, @code{ufix}.
+
+@item (cmpop mode operand1 operand2)
+Perform a comparison. @samp{cmpop} is one of @code{eq}, @code{ne},
+@code{lt}, @code{le}, @code{gt}, @code{ge}, @code{ltu}, @code{leu},
+@code{gtu}, @code{geu}.
+
+@item (if mode condition then [else])
+Standard @code{if} statement.
+
+@samp{condition} is any arithmetic expression.
+If the value is non-zero the @samp{then} part is executed.
+Otherwise, the @samp{else} part is executed (if present).
+
+@samp{mode} is the mode of the result, not of @samp{condition}.
+If @samp{mode} is not @code{VOID} (void mode), @samp{else} must be present.
+
+@item (cond mode (condition1 expr1a ...) (...) [(else exprNa...)])
+From Scheme: keep testing conditions until one succeeds, and then
+process the associated expressions.
+
+@item (case mode test ((case1 ..) expr1a ..) (..) [(else exprNa ..)])
+From Scheme: Compare @samp{test} with @samp{case1}, @samp{case2},
+etc. and process the associated expressions.
+
+@item (c-code mode "C expression")
+An escape hook to insert arbitrary C code. @samp{mode} must the
+compatible with the result of ``C expression''.
+
+@item (c-call mode symbol operand1 operand2 ...)
+An escape hook to emit a subroutine call to function named @samp{symbol}
+passing operands @samp{operand1}, @samp{operand2}, etc.  An implicit
+first argument of @code{current_cpu} is passed to @samp{symbol}.
+@samp{mode} is the mode of the result.  Be aware that @samp{symbol} will
+be restricted by reserved words in the C programming language any by
+existing symbols in the generated code.
+
+@item (c-raw-call mode symbol operand1 operand2 ...)
+Same as @code{c-call}: except there is no implicit @code{current_cpu}
+first argument.
+@samp{mode} is the mode of the result.
+
+@item (clobber mode object)
+Indicate that @samp{object} is written in mode @samp{mode}, without
+saying how. This could be useful in conjunction with the C escape hooks.
+
+@item (annul yes?)
+@c FIXME: put annul into the glossary.
+Annul the following instruction if @samp{yes?} is non-zero. This rtx is
+an experiment and will probably change.
+
+@item (skip yes?)
+Skip the next instruction if @samp{yes?} is non-zero. This rtx is
+an experiment and will probably change.
+
+@item (attr mode kind attr-name)
+Return the value of attribute @samp{attr-name} in mode
+@samp{mode}. @samp{kind} must currently be @samp{insn}: the current
+instruction.
+
+@item (symbol name)
+Return a symbol with value @samp{name}, for use in attribute
+processing. This is equivalent to @samp{quote} in Scheme but
+@samp{quote} sounds too jargonish.
+
+@item (eq-attr mode attr-name value)
+Return non-zero if the value of attribute @samp{attr-name} is
+@samp{value}. If @samp{value} is a list return ``true'' if
+@samp{attr-name} is any of the listed values.
+
+@item (nop)
+A no-op.
+
+@item (ifield field-name)
+Return the value of field @samp{field-name}. @samp{field-name} must be a
+field in the instruction. Operands can be any of:
+@c ???
+
+@itemize @bullet
+@item an operand defined in the description file
+@item a register reference, created with (reg mode [index])
+@item a memory reference, created with (mem mode address)
+@item a constant, created with (const mode value)
+@item a `sequence' local variable
+@item another expression
+@end itemize
+
+The @samp{symbol} in a @code{c-call} or @code{c-raw-call} function is
+currently the name of a C function or macro that is invoked by the
+generated semantic code.
+@end table
+
+@node Macro-expressions
+@section Macro-expressions
+@cindex Macro-expressions
+
+Macro RTL expressions started out by wanting to not have to always
+specify a mode for every expression (and sub-expression
+thereof).  Whereas the formal way to specify, say, an add is @code{(add
+SI arg1 arg2)} if SI is the default mode of `arg1' then this can be
+simply written as @code{(add arg1 arg2)}.  This gets expanded to
+@code{(add DFLT arg1 arg2)} where @code{DFLT} means ``default mode''.
+
+It might be possible to replace macro expressions with preprocessor macros,
+however for the nonce there is no plan to do this.
diff --git a/cgen/doc/running.texi b/cgen/doc/running.texi
new file mode 100644 (file)
index 0000000..644dad1
--- /dev/null
@@ -0,0 +1,9 @@
+@c Copyright (C) 2000 Red Hat, Inc.
+@c This file is part of the CGEN manual.
+@c For copying conditions, see the file cgen.texi.
+
+@node Running CGEN
+@chapter Running CGEN
+
+This chapter needs to explain how to run CGEN, how it fits together, and
+what to expect when you do run it (ie. output, resultant files, etc).
diff --git a/cgen/doc/sim.texi b/cgen/doc/sim.texi
new file mode 100644 (file)
index 0000000..11c08fa
--- /dev/null
@@ -0,0 +1,45 @@
+@c Copyright (C) 2000 Red Hat, Inc.
+@c This file is part of the CGEN manual.
+@c For copying conditions, see the file cgen.texi.
+
+@node Simulation
+@chapter Simulation support
+@cindex Simulation support
+
+Simulator support comes in the form of machine generated the decoder/executer
+as well as the structure that records CPU state information (ie. registers).
+
+There are 3 architecture-wide generated files:
+
+@table @file
+@item arch.h
+Definitions and declarations common to the entire architecture.
+@item arch.c
+Tables and code common to the entire architecture, but which can't be
+put in the common area.
+@item cpuall.h
+Pseudo base classes of various structures.
+@end table
+
+Each ``CPU family'' has its own set of the following files:
+
+@table @file
+@item cpu.h
+Definitions and declarations specific to a particular CPU family.
+@item cpu.c
+Tables and code specific to a particular CPU family.
+@item decode.h
+Decoder definitions and declarations.
+@item decode.c
+Decoder tables and code.
+@item model.c
+Tables and code for each model in the CPU family.
+@item semantics.c
+Code to perform each instruction.
+@item sem-switch.c
+Same as @file{semantics.c} but as one giant @code{switch} statement.
+@end table
+
+A ``CPU family'' is an artificial creation to sort architecture variants
+along whatever lines seem useful.  Additional hand-written files must be
+provided.  @xref{Porting} for details.
diff --git a/cgen/doc/stamp-vti b/cgen/doc/stamp-vti
new file mode 100644 (file)
index 0000000..3e1e7a5
--- /dev/null
@@ -0,0 +1,3 @@
+@set UPDATED 11 October 1999
+@set EDITION 1.0
+@set VERSION 1.0
diff --git a/cgen/doc/version.texi b/cgen/doc/version.texi
new file mode 100644 (file)
index 0000000..ef3c4e2
--- /dev/null
@@ -0,0 +1,3 @@
+@set UPDATED 31 July 2000
+@set EDITION 1.0
+@set VERSION 1.0
diff --git a/cgen/enum.scm b/cgen/enum.scm
new file mode 100644 (file)
index 0000000..3e4c9c9
--- /dev/null
@@ -0,0 +1,391 @@
+; Enums.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; Enums having attribute PREFIX have their symbols prepended with
+; the enum class' name.
+; Member PREFIX is always prepended to the symbol names.
+;
+; Enum values are looked up with `enum-lookup-val'.  The value to search for
+; has PREFIX prepended.
+;
+; Enums always have mode INT.
+
+(define <enum>
+  (class-make '<enum>
+             '(<ident>)
+             '(prefix vals)
+             nil)
+)
+
+; FIXME: this make! method is required by <insn-enum> for some reason. 
+(method-make!
+ <enum> 'make!
+ (lambda (self name comment attrs prefix vals)
+   (elm-set! self 'name name)
+   (elm-set! self 'comment comment)
+   (elm-set! self 'attrs attrs)
+   (elm-set! self 'prefix prefix)
+   (elm-set! self 'vals vals)
+   self)
+)
+
+(define enum-prefix (elm-make-getter <enum> 'prefix))
+
+(method-make! <enum> 'enum-values (lambda (self) (elm-get self 'vals)))
+
+; Parse a list of enum name/value entries.
+; PREFIX is prepended to each name.
+; Elements are any of: symbol, (symbol), (symbol value)
+; (symbol - attrs), (symbol value attrs).
+; The `-' means use the next value.
+; The result is the same list, except values are filled in where missing,
+; and each symbol is prepended with `prefix'.
+
+(define (parse-enum-vals prefix vals)
+  ; Scan the value list, building up RES-VALS as we go.
+  ; Each element's value is 1+ the previous, unless there's an explicit value.
+  (let loop ((result nil) (last -1) (remaining vals))
+    (if (null? remaining)
+       (reverse! result)
+       (let
+           ; Compute the numeric value the next entry will have.
+           ((val (if (and (pair? (car remaining))
+                          (not (null? (cdar remaining))))
+                     (if (eq? '- (cadar remaining))
+                         (+ last 1)
+                         (cadar remaining))
+                     (+ last 1))))
+         (if (eq? (car remaining) '-)
+             (loop result val (cdr remaining))
+             (loop (cons (cons (symbol-append prefix
+                                              (if (pair? (car remaining))
+                                                  (caar remaining)
+                                                  (car remaining)))
+                               (cons val
+                                     ; Pass any attributes through unchanged.
+                                     (if (and (pair? (car remaining))
+                                              (pair? (cdar remaining)))
+                                         (cddar remaining)
+                                         nil)))
+                         result)
+                   val
+                   (cdr remaining))))))
+)
+
+; Convert the names in the result of parse-enum-vals to uppercase.
+
+(define (enum-vals-upcase vals)
+  (map (lambda (elm)
+        (cons (string->symbol (string-upcase (car elm))) (cdr elm)))
+       vals)
+)
+\f
+; Parse an enum definition.
+
+; Utility of -enum-parse to parse the prefix.
+
+(define (-enum-parse-prefix errtxt prefix)
+  (if (symbol? prefix)
+      (set! prefix (symbol->string prefix)))
+
+  (if (not (string? prefix))
+      (parse-error errtxt "prefix is not a string" prefix))
+
+  ; Prefix must not contain lowercase chars (enforced style rule, sue me).
+  (if (any-true? (map char-lower-case? (string->list prefix)))
+      (parse-error errtxt "prefix must be uppercase" prefix))
+
+  prefix
+)
+
+; This is the main routine for building an ifield object from a
+; description in the .cpu file.
+; All arguments are in raw (non-evaluated) form.
+
+(define (-enum-parse errtxt name comment attrs prefix vals)
+  (logit 2 "Processing enum " name " ...\n")
+
+  (let* ((name (parse-name name errtxt))
+        (errtxt (string-append errtxt " " name)))
+
+    (make <enum>
+         name
+         (parse-comment comment errtxt)
+         (atlist-parse attrs "enum" errtxt)
+         (-enum-parse-prefix errtxt prefix)
+         (parse-enum-vals prefix vals)))
+)
+
+; Read an enum description
+; This is the main routine for analyzing enums in the .cpu file.
+; ERRTXT is prepended to error messages to provide context.
+; ARG-LIST is an associative list of field name and field value.
+; -enum-parse is invoked to create the `enum' object.
+
+(define (-enum-read errtxt . arg-list)
+  (let (; Current enum elements:
+       (name nil)    ; name of field
+       (comment "")  ; description of field
+       (attrs nil)   ; attributes
+       (prefix "")   ; prepended to each element's name
+       (values nil)  ; enum values
+       )
+    ; Loop over each element in ARG-LIST, recording what's found.
+    (let loop ((arg-list arg-list))
+      (if (null? arg-list)
+         nil
+         (let ((arg (car arg-list))
+               (elm-name (caar arg-list)))
+           (case elm-name
+             ((name) (set! name (cadr arg)))
+             ((comment) (set! comment (cadr arg)))
+             ((attrs) (set! attrs (cdr arg)))
+             ((prefix) (set! prefix (cadr arg)))
+             ((values) (set! values (cadr arg)))
+             (else (parse-error errtxt "invalid enum arg" arg)))
+           (loop (cdr arg-list)))))
+    ; Now that we've identified the elements, build the object.
+    (-enum-parse errtxt name comment attrs prefix values)
+    )
+)
+
+; Define an enum object, name/value pair list version.
+
+(define define-enum
+  (lambda arg-list
+    (let ((e (apply -enum-read (cons "define-enum" arg-list))))
+      (current-enum-add! e)
+      e))
+)
+
+; Define an enum object, all arguments specified.
+
+(define (define-full-enum name comment attrs prefix vals)
+  (let ((e (-enum-parse "define-full-enum" name comment attrs prefix vals)))
+    (current-enum-add! e)
+    e)
+)
+\f
+; Lookup SYM in all recorded enums.
+; The result is (value . enum-obj) or #f if not found.
+
+(define (enum-lookup-val name)
+  (let loop ((elist (current-enum-list)))
+    (if (null? elist)
+       #f
+       (let ((e (assq name (send (car elist) 'enum-values))))
+         ;(display e) (newline)
+         (if e
+             (begin
+               ; sanity check, ensure the enum has a value
+               (if (null? (cdr e)) (error "enum-lookup-val: enum missing value: " (car e)))
+               (cons (cadr e) (car elist)))
+             (loop (cdr elist)))
+         )
+       )
+    )
+)
+\f
+; Enums support code.
+
+; Return #t if VALS is a sequential list of enum values.
+; VALS is a list of enums.  e.g. ((sym1) (sym2 3) (sym3 '- attr1 (attr2 4)))
+; FIXME: Doesn't handle gaps in specified values.
+; e.g. (sym1 val1) sym2 (sym3 val3)
+
+(define (enum-sequential? vals)
+  (let loop ((last -1) (remaining vals))
+    (if (null? remaining)
+       #t
+       (let ((val (if (and (pair? (car remaining))
+                           (not (null? (cdar remaining))))
+                      (cadar remaining)
+                      (+ last 1))))
+         (if (eq? val '-)
+             (loop (+ last 1) (cdr remaining))
+             (if (not (= val (+ last 1)))
+                 #f
+                 (loop val (cdr remaining)))))))
+)
+
+; Return C code to declare enum SYM with values VALS.
+; COMMENT is inserted in "/* Enum declaration for <...>.  */".
+; PREFIX is added to each element of VALS.
+; All enum symbols are uppercase.
+; If the list of vals is sequential beginning at 0, don't output them.
+; This simplifies the output and is necessary for sanitized values where
+; some values may be cut out.
+; VALS may have '- for the value, signifying use the next value as in C.
+
+(define (gen-enum-decl name comment prefix vals)
+  (logit 2 "Generating enum decl for " name " ...\n")
+  ; Build result up as a list and then flatten it into a string.
+  ; We could just return a string-list but that seems like too much to ask
+  ; of callers.
+  (string-list->string
+   (append!
+    (string-list
+     "/* Enum declaration for " comment ".  */\n"
+     "typedef enum "
+     (string-downcase (gen-c-symbol name))
+     " {")
+    (let loop ((n 0) ; `n' is used to track the number of entries per line only
+              (sequential? (enum-sequential? vals))
+              (vals vals)
+              (result (list "")))
+      (if (null? vals)
+         result
+         (let* ((e (car vals))
+                (attrs (if (null? (cdr e)) nil (cddr e)))
+                (san-code (attr-value attrs 'sanitize #f))
+                (san? (and san-code (not (eq? san-code 'none)))))
+           (loop
+            (if san?
+                4 ; reset to beginning of line (but != 0)
+                (+ n 1))
+            sequential?
+            (cdr vals)
+            (append!
+             result
+             (string-list
+              (if san?
+                  (string-append "\n"
+                                 (if include-sanitize-marker?
+                                     ; split string to avoid removal
+                                     (string-append "/* start-"
+                                                    "sanitize-"
+                                                    san-code " */\n")
+                                     "")
+                                 " ")
+                  "")
+              (string-upcase
+               (string-append
+                (if (and (not san?) (=? (remainder n 4) 0))
+                    "\n "
+                    "")
+                (if (= n 0)
+                    " "
+                    ", ")
+                (gen-c-symbol prefix)
+                (gen-c-symbol (car e))
+                (if (or sequential? (null? (cdr e)) (eq? '- (cadr e)))
+                    ""
+                    (string-append " = "
+                                   (if (number? (cadr e))
+                                       (number->string (cadr e))
+                                       (cadr e))))
+                ))
+              (if (and san? include-sanitize-marker?)
+                  ; split string to avoid removal
+                  (string-append "\n/* end-"
+                                 "sanitize-" san-code " */")
+                  "")))))))
+    (string-list
+     "\n} "
+     (string-upcase (gen-c-symbol name))
+     ";\n\n")
+    ))
+)
+
+; Return a list of enum value definitions for gen-enum-decl.
+; OBJ-LIST is a list of objects that support obj:name, obj-atlist.
+
+(define (gen-obj-list-enums obj-list)
+  (map (lambda (o)
+        (cons (obj:name o) (cons '- (atlist-attrs (obj-atlist o)))))
+       obj-list)
+)
+
+; Return C code that declares[/defines] an enum.
+
+(method-make!
+ <enum> 'gen-decl
+ (lambda (self)
+   (gen-enum-decl (elm-get self 'name)
+                 (elm-get self 'comment)
+                 (if (has-attr? self 'PREFIX)
+                     (string-append (elm-get self 'name) "_")
+                     "")
+                 (elm-get self 'vals)))
+)
+
+; Return the C symbol of an enum value named VAL.
+
+(define (gen-enum-sym enum-obj val)
+  (string-upcase (gen-c-symbol (string-append (enum-prefix enum-obj) val)))
+)
+\f
+; Instruction code enums.
+; These associate an enum with an instruction field so that the enum values
+; can be used in instruction field lists.
+
+(define <insn-enum> (class-make '<insn-enum> '(<enum>) '(fld) nil))
+
+(method-make!
+ <insn-enum> 'make!
+ (lambda (self name comment attrs prefix fld vals)
+   (send (object-parent self <enum>) 'make! name comment attrs prefix vals)
+   (elm-set! self 'fld fld)
+   self
+   )
+)
+
+(define ienum:fld (elm-make-getter <insn-enum> 'fld))
+
+; Same as enum-lookup-val except returned enum must be an insn-enum.
+
+(define (ienum-lookup-val name)
+  (let ((result (enum-lookup-val name)))
+    (if (and result (eq? (object-class-name (cdr result)) '<insn-enum>))
+       result
+       #f))
+)
+
+; Define an insn enum, all arguments specified.
+
+(define (define-full-insn-enum name comment attrs prefix fld vals)
+  (let ((errtxt "define-full-insn-enum")
+       (fld-obj (current-ifld-lookup fld)))
+
+    (if (not fld-obj)
+       (parse-error errtxt "unknown insn field" fld))
+
+    ; Create enum object and add it to the list of enums.
+    (let ((e (make <insn-enum>
+              (parse-name name errtxt)
+              (parse-comment comment errtxt)
+              (atlist-parse attrs "insn-enum" errtxt)
+              (-enum-parse-prefix errtxt prefix)
+              fld-obj
+              (parse-enum-vals prefix vals))))
+      (current-enum-add! e)
+      e))
+)
+\f
+(define (enum-init!)
+
+  (reader-add-command! 'define-enum
+                      "\
+Define an enum, name/value pair list version.
+"
+                      nil 'arg-list define-enum)
+  (reader-add-command! 'define-full-enum
+                      "\
+Define an enum, all arguments specified.
+"
+                      nil '(name comment attrs prefix vals) define-full-enum)
+  (reader-add-command! 'define-full-insn-enum
+                      "\
+Define an instruction opcode enum, all arguments specified.
+"
+                      nil '(name comment attrs prefix ifld vals)
+                      define-full-insn-enum)
+
+  *UNSPECIFIED*
+)
+
+(define (enum-finish!)
+  *UNSPECIFIED*
+)
diff --git a/cgen/fixup.scm b/cgen/fixup.scm
new file mode 100644 (file)
index 0000000..fe06241
--- /dev/null
@@ -0,0 +1,38 @@
+; Fix up the current interpreter-du-jour to conform to what we've
+; been working with.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; check for newer guile
+
+(if (symbol-bound? #f 'load-from-path)
+    (begin
+      (define (load file)
+       (begin
+         ;(load-from-path file)
+         (primitive-load-path file)
+         ))
+      )
+)
+
+; FIXME: to be deleted
+(define =? =)
+(define >=? >=)
+
+(if (not (symbol-bound? #f '%stat))
+    (begin
+      (define %stat stat)
+      )
+)
+
+(if (symbol-bound? #f 'debug-enable)
+    (debug-enable 'backtrace)
+)
+
+; Guile 1.3 has reverse!, Guile 1.2 has list-reverse!.
+; CGEN uses reverse!
+(if (and (not (symbol-bound? #f 'reverse!))
+        (symbol-bound? #f 'list-reverse!))
+    (define reverse! list-reverse!)
+)
diff --git a/cgen/fr30.cpu b/cgen/fr30.cpu
new file mode 100644 (file)
index 0000000..eb1d397
--- /dev/null
@@ -0,0 +1,1845 @@
+; Fujitsu FR30 CPU description.  -*- Scheme -*-
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+(include "simplify.inc")
+
+; define-arch must appear first
+
+(define-arch
+  (name fr30) ; name of cpu family
+  (comment "Fujitsu FR30")
+  (default-alignment forced)
+  (insn-lsb0? #f)
+  (machs fr30)
+  (isas fr30)
+)
+
+(define-isa
+  (name fr30)
+  (base-insn-bitsize 16)
+  (decode-assist (0 1 2 3 4 5 6 7)) ; Initial bitnumbers to decode insns by.
+  (liw-insns 1)       ; The fr30 fetches  1 insn at a time.
+  (parallel-insns 1)  ; The fr30 executes 1 insn at a time.
+)
+
+(define-cpu
+  ; cpu names must be distinct from the architecture name and machine names.
+  ; The "b" suffix stands for "base" and is the convention.
+  ; The "f" suffix stands for "family" and is the convention.
+  (name fr30bf)
+  (comment "Fujitsu FR30 base family")
+  (endian big)
+  (word-bitsize 32)
+)
+
+(define-mach
+  (name fr30)
+  (comment "Generic FR30 cpu")
+  (cpu fr30bf)
+)
+\f
+; Model descriptions.
+;
+(define-model
+  (name fr30-1) (comment "fr30-1") (attrs)
+  (mach fr30)
+
+  (pipeline all "" () ((fetch) (decode) (execute) (writeback)))
+
+  ; `state' is a list of variables for recording model state
+  (state
+   ; bit mask of h-gr registers loaded from memory by previous insn
+   (load-regs UINT)
+   ; bit mask of h-gr registers loaded from memory by current insn
+   (load-regs-pending UINT)
+   )
+
+  (unit u-exec "Execution Unit" ()
+       1 1 ; issue done
+       () ; state
+       ((Ri INT -1) (Rj INT -1)) ; inputs
+       ((Ri INT -1)) ; outputs
+       () ; profile action (default)
+       )
+  (unit u-cti "Branch Unit" ()
+       1 1 ; issue done
+       () ; state
+       ((Ri INT -1)) ; inputs
+       ((pc)) ; outputs
+       () ; profile action (default)
+       )
+  (unit u-load "Memory Load Unit" ()
+       1 1 ; issue done
+       () ; state
+       ((Rj INT -1)
+        ;(ld-mem AI)
+        ) ; inputs
+       ((Ri INT -1)) ; outputs
+       () ; profile action (default)
+       )
+  (unit u-store "Memory Store Unit" ()
+       1 1 ; issue done
+       () ; state
+       ((Ri INT -1) (Rj INT -1)) ; inputs
+       () ; ((st-mem AI)) ; outputs
+       () ; profile action (default)
+       )
+  (unit u-ldm "LDM Memory Load Unit" ()
+       1 1 ; issue done
+       () ; state
+       ((reglist INT)) ; inputs
+       () ; outputs
+       () ; profile action (default)
+       )
+  (unit u-stm "STM Memory Store Unit" ()
+       1 1 ; issue done
+       () ; state
+       ((reglist INT)) ; inputs
+       () ; outputs
+       () ; profile action (default)
+       )
+)
+\f
+; The instruction fetch/execute cycle.
+;
+; This is how to fetch and decode an instruction.
+; Leave it out for now
+
+; (define-extract (const SI 0))
+
+; This is how to execute a decoded instruction.
+; Leave it out for now
+
+; (define-execute (const SI 0))
+\f
+; Instruction fields.
+;
+; Attributes:
+; PCREL-ADDR: pc relative value (for reloc and disassembly purposes)
+; ABS-ADDR: absolute address (for reloc and disassembly purposes?)
+; RESERVED: bits are not used to decode insn, must be all 0
+
+(dnf f-op1       "1st 4 bits of opcode"  ()  0  4)
+(dnf f-op2       "2nd 4 bits of opcode"  ()  4  4)
+(dnf f-op3       "3rd 4 bits of opcode"  ()  8  4)
+(dnf f-op4       "4th 4 bits of opcode"  () 12  4)
+(dnf f-op5       "5th bit of opcode"     ()  4  1)
+(dnf f-cc        "condition code"        ()  4  4)
+(dnf f-ccc       "coprocessor calc code" () 16  8)
+(dnf f-Rj        "register Rj"           ()  8  4)
+(dnf f-Ri        "register Ri"           () 12  4)
+(dnf f-Rs1       "register Rs"           ()  8  4)
+(dnf f-Rs2       "register Rs"           () 12  4)
+(dnf f-Rjc       "register Rj"           () 24  4)
+(dnf f-Ric       "register Ri"           () 28  4)
+(dnf f-CRj       "coprocessor register"  () 24  4)
+(dnf f-CRi       "coprocessor register"  () 28  4)
+(dnf f-u4        "4 bit 0 extended"      ()  8  4)
+(dnf f-u4c       "4 bit 0 extended"      () 12  4)
+(df  f-i4        "4 bit sign extended"   ()  8  4 INT #f #f)
+(df  f-m4        "4 bit minus extended"  ()  8  4 UINT
+     ((value pc) (and WI value (const #xf)))
+     ; ??? On a 64 bit host this doesn't get completely sign extended
+     ; if the value is recorded in a long, as it is during extraction.
+     ; Various fixes exist, pick one.
+     ((value pc) (or  WI value (sll WI (const -1) (const 4))))
+)
+(dnf f-u8        "8 bit unsigned"        ()  8  8)
+(dnf f-i8        "8 bit unsigned"        ()  4  8)
+
+(dnf  f-i20-4     "upper 4 bits of i20"  ()  8  4)
+(dnf  f-i20-16    "lower 16 bits of i20" () 16 16)
+(dnmf f-i20       "20 bit unsigned"      () UINT
+      (f-i20-4 f-i20-16)
+      (sequence () ; insert
+               (set (ifield f-i20-4)  (srl (ifield f-i20) (const 16)))
+               (set (ifield f-i20-16) (and (ifield f-i20) (const #xffff)))
+               )
+      (sequence () ; extract
+               (set (ifield f-i20) (or (sll (ifield f-i20-4) (const 16))
+                                       (ifield f-i20-16)))
+               )
+)
+
+(dnf f-i32       "32 bit immediate"      (SIGN-OPT) 16 32)
+
+(df  f-udisp6    "6 bit unsigned offset" ()  8  4 UINT
+     ((value pc) (srl UWI value (const 2)))
+     ((value pc) (sll UWI value (const 2)))
+)
+(df  f-disp8     "8 bit signed offset"   ()  4  8 INT #f #f)
+(df  f-disp9     "9 bit signed offset"   ()  4  8 INT
+    ((value pc) (sra WI value (const 1)))
+    ((value pc) (sll WI value (const 1)))
+)
+(df  f-disp10    "10 bit signed offset"  ()  4  8 INT
+     ((value pc) (sra WI value (const 2)))
+     ((value pc) (sll WI value (const 2)))
+)
+(df  f-s10       "10 bit signed offset"  ()  8  8 INT
+     ((value pc) (sra WI value (const 2)))
+     ((value pc) (sll WI value (const 2)))
+)
+(df  f-u10       "10 bit unsigned offset" ()  8  8 UINT
+     ((value pc) (srl UWI value (const 2)))
+     ((value pc) (sll UWI value (const 2)))
+)
+(df  f-rel9 "9 pc relative signed offset" (PCREL-ADDR) 8 8 INT
+     ((value pc) (sra WI (sub WI value (add WI pc (const 2))) (const 1)))
+     ((value pc) (add WI (sll WI value (const 1)) (add WI pc (const 2))))
+)
+(dnf f-dir8      "8  bit direct address"  ()  8  8)
+(df  f-dir9      "9  bit direct address"  ()  8  8 UINT
+     ((value pc) (srl UWI value (const 1)))
+     ((value pc) (sll UWI value (const 1)))
+)
+(df  f-dir10     "10 bit direct address"  ()  8  8 UINT
+     ((value pc) (srl UWI value (const 2)))
+     ((value pc) (sll UWI value (const 2)))
+)
+(df  f-rel12     "12 bit pc relative signed offset" (PCREL-ADDR) 5 11 INT
+     ((value pc) (sra WI (sub WI value (add WI pc (const 2))) (const 1)))
+     ((value pc) (add WI (sll WI value (const 1)) (add WI pc (const 2))))
+)
+
+(dnf f-reglist_hi_st  "8 bit register mask for stm" () 8 8)
+(dnf f-reglist_low_st "8 bit register mask for stm" () 8 8)
+(dnf f-reglist_hi_ld  "8 bit register mask for ldm" () 8 8)
+(dnf f-reglist_low_ld "8 bit register mask for ldm" () 8 8)
+\f
+; Enums.
+
+; insn-op1: bits 0-3
+; FIXME: should use die macro or some such
+(define-normal-insn-enum insn-op1 "insn op1 enums" () OP1_ f-op1
+  ("0" "1" "2" "3" "4" "5" "6" "7"
+   "8" "9" "A" "B" "C" "D" "E" "F")
+)
+
+; insn-op2: bits 4-7
+; FIXME: should use die macro or some such
+(define-normal-insn-enum insn-op2 "insn op2 enums" () OP2_ f-op2
+  ("0" "1" "2" "3" "4" "5" "6" "7"
+   "8" "9" "A" "B" "C" "D" "E" "F")
+)
+
+; insn-op3: bits 8-11
+; FIXME: should use die macro or some such
+(define-normal-insn-enum insn-op3 "insn op3 enums" () OP3_ f-op3
+  ("0" "1" "2" "3" "4" "5" "6" "7"
+   "8" "9" "A" "B" "C" "D" "E" "F")
+)
+
+; insn-op4: bits 12-15
+; FIXME: should use die macro or some such
+(define-normal-insn-enum insn-op4 "insn op4 enums" () OP4_ f-op4
+  ("0")
+)
+
+; insn-op5: bit 4 (5th bit origin 0)
+; FIXME: should use die macro or some such
+(define-normal-insn-enum insn-op5 "insn op5 enums" () OP5_ f-op5
+  ("0" "1")
+)
+
+; insn-cc: condition codes
+; FIXME: should use die macro or some such
+(define-normal-insn-enum insn-cc "insn cc enums" () CC_ f-cc
+  ("ra" "no" "eq" "ne" "c" "nc" "n" "p" "v" "nv" "lt" "ge" "le" "gt" "ls" "hi")
+)
+\f
+; Hardware pieces.
+; These entries list the elements of the raw hardware.
+; They're also used to provide tables and other elements of the assembly
+; language.
+
+(dnh h-pc "program counter" (PC PROFILE) (pc) () () ())
+
+(define-keyword
+  (name gr-names)
+  (print-name h-gr)
+  (prefix "")
+  (values (r0 0) (r1 1) (r2 2) (r3 3) (r4 4) (r5 5) (r6 6) (r7 7)
+         (r8 8) (r9 9) (r10 10) (r11 11) (r12 12) (r13 13) (r14 14) (r15 15)
+         (ac 13) (fp 14) (sp 15))
+)
+
+(define-hardware
+  (name h-gr)
+  (comment "general registers")
+  (attrs PROFILE CACHE-ADDR)
+  (type register WI (16))
+  (indices extern-keyword gr-names)
+)
+
+(define-keyword
+  (name cr-names)
+  (print-name h-cr)
+  (prefix "")
+  (values (cr0 0) (cr1 1) (cr2 2) (cr3 3)
+         (cr4 4) (cr5 5) (cr6 6) (cr7 7)
+         (cr8 8) (cr9 9) (cr10 10) (cr11 11)
+         (cr12 12) (cr13 13) (cr14 14) (cr15 15))
+)
+
+(define-hardware
+  (name h-cr)
+  (comment "coprocessor registers")
+  (attrs)
+  (type register WI (16))
+  (indices extern-keyword cr-names)
+)
+
+(define-keyword
+  (name dr-names)
+  (print-name h-dr)
+  (prefix "")
+  (values (tbr 0) (rp 1) (ssp 2) (usp 3) (mdh 4) (mdl 5))
+)
+
+(define-hardware
+  (name h-dr)
+  (comment "dedicated registers")
+  (type register WI (6))
+  (indices extern-keyword dr-names)
+  (get (index) (c-call WI "@cpu@_h_dr_get_handler" index))
+  (set (index newval) (c-call VOID "@cpu@_h_dr_set_handler" index newval))
+)
+
+(define-hardware
+  (name h-ps)
+  (comment "processor status")
+  (type register UWI)
+  (indices keyword "" ((ps 0)))
+  (get () (c-call UWI "@cpu@_h_ps_get_handler"))
+  (set (newval) (c-call VOID "@cpu@_h_ps_set_handler" newval))
+)
+
+(dnh h-r13 "General Register 13 explicitly required"
+    ()
+    (register WI)
+    (keyword "" ((r13 0)))
+    () ()
+)
+
+(dnh h-r14 "General Register 14 explicitly required"
+    ()
+    (register WI)
+    (keyword "" ((r14 0)))
+    () ()
+)
+
+(dnh h-r15 "General Register 15 explicitly required"
+    ()
+    (register WI)
+    (keyword "" ((r15 0)))
+    () ()
+)
+
+; These bits are actually part of the PS register but are accessed more
+; often than the entire register, so define them directly. We can assemble
+; the PS register from its components when necessary.
+
+(dsh h-nbit  "negative         bit" ()           (register BI))
+(dsh h-zbit  "zero             bit" ()           (register BI))
+(dsh h-vbit  "overflow         bit" ()           (register BI))
+(dsh h-cbit  "carry            bit" ()           (register BI))
+(dsh h-ibit  "interrupt enable bit" ()           (register BI))
+(define-hardware
+  (name h-sbit)
+  (comment "stack bit")
+  (type register BI)
+  (get () (c-call BI "@cpu@_h_sbit_get_handler"))
+  (set (newval) (c-call VOID "@cpu@_h_sbit_set_handler" newval))
+)
+(dsh h-tbit  "trace trap       bit" ()           (register BI))
+(dsh h-d0bit "division 0       bit" ()           (register BI))
+(dsh h-d1bit "division 1       bit" ()           (register BI))
+
+; These represent sub-registers within the program status register
+
+(define-hardware
+  (name h-ccr)
+  (comment "condition code bits")
+  (type register UQI)
+  (get () (c-call UQI "@cpu@_h_ccr_get_handler"))
+  (set (newval) (c-call VOID "@cpu@_h_ccr_set_handler" newval))
+)
+(define-hardware
+  (name h-scr)
+  (comment "system condition bits")
+  (type register UQI)
+  (get () (c-call UQI "@cpu@_h_scr_get_handler"))
+  (set (newval) (c-call VOID "@cpu@_h_scr_set_handler" newval))
+)
+(define-hardware
+  (name h-ilm)
+  (comment "interrupt level mask")
+  (type register UQI)
+  (get () (c-call UQI "@cpu@_h_ilm_get_handler"))
+  (set (newval) (c-call VOID "@cpu@_h_ilm_set_handler" newval))
+)
+\f
+; Instruction Operands.
+; These entries provide a layer between the assembler and the raw hardware
+; description, and are used to refer to hardware elements in the semantic
+; code.  Usually there's a bit of over-specification, but in more complicated
+; instruction sets there isn't.
+
+; FR30 specific operand attributes:
+
+(define-attr
+  (for operand)
+  (type boolean)
+  (name HASH-PREFIX)
+  (comment "immediates have an optional '#' prefix")
+)
+
+; ??? Convention says this should be o-sr, but then the insn definitions
+; should refer to o-sr which is clumsy.  The "o-" could be implicit, but
+; then it should be implicit for all the symbols here, but then there would
+; be confusion between (f-)simm8 and (h-)simm8.
+; So for now the rule is exactly as it appears here.
+
+(dnop Ri      "destination register"         ()            h-gr   f-Ri)
+(dnop Rj      "source register"              ()            h-gr   f-Rj)
+(dnop Ric     "target register coproc insn"  ()            h-gr   f-Ric)
+(dnop Rjc     "source register coproc insn"  ()            h-gr   f-Rjc)
+(dnop CRi     "coprocessor register"         ()            h-cr   f-CRi)
+(dnop CRj     "coprocessor register"         ()            h-cr   f-CRj)
+(dnop Rs1     "dedicated register"           ()            h-dr   f-Rs1)
+(dnop Rs2     "dedicated register"           ()            h-dr   f-Rs2)
+(dnop R13     "General Register 13"          ()            h-r13  f-nil)
+(dnop R14     "General Register 14"          ()            h-r14  f-nil)
+(dnop R15     "General Register 15"          ()            h-r15  f-nil)
+(dnop ps      "Program Status register"      ()            h-ps   f-nil)
+(dnop u4      "4  bit unsigned immediate"    (HASH-PREFIX) h-uint f-u4)
+(dnop u4c     "4  bit unsigned immediate"    (HASH-PREFIX) h-uint f-u4c)
+(dnop u8      "8  bit unsigned immediate"    (HASH-PREFIX) h-uint f-u8)
+(dnop i8      "8  bit unsigned immediate"    (HASH-PREFIX) h-uint f-i8)
+(dnop udisp6  "6  bit unsigned immediate"    (HASH-PREFIX) h-uint f-udisp6)
+(dnop disp8   "8  bit signed   immediate"    (HASH-PREFIX) h-sint f-disp8)
+(dnop disp9   "9  bit signed   immediate"    (HASH-PREFIX) h-sint f-disp9)
+(dnop disp10  "10 bit signed   immediate"    (HASH-PREFIX) h-sint f-disp10)
+
+(dnop s10     "10 bit signed   immediate"    (HASH-PREFIX) h-sint f-s10)
+(dnop u10     "10 bit unsigned immediate"    (HASH-PREFIX) h-uint f-u10)
+(dnop i32     "32 bit immediate"             (HASH-PREFIX) h-uint f-i32)
+
+(define-operand
+  (name m4)
+  (comment "4  bit negative immediate")
+  (attrs HASH-PREFIX)
+  (type h-sint)
+  (index f-m4)
+  (handlers (print "m4"))
+)
+
+(define-operand
+  (name i20)
+  (comment "20 bit immediate")
+  (attrs HASH-PREFIX)
+  (type h-uint)
+  (index f-i20)
+)
+
+(dnop dir8    "8  bit direct address"        ()  h-uint f-dir8)
+(dnop dir9    "9  bit direct address"        ()  h-uint f-dir9)
+(dnop dir10   "10 bit direct address"        ()  h-uint f-dir10)
+
+(dnop label9  "9  bit pc relative address"   ()  h-iaddr f-rel9)
+(dnop label12 "12 bit pc relative address"   ()  h-iaddr f-rel12)
+
+(define-operand 
+  (name    reglist_low_ld)
+  (comment "8 bit low register mask for ldm")
+  (attrs)
+  (type    h-uint)
+  (index   f-reglist_low_ld)
+  (handlers (parse "low_register_list_ld")
+           (print "low_register_list_ld"))
+)
+
+(define-operand 
+  (name    reglist_hi_ld)
+  (comment "8 bit high register mask for ldm")
+  (attrs)
+  (type    h-uint)
+  (index   f-reglist_hi_ld)
+  (handlers (parse "hi_register_list_ld")
+           (print "hi_register_list_ld"))
+)
+
+(define-operand 
+  (name    reglist_low_st)
+  (comment "8 bit low register mask for stm")
+  (attrs)
+  (type    h-uint)
+  (index   f-reglist_low_st)
+  (handlers (parse "low_register_list_st")
+           (print "low_register_list_st"))
+)
+
+(define-operand 
+  (name    reglist_hi_st)
+  (comment "8 bit high register mask for stm")
+  (attrs)
+  (type    h-uint)
+  (index   f-reglist_hi_st)
+  (handlers (parse "hi_register_list_st")
+           (print "hi_register_list_st"))
+)
+
+(dnop cc   "condition codes"  ()            h-uint f-cc)
+(dnop ccc  "coprocessor calc" (HASH-PREFIX) h-uint f-ccc)
+
+(dnop nbit  "negative   bit"       (SEM-ONLY) h-nbit  f-nil)
+(dnop vbit  "overflow   bit"       (SEM-ONLY) h-vbit  f-nil)
+(dnop zbit  "zero       bit"       (SEM-ONLY) h-zbit  f-nil)
+(dnop cbit  "carry      bit"       (SEM-ONLY) h-cbit  f-nil)
+(dnop ibit  "interrupt  bit"       (SEM-ONLY) h-ibit  f-nil)
+(dnop sbit  "stack      bit"       (SEM-ONLY) h-sbit  f-nil)
+(dnop tbit  "trace trap bit"       (SEM-ONLY) h-tbit  f-nil)
+(dnop d0bit "division 0 bit"       (SEM-ONLY) h-d0bit f-nil)
+(dnop d1bit "division 1 bit"       (SEM-ONLY) h-d1bit f-nil)
+
+(dnop ccr  "condition code bits"   (SEM-ONLY) h-ccr  f-nil)
+(dnop scr  "system condition bits" (SEM-ONLY) h-scr  f-nil)
+(dnop ilm  "interrupt level mask"  (SEM-ONLY) h-ilm  f-nil)
+\f
+; Instruction definitions.
+;
+; Notes:
+; - dni is short for "define-normal-instruction"
+
+; FR30 specific insn attributes:
+
+(define-attr
+  (for insn)
+  (type boolean)
+  (name NOT-IN-DELAY-SLOT)
+  (comment "insn can't go in delay slot")
+)
+
+; Sets zbit and nbit based on the value of x
+;
+(define-pmacro (set-z-and-n x)
+  (sequence ()
+           (set zbit (eq x (const 0)))
+           (set nbit (lt x (const 0))))
+)
+
+; Binary integer instruction which sets status bits
+;
+(define-pmacro (binary-int-op name insn comment opc1 opc2 op arg1 arg2)
+  (dni name
+       (.str insn " " comment)
+       ()
+       (.str insn " $" arg1 ",$" arg2)
+       (+ opc1 opc2 arg1 arg2)
+       (sequence ()
+                (set vbit ((.sym op -oflag) arg2 arg1 (const 0)))
+                (set cbit ((.sym op -cflag) arg2 arg1 (const 0)))
+                (set arg2 (op arg2 arg1))
+                (set-z-and-n arg2))
+       ()
+  )
+)
+
+; Binary integer instruction which does *not* set status bits
+;
+(define-pmacro (binary-int-op-n name insn comment opc1 opc2 op arg1 arg2)
+  (dni name
+       (.str insn " " comment)
+       ()
+       (.str insn " $" arg1 ",$" arg2)
+       (+ opc1 opc2 arg1 arg2)
+       (set arg2 (op arg2 arg1))
+       ()
+  )
+)
+
+; Binary integer instruction with carry which sets status bits
+;
+(define-pmacro (binary-int-op-c name insn comment opc1 opc2 op arg1 arg2)
+  (dni name
+       (.str insn " " comment)
+       ()
+       (.str insn " $" arg1 ",$" arg2)
+       (+ opc1 opc2 arg1 arg2)
+       (sequence ((WI tmp))
+                (set tmp  ((.sym op c)      arg2 arg1 cbit))
+                (set vbit ((.sym op -oflag) arg2 arg1 cbit))
+                (set cbit ((.sym op -cflag) arg2 arg1 cbit))
+                (set arg2 tmp)
+                (set-z-and-n arg2))
+       ()
+  )
+)
+
+(binary-int-op   add   add   "reg/reg"   OP1_A OP2_6 add Rj Ri)
+(binary-int-op   addi  add   "immed/reg" OP1_A OP2_4 add u4 Ri)
+(binary-int-op   add2  add2  "immed/reg" OP1_A OP2_5 add m4 Ri)
+(binary-int-op-c addc  addc  "reg/reg"   OP1_A OP2_7 add Rj Ri)
+(binary-int-op-n addn  addn  "reg/reg"   OP1_A OP2_2 add Rj Ri)
+(binary-int-op-n addni addn  "immed/reg" OP1_A OP2_0 add u4 Ri)
+(binary-int-op-n addn2 addn2 "immed/reg" OP1_A OP2_1 add m4 Ri)
+
+(binary-int-op   sub   sub   "reg/reg"   OP1_A OP2_C sub Rj Ri)
+(binary-int-op-c subc  subc  "reg/reg"   OP1_A OP2_D sub Rj Ri)
+(binary-int-op-n subn  subn  "reg/reg"   OP1_A OP2_E sub Rj Ri)
+
+; Integer compare instruction
+;
+(define-pmacro (int-cmp name insn comment opc1 opc2 arg1 arg2)
+  (dni name
+       (.str insn " " comment)
+       ()
+       (.str insn " $" arg1 ",$" arg2)
+       (+ opc1 opc2 arg1 arg2)
+       (sequence ((WI tmp1))
+                (set vbit (sub-oflag arg2 arg1 (const 0)))
+                (set cbit (sub-cflag arg2 arg1 (const 0)))
+                (set tmp1 (sub       arg2 arg1))
+                (set-z-and-n tmp1)
+       )
+       ()
+  )
+)
+
+(int-cmp cmp  cmp  "reg/reg"   OP1_A OP2_A Rj Ri)
+(int-cmp cmpi cmp  "immed/reg" OP1_A OP2_8 u4 Ri)
+(int-cmp cmp2 cmp2 "immed/reg" OP1_A OP2_9 m4 Ri)
+
+; Binary logical instruction
+;
+(define-pmacro (binary-logical-op name insn comment opc1 opc2 op arg1 arg2)
+  (dni name
+       (.str insn " " comment)
+       ()
+       (.str insn " $" arg1 ",$" arg2)
+       (+ opc1 opc2 arg1 arg2)
+       (sequence ()
+                (set arg2 (op arg2 arg1))
+                (set-z-and-n arg2))
+       ()
+  )
+)
+
+(binary-logical-op and and "reg/reg" OP1_8 OP2_2 and Rj Ri)
+(binary-logical-op or  or  "reg/reg" OP1_9 OP2_2 or  Rj Ri)
+(binary-logical-op eor eor "reg/reg" OP1_9 OP2_A xor Rj Ri)
+
+(define-pmacro (les-units model) ; les: load-exec-store
+  (model (unit u-exec) (unit u-load) (unit u-store))
+)
+
+; Binary logical instruction to memory
+;
+(define-pmacro (binary-logical-op-m name insn comment opc1 opc2 mode op arg1 arg2)
+  (dni name
+       (.str insn " " comment)
+       (NOT-IN-DELAY-SLOT)
+       (.str insn " $" arg1 ",@$" arg2)
+       (+ opc1 opc2 arg1 arg2)
+       (sequence ((mode tmp))
+                (set mode tmp (op mode (mem mode arg2) arg1))
+                (set-z-and-n tmp)
+                (set mode (mem mode arg2) tmp))
+       ((les-units fr30-1))
+  )
+)
+
+(binary-logical-op-m andm and  "reg/mem" OP1_8 OP2_4 WI and Rj Ri)
+(binary-logical-op-m andh andh "reg/mem" OP1_8 OP2_5 HI and Rj Ri)
+(binary-logical-op-m andb andb "reg/mem" OP1_8 OP2_6 QI and Rj Ri)
+(binary-logical-op-m orm  or   "reg/mem" OP1_9 OP2_4 WI or  Rj Ri)
+(binary-logical-op-m orh  orh  "reg/mem" OP1_9 OP2_5 HI or  Rj Ri)
+(binary-logical-op-m orb  orb  "reg/mem" OP1_9 OP2_6 QI or  Rj Ri)
+(binary-logical-op-m eorm eor  "reg/mem" OP1_9 OP2_C WI xor Rj Ri)
+(binary-logical-op-m eorh eorh "reg/mem" OP1_9 OP2_D HI xor Rj Ri)
+(binary-logical-op-m eorb eorb "reg/mem" OP1_9 OP2_E QI xor Rj Ri)
+
+; Binary logical instruction to low half of byte in memory
+;
+(dni bandl
+     "bandl #u4,@Ri"
+     (NOT-IN-DELAY-SLOT)
+     "bandl $u4,@$Ri"
+     (+ OP1_8 OP2_0 u4 Ri)
+     (set QI (mem QI Ri)
+          (and QI
+                (or  QI u4 (const #xf0))
+                (mem QI Ri)))
+     ((les-units fr30-1))
+)
+
+(dni borl
+     "borl #u4,@Ri"
+     (NOT-IN-DELAY-SLOT)
+     "borl $u4,@$Ri"
+     (+ OP1_9 OP2_0 u4 Ri)
+     (set QI (mem QI Ri) (or QI u4 (mem QI Ri)))
+     ((les-units fr30-1))
+)
+
+(dni beorl
+     "beorl #u4,@Ri"
+     (NOT-IN-DELAY-SLOT)
+     "beorl $u4,@$Ri"
+     (+ OP1_9 OP2_8 u4 Ri)
+     (set QI (mem QI Ri) (xor QI u4 (mem QI Ri)))
+     ((les-units fr30-1))
+)
+
+; Binary logical instruction to high half of byte in memory
+;
+(dni bandh
+     "bandh #u4,@Ri"
+     (NOT-IN-DELAY-SLOT)
+     "bandh $u4,@$Ri"
+     (+ OP1_8 OP2_1 u4 Ri)
+     (set QI (mem QI Ri)
+          (and QI
+                (or QI (sll QI u4 (const 4)) (const #x0f))
+                (mem QI Ri)))
+     ((les-units fr30-1))
+)
+
+(define-pmacro (binary-or-op-mh name insn opc1 opc2 op arg1 arg2)
+  (dni name
+       (.str name " #" arg1 ",@" args)
+       (NOT-IN-DELAY-SLOT)
+       (.str name " $" arg1 ",@$" arg2)
+       (+ opc1 opc2 arg1 arg2)
+       (set QI (mem QI arg2)
+            (insn QI
+                  (sll QI arg1 (const 4))
+                  (mem QI arg2)))
+       ((les-units fr30-1))
+  )
+)
+
+(binary-or-op-mh borh  or  OP1_9 OP2_1 or  u4 Ri)
+(binary-or-op-mh beorh xor OP1_9 OP2_9 xor u4 Ri)
+
+(dni btstl
+     "btstl #u4,@Ri"
+     (NOT-IN-DELAY-SLOT)
+     "btstl $u4,@$Ri"
+     (+ OP1_8 OP2_8 u4 Ri)
+     (sequence ((QI tmp))
+              (set tmp (and QI u4 (mem QI Ri)))
+              (set zbit (eq tmp (const 0)))
+              (set nbit (const 0)))
+     ((fr30-1 (unit u-load) (unit u-exec (cycles 2))))
+)
+
+(dni btsth
+     "btsth #u4,@Ri"
+     (NOT-IN-DELAY-SLOT)
+     "btsth $u4,@$Ri"
+     (+ OP1_8 OP2_9 u4 Ri)
+     (sequence ((QI tmp))
+              (set tmp (and QI (sll QI u4 (const 4)) (mem QI Ri)))
+              (set zbit (eq tmp (const 0)))
+              (set nbit (lt tmp (const 0))))
+     ((fr30-1 (unit u-load) (unit u-exec (cycles 2))))
+)
+
+(dni mul
+     "mul Rj,Ri"
+     (NOT-IN-DELAY-SLOT)
+     "mul $Rj,$Ri"
+     (+ OP1_A OP2_F Rj Ri)
+     (sequence ((DI tmp))
+              (set tmp (mul DI (ext DI Rj) (ext DI Ri)))
+              (set (reg h-dr 5) (trunc WI tmp))
+              (set (reg h-dr 4) (trunc WI (srl tmp (const 32))))
+              (set nbit (lt (reg h-dr 5) (const 0)))
+              (set zbit (eq tmp (const DI 0)))
+              (set vbit (orif
+                         (gt  tmp (const DI #x7fffffff))
+                         (lt  tmp (neg (const DI #x80000000))))))
+     ((fr30-1 (unit u-exec (cycles 5))))
+)
+
+(dni mulu
+     "mulu Rj,Ri"
+     (NOT-IN-DELAY-SLOT)
+     "mulu $Rj,$Ri"
+     (+ OP1_A OP2_B Rj Ri)
+     (sequence ((DI tmp))
+              (set tmp (mul DI (zext DI Rj) (zext DI Ri)))
+              (set (reg h-dr 5) (trunc WI tmp))
+              (set (reg h-dr 4) (trunc WI (srl tmp (const 32))))
+              (set nbit (lt (reg h-dr 4) (const 0)))
+              (set zbit (eq (reg h-dr 5) (const 0)))
+              (set vbit (ne (reg h-dr 4) (const 0))))
+     ((fr30-1 (unit u-exec (cycles 5))))
+)
+
+(dni mulh
+     "mulh Rj,Ri"
+     (NOT-IN-DELAY-SLOT)
+     "mulh $Rj,$Ri"
+     (+ OP1_B OP2_F Rj Ri)
+     (sequence ()
+              (set (reg h-dr 5) (mul (trunc HI Rj) (trunc HI Ri)))
+              (set nbit (lt (reg h-dr 5) (const 0)))
+              (set zbit (ge (reg h-dr 5) (const 0))))
+     ((fr30-1 (unit u-exec (cycles 3))))
+)
+
+(dni muluh
+     "muluh Rj,Ri"
+     (NOT-IN-DELAY-SLOT)
+     "muluh $Rj,$Ri"
+     (+ OP1_B OP2_B Rj Ri)
+     (sequence ()
+              (set (reg h-dr 5) (mul (and Rj (const #xffff))
+                                     (and Ri (const #xffff))))
+              (set nbit (lt (reg h-dr 5) (const 0)))
+              (set zbit (ge (reg h-dr 5) (const 0))))
+     ((fr30-1 (unit u-exec (cycles 3))))
+)
+
+(dni div0s
+     "div0s Ri"
+     ()
+     "div0s $Ri"
+     (+ OP1_9 OP2_7 OP3_4 Ri)
+     (sequence ()
+              (set d0bit (lt (reg h-dr 5) (const 0)))
+              (set d1bit (xor d0bit (lt Ri (const 0))))
+              (if (ne d0bit (const 0))
+                  (set (reg h-dr 4) (const #xffffffff))
+                  (set (reg h-dr 4) (const 0))))
+     ()
+)
+
+(dni div0u
+     "div0u Ri"
+     ()
+     "div0u $Ri"
+     (+ OP1_9 OP2_7 OP3_5 Ri)
+     (sequence ()
+              (set d0bit (const 0))
+              (set d1bit (const 0))
+              (set (reg h-dr 4) (const 0)))
+     ()
+)
+
+(dni div1
+     "div1 Ri"
+     ()
+     "div1 $Ri"
+     (+ OP1_9 OP2_7 OP3_6 Ri)
+     (sequence ((WI tmp))
+              (set (reg h-dr 4) (sll (reg h-dr 4) (const 1)))
+              (if (lt (reg h-dr 5) (const 0))
+                  (set (reg h-dr 4) (add (reg h-dr 4) (const 1))))
+              (set (reg h-dr 5) (sll (reg h-dr 5) (const 1)))
+              (if (eq d1bit (const 1))
+                  (sequence ()
+                            (set tmp  (add       (reg h-dr 4) Ri))
+                            (set cbit (add-cflag (reg h-dr 4) Ri (const 0))))
+                  (sequence ()
+                            (set tmp  (sub       (reg h-dr 4) Ri))
+                            (set cbit (sub-cflag (reg h-dr 4) Ri (const 0)))))
+              (if (not (xor (xor d0bit d1bit) cbit))
+                  (sequence ()
+                            (set (reg h-dr 4) tmp)
+                            (set (reg h-dr 5) (or (reg h-dr 5) (const 1)))))
+              (set zbit (eq (reg h-dr 4) (const 0))))
+     ()
+)
+
+(dni div2
+     "div2 Ri"
+     ()
+     "div2 $Ri"
+     (+ OP1_9 OP2_7 OP3_7 Ri)
+     (sequence ((WI tmp))
+              (if (eq d1bit (const 1))
+                  (sequence ()
+                            (set tmp  (add       (reg h-dr 4) Ri))
+                            (set cbit (add-cflag (reg h-dr 4) Ri (const 0))))
+                  (sequence ()
+                            (set tmp  (sub       (reg h-dr 4) Ri))
+                            (set cbit (sub-cflag (reg h-dr 4) Ri (const 0)))))
+              (if (eq tmp (const 0))
+                  (sequence ()
+                            (set zbit (const 1))
+                            (set (reg h-dr 4) (const 0)))
+                  (set zbit (const 0))))
+     ()
+)
+
+(dni div3
+     "div3"
+     ()
+     "div3"
+     (+ OP1_9 OP2_F OP3_6 OP4_0)
+     (if (eq zbit (const 1))
+        (set (reg h-dr 5) (add (reg h-dr 5) (const 1))))
+     ()
+)
+
+(dni div4s
+     "div4s"
+     ()
+     "div4s"
+     (+ OP1_9 OP2_F OP3_7 OP4_0)
+     (if (eq d1bit (const 1))
+        (set (reg h-dr 5) (neg (reg h-dr 5))))
+     ()
+)
+
+(define-pmacro (leftshift-op name insn opc1 opc2 arg1 arg2 shift-expr)
+  (dni name
+       (.str insn " " arg1 "," arg2)
+       ()
+       (.str insn " $" arg1 ",$" arg2)
+       (+ opc1 opc2 arg1 arg2)
+       (sequence ((WI shift))
+                (set shift shift-expr)
+                (if (ne shift (const 0))
+                    (sequence ()
+                              (set cbit (ne (and arg2
+                                                 (sll (const 1)
+                                                      (sub (const 32) shift)))
+                                            (const 0)))
+                              (set arg2 (sll arg2 shift)))
+                    (set cbit (const 0)))
+                (set nbit (lt arg2 (const 0)))
+                (set zbit (eq arg2 (const 0))))
+       ()
+  )
+)
+(leftshift-op  lsl   lsl   OP1_B OP2_6 Rj Ri (and Rj (const #x1f)))
+(leftshift-op  lsli  lsl   OP1_B OP2_4 u4 Ri u4)
+(leftshift-op  lsl2  lsl2  OP1_B OP2_5 u4 Ri (add u4 (const #x10)))
+
+(define-pmacro (rightshift-op name insn opc1 opc2 op arg1 arg2 shift-expr)
+  (dni name
+       (.str insn " " arg1 "," arg2)
+       ()
+       (.str insn " $" arg1 ",$" arg2)
+       (+ opc1 opc2 arg1 arg2)
+       (sequence ((WI shift))
+                (set shift shift-expr)
+                (if (ne shift (const 0))
+                    (sequence ()
+                              (set cbit (ne (and arg2
+                                                 (sll (const 1)
+                                                      (sub shift (const 1))))
+                                            (const 0)))
+                              (set arg2 (op arg2 shift)))
+                    (set cbit (const 0)))
+                (set nbit (lt arg2 (const 0)))
+                (set zbit (eq arg2 (const 0))))
+       ()
+  )
+)
+(rightshift-op lsr  lsr  OP1_B OP2_2 srl Rj Ri (and Rj (const #x1f)))
+(rightshift-op lsri lsr  OP1_B OP2_0 srl u4 Ri u4)
+(rightshift-op lsr2 lsr2 OP1_B OP2_1 srl u4 Ri (add u4 (const #x10)))
+(rightshift-op asr  asr  OP1_B OP2_A sra Rj Ri (and Rj (const #x1f)))
+(rightshift-op asri asr  OP1_B OP2_8 sra u4 Ri u4)
+(rightshift-op asr2 asr2 OP1_B OP2_9 sra u4 Ri (add u4 (const #x10)))
+
+(dni ldi8
+     "load 8 bit unsigned immediate"
+     ()
+     "ldi:8 $i8,$Ri"
+     (+ OP1_C i8 Ri)
+     (set Ri i8)
+     ()
+)
+
+; Typing ldi:8 in in emacs is a pain.
+(dnmi ldi8m "ldi:8 without the colon"
+      (NO-DIS)
+      "ldi8 $i8,$Ri"
+      (emit ldi8 i8 Ri)
+)
+
+(dni ldi20
+     "load 20 bit unsigned immediate"
+     (NOT-IN-DELAY-SLOT)
+     "ldi:20 $i20,$Ri"
+     (+ OP1_9 OP2_B Ri i20)
+     (set Ri i20)
+     ((fr30-1 (unit u-exec (cycles 2))))
+)
+
+; Typing ldi:20 in in emacs is a pain.
+(dnmi ldi20m "ldi:20 without the colon"
+      (NO-DIS)
+      "ldi20 $i20,$Ri"
+      (emit ldi20 i20 Ri)
+)
+
+(dni ldi32
+     "load 32 bit immediate"
+     (NOT-IN-DELAY-SLOT)
+     "ldi:32 $i32,$Ri"
+     (+ OP1_9 OP2_F OP3_8 Ri i32)
+     (set Ri i32)
+     ((fr30-1 (unit u-exec (cycles 3))))
+)
+
+; Typing ldi:32 in in emacs is a pain.
+(dnmi ldi32m "ldi:32 without the colon"
+      (NO-DIS)
+      "ldi32 $i32,$Ri"
+      (emit ldi32 i32 Ri)
+)
+
+(define-pmacro (basic-ld name insn opc1 opc2 mode arg1 arg2)
+  (dni name
+       (.str name " @" arg1 "," arg2)
+       ()
+       (.str name " @$" arg1 ",$" arg2)
+       (+ opc1 opc2 arg1 arg2)
+       (set arg2 (mem mode arg1))
+       ((fr30-1 (unit u-load)))
+  )
+)
+
+(basic-ld ld   ld   OP1_0 OP2_4 WI  Rj Ri)
+(basic-ld lduh lduh OP1_0 OP2_5 UHI Rj Ri)
+(basic-ld ldub ldub OP1_0 OP2_6 UQI Rj Ri)
+
+(define-pmacro (r13base-ld name insn opc1 opc2 mode arg1 arg2)
+  (dni name
+       (.str insn " @(R13," arg1 ")," arg2)
+       ()
+       (.str insn " @($R13,$" arg1 "),$" arg2)
+       (+ opc1 opc2 arg1 arg2)
+       (set arg2 (mem mode (add arg1 (reg h-gr 13))))
+       ((fr30-1 (unit u-load)))
+  )
+)
+
+(r13base-ld ldr13   ld   OP1_0 OP2_0 WI  Rj Ri)
+(r13base-ld ldr13uh lduh OP1_0 OP2_1 UHI Rj Ri)
+(r13base-ld ldr13ub ldub OP1_0 OP2_2 UQI Rj Ri)
+
+(define-pmacro (r14base-ld name insn opc1 mode arg1 arg2)
+  (dni name
+       (.str insn " @(R14," arg1 ")," arg2)
+       ()
+       (.str insn " @($R14,$" arg1 "),$" arg2)
+       (+ opc1 arg1 arg2)
+       (set arg2 (mem mode (add arg1 (reg h-gr 14))))
+       ((fr30-1 (unit u-load)))
+  )
+)
+
+(r14base-ld ldr14   ld   OP1_2 WI  disp10 Ri)
+(r14base-ld ldr14uh lduh OP1_4 UHI disp9  Ri)
+(r14base-ld ldr14ub ldub OP1_6 UQI disp8  Ri)
+
+(dni ldr15
+     "ld @(R15,udisp6),Ri mem/reg"
+     ()
+     "ld @($R15,$udisp6),$Ri"
+     (+ OP1_0 OP2_3 udisp6 Ri)
+     (set Ri (mem WI (add udisp6 (reg h-gr 15))))
+     ((fr30-1 (unit u-load)))
+)
+
+(dni ldr15gr
+     "ld @R15+,Ri"
+     ()
+     "ld @$R15+,$Ri"
+     (+ OP1_0 OP2_7 OP3_0 Ri)
+     (sequence ()
+              (set Ri (mem WI (reg h-gr 15)))
+              (if (ne (ifield f-Ri) (const 15))
+                  (set (reg h-gr 15) (add (reg h-gr 15) (const 4)))))
+     ((fr30-1 (unit u-load)))
+)
+
+; This insn loads a value from where r15 points into the target register and
+; then increments r15. If the target register is also r15, then the post
+; increment is not performed.
+;
+(dni ldr15dr
+     "ld @R15+,Rs2"
+     ()
+     "ld @$R15+,$Rs2"
+     (+ OP1_0 OP2_7 OP3_8 Rs2)
+; This seems more straight forward, but doesn't work due to a problem in
+; cgen. We're trying to not increment r15 if it is the target register.
+;     (sequence ()
+;             (set Rs2 (mem WI (reg h-gr 15)))
+;             (if (not (or (and (eq (ifield f-Rs2) (const 2))
+;                               (eq sbit (const 0)))
+;                          (and (eq (ifield f-Rs2) (const 3))
+;                               (eq sbit (const 1)))))
+;                 (set (reg h-gr 15) (add (reg h-gr 15) (const 4)))
+;             )
+;     )
+     (sequence ((WI tmp))
+              (set tmp (mem WI (reg h-gr 15))) ; save in case target is r15
+              (set (reg h-gr 15) (add (reg h-gr 15) (const 4)))
+              (set Rs2 tmp))
+     ((fr30-1 (unit u-load)))
+)
+
+(dni ldr15ps
+     "ld @R15+,ps mem/reg"
+     (NOT-IN-DELAY-SLOT)
+     "ld @$R15+,$ps"
+     (+ OP1_0 OP2_7 OP3_9 OP4_0)
+     (sequence ()
+              (set ps (mem WI (reg h-gr 15)))
+              (set (reg h-gr 15) (add (reg h-gr 15) (const 4))))
+     ((fr30-1 (unit u-load)))
+)
+
+(define-pmacro (basic-st name insn opc1 opc2 mode arg1 arg2)
+  (dni name
+       (.str name " " arg1 ",@" arg2)
+       ()
+       (.str name " $" arg1 ",@$" arg2)
+       (+ opc1 opc2 arg1 arg2)
+       (set (mem mode arg2) arg1)
+       ((fr30-1 (unit u-store)))
+  )
+)
+
+(basic-st st  st  OP1_1 OP2_4 WI Ri Rj)
+(basic-st sth sth OP1_1 OP2_5 HI Ri Rj)
+(basic-st stb stb OP1_1 OP2_6 QI Ri Rj)
+
+(define-pmacro (r13base-st name insn opc1 opc2 mode arg1 arg2)
+  (dni name
+       (.str insn " " arg1 ",@(R13," arg2 ")")
+       ()
+       (.str insn " $" arg1 ",@($R13,$" arg2 ")")
+       (+ opc1 opc2 arg1 arg2)
+       (set (mem mode (add arg2 (reg h-gr 13))) arg1)
+       ((fr30-1 (unit u-store)))
+  )
+)
+
+(r13base-st str13  st  OP1_1 OP2_0 WI Ri Rj)
+(r13base-st str13h sth OP1_1 OP2_1 HI Ri Rj)
+(r13base-st str13b stb OP1_1 OP2_2 QI Ri Rj)
+
+(define-pmacro (r14base-st name insn opc1 mode arg1 arg2)
+  (dni name
+       (.str insn " " arg1 ",@(R14," arg2 ")")
+       ()
+       (.str insn " $" arg1 ",@($R14,$" arg2 ")")
+       (+ opc1 arg1 arg2)
+       (set (mem mode (add arg2 (reg h-gr 14))) arg1)
+       ((fr30-1 (unit u-store)))
+  )
+)
+
+(r14base-st str14  st  OP1_3 WI  Ri disp10)
+(r14base-st str14h sth OP1_5 HI  Ri disp9)
+(r14base-st str14b stb OP1_7 QI  Ri disp8)
+
+(dni str15
+     "st Ri,@(R15,udisp6) reg/mem"
+     ()
+     "st $Ri,@($R15,$udisp6)"
+     (+ OP1_1 OP2_3 udisp6 Ri)
+     (set (mem WI (add (reg h-gr 15) udisp6)) Ri)
+     ((fr30-1 (unit u-store)))
+)
+
+; These store insns predecrement r15 and then store the contents of the source
+; register where r15 then points. If the source register is also r15, then the
+; original value of r15 is stored.
+;
+(dni str15gr
+     "st Ri,@-R15 reg/mem"
+     ()
+     "st $Ri,@-$R15"
+     (+ OP1_1 OP2_7 OP3_0 Ri)
+     (sequence ((WI tmp))
+              (set tmp Ri) ; save in case it's r15
+              (set (reg h-gr 15) (sub (reg h-gr 15) (const 4)))
+              (set (mem WI (reg h-gr 15)) tmp))
+     ((fr30-1 (unit u-store)))
+)
+
+(dni str15dr
+     "st Rs,@-R15 reg/mem"
+     ()
+     "st $Rs2,@-$R15"
+     (+ OP1_1 OP2_7 OP3_8 Rs2)
+     (sequence ((WI tmp))
+              (set tmp Rs2) ; save in case it's r15
+              (set (reg h-gr 15) (sub (reg h-gr 15) (const 4)))
+              (set (mem WI (reg h-gr 15)) tmp))
+     ((fr30-1 (unit u-store)))
+)
+
+(dni str15ps
+     "st ps,@-R15 reg/mem"
+     ()
+     "st $ps,@-$R15"
+     (+ OP1_1 OP2_7 OP3_9 OP4_0)
+     (sequence ()
+              (set (reg h-gr 15) (sub (reg h-gr 15) (const 4)))
+              (set (mem WI (reg h-gr 15)) ps))
+     ((fr30-1 (unit u-store)))
+)
+
+(define-pmacro (mov2gr name opc1 opc2 arg1 arg2)
+  (dni name
+       (.str "mov " arg1 "," arg2)
+       ()
+       (.str "mov $" arg1 ",$" arg2)
+       (+ opc1 opc2 arg1 arg2)
+       (set arg2 arg1)
+       ()
+  )
+)
+
+(mov2gr mov   OP1_8 OP2_B Rj Ri)
+(mov2gr movdr OP1_B OP2_7 Rs1 Ri)
+
+(dni movps
+     "mov ps,Ri reg/reg"
+     ()
+     "mov $ps,$Ri"
+     (+ OP1_1 OP2_7 OP3_1 Ri)
+     (set Ri ps)
+     ()
+)
+
+(dni mov2dr
+     "mov Ri,Rs reg/reg"
+     ()
+     "mov $Ri,$Rs1"
+     (+ OP1_B OP2_3 Rs1 Ri)
+     (set Rs1 Ri)
+     ()
+)
+
+(dni mov2ps
+     "mov Ri,ps reg/reg"
+     ()
+     "mov $Ri,$ps"
+     (+ OP1_0 OP2_7 OP3_1 Ri)
+     (set ps Ri)
+     ()
+)
+
+(dni jmp
+     "jmp with no delay slot"
+     (NOT-IN-DELAY-SLOT)
+     "jmp @$Ri"
+     (+ OP1_9 OP2_7 OP3_0 Ri)
+     (set pc Ri)
+     ((fr30-1 (unit u-cti)))
+)
+
+(dni jmpd "jmp with delay slot"
+     (NOT-IN-DELAY-SLOT)
+     "jmp:d @$Ri"
+     (+ OP1_9 OP2_F OP3_0 Ri)
+     (delay (const 1)
+           (set pc Ri))
+     ((fr30-1 (unit u-cti)))
+)
+
+; These versions which use registers must appear before the other
+; versions which use relative addresses due to a problem in cgen
+; - DB.
+(dni callr
+     "call @Ri"
+     (NOT-IN-DELAY-SLOT)
+     "call @$Ri"
+     (+ OP1_9 OP2_7 OP3_1 Ri)
+     (sequence ()
+              (set (reg h-dr 1) (add pc (const 2)))
+              (set pc Ri))
+     ((fr30-1 (unit u-cti)))
+)
+(dni callrd
+     "call:d @Ri"
+     (NOT-IN-DELAY-SLOT)
+     "call:d @$Ri"
+     (+ OP1_9 OP2_F OP3_1 Ri)
+     (delay (const 1)
+           (sequence ()
+                     (set (reg h-dr 1) (add pc (const 4)))
+                     (set pc Ri)))
+     ((fr30-1 (unit u-cti)))
+)
+; end of reordered insns
+
+(dni call
+     "call relative to pc"
+     (NOT-IN-DELAY-SLOT)
+     "call $label12"
+     (+ OP1_D OP5_0 label12)
+     (sequence ()
+              (set (reg h-dr 1) (add pc (const 2)))
+              (set pc label12))
+     ((fr30-1 (unit u-cti)))
+)
+(dni calld
+     "call relative to pc"
+     (NOT-IN-DELAY-SLOT)
+     "call:d $label12"
+     (+ OP1_D OP5_1 label12)
+     (delay (const 1)
+           (sequence ()
+                     (set (reg h-dr 1) (add pc (const 4)))
+                     (set pc label12)))
+     ((fr30-1 (unit u-cti)))
+)
+
+(dni ret
+     "return from subroutine"
+     (NOT-IN-DELAY-SLOT)
+     "ret"
+     (+ OP1_9 OP2_7 OP3_2 OP4_0)
+     (set pc (reg h-dr 1))
+     ((fr30-1 (unit u-cti)))
+)
+
+(dni ret:d
+     "return from subroutine with delay slot"
+     (NOT-IN-DELAY-SLOT)
+     "ret:d"
+     (+ OP1_9 OP2_F OP3_2 OP4_0)
+     (delay (const 1)
+           (set pc (reg h-dr 1)))
+     ((fr30-1 (unit u-cti)))
+)
+
+(dni int
+     "interrupt"
+     (NOT-IN-DELAY-SLOT)
+     "int $u8"
+     (+ OP1_1 OP2_F u8)
+     (sequence ()
+              ; This is defered to fr30_int because for the breakpoint case
+              ; we want to change as little of the machine state as possible.
+              ; Push PS onto the system stack
+              ;(set  (reg h-dr 2) (sub (reg h-dr 2) (const 4)))
+              ;(set UWI (mem UWI (reg h-dr 2)) ps)
+              ; Push the return address onto the system stack
+              ;(set  (reg h-dr 2) (sub (reg h-dr 2) (const 4)))
+              ;(set UWI (mem UWI (reg h-dr 2)) (add pc (const 2)))
+              ; Set status bits
+              ;(set ibit (const 0))
+              ;(set sbit (const 0))
+
+              ; We still should indicate what is modified by this insn.
+              (clobber (reg h-dr 2))
+              (clobber ibit)
+              (clobber sbit)
+              ; ??? (clobber memory)?
+
+              ; fr30_int handles operating vs user mode
+              (set WI pc (c-call WI "fr30_int" pc u8))
+     )
+     ; This is more properly a cti, but branch stall calculation is different.
+     ((fr30-1 (unit u-exec (cycles 6))))
+)
+
+(dni inte
+     "interrupt for emulator"
+     (NOT-IN-DELAY-SLOT)
+     "inte"
+     (+ OP1_9 OP2_F OP3_3 OP4_0)
+     (sequence ()
+              ; This is defered to fr30_inte because for the breakpoint case
+              ; we want to change as little of the machine state as possible.
+              ; Push PS onto the system stack
+              ;(set  (reg h-dr 2) (sub (reg h-dr 2) (const 4)))
+              ;(set UWI (mem UWI (reg h-dr 2)) ps)
+              ; Push the return address onto the system stack
+              ;(set  (reg h-dr 2) (sub (reg h-dr 2) (const 4)))
+              ;(set UWI (mem UWI (reg h-dr 2)) (add pc (const 2)))
+              ; Set status bits
+              ;(set ibit (const 0))
+              ;(set ilm  (const 4))
+
+              ; We still should indicate what is modified by this insn.
+              (clobber (reg h-dr 2))
+              (clobber ibit)
+              (clobber ilm)
+              ; ??? (clobber memory)?
+
+              ; fr30_int handles operating vs user mode
+              (set WI pc (c-call WI "fr30_inte" pc))
+     )
+     ; This is more properly a cti, but branch stall calculation is different.
+     ((fr30-1 (unit u-exec (cycles 6))))
+)
+
+(dni reti
+     "return from interrupt"
+     (NOT-IN-DELAY-SLOT)
+     "reti"
+     (+ OP1_9 OP2_7 OP3_3 OP4_0)
+     (if (eq sbit (const 0))
+        (sequence ()
+                  ; Pop the return address from the system stack
+                  (set UWI pc (mem UWI (reg h-dr 2)))
+                  (set  (reg h-dr 2) (add (reg h-dr 2) (const 4)))
+                  ; Pop PS from the system stack
+                  (set UWI ps (mem UWI (reg h-dr 2)))
+                  (set  (reg h-dr 2) (add (reg h-dr 2) (const 4)))
+         )
+        (sequence ()
+                  ; Pop the return address from the user stack
+                  (set UWI pc (mem UWI (reg h-dr 3)))
+                  (set  (reg h-dr 3) (add (reg h-dr 3) (const 4)))
+                  ; Pop PS from the user stack
+                  (set UWI ps (mem UWI (reg h-dr 3)))
+                  (set  (reg h-dr 3) (add (reg h-dr 3) (const 4)))
+         )
+     )    
+     ; This is more properly a cti, but branch stall calculation is different.
+     ((fr30-1 (unit u-exec (cycles 4))))
+)
+
+; Conditional branches with and without delay slots
+;
+(define-pmacro (cond-branch cc condition)
+  (begin
+    (dni (.sym b cc d)
+        (.str (.sym b cc :d) " label9")
+        (NOT-IN-DELAY-SLOT)
+        (.str (.sym b cc :d) " $label9")
+        (+ OP1_F (.sym CC_ cc) label9)
+        (delay (const 1)
+               (if condition (set pc label9)))
+        ((fr30-1 (unit u-cti)))
+    )
+    (dni (.sym b cc)
+        (.str (.sym b cc) " label9")
+        (NOT-IN-DELAY-SLOT)
+        (.str (.sym b cc) " $label9")
+        (+ OP1_E (.sym CC_ cc) label9)
+        (if condition (set pc label9))
+        ((fr30-1 (unit u-cti)))
+    )
+  )
+)
+
+(cond-branch ra (const BI 1))
+(cond-branch no (const BI 0))
+(cond-branch eq      zbit)
+(cond-branch ne (not zbit))
+(cond-branch c       cbit)
+(cond-branch nc (not cbit))
+(cond-branch n       nbit)
+(cond-branch p  (not nbit))
+(cond-branch v       vbit)
+(cond-branch nv (not vbit))
+(cond-branch lt      (xor vbit nbit))
+(cond-branch ge (not (xor vbit nbit)))
+(cond-branch le      (or (xor vbit nbit) zbit))
+(cond-branch gt (not (or (xor vbit nbit) zbit)))
+(cond-branch ls      (or cbit zbit))
+(cond-branch hi (not (or cbit zbit)))
+
+(define-pmacro (dir2r13 name insn opc1 opc2 mode arg1)
+  (dni name
+       (.str insn " @" arg1 ",R13")
+       ()
+       (.str insn " @$" arg1 ",$R13")
+       (+ opc1 opc2 arg1)
+       (set (reg h-gr 13) (mem mode arg1))
+       ((fr30-1 (unit u-load)))
+  )
+)
+
+(define-pmacro (dir2r13-postinc name insn opc1 opc2 mode arg1 incr)
+  (dni name
+       (.str insn " @" arg1 ",@R13+")
+       (NOT-IN-DELAY-SLOT)
+       (.str insn " @$" arg1 ",@$R13+")
+       (+ opc1 opc2 arg1)
+       (sequence ()
+                (set (mem mode (reg h-gr 13)) (mem mode arg1))
+                (set (reg h-gr 13) (add (reg h-gr 13) incr)))
+       ((fr30-1 (unit u-load) (unit u-store)))
+  )
+)
+
+(define-pmacro (r132dir name insn opc1 opc2 mode arg1)
+  (dni name
+       (.str insn " R13,@" arg1)
+       ()
+       (.str insn " $R13,@$" arg1)
+       (+ opc1 opc2 arg1)
+       (set (mem mode arg1) (reg h-gr 13))
+       ((fr30-1 (unit u-store)))
+  )
+)
+
+(define-pmacro (r13-postinc2dir name insn opc1 opc2 mode arg1 incr)
+  (dni name
+       (.str insn " @R13+,@" arg1)
+       (NOT-IN-DELAY-SLOT)
+       (.str insn " @$R13+,@$" arg1)
+       (+ opc1 opc2 arg1)
+       (sequence ()
+                (set (mem mode arg1) (mem mode (reg h-gr 13)))
+                (set (reg h-gr 13) (add (reg h-gr 13) incr)))
+       ((fr30-1 (unit u-load) (unit u-store)))
+  )
+)
+
+; These versions which move from reg to mem must appear before the other
+; versions which use immediate addresses due to a problem in cgen
+; - DB.
+(r132dir dmovr13  dmov  OP1_1 OP2_8 WI dir10)
+(r132dir dmovr13h dmovh OP1_1 OP2_9 HI dir9)
+(r132dir dmovr13b dmovb OP1_1 OP2_A QI dir8)
+
+(r13-postinc2dir dmovr13pi  dmov  OP1_1 OP2_C WI dir10 (const 4))
+(r13-postinc2dir dmovr13pih dmovh OP1_1 OP2_D HI dir9  (const 2))
+(r13-postinc2dir dmovr13pib dmovb OP1_1 OP2_E QI dir8  (const 1))
+
+(dni dmovr15pi
+     "dmov @R15+,@dir10"
+     (NOT-IN-DELAY-SLOT)
+     "dmov @$R15+,@$dir10"
+     (+ OP1_1 OP2_B dir10)
+     (sequence ()
+              (set (mem WI dir10) (mem WI (reg h-gr 15)))
+              (set (reg h-gr 15) (add (reg h-gr 15) (const 4))))
+     ((fr30-1 (unit u-load) (unit u-store)))
+)
+; End of reordered insns.
+
+(dir2r13 dmov2r13  dmov  OP1_0 OP2_8 WI dir10)
+(dir2r13 dmov2r13h dmovh OP1_0 OP2_9 HI dir9)
+(dir2r13 dmov2r13b dmovb OP1_0 OP2_A QI dir8)
+
+(dir2r13-postinc dmov2r13pi  dmov  OP1_0 OP2_C WI dir10 (const 4))
+(dir2r13-postinc dmov2r13pih dmovh OP1_0 OP2_D HI dir9  (const 2))
+(dir2r13-postinc dmov2r13pib dmovb OP1_0 OP2_E QI dir8  (const 1))
+
+(dni dmov2r15pd
+     "dmov @dir10,@-R15"
+     (NOT-IN-DELAY-SLOT)
+     "dmov @$dir10,@-$R15"
+     (+ OP1_0 OP2_B dir10)
+     (sequence ()
+              (set (reg h-gr 15) (sub (reg h-gr 15) (const 4)))
+              (set (mem WI (reg h-gr 15)) (mem WI dir10)))
+     ((fr30-1 (unit u-load) (unit u-store)))
+)
+
+; Leave these insns as stubs for now, except for the increment of $Ri
+;
+(dni ldres
+     "ldres @Ri+,#u4"
+     ()
+     "ldres @$Ri+,$u4"
+     (+ OP1_B OP2_C u4 Ri)
+     (set Ri (add Ri (const 4)))
+     ()
+)
+
+(dni stres
+     "stres #u4,@Ri+"
+     ()
+     "stres $u4,@$Ri+"
+     (+ OP1_B OP2_D u4 Ri)
+     (set Ri (add Ri (const 4)))
+     ()
+)
+
+; Leave the coprocessor insns as stubs for now.
+;
+(define-pmacro (cop-stub name insn opc1 opc2 opc3 arg1 arg2)
+  (dni name
+       (.str insn " u4c,ccc,CRj," arg1 "," arg2)
+       (NOT-IN-DELAY-SLOT)
+       (.str insn " $u4c,$ccc,$" arg1 ",$" arg2)
+       (+ opc1 opc2 opc3 u4c ccc arg1 arg2)
+       (nop) ; STUB
+       ()
+  )
+)
+
+(cop-stub copop copop OP1_9 OP2_F OP3_C CRj CRi)
+(cop-stub copld copld OP1_9 OP2_F OP3_D Rjc CRi)
+(cop-stub copst copst OP1_9 OP2_F OP3_E CRj Ric)
+(cop-stub copsv copsv OP1_9 OP2_F OP3_F CRj Ric)
+
+(dni nop
+     "nop"
+     ()
+     "nop"
+     (+ OP1_9 OP2_F OP3_A OP4_0)
+     (nop)
+     ()
+)
+
+(dni andccr
+     "andccr #u8"
+     ()
+     "andccr $u8"
+     (+ OP1_8 OP2_3 u8)
+     (set ccr (and ccr u8))
+     ()
+)
+
+(dni orccr
+     "orccr #u8"
+     ()
+     "orccr $u8"
+     (+ OP1_9 OP2_3 u8)
+     (set ccr (or ccr u8))
+     ()
+)
+
+(dni stilm
+     "stilm #u8"
+     ()
+     "stilm $u8"
+     (+ OP1_8 OP2_7 u8)
+     (set ilm (and u8 (const #x1f)))
+     ()
+)
+
+(dni addsp
+     "addsp #s10"
+     ()
+     "addsp $s10"
+     (+ OP1_A OP2_3 s10)
+     (set (reg h-gr 15) (add (reg h-gr 15) s10))
+     ()
+)
+
+(define-pmacro (ext-op name opc1 opc2 opc3 op mode mask)
+  (dni name
+       (.str name " Ri")
+       ()
+       (.str name " $Ri")
+       (+ opc1 opc2 opc3 Ri)
+       (set Ri (op WI (and mode Ri mask)))
+       ()
+  )
+)
+
+(ext-op extsb OP1_9 OP2_7 OP3_8 ext  QI  (const #xff))
+(ext-op extub OP1_9 OP2_7 OP3_9 zext UQI (const #xff))
+(ext-op extsh OP1_9 OP2_7 OP3_A ext  HI  (const #xffff))
+(ext-op extuh OP1_9 OP2_7 OP3_B zext UHI (const #xffff))
+
+(dni ldm0
+     "ldm0 (reglist_low_ld)"
+     (NOT-IN-DELAY-SLOT)
+     "ldm0 ($reglist_low_ld)"
+     (+ OP1_8 OP2_C reglist_low_ld)
+     (sequence ()
+              (if (and reglist_low_ld (const #x1))
+                  (sequence ()
+                            (set (reg h-gr 0) (mem WI (reg h-gr 15)))
+                            (set (reg h-gr 15) (add (reg h-gr 15) (const 4)))))
+              (if (and reglist_low_ld (const #x2))
+                  (sequence ()
+                            (set (reg h-gr 1) (mem WI (reg h-gr 15)))
+                            (set (reg h-gr 15) (add (reg h-gr 15) (const 4)))))
+              (if (and reglist_low_ld (const #x4))
+                  (sequence ()
+                            (set (reg h-gr 2) (mem WI (reg h-gr 15)))
+                            (set (reg h-gr 15) (add (reg h-gr 15) (const 4)))))
+              (if (and reglist_low_ld (const #x8))
+                  (sequence ()
+                            (set (reg h-gr 3) (mem WI (reg h-gr 15)))
+                            (set (reg h-gr 15) (add (reg h-gr 15) (const 4)))))
+              (if (and reglist_low_ld (const #x10))
+                  (sequence ()
+                            (set (reg h-gr 4) (mem WI (reg h-gr 15)))
+                            (set (reg h-gr 15) (add (reg h-gr 15) (const 4)))))
+              (if (and reglist_low_ld (const #x20))
+                  (sequence ()
+                            (set (reg h-gr 5) (mem WI (reg h-gr 15)))
+                            (set (reg h-gr 15) (add (reg h-gr 15) (const 4)))))
+              (if (and reglist_low_ld (const #x40))
+                  (sequence ()
+                            (set (reg h-gr 6) (mem WI (reg h-gr 15)))
+                            (set (reg h-gr 15) (add (reg h-gr 15) (const 4)))))
+              (if (and reglist_low_ld (const #x80))
+                  (sequence ()
+                            (set (reg h-gr 7) (mem WI (reg h-gr 15)))
+                            (set (reg h-gr 15) (add (reg h-gr 15) (const 4)))))
+     )
+     ((fr30-1 (unit u-ldm)))
+)
+
+(dni ldm1
+     "ldm1 (reglist_hi_ld)"
+     (NOT-IN-DELAY-SLOT)
+     "ldm1 ($reglist_hi_ld)"
+     (+ OP1_8 OP2_D reglist_hi_ld)
+     (sequence ()
+              (if (and reglist_hi_ld (const #x1))
+                  (sequence ()
+                            (set (reg h-gr 8) (mem WI (reg h-gr 15)))
+                            (set (reg h-gr 15) (add (reg h-gr 15) (const 4)))))
+              (if (and reglist_hi_ld (const #x2))
+                  (sequence ()
+                            (set (reg h-gr 9) (mem WI (reg h-gr 15)))
+                            (set (reg h-gr 15) (add (reg h-gr 15) (const 4)))))
+              (if (and reglist_hi_ld (const #x4))
+                  (sequence ()
+                            (set (reg h-gr 10) (mem WI (reg h-gr 15)))
+                            (set (reg h-gr 15) (add (reg h-gr 15) (const 4)))))
+              (if (and reglist_hi_ld (const #x8))
+                  (sequence ()
+                            (set (reg h-gr 11) (mem WI (reg h-gr 15)))
+                            (set (reg h-gr 15) (add (reg h-gr 15) (const 4)))))
+              (if (and reglist_hi_ld (const #x10))
+                  (sequence ()
+                            (set (reg h-gr 12) (mem WI (reg h-gr 15)))
+                            (set (reg h-gr 15) (add (reg h-gr 15) (const 4)))))
+              (if (and reglist_hi_ld (const #x20))
+                  (sequence ()
+                            (set (reg h-gr 13) (mem WI (reg h-gr 15)))
+                            (set (reg h-gr 15) (add (reg h-gr 15) (const 4)))))
+              (if (and reglist_hi_ld (const #x40))
+                  (sequence ()
+                            (set (reg h-gr 14) (mem WI (reg h-gr 15)))
+                            (set (reg h-gr 15) (add (reg h-gr 15) (const 4)))))
+              (if (and reglist_hi_ld (const #x80))
+                  (set (reg h-gr 15) (mem WI (reg h-gr 15))))
+     )
+     ((fr30-1 (unit u-ldm)))
+)
+
+(dni stm0
+     "stm0 (reglist_low_st)"
+     (NOT-IN-DELAY-SLOT)
+     "stm0 ($reglist_low_st)"
+     (+ OP1_8 OP2_E reglist_low_st)
+     (sequence ()
+              (if (and reglist_low_st (const #x1))
+                  (sequence ()
+                            (set (reg h-gr 15) (sub (reg h-gr 15) (const 4)))
+                            (set (mem WI (reg h-gr 15)) (reg h-gr 7))))
+              (if (and reglist_low_st (const #x2))
+                  (sequence ()
+                            (set (reg h-gr 15) (sub (reg h-gr 15) (const 4)))
+                            (set (mem WI (reg h-gr 15)) (reg h-gr 6))))
+              (if (and reglist_low_st (const #x4))
+                  (sequence ()
+                            (set (reg h-gr 15) (sub (reg h-gr 15) (const 4)))
+                            (set (mem WI (reg h-gr 15)) (reg h-gr 5))))
+              (if (and reglist_low_st (const #x8))
+                  (sequence ()
+                            (set (reg h-gr 15) (sub (reg h-gr 15) (const 4)))
+                            (set (mem WI (reg h-gr 15)) (reg h-gr 4))))
+              (if (and reglist_low_st (const #x10))
+                  (sequence ()
+                            (set (reg h-gr 15) (sub (reg h-gr 15) (const 4)))
+                            (set (mem WI (reg h-gr 15)) (reg h-gr 3))))
+              (if (and reglist_low_st (const #x20))
+                  (sequence ()
+                            (set (reg h-gr 15) (sub (reg h-gr 15) (const 4)))
+                            (set (mem WI (reg h-gr 15)) (reg h-gr 2))))
+              (if (and reglist_low_st (const #x40))
+                  (sequence ()
+                            (set (reg h-gr 15) (sub (reg h-gr 15) (const 4)))
+                            (set (mem WI (reg h-gr 15)) (reg h-gr 1))))
+              (if (and reglist_low_st (const #x80))
+                  (sequence ()
+                            (set (reg h-gr 15) (sub (reg h-gr 15) (const 4)))
+                            (set (mem WI (reg h-gr 15)) (reg h-gr 0))))
+     )
+     ((fr30-1 (unit u-stm)))
+)
+
+(dni stm1
+     "stm1 (reglist_hi_st)"
+     (NOT-IN-DELAY-SLOT)
+     "stm1 ($reglist_hi_st)"
+     (+ OP1_8 OP2_F reglist_hi_st)
+     (sequence ()
+              (if (and reglist_hi_st (const #x1))
+                  (sequence ((WI save-r15))
+                            (set save-r15 (reg h-gr 15))
+                            (set (reg h-gr 15) (sub (reg h-gr 15) (const 4)))
+                            (set (mem WI (reg h-gr 15)) save-r15)))
+              (if (and reglist_hi_st (const #x2))
+                  (sequence ()
+                            (set (reg h-gr 15) (sub (reg h-gr 15) (const 4)))
+                            (set (mem WI (reg h-gr 15)) (reg h-gr 14))))
+              (if (and reglist_hi_st (const #x4))
+                  (sequence ()
+                            (set (reg h-gr 15) (sub (reg h-gr 15) (const 4)))
+                            (set (mem WI (reg h-gr 15)) (reg h-gr 13))))
+              (if (and reglist_hi_st (const #x8))
+                  (sequence ()
+                            (set (reg h-gr 15) (sub (reg h-gr 15) (const 4)))
+                            (set (mem WI (reg h-gr 15)) (reg h-gr 12))))
+              (if (and reglist_hi_st (const #x10))
+                  (sequence ()
+                            (set (reg h-gr 15) (sub (reg h-gr 15) (const 4)))
+                            (set (mem WI (reg h-gr 15)) (reg h-gr 11))))
+              (if (and reglist_hi_st (const #x20))
+                  (sequence ()
+                            (set (reg h-gr 15) (sub (reg h-gr 15) (const 4)))
+                            (set (mem WI (reg h-gr 15)) (reg h-gr 10))))
+              (if (and reglist_hi_st (const #x40))
+                  (sequence ()
+                            (set (reg h-gr 15) (sub (reg h-gr 15) (const 4)))
+                            (set (mem WI (reg h-gr 15)) (reg h-gr 9))))
+              (if (and reglist_hi_st (const #x80))
+                  (sequence ()
+                            (set (reg h-gr 15) (sub (reg h-gr 15) (const 4)))
+                            (set (mem WI (reg h-gr 15)) (reg h-gr 8))))
+     )
+     ((fr30-1 (unit u-stm)))
+)
+
+(dni enter
+     "enter #u10"
+     (NOT-IN-DELAY-SLOT)
+     "enter $u10"
+     (+ OP1_0 OP2_F u10)
+     (sequence ((WI tmp))
+              (set tmp (sub (reg h-gr 15) (const 4)))
+              (set (mem WI tmp) (reg h-gr 14))
+              (set (reg h-gr 14) tmp)
+              (set (reg h-gr 15) (sub (reg h-gr 15) u10)))
+     ((fr30-1 (unit u-exec (cycles 2))))
+)
+
+(dni leave
+     "leave"
+     ()
+     "leave"
+     (+ OP1_9 OP2_F OP3_9 OP4_0)
+     (sequence ()
+              (set (reg h-gr 15) (add (reg h-gr 14) (const 4)))
+              (set (reg h-gr 14) (mem WI (sub (reg h-gr 15) (const 4)))))
+     ()
+)
+
+(dni xchb  
+     "xchb @Rj,Ri"
+     (NOT-IN-DELAY-SLOT)
+     "xchb @$Rj,$Ri"
+     (+ OP1_8 OP2_A Rj Ri)
+     (sequence ((WI tmp))
+              (set tmp Ri)
+              (set Ri (mem UQI Rj))
+              (set (mem UQI Rj) tmp))
+     ((fr30-1 (unit u-load) (unit u-store)))
+)
diff --git a/cgen/fr30.opc b/cgen/fr30.opc
new file mode 100644 (file)
index 0000000..a30cb0a
--- /dev/null
@@ -0,0 +1,242 @@
+/* FR30 opcode support.  -*- C -*-
+   Copyright (C) 2000 Red Hat, Inc.
+   This file is part of CGEN.  */
+
+/* This file is an addendum to fr30.cpu.  Heavy use of C code isn't
+   appropriate in .cpu files, so it resides here.  This especially applies
+   to assembly/disassembly where parsing/printing can be quite involved.
+   Such things aren't really part of the specification of the cpu, per se,
+   so .cpu files provide the general framework and .opc files handle the
+   nitty-gritty details as necessary.
+
+   Each section is delimited with start and end markers.
+
+   <arch>-opc.h additions use: "-- opc.h"
+   <arch>-opc.c additions use: "-- opc.c"
+   <arch>-asm.c additions use: "-- asm.c"
+   <arch>-dis.c additions use: "-- dis.c"
+   <arch>-ibd.h additions use: "-- ibd.h"
+*/
+\f
+/* -- opc.h */
+
+/* ??? This can be improved upon.  */
+#undef CGEN_DIS_HASH_SIZE
+#define CGEN_DIS_HASH_SIZE 16
+#undef CGEN_DIS_HASH
+#define CGEN_DIS_HASH(buffer, value) (((unsigned char *) (buffer))[0] >> 4)
+
+/* -- */
+\f
+/* -- asm.c */
+/* Handle register lists for LDMx and STMx  */
+
+static int
+parse_register_number (strp)
+     const char **strp;
+{
+  int regno;
+  if (**strp < '0' || **strp > '9')
+    return -1; /* error */
+  regno = **strp - '0';
+  ++*strp;
+
+  if (**strp >= '0' && **strp <= '9')
+    {
+      regno = regno * 10 + (**strp - '0');
+      ++*strp;
+    }
+
+  return regno;
+}
+
+static const char *
+parse_register_list (cd, strp, opindex, valuep, high_low, load_store)
+     CGEN_CPU_DESC cd;
+     const char **strp;
+     int opindex;
+     unsigned long *valuep;
+     int high_low;   /* 0 == high, 1 == low */
+     int load_store; /* 0 == load, 1 == store */
+{
+  int regno;
+  *valuep = 0;
+  while (**strp && **strp != ')')
+    {
+      if (**strp != 'R' && **strp != 'r')
+       break;
+      ++*strp;
+
+      regno = parse_register_number (strp);
+      if (regno == -1)
+       return "Register number is not valid";
+      if (regno > 7 && !high_low)
+       return "Register must be between r0 and r7";
+      if (regno < 8 && high_low)
+       return "Register must be between r8 and r15";
+
+      if (high_low)
+       regno -= 8;
+
+      if (load_store) /* mask is reversed for store */
+       *valuep |= 0x80 >> regno;
+      else
+       *valuep |= 1 << regno;
+
+      if (**strp == ',')
+       {
+         if (*(*strp + 1) == ')')
+           break;
+         ++*strp;
+       }
+    }
+
+  if (!*strp || **strp != ')')
+    return "Register list is not valid";
+
+  return NULL;
+}
+
+static const char *
+parse_low_register_list_ld (cd, strp, opindex, valuep)
+     CGEN_CPU_DESC cd;
+     const char **strp;
+     int opindex;
+     unsigned long *valuep;
+{
+  return parse_register_list (cd, strp, opindex, valuep, 0/*low*/, 0/*load*/);
+}
+
+static const char *
+parse_hi_register_list_ld (cd, strp, opindex, valuep)
+     CGEN_CPU_DESC cd;
+     const char **strp;
+     int opindex;
+     unsigned long *valuep;
+{
+  return parse_register_list (cd, strp, opindex, valuep, 1/*high*/, 0/*load*/);
+}
+
+static const char *
+parse_low_register_list_st (cd, strp, opindex, valuep)
+     CGEN_CPU_DESC cd;
+     const char **strp;
+     int opindex;
+     unsigned long *valuep;
+{
+  return parse_register_list (cd, strp, opindex, valuep, 0/*low*/, 1/*store*/);
+}
+
+static const char *
+parse_hi_register_list_st (cd, strp, opindex, valuep)
+     CGEN_CPU_DESC cd;
+     const char **strp;
+     int opindex;
+     unsigned long *valuep;
+{
+  return parse_register_list (cd, strp, opindex, valuep, 1/*high*/, 1/*store*/);
+}
+
+/* -- */
+
+/* -- dis.c */
+
+static void
+print_register_list (dis_info, value, offset, load_store)
+     PTR dis_info;
+     long value;
+     long offset;
+     int load_store; /* 0 == load, 1 == store */
+{
+  disassemble_info *info = dis_info;
+  int mask;
+  int index = 0;
+  char* comma = "";
+
+  if (load_store)
+    mask = 0x80;
+  else
+    mask = 1;
+
+  if (value & mask)
+    {
+      (*info->fprintf_func) (info->stream, "r%i", index + offset);
+      comma = ",";
+    }
+    
+  for (index = 1; index <= 7; ++index)
+    {
+      if (load_store)
+       mask >>= 1;
+      else
+       mask <<= 1;
+
+      if (value & mask)
+       {
+         (*info->fprintf_func) (info->stream, "%sr%i", comma, index + offset);
+         comma = ",";
+       }
+    }
+}
+
+static void
+print_hi_register_list_ld (cd, dis_info, value, attrs, pc, length)
+     CGEN_CPU_DESC cd;
+     PTR dis_info;
+     long value;
+     unsigned int attrs;
+     bfd_vma pc;
+     int length;
+{
+  print_register_list (dis_info, value, 8, 0/*load*/);
+}
+
+static void
+print_low_register_list_ld (cd, dis_info, value, attrs, pc, length)
+     CGEN_CPU_DESC cd;
+     PTR dis_info;
+     long value;
+     unsigned int attrs;
+     bfd_vma pc;
+     int length;
+{
+  print_register_list (dis_info, value, 0, 0/*load*/);
+}
+
+static void
+print_hi_register_list_st (cd, dis_info, value, attrs, pc, length)
+     CGEN_CPU_DESC cd;
+     PTR dis_info;
+     long value;
+     unsigned int attrs;
+     bfd_vma pc;
+     int length;
+{
+  print_register_list (dis_info, value, 8, 1/*store*/);
+}
+
+static void
+print_low_register_list_st (cd, dis_info, value, attrs, pc, length)
+     CGEN_CPU_DESC cd;
+     PTR dis_info;
+     long value;
+     unsigned int attrs;
+     bfd_vma pc;
+     int length;
+{
+  print_register_list (dis_info, value, 0, 1/*store*/);
+}
+
+static void
+print_m4 (cd, dis_info, value, attrs, pc, length)
+     CGEN_CPU_DESC cd;
+     PTR dis_info;
+     long value;
+     unsigned int attrs;
+     bfd_vma pc;
+     int length;
+{
+  disassemble_info *info = (disassemble_info *) dis_info;
+  (*info->fprintf_func) (info->stream, "%ld", value);
+}
+/* -- */
diff --git a/cgen/gas-test.scm b/cgen/gas-test.scm
new file mode 100644 (file)
index 0000000..1883aae
--- /dev/null
@@ -0,0 +1,227 @@
+; CPU description file generator for the GAS testsuite.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; This is invoked to build allinsn.exp and a script to run to
+; generate allinsn.s and allinsn.d.
+
+; Specify which application.
+(set! APPLICATION 'GAS-TEST)
+\f
+; Called before/after the .cpu file has been read.
+
+(define (gas-test-init!) (opcodes-init!))
+(define (gas-test-finish!) (opcodes-finish!))
+
+; Called after .cpu file has been read and global error checks are done.
+; We use the `tmp' member to record the syntax split up into its components.
+
+(define (gas-test-analyze!)
+  (opcodes-analyze!)
+  (map (lambda (insn)
+        (elm-xset! insn 'tmp (syntax-break-out (insn-syntax insn))))
+       (non-multi-insns (current-insn-list)))
+  *UNSPECIFIED*
+)
+\f
+; Methods to compute test data.
+; The result is a list of strings to be inserted in the assembler
+; in the operand's position.
+
+(method-make!
+ <hw-asm> 'test-data
+ (lambda (self n)
+   ; FIXME: floating point support
+   (let ((signed (list 0 1 -1 2 -2))
+        (unsigned (list 0 1 2 3 4))
+        (mode (elm-get self 'mode)))
+     (map number->string
+         (list-take n
+                    (if (eq? (mode:class mode) 'UINT)
+                        unsigned
+                        signed)))))
+)
+
+(method-make!
+ <keyword> 'test-data
+ (lambda (self n)
+   (let* ((values (elm-get self 'values))
+         (n (min n (length values))))
+     ; FIXME: Need to handle mach variants.
+     (map car (list-take n values))))
+)
+
+(method-make!
+ <hw-address> 'test-data
+ (lambda (self n)
+   (let ((test-data '("foodata" "4" "footext" "-4")))
+     (list-take n test-data)))
+)
+
+(method-make!
+ <hw-iaddress> 'test-data
+ (lambda (self n)
+   (let ((test-data '("footext" "4" "foodata" "-4")))
+     (list-take n test-data)))
+)
+
+(method-make-forward! <hw-register> 'indices '(test-data))
+(method-make-forward! <hw-immediate> 'values '(test-data))
+
+; This can't use method-make-forward! as we need to call op:type to
+; resolve the hardware reference.
+
+(method-make!
+ <operand> 'test-data
+ (lambda (self n)
+   (send (op:type self) 'test-data n))
+)
+
+; Given an operand, return a set of N test data.
+; e.g. For a keyword operand, return a random subset.
+; For a number, return N numbers.
+
+(define (operand-test-data op n)
+  (send op 'test-data n)
+)
+
+; Given the broken out assembler syntax string, return the list of operand
+; objects.
+
+(define (extract-operands syntax-list)
+  (let loop ((result nil) (l syntax-list))
+    (cond ((null? l) (reverse! result))
+         ((object? (car l)) (loop (cons (car l) result) (cdr l)))
+         (else (loop result (cdr l)))))
+)
+
+; Given a list of operands for an instruction, return the test set
+; (all possible combinations).
+; N is the number of testcases for each operand.
+; The result has N to-the-power (length OP-LIST) elements.
+
+(define (build-test-set op-list n)
+  (let ((test-data (map (lambda (op) (operand-test-data op n)) op-list))
+       (len (length op-list)))
+    ; FIXME: Make slicker later.
+    (cond ((=? len 0) (list (list)))
+         ((=? len 1) test-data)
+         (else (list (map car test-data)))))
+)
+
+; Given an assembler expression and a set of operands build a testcase.
+; TEST-DATA is a list of strings, one element per operand.
+
+(define (build-asm-testcase syntax-list test-data)
+  (let loop ((result nil) (sl syntax-list) (td test-data))
+    ;(display (list result sl td "\n"))
+    (cond ((null? sl)
+          (string-append "\t"
+                         (apply string-append (reverse result))
+                         "\n"))
+         ((string? (car sl))
+          (loop (cons (car sl) result) (cdr sl) td))
+         (else (loop (cons (car td) result) (cdr sl) (cdr td)))))
+)
+
+; Generate the testsuite for INSN.
+; FIXME: This needs to be expanded upon.
+
+(define (gen-gas-test insn)
+  (logit 2 "Generating gas test data for " (obj:name insn) " ...\n")
+  (string-append
+   "\t.text\n"
+   "\t.global " (gen-sym insn) "\n"
+   (gen-sym insn) ":\n"
+   (let* ((syntax-list (insn-tmp insn))
+         (op-list (extract-operands syntax-list))
+         (test-set (build-test-set op-list 2)))
+     ;(display test-set) (newline)
+     (string-map (lambda (test-data)
+                  (build-asm-testcase syntax-list test-data))
+                test-set))
+   )
+)
+
+; Generate the shell script that builds the .d file.
+; .d files contain the objdump result that is used to see whether the
+; testcase passed.
+; We do this by running gas and objdump.
+; Obviously this isn't quite right - bugs in gas or
+; objdump - the things we're testing - will cause an incorrect testsuite to
+; be built and thus the bugs will be missed.  It is *not* intended that this
+; be run immediately before running the testsuite!  Rather, this is run to
+; generate the testsuite which is then inspected for accuracy and checked
+; into CVS.  As bugs in the testsuite are found they are corrected by hand.
+; Or if they're due to bugs in the generator the generator can be rerun and
+; the output diff'd to ensure no errors have crept back in.
+; The point of doing things this way is TO SAVE A HELL OF A LOT OF TYPING!
+; Clearly some hand generated testcases will also be needed, but this
+; provides a good test for each instruction.
+
+(define (cgen-build.sh)
+  (logit 1 "Generating gas-build.sh ...\n")
+  (string-append
+   "\
+#/bin/sh
+# Generate test result data for " (current-arch-name) " GAS testing.
+# This script is machine generated.
+# It is intended to be run in the testsuite source directory.
+#
+# Syntax: build.sh /path/to/build/gas
+
+BUILD=$1
+
+if [ ! -f $BUILD/as-new ] ; then
+    echo \"$BUILD is not a GAS build directory.\"
+    exit 1
+fi
+
+# Put results here, so we preserve the existing set for comparison.
+rm -rf tmpdir
+mkdir tmpdir
+cd tmpdir
+
+function gentest {
+    rm -f a.out
+    $BUILD/as-new ${1}.s -o a.out
+    echo \"#as:\" >${1}.d
+    echo \"#objdump: -dr\" >>${1}.d
+    echo \"#name: $1\" >>${1}.d
+    $BUILD/../binutils/objdump -dr a.out | \
+       sed -e 's/(/\\\\(/g' -e 's/)/\\\\)/g' -e 's/[+]/\\\\+/g' -e 's/[*]/\\\*/g' | \
+       sed -e 's/^.*file format.*$/.*: +file format .*/' \
+       >>${1}.d
+    rm -f a.out
+}
+
+# Now come all the testcases.
+cat > allinsn.s <<EOF
+ .data
+foodata: .word 42
+ .text
+footext:\n"
+    (string-map (lambda (insn)
+                 (gen-gas-test insn))
+               (non-multi-insns (current-insn-list)))
+    "EOF\n"
+    "\n"
+    "# Finally, generate the .d file.\n"
+    "gentest allinsn\n"
+   )
+)
+
+; Generate the dejagnu allinsn.exp file that drives the tests.
+
+(define (cgen-allinsn.exp)
+  (logit 1 "Generating allinsn.exp ...\n")
+  (string-append
+   "\
+# " (string-upcase (current-arch-name)) " assembler testsuite.
+
+if [istarget " (current-arch-name) "*-*-*] {
+    run_dump_test \"allinsn\"
+}\n"
+   )
+)
diff --git a/cgen/hardware.scm b/cgen/hardware.scm
new file mode 100644 (file)
index 0000000..7f8d553
--- /dev/null
@@ -0,0 +1,1172 @@
+; Hardware descriptions.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; This is the base class for all hardware descriptions.
+; The actual hardware objects inherit from this (e.g. register, immediate).
+; This is used to describe registers, memory, and immediates.
+; ??? Maybe other things as well, but this is all that's needed at present.
+; ??? Eventually rename to <hardware> but not yet.
+
+(define <hardware-base>
+  (class-make '<hardware-base>
+             '(<ident>)
+             '(
+               ; Name used in semantics.
+               ; This is for cases where a particular hardware element is
+               ; sufficiently different on different mach's of an architecture
+               ; that it is defined separately for each case.  The semantics
+               ; refer to this name (which means that one must use a different
+               ; mechanism if one wants both machs in the same semantic code).
+               sem-name
+
+               ; The type, an object of class <array>.
+               ; (mode + scalar or vector length)
+               type
+
+               ; Indexing support.
+               ; An object of class <hw-asm>, or a subclass of it, or
+               ; #f if there is no special indexing support.
+               ; For register banks, a table of register names.
+               ; ??? Same class as VALUES.
+               ; ??? There are currently no descriptions that require both an
+               ; INDICES and a VALUES specification.  It might make sense to
+               ; combine them (which is how things used to be), but it is odd
+               ; to have them combined.
+               (indices . #f)
+
+               ; Table of values.
+               ; An object of class <hw-asm>, or a subclass of it, or
+               ; #f if there is no special values support.
+               ; For immediates with special names, a table of names.
+               ; ??? Same class as INDICES.
+               (values . #f)
+
+               ; Associative list of (symbol . "handler") entries.
+               ; Each entry maps an operation to its handler (which is up to
+               ; the application but is generally a function name).
+               (handlers . ())
+
+               ; Get/set handlers or #f to use the default.
+               (get . #f)
+               (set . #f)
+
+               ; Associative list of get/set handlers for each supported mode,
+               ; or #f to use the default.
+               ; ??? An interesting idea, but not sure it's the best way
+               ; to go.  Another way is to explicitly handle it in the insn
+               ; [complicates the RTL].  Another way is to handle this in
+               ; operand get/set handlers.  Another way is to have virtual
+               ; regs for each non-default mode.  Not sure which is better.
+               ;(getters . #f)
+               ;(setters . #f)
+
+               ; List of <isa> objects that use this hardware element
+               ; or #f if not computed yet.
+               ; This is a derived from the ISA attribute and is for speed.
+               (isas-cache . #f)
+               )
+             nil)
+)
+
+; Accessors
+
+(define-getters <hardware-base> hw
+  (sem-name type indices values handlers
+   ; ??? These might be more properly named hw-get/hw-set, but those names
+   ; seem ambiguous.
+   (get . getter) (set . setter)
+   isas-cache)
+)
+
+; Mode,rank,shape support.
+
+(method-make-forward! <hardware-base> 'type '(get-mode get-rank get-shape get-num-elms))
+(define (hw-mode hw) (send hw 'get-mode))
+(define (hw-rank hw) (send hw 'get-rank))
+(define (hw-shape hw) (send hw 'get-shape))
+(define (hw-num-elms hw) (send hw 'get-num-elms))
+
+; Return default mode to reference HW in.
+
+(define (hw-default-mode hw)
+  (hw-mode hw)
+)
+
+; Return a boolean indicating if X is a hardware object.
+; ??? <hardware-base> to be renamed <hardware> in time.
+
+(define (hardware? x) (class-instance? <hardware-base> x))
+
+; Return #t if HW is a scalar.
+
+(define (hw-scalar? hw) (= (hw-rank hw) 0))
+
+; Return number of bits in an element of HW.
+
+(define (hw-bits hw)
+  (type-bits (hw-type hw))
+)
+
+; Generate the name of the enum for hardware object HW.
+; This uses the semantic name, not obj:name.
+; If HW is a symbol, it is already the semantic name.
+
+(define (hw-enum hw)
+  (if (symbol? hw)
+      (string-upcase (string-append "HW_" (gen-c-symbol hw)))
+      (string-upcase (string-append "HW_" (gen-c-symbol (hw-sem-name hw)))))
+)
+
+; Return a boolean indicating if it's ok to reference SELF in mode
+; NEW-MODE-NAME, index INDEX.
+; Hardware types are required to override this method.
+; VOID and DFLT are never valid for NEW-MODE-NAME.
+
+(method-make!
+ <hardware-base> 'mode-ok?
+ (lambda (self new-mode-name index)
+   (error "mode-ok? method not overridden:" (obj:name self)))
+)
+
+(define (hw-mode-ok? hw new-mode-name index)
+  (send hw 'mode-ok? new-mode-name index)
+)
+
+; Return mode to use for the index or #f if scalar.
+
+(method-make!
+ <hardware-base> 'get-index-mode
+ (lambda (self)
+   (error "get-index-mode method not overridden:" (obj:name self)))
+)
+
+(define (hw-index-mode hw) (send hw 'get-index-mode))
+
+; Compute the isas used by HW and cache the results.
+
+(method-make!
+ <hardware-base> 'get-isas
+ (lambda (self)
+   (or (elm-get self 'isas-cache)
+       (let* ((isas (obj-attr-value self 'ISA))
+             (isa-objs (if (eq? isas 'all) (current-isa-list)
+                           (map current-isa-lookup
+                                (bitset-attr->list isas)))))
+        (elm-set! self 'isas-cache isa-objs)
+        isa-objs)))
+)
+
+(define (hw-isas hw) (send hw 'get-isas))
+
+; FIXME: replace pc?,memory?,register?,iaddress? with just one method.
+
+; Return boolean indicating if hardware element is the PC.
+
+(method-make! <hardware-base> 'pc? (lambda (self) #f))
+
+; Return boolean indicating if hardware element is some kind of memory.
+; ??? Need to allow multiple kinds of memory and therefore need to allow
+; .cpu files to specify this (i.e. an attribute).  We could use has-attr?
+; here, or we could have the code that creates the object override this
+; method if the MEMORY attribute is present.
+; ??? Could also use a member instead of a method.
+
+(method-make! <hardware-base> 'memory? (lambda (self) #f))
+(define (memory? hw) (send hw 'memory?))
+
+; Return boolean indicating if hardware element is some kind of register.
+
+(method-make! <hardware-base> 'register? (lambda (self) #f))
+(define (register? hw) (send hw 'register?))
+
+; Return boolean indicating if hardware element is an address.
+
+(method-make! <hardware-base> 'address? (lambda (self) #f))
+(method-make! <hardware-base> 'iaddress? (lambda (self) #f))
+(define (address? hw) (send hw 'address?))
+(define (iaddress? hw) (send hw 'iaddress?))
+\f
+; Assembler support.
+
+; Baseclass.
+
+(define <hw-asm>
+  (class-make '<hw-asm> '(<ident>)
+             '(
+               ; The mode to use.
+               ; A copy of the object's mode if we're in the "values"
+               ; member.  If we're in the "indices" member this is typically
+               ; UINT.
+               mode
+               )
+             nil)
+)
+
+; Keywords.
+; Keyword lists associate a name with a number and are used for things
+; like register name tables (the `indices' field of a hw spec) and
+; immediate value tables (the `values' field of a hw spec).
+;
+; TODO: For things like the sparc fp regs, have a quasi-keyword that is
+; prefix plus number.  This will save having to create a table of each
+; register name.
+
+(define <keyword>
+  (class-make '<keyword> '(<hw-asm>)
+             '(
+               ; Name to use in generated code.
+               print-name
+
+               ; Prefix of each name in VALUES, as a string.
+               prefix
+
+               ; Associative list of values.
+               ; Each element is (name value [attrs]).
+               ; ??? May wish to allow calling a function to compute the
+               ; value at runtime.
+               values
+               )
+             nil)
+)
+
+; Accessors
+
+(define kw-mode (elm-make-getter <keyword> 'mode))
+(define kw-print-name (elm-make-getter <keyword> 'print-name))
+(define kw-prefix (elm-make-getter <keyword> 'prefix))
+(define kw-values (elm-make-getter <keyword> 'values))
+
+; Parse a keyword spec.
+;
+; The syntax of VALUES is: (prefix ((name1 [value1 [(attr-list1)]]) ...))
+; PREFIX is a string prefix for each name.
+; Each value is a number of mode MODE.
+; ??? We have no problem handling any kind of number, we're Scheme.
+; However, it's not clear yet how applications will want to handle it, but
+; that is left to the application.  Still, it might be preferable to impose
+; some restrictions which can later be relaxed as necessary.
+
+(define (keyword-parse context name comment attrs mode print-name prefix values)
+  ; FIXME: parse values.
+  (let ((result (make <keyword>
+                 (parse-name name context)
+                 (parse-comment comment context)
+                 (atlist-parse attrs "" context)
+                 (parse-mode-name mode (string-append context ": mode"))
+                 (parse-string (string-append context ": print-name") print-name)
+                 (parse-string (string-append context ": prefix") prefix)
+                 values)))
+    result)
+)
+
+; Read a keyword description
+; This is the main routine for analyzing a keyword description in the .cpu
+; file.
+; ARG-LIST is an associative list of field name and field value.
+; keyword-parse is invoked to create the <keyword> object.
+
+(define (-keyword-read context . arg-list)
+  (let ((name #f)
+       (comment "")
+       (attrs nil)
+       (mode INT)
+       (print-name #f)
+       (prefix "")
+       (values nil)
+       )
+    ; Loop over each element in ARG-LIST, recording what's found.
+    (let loop ((arg-list arg-list))
+      (if (null? arg-list)
+         nil
+         (let ((arg (car arg-list))
+               (elm-name (caar arg-list)))
+           (case elm-name
+             ((name) (set! name (cadr arg)))
+             ((comment) (set! comment (cadr arg)))
+             ((attrs) (set! attrs (cdr arg)))
+             ((mode) (set! mode (cadr arg)))
+             ((print-name) (set! print-name (cadr arg)))
+             ((prefix) (set! prefix (cadr arg)))
+             ((values) (set! values (cdr arg)))
+             (else (parse-error context "invalid hardware arg" arg)))
+           (loop (cdr arg-list)))))
+    ; Now that we've identified the elements, build the object.
+    (keyword-parse context name comment attrs mode
+                  (or print-name name)
+                  prefix values)
+    )
+)
+
+; Define a keyword object, name/value pair list version.
+
+(define define-keyword
+  (lambda arg-list
+    (let ((kw (apply -keyword-read (cons "define-keyword" arg-list))))
+      (if kw
+         (begin
+           (current-kw-add! kw)
+           ; Define an enum so the values are usable everywhere.
+           ; One use is giving names to register numbers and special constants
+           ; to make periphery C/C++ code more legible.
+           (define-full-enum (obj:name kw) (obj:comment kw)
+             (atlist-source-form (obj-atlist kw))
+             (string-upcase (symbol-append (kw-print-name kw) '-))
+             (kw-values kw))))
+      kw))
+)
+\f
+; Parsing support.
+
+; List of hardware types.
+; This maps names in the `type' entry of define-hardware to the class name.
+
+(define -hardware-types
+  '((register . <hw-register>)
+    (pc . <hw-pc>)
+    (memory . <hw-memory>)
+    (immediate . <hw-immediate>)
+    (address . <hw-address>)
+    (iaddress . <hw-iaddress>))
+)
+
+; Parse an inline keyword spec.
+; These are keywords defined inside something else.
+; CONTAINER is the <ident> object of the container.
+
+(define (-hw-parse-keyword context args container mode)
+  (if (!= (length args) 2)
+      (parse-error context "invalid keyword spec" args))
+
+  ; These are copied from our container object.
+  ; They're needed to output the table.
+  ; ??? This isn't quite right as the container may contain multiple keyword
+  ; instances.  To be fixed in time.
+  (keyword-parse context (obj:name container) (obj:comment container)
+                ; PRIVATE: keyword table is implicitly defined and made
+                ; "static" (in the C sense).
+                (cons 'PRIVATE (atlist-source-form (obj-atlist container)))
+                mode
+                (obj:name container) ; print-name
+                (car args) ; prefix
+                (cadr args)) ; value
+)
+
+; Parse an indices spec.
+; CONTAINER is the <ident> object of the container.
+; Currently there is only special support for keywords.
+; Otherwise MODE is used.
+; The syntax is: (keyword keyword-spec) - see <keyword> for details.
+
+(define (-hw-parse-indices errtxt indices container mode)
+  (if (null? indices)
+      (make <hw-asm>
+       (obj:name container) (obj:comment container) (obj-atlist container)
+       mode)
+      (begin
+       (if (not (list? indices))
+           (parse-error errtxt "invalid indices spec" indices))
+       (case (car indices)
+         ((keyword) (-hw-parse-keyword errtxt (cdr indices) container mode))
+         ((extern-keyword) (begin
+                             (if (null? (cdr indices))
+                                 (parse-error errtxt "missing keyword name"
+                                              indices))
+                             (let ((kw (current-kw-lookup (cadr indices))))
+                               (if (not kw)
+                                   (parse-error errtxt "unknown keyword"
+                                                indices))
+                               kw)))
+         (else (parse-error errtxt "unknown indices type" (car indices))))))
+)
+
+; Parse a values spec.
+; CONTAINER is the <ident> object of the container.
+; Currently there is only special support for keywords.
+; Otherwise MODE is used.
+; The syntax is: (keyword keyword-spec) - see <keyword> for details.
+
+(define (-hw-parse-values errtxt values container mode)
+  (if (null? values)
+      (make <hw-asm>
+       (obj:name container) (obj:comment container) (obj-atlist container)
+       mode)
+      (begin
+       (if (not (list? values))
+           (parse-error errtxt "invalid values spec" values))
+       (case (car values)
+         ((keyword) (-hw-parse-keyword errtxt (cdr values) container mode))
+         ((extern-keyword) (begin
+                             (if (null? (cdr values))
+                                 (parse-error errtxt "missing keyword name"
+                                              values))
+                             (let ((kw (current-kw-lookup (cadr values))))
+                               (if (not kw)
+                                   (parse-error errtxt "unknown keyword"
+                                                values))
+                               kw)))
+         (else (parse-error errtxt "unknown values type" (car values))))))
+)
+
+; Parse a handlers spec.
+; Each element is (name "string").
+
+(define (-hw-parse-handlers errtxt handlers)
+  (parse-handlers errtxt '(parse print) handlers)
+)
+
+; Parse a getter spec.
+; The syntax is (([index]) (expression)).
+; Omit `index' for scalar objects.
+; Externally they're specified as `get'.  Internally we use `getter'.
+
+(define (-hw-parse-getter errtxt getter scalar?)
+  (if (null? getter)
+      #f ; use default
+      (let ((valid "((index) (expression))")
+           (scalar-valid "(() (expression))"))
+       (if (or (not (list? getter))
+               (!= (length getter) 2)
+               (not (and (list? (car getter))
+                         (= (length (car getter)) (if scalar? 0 1)))))
+           (parse-error errtxt
+                        (string-append "invalid getter, should be "
+                                       (if scalar? scalar-valid valid))
+                        getter))
+       (if (not (rtx? (cadr getter)))
+           (parse-error errtxt "invalid rtx expression" getter))
+       getter))
+)
+
+; Parse a setter spec.
+; The syntax is (([index] newval) (expression)).
+; Omit `index' for scalar objects.
+; Externally they're specified as `set'.  Internally we use `setter'.
+
+(define (-hw-parse-setter errtxt setter scalar?)
+  (if (null? setter)
+      #f ; use default
+      (let ((valid "((index newval) (expression))")
+           (scalar-valid "((newval) (expression))"))
+       (if (or (not (list? setter))
+               (!= (length setter) 2)
+               (not (and (list? (car setter))
+                         (= (length (car setter)) (if scalar? 1 2)))))
+           (parse-error errtxt
+                        (string-append "invalid setter, should be "
+                                       (if scalar? scalar-valid valid))
+                        setter))
+       (if (not (rtx? (cadr setter)))
+           (parse-error errtxt "invalid rtx expression" setter))
+       setter))
+)
+
+; Parse hardware description
+; This is the main routine for building a hardware object from a hardware
+; description in the .cpu file.
+; All arguments are in raw (non-evaluated) form.
+; The result is the parsed object or #f if object isn't for selected mach(s).
+;
+; ??? Might want to redo to handle hardware type specific specs more cleanly.
+; E.g. <hw-immediate> shouldn't have to see get/set specs.
+
+(define (-hw-parse errtxt name comment attrs semantic-name type
+                  indices values handlers get set layout)
+  (logit 2 "Processing hardware element " name " ...\n")
+
+  (if (null? type)
+      (parse-error errtxt "missing hardware type" name))
+
+  ; Pick out name first 'cus we need it as a string(/symbol).
+  (let ((name (parse-name name "hardware"))
+       (class-name (assq-ref -hardware-types (car type)))
+       (atlist-obj (atlist-parse attrs "cgen_hw" errtxt)))
+
+    (if (not class-name)
+       (parse-error errtxt "unknown hardware type" type))
+
+    (if (keep-atlist? atlist-obj #f)
+
+       (let ((result (new (class-lookup class-name))))
+         (send result 'set-name! name)
+         (send result 'set-comment! (parse-comment comment errtxt))
+         (send result 'set-atlist! atlist-obj)
+         (elm-xset! result 'sem-name semantic-name)
+         (send result 'parse! errtxt
+               (cdr type) indices values handlers get set layout)
+         ; If this is a virtual reg, get/set specs must be provided.
+         (if (and (obj-has-attr? result 'VIRTUAL)
+                  (not (and (hw-getter result) (hw-setter result))))
+             (parse-error errtxt "virtual reg requires get/set specs" name))
+         ; If get or set specs are specified, can't have CACHE-ADDR.
+         (if (and (obj-has-attr? result 'CACHE-ADDR)
+                  (or (hw-getter result) (hw-setter result)))
+             (parse-error errtxt "can't have CACHE-ADDR with get/set specs" name))
+         result)
+
+       (begin
+         (logit 2 "Ignoring " name ".\n")
+         #f)))
+)
+
+; Read a hardware description
+; This is the main routine for analyzing a hardware description in the .cpu
+; file.
+; ARG-LIST is an associative list of field name and field value.
+; -hw-parse is invoked to create the <hardware> object.
+
+(define (-hw-read errtxt . arg-list)
+  (let ((name nil)          ; name of hardware
+       (comment "")
+       (attrs nil)
+       (semantic-name nil) ; name used in semantics, default is `name'
+       (type nil)          ; hardware type (register, immediate, etc.)
+       (indices nil)
+       (values nil)
+       (handlers nil)
+       (get nil)
+       (set nil)
+       (layout nil)
+       )
+    ; Loop over each element in ARG-LIST, recording what's found.
+    (let loop ((arg-list arg-list))
+      (if (null? arg-list)
+         nil
+         (let ((arg (car arg-list))
+               (elm-name (caar arg-list)))
+           (case elm-name
+             ((name) (set! name (cadr arg)))
+             ((comment) (set! comment (cadr arg)))
+             ((attrs) (set! attrs (cdr arg)))
+             ((semantic-name) (set! semantic-name (cadr arg)))
+             ((type) (set! type (cdr arg)))
+             ((indices) (set! indices (cdr arg)))
+             ((values) (set! values (cdr arg)))
+             ((handlers) (set! handlers (cdr arg)))
+             ((get) (set! get (cdr arg)))
+             ((set) (set! set (cdr arg)))
+             ((layout) (set! layout (cdr arg)))
+             (else (parse-error errtxt "invalid hardware arg" arg)))
+           (loop (cdr arg-list)))))
+    ; Now that we've identified the elements, build the object.
+    (-hw-parse errtxt name comment attrs
+              (if (null? semantic-name) name semantic-name)
+              type indices values handlers get set layout)
+    )
+)
+
+; Define a hardware object, name/value pair list version.
+
+(define define-hardware
+  (lambda arg-list
+    (let ((hw (apply -hw-read (cons "define-hardware" arg-list))))
+      (if hw
+         (current-hw-add! hw))
+      hw))
+)
+
+; Define a hardware object, all arguments specified.
+
+(define (define-full-hardware name comment attrs semantic-name type
+                             indices values handlers get set layout)
+  (let ((hw (-hw-parse "define-full-hardware"
+                      name comment attrs semantic-name type
+                      indices values handlers get set layout)))
+    (if hw
+       (current-hw-add! hw))
+    hw)
+)
+
+; Main routine for modifying existing definitions.
+
+(define modify-hardware
+  (lambda arg-list
+    (let ((errtxt "modify-hardware"))
+
+      ; FIXME: Experiment.  This implements the :name/value style by
+      ; converting it to (name value).  In the end there shouldn't be two
+      ; styles.  People might prefer :name/value, but it's not as amenable
+      ; to macro processing (insert potshots regarding macro usage).
+      (if (keyword-list? (car arg-list))
+         (set! arg-list (keyword-list->arg-list arg-list)))
+
+      ; First find out which element.
+      ; There's no requirement that the name be specified first.
+      (let ((hw-spec (assq 'name arg-list)))
+       (if (not hw-spec)
+           (parse-error errtxt "hardware name not specified"))
+
+       (let ((hw (current-hw-lookup (arg-list-symbol-arg errtxt hw-spec))))
+         (if (not hw)
+             (parse-error errtxt "undefined hardware element" hw-spec))
+
+         ; Process the rest of the args now that we have the affected object.
+         (let loop ((args arg-list))
+           (if (null? args)
+               #f ; done
+               (let ((arg-spec (car args)))
+                 (case (car arg-spec)
+                   ((name) #f) ; ignore, already processed
+                   ((add-attrs)
+                    (let ((atlist-obj (atlist-parse (cdr arg-spec)
+                                                    "cgen_hw" errtxt)))
+                      ; prepend attrs so new ones override existing ones
+                      (obj-prepend-atlist! hw atlist-obj)))
+                   (else
+                    (parse-error errtxt "invalid/unsupported option" (car arg-spec))))
+                 (loop (cdr args))))))))
+
+    *UNSPECIFIED*)
+)
+
+; Lookup a hardware object using its semantic name.
+; The result is a list of elements with SEM-NAME.
+; Callers must deal with cases where there is more than one.
+
+(define (current-hw-sem-lookup sem-name)
+  (find (lambda (hw) (eq? (hw-sem-name hw) sem-name))
+       (current-hw-list))
+)
+
+; Same as current-hw-sem-lookup, but result is 1 hw element or #f if not
+; found.  An error is signalled if multiple hw elements are found.
+
+(define (current-hw-sem-lookup-1 sem-name)
+  (let ((hw-objs (current-hw-sem-lookup sem-name)))
+    (case (length hw-objs)
+      ((0) #f)
+      ((1) (car hw-objs))
+      (else (error "ambiguous hardware reference" sem-name))))
+)
+\f
+; Basic hardware types.
+; These inherit from `hardware-base'.
+; ??? Might wish to allow each target to add more, but we provide enough
+; examples to cover most cpus.
+
+; A register (or an array of them).
+
+(define <hw-register> (class-make '<hw-register> '(<hardware-base>) nil nil))
+
+; Subroutine of -hw-create-[gs]etter-from-layout to validate a layout.
+; Valid values:
+; - 0 or 1
+; - (value length)
+; - hardware-name
+
+(define (-hw-validate-layout errtxt layout width)
+  (if (not (list? layout))
+      (parse-error errtxt "layout is not a list" layout))
+
+  (let loop ((layout layout) (shift 0))
+    (if (null? layout)
+       (begin
+         ; Done.  Now see if number of bits in layout matches total width.
+         (if (not (= shift width))
+             (parse-error errtxt (string-append
+                                  "insufficient number of bits (need "
+                                  (number->string width)
+                                  ")")
+                          shift)))
+       ; Validate next entry.
+       (let ((val (car layout)))
+         (cond ((number? val)
+                (if (not (memq val '(0 1)))
+                    (parse-error errtxt
+                                 "non 0/1 layout entry requires length"
+                                 val))
+                (loop (cdr layout) (1+ shift)))
+               ((pair? val)
+                (if (or (not (number? (car val)))
+                        (not (pair? (cdr val)))
+                        (not (number? (cadr val)))
+                        (not (null? (cddr val))))
+                    (parse-error errtxt
+                                 "syntax error in layout, expecting `(value length)'"
+                                 val))
+                (loop (cdr layout) (+ shift (cadr val))))
+               ((symbol? val)
+                (let ((hw (current-hw-lookup val)))
+                  (if (not hw)
+                      (parse-error errtxt "unknown hardware element" val))
+                  (if (not (hw-scalar? hw))
+                      (parse-error errtxt "non-scalar hardware element" val))
+                  (loop (cdr layout)
+                        (+ shift (hw-bits hw)))))
+               (else
+                (parse-error errtxt "bad layout element" val))))))
+  *UNSPECIFIED*
+)
+
+; Return the getter spec to use for LAYOUT.
+; WIDTH is the width of the combined value in bits.
+;
+; Example:
+; Assuming h-hw[123] are 1 bit registers, and width is 32
+; given ((0 29) h-hw1 h-hw2 h-hw3), return
+; (()
+;  (or SI (sll SI (zext SI (reg h-hw1)) 2)
+;      (or SI (sll SI (zext SI (reg h-hw2)) 1)
+;          (zext SI (reg h-hw3)))))
+
+(define (-hw-create-getter-from-layout errtxt layout width)
+  (let ((add-to-res (lambda (result mode-name val shift)
+                     (if (null? result)
+                         (rtx-make 'sll mode-name val shift)
+                         (rtx-make 'or mode-name
+                                   (rtx-make 'sll mode-name
+                                             (rtx-make 'zext mode-name val)
+                                             shift)
+                                   result))))
+       (mode-name (obj:name (mode-find width 'UINT))))
+    (let loop ((result nil) (layout (reverse layout)) (shift 0))
+      (if (null? layout)
+         (list nil result) ; getter spec: (get () (expression))
+         (let ((val (car layout)))
+           (cond ((number? val)
+                  ; ignore if zero
+                  (if (= val 0)
+                      (loop result (cdr layout) (1+ shift))
+                      (loop (add-to-res result mode-name val shift)
+                            (cdr layout)
+                            (1+ shift))))
+                 ((pair? val)
+                  ; ignore if zero
+                  (if (= (car val) 0)
+                      (loop result (cdr layout) (+ shift (cadr val)))
+                      (loop (add-to-res result mode-name (car val) shift)
+                            (cdr layout)
+                            (+ shift (cadr val)))))
+                 ((symbol? val)
+                  (let ((hw (current-hw-lookup val)))
+                    (loop (add-to-res result mode-name
+                                      (rtx-make 'reg val)
+                                      shift)
+                          (cdr layout)
+                          (+ shift (hw-bits hw)))))
+                 (else
+                  (assert (begin "bad layout element" #f))))))))
+)
+
+; Return the setter spec to use for LAYOUT.
+; WIDTH is the width of the combined value in bits.
+;
+; Example:
+; Assuming h-hw[123] are 1 bit registers,
+; given (h-hw1 h-hw2 h-hw3), return
+; ((val)
+;  (sequence ()
+;            (set (reg h-hw1) (and (srl val 2) 1))
+;            (set (reg h-hw2) (and (srl val 1) 1))
+;            (set (reg h-hw3) (and (srl val 0) 1))
+;            ))
+
+(define (-hw-create-setter-from-layout errtxt layout width)
+  (let ((mode-name (obj:name (mode-find width 'UINT))))
+    (let loop ((sets nil) (layout (reverse layout)) (shift 0))
+      (if (null? layout)
+         (list '(val) ; setter spec: (set (val) (expression))
+               (apply rtx-make (cons 'sequence (cons nil sets))))
+         (let ((val (car layout)))
+           (cond ((number? val)
+                  (loop sets (cdr layout) (1+ shift)))
+                 ((pair? val)
+                  (loop sets (cdr layout) (+ shift (cadr val))))
+                 ((symbol? val)
+                  (let ((hw (current-hw-lookup val)))
+                    (loop (cons (rtx-make 'set
+                                          (rtx-make 'reg val)
+                                          (rtx-make 'and
+                                                    (rtx-make 'srl 'val shift)
+                                                    (1- (logsll 1 (hw-bits hw)))))
+                                sets)
+                          (cdr layout)
+                          (+ shift (hw-bits hw)))))
+                 (else
+                  (assert (begin "bad layout element" #f))))))))
+)
+
+; Parse a register spec.
+; .cpu syntax: (register mode [(dimension)])
+;          or: (register (mode bits) [(dimension)])
+
+(method-make!
+ <hw-register> 'parse!
+ (lambda (self errtxt type indices values handlers getter setter layout)
+   (if (or (null? type)
+          (> (length type) 2))
+       (parse-error errtxt "invalid register spec" type))
+   (if (and (= (length type) 2)
+           (or (not (list? (cadr type)))
+               (> (length (cadr type)) 1)))
+       (parse-error errtxt "bad register dimension spec" type))
+
+   ; Must parse and set type before analyzing LAYOUT.
+   (elm-set! self 'type (parse-type errtxt type))
+
+   ; LAYOUT is a shorthand way of specifying getter/setter specs.
+   ; For registers that are just a collection of other registers
+   ; (e.g. the status register in mips), it's easier to specify the
+   ; registers that make up the bigger register, rather than to specify
+   ; get/set specs.
+   ; We don't override any provided get/set specs though.
+   (if (not (null? layout))
+       (let ((width (hw-bits self)))
+        (-hw-validate-layout errtxt layout width)
+        (if (null? getter)
+            (set! getter
+                  (-hw-create-getter-from-layout errtxt layout width)))
+        (if (null? setter)
+            (set! setter
+                  (-hw-create-setter-from-layout errtxt layout width)))
+        ))
+
+   (elm-set! self 'indices (-hw-parse-indices errtxt indices self UINT))
+   (elm-set! self 'values (-hw-parse-values errtxt values self
+                                           (send (elm-get self 'type)
+                                                 'get-mode)))
+   (elm-set! self 'handlers (-hw-parse-handlers errtxt handlers))
+   (elm-set! self 'get (-hw-parse-getter errtxt getter (hw-scalar? self)))
+   (elm-set! self 'set (-hw-parse-setter errtxt setter (hw-scalar? self)))
+   *UNSPECIFIED*)
+)
+
+; Return boolean indicating if hardware element is some kind of register.
+
+(method-make! <hw-register> 'register? (lambda (self) #t))
+
+; Return a boolean indicating if it's ok to reference SELF in mode
+; NEW-MODE-NAME, index INDEX.
+;
+; ??? INDEX isn't currently used.  The intent is to use it if it's a known
+; value, and otherwise assume for our purposes it's valid and leave any
+; further error checking to elsewhere.
+;
+; ??? This method makes more sense if we support multiple modes via
+; getters/setters.  Maybe we will some day, so this is left as is for now.
+
+(method-make!
+ <hw-register> 'mode-ok?
+ (lambda (self new-mode-name index)
+   (let ((cur-mode (send self 'get-mode))
+        (new-mode (mode:lookup new-mode-name)))
+     (if (mode:eq? new-mode-name cur-mode)
+        #t
+        ; ??? Subject to revisiting.
+        ; Only allow floats if same mode (which is handled above).
+        ; Only allow non-widening if ints.
+        ; On architectures where shortening/widening can refer to a
+        ; quasi-different register, it is up to the target to handle this.
+        ; See the comments for the getter/setter/getters/setters class
+        ; members.
+        (let ((cur-mode-class (mode:class cur-mode))
+              (cur-bits (mode:bits cur-mode))
+              (new-mode-class (mode:class new-mode))
+              (new-bits (mode:bits new-mode)))
+          ; Compensate for registers defined with an unsigned mode.
+          (if (eq? cur-mode-class 'UINT)
+              (set! cur-mode-class 'INT))
+          (if (eq? new-mode-class 'UINT)
+              (set! new-mode-class 'INT))
+          (if (eq? cur-mode-class 'INT)
+              (and (eq? new-mode-class cur-mode-class)
+                   (<= new-bits cur-bits))
+              #f)))))
+)
+
+; Return mode to use for the index or #f if scalar.
+
+(method-make!
+ <hw-register> 'get-index-mode
+ (lambda (self)
+   (if (scalar? (hw-type self))
+       #f
+       UINT))
+)
+
+; The program counter (PC) hardware register.
+; This is a separate class as the simulator needs a place to put special
+; get/set methods.
+
+(define <hw-pc> (class-make '<hw-pc> '(<hw-register>) nil nil))
+
+; Parse a pc spec.
+
+(method-make!
+ <hw-pc> 'parse!
+ (lambda (self errtxt type indices values handlers getter setter layout)
+   (if (not (null? type))
+       (elm-set! self 'type (parse-type errtxt type))
+       (elm-set! self 'type (make <scalar> (mode:lookup 'IAI))))
+   (if (not (null? indices))
+       (parse-error errtxt "indices specified for pc" indices))
+   (if (not (null? values))
+       (parse-error errtxt "values specified for pc" values))
+   (if (not (null? layout))
+       (parse-error errtxt "layout specified for pc" values))
+   ; The initial value of INDICES, VALUES is #f which is what we want.
+   (elm-set! self 'handlers (-hw-parse-handlers errtxt handlers))
+   (elm-set! self 'get (-hw-parse-getter errtxt getter (hw-scalar? self)))
+   (elm-set! self 'set (-hw-parse-setter errtxt setter (hw-scalar? self)))
+   *UNSPECIFIED*)
+)
+
+; Indicate we're the pc.
+
+(method-make! <hw-pc> 'pc? (lambda (self) #t))
+
+; Memory.
+
+(define <hw-memory> (class-make '<hw-memory> '(<hardware-base>) nil nil))
+
+; Parse a memory spec.
+; .cpu syntax: (memory mode [(dimension)])
+;          or: (memory (mode bits) [(dimension)])
+
+(method-make!
+ <hw-memory> 'parse!
+ (lambda (self errtxt type indices values handlers getter setter layout)
+   (if (or (null? type)
+          (> (length type) 2))
+       (parse-error errtxt "invalid memory spec" type))
+   (if (and (= (length type) 2)
+           (or (not (list? (cadr type)))
+               (> (length (cadr type)) 1)))
+       (parse-error errtxt "bad memory dimension spec" type))
+   (if (not (null? layout))
+       (parse-error errtxt "layout specified for memory" values))
+   (elm-set! self 'type (parse-type errtxt type))
+   ; Setting INDICES,VALUES here is mostly for experimentation at present.
+   (elm-set! self 'indices (-hw-parse-indices errtxt indices self AI))
+   (elm-set! self 'values (-hw-parse-values errtxt values self
+                                           (send (elm-get self 'type)
+                                                 'get-mode)))
+   (elm-set! self 'handlers (-hw-parse-handlers errtxt handlers))
+   (elm-set! self 'get (-hw-parse-getter errtxt getter (hw-scalar? self)))
+   (elm-set! self 'set (-hw-parse-setter errtxt setter (hw-scalar? self)))
+   *UNSPECIFIED*)
+)
+
+; Return boolean indicating if hardware element is some kind of memory.
+
+(method-make! <hw-memory> 'memory? (lambda (self) #t))
+
+; Return a boolean indicating if it's ok to reference SELF in mode
+; NEW-MODE-NAME, index INDEX.
+
+(method-make!
+ <hw-memory> 'mode-ok?
+ (lambda (self new-mode-name index)
+   ; Allow any mode for now.
+   #t)
+)
+
+; Return mode to use for the index or #f if scalar.
+
+(method-make!
+ <hw-memory> 'get-index-mode
+ (lambda (self)
+   AI)
+)
+
+; Immediate values (numbers recorded in the insn).
+
+(define <hw-immediate> (class-make '<hw-immediate> '(<hardware-base>) nil nil))
+
+; Parse an immediate spec.
+; .cpu syntax: (immediate mode)
+;          or: (immediate (mode bits))
+
+(method-make!
+ <hw-immediate> 'parse!
+ (lambda (self errtxt type indices values handlers getter setter layout)
+   (if (not (= (length type) 1))
+       (parse-error errtxt "invalid immediate spec" type))
+   (elm-set! self 'type (parse-type errtxt type))
+   ; An array of immediates may be useful some day, but not yet.
+   (if (not (null? indices))
+       (parse-error errtxt "indices specified for immediate" indices))
+   (if (not (null? layout))
+       (parse-error errtxt "layout specified for immediate" values))
+   (elm-set! self 'values (-hw-parse-values errtxt values self
+                                           (send (elm-get self 'type)
+                                                 'get-mode)))
+   (elm-set! self 'handlers (-hw-parse-handlers errtxt handlers))
+   (if (not (null? getter))
+       (parse-error errtxt "getter specified for immediate" getter))
+   (if (not (null? setter))
+       (parse-error errtxt "setter specified for immediate" setter))
+   *UNSPECIFIED*)
+)
+
+; Return a boolean indicating if it's ok to reference SELF in mode
+; NEW-MODE-NAME, index INDEX.
+
+(method-make!
+ <hw-immediate> 'mode-ok?
+ (lambda (self new-mode-name index)
+   (let ((cur-mode (send self 'get-mode))
+        (new-mode (mode:lookup new-mode-name)))
+     (if (mode:eq? new-mode-name cur-mode)
+        #t
+        ; ??? Subject to revisiting.
+        ; Only allow floats if same mode (which is handled above).
+        ; For ints allow anything.
+        (let ((cur-mode-class (mode:class cur-mode))
+              (new-mode-class (mode:class new-mode)))
+          (->bool (and (memq cur-mode-class '(INT UINT))
+                       (memq new-mode-class '(INT UINT))))))))
+)
+
+; Addresses.
+; These are usually symbols.
+
+(define <hw-address> (class-make '<hw-address> '(<hardware-base>) nil nil))
+
+(method-make! <hw-address> 'address? (lambda (self) #t))
+
+; Parse an address spec.
+
+(method-make!
+ <hw-address> 'parse!
+ (lambda (self errtxt type indices values handlers getter setter layout)
+   (if (not (null? type))
+       (parse-error errtxt "invalid address spec" type))
+   (elm-set! self 'type (make <scalar> AI))
+   (if (not (null? indices))
+       (parse-error errtxt "indices specified for address" indices))
+   (if (not (null? values))
+       (parse-error errtxt "values specified for address" values))
+   (if (not (null? layout))
+       (parse-error errtxt "layout specified for address" values))
+   (elm-set! self 'values (-hw-parse-values errtxt values self
+                                           (send (elm-get self 'type)
+                                                 'get-mode)))
+   (elm-set! self 'handlers (-hw-parse-handlers errtxt handlers))
+   (if (not (null? getter))
+       (parse-error errtxt "getter specified for address" getter))
+   (if (not (null? setter))
+       (parse-error errtxt "setter specified for address" setter))
+   *UNSPECIFIED*)
+)
+
+; Return a boolean indicating if it's ok to reference SELF in mode
+; NEW-MODE-NAME, index INDEX.
+
+(method-make!
+ <hw-address> 'mode-ok?
+ (lambda (self new-mode-name index)
+   ; We currently don't allow referencing an address in any mode other than
+   ; the original mode.
+   (mode-compatible? 'samesize new-mode-name (send self 'get-mode)))
+)
+
+; Instruction addresses.
+; These are treated separately from normal addresses as the simulator
+; may wish to treat them specially.
+; FIXME: Doesn't use mode IAI.
+
+(define <hw-iaddress> (class-make '<hw-iaddress> '(<hw-address>) nil nil))
+
+(method-make! <hw-iaddress> 'iaddress? (lambda (self) #t))
+\f
+; Builtins, attributes, init/fini support.
+
+(define h-memory #f)
+(define h-sint #f)
+(define h-uint #f)
+(define h-addr #f)
+(define h-iaddr #f)
+
+
+; Map a mode to a hardware object that can contain immediate values of that mode
+(define (hardware-for-mode mode)
+  (cond ((mode:eq? mode 'AI) h-addr)
+       ((mode:eq? mode 'IAI) h-addr)
+       ((mode-signed? mode) h-sint)
+       ((mode-unsigned? mode) h-uint)
+       (else (error "Don't know h-object for mode " mode)))
+)
+
+
+; Called before reading a .cpu file in.
+
+(define (hardware-init!)
+  (reader-add-command! 'define-keyword
+                      "\
+Define a keyword, name/value pair list version.
+"
+                      nil 'arg-list define-keyword)
+  (reader-add-command! 'define-hardware
+                      "\
+Define a hardware element, name/value pair list version.
+"
+                      nil 'arg-list define-hardware)
+  (reader-add-command! 'define-full-hardware
+                      "\
+Define a hardware element, all arguments specified.
+"
+                      nil '(name comment attrs semantic-name type
+                                 indices values handlers get set layout)
+                      define-full-hardware)
+  (reader-add-command! 'modify-hardware
+                      "\
+Modify a hardware element, name/value pair list version.
+"
+                      nil 'arg-list modify-hardware)
+
+  *UNSPECIFIED*
+)
+
+; Install builtin hardware objects.
+
+(define (hardware-builtin!)
+  ; Standard h/w attributes.
+  (define-attr '(for hardware) '(type boolean) '(name CACHE-ADDR)
+    '(comment "cache register address during insn extraction"))
+  ; FIXME: This should be deletable.
+  (define-attr '(for hardware) '(type boolean) '(name PC)
+    '(comment "the program counter"))
+  (define-attr '(for hardware) '(type boolean) '(name PROFILE)
+    '(comment "collect profiling data"))
+
+  (let ((all (stringize (current-arch-isa-name-list) ",")))
+    ; ??? The program counter, h-pc, used to be defined here.
+    ; However, some targets need to modify it (e.g. provide special get/set
+    ; specs).  There's still an outstanding issue of how to add things to
+    ; objects after the fact (e.g. model parameters to instructions), but
+    ; that's further down the road.
+    (set! h-memory (define-full-hardware 'h-memory "memory"
+                    `((ISA ,all))
+                    ; Ensure memory not flagged as a scalar.
+                    'h-memory '(memory UQI (1)) nil nil nil
+                    nil nil nil))
+    (set! h-sint (define-full-hardware 'h-sint "signed integer"
+                  `((ISA ,all))
+                  'h-sint '(immediate (INT 32)) nil nil nil
+                  nil nil nil))
+    (set! h-uint (define-full-hardware 'h-uint "unsigned integer"
+                  `((ISA ,all))
+                  'h-uint '(immediate (UINT 32)) nil nil nil
+                  nil nil nil))
+    (set! h-addr (define-full-hardware 'h-addr "address"
+                  `((ISA ,all))
+                  'h-addr '(address) nil nil '((print "print_address"))
+                  nil nil nil))
+    ; Instruction addresses.
+    ; These are different because the simulator may want to do something
+    ; special with them, and some architectures treat them differently.
+    (set! h-iaddr (define-full-hardware 'h-iaddr "instruction address"
+                   `((ISA ,all))
+                   'h-iaddr '(iaddress) nil nil '((print "print_address"))
+                   nil nil nil)))
+
+  *UNSPECIFIED*
+)
+
+; Called after a .cpu file has been read in.
+
+(define (hardware-finish!)
+  *UNSPECIFIED*
+)
diff --git a/cgen/i960.cpu b/cgen/i960.cpu
new file mode 100644 (file)
index 0000000..6bd641e
--- /dev/null
@@ -0,0 +1,1320 @@
+; Intel 80960 CPU description.  -*- Scheme -*-
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; Misc CGEN related problems.
+
+; ??? CGEN assumes that the program counter is called PC.  On the i960, it
+; is called IP (Instruction Pointer).
+
+; ??? Try using (f-m3 1) instead of M3_1.
+
+; ??? Try using the RESERVED attribute for instruction fields.
+
+(include "simplify.inc")
+
+\f
+; Architecture and cpu family definitions.
+
+; ??? This should be using (insn-lsb0? #t), but it doesn't work yet.
+
+(define-arch
+  (name i960)
+  (comment "Intel 80960 architecture")
+  (machs i960:ka_sa i960:ca)
+  (isas i960)
+)
+
+(define-isa
+  (name i960)
+  (base-insn-bitsize 32)
+  (decode-assist (0 1 2 3 4 5 6 7))
+  (liw-insns 1)
+  (parallel-insns 1)
+)
+
+(define-cpu
+  (name i960base)
+  (comment "Intel 80960 cpu family")
+  (endian little)
+  (word-bitsize 32)
+)
+\f
+(define-mach
+  (name i960:ka_sa)
+  (comment "I960 KA and SA processors")
+  (cpu i960base)
+)
+
+; ??? Incomplete.  Pipeline and unit info wrong.
+
+(define-model
+  (name i960KA)
+  (comment "I960 KA processor")
+  (mach i960:ka_sa)
+  (pipeline all "" () ((fetch) (decode) (execute) (writeback)))
+  (unit u-exec "Execution Unit" () 1 1
+       () () () ())
+)
+\f
+(define-mach
+  (name i960:ca)
+  (comment "I960 CA processor")
+  (cpu i960base)
+)
+
+; ??? Incomplete.  Pipeline and unit info wrong.
+
+(define-model
+  (name i960CA)
+  (comment "I960 CA processor")
+  (mach i960:ca)
+  (pipeline all "" () ((fetch) (decode) (execute) (writeback)))
+  (unit u-exec "Execution Unit" () 1 1
+       () () () ())
+)
+\f
+; Instruction fields.
+;
+; Attributes:
+; PCREL-ADDR: pc relative value (for reloc and disassembly purposes)
+; ABS-ADDR: absolute address (for reloc and disassembly purposes?)
+; RESERVED: bits are not used to decode insn, must be all 0
+
+; All of the fields for a REG format instruction.
+
+(dnf f-opcode  "opcode"                () 0 8)
+(dnf f-srcdst  "src/dst"               () 8 5)
+(dnf f-src2    "src2"                  () 13 5)
+(dnf f-m3      "m3"                    () 18 1)
+(dnf f-m2      "m2"                    () 19 1)
+(dnf f-m1      "m1"                    () 20 1)
+(dnf f-opcode2 "opcode2"               () 21 4)
+(dnf f-zero    "zero"                  () 25 2)
+(dnf f-src1    "src1"                  () 27 5)
+
+; Extra fields needed for a MEMA format instruction.
+
+(dnf f-abase   "abase"                 () 13 5)
+(dnf f-modea   "modea"                 () 18 1)
+(dnf f-zeroa   "zeroa"                 () 19 1)
+(dnf f-offset  "offset"                () 20 12)
+
+; Extra fields needed for a MEMB format instruction.
+
+(dnf f-modeb   "modeb"                 () 18 4)
+(dnf f-scale   "scale"                 () 22 3)
+(dnf f-zerob   "zerob"                 () 25 2)
+(dnf f-index   "index"                 () 27 5)
+(dnf f-optdisp "optional displacement" () 32 32)
+
+; Extra fields needed for a COBR format instruction.
+
+(dnf f-br-src1 "branch src1"           () 8 5)
+(dnf f-br-src2 "branch src2"           () 13 5)
+(dnf f-br-m1   "branch m1"             () 18 1)
+(df  f-br-disp "branch displacement"   (PCREL-ADDR) 19 11 INT
+     ((value pc) (sra WI (sub WI value pc) (const 2)))
+     ((value pc) (add WI (sll WI value (const 2)) pc)))
+(dnf f-br-zero "branch zero"           () 30 2)
+
+; Extra fields needed for a CRTL format instruction.
+
+(df  f-ctrl-disp "ctrl branch disp"    (PCREL-ADDR) 8 22 INT
+     ((value pc) (sra WI (sub WI value pc) (const 2)))
+     ((value pc) (add WI (sll WI value (const 2)) pc)))
+(dnf f-ctrl-zero "ctrl branch zero"    () 30 2)
+
+\f
+; Enums.
+
+(define-pmacro (build-hex2 num) (.hex num 2))
+
+; insn-opcode
+(define-normal-insn-enum insn-opcode "insn opcode enums" () OPCODE_ f-opcode
+  (.map .upcase (.map build-hex2 (.iota 256))) ; "00" -> "FF"
+)
+
+(define-normal-insn-enum insn-opcode2 "insn opcode2 enums" () OPCODE2_
+  f-opcode2
+  (.map .upcase (.map .hex (.iota 16))) ; "0" -> "F"
+)
+
+(define-normal-insn-enum insn-m3 "insn m3 enums" () M3_
+  f-m3
+  ("0" "1")
+)
+
+(define-normal-insn-enum insn-m2 "insn m3 enums" () M2_
+  f-m2
+  ("0" "1")
+)
+
+(define-normal-insn-enum insn-m1 "insn m1 enums" () M1_
+  f-m1
+  ("0" "1")
+)
+
+(define-normal-insn-enum insn-zero "insn zero enums" () ZERO_
+  f-zero
+  ("0")
+)
+
+(define-normal-insn-enum insn-modea "insn mode a enums" () MODEA_
+  f-modea
+  ("OFFSET" "INDIRECT-OFFSET")
+)
+
+(define-normal-insn-enum insn-zeroa "insn zero a enums" () ZEROA_
+  f-zeroa
+  ("0")
+)
+
+(define-normal-insn-enum insn-modeb "insn mode b enums" () MODEB_
+  f-modeb
+  ("ILL0" "ILL1" "ILL2" "ILL3" "INDIRECT" "IP-DISP" "RES6" "INDIRECT-INDEX"
+   "ILL8" "ILL9" "ILL10" "ILL11" "DISP" "INDIRECT-DISP" "INDEX-DISP"
+   "INDIRECT-INDEX-DISP")
+)
+
+(define-normal-insn-enum insn-zerob "insn zero b enums" () ZEROB_
+  f-zerob
+  ("0")
+)
+
+(define-normal-insn-enum insn-br-m1 "insn branch m1 enums" () BR_M1_
+  f-br-m1
+  ("0" "1")
+)
+
+(define-normal-insn-enum insn-br-zero "insn branch zero enums" () BR_ZERO_
+  f-br-zero
+  ("0")
+)
+
+(define-normal-insn-enum insn-ctrl-zero "insn ctrl zero enums" () CTRL_ZERO_
+  f-ctrl-zero
+  ("0")
+)
+
+\f
+; Hardware pieces
+
+(dnh h-pc "program counter" (PC PROFILE) (pc) () () ())
+
+(define-hardware
+  (name h-gr)
+  (comment "general registers")
+  (attrs PROFILE CACHE-ADDR)
+  (type register WI (32))
+  (indices keyword ""
+          ((fp 31) (sp 1)
+           (r0 0) (r1 1) (r2 2) (r3 3) (r4 4) (r5 5) (r6 6) (r7 7)
+           (r8 8) (r9 9) (r10 10) (r11 11) (r12 12) (r13 13) (r14 14) (r15 15)
+           (g0 16) (g1 17) (g2 18) (g3 19) (g4 20) (g5 21) (g6 22) (g7 23)
+           (g8 24) (g9 25) (g10 26) (g11 27) (g12 28) (g13 29) (g14 30) (g15 31)
+           ))
+)
+
+; ??? This is actually part of the AC register.
+
+(define-hardware
+  (name h-cc)
+  (comment "condition code")
+  (attrs PROFILE CACHE-ADDR)
+  (type register WI)
+  (indices keyword "" ((cc 0)))
+)
+
+;(define-hardware
+;  (name h-pc)
+;  (comment "program counter")
+;  (attrs PC)
+;  (type register WI)
+;  ; (handlers (print "ip"))
+;)
+
+; ??? Incomplete.
+
+\f
+; Instruction Operands.
+; These entries provide a layer between the assembler and the raw hardware
+; description, and are used to refer to hardware elements in the semantic
+; code.  Usually there's a bit of over-specification, but in more complicated
+; instruction sets there isn't.
+
+; Operand fields for a REG format instruction.
+
+(dnop src1     "source register 1"     () h-gr   f-src1)
+(dnop src2     "source register 2"     () h-gr   f-src2)
+(dnop dst      "source/dest register"  () h-gr   f-srcdst)
+
+(dnop lit1     "literal 1"             () h-uint f-src1)
+(dnop lit2     "literal 2"             () h-uint f-src2)
+
+; Operand fields for a MEMA format instruction.
+
+(dnop st_src   "store src"             () h-gr   f-srcdst)
+(dnop abase    "abase"                 () h-gr   f-abase)
+(dnop offset   "offset"                () h-uint f-offset)
+
+; Operand fields for a MEMB format instruction.
+
+(dnop scale    "scale"                 () h-uint f-scale)
+(dnop index    "index"                 () h-gr   f-index)
+(dnop optdisp  "optional displacement" () h-uint f-optdisp)
+
+; Operand fields for a COBR format instruction.
+
+(dnop br_src1  "branch src1"           () h-gr   f-br-src1)
+(dnop br_src2  "branch src2"           () h-gr   f-br-src2)
+(dnop br_disp  "branch displacement"   () h-iaddr f-br-disp)
+
+(dnop br_lit1  "branch literal 1"      () h-uint f-br-src1)
+
+; Operand fields for a CRTL format instruction.
+
+(dnop ctrl_disp "ctrl branch disp"     () h-iaddr f-ctrl-disp)
+
+\f
+; Instruction definitions.
+
+; ??? Maybe I should just reverse the operands in the alu-op macro.
+
+(define-pmacro (divo-expr expr1 expr2) (udiv expr2 expr1))
+(define-pmacro (divi-expr expr1 expr2) (div expr2 expr1))
+(define-pmacro (remo-expr expr1 expr2) (umod expr2 expr1))
+(define-pmacro (remi-expr expr1 expr2) (mod expr2 expr1))
+
+(define-pmacro (sub-expr expr1 expr2) (sub expr2 expr1))
+
+(define-pmacro (notbit-expr expr1 expr2)
+  (xor (sll (const 1) expr1) expr2))
+(define-pmacro (andnot-expr expr1 expr2)
+  (and expr2 (inv expr1)))
+(define-pmacro (setbit-expr expr1 expr2)
+  (or (sll (const 1) expr1) expr2))
+(define-pmacro (notand-expr expr1 expr2)
+  (and (inv expr2) expr1))
+(define-pmacro (nor-expr expr1 expr2)
+  (and (inv expr2) (inv expr1)))
+(define-pmacro (xnor-expr expr1 expr2)
+  (inv (xor expr1 expr2)))
+(define-pmacro (not-expr expr1 expr2)
+  (inv expr1))
+(define-pmacro (ornot-expr expr1 expr2)
+  (or expr2 (inv expr1)))
+(define-pmacro (clrbit-expr expr1 expr2)
+  (and (inv (sll (const 1) expr1)) expr2))
+
+; A shift of 32 or more shifts out all input bits.
+
+(define-pmacro (sll-expr expr1 expr2)
+  (cond WI
+        ((geu UWI expr1 (const 32)) (const 0))
+        (else (sll expr2 expr1))))
+(define-pmacro (srl-expr expr1 expr2)
+  (cond WI
+        ((geu UWI expr1 (const 32)) (const 0))
+        (else (srl expr2 expr1))))
+(define-pmacro (sra-expr expr1 expr2)
+  (cond WI
+        ((geu UWI expr1 (const 32)) (sra expr2 (const 31)))
+        (else (sra expr2 expr1))))
+
+(define-pmacro (alu-op mnemonic opcode-op opcode2-op sem-op)
+  (begin
+    (dni mnemonic
+        (.str mnemonic " reg/reg")
+        ()
+        (.str mnemonic " $src1, $src2, $dst")
+        (+ opcode-op dst src2 M3_0 M2_0 M1_0 opcode2-op ZERO_0 src1)
+        (set dst (sem-op src1 src2))
+        ()
+    )
+    (dni (.sym mnemonic "1")
+        (.str mnemonic " lit/reg")
+        ()
+        (.str mnemonic " $lit1, $src2, $dst")
+        (+ opcode-op dst src2 M3_0 M2_0 M1_1 opcode2-op ZERO_0 lit1)
+        (set dst (sem-op lit1 src2))
+        ()
+    )
+    (dni (.sym mnemonic "2")
+        (.str mnemonic " reg/lit")
+        ()
+        (.str mnemonic " $src1, $lit2, $dst")
+        (+ opcode-op dst lit2 M3_0 M2_1 M1_0 opcode2-op ZERO_0 src1)
+        (set dst (sem-op src1 lit2))
+        ()
+    )
+    (dni (.sym mnemonic "3")
+        (.str mnemonic " lit/lit")
+        ()
+        (.str mnemonic " $lit1, $lit2, $dst")
+        (+ opcode-op dst lit2 M3_0 M2_1 M1_1 opcode2-op ZERO_0 lit1)
+        (set dst (sem-op lit1 lit2))
+        ()
+    )
+  )
+)
+
+(alu-op mulo OPCODE_70 OPCODE2_1 mul)
+(alu-op remo OPCODE_70 OPCODE2_8 remo-expr)
+(alu-op divo OPCODE_70 OPCODE2_B divo-expr)
+(alu-op remi OPCODE_74 OPCODE2_8 remi-expr)
+(alu-op divi OPCODE_74 OPCODE2_B divi-expr)
+
+(alu-op addo OPCODE_59 OPCODE2_0 add)
+(alu-op subo OPCODE_59 OPCODE2_2 sub-expr)
+
+(alu-op notbit OPCODE_58 OPCODE2_0 notbit-expr)
+(alu-op and  OPCODE_58 OPCODE2_1 and)
+(alu-op andnot OPCODE_58 OPCODE2_2 andnot-expr)
+(alu-op setbit OPCODE_58 OPCODE2_3 setbit-expr)
+(alu-op notand OPCODE_58 OPCODE2_4 notand-expr)
+(alu-op xor  OPCODE_58 OPCODE2_6 xor)
+(alu-op or   OPCODE_58 OPCODE2_7 or)
+(alu-op nor  OPCODE_58 OPCODE2_8 nor-expr)
+(alu-op xnor OPCODE_58 OPCODE2_9 xnor-expr)
+(alu-op not  OPCODE_58 OPCODE2_A not-expr)
+(alu-op ornot OPCODE_58 OPCODE2_B ornot-expr)
+(alu-op clrbit OPCODE_58 OPCODE2_C clrbit-expr)
+
+; ??? Incomplete.  Does not handle overflow for integer shifts.
+
+(alu-op shlo OPCODE_59 OPCODE2_C sll-expr)
+(alu-op shro OPCODE_59 OPCODE2_8 srl-expr)
+(alu-op shli OPCODE_59 OPCODE2_E sll-expr)
+(alu-op shri OPCODE_59 OPCODE2_B sra-expr)
+
+\f
+; ??? Does not verify alignment of dest reg.
+
+(define-pmacro (emul-expr dest expr1 expr2)
+  (sequence ((DI temp) (SI dregno))
+           (set temp (mul DI (zext DI expr1) (zext DI expr2)))
+           ; ??? Workaround cgen s-i-o-o bug.
+           (set dregno (ifield f-srcdst))
+           (set dest (trunc SI temp))
+           (set (reg h-gr (add (index-of dest) (const 1)))
+                (trunc SI (srl temp (const 32))))))
+
+; ??? Needless duplicate of alu-op.  Should eliminate alu-op.
+
+(define-pmacro (alu2-op mnemonic opcode-op opcode2-op sem-op)
+  (begin
+    (dni mnemonic
+        (.str mnemonic " reg/reg")
+        ()
+        (.str mnemonic " $src1, $src2, $dst")
+        (+ opcode-op dst src2 M3_0 M2_0 M1_0 opcode2-op ZERO_0 src1)
+        (sem-op dst src1 src2)
+        ()
+    )
+    (dni (.sym mnemonic "1")
+        (.str mnemonic " lit/reg")
+        ()
+        (.str mnemonic " $lit1, $src2, $dst")
+        (+ opcode-op dst src2 M3_0 M2_0 M1_1 opcode2-op ZERO_0 lit1)
+        (sem-op dst lit1 src2)
+        ()
+    )
+    (dni (.sym mnemonic "2")
+        (.str mnemonic " reg/lit")
+        ()
+        (.str mnemonic " $src1, $lit2, $dst")
+        (+ opcode-op dst lit2 M3_0 M2_1 M1_0 opcode2-op ZERO_0 src1)
+        (sem-op dst src1 lit2)
+        ()
+    )
+    (dni (.sym mnemonic "3")
+        (.str mnemonic " lit/lit")
+        ()
+        (.str mnemonic " $lit1, $lit2, $dst")
+        (+ opcode-op dst lit2 M3_0 M2_1 M1_1 opcode2-op ZERO_0 lit1)
+        (sem-op dst lit1 lit2)
+        ()
+    )
+  )
+)
+
+(alu2-op emul OPCODE_67 OPCODE2_0 emul-expr)
+
+\f
+
+; ??? lit2 must be zero.
+; ??? should verify multi-word reg alignment.
+
+(define-pmacro (mov-expr expr1 expr2)
+  (set expr1 expr2))
+(define-pmacro (movl-expr expr1 expr2)
+  (sequence ((SI dregno) (SI sregno))
+           ; ??? Workaround cgen s-i-o-o bug.
+           (set dregno (ifield f-srcdst))
+           (set sregno (ifield f-src1))
+           (set expr1 expr2)
+           (set (reg h-gr (add (index-of expr1) (const 1)))
+                (reg h-gr (add (index-of expr2) (const 1))))))
+(define-pmacro (movllit-expr expr1 expr2)
+  (sequence ((SI dregno))
+           ; ??? Workaround cgen s-i-o-o bug.
+           (set dregno (ifield f-srcdst))
+           (set expr1 expr2)
+           (set (reg h-gr (add (index-of expr1) (const 1)))
+                (const 0))))
+(define-pmacro (movt-expr expr1 expr2)
+  (sequence ((SI dregno) (SI sregno))
+           ; ??? Workaround cgen s-i-o-o bug.
+           (set dregno (ifield f-srcdst))
+           (set sregno (ifield f-src1))
+           (set expr1 expr2)
+           (set (reg h-gr (add (index-of expr1) (const 1)))
+                (reg h-gr (add (index-of expr2) (const 1))))
+           (set (reg h-gr (add (index-of expr1) (const 2)))
+                (reg h-gr (add (index-of expr2) (const 2))))))
+(define-pmacro (movtlit-expr expr1 expr2)
+  (sequence ((SI dregno))
+           ; ??? Workaround cgen s-i-o-o bug.
+           (set dregno (ifield f-srcdst))
+           (set expr1 expr2)
+           (set (reg h-gr (add (index-of expr1) (const 1)))
+                (const 0))
+           (set (reg h-gr (add (index-of expr1) (const 2)))
+                (const 0))))
+(define-pmacro (movq-expr expr1 expr2)
+  (sequence ((SI dregno) (SI sregno))
+           ; ??? Workaround cgen s-i-o-o bug.
+           (set dregno (ifield f-srcdst))
+           (set sregno (ifield f-src1))
+           (set expr1 expr2)
+           (set (reg h-gr (add (index-of expr1) (const 1)))
+                (reg h-gr (add (index-of expr2) (const 1))))
+           (set (reg h-gr (add (index-of expr1) (const 2)))
+                (reg h-gr (add (index-of expr2) (const 2))))
+           (set (reg h-gr (add (index-of expr1) (const 3)))
+                (reg h-gr (add (index-of expr2) (const 3))))))
+(define-pmacro (movqlit-expr expr1 expr2)
+  (sequence ((SI dregno))
+           ; ??? Workaround cgen s-i-o-o bug.
+           (set dregno (ifield f-srcdst))
+           (set expr1 expr2)
+           (set (reg h-gr (add (index-of expr1) (const 1)))
+                (const 0))
+           (set (reg h-gr (add (index-of expr1) (const 2)))
+                (const 0))
+           (set (reg h-gr (add (index-of expr1) (const 3)))
+                (const 0))))
+
+(define-pmacro (move-op mnemonic opcode-op opcode2-op sem-op semlit-op)
+  (begin
+    (dni mnemonic
+        (.str mnemonic " reg")
+        ()
+        (.str mnemonic " $src1, $dst")
+        (+ opcode-op dst lit2 M3_0 M2_1 M1_0 opcode2-op ZERO_0 src1)
+        (sem-op dst src1)
+        ()
+    )
+    (dni (.sym mnemonic "1")
+        (.str mnemonic " lit")
+        ()
+        (.str mnemonic " $lit1, $dst")
+        (+ opcode-op dst lit2 M3_0 M2_1 M1_1 opcode2-op ZERO_0 lit1)
+        (semlit-op dst lit1)
+        ()
+    )
+  )
+)
+
+(move-op mov OPCODE_5C OPCODE2_C mov-expr mov-expr)
+(move-op movl OPCODE_5D OPCODE2_C movl-expr movllit-expr)
+(move-op movt OPCODE_5E OPCODE2_C movt-expr movtlit-expr)
+(move-op movq OPCODE_5F OPCODE2_C movq-expr movqlit-expr)
+
+; ??? This is very incomplete.  This does not handle src1 or src2 as literals.
+; This doesn't implement any of the effects of the instruction.
+(dni modpc "modpc"
+     ()
+     "modpc $src1, $src2, $dst"
+     (+ OPCODE_65 dst src1 M3_0 M2_0 M1_0 OPCODE2_5 ZERO_0 src2)
+     (set dst src2)
+     ()
+)
+
+; ??? This is very incomplete.  This does not handle src1 or src2 as literals.
+; This doesn't implement any of the effects of the instruction.
+(dni modac "modac"
+     ()
+     "modac $src1, $src2, $dst"
+     (+ OPCODE_64 dst src1 M3_0 M2_0 M1_0 OPCODE2_5 ZERO_0 src2)
+     (set dst src2)
+     ()
+)
+
+; ??? Incomplete.  Only handles 8 of the 10 addressing modes.
+; Does not handle sign/zero extend operations.  Does not handle
+; different modes.
+
+; ??? should verify multi-word reg alignment.
+
+; ??? index-index scale disasssembles wrong
+
+; ??? See also the store-op macro below.
+
+(define-pmacro (lda-expr expr1 expr2)
+  (set expr1 expr2))
+
+(define-pmacro (ld-expr expr1 expr2)
+  (set expr1 (mem WI expr2)))
+(define-pmacro (ldob-expr expr1 expr2)
+  (set expr1 (mem UQI expr2)))
+(define-pmacro (ldos-expr expr1 expr2)
+  (set expr1 (mem UHI expr2)))
+(define-pmacro (ldib-expr expr1 expr2)
+  (set expr1 (mem QI expr2)))
+(define-pmacro (ldis-expr expr1 expr2)
+  (set expr1 (mem HI expr2)))
+(define-pmacro (ldl-expr expr1 expr2)
+  (sequence ((WI temp) (SI dregno))
+           ; ??? Workaround cgen s-i-o-o bug.
+           (set dregno (ifield f-srcdst))
+           (set temp expr2)
+           (set expr1 (mem WI temp))
+           (set (reg h-gr (add (index-of expr1) (const 1)))
+                (mem WI (add temp (const 4))))))
+(define-pmacro (ldt-expr expr1 expr2)
+  (sequence ((WI temp) (SI dregno))
+           ; ??? Workaround cgen s-i-o-o bug.
+           (set dregno (ifield f-srcdst))
+           (set temp expr2)
+           (set expr1 (mem WI temp))
+           (set (reg h-gr (add (index-of expr1) (const 1)))
+                (mem WI (add temp (const 4))))
+           (set (reg h-gr (add (index-of expr1) (const 2)))
+                (mem WI (add temp (const 8))))))
+(define-pmacro (ldq-expr expr1 expr2)
+  (sequence ((WI temp) (SI dregno))
+           ; ??? Workaround cgen s-i-o-o bug.
+           (set dregno (ifield f-srcdst))
+           ; Evaluate the address first, for correctness, in case an address
+           ; reg will be loaded into.  Also, makes the simulator faster.
+           (set temp expr2)
+           (set expr1 (mem WI temp))
+           (set (reg h-gr (add (index-of expr1) (const 1)))
+                (mem WI (add temp (const 4))))
+           (set (reg h-gr (add (index-of expr1) (const 2)))
+                (mem WI (add temp (const 8))))
+           (set (reg h-gr (add (index-of expr1) (const 3)))
+                (mem WI (add temp (const 12))))))
+
+(define-pmacro (load-op suffix opcode-op sem-op)
+  (begin
+    (dni (.sym ld suffix -offset) (.str "ld" suffix "-offset")
+        ()
+        (.str "ld" suffix " $offset, $dst")
+        (+ opcode-op dst abase MODEA_OFFSET ZEROA_0 offset)
+        (sem-op dst offset)
+        ()
+    )
+    (dni (.sym ld suffix -indirect-offset)
+        (.str "ld" suffix "-indirect-offset")
+        ()
+        (.str "ld" suffix " $offset($abase), $dst")
+        (+ opcode-op dst abase MODEA_INDIRECT-OFFSET ZEROA_0 offset)
+        (sem-op dst (add offset abase))
+        ()
+    )
+    (dni (.sym ld suffix -indirect) (.str "ld" suffix "-indirect")
+        ()
+        (.str "ld" suffix " ($abase), $dst")
+        (+ opcode-op dst abase MODEB_INDIRECT scale ZEROB_0 index)
+        (sem-op dst abase)
+        ()
+    )
+    (dni (.sym ld suffix -indirect-index) (.str "ld" suffix "-indirect-index")
+        ()
+        (.str "ld" suffix " ($abase)[$index*S$scale], $dst")
+        (+ opcode-op dst abase MODEB_INDIRECT-INDEX scale ZEROB_0 index)
+        (sem-op dst (add abase (mul index (sll (const 1) scale))))
+        ()
+    )
+    (dni (.sym ld suffix -disp) (.str "ld" suffix "-disp")
+        ()
+        (.str "ld" suffix " $optdisp, $dst")
+        (+ opcode-op dst abase MODEB_DISP scale ZEROB_0 index optdisp)
+        (sem-op dst optdisp)
+        ()
+    )
+    (dni (.sym ld suffix -indirect-disp) (.str "ld" suffix "-indirect-disp")
+        ()
+        (.str "ld" suffix " $optdisp($abase), $dst")
+        (+ opcode-op dst abase MODEB_INDIRECT-DISP scale ZEROB_0 index optdisp)
+        (sem-op dst (add optdisp abase))
+        ()
+    )
+    (dni (.sym ld suffix -index-disp) (.str "ld" suffix "-index-disp")
+        ()
+        (.str "ld" suffix " $optdisp[$index*S$scale], $dst")
+        (+ opcode-op dst abase MODEB_INDEX-DISP scale ZEROB_0 index optdisp)
+        (sem-op dst (add optdisp (mul index (sll (const 1) scale))))
+        ()
+    )
+    (dni (.sym ld suffix -indirect-index-disp)
+        (.str "ld" suffix "-indirect-index-disp")
+        ()
+        (.str "ld" suffix " $optdisp($abase)[$index*S$scale], $dst")
+        (+ opcode-op dst abase MODEB_INDIRECT-INDEX-DISP scale ZEROB_0 index optdisp)
+        (sem-op dst (add optdisp (add abase
+                                      (mul index (sll (const 1) scale)))))
+        ()
+    )
+  )
+)
+
+(load-op "a" OPCODE_8C lda-expr)
+
+(load-op ""  OPCODE_90 ld-expr)
+(load-op "ob" OPCODE_80 ldob-expr)
+(load-op "os" OPCODE_88 ldos-expr)
+(load-op "ib" OPCODE_C0 ldib-expr)
+(load-op "is" OPCODE_C8 ldis-expr)
+(load-op "l" OPCODE_98 ldl-expr)
+(load-op "t" OPCODE_A0 ldt-expr)
+(load-op "q" OPCODE_B0 ldq-expr)
+
+; ??? Incomplete.  This is a near duplicate of the above load-op macro.
+
+; ??? For efficiency, should eval the address only once.  See the load patterns
+; above.
+
+(define-pmacro (st-expr expr1 expr2)
+  (set (mem WI expr1) expr2))
+(define-pmacro (stob-expr expr1 expr2)
+  (set (mem QI expr1) expr2))
+(define-pmacro (stos-expr expr1 expr2)
+  (set (mem HI expr1) expr2))
+(define-pmacro (stl-expr expr1 expr2)
+  (sequence ((SI sregno))
+           ; ??? Workaround cgen s-i-o-o bug.
+           (set sregno (ifield f-srcdst))
+           (set (mem WI expr1) expr2)
+           (set (mem WI (add expr1 (const 4)))
+                (reg h-gr (add (index-of expr2) (const 1))))))
+(define-pmacro (stt-expr expr1 expr2)
+  (sequence ((SI sregno))
+           ; ??? Workaround cgen s-i-o-o bug.
+           (set sregno (ifield f-srcdst))
+           (set (mem WI expr1) expr2)
+           (set (mem WI (add expr1 (const 4)))
+                (reg h-gr (add (index-of expr2) (const 1))))
+           (set (mem WI (add expr1 (const 8)))
+                (reg h-gr (add (index-of expr2) (const 2))))))
+(define-pmacro (stq-expr expr1 expr2)
+  (sequence ((SI sregno))
+           ; ??? Workaround cgen s-i-o-o bug.
+           (set sregno (ifield f-srcdst))
+           (set (mem WI expr1) expr2)
+           (set (mem WI (add expr1 (const 4)))
+                (reg h-gr (add (index-of expr2) (const 1))))
+           (set (mem WI (add expr1 (const 8)))
+                (reg h-gr (add (index-of expr2) (const 2))))
+           (set (mem WI (add expr1 (const 12)))
+                (reg h-gr (add (index-of expr2) (const 3))))))
+
+(define-pmacro (store-op suffix opcode-op sem-op)
+  (begin
+    (dni (.sym st suffix -offset) (.str "st" suffix "-offset")
+        ()
+        (.str "st" suffix " $st_src, $offset")
+        (+ opcode-op st_src abase MODEA_OFFSET ZEROA_0 offset)
+        (sem-op offset st_src)
+        ()
+    )
+    (dni (.sym st suffix -indirect-offset)
+        (.str "st" suffix "-indirect-offset")
+        ()
+        (.str "st" suffix " $st_src, $offset($abase)")
+        (+ opcode-op st_src abase MODEA_INDIRECT-OFFSET ZEROA_0 offset)
+        (sem-op (add offset abase) st_src)
+        ()
+    )
+    (dni (.sym st suffix -indirect) (.str "st" suffix "-indirect")
+        ()
+        (.str "st" suffix " $st_src, ($abase)")
+        (+ opcode-op st_src abase MODEB_INDIRECT scale ZEROB_0 index)
+        (sem-op abase st_src)
+        ()
+    )
+    (dni (.sym st suffix -indirect-index) (.str "st" suffix "-indirect-index")
+        ()
+        (.str "st" suffix " $st_src, ($abase)[$index*S$scale]")
+        (+ opcode-op st_src abase MODEB_INDIRECT-INDEX scale ZEROB_0 index)
+        (sem-op (add abase (mul index (sll (const 1) scale))) st_src)
+        ()
+    )
+    (dni (.sym st suffix -disp) (.str "st" suffix "-disp")
+        ()
+        (.str "st" suffix " $st_src, $optdisp")
+        (+ opcode-op st_src abase MODEB_DISP scale ZEROB_0 index optdisp)
+        (sem-op optdisp st_src)
+        ()
+    )
+    (dni (.sym st suffix -indirect-disp) (.str "st" suffix "-indirect-disp")
+        ()
+        (.str "st" suffix " $st_src, $optdisp($abase)")
+        (+ opcode-op st_src abase MODEB_INDIRECT-DISP scale ZEROB_0 index optdisp)
+        (sem-op (add optdisp abase) st_src)
+        ()
+    )
+    (dni (.sym st suffix -index-disp) (.str "st" suffix "-index-disp")
+        ()
+        (.str "st" suffix " $st_src, $optdisp[$index*S$scale")
+        (+ opcode-op st_src abase MODEB_INDEX-DISP scale ZEROB_0 index optdisp)
+        (sem-op (add optdisp (mul index (sll (const 1) scale))) st_src)
+        ()
+    )
+    (dni (.sym st suffix -indirect-index-disp)
+        (.str "st" suffix "-indirect-index-disp")
+        ()
+        (.str "st" suffix " $st_src, $optdisp($abase)[$index*S$scale]")
+        (+ opcode-op st_src abase MODEB_INDIRECT-INDEX-DISP scale ZEROB_0 index optdisp)
+        (sem-op (add optdisp (add abase (mul index (sll (const 1) scale))))
+                st_src)
+        ()
+    )
+  )
+)
+
+(store-op "" OPCODE_92 st-expr)
+(store-op "ob" OPCODE_82 stob-expr)
+(store-op "os" OPCODE_8A stos-expr)
+(store-op "l" OPCODE_9A stl-expr)
+(store-op "t" OPCODE_A2 stt-expr)
+(store-op "q" OPCODE_B2 stq-expr)
+
+; ??? Incomplete, does not set condition code register.
+
+; ??? Without these functions, I end up with a call to the undefined
+; function EQUSI, because br_lit1 is an unsigned field.  Should be a better
+; way to solve this.
+
+(define-pmacro (eq-expr expr1 expr2) (eq WI expr1 expr2))
+(define-pmacro (ne-expr expr1 expr2) (ne WI expr1 expr2))
+(define-pmacro (ltu-expr expr1 expr2) (ltu UWI expr1 expr2))
+(define-pmacro (leu-expr expr1 expr2) (leu UWI expr1 expr2))
+(define-pmacro (gtu-expr expr1 expr2) (gtu UWI expr1 expr2))
+(define-pmacro (geu-expr expr1 expr2) (geu UWI expr1 expr2))
+(define-pmacro (lt-expr expr1 expr2) (lt WI expr1 expr2))
+(define-pmacro (le-expr expr1 expr2) (le WI expr1 expr2))
+(define-pmacro (gt-expr expr1 expr2) (gt WI expr1 expr2))
+(define-pmacro (ge-expr expr1 expr2) (ge WI expr1 expr2))
+
+; ??? Does not handle shifts greater than 32 correctly.
+
+(define-pmacro (bbc-expr expr1 expr2)
+  (eq WI (and (sll (const 1) expr1) expr2) (const 0)))
+(define-pmacro (bbs-expr expr1 expr2)
+  (ne WI (and (sll (const 1) expr1) expr2) (const 0)))
+
+(define-pmacro (cmp-op mnemonic opcode-op sem-op)
+  (begin
+    (dni (.sym mnemonic -reg)
+        (.str mnemonic " reg")
+        ()
+        (.str mnemonic " $br_src1, $br_src2, $br_disp")
+        (+ opcode-op br_src1 br_src2 BR_M1_0 br_disp BR_ZERO_0)
+        (if (sem-op br_src1 br_src2) (set pc br_disp))
+        ()
+    )
+    (dni (.sym mnemonic -lit)
+        (.str mnemonic " lit")
+        ()
+        (.str mnemonic " $br_lit1, $br_src2, $br_disp")
+        (+ opcode-op br_lit1 br_src2 BR_M1_1 br_disp BR_ZERO_0)
+        (if (sem-op br_lit1 br_src2) (set pc br_disp))
+        ()
+    )
+  )
+)
+
+(cmp-op "cmpobe" OPCODE_32 eq-expr)
+(cmp-op "cmpobne" OPCODE_35 ne-expr)
+(cmp-op "cmpobl" OPCODE_34 ltu-expr)
+(cmp-op "cmpoble" OPCODE_36 leu-expr)
+(cmp-op "cmpobg" OPCODE_31 gtu-expr)
+(cmp-op "cmpobge" OPCODE_33 geu-expr)
+
+(cmp-op "cmpibe" OPCODE_3A eq-expr)
+(cmp-op "cmpibne" OPCODE_3D ne-expr)
+(cmp-op "cmpibl" OPCODE_3C lt-expr)
+(cmp-op "cmpible" OPCODE_3E le-expr)
+(cmp-op "cmpibg" OPCODE_39 gt-expr)
+(cmp-op "cmpibge" OPCODE_3B ge-expr)
+
+(cmp-op "bbc" OPCODE_30 bbc-expr)
+(cmp-op "bbs" OPCODE_37 bbs-expr)
+
+; ??? This is a near copy of alu-op, but without the dst field.
+; ??? Should create fake operands instead of using h-cc.
+; ??? M3 can be either 0 or 1.  We only handle a value of 1 here.
+
+; ??? The else clause if not optional.
+
+(define-pmacro (cmpi-expr expr1 expr2)
+  (cond WI
+   ((lt WI expr1 expr2) (const 4))
+   ((eq WI expr1 expr2) (const 2))
+   ; gt: WI
+   (else (const 1))))
+(define-pmacro (cmpo-expr expr1 expr2)
+  (cond WI
+   ((ltu UWI expr1 expr2) (const 4))
+   ((eq  WI expr1 expr2) (const 2))
+   ; gtu: UWI
+   (else (const 1))))
+
+(define-pmacro (cc-op mnemonic opcode-op opcode2-op sem-op)
+  (begin
+    (dni mnemonic
+        (.str mnemonic " reg/reg")
+        ()
+        (.str mnemonic " $src1, $src2")
+        (+ opcode-op dst src2 M3_1 M2_0 M1_0 opcode2-op ZERO_0 src1)
+        (set (reg h-cc 0) (sem-op src1 src2))
+        ()
+    )
+    (dni (.sym mnemonic "1")
+        (.str mnemonic " lit/reg")
+        ()
+        (.str mnemonic " $lit1, $src2")
+        (+ opcode-op dst src2 M3_1 M2_0 M1_1 opcode2-op ZERO_0 lit1)
+        (set (reg h-cc 0) (sem-op lit1 src2))
+        ()
+    )
+    (dni (.sym mnemonic "2")
+        (.str mnemonic " reg/lit")
+        ()
+        (.str mnemonic " $src1, $lit2")
+        (+ opcode-op dst lit2 M3_1 M2_1 M1_0 opcode2-op ZERO_0 src1)
+        (set (reg h-cc 0) (sem-op src1 lit2))
+        ()
+    )
+    (dni (.sym mnemonic "3")
+        (.str mnemonic " lit/lit")
+        ()
+        (.str mnemonic " $lit1, $lit2")
+        (+ opcode-op dst lit2 M3_1 M2_1 M1_1 opcode2-op ZERO_0 lit1)
+        (set (reg h-cc 0) (sem-op lit1 lit2))
+        ()
+    )
+  )
+)
+
+(cc-op "cmpi" OPCODE_5A OPCODE2_1 cmpi-expr)
+(cc-op "cmpo" OPCODE_5A OPCODE2_0 cmpo-expr)
+
+; ??? The M1 field should be ignored.
+
+(define-pmacro (testno-expr)
+  (eq WI (reg h-cc 0) (const 0)))
+(define-pmacro (testg-expr)
+  (ne WI (and (reg h-cc 0) (const 1)) (const 0)))
+(define-pmacro (teste-expr)
+  (ne WI (and (reg h-cc 0) (const 2)) (const 0)))
+(define-pmacro (testge-expr)
+  (ne WI (and (reg h-cc 0) (const 3)) (const 0)))
+(define-pmacro (testl-expr)
+  (ne WI (and (reg h-cc 0) (const 4)) (const 0)))
+(define-pmacro (testne-expr)
+  (ne WI (and (reg h-cc 0) (const 5)) (const 0)))
+(define-pmacro (testle-expr)
+  (ne WI (and (reg h-cc 0) (const 6)) (const 0)))
+(define-pmacro (testo-expr)
+  (ne WI (and (reg h-cc 0) (const 7)) (const 0)))
+
+
+(define-pmacro (test-op mnemonic opcode-op sem-op)
+  (dni (.sym mnemonic -reg)
+       (.str mnemonic " reg")
+       ()
+       (.str mnemonic " $br_src1")
+       (+ opcode-op br_src1 br_src2 BR_M1_0 br_disp BR_ZERO_0)
+       (set br_src1 (sem-op))
+       ()
+  )
+)
+
+(test-op "testno" OPCODE_20 testno-expr)
+(test-op "testg" OPCODE_21 testg-expr)
+(test-op "teste" OPCODE_22 teste-expr)
+(test-op "testge" OPCODE_23 testge-expr)
+(test-op "testl" OPCODE_24 testl-expr)
+(test-op "testne" OPCODE_25 testne-expr)
+(test-op "testle" OPCODE_26 testle-expr)
+(test-op "testo" OPCODE_27 testo-expr)
+
+(define-pmacro (branch-op mnemonic opcode-op sem-op)
+  (dni (.sym mnemonic) (.str mnemonic)
+       ()
+       (.str mnemonic " $ctrl_disp")
+       (+ opcode-op ctrl_disp CTRL_ZERO_0)
+       (if (sem-op) (set pc ctrl_disp))
+       ()
+  )
+)
+
+(branch-op "bno" OPCODE_10 testno-expr)
+(branch-op "bg" OPCODE_11 testg-expr)
+(branch-op "be" OPCODE_12 teste-expr)
+(branch-op "bge" OPCODE_13 testge-expr)
+(branch-op "bl" OPCODE_14 testl-expr)
+(branch-op "bne" OPCODE_15 testne-expr)
+(branch-op "ble" OPCODE_16 testle-expr)
+(branch-op "bo" OPCODE_17 testo-expr)
+
+(dni b "b"
+     ()
+     "b $ctrl_disp"
+     (+ OPCODE_08 ctrl_disp CTRL_ZERO_0)
+     (set pc ctrl_disp)
+     ()
+)
+
+; ??? Incomplete.  Only handles 5 of 10 addressing modes.
+; Should be a macro.
+
+(dni bx-indirect-offset "bx-indirect-offset"
+     ()
+     "bx $offset($abase)"
+     (+ OPCODE_84 dst abase MODEA_INDIRECT-OFFSET ZEROA_0 offset)
+     (set pc (add offset abase))
+     ()
+)
+
+(dni bx-indirect "bx-indirect"
+     ()
+     "bx ($abase)"
+     (+ OPCODE_84 dst abase MODEB_INDIRECT scale ZEROB_0 index)
+     (set pc abase)
+     ()
+)
+
+(dni bx-indirect-index "bx-indirect-index"
+     ()
+     "bx ($abase)[$index*S$scale]"
+     (+ OPCODE_84 dst abase MODEB_INDIRECT-INDEX scale ZEROB_0 index)
+     (set pc (add abase (mul index (sll (const 1) scale))))
+     ()
+)
+
+(dni bx-disp "bx-disp"
+     ()
+     "bx $optdisp"
+     (+ OPCODE_84 dst abase MODEB_DISP scale ZEROB_0 index optdisp)
+     (set pc optdisp)
+     ()
+)
+
+(dni bx-indirect-disp "bx-indirect-disp"
+     ()
+     "bx $optdisp($abase)"
+     (+ OPCODE_84 dst abase MODEB_INDIRECT-DISP scale ZEROB_0 index optdisp)
+     (set pc (add optdisp abase))
+     ()
+)
+
+; ??? Incomplete.  Only handles 3 of 10 addressing modes.  Only handles
+; one local register set.
+
+; ??? If we don't want all of the set-quiet calls, then we need to increase
+; SIZE_TRACE_BUF in sim/common/cgen-trace.c.
+
+(dni callx-disp "callx-disp"
+     ()
+     "callx $optdisp"
+     (+ OPCODE_86 dst abase MODEB_DISP scale ZEROB_0 index optdisp)
+     (sequence ((WI temp))
+              (set temp (and (add (reg h-gr 1) (const 63)) (inv (const 63))))
+              ; ??? This doesn't seem right.  Why do I have to add 8?.
+              (set (reg h-gr 2) (add pc (const 8)))
+              ; Save current local reg set on stack.
+              (set-quiet (mem WI (add (reg h-gr 31) (const 0)))
+                         (reg h-gr 0))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 4)))
+                         (reg h-gr 1))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 8)))
+                         (reg h-gr 2))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 12)))
+                         (reg h-gr 3))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 16))) 
+                         (reg h-gr 4))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 20)))
+                         (reg h-gr 5))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 24)))
+                         (reg h-gr 6))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 28)))
+                         (reg h-gr 7))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 32)))
+                         (reg h-gr 8))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 36)))
+                         (reg h-gr 9))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 40)))
+                         (reg h-gr 10))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 44)))
+                         (reg h-gr 11))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 48)))
+                         (reg h-gr 12))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 52)))
+                         (reg h-gr 13))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 56)))
+                         (reg h-gr 14))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 60)))
+                         (reg h-gr 15))
+              (set pc optdisp)
+              ; Allocate new local reg set.
+              (set-quiet (reg h-gr 0) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 1) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 2) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 3) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 4) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 5) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 6) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 7) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 8) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 9) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 10) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 11) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 12) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 13) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 14) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 15) (const #xDEADBEEF))
+              (set (reg h-gr 0) (reg h-gr 31))
+              (set (reg h-gr 31) temp)
+              (set (reg h-gr 1) (add temp (const 64))))
+     ()
+)
+
+; ??? This should be macro-ized somehow.
+
+; ??? This adds 4 to pc.  The above pattern adds 8.
+
+(dni callx-indirect "callx-indirect"
+     ()
+     "callx ($abase)"
+     (+ OPCODE_86 dst abase MODEB_INDIRECT scale ZEROB_0 index)
+     (sequence ((WI temp))
+              (set temp (and (add (reg h-gr 1) (const 63)) (inv (const 63))))
+              ; ??? This doesn't seem right.  Why do I have to add 4?.
+              (set (reg h-gr 2) (add pc (const 4)))
+              ; Save current local reg set on stack.
+              (set-quiet (mem WI (add (reg h-gr 31) (const 0)))
+                         (reg h-gr 0))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 4)))
+                         (reg h-gr 1))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 8)))
+                         (reg h-gr 2))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 12)))
+                         (reg h-gr 3))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 16)))
+                         (reg h-gr 4))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 20)))
+                         (reg h-gr 5))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 24)))
+                         (reg h-gr 6))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 28)))
+                         (reg h-gr 7))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 32)))
+                         (reg h-gr 8))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 36)))
+                         (reg h-gr 9))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 40)))
+                         (reg h-gr 10))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 44)))
+                         (reg h-gr 11))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 48)))
+                         (reg h-gr 12))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 52)))
+                         (reg h-gr 13))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 56)))
+                         (reg h-gr 14))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 60)))
+                         (reg h-gr 15))
+              ; We do this first, because abase might be a local reg.
+              (set pc abase)
+              ; Allocate new local reg set.
+              (set-quiet (reg h-gr 0) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 1) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 2) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 3) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 4) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 5) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 6) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 7) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 8) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 9) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 10) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 11) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 12) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 13) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 14) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 15) (const #xDEADBEEF))
+              (set (reg h-gr 0) (reg h-gr 31))
+              (set (reg h-gr 31) temp)
+              (set (reg h-gr 1) (add temp (const 64))))
+     ()
+)
+
+; ??? This adds 4 to pc.
+
+; ??? This should be macro-ized somehow.
+
+(dni callx-indirect-offset "callx-indirect-offset"
+     ()
+     "callx $offset($abase)"
+     (+ OPCODE_86 dst abase MODEA_INDIRECT-OFFSET ZEROA_0 offset)
+     (sequence ((WI temp))
+              (set temp (and (add (reg h-gr 1) (const 63)) (inv (const 63))))
+              ; ??? This doesn't seem right.  Why do I have to add 4?.
+              (set (reg h-gr 2) (add pc (const 4)))
+              ; Save current local reg set on stack.
+              (set-quiet (mem WI (add (reg h-gr 31) (const 0)))
+                         (reg h-gr 0))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 4)))
+                         (reg h-gr 1))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 8)))
+                         (reg h-gr 2))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 12)))
+                         (reg h-gr 3))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 16)))
+                         (reg h-gr 4))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 20)))
+                         (reg h-gr 5))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 24)))
+                         (reg h-gr 6))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 28)))
+                         (reg h-gr 7))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 32)))
+                         (reg h-gr 8))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 36)))
+                         (reg h-gr 9))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 40)))
+                         (reg h-gr 10))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 44)))
+                         (reg h-gr 11))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 48)))
+                         (reg h-gr 12))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 52)))
+                         (reg h-gr 13))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 56)))
+                         (reg h-gr 14))
+              (set-quiet (mem WI (add (reg h-gr 31) (const 60)))
+                         (reg h-gr 15))
+              ; We do this first, because abase might be a local reg.
+              (set pc (add offset abase))
+              ; Allocate new local reg set.
+              (set-quiet (reg h-gr 0) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 1) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 2) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 3) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 4) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 5) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 6) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 7) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 8) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 9) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 10) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 11) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 12) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 13) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 14) (const #xDEADBEEF))
+              (set-quiet (reg h-gr 15) (const #xDEADBEEF))
+              (set (reg h-gr 0) (reg h-gr 31))
+              (set (reg h-gr 31) temp)
+              (set (reg h-gr 1) (add temp (const 64))))
+     ()
+)
+
+; ??? Incomplete.  Does not handle return status in PFP.
+
+(dni ret "ret"
+     ()
+     "ret"
+     (+ OPCODE_0A ctrl_disp CTRL_ZERO_0)
+     (sequence ()
+              (set (reg h-gr 31) (reg h-gr 0))
+              (set-quiet (reg h-gr 0)
+                         (mem WI (add (reg h-gr 31) (const 0))))
+              (set-quiet (reg h-gr 1)
+                         (mem WI (add (reg h-gr 31) (const 4))))
+              (set-quiet (reg h-gr 2)
+                         (mem WI (add (reg h-gr 31) (const 8))))
+              (set-quiet (reg h-gr 3)
+                         (mem WI (add (reg h-gr 31) (const 12))))
+              (set-quiet (reg h-gr 4)
+                         (mem WI (add (reg h-gr 31) (const 16))))
+              (set-quiet (reg h-gr 5)
+                         (mem WI (add (reg h-gr 31) (const 20))))
+              (set-quiet (reg h-gr 6)
+                         (mem WI (add (reg h-gr 31) (const 24))))
+              (set-quiet (reg h-gr 7)
+                         (mem WI (add (reg h-gr 31) (const 28))))
+              (set-quiet (reg h-gr 8)
+                         (mem WI (add (reg h-gr 31) (const 32))))
+              (set-quiet (reg h-gr 9)
+                         (mem WI (add (reg h-gr 31) (const 36))))
+              (set-quiet (reg h-gr 10)
+                         (mem WI (add (reg h-gr 31) (const 40))))
+              (set-quiet (reg h-gr 11)
+                         (mem WI (add (reg h-gr 31) (const 44))))
+              (set-quiet (reg h-gr 12)
+                         (mem WI (add (reg h-gr 31) (const 48))))
+              (set-quiet (reg h-gr 13)
+                         (mem WI (add (reg h-gr 31) (const 52))))
+              (set-quiet (reg h-gr 14)
+                         (mem WI (add (reg h-gr 31) (const 56))))
+              (set-quiet (reg h-gr 15)
+                         (mem WI (add (reg h-gr 31) (const 60))))
+              (set pc (reg h-gr 2)))
+     ()
+)
+
+; ??? Incomplete, does not do any system operations.
+
+; ??? Should accept either reg or lit for src1.
+
+; ??? M3/M2 should not matter.
+
+(dni calls "calls"
+     ()
+     "calls $src1"
+     (+ OPCODE_66 dst src2 M3_1 M2_1 M1_0 OPCODE2_0 ZERO_0 src1)
+     (set WI pc (c-call WI "i960_trap" pc src1))
+     ()
+)
+
+; ??? Incomplete, does not do any system operations.
+
+; ??? M3/M2/M1 should not matter.
+
+(dni fmark "fmark"
+     ()
+     "fmark"
+     (+ OPCODE_66 dst src2 M3_1 M2_1 M1_1 OPCODE2_C ZERO_0 src1)
+     (set WI pc (c-call WI "i960_breakpoint" pc))
+     ()
+)
+
+; ??? Incomplete.  This doesn't actually have to do anything, because we
+; currently support only one set of local registers.
+
+; ??? The settings of the M1/2/3 bits shouldn't matter.
+
+(dni flushreg "flushreg"
+     ()
+     "flushreg"
+     (+ OPCODE_66 dst src2 M3_1 M2_1 M1_1 OPCODE2_D ZERO_0 src1)
+     (nop)
+     ()
+)
diff --git a/cgen/i960.opc b/cgen/i960.opc
new file mode 100644 (file)
index 0000000..acfc53d
--- /dev/null
@@ -0,0 +1,32 @@
+/* Intel 80960 opcode support.  -*- C -*-
+   Copyright (C) 2000 Red Hat, Inc.
+   This file is part of CGEN.  */
+
+/* This file is an addendum to i960.cpu.  Heavy use of C code isn't
+   appropriate in .cpu files, so it resides here.  This especially applies
+   to assembly/disassembly where parsing/printing can be quite involved.
+   Such things aren't really part of the specification of the cpu, per se,
+   so .cpu files provide the general framework and .opc files handle the
+   nitty-gritty details as necessary.
+
+   Each section is delimited with start and end markers.
+
+   <arch>-opc.h additions use: "-- opc.h"
+   <arch>-opc.c additions use: "-- opc.c"
+   <arch>-asm.c additions use: "-- asm.c"
+   <arch>-dis.c additions use: "-- dis.c"
+   <arch>-ibd.h additions use: "-- ibd.h"
+*/
+\f
+/* -- opc.h */
+
+#undef CGEN_DIS_HASH_SIZE
+#define CGEN_DIS_HASH_SIZE 256
+#undef CGEN_DIS_HASH
+#define CGEN_DIS_HASH(buffer, value) ((unsigned char *) (buffer))[3]
+
+/* ??? Until cgen disassembler complete and functioning well, redirect back
+   to old disassembler.  */
+#define CGEN_PRINT_INSN(od, pc, info) print_insn_i960_orig (pc, info)
+
+/* -- */
diff --git a/cgen/ia32.cpu b/cgen/ia32.cpu
new file mode 100644 (file)
index 0000000..4f8e841
--- /dev/null
@@ -0,0 +1,917 @@
+; Intel IA32 CPU description.  -*- Scheme -*-
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+;
+; References:
+;
+; Intel486 Processor Family, Programmer's Reference Manual, Intel
+
+(include "simplify.inc")
+
+; define-arch must appear first
+
+(define-arch
+  (name ia32) ; name of cpu family
+  (comment "Intel IA32 (x86)")
+  (default-alignment unaligned)
+  (insn-lsb0? #t)
+  (machs i386 i486 pentium pentium-ii pentium-iii) ; ??? wip
+  (isas ia32) ; ??? separate 8086 isa?
+)
+
+; Attributes.
+
+; Instruction set parameters.
+
+(define-isa
+  (name ia32)
+
+  (default-insn-bitsize 8)
+
+  ; Number of bytes of insn we can initially fetch.
+  (base-insn-bitsize 8)
+
+  ; Used in computing bit numbers.
+  (default-insn-word-bitsize 32)
+
+  ; Initial bitnumbers to decode insns by.
+  (decode-assist (0 1 2 3 4 5 6 7))
+)
+\f
+; Cpu family definitions.
+
+(define-cpu
+  ; cpu names must be distinct from the architecture name and machine names.
+  ; The "b" suffix stands for "base" and is the convention.
+  ; The "f" suffix stands for "family" and is the convention.
+  (name ia32bf)
+  (comment "Intel x86 base family")
+  (endian little)
+  (word-bitsize 32)
+)
+
+(define-mach
+  (name pentium-ii)
+  (comment "Pentium II")
+  (cpu ia32bf)
+)
+\f
+; Model descriptions.
+
+; The meaning of this value is wip but at the moment it's intended to describe
+; the implementation (i.e. what -mtune=foo does in sparc gcc).
+; ??? This is intended to be redesigned later.
+
+(define-model
+  (name pentium-ii)
+  (comment "Pentium II model")
+  (mach pentium-ii)
+  (unit u-exec "Execution Unit" ()
+       1 1 ; issue done
+       () ; state
+       () ; inputs
+       () ; outputs
+       () ; profile action (default)
+       )
+)
+\f
+; Instruction fields.
+
+; There currently doesn't exist shorthand macros for CISC ISA's,
+; so define our own.
+; DIF: define-ia32-field
+; DNIF: define-normal-ia32-field
+
+(define-pmacro (dif x-name x-comment x-attrs x-word-offset x-word-length x-start x-length x-mode x-encode x-decode)
+  (define-ifield
+    (name x-name)
+    (comment x-comment)
+    (.splice attrs (.unsplice x-attrs))
+    (word-offset x-word-offset)
+    (word-length x-word-length)
+    (start x-start)
+    (length x-length)
+    (mode x-mode)
+    (encode x-encode)
+    (decode x-decode)
+    )
+)
+
+(define-pmacro (dnif x-name x-comment x-attrs x-word-offset x-word-length x-start x-length)
+  (dif x-name x-comment x-attrs x-word-offset x-word-length x-start x-length
+       UINT #f #f)
+)
+
+(dnif f-opcode "first insn byte" () 0 8 7 8)
+
+; The mod-r/m byte.
+(dnif f-mod "mod field of mod-r/m byte" () 8 8 7 2)
+(dnif f-reg/opcode "reg/opcode field of mod-r/m byte" () 8 8 5 3)
+(dnif f-r/m "r/m field of mod-r/m byte" () 8 8 2 3)
+(dsmf f-mod-r/m "entire mod-r/m byte" () (f-mod f-reg/opcode f-r/m))
+
+(dnif f-simm8  "signed 8 bit immediate"  () 8 8 7 8)
+(dnif f-simm16 "signed 16 bit immediate" () 8 16 15 16)
+(dnif f-simm32 "signed 32 bit immediate" () 8 32 31 32)
+
+(dnif f-disp8  "signed 8 bit displacement"  () 8 8 7 8)
+(dnif f-disp16 "signed 16 bit displacement" () 8 16 15 16)
+(dnif f-disp32 "signed 32 bit displacement" () 8 32 31 32)
+
+(dnif f-rel8  "signed 8 bit pc-relative displacement"  (PCREL-ADDR) 8 8 7 8)
+(dnif f-rel16 "signed 16 bit pc-relative displacement" (PCREL-ADDR) 8 16 15 16)
+(dnif f-rel32 "signed 32 bit pc-relative displacement" (PCREL-ADDR) 8 32 31 32)
+
+; The sib byte.
+(dnif f-sib-ss "sib scale size" () 16 8 7 2)
+(dnif f-sib-base "sib base reg" () 16 8 5 3)
+(dnif f-sib-index "sib index reg" () 16 8 2 3)
+(dsmf f-sib "entire sib byte" () (f-sib-ss f-sib-base f-sib-index))
+\f
+; Enums.
+
+(define-pmacro (build-hex2 num) (.hex num 2))
+
+; insn-opcode
+; "00" ... "FF"
+(define-normal-insn-enum insn-opcode "insn opcode enums" () OP_ f-opcode
+  (.map .upcase (.map build-hex2 (.iota 256)))
+)
+\f
+; Hardware pieces.
+; These entries list the elements of the raw hardware.
+; They're also used to provide tables and other elements of the assembly
+; language.
+;
+; ??? Sets of SP have extra-special semantics.
+
+(dnh h-pc "program counter" (PC PROFILE) (pc) () () ())
+
+(define-keyword
+  (name gr8-names)
+  (print-name h-gr8)
+  (prefix "%")
+  (values (al 0) (cl 1) (dl 2) (bl 3) (ah 4) (ch 5) (dh 6) (bh 7))
+)
+
+(define-hardware
+  (name h-gr8)
+  (comment "8 bit general registers")
+  (attrs VIRTUAL PROFILE)
+  (type register QI (8))
+  (indices extern-keyword gr8-names)
+  (get (index)
+       (if (lt index 4)
+          (reg QI h-gr index)
+          (bitfield (reg h-gr (sub index 4)) 15 8)))
+  (set (index newval)
+       (if (lt index 4)
+          (set (bitfield (reg h-gr index) 7 8) newval)
+          (set (bitfield (reg h-gr (sub index 4)) 15 8) newval)))
+)
+
+(define-keyword
+  (name gr16-names)
+  (print-name h-gr16)
+  (prefix "%")
+  (values (ax 0) (cx 1) (dx 2) (bx 3) (sp 4) (bp 5) (si 6) (di 7))
+)
+
+(define-hardware
+  (name h-gr16)
+  (comment "16 bit general registers")
+  (attrs VIRTUAL PROFILE)
+  (type register HI (8))
+  (indices extern-keyword gr16-names)
+  (get (index) (reg HI h-gr index))
+  (set (index newval) (set (bitfield (reg h-gr index) 15 16) newval))
+)
+
+(define-keyword
+  (name gr-names)
+  (print-name h-gr)
+  (prefix "%")
+  (values (eax 0) (ecx 1) (edx 2) (ebx 3) (esp 4) (ebp 5) (esi 6) (edi 7))
+)
+
+(define-hardware
+  (name h-gr)
+  (comment "general registers")
+  (attrs PROFILE CACHE-ADDR)
+  (type register SI (8))
+  (indices extern-keyword gr-names)
+)
+
+(dsh h-cf "carry flag"    () (register BI))
+(dsh h-sf "sign flag"     () (register BI))
+(dsh h-of "overflow flag" () (register BI))
+(dsh h-zf "zero flag"     () (register BI))
+\f
+; Instruction Operands.
+
+; M32R specific operand attributes:
+; - none yet
+
+; Some registers are refered to explicitly.
+; ??? Might eventually be worth defining them all, but for now we just
+; define the ones we need.
+; ??? Another way to do this is to use pmacros.
+
+(dnop al  "%al register"  () h-gr8 0)
+(dnop ax  "%ax register"  () h-gr16 0)
+(dnop eax "%eax register" () h-gr 0)
+
+; Registers specified in the Reg/Opcode field of the r/m byte.
+
+(dnop reg8  "8 bit register"  () h-gr8  f-reg/opcode)
+(dnop reg16 "16 bit register" () h-gr16 f-reg/opcode)
+(dnop reg32 "32 bit register" () h-gr f-reg/opcode)
+
+; Various numeric operands.
+
+(dnop simm8  "8 bit signed immediate"  () h-sint f-simm8)
+(dnop simm16 "16 bit signed immediate" () h-sint f-simm16)
+(dnop simm32 "32 bit signed immediate" () h-sint f-simm32)
+
+(dnop disp8  "8 bit displacement"  () h-sint f-disp8)
+(dnop disp16 "16 bit displacement" () h-sint f-disp16)
+(dnop disp32 "32 bit displacement" () h-sint f-disp32)
+
+(dnop rel8  "8 bit displacement"  () h-iaddr f-rel8)
+(dnop rel16 "16 bit displacement" () h-iaddr f-rel16)
+(dnop rel32 "32 bit displacement" () h-iaddr f-rel32)
+
+; The condition code registers.
+
+(dnop cf "carry flag"    () h-cf f-nil)
+(dnop sf "sign flag"     () h-sf f-nil)
+(dnop of "overflow flag" () h-of f-nil)
+(dnop zf "zero flag"     () h-zf f-nil)
+
+; ModRM support.
+
+(dnop r/m-reg8  "8 bit register in r/m field"  () h-gr8  f-r/m)
+(dnop r/m-reg16 "16 bit register in r/m field" () h-gr16 f-r/m)
+(dnop r/m-reg32 "32 bit register in r/m field" () h-gr f-r/m)
+
+(define-operand
+  (name mod-r/m-base-reg)
+  (comment "base register for mod-r/m addressing")
+  (mode SI)
+  (type h-gr)
+  (index f-r/m)
+)
+
+(define-operand
+  (name sib-base)
+  (comment "base register for sib addressing")
+  (mode SI)
+  (type h-gr)
+  (index f-sib-base)
+)
+
+(define-operand
+  (name sib-index)
+  (comment "index register for sib addressing")
+  (mode SI)
+  (type h-gr)
+  (index f-sib-index)
+)
+\f
+; The mod-r/m and sib ifields.
+; These are composed of several ifields and specify a set of choices
+; (addressing modes) to choose from.
+
+(define-pmacro (diff x-name x-comment x-attrs x-start x-length x-follows x-mode)
+  "Define an ia32 ifield that follows another ifield."
+  (define-ifield
+    (name x-name)
+    (comment x-comment)
+    (.splice attrs (.unsplice x-attrs))
+    (start x-start)
+    (length x-length)
+    (follows x-follows)
+    (mode x-mode)
+    )
+)
+
+; These must be defined before they're used and it makes sense to define
+; the operand with the ifield (rather than follow the usual convention of
+; defining all ifields first - not that that convention is necessarily the
+; best).
+
+(dnif f-disp8-@16 "signed 8 bit displacement at offset 16" () 16 8 7 8)
+(dnop disp8-@16   "signed 8 bit displacement at offset 16" () h-sint f-disp8-@16)
+
+(dnif f-disp32-@16 "signed 32 bit displacement at offset 16" () 16 32 31 32)
+(dnop disp32-@16   "signed 32 bit displacement at offset 16" () h-sint f-disp32-@16)
+
+(dnif f-disp32-@24 "signed 32 bit displacement at offset 24" () 24 32 31 32)
+(dnop disp32-@24   "signed 32 bit displacement at offset 24" () h-sint f-disp32-@24)
+
+; The sib operand, used by the mod-r/m operand.
+
+(dndo base+index*1 
+      SI
+      (sib-base sib-index)
+      "${sib-base}+${sib-index}"
+      f-sib
+      (+ (f-sib-ss 0) sib-base sib-index)
+      (andif (orif (ne f-mod 0)
+                  (ne f-sib-base 5))
+            (ne f-sib-index 4))
+      (add sib-base sib-index)
+      () ; no setter
+)
+
+(dndo base-1
+      SI
+      (sib-base)
+      "${sib-base}"
+      f-sib
+      (+ (f-sib-ss 0) sib-base (f-sib-index 4))
+      (orif (ne f-mod 0)
+           (ne f-sib-base 5))
+      sib-base
+      () ; no setter
+)
+
+(dndo index*1+disp32
+      SI
+      (sib-index disp32)
+      "${disp32-@24}(${sib-index})"
+      f-sib
+      (+ (f-sib-ss 0) (f-sib-base 5) sib-index disp32-@24)
+      (andif (eq f-mod 0)
+            (ne f-sib-index 4))
+      (add sib-index disp32-@24)
+      () ; no setter
+)
+
+(dndo disp32-1
+      SI
+      (disp32)
+      "${disp32-@24}"
+      f-sib
+      (+ (f-sib-ss 0) (f-sib-base 5) (f-sib-index 4) disp32-@24)
+      (eq f-mod 0)
+      disp32-@24
+      () ; no setter
+)
+
+(dndo base+index*2
+      SI
+      (sib-base sib-index)
+      "${sib-base}+${sib-index}*2"
+      f-sib
+      (+ (f-sib-ss 1) sib-base sib-index)
+      (andif (orif (ne f-mod 0)
+                  (ne f-sib-base 5))
+            (ne f-sib-index 4))
+      (add sib-base (mul sib-index 2))
+      () ; no setter
+)
+
+(dndo base-2
+      SI
+      (sib-base)
+      "${sib-base}"
+      f-sib
+      (+ (f-sib-ss 1) sib-base (f-sib-index 4))
+      ()
+      sib-base
+      () ; no setter
+)
+
+(dndo index*2+disp32
+      SI
+      (sib-index disp32)
+      "${disp32-@24}(${sib-index})"
+      f-sib
+      (+ (f-sib-ss 1) (f-sib-base 5) sib-index disp32-@24)
+      (andif (eq f-mod 0)
+            (ne f-sib-index 4))
+      (add (mul sib-index 2) disp32-@24)
+      () ; no setter
+)
+
+(dndo disp32-2
+      SI
+      (disp32)
+      "${disp32-@24}"
+      f-sib
+      (+ (f-sib-ss 1) (f-sib-base 5) (f-sib-index 4) disp32-@24)
+      (eq f-mod 0)
+      disp32-@24
+      () ; no setter
+)
+
+(dndo base+index*4
+      SI
+      (sib-base sib-index)
+      "${sib-base}+${sib-index}*4"
+      f-sib
+      (+ (f-sib-ss 2) sib-base sib-index)
+      (andif (orif (ne f-mod 0)
+                  (ne f-sib-base 5))
+            (ne f-sib-index 4))
+      (add sib-base (mul sib-index 4))
+      () ; no setter
+)
+
+(dndo base-4
+      SI
+      (sib-base)
+      "${sib-base}"
+      f-sib
+      (+ (f-sib-ss 2) sib-base (f-sib-index 4))
+      ()
+      sib-base
+      () ; no setter
+)
+
+(dndo index*4+disp32
+      SI
+      (sib-index disp32)
+      "${disp32-@24}(${sib-index})"
+      f-sib
+      (+ (f-sib-ss 2) (f-sib-base 5) sib-index disp32-@24)
+      (andif (eq f-mod 0)
+            (ne f-sib-index 4))
+      (add (mul sib-index 4) disp32-@24)
+      () ; no setter
+)
+
+(dndo disp32-4
+      SI
+      (disp32)
+      "${disp32-@24}"
+      f-sib
+      (+ (f-sib-ss 2) (f-sib-base 5) (f-sib-index 4) disp32-@24)
+      (eq f-mod 0)
+      disp32-@24
+      () ; no setter
+)
+
+(dndo base+index*8
+      SI
+      (sib-base sib-index)
+      "${sib-base}+${sib-index}*8"
+      f-sib
+      (+ (f-sib-ss 3) sib-base sib-index)
+      (andif (orif (ne f-mod 0)
+                  (ne f-sib-base 5))
+            (ne f-sib-index 4))
+      (add sib-base (mul sib-index 8))
+      () ; no setter
+)
+
+(dndo base-8
+      SI
+      (sib-base)
+      "${sib-base}"
+      f-sib
+      (+ (f-sib-ss 3) sib-base (f-sib-index 4))
+      ()
+      sib-base
+      () ; no setter
+)
+
+(dndo index*8+disp32
+      SI
+      (sib-index disp32)
+      "${disp32-@24}(${sib-index})"
+      f-sib
+      (+ (f-sib-ss 3) (f-sib-base 5) sib-index disp32-@24)
+      (andif (eq f-mod 0)
+            (ne f-sib-index 4))
+      (add (mul sib-index 8) disp32-@24)
+      () ; no setter
+)
+
+(dndo disp32-8
+      SI
+      (disp32)
+      "${disp32-@24}"
+      f-sib
+      (+ (f-sib-ss 3) (f-sib-base 5) (f-sib-index 4) disp32-@24)
+      (eq f-mod 0)
+      disp32-@24
+      () ; no setter
+)
+
+; Now define an "anyof" operand that puts it all together.
+
+(define-anyof-operand
+  (name sib)
+  (comment "base + scaled-index + displacement")
+  (mode SI)
+  ; Each choice must have the same base-ifield.
+  (choices base+index*1
+          base-1
+          index*1+disp32
+          disp32-1
+          base+index*2
+          base-2
+          index*2+disp32
+          disp32-2
+          base+index*4
+          base-4
+          index*4+disp32
+          disp32-4
+          base+index*8
+          base-8
+          index*8+disp32
+          disp32-8
+          )
+)
+
+; Additional ifields/operands used by the mod-r/m byte.
+; It seems cleaner to define the operand with its ifield so they are.
+; Maybe the rest should be organized similarily.
+; Also, the ones that "follow" other ifields must be defined after the latter
+; has been defined.
+
+(diff f-disp8-follows-sib "disp8 ifield after sib ifields"
+      () 7 8 sib INT
+)
+(dnop disp8-follows-sib "disp8 following sib"
+      () h-sint f-disp8-follows-sib
+)
+
+(diff f-disp32-follows-sib "disp32 ifield after sib ifields"
+      () 31 32 sib INT
+)
+(dnop disp32-follows-sib "disp32 following sib"
+      () h-sint f-disp32-follows-sib
+)
+
+; The complete mod-r/m operand, used by instructions.
+; ??? The [] bracketing is for clarity.  Match actual assembler later.
+; blah blah blah intel vs at&t blah blah blah
+
+(define-pmacro (define-mod-r/m-choices x-mode x-r/m-reg)
+  (begin
+    (dndo (.sym @reg- x-mode)
+         x-mode
+         (mod-r/m-base-reg)
+         "[${mod-r/m-base-reg}]"
+         f-mod-r/m
+         (+ (f-mod 0) mod-r/m-base-reg)
+         (andif (ne f-r/m 4) (ne f-r/m 5))
+         (mem x-mode mod-r/m-base-reg)
+         ()
+         )
+    (dndo (.sym @sib- x-mode)
+         x-mode
+         (sib)
+         "[$sib]"
+         f-mod-r/m
+         (+ (f-mod 0) (f-r/m 4) sib)
+         ()
+         (mem x-mode sib)
+         ()
+         )
+    (dndo (.sym @disp32- x-mode)
+         x-mode
+         (disp32-@16)
+         "[${disp32-@16}]"
+         f-mod-r/m
+         (+ (f-mod 0) (f-r/m 5) disp32-@16)
+         ()
+         (mem x-mode disp32-@16)
+         ()
+         )
+    (dndo (.sym @reg+disp8- x-mode)
+         x-mode
+         (mod-r/m-base-reg disp8)
+         "[${disp8-@16}(${mod-r/m-base-reg})]"
+         f-mod-r/m
+         (+ (f-mod 1) mod-r/m-base-reg disp8-@16)
+         (ne f-r/m 4)
+         (mem x-mode (add mod-r/m-base-reg disp8-@16))
+         ()
+         )
+    (dndo (.sym @sib+disp8- x-mode)
+         x-mode
+         (sib disp8-follows-sib)
+         "[${disp8-follows-sib}($sib)]"
+         f-mod-r/m
+         (+ (f-mod 1) (f-r/m 4) sib disp8-follows-sib)
+         ()
+         (mem x-mode (add sib disp8-follows-sib))
+         ()
+         )
+    (dndo (.sym @reg+disp32- x-mode)
+         x-mode
+         (mod-r/m-base-reg disp32)
+         "[${disp32-@16}(${mod-r/m-base-reg})]"
+         f-mod-r/m
+         (+ (f-mod 2) mod-r/m-base-reg disp32-@16)
+         (ne f-r/m 4)
+         (mem x-mode (add mod-r/m-base-reg disp32-@16))
+         ()
+         )
+    (dndo (.sym @sib+disp32- x-mode)
+         x-mode
+         (sib disp32-follows-sib)
+         "[${disp32-follows-sib}($sib)]"
+         f-mod-r/m
+         (+ (f-mod 2) (f-r/m 4) sib disp32-follows-sib)
+         ()
+         (mem x-mode (add sib disp32-follows-sib))
+         ()
+         )
+    (dndo (.sym reg- x-mode)
+         x-mode
+         (x-r/m-reg)
+         (.str "${" x-r/m-reg "}")
+         f-mod-r/m
+         (+ (f-mod 3) x-r/m-reg)
+         ()
+         x-r/m-reg
+         ()
+         )
+    )
+)
+
+(define-pmacro (define-mod-r/m-operand x-name x-comment x-mode x-r/m-reg)
+  (begin
+    (define-mod-r/m-choices x-mode x-r/m-reg)
+    (define-anyof-operand
+      (name x-name)
+      (comment x-comment)
+      (mode x-mode)
+      ; Each choice must have the same base-ifield.
+      (choices (.sym @reg- x-mode)
+              (.sym @sib- x-mode)
+              (.sym @disp32- x-mode)
+              (.sym @reg+disp8- x-mode)
+              (.sym @sib+disp8- x-mode)
+              (.sym @reg+disp32- x-mode)
+              (.sym @sib+disp32- x-mode)
+              (.sym reg- x-mode)
+              ))
+    )
+)
+
+(define-mod-r/m-operand mod-r/m-8  "8 bit mod-r/m value"  QI r/m-reg8)
+(define-mod-r/m-operand mod-r/m-16 "16 bit mod-r/m value" HI r/m-reg16)
+(define-mod-r/m-operand mod-r/m-32 "32 bit mod-r/m value" SI r/m-reg32)
+
+; Additional ifields/operands used by instructions.
+; These "follow" the mod-r/m byte so must be defined afterwards.
+
+(diff f-simm8-follows-mod-r/m-8 "simm8 ifield after mod-r/m-8 ifields"
+      () 7 8 mod-r/m-8 INT
+)
+(dnop simm8-follows-mod-r/m-8 "simm8 following mod-r/m-8"
+      () h-sint f-simm8-follows-mod-r/m-8
+)
+
+(diff f-simm16-follows-mod-r/m-16 "simm16 ifield after mod-r/m-16 ifields"
+      () 15 16 mod-r/m-16 INT
+)
+(dnop simm16-follows-mod-r/m-16 "simm16 following mod-r/m-16"
+      () h-sint f-simm16-follows-mod-r/m-16
+)
+
+(diff f-simm32-follows-mod-r/m-32 "simm32 ifield after mod-r/m-32 ifields"
+      () 31 32 mod-r/m-32 INT
+)
+(dnop simm32-follows-mod-r/m-32 "simm32 following mod-r/m-32"
+      () h-sint f-simm32-follows-mod-r/m-32
+)
+
+(diff f-simm8-follows-mod-r/m-16 "simm8 ifield after mod-r/m-16 ifields"
+      () 7 8 mod-r/m-16 INT
+)
+(dnop simm8-follows-mod-r/m-16 "simm8 following mod-r/m-16"
+      () h-sint f-simm8-follows-mod-r/m-16
+)
+
+(diff f-simm8-follows-mod-r/m-32 "simm8 ifield after mod-r/m-32 ifields"
+      () 7 8 mod-r/m-32 INT
+)
+(dnop simm8-follows-mod-r/m-32 "simm8 following mod-r/m-32"
+      () h-sint f-simm8-follows-mod-r/m-32
+)
+\f
+; Some subroutines, to simplify the semantic specs.
+
+(define-pmacro (define-arith-subr x-name x-mode x-fn x-set-cc-fn)
+  (define-subr
+    (name x-name)
+    (mode VOID)
+    (args ((x-mode dst) (x-mode src1) (x-mode src2)))
+    (code (sequence ((x-mode arg1)
+                    (x-mode arg2)
+                    (x-mode result))
+                   (set arg1 src1)
+                   (set arg2 src2)
+                   (set result (x-fn arg1 arg2))
+                   (set dst result)
+                   (x-set-cc-fn result arg1 arg2)))
+    )
+)
+
+(define-arith-subr add-QI QI add set-add-cc)
+(define-arith-subr add-HI HI add set-add-cc)
+(define-arith-subr add-SI SI add set-add-cc)
+\f
+; Instruction definitions.
+
+; IA32 specific instruction attributes:
+; - none yet
+
+(dni nop
+     "nop"
+     ()
+     "nop"
+     (+ OP_90)
+     (nop)
+     ()
+)
+\f
+; Add, subtract.
+;
+; ??? Insn naming puts destination before addend.  Ok?
+
+(dni add-al-simm8
+     "add 8 bit signed immediate to %al"
+     ()
+     "FIXME"
+     (+ OP_04 simm8)
+     (sequence ()
+              (set al (add al simm8))
+              ; ??? condition codes
+              )
+     ()
+)
+
+(dni add-ax-simm16
+     "add 16 bit signed immediate to %ax"
+     ()
+     "FIXME"
+     ; ??? Need something like ifield assertions to distinguish from
+     ; 32 bit case.
+     (+ OP_05 simm16)
+     (sequence ()
+              (set ax (add ax simm16))
+              ; ??? condition codes
+              )
+     ()
+)
+
+(dni add-eax-simm32
+     "add 32 bit signed immediate to %eax"
+     ()
+     "FIXME"
+     (+ OP_05 simm32)
+     (sequence ()
+              (set eax (add eax simm32))
+              ; ??? condition codes
+              )
+     ()
+)
+
+(dni add-r/m8-simm8
+     "add 8 bit immediate"
+     ()
+     "FIXME"
+     (+ OP_80 mod-r/m-8 simm8-follows-mod-r/m-8 (f-reg/opcode 0))
+     (sequence ()
+              (set mod-r/m-8 (add mod-r/m-8 simm8-follows-mod-r/m-8))
+              ; ??? condition codes
+              )
+     ()
+)
+
+(dni add-r/m16-simm16
+     "add 16 bit immediate"
+     ()
+     "FIXME"
+     ; ??? Need something akin to ifield-assertions to distinguish from
+     ; 32 bit version.
+     (+ OP_81 mod-r/m-16 simm16-follows-mod-r/m-16 (f-reg/opcode 0))
+     (sequence ()
+              (set mod-r/m-16 (add mod-r/m-16 simm16-follows-mod-r/m-16))
+              ; ??? condition codes
+              )
+     ()
+)
+
+(dni add-r/m32-simm32
+     "add 32 bit immediate"
+     ()
+     "FIXME"
+     (+ OP_81 mod-r/m-32 simm32-follows-mod-r/m-32 (f-reg/opcode 0))
+     (sequence ()
+              (set mod-r/m-32 (add mod-r/m-32 simm32-follows-mod-r/m-32))
+              ; ??? condition codes
+              )
+     ()
+)
+
+(dni add-r/m16-simm8
+     "add 8 bit signed immediate to 16 bit value"
+     ()
+     "FIXME"
+     ; ??? Need something akin to ifield-assertions to distinguish from
+     ; 32 bit version.
+     (+ OP_83 mod-r/m-16 simm8-follows-mod-r/m-16 (f-reg/opcode 0))
+     (sequence ()
+              (set mod-r/m-16 (add mod-r/m-16 (ext HI simm8-follows-mod-r/m-16)))
+              ; ??? condition codes
+              )
+     ()
+)
+
+(dni add-r/m32-simm8
+     "add 8 bit signed immediate to 32 bit value"
+     ()
+     "FIXME"
+     (+ OP_83 mod-r/m-32 simm8-follows-mod-r/m-32 (f-reg/opcode 0))
+     (sequence ()
+              (set mod-r/m-32 (add mod-r/m-32 (ext SI simm8-follows-mod-r/m-32)))
+              ; ??? condition codes
+              )
+     ()
+)
+
+(dni add-r/m8-reg8
+     "add 8 bit reg to 8 bit r/m"
+     ()
+     "FIXME"
+     (+ OP_00 mod-r/m-8 reg8)
+     (sequence ()
+              (set mod-r/m-8 (add mod-r/m-8 reg8))
+              ; ??? condition codes
+              )
+     ()
+)
+
+(dni add-r/m16-reg16
+     "add 16 bit reg to 16 bit r/m"
+     ()
+     "FIXME"
+     ; ??? Need something akin to ifield-assertions to distinguish from
+     ; 32 bit version.
+     (+ OP_01 mod-r/m-16 reg16)
+     (sequence ()
+              (set mod-r/m-16 (add mod-r/m-16 reg16))
+              ; ??? condition codes
+              )
+     ()
+)
+
+(dni add-r/m32-reg32
+     "add 32 bit reg to 32 bit r/m"
+     ()
+     "FIXME"
+     (+ OP_01 mod-r/m-32 reg32)
+     (sequence ()
+              (set mod-r/m-32 (add mod-r/m-32 reg32))
+              ; ??? condition codes
+              )
+     ()
+)
+
+(dni add-reg8-r/m8
+     "add 8 bit r/m to 8 bit reg"
+     ()
+     "FIXME"
+     (+ OP_02 mod-r/m-8 reg8)
+     (sequence ()
+              (set reg8 (add reg8 mod-r/m-8))
+              ; ??? condition codes
+              )
+     ()
+)
+
+(dni add-reg16-r/m16
+     "add 16 bit r/m to 16 bit reg"
+     ()
+     "FIXME"
+     ; ??? Need something akin to ifield-assertions to distinguish from
+     ; 32 bit version.
+     (+ OP_03 mod-r/m-16 reg16)
+     (sequence ()
+              (set reg16 (add reg16 mod-r/m-16))
+              ; ??? condition codes
+              )
+     ()
+)
+
+(dni add-reg32-r/m32
+     "add 32 bit r/m to 32 bit reg"
+     ()
+     "FIXME"
+     (+ OP_03 mod-r/m-32 reg32)
+     (sequence ()
+              (set reg32 (add reg32 mod-r/m-32))
+              ; ??? condition codes
+              )
+     ()
+)
diff --git a/cgen/ia64.cpu b/cgen/ia64.cpu
new file mode 100644 (file)
index 0000000..270fdf4
--- /dev/null
@@ -0,0 +1,2355 @@
+;;; Intel IA-64 CPU description.  -*- Scheme -*-
+;;; Copyright (C) 2000 Red Hat, Inc.
+;;; This file is part of CGEN.
+;;; See file COPYING.CGEN for details.
+
+(include "simplify.inc")
+
+\f
+;;; Architecture and cpu family definitions.
+
+(define-arch
+  (name ia64)
+  (comment "Intel IA-64 architecture")
+  (insn-lsb0? #t)
+  (machs ia64)
+  (isas ia64)
+)
+
+(define-isa
+  (name ia64)
+
+  ;; Each instruction in the 128-bit bundle is 41 bits wide.
+  (base-insn-bitsize 41)
+
+  ;; Each bundle is 3 insns wide.
+  (liw-insns 3)
+
+  ;; ??? How to specify "lots", as that's what the architecture's
+  ;; stop bits means;
+  (parallel-insns 3)
+
+  ;; Initial bit numbers to decode by.
+  (decode-assist (40 39 38 37))
+)
+
+(define-cpu
+  (name ia64)
+  (comment "Intel IA-64 family")
+  (insn-endian little)
+  (data-endian either)
+  (word-bitsize 64)
+)
+
+(eval
+ (begin
+   ;; We need 64-bit host support.
+   (set! INT (mode:add! 'INT (mode:lookup 'DI)))
+   (set! UINT (mode:add! 'UINT (mode:lookup 'UDI)))
+
+   ;; ??? This shouldn't be necessary, IMO.
+   (set! WI (mode:add! 'WI (mode:lookup 'DI)))
+   (set! UWI (mode:add! 'UWI (mode:lookup 'UDI)))
+   (set! AI (mode:add! 'AI (mode:lookup 'UDI)))
+   (set! IAI (mode:add! 'IAI (mode:lookup 'UDI)))
+   )
+)
+
+\f
+(define-mach
+  (name ia64)
+  (comment "Intel IA-64 processors")
+  (cpu ia64)
+)
+
+; ??? Incomplete.  Pipeline and unit info wrong.
+
+(define-model
+  (name ia64_itanium)
+  (comment "Intel Itanium processor")
+  (mach ia64)
+  (pipeline all "" () ((fetch) (decode) (execute) (writeback)))
+  (unit u-exec "Execution Unit" () 1 1
+       () () () ())
+)
+\f
+;;; Attributes. 
+;;;
+;;; These are used to mark instructions so that we can decode the
+;;; dependancy violation data in Intel's tables.
+
+(define-attr
+  (name FORMAT)
+  (for insn)
+  (type enum)
+  (attrs META)
+  (values UNKNOWN
+
+         A1 A2 A3 A4 A5 A6 A7 A8 A9 A10
+
+         I1  I2  I3  I4  I5  I6  I7  I8  I9  I10
+         I11 I12 I13 I14 I15 I16 I17 I18 I19 I20
+         I21 I22 I23 I24 I25 I26 I27 I28 I29
+
+         M1  M2  M3  M4  M5  M6  M7  M8  M9  M10
+         M11 M12 M13 M14 M15 M16 M17 M18 M19 M20
+         M21 M22 M23 M24 M25 M26 M27 M28 M29 M30
+         M31 M32 M33 M34 M35 M36 M37 M38 M39 M40
+         M41 M42 M43 M44 M45 M46
+
+         B1 B2 B3 B4 B5 B6 B7 B8 B9
+
+         F1  F2  F3  F4  F5  F6  F7  F8  F9  F10
+         F11 F12 F13 F14 F15
+         )
+  (default UNKNOWN)
+)
+
+;; ??? NONE isn't a valid value, but non-FP insns obviously can't have
+;; a valid value either.
+(define-attr
+  (name FIELD-SF)
+  (for insn)
+  (type enum)
+  (attrs META)
+  (values NONE s0 s1 s2 s3)
+  (default NONE)
+)
+
+(define-attr
+  (name FIELD-LFTYPE)
+  (for insn)
+  (type enum)
+  (attrs META)
+  (values NONE fault)
+  (default NONE)
+)
+
+(define-attr
+  (name FIELD-CTYPE)
+  (for insn)
+  (type enum)
+  (attrs META)
+  (values NONE unc or and or.andcm orcm andcm and.orcm)
+  (default NONE)
+)
+
+;; Field AR3 references a register field.
+;; Field CR3 references a register field.
+;; Field ireg references a register field.
+
+;;; ??? IA-64 specific instruction attributes:
+;;;
+;;; FIRST      Must be at the beginning of an instruction group.
+;;; SLOT2      Must be in slot 2 on a bundle.
+;;; LAST       Must be at the end of an instruction group.
+;;; I_IN_MLI   Insn is allowed in I slot of MLI.
+;;; PRIV       Privileged instruction.
+;;; NO_PRED    Insn cannot be predicated.
+
+\f
+;;; Instruction fields.
+;;;
+;;; ??? This is confusing (at least to me) -- note that we specify the _top_
+;;; of the field and a length.
+;;;
+;;; ??? There are only two fields used nearly universally.  But the
+;;; instruction formats are very regular in the sense that the same 
+;;; field specifications are re-used many times.  So we just have the 
+;;; raw fields here first.
+
+;; Fields used by most instructions.
+(dnf f-opcode  "major opcode"          () 40 4)
+(dnf f-qp      "qualifying predicate"  ()  5 6)
+
+;; Random parts used by the 109 (!) instruction formats.
+(dnf f-36-6    "6 @ 36"                () 36 6)
+(df f-36-1s    "1 @ 36, signed"        () 36 1 INT #f #f)
+(dnf f-36-1    "1 @ 36"                () 36 1)
+(dnf f-35-9    "9 @ 35"                () 35 9)
+(dnf f-35-6    "6 @ 35"                () 35 6)
+(dnf f-35-3    "3 @ 35"                () 35 3)
+(dnf f-35-2    "2 @ 35"                () 35 2)
+(dnf f-35-1    "1 @ 35"                () 35 1)
+(dnf f-34-2    "2 @ 34"                () 34 2)
+(dnf f-33-1    "1 @ 33"                () 33 1)
+(dnf f-32-27   "27 @ 32"               () 32 27)
+(dnf f-32-20   "20 @ 32"               () 32 20)
+(dnf f-32-13   "13 @ 32"               () 32 13)
+(dnf f-32-9    "9 @ 32"                () 32 9)
+(dnf f-32-6    "6 @ 32"                () 32 6)
+(dnf f-32-4    "4 @ 32"                () 32 4)
+(dnf f-32-2    "2 @ 32"                () 32 2)
+(dnf f-32-1    "1 @ 32"                () 32 1)
+(dnf f-31-8    "8 @ 31"                () 31 8)
+(dnf f-31-2    "2 @ 31"                () 31 2)
+(dnf f-30-4    "4 @ 30"                () 30 4)
+(dnf f-30-19   "19 @ 30"               () 30 19)
+(dnf f-29-2    "2 @ 29"                () 29 2)
+(dnf f-28-2    "2 @ 28"                () 28 2)
+(dnf f-27-8    "8 @ 27"                () 27 8)
+(dnf f-27-4    "4 @ 27"                () 27 4)
+(dnf f-27-3    "3 @ 27"                () 27 3)
+(dnf f-27-1    "1 @ 27"                () 27 1)
+(dnf f-26-21   "21 @ 26"               () 26 21)
+(dnf f-26-11   "11 @ 26"               () 26 11)
+(dnf f-26-7    "7 @ 26"                () 26 7)
+(dnf f-26-5    "5 @ 26"                () 26 5)
+(dnf f-26-1    "1 @ 26"                () 26 1)
+(dnf f-25-20   "20 @ 25"               () 25 20)
+(dnf f-25-6    "6 @ 25"                () 25 6)
+(dnf f-24-5    "5 @ 24"                () 24 5)
+(dnf f-23-4    "4 @ 23"                () 23 4)
+(dnf f-23-1    "1 @ 23"                () 23 1)
+(dnf f-22-1    "1 @ 22"                () 22 1)
+(dnf f-21-2    "2 @ 21"                () 21 2)
+(dnf f-21-1    "1 @ 21"                () 21 1)
+(dnf f-20-1    "1 @ 20"                () 20 1)
+(dnf f-19-7    "7 @ 19"                () 19 7)
+(dnf f-19-6    "6 @ 19"                () 19 6)
+(dnf f-19-4    "4 @ 19"                () 19 4)
+(dnf f-19-1    "1 @ 19"                () 19 1)
+(dnf f-18-5    "5 @ 18"                () 18 5)
+(dnf f-15-3    "3 @ 15"                () 15 3)
+(dnf f-15-1    "1 @ 15"                () 15 1)
+(dnf f-14-2    "2 @ 14"                () 14 2)
+(dnf f-13-1    "1 @ 13"                () 13 1)
+(dnf f-12-7    "7 @ 12"                () 12 7)
+(dnf f-12-1    "1 @ 12"                () 12 1)
+(dnf f-11-6    "6 @ 11"                () 11 6)
+(dnf f-11-3    "3 @ 11"                () 11 3)
+(dnf f-8-3     "3 @ 8"                 ()  8 3)
+
+;; The extra field for movl
+(dnf f-81-41   "41 @ 81"               () 81 41)
+
+;; Virtual fields of the broken up constants.
+(dnmf fv-sint8 "i8 for A3 A8 I27 M30" 
+      () INT
+
+      (f-36-1s f-19-7)
+      (sequence ()                     ; insert
+               (set (ifield f-36-1s) (srl (ifield fv-sint8) (const 7)))
+               (set (ifield f-19-7) (and (ifield fv-sint8) (const #x7f)))
+               )
+      (sequence ()                     ; extract
+               (set (ifield fv-sint8)
+                    (or (sll (ifield f-36-1s) (const 7))
+                        (ifield f-19-7)))
+               )
+)
+
+(dnmf fv-sint9a        "i9 for M3 M8 M15"
+      () INT
+      (f-36-1s f-27-1 f-19-7)
+      (sequence ()                     ; insert
+               (set (ifield f-36-1s) (srl (ifield fv-sint9a) (const 8)))
+               (set (ifield f-27-1)
+                    (and (srl (ifield fv-sint9a) (const 7)) (const 1)))
+               (set (ifield f-19-7) (and (ifield fv-sint9a) (const #x7f)))
+               )
+      (sequence ()                     ; extract
+               (set (ifield fv-sint9a)
+                    (or (sll (ifield f-36-1s) (const 8))
+                        (or (sll (ifield f-27-1) (const 7))
+                            (ifield f-19-7))))
+               )
+)
+
+(dnmf fv-sint9b        "i9 for M5 M10"
+      () INT
+      (f-36-1s f-27-1 f-12-7)
+      (sequence ()                     ; insert
+               (set (ifield f-36-1s) (srl (ifield fv-sint9b) (const 8)))
+               (set (ifield f-27-1)
+                    (and (srl (ifield fv-sint9b) (const 7)) (const 1)))
+               (set (ifield f-12-7) (and (ifield fv-sint9b) (const #x7f)))
+               )
+      (sequence ()                     ; extract
+               (set (ifield fv-sint9b)
+                    (or (sll (ifield f-36-1s) (const 8))
+                        (or (sll (ifield f-27-1) (const 7))
+                            (ifield f-12-7))))
+               )
+)
+
+(dnmf fv-sint14        "i14 for A4"
+      () INT
+      (f-36-1s f-32-6 f-19-7)
+      (sequence ()                     ; insert
+               (set (ifield f-36-1s) (srl (ifield fv-sint14) (const 13)))
+               (set (ifield f-32-6)
+                    (and (srl (ifield fv-sint14) (const 7)) (const #x3f)))
+               (set (ifield f-19-7) (and (ifield fv-sint14) (const #x7f)))
+               )
+      (sequence ()                     ; extract
+               (set (ifield fv-sint14)
+                    (or (sll (ifield f-36-1s) (const 13))
+                        (or (sll (ifield f-32-6) (const 7))
+                            (ifield f-19-7))))
+               )
+)
+
+(dnmf fv-sint17        "mask17 for I23"
+      () INT
+      (f-36-1s f-31-8 f-12-7)
+      (sequence ()                     ; insert
+               (set (ifield f-36-1s) (srl (ifield fv-sint17) (const 16)))
+               (set (ifield f-31-8)
+                    (and (srl (ifield fv-sint17) (const 8)) (const #xff)))
+               (set (ifield f-12-7)
+                    (and (srl (ifield fv-sint17) (const 1)) (const #x7f)))
+               )
+      (sequence ()                     ; extract
+               (set (ifield fv-sint17)
+                    (or (sll (ifield f-36-1s) (const 16))
+                        (or (sll (ifield f-31-8) (const 8))
+                            (ifield f-12-7))))
+               )
+)
+
+(dnmf fv-sint22        "i22 for A5"
+      () INT
+      (f-36-1s f-35-9 f-26-5 f-19-7)
+      (sequence ()                     ; insert
+               (set (ifield f-36-1s) (srl (ifield fv-sint22) (const 21)))
+               (set (ifield f-26-5)
+                    (and (srl (ifield fv-sint22) (const 16)) (const #x1f)))
+               (set (ifield f-35-9)
+                    (and (srl (ifield fv-sint22) (const 7)) (const #x1ff)))
+               (set (ifield f-19-7) (and (ifield fv-sint22) (const #x7f)))
+               )
+      (sequence ()                     ; extract
+               (set (ifield fv-sint22)
+                    (or (or (sll (ifield f-36-1s) (const 21))
+                            (sll (ifield f-26-5) (const 16)))
+                        (or (sll (ifield f-35-9) (const 7))
+                            (ifield f-19-7))))
+               )
+)
+
+(dnmf fv-sint44        "i44 for I24"
+      () INT
+      (f-36-1s f-32-27)
+      (sequence ()                     ; insert
+               (set (ifield f-36-1s) (srl (ifield fv-sint44) (const 43)))
+               (set (ifield f-19-7)
+                    (and (srl (ifield fv-sint44) (const 16))
+                         (const #x7ffffff)))
+               )
+      (sequence ()                     ; extract
+               (set (ifield fv-sint44)
+                    (or (sll (ifield f-36-1s) (const 43))
+                        (sll (ifield f-32-27) (const 16))))
+               )
+)
+
+(dnmf fv-sint64 "i64 for I18"
+      () INT
+      (f-81-41 f-36-1s f-35-9 f-26-5 f-21-1 f-19-7)
+      (sequence ()                     ; insert
+               (set (ifield f-36-1s) (srl (ifield fv-sint64) (const 63)))
+               (set (ifield f-81-41)
+                    (and (srl (ifield fv-sint64) (const 22))
+                         (const #x1fffffffff)))
+               (set (ifield f-21-1)
+                    (and (srl (ifield fv-sint64) (const 21)) (const 1)))
+               (set (ifield f-26-5)
+                    (and (srl (ifield fv-sint64) (const 16)) (const #x1f)))
+               (set (ifield f-35-9)
+                    (and (srl (ifield fv-sint64) (const 7)) (const #x1ff)))
+               (set (ifield f-19-7) (and (ifield fv-sint64) (const #x7f)))
+               )
+      (sequence ()                     ; extract
+               (set (ifield fv-sint64)
+                    (or (or (or (sll (ifield f-36-1s) (const 63))
+                                (sll (ifield f-81-41) (const 22)))
+                            (or (sll (ifield f-21-1) (const 21))
+                                (sll (ifield f-26-5) (const 16))))
+                        (or (sll (ifield f-35-9) (const 7))
+                            (ifield f-19-7))))
+               )
+)
+
+(dnmf fv-uint21        "u21 for I19 M37 F15"
+      () UINT
+      (f-36-1 f-25-20)
+      (sequence ()                     ; insert
+               (set (ifield f-36-1) (srl (ifield fv-uint21) (const 20)))
+               (set (ifield f-25-20) (and (ifield fv-uint21) (const #xfffff)))
+               )
+      (sequence ()                     ; extract
+               (set (ifield fv-uint21)
+                    (or (sll (ifield f-36-1) (const 20))
+                        (ifield f-25-20)))
+               )
+)
+
+(dnmf fv-uint24        "u24 for M44"
+      () UINT
+      (f-36-1 f-32-2 f-26-21)
+      (sequence ()                     ; insert
+               (set (ifield f-36-1) (srl (ifield fv-uint24) (const 23)))
+               (set (ifield f-32-1)
+                    (and (srl (ifield fv-uint24) (const 21)) (const 3)))
+               (set (ifield f-26-21)
+                    (and (ifield fv-uint24) (const #x1fffff)))
+               )
+      (sequence ()                     ; extract
+               (set (ifield fv-uint24)
+                    (or (sll (ifield f-36-1) (const 23))
+                        (or (sll (ifield f-32-2) (const 21))
+                            (ifield f-26-21))))
+               )
+)
+
+(dnmf fv-tgt25a "target25 for I20 M20 M21"
+      (PCREL-ADDR) INT
+      (f-36-1s f-32-13 f-12-7)
+      (sequence ()                     ; insert
+               ;; ??? Wherefore right shift.
+               (set (ifield f-36-1s) (srl (ifield fv-tgt25a) (const 20)))
+               (set (ifield f-32-13)
+                    (and (srl (ifield fv-tgt25a) (const 7)) (const #x1fff)))
+               (set (ifield f-12-7) (and (ifield fv-tgt25a) (const #x7f)))
+               )
+      (sequence ()                     ; extract
+               ;; ??? Where will pc be added.
+               ;; ??? Wherefore left shift.
+               (set (ifield fv-tgt25a)
+                    (or (sll (ifield f-36-1s) (const 20))
+                        (or (sll (ifield f-32-13) (const 7))
+                            (ifield f-12-7))))
+               )
+)
+
+(dnmf fv-tgt25b "target25 for F14"
+      (PCREL-ADDR) INT
+      (f-36-1s f-25-20)
+      (sequence ()                     ; insert
+               ;; ??? Wherefore right shift.
+               (set (ifield f-36-1s) (srl (ifield fv-tgt25b) (const 20)))
+               (set (ifield f-25-20) (and (ifield fv-tgt25b) (const #xfffff)))
+               )
+      (sequence ()                     ; extract
+               ;; ??? Where will pc be added.
+               ;; ??? Wherefore left shift.
+               (set (ifield fv-tgt25b)
+                    (or (sll (ifield f-36-1) (const 20))
+                        (ifield f-25-20)))
+               )
+)
+
+(dnmf fv-tgt25c "target25 for M22 M23 B1 B2 B3 B6"
+      (PCREL-ADDR) INT
+      (f-36-1s f-32-20)
+      (sequence ()                     ; insert
+               ;; ??? Wherefore right shift.
+               (set (ifield f-36-1s) (srl (ifield fv-tgt25c) (const 20)))
+               (set (ifield f-32-20) (and (ifield fv-tgt25c) (const #xfffff)))
+               )
+      (sequence ()                     ; extract
+               ;; ??? Where will pc be added.
+               ;; ??? Wherefore left shift.
+               (set (ifield fv-tgt25c)
+                    (or (sll (ifield f-36-1s) (const 20))
+                        (ifield f-32-20)))
+               )
+)
+
+(dnmf fv-tag13a "tag13 for I21"
+      (PCREL-ADDR) INT
+      (f-32-9)
+      (sequence ()                     ; insert
+               ;; ??? Wherefore right shift.
+               (set (ifield f-32-9) (and (ifield fv-tag13a (const #x1ff))))
+               )
+      (sequence ()                     ; extract
+               ;; ??? Where will pc be added.
+               ;; ??? Wherefore left shift.
+               (set (ifield fv-tag13a)
+                    (sub (xor (ifield f-32-9) (const #x100)) (const #x100)))
+               )
+)
+
+(dnmf fv-tag13b "tag13 for B6 B7"
+      (PCREL-ADDR) INT
+      (f-34-2 f-12-7)
+      (sequence ()                     ; insert
+               ;; ??? Wherefore right shift.
+               (set (ifield f-34-2)
+                    (and (sll (ifield fv-tag13b) (const 7)) (const 3)))
+               (set (ifield f-12-7) (and (ifield fv-tag13b) (const #x7f)))
+               )
+      (sequence ()                     ; extract
+               ;; ??? Where will pc be added.
+               ;; ??? Wherefore left shift.
+               (set (ifield fv-tag13a)
+                    (or (sll (sub (xor (ifield f-34-2) (const 2))
+                                  (const 2))
+                             (const 7))
+                        (ifield f-12-7)))
+               )
+)
+
+(dnmf fv-uint9 "u9 for F5"
+      () UINT
+      (f-34-2 f-26-7)
+      (sequence ()                     ; insert
+               (set (ifield f-26-7) (srl (ifield fv-uint9) (const 2)))
+               (set (ifield f-34-2) (and (ifield fv-uint9) (const 3)))
+               )
+      (sequence ()                     ; extract
+               (set (ifield fv-uint9)
+                    (or (sll (ifield f-26-7) (const 2))
+                        (ifield f-34-2)))
+               )
+)
+
+;; Fields with funny arithmetic
+
+(df f-count2a "count2 for A2" () 28 2 UINT
+    ((value pc) (sub WI value (const 1)))
+    ((value pc) (add WI value (const 1)))
+)
+    
+(df f-count2b "count2 for A10" () 28 2 UINT
+    ((value pc)
+     (if WI (le value (const 2))
+         (sub WI value (const 1))
+         (error "invalid value for field count2b")))
+    ((value pc) (add WI value (const 1)))
+)
+
+(df f-count2c "count2 for I1" () 31 2 UINT
+    ((value pc)
+     (cond WI
+           ((eq value (const 0)) (const 0))
+           ((eq value (const 7)) (const 1))
+           ((eq value (const 15)) (const 2))
+           ((eq value (const 16)) (const 3))
+           (else (error "invalid value for field count2c"))))
+    ((value pc)
+     (cond WI
+           ((eq value (const 0)) (const 0))
+           ((eq value (const 1)) (const 7))
+           ((eq value (const 2)) (const 15))
+           ((eq value (const 3)) (const 16))))
+)
+
+(df f-ccount5 "ccount5 for I8" () 24 5 UINT
+    ((value pc) (sub WI (const 31) value))
+    ((value pc) (sub WI (const 31) value))
+)
+    
+(df f-len4 "len4 for I15" () 30 4 UINT
+    ((value pc) (sub WI value (const 1)))
+    ((value pc) (add WI value (const 1)))
+)
+
+(df f-len6 "len6 for I11 I12 I13 I14" () 32 6 UINT
+    ((value pc) (sub WI value (const 1)))
+    ((value pc) (add WI value (const 1)))
+)
+
+(df f-cpos6a "cpos6 for I12 I13" () 25 6 UINT
+    ((value pc) (sub WI (const 63) value))
+    ((value pc) (sub WI (const 63) value))
+)
+
+(df f-cpos6b "cpos6 for I14" () 19 6 UINT
+    ((value pc) (sub WI (const 63) value))
+    ((value pc) (sub WI (const 63) value))
+)
+
+(df f-cpos6c "cpos6 for I15" () 36 6 UINT
+    ((value pc) (sub WI (const 63) value))
+    ((value pc) (sub WI (const 63) value))
+)
+
+(dnmf fv-inc3 "inc3 for M17" () INT
+      (f-15-1 f-14-2)
+      (sequence ()                     ; insert
+               (set (ifield f-15-1) (lt (ifield fv-inc3) (const 0)))
+               (set (ifield f-14-2) (abs (ifield fv-inc3)))
+               (set (ifield f-14-2)
+                    (cond ((eq (ifield f-14-2) (const 1)) (const 3))
+                          ((eq (ifield f-14-2) (const 4)) (const 2))
+                          ((eq (ifield f-14-2) (const 8)) (const 1))
+                          ((eq (ifield f-14-2) (const 16)) (const 0))
+                          (else (error "invalid value for field inc3"))))
+               )
+      (sequence ()                     ; extract
+               (set (ifield fv-inc3)
+                    (mul (add (mul (neg (ifield f-15-1)) (const 2)) (const 1))
+                         (if (eq (ifield f-14-2) (const 3))
+                             (const 1)
+                             (sll (const 1) (sub (const 4)
+                                                 (ifield f-14-2))))))
+               )
+)
+\f
+;;; Hardware pieces.
+;;;
+;;; These entries list the elements of the raw hardware.  They're also
+;;; used to provide tables and other elements of the assembly language.
+
+;; The normal h-uint only provides 32 bits of integer.
+(dnh h-int64 "64-bit integer" ()
+     (immediate (INT 64))
+     () () ()
+)
+
+;; ??? Intel calls this if IP, but from experience with the i960
+;; simulator using the name "ip", we know that gdb reacts badly.
+(dnh h-pc "program counter" (PC PROFILE) (pc) () () ())
+
+(define-pmacro (build-decpair num) ((.dec num) num))
+
+(define-hardware
+  (name h-gr)
+  (comment "general registers")
+  (attrs CACHE-ADDR)
+  (type register WI (128))
+  (indices keyword "r"
+    (.map build-decpair (.iota 128)))
+)
+
+;; ??? Skip GR NaTs for now, since we're not simulating.
+
+(define-hardware
+  (name h-fr)
+  (comment "floating-point registers")
+  (type register XF (128))
+  (indices keyword "fr"
+    (.map build-decpair (.iota 128)))
+)
+
+(define-hardware
+  (name h-br)
+  (comment "branch registers")
+  (attrs CACHE-ADDR)
+  (type register WI (8))
+  (indices keyword "br"
+    (.map build-decpair (.iota 8)))
+)
+
+(define-hardware
+  (name h-ar)
+  (comment "application registers")
+  (type register WI (128))
+  (indices keyword "ar"
+    (.map build-decpair (.iota 128)))
+)
+
+(define-hardware
+  (name h-pr)
+  (comment "predicate registers")
+  (type register BI (64))
+  (indices keyword "pr"
+    (.map build-decpair (.iota 64)))
+)
+
+(define-hardware
+  (name h-cr)
+  (comment "control registers")
+  (type register WI (128))
+  (indices keyword "cr"
+    (.map build-decpair (.iota 128)))
+)
+
+;; ??? CFM, PSR, PMD, CPUID
+\f
+;;; Instruction Operands.
+;;;
+;;; These entries provide a layer between the assembler and the raw
+;;; hardware description, and are used to refer to hardware elements
+;;; in the semantic code.  Usually there's a bit of over-specification,
+;;; but in more complicated instruction sets there isn't.
+
+(dnop qp       "qualifying predicate"          () h-pr f-qp)
+
+(dnop r1       "general register 1"            () h-gr f-12-7)
+(dnop r2       "general register 2"            () h-gr f-19-7)
+(dnop r3       "general register 3"            () h-gr f-26-7)
+(dnop r33      "general register 3 for A5"     () h-gr f-21-2)
+
+(dnop f1       "floating-point register 1"     () h-fr f-12-7)
+(dnop f2       "floating-point register 2"     () h-fr f-19-7)
+(dnop f3       "floating-point register 3"     () h-fr f-26-7)
+
+(dnop p1       "predicate register 1"          () h-pr f-11-6)
+(dnop p2       "predicate register 2"          () h-pr f-32-6)
+
+(dnop b1       "branch register 1"             () h-br f-8-3)
+(dnop b2       "branch register 2"             () h-br f-15-3)
+
+(dnop ar3      "application register 3"        () h-ar f-26-7)
+(dnop cr3      "control register 3"            () h-cr f-26-7)
+
+(dnop imm1     "imm1 for I14"                  () h-int64 f-36-1s)
+(dnop imm8     "imm8 for A3 A8 I27 M30"        () h-int64 fv-sint8)
+(dnop imm9a    "imm9 for M3 M8 M15"            () h-int64 fv-sint9a)
+(dnop imm9b    "imm9 for M5 M10"               () h-int64 fv-sint9b)
+(dnop imm14    "imm14 for A4"                  () h-int64 fv-sint14)
+(dnop imm17    "mask17 for I23"                () h-int64 fv-sint17)
+(dnop imm21    "imm21 for I19"                 () h-int64 fv-uint21)
+(dnop imm22    "imm22 for A5"                  () h-int64 fv-sint22)
+(dnop imm44    "imm44 for I24"                 () h-int64 fv-sint44)
+(dnop imm64    "imm64 for I18"                 () h-int64 fv-sint64)
+
+(dnop count2a  "count2 for A2"                 () h-int64 f-count2a)
+(dnop count2b  "count2 for A10"                () h-int64 f-count2b)
+(dnop count2c  "count2 for I1"                 () h-int64 f-count2c)
+(dnop count5   "count5 for I6"                 () h-int64 f-18-5)
+(dnop count6   "count6 for I10"                () h-int64 f-32-6)
+(dnop ccount5  "ccount5 for I8"                () h-int64 f-ccount5)
+
+(dnop len4     "len4 for I15"                  () h-int64 f-len4)
+(dnop len6     "len6 for I11 I12 I13 I14"      () h-int64 f-len6)
+
+(dnop pos6     "pos6 for I11"                  () h-int64 f-19-6)
+(dnop cpos6a   "cpos6 for I12 I13"             () h-int64 f-cpos6a)
+(dnop cpos6b   "cpos6 for I14"                 () h-int64 f-cpos6b)
+(dnop cpos6c   "cpos6 for I15"                 () h-int64 f-cpos6c)
+
+(dnop inc3     "inc3 for M17"                  () h-int64 fv-inc3)
+
+(define-operand
+  (name mbtype4)
+  (comment "mbtype4 type for I3")
+  (type h-int64)
+  (index f-23-4)
+  (handlers (parse "mbtype4")
+           (print "mbtype4"))
+)
+
+(dnop mhtype8  "mhtype8 for I4"                () h-int64 f-27-8)
+
+(dnop tgt25a   "tgt25 for I20 M20 M21"         () h-int64 fv-tgt25a)
+(dnop tgt25b   "tgt25 for F14"                 () h-int64 fv-tgt25b)
+(dnop tgt25c   "tgt25 for M22 M23 B1 B2 B3 B6" () h-int64 fv-tgt25c)
+
+(dnop tag13a   "tag13 for I21"                 () h-int64 fv-tag13a)
+
+;; Completers 
+
+(define-operand
+  (name ldhint)
+  (comment "ldhint completer")
+  (type h-int64)
+  (index f-29-2)
+  (handlers (parse "ldhint")
+           (print "ldhint"))
+)
+
+(define-operand
+  (name sthint)
+  (comment "sthint completer")
+  (type h-int64)
+  (index f-29-2)
+  (handlers (parse "sthint")
+           (print "sthint"))
+)
+
+(define-operand
+  (name movbr_mwh)
+  (comment "mwh completer for mov_br")
+  (type h-int64)
+  (index f-21-2)
+  (handlers (parse "mwh")
+           (print "mwh"))
+)
+
+(define-operand
+  (name movbr_ih)
+  (comment "ih completer for mov_br")
+  (type h-int64)
+  (index f-23-1)
+  (handlers (parse "ih")
+           (print "ih"))
+)
+
+(define-operand
+  (name lfhint)
+  (comment "lfhint for lfetch")
+  (type h-int64)
+  (index f-29-2)
+  (handlers (parse "lfhint")
+           (print "lfhint"))
+)
+
+(define-operand
+  (name sorsolsof)
+  (comment "combined i,l,o,r for alloc")
+  (type h-int64)
+  (index f-30-19)
+  (handlers (parse "sorsolsof")
+           (print "sorsolsof"))
+)
+
+;; These are architecturally ignored bits, as opposed to architecturally
+;; reserved bits.  I.e. we should assemble them in with zeros, but we should
+;; ignore them when disassembling.
+
+(dnop ign_36_1 "ignore 1 @ 36"                 () h-int64 f-36-1)
+(dnop ign_32_2 "ignore 2 @ 32"                 () h-int64 f-32-2)
+(dnop ign_32_1 "ignore 1 @ 32"                 () h-int64 f-32-1)
+(dnop ign_29_2 "ignore 2 @ 29"                 () h-int64 f-29-2)
+(dnop ign_27_4 "ignore 4 @ 27"                 () h-int64 f-27-4)
+(dnop ign_27_3 "ignore 3 @ 27"                 () h-int64 f-27-3)
+(dnop ign_27_1 "ignore 1 @ 27"                 () h-int64 f-27-1)
+(dnop ign_26_11        "ignore 11 @ 26"                () h-int64 f-26-11)
+(dnop ign_26_7 "ignore 7 @ 26"                 () h-int64 f-26-7)
+(dnop ign_26_1 "ignore 1 @ 26"                 () h-int64 f-26-1)
+(dnop ign_23_4 "ignore 4 @ 23"                 () h-int64 f-23-4)
+(dnop ign_19_7 "ignore 7 @ 19"                 () h-int64 f-19-7)
+(dnop ign_19_6 "ignore 6 @ 19"                 () h-int64 f-19-6)
+(dnop ign_19_4 "ignore 4 @ 19"                 () h-int64 f-19-4)
+(dnop ign_19_1 "ignore 1 @ 19"                 () h-int64 f-19-1)
+(dnop ign_13_1 "ignore 1 @ 13"                 () h-int64 f-13-1)
+(dnop ign_12_7 "ignore 7 @ 12"                 () h-int64 f-12-7)
+
+;; ??? Add more as needed.
+\f
+;;; "A" Format Instruction definitions.
+
+(define-pmacro (I-A1 mnemonic maybe-p1 op x2a ve x4 x2b)
+  (dni (.sym mnemonic maybe-p1)
+       (.str "Integer ALU, reg-reg, " mnemonic maybe-p1)
+       ((FORMAT A1))
+       (.str mnemonic " $r1=$r2,$r3" maybe-p1)
+       (+ (f-opcode op) (f-35-2 x2a) (f-33-1 ve) (f-32-4 x4) (f-28-2 x2b)
+         ign_36_1 r3 r2 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-A1 add ""   8 0 0 0 0)
+(I-A1 add ",1" 8 0 0 0 1)
+(I-A1 sub ""   8 0 0 1 1)
+(I-A1 sub ",1" 8 0 0 1 0)
+(I-A1 addp4 "" 8 0 0 2 0)
+(I-A1 and ""   8 0 0 3 0)
+(I-A1 andcm "" 8 0 0 3 1)
+(I-A1 or ""    8 0 0 3 2)
+(I-A1 xor ""   8 0 0 3 3)
+
+(define-pmacro (I-A2 mnemonic op x2a ve x4)
+  (dni mnemonic
+       (.str "Shift Left and Add, " mnemonic)
+       ((FORMAT A2))
+       (.str mnemonic " $r1=$r2,$count2a,$r3")
+       (+ (f-opcode op) (f-35-2 x2a) (f-33-1 ve) (f-32-4 x4)
+         ign_36_1 count2a r3 r2 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-A2 shladd   8 0 0 4)
+(I-A2 shladdp4 8 0 0 6)
+
+(define-pmacro (I-A3 mnemonic op x2a ve x4 x2b)
+  (dni (.sym mnemonic "i")
+       (.str "Integer ALU, imm8-reg, " mnemonic)
+       ((FORMAT A3))
+       (.str mnemonic " $r1=$imm8,$r3")
+       (+ (f-opcode op) (f-35-2 x2a) (f-33-1 ve) (f-32-4 x4) (f-28-2 x2b)
+         r3 imm8 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-A3 sub      8 0 0  9 1)
+(I-A3 and      8 0 0 11 0)
+(I-A3 andcm    8 0 0 11 1)
+(I-A3 or       8 0 0 11 2)
+(I-A3 xor      8 0 0 11 3)
+
+(define-pmacro (I-A4 mnemonic op x2a ve)
+  (dni (.str mnemonic "i")
+       (.str "Add imm14, " mnemonic)
+       ((FORMAT A4))
+       (.str mnemonic " $r1=$imm14,$r3")
+       (+ (f-opcode op) (f-35-2 x2a) (f-33-1 ve)
+         r3 imm14 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-A4 adds     8 2 0)
+(I-A4 addp4    8 3 0)
+
+(define-pmacro (I-A5 mnemonic op)
+  (dni (.str mnemonic)
+       (.str "Add imm22, " mnemonic)
+       ((FORMAT A5))
+       (.str mnemonic " $r1=$imm22,$r33")
+       (+ (f-opcode op) imm22 r33 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-A5 addl     9)
+
+(define-pmacro (I-A6 mnemonic ctype-attr op x2 tb ta c)
+  (dni (.sym mnemonic)
+       (.str "Integer Compare, reg-reg, " mnemonic)
+       ((FORMAT A6) (FIELD-CTYPE ctype-attr))
+       (.str mnemonic " $p1,$p2=$r2,$r3")
+       (+ (f-opcode op) (f-36-1 tb) (f-35-2 x2) (f-33-1 ta) (f-12-1 c)
+         p2 r3 r2 p1 qp)
+       ()
+       ()
+       )
+)
+
+(define-pmacro (I-A6-cmp-cond-ctype cmp cond ctype op x2 ta c)
+  (I-A6 (.sym cmp "." cond
+             (.eval (if (eq? (string-length ctype) 0) "" "."))
+             ctype)
+       (.eval (if (eq? (string-length ctype) 0) 'NONE (string->symbol ctype)))
+       op 0 x2 ta c)
+)
+
+(define-pmacro (I-A6-cmp cmp x2)
+  (begin
+    (I-A6-cmp-cond-ctype cmp lt  ""            12 x2 0 0)
+    (I-A6-cmp-cond-ctype cmp ltu ""            13 x2 0 0)
+    (I-A6-cmp-cond-ctype cmp eq  ""            14 x2 0 0)
+
+    (I-A6-cmp-cond-ctype cmp lt  "unc"         12 x2 0 1)
+    (I-A6-cmp-cond-ctype cmp ltu "unc"         13 x2 0 1)
+    (I-A6-cmp-cond-ctype cmp eq  "unc"         14 x2 0 1)
+
+    (I-A6-cmp-cond-ctype cmp eq  "and"         12 x2 1 0)
+    (I-A6-cmp-cond-ctype cmp eq  "or"          13 x2 1 0)
+    (I-A6-cmp-cond-ctype cmp eq  "or.andcm"    14 x2 1 0)
+
+    (I-A6-cmp-cond-ctype cmp ne  "and"         12 x2 1 1)
+    (I-A6-cmp-cond-ctype cmp ne  "or"          13 x2 1 1)
+    (I-A6-cmp-cond-ctype cmp ne  "or.andcm"    14 x2 1 1)
+    )
+)
+
+(I-A6-cmp cmp  0)
+(I-A6-cmp cmp4 1)
+
+(define-pmacro (I-A7 mnemonic ctype-attr op x2 tb ta c)
+  (dni (.sym mnemonic)
+       (.str "Integer Compare, zero-reg, " mnemonic)
+       ((FORMAT A7) (FIELD-CTYPE ctype-attr))
+       (.str mnemonic " $p1,$p2=r0,$r3")
+       (+ (f-opcode op) (f-36-1 tb) (f-35-2 x2) (f-33-1 ta) (f-12-1 c)
+         p2 r3 (f-19-7 0) p1 qp)
+       ()
+       ()
+       )
+)
+
+(define-pmacro (I-A7-cmp-cond-ctype cmp cond ctype op x2 ta c)
+  (I-A7 (.sym cmp "." cond "." ctype) (.sym ctype) op x2 1 ta c)
+)
+
+(define-pmacro (I-A7-cmp-cond cmp cond x2 ta c)
+  (begin
+    (I-A7-cmp-cond-ctype cmp cond and  12 x2 ta c)
+    (I-A7-cmp-cond-ctype cmp cond or   13 x2 ta c)
+    (I-A7-cmp-cond-ctype cmp cond andcm        14 x2 ta c)
+    )
+)
+
+(define-pmacro (I-A7-cmp cmp x2)
+  (begin
+    (I-A7-cmp-cond cmp gt x2 0 0)
+    (I-A7-cmp-cond cmp le x2 0 1)
+    (I-A7-cmp-cond cmp ge x2 1 0)
+    (I-A7-cmp-cond cmp lt x2 1 1)
+    )
+)
+
+(I-A7-cmp cmp  0)
+(I-A7-cmp cmp4 1)
+
+(define-pmacro (I-A8 mnemonic ctype-attr op x2 ta c)
+  (dni (.sym mnemonic)
+       (.str "Integer Compare, imm8-reg, " mnemonic)
+       ((FORMAT A7) (FIELD-CTYPE ctype-attr))
+       (.str mnemonic " $p1,$p2=$imm8,$r3")
+       (+ (f-opcode op) (f-35-2 x2) (f-33-1 ta) (f-12-1 c)
+         p2 r3 imm8 p1 qp)
+       ()
+       ()
+       )
+)
+
+(define-pmacro (I-A8-cmp-cond-ctype cmp cond ctype op x2 ta c)
+  (I-A8 (.sym cmp "." cond
+             (.eval (if (eq? (string-length ctype) 0) "" "."))
+             ctype)
+       (.eval (if (eq? (string-length ctype) 0) 'NONE (string->symbol ctype)))
+       op x2 ta c)
+)
+
+(define-pmacro (I-A8-cmp cmp x2)
+  (begin
+    (I-A8-cmp-cond-ctype cmp lt  ""            12 x2 0 0)
+    (I-A8-cmp-cond-ctype cmp ltu ""            13 x2 0 0)
+    (I-A8-cmp-cond-ctype cmp eq  ""            14 x2 0 0)
+
+    (I-A8-cmp-cond-ctype cmp lt  "unc"         12 x2 0 1)
+    (I-A8-cmp-cond-ctype cmp ltu "unc"         13 x2 0 1)
+    (I-A8-cmp-cond-ctype cmp eq  "unc"         14 x2 0 1)
+
+    (I-A8-cmp-cond-ctype cmp eq  "and"         12 x2 1 0)
+    (I-A8-cmp-cond-ctype cmp eq  "or"          12 x2 1 0)
+    (I-A8-cmp-cond-ctype cmp eq  "or.andcm"    12 x2 1 0)
+
+    (I-A8-cmp-cond-ctype cmp ne  "and"         12 x2 1 1)
+    (I-A8-cmp-cond-ctype cmp ne  "or"          12 x2 1 1)
+    (I-A8-cmp-cond-ctype cmp ne  "or.andcm"    12 x2 1 1)
+    )
+)
+
+(I-A8-cmp cmp  2)
+(I-A8-cmp cmp4 3)
+
+(define-pmacro (I-A9 mnemonic op x2a za zb x4 x2b)
+  (dni (.str mnemonic)
+       (.str "Multimetia ALU, " mnemonic)
+       ((FORMAT A9))
+       (.str mnemonic " $r1=$r2,$r3")
+       (+ (f-opcode op) (f-36-1 za) (f-35-2 x2a) (f-33-1 zb) (f-32-4 x4)
+         (f-28-2 x2b) r3 r2 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-A9 padd1    8 1 0 0 0 0)
+(I-A9 padd2    8 1 0 1 0 0)
+(I-A9 padd4    8 1 1 0 0 0)
+(I-A9 padd1.sss        8 1 0 0 0 1)
+(I-A9 padd2.sss        8 1 0 1 0 1)
+(I-A9 padd1.uuu        8 1 0 0 0 2)
+(I-A9 padd2.uuu        8 1 0 1 0 2)
+(I-A9 padd1.uus        8 1 0 0 0 3)
+(I-A9 padd2.uus        8 1 0 1 0 3)
+
+(I-A9 psub1    8 1 0 0 1 0)
+(I-A9 psub2    8 1 0 1 1 0)
+(I-A9 psub4    8 1 1 0 1 0)
+(I-A9 psub1.sss        8 1 0 0 1 1)
+(I-A9 psub2.sss        8 1 0 1 1 1)
+(I-A9 psub1.uuu        8 1 0 0 1 2)
+(I-A9 psub2.uuu        8 1 0 1 1 2)
+(I-A9 psub1.uus        8 1 0 0 1 3)
+(I-A9 psub2.uus        8 1 0 1 1 3)
+
+(I-A9 pavg1    8 1 0 0 2 2)
+(I-A9 pavg2    8 1 0 1 2 2)
+(I-A9 pavg1.raz        8 1 0 0 2 3)
+(I-A9 pavg2.raz        8 1 0 1 2 3)
+
+(I-A9 pavgsub1 8 1 0 0 3 2)
+(I-A9 pavgsub2 8 1 0 1 3 2)
+
+(I-A9 pcmp1.eq 8 1 0 0 9 0)
+(I-A9 pcmp2.eq 8 1 0 1 9 0)
+(I-A9 pcmp4.eq 8 1 1 0 9 0)
+(I-A9 pcmp1.gt 8 1 0 0 9 1)
+(I-A9 pcmp2.gt 8 1 0 1 9 1)
+(I-A9 pcmp4.gt 8 1 1 0 9 1)
+
+(define-pmacro (I-A10 mnemonic op x2a za zb x4)
+  (dni mnemonic
+       (.str "Multimedia Shift and Add, " mnemonic)
+       ((FORMAT A10))
+       (.str mnemonic " $r1=$r2,$count2b,$r3")
+       (+ (f-opcode op) (f-36-1 za) (f-35-2 x2a) (f-33-1 zb) (f-32-4 x4)
+         count2b r3 r2 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-A10 pshladd2 8 1 0 1 4)
+(I-A10 pshradd2 8 1 0 1 6)
+\f
+;;; "I" Format Instruction definitions.
+
+(define-pmacro (I-I1 mnemonic op za zb ve x2a x2b)
+  (dni mnemonic
+       (.str "Multimedia Multiply and Shift, " mnemonic)
+       ((FORMAT I1))
+       (.str mnemonic " $r1=$r2,$r3,$count2c")
+       (+ (f-opcode op) (f-36-1 za) (f-35-2 x2a) (f-33-1 zb) (f-32-1 ve)
+         (f-29-2 x2b) count2c ign_27_1 r3 r2 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-I1 pmpyshr2   7 0 1 0 0 3)
+(I-I1 pmpyshr2.u 7 0 1 0 0 1)
+
+(define-pmacro (I-I2 mnemonic op za zb ve x2a x2b x2c)
+  (dni mnemonic
+       (.str "Multimedia Multiply/Mix/Pack/Unpack, " mnemonic)
+       ((FORMAT I2))
+       (.str mnemonic " $r1=$r2,$r3")
+       (+ (f-opcode op) (f-36-1 za) (f-35-2 x2a) (f-33-1 zb) (f-32-1 ve)
+         (f-31-2 x2c) (f-29-2 x2b) ign_27_1 r3 r2 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-I2 pmpy2.r  7 0 1 0 2 1 3)
+(I-I2 pmpy2.l  7 0 1 0 2 3 3)
+
+(I-I2 mix1.r   7 0 0 0 2 0 2)
+(I-I2 mix2.r   7 0 1 0 2 0 2)
+(I-I2 mix4.r   7 1 0 0 2 0 2)
+(I-I2 mix1.l   7 0 0 0 2 2 2)
+(I-I2 mix2.l   7 0 1 0 2 2 2)
+(I-I2 mix4.l   7 1 0 0 2 2 2)
+
+(I-I2 pack2.uss        7 0 1 0 2 0 0)
+(I-I2 pack2.sss        7 0 1 0 2 2 0)
+(I-I2 pack4.sss        7 1 0 0 2 2 0)
+
+(I-I2 unpack1.h        7 0 0 0 2 0 1)
+(I-I2 unpack2.h        7 0 1 0 2 0 1)
+(I-I2 unpack4.h        7 1 0 0 2 0 1)
+(I-I2 unpack1.l        7 0 0 0 2 2 1)
+(I-I2 unpack2.l        7 0 1 0 2 2 1)
+(I-I2 unpack4.l        7 1 0 0 2 2 1)
+
+(I-I2 pmin1.u  7 0 0 0 2 1 0)
+(I-I2 pmax1.u  7 0 0 0 2 1 1)
+(I-I2 pmin2    7 0 1 0 2 3 0)
+(I-I2 pmax2    7 0 1 0 2 3 1)
+
+(I-I2 psad1    7 0 0 0 2 3 2)
+
+(define-pmacro (I-I3 mnemonic op za zb ve x2a x2b x2c)
+  (dni mnemonic
+       (.str "Multimedia Mux1, " mnemonic)
+       ((FORMAT I3))
+       (.str mnemonic " $r1=$r2,$mbtype4")
+       (+ (f-opcode op) (f-36-1 za) (f-35-2 x2a) (f-33-1 zb) (f-32-1 ve)
+         (f-31-2 x2c) (f-29-2 x2b) ign_27_4 mbtype4 r2 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-I3 mux1     7 0 0 0 3 2 2)
+
+(define-pmacro (I-I4 mnemonic op za zb ve x2a x2b x2c)
+  (dni mnemonic
+       (.str "Multimedia Mux2, " mnemonic)
+       ((FORMAT I4))
+       (.str mnemonic " $r1=$r2,$mhtype8")
+       (+ (f-opcode op) (f-36-1 za) (f-35-2 x2a) (f-33-1 zb) (f-32-1 ve)
+         (f-31-2 x2c) (f-29-2 x2b) mhtype8 r2 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-I4 mux2     7 0 1 0 3 2 2)
+
+(define-pmacro (I-I5 mnemonic op za zb ve x2a x2b x2c)
+  (dni mnemonic
+       (.str "Shift Right, variable, " mnemonic)
+       ((FORMAT I5))
+       (.str mnemonic " $r1=$r3,$r2")
+       (+ (f-opcode op) (f-36-1 za) (f-35-2 x2a) (f-33-1 zb) (f-32-1 ve)
+         (f-31-2 x2c) (f-29-2 x2b) ign_27_1 r3 r2 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-I5 pshr2    7 0 1 0 0 2 0)
+(I-I5 pshr4    7 1 0 0 0 2 0)
+(I-I5 shr      7 1 1 0 0 2 0)
+
+(I-I5 pshr2.u  7 0 1 0 0 0 0)
+(I-I5 pshr4.u  7 1 0 0 0 0 0)
+(I-I5 shr.u    7 1 1 0 0 0 0)
+
+(define-pmacro (I-I6 mnemonic op za zb ve x2a x2b x2c)
+  (dni (.sym mnemonic "i")
+       (.str "Shift Right, fixed, " mnemonic)
+       ((FORMAT I6))
+       (.str mnemonic " $r1=$r3,$count5")
+       (+ (f-opcode op) (f-36-1 za) (f-35-2 x2a) (f-33-1 zb) (f-32-1 ve)
+         (f-31-2 x2c) (f-29-2 x2b) ign_27_1 r3 ign_19_1 count5 ign_13_1
+         r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-I6 pshr2    7 0 1 0 1 3 0)
+(I-I6 pshr4    7 1 0 0 1 3 0)
+(I-I6 pshr2.u  7 0 1 0 1 1 0)
+(I-I6 pshr4.u  7 1 0 0 1 1 0)
+
+(define-pmacro (I-I7 mnemonic op za zb ve x2a x2b x2c)
+  (dni mnemonic
+       (.str "Shift Left, variable, " mnemonic)
+       ((FORMAT I7))
+       (.str mnemonic " $r1=$r2,$r3")
+       (+ (f-opcode op) (f-36-1 za) (f-35-2 x2a) (f-33-1 zb) (f-32-1 ve)
+         (f-31-2 x2c) (f-29-2 x2b) ign_27_1 r3 r2 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-I7 pshl2    7 0 1 0 0 0 1)
+(I-I7 pshl4    7 1 0 0 0 0 1)
+(I-I7 shl      7 1 1 0 0 0 1)
+
+(define-pmacro (I-I8 mnemonic op za zb ve x2a x2b x2c)
+  (dni (.sym mnemonic "i")
+       (.str "Shift Left, fixed, " mnemonic)
+       ((FORMAT I8))
+       (.str mnemonic " $r1=$r2,$ccount5")
+       (+ (f-opcode op) (f-36-1 za) (f-35-2 x2a) (f-33-1 zb) (f-32-1 ve)
+         (f-31-2 x2c) (f-29-2 x2b) ign_27_3 ccount5  r2 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-I8 pshl2    7 0 1 0 0 0 1)
+(I-I8 pshl4    7 1 0 0 0 0 1)
+
+(define-pmacro (I-I9 mnemonic op za zb ve x2a x2b x2c)
+  (dni mnemonic
+       (.str "Population Count, " mnemonic)
+       ((FORMAT I9))
+       (.str mnemonic " $r1=$r3")
+       (+ (f-opcode op) (f-36-1 za) (f-35-2 x2a) (f-33-1 zb) (f-32-1 ve)
+         (f-31-2 x2c) (f-29-2 x2b) ign_27_1 r3 (f-19-7 0) r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-I9 popcnt   7 0 1 0 1 1 2)
+
+(define-pmacro (I-I10 mnemonic op x2 x)
+  (dni mnemonic
+       (.str "Shift Right Pair, " mnemonic)
+       ((FORMAT I10))
+       (.str mnemonic " $r1=$r2,$r3,$count6")
+       (+ (f-opcode op) ign_36_1 (f-35-2 x2) (f-33-1 x) count6 r3 r2 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-I10 shrp    5 3 0)
+
+(define-pmacro (I-I11 mnemonic op x2 x y)
+  (dni mnemonic
+       (.str "Extract, " mnemonic)
+       ((FORMAT I11))
+       (.str mnemonic " $r1=$r3,$pos6,$len6")
+       (+ (f-opcode op) ign_36_1 (f-35-2 x2) (f-33-1 x) (f-13-1 y)
+         r3 pos6 len6 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-I11 extr.u  5 1 0 0)
+(I-I11 extr    5 1 0 1)
+
+(define-pmacro (I-I12 mnemonic op x2 x y)
+  (dni mnemonic
+       (.str "Zero and Deposit, " mnemonic)
+       ((FORMAT I12))
+       (.str mnemonic " $r1=$r2,$cpos6a,$len6")
+       (+ (f-opcode op) ign_36_1 (f-35-2 x2) (f-33-1 x) (f-26-1 y)
+         r2 cpos6a len6 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-I12 dep.z   5 1 1 0)
+
+(define-pmacro (I-I13 mnemonic op x2 x y)
+  (dni (.sym mnemonic "i")
+       (.str "Zero and Deposit Immediate, " mnemonic)
+       ((FORMAT I13))
+       (.str mnemonic " $r1=$imm8,$cpos6a,$len6")
+       (+ (f-opcode op) (f-35-2 x2) (f-33-1 x) (f-26-1 y)
+         imm8 cpos6a len6 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-I13 dep.z   5 1 1 0)
+
+(define-pmacro (I-I14 mnemonic op x2 x)
+  (dni (.sym mnemonic "i")
+       (.str "Deposit Immediate, " mnemonic)
+       ((FORMAT I14))
+       (.str mnemonic " $r1=$imm1,$r3,$cpos6b,$len6")
+       (+ (f-opcode op) (f-35-2 x2) (f-33-1 x) ign_13_1
+         imm1 r3 cpos6b len6 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-I14 dep     5 3 1)
+
+(define-pmacro (I-I15 mnemonic op)
+  (dni mnemonic
+       (.str "Deposit, " mnemonic)
+       ((FORMAT I15))
+       (.str mnemonic " $r1=$r2,$r3,$cpos6c,$len4")
+       (+ (f-opcode op) cpos6c len4 r2 r3 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-I15 dep     4)
+
+(define-pmacro (I-I16 mnemonic ctype-attr op x2 ta tb y c)
+  (dni mnemonic
+       (.str "Test Bit, " mnemonic)
+       ((FORMAT I16) (FIELD-CTYPE ctype-attr))
+       (.str mnemonic " $p1,$p2=$r3,$pos6")
+       (+ (f-opcode op) (f-36-1 tb) (f-35-2 x2) (f-33-1 ta) (f-13-1 y)
+         (f-12-1 c) p2 r3 pos6 p1 qp)
+       ()
+       ()
+       )
+)
+
+(define-pmacro (I-I16-ctype mnemonic ctype op x2 ta tb y c)
+  (I-I16 (.sym mnemonic
+              (.eval (if (eq? (string-length ctype) 0) "" "."))
+              ctype)
+        (.eval (if (eq? (string-length ctype) 0) 'NONE
+                   (string->symbol ctype)))
+        op x2 ta tb y c)
+)
+
+(I-I16-ctype tbit.z  ""                5 0 0 0 0 0)
+(I-I16-ctype tbit.z  "unc"     5 0 0 0 0 1)
+(I-I16-ctype tbit.z  "and"     5 0 0 1 0 0)
+(I-I16-ctype tbit.nz "and"     5 0 0 1 0 1)
+(I-I16-ctype tbit.z  "or"      5 0 1 0 0 0)
+(I-I16-ctype tbit.nz "or"      5 0 1 0 0 1)
+(I-I16-ctype tbit.z  "or.andcm"        5 0 1 1 0 0)
+(I-I16-ctype tbit.nz "or.andcm"        5 0 1 1 0 1)
+
+(define-pmacro (I-I17 mnemonic ctype-attr op x2 ta tb y c)
+  (dni mnemonic
+       (.str "Test Bit, " mnemonic)
+       ((FORMAT I17) (FIELD-CTYPE ctype-attr))
+       (.str mnemonic " $p1,$p2=$r3")
+       (+ (f-opcode op) (f-36-1 tb) (f-35-2 x2) (f-33-1 ta) (f-13-1 y)
+         (f-12-1 c) p2 r3 ign_19_6 p1 qp)
+       ()
+       ()
+       )
+)
+
+(define-pmacro (I-I17-ctype mnemonic ctype op x2 ta tb y c)
+  (I-I17 (.sym mnemonic
+              (.eval (if (eq? (string-length ctype) 0) "" "."))
+              ctype)
+        (.eval (if (eq? (string-length ctype) 0) 'NONE
+                   (string->symbol ctype)))
+        op x2 ta tb y c)
+)
+
+(I-I17-ctype tnat.z  ""                5 0 0 0 0 0)
+(I-I17-ctype tnat.z  "unc"     5 0 0 0 0 1)
+(I-I17-ctype tnat.z  "and"     5 0 0 1 0 0)
+(I-I17-ctype tnat.nz "and"     5 0 0 1 0 1)
+(I-I17-ctype tnat.z  "or"      5 0 1 0 0 0)
+(I-I17-ctype tnat.nz "or"      5 0 1 0 0 1)
+(I-I17-ctype tnat.z  "or.andcm"        5 0 1 1 0 0)
+(I-I17-ctype tnat.nz "or.andcm"        5 0 1 1 0 1)
+
+(define-pmacro (I-I18 mnemonic op vc)
+  (dni mnemonic
+       (.str "Move Long Immediate, " mnemonic)
+       ((FORMAT I18))
+       (.str mnemonic " $r1=$imm64")
+       (+ (f-opcode op) (f-20-1 vc) r1 imm64 qp)
+       ()
+       ()
+       )
+)
+
+(I-I18 movl    6 0)
+
+(define-pmacro (I-I19 mnemonic op x3 x6)
+  (dni mnemonic
+       (.str "Break/Nop, " mnemonic)
+       ((FORMAT I19))
+       (.str mnemonic " $imm21")
+       (+ (f-opcode op) (f-35-3 x3) (f-32-6 x6) ign_26_1 imm21 qp)
+       ()
+       ()
+       )
+)
+
+(I-I19 break.i 0 0 0)
+(I-I19 nop.i   0 0 1)
+
+(define-pmacro (I-I20 mnemonic op x3)
+  (dni mnemonic
+       (.str "Integer Speculation Check, " mnemonic)
+       ((FORMAT I20))
+       (.str mnemonic " $r2,$tgt25a")
+       (+ (f-opcode op) (f-35-3 x3) tgt25a r2 qp)
+       ()
+       ()
+       )
+)
+
+(I-I20 chk.s.i 0 1)
+
+(define-pmacro (I-I21 mnemonic op x3 x)
+  (dni (.sym mnemonic _tbr)
+       (.str "Move to BR, " mnemonic)
+       ((FORMAT I21))
+       (.str mnemonic
+            "$movbr_mwh$movbr_ih $b1=$r2,$tag13a")
+       (+ (f-opcode op) (f-35-3 x3) movbr_ih (f-22-1 x) movbr_mwh
+         (f-12-1 x) (f-11-3 x3) ign_36_1 b1 r2 tag13a qp)
+       ()
+       ()
+       )
+)
+
+(I-I21 mov     0 7 0)
+(I-I21 mov.ret 0 7 1)
+
+(define-pmacro (I-I22 mnemonic op x3 x6)
+  (dni (.sym mnemonic _fbr)
+       (.str "Move from BR, " mnemonic)
+       ((FORMAT I22))
+       (.str mnemonic " $r1=$b2")
+       (+ (f-opcode op) (f-35-3 x3) (f-32-6 x6) ign_36_1 ign_26_11
+         r1 b2 qp)
+       ()
+       ()
+       )
+)
+
+(I-I22 mov     0 0 #x31)
+
+(define-pmacro (I-I23 mnemonic op x3)
+  (dni (.sym mnemonic _tpr)
+       (.str "Move to PR, reg, " mnemonic)
+       ((FORMAT I23))
+       (.str mnemonic " pr=$r2,$imm17")
+       (+ (f-opcode op) (f-35-3 x3) ign_32_1 ign_23_4 r2 imm17 qp)
+       ()
+       ()
+       )
+)
+
+(I-I23 mov     0 3)
+
+(define-pmacro (I-I24 mnemonic op x3)
+  (dni (.sym mnemonic _tpri)
+       (.str "Move to PR, imm, " mnemonic)
+       ((FORMAT I24))
+       (.str mnemonic " pr.rot=$imm44")
+       (+ (f-opcode op) (f-35-3 x3) imm44 qp)
+       ()
+       ()
+       )
+)
+
+(I-I24 mov     0 2)
+
+(define-pmacro (I-I25 mnemonic src op x3 x6)
+  (dni (.sym mnemonic _f src)
+       (.str "Move from Pred/IP, " mnemonic)
+       ((FORMAT I25))
+       (.str mnemonic " $r1=" src)
+       (+ (f-opcode op) (f-35-3 x3) (f-32-6 x6) ign_26_7 ign_19_7 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-I25 mov ip  0 0 #x30)
+(I-I25 mov pr  0 0 #x33)
+
+(define-pmacro (I-I26 mnemonic op x3 x6)
+  (dni (.sym mnemonic _tar)
+       (.str "Move to AR, reg, " mnemonic)
+       ((FORMAT I26))
+       (.str mnemonic " $ar3=$r2")
+       (+ (f-opcode op) (f-35-3 x3) (f-32-6 x6) ign_36_1 ign_12_7 ar3 r2 qp)
+       ()
+       ()
+       )
+)
+
+(I-I26 mov.i   0 0 #x2A)
+
+(define-pmacro (I-I27 mnemonic op x3 x6)
+  (dni (.sym mnemonic _tari)
+       (.str "Move to AR, imm, " mnemonic)
+       ((FORMAT I27))
+       (.str mnemonic " $ar3=$imm8")
+       (+ (f-opcode op) (f-35-3 x3) (f-32-6 x6) ign_12_7 ar3 imm8 qp)
+       ()
+       ()
+       )
+)
+
+(I-I27 mov.i   0 0 #x0A)
+
+(define-pmacro (I-I28 mnemonic op x3 x6)
+  (dni (.sym mnemonic _far)
+       (.str "Move from AR, " mnemonic)
+       ((FORMAT I28))
+       (.str mnemonic " $r1=$ar3")
+       (+ (f-opcode op) (f-35-3 x3) (f-32-6 x6) ign_36_1 ign_19_7 ar3 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-I28 mov.i   0 0 #x32)
+
+(define-pmacro (I-I29 mnemonic op x3 x6)
+  (dni mnemonic
+       (.str "Sign/Zero Extend/Compute Zero Index, " mnemonic)
+       ((FORMAT I29))
+       (.str mnemonic " $r1=$r3")
+       (+ (f-opcode op) (f-35-3 x3) (f-32-6 x6) ign_36_1 ign_19_7 r3 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-I29 zxt1    0 0 #x10)
+(I-I29 zxt2    0 0 #x11)
+(I-I29 zxt4    0 0 #x12)
+
+(I-I29 sxt1    0 0 #x14)
+(I-I29 sxt2    0 0 #x15)
+(I-I29 sxt4    0 0 #x16)
+
+(I-I29 czx1.l  0 0 #x18)
+(I-I29 czx2.l  0 0 #x19)
+(I-I29 czx1.r  0 0 #x1C)
+(I-I29 czx2.r  0 0 #x1D)
+\f
+;;; "M" Format Instruction definitions.
+
+(define-pmacro (apply-ildspec macro mnemonic x6-2)
+  (begin
+    (.apply macro (.splice mnemonic            x6-2))
+    (.apply macro (.splice (.sym mnemonic .s)  (.eval (+ x6-2 #x04))))
+    (.apply macro (.splice (.sym mnemonic .a)  (.eval (+ x6-2 #x08))))
+    (.apply macro (.splice (.sym mnemonic .sa) (.eval (+ x6-2 #x0C))))
+    (.apply macro (.splice (.sym mnemonic .bias) (.eval (+ x6-2 #x10))))
+    (.apply macro (.splice (.sym mnemonic .acq)  (.eval (+ x6-2 #x14))))
+    (.apply macro (.splice (.sym mnemonic .c.clr) (.eval (+ x6-2 #x20))))
+    (.apply macro (.splice (.sym mnemonic .c.nc)  (.eval (+ x6-2 #x24))))
+    (.apply macro (.splice (.sym mnemonic .c.clr.acq)  (.eval (+ x6-2 #x28))))
+    )
+)
+
+(define-pmacro (I-M1 mnemonic op m x x6)
+  (dni mnemonic
+       (.str "Integer Load, " mnemonic)
+       ((FORMAT M1))
+       (.str mnemonic "$ldhint $r1=[$r3]")
+       (+ (f-opcode op) (f-36-1 m) (f-35-6 x6) ldhint (f-27-1 x)
+         r3 r1 ign_19_7 qp)
+       ()
+       ()
+       )
+)
+
+(apply-ildspec
+ (.pmacro (mnemonic x6)
+         (I-M1 mnemonic 4 0 0 x6))
+ ld1 0)
+
+(apply-ildspec
+ (.pmacro (mnemonic x6)
+         (I-M1 mnemonic 4 0 0 x6))
+ ld2 1)
+
+(apply-ildspec
+ (.pmacro (mnemonic x6)
+         (I-M1 mnemonic 4 0 0 x6))
+ ld4 2)
+
+(apply-ildspec
+ (.pmacro (mnemonic x6)
+         (I-M1 mnemonic 4 0 0 x6))
+ ld8 3)
+
+(I-M1 ld8.fill 4 0 0 #x1B)
+
+(define-pmacro (I-M2 mnemonic op m x x6)
+  (dni (.sym mnemonic .ir)
+       (.str "Integer Load, incr reg, " mnemonic)
+       ((FORMAT M2))
+       (.str mnemonic "$ldhint $r1=[$r3],$r2")
+       (+ (f-opcode op) (f-36-1 m) (f-35-6 x6) ldhint (f-27-1 x)
+         r3 r2 r1 qp)
+       ()
+       ()
+       )
+)
+
+(apply-ildspec
+ (.pmacro (mnemonic x6)
+         (I-M2 mnemonic 4 1 0 x6))
+ ld1 0)
+
+(apply-ildspec
+ (.pmacro (mnemonic x6)
+         (I-M2 mnemonic 4 1 0 x6))
+ ld2 1)
+
+(apply-ildspec
+ (.pmacro (mnemonic x6)
+         (I-M2 mnemonic 4 1 0 x6))
+ ld4 2)
+
+(apply-ildspec
+ (.pmacro (mnemonic x6)
+         (I-M2 mnemonic 4 1 0 x6))
+ ld8 3)
+
+(I-M2 ld8.fill 4 1 0 #x1B)
+
+(define-pmacro (I-M3 mnemonic op x6)
+  (dni (.sym mnemonic .ii)
+       (.str "Integer Load, incr imm, " mnemonic)
+       ((FORMAT M3))
+       (.str mnemonic "$ldhint $r1=[$r3],$imm9a")
+       (+ (f-opcode op) (f-35-6 x6) ldhint r3 imm9a r1 qp)
+       ()
+       ()
+       )
+)
+
+(apply-ildspec
+ (.pmacro (mnemonic x6)
+         (I-M3 mnemonic 5 x6))
+ ld1 0)
+
+(apply-ildspec
+ (.pmacro (mnemonic x6)
+         (I-M3 mnemonic 5 x6))
+ ld2 1)
+
+(apply-ildspec
+ (.pmacro (mnemonic x6)
+         (I-M3 mnemonic 5 x6))
+ ld4 2)
+
+(apply-ildspec
+ (.pmacro (mnemonic x6)
+         (I-M3 mnemonic 5 x6))
+ ld8 3)
+
+(I-M3 ld8.fill 5 #x1B)
+
+(define-pmacro (apply-istspec macro mnemonic x6-2)
+  (begin
+    (.apply macro (.splice mnemonic            x6-2))
+    (.apply macro (.splice (.sym mnemonic .rel)        (.eval (+ x6-2 #x04))))
+    )
+)
+
+(define-pmacro (I-M4 mnemonic op m x x6)
+  (dni mnemonic
+       (.str "Integer Store, " mnemonic)
+       ((FORMAT M4))
+       (.str mnemonic "$sthint [$r3]=$r2")
+       (+ (f-opcode op) (f-36-1 m) (f-35-6 x6) (f-27-1 x)
+         sthint r3 r2 ign_12_7 qp)
+       ()
+       ()
+       )
+)
+
+(apply-istspec
+ (.pmacro (mnemonic x6)
+         (I-M4 mnemonic 4 0 0 x6))
+ st1 #x30)
+
+(apply-istspec
+ (.pmacro (mnemonic x6)
+         (I-M4 mnemonic 4 0 0 x6))
+ st2 #x31)
+
+(apply-istspec
+ (.pmacro (mnemonic x6)
+         (I-M4 mnemonic 4 0 0 x6))
+ st4 #x32)
+
+(apply-istspec
+ (.pmacro (mnemonic x6)
+         (I-M4 mnemonic 4 0 0 x6))
+ st8 #x33)
+
+(I-M4 st8.spill 4 0 0 #x3B)
+
+(define-pmacro (I-M5 mnemonic op x6)
+  (dni (.sym mnemonic .ii)
+       (.str "Integer Store, incr imm, " mnemonic)
+       ((FORMAT M5))
+       (.str mnemonic "$sthint [$r3]=$r2,$imm9b")
+       (+ (f-opcode op) (f-35-6 x6) sthint r3 imm9b r2 qp)
+       ()
+       ()
+       )
+)
+
+(apply-istspec
+ (.pmacro (mnemonic x6)
+         (I-M5 mnemonic 5 x6))
+ st1 #x30)
+
+(apply-istspec
+ (.pmacro (mnemonic x6)
+         (I-M5 mnemonic 5 x6))
+ st2 #x31)
+
+(apply-istspec
+ (.pmacro (mnemonic x6)
+         (I-M5 mnemonic 5 x6))
+ st4 #x32)
+
+(apply-istspec
+ (.pmacro (mnemonic x6)
+         (I-M5 mnemonic 5 x6))
+ st8 #x33)
+
+(I-M5 st8.spill 5 #x3B)
+
+(define-pmacro (apply-fldspec macro mnemonic x6-2)
+  (begin
+    (.apply macro (.splice mnemonic              x6-2))
+    (.apply macro (.splice (.sym mnemonic .s)     (.eval (+ x6-2 #x04))))
+    (.apply macro (.splice (.sym mnemonic .a)     (.eval (+ x6-2 #x08))))
+    (.apply macro (.splice (.sym mnemonic .sa)    (.eval (+ x6-2 #x0C))))
+    (.apply macro (.splice (.sym mnemonic .c.clr) (.eval (+ x6-2 #x20))))
+    (.apply macro (.splice (.sym mnemonic .c.nc)  (.eval (+ x6-2 #x24))))
+    )
+)
+
+(define-pmacro (I-M6 mnemonic op m x x6)
+  (dni mnemonic
+       (.str "Floating-point Load, " mnemonic)
+       ((FORMAT M6))
+       (.str mnemonic "$ldhint $f1=[$r3]")
+       (+ (f-opcode op) (f-36-1 m) (f-35-6 x6) ldhint (f-27-1 x)
+         r3 f1 ign_19_7 qp)
+       ()
+       ()
+       )
+)
+
+(apply-fldspec
+ (.pmacro (mnemonic x6)
+         (I-M6 mnemonic 6 0 0 x6))
+ ldfs 2)
+
+(apply-fldspec
+ (.pmacro (mnemonic x6)
+         (I-M6 mnemonic 6 0 0 x6))
+ ldfd 3)
+
+(apply-fldspec
+ (.pmacro (mnemonic x6)
+         (I-M6 mnemonic 6 0 0 x6))
+ ldf8 1)
+
+(apply-fldspec
+ (.pmacro (mnemonic x6)
+         (I-M6 mnemonic 6 0 0 x6))
+ ldfe 0)
+
+(I-M6 ldf.fill 6 0 0 #x1B)
+
+(define-pmacro (I-M7 mnemonic op m x x6)
+  (dni (.sym mnemonic .ir)
+       (.str "Floating-point Load, incr reg, " mnemonic)
+       ((FORMAT M7))
+       (.str mnemonic "$ldhint $f1=[$r3],$r2")
+       (+ (f-opcode op) (f-36-1 m) (f-35-6 x6) ldhint (f-27-1 x)
+         r3 r2 f1 qp)
+       ()
+       ()
+       )
+)
+
+(apply-fldspec
+ (.pmacro (mnemonic x6)
+         (I-M7 mnemonic 6 1 0 x6))
+ ldfs 2)
+
+(apply-fldspec
+ (.pmacro (mnemonic x6)
+         (I-M7 mnemonic 6 1 0 x6))
+ ldfd 3)
+
+(apply-fldspec
+ (.pmacro (mnemonic x6)
+         (I-M7 mnemonic 6 1 0 x6))
+ ldf8 1)
+
+(apply-fldspec
+ (.pmacro (mnemonic x6)
+         (I-M7 mnemonic 6 1 0 x6))
+ ldfe 0)
+
+(I-M7 ldf.fill 6 1 0 #x1B)
+
+(define-pmacro (I-M8 mnemonic op x6)
+  (dni (.sym mnemonic .ii)
+       (.str "Floating-point Load, incr imm, " mnemonic)
+       ((FORMAT M8))
+       (.str mnemonic "$ldhint $f1=[$r3],$imm9a")
+       (+ (f-opcode op) (f-35-6 x6) ldhint r3 imm9a f1 qp)
+       ()
+       ()
+       )
+)
+
+(apply-fldspec
+ (.pmacro (mnemonic x6)
+         (I-M8 mnemonic 7 x6))
+ ldfs 2)
+
+(apply-fldspec
+ (.pmacro (mnemonic x6)
+         (I-M8 mnemonic 7 x6))
+ ldfd 3)
+
+(apply-fldspec
+ (.pmacro (mnemonic x6)
+         (I-M8 mnemonic 7 x6))
+ ldf8 1)
+
+(apply-fldspec
+ (.pmacro (mnemonic x6)
+         (I-M8 mnemonic 7 x6))
+ ldfe 0)
+
+(I-M8 ldf.fill 7 #x1B)
+
+(define-pmacro (I-M9 mnemonic op m x x6)
+  (dni mnemonic
+       (.str "Floating-point Store, " mnemonic)
+       ((FORMAT M9))
+       (.str mnemonic "$sthint [$r3]=$f2")
+       (+ (f-opcode op) (f-36-1 m) (f-35-6 x6) (f-27-1 x)
+         sthint r3 f2 ign_12_7 qp)
+       ()
+       ()
+       )
+)
+
+(I-M9 stfs             6 0 0 #x32)
+(I-M9 stfd             6 0 0 #x33)
+(I-M9 stf8             6 0 0 #x31)
+(I-M9 stfe             6 0 0 #x30)
+(I-M9 stf.spill                6 0 0 #x3B)
+
+(define-pmacro (I-M10 mnemonic op x6)
+  (dni (.sym mnemonic .ii)
+       (.str "Floating-point Store, incr imm, " mnemonic)
+       ((FORMAT M10))
+       (.str mnemonic "$sthint [$r3]=$f2,$imm9b")
+       (+ (f-opcode op) (f-35-6 x6) sthint r3 imm9b f2 qp)
+       ()
+       ()
+       )
+)
+
+(I-M10 stfs            7 #x32)
+(I-M10 stfd            7 #x33)
+(I-M10 stf8            7 #x31)
+(I-M10 stfe            7 #x30)
+(I-M10 stf.spill       7 #x3B)
+
+(define-pmacro (I-M11 mnemonic op m x x6)
+  (dni mnemonic
+       (.str "Floating-point Load Pair, " mnemonic)
+       ((FORMAT M11))
+       (.str mnemonic "$ldhint $f1,$f2=[$r3]")
+       (+ (f-opcode op) (f-36-1 m) (f-35-6 x6) ldhint (f-27-1 x)
+         r3 f1 f2 qp)
+       ()
+       ()
+       )
+)
+
+(apply-fldspec
+ (.pmacro (mnemonic x6)
+         (I-M11 mnemonic 6 0 1 x6))
+ ldfps 2)
+
+(apply-fldspec
+ (.pmacro (mnemonic x6)
+         (I-M11 mnemonic 6 0 1 x6))
+ ldfpd 3)
+
+(apply-fldspec
+ (.pmacro (mnemonic x6)
+         (I-M11 mnemonic 6 0 1 x6))
+ ldfp8 1)
+
+(define-pmacro (I-M12 mnemonic n op m x x6)
+  (dni mnemonic
+       (.str "Floating-point Load Pair, incr imm, " mnemonic)
+       ((FORMAT M12))
+       (.str mnemonic "$ldhint $f1,$f2=[$r3]," n)
+       (+ (f-opcode op) (f-36-1 m) (f-35-6 x6) ldhint (f-27-1 x)
+         r3 f1 f2 qp)
+       ()
+       ()
+       )
+)
+
+(apply-fldspec
+ (.pmacro (mnemonic x6)
+         (I-M12 mnemonic 8 6 1 1 x6))
+ ldfps 2)
+
+(apply-fldspec
+ (.pmacro (mnemonic x6)
+         (I-M12 mnemonic 16 6 1 1 x6))
+ ldfpd 3)
+
+(apply-fldspec
+ (.pmacro (mnemonic x6)
+         (I-M12 mnemonic 16 6 1 1 x6))
+ ldfp8 1)
+
+(define-pmacro (apply-lftype macro mnemonic)
+  (begin
+    (.apply macro (.splice mnemonic                    NONE    #x2C))
+    (.apply macro (.splice (.sym mnemonic .excl)       NONE    #x2D))
+    (.apply macro (.splice (.sym mnemonic .fault)      fault   #x2E))
+    (.apply macro (.splice (.sym mnemonic .fault.excl) fault   #x2F))
+    )
+)
+
+(define-pmacro (I-M13 mnemonic fault-attr op m x x6)
+  (dni (.sym mnemonic)
+       (.str "Line Prefetch, " mnemonic)
+       ((FORMAT M13) (FIELD-LFTYPE fault-attr))
+       (.str mnemonic "$lfhint [$r3]")
+       (+ (f-opcode op) (f-36-1 m) (f-35-6 x6) lfhint (f-27-1 x)
+         r3 ign_19_7 ign_12_7 qp)
+       ()
+       ()
+       )
+)
+
+(apply-lftype
+ (.pmacro (mnemonic fault-attr x6)
+         (I-M13 mnemonic fault-attr 6 0 0 x6))
+ lfetch)
+
+(define-pmacro (I-M14 mnemonic fault-attr op m x x6)
+  (dni (.sym mnemonic .ir)
+       (.str "Line Prefetch, incr reg" mnemonic)
+       ((FORMAT M14) (FIELD-LFTYPE fault-attr))
+       (.str mnemonic "$lfhint [$r3],$r2")
+       (+ (f-opcode op) (f-36-1 m) (f-35-6 x6) lfhint (f-27-1 x)
+         r3 r2 ign_12_7 qp)
+       ()
+       ()
+       )
+)
+
+(apply-lftype
+ (.pmacro (mnemonic fault-attr x6)
+         (I-M14 mnemonic fault-attr 6 0 0 x6))
+ lfetch)
+
+(define-pmacro (I-M15 mnemonic fault-attr op x6)
+  (dni (.sym mnemonic .ii)
+       (.str "Line Prefetch, incr imm" mnemonic)
+       ((FORMAT M15) (FIELD-LFTYPE fault-attr))
+       (.str mnemonic "$lfhint [$r3],$imm9a")
+       (+ (f-opcode op) (f-35-6 x6) lfhint r3 imm9a ign_12_7 qp)
+       ()
+       ()
+       )
+)
+
+(apply-lftype
+ (.pmacro (mnemonic fault-attr x6)
+         (I-M15 mnemonic fault-attr 7 x6))
+ lfetch)
+
+(define-pmacro (I-M16 mnemonic extra op m x x6)
+  (dni mnemonic
+       (.str "Exchange/Compare and Exchange, " mnemonic)
+       ((FORMAT M16))
+       (.str mnemonic "$ldhint $r1=[$r3],$r2" extra)
+       (+ (f-opcode op) (f-36-1 m) (f-35-6 x6) (f-27-1 x)
+         ldhint r3 r2 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-M16 cmpxchg1.acq ",ar.ccv"  4 0 1 #x00)
+(I-M16 cmpxchg2.acq ",ar.ccv"  4 0 1 #x01)
+(I-M16 cmpxchg4.acq ",ar.ccv"  4 0 1 #x02)
+(I-M16 cmpxchg8.acq ",ar.ccv"  4 0 1 #x03)
+
+(I-M16 cmpxchg1.rel ",ar.ccv"  4 0 1 #x04)
+(I-M16 cmpxchg2.rel ",ar.ccv"  4 0 1 #x05)
+(I-M16 cmpxchg4.rel ",ar.ccv"  4 0 1 #x06)
+(I-M16 cmpxchg8.rel ",ar.ccv"  4 0 1 #x07)
+
+(I-M16 xchg1.rel ""            4 0 1 #x08)
+(I-M16 xchg2.rel ""            4 0 1 #x09)
+(I-M16 xchg4.rel ""            4 0 1 #x0A)
+(I-M16 xchg8.rel ""            4 0 1 #x0B)
+
+(define-pmacro (I-M17 mnemonic op m x x6)
+  (dni mnemonic
+       (.str "Fetch and Add, " mnemonic)
+       ((FORMAT M17))
+       (.str mnemonic "$ldhint $r1=[$r3],$inc3")
+       (+ (f-opcode op) (f-36-1 m) (f-35-6 x6) (f-27-1 x)
+         ldhint r3 ign_19_4 inc3 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-M17 fetchadd4.acq           4 0 1 #x12)
+(I-M17 fetchadd8.acq           4 0 1 #x13)
+(I-M17 fetchadd4.rel           4 0 1 #x16)
+(I-M17 fetchadd8.rel           4 0 1 #x17)
+
+(define-pmacro (I-M18 mnemonic op m x x6)
+  (dni mnemonic
+       (.str "Set FR, " mnemonic)
+       ((FORMAT M18))
+       (.str mnemonic " $f1=$r2")
+       (+ (f-opcode op) (f-36-1 m) (f-35-6 x6) (f-27-1 x)
+         ign_26_7 ign_29_2 r2 f1 qp)
+       ()
+       ()
+       )
+)
+
+(I-M18 setf.sig                        6 0 1 #x1C)
+(I-M18 setf.exp                        6 0 1 #x1D)
+(I-M18 setf.s                  6 0 1 #x1E)
+(I-M18 setf.d                  6 0 1 #x1F)
+
+(define-pmacro (I-M19 mnemonic op m x x6)
+  (dni mnemonic
+       (.str "Get FR, " mnemonic)
+       ((FORMAT M19))
+       (.str mnemonic " $r1=$f2")
+       (+ (f-opcode op) (f-36-1 m) (f-35-6 x6) (f-27-1 x)
+         ign_26_7 ign_29_2 f2 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-M19 getf.sig                        4 0 1 #x1C)
+(I-M19 getf.exp                        4 0 1 #x1D)
+(I-M19 getf.s                  4 0 1 #x1E)
+(I-M19 getf.d                  4 0 1 #x1F)
+
+(define-pmacro (I-M20 mnemonic op x3)
+  (dni mnemonic
+       (.str "Integer Speculation Check, " mnemonic)
+       ((FORMAT M20))
+       (.str mnemonic " $r2,$tgt25a")
+       (+ (f-opcode op) (f-35-3 x3) r2 tgt25a qp)
+       ()
+       ()
+       )
+)
+
+(I-M20 chk.s.m                 1 1)
+
+(define-pmacro (I-M21 mnemonic op x3)
+  (dni (.sym mnemonic .f)
+       (.str "Floating-point Speculation Check, " mnemonic)
+       ((FORMAT M21))
+       (.str mnemonic " $f2,$tgt25a")
+       (+ (f-opcode op) (f-35-3 x3) f2 tgt25a qp)
+       ()
+       ()
+       )
+)
+
+(I-M21 chk.s                   1 3)
+
+(define-pmacro (I-M22 mnemonic op x3)
+  (dni mnemonic
+       (.str "Integer Advanced Load Check, " mnemonic)
+       ((FORMAT M22))
+       (.str mnemonic " $r1,$tgt25c")
+       (+ (f-opcode op) (f-35-3 x3) tgt25c r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-M22 chk.a.nc                        0 4)
+(I-M22 chk.a.clr               0 5)
+
+(define-pmacro (I-M23 mnemonic op x3)
+  (dni (.sym mnemonic .f)
+       (.str "Floating-point Advanced Load Check, " mnemonic)
+       ((FORMAT M23))
+       (.str mnemonic " $f1,$tgt25c")
+       (+ (f-opcode op) (f-35-3 x3) tgt25c f1 qp)
+       ()
+       ()
+       )
+)
+
+(I-M22 chk.a.nc                        0 6)
+(I-M22 chk.a.clr               0 7)
+
+(define-pmacro (I-M24 mnemonic op x3 x4 x2)
+  (dni mnemonic
+       (.str "Sync/Fence/Serialize/ALAT Control, " mnemonic)
+       ((FORMAT M24))
+       (.str mnemonic)
+       (+ (f-opcode op) (f-35-3 x3) (f-32-2 x2) (f-30-4 x4)
+         ign_36_1 ign_26_7 ign_19_7 ign_12_7 qp)
+       ()
+       ()
+       )
+)
+
+(I-M24 invala                  0 0 0 1)
+(I-M24 fwb                     0 0 0 2)
+(I-M24 mf                      0 0 2 2)
+(I-M24 mf.a                    0 0 3 2)
+(I-M24 srlz.d                  0 0 0 3)
+(I-M24 srlz.i                  0 0 1 3)
+(I-M24 sync.i                  0 0 3 3)
+
+(define-pmacro (I-M25 mnemonic op x3 x4 x2)
+  (dni mnemonic
+       (.str "RSE Control, " mnemonic)
+       ((FORMAT M25))
+       (.str mnemonic)
+       (+ (f-opcode op) (f-35-3 x3) (f-32-2 x2) (f-30-4 x4)
+         ign_36_1 ign_26_7 ign_19_7 ign_12_7 (f-qp 0))
+       ()
+       ()
+       )
+)
+
+(I-M25 flushrs                 0 0 #xC 0)
+(I-M25 loadrs                  0 0 #xA 0)
+
+(define-pmacro (I-M26 mnemonic op x3 x4 x2)
+  (dni mnemonic
+       (.str "Integer ALAT Entry Invalidate, " mnemonic)
+       ((FORMAT M26))
+       (.str mnemonic " $r1")
+       (+ (f-opcode op) (f-35-3 x3) (f-32-2 x2) (f-30-4 x4)
+         ign_36_1 ign_26_7 ign_19_7 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-M26 invala.e                        0 0 2 1)
+
+(define-pmacro (I-M27 mnemonic op x3 x4 x2)
+  (dni (.sym mnemonic .f)
+       (.str "Floating-point ALAT Entry Invalidate, " mnemonic)
+       ((FORMAT M27))
+       (.str mnemonic " $f1")
+       (+ (f-opcode op) (f-35-3 x3) (f-32-2 x2) (f-30-4 x4)
+         ign_36_1 ign_26_7 ign_19_7 f1 qp)
+       ()
+       ()
+       )
+)
+
+(I-M27 invala.e                        0 0 3 1)
+
+(define-pmacro (I-M28 mnemonic op x3 x6)
+  (dni mnemonic
+       (.str "Flush Cache/Purge Translation Cache Entry, " mnemonic)
+       ((FORMAT M28))
+       (.str mnemonic " $r3")
+       (+ (f-opcode op) (f-35-3 x3) (f-32-6 x6)
+         ign_36_1 r3 ign_19_7 ign_12_7 qp)
+       ()
+       ()
+       )
+)
+
+(I-M28 fc                      1 0 #x30)
+(I-M28 ptc.e                   1 0 #x34)
+
+(define-pmacro (I-M29 mnemonic op x3 x6)
+  (dni (.sym mnemonic _tar)
+       (.str "Move to AR, reg, " mnemonic)
+       ((FORMAT M29))
+       (.str mnemonic " $ar3=$r2")
+       (+ (f-opcode op) (f-35-3 x3) (f-32-6 x6)
+         ign_36_1 ar3 r2 ign_12_7 qp)
+       ()
+       ()
+       )
+)
+
+(I-M29 mov.m   1 0 #x2A)
+
+(define-pmacro (I-M30 mnemonic op x3 x4 x2)
+  (dni (.sym mnemonic _tari)
+       (.str "Move to AR, imm," mnemonic)
+       ((FORMAT M30))
+       (.str mnemonic " $ar3=$imm8")
+       (+ (f-opcode op) (f-35-3 x3) (f-32-2 x2) (f-30-4 x4)
+         ar3 imm8 ign_12_7 qp)
+       ()
+       ()
+       )
+)
+
+(I-M30 mov.m   0 0 8 2)
+
+(define-pmacro (I-M31 mnemonic op x3 x6)
+  (dni (.sym mnemonic _far)
+       (.str "Move from AR, " mnemonic)
+       ((FORMAT M31))
+       (.str mnemonic " $r1=$ar3")
+       (+ (f-opcode op) (f-35-3 x3) (f-32-6 x6) ign_36_1 ign_19_7 ar3 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-M31 mov.m   1 0 #x22)
+
+(define-pmacro (I-M32 mnemonic op x3 x6)
+  (dni (.sym mnemonic _tcr)
+       (.str "Move to CR, " mnemonic)
+       ((FORMAT M32))
+       (.str mnemonic " $cr3=$r2")
+       (+ (f-opcode op) (f-35-3 x3) (f-32-6 x6)
+         ign_36_1 cr3 r2 ign_12_7 qp)
+       ()
+       ()
+       )
+)
+
+(I-M32 mov     1 0 #x2C)
+
+(define-pmacro (I-M33 mnemonic op x3 x6)
+  (dni (.sym mnemonic _fcr)
+       (.str "Move from CR, " mnemonic)
+       ((FORMAT M33))
+       (.str mnemonic " $r1=$cr3")
+       (+ (f-opcode op) (f-35-3 x3) (f-32-6 x6)
+         ign_36_1 cr3 ign_19_7 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-M33 mov     1 0 #x24)
+
+(define-pmacro (I-M34 mnemonic op x3)
+  (dni mnemonic
+       (.str "Allocate Register Stack Frame, " mnemonic)
+       ((FORMAT M34))
+       (.str mnemonic " $r1=ar.pfs,$sorsolsof")
+       (+ (f-opcode op) (f-35-3 x3) ign_36_1 ign_32_2
+         sorsolsof r1 (f-qp 0))
+       ()
+       ()
+       )
+)
+
+(I-M34 alloc   1 6)
+
+(define-pmacro (I-M35 mnemonic which op x3 x6)
+  (dni (.sym mnemonic _t which)
+       (.str "Move to PSR, " mnemonic)
+       ((FORMAT M35))
+       (.str mnemonic " " which "=$r2")
+       (+ (f-opcode op) (f-35-3 x3) (f-32-6 x6) ign_36_1
+         r2 ign_26_7 ign_12_7 qp)
+       ()
+       ()
+       )
+)
+
+(I-M35 mov psr.l       1 0 #x2D)
+(I-M35 mov psr.um      1 0 #x29)
+
+(define-pmacro (I-M36 mnemonic which op x3 x6)
+  (dni (.sym mnemonic _f which)
+       (.str "Move from PSR, " mnemonic)
+       ((FORMAT M35))
+       (.str mnemonic " $r1=" which)
+       (+ (f-opcode op) (f-35-3 x3) (f-32-6 x6) ign_36_1
+         ign_26_7 ign_19_7 r1 qp)
+       ()
+       ()
+       )
+)
+
+(I-M36 mov psr         1 0 #x25)
+(I-M36 mov psr.um      1 0 #x21)
+
+(define-pmacro (I-M37 mnemonic op x3 x4 x2)
+  (dni mnemonic
+       (.str "Break/Nop, " mnemonic)
+       ((FORMAT M37))
+       (.str mnemonic " $imm21")
+       (+ (f-opcode op) (f-35-3 x3) (f-32-2 x2) (f-30-4 x4) ign_26_1 imm21 qp)
+       ()
+       ()
+       )
+)
+
+(I-M37 break.m         0 0 0 0)
+(I-M37 nop.m           0 0 1 0)
+
diff --git a/cgen/ifield.scm b/cgen/ifield.scm
new file mode 100644 (file)
index 0000000..0a47f02
--- /dev/null
@@ -0,0 +1,1164 @@
+; Instruction fields.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; The `<ifield>' class.
+; (pronounced "I-field")
+;
+; These describe raw data, little semantic content is attributed to them.
+; The goal being to avoid interfering with future applications.
+;
+; FIXME: Move start, word-offset, word-length into the instruction format?
+; - would require proper ordering of fields in insns, but that's ok.
+;   (??? though the sparc64 description shows a case where its useful to
+;   not have to worry about instruction ordering - different versions of an
+;   insn take different fields and these fields are passed via a macro)
+;
+; ??? One could treat all ifields as being unsigned.  They could be thought of
+; as indices into a table of values, be they signed, unsigned, floating point,
+; whatever.  Just an idea.
+;
+; ??? Split into two?  One for definition, and one for value.
+
+(define <ifield>
+  (class-make '<ifield>
+             '(<ident>)
+             '(
+               ; The mode the raw value is to be interpreted in.
+               mode
+
+               ; A <bitrange> object.
+               ; This contains the field's offset, start, length, word-length,
+               ; and orientation (msb==0, lsb==0).  The orientation is
+               ; recorded to keep the <bitrange> object self-contained.
+               ; Endianness is not recorded.
+               bitrange
+
+               ; Argument to :follows, as an object.
+               ; FIXME: wip
+               (follows . #f)
+
+               ; ENCODE/DECODE operate on the raw value, absent of any context
+               ; save `pc' and mode of field.
+               ; If #f, no special processing is required.
+               ; ??? It's not clear where the best place to process fields is.
+               ; An earlier version had insert/extract fields in operands to
+               ; handle more complicated cases.  Following the goal of
+               ; incremental complication, the special handling for m32r's
+               ; f-disp8 field is handled entirely here, rather than partially
+               ; here and partially in the operand.
+               encode decode
+
+               ; Value of field, if there is one.
+               ; Possible types are: integer, <operand>, ???
+               value
+               )
+             nil)
+)
+
+; {value},{follows} are missing on purpose
+; {value} is handled specially.
+; {follows} is rarely used
+(method-make-make! <ifield> '(name comment attrs mode bitrange encode decode))
+
+; Accessor fns
+; ??? `value' is treated specially, needed anymore?
+
+(define-getters <ifield> ifld (mode encode decode follows))
+
+(define-setters <ifield> ifld (follows))
+
+; internal fn
+(define -ifld-bitrange (elm-make-getter <ifield> 'bitrange))
+
+(define (ifld-word-offset f) (bitrange-word-offset (-ifld-bitrange f)))
+(define (ifld-word-length f) (bitrange-word-length (-ifld-bitrange f)))
+
+; Return the mode of the value passed to the encode rtl.
+; This is the mode of the result of the decode rtl.
+
+(define (ifld-encode-mode f)
+  (if (ifld-decode f)
+      ; cadr/cadr gets WI in ((value pc) (sra WI ...))
+      (mode:lookup (cadr (cadr (ifld-decode f))))
+      (ifld-mode f))
+)
+
+; Return the mode of the value passed to the decode rtl.
+; This is the mode of the field.
+
+(define (ifld-decode-mode f) (ifld-mode f))
+
+; Return start of ifield.
+; WORD-LEN is the length of the word in which to compute the value or
+; #f meaning to use the default length (recorded with the bitrange).
+; WORD-LEN is present for architectures like the m32r where there are insns
+; smaller than the base insn size (LIW).
+; ??? Not sure it'll be applicable to other LIW architectures.  The m32r is
+; rather easy as the insns are 16 and 32 bits.
+; ??? Another way to do this would be to either set the base-insn-size for
+; the m32r to be 16 bits, or to add a new field to hold the insn-word-size
+; and set it to 16 for the m32r.  The problem here is that there is no
+; canonicalization that works regardless of whether a "word" is shortened
+; or lengthened.
+
+(method-make-virtual!
+ <ifield> 'field-start
+ (lambda (self word-len)
+   (let* ((bitrange (-ifld-bitrange self))
+         (lsb0? (bitrange-lsb0? bitrange))
+         (recorded-word-len (bitrange-word-length bitrange))
+         (wanted-word-len (or word-len recorded-word-len)))
+     ; Note that this is only intended for situations like the m32r.
+     ; If it doesn't work elsewhere, it may be that you need to
+     ; do things different (use two fields instead of one).
+     (cond ((= wanted-word-len recorded-word-len)
+           (bitrange-start bitrange))
+          ((< wanted-word-len recorded-word-len)
+           ; smaller word wanted
+           (if lsb0?
+               (- (bitrange-start bitrange) (- recorded-word-len
+                                               wanted-word-len))
+               (bitrange-start bitrange)))
+          (else
+           ; larger word wanted
+           (if lsb0?
+               (+ (bitrange-start bitrange) (- wanted-word-len
+                                               recorded-word-len))
+               (bitrange-start bitrange))))))
+)
+
+(define (ifld-start ifld word-len)
+  (send ifld 'field-start word-len)
+)
+
+(method-make-virtual!
+ <ifield> 'field-length
+ (lambda (self)
+   (bitrange-length (elm-get self 'bitrange)))
+)
+
+(define (ifld-length f) (send f 'field-length))
+
+; FIXME: It might make things more "readable" if enum values were preserved in
+; their symbolic form and the get-field-value method did the lookup.
+
+(method-make!
+ <ifield> 'get-field-value
+ (lambda (self)
+   (elm-get self 'value))
+)
+(define (ifld-get-value self)
+  (send self 'get-field-value)
+)
+(method-make!
+ <ifield> 'set-field-value!
+ (lambda (self new-val)
+   (elm-set! self 'value new-val))
+)
+(define (ifld-set-value! self new-val)
+  (send self 'set-field-value! new-val)
+)
+
+; Return a boolean indicating if X is an <ifield>.
+
+(define (ifield? x) (class-instance? <ifield> x))
+
+; Return ilk of field.
+; ("ilk" sounds klunky but "type" is too ambiguous.  Here "ilk" means
+; the kind of the hardware element, enum, etc.)
+; The result is a character string naming the field type.
+
+(define (ifld-ilk fld)
+  (let ((value (elm-xget fld 'value)))
+    ; ??? One could require that the `value' field always be an object.
+    ; I can't get too worked up over it yet.
+    (if (object? value)
+       (obj:name value) ; send's message 'get-name to fetch object's `name'
+       "#")) ; # -> "it's a number"
+)
+
+; Generate the name of the enum for instruction field ifld.
+; If PREFIX? is present and #f, the @ARCH@_ prefix is omitted.
+
+(define (ifld-enum ifld . prefix?)
+  (string-upcase (string-append (if (or (null? prefix?) (car prefix?))
+                                   "@ARCH@_"
+                                   "")
+                               (gen-sym ifld)))
+)
+
+; Return a boolean indicating if ifield F is an opcode field
+; (has a constant value).
+
+(define (ifld-constant? f)
+  (number? (ifld-get-value f))
+;  (and (number? (ifld-get-value f))
+;       (if option:reserved-as-opcode?
+;         #t
+;         (not (has-attr? f 'RESERVED))))
+)
+
+; Return a boolean indicating if ifield F is an operand.
+; FIXME: Should check for operand? or some such.
+
+(define (ifld-operand? f) (not (number? (ifld-get-value f))))
+
+; Return known value table for rtx-simplify of <ifield> list ifld-list.
+
+(define (ifld-known-values ifld-list)
+  (let ((constant-iflds (find ifld-constant? (collect ifld-base-ifields ifld-list))))
+    (map (lambda (f)
+          (cons (obj:name f)
+                (rtx-make-const 'INT (ifld-get-value f))))
+        constant-iflds))
+)
+
+; Return mask to use for a field in <bitrange> CONTAINER.
+; If the bitrange is outside the range of the field, return 0.
+; If CONTAINER is #f, use the recorded bitrange.
+; BASE-LEN, if non-#f, overrides the base insn length of the insn.
+; BASE-LEN is present for architectures like the m32r where there are insns
+; smaller than the base insn size (LIW).
+;
+; Simplifying restrictions [to be relaxed as necessary]:
+; - the field must either be totally contained within CONTAINER or totally
+;   outside it, partial overlaps aren't handled
+; - CONTAINER must be an integral number of bytes, beginning on a
+;   byte boundary [simplifies things]
+; - both SELF's bitrange and CONTAINER must have the same word length
+; - LSB0? of SELF's bitrange and CONTAINER must be the same
+
+(method-make!
+ <ifield> 'field-mask
+ (lambda (self base-len container)
+   (let* ((container (or container (-ifld-bitrange self)))
+         (bitrange (-ifld-bitrange self))
+         (recorded-word-length (bitrange-word-length bitrange))
+         (word-offset (bitrange-word-offset bitrange)))
+     (let ((lsb0? (bitrange-lsb0? bitrange))
+          (start (bitrange-start bitrange))
+          (length (bitrange-length bitrange))
+          (word-length (or (and (= word-offset 0) base-len)
+                           recorded-word-length))
+          (container-word-offset (bitrange-word-offset container))
+          (container-word-length (bitrange-word-length container)))
+       (cond
+       ; must be same lsb0
+       ((not (eq? lsb0? (bitrange-lsb0? container)))
+        (error "field-mask: different lsb0? values"))
+       ((not (= word-length container-word-length))
+        0)
+       ; container occurs after?
+       ((<= (+ word-offset word-length) container-word-offset)
+        0)
+       ; container occurs before?
+       ((>= word-offset (+ container-word-offset container-word-length))
+        0)
+       (else
+        (word-mask start length word-length lsb0? #f))))))
+)
+
+(define (ifld-mask ifld base-len container)
+  (send ifld 'field-mask base-len container)
+)
+
+; Return VALUE inserted into the field's position.
+; BASE-LEN, if non-#f, overrides the base insn length of the insn.
+; BASE-LEN is present for architectures like the m32r where there are insns
+; smaller than the base insn size (LIW).
+
+(method-make!
+ <ifield> 'field-value
+ (lambda (self base-len value)
+   (let* ((bitrange (-ifld-bitrange self))
+         (recorded-word-length (bitrange-word-length bitrange))
+         (word-offset (bitrange-word-offset bitrange))
+         (word-length (or (and (= word-offset 0) base-len)
+                          recorded-word-length)))
+     (word-value (ifld-start self base-len)
+                (bitrange-length bitrange)
+                word-length
+                (bitrange-lsb0? bitrange) #f
+                value)))
+)
+
+; FIXME: confusion with ifld-get-value.
+(define (ifld-value f base-len value)
+  (send f 'field-value base-len value)
+)
+
+; Return a list of ifields required to compute <ifield> F's value.
+; Normally this is just F itself.  For multi-ifields it will be more.
+; ??? It can also be more if F's value is derived from other fields but
+; that isn't supported yet.
+
+(method-make!
+ <ifield> 'needed-iflds
+ (lambda (self)
+   (list self))
+)
+
+(define (ifld-needed-iflds f)
+  (send f 'needed-iflds)
+)
+
+; Extract <ifield> IFLD's value out of VALUE in <insn> INSN.
+; VALUE is the entire insn's value if it fits in a word, or is a list
+; of values, one per word (not implemented, sigh).
+; ??? The instruction's format should specify where the word boundaries are.
+
+(method-make!
+ <ifield> 'field-extract
+ (lambda (self insn value)
+   (let ((base-len (insn-base-mask-length insn)))
+     (word-extract (ifld-start self base-len)
+                  (ifld-length self)
+                  base-len
+                  (ifld-lsb0? self)
+                  #f ; start is msb
+                  value)))
+)
+
+(define (ifld-extract ifld value insn)
+  (send ifld 'field-extract value insn)
+)
+
+; Return a boolean indicating if bit 0 is the least significant bit.
+
+(method-make!
+ <ifield> 'field-lsb0?
+ (lambda (self)
+   (bitrange-lsb0? (-ifld-bitrange self)))
+)
+
+(define (ifld-lsb0? f) (send f 'field-lsb0?))
+
+; Return the minimum value of a field.
+
+(method-make!
+ <ifield> 'min-value
+ (lambda (self)
+  (case (mode:class (ifld-mode self))
+    ((INT) (- (integer-expt 2 (- (ifld-length self) 1))))
+    ((UINT) 0)
+    (else (error "unsupported mode class" (mode:class (ifld-mode self))))))
+)
+
+; Return the maximum value of a field.
+
+(method-make!
+ <ifield> 'max-value
+ (lambda (self)
+  (case (mode:class (ifld-mode self))
+    ((INT) (- (integer-expt 2 (- (ifld-length self) 1)) 1))
+    ((UINT) (- (integer-expt 2 (ifld-length self)) 1))
+    (else (error "unsupported mode class" (mode:class (ifld-mode self))))))
+)
+
+; Create a copy of field F with value VALUE.
+; VALUE is either ... ???
+
+(define (ifld-new-value f value)
+  (let ((new-f (object-copy-top f)))
+    (ifld-set-value! new-f value)
+    new-f)
+)
+
+; Change the offset of the word containing an ifield to {word-offset}.
+
+(method-make!
+ <ifield> 'set-word-offset!
+ (lambda (self word-offset)
+   (let ((bitrange (object-copy-top (-ifld-bitrange self))))
+     (bitrange-set-word-offset! bitrange word-offset)
+     (elm-set! self 'bitrange bitrange)
+     *UNSPECIFIED*))
+)
+(define (ifld-set-word-offset! f word-offset)
+  (send f 'set-word-offset! word-offset)
+)
+
+; Return a copy of F with new {word-offset}.
+
+(define (ifld-new-word-offset f word-offset)
+  (let ((new-f (object-copy-top f)))
+    (ifld-set-word-offset! new-f word-offset)
+    new-f)
+)
+
+; Return the bit offset of the word after the word <ifield> F is in.
+; What a `word' here is defined by F in its bitrange.
+
+(method-make!
+ <ifield> 'next-word
+ (lambda (self)
+  (let ((br (-ifld-bitrange f)))
+    (bitrange-next-word br)))
+)
+
+(define (ifld-next-word f) (send f 'next-word))
+
+; Return a boolean indicating if <ifield> F1 precedes <ifield> F2.
+; FIXME: Move into a method as different subclasses will need
+; different handling.
+
+(define (ifld-precedes? f1 f2)
+  (let ((br1 (-ifld-bitrange f1))
+       (br2 (-ifld-bitrange f2)))
+    (cond ((< (bitrange-word-offset br1) (bitrange-word-offset br2))
+          #t)
+         ((= (bitrange-word-offset br1) (bitrange-word-offset br2))
+          (begin
+            (assert (eq? (bitrange-lsb0? br1) (bitrange-lsb0? br2)))
+            (assert (= (bitrange-word-length br1) (bitrange-word-length br1)))
+            ; ??? revisit
+            (if (bitrange-lsb0? br1)
+                (> (bitrange-start br1) (bitrange-start br2))
+                (< (bitrange-start br1) (bitrange-start br2)))))
+         (else
+          #f)))
+)
+\f
+; Parse an ifield definition.
+; This is the main routine for building an ifield object from a
+; description in the .cpu file.
+; All arguments are in raw (non-evaluated) form.
+; The result is the parsed object or #f if object isn't for selected mach(s).
+;
+; Two forms of specification are supported, loosely defined as the RISC way
+; and the CISC way.  The reason for the distinction is to simplify ifield
+; specification of RISC-like cpus.
+; Note that VLIW's are another way.  These are handled like the RISC way, with
+; the possible addition of instruction framing (which is, surprise surprise,
+; wip).
+;
+; RISC:
+; WORD-OFFSET and WORD-LENGTH are #f.  Insns are assumed to be N copies of
+; (isa-default-insn-word-bitsize).  WORD-OFFSET is computed from START.
+; START is the offset in bits from the start of the insn.
+; FLENGTH is the length of the field in bits.
+;
+; CISC:
+; WORD-OFFSET is the offset in bits from the start to the first byte of the
+; word containing the ifield.
+; WORD-LENGTH is the length in bits of the word containing the ifield.
+; START is the starting bit number in the word.  Bit numbering is taken from
+; (current-arch-insn-lsb0?).
+; FLENGTH is the length in bits of the ifield.  It is named that way to avoid
+; collision with the proc named `length'.
+;
+; FIXME: More error checking.
+
+(define (-ifield-parse errtxt name comment attrs
+                      word-offset word-length start flength follows
+                      mode encode decode)
+  (logit 2 "Processing ifield " name " ...\n")
+
+  (let* ((name (parse-name name errtxt))
+        (atlist (atlist-parse attrs "cgen_ifld" errtxt))
+        (isas (bitset-attr->list (atlist-attr-value atlist 'ISA #f))))
+
+    ; Ensure only one isa specified.
+    (if (!= (length isas) 1)
+       (parse-error errtxt "can only specify 1 isa" attrs))
+
+    (if (not (eq? (->bool word-offset)
+                 (->bool word-length)))
+       (parse-error errtxt "either both or neither of word-offset,word-length can be specified"))
+
+    (if (keep-isa-atlist? atlist #f)
+
+       (let ((isa (current-isa-lookup (car isas)))
+             (word-offset (and word-offset
+                               (parse-number errtxt word-offset '(0 . 256))))
+             (word-length (and word-length
+                               (parse-number errtxt word-length '(0 . 128))))
+             ; ??? 0.127 for now
+             (start (parse-number errtxt start '(0 . 127)))
+             ; ??? 0.127 for now
+             (flength (parse-number errtxt flength '(0 . 127)))
+             (lsb0? (current-arch-insn-lsb0?))
+             (mode-obj (parse-mode-name mode errtxt))
+             (follows-obj (-ifld-parse-follows errtxt follows))
+             )
+
+         ; Calculate the <bitrange> object.
+         ; FIXME: word-offset/word-length computation needs work.
+         ; Move positional info to format?
+         (let ((bitrange
+                (if word-offset
+                    ; CISC
+                    (make <bitrange>
+                      word-offset start flength word-length lsb0?)
+                    ; RISC
+                    (let* ((default-insn-word-bitsize
+                             (isa-default-insn-word-bitsize isa))
+                           (word-offset
+                            (- start
+                               (remainder start
+                                          default-insn-word-bitsize)))
+                           (start (remainder start default-insn-word-bitsize)))
+                      (make <bitrange>
+                        word-offset
+                        start
+                        flength
+                        (if lsb0?
+                            (* (quotient (+ start 1
+                                            (- default-insn-word-bitsize 1))
+                                         default-insn-word-bitsize)
+                               default-insn-word-bitsize)
+                            (* (quotient (+ start flength
+                                            (- default-insn-word-bitsize 1))
+                                         default-insn-word-bitsize)
+                               default-insn-word-bitsize))
+                        lsb0?))))
+                )
+
+           (let ((result
+                  (make <ifield>
+                        name
+                        (parse-comment comment errtxt)
+                        atlist
+                        mode-obj
+                        bitrange
+                        (-ifld-parse-encode errtxt encode)
+                        (-ifld-parse-decode errtxt decode))))
+             (if follows-obj
+                 (ifld-set-follows! result follows-obj))
+             result)))
+
+       ; Else ignore entry.
+       (begin
+         (logit 2 "Ignoring " name ".\n")
+         #f)))
+)
+
+; Read an instruction field description.
+; This is the main routine for analyzing instruction fields in the .cpu file.
+; ERRTXT is prepended to error messages to provide context.
+; ARG-LIST is an associative list of field name and field value.
+; -ifield-parse is invoked to create the <ifield> object.
+
+(define (-ifield-read errtxt . arg-list)
+  (let (; Current ifield elements:
+       (name nil)
+       (comment "")
+       (attrs nil)
+       (word-offset #f)
+       (word-length #f)
+       (start 0)
+       ; FIXME: Hobbit computes the wrong symbol for `length'
+       ; in the `case' expression below because there is a local var
+       ; of the same name ("__1" gets appended to the symbol name).
+       ; As a workaround we name it "length-".
+       (length- 0)
+       (follows #f)
+       (mode 'UINT)
+       (encode #f)
+       (decode #f)
+       )
+    ; Loop over each element in ARG-LIST, recording what's found.
+    (let loop ((arg-list arg-list))
+      (if (null? arg-list)
+         nil
+         (let ((arg (car arg-list))
+               (elm-name (caar arg-list)))
+           (case elm-name
+             ((name) (set! name (cadr arg)))
+             ((comment) (set! comment (cadr arg)))
+             ((attrs) (set! attrs (cdr arg)))
+             ((mode) (set! mode (cadr arg)))
+             ((word-offset) (set! word-offset (cadr arg)))
+             ((word-length) (set! word-length (cadr arg)))
+             ((start) (set! start (cadr arg)))
+             ((length) (set! length- (cadr arg)))
+             ((follows) (set! follows (cadr arg)))
+             ((encode) (set! encode (cdr arg)))
+             ((decode) (set! decode (cdr arg)))
+             (else (parse-error errtxt "invalid ifield arg" arg)))
+           (loop (cdr arg-list)))))
+
+    ; See if encode/decode were specified as "unspecified".
+    ; This happens with shorthand macros.
+    (if (and (pair? encode)
+            (eq? (car encode) #f))
+       (set! encode #f))
+    (if (and (pair? decode)
+            (eq? (car decode) #f))
+       (set! decode #f))
+
+    ; Now that we've identified the elements, build the object.
+    (-ifield-parse errtxt name comment attrs
+                  word-offset word-length start length- follows
+                  mode encode decode)
+    )
+)
+
+; Parse a `follows' spec.
+
+(define (-ifld-parse-follows errtxt follows)
+  (if follows
+      (let ((follows-obj (current-op-lookup follows)))
+       (if (not follows-obj)
+           (parse-error errtxt "unknown operand to follow" follows))
+       follows-obj)
+      #f)
+)
+
+; Do common parts of <ifield> encode/decode processing.
+
+(define (-ifld-parse-encode-decode errtxt which value)
+  (if value
+      (begin
+       (if (or (not (list? value))
+               (not (= (length value) 2))
+               (not (list? (car value)))
+               (not (= (length (car value)) 2))
+               (not (list? (cadr value))))
+           (parse-error errtxt
+                        (string-append "bad ifield " which " spec")
+                        value))
+       (if (or (not (> (length (cadr value)) 2))
+               (not (mode:lookup (cadr (cadr value)))))
+           (parse-error errtxt
+                        (string-append which " expression must have a mode")
+                        value))))
+  value
+)
+
+; Parse an <ifield> encode spec.
+
+(define (-ifld-parse-encode errtxt encode)
+  (-ifld-parse-encode-decode errtxt "encode" encode)
+)
+
+; Parse an <ifield> decode spec.
+
+(define (-ifld-parse-decode errtxt decode)
+  (-ifld-parse-encode-decode errtxt "decode" decode)
+)
+
+; Define an instruction field object, name/value pair list version.
+
+(define define-ifield
+  (lambda arg-list
+    (let ((f (apply -ifield-read (cons "define-ifield" arg-list))))
+      (if f
+         (current-ifld-add! f))
+      f))
+)
+
+; Define an instruction field object, all arguments specified.
+; ??? Leave out word-offset,word-length,follows for now (RISC version).
+; Not sure whether to add another function or leave CISC cpu's to define
+; a shorthand macro if they want.
+
+(define (define-full-ifield name comment attrs start length mode encode decode)
+  (let ((f (-ifield-parse "define-full-ifield" name comment attrs
+                         #f #f start length #f mode encode decode)))
+    (if f
+       (current-ifld-add! f))
+    f)
+)
+
+(define (-ifield-add-commands!)
+  (reader-add-command! 'define-ifield
+                      "\
+Define an instruction field, name/value pair list version.
+"
+                      nil 'arg-list define-ifield)
+  (reader-add-command! 'define-full-ifield
+                      "\
+Define an instruction field, all arguments specified.
+"
+                      nil '(name comment attrs start length mode encode decode)
+                      define-full-ifield)
+  (reader-add-command! 'define-multi-ifield
+                      "\
+Define an instruction multi-field, name/value pair list version.
+"
+                      nil 'arg-list define-multi-ifield)
+  (reader-add-command! 'define-full-multi-ifield
+                      "\
+Define an instruction multi-field, all arguments specified.
+"
+                      nil '(name comment attrs mode subflds insert extract)
+                      define-full-multi-ifield)
+
+  *UNSPECIFIED*
+)
+\f
+; Instruction fields consisting of multiple parts.
+
+(define <multi-ifield>
+  (class-make '<multi-ifield>
+             '(<ifield>)
+             '(
+               ; List of <ifield> objects.
+               subfields
+               ; rtl to set SUBFIELDS from self
+               insert
+               ; rtl to set self from SUBFIELDS
+               extract
+               )
+             nil)
+)
+
+; Accessors
+
+(define-getters <multi-ifield> multi-ifld
+  (subfields insert extract)
+)
+
+; Return a boolean indicating if X is an <ifield>.
+
+(define (multi-ifield? x) (class-instance? <multi-ifield> x))
+
+(define (non-multi-ifields ifld-list)
+  (find (lambda (ifld) (not (multi-ifield? ifld))) ifld-list)
+)
+
+(define (non-derived-ifields ifld-list)
+  (find (lambda (ifld) (not (derived-ifield? ifld))) ifld-list)
+)
+
+
+; Return the starting bit number of the first field.
+
+(method-make-virtual!
+ <multi-ifield> 'field-start
+ (lambda (self word-len)
+   (apply min (map (lambda (f) (ifld-start f #f)) (elm-get self 'subfields))))
+)
+
+; Return the total length.
+
+(method-make-virtual!
+ <multi-ifield> 'field-length
+ (lambda (self)
+   (apply + (map ifld-length (elm-get self 'subfields))))
+)
+
+; Return the bit offset of the word after the last word SELF is in.
+; What a `word' here is defined by subfields in their bitranges.
+
+(method-make!
+ <multi-ifield> 'next-word
+ (lambda (self)
+   (apply max (map (lambda (f)
+                    (bitrange-next-word (-ifld-bitrange f)))
+                  (multi-ifld-subfields self))))
+)
+
+; Return mask of field in bitrange CONTAINER.
+
+(method-make!
+ <multi-ifield> 'field-mask
+ (lambda (self base-len container)
+   (apply + (map (lambda (f) (ifld-mask f base-len container)) (elm-get self 'subfields))))
+)
+
+; Return VALUE inserted into the field's position.
+; The value is spread out over the various subfields in sorted order.
+; We assume the subfields have been sorted by starting bit position.
+
+(method-make!
+ <multi-ifield> 'field-value
+ (lambda (self base-len value)
+   (apply + (map (lambda (f) (ifld-value f base-len value)) (elm-get self 'subfields))))
+)
+
+; Return a list of ifields required to compute the field's value.
+
+(method-make!
+ <multi-ifield> 'needed-iflds
+ (lambda (self)
+   (cons self (elm-get self 'subfields)))
+)
+
+; Extract <ifield> IFLD's value out of VALUE in <insn> INSN.
+; VALUE is the entire insn's value if it fits in a word, or is a list
+; of values, one per word (not implemented, sigh).
+; ??? The instruction's format should specify where the word boundaries are.
+
+(method-make!
+ <multi-ifield> 'field-extract
+ (lambda (self insn value)
+   (let* ((subflds (sort-ifield-list (elm-get self 'subfields)
+                                    (not (ifld-lsb0? self))))
+         (subvals (map (lambda (subfld)
+                         (ifld-extract subfld insn value))
+                       subflds))
+        )
+     ; We have each subfield's value, now concatenate them.
+     (letrec ((plus-scan (lambda (lengths current)
+                          ; do the -1 drop here as it's easier
+                          (if (null? (cdr lengths))
+                              nil
+                              (cons current
+                                    (plus-scan (cdr lengths)
+                                               (+ current (car lengths))))))))
+       (apply + (map logsll
+                    subvals
+                    (plus-scan (map ifld-length subflds) 0))))))
+)
+
+; Return a boolean indicating if bit 0 is the least significant bit.
+
+(method-make!
+ <multi-ifield> 'field-lsb0?
+ (lambda (self)
+   (ifld-lsb0? (car (elm-get self 'subfields))))
+)
+\f
+; Multi-ifield parsing.
+
+; Subroutine of -multi-ifield-parse to build the default insert expression.
+
+(define (-multi-ifield-make-default-insert container-name subfields)
+  (let* ((lengths (map ifld-length subfields))
+        (shifts (cons 0 (list-tail-drop 1 (plus-scan (cons 0 lengths))))))
+    ; Build RTL expression to shift and mask each ifield into right spot.
+    (let ((exprs (map (lambda (f length shift)
+                       (rtx-make 'and (rtx-make 'srl container-name shift)
+                                 (mask length)))
+                     subfields lengths shifts)))
+      ; Now set each ifield with their respective values.
+      (apply rtx-make (cons 'sequence
+                           (cons nil
+                                 (map (lambda (f expr)
+                                        (rtx-make-set f expr))
+                                      subfields exprs))))))
+)
+
+; Subroutine of -multi-ifield-parse to build the default extract expression.
+
+(define (-multi-ifield-make-default-extract container-name subfields)
+  (let* ((lengths (map ifld-length subfields))
+        (shifts (cons 0 (list-tail-drop 1 (plus-scan (cons 0 lengths))))))
+    ; Build RTL expression to shift and mask each ifield into right spot.
+    (let ((exprs (map (lambda (f length shift)
+                       (rtx-make 'sll (rtx-make 'and (obj:name f)
+                                                (mask length))
+                                 shift))
+                     subfields lengths shifts)))
+      ; Now set {container-name} with all the values or'd together.
+      (rtx-make-set container-name
+                   (rtx-combine 'or exprs))))
+)
+
+; Parse a multi-ifield spec.
+; This is the main routine for building the object from the .cpu file.
+; All arguments are in raw (non-evaluated) form.
+; The result is the parsed object or #f if object isn't for selected mach(s).
+
+(define (-multi-ifield-parse errtxt name comment attrs mode subfields insert extract encode decode)
+  (logit 2 "Processing multi-ifield element " name " ...\n")
+
+  (let ((name (parse-name name errtxt))
+       (result (new <multi-ifield>))
+       (subfields (map (lambda (subfld)
+                         (let ((f (current-ifld-lookup subfld)))
+                           (if (not f)
+                               (parse-error errtxt "unknown ifield" subfld))
+                           f))
+                       subfields)))
+
+    (elm-xset! result 'name name)
+    (elm-xset! result 'comment (parse-comment comment errtxt))
+    ; multi-ifields are always VIRTUAL
+    (elm-xset! result 'attrs
+              (atlist-parse (cons 'VIRTUAL attrs) "multi-ifield" errtxt))
+    (elm-xset! result 'mode (parse-mode-name mode errtxt))
+    (elm-xset! result 'encode (-ifld-parse-encode errtxt encode))
+    (elm-xset! result 'decode (-ifld-parse-encode errtxt decode))
+    (if insert
+       (elm-xset! result 'insert insert)
+       (elm-xset! result 'insert
+                  (-multi-ifield-make-default-insert name subfields)))
+    (if extract
+       (elm-xset! result 'extract extract)
+       (elm-xset! result 'extract
+                  (-multi-ifield-make-default-extract name subfields)))
+    (elm-xset! result 'subfields subfields)
+
+    result)
+)
+
+; Read an instruction multi-ifield.
+
+(define (-multi-ifield-read errtxt . arg-list)
+  (let (; Current multi-ifield elements:
+       (name nil)
+       (comment "")
+       (attrs nil)
+       (mode 'UINT)
+       (subflds nil)
+       (insert #f)
+       (extract #f)
+       (encode #f)
+       (decode #f)
+       )
+    ; Loop over each element in ARG-LIST, recording what's found.
+    (let loop ((arg-list arg-list))
+      (if (null? arg-list)
+         nil
+         (let ((arg (car arg-list))
+               (elm-name (caar arg-list)))
+           (case elm-name
+             ((name) (set! name (cadr arg)))
+             ((comment) (set! comment (cadr arg)))
+             ((attrs) (set! attrs (cdr arg)))
+             ((mode) (set! mode (cadr arg)))
+             ((subfields) (set! subflds (cdr arg)))
+             ((insert) (set! insert (cadr arg)))
+             ((extract) (set! extract (cadr arg)))
+             ((encode) (set! encode (cdr arg)))
+             ((decode) (set! decode (cdr arg)))
+             (else (parse-error errtxt "invalid ifield arg" arg)))
+           (loop (cdr arg-list)))))
+    ; Now that we've identified the elements, build the object.
+    (-multi-ifield-parse errtxt name comment attrs mode subflds insert extract encode decode)
+    )
+)
+
+; Define an instruction multi-field object, name/value pair list version.
+
+(define define-multi-ifield
+  (lambda arg-list
+    (let ((f (apply -multi-ifield-read (cons "define-multi-ifield" arg-list))))
+      (current-ifld-add! f)
+      f))
+)
+
+; Define an instruction multi-field object, all arguments specified.
+
+(define (define-full-multi-ifield name comment attrs mode subflds insert extract)
+  (let ((f (-multi-ifield-parse "define-full-multi-ifield" name comment attrs
+                               mode subflds insert extract #f #f)))
+    (current-ifld-add! f)
+    f)
+)
+\f
+; Derived ifields (ifields based on one or more other ifields).
+; These support the complicated requirements of CISC instructions
+; where one "ifield" is actually a placeholder for an addressing mode
+; which can consist of several ifields.
+; These are also intended to support other complex ifield usage.
+;
+; Derived ifields are (currently) always machine generated from other
+; elements of the description file so there is no reader support.
+;
+; ??? experimental and wip!
+; ??? These are kind of like multi-ifields but I don't want to disturb them
+; while this is still experimental.
+
+(define <derived-ifield>
+  (class-make '<derived-ifield>
+             '(<ifield>)
+             '(
+               ; Operand that uses this ifield.
+               ; Unlike other ifields, derived ifields have a one-to-one
+               ; correspondence with the operand that uses them.
+               ; ??? Not true in -anyof-merge-subchoices.
+               owner
+
+               ; List of ifields that make up this ifield.
+               subfields
+               )
+             nil)
+)
+
+(method-make!
+ <derived-ifield> 'make!
+ (lambda (self name comment attrs owner subfields)
+   (elm-set! self 'name name)
+   (elm-set! self 'comment comment)
+   (elm-set! self 'attrs attrs)
+   (elm-set! self 'mode UINT)
+   (elm-set! self 'bitrange (make <bitrange> 0 0 0 0 #f))
+   (elm-set! self 'owner owner)
+   (elm-set! self 'subfields subfields)
+   self)
+)
+
+; Accessors.
+
+(define-getters <derived-ifield> derived-ifield (owner subfields))
+
+(define-setters <derived-ifield> derived-ifield (owner subfields))
+
+(define (derived-ifield? x) (class-instance? <derived-ifield> x))
+
+; Return a boolean indicating if F is a derived ifield with a derived operand
+; for a value.
+; ??? The former might imply the latter so some simplification may be possible.
+
+(define (ifld-derived-operand? f)
+  (and (derived-ifield? f)
+       (derived-operand? (ifld-get-value f)))
+)
+
+; Return the bit offset of the word after the last word SELF is in.
+; What a `word' here is defined by subfields in their bitranges.
+
+(method-make!
+ <derived-ifield> 'next-word
+ (lambda (self)
+   (apply max (map (lambda (f)
+                    (bitrange-next-word (-ifld-bitrange f)))
+                  (derived-ifield-subfields self))))
+)
+
+
+; Traverse the ifield to collect all base (non-derived) ifields used in it.
+(define (ifld-base-ifields ifld)
+  (cond ((derived-ifield? ifld) (collect (lambda (subfield) (ifld-base-ifields subfield))
+                                        (derived-ifield-subfields ifld)))
+       ; ((multi-ifield? ifld) (collect (lambda (subfield) (ifld-base-ifields subfield))
+       ;                              (multi-ifld-subfields ifld)))
+       (else (list ifld)))
+)
+
+
+\f
+; Misc. utilities.
+
+; Sort a list of fields (sorted by the starting bit number).
+; This must be carefully defined to pass through Hobbit.
+; (define foo (if x bar baz)) is ok.
+; (if x (define foo bar) (define foo baz)) is not ok.
+;
+; ??? Usually there aren't that many fields and the range of values is fixed,
+; so I think this needn't use a general purpose sort routine (should it become
+; an issue).
+
+(define sort-ifield-list
+  (if (and (defined? 'cgh-qsort) (defined? 'cgh-qsort-int-cmp))
+      (lambda (fld-list up?)
+       (cgh-qsort fld-list
+                  (if up?
+                      (lambda (a b)
+                        (cgh-qsort-int-cmp (ifld-start a #f)
+                                           (ifld-start b #f)))
+                      (lambda (a b)
+                        (- (cgh-qsort-int-cmp (ifld-start a #f)
+                                              (ifld-start b #f)))))))
+      (lambda (fld-list up?)
+       (sort fld-list
+             (if up?
+                 (lambda (a b) (< (ifld-start a #f)
+                                  (ifld-start b #f)))
+                 (lambda (a b) (> (ifld-start a #f)
+                                  (ifld-start b #f)))))))
+)
+
+; Return a boolean indicating if field F extends beyond the base insn.
+
+(define (ifld-beyond-base? f base-bitsize total-bitsize)
+  ; old way
+  ;(< base-bitsize (+ (ifld-start f total-bitsize) (ifld-length f)))
+  (> (ifld-word-offset f) 0)
+)
+
+; Return the mode of the decoded value of <ifield> F.
+; ??? This is made easy because we require the decode expression to have
+; an explicit mode.
+
+(define (ifld-decode-mode f)
+  (if (not (elm-bound? f 'decode))
+      (ifld-mode f)
+      (let ((d (ifld-decode f)))
+       (if d
+           (mode:lookup (cadr (cadr d)))
+           (ifld-mode f))))
+)
+
+; Return <hardware> object to use to hold value of <ifield> F.
+; i.e. one of h-uint, h-sint.
+; NB: Should be defined in terms of `hardware-for-mode'.
+(define (ifld-hw-type f)
+  (case (mode:class (ifld-mode f))
+    ((INT) h-sint)
+    ((UINT) h-uint)
+    (else (error "unsupported mode class" (mode:class (ifld-mode f)))))
+)
+\f
+; Builtin fields, attributes, init/fini support.
+
+; The f-nil field is a placeholder when building operands out of hardware
+; elements that aren't indexed by an instruction field (scalars).
+(define f-nil #f)
+
+(define (ifld-nil? f)
+  (eq? (obj:name f) 'f-nil)
+)
+
+; The f-anyof field is a placeholder when building "anyof" operands.
+(define f-anyof #f)
+
+(define (ifld-anyof? f)
+  (eq? (obj:name f) 'f-anyof)
+)
+
+; Return a boolean indicating if F is an anyof ifield with an anyof operand
+; for a value.
+; ??? The former implies the latter so some simplification is possible.
+
+(define (ifld-anyof-operand? f)
+  (and (ifld-anyof? f)
+       (anyof-operand? (ifld-get-value f)))
+)
+
+; Called before loading the .cpu file to initialize.
+
+(define (ifield-init!)
+  (-ifield-add-commands!)
+
+  *UNSPECIFIED*
+)
+
+; Called before loading the .cpu file to create any builtins.
+
+(define (ifield-builtin!)
+  ; Standard ifield attributes.
+  ; ??? Some of these can be combined into one, booleans are easier to
+  ; work with.
+  (define-attr '(for ifield operand) '(type boolean) '(name PCREL-ADDR)
+    '(comment "pc relative address"))
+  (define-attr '(for ifield operand) '(type boolean) '(name ABS-ADDR)
+    '(comment "absolute address"))
+  (define-attr '(for ifield) '(type boolean) '(name RESERVED)
+    '(comment "field is reserved"))
+  (define-attr '(for ifield operand) '(type boolean) '(name SIGN-OPT)
+    '(comment "value is signed or unsigned"))
+  ; ??? This is an internal attribute for implementation purposes only.
+  ; To be revisited.
+  (define-attr '(for ifield operand) '(type boolean) '(name SIGNED)
+    '(comment "value is unsigned"))
+  ; Also (defined elsewhere): VIRTUAL
+
+  (set! f-nil (make <ifield> 'f-nil "empty ifield"
+                   atlist-empty
+                   UINT
+                   (make <bitrange> 0 0 0 0 #f)
+                   #f #f)) ; encode/decode
+  (current-ifld-add! f-nil)
+
+  (set! f-anyof (make <ifield> 'f-anyof "placeholder for anyof operands"
+                   atlist-empty
+                   UINT
+                   (make <bitrange> 0 0 0 0 #f)
+                   #f #f)) ; encode/decode
+  (current-ifld-add! f-anyof)
+
+  *UNSPECIFIED*
+)
+
+; Called after the .cpu file has been read in.
+
+(define (ifield-finish!)
+  *UNSPECIFIED*
+)
diff --git a/cgen/iformat.scm b/cgen/iformat.scm
new file mode 100644 (file)
index 0000000..1717f38
--- /dev/null
@@ -0,0 +1,614 @@
+; Instruction formats.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; Instruction formats are computed after the .cpu file has been read in.
+; ??? May also wish to allow programmer to specify formats, but not sure this
+; will complicate things more than it simplifies them, so it's defered.
+;
+; Two kinds of formats are defined here: iformat and sformat.
+; (pronounced "I-format" and "S-format")
+;
+; Iformats are the instruction format as specified by the instructions' fields,
+; and are the machine computed version of the generally known notion of an
+; "instruction format".  No semantic information is attributed to iformats.
+;
+; Sformats are the same as iformats except that semantics are used to
+; distinguish them.  For example, if an operand is refered to in one mode by
+; one instruction and in a different mode by another instruction, then these
+; two insns would have different sformats but the same iformat.  Sformats
+; are used in simulator extraction code to collapse the number of cases that
+; must be handled.  They can also be used to collapse the number of cases
+; in the modeling code.
+;
+; The "base length" is the length of the insn that is initially fetched for
+; decoding purposes.
+; Formats are fixed in length.  For variable instruction length architectures
+; there are separate formats for each insn's possible length.
+
+(define <iformat>
+  (class-make '<iformat>
+             '(<ident>)
+               ; From <ident>:
+               ; - NAME is derived from number, but we might have user
+               ;   specified formats someday [though I wouldn't add them
+               ;   without a clear need].
+               ; - COMMENT is the assembler syntax of an example insn that
+               ;   uses the format.
+             '(
+               ; Index into the iformat table.
+               number
+
+               ; Sort key, used to determine insns with identical formats.
+               key
+
+               ; List of <ifield> objects.
+               ifields
+
+               ; min (insn-length, base-insn-size)
+               mask-length
+
+               ; total length of insns with this format
+               length
+
+               ; mask of base part
+               mask
+
+               ; An example insn that uses the format.
+               eg-insn
+               )
+             nil)
+)
+
+; Accessor fns.
+
+(define-getters <iformat> ifmt
+  (number key ifields mask-length length mask eg-insn)
+)
+
+; Traverse the ifield list to collect all base (non-derived) ifields used in it.
+(define (ifields-base-ifields ifld-list)
+  (collect (lambda (ifld)
+            (ifld-base-ifields ifld))
+          ifld-list)
+)
+
+; Return enum cgen_fmt_type value for FMT.
+; ??? Not currently used.
+
+(define (ifmt-enum fmt)
+  (string-append "@CPU@_" (string-upcase (gen-sym fmt)))
+)
+\f
+; Given FLD-LIST, compute the length of the insn in bits.
+; This is done by adding up all the field sizes.
+; All bits must be represent exactly once.
+
+(define (compute-insn-length fld-list)
+  (apply + (map ifld-length (collect ifld-base-ifields fld-list)))
+)
+
+; Given FLD-LIST, compute the base length in bits.
+; Computing the min of state-base-insn-bitsize and the total-length
+; is for [V]LIW instruction sets.
+
+(define (compute-insn-base-mask-length fld-list)
+  (min (state-base-insn-bitsize) (compute-insn-length fld-list))
+)
+
+; Given FLD-LIST, compute the bitmask of constant values in the base part
+; of the insn (i.e. the opcode field).
+;
+; FIXME: Need to add support for constant fields appearing outside the base
+; insn.  One way would be to record with each insn the value for each constant
+; field.  That would allow code to straightforwardly fetch it.  Another would
+; be to only record constant values appearing outside the base insn.
+;
+; See also (insn-value).
+;
+(define (compute-insn-base-mask fld-list)
+  (let* ((mask-len (compute-insn-base-mask-length fld-list))
+        (lsb0? (ifld-lsb0? (car fld-list)))
+        (mask-bitrange (make <bitrange>
+                             0 ; word-offset
+                             (if lsb0? (- mask-len 1) 0) ; start
+                             mask-len ; length
+                             mask-len ; word-length
+                             lsb0?)))
+    (apply +
+          (map (lambda (fld) (ifld-mask fld mask-len mask-bitrange))
+               ; Find the fields that have constant values.
+               (find ifld-constant? (collect ifld-base-ifields fld-list)))
+          )
+    )
+)
+\f
+; Return the <iformat> search key for a sorted field list.
+; This determines how iformats differ from each other.
+; It also speeds up searching as the search key can be anything
+; (though at present searching isn't as fast as it could be).
+; INSN is passed so that we can include its sanytize attribute, if present,
+; so sanytized sources work (needed formats don't disappear).
+
+(define (-ifmt-search-key insn sorted-ifld-list)
+  (string-map (lambda (ifld)
+               (string-append " ("
+                              (or (obj-attr-value insn 'sanitize)
+                                  "-nosan-")
+                              " "
+                              (obj:name ifld)
+                              " "
+                              (ifld-ilk ifld)
+                              ")"))
+             sorted-ifld-list)
+)
+
+; Create an <iformat> object for INSN.
+; INDEX is the ordinal to assign to the result or -1 if unknown.
+; SEARCH-KEY is the search key used to determine the iformat's uniqueness.
+; IFLDS is a sorted list of INSN's ifields.
+
+(define (ifmt-build insn index search-key iflds)
+  (make <iformat>
+    (symbol-append 'ifmt- (obj:name insn))
+    (string-append "e.g. " (insn-syntax insn))
+    atlist-empty
+    index
+    search-key
+    iflds
+    (compute-insn-base-mask-length iflds)
+    (compute-insn-length iflds)
+    (compute-insn-base-mask iflds)
+    insn)
+)
+\f
+; Sformats.
+
+(define <sformat>
+  (class-make '<sformat>
+             '(<ident>)
+             ; From <ident>:
+             ; - NAME is derived from number.
+             ; - COMMENT is the assembler syntax of an example insn that
+             ;   uses the format.
+             '(
+               ; Index into the sformat table.
+               number
+
+               ; Sort key, used to determine insns with identical formats.
+               key
+
+               ; Non-#f if insns with this format are cti insns.
+               cti?
+
+               ; IN-OPS is a list of input operands.
+               ; OUT-OPS is a list of output operands.
+               ; These are used to distinguish the format from others,
+               ; so that the extract and read operations can be based on the
+               ; sformat.
+               ; The extract fns use this data to record the necessary
+               ; information for profiling [which isn't necessarily a property
+               ; of the field list].  We could have one extraction function
+               ; per instruction, but there's a *lot* of duplicated code, and
+               ; the semantic operands rarely contribute to extra formats.
+               ; The parallel execution support uses this data to record the
+               ; input (or output) values based on the instruction format,
+               ; again cutting down on duplicated code.
+               in-ops
+               out-ops
+
+               ; Length of all insns with this format.
+               ; Since insns with different iformats can have the same sformat
+               ; we need to ensure ifield extraction works among the various
+               ; iformats.  We do this by ensuring all insns with the same
+               ; sformat have the same length.
+               length
+
+               ; Cached list of all ifields used.
+               ; This can be derived from IN-OPS/OUT-OPS but is computed once
+               ; and cached here for speed.
+               iflds
+
+               ; An example insn that uses the format.
+               ; This is used for debugging purposes, but also to help get
+               ; sanytization (spelled wrong on purpose) right.
+               eg-insn
+
+               ; <sformat-argbuf> entry
+               ; FIXME: Temporary location, to be moved elsewhere
+               (sbuf . #f)
+               )
+             nil)
+)
+
+; Accessor fns.
+
+(define-getters <sformat> sfmt
+  (number key cti? in-ops out-ops length iflds eg-insn sbuf)
+)
+
+(define-setters <sformat> sfmt (sbuf))
+
+(method-make-make! <sformat>
+                  '(name comment attrs
+                    number key cti? in-ops out-ops length iflds eg-insn)
+)
+\f
+; Return the <sformat> search key for a sorted field list and semantic
+; operands.
+; This determines how sformats differ from each other.
+; It also speeds up searching as the search key can be anything
+; (though at present searching isn't as fast as it could be).
+;
+; INSN is passed so that we can include its sanytize attribute, if present,
+; so sanytized sources work (needed formats don't disappear).
+; SORTED-USED-IFLDS is a sorted list of ifields used by SEM-{IN,OUT}-OPS.
+; Note that it is not the complete set of ifields used by INSN.
+;
+; We assume INSN's <iformat> has been recorded.
+;
+; Note: It's important to minimize the number of created sformats.  It keeps
+; the generated code smaller (and sometimes faster - more usable common
+; fragments in pbb simulators).  Don't cause spurious differences.
+
+(define (-sfmt-search-key insn cti? sorted-used-iflds sem-in-ops sem-out-ops)
+  (let ((op-key (lambda (op)
+                 (string-append " ("
+                                (or (obj-attr-value insn 'sanitize)
+                                    "-nosan-")
+                                " "
+                                (obj:name op)
+                                ; ??? Including memory operands currently
+                                ; isn't necessary and it can account for some
+                                ; spurious differences.  On the other hand
+                                ; leaving it out doesn't seem like the right
+                                ; thing to do.
+                                (if (memory? (op:type op))
+                                    ""
+                                    (string-append " "
+                                                   (obj:name (op:mode op))))
+                                ; CGEN_OPERAND_INSTANCE_COND_REF is stored
+                                ; with the operand in the operand instance
+                                ; table thus formats must be distinguished
+                                ; by this.
+                                (if (op:cond? op) " cond" "")
+                                ")")))
+       )
+    (list
+     cti?
+     (insn-length insn)
+     (string-map (lambda (ifld)
+                  (string-append " (" (obj:name ifld) " " (ifld-ilk ifld) ")"))
+                sorted-used-iflds)
+     (string-map op-key
+                sem-in-ops)
+     (string-map op-key
+                sem-out-ops)
+     ))
+)
+
+; Create an <sformat> object for INSN.
+; INDEX is the ordinal to assign to the result or -1 if unknown.
+; SEARCH-KEY is the search key used to determine the sformat's uniqueness.
+; {IN,OUT}-OPS are lists of INSN's input/output operands.
+; SORTED-USED-IFLDS is a sorted list of ifields used by {IN,OUT}-OPS.
+; Note that it is not the complete set of ifields used by INSN.
+;
+; We assume INSN's <iformat> has already been recorded.
+
+(define (sfmt-build insn index search-key cti? in-ops out-ops sorted-used-iflds)
+  (make <sformat>
+    (symbol-append 'sfmt- (obj:name insn))
+    (string-append "e.g. " (insn-syntax insn))
+    atlist-empty
+    index
+    search-key
+    cti?
+    in-ops
+    out-ops
+    (insn-length insn)
+    sorted-used-iflds
+    insn)
+)
+
+; Sort IFLDS by dependencies and then by starting bit number.
+
+(define (-sfmt-order-iflds iflds)
+  (let ((up? 
+        ; ??? Something like this is preferable.
+        ;(not (ifld-lsb0? (car ifld-list)))
+        (not (current-arch-insn-lsb0?))))
+    (let loop ((independent nil) (dependent nil) (iflds iflds))
+      (cond ((null? iflds)
+            (append (sort-ifield-list independent up?)
+                    (sort-ifield-list dependent up?)))
+           ; FIXME: quick hack.
+           ((multi-ifield? (car iflds))
+            (loop independent (cons (car iflds) dependent) (cdr iflds)))
+           (else
+            (loop (cons (car iflds) independent) dependent (cdr iflds))))))
+)
+
+; Return a sorted list of ifields used by IN-OPS, OUT-OPS.
+; The ifields are sorted by dependencies and then by start bit.
+; The important points are to help distinguish sformat's by the ifields used
+; and to put ifields that others depend on first.
+
+(define (-sfmt-used-iflds in-ops out-ops)
+  (let ((in-iflds (map op-iflds-used in-ops))
+       (out-iflds (map op-iflds-used out-ops)))
+    (let ((all-iflds (nub (append (apply append in-iflds)
+                                 (apply append out-iflds))
+                         obj:name)))
+      (-sfmt-order-iflds all-iflds)))
+)
+\f
+; The format descriptor is used to sort formats.
+; This is a utility class internal to this file.
+; There is one instance per insn.
+
+(define <fmt-desc>
+  (class-make '<fmt-desc>
+             nil
+             '(
+               ; #t if insn is a cti insn
+               cti?
+
+               ; sorted list of insn's ifields
+               iflds
+
+               ; computed set of input/output operands
+               in-ops out-ops
+
+               ; set of ifields used by IN-OPS,OUT-OPS.
+               used-iflds
+
+               ; computed set of attributes
+               attrs
+               )
+             nil)
+)
+
+; Accessors.
+
+(define-getters <fmt-desc> -fmt-desc
+  (cti? iflds in-ops out-ops used-iflds attrs)
+)
+
+; Compute an iformat descriptor used to build an <iformat> object for INSN.
+;
+; If COMPUTE-SFORMAT? is #t compile the semantics and compute the semantic
+; format (same as instruction format except that operands are used to
+; distinguish insns).
+; Attributes derivable from the semantics are also computed.
+; This is all done at the same time to minimize the number of times the
+; semantic code is traversed.
+;
+; The result is (descriptor compiled-semantics attrs).
+; `descriptor' is #f for insns with an empty field list
+; (this happens for virtual insns).
+; `compiled-semantics' is #f if COMPUTE-SFORMAT? is #f.
+; `attrs' is an <attr-list> object of attributes derived from the semantics.
+;
+; ??? We never traverse the semantics of virtual insns.
+
+(define (ifmt-analyze insn compute-sformat?)
+  ; First sort by starting bit number the list of fields in INSN.
+  (let ((sorted-ifields
+        (sort-ifield-list (insn-iflds insn)
+                          ; ??? Something like this is preferable, but
+                          ; if the first insn is a virtual insn there are
+                          ; no fields.
+                          ;(not (ifld-lsb0? (car (insn-iflds insn))))
+                          (not (current-arch-insn-lsb0?))
+                          )))
+
+    (if (null? sorted-ifields)
+
+       ; Field list is unspecified.
+       (list #f #f atlist-empty)
+
+       ; FIXME: error checking (e.g. missing or overlapping bits)
+       (let* (; A list of the various bits of semantic code.
+              (sems (list (insn-semantics insn)))
+              ; Compute list of input and output operands if asked for.
+              (sem-ops (if compute-sformat?
+                           (semantic-compile #f ; FIXME: context
+                                             insn sems)
+                           (csem-make #f #f #f
+                                      (if (insn-semantics insn)
+                                          (semantic-attrs #f ; FIXME: context
+                                                          insn sems)
+                                          atlist-empty))))
+              )
+         (let ((compiled-sems (csem-code sem-ops))
+               (in-ops (csem-inputs sem-ops))
+               (out-ops (csem-outputs sem-ops))
+               (attrs (csem-attrs sem-ops))
+               (cti? (or (atlist-cti? (csem-attrs sem-ops))
+                         (insn-cti? insn))))
+           (list (make <fmt-desc>
+                   cti? sorted-ifields in-ops out-ops
+                   (if (and in-ops out-ops)
+                       (-sfmt-used-iflds in-ops out-ops)
+                       #f)
+                   attrs)
+                 compiled-sems
+                 attrs)))))
+)
+
+; Subroutine of ifmt-compute!, to simplify it.
+; Lookup INSN's iformat in IFMT-LIST and if not found add it.
+; FMT-DESC is INSN's <fmt-desc> object.
+; IFMT-LIST is append!'d to and the found iformat is stored in INSN.
+
+(define (-ifmt-lookup-ifmt! insn fmt-desc ifmt-list)
+  (let* ((search-key (-ifmt-search-key insn (-fmt-desc-iflds fmt-desc)))
+        (ifmt (find-first (lambda (elm)
+                            (equal? (ifmt-key elm) search-key))
+                          ifmt-list)))
+
+    (if ifmt
+
+       ; Format was found, use it.
+       (begin
+         (logit 3 "Using iformat " (number->string (ifmt-number ifmt)) ".\n")
+         (insn-set-ifmt! insn ifmt)
+         )
+
+       ; Format wasn't found, create new entry.
+       (let* ((ifmt-index (length ifmt-list))
+              (ifmt (ifmt-build insn ifmt-index search-key
+                                (ifields-base-ifields (-fmt-desc-iflds fmt-desc)))))
+         (logit 3 "Creating iformat " (number->string ifmt-index) ".\n")
+         (insn-set-ifmt! insn ifmt)
+         (append! ifmt-list (list ifmt))
+         )
+       ))
+
+  *UNSPECIFIED*
+)
+
+; Subroutine of ifmt-compute!, to simplify it.
+; Lookup INSN's sformat in SFMT-LIST and if not found add it.
+; FMT-DESC is INSN's <fmt-desc> object.
+; SFMT-LIST is append!'d to and the found sformat is stored in INSN.
+;
+; We assume INSN's <iformat> has already been recorded.
+
+(define (-ifmt-lookup-sfmt! insn fmt-desc sfmt-list)
+  (let* ((search-key (-sfmt-search-key insn (-fmt-desc-cti? fmt-desc)
+                                      (-fmt-desc-used-iflds fmt-desc)
+                                      (-fmt-desc-in-ops fmt-desc)
+                                      (-fmt-desc-out-ops fmt-desc)))
+        (sfmt (find-first (lambda (elm)
+                            (equal? (sfmt-key elm) search-key))
+                          sfmt-list)))
+
+    (if sfmt
+
+       ; Format was found, use it.
+       (begin
+         (logit 3 "Using sformat " (number->string (sfmt-number sfmt)) ".\n")
+         (insn-set-sfmt! insn sfmt)
+         )
+
+       ; Format wasn't found, create new entry.
+       (let* ((sfmt-index (length sfmt-list))
+              (sfmt (sfmt-build insn sfmt-index search-key
+                                (-fmt-desc-cti? fmt-desc)
+                                (-fmt-desc-in-ops fmt-desc)
+                                (-fmt-desc-out-ops fmt-desc)
+                                (-fmt-desc-used-iflds fmt-desc))))
+         (logit 3 "Creating sformat " (number->string sfmt-index) ".\n")
+         (insn-set-sfmt! insn sfmt)
+         (append! sfmt-list (list sfmt))
+         )
+       ))
+
+  *UNSPECIFIED*
+)
+\f
+; Main entry point.
+
+; Given a list of insns, compute the set of instruction formats, semantic
+; formats, semantic attributes, and compiled semantics for each insn.
+;
+; The computed <iformat> object is stored in the `ifmt' field of each insn.
+;
+; Attributes derived from the semantic code are added to the insn's attributes,
+; but they don't override any prespecified values.
+;
+; If COMPUTE-SFORMAT? is #t, the computed <sformat> object is stored in the
+; `sfmt' field of each insn, and the processed semantic code is stored in the
+; `compiled-semantics' field of each insn.
+;
+; The `fmt-desc' field of each insn is used to store an <fmt-desc> object
+; which contains the search keys, sorted field list, input-operands, and
+; output-operands, and is not used outside this procedure.
+;
+; The result is a list of two lists: the set of computed iformats, and the
+; set of computed sformats.
+;
+; *** This is the most expensive calculation in CGEN.   ***
+; *** (mainly because of the detailed semantic parsing) ***
+
+(define (ifmt-compute! insn-list compute-sformat?)
+  (logit 2 "Computing instruction formats and analyzing semantics ...\n")
+
+  ; First analyze each insn, storing the result in fmt-desc.
+  ; If asked to, convert the semantic code to a compiled form to simplify more
+  ; intelligent processing of it later.
+
+  (for-each (lambda (insn)
+             (logit 3 "Scanning operands of " (obj:name insn) ": "
+                    (insn-syntax insn) " ...\n")
+             (let ((sem-ops (ifmt-analyze insn compute-sformat?)))
+               (insn-set-fmt-desc! insn (car sem-ops))
+               (if (and compute-sformat? (cadr sem-ops))
+                   (let ((compiled-sems (cadr sem-ops)))
+                     (insn-set-compiled-semantics! insn (car compiled-sems))))
+               (obj-set-atlist! insn
+                                (atlist-append (obj-atlist insn)
+                                               (caddr sem-ops)))
+               ))
+           insn-list)
+
+  ; Now for each insn, look up the ifield list in the format table (and if not
+  ; found add it), and set the ifmt/sfmt elements of the insn.
+
+  (let* ((empty-ifmt (make <iformat>
+                         'ifmt-empty
+                         "empty iformat for unspecified field list"
+                         atlist-empty ; attrs
+                         -1 ; number
+                         #f ; key
+                         nil ; fields
+                         0 ; mask-length
+                         0 ; length
+                         0 ; mask
+                         #f)) ; eg-insn
+        (empty-sfmt (make <sformat>
+                         'sfmt-empty
+                         "empty sformat for unspecified field list"
+                         atlist-empty ; attrs
+                         -1 ; number
+                         #f ; key
+                         #f ; cti?
+                         nil ; sem-in-ops
+                         nil ; sem-out-ops
+                         0 ; length
+                         nil ; used iflds
+                         #f)) ; eg-insn
+        (ifmt-list (list empty-ifmt))
+        (sfmt-list (list empty-sfmt))
+        )
+
+    (for-each (lambda (insn)
+               (logit 3 "Processing format for " (obj:name insn) ": "
+                      (insn-syntax insn) " ...\n")
+
+               (let ((fmt-desc (insn-fmt-desc insn)))
+
+                 (if fmt-desc
+
+                     (begin
+                       ; Must compute <iformat> before <sformat>, the latter
+                       ; needs the former.
+                       (-ifmt-lookup-ifmt! insn fmt-desc ifmt-list)
+                       (if compute-sformat?
+                           (-ifmt-lookup-sfmt! insn fmt-desc sfmt-list)))
+
+                     ; No field list present, use empty format.
+                     (begin
+                       (insn-set-ifmt! insn empty-ifmt)
+                       (if compute-sformat?
+                           (insn-set-sfmt! insn empty-sfmt))))))
+
+             (non-multi-insns insn-list))
+
+    ; Done.  Return the computed iformat and sformat lists.
+    (list ifmt-list sfmt-list)
+    )
+)
diff --git a/cgen/insn.scm b/cgen/insn.scm
new file mode 100644 (file)
index 0000000..bb39a7f
--- /dev/null
@@ -0,0 +1,958 @@
+; Instruction definitions.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; Class to hold an insn.
+
+(define <insn>
+  (class-make '<insn>
+             '(<ident>)
+             '(
+               ; Used to explicitly specify mnemonic, now it's computed from
+               ; syntax string.  ??? Might be useful as an override someday.
+               ;mnemonic
+
+               ; Instruction syntax string.
+               syntax
+
+               ; The insn fields as specified in the .cpu file.
+               ; Also contains values for constant fields.
+               iflds
+               (iflds-values . #f) ; Lazily computed cache
+
+               ; RTL source of assertions of ifield values or #f if none.
+               ; This is used, for example, by the decoder to help
+               ; distinguish what would otherwise be an ambiguity in the
+               ; specification.  It is also used by decode-split support.
+               ; ??? It could also be used the the assembler/disassembler
+               ; some day.
+               (ifield-assertion . #f)
+
+               ; The <fmt-desc> of the insn.
+               ; This is used to help calculate the ifmt,sfmt members.
+               fmt-desc
+
+               ; The <iformat> of the insn.
+               ifmt
+
+               ; The <sformat> of the insn.
+               sfmt
+
+               ; Temp slot for use by applications.
+               ; ??? Will go away in time.
+               tmp
+
+               ; Instruction semantics.
+               ; This is the rtl in source form or #f if there is none.
+               ;
+               ; There are a few issues (ick, I hate that word) to consider
+               ; here:
+               ; - some apps don't need the trap checks (e.g. SIGSEGV)
+               ; - some apps treat the pieces in different ways
+               ; - the simulator tries to merge common fragments among insns
+               ;   to reduce code size in a pbb simulator
+               ;
+               ; Some insns don't have any semantics at all, they are defined
+               ; in another insn [akin to anonymous patterns in gcc].  wip.
+               ;
+               ; ??? GCC-like apps will need a new field to allow specifying
+               ; the semantics if a different value is needed.  wip.
+               ; ??? May wish to put this and the compiled forms in a
+               ; separate class.
+               ; ??? Contents of trap expressions is wip.  It will probably
+               ; be a sequence with an #:errchk modifier or some such.
+               (semantics . #f)
+
+               ; The processed form of the above.
+               ; Each element of rtl is replaced with the associated object.
+               (compiled-semantics . #f)
+
+               ; The mapping of the semantics onto the host.
+               ; FIXME: Not sure what its value will be.
+               ; Another thing that will be needed is [in some cases] a more
+               ; simplified version of the RTL for use by apps like compilers.
+               ; Perhaps that's what this will become.
+               host-semantics
+
+               ; The function unit usage of the instruction.
+               timing
+               )
+             nil)
+)
+
+(method-make-make! <insn>
+                  '(name comment attrs syntax iflds ifield-assertion
+                         semantics timing)
+)
+
+; Accessor fns
+
+(define-getters <insn> insn
+  (syntax iflds ifield-assertion fmt-desc ifmt sfmt tmp
+         semantics compiled-semantics host-semantics timing)
+)
+
+(define-setters <insn> insn
+  (fmt-desc ifmt sfmt ifield-assertion compiled-semantics)
+)
+
+; Return a boolean indicating if X is an <insn>.
+
+(define (insn? x) (class-instance? <insn> x))
+
+; Return a list of the machs that support INSN.
+
+(define (insn-machs insn)
+  nil ; ??? wip
+)
+
+; Return the length of INSN in bits.
+
+(define (insn-length insn)
+  (ifmt-length (insn-ifmt insn))
+)
+
+; Return the length of INSN in bytes.
+
+(define (insn-length-bytes insn)
+  (bits->bytes (insn-length insn))
+)
+
+; Return instruction mnemonic.
+; This is computed from the syntax string.
+; The mnemonic, as we define it, is everything up to, but not including, the
+; first space or '$'.
+; FIXME: Rename to syntax-mnemonic, and take a syntax string argument.
+
+(define (insn-mnemonic insn)
+  (letrec ((mnem-len (lambda (str len)
+                      (cond ((= (string-length str) 0) len)
+                            ((char=? #\space (string-ref str 0)) len)
+                            ((char=? #\$ (string-ref str 0)) len)
+                            (else (mnem-len (string-drop1 str) (+ len 1)))))))
+    (string-take (mnem-len (insn-syntax insn) 0) (insn-syntax insn)))
+)
+
+; Return enum cgen_insn_types value for INSN.
+
+(define (insn-enum insn)
+  (string-upcase (string-append "@ARCH@_INSN_" (gen-sym insn)))
+)
+
+; Return enum for insn named INSN-NAME.
+; This is needed for the `invalid' insn, there is no object for it.
+; [Though obviously having such an object seems like a good idea.]
+
+(define (gen-insn-enum insn-name)
+  (string-upcase (string-append "@ARCH@_INSN_" (gen-c-symbol insn-name)))
+)
+\f
+; Insns with derived operands (see define-derived-operand).
+; ??? These are [currently] recorded separately to minimize impact on existing
+; code while the design is worked out.
+;
+; The class is called <multi-insn> because the insn has multiple variants,
+; one for each combination of "anyof" alternatives.
+; Internally we create one <insn> per alternative.  The theory is that this
+; will remain an internal implementation issue.  When appropriate applications
+; will collapse the number of insns in a way that is appropriate for them.
+;
+; ??? Another way to do this is with insn templates.  One problem the current
+; way has is that it requires each operand's assembler syntax to be self
+; contained (one way to fix this is to use "fake" operands like before).
+; Insn templates needn't have this problem.  On the other hand insn templates
+; [seem to] require more description file entries.
+;
+; ??? This doesn't use all of the members of <insn>.
+; The <multi-insn> class is wip, but should eventually reorganize <insn>.
+; This reorganization might also take into account real, virtual, etc. insns.
+
+(define <multi-insn>
+  (class-make '<multi-insn>
+             '(<insn>)
+             '(
+               ; An <insn> is created for each combination of "anyof"
+               ; alternatives.  They are recorded with other insns, but a
+               ; list of them is recorded here as well.
+               ; This is #f if the sub-insns haven't been instantiated yet.
+               (sub-insns . #f)
+               )
+             nil)
+)
+
+(method-make-make! <multi-insn>
+                  '(name comment attrs syntax iflds ifield-assertion
+                         semantics timing)
+)
+
+(define-getters <multi-insn> multi-insn (sub-insns))
+
+; Return a boolean indicating if X is a <multi-insn>.
+
+(define (multi-insn? x) (class-instance? <multi-insn> x))
+
+; Subroutine of -sub-insn-make! to create the ifield list.
+; Return encoding of {insn} with each element of {anyof-operands} replaced
+; with {new-values}.
+; {value-names} is a list of names of {anyof-operands}.
+
+(define (-sub-insn-ifields insn anyof-operands value-names new-values)
+  ; (debug-repl-env insn anyof-operands value-names new-values)
+
+  ; Delete ifields of {anyof-operands} and add those for {new-values}.
+  (let ((iflds
+        (append!
+         ; Delete ifields in {anyof-operands}.
+         (find (lambda (f)
+                 (not (and (ifld-anyof-operand? f)
+                           (memq (obj:name (ifld-get-value f))
+                                 value-names))))
+               (insn-iflds insn))
+         ; Add ifields for {new-values}.
+         (map derived-encoding new-values)))
+
+       ; Return the last ifield of OWNER in IFLD-LIST.
+       ; OWNER is the object that owns the <ifield> we want.
+       ; For ifields, the owner is the ifield itself.
+       ; For operands, the owner is the operand.
+       ; For derived operands, the owner is the "anyof" parent.
+       ; IFLD-LIST is an unsorted list of <ifield> elements.
+       (find-preceder
+        (lambda (ifld-list owner)
+          ;(debug-repl-env ifld-list owner)
+          (cond ((ifield? owner)
+                 owner)
+                ((anyof-operand? owner)
+                 ; This is the interesting case.  The instantiated choice of
+                 ; {owner} is in {ifld-list}.  We have to find it.
+                 (let* ((name (obj:name owner))
+                        (result
+                         (find-first (lambda (f)
+                                       (and (derived-ifield? f)
+                                            (anyof-instance? (derived-ifield-owner f))
+                                            (eq? name (obj:name (anyof-instance-parent (derived-ifield-owner f))))))
+                                     ifld-list)))
+                   ;(debug-repl-env ifld-list owner)
+                   (assert result)
+                   result))
+                ((operand? owner) ; derived operands are handled here too
+                 (let ((result (op-ifield owner)))
+                   (assert result)
+                   result))
+                (else
+                 (error "`owner' not <ifield>, <operand>, or <derived-operand>")))))
+       )
+
+    ; Resolve any `follows' specs.
+    ; Bad worst case performance but ifield lists aren't usually that long.
+    ; FIXME: Doesn't handle A following B following C.
+    (map (lambda (f)
+          (let ((follows (ifld-follows f)))
+            (if follows
+                (let ((preceder (find-preceder iflds follows)))
+                  (ifld-new-word-offset f (ifld-next-word preceder)))
+                f)))
+        iflds))
+)
+
+
+; Subroutine of multi-insn-instantiate! to instantiate one insn.
+; INSN is the parent insn.
+; ANYOF-OPERANDS is a list of the <anyof-operand>'s of INSN.
+; NEW-VALUES is a list of the value to use for each corresponding element in
+; ANYOF-OPERANDS.  Each element is a <derived-operand>.
+
+(define (-sub-insn-make! insn anyof-operands new-values)
+  ;(debug-repl-env insn anyof-operands new-values)
+  (assert (= (length anyof-operands) (length new-values)))
+  (assert (all-true? (map anyof-operand? anyof-operands)))
+  (assert (all-true? (map derived-operand? new-values)))
+  (logit 3 "Instantiating "
+        (obj:name insn)
+        ":"
+        (string-map (lambda (op newval)
+                      (string-append " "
+                                     (obj:name op)
+                                     "="
+                                     (obj:name newval)))
+                    anyof-operands new-values)
+        " ...\n")
+
+;  (if (eq? '@sib+disp8-QI-disp32-8
+;         (obj:name (car new-values)))
+;      (debug-repl-env insn anyof-operands new-values))
+
+  (let* ((value-names (map obj:name anyof-operands))
+        (ifields (-sub-insn-ifields insn anyof-operands value-names new-values))
+        (known-values (ifld-known-values ifields)))
+
+    ; Don't create insn if ifield assertions fail.
+    (if (all-true? (map (lambda (op)
+                         (anyof-satisfies-assertions? op known-values))
+                       new-values))
+
+       (let ((sub-insn
+              (make <insn>
+                    (apply symbol-append
+                           (cons (obj:name insn)
+                                 (map (lambda (anyof)
+                                        (symbol-append '- (obj:name anyof)))
+                                      new-values)))
+                    (obj:comment insn)
+                    (obj-atlist insn)
+                    (-anyof-merge-syntax (insn-syntax insn)
+                                         value-names new-values)
+                    ifields
+                    (insn-ifield-assertion insn) ; FIXME
+                    (anyof-merge-semantics (insn-semantics insn)
+                                           value-names new-values)
+                    (insn-timing insn)
+                    )))
+         (logit 3 "   instantiated.\n")
+         (current-insn-add! sub-insn))
+
+       (begin
+         logit 3 "    failed ifield assertions.\n")))
+
+  *UNSPECIFIED*
+)
+
+; Instantiate all sub-insns of MULTI-INSN.
+; ??? Might be better to return the list of insns, rather than add them to
+; the global list, and leave it to the caller to add them.
+
+(define (multi-insn-instantiate! multi-insn)
+  (logit 2 "Instantiating " (obj:name multi-insn) " ...\n")
+
+  ; We shouldn't get called more than once.
+  ; ??? Though we could ignore second and subsequent calls.
+  (assert (not (multi-insn-sub-insns multi-insn)))
+
+  (let ((iflds (insn-iflds multi-insn)))
+
+    ; What we want to create here is the set of all "anyof" alternatives.
+    ; From that we create one <insn> per alternative.
+
+    (let ((anyof-iflds (find ifld-anyof-operand? iflds)))
+
+      (assert (all-true? (map anyof-operand? (map ifld-get-value anyof-iflds))))
+      ;(display (obj:name multi-insn) (current-error-port))
+      ;(display " anyof: " (current-error-port))
+      ;(display (map obj:name (map ifld-get-value anyof-iflds)) (current-error-port))
+      ;(newline (current-error-port))
+
+      ; Iterate over all combinations.
+      ; TODO is a list with one element for each <anyof-operand>.
+      ; Each element is in turn a list of all choices (<derived-operands>'s)
+      ; for the <anyof-operand>.  Note that some of these values may be
+      ; derived from nested <anyof-operand>'s.
+      ; ??? anyof-all-choices should cache the results.
+      ; ??? Need to cache results of assertion processing in addition or
+      ; instead of anyof-all-choices.
+
+      (let* ((anyof-operands (map ifld-get-value anyof-iflds))
+            (todo (map anyof-all-choices anyof-operands))
+            (lengths (map length todo))
+            (total (apply * lengths)))
+       ; ??? One might prefer a `do' loop here, but every time I see one I
+       ; have to spend too long remembering its syntax.
+       (let loop ((i 0))
+         (if (< i total)
+             (let* ((indices (split-value lengths i))
+                    (anyof-instances (map list-ref todo indices)))
+               ;(display "derived: " (current-error-port))
+               ;(display (map obj:name anyof-instances) (current-error-port))
+               ;(newline (current-error-port))
+               (-sub-insn-make! multi-insn anyof-operands anyof-instances)
+               (loop (+ i 1))))))))
+
+  *UNSPECIFIED*
+)
+\f
+; Parse an instruction description.
+; This is the main routine for building an insn object from a
+; description in the .cpu file.
+; All arguments are in raw (non-evaluated) form.
+; The result is the parsed object or #f if insn isn't for selected mach(s).
+
+(define (-insn-parse errtxt name comment attrs syntax fmt ifield-assertion
+                    semantics timing)
+  (logit 2 "Processing insn " name " ...\n")
+
+  (let ((name (parse-name name errtxt))
+       (atlist-obj (atlist-parse attrs "cgen_insn" errtxt)))
+
+    (if (keep-atlist? atlist-obj #f)
+
+       (let ((ifield-assertion (if (not (null? ifield-assertion))
+                                   ifield-assertion
+                                   #f))
+             (semantics (if (not (null? semantics))
+                            semantics
+                            #f))
+             (format (-parse-insn-format (string-append errtxt " format")
+                                         fmt))
+             (comment (parse-comment comment errtxt))
+             ; If there are no semantics, mark this as an alias.
+             ; ??? Not sure this makes sense for multi-insns.
+             (atlist-obj (if semantics
+                             atlist-obj
+                             (atlist-cons (bool-attr-make 'ALIAS #t)
+                                          atlist-obj)))
+             (syntax (parse-syntax syntax errtxt))
+             (timing (parse-insn-timing errtxt timing))
+             )
+
+         (if (anyof-operand-format? format)
+
+             (make <multi-insn>
+               name comment atlist-obj
+               syntax
+               format
+               ifield-assertion
+               semantics
+               timing)
+
+             (make <insn>
+               name comment atlist-obj
+               syntax
+               format
+               ifield-assertion
+               semantics
+               timing)))
+
+       (begin
+         (logit 2 "Ignoring " name ".\n")
+         #f)))
+)
+
+; Read an instruction description.
+; This is the main routine for analyzing instructions in the .cpu file.
+; ERRTXT is prepended to error messages to provide context.
+; ARG-LIST is an associative list of field name and field value.
+; -insn-parse is invoked to create the <insn> object.
+
+(define (insn-read errtxt . arg-list)
+  (let ((name nil)
+       (comment "")
+       (attrs nil)
+       (syntax nil)
+       (fmt nil)
+       (ifield-assertion nil)
+       (semantics nil)
+       (timing nil)
+       )
+    ; Loop over each element in ARG-LIST, recording what's found.
+    (let loop ((arg-list arg-list))
+      (if (null? arg-list)
+         nil
+         (let ((arg (car arg-list))
+               (elm-name (caar arg-list)))
+           (case elm-name
+             ((name) (set! name (cadr arg)))
+             ((comment) (set! comment (cadr arg)))
+             ((attrs) (set! attrs (cdr arg)))
+             ((syntax) (set! syntax (cadr arg)))
+             ((format) (set! fmt (cadr arg)))
+             ((ifield-assertion) (set! ifield-assertion (cadr arg)))
+             ((semantics) (set! semantics (cadr arg)))
+             ((timing) (set! timing (cdr arg)))
+             (else (parse-error errtxt "invalid insn arg" arg)))
+           (loop (cdr arg-list)))))
+    ; Now that we've identified the elements, build the object.
+    (-insn-parse errtxt name comment attrs syntax fmt ifield-assertion
+                semantics timing)
+    )
+)
+
+; Define an instruction object, name/value pair list version.
+
+(define define-insn
+  (lambda arg-list
+    (let ((i (apply insn-read (cons "define-insn" arg-list))))
+      (if i
+         (current-insn-add! i))
+      i))
+)
+
+; Define an instruction object, all arguments specified.
+
+(define (define-full-insn name comment attrs syntax fmt ifield-assertion
+         semantics timing)
+  (let ((i (-insn-parse "define-full-insn" name comment attrs
+                       syntax fmt ifield-assertion
+                       semantics timing)))
+    (if i
+       (current-insn-add! i))
+    i)
+)
+\f
+; Parsing support.
+
+; Parse an insn syntax field.
+; SYNTAX is either a string or a list of strings, each element of which may
+; in turn be a list of strings.
+; ??? Not sure this extra flexibility is worth it yet.
+
+(define (parse-syntax syntax errtxt)
+  (cond ((list? syntax)
+        (string-map (lambda (elm) (parse-syntax elm errtxt)) syntax))
+       ((or (string? syntax) (symbol? syntax))
+        syntax)
+       (else (parse-error errtxt "improper syntax" syntax)))
+)
+
+; Subroutine of -parse-insn-format to parse a symbol ifield spec.
+
+(define (-parse-insn-format-symbol errtxt sym)
+  ;(debug-repl-env sym)
+  (let ((op (current-op-lookup sym)))
+    (if op
+       (cond ((derived-operand? op)
+              ; There is a one-to-one relationship b/w derived operands and
+              ; the associated derived ifield.
+              (let ((ifld (op-ifld op)))
+                (assert (derived-ifield? ifld))
+                ifld))
+             ((anyof-operand? op)
+              (ifld-new-value f-anyof op))
+             (else
+              (let ((ifld (op-ifield op)))
+                (ifld-new-value ifld op))))
+       ; An insn-enum?
+       (let ((e (ienum-lookup-val sym)))
+         (if e
+             (ifld-new-value (ienum:fld (cdr e)) (car e))
+             (parse-error errtxt "bad format element" sym)))))
+)
+
+; Subroutine of -parse-insn-format to parse an (ifield-name value) ifield spec.
+;
+; The last element is the ifield's value.  It must be an integer.
+; ??? Whether it can be negative is still unspecified.
+; ??? While there might be a case where allowing floating point values is
+; desirable, supporting them would require precise conversion routines.
+; They should be rare enough that we instead punt.
+;
+; ??? May wish to support something like "(% startbit bitsize value)".
+;
+; ??? Error messages need improvement, but that's generally true of cgen.
+
+(define (-parse-insn-format-ifield-spec errtxt ifld ifld-spec)
+  (if (!= (length ifld-spec) 2)
+      (parse-error errtxt "bad ifield format, should be (ifield-name value)" ifld-spec))
+
+  (let ((value (cadr ifld-spec)))
+    ; ??? This use to allow (ifield-name operand-name).  That's how
+    ; `operand-name' elements are handled, but there's no current need
+    ; to handle (ifield-name operand-name).
+    (if (not (integer? value))
+       (parse-error errtxt "ifield value not an integer" ifld-spec))
+    (ifld-new-value ifld value))
+)
+
+; Subroutine of -parse-insn-format to parse an
+; (ifield-name value) ifield spec.
+; ??? There is room for growth in the specification syntax here.
+; Possibilities are (ifield-name|operand-name [options] [value]).
+
+(define (-parse-insn-format-list errtxt spec)
+  (let ((ifld (current-ifld-lookup (car spec))))
+    (if ifld
+       (-parse-insn-format-ifield-spec errtxt ifld spec)
+       (parse-error errtxt "unknown ifield" spec)))
+)
+
+; Given an insn format field from a .cpu file, replace it with a list of
+; ifield objects with the values assigned.
+;
+; An insn format field is a list of ifields that make up the instruction.
+; All bits must be specified, including reserved bits
+; [at present no checking is made of this, but the rule still holds].
+;
+; A normal entry begins with `+' and then consist of the following:
+; - operand name
+; - (ifield-name [options] value)
+; - (operand-name [options] [value])
+; - insn ifield enum
+;
+; Example: (+ OP1_ADD (f-res2 0) dr src1 (f-src2 1) (f-res1 #xea))
+;
+; where OP1_ADD is an enum, dr and src1 are operands, and f-src2 and f-res1
+; are ifield's.  The `+' allows for future extension.
+;
+; The other form of entry begins with `=' and is followed by an instruction
+; name that has the same format.  The specified instruction must already be
+; defined.  Instructions with this form typically also include an
+; `ifield-assertion' spec to keep them separate.
+;
+; An empty field list is ok.  This means it's unspecified.
+; VIRTUAL insns have this.
+;
+; This is one of the more important routines to be efficient.
+; It's called for each instruction, and is one of the more expensive routines
+; in insn parsing.
+
+(define (-parse-insn-format errtxt fld-list)
+  (if (null? fld-list)
+      nil ; field list unspecified
+      (case (car fld-list)
+       ((+) (map (lambda (fld)
+                   (let ((f (if (string? fld)
+                                (string->symbol fld)
+                                fld)))
+                     (cond ((symbol? f)
+                            (-parse-insn-format-symbol errtxt f))
+                           ((and (list? f)
+                                 ; ??? This use to allow <ifield> objects
+                                 ; in the `car' position.  Checked for below.
+                                 (symbol? (car f)))
+                            (-parse-insn-format-list errtxt f))
+                           (else
+                            (if (and (list? f)
+                                     (ifield? (car f)))
+                                (parse-error errtxt "FIXME: <ifield> object in format spec"))
+                            (parse-error errtxt "bad format element" f)))))
+                 (cdr fld-list)))
+       ((=) (begin
+              (if (or (!= (length fld-list) 2)
+                      (not (symbol? (cadr fld-list))))
+                  (parse-error errtxt
+                               "bad `=' format spec, should be `(= insn-name)'"
+                               fld-list))
+              (let ((insn (current-insn-lookup (cadr fld-list))))
+                (if (not insn)
+                    (parse-error errtxt "unknown insn" (cadr fld-list)))
+                (insn-iflds insn))))
+       (else
+        (parse-error errtxt "format must begin with `+' or `='" fld-list))
+       ))
+)
+
+; Return a boolean indicating if IFLD-LIST contains anyof operands.
+
+(define (anyof-operand-format? ifld-list)
+  (any-true? (map (lambda (f)
+                   (or (ifld-anyof? f)
+                       (derived-ifield? f)))
+                 ifld-list))
+)
+\f
+; Insn utilities.
+; ??? multi-insn support wip, may require changes here.
+
+; Return a boolean indicating if INSN is an alias insn.
+
+(define (insn-alias? insn)
+  (obj-has-attr? insn 'ALIAS)
+)
+
+; Return a list of instructions that are not aliases in INSN-LIST.
+
+(define (non-alias-insns insn-list)
+  (find (lambda (insn)
+         (not (insn-alias? insn)))
+       insn-list)
+)
+
+; Return a boolean indicating if INSN is a "real" INSN
+; (not ALIAS and not VIRTUAL and not a <multi-insn>).
+
+(define (insn-real? insn)
+  (let ((atlist (obj-atlist insn)))
+    (and (not (atlist-has-attr? atlist 'ALIAS))
+        (not (atlist-has-attr? atlist 'VIRTUAL))
+        (not (multi-insn? insn))))
+)
+
+; Return a list of real instructions in INSN-LIST.
+
+(define (real-insns insn-list)
+  (find insn-real? insn-list)
+)
+
+; Return a boolean indicating if INSN is a virtual insn.
+
+(define (insn-virtual? insn)
+  (obj-has-attr? insn 'VIRTUAL)
+)
+
+; Return a list of virtual instructions in INSN-LIST.
+
+(define (virtual-insns insn-list)
+  (find insn-virtual? insn-list)
+)
+
+; Return a list of non-alias/non-pbb insns in INSN-LIST.
+
+(define (non-alias-pbb-insns insn-list)
+  (find (lambda (insn)
+         (let ((atlist (obj-atlist insn)))
+           (and (not (atlist-has-attr? atlist 'ALIAS))
+                (not (atlist-has-attr? atlist 'PBB)))))
+       insn-list)
+)
+
+; Return a list of multi-insns in INSN-LIST.
+
+(define (multi-insns insn-list)
+  (find multi-insn? insn-list)
+)
+
+; And the opposite:
+
+(define (non-multi-insns insn-list)
+  (find (lambda (insn) (not (multi-insn? insn))) insn-list)
+)
+
+
+; Filter out instructions whose ifield patterns are strict subsets of
+; another.  For decoding purpose, it is sufficient to consider the
+; more general cousin.
+
+(define (filter-harmlessly-ambiguous-insns insn-list)
+  (logit 3 "Filtering " (length insn-list) " instructions.\n")
+  (find (lambda (insn)
+         (let* ((i-mask (insn-base-mask insn))
+                (i-mask-len (insn-base-mask-length insn))
+                (i-value (insn-value insn))
+                (superset-insn (find-first 
+                                 (lambda (insn2) ; insn2: possible supermatch (fewer mask bits)
+                                   (let ((i2-mask (insn-base-mask insn2))
+                                         (i2-mask-len (insn-base-mask-length insn2))
+                                         (i2-value (insn-value insn2)))
+                                     (and (not (eq? insn insn2))
+                                          (= i-mask-len i2-mask-len)
+                                          (mask-superset? i2-mask i2-value i-mask i-value))))
+                                 insn-list))
+                (keep? (not superset-insn)))
+           (if (not keep?) 
+               (logit 2
+                      "Instruction " (obj:name insn) "ambiguity-filtered by "
+                      (obj:name superset-insn) "\n"))
+           keep?))
+       insn-list)
+)
+
+
+; Helper function for above: does (m1,v1) match a superset of (m2,v2) ?
+;
+; eg> mask-superset? #b1100 #b1000 #b1110 #b1010 -> #t
+; eg> mask-superset? #b1100 #b1000 #b1010 #b1010 -> #f
+; eg> mask-superset? #b1100 #b1000 #b1110 #b1100 -> #f
+(define (mask-superset? m1 v1 m2 v2)
+  (let ((result
+        (and (= (cg-logand m1 m2) m1)
+             (= (cg-logand m1 v1) (cg-logand m1 v2)))))
+    (if result (logit 4
+                     "(" (number->string m1 16) "," (number->string v1 16) ")"
+                     " contains "
+                     "(" (number->string m2 16) "," (number->string v2 16) ")"
+                     "\n"))
+    result)
+)
+
+
+
+
+; Return a boolean indicating if INSN is a cti [control transfer insn].
+; This includes SKIP-CTI insns even though they don't terminate a basic block.
+; ??? SKIP-CTI insns are wip, waiting for more examples of how they're used.
+
+(define (insn-cti? insn)
+  (atlist-cti? (obj-atlist insn))
+)
+
+; Return a boolean indicating if INSN can be executed in parallel.
+; Such insns are required to have enum attribute PARALLEL != NO.
+; This is worded specifically to allow the PARALLEL attribute to have more
+; than just NO/YES values (should a target want to do so).
+; This specification may not be sufficient, but the intent is explicit.
+
+(define (insn-parallel? insn)
+  (let ((atval (obj-attr-value insn 'PARALLEL)))
+    (and atval (not (eq? atval 'NO))))
+)
+
+; Return a list of the insns that support parallel execution in INSN-LIST.
+
+(define (parallel-insns insn-list)
+  (find insn-parallel? insn-list)
+)
+\f
+; Instruction field utilities.
+
+; Return a boolean indicating if INSN has ifield named F-NAME.
+
+(define (insn-has-ifield? insn f-name)
+  (->bool (object-assq f-name (insn-iflds insn)))
+)
+\f
+; Insn opcode value utilities.
+
+; Given INSN, return the length in bits of the base mask (insn-base-mask).
+
+(define (insn-base-mask-length insn)
+  (ifmt-mask-length (insn-ifmt insn))
+)
+
+; Given INSN, return the bitmask of constant values (the opcode field)
+; in the base part.
+
+(define (insn-base-mask insn)
+  (ifmt-mask (insn-ifmt insn))
+)
+
+; Given INSN, return the sum of the constant values in the insn
+; (i.e. the opcode field).
+;
+; See also (compute-insn-base-mask).
+;
+(define (insn-value insn)
+  (if (elm-get insn 'iflds-values)
+      (elm-get insn 'iflds-values)
+      (let* ((base-len (insn-base-mask-length insn))
+            (value (apply +
+                          (map (lambda (fld) (ifld-value fld base-len (ifld-get-value fld)))
+                               (find ifld-constant?
+                                     (collect ifld-base-ifields (insn-iflds insn))))
+                          )))
+       (elm-set! insn 'iflds-values value)
+       value)
+      )
+  )
+\f
+; Insn operand utilities.
+
+; Lookup operand SEM-NAME in INSN.
+
+(define (insn-lookup-op insn sem-name)
+  (or (op:lookup-sem-name (sfmt-in-ops (insn-sfmt insn)) sem-name)
+      (op:lookup-sem-name (sfmt-out-ops (insn-sfmt insn)) sem-name))
+)
+\f
+; Insn syntax utilities.
+
+; Create a list of syntax strings broken up into a list of characters and
+; operand objects.
+
+(define (syntax-break-out syntax)
+  (let ((result nil))
+    ; ??? The style of the following could be more Scheme-like.  Later.
+    (let loop ()
+      (if (> (string-length syntax) 0)
+         (begin
+           (cond 
+            ; Handle escaped syntax metacharacters 
+            ((char=? #\\ (string-ref syntax 0))
+             (set! result (cons (substring syntax 0 1) result))
+             (set! result (cons (substring syntax 1 1) result))
+             (set! syntax (string-drop 2 syntax)))
+            ; Handle operand reference
+            ((char=? #\$ (string-ref syntax 0))
+             ; Extract the symbol from the string, get the operand.
+             (if (char=? #\{ (string-ref syntax 1))
+                 (let ((n (string-index syntax #\})))
+                   (set! result (cons (current-op-lookup
+                                       (string->symbol
+                                        (substring syntax 2 n)))
+                                      result))
+                   (set! syntax (string-drop (+ 1 n) syntax)))
+                 (let ((n (id-len (string-drop1 syntax))))
+                   (set! result (cons (current-op-lookup
+                                       (string->symbol
+                                        (substring syntax 1 (+ 1 n))))
+                                      result))
+                   (set! syntax (string-drop (+ 1 n) syntax)))))
+            ; Handle everything else
+            (else (set! result (cons (substring syntax 0 1) result))
+                  (set! syntax (string-drop1 syntax))))
+           (loop))))
+    (reverse result))
+  )
+
+; Given a list of syntax elements (e.g. the result of syntax-break-out),
+; create a syntax string.
+
+(define (syntax-make elements)
+  (apply string-append
+        (map (lambda (e)
+               (cond ((char? e)
+                      (string "\\" e))
+                     ((string? e)
+                      e)
+                     (else
+                      (assert (operand? e))
+                      (string-append "${" (obj:name e) "}"))))
+             elements))
+)
+\f
+; Called before a .cpu file is read in.
+
+(define (insn-init!)
+  (reader-add-command! 'define-insn
+                      "\
+Define an instruction, name/value pair list version.
+"
+                      nil 'arg-list define-insn)
+  (reader-add-command! 'define-full-insn
+                      "\
+Define an instruction, all arguments specified.
+"
+                      nil '(name comment attrs syntax fmt ifield-assertion semantics timing)
+                      define-full-insn)
+
+  *UNSPECIFIED*
+)
+
+; Called before a . cpu file is read in to install any builtins.
+
+(define (insn-builtin!)
+  ; Standard insn attributes.
+  ; ??? Some of these can be combined into one.
+
+  (define-attr '(for insn) '(type boolean) '(name UNCOND-CTI) '(comment "unconditional cti"))
+
+  (define-attr '(for insn) '(type boolean) '(name COND-CTI) '(comment "conditional cti"))
+
+  ; SKIP-CTI: one or more immediately following instructions are conditionally
+  ; executed (or skipped)
+  (define-attr '(for insn) '(type boolean) '(name SKIP-CTI) '(comment "skip cti"))
+
+  ; DELAY-SLOT: insn has one or more delay slots (wip)
+  (define-attr '(for insn) '(type boolean) '(name DELAY-SLOT) '(comment "insn has a delay slot"))
+
+  ; RELAXABLE: Insn has one or more identical but larger variants.
+  ; The assembler tries this one first and then the relaxation phase
+  ; switches to the larger ones as necessary.
+  ; All insns of identical behaviour have a RELAX_FOO attribute that groups
+  ; them together.
+  ; FIXME: This is a case where we need one attribute with several values.
+  ; Presently each RELAX_FOO will use up a bit.
+  (define-attr '(for insn) '(type boolean) '(name RELAXABLE) '(comment "insn is relaxable"))
+
+  ; RELAX: Large relaxable variant.  Avoided by assembler in first pass.
+  ; FIXME: Rename this to RELAXED.
+  (define-attr '(for insn) '(type boolean) '(name RELAX) '(comment "relaxed form of insn"))
+
+  ; NO-DIS: For macro insns, do not use during disassembly.
+  (define-attr '(for insn) '(type boolean) '(name NO-DIS) '(comment "don't use for disassembly"))
+
+  ; PBB: Virtual insn used for PBB support.
+  (define-attr '(for insn) '(type boolean) '(name PBB) '(comment "virtual insn used for PBB support"))
+
+  ; DECODE-SPLIT: insn resulted from decode-split processing
+  (define-attr '(for insn) '(type boolean) '(name DECODE-SPLIT) '(comment "insn split from another insn for decoding purposes") '(attrs META))
+
+  ; Also (defined elsewhere):
+  ; VIRTUAL: Helper insn used by the simulator.
+
+  *UNSPECIFIED*
+)
+
+; Called after the .cpu file has been read in.
+
+(define (insn-finish!)
+  *UNSPECIFIED*
+)
diff --git a/cgen/m32r.cpu b/cgen/m32r.cpu
new file mode 100644 (file)
index 0000000..047e257
--- /dev/null
@@ -0,0 +1,2088 @@
+; Mitsubishi M32R CPU description.  -*- Scheme -*-
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+(include "simplify.inc")
+
+; FIXME: Delete sign extension of accumulator results.
+; Sign extension is done when accumulator is read.
+
+; define-arch must appear first
+
+(define-arch
+  (name m32r) ; name of cpu family
+  (comment "Mitsubishi M32R")
+  (default-alignment aligned)
+  (insn-lsb0? #f)
+  (machs m32r m32rx)
+  (isas m32r)
+)
+
+; Attributes.
+
+; An attribute to describe which pipeline an insn runs in.
+(define-attr
+  (for insn)
+  (type enum)
+  (name PIPE)
+  (comment "parallel execution pipeline selection")
+  (values NONE O S OS)
+)
+; A derived attribute that says which insns can be executed in parallel
+; with others.  This is a required attribute for architectures with
+; parallel execution.
+(define-attr
+  (for insn)
+  (type enum)
+  (name PARALLEL)
+  (attrs META) ; do not define in any generated file for now
+  (values NO YES)
+  (default (if (eq-attr (current-insn) PIPE NONE) (symbol NO) (symbol YES)))
+)
+
+; Instruction set parameters.
+
+(define-isa
+  (name m32r)
+
+  ; This is 32 because 16 bit insns always appear as pairs.
+  ; ??? See if this can go away.  It's only used by the disassembler (right?)
+  ; to decide how long an unknown insn is.  One value isn't sufficient (e.g. if
+  ; on a 16 bit (and not 32 bit) boundary, will only want to advance pc by 16.)
+  (default-insn-bitsize 32)
+
+  ; Number of bytes of insn we can initially fetch.
+  ; The M32R is tricky in that insns are either two 16-bit insns
+  ; (executed sequentially or in parallel) or one 32-bit insn.
+  ; So on one hand the base insn size is 16 bits, but on another it's 32.
+  ; 32 is chosen because:
+  ; - if the chip were ever bi-endian it is believed that the byte order would
+  ;   be based on 32 bit quantities
+  ; - 32 bit insns are always aligned on 32 bit boundaries
+  ; - the pc will never stop on a 16 bit (and not 32 bit) boundary
+  ;   [well actually it can, but there are no branches to such places]
+  (base-insn-bitsize 32)
+
+  ; Used in computing bit numbers.
+  (default-insn-word-bitsize 32)
+
+  ; The m32r fetches 2 insns at a time.
+  (liw-insns 2)
+
+  ; While the m32r can execute insns in parallel, the base mach can't
+  ; (other than nop).  The base mach is greatly handicapped by this, but
+  ; we still need to cleanly handle it.
+  (parallel-insns 2)
+
+  ; Initial bitnumbers to decode insns by.
+  (decode-assist (0 1 2 3 8 9 10 11))
+
+  ; Classification of instructions that fit in the various frames.
+  ; wip, not currently used
+  (insn-types (long ; name
+              31 ; length
+              (eq-attr (current-insn) LENGTH 31) ; matching insns
+              (0 1 2 7 8 9 10) ; decode-assist
+              )
+             (short
+              15
+              (eq-attr (current-insn) LENGTH 15) ; matching insns
+              (0 1 2 7 8 9 10)
+              )
+             )
+
+  ; Instruction framing.
+  ; Each m32r insn is either one 32 bit insn, two 16 bit insns executed
+  ; serially (left->right), or two 16 bit insns executed parallelly.
+  ; wip, not currently used
+  (frame long32 ; name
+        ((long)) ; list of insns in frame, plus constraint
+        "$0"   ; assembler
+        (+ (1 1) (31 $0)) ; value
+        (sequence () (execute $0)) ; action
+        )
+  (frame serial2x16
+        ((short)
+         (short))
+        "$0 -> $1"
+        (+ (1 0) (15 $0) (1 0) (15 $1))
+        (sequence ()
+                  (execute $0)
+                  (execute $1))
+        )
+  (frame parallel2x16
+        ((short (eq-attr (current-insn) PIPE "O,BOTH"))
+         (short (eq-attr (current-insn) PIPE "S,BOTH")))
+        "$0 || $1"
+        (+ (1 0) (15 $0) (1 1) (15 $1))
+        (parallel ()
+                  (execute $0)
+                  (execute $1))
+        )
+)
+\f
+; Cpu family definitions.
+
+; ??? define-cpu-family [and in general "cpu-family"] might be clearer than
+; define-cpu.
+; ??? Have define-arch provide defaults for architecture that define-cpu can
+; then override [reduces duplication in define-cpu].
+; ??? Another way to go is to delete cpu-families entirely and have one mach
+; able to inherit things from another mach (would also need the ability to
+; not only override specific inherited things but also disable some,
+; e.g. if an insn wasn't supported).
+
+(define-cpu
+  ; cpu names must be distinct from the architecture name and machine names.
+  ; The "b" suffix stands for "base" and is the convention.
+  ; The "f" suffix stands for "family" and is the convention.
+  (name m32rbf)
+  (comment "Mitsubishi M32R base family")
+  (endian big)
+  (word-bitsize 32)
+  ; Override isa spec (??? keeps things simpler, though it was more true
+  ; in the early days and not so much now).
+  (parallel-insns 1)
+)
+
+(define-cpu
+  (name m32rxf)
+  (comment "Mitsubishi M32Rx family")
+  (endian big)
+  (word-bitsize 32)
+  ; Generated files have an "x" suffix.
+  (file-transform "x")
+)
+
+(define-mach
+  (name m32r)
+  (comment "Generic M32R cpu")
+  (cpu m32rbf)
+)
+
+(define-mach
+  (name m32rx)
+  (comment "M32RX cpu")
+  (cpu m32rxf)
+)
+\f
+; Model descriptions.
+
+; The meaning of this value is wip but at the moment it's intended to describe
+; the implementation (i.e. what -mtune=foo does in sparc gcc).
+;
+; Notes while wip:
+; - format of pipeline entry:
+;   (pipeline name (stage1-name ...) (stage2-name ...) ...)
+;   The contents of a stage description is wip.
+; - each mach must have at least one model
+; - the default model must be the first one
+;- maybe have `retire' support update total cycle count to handle current
+;  parallel insn cycle counting problems
+
+(define-model
+  (name m32r/d) (comment "m32r/d") (attrs)
+  (mach m32r)
+
+  ;(prefetch)
+  ;(retire)
+
+  (pipeline p-non-mem "" () ((fetch) (decode) (execute) (writeback)))
+  (pipeline p-mem "" () ((fetch) (decode) (execute) (memory) (writeback)))
+
+  ; `state' is a list of variables for recording model state
+  (state
+   ; bit mask of h-gr registers, =1 means value being loaded from memory
+   (h-gr UINT)
+   )
+
+  (unit u-exec "Execution Unit" ()
+       1 1 ; issue done
+       () ; state
+       ((sr INT -1) (dr INT -1)) ; inputs
+       ((dr INT -1)) ; outputs
+       () ; profile action (default)
+       )
+  (unit u-cmp "Compare Unit" ()
+       1 1 ; issue done
+       () ; state
+       ((src1 INT -1) (src2 INT -1)) ; inputs
+       () ; outputs
+       () ; profile action (default)
+       )
+  (unit u-mac "Multiply/Accumulate Unit" ()
+       1 1 ; issue done
+       () ; state
+       ((src1 INT -1) (src2 INT -1)) ; inputs
+       () ; outputs
+       () ; profile action (default)
+       )
+  (unit u-cti "Branch Unit" ()
+       1 1 ; issue done
+       () ; state
+       ((sr INT -1)) ; inputs
+       ((pc)) ; outputs
+       () ; profile action (default)
+       )
+  (unit u-load "Memory Load Unit" ()
+       1 1 ; issue done
+       () ; state
+       ((sr INT)
+        ;(ld-mem AI)
+        ) ; inputs
+       ((dr INT)) ; outputs
+       () ; profile action (default)
+       )
+  (unit u-store "Memory Store Unit" ()
+       1 1 ; issue done
+       () ; state
+       ((src1 INT) (src2 INT)) ; inputs
+       () ; ((st-mem AI)) ; outputs
+       () ; profile action (default)
+       )
+)
+
+(define-model
+  (name test) (comment "test") (attrs)
+  (mach m32r)
+  (pipeline all "" () ((fetch) (decode) (execute) (writeback)))
+  (unit u-exec "Execution Unit" ()
+       1 1 ; issue done
+       () () () ())
+)
+
+; Each mach must have at least one model.
+
+(define-model
+  (name m32rx) (comment "m32rx") (attrs)
+  (mach m32rx)
+
+  ; ??? It's 6 stages but I forget the details right now.
+  (pipeline p-o "" () ((fetch) (decode) (execute) (writeback)))
+  (pipeline p-s "" () ((fetch) (decode) (execute) (writeback)))
+  (pipeline p-o-mem "" () ((fetch) (decode) (execute) (memory) (writeback)))
+
+  (unit u-exec "Execution Unit" ()
+       1 1 ; issue done
+       () ; state
+       ((sr INT -1) (dr INT -1)) ; inputs
+       ((dr INT -1)) ; outputs
+       () ; profile action (default)
+       )
+  (unit u-cmp "Compare Unit" ()
+       1 1 ; issue done
+       () ; state
+       ((src1 INT -1) (src2 INT -1)) ; inputs
+       () ; outputs
+       () ; profile action (default)
+       )
+  (unit u-mac "Multiply/Accumulate Unit" ()
+       1 1 ; issue done
+       () ; state
+       ((src1 INT -1) (src2 INT -1)) ; inputs
+       () ; outputs
+       () ; profile action (default)
+       )
+  (unit u-cti "Branch Unit" ()
+       1 1 ; issue done
+       () ; state
+       ((sr INT -1)) ; inputs
+       ((pc)) ; outputs
+       () ; profile action (default)
+       )
+  (unit u-load "Memory Load Unit" ()
+       1 1 ; issue done
+       () ; state
+       ((sr INT)) ; inputs
+       ((dr INT)) ; outputs
+       () ; profile action (default)
+       )
+  (unit u-store "Memory Store Unit" ()
+       1 1 ; issue done
+       () ; state
+       ((src1 INT) (src2 INT)) ; inputs
+       () ; outputs
+       () ; profile action (default)
+       )
+)
+\f
+; The instruction fetch/execute cycle.
+; This is split into two parts as sometimes more than one instruction is
+; decoded at once.
+; The `const SI' argument to decode/execute is used to distinguish
+; multiple instructions processed at the same time (e.g. m32r).
+;
+; ??? This is wip, and not currently used.
+; ??? Needs to be moved to define-isa.
+
+; This is how to fetch and decode an instruction.
+
+;(define-extract
+;  (sequence VOID
+;          (if VOID (ne AI (and AI pc (const AI 3)) (const AI 0))
+;              (sequence VOID
+;                        (set-quiet USI (scratch UHI insn1) (ifetch UHI pc))
+;                        (decode VOID pc (and UHI insn1 (const UHI #x7fff))
+;                                (const SI 0)))
+;              (sequence VOID
+;                        (set-quiet USI (scratch USI insn) (ifetch USI pc))
+;                        (if VOID (ne USI (and USI insn (const USI #x80000000))
+;                                   (const USI 0))
+;                            (decode VOID pc (srl USI insn (const WI 16)) (const SI 0))
+;                            (sequence VOID
+;                                      ; ??? parallel support
+;                                      (decode VOID pc (srl USI insn (const WI 16))
+;                                              (const SI 0))
+;                                      (decode VOID (add AI pc (const AI 2))
+;                                              (and USI insn (const WI #x7fff))
+;                                              (const SI 1))))))
+;          )
+;)
+
+; This is how to execute a decoded instruction.
+
+;(define-execute
+;  (sequence VOID () ; () is empty option list
+;           ((AI new_pc))
+;           (set AI new_pc (execute: AI (const 0)) #:quiet)
+;           (set AI pc new_pc #:direct)
+;           )
+;)
+
+; FIXME: It might simplify things to separate the execute process from the
+; one that updates the PC.
+\f
+; Instruction fields.
+;
+; Attributes:
+; PCREL-ADDR: pc relative value (for reloc and disassembly purposes)
+; ABS-ADDR: absolute address (for reloc and disassembly purposes?)
+; RESERVED: bits are not used to decode insn, must be all 0
+; RELOC: there is a relocation associated with this field (experiment)
+
+(define-attr
+  (for ifield operand)
+  (type boolean)
+  (name RELOC)
+  (comment "there is a reloc associated with this field (experiment)")
+)
+
+(dnf f-op1       "op1"                 () 0 4)
+(dnf f-op2       "op2"                 () 8 4)
+(dnf f-cond      "cond"                () 4 4)
+(dnf f-r1        "r1"                  () 4 4)
+(dnf f-r2        "r2"                  () 12 4)
+(df f-simm8      "simm8"               () 8 8 INT #f #f)
+(df f-simm16     "simm16"              () 16 16 INT #f #f)
+(dnf f-shift-op2 "shift op2"           () 8 3)
+(dnf f-uimm4     "uimm4"               () 12 4)
+(dnf f-uimm5     "uimm5"               () 11 5)
+(dnf f-uimm16    "uimm16"              () 16 16)
+(dnf f-uimm24    "uimm24"              (ABS-ADDR RELOC) 8 24)
+(dnf f-hi16      "high 16 bits"        (SIGN-OPT) 16 16)
+(df f-disp8      "disp8, slot unknown" (PCREL-ADDR RELOC) 8 8 INT
+    ((value pc) (sra WI (sub WI value (and WI pc (const -4))) (const 2)))
+    ((value pc) (add WI (sll WI value (const 2)) (and WI pc (const -4)))))
+(df f-disp16     "disp16"              (PCREL-ADDR RELOC) 16 16 INT
+    ((value pc) (sra WI (sub WI value pc) (const 2)))
+    ((value pc) (add WI (sll WI value (const 2)) pc)))
+(df f-disp24     "disp24"              (PCREL-ADDR RELOC) 8 24 INT
+    ((value pc) (sra WI (sub WI value pc) (const 2)))
+    ((value pc) (add WI (sll WI value (const 2)) pc)))
+
+(dnf f-op23      "op2.3"               ()  9 3)
+(dnf f-op3       "op3"                 () 14 2)
+(dnf f-acc       "acc"                 ()  8 1)
+(dnf f-accs      "accs"                () 12 2)
+(dnf f-accd      "accd"                ()  4 2)
+(dnf f-bits67    "bits67"              ()  6 2)
+(dnf f-bit14     "bit14"               () 14 1)
+
+(define-ifield (name f-imm1) (comment "1 bit immediate, 0->1 1->2")
+  (attrs)
+  (start 15) (length 1)
+  (encode (value pc) (sub WI value (const WI 1)))
+  (decode (value pc) (add WI value (const WI 1)))
+)
+\f
+; Enums.
+
+; insn-op1: bits 0-3
+; FIXME: should use die macro or some such
+(define-normal-insn-enum insn-op1 "insn format enums" () OP1_ f-op1
+  ("0" "1" "2" "3" "4" "5" "6" "7"
+   "8" "9" "10" "11" "12" "13" "14" "15")
+)
+
+; insn-op2: bits 8-11
+; FIXME: should use die macro or some such
+(define-normal-insn-enum insn-op2 "op2 enums" () OP2_ f-op2
+  ("0" "1" "2" "3" "4" "5" "6" "7"
+   "8" "9" "10" "11" "12" "13" "14" "15")
+)
+\f
+; Hardware pieces.
+; These entries list the elements of the raw hardware.
+; They're also used to provide tables and other elements of the assembly
+; language.
+
+(dnh h-pc "program counter" (PC PROFILE) (pc) () () ())
+
+(dnh h-hi16 "high 16 bits" ()
+     (immediate (UINT 16))
+     () () ()
+)
+
+; These two aren't technically needed.
+; They're here for illustration sake mostly.
+; Plus they cause the value to be stored in the extraction buffers to only
+; be 16 bits wide (vs 32 or 64).  Whoopie ding.  But it's fun.
+(dnh h-slo16 "signed low 16 bits" ()
+     (immediate (INT 16))
+     () () ()
+)
+(dnh h-ulo16 "unsigned low 16 bits" ()
+     (immediate (UINT 16))
+     () () ()
+)
+
+(define-keyword
+  (name gr-names)
+  (print-name h-gr)
+  (prefix "")
+  (values (fp 13) (lr 14) (sp 15)
+         (r0 0) (r1 1) (r2 2) (r3 3) (r4 4) (r5 5) (r6 6) (r7 7)
+         (r8 8) (r9 9) (r10 10) (r11 11) (r12 12) (r13 13) (r14 14) (r15 15))
+)
+
+(define-hardware
+  (name h-gr)
+  (comment "general registers")
+  (attrs PROFILE CACHE-ADDR)
+  (type register WI (16))
+  (indices extern-keyword gr-names)
+)
+
+(define-keyword
+  (name cr-names)
+  (print-name h-cr)
+  (prefix "")
+  (values (psw 0)   (cbr 1)   (spi 2)   (spu 3)
+         (bpc 6)   (bbpsw 8) (bbpc 14)
+         (cr0 0)   (cr1 1)   (cr2 2)   (cr3 3)
+         (cr4 4)   (cr5 5)   (cr6 6)   (cr7 7)
+         (cr8 8)   (cr9 9)   (cr10 10) (cr11 11)
+         (cr12 12) (cr13 13) (cr14 14) (cr15 15))
+)
+
+(define-hardware
+  (name h-cr)
+  (comment "control registers")
+  (type register UWI (16))
+  (indices extern-keyword cr-names)
+  (get (index) (c-call UWI "@cpu@_h_cr_get_handler" index))
+  (set (index newval) (c-call VOID "@cpu@_h_cr_set_handler" index newval))
+)
+
+; The actual accumulator is only 56 bits.
+; The top 8 bits are sign extended from bit 8 (when counting msb = bit 0).
+; To simplify the accumulator instructions, no attempt is made to keep the
+; top 8 bits properly sign extended (currently there's no point since they
+; all ignore them).  When the value is read it is properly sign extended
+; [in the `get' handler].
+(define-hardware
+  (name h-accum)
+  (comment "accumulator")
+  (type register DI)
+  (get () (c-call DI "@cpu@_h_accum_get_handler"))
+  (set (newval) (c-call VOID "@cpu@_h_accum_set_handler" newval))
+)
+
+; FIXME: Revisit after sanitization can be removed.  Remove h-accum.
+(define-hardware
+  (name h-accums)
+  (comment "accumulators")
+  (attrs (MACH m32rx))
+  (type register DI (2))
+  (indices keyword "" ((a0 0) (a1 1)))
+  ; get/set so a0 accesses are redirected to h-accum.
+  ; They're also so reads can properly sign extend the value.
+  ; FIXME: Needn't be a function call.
+  (get (index) (c-call DI "@cpu@_h_accums_get_handler" index))
+  (set (index newval) (c-call VOID "@cpu@_h_accums_set_handler" index newval))
+)
+
+; For condbit operand.  FIXME: Need to allow spec of get/set of operands.
+; Having this separate from h-psw keeps the parts that use it simpler
+; [since they greatly outnumber those that use h-psw].
+(dsh h-cond "condition bit" () (register BI))
+
+; The actual values of psw,bpsw,bbpsw are recorded here to allow access
+; to them as a unit.
+(define-hardware
+  (name h-psw)
+  (comment "psw part of psw")
+  (type register UQI)
+  ; get/set to handle cond bit.
+  ; FIXME: missing: use's and clobber's
+  ; FIXME: remove c-call?
+  (get () (c-call UQI "@cpu@_h_psw_get_handler"))
+  (set (newval) (c-call VOID "@cpu@_h_psw_set_handler" newval))
+)
+(dsh h-bpsw  "backup psw"      () (register UQI))
+(dsh h-bbpsw "backup bpsw"     () (register UQI))
+
+; FIXME: Later make add get/set specs and support SMP.
+(dsh h-lock  "lock"  () (register BI))
+\f
+; Instruction Operands.
+; These entries provide a layer between the assembler and the raw hardware
+; description, and are used to refer to hardware elements in the semantic
+; code.  Usually there's a bit of over-specification, but in more complicated
+; instruction sets there isn't.
+
+; M32R specific operand attributes:
+
+(define-attr
+  (for operand)
+  (type boolean)
+  (name HASH-PREFIX)
+  (comment "immediates have an optional '#' prefix")
+)
+
+; ??? Convention says this should be o-sr, but then the insn definitions
+; should refer to o-sr which is clumsy.  The "o-" could be implicit, but
+; then it should be implicit for all the symbols here, but then there would
+; be confusion between (f-)simm8 and (h-)simm8.
+; So for now the rule is exactly as it appears here.
+
+(dnop sr     "source register"              () h-gr   f-r2)
+(dnop dr     "destination register"         () h-gr   f-r1)
+;; The assembler relies upon the fact that dr and src1 are the same field.
+;; FIXME: Revisit.
+(dnop src1   "source register 1"            () h-gr   f-r1)
+(dnop src2   "source register 2"            () h-gr   f-r2)
+(dnop scr    "source control register"      () h-cr   f-r2)
+(dnop dcr    "destination control register" () h-cr   f-r1)
+
+(dnop simm8  "8 bit signed immediate"       (HASH-PREFIX) h-sint f-simm8)
+(dnop simm16 "16 bit signed immediate"      (HASH-PREFIX) h-sint f-simm16)
+(dnop uimm4  "4 bit trap number"            (HASH-PREFIX) h-uint f-uimm4)
+(dnop uimm5  "5 bit shift count"            (HASH-PREFIX) h-uint f-uimm5)
+(dnop uimm16 "16 bit unsigned immediate"    (HASH-PREFIX) h-uint f-uimm16)
+
+(dnop imm1   "1 bit immediate"              ((MACH m32rx) HASH-PREFIX) h-uint f-imm1)
+(dnop accd   "accumulator destination register" ((MACH m32rx))        h-accums f-accd)
+(dnop accs   "accumulator source register"  ((MACH m32rx))            h-accums f-accs)
+(dnop acc    "accumulator reg (d)"          ((MACH m32rx))            h-accums f-acc)
+
+; slo16,ulo16 are used in both with-hash-prefix/no-hash-prefix cases.
+; e.g. add3 r3,r3,#1 and ld r3,@(4,r4).  We could use HASH-PREFIX.
+; Instead we create a fake operand `hash'.  The m32r is an illustration port,
+; so we often try out various ways of doing things.
+
+(define-operand (name hash) (comment "# prefix") (attrs)
+  (type h-sint) ; doesn't really matter
+  (index f-nil)
+  (handlers (parse "hash") (print "hash"))
+)
+
+; For high(foo),shigh(foo).
+(define-operand
+  (name hi16)
+  (comment "high 16 bit immediate, sign optional")
+  (attrs)
+  (type h-hi16)
+  (index f-hi16)
+  (handlers (parse "hi16"))
+)
+
+; For low(foo),sda(foo).
+(define-operand
+  (name slo16)
+  (comment "16 bit signed immediate, for low()")
+  (attrs)
+  (type h-slo16)
+  (index f-simm16)
+  (handlers (parse "slo16"))
+)
+
+; For low(foo).
+(define-operand
+  (name ulo16)
+  (comment "16 bit unsigned immediate, for low()")
+  (attrs)
+  (type h-ulo16)
+  (index f-uimm16)
+  (handlers (parse "ulo16"))
+)
+
+(dnop uimm24 "24 bit address" (HASH-PREFIX) h-addr f-uimm24)
+
+(define-operand
+  (name disp8)
+  (comment "8 bit displacement")
+  (attrs RELAX)
+  (type h-iaddr)
+  (index f-disp8)
+  ; ??? Early experiments had insert/extract fields here.
+  ; Moving these to f-disp8 made things cleaner, but may wish to re-introduce
+  ; fields here to handle more complicated cases.
+)
+
+(dnop disp16 "16 bit displacement" ()      h-iaddr f-disp16)
+(dnop disp24 "24 bit displacement" (RELAX) h-iaddr f-disp24)
+
+; These hardware elements are refered to frequently.
+
+(dnop condbit "condition bit" (SEM-ONLY) h-cond f-nil)
+(dnop accum "accumulator" (SEM-ONLY) h-accum f-nil)
+\f
+; Instruction definitions.
+;
+; Notes while wip:
+; - dni is a cover macro to the real "this is an instruction" keyword.
+;   The syntax of the real one is yet to be determined.
+;   At the lowest level (i.e. the "real" one) it will probably take a variable
+;   list of arguments where each argument [perhaps after the standard three of
+;   name, comment, attrs] is "(keyword arg-to-keyword)".  This syntax is simple
+;   and yet completely upward extensible.  And given the macro facility, one
+;   needn't code at that low a level so even though it'll be more verbose than
+;   necessary it won't matter.  This same reasoning can be applied to most
+;   types of entries in this file.
+
+; M32R specific instruction attributes:
+
+; FILL-SLOT: Need next insn to begin on 32 bit boundary.
+; (A "slot" as used here is a 32 bit quantity that can either be filled with
+; one 32 bit insn or two 16 bit insns which go in the "left bin" and "right
+; bin" where the left bin is the one with a lower address).
+
+(define-attr
+  (for insn)
+  (type boolean)
+  (name FILL-SLOT)
+  (comment "fill right bin with `nop' if insn is in left bin")
+)
+
+(define-attr
+  (for insn)
+  (type boolean)
+  (name SPECIAL)
+  (comment "non-public m32rx insn")
+)
+
+(define-pmacro (bin-op mnemonic op2-op sem-op imm-prefix imm)
+  (begin
+     (dni mnemonic
+         (.str mnemonic " reg/reg")
+         ((PIPE OS))
+         (.str mnemonic " $dr,$sr")
+         (+ OP1_0 op2-op dr sr)
+         (set dr (sem-op dr sr))
+         ()
+     )
+     (dni (.sym mnemonic "3")
+         (.str mnemonic " reg/" imm)
+         ()
+         (.str mnemonic "3 $dr,$sr," imm-prefix "$" imm)
+         (+ OP1_8 op2-op dr sr imm)
+         (set dr (sem-op sr imm))
+         ()
+     )
+   )
+)
+(bin-op add OP2_10 add "$hash" slo16)
+; sub isn't present because sub3 doesn't exist.
+(bin-op and OP2_12 and "" uimm16)
+(bin-op or OP2_14 or "$hash" ulo16)
+(bin-op xor OP2_13 xor "" uimm16)
+
+(dni addi "addi"
+     ((PIPE OS))
+     ; #.: experiment
+     #.(string-append "addi " "$dr,$simm8")
+     (+ OP1_4 dr simm8)
+     (set dr (add dr simm8))
+     ((m32r/d (unit u-exec))
+      (m32rx (unit u-exec)))
+)
+
+(dni addv "addv"
+     ((PIPE OS))
+     "addv $dr,$sr"
+     (+ OP1_0 OP2_8 dr sr)
+     (parallel ()
+              (set dr (add dr sr))
+              (set condbit (add-oflag dr sr (const 0))))
+     ()
+)
+
+(dni addv3 "addv3"
+     ()
+     "addv3 $dr,$sr,$simm16"
+     (+ OP1_8 OP2_8 dr sr simm16)
+     (parallel ()
+              (set dr (add sr simm16))
+              (set condbit (add-oflag sr simm16 (const 0))))
+     ()
+)
+
+(dni addx "addx"
+     ((PIPE OS))
+     "addx $dr,$sr"
+     (+ OP1_0 OP2_9 dr sr)
+     (parallel ()
+              (set dr (addc dr sr condbit))
+              (set condbit (add-cflag dr sr condbit)))
+     ()
+)
+
+(dni bc8 "bc with 8 bit displacement"
+     (COND-CTI (PIPE O))
+     "bc.s $disp8"
+     (+ OP1_7 (f-r1 12) disp8)
+     (if condbit (set pc disp8))
+     ((m32r/d (unit u-cti))
+      (m32rx (unit u-cti)))
+)
+
+(dnmi bc8r "relaxable bc8"
+     (COND-CTI RELAXABLE (PIPE O))
+     "bc $disp8"
+     (emit bc8 disp8)
+)
+
+(dni bc24 "bc with 24 bit displacement"
+     (COND-CTI)
+     "bc.l $disp24"
+     (+ OP1_15 (f-r1 12) disp24)
+     (if condbit (set pc disp24))
+     ((m32r/d (unit u-cti))
+      (m32rx (unit u-cti)))
+)
+
+(dnmi bc24r "relaxable bc24"
+     (COND-CTI RELAX)
+     "bc $disp24"
+     (emit bc24 disp24)
+)
+
+(dni beq "beq"
+     (COND-CTI)
+     "beq $src1,$src2,$disp16"
+     (+ OP1_11 OP2_0 src1 src2 disp16)
+     (if (eq src1 src2) (set pc disp16))
+     ((m32r/d (unit u-cti) (unit u-cmp (cycles 0)))
+      (m32rx (unit u-cti) (unit u-cmp (cycles 0))))
+)
+
+(define-pmacro (cbranch sym comment op2-op comp-op)
+  (dni sym comment (COND-CTI)
+       (.str sym " $src2,$disp16")
+       (+ OP1_11 op2-op (f-r1 0) src2 disp16)
+       (if (comp-op src2 (const WI 0)) (set pc disp16))
+       ((m32r/d (unit u-cti) (unit u-cmp (cycles 0)))
+        (m32rx (unit u-cti) (unit u-cmp (cycles 0))))
+       )
+)
+(cbranch beqz "beqz" OP2_8 eq)
+(cbranch bgez "bgez" OP2_11 ge)
+(cbranch bgtz "bgtz" OP2_13 gt)
+(cbranch blez "blez" OP2_12 le)
+(cbranch bltz "bltz" OP2_10 lt)
+(cbranch bnez "bnez" OP2_9 ne)
+
+(dni bl8 "bl with 8 bit displacement"
+     (UNCOND-CTI FILL-SLOT (PIPE O))
+     "bl.s $disp8"
+     (+ OP1_7 (f-r1 14) disp8)
+     (sequence ()
+              (set (reg h-gr 14)
+                   (add (and pc (const -4)) (const 4)))
+              (set pc disp8))
+     ((m32r/d (unit u-cti))
+      (m32rx (unit u-cti)))
+)
+
+(dnmi bl8r "relaxable bl8"
+     (UNCOND-CTI FILL-SLOT RELAXABLE (PIPE O))
+     "bl $disp8"
+     (emit bl8 disp8)
+)
+
+(dni bl24 "bl with 24 bit displacement"
+     (UNCOND-CTI)
+     "bl.l $disp24"
+     (+ OP1_15 (f-r1 14) disp24)
+     (sequence ()
+              (set (reg h-gr 14) (add pc (const 4)))
+              (set pc disp24))
+     ((m32r/d (unit u-cti))
+      (m32rx (unit u-cti)))
+)
+
+(dnmi bl24r "relaxable bl24"
+     (UNCOND-CTI RELAX)
+     "bl $disp24"
+     (emit bl24 disp24)
+)
+
+(dni bcl8 "bcl with 8 bit displacement"
+     (COND-CTI FILL-SLOT (MACH m32rx) (PIPE O))
+     "bcl.s $disp8"
+     (+ OP1_7 (f-r1 8) disp8)
+     (if condbit
+         (sequence ()
+                  (set (reg h-gr 14)
+                       (add (and pc (const -4))
+                            (const 4)))
+                  (set pc disp8)))
+     ((m32rx (unit u-cti)))
+)
+
+(dnmi bcl8r "relaxable bcl8"
+     (COND-CTI FILL-SLOT (MACH m32rx) (PIPE O) RELAXABLE)
+     "bcl $disp8"
+     (emit bcl8 disp8)
+)
+
+(dni bcl24 "bcl with 24 bit displacement"
+     (COND-CTI (MACH m32rx))
+     "bcl.l $disp24"
+     (+ OP1_15 (f-r1 8) disp24)
+     (if condbit
+         (sequence ()
+                  (set (reg h-gr 14) (add pc (const 4)))
+                  (set pc disp24)))
+     ((m32rx (unit u-cti)))
+)
+
+(dnmi bcl24r "relaxable bcl24"
+     (COND-CTI (MACH m32rx) RELAX)
+     "bcl $disp24"
+     (emit bcl24 disp24)
+)
+
+(dni bnc8 "bnc with 8 bit displacement"
+     (COND-CTI (PIPE O))
+     "bnc.s $disp8"
+     (+ OP1_7 (f-r1 13) disp8)
+     (if (not condbit) (set pc disp8))
+     ((m32r/d (unit u-cti))
+      (m32rx (unit u-cti)))
+)
+
+(dnmi bnc8r "relaxable bnc8"
+     (COND-CTI RELAXABLE (PIPE O))
+     "bnc $disp8"
+     (emit bnc8 disp8)
+)
+
+(dni bnc24 "bnc with 24 bit displacement"
+     (COND-CTI)
+     "bnc.l $disp24"
+     (+ OP1_15 (f-r1 13) disp24)
+     (if (not condbit) (set pc disp24))
+     ((m32r/d (unit u-cti))
+      (m32rx (unit u-cti)))
+)
+
+(dnmi bnc24r "relaxable bnc24"
+     (COND-CTI RELAX)
+     "bnc $disp24"
+     (emit bnc24 disp24)
+)
+
+(dni bne "bne"
+     (COND-CTI)
+     "bne $src1,$src2,$disp16"
+     (+ OP1_11 OP2_1 src1 src2 disp16)
+     (if (ne src1 src2) (set pc disp16))
+     ((m32r/d (unit u-cti) (unit u-cmp (cycles 0)))
+      (m32rx (unit u-cti) (unit u-cmp (cycles 0))))
+)
+
+(dni bra8 "bra with 8 bit displacement"
+     (UNCOND-CTI FILL-SLOT (PIPE O))
+     "bra.s $disp8"
+     (+ OP1_7 (f-r1 15) disp8)
+     (set pc disp8)
+     ((m32r/d (unit u-cti))
+      (m32rx (unit u-cti)))
+)
+
+(dnmi bra8r "relaxable bra8"
+     (UNCOND-CTI FILL-SLOT RELAXABLE (PIPE O))
+     "bra $disp8"
+     (emit bra8 disp8)
+)
+
+(dni bra24 "bra with 24 displacement"
+     (UNCOND-CTI)
+     "bra.l $disp24"
+     (+ OP1_15 (f-r1 15) disp24)
+     (set pc disp24)
+     ((m32r/d (unit u-cti))
+      (m32rx (unit u-cti)))
+)
+
+(dnmi bra24r "relaxable bra24"
+     (UNCOND-CTI RELAX)
+     "bra $disp24"
+     (emit bra24 disp24)
+)
+
+(dni bncl8 "bncl with 8 bit displacement"
+     (COND-CTI FILL-SLOT (MACH m32rx) (PIPE O))
+     "bncl.s $disp8"
+     (+ OP1_7 (f-r1 9) disp8)
+     (if (not condbit) 
+         (sequence ()
+                  (set (reg h-gr 14)
+                       (add (and pc (const -4))
+                            (const 4)))
+                  (set pc disp8)))
+     ((m32rx (unit u-cti)))
+)
+
+(dnmi bncl8r "relaxable bncl8"
+     (COND-CTI FILL-SLOT (MACH m32rx) (PIPE O) RELAXABLE)
+     "bncl $disp8"
+     (emit bncl8 disp8)
+)
+
+(dni bncl24 "bncl with 24 bit displacement"
+     (COND-CTI (MACH m32rx))
+     "bncl.l $disp24"
+     (+ OP1_15 (f-r1 9) disp24)
+     (if (not condbit)
+         (sequence ()
+                  (set (reg h-gr 14) (add pc (const 4)))
+                  (set pc disp24)))
+     ((m32rx (unit u-cti)))
+)
+
+(dnmi bncl24r "relaxable bncl24"
+     (COND-CTI (MACH m32rx) RELAX)
+     "bncl $disp24"
+     (emit bncl24 disp24)
+)
+
+(dni cmp "cmp"
+     ((PIPE OS))
+     "cmp $src1,$src2"
+     (+ OP1_0 OP2_4 src1 src2)
+     (set condbit (lt src1 src2))
+     ((m32r/d (unit u-cmp))
+      (m32rx (unit u-cmp)))
+)
+
+(dni cmpi "cmpi"
+     ()
+     "cmpi $src2,$simm16"
+     (+ OP1_8 (f-r1 0) OP2_4 src2 simm16)
+     (set condbit (lt src2 simm16))
+     ((m32r/d (unit u-cmp))
+      (m32rx (unit u-cmp)))
+)
+
+(dni cmpu "cmpu"
+     ((PIPE OS))
+     "cmpu $src1,$src2"
+     (+ OP1_0 OP2_5 src1 src2)
+     (set condbit (ltu src1 src2))
+     ((m32r/d (unit u-cmp))
+      (m32rx (unit u-cmp)))
+)
+
+(dni cmpui "cmpui"
+     ()
+     "cmpui $src2,$simm16"
+     (+ OP1_8 (f-r1 0) OP2_5 src2 simm16)
+     (set condbit (ltu src2 simm16))
+     ((m32r/d (unit u-cmp))
+      (m32rx (unit u-cmp)))
+)
+
+(dni cmpeq "cmpeq"
+     ((MACH m32rx) (PIPE OS))
+     "cmpeq $src1,$src2"
+     (+ OP1_0 OP2_6 src1 src2)
+     (set condbit (eq src1 src2))
+     ((m32rx (unit u-cmp)))
+)
+
+(dni cmpz "cmpz"
+     ((MACH m32rx) (PIPE OS))
+     "cmpz $src2"
+     (+ OP1_0 OP2_7 (f-r1 0) src2)
+     (set condbit (eq src2 (const 0)))
+     ((m32rx (unit u-cmp)))
+)
+
+(dni div "div"
+     ()
+     "div $dr,$sr"
+     (+ OP1_9 OP2_0 dr sr (f-simm16 0))
+     (if (ne sr (const 0)) (set dr (div dr sr)))
+     ((m32r/d (unit u-exec (cycles 37)))
+      (m32rx (unit u-exec (cycles 37))))
+)
+
+(dni divu "divu"
+     ()
+     "divu $dr,$sr"
+     (+ OP1_9 OP2_1 dr sr (f-simm16 0))
+     (if (ne sr (const 0)) (set dr (udiv dr sr)))
+     ((m32r/d (unit u-exec (cycles 37)))
+      (m32rx (unit u-exec (cycles 37))))
+)
+
+(dni rem "rem"
+     ()
+     "rem $dr,$sr"
+     (+ OP1_9 OP2_2 dr sr (f-simm16 0))
+     ; FIXME: Check rounding direction.
+     (if (ne sr (const 0)) (set dr (mod dr sr)))
+     ((m32r/d (unit u-exec (cycles 37)))
+      (m32rx (unit u-exec (cycles 37))))
+)
+
+(dni remu "remu"
+     ()
+     "remu $dr,$sr"
+     (+ OP1_9 OP2_3 dr sr (f-simm16 0))
+     ; FIXME: Check rounding direction.
+     (if (ne sr (const 0)) (set dr (umod dr sr)))
+     ((m32r/d (unit u-exec (cycles 37)))
+      (m32rx (unit u-exec (cycles 37))))
+)
+
+(dni divh "divh"
+     ((MACH m32rx))
+     "divh $dr,$sr"
+     (+ OP1_9 OP2_0 dr sr (f-simm16 #x10))
+     (if (ne sr (const 0)) (set dr (div (ext WI (trunc HI dr)) sr)))
+     ((m32rx (unit u-exec (cycles 21))))
+)
+
+(dni jc "jc"
+     (COND-CTI (MACH m32rx) (PIPE O) SPECIAL)
+     "jc $sr"
+     (+ OP1_1 (f-r1 12) OP2_12 sr)
+     (if condbit (set pc (and sr (const -4))))
+     ((m32rx (unit u-cti)))
+)
+
+(dni jnc "jnc"
+     (COND-CTI (MACH m32rx) (PIPE O) SPECIAL)
+     "jnc $sr"
+     (+ OP1_1 (f-r1 13) OP2_12 sr)
+     (if (not condbit) (set pc (and sr (const -4))))
+     ((m32rx (unit u-cti)))
+)
+
+(dni jl "jl"
+     (UNCOND-CTI FILL-SLOT (PIPE O))
+     "jl $sr"
+     (+ OP1_1 (f-r1 14) OP2_12 sr)
+     (parallel ()
+              (set (reg h-gr 14)
+                   (add (and pc (const -4)) (const 4)))
+              (set pc (and sr (const -4))))
+     ((m32r/d (unit u-cti))
+      (m32rx (unit u-cti)))
+)
+
+(dni jmp "jmp"
+     (UNCOND-CTI (PIPE O))
+     "jmp $sr"
+     (+ OP1_1 (f-r1 15) OP2_12 sr)
+     (set pc (and sr (const -4)))
+     ; The above works now so this kludge has been commented out.
+     ; It's kept around because the f-r1 reference in the semantic part
+     ; should work.
+     ; FIXME: kludge, instruction decoding not finished.
+     ; But this should work, so that's another FIXME.
+     ;(sequence VOID (if VOID (eq SI f-r1 (const SI 14))
+     ; FIXME: abuf->insn should be a macro of some sort.
+     ;(sequence VOID
+     ;        (if VOID (eq SI (c-code SI "((abuf->insn >> 8) & 15)")
+     ;                   (const SI 14))
+     ;            (set WI (reg WI h-gr 14)
+     ;                 (add WI (and WI pc (const WI -4)) (const WI 4))))
+     ;        (set WI pc sr))
+     ((m32r/d (unit u-cti))
+      (m32rx (unit u-cti)))
+)
+
+(define-pmacro (no-ext-expr mode expr) expr)
+(define-pmacro (ext-expr mode expr) (ext mode expr))
+(define-pmacro (zext-expr mode expr) (zext mode expr))
+
+(define-pmacro (load-op suffix op2-op mode ext-op)
+  (begin
+    (dni (.sym ld suffix) (.str "ld" suffix)
+        ((PIPE O))
+        (.str "ld" suffix " $dr,@$sr")
+        (+ OP1_2 op2-op dr sr)
+        (set dr (ext-op WI (mem mode sr)))
+        ((m32r/d (unit u-load))
+         (m32rx (unit u-load)))
+        )
+    (dnmi (.sym ld suffix "-2") (.str "ld" suffix "-2")
+         (NO-DIS (PIPE O))
+         (.str "ld" suffix " $dr,@($sr)")
+         (emit (.sym ld suffix) dr sr))
+    (dni (.sym ld suffix -d) (.str "ld" suffix "-d")
+        ()
+        (.str "ld" suffix " $dr,@($slo16,$sr)")
+        (+ OP1_10 op2-op dr sr slo16)
+        (set dr (ext-op WI (mem mode (add sr slo16))))
+        ((m32r/d (unit u-load (cycles 2)))
+         (m32rx (unit u-load (cycles 2))))
+        )
+    (dnmi (.sym ld suffix -d2) (.str "ld" suffix "-d2")
+         (NO-DIS)
+         (.str "ld" suffix " $dr,@($sr,$slo16)")
+         (emit (.sym ld suffix -d) dr sr slo16))
+    )
+)
+(load-op "" OP2_12 WI no-ext-expr)
+(load-op b OP2_8 QI ext-expr)
+(load-op h OP2_10 HI ext-expr)
+(load-op ub OP2_9 QI zext-expr)
+(load-op uh OP2_11 HI zext-expr)
+
+(dni ld-plus "ld+"
+     ((PIPE O))
+     "ld $dr,@$sr+"
+     (+ OP1_2 dr OP2_14 sr)
+     (parallel ()
+              ; wip: memory addresses in profiling support
+              ;(set dr (name ld-mem (mem WI sr)))
+              (set dr (mem WI sr))
+              (set sr (add sr (const 4))))
+     ; Note: `pred' is the constraint.  Also useful here is (ref name)
+     ; and returns true if operand <name> was referenced
+     ; (where "referenced" means _read_ if input operand and _written_ if
+     ; output operand).
+     ; args to unit are "unit-name (name1 value1) ..."
+     ; - cycles(done),issue,pred are also specified this way
+     ; - if unspecified, default is used
+     ; - for ins/outs, extra arg is passed that says what was specified
+     ;   - this is AND'd with `written' for outs
+     ((m32r/d (unit u-load (pred (const 1)))
+             (unit u-exec (in sr #f) (in dr sr) (out dr sr) (cycles 0) (pred (const 1))))
+      (m32rx (unit u-load)
+            (unit u-exec (in sr #f) (in dr sr) (out dr sr) (cycles 0) (pred (const 1))))
+      )
+)
+
+(dnmi pop "pop"
+      ()
+      "pop $dr"
+      (emit ld-plus dr (sr 15)) ; "ld %0,@sp+"
+)
+
+(dni ld24 "ld24"
+     ()
+     "ld24 $dr,$uimm24"
+     (+ OP1_14 dr uimm24)
+     (set dr uimm24)
+     ()
+)
+
+; ldi8 appears before ldi16 so we try the shorter version first
+
+(dni ldi8 "ldi8"
+     ((PIPE OS))
+     "ldi8 $dr,$simm8"
+     (+ OP1_6 dr simm8)
+     (set dr simm8)
+     ()
+)
+
+(dnmi ldi8a "ldi8 alias"
+     ((PIPE OS))
+     "ldi $dr,$simm8"
+     (emit ldi8 dr simm8)
+)
+
+(dni ldi16 "ldi16"
+     ()
+     "ldi16 $dr,$hash$slo16"
+     (+ OP1_9 OP2_15 (f-r2 0) dr slo16)
+     (set dr slo16)
+     ()
+)
+
+(dnmi ldi16a "ldi16 alias"
+     ()
+     "ldi $dr,$hash$slo16"
+     (emit ldi16 dr slo16)
+)
+
+(dni lock "lock"
+     ((PIPE O))
+     "lock $dr,@$sr"
+     (+ OP1_2 OP2_13 dr sr)
+     (sequence ()
+              (set (reg h-lock) (const BI 1))
+              (set dr (mem WI sr)))
+     ((m32r/d (unit u-load))
+      (m32rx (unit u-load)))
+)
+
+(dni machi "machi"
+     (
+      ; (MACH m32r) is a temporary hack.  This insn collides with machi-a
+      ; in the simulator so disable it for m32rx.
+      (MACH m32r) (PIPE S)
+     )
+     "machi $src1,$src2"
+     (+ OP1_3 OP2_4 src1 src2)
+     ; FIXME: TRACE_RESULT will print the wrong thing since we
+     ; alter one of the arguments.
+     (set accum
+         (sra DI
+              (sll DI
+                   (add DI
+                        accum
+                        (mul DI
+                             (ext DI (and WI src1 (const #xffff0000)))
+                             (ext DI (trunc HI (sra WI src2 (const 16))))))
+                   (const 8))
+              (const 8)))
+     ((m32r/d (unit u-mac)))
+)
+
+(dni machi-a "machi-a"
+     ((MACH m32rx) (PIPE S))
+     "machi $src1,$src2,$acc"
+     (+ OP1_3 src1 acc (f-op23 4) src2)
+     (set acc
+         (sra DI
+              (sll DI
+                   (add DI
+                        acc
+                        (mul DI
+                             (ext DI (and WI src1 (const #xffff0000)))
+                             (ext DI (trunc HI (sra WI src2 (const 16))))))
+                   (const 8))
+              (const 8)))
+     ((m32rx (unit u-mac)))
+)
+
+(dni maclo "maclo"
+     ((MACH m32r) (PIPE S))
+     "maclo $src1,$src2"
+     (+ OP1_3 OP2_5 src1 src2)
+     (set accum
+         (sra DI
+              (sll DI
+                   (add DI
+                        accum
+                        (mul DI
+                             (ext DI (sll WI src1 (const 16)))
+                             (ext DI (trunc HI src2))))
+                   (const 8))
+              (const 8)))
+     ((m32r/d (unit u-mac)))
+)
+
+(dni maclo-a "maclo-a"
+     ((MACH m32rx) (PIPE S))
+     "maclo $src1,$src2,$acc"
+     (+ OP1_3 src1 acc (f-op23 5) src2)
+     (set acc
+         (sra DI
+              (sll DI
+                   (add DI
+                        acc
+                        (mul DI
+                             (ext DI (sll WI src1 (const 16)))
+                             (ext DI (trunc HI src2))))
+                   (const 8))
+              (const 8)))
+     ((m32rx (unit u-mac)))
+)
+
+(dni macwhi "macwhi"
+     ((MACH m32r) (PIPE S))
+     "macwhi $src1,$src2"
+     (+ OP1_3 OP2_6 src1 src2)
+     (set accum
+         (sra DI
+              (sll DI
+                   (add DI
+                        accum
+                        (mul DI
+                             (ext DI src1)
+                             (ext DI (trunc HI (sra WI src2 (const 16))))))
+                   (const 8))
+              (const 8)))
+     ((m32r/d (unit u-mac)))
+)
+
+(dni macwhi-a "macwhi-a"
+     ((MACH m32rx) (PIPE S) SPECIAL)
+     "macwhi $src1,$src2,$acc"
+     (+ OP1_3 src1 acc (f-op23 6) src2)
+     ; Note that this doesn't do the sign extension, which is correct.
+     (set acc
+         (add acc
+              (mul (ext DI src1)
+                   (ext DI (trunc HI (sra src2 (const 16)))))))
+     ((m32rx (unit u-mac)))
+)
+
+(dni macwlo "macwlo"
+     ((MACH m32r) (PIPE S))
+     "macwlo $src1,$src2"
+     (+ OP1_3 OP2_7 src1 src2)
+     (set accum
+         (sra DI
+              (sll DI
+                   (add DI
+                        accum
+                        (mul DI
+                             (ext DI src1)
+                             (ext DI (trunc HI src2))))
+                   (const 8))
+              (const 8)))
+     ((m32r/d (unit u-mac)))
+)
+
+(dni macwlo-a "macwlo-a"
+     ((MACH m32rx) (PIPE S) SPECIAL)
+     "macwlo $src1,$src2,$acc"
+     (+ OP1_3 src1 acc (f-op23 7) src2)
+     ; Note that this doesn't do the sign extension, which is correct.
+     (set acc
+         (add acc
+              (mul (ext DI src1)
+                   (ext DI (trunc HI src2)))))
+     ((m32rx (unit u-mac)))
+)
+
+(dni mul "mul"
+     ((PIPE S))
+     "mul $dr,$sr"
+     (+ OP1_1 OP2_6 dr sr)
+     (set dr (mul dr sr))
+     ((m32r/d (unit u-exec (cycles 4)))
+      (m32rx (unit u-exec (cycles 4))))
+)
+
+(dni mulhi "mulhi"
+     ((MACH m32r) (PIPE S))
+     "mulhi $src1,$src2"
+     (+ OP1_3 OP2_0 src1 src2)
+     (set accum
+         (sra DI
+              (sll DI
+                   (mul DI
+                        (ext DI (and WI src1 (const #xffff0000)))
+                        (ext DI (trunc HI (sra WI src2 (const 16)))))
+                   (const 16))
+              (const 16)))
+     ((m32r/d (unit u-mac)))
+)
+
+(dni mulhi-a "mulhi-a"
+     ((MACH m32rx) (PIPE S))
+     "mulhi $src1,$src2,$acc"
+     (+ OP1_3 (f-op23 0) src1 acc src2)
+     (set acc
+         (sra DI
+              (sll DI
+                   (mul DI
+                        (ext DI (and WI src1 (const #xffff0000)))
+                        (ext DI (trunc HI (sra WI src2 (const 16)))))
+                   (const 16))
+              (const 16)))
+     ((m32rx (unit u-mac)))
+)
+
+(dni mullo "mullo"
+     ((MACH m32r) (PIPE S))
+     "mullo $src1,$src2"
+     (+ OP1_3 OP2_1 src1 src2)
+     (set accum
+         (sra DI
+              (sll DI
+                   (mul DI
+                        (ext DI (sll WI src1 (const 16)))
+                        (ext DI (trunc HI src2)))
+                   (const 16))
+              (const 16)))
+     ((m32r/d (unit u-mac)))
+)
+
+(dni mullo-a "mullo-a"
+     ((MACH m32rx) (PIPE S))
+     "mullo $src1,$src2,$acc"
+     (+ OP1_3 src1 acc (f-op23 1) src2)
+     (set acc
+         (sra DI
+              (sll DI
+                   (mul DI
+                        (ext DI (sll WI src1 (const 16)))
+                        (ext DI (trunc HI src2)))
+                   (const 16))
+              (const 16)))
+     ((m32rx (unit u-mac)))
+)
+
+(dni mulwhi "mulwhi"
+     ((MACH m32r) (PIPE S))
+     "mulwhi $src1,$src2"
+     (+ OP1_3 OP2_2 src1 src2)
+     (set accum
+         (sra DI
+              (sll DI
+                   (mul DI
+                        (ext DI src1)
+                        (ext DI (trunc HI (sra WI src2 (const 16)))))
+                   (const 8))
+              (const 8)))
+     ((m32r/d (unit u-mac)))
+)
+
+(dni mulwhi-a "mulwhi-a"
+     ((MACH m32rx) (PIPE S) SPECIAL)
+     "mulwhi $src1,$src2,$acc"
+     (+ OP1_3 src1 acc (f-op23 2) src2)
+     ; Note that this doesn't do the sign extension, which is correct.
+     (set acc
+         (mul (ext DI src1)
+              (ext DI (trunc HI (sra src2 (const 16))))))
+     ((m32rx (unit u-mac)))
+)
+
+(dni mulwlo "mulwlo"
+     ((MACH m32r) (PIPE S))
+     "mulwlo $src1,$src2"
+     (+ OP1_3 OP2_3 src1 src2)
+     (set accum
+         (sra DI
+              (sll DI
+                   (mul DI
+                        (ext DI src1)
+                        (ext DI (trunc HI src2)))
+                   (const 8))
+              (const 8)))
+     ((m32r/d (unit u-mac)))
+)
+
+(dni mulwlo-a "mulwlo-a"
+     ((MACH m32rx) (PIPE S) SPECIAL)
+     "mulwlo $src1,$src2,$acc"
+     (+ OP1_3 src1 acc (f-op23 3) src2)
+     ; Note that this doesn't do the sign extension, which is correct.
+     (set acc
+         (mul (ext DI src1)
+              (ext DI (trunc HI src2))))
+     ((m32rx (unit u-mac)))
+)
+
+(dni mv "mv"
+     ((PIPE OS))
+     "mv $dr,$sr"
+     (+ OP1_1 OP2_8 dr sr)
+     (set dr sr)
+     ()
+)
+
+(dni mvfachi "mvfachi"
+     ((MACH m32r) (PIPE S))
+     "mvfachi $dr"
+     (+ OP1_5 OP2_15 (f-r2 0) dr)
+     (set dr (trunc WI (sra DI accum (const 32))))
+     ((m32r/d (unit u-exec (cycles 2))))
+)
+
+(dni mvfachi-a "mvfachi-a"
+     ((MACH m32rx) (PIPE S))
+     "mvfachi $dr,$accs"
+     (+ OP1_5 dr OP2_15 accs (f-op3 0))
+     (set dr (trunc WI (sra DI accs (const 32))))
+     ((m32rx (unit u-exec (cycles 2))))
+)
+
+(dni mvfaclo "mvfaclo"
+     ((MACH m32r) (PIPE S))
+     "mvfaclo $dr"
+     (+ OP1_5 OP2_15 (f-r2 1) dr)
+     (set dr (trunc WI accum))
+     ((m32r/d (unit u-exec (cycles 2))))
+)
+
+(dni mvfaclo-a "mvfaclo-a"
+     ((MACH m32rx) (PIPE S))
+     "mvfaclo $dr,$accs"
+     (+ OP1_5 dr OP2_15 accs (f-op3 1))
+     (set dr (trunc WI accs))
+     ((m32rx (unit u-exec (cycles 2))))
+)
+
+(dni mvfacmi "mvfacmi"
+     ((MACH m32r) (PIPE S))
+     "mvfacmi $dr"
+     (+ OP1_5 OP2_15 (f-r2 2) dr)
+     (set dr (trunc WI (sra DI accum (const 16))))
+     ((m32r/d (unit u-exec (cycles 2))))
+)
+
+(dni mvfacmi-a "mvfacmi-a"
+     ((MACH m32rx) (PIPE S))
+     "mvfacmi $dr,$accs"
+     (+ OP1_5 dr OP2_15 accs (f-op3 2))
+     (set dr (trunc WI (sra DI accs (const 16))))
+     ((m32rx (unit u-exec (cycles 2))))
+)
+
+(dni mvfc "mvfc"
+     ((PIPE O))
+     "mvfc $dr,$scr"
+     (+ OP1_1 OP2_9 dr scr)
+     (set dr scr)
+     ()
+)
+
+(dni mvtachi "mvtachi"
+     ((MACH m32r) (PIPE S))
+     "mvtachi $src1"
+     (+ OP1_5 OP2_7 (f-r2 0) src1)
+     (set accum
+         (or DI
+             (and DI accum (const DI #xffffffff))
+             (sll DI (ext DI src1) (const 32))))
+     ((m32r/d (unit u-exec (in sr src1))))
+)
+
+(dni mvtachi-a "mvtachi-a"
+     ((MACH m32rx) (PIPE S))
+     "mvtachi $src1,$accs"
+     (+ OP1_5 src1 OP2_7 accs (f-op3 0))
+     (set accs
+         (or DI
+             (and DI accs (const DI #xffffffff))
+             (sll DI (ext DI src1) (const 32))))
+     ((m32rx (unit u-exec (in sr src1))))
+)
+
+(dni mvtaclo "mvtaclo"
+     ((MACH m32r) (PIPE S))
+     "mvtaclo $src1"
+     (+ OP1_5 OP2_7 (f-r2 1) src1)
+     (set accum
+         (or DI
+             (and DI accum (const DI #xffffffff00000000))
+             (zext DI src1)))
+     ((m32r/d (unit u-exec (in sr src1))))
+)
+
+(dni mvtaclo-a "mvtaclo-a"
+     ((MACH m32rx) (PIPE S))
+     "mvtaclo $src1,$accs"
+     (+ OP1_5 src1 OP2_7 accs (f-op3 1))
+     (set accs
+         (or DI
+             (and DI accs (const DI #xffffffff00000000))
+             (zext DI src1)))
+     ((m32rx (unit u-exec (in sr src1))))
+)
+
+(dni mvtc "mvtc"
+     ((PIPE O))
+     "mvtc $sr,$dcr"
+     (+ OP1_1 OP2_10 dcr sr)
+     (set dcr sr)
+     ()
+)
+
+(dni neg "neg"
+     ((PIPE OS))
+     "neg $dr,$sr"
+     (+ OP1_0 OP2_3 dr sr)
+     (set dr (neg sr))
+     ()
+)
+
+(dni nop "nop"
+     ((PIPE OS))
+     "nop"
+     (+ OP1_7 OP2_0 (f-r1 0) (f-r2 0))
+     (c-code VOID "PROFILE_COUNT_FILLNOPS (current_cpu, abuf->addr);\n")
+     ; FIXME: quick hack: parallel nops don't contribute to cycle count.
+     ; Other kinds of nops do however (which we currently ignore).
+     ((m32r/d (unit u-exec (cycles 0)))
+      (m32rx (unit u-exec (cycles 0))))
+)
+
+(dni not "not"
+     ((PIPE OS))
+     "not $dr,$sr"
+     (+ OP1_0 OP2_11 dr sr)
+     (set dr (inv sr))
+     ()
+)
+
+(dni rac "rac"
+     ((MACH m32r) (PIPE S))
+     "rac"
+     (+ OP1_5 OP2_9 (f-r1 0) (f-r2 0))
+     (sequence ((DI tmp1))
+              (set tmp1 (sll DI accum (const 1)))
+              (set tmp1 (add DI tmp1 (const DI #x8000)))
+              (set accum
+                   (cond DI
+                         ((gt tmp1 (const DI #x00007fffffff0000))
+                          (const DI #x00007fffffff0000))
+                         ((lt tmp1 (const DI #xffff800000000000))
+                          (const DI #xffff800000000000))
+                         (else (and tmp1 (const DI #xffffffffffff0000)))))
+              )
+     ((m32r/d (unit u-mac)))
+)
+
+(dni rac-dsi "rac-dsi"
+     ((MACH m32rx) (PIPE S))
+     "rac $accd,$accs,$imm1"
+     (+ OP1_5 accd (f-bits67 0) OP2_9 accs (f-bit14 0) imm1)
+     (sequence ((DI tmp1))
+              (set tmp1 (sll accs imm1))
+              (set tmp1 (add tmp1 (const DI #x8000)))
+              (set accd
+                   (cond DI
+                         ((gt tmp1 (const DI #x00007fffffff0000))
+                          (const DI #x00007fffffff0000))
+                         ((lt tmp1 (const DI #xffff800000000000))
+                          (const DI #xffff800000000000))
+                         (else (and tmp1 (const DI #xffffffffffff0000)))))
+              )
+     ((m32rx (unit u-mac)))
+)
+
+(dnmi rac-d "rac-d"
+     ((MACH m32rx) (PIPE S))
+     "rac $accd"
+     (emit rac-dsi accd (f-accs 0) (f-imm1 0))
+)
+
+(dnmi rac-ds "rac-ds"
+     ((MACH m32rx) (PIPE S))
+     "rac $accd,$accs"
+     (emit rac-dsi accd accs (f-imm1 0))
+)
+
+
+(dni rach "rach"
+     ((MACH m32r) (PIPE S))
+     "rach"
+     (+ OP1_5 OP2_8 (f-r1 0) (f-r2 0))
+     (sequence ((DI tmp1))
+              ; Lop off top 8 bits.
+              ; The sign bit we want to use is bit 55 so the 64 bit value
+              ; isn't properly signed which we deal with in the if's below.
+              (set tmp1 (and accum (const DI #xffffffffffffff)))
+              (if (andif (ge tmp1 (const DI #x003fff80000000))
+                         (le tmp1 (const DI #x7fffffffffffff)))
+                  (set tmp1 (const DI #x003fff80000000))
+                  ; else part
+                  (if (andif (ge tmp1 (const DI #x80000000000000))
+                             (le tmp1 (const DI #xffc00000000000)))
+                      (set tmp1 (const DI #xffc00000000000))
+                      (set tmp1 (and (add accum (const DI #x40000000))
+                                     (const DI #xffffffff80000000)))))
+              (set tmp1 (sll tmp1 (const 1)))
+              ; Sign extend top 8 bits.
+              (set accum
+                   ; FIXME: 7?
+                   (sra DI (sll DI tmp1 (const 7)) (const 7)))
+              )
+     ((m32r/d (unit u-mac)))
+)
+
+(dni rach-dsi "rach-dsi"
+     ((MACH m32rx) (PIPE S))
+     "rach $accd,$accs,$imm1"
+     (+ OP1_5 accd (f-bits67 0) OP2_8 accs (f-bit14 0) imm1)
+     (sequence ((DI tmp1))
+              (set tmp1 (sll accs imm1))
+              (set tmp1 (add tmp1 (const DI #x80000000)))
+              (set accd
+                   (cond DI
+                         ((gt tmp1 (const DI #x00007fff00000000))
+                          (const DI #x00007fff00000000))
+                         ((lt tmp1 (const DI #xffff800000000000))
+                          (const DI #xffff800000000000))
+                         (else (and tmp1 (const DI #xffffffff00000000)))))
+              )
+     ((m32rx (unit u-mac)))
+)
+
+(dnmi rach-d "rach-d"
+     ((MACH m32rx) (PIPE S))
+     "rach $accd"
+     (emit rach-dsi accd (f-accs 0) (f-imm1 0))
+)
+
+(dnmi rach-ds "rach-ds"
+     ((MACH m32rx) (PIPE S))
+     "rach $accd,$accs"
+     (emit rach-dsi accd accs (f-imm1 0))
+)
+
+(dni rte "rte"
+     (UNCOND-CTI (PIPE O))
+     "rte"
+     (+ OP1_1 OP2_13 (f-r1 0) (f-r2 6))
+     (sequence ()
+              ; pc = bpc & -4
+              (set pc (and (reg h-cr 6) (const -4)))
+              ; bpc = bbpc
+              (set (reg h-cr 6) (reg h-cr 14))
+              ; psw = bpsw
+              (set (reg h-psw) (reg h-bpsw))
+              ; bpsw = bbpsw
+              (set (reg h-bpsw) (reg h-bbpsw))
+     )
+     ()
+)
+
+(dni seth "seth"
+     ()
+     "seth $dr,$hash$hi16"
+     (+ OP1_13 OP2_12 dr (f-r2 0) hi16)
+     (set dr (sll WI hi16 (const 16)))
+     ()
+)
+
+(define-pmacro (shift-op sym op2-r-op op2-3-op op2-i-op sem-op)
+  (begin
+     (dni sym sym ((PIPE O))
+         (.str sym " $dr,$sr")
+         (+ OP1_1 op2-r-op dr sr)
+         (set dr (sem-op dr (and sr (const 31))))
+         ()
+     )
+     (dni (.sym sym "3") sym ()
+         (.str sym "3 $dr,$sr,$simm16")
+         (+ OP1_9 op2-3-op dr sr simm16)
+         (set dr (sem-op sr (and WI simm16 (const 31))))
+         ()
+     )
+     (dni (.sym sym "i") sym ((PIPE O))
+         (.str sym "i $dr,$uimm5")
+         (+ OP1_5 (f-shift-op2 op2-i-op) dr uimm5)
+         (set dr (sem-op dr uimm5))
+         ()
+     )
+   )
+)
+(shift-op sll OP2_4 OP2_12 2 sll)
+(shift-op sra OP2_2 OP2_10 1 sra)
+(shift-op srl OP2_0 OP2_8 0 srl)
+
+(define-pmacro (store-op suffix op2-op mode)
+  (begin
+    (dni (.sym st suffix) (.str "st" suffix)
+        ((PIPE O))
+        (.str "st" suffix " $src1,@$src2")
+        (+ OP1_2 op2-op src1 src2)
+        (set mode (mem mode src2) src1)
+        ((m32r/d (unit u-store (cycles 1)))
+         (m32rx (unit u-store (cycles 1))))
+        )
+    (dnmi (.sym st suffix "-2") (.str "st" suffix "-2")
+         (NO-DIS (PIPE O))
+         (.str "st" suffix " $src1,@($src2)")
+         (emit (.sym st suffix) src1 src2))
+    (dni (.sym st suffix -d) (.str "st" suffix "-d")
+        ()
+        (.str "st" suffix " $src1,@($slo16,$src2)")
+        (+ OP1_10 op2-op src1 src2 slo16)
+        (set mode (mem mode (add src2 slo16)) src1)
+        ((m32r/d (unit u-store (cycles 2)))
+         (m32rx (unit u-store (cycles 2))))
+        )
+    (dnmi (.sym st suffix -d2) (.str "st" suffix "-d2")
+         (NO-DIS)
+         (.str "st" suffix " $src1,@($src2,$slo16)")
+         (emit (.sym st suffix -d) src1 src2 slo16))
+    )
+)
+(store-op "" OP2_4 WI)
+(store-op b OP2_0 QI)
+(store-op h OP2_2 HI)
+
+(dni st-plus "st+"
+     ((PIPE O))
+     "st $src1,@+$src2"
+     (+ OP1_2 OP2_6 src1 src2)
+     ; This has to be coded carefully to avoid an "earlyclobber" of src2.
+     (sequence ((WI new-src2))
+              (set new-src2 (add WI src2 (const WI 4)))
+              (set (mem WI new-src2) src1)
+              (set src2 new-src2))
+     ((m32r/d (unit u-store)
+             (unit u-exec (in dr src2) (out dr src2) (cycles 0)))
+      (m32rx (unit u-store)
+            (unit u-exec (in dr src2) (out dr src2) (cycles 0)))
+      )
+)
+
+(dni st-minus "st-"
+     ((PIPE O))
+     "st $src1,@-$src2"
+     (+ OP1_2 OP2_7 src1 src2)
+     ; This is the original way.  It doesn't work for parallel execution
+     ; because of the earlyclobber of src2.
+     ;(sequence ()
+     ;        (set src2 (sub src2 (const 4)))
+     ;        (set (mem WI src2) src1))
+     (sequence ((WI new-src2))
+              (set new-src2 (sub src2 (const 4)))
+              (set (mem WI new-src2) src1)
+              (set src2 new-src2))
+     ((m32r/d (unit u-store)
+             (unit u-exec (in dr src2) (out dr src2) (cycles 0)))
+      (m32rx (unit u-store)
+            (unit u-exec (in dr src2) (out dr src2) (cycles 0)))
+      )
+)
+
+(dnmi push "push" ()
+  "push $src1"
+  (emit st-minus src1 (src2 15)) ; "st %0,@-sp"
+)
+
+(dni sub "sub"
+     ((PIPE OS))
+     "sub $dr,$sr"
+     (+ OP1_0 OP2_2 dr sr)
+     (set dr (sub dr sr))
+     ()
+)
+
+(dni subv "sub:rv"
+     ((PIPE OS))
+     "subv $dr,$sr"
+     (+ OP1_0 OP2_0 dr sr)
+     (parallel ()
+              (set dr (sub dr sr))
+              (set condbit (sub-oflag dr sr (const 0))))
+     ()
+)
+
+(dni subx "sub:rx"
+     ((PIPE OS))
+     "subx $dr,$sr"
+     (+ OP1_0 OP2_1 dr sr)
+     (parallel ()
+              (set dr (subc dr sr condbit))
+              (set condbit (sub-cflag dr sr condbit)))
+     ()
+)
+
+(dni trap "trap"
+     (UNCOND-CTI FILL-SLOT (PIPE O))
+     "trap $uimm4"
+     (+ OP1_1 OP2_15 (f-r1 0) uimm4)
+     (sequence ()
+              ; bbpc = bpc
+              (set (reg h-cr 14) (reg h-cr 6))
+              ; Set bpc to the return address.  Actually it's not quite the
+              ; return address as RTE rounds the address down to a word
+              ; boundary.
+              (set (reg h-cr 6) (add pc (const 4)))
+              ; bbpsw = bpsw
+              (set (reg h-bbpsw) (reg h-bpsw))
+              ; bpsw = psw
+              (set (reg h-bpsw) (reg h-psw))
+              ; sm is unchanged, ie,c are set to zero.
+              (set (reg h-psw) (and (reg h-psw) (const #x80)))
+              ; m32r_trap handles operating vs user mode
+              (set WI pc (c-call WI "m32r_trap" pc uimm4))
+     )
+     ()
+)
+
+(dni unlock "unlock"
+     ((PIPE O))
+     "unlock $src1,@$src2"
+     (+ OP1_2 OP2_5 src1 src2)
+     (sequence ()
+              (if (reg h-lock)
+                  (set (mem WI src2) src1))
+              (set (reg h-lock) (const BI 0)))
+     ((m32r/d (unit u-load))
+      (m32rx (unit u-load)))
+)
+
+; Saturate into byte.
+(dni satb "satb"
+     ((MACH m32rx))
+     "satb $dr,$sr"
+     (+ OP1_8 dr OP2_6 sr (f-uimm16 #x0300))
+     (set dr
+         ; FIXME: min/max would simplify this nicely of course.
+         (cond WI
+               ((ge sr (const 127)) (const 127))
+               ((le sr (const -128)) (const -128))
+               (else sr)))
+     ()
+)
+
+; Saturate into half word.
+(dni sath "sath"
+     ((MACH m32rx))
+     "sath $dr,$sr"
+     (+ OP1_8 dr OP2_6 sr (f-uimm16 #x0200))
+     (set dr
+         (cond WI
+               ((ge sr (const 32767)) (const 32767))
+               ((le sr (const -32768)) (const -32768))
+               (else sr)))
+     ()
+)
+
+; Saturate word.
+(dni sat "sat"
+     ((MACH m32rx) SPECIAL)
+     "sat $dr,$sr"
+     (+ OP1_8 dr OP2_6 sr (f-uimm16 0))
+     (set dr
+         (if WI condbit
+              (if WI (lt sr (const 0))
+                   (const #x7fffffff)
+                   (const #x80000000))
+              sr))
+     ()
+)
+
+; Parallel compare byte zeros.
+; Set C bit in condition register if any byte in source register is zero.
+(dni pcmpbz "pcmpbz"
+     ((MACH m32rx) (PIPE OS) SPECIAL)
+     "pcmpbz $src2"
+     (+ OP1_0 (f-r1 3) OP2_7 src2)
+     (set condbit
+         (cond BI
+                ((eq (and src2 (const #xff)) (const 0)) (const BI 1))
+                ((eq (and src2 (const #xff00)) (const 0)) (const BI 1))
+                ((eq (and src2 (const #xff0000)) (const 0)) (const BI 1))
+                ((eq (and src2 (const #xff000000)) (const 0)) (const BI 1))
+                (else (const BI 0))))
+     ((m32rx (unit u-cmp)))
+)
+
+; Add accumulators
+(dni sadd "sadd"
+     ((MACH m32rx) (PIPE S))
+     "sadd"
+     (+ OP1_5 (f-r1 0) OP2_14 (f-r2 4))
+     (set (reg h-accums 0)
+         (add (sra (reg h-accums 1) (const 16))
+              (reg h-accums 0)))
+     ((m32rx (unit u-mac)))
+)
+
+; Multiply and add into accumulator 1
+(dni macwu1 "macwu1"
+     ((MACH m32rx) (PIPE S))
+     "macwu1 $src1,$src2"
+     (+ OP1_5 src1 OP2_11 src2)
+     (set (reg h-accums 1)
+         (sra DI
+               (sll DI
+                     (add DI
+                           (reg h-accums 1)
+                           (mul DI
+                                 (ext DI src1)
+                                 (ext DI (and src2 (const #xffff)))))
+                     (const 8))
+               (const 8)))
+     ((m32rx (unit u-mac)))
+)
+
+; Multiply and subtract from accumulator 0
+(dni msblo "msblo"
+     ((MACH m32rx) (PIPE S))
+     "msblo $src1,$src2"
+     (+ OP1_5 src1 OP2_13 src2)
+     (set accum
+         (sra DI
+               (sll DI
+                     (sub accum
+                          (sra DI
+                                (sll DI
+                                      (mul DI
+                                            (ext DI (trunc HI src1))
+                                            (ext DI (trunc HI src2)))
+                                      (const 32))
+                                (const 16)))
+                     (const 8))
+               (const 8)))
+     ((m32rx (unit u-mac)))
+)
+
+; Multiply into accumulator 1
+(dni mulwu1 "mulwu1"
+     ((MACH m32rx) (PIPE S))
+     "mulwu1 $src1,$src2"
+     (+ OP1_5 src1 OP2_10 src2)
+     (set (reg h-accums 1)
+         (sra DI
+               (sll DI
+                     (mul DI
+                           (ext DI src1)
+                           (ext DI (and src2 (const #xffff))))
+                     (const 16))
+               (const 16)))
+     ((m32rx (unit u-mac)))
+)
+
+; Multiply and add into accumulator 1
+(dni maclh1 "maclh1"
+     ((MACH m32rx) (PIPE S))
+     "maclh1 $src1,$src2"
+     (+ OP1_5 src1 OP2_12 src2)
+     (set (reg h-accums 1)
+         (sra DI
+               (sll DI
+                   (add DI
+                         (reg h-accums 1)
+                         (sll DI
+                               (ext DI
+                                     (mul SI
+                                           (ext SI (trunc HI src1))
+                                           (sra SI src2 (const SI 16))))
+                             (const 16)))
+                   (const 8))
+              (const 8)))
+     ((m32rx (unit u-mac)))
+)
+
+; skip instruction if C
+(dni sc "sc"
+     ((MACH m32rx) (PIPE O) SPECIAL)
+     "sc"
+     (+ OP1_7 (f-r1 4) OP2_0 (f-r2 1))
+     (skip (zext INT condbit))
+     ()
+)
+
+; skip instruction if not C
+(dni snc "snc"
+     ((MACH m32rx) (PIPE O) SPECIAL)
+     "snc"
+     (+ OP1_7 (f-r1 5) OP2_0 (f-r2 1))
+     (skip (zext INT (not condbit)))
+     ()
+)
diff --git a/cgen/m32r.opc b/cgen/m32r.opc
new file mode 100644 (file)
index 0000000..601ca58
--- /dev/null
@@ -0,0 +1,264 @@
+/* M32R opcode support.  -*- C -*-
+   Copyright (C) 2000 Red Hat, Inc.
+   This file is part of CGEN.  */
+
+/* This file is an addendum to m32r.cpu.  Heavy use of C code isn't
+   appropriate in .cpu files, so it resides here.  This especially applies
+   to assembly/disassembly where parsing/printing can be quite involved.
+   Such things aren't really part of the specification of the cpu, per se,
+   so .cpu files provide the general framework and .opc files handle the
+   nitty-gritty details as necessary.
+
+   Each section is delimited with start and end markers.
+
+   <arch>-opc.h additions use: "-- opc.h"
+   <arch>-opc.c additions use: "-- opc.c"
+   <arch>-asm.c additions use: "-- asm.c"
+   <arch>-dis.c additions use: "-- dis.c"
+   <arch>-ibd.h additions use: "-- ibd.h"
+*/
+\f
+/* -- opc.h */
+
+#undef CGEN_DIS_HASH_SIZE
+#define CGEN_DIS_HASH_SIZE 256
+#undef CGEN_DIS_HASH
+#define X(b) (((unsigned char *) (b))[0] & 0xf0)
+#define CGEN_DIS_HASH(buffer, value) \
+(X (buffer) | \
+ (X (buffer) == 0x40 || X (buffer) == 0xe0 || X (buffer) == 0x60 || X (buffer) == 0x50 ? 0 \
+  : X (buffer) == 0x70 || X (buffer) == 0xf0 ? (((unsigned char *) (buffer))[0] & 0xf) \
+  : X (buffer) == 0x30 ? ((((unsigned char *) (buffer))[1] & 0x70) >> 4) \
+  : ((((unsigned char *) (buffer))[1] & 0xf0) >> 4)))
+
+/* -- */
+\f
+/* -- asm.c */
+
+/* Handle '#' prefixes (i.e. skip over them).  */
+
+static const char *
+parse_hash (cd, strp, opindex, valuep)
+     CGEN_CPU_DESC cd;
+     const char **strp;
+     int opindex;
+     unsigned long *valuep;
+{
+  if (**strp == '#')
+    ++*strp;
+  return NULL;
+}
+
+/* Handle shigh(), high().  */
+
+static const char *
+parse_hi16 (cd, strp, opindex, valuep)
+     CGEN_CPU_DESC cd;
+     const char **strp;
+     int opindex;
+     unsigned long *valuep;
+{
+  const char *errmsg;
+  enum cgen_parse_operand_result result_type;
+  bfd_vma value;
+
+  if (**strp == '#')
+    ++*strp;
+
+  if (strncasecmp (*strp, "high(", 5) == 0)
+    {
+      *strp += 5;
+      errmsg = cgen_parse_address (cd, strp, opindex, BFD_RELOC_M32R_HI16_ULO,
+                                  &result_type, &value);
+      if (**strp != ')')
+       return "missing `)'";
+      ++*strp;
+      if (errmsg == NULL
+         && result_type == CGEN_PARSE_OPERAND_RESULT_NUMBER)
+       value >>= 16;
+      *valuep = value;
+      return errmsg;
+    }
+  else if (strncasecmp (*strp, "shigh(", 6) == 0)
+    {
+      *strp += 6;
+      errmsg = cgen_parse_address (cd, strp, opindex, BFD_RELOC_M32R_HI16_SLO,
+                                  &result_type, &value);
+      if (**strp != ')')
+       return "missing `)'";
+      ++*strp;
+      if (errmsg == NULL
+         && result_type == CGEN_PARSE_OPERAND_RESULT_NUMBER)
+       value = (value >> 16) + (value & 0x8000 ? 1 : 0);
+      *valuep = value;
+      return errmsg;
+    }
+
+  return cgen_parse_unsigned_integer (cd, strp, opindex, valuep);
+}
+
+/* Handle low() in a signed context.  Also handle sda().
+   The signedness of the value doesn't matter to low(), but this also
+   handles the case where low() isn't present.  */
+
+static const char *
+parse_slo16 (cd, strp, opindex, valuep)
+     CGEN_CPU_DESC cd;
+     const char **strp;
+     int opindex;
+     long *valuep;
+{
+  const char *errmsg;
+  enum cgen_parse_operand_result result_type;
+  bfd_vma value;
+
+  if (**strp == '#')
+    ++*strp;
+
+  if (strncasecmp (*strp, "low(", 4) == 0)
+    {
+      *strp += 4;
+      errmsg = cgen_parse_address (cd, strp, opindex, BFD_RELOC_M32R_LO16,
+                                  &result_type, &value);
+      if (**strp != ')')
+       return "missing `)'";
+      ++*strp;
+      if (errmsg == NULL
+         && result_type == CGEN_PARSE_OPERAND_RESULT_NUMBER)
+       value &= 0xffff;
+      *valuep = value;
+      return errmsg;
+    }
+
+  if (strncasecmp (*strp, "sda(", 4) == 0)
+    {
+      *strp += 4;
+      errmsg = cgen_parse_address (cd, strp, opindex, BFD_RELOC_M32R_SDA16,
+                                  NULL, &value);
+      if (**strp != ')')
+       return "missing `)'";
+      ++*strp;
+      *valuep = value;
+      return errmsg;
+    }
+
+  return cgen_parse_signed_integer (cd, strp, opindex, valuep);
+}
+
+/* Handle low() in an unsigned context.
+   The signedness of the value doesn't matter to low(), but this also
+   handles the case where low() isn't present.  */
+
+static const char *
+parse_ulo16 (cd, strp, opindex, valuep)
+     CGEN_CPU_DESC cd;
+     const char **strp;
+     int opindex;
+     unsigned long *valuep;
+{
+  const char *errmsg;
+  enum cgen_parse_operand_result result_type;
+  bfd_vma value;
+
+  if (**strp == '#')
+    ++*strp;
+
+  if (strncasecmp (*strp, "low(", 4) == 0)
+    {
+      *strp += 4;
+      errmsg = cgen_parse_address (cd, strp, opindex, BFD_RELOC_M32R_LO16,
+                                  &result_type, &value);
+      if (**strp != ')')
+       return "missing `)'";
+      ++*strp;
+      if (errmsg == NULL
+         && result_type == CGEN_PARSE_OPERAND_RESULT_NUMBER)
+       value &= 0xffff;
+      *valuep = value;
+      return errmsg;
+    }
+
+  return cgen_parse_unsigned_integer (cd, strp, opindex, valuep);
+}
+
+/* -- */
+\f
+/* -- dis.c */
+
+/* Immediate values are prefixed with '#'.  */
+
+#define CGEN_PRINT_NORMAL(cd, info, value, attrs, pc, length) \
+do { \
+  if (CGEN_BOOL_ATTR ((attrs), CGEN_OPERAND_HASH_PREFIX)) \
+    (*info->fprintf_func) (info->stream, "#"); \
+} while (0)
+
+/* Handle '#' prefixes as operands.  */
+
+static void
+print_hash (cd, dis_info, value, attrs, pc, length)
+     CGEN_CPU_DESC cd;
+     PTR dis_info;
+     long value;
+     unsigned int attrs;
+     bfd_vma pc;
+     int length;
+{
+  disassemble_info *info = (disassemble_info *) dis_info;
+  (*info->fprintf_func) (info->stream, "#");
+}
+
+#undef CGEN_PRINT_INSN
+#define CGEN_PRINT_INSN my_print_insn
+
+static int
+my_print_insn (cd, pc, info)
+     CGEN_CPU_DESC cd;
+     bfd_vma pc;
+     disassemble_info *info;
+{
+  char buffer[CGEN_MAX_INSN_SIZE];
+  char *buf = buffer;
+  int status;
+  int buflen = (pc & 3) == 0 ? 4 : 2;
+
+  /* Read the base part of the insn.  */
+
+  status = (*info->read_memory_func) (pc, buf, buflen, info);
+  if (status != 0)
+    {
+      (*info->memory_error_func) (status, pc, info);
+      return -1;
+    }
+
+  /* 32 bit insn?  */
+  if ((pc & 3) == 0 && (buf[0] & 0x80) != 0)
+    return print_insn (cd, pc, info, buf, buflen);
+
+  /* Print the first insn.  */
+  if ((pc & 3) == 0)
+    {
+      if (print_insn (cd, pc, info, buf, 2) == 0)
+       (*info->fprintf_func) (info->stream, UNKNOWN_INSN_MSG);
+      buf += 2;
+    }
+
+  if (buf[0] & 0x80)
+    {
+      /* Parallel.  */
+      (*info->fprintf_func) (info->stream, " || ");
+      buf[0] &= 0x7f;
+    }
+  else
+    (*info->fprintf_func) (info->stream, " -> ");
+
+  /* The "& 3" is to pass a consistent address.
+     Parallel insns arguably both begin on the word boundary.
+     Also, branch insns are calculated relative to the word boundary.  */
+  if (print_insn (cd, pc & ~ (bfd_vma) 3, info, buf, 2) == 0)
+    (*info->fprintf_func) (info->stream, UNKNOWN_INSN_MSG);
+
+  return (pc & 3) ? 2 : 4;
+}
+
+/* -- */
diff --git a/cgen/m68k.cpu b/cgen/m68k.cpu
new file mode 100644 (file)
index 0000000..5a614dd
--- /dev/null
@@ -0,0 +1,253 @@
+; Motorola M68000 family CPU description.  -*- Scheme -*-
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; NOTE: this file is still strictly WORK-IN-PROGRESS.
+
+(include "simplify.inc")
+
+(define-arch
+  (name m68k)
+  (comment "Motorola M68000 architecture")
+  (insn-lsb0? #t)
+  (machs m68k16)
+  (isas basic)
+)
+
+(define-isa
+  (name basic)
+  (comment "Basic M68K instruction set")
+  (default-insn-word-bitsize 16)
+  (default-insn-bitsize 16)
+  (base-insn-bitsize 16)
+  (decode-assist (15 14 13 12))
+)
+
+(define-cpu
+  (name m68k)
+  (comment "Motorola M68000 family")
+  (endian big)
+  (word-bitsize 32)
+)
+
+(define-mach
+  (name m68k16)
+  (comment "Motorola M68000 (16-bit bus)")
+  (cpu m68k)
+  (isas basic)
+)
+
+(define-model
+  (name mc68000)
+  (comment "Motorola MC68000 microprocessor")
+  (mach m68k16)
+  (unit u-exec "Execution Unit" ()
+       1 1 ; issue done
+       () () () ())
+)
+\f
+; Hardware elements.
+
+(dnh h-pc "program counter" (PC PROFILE (ISA basic)) (pc) () () ())
+
+(dsh h-ccr "condition code register" () (register HI))
+
+(define-keyword
+  (name dr-names)
+  (print-name h-dr)
+  (prefix "")
+  (values (d0 0)  (d1 1) (d2 2)  (d3 3)  (d4 4)  (d5 5)  (d6 6)  (d7 7))
+)
+
+(define-keyword
+  (name ar-names)
+  (print-name h-ar)
+  (prefix "")
+  (values (a0 0) (a1 1) (a2 2) (a3 3) (a4 4) (a5 5) (a6 6) (a7 7)
+         (sp 7))
+)
+
+(define-hardware 
+  (name h-dr)
+  (comment "data registers")
+  (attrs (ISA basic) CACHE-ADDR)
+  (type register SI (8))
+  (indices extern-keyword dr-names)
+)
+
+(define-hardware
+  (name h-ar)
+  (comment "address registers")
+  (attrs (ISA basic) CACHE-ADDR)
+  (type register SI (8))
+  (indices extern-keyword ar-names)
+)
+
+; FIXME: need three shadowed A7 registers here for:
+;   * User stack pointer (USP)
+;   * Interrupt stack pointer (ISP)
+;   * Master stack pointer (MSP).
+; These can be omitted for now since we intend to only do user mode.
+; c.f. arm.cpu for tips on how to do this.  ARM shadows some registers
+; depending on any of its five operating modes.
+
+\f
+; Instruction fields.
+
+(define-pmacro (d68f x-name x-comment x-attrs x-word-offset x-word-length
+                    x-start x-length x-mode x-encode x-decode)
+  (define-ifield
+    (name x-name)
+    (comment x-comment)
+    (.splice attrs (.unsplice x-attrs))
+    (word-offset x-word-offset)
+    (word-length x-word-length)
+    (start x-start)
+    (length x-length)
+    (mode x-mode)
+    (encode x-encode)
+    (decode x-decode)
+  )
+)
+
+(define-pmacro (dn68f x-name x-comment x-attrs x-word-offset
+                     x-word-length x-start x-length)
+  (d68f x-name x-comment x-attrs x-word-offset x-word-length x-start
+       x-length UINT #f #f)
+)
+
+(d68f f-simm8  "signed 8 bit immediate"  () 16 16 7  8  INT #f #f)
+(d68f f-simm16 "signed 16 bit immediate" () 16 16 15 16 INT #f #f)
+(d68f f-simm32 "signed 32 bit immediate" () 16 32 31 32 INT #f #f)
+
+(dn68f f-uimm8  "unsigned 8 bit immediate"  () 16 16 7  8)
+(dn68f f-uimm16 "unsigned 16 bit immediate" () 16 16 15 16)
+(dn68f f-iumm32 "unsigned 32 bit immediate" () 16 32 31 32)
+
+(dn68f f-imm8-filler "unused part of 8 bit immediate" () 16 16 15 8)
+
+(dn68f f-15-4  "4 bits at bit 15"  () 0 16 15 4)
+(dn68f f-15-12 "12 bits at bit 15" () 0 16 15 12)
+(dn68f f-15-13 "13 bits at bit 15" () 0 16 15 13)
+(dn68f f-15-16 "16 bits at bit 15" () 0 16 15 16)
+(dn68f f-8-1   "1 bit at bit 8"    () 0 16 8  1)
+
+(dnf f-rx     "register Rx field"              ()   11  3)
+(dnf f-ry     "register Ry field"              ()    2  3)
+(dnf f-opmode "operation mode"                 ()    7  5)
+(dnf f-vector "vector field"                   ()    3  4)
+
+(dnf f-imm8   "immediate constant (8 bits)"    ()    7  8)
+\f
+; Operands.
+(dnop rx      "register Rx operand"            () h-uint f-rx)
+(dnop reg-@2  "general reg number (at bit 2)"  () h-uint f-rx)
+(dnop reg-@11 "general reg number (at bit 11)" () h-uint f-ry)
+(dnop ry      "register Ry operand"            () h-uint f-ry)
+(dnop vector  "trap vector operand"            () h-uint f-vector)
+(dnop imm8    "immediate constant (8 bits)"    () h-uint f-imm8)
+\f
+; Instructions.
+
+(dni nop "no operation" ()
+     "nop"
+      (+ (f-15-16 #x4E71))
+      (nop)
+      ()
+)
+
+(dni exg-data "exchange data registers" ()
+     "FIXME"
+     (+ (f-15-4 #xC) rx (f-8-1 1) (f-opmode 8) ry)
+     (sequence ((SI temp))
+              (set temp (reg h-dr rx))
+              (set (reg h-dr rx) (reg h-dr ry))
+              (set (reg h-dr ry) temp))
+     ()
+)
+
+(dni exg-addr "exchange address registers" ()
+     "FIXME"
+     (+ (f-15-4 #xC) rx (f-8-1 1) (f-opmode 9) ry)
+     (sequence ((SI temp))
+              (set temp (reg h-ar rx))
+              (set (reg h-ar rx) (reg h-ar ry))
+              (set (reg h-ar ry) temp))
+     ()
+)
+
+(dni exg-data-addr "exchange data and address register" ()
+     "FIXME"
+     (+ (f-15-4 #xC) rx (f-8-1 1) (f-opmode #x11) ry)
+     (sequence ((SI temp))
+              (set temp (reg h-dr rx))
+              (set (reg h-dr rx) (reg h-ar ry))
+              (set (reg h-ar ry) temp))
+     ()
+)
+
+(dni illegal "illegal instruction" ()
+     "FIXME"
+     (+ (f-15-16 #x4AFC))
+     (nop)
+     ()
+)
+
+(dni moveq "move quick" ()
+     "FIXME"
+     (+ (f-15-4 7) reg-@2 (f-8-1 0) imm8)
+     ; FIXME: set condition codes.
+     (sequence ()
+              (set (reg h-dr reg-@2) (ext SI imm8)))
+     ()
+)
+
+(dni reset "reset external devices" ()
+     "FIXME"
+     (+ (f-15-16 #x4E70))
+     (nop)
+     ()
+)
+
+(dni rte "return from exception" ()
+     "FIXME"
+     (+ (f-15-16 #x4E73))
+     (nop)
+     ()
+)
+
+(dni rtr "return and restore condition codes" ()
+     "FIXME"
+     (+ (f-15-16 #x4E77))
+     (nop)
+     ()
+)
+
+(dni rts "return from subroutine" ()
+     "RTS"
+     (+ (f-15-16 #x4E75))
+     (nop)
+     ()
+)
+
+(dni trap "trap" ()
+     "FIXME"
+     (+ (f-15-12 #x4E4) vector)
+     (nop)
+     ()
+)
+
+(dni trapv "trap on overflow" ()
+     "FIXME"
+     (+ (f-15-16 #x4E76))
+     (nop)
+     ()
+)
+
+(dni unlk "unlink" ()
+     "FIXME"
+     (+ (f-15-13 #x9CB) reg-@2)
+     (nop)
+     ()
+)
diff --git a/cgen/mach.scm b/cgen/mach.scm
new file mode 100644 (file)
index 0000000..6069788
--- /dev/null
@@ -0,0 +1,1473 @@
+; CPU architecture description.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; Top level class that records everything about a cpu.
+; FIXME: Rename this to something else and rename <arch-data> to <arch>
+; for consistency with other classes (define-foo -> <foo> object).
+
+(define <arch>
+  (class-make '<arch>
+             nil
+             '(
+               ; An object of type <arch-data>.
+               data
+               (attr-list . (() . ()))
+               (enum-list . ())
+               (kw-list . ())
+               (isa-list . ())
+               (cpu-list . ())
+               (mach-list . ())
+               (model-list . ())
+               (ifld-list . ())
+               (hw-list . ())
+               (op-list . ())
+               (ifmt-list . ())
+               (sfmt-list . ())
+               (insn-list . ())
+               (minsn-list . ())
+               (subr-list . ())
+               (insn-extract . #f) ; FIXME: wip (and move elsewhere)
+               (insn-execute . #f) ; FIXME: wip (and move elsewhere)
+
+               ; standard values derived from the input data
+               derived
+
+               ; #t if instructions have been analyzed
+               (insns-analyzed? . #f)
+               ; #t if semantics were included in the analysis
+               (semantics-analyzed? . #f)
+               ; #t if alias insns were included in the analysis
+               (aliases-analyzed? . #f)
+               )
+             nil)
+)
+
+; Accessors.
+; Each getter is arch-foo.
+; Each setter is arch-set-foo!.
+
+(define-getters <arch> arch
+  (data
+   attr-list enum-list kw-list
+   isa-list cpu-list mach-list model-list
+   ifld-list hw-list op-list ifmt-list sfmt-list
+   insn-list minsn-list subr-list
+   derived
+   insns-analyzed? semantics-analyzed? aliases-analyzed?
+   )
+)
+(define-setters <arch> arch 
+  (data
+   attr-list enum-list kw-list
+   isa-list cpu-list mach-list model-list
+   ifld-list hw-list op-list ifmt-list sfmt-list
+   insn-list minsn-list subr-list
+   derived
+   insns-analyzed? semantics-analyzed? aliases-analyzed?
+   )
+)
+
+; Class for recording things specified in `define-arch'.
+; This simplifies define-arch as the global arch object CURRENT-ARCH
+; must exist before loading the .cpu file.
+
+(define <arch-data>
+  (class-make '<arch-data>
+             '(<ident>)
+             '(
+               ; Default alignment of memory operations.
+               ; One of aligned, unaligned, forced.
+               default-alignment
+
+               ; Orientation of insn bit numbering (#f->msb=0, #t->lsb=0).
+               insn-lsb0?
+
+               ; List of all machs.
+               ; Each element is pair of (mach-name . sanitize-key)
+               ; where sanitize-key is #f if there is none.
+               ; blah blah blah ... ooohhh, evil sanitize key, blah blah blah
+               machs
+
+               ; List of all isas (instruction set architecture).
+               ; Each element is a pair of (isa-name . sanitize-key)
+               ; where sanitize-key is #f if there is none.
+               ; There is usually just one.  ARM has two (arm, thumb).
+               ; blah blah blah ... ooohhh, evil sanitize key, blah blah blah
+               isas
+
+               ; ??? Defaults for other things should be here.
+               )
+             nil)
+)
+
+(define-getters <arch-data> adata
+  (default-alignment insn-lsb0? machs isas)
+)
+\f
+; Add, list, lookup accessors for <arch>.
+;
+; For the lookup routines, the result is the object or #f if not found.
+; For some, if X is already an object, return that.
+
+(define (current-arch-name) (obj:name (arch-data CURRENT-ARCH)))
+
+(define (current-arch-comment) (obj:comment (arch-data CURRENT-ARCH)))
+
+(define (current-arch-atlist) (obj-atlist (arch-data CURRENT-ARCH)))
+
+(define (current-arch-default-alignment)
+  (adata-default-alignment (arch-data CURRENT-ARCH)))
+
+(define (current-arch-insn-lsb0?)
+  (adata-insn-lsb0? (arch-data CURRENT-ARCH)))
+
+(define (current-arch-mach-name-list)
+  (map car (adata-machs (arch-data CURRENT-ARCH)))
+)
+
+(define (current-arch-isa-name-list)
+  (map car (adata-isas (arch-data CURRENT-ARCH)))
+)
+
+; Attributes.
+; Recorded as a pair of lists.
+; The car is a list of <attribute> objects.
+; The cdr is an associative list of (name . <attribute>) elements, for lookup.
+; Could use a hash table except that there currently aren't that many.
+
+(define (current-attr-list) (car (arch-attr-list CURRENT-ARCH)))
+(define (current-attr-add! a)
+  (let ((adata (arch-attr-list CURRENT-ARCH)))
+    ; Build list in normal order so we don't have to reverse it at the end
+    ; (since our format is non-trivial).
+    (if (null? (car adata))
+       (arch-set-attr-list! CURRENT-ARCH
+                            (cons (cons a nil)
+                                  (acons (obj:name a) a nil)))
+       (begin
+         (append! (car adata) (cons a nil))
+         (append! (cdr adata) (acons (obj:name a) a nil)))))
+  *UNSPECIFIED*
+)
+(define (current-attr-lookup attr-name)
+  (assq-ref (cdr (arch-attr-list CURRENT-ARCH)) attr-name)
+)
+
+; Enums.
+
+(define (current-enum-list) (arch-enum-list CURRENT-ARCH))
+(define (current-enum-add! e)
+  (arch-set-enum-list! CURRENT-ARCH (cons e (arch-enum-list CURRENT-ARCH)))
+)
+(define (current-enum-lookup enum-name)
+  (object-assq enum-name (current-enum-list))
+)
+
+; Keywords.
+
+(define (current-kw-list) (arch-kw-list CURRENT-ARCH))
+(define (current-kw-add! kw)
+  (arch-set-kw-list! CURRENT-ARCH (cons kw (arch-kw-list CURRENT-ARCH)))
+)
+(define (current-kw-lookup kw-name)
+  (object-assq kw-name (current-kw-list))
+)
+
+; Instruction sets.
+
+(define (current-isa-list) (arch-isa-list CURRENT-ARCH))
+(define (current-isa-add! i)
+  (arch-set-isa-list! CURRENT-ARCH (cons i (arch-isa-list CURRENT-ARCH)))
+)
+(define (current-isa-lookup isa-name)
+  (object-assq isa-name (current-isa-list))
+)
+
+; Cpu families.
+
+(define (current-cpu-list) (arch-cpu-list CURRENT-ARCH))
+(define (current-cpu-add! c)
+  (arch-set-cpu-list! CURRENT-ARCH (cons c (arch-cpu-list CURRENT-ARCH)))
+)
+(define (current-cpu-lookup cpu-name)
+  (object-assq cpu-name (current-cpu-list))
+)
+
+; Machines.
+
+(define (current-mach-list) (arch-mach-list CURRENT-ARCH))
+(define (current-mach-add! m)
+  (arch-set-mach-list! CURRENT-ARCH (cons m (arch-mach-list CURRENT-ARCH)))
+)
+(define (current-mach-lookup mach-name)
+  (object-assq mach-name (current-mach-list))
+)
+
+; Models.
+
+(define (current-model-list) (arch-model-list CURRENT-ARCH))
+(define (current-model-add! m)
+  (arch-set-model-list! CURRENT-ARCH (cons m (arch-model-list CURRENT-ARCH)))
+)
+(define (current-model-lookup model-name)
+  (object-assq model-name (current-model-list))
+)
+
+; Hardware elements.
+
+(define (current-hw-list) (arch-hw-list CURRENT-ARCH))
+(define (current-hw-add! hw)
+  (arch-set-hw-list! CURRENT-ARCH (cons hw (arch-hw-list CURRENT-ARCH)))
+)
+(define (current-hw-lookup hw)
+  (if (object? hw)
+      hw
+      ; This doesn't use object-assq on purpose.  Hardware objects handle
+      ; get-name specially.
+      (find-first (lambda (hw-obj) (eq? (send hw-obj 'get-name) hw))
+                 (current-hw-list)))
+)
+
+; Instruction fields.
+
+(define (current-ifld-list) (map cdr (arch-ifld-list CURRENT-ARCH)))
+(define (current-ifld-add! f)
+  (arch-set-ifld-list! CURRENT-ARCH
+                      (acons (obj:name f) f (arch-ifld-list CURRENT-ARCH)))
+)
+(define (current-ifld-lookup x)
+  (if (ifield? x)
+      x
+      (assq-ref (arch-ifld-list CURRENT-ARCH) x))
+)
+
+; Operands.
+
+(define (current-op-list) (map cdr (arch-op-list CURRENT-ARCH)))
+(define (current-op-add! op)
+  (arch-set-op-list! CURRENT-ARCH
+                    (acons (obj:name op) op (arch-op-list CURRENT-ARCH)))
+)
+(define (current-op-lookup name)
+  (assq-ref (arch-op-list CURRENT-ARCH) name)
+)
+
+; Instruction field formats.
+
+(define (current-ifmt-list) (arch-ifmt-list CURRENT-ARCH))
+
+; Semantic formats (akin to ifmt's, except includes semantics to distinguish
+; insns).
+
+(define (current-sfmt-list) (arch-sfmt-list CURRENT-ARCH))
+
+; Instructions.
+
+(define (current-raw-insn-list) (arch-insn-list CURRENT-ARCH))
+(define (current-insn-list) (map cdr (arch-insn-list CURRENT-ARCH)))
+(define (current-insn-add! i)
+  (arch-set-insn-list! CURRENT-ARCH
+                      (acons (obj:name i) i (arch-insn-list CURRENT-ARCH)))
+)
+(define (current-insn-lookup name)
+  (assq-ref (arch-insn-list CURRENT-ARCH) name)
+)
+
+; Return the insn in the `car' position of INSN-LIST.
+
+(define insn-list-car cdar)
+
+; Splice INSN into INSN-LIST after (car INSN-LIST).
+; This is useful when creating machine generating insns - it's useful to
+; keep them close to their progenitor.
+; The result is the same list, but beginning at the spliced-in insn.
+
+(define (insn-list-splice! insn-list insn)
+  (set-cdr! insn-list (acons (obj:name insn) insn (cdr insn-list)))
+  (cdr insn-list)
+)
+
+; Macro instructions.
+
+(define (current-minsn-list) (map cdr (arch-minsn-list CURRENT-ARCH)))
+(define (current-minsn-add! m)
+  (arch-set-minsn-list! CURRENT-ARCH
+                       (acons (obj:name m) m (arch-minsn-list CURRENT-ARCH)))
+)
+(define (current-minsn-lookup name)
+  (assq-ref (arch-minsn-list CURRENT-ARCH) name)
+)
+
+; rtx subroutines.
+
+(define (current-subr-list) (map cdr (arch-subr-list CURRENT-ARCH)))
+(define (current-subr-add! m)
+  (arch-set-subr-list! CURRENT-ARCH
+                      (acons (obj:name m) m (arch-subr-list CURRENT-ARCH)))
+)
+(define (current-subr-lookup name)
+  (assq-ref (arch-subr-list CURRENT-ARCH) name)
+)
+\f
+; Arch parsing support.
+
+; Parse an alignment spec.
+
+(define (-arch-parse-alignment errtxt alignment)
+  (if (memq alignment '(aligned unaligned forced))
+      alignment
+      (parse-error errtxt "invalid alignment" alignment))
+)
+
+; Parse an arch mach spec.
+; The value is a list of mach names or (mach-name sanitize-key) elements.
+; The result is a list of (mach-name . sanitize-key) elements.
+
+(define (-arch-parse-machs errtxt machs)
+  (for-each (lambda (m)
+             (if (or (symbol? m)
+                     (and (list? m) (= (length m) 2)
+                          (symbol? (car m)) (symbol? (cadr m))))
+                 #t ; ok
+                 (parse-error errtxt "bad arch mach spec" m)))
+           machs)
+  (map (lambda (m)
+        (if (symbol? m)
+            (cons m #f)
+            (cons (car m) (cadr m))))
+       machs)
+)
+
+; Parse an arch isa spec.
+; The value is a list of isa names or (isa-name sanitize-key) elements.
+; The result is a list of (isa-name . sanitize-key) elements.
+
+(define (-arch-parse-isas errtxt isas)
+  (for-each (lambda (m)
+             (if (or (symbol? m)
+                     (and (list? m) (= (length m) 2)
+                          (symbol? (car m)) (symbol? (cadr m))))
+                 #t ; ok
+                 (parse-error errtxt "bad arch isa spec" m)))
+           isas)
+  (map (lambda (m)
+        (if (symbol? m)
+            (cons m #f)
+            (cons (car m) (cadr m))))
+       isas)
+)
+
+; Parse an architecture description
+; This is the main routine for building an arch object from a cpu
+; description in the .cpu file.
+; All arguments are in raw (non-evaluated) form.
+
+(define (-arch-parse context name comment attrs
+                    default-alignment insn-lsb0?
+                    machs isas)
+  (logit 2 "Processing arch " name " ...\n")
+  (make <arch-data>
+    (parse-name name context)
+    (parse-comment comment context)
+    (atlist-parse attrs "arch" context)
+    (-arch-parse-alignment context default-alignment)
+    (parse-boolean context insn-lsb0?)
+    (-arch-parse-machs context machs)
+    (-arch-parse-isas context isas))
+)
+
+; Read an architecture description.
+; This is the main routine for analyzing an arch description in the .cpu file.
+; ARG-LIST is an associative list of field name and field value.
+; parse-arch is invoked to create the `arch' object.
+
+(define -arch-read
+  (lambda arg-list
+    (let ((context "arch-read")
+         ; <arch-data> object members and default values
+         (name "unknown")
+         (comment "")
+         (attrs nil)
+         (default-alignment 'aligned)
+         (insn-lsb0? #f)
+         (machs #f)
+         (isas #f)
+         )
+      ; Loop over each element in ARG-LIST, recording what's found.
+      (let loop ((arg-list arg-list))
+       (if (null? arg-list)
+           nil
+           (let ((arg (car arg-list))
+                 (elm-name (caar arg-list)))
+             (case elm-name
+               ((name) (set! name (cadr arg)))
+               ((comment) (set! comment (cadr arg)))
+               ((attrs) (set! attrs (cdr arg)))
+               ((default-alignment) (set! default-alignment (cadr arg)))
+               ((insn-lsb0?) (set! insn-lsb0? (cadr arg)))
+               ((machs) (set! machs (cdr arg)))
+               ((isas) (set! isas (cdr arg)))
+               (else (parse-error context "invalid arch arg" arg)))
+             (loop (cdr arg-list)))))
+      ; Ensure required fields are present.
+      (if (not machs)
+         (parse-error context "missing machs spec"))
+      (if (not isas)
+         (parse-error context "missing isas spec"))
+      ; Now that we've identified the elements, build the object.
+      (-arch-parse context name comment attrs default-alignment insn-lsb0?
+                  machs isas)
+      )
+    )
+)
+
+; Define an arch object, name/value pair list version.
+
+(define define-arch
+  (lambda arg-list
+    (let ((a (apply -arch-read arg-list)))
+      (arch-set-data! CURRENT-ARCH a)
+      (def-mach-attr! (adata-machs a))
+      (keep-mach-validate!)
+      (def-isa-attr! (adata-isas a))
+      (keep-isa-validate!)
+      ; Install the builtin objects now that we have an arch, and now that
+      ; attributes MACH and ISA exist.
+      (reader-install-builtin!)
+      a))
+)
+\f
+; Mach/isa processing.
+
+; Create the MACH attribute.
+; MACHS is the canonicalized machs spec to define-arch: (name . sanitize-key).
+
+(define (def-mach-attr! machs)
+  (let ((mach-enums (append
+                    '((base))
+                    (map (lambda (mach)
+                           (cons (car mach)
+                                 (cons '-
+                                       (if (cdr mach)
+                                           (list (cons 'sanitize (cdr mach)))
+                                           nil))))
+                         machs)
+                    '((max)))))
+    (define-attr '(type bitset) '(name MACH)
+      '(comment "machine type selection")
+      '(default base) (cons 'values mach-enums))
+    )
+
+  *UNSPECIFIED*
+)
+
+; Return #t if MACH is supported by OBJ.
+; This is done by looking for the MACH attribute in OBJ.
+; By definition, objects that support the default (base) mach support
+; all machs.
+
+(define (mach-supports? mach obj)
+  (let ((machs (bitset-attr->list (obj-attr-value obj 'MACH)))
+       (name (obj:name mach)))
+    (or (memq name machs)
+       (memq 'base machs)))
+       ;(let ((deflt (attr-lookup-default 'MACH obj)))
+       ;  (any-true? (map (lambda (m) (memq m deflt)) machs)))))
+)
+
+; Create the ISA attribute.
+; ISAS is the canonicalized isas spec to define-arch: (name . sanitize-key).
+; ISAS is a list of isa names.
+
+(define (def-isa-attr! isas)
+  (let ((isa-enums (append
+                   (map (lambda (isa)
+                          (cons (car isa)
+                                (cons '-
+                                      (if (cdr isa)
+                                          (list (cons 'sanitize (cdr isa)))
+                                          nil))))
+                        isas)
+                   '((max)))))
+    ; Using a bitset attribute here implies something could be used by two
+    ; separate isas.  This seems highly unlikely but we don't [as yet]
+    ; preclude it.  The other thing to consider is whether the cpu table
+    ; would ever want to be opened for multiple isas.
+    (define-attr '(type bitset) '(name ISA)
+      '(comment "instruction set selection")
+      ; If there's only one isa, don't (yet) pollute the tables with a value
+      ; for it.
+      (if (= (length isas) 1)
+         '(for)
+         '(for ifield operand insn))
+      (cons 'values isa-enums))
+    )
+
+  *UNSPECIFIED*
+)
+
+; Return #t if <isa> ISA is supported by OBJ.
+; This is done by looking for the ISA attribute in OBJ.
+
+(define (isa-supports? isa obj)
+  (let ((isas (bitset-attr->list (obj-attr-value obj 'ISA)))
+       (name (obj:name isa)))
+    (->bool (memq name isas)))
+)
+\f
+; The fetch/decode/execute process.
+; "extract" is a fancy word for fetch/decode.
+; FIXME: wip, not currently used.
+; FIXME: move to inside define-isa, and maybe elsewhere.
+;
+;(defmacro
+;  define-extract (code)
+;  ;(arch-set-insn-extract! CURRENT-ARCH code)
+;  *UNSPECIFIED*
+;)
+;
+;(defmacro
+;  define-execute (code)
+;  ;(arch-set-insn-execute! CURRENT-ARCH code)
+;  *UNSPECIFIED*
+;)
+\f
+; ISA specification.
+; Each architecture is generally one isa, but in the case of ARM (and a few
+; others) there is more than one.
+;
+; ??? "ISA" has a very well defined meaning, and our usage of it one might
+; want to quibble over.  A better name would be welcome.
+
+; Associated with an instruction set is its framing.
+; This refers to how instructions are laid out at the liw level (where several
+; insns are framed together and executed sequentially or in parallel).
+; ??? If one defines the term "format" as being how an individual instruction
+; is laid out then formatting can be thought of as being different from
+; framing.  However, it's possible for a particular ISA to intertwine the two.
+; Thus this will need to evolve.
+; ??? Not used yet, wip.
+
+(define <iframe> ; pronounced I-frame
+  (class-make '<iframe> '(<ident>)
+             '(
+               ; list of <itype> objects that make up the frame
+               insns
+
+               ; assembler syntax
+               syntax
+
+               ; list of (length value) elements that make up the format
+               ; Length is in bits.  Value is either a number or a $number
+               ; symbol refering to the insn specified in `insns'.
+               value
+
+               ; Initial bitnumbers to decode insns by.
+               ; ??? At present the rest of the decoding is determined
+               ; algorithmically.  May wish to give the user more control
+               ; [like psim].
+               decode-assist
+
+               ; rtl that executes instructions in `value'
+               ; Fields specified in `value' can be used here.
+               action
+               )
+             nil)
+)
+
+; Accessors.
+
+(define-getters <iframe> iframe (insns syntax value decode-assist action))
+
+; Instruction types, recorded in <iframe>.
+; ??? Not used yet, wip.
+
+(define <itype>
+  (class-make '<itype> '(<ident>)
+             '(
+               ; length in bits, or initial part if variable length (wip)
+               length
+
+               ; constraint specifying which insns are included
+               constraint
+
+               ; Initial bitnumbers to decode insns by.
+               ; ??? At present the rest of the decoding is determined
+               ; algorithmically.  May wish to give the user more control
+               ; [like psim].
+               decode-assist
+               )
+             nil)
+)
+
+; Accessors.
+
+(define-getters <itype> itype (length constraint decode-assist))
+
+; Simulator instruction decode splitting.
+; FIXME: Should live in simulator specific code.  Requires class handling
+; cleanup first.
+;
+; Instructions can be split by particular values for an ifield.
+; The ARM port uses this to split insns into those that set the pc and
+; those that don't.
+
+(define <decode-split>
+  (class-make '<decode-split> '()
+             '(
+               ; Name of ifield to split on.
+               name
+
+               ; Constraint.  Only insns satifying this constraint are
+               ; split.  #f if no constraint.
+               constraint
+
+               ; List of ifield splits.
+               ; Each element is one of (name value) or (name (values)).
+               values
+               )
+             nil
+             )
+)
+
+; Accessors.
+
+(define-getters <decode-split> decode-split (name constraint values))
+
+; Parse a decode-split spec.
+; SPEC is (ifield-name constraint value-list).
+; CONSTRAINT is an rtl expression.  Only insns satifying the constraint
+; are split.
+; Each element of VALUE-LIST is one of (name value) or (name (values)).
+; FIXME: All possible values must be specified.  Need an `else' clause.
+; Ranges would also be useful.
+
+(define (-isa-parse-decode-split context spec)
+  (if (!= (length spec) 3)
+      (parse-error context "decode-split spec is (ifield-name constraint value-list)" spec))
+
+  (let ((name (parse-name (car spec) context))
+       (constraint (cadr spec))
+       (value-list (caddr spec)))
+
+    ; FIXME: more error checking.
+
+    (make <decode-split>
+      name
+      (if (null? constraint) #f constraint)
+      value-list))
+)
+
+; Parse a list of decode-split specs.
+
+(define (-isa-parse-decode-splits context spec-list)
+  (map (lambda (spec)
+        (-isa-parse-decode-split context spec))
+       spec-list)
+)
+
+; Top level class to describe an isa.
+
+(define <isa>
+  (class-make '<isa> '(<ident>)
+             '(
+               ; Default length to record in ifields.
+               ; This is used in calculations involving bit numbers.
+               default-insn-word-bitsize
+
+               ; Length of an unknown instruction.  Used by disassembly
+               ; and by the simulator's invalid insn handler.
+               default-insn-bitsize
+
+               ; Number of bytes of insn that can be initially fetched.
+               ; In non-LIW isas this would be the length of the smallest
+               ; insn.  For LIW isas it depends - only one LIW isa is
+               ; currently supported (m32r).
+               base-insn-bitsize
+
+               ; Initial bitnumbers to decode insns by.
+               ; ??? At present the rest of the decoding is determined
+               ; algorithmically.  May wish to give the user more control
+               ; [like psim].
+               decode-assist
+
+               ; Number of instructions that can be fetched at a time
+               ; [e.g. 2 on m32r].
+               liw-insns
+
+               ; Maximum number of instructions the cpu can execute in
+               ; parallel.
+               ; FIXME: Rename to max-parallel-insns.
+               parallel-insns
+
+               ; List of <iframe> objects.
+               ;frames
+
+               ; Condition tested before execution of any instruction or
+               ; #f if there is none.  For architectures like ARM, ARC.
+               ; If specified it is a pair of
+               ; (condition-field-name . rtl-for-condition)
+               (condition . #f)
+
+               ; Code to execute after CONDITION and prior to SEMANTICS.
+               ; This is rtl in source form or #f if there is none.
+               ; This is generally unused.  It is used on the ARM to set
+               ; R15 to the correct value.
+               ; The reason it's not specified with SEMANTICS is that it is
+               ; believed some applications won't need/want this.
+               ; ??? It is a bit of a hack though, as it is used to aid
+               ; implementation of apps (e.g. simulator).  Arguably something
+               ; that doesn't belong here.  Maybe as more architectures are
+               ; ported that have the PC as a general register, a better way
+               ; to do this will arise.
+               (setup-semantics . #f)
+
+               ; list of simulator instruction splits
+               ; FIXME: should live in simulator file (needs class cleanup).
+               (decode-splits . ())
+
+               ; ??? More may need to migrate here.
+               )
+             nil)
+)
+
+; Accessors.
+
+(define-getters <isa> isa
+  (base-insn-bitsize default-insn-bitsize default-insn-word-bitsize
+   decode-assist liw-insns parallel-insns condition
+   setup-semantics decode-splits)
+)
+
+(define-setters <isa> isa
+  (decode-splits)
+)
+
+(define (isa-enum isa) (string-append "ISA_" (string-upcase (gen-sym isa))))
+
+; Return minimum/maximum size in bits of all insns in the isa.
+
+(define (isa-min-insn-bitsize isa)
+  ; add `65535' in case list is nil (avoids crash)
+  ; [a language with infinite precision can't have min-reduce-iota-0 :-)]
+  (apply min (cons 65535
+                  (map insn-length (find (lambda (insn)
+                                           (and (not (has-attr? insn 'ALIAS))
+                                                (eq? (obj-attr-value insn 'ISA)
+                                                     (obj:name isa))))
+                                         (non-multi-insns (current-insn-list))))))
+)
+
+(define (isa-max-insn-bitsize isa)
+  ; add `0' in case list is nil (avoids crash)
+  ; [a language with infinite precision can't have max-reduce-iota-0 :-)]
+  (apply max (cons 0
+                  (map insn-length (find (lambda (insn)
+                                           (and (not (has-attr? insn 'ALIAS))
+                                                (eq? (obj-attr-value insn 'ISA)
+                                                     (obj:name isa))))
+                                         (non-multi-insns (current-insn-list))))))
+)
+
+; Return a boolean indicating if instructions in ISA can be kept in a
+; portable int.
+
+(define (isa-integral-insn? isa)
+  (<= (isa-max-insn-bitsize isa) 32)
+)
+
+; Parse an isa condition spec.
+; `condition' here refers to the condition performed by architectures like
+; ARM and ARC before each insn.
+
+(define (-isa-parse-condition context spec)
+  (if (null? spec)
+      #f
+      (begin
+       (if (or (!= (length spec) 2)
+               (not (symbol? (car spec)))
+               (not (form? (cadr spec))))
+           (parse-error context
+                        "condition spec not `(ifield-name rtl-code)'" spec))
+       spec))
+)
+
+; Parse a setup-semantics spec.
+
+(define (-isa-parse-setup-semantics context spec)
+  (if (not (null? spec))
+      spec
+      #f)
+)
+
+; Parse an isa spec.
+; The result is the <isa> object.
+; All arguments are in raw (non-evaluated) form.
+
+(define (-isa-parse context name comment attrs
+                   base-insn-bitsize default-insn-bitsize default-insn-word-bitsize
+                   decode-assist liw-insns parallel-insns condition
+                   setup-semantics decode-splits)
+  (logit 2 "Processing isa " name " ...\n")
+
+  (let ((name (parse-name name context)))
+    (if (not (memq name (current-arch-isa-name-list)))
+       (parse-error context "isa name is not present in `define-arch'" name))
+
+    ; Isa's are always kept - we need them to validate later uses, even if
+    ; the then resulting object won't be kept.  All isas are also needed to
+    ; compute a proper value for the isas-cache member of <hardware-base>
+    ; for builtin objects.
+    (make <isa>
+      name
+      (parse-comment comment context)
+      (atlist-parse attrs "isa" context)
+      (parse-number (string-append context
+                                  ": default-insn-word-bitsize")
+                   default-insn-word-bitsize '(8 . 128))
+      (parse-number (string-append context
+                                  ": default-insn-bitsize")
+                   default-insn-bitsize '(8 . 128))
+      (parse-number (string-append context
+                                  ": base-insn-bitsize")
+                   base-insn-bitsize '(8 . 128))
+      decode-assist
+      liw-insns
+      parallel-insns
+      (-isa-parse-condition context condition)
+      (-isa-parse-setup-semantics context setup-semantics)
+      (-isa-parse-decode-splits context decode-splits)
+      ))
+)
+
+; Read an isa entry.
+; ARG-LIST is an associative list of field name and field value.
+
+(define -isa-read
+  (lambda arg-list
+    (let ((context "isa-read")
+         ; <isa> object members and default values
+         (name #f)
+         (attrs nil)
+         (comment "")
+         (base-insn-bitsize #f)
+         (default-insn-bitsize #f)
+         (default-insn-word-bitsize #f)
+         (decode-assist nil)
+         (liw-insns 1)
+         ; FIXME: Hobbit computes the wrong symbol for `parallel-insns'
+         ; in the `case' expression below because there is a local var
+         ; of the same name ("__1" gets appended to the symbol name).
+         (parallel-insns- 1)
+         (condition nil)
+         (setup-semantics nil)
+         (decode-splits nil)
+         )
+      (let loop ((arg-list arg-list))
+       (if (null? arg-list)
+           nil
+           (let ((arg (car arg-list))
+                 (elm-name (caar arg-list)))
+             (case elm-name
+               ((name) (set! name (cadr arg)))
+               ((comment) (set! comment (cadr arg)))
+               ((attrs) (set! attrs (cdr arg)))
+               ((default-insn-word-bitsize)
+                (set! default-insn-word-bitsize (cadr arg)))
+               ((default-insn-bitsize) (set! default-insn-bitsize (cadr arg)))
+               ((base-insn-bitsize) (set! base-insn-bitsize (cadr arg)))
+               ((decode-assist) (set! decode-assist (cadr arg)))
+               ((liw-insns) (set! liw-insns (cadr arg)))
+               ((parallel-insns) (set! parallel-insns- (cadr arg)))
+               ((condition) (set! condition (cdr arg)))
+               ((setup-semantics) (set! setup-semantics (cadr arg)))
+               ((decode-splits) (set! decode-splits (cdr arg)))
+               ((insn-types) #t) ; ignore for now
+               ((frame) #t) ; ignore for now
+               (else (parse-error context "invalid isa arg" arg)))
+             (loop (cdr arg-list)))))
+      ; Now that we've identified the elements, build the object.
+      (-isa-parse context name comment attrs
+                 base-insn-bitsize
+                 (if default-insn-word-bitsize
+                     default-insn-word-bitsize
+                     base-insn-bitsize)
+                 (if default-insn-bitsize
+                     default-insn-bitsize
+                     base-insn-bitsize)
+                 decode-assist liw-insns parallel-insns- condition
+                 setup-semantics decode-splits)
+      )
+    )
+)
+
+; Define a <isa> object, name/value pair list version.
+
+(define define-isa
+  (lambda arg-list
+    (let ((i (apply -isa-read arg-list)))
+      (if i
+         (current-isa-add! i))
+      i))
+)
+
+; Subroutine of modify-isa to process one add-decode-split spec.
+
+(define (-isa-add-decode-split! context isa spec)
+  (let ((decode-split (-isa-parse-decode-split context spec)))
+    (isa-set-decode-splits! (cons decode-split (isa-decode-splits isa)))
+    *UNSPECIFIED*)
+)
+
+; Main routine for modifying existing isa definitions
+
+(define modify-isa
+  (lambda arg-list
+    (let ((errtxt "modify-isa")
+         (isa-spec (assq 'name arg-list)))
+      (if (not isa-spec)
+         (parse-error errtxt "isa name not specified"))
+
+      (let ((isa (current-isa-lookup (arg-list-symbol-arg errtxt isa-spec))))
+       (if (not isa)
+           (parse-error errtxt "undefined isa" isa-spec))
+
+       (let loop ((args arg-list))
+         (if (null? args)
+             #f ; done
+             (let ((arg-spec (car args)))
+               (case (car arg-spec)
+                 ((name) #f) ; ignore, already processed
+                 ((add-decode-split)
+                  (-isa-add-decode-split! errtxt isa (cdr arg-spec)))
+                 (else
+                  (parse-error errtxt "invalid/unsupported option" (car arg-spec))))
+               (loop (cdr args)))))))
+
+    *UNSPECIFIED*)
+)
+
+; Return boolean indicating if ISA supports parallel execution.
+
+(define (isa-parallel-exec? isa) (> (isa-parallel-insns isa) 1))
+
+; Return a boolean indicating if ISA supports conditional execution
+; of all instructions.
+
+(define (isa-conditional-exec? isa) (->bool (isa-condition isa)))
+\f
+; The `<cpu>' object collects together various details about a particular
+; subset of the architecture (e.g. perhaps all 32 bit variants of the sparc
+; architecture).
+; This is called a "cpu-family".
+; ??? May be renamed to <family> (both internally and in the .cpu file).
+; ??? Another way to do this would be to discard the family notion and allow
+; machs to inherit from other machs, as well as use isas to distinguish
+; sufficiently dissimilar machs.  This would remove a fuzzy illspecified
+; notion with a concrete one.
+; ??? Maybe a better way to organize sparc32 vs sparc64 is via an isa.
+
+(define <cpu>
+  (class-make '<cpu>
+             '(<ident>)
+             '(
+               ; one of big/little/either/#f.
+               ; If #f, then {insn,data,float}-endian are used.
+               ; Otherwise they're ignored.
+               endian
+
+               ; one of big/little/either.
+               insn-endian
+
+               ; one of big/little/either/big-words/little-words.
+               ; If big-words then each word is little-endian.
+               ; If little-words then each word is big-endian.
+               data-endian
+
+               ; one of big/little/either/big-words/little-words.
+               float-endian
+
+               ; number of bits in a word.
+               word-bitsize
+
+               ; Transformation to use in generated files should one be
+               ; needed.  At present the only supported value is a string
+               ; which is the file suffix.
+               ; ??? A dubious element of the description language, but given
+               ; the quantity of generated files, some machine generated
+               ; headers may need to #include other machine generated headers
+               ; (e.g. cpuall.h).
+               file-transform
+
+               ; Allow a cpu family to override the isa parallel-insns spec.
+               ; ??? Concession to the m32r port which can go away, in time.
+               parallel-insns
+               )
+             nil)
+)
+
+; Accessors.
+
+(define-getters <cpu> cpu (word-bitsize file-transform parallel-insns))
+
+; Return endianness of instructions.
+
+(define (cpu-insn-endian cpu)
+  (let ((endian (elm-xget cpu 'endian)))
+    (if endian
+       endian
+       (elm-xget cpu 'insn-endian)))
+)
+
+; Return endianness of data.
+
+(define (cpu-data-endian cpu)
+  (let ((endian (elm-xget cpu 'endian)))
+    (if endian
+       endian
+       (elm-xget cpu 'data-endian)))
+)
+
+; Return endianness of floats.
+
+(define (cpu-float-endian cpu)
+  (let ((endian (elm-xget cpu 'endian)))
+    (if endian
+       endian
+       (elm-xget cpu 'float-endian)))
+)
+
+; Parse a cpu family description
+; This is the main routine for building a <cpu> object from a cpu
+; description in the .cpu file.
+; All arguments are in raw (non-evaluated) form.
+
+(define (-cpu-parse name comment attrs
+                   endian insn-endian data-endian float-endian
+                   word-bitsize file-transform parallel-insns)
+  (logit 2 "Processing cpu family " name " ...\n")
+  ; Pick out name first 'cus we need it as a string(/symbol).
+  (let* ((name (parse-name name "cpu"))
+        (errtxt (string-append "cpu " name)))
+    (if (keep-cpu? name)
+       (make <cpu>
+             name
+             (parse-comment comment errtxt)
+             (atlist-parse attrs "cpu" errtxt)
+             endian insn-endian data-endian float-endian
+             word-bitsize
+             file-transform
+             parallel-insns)
+       (begin
+         (logit 2 "Ignoring " name ".\n")
+         #f))) ; cpu is not to be kept
+)
+
+; Read a cpu family description
+; This is the main routine for analyzing a cpu description in the .cpu file.
+; ARG-LIST is an associative list of field name and field value.
+; -cpu-parse is invoked to create the <cpu> object.
+
+(define -cpu-read
+  (lambda arg-list
+    (let ((errtxt "cpu-read")
+         ; <cpu> object members and default values
+         (name nil)
+         (comment nil)
+         (attrs nil)
+         (endian #f)
+         (insn-endian #f)
+         (data-endian #f)
+         (float-endian #f)
+         (word-bitsize nil)
+         (file-transform "")
+         ; FIXME: Hobbit computes the wrong symbol for `parallel-insns'
+         ; in the `case' expression below because there is a local var
+         ; of the same name ("__1" gets appended to the symbol name).
+         (parallel-insns- #f)
+         )
+      ; Loop over each element in ARG-LIST, recording what's found.
+      (let loop ((arg-list arg-list))
+       (if (null? arg-list)
+           nil
+           (let ((arg (car arg-list))
+                 (elm-name (caar arg-list)))
+             (case elm-name
+               ((name) (set! name (cadr arg)))
+               ((comment) (set! comment (cadr arg)))
+               ((attrs) (set! attrs (cdr arg)))
+               ((endian) (set! endian (cadr arg)))
+               ((insn-endian) (set! insn-endian (cadr arg)))
+               ((data-endian) (set! data-endian (cadr arg)))
+               ((float-endian) (set! float-endian (cadr arg)))
+               ((word-bitsize) (set! word-bitsize (cadr arg)))
+               ((file-transform) (set! file-transform (cadr arg)))
+               ((parallel-insns) (set! parallel-insns- (cadr arg)))
+               (else (parse-error errtxt "invalid cpu arg" arg)))
+             (loop (cdr arg-list)))))
+      ; Now that we've identified the elements, build the object.
+      (-cpu-parse name comment attrs
+                 endian insn-endian data-endian float-endian
+                 word-bitsize file-transform parallel-insns-)
+      )
+    )
+)
+
+; Define a cpu family object, name/value pair list version.
+
+(define define-cpu
+  (lambda arg-list
+    (let ((c (apply -cpu-read arg-list)))
+      (if c
+         (current-cpu-add! c))
+      c))
+)
+\f
+; The `<mach>' object describes one member of a `cpu' family.
+
+(define <mach>
+  (class-make '<mach> '(<ident>)
+             '(
+               ; cpu family this mach is a member of
+               cpu
+               ; bfd name of mach
+               bfd-name
+               ; list of <isa> objects
+               isas
+               )
+             nil)
+)
+
+; Accessors.
+
+(define-getters <mach> mach (cpu bfd-name isas))
+
+(define (mach-enum obj)
+  (string-append "MACH_" (string-upcase (gen-sym obj)))
+)
+
+(define (mach-number obj) (mach-enum obj))
+
+; Parse a machine entry.
+; The result is a <mach> object or #f if the mach isn't to be kept.
+; All arguments are in raw (non-evaluated) form.
+
+(define (-mach-parse context name comment attrs cpu bfd-name isas)
+  (logit 2 "Processing mach " name " ...\n")
+
+  (let ((name (parse-name name context)))
+    (if (not (list? isas))
+       (parse-error context "isa spec not a list" isas))
+    (let ((cpu-obj (current-cpu-lookup cpu))
+         (isa-list (map current-isa-lookup isas)))
+      (if (not (memq name (current-arch-mach-name-list)))
+         (parse-error context "mach name is not present in `define-arch'" name))
+      (if (null? cpu)
+         (parse-error context "missing cpu spec" cpu))
+      (if (not cpu-obj)
+         (parse-error context "unknown cpu" cpu))
+      (if (null? isas)
+         (parse-error context "missing isas spec" isas))
+      (if (not (all-true? isa-list))
+         (parse-error context "unknown isa in" isas))
+      (if (not (string? bfd-name))
+         (parse-error context "bfd-name not a string" bfd-name))
+      (if (keep-mach? (list name))
+         (make <mach>
+               name
+               (parse-comment comment context)
+               (atlist-parse attrs "mach" context)
+               cpu-obj
+               bfd-name
+               isa-list)
+         (begin
+           (logit 2 "Ignoring " name ".\n")
+           #f)))) ; mach is not to be kept
+)
+
+; Read a mach entry.
+; ARG-LIST is an associative list of field name and field value.
+
+(define -mach-read
+  (lambda arg-list
+    (let ((context "mach-read")
+         (name nil)
+         (attrs nil)
+         (comment nil)
+         (cpu nil)
+         (bfd-name #f)
+         (isas #f)
+         )
+      (let loop ((arg-list arg-list))
+       (if (null? arg-list)
+           nil
+           (let ((arg (car arg-list))
+                 (elm-name (caar arg-list)))
+             (case elm-name
+               ((name) (set! name (cadr arg)))
+               ((comment) (set! comment (cadr arg)))
+               ((attrs) (set! attrs (cdr arg)))
+               ((cpu) (set! cpu (cadr arg)))
+               ((bfd-name) (set! bfd-name (cadr arg)))
+               ((isas) (set! isas (cdr arg)))
+               (else (parse-error context "invalid mach arg" arg)))
+             (loop (cdr arg-list)))))
+      ; Now that we've identified the elements, build the object.
+      (-mach-parse context name comment attrs cpu
+                  ; Default bfd-name is same as object's name.
+                  (if bfd-name bfd-name (symbol->string name))
+                  ; Default isa is the first one.
+                  (if isas isas (list (obj:name (car (current-isa-list))))))
+      )
+    )
+)
+
+; Define a <mach> object, name/value pair list version.
+
+(define define-mach
+  (lambda arg-list
+    (let ((m (apply -mach-read arg-list)))
+      (if m
+         (current-mach-add! m))
+      m))
+)
+\f
+; Miscellaneous state derived from the input data.
+; FIXME: being redone
+
+; Size of a word in bits.
+; All selected cpu families must have same value or error.
+; FIXME: Only user is opcodes.scm and we don't want this restriction there.
+
+(define (state-word-bitsize)
+  (let ((wb (map cpu-word-bitsize (current-cpu-list))))
+    ; FIXME: ensure all have same value.
+    (car wb))
+)
+
+; Return maximum word bitsize.
+
+(define (state-max-word-bitsize)
+  (apply max (map cpu-word-bitsize (current-cpu-list)))
+)
+
+; Size of normal instruction.
+; All selected isas must have same value or error.
+
+(define (state-default-insn-bitsize)
+  (let ((dib (map isa-default-insn-bitsize (current-isa-list))))
+    ; FIXME: ensure all have same value.
+    (car dib))
+)
+
+; Number of bytes of insn we can initially fetch.
+; All selected isas must have same value or error.
+
+(define (state-base-insn-bitsize)
+  (let ((bib (map isa-base-insn-bitsize (current-isa-list))))
+    ; FIXME: ensure all have same value.
+    (car bib))
+)
+
+; Return parallel-insns spec.
+
+(define (state-parallel-insns)
+  ; Assert only one cpu family has been selected.
+  (assert-keep-one)
+
+  (let ((par-insns (map isa-parallel-insns (current-isa-list)))
+       (cpu-par-insns (cpu-parallel-insns (current-cpu))))
+    ; ??? The m32r does have parallel execution, but to keep support for the
+    ; base mach simpler, a cpu family is allowed to override the isa spec.
+    (or cpu-par-insns
+       ; FIXME: ensure all have same value.
+       (car par-insns)))
+)
+
+; Return boolean indicating if parallel execution support is required.
+
+(define (state-parallel-exec?)
+  (> (state-parallel-insns) 1)
+)
+
+; Return liw-insns spec.
+
+(define (state-liw-insns)
+  (let ((liw-insns (map isa-liw-insns (current-isa-list))))
+    ; FIXME: ensure all have same value.
+    (car liw-insns))
+)
+
+; Return decode-assist spec.
+
+(define (state-decode-assist)
+  (isa-decode-assist (current-isa))
+)
+
+; Return boolean indicating if current isa conditionally executes all insn.
+
+(define (state-conditional-exec?)
+  (isa-conditional-exec? (current-isa))
+)
+\f
+; Architecture or cpu wide values derived from other data.
+
+(define <derived-arch-data>
+  (class-make '<derived-arch-data>
+             nil
+             '(
+               ; whether all insns can be recorded in a host int
+               integral-insn?
+               )
+             nil)
+)
+
+; Called after the .cpu file has been read in to prime derived value
+; computation.
+; Often this data isn't needed so we only computed it if we have to.
+
+(define (-adata-set-derived! arch)
+  ; Don't compute this data unless we need to.
+  (arch-set-derived!
+   arch
+   (make <derived-arch-data>
+     ; integral-insn?
+     (delay (isa-integral-insn? (current-isa)))
+     ))
+)
+
+; Accessors.
+
+(define (adata-integral-insn? arch)
+  (force (elm-xget (arch-derived arch) 'integral-insn?))
+)
+\f
+; Instruction analysis control.
+
+; Analyze the instruction set.
+; The name is explicitly vague because it's intended that all insn analysis
+; would be controlled here.
+; If the instruction set has already been sufficiently analyzed, do nothing.
+; INCLUDE-ALIASES? is #t if alias insns are to be included.
+; ANALYZE-SEMANTICS? is #t if insn semantics are to be analyzed.
+;
+; This is a very expensive operation, so we only do it as necessary.
+; There are (currently) two different kinds of users: assemblers and
+; simulators.  Assembler style apps don't always need to analyze the semantics.
+; Simulator style apps don't want to include the alias insns.
+
+(define (arch-analyze-insns! arch include-aliases? analyze-semantics?)
+  (if (or (not (arch-insns-analyzed? arch))
+         (not (eq? analyze-semantics? (arch-semantics-analyzed? arch)))
+         (not (eq? include-aliases? (arch-aliases-analyzed? arch))))
+
+      (begin
+       (if (any-true? (map multi-insn? (current-insn-list)))
+           (begin
+             ; Instantiate sub-insns of all multi-insns.
+             (logit 1 "Instantiating multi-insns ...\n")
+             (for-each (lambda (insn)
+                         (multi-insn-instantiate! insn))
+                       (multi-insns (current-insn-list)))
+             ))
+
+       ; This is expensive so indicate start/finish.
+       (logit 1 "Analyzing instruction set ...\n")
+
+       (let ((fmt-lists
+              (ifmt-compute! (non-multi-insns 
+                              (if include-aliases?
+                                  (map cdr (arch-insn-list arch))
+                                  (non-alias-insns (map cdr (arch-insn-list arch)))))
+                             analyze-semantics?)))
+
+         (arch-set-ifmt-list! arch (car fmt-lists))
+         (arch-set-sfmt-list! arch (cadr fmt-lists))
+         (arch-set-insns-analyzed?! arch #t)
+         (arch-set-semantics-analyzed?! arch analyze-semantics?)
+         (arch-set-aliases-analyzed?! arch include-aliases?)
+
+         (logit 1 "Done analysis.\n")
+         ))
+      )
+
+  *UNSPECIFIED*
+)
+\f
+; Called before a .cpu file is read in.
+
+(define (arch-init!)
+
+  (reader-add-command! 'define-arch
+                      "\
+Define an architecture, name/value pair list version.
+"
+                      nil 'arg-list define-arch)
+
+  (reader-add-command! 'define-isa
+                      "\
+Define an instruction set architecture, name/value pair list version.
+"
+                      nil 'arg-list define-isa)
+  (reader-add-command! 'modify-isa
+                      "\
+Modify an isa, name/value pair list version.
+"
+                      nil 'arg-list modify-isa)
+
+  (reader-add-command! 'define-cpu
+                      "\
+Define a cpu family, name/value pair list version.
+"
+                      nil 'arg-list define-cpu)
+
+  *UNSPECIFIED*
+)
+
+; Called before a .cpu file is read in.
+
+(define (mach-init!)
+
+  (reader-add-command! 'define-mach
+                      "\
+Define a machine, name/value pair list version.
+"
+                      nil 'arg-list define-mach)
+
+  *UNSPECIFIED*
+)
+
+; Called after .cpu file is read in.
+
+(define (arch-finish!)
+  (let ((arch CURRENT-ARCH))
+
+    ; Lists are constructed in the reverse order they appear in the file
+    ; [for simplicity and efficiency].  Restore them to file order for the
+    ; human reader/debugger.
+    (arch-set-enum-list! arch (reverse (arch-enum-list arch)))
+    (arch-set-kw-list! arch (reverse (arch-kw-list arch)))
+    (arch-set-isa-list! arch (reverse (arch-isa-list arch)))
+    (arch-set-cpu-list! arch (reverse (arch-cpu-list arch)))
+    (arch-set-mach-list! arch (reverse (arch-mach-list arch)))
+    (arch-set-model-list! arch (reverse (arch-model-list arch)))
+    (arch-set-ifld-list! arch (reverse (arch-ifld-list arch)))
+    (arch-set-hw-list! arch (reverse (arch-hw-list arch)))
+    (arch-set-op-list! arch (reverse (arch-op-list arch)))
+    (arch-set-insn-list! arch (reverse (arch-insn-list arch)))
+    (arch-set-minsn-list! arch (reverse (arch-minsn-list arch)))
+    (arch-set-subr-list! arch (reverse (arch-subr-list arch)))
+    )
+
+  *UNSPECIFIED*
+)
+
+; Called after .cpu file is read in.
+
+(define (mach-finish!)
+  (-adata-set-derived! CURRENT-ARCH)
+
+  *UNSPECIFIED*
+)
diff --git a/cgen/minsn.scm b/cgen/minsn.scm
new file mode 100644 (file)
index 0000000..671c3a1
--- /dev/null
@@ -0,0 +1,259 @@
+; Macro instruction definitions.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; Expansion:
+; If the macro expands to a string, arguments in the input string
+; are refered to with %N.  Multiple insns are separated with '\n'.
+; String expansion is a special case of the normal form which is a Scheme
+; expression that controls the expansion.  The Scheme expression will be able
+; to refer to the current assembly state to decide how to perform the
+; expansion.  Special expression `emit' is used to call the assembler emitter
+; for a particular insn.  Special expression `expand' is used to return a
+; string to be reparsed (which is special cased).
+
+; Parse a list of macro-instruction expansion descriptions.
+; This is the main routine for building an minsn-expansion object from a
+; description in the .cpu file.
+; All arguments are in raw (non-evaluated) form.
+
+; ??? At present we only support macros that are aliases of one real insn.
+\f
+; Object to describe a macro-insn.
+
+(define <macro-insn>
+  (class-make '<macro-insn>
+             '(<ident>)
+             '(
+               ; syntax of the macro
+               syntax
+               ; list of expansion expressions
+               expansions
+               )
+             nil)
+)
+
+; Accessor fns
+
+(define minsn-syntax (elm-make-getter <macro-insn> 'syntax))
+(define minsn-expansions (elm-make-getter <macro-insn> 'expansions))
+
+; Return a list of the machs that support MINSN.
+
+(define (minsn-machs minsn)
+  nil
+)
+
+; Return macro-instruction mnemonic.
+; This is computed from the syntax string.
+
+(define minsn-mnemonic insn-mnemonic)
+
+; Return enum cgen_minsn_types value for MINSN.
+
+(define (minsn-enum minsn)
+  (string-upcase (string-append "@ARCH@_MINSN_" (gen-sym minsn)))
+)
+
+; Parse a macro-insn expansion description.
+; ??? At present we only support unconditional simple expansion.
+
+(define (-minsn-parse-expansion errtxt expn)
+  (if (not (form? expn))
+      (parse-error errtxt "invalid macro expansion" expn))
+  (if (not (eq? 'emit (car expn)))
+      (parse-error errtxt "invalid macro expansion, must be `(emit ...)'" expn))
+  expn
+)
+\f
+; Parse a macro-instruction description.
+; This is the main routine for building a macro-insn object from a
+; description in the .cpu file.
+; All arguments are in raw (non-evaluated) form.
+; The result is the parsed object or #f if object isn't for selected mach(s).
+
+(define (-minsn-parse errtxt name comment attrs syntax expansions)
+  (logit 2 "Processing macro-insn " name " ...\n")
+
+  (if (not (list? expansions))
+      (parse-error errtxt "invalid macro expansion list" expansions))
+
+  (let ((name (parse-name name errtxt))
+       (atlist-obj (atlist-parse attrs "cgen_minsn" errtxt)))
+
+    (if (keep-atlist? atlist-obj #f)
+
+       (let ((result (make <macro-insn>
+                       name
+                       (parse-comment comment errtxt)
+                       atlist-obj
+                       (parse-syntax syntax errtxt)
+                       (map (lambda (e) (-minsn-parse-expansion errtxt e))
+                            expansions))))
+         result)
+
+       (begin
+         (logit 2 "Ignoring " name ".\n")
+         #f)))
+)
+
+; Read a macro-insn description
+; This is the main routine for analyzing macro-insns in the .cpu file.
+; ERRTXT is prepended to error messages to provide context.
+; ARG-LIST is an associative list of field name and field value.
+; -minsn-parse is invoked to create the `macro-insn' object.
+
+(define (-minsn-read errtxt . arg-list)
+  (let (; Current macro-insn elements:
+       (name nil)
+       (comment "")
+       (attrs nil)
+       (syntax "")
+       (expansions nil)
+       )
+    ; Loop over each element in ARG-LIST, recording what's found.
+    (let loop ((arg-list arg-list))
+      (if (null? arg-list)
+         nil
+         (let ((arg (car arg-list))
+               (elm-name (caar arg-list)))
+           (case elm-name
+             ((name) (set! name (cadr arg)))
+             ((comment) (set! comment (cadr arg)))
+             ((attrs) (set! attrs (cdr arg)))
+             ((syntax) (set! syntax (cadr arg)))
+             ((expansions) (set! expansions (cdr arg)))
+             (else (parse-error errtxt "invalid macro-insn arg" arg)))
+           (loop (cdr arg-list)))))
+    ; Now that we've identified the elements, build the object.
+    (-minsn-parse errtxt name comment attrs syntax expansions)
+    )
+)
+
+; Define a macro-insn object, name/value pair list version.
+
+(define define-minsn
+  (lambda arg-list
+    (if (eq? APPLICATION 'SIMULATOR)
+       #f ; don't waste time if simulator
+       (let ((m (apply -minsn-read (cons "define-minsn" arg-list))))
+         (if m
+             (current-minsn-add! m))
+         m)))
+)
+
+; Define a macro-insn object, all arguments specified.
+; This only supports one expansion.
+; Use define-minsn for the general case (??? which is of course not implemented
+; yet :-).
+
+(define (define-full-minsn name comment attrs syntax expansion)
+  (if (eq? APPLICATION 'SIMULATOR)
+      #f ; don't waste time if simulator
+      (let ((m (-minsn-parse "define-full-minsn" name comment
+                            (cons 'ALIAS attrs)
+                            syntax (list expansion))))
+       (if m
+           (current-minsn-add! m))
+       m))
+)
+\f
+; Compute the ifield list for an alias macro-insn.
+; This involves making a copy of REAL-INSN's ifield list and assigning
+; known quantities to operands that have fixed values in the macro-insn.
+
+(define (minsn-compute-iflds errtxt minsn-iflds real-insn)
+  (let* ((iflds (list-copy (insn-iflds real-insn)))
+        ; List of "free variables", i.e. operands.
+        (ifld-ops (find ifld-operand? iflds))
+        ; Names of fields in `ifld-ops'.  As elements of minsn-iflds are
+        ; parsed the associated element in ifld-names is deleted.  At the
+        ; end ifld-names must be empty.  delq! can't delete the first
+        ; element in a list, so we insert a fencepost.
+        (ifld-names (cons #f (map obj:name ifld-ops))))
+    ;(logit 3 "Computing ifld list, operand field names: " ifld-names "\n")
+    ; For each macro-insn ifield expression, look it up in the real insn's
+    ; ifield list.  If an operand without a prespecified value, leave
+    ; unchanged.  If an operand or ifield with a value, assign the value to
+    ; the ifield entry.
+    (for-each (lambda (f)
+               (let* ((op-name (if (pair? f) (car f) f))
+                      (op-obj (current-op-lookup op-name))
+                      ; If `op-name' is an operand, use its ifield.
+                      ; Otherwise `op-name' must be an ifield name.
+                      (f-name (if op-obj
+                                  (obj:name (hw-index:value (op:index op-obj)))
+                                  op-name))
+                      (ifld-pair (object-memq f-name iflds)))
+                 ;(logit 3 "Processing ifield " f-name " ...\n")
+                 (if (not ifld-pair)
+                     (parse-error errtxt "unknown operand" f))
+                 ; Ensure `f' is an operand.
+                 (if (not (memq f-name ifld-names))
+                     (parse-error errtxt "not an operand" f))
+                 (if (pair? f)
+                     (set-car! ifld-pair (ifld-new-value (car ifld-pair) (cadr f))))
+                 (delq! f-name ifld-names)))
+             minsn-iflds)
+    (if (not (equal? ifld-names '(#f)))
+       (parse-error errtxt "incomplete operand list, missing: " (cdr ifld-names)))
+    iflds)
+)
+
+; Create an aliased real insn from an alias macro-insn.
+
+(define (minsn-make-alias errtxt minsn)
+  (if (or (not (has-attr? minsn 'ALIAS))
+         ; Must emit exactly one real insn.
+         (not (eq? 'emit (caar (minsn-expansions minsn)))))
+      (parse-error errtxt "not an alias macro-insn" minsn))
+
+  (let* ((expn (car (minsn-expansions minsn)))
+        (alias-of (current-insn-lookup (cadr expn))))
+
+    (if (not alias-of)
+       (parse-error errtxt "unknown real insn in expansion" minsn))
+
+    (let ((i (make <insn>
+                  (obj:name minsn)
+                  (obj:comment minsn)
+                  (obj-atlist minsn)
+                  (minsn-syntax minsn)
+                  (minsn-compute-iflds (string-append errtxt
+                                                      ": " (obj:name minsn))
+                                       (cddr expn) alias-of)
+                  #f ; ifield-assertion
+                  #f ; semantics
+                  #f ; timing
+                  )))
+      ; FIXME: use same format entry as real insn,
+      ; build mask and test value at run time.
+      (insn-set-ifmt! i (ifmt-build i -1 #f (insn-iflds i))) ; (car (ifmt-analyze i #f))))
+      ;(insn-set-ifmt! i (insn-ifmt alias-of))
+      i))
+)
+\f
+; Called before a .cpu file is read in.
+
+(define (minsn-init!)
+  (reader-add-command! 'define-minsn
+                      "\
+Define a macro instruction, name/value pair list version.
+"
+                      nil 'arg-list define-minsn)
+  (reader-add-command! 'define-full-minsn
+                      "\
+Define a macro instruction, all arguments specified.
+"
+                      nil '(name comment attrs syntax expansion)
+                      define-full-minsn)
+
+  *UNSPECIFIED*
+)
+
+; Called after the .cpu file has been read in.
+
+(define (minsn-finish!)
+  *UNSPECIFIED*
+)
diff --git a/cgen/mode.scm b/cgen/mode.scm
new file mode 100644 (file)
index 0000000..5e0c69e
--- /dev/null
@@ -0,0 +1,471 @@
+; Mode objects.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; FIXME: Later allow target to add new modes.
+
+(define <mode>
+  (class-make '<mode>
+             '(<ident>)
+             '(
+               ; One of RANDOM, INT, UINT, FLOAT.
+               class
+
+               ; size in bits
+               bits
+
+               ; size in bytes
+               bytes
+
+               ; NON-MODE-C-TYPE is the C type to use in situations where
+               ; modes aren't available.  A somewhat dubious feature, but at
+               ; the moment the opcodes tables use it.  It is either the C
+               ; type as a string (e.g. "int") or #f for non-portable modes
+               ; (??? could use other typedefs for #f, e.g. int64 for DI).
+               ; Use of GCC can't be assumed though.
+               non-mode-c-type
+
+               ; PRINTF-TYPE is the %<letter> arg to printf-like functions,
+               ; however we define our own extensions for non-portable modes.
+               ; Values not understood by printf aren't intended to be used
+               ; with printf.
+               ;
+               ; Possible values:
+               ; %x - as always
+               ; %D - DI mode
+               ; %f - SF,DF modes
+               ; %F - XF,TF modes
+               printf-type
+
+               ; SEM-MODE is the mode to use for semantic operations.
+               ; Unsigned modes are not part of the semantic language proper,
+               ; but they can be used in hardware descriptions.  This maps
+               ; unusable -> usable modes.  It is #f if the mode is usable by
+               ; itself.  This prevents circular data structures and makes it
+               ; easy to define since the object doesn't exist before it's
+               ; defined.
+               ; ??? May wish to later remove SEM-MODE (e.g. mips signed add
+               ; is different than mips unsigned add) however for now it keeps
+               ; things simpler (and prevents being wildly dissimilar from
+               ; GCC-RTL.  And the mips case needn't be handled with different
+               ; adds anyway.
+               sem-mode
+
+               ; PTR-TO, if non-#f, is the mode being pointed to.
+               ptr-to
+
+               ; HOST? is non-#f if the mode is a portable int for hosts,
+               ; or other host-related value.
+               ; This is used for things like register numbers and small
+               ; odd-sized immediates and registers.
+               ; ??? Not my favorite word choice here, but it's close.
+               host?
+               )
+             nil)
+)
+
+; Accessor fns
+
+(define mode:class (elm-make-getter <mode> 'class))
+(define mode:bits (elm-make-getter <mode> 'bits))
+(define mode:bytes (elm-make-getter <mode> 'bytes))
+(define mode:non-mode-c-type (elm-make-getter <mode> 'non-mode-c-type))
+(define mode:printf-type (elm-make-getter <mode> 'printf-type))
+(define mode:sem-mode (elm-make-getter <mode> 'sem-mode))
+; ptr-to is currently private so there is no accessor.
+(define mode:host? (elm-make-getter <mode> 'host?))
+
+; Return C type to use for values of mode M.
+
+(define (mode:c-type m)
+  (let ((ptr-to (elm-xget m 'ptr-to)))
+    (if ptr-to
+       (string-append (mode:c-type ptr-to) " *")
+       (obj:name m)))
+)
+
+; CM is short for "concat mode".  It is a list of modes of the elements
+; of a `concat'.
+; ??? Experiment.  Not currently used.
+
+(define <concat-mode>
+  (class-make '<concat-mode> '(<mode>)
+             '(
+               ; List of element modes
+               elm-modes
+               )
+             nil)
+)
+
+; Accessors.
+
+(define cmode-elm-modes (elm-make-getter <concat-mode> 'elm-modes))
+\f
+; List of all modes.
+
+(define mode-list nil)
+
+; Return list of mode objects.
+; Hides the fact that its stored as an alist from caller.
+
+(define (mode-list-values) (map cdr mode-list))
+
+; Return list of real mode objects (no aliases).
+
+(define (mode-list-non-alias-values)
+  (map cdr
+       (find (lambda (m) (eq? (car m) (obj:name (cdr m))))
+            mode-list))
+)
+
+; Return a boolean indicating if X is a <mode> object.
+
+(define (mode? x) (class-instance? <mode> x))
+
+; Return enum cgen_mode_types value for M.
+
+(define (mode:enum m)
+  (gen-c-symbol (string-append "MODE_" (string-upcase (obj:name m))))
+)
+
+; Return a boolean indicating if MODE1 is equal to MODE2
+; Either may be the name of a mode or a <mode> object.
+; Aliases are handled by refering to their real name.
+
+(define (mode:eq? mode1 mode2)
+  (let ((mode1-name (mode-real-name mode1))
+       (mode2-name (mode-real-name mode2)))
+    (eq? mode1-name mode2-name))
+)
+
+; Return a boolean indicating if CLASS is one of INT/UINT.
+
+(define (mode-class-integral? class) (memq class '(INT UINT)))
+(define (mode-class-signed? class) (eq? class 'INT))
+(define (mode-class-unsigned? class) (eq? class 'UINT))
+
+; Return a boolean indicating if CLASS is floating point.
+
+(define (mode-class-float? class) (memq class '(FLOAT)))
+
+; Return a boolean indicating if CLASS is numeric.
+
+(define (mode-class-numeric? class) (memq class '(INT UINT FLOAT)))
+
+; Return a boolean indicating if MODE has an integral mode class.
+; Similarily for signed/unsigned.
+
+(define (mode-integral? mode) (mode-class-integral? (mode:class mode)))
+(define (mode-signed? mode) (mode-class-signed? (mode:class mode)))
+(define (mode-unsigned? mode) (mode-class-unsigned? (mode:class mode)))
+
+; Return a boolean indicating if MODE has a floating point mode class.
+
+(define (mode-float? mode) (mode-class-float? (mode:class mode)))
+
+; Return a boolean indicating if MODE has a numeric mode class.
+
+(define (mode-numeric? mode) (mode-class-numeric? (mode:class mode))) 
+
+; Return a boolean indicating if MODE1 is compatible with MODE2.
+; MODE[12] are either names or <mode> objects.
+; HOW is a symbol indicating how the test is performed:
+; strict: modes must have same name
+; samesize: modes must be both float or both integer (int or uint) and have
+;           same size
+; sameclass: modes must be both float or both integer (int or uint)
+; numeric: modes must be both numeric
+
+(define (mode-compatible? how mode1 mode2)
+  (let ((m1 (mode:lookup mode1))
+       (m2 (mode:lookup mode2)))
+    (case how
+      ((strict)
+       (eq? (obj:name m1) (obj:name m2)))
+      ((samesize)
+       (cond ((mode-integral? m1)
+             (and (mode-integral? m2)
+                  (= (mode:bits m1) (mode:bits m2))))
+            ((mode-float? m1)
+             (and (mode-float? m2)
+                  (= (mode:bits m1) (mode:bits m2))))
+            (else #f)))
+      ((sameclass)
+       (cond ((mode-integral? m1) (mode-integral? m2))
+            ((mode-float? m1) (mode-float? m2))
+            (else #f)))
+      ((numeric)
+       (and (mode-numeric? m1) (mode-numeric? m2)))
+      (else (error "bad `how' arg to mode-compatible?" how))))
+)
+
+; Add MODE named NAME to the list of recognized modes.
+; If NAME is already present, replace it with MODE.
+; MODE is a mode object.
+; NAME exists to allow aliases of modes [e.g. WI, UWI, AI].
+;
+; No attempt to preserve any particular order of entries is done here.
+; That is up to the caller.
+
+(define (mode:add! name mode)
+  (let ((entry (assq name mode-list)))
+    (if entry
+       (set-cdr! entry mode)
+       (set! mode-list (acons name mode mode-list)))
+    mode)
+)
+\f
+; Parse a mode.
+; This is the main routine for building a mode object.
+; All arguments are in raw (non-evaluated) form.
+
+(define (-mode-parse errtxt name comment attrs class bits bytes
+                   non-mode-c-type printf-type sem-mode ptr-to host?)
+  (logit 2 "Processing mode " name " ...\n")
+  (let* ((name (parse-name name errtxt))
+        (errtxt (string-append errtxt " " name))
+        (result (make <mode>
+                      name
+                      (parse-comment comment errtxt)
+                      (atlist-parse attrs "mode" errtxt)
+                      class bits bytes non-mode-c-type printf-type
+                      sem-mode ptr-to host?)))
+    result)
+)
+
+; ??? At present there is no define-mode that takes an associative list
+; of arguments.
+
+; Define a mode object, all arguments specified.
+
+(define (define-full-mode name comment attrs class bits bytes
+         non-mode-c-type printf-type sem-mode ptr-to host?)
+  (let ((m (-mode-parse "define-full-mode" name comment attrs
+                       class bits bytes
+                       non-mode-c-type printf-type sem-mode ptr-to host?)))
+    ; Add it to the list of insn modes.
+    (mode:add! name m)
+    m)
+)
+\f
+; Lookup the mode named X.
+; Return the found object or #f.
+; If X is already a mode object, return that.
+
+(define (mode:lookup x)
+  (if (mode? x)
+      x
+      (let ((result (assq x mode-list)))
+       (if result
+           (cdr result)
+           #f)))
+)
+
+; Return a boolean indicating if X is a valid mode name.
+
+(define (mode-name? x)
+  (and (symbol? x)
+       ; FIXME: Time to make `mode-list' a hash table.
+       (->bool (assq x mode-list)))
+)
+
+; Return the name of the real mode of M.
+; This is a no-op unless M is an alias in which case we return the
+; real mode of the alias.
+
+(define (mode-real-name m)
+  (obj:name (mode:lookup m))
+)
+
+; Return the real mode of M.
+; This is a no-op unless M is an alias in which case we return the
+; real mode of the alias.
+
+(define (mode-real-mode m)
+  (mode:lookup (mode-real-name m))
+)
+
+; Return #t if mode M1-NAME is bigger than mode M2-NAME.
+
+(define (mode-bigger? m1-name m2-name)
+  (> (mode:bits (mode:lookup m1-name))
+     (mode:bits (mode:lookup m2-name)))
+)
+
+; Return a mode in mode class CLASS wide enough to hold BITS.
+
+(define (mode-find bits class)
+  (let ((modes (find (lambda (mode) (eq? (mode:class (cdr mode)) class))
+                    mode-list)))
+    (if (null? modes)
+       (error "invalid mode class" class))
+    (let loop ((modes modes))
+      (cond ((null? modes) (error "no modes for bits" bits))
+           ((<= bits (mode:bits (cdar modes))) (cdar modes))
+           (else (loop (cdr modes))))))
+)
+
+; Parse MODE-NAME and return the mode object.
+; An error is signalled if MODE isn't valid.
+
+(define (parse-mode-name mode-name errtxt)
+  (let ((m (mode:lookup mode-name)))
+    (if (not m) (parse-error errtxt "not a valid mode" mode-name))
+    m)
+)
+
+; Make a new INT/UINT mode.
+; These have a variable number of bits (1-32).
+
+(define (mode-make-int bits)
+  (if (or (<= bits 0) (> bits 64))
+      (error "unsupported number of bits" bits))
+  (let ((result (object-copy-top INT)))
+    (elm-xset! result 'bits bits)
+    (elm-xset! result 'bytes (bits->bytes bits))
+    result)
+)
+
+(define (mode-make-uint bits)
+  (if (or (<= bits 0) (> bits 64))
+      (error "unsupported number of bits" bits))
+  (let ((result (object-copy-top UINT)))
+    (elm-xset! result 'bits bits)
+    (elm-xset! result 'bytes (bits->bytes bits))
+    result)
+)
+\f
+; Initialization.
+
+; Some modes are refered to by the Scheme code.
+; These have global bindings, but we try not to make this the general rule.
+; [Actually I don't think this is all that bad, but it seems reasonable to
+; not create global bindings that we don't have to.]
+
+(define VOID #f)
+(define DFLT #f)
+
+; This is defined by the target.  We provide a default def'n.
+(define WI #f)
+(define UWI #f)
+
+; An "address int".  This is recorded in addition to a "word int" because it
+; is believed that some target will need it.  It also stays consistent with
+; what BFD does.
+; This can also be defined by the target.  We provide a default.
+(define AI #f)
+(define IAI #f)
+
+; Variable sized portable ints.
+(define INT #f)
+(define UINT #f)
+
+(define (mode-init!)
+  (set! mode-list nil)
+
+  (reader-add-command! 'define-full-mode
+                      "\
+Define a mode, all arguments specified.
+"
+                      nil '(name commment attrs class bits bytes
+                            non-c-mode-type printf-type sem-mode ptr-to host?)
+                      define-full-mode)
+
+  *UNSPECIFIED*
+)
+
+; Called before a . cpu file is read in to install any builtins.
+
+(define (mode-builtin!)
+  ; FN-SUPPORT: In sem-ops.h file, include prototypes as well as macros.
+  ;             Elsewhere, functions are defined to perform the operation.
+  (define-attr '(for mode) '(type boolean) '(name FN-SUPPORT))
+
+  (let ((dfm define-full-mode))
+    ; This list must be defined in order of increasing size among each type.
+
+    (dfm 'VOID "void" '() 'RANDOM 0 0 "void" "" #f #f #f) ; VOIDmode
+
+    ; Special marker to indicate "use the default mode".
+    ; ??? Not yet used everywhere it should be.
+    (dfm 'DFLT "default mode" '() 'RANDOM 0 0 "" "" #f #f #f)
+
+    ; Not UINT on purpose.
+    (dfm 'BI "one bit (0,1 not 0,-1)" '() 'INT 1 1 "int" "'x'" #f #f #f)
+
+    (dfm 'QI "8 bit byte" '() 'INT 8 1 "int" "'x'" #f #f #f)
+    (dfm 'HI "16 bit int" '() 'INT 16 2 "int" "'x'" #f #f #f)
+    (dfm 'SI "32 bit int" '() 'INT 32 4 "int" "'x'" #f #f #f)
+    (dfm 'DI "64 bit int" '(FN-SUPPORT) 'INT 64 8 "" "'D'" #f #f #f)
+
+    (dfm 'UQI "8 bit unsigned byte" '() 'UINT
+        8 1 "unsigned int" "'x'" (mode:lookup 'QI) #f #f)
+    (dfm 'UHI "16 bit unsigned int" '() 'UINT
+        16 2 "unsigned int" "'x'" (mode:lookup 'HI) #f #f)
+    (dfm 'USI "32 bit unsigned int" '() 'UINT
+        32 4 "unsigned int" "'x'" (mode:lookup 'SI) #f #f)
+    (dfm 'UDI "64 bit unsigned int" '(FN-SUPPORT) 'UINT
+        64 8 "" "'D'" (mode:lookup 'DI) #f #f)
+
+    ; Floating point values.
+    (dfm 'SF "32 bit float" '(FN-SUPPORT) 'FLOAT
+        32 4 "" "'f'" #f #f #f)
+    (dfm 'DF "64 bit float" '(FN-SUPPORT) 'FLOAT
+        64 8 "" "'f'" #f #f #f)
+    (dfm 'XF "80/96 bit float" '(FN-SUPPORT) 'FLOAT
+        96 12 "" "'F'" #f #f #f)
+    (dfm 'TF "128 bit float" '(FN-SUPPORT) 'FLOAT
+        128 16 "" "'F'" #f #f #f)
+
+    ; These are useful modes that represent host values.
+    ; For INT/UINT the sizes indicate maximum portable values.
+    ; These are also used for random width hardware elements (e.g. immediates
+    ; and registers).
+    ; FIXME: Can't be used to represent both host and target values.
+    ; Either remove the distinction or add new modes with the distinction.
+    (dfm 'INT "portable int" '() 'INT 32 4 "int" "'x'"
+        (mode:lookup 'SI) #f #t)
+    (dfm 'UINT "portable unsigned int" '() 'UINT 32 4 "unsigned int" "'x'"
+        (mode:lookup 'SI) #f #t)
+
+    ; ??? Experimental.
+    (dfm 'PTR "host pointer" '() 'RANDOM 0 0 "PTR" "'x'"
+        #f (mode:lookup 'VOID) #t)
+    )
+
+  (set! VOID (mode:lookup 'VOID))
+  (set! DFLT (mode:lookup 'DFLT))
+
+  (set! INT (mode:lookup 'INT))
+  (set! UINT (mode:lookup 'UINT))
+
+  ; To redefine these, use mode:add! again.
+  (set! WI (mode:add! 'WI (mode:lookup 'SI)))
+  (set! UWI (mode:add! 'UWI (mode:lookup 'USI)))
+  (set! AI (mode:add! 'AI (mode:lookup 'USI)))
+  (set! IAI (mode:add! 'IAI (mode:lookup 'USI)))
+
+  *UNSPECIFIED*
+)
+
+(define (mode-finish!)
+  ; Keep the fields sorted for mode-find.
+  (set! mode-list (reverse mode-list))
+
+  (if #f
+  ; ???: Something like this would be nice if it was timed appropriately
+  ; redefine WI/UWI/AI/IAI for this target
+      (case (cpu-word-bitsize (current-cpu))
+       ((32) (begin
+               (display "Recognized 32-bit cpu.\n")))
+       ((64) (begin
+               (display "Recognized 64-bit cpu.\n")
+               (set! WI (mode:add! 'WI (mode:lookup 'DI)))
+               (set! UWI (mode:add! 'UWI (mode:lookup 'UDI)))
+               (set! AI (mode:add! 'AI (mode:lookup 'UDI)))
+               (set! IAI (mode:add! 'IAI (mode:lookup 'UDI)))))
+       (else (error "Unknown word-bitsize for WI/UWI/AI/IAI mode!"))))
+
+  *UNSPECIFIED*
+)
diff --git a/cgen/model.scm b/cgen/model.scm
new file mode 100644 (file)
index 0000000..f57ca55
--- /dev/null
@@ -0,0 +1,304 @@
+; CPU implementation description.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; A model is an implementation of a mach.
+; NOTE: wip [with all the caveats that implies].
+; The intent here is to define the aspects of a CPU that affect performance,
+; usable by any tool (but for the immediate future a simulator).
+
+; Pipeline specification.
+
+(define <pipeline>
+  (class-make '<pipeline> nil '(name comment atlist elms) nil))
+
+(define (pipeline:length p) (length (elm-xget p 'elms)))
+\f
+; Function unit specification.
+
+; FIXME: Might wish to record which pipeline element(s) the unit is associated
+; with.  At the moment pipeline data isn't used, but later.
+
+(define <unit>
+  (class-make '<unit>
+             '(<ident>)
+             '(
+               ; wip
+               issue done
+               ; Lists of (name mode) pairs that record unit state.
+               state
+               ; Lists of (name mode [default-value]).
+               inputs outputs
+               ; RTL of code to invoke to do profiling.
+               ; `nil' means use the default
+               ; ??? Not currently used since all profiling handlers
+               ; are user-written.
+               profile
+               ; Model this unit is associated with.
+               model-name
+               )
+             nil))
+
+; ??? Rather than create a circularity, we record the model's symbol in
+; the `model' element.
+; FIXME: Shouldn't use current-model-lookup.  Guile is better at printing
+; things with circularities now, so should probably put back the circularity
+; and delete the current-model-lookup reference.
+(define (unit:model u) (current-model-lookup (elm-xget u 'model-name)))
+(define unit:issue (elm-make-getter <unit> 'issue))
+(define unit:done (elm-make-getter <unit> 'done))
+(define unit:state (elm-make-getter <unit> 'state))
+(define unit:inputs (elm-make-getter <unit> 'inputs))
+(define unit:outputs (elm-make-getter <unit> 'outputs))
+(define unit:profile (elm-make-getter <unit> 'profile))
+
+; Create a copy of unit U with new values for ISSUE and DONE.
+; This is used when recording an instruction's timing information.
+; ??? This might be better recorded in a different class from UNIT
+; since we're not creating a new unit, we're just special casing it for
+; one instruction.
+; FIXME: No longer used.
+
+(define (unit:make-insn-timing u issue done)
+  (let ((result (object-copy-top u)))
+    (elm-xset! result 'issue issue)
+    (elm-xset! result 'done done)
+    result)
+)
+
+(define (unit:enum u)
+  (gen-c-symbol (string-append "UNIT_"
+                              (string-upcase (obj:name (unit:model u)))
+                              "_"
+                              (string-upcase (obj:name u))))
+)
+\f
+; The `<model>' class.
+;
+; FETCH is the instruction fetch process as it relates to the implementation.
+; e.g.
+; - how many instructions are fetched at once
+; - how those instructions are initially processed for delivery to the
+;   appropriate pipeline
+; RETIRE is used to specify any final processing needed to complete an insn.
+; PIPELINES is a list of pipeline objects.
+; UNITS is a list of function units.
+; STATE is a list of (var mode) pairs.
+;
+; For the more complicated cpus this can get really complicated really fast.
+; No intent is made to get there in one day.
+
+(define <model>
+  (class-make '<model>
+             '(<ident>)
+             '(mach prefetch retire pipelines state units)
+             nil))
+
+(define model:mach (elm-make-getter <model> 'mach))
+(define model:prefetch (elm-make-getter <model> 'prefetch))
+(define model:retire (elm-make-getter <model> 'retire))
+(define model:pipelines (elm-make-getter <model> 'pipelines))
+(define model:state (elm-make-getter <model> 'state))
+(define model:units (elm-make-getter <model> 'units))
+
+(define (model:enum m)
+  (gen-c-symbol (string-append "MODEL_" (string-upcase (obj:name m))))
+)
+\f
+; Parse a `prefetch' spec.
+
+(define (-prefetch-parse errtxt expr)
+  nil
+)
+
+; Parse a `retire' spec.
+
+(define (-retire-parse errtxt expr)
+  nil
+)
+
+; Parse a `pipeline' spec.
+; ??? Perhaps we should also use name/value pairs here, but that's an
+; unnecessary complication at this point in time.
+
+(define (-pipeline-parse errtxt model-name spec) ; name comments attrs elements)
+  (if (not (= (length spec) 4))
+      (parse-error errtxt "pipeline spec not `name comment attrs elements'" spec))
+  (apply make (cons <pipeline> spec))
+)
+
+; Parse a function `unit' spec.
+; ??? Perhaps we should also use name/value pairs here, but that's an
+; unnecessary complication at this point in time.
+
+(define (-unit-parse errtxt model-name spec) ; name comments attrs elements)
+  (if (not (= (length spec) 9))
+      (parse-error errtxt "unit spec not `name comment attrs issue done state inputs outputs profile'" spec))
+  (apply make (append (cons <unit> spec) (list model-name)))
+)
+\f
+; Parse a model definition.
+; This is the main routine for building a model object from a
+; description in the .cpu file.
+; All arguments are in raw (non-evaluated) form.
+
+(define (-model-parse errtxt name comment attrs mach-name prefetch retire pipelines state units)
+  (logit 2 "Processing model " name " ...\n")
+  (let ((name (parse-name name errtxt))
+       ; FIXME: switch to `context' like in cver.
+       (errtxt (string-append errtxt " " name))
+       (mach (current-mach-lookup mach-name)))
+    (if (null? units)
+       (parse-error errtxt "there must be at least one function unit" name))
+    (if mach ; is `mach' being "kept"?
+       (let ((model-obj
+              (make <model>
+                    name
+                    (parse-comment comment errtxt)
+                    (atlist-parse attrs "cpu" errtxt)
+                    mach
+                    (-prefetch-parse errtxt prefetch)
+                    (-retire-parse errtxt retire)
+                    (map (lambda (p) (-pipeline-parse errtxt name p)) pipelines)
+                    state
+                    (map (lambda (u) (-unit-parse errtxt name u)) units))))
+         model-obj)
+       (begin
+         ; MACH wasn't found, ignore this model.
+         (logit 2 "Nonexistant mach " mach-name ", ignoring " name ".\n")
+         #f)))
+)
+
+; Read a model description.
+; This is the main routine for analyzing models in the .cpu file.
+; ERRTXT is prepended to error messages to provide context.
+; ARG-LIST is an associative list of field name and field value.
+; -model-parse is invoked to create the `model' object.
+
+(define (-model-read errtxt . arg-list)
+  (let (; Current mach elements:
+       (name nil)      ; name of model
+       (comment nil)   ; description of model
+       (attrs nil)     ; attributes
+       (mach nil)      ; mach this model implements
+       (prefetch nil)  ; instruction prefetch handling
+       (retire nil)    ; instruction completion handling
+       (pipelines nil) ; list of pipelines
+       (state nil)     ; list of (name mode) pairs to record state
+       (units nil)     ; list of function units
+       )
+    (let loop ((arg-list arg-list))
+      (if (null? arg-list)
+         nil
+         (let ((arg (car arg-list))
+               (elm-name (caar arg-list)))
+           (case elm-name
+             ((name) (set! name (cadr arg)))
+             ((comment) (set! comment (cadr arg)))
+             ((attrs) (set! attrs (cdr arg)))
+             ((mach) (set! mach (cadr arg)))
+             ((prefetch) (set! prefetch (cadr arg)))
+             ((retire) (set! retire (cadr arg)))
+             ((pipeline) (set! pipelines (cons (cdr arg) pipelines)))
+             ((state) (set! state (cdr arg)))
+             ((unit) (set! units (cons (cdr arg) units)))
+             (else (parse-error errtxt "invalid model arg" arg)))
+           (loop (cdr arg-list)))))
+    ; Now that we've identified the elements, build the object.
+    (-model-parse errtxt name comment attrs mach prefetch retire pipelines state units)
+    )
+)
+
+; Define a cpu model object, name/value pair list version.
+
+(define define-model
+  (lambda arg-list
+    (let ((m (apply -model-read (cons "define-model" arg-list))))
+      (if m
+         (current-model-add! m))
+      m))
+)
+\f
+; Instruction timing.
+
+; There is one of these for each model timing description per instruction.
+
+(define <timing> (class-make '<timing> nil '(model units) nil))
+
+(define timing:model (elm-make-getter <timing> 'model))
+(define timing:units (elm-make-getter <timing> 'units))
+
+; timing:units is a list of these.
+; ARGS is a list of (name value) pairs.
+
+(define <iunit> (class-make '<iunit> nil '(unit args) nil))
+
+(define iunit:unit (elm-make-getter <iunit> 'unit))
+(define iunit:args (elm-make-getter <iunit> 'args))
+
+; Return the default unit used by MODEL.
+; ??? For now this is always u-exec.
+
+(define (model-default-unit model)
+  (object-assq 'u-exec (model:units model))
+)
+
+; Subroutine of parse-insn-timing to parse the timing spec for MODEL.
+; The result is a <timing> object.
+
+(define (-insn-timing-parse-model context model spec)
+  (make <timing> model
+       (map (lambda (unit-timing-desc)
+              (let ((type (car unit-timing-desc))
+                    (args (cdr unit-timing-desc)))
+                (case type
+                  ((unit) ; syntax is `unit name (arg1 val1) ...'
+                   (let ((unit (object-assq (car args)
+                                            (model:units model))))
+                     (if (not unit)
+                         (parse-error context "unknown function unit" args))
+                     (make <iunit> unit (cdr args))))
+                  (else (parse-error context "bad unit timing spec"
+                                     unit-timing-desc)))))
+            spec))
+)
+
+; Given the timing information for an instruction return an associative
+; list of timing objects (one for each specified model).
+; INSN-TIMING-DESC is a list of
+; (model1 (unit unit1-name ...) ...) (model2 (unit unit1-name ...) ...) ...
+; Entries for models not included (because the machine wasn't selected)
+; are returned as (model1), i.e. an empty unit list.
+
+(define (parse-insn-timing context insn-timing-desc)
+  (map (lambda (model-timing-desc)
+        (let* ((model-name (car model-timing-desc))
+               (model (current-model-lookup model-name)))
+          (cons model-name
+                (if model
+                    (-insn-timing-parse-model context model
+                                              (cdr model-timing-desc))
+                    ()))))
+       insn-timing-desc)
+)
+\f
+; Called before a .cpu file is read in.
+
+(define (model-init!)
+
+  (reader-add-command! 'define-model
+                      "\
+Define a cpu model, name/value pair list version.
+"
+                      nil 'arg-list define-model
+  )
+
+  *UNSPECIFIED*
+)
+
+; Called after a .cpu file has been read in.
+
+(define (model-finish!)
+  *UNSPECIFIED*
+)
diff --git a/cgen/opc-asmdis.scm b/cgen/opc-asmdis.scm
new file mode 100644 (file)
index 0000000..d3a441c
--- /dev/null
@@ -0,0 +1,182 @@
+; Assembler/disassembler support generator.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+
+; Assembler support.
+
+(define (-gen-parse-switch)
+  (logit 2 "Generating parse switch ...\n")
+  (string-list
+   "\
+/* Main entry point for operand parsing.
+
+   This function is basically just a big switch statement.  Earlier versions
+   used tables to look up the function to use, but
+   - if the table contains both assembler and disassembler functions then
+     the disassembler contains much of the assembler and vice-versa,
+   - there's a lot of inlining possibilities as things grow,
+   - using a switch statement avoids the function call overhead.
+
+   This function could be moved into `parse_insn_normal', but keeping it
+   separate makes clear the interface between `parse_insn_normal' and each of
+   the handlers.
+*/
+
+const char *
+@arch@_cgen_parse_operand (cd, opindex, strp, fields)
+     CGEN_CPU_DESC cd;
+     int opindex;
+     const char ** strp;
+     CGEN_FIELDS * fields;
+{
+  const char * errmsg = NULL;
+  /* Used by scalar operands that still need to be parsed.  */
+  " (gen-ifield-default-type) " junk;
+
+  switch (opindex)
+    {
+"
+   (gen-switch 'parse)
+"
+    default :
+      /* xgettext:c-format */
+      fprintf (stderr, _(\"Unrecognized field %d while parsing.\\n\"), opindex);
+      abort ();
+  }
+
+  return errmsg;
+}\n\n")
+)
+
+; Assembler initialization C code
+; Code is appended during processing.
+
+(define -asm-init-code "")
+(define (add-asm-init code)
+  (set! -asm-init-code (string-append -asm-init-code code))
+)
+
+; Return C code to define the assembler init function.
+; This is called after opcode_open.
+
+(define (-gen-init-asm-fn)
+  (string-append
+   "\
+void
+@arch@_cgen_init_asm (cd)
+     CGEN_CPU_DESC cd;
+{
+  @arch@_cgen_init_opcode_table (cd);
+  @arch@_cgen_init_ibld_table (cd);
+  cd->parse_handlers = & @arch@_cgen_parse_handlers[0];
+  cd->parse_operand = @arch@_cgen_parse_operand;
+"
+   -asm-init-code
+"}\n\n"
+   )
+)
+
+; Generate C code that is inserted into the assembler source.
+
+(define (cgen-asm.in)
+  (logit 1 "Generating " (current-arch-name) "-asm.in ...\n")
+  (string-write
+   ; No need for copyright, appended to file with one.
+   "\n"
+   (lambda () (gen-extra-asm.c srcdir (current-arch-name))) ; from <arch>.opc
+   "\n"
+   -gen-parse-switch
+   (lambda () (gen-handler-table "parse" opc-parse-handlers))
+   -gen-init-asm-fn
+   )
+)
+\f
+; Disassembler support.
+
+(define (-gen-print-switch)
+  (logit 2 "Generating print switch ...\n")
+  (string-list
+   "\
+/* Main entry point for printing operands.
+   XINFO is a `void *' and not a `disassemble_info *' to not put a requirement
+   of dis-asm.h on cgen.h.
+
+   This function is basically just a big switch statement.  Earlier versions
+   used tables to look up the function to use, but
+   - if the table contains both assembler and disassembler functions then
+     the disassembler contains much of the assembler and vice-versa,
+   - there's a lot of inlining possibilities as things grow,
+   - using a switch statement avoids the function call overhead.
+
+   This function could be moved into `print_insn_normal', but keeping it
+   separate makes clear the interface between `print_insn_normal' and each of
+   the handlers.
+*/
+
+void
+@arch@_cgen_print_operand (cd, opindex, xinfo, fields, attrs, pc, length)
+     CGEN_CPU_DESC cd;
+     int opindex;
+     PTR xinfo;
+     CGEN_FIELDS *fields;
+     void const *attrs;
+     bfd_vma pc;
+     int length;
+{
+ disassemble_info *info = (disassemble_info *) xinfo;
+
+  switch (opindex)
+    {
+"
+   (gen-switch 'print)
+"
+    default :
+      /* xgettext:c-format */
+      fprintf (stderr, _(\"Unrecognized field %d while printing insn.\\n\"),
+              opindex);
+    abort ();
+  }
+}\n\n")
+)
+
+; Disassembler initialization C code.
+; Code is appended during processing.
+
+(define -dis-init-code "")
+(define (add-dis-init code)
+  (set! -dis-init-code (string-append -dis-init-code code))
+)
+
+; Return C code to define the disassembler init function.
+
+(define (-gen-init-dis-fn)
+  (string-append
+   "
+void
+@arch@_cgen_init_dis (cd)
+     CGEN_CPU_DESC cd;
+{
+  @arch@_cgen_init_opcode_table (cd);
+  @arch@_cgen_init_ibld_table (cd);
+  cd->print_handlers = & @arch@_cgen_print_handlers[0];
+  cd->print_operand = @arch@_cgen_print_operand;
+"
+   -dis-init-code
+"}\n\n"
+   )
+)
+
+; Generate C code that is inserted into the disassembler source.
+
+(define (cgen-dis.in)
+  (logit 1 "Generating " (current-arch-name) "-dis.in ...\n")
+  (string-write
+   ; No need for copyright, appended to file with one.
+   "\n"
+   (lambda () (gen-extra-dis.c srcdir (current-arch-name))) ; from <arch>.opc
+   "\n"
+   -gen-print-switch
+   (lambda () (gen-handler-table "print" opc-print-handlers))
+   -gen-init-dis-fn
+   )
+)
diff --git a/cgen/opc-ibld.scm b/cgen/opc-ibld.scm
new file mode 100644 (file)
index 0000000..0795187
--- /dev/null
@@ -0,0 +1,319 @@
+; Instruction builder support.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+
+; Instruction field support.
+
+(define (-gen-fget-switch)
+  (logit 2 "Generating field get switch ...\n")
+  (string-list
+   "\
+/* Getting values from cgen_fields is handled by a collection of functions.
+   They are distinguished by the type of the VALUE argument they return.
+   TODO: floating point, inlining support, remove cases where result type
+   not appropriate.  */
+
+int
+@arch@_cgen_get_int_operand (cd, opindex, fields)
+     CGEN_CPU_DESC cd;
+     int opindex;
+     const CGEN_FIELDS * fields;
+{
+  int value;
+
+  switch (opindex)
+    {
+"
+   (gen-switch 'fget)
+"
+    default :
+      /* xgettext:c-format */
+      fprintf (stderr, _(\"Unrecognized field %d while getting int operand.\\n\"),
+                      opindex);
+      abort ();
+  }
+
+  return value;
+}
+
+bfd_vma
+@arch@_cgen_get_vma_operand (cd, opindex, fields)
+     CGEN_CPU_DESC cd;
+     int opindex;
+     const CGEN_FIELDS * fields;
+{
+  bfd_vma value;
+
+  switch (opindex)
+    {
+"
+   (gen-switch 'fget)
+"
+    default :
+      /* xgettext:c-format */
+      fprintf (stderr, _(\"Unrecognized field %d while getting vma operand.\\n\"),
+                      opindex);
+      abort ();
+  }
+
+  return value;
+}
+\n")
+)
+
+(define (-gen-fset-switch)
+  (logit 2 "Generating field set switch ...\n")
+  (string-list
+   "\
+/* Stuffing values in cgen_fields is handled by a collection of functions.
+   They are distinguished by the type of the VALUE argument they accept.
+   TODO: floating point, inlining support, remove cases where argument type
+   not appropriate.  */
+
+void
+@arch@_cgen_set_int_operand (cd, opindex, fields, value)
+     CGEN_CPU_DESC cd;
+     int opindex;
+     CGEN_FIELDS * fields;
+     int value;
+{
+  switch (opindex)
+    {
+"
+   (gen-switch 'fset)
+"
+    default :
+      /* xgettext:c-format */
+      fprintf (stderr, _(\"Unrecognized field %d while setting int operand.\\n\"),
+                      opindex);
+      abort ();
+  }
+}
+
+void
+@arch@_cgen_set_vma_operand (cd, opindex, fields, value)
+     CGEN_CPU_DESC cd;
+     int opindex;
+     CGEN_FIELDS * fields;
+     bfd_vma value;
+{
+  switch (opindex)
+    {
+"
+   (gen-switch 'fset)
+"
+    default :
+      /* xgettext:c-format */
+      fprintf (stderr, _(\"Unrecognized field %d while setting vma operand.\\n\"),
+                      opindex);
+      abort ();
+  }
+}
+\n")
+)
+\f
+; Utilities of cgen-ibld.h.
+
+; Return a list of operands the assembler syntax uses.
+; This is a subset of the fields of the insn.
+
+(define (ifmt-opcode-operands ifmt)
+  (map ifld-get-value
+       (find (lambda (elm) (not (number? (ifld-get-value elm))))
+            (ifmt-ifields ifmt)))
+)
+
+; Subroutine of gen-insn-builders to generate the builder for one insn.
+; FIXME: wip.
+
+(define (gen-insn-builder insn)
+  (let* ((ifmt (insn-ifmt insn))
+        (operands (ifmt-opcode-operands ifmt))
+        (length (ifmt-length ifmt)))
+    (gen-obj-sanitize
+     insn
+     (string-append
+      "#define @ARCH@_IBLD_"
+      (string-upcase (gen-sym insn))
+      "(endian, buf, lenp"
+      (gen-c-args (map obj:name operands))
+      ")\n"
+      "\n")))
+)
+
+(define (gen-insn-builders)
+  (string-write
+   "\
+/* For each insn there is an @ARCH@_IBLD_<NAME> macro that builds the
+   instruction in the supplied buffer.  For architectures where it's
+   possible to represent all machine codes as host integer values it
+   would be nicer to have these return the instruction rather than store
+   it in BUF.  For consistency with variable length ISA's this does not.  */
+
+"
+   (lambda () (string-write-map gen-insn-builder (current-insn-list)))
+   )
+)
+\f
+; Generate the C code for dealing with operands.
+
+(define (-gen-insert-switch)
+  (logit 2 "Generating insert switch ...\n")
+  (string-list
+   "\
+/* Main entry point for operand insertion.
+
+   This function is basically just a big switch statement.  Earlier versions
+   used tables to look up the function to use, but
+   - if the table contains both assembler and disassembler functions then
+     the disassembler contains much of the assembler and vice-versa,
+   - there's a lot of inlining possibilities as things grow,
+   - using a switch statement avoids the function call overhead.
+
+   This function could be moved into `parse_insn_normal', but keeping it
+   separate makes clear the interface between `parse_insn_normal' and each of
+   the handlers.  It's also needed by GAS to insert operands that couldn't be
+   resolved during parsing.
+*/
+
+const char *
+@arch@_cgen_insert_operand (cd, opindex, fields, buffer, pc)
+     CGEN_CPU_DESC cd;
+     int opindex;
+     CGEN_FIELDS * fields;
+     CGEN_INSN_BYTES_PTR buffer;
+     bfd_vma pc;
+{
+  const char * errmsg = NULL;
+  unsigned int total_length = CGEN_FIELDS_BITSIZE (fields);
+
+  switch (opindex)
+    {
+"
+   (gen-switch 'insert)
+"
+    default :
+      /* xgettext:c-format */
+      fprintf (stderr, _(\"Unrecognized field %d while building insn.\\n\"),
+              opindex);
+      abort ();
+  }
+
+  return errmsg;
+}\n\n")
+)
+
+(define (-gen-extract-switch)
+  (logit 2 "Generating extract switch ...\n")
+  (string-list
+   "\
+/* Main entry point for operand extraction.
+   The result is <= 0 for error, >0 for success.
+   ??? Actual values aren't well defined right now.
+
+   This function is basically just a big switch statement.  Earlier versions
+   used tables to look up the function to use, but
+   - if the table contains both assembler and disassembler functions then
+     the disassembler contains much of the assembler and vice-versa,
+   - there's a lot of inlining possibilities as things grow,
+   - using a switch statement avoids the function call overhead.
+
+   This function could be moved into `print_insn_normal', but keeping it
+   separate makes clear the interface between `print_insn_normal' and each of
+   the handlers.
+*/
+
+int
+@arch@_cgen_extract_operand (cd, opindex, ex_info, insn_value, fields, pc)
+     CGEN_CPU_DESC cd;
+     int opindex;
+     CGEN_EXTRACT_INFO *ex_info;
+     CGEN_INSN_INT insn_value;
+     CGEN_FIELDS * fields;
+     bfd_vma pc;
+{
+  /* Assume success (for those operands that are nops).  */
+  int length = 1;
+  unsigned int total_length = CGEN_FIELDS_BITSIZE (fields);
+
+  switch (opindex)
+    {
+"
+   (gen-switch 'extract)
+"
+    default :
+      /* xgettext:c-format */
+      fprintf (stderr, _(\"Unrecognized field %d while decoding insn.\\n\"),
+              opindex);
+      abort ();
+    }
+
+  return length;
+}\n\n")
+)
+\f
+; Utilities of cgen-ibld.in.
+
+; Emit a function to call to initialize the ibld tables.
+
+(define (-gen-ibld-init-fn)
+  (string-write
+   "\
+/* Function to call before using the instruction builder tables.  */
+
+void
+@arch@_cgen_init_ibld_table (cd)
+     CGEN_CPU_DESC cd;
+{
+  cd->insert_handlers = & @arch@_cgen_insert_handlers[0];
+  cd->extract_handlers = & @arch@_cgen_extract_handlers[0];
+
+  cd->insert_operand = @arch@_cgen_insert_operand;
+  cd->extract_operand = @arch@_cgen_extract_operand;
+
+  cd->get_int_operand = @arch@_cgen_get_int_operand;
+  cd->set_int_operand = @arch@_cgen_set_int_operand;
+  cd->get_vma_operand = @arch@_cgen_get_vma_operand;
+  cd->set_vma_operand = @arch@_cgen_set_vma_operand;
+}
+"
+   )
+)
+\f
+; Generate the C header for building instructions.
+
+(define (cgen-ibld.h)
+  (logit 1 "Generating " (current-arch-name) "-ibld.h ...\n")
+  (string-write
+   (gen-copyright "Instruction builder for @arch@."
+                 CURRENT-COPYRIGHT CURRENT-PACKAGE)
+   "\
+#ifndef @ARCH@_IBLD_H
+#define @ARCH@_IBLD_H
+
+"
+   (lambda () (gen-extra-ibld.h srcdir (current-arch-name))) ; from <arch>.opc
+   "\n"
+   gen-insn-builders
+   "
+#endif /* @ARCH@_IBLD_H */
+"
+   )
+)
+
+; Generate the C support for building instructions.
+
+(define (cgen-ibld.in)
+  (logit 1 "Generating " (current-arch-name) "-ibld.in ...\n")
+  (string-write
+   ; No need for copyright, appended to file with one.
+   "\n"
+   -gen-insert-switch
+   -gen-extract-switch
+   (lambda () (gen-handler-table "insert" opc-insert-handlers))
+   (lambda () (gen-handler-table "extract" opc-extract-handlers))
+   -gen-fget-switch
+   -gen-fset-switch
+   -gen-ibld-init-fn
+   )
+)
diff --git a/cgen/opc-itab.scm b/cgen/opc-itab.scm
new file mode 100644 (file)
index 0000000..830b7e0
--- /dev/null
@@ -0,0 +1,724 @@
+; Opcode table support.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+
+; Append code here to be run before insn parsing/etc.
+; These are for internal use and aren't intended to appear in .cpu files.
+; ??? Nothing currently uses them but that might change.
+
+(define parse-init-code "")
+(define insert-init-code "")
+(define extract-init-code "")
+(define print-init-code "")
+
+; Define CGEN_INIT_{PARSE,INSERT,EXTRACT,PRINT} macros.
+; ??? These were early escape hatches.  Not currently used.
+
+(define (-gen-init-macros)
+  (logit 2 "Generating init macros ...\n")
+  (string-append
+   "#define CGEN_INIT_PARSE(od) \\
+{\\\n"
+   parse-init-code
+   "}\n"
+   "#define CGEN_INIT_INSERT(od) \\
+{\\\n"
+   insert-init-code
+   "}\n"
+   "#define CGEN_INIT_EXTRACT(od) \\
+{\\\n"
+   extract-init-code
+   "}\n"
+   "#define CGEN_INIT_PRINT(od) \\
+{\\\n"
+   print-init-code
+   "}\n"
+  )
+)
+\f
+; Instruction field support.
+
+; Return C code to declare various ifield types,decls.
+
+(define (-gen-ifield-decls)
+  (logit 2 "Generating instruction field decls ...\n")
+  (string-append
+   "/* This struct records data prior to insertion or after extraction.  */\n"
+   "struct cgen_fields\n{\n"
+   ; A special member `length' is used to record the length.
+   "  int length;\n"
+   (string-map gen-ifield-value-decl (non-derived-ifields (current-ifld-list)))
+   "};\n\n"
+   )
+)
+\f
+; Instruction syntax support.
+
+; Extract the operand fields in SYNTAX-STRING.
+; The result is a list of operand names.
+; ??? Not currently used, but keep awhile.
+
+(define (extract-syntax-operands syntax)
+  (let loop ((syn syntax) (result nil))
+
+    (cond ((= (string-length syn) 0)
+          (reverse! result))
+
+         ((char=? #\\ (string-ref syn 0))
+          (if (= (string-length syn) 1)
+              (error "missing char after '\\'" syntax))
+          (loop (string-drop 2 syn) result))
+
+         ((char=? #\$ (string-ref syn 0))
+          ; Extract the symbol from the string, which will be the name of
+          ; an operand.  Append it to the result.
+          (if (= (string-length syn) 1)
+              (error "missing operand name" syntax))
+          (if (char=? (string-ref syn 1) #\{)
+              (let ((n (chars-until-delimiter syn #\})))
+                ; Note that 'n' includes the leading ${.
+                (case n
+                  ((0) (error "empty operand name" syntax))
+                  ((#f) (error "missing '}'" syntax))
+                  (else (loop (string-drop (+ n 1) syn)
+                              (cons (string->symbol (substring syn 2 n))
+                                    result)))))
+              (let ((n (id-len (string-drop1 syn))))
+                (if (= n 0)
+                    (error "empty or invalid operand name" syntax))
+                (loop (string-drop (1+ n) syn)
+                      (cons (string->symbol (substring syn 1 (1+ n)))
+                            result)))))
+
+         (else (loop (string-drop1 syn) result))))
+)
+
+; Strip the mnemonic part from SYNTAX.
+; (ie: everything up to but not including the first space or '$')
+; If STRIP-MNEM-OPERANDS?, strip them too.
+
+(define (strip-mnemonic strip-mnem-operands? syntax)
+  (let ((space (string-index syntax #\space)))
+    (if strip-mnem-operands?
+       (if space
+           (string-drop space syntax)
+           "")
+       (let loop ((syn syntax))
+         (if (= (string-length syn) 0)
+             ""
+             (case (string-ref syn 0)
+               ((#\space) syn)
+               ((#\\) (loop (string-drop 2 syn)))
+               ((#\$) syn)
+               (else (loop (string-drop1 syn))))))))
+)
+
+; Compute the sequence of syntax bytes for SYNTAX.
+; STRIP-MNEMONIC? is #t if the mnemonic part is to be stripped off.
+; STRIP-MNEM-OPERANDS? is #t if any mnemonic operands are to be stripped off.
+; SYNTAX is a string of text and operands.
+; OP-MACRO is the macro to call that computes an operand's value.
+; The resulting syntax is expressed as a sequence of bytes.
+; Values < 128 are characters that must be matched.
+; Values >= 128 are 128 + the index into the operand table.
+
+(define (compute-syntax strip-mnemonic? strip-mnem-operands? syntax op-macro)
+  (let ((context "syntax computation")
+       (syntax (if strip-mnemonic?
+                   (strip-mnemonic strip-mnem-operands? syntax)
+                   syntax)))
+
+    (let loop ((syn syntax) (result ""))
+
+      (cond ((= (string-length syn) 0)
+            (string-append result "0"))
+
+           ((char=? #\\ (string-ref syn 0))
+            (if (= (string-length syn) 1)
+                (parse-error context "missing char after '\\'" syntax))
+            (let ((escaped-char (string-ref syn 1))
+                  (remainder (string-drop 2 syn)))
+              (if (char=? #\\ escaped-char)
+                  (loop remainder (string-append result "'\\\\', "))
+                  (loop remainder (string-append result "'" (string escaped-char) "', ")))))
+
+           ((char=? #\$ (string-ref syn 0))
+            ; Extract the symbol from the string, which will be the name of
+            ; an operand.  Append it to the result.
+            (if (= (string-length syn) 1)
+                (parse-error context "missing operand name" syntax))
+            ; Is it $foo or ${foo}?
+            (if (char=? (string-ref syn 1) #\{)
+                (let ((n (chars-until-delimiter syn #\})))
+                  ; Note that 'n' includes the leading ${.
+                  ; FIXME: \} not implemented yet.
+                  (case n
+                    ((0) (parse-error context "empty operand name" syntax))
+                    ((#f) (parse-error context "missing '}'" syntax))
+                    (else (loop (string-drop (+ n 1) syn)
+                                (string-append result op-macro " ("
+                                               (string-upcase
+                                                (gen-c-symbol
+                                                 (substring syn 2 n)))
+                                               "), ")))))
+                (let ((n (id-len (string-drop1 syn))))
+                  (loop (string-drop (1+ n) syn)
+                        (string-append result op-macro " ("
+                                       (string-upcase
+                                        (gen-c-symbol
+                                         (substring syn 1 (1+ n))))
+                                       "), ")))))
+
+           ; Append the character to the result.
+           (else (loop (string-drop1 syn)
+                       (string-append result
+                                      "'" (string-take1 syn) "', "))))))
+)
+
+; Return C code to define the syntax string for SYNTAX
+; MNEM is the C value to use to represent the instruction's mnemonic.
+; OP is the C macro to use to compute an operand's syntax value.
+
+(define (gen-syntax-entry mnem op syntax)
+  (string-append
+   "{ { "
+   mnem ", "
+   ; `mnem' is used to represent the mnemonic, so we always want to strip it
+   ; from the syntax string, regardless of the setting of `strip-mnemonic?'.
+   (compute-syntax #t #f syntax op)
+   " } }")
+)
+\f
+; Instruction format table support.
+
+; Return the table for IFMT, an <iformat> object.
+
+(define (-gen-ifmt-table-1 ifmt)
+  (gen-obj-sanitize
+   (ifmt-eg-insn ifmt) ; sanitize based on the example insn
+   (string-list
+    "static const CGEN_IFMT " (gen-sym ifmt) " = {\n"
+    "  "
+    (number->string (ifmt-mask-length ifmt)) ", "
+    (number->string (ifmt-length ifmt)) ", "
+    "0x" (number->string (ifmt-mask ifmt) 16) ", "
+    "{ "
+    (string-list-map (lambda (ifld)
+                      (string-list "{ F (" (ifld-enum ifld #f) ") }, "))
+                    (ifmt-ifields ifmt))
+    "{ 0 } }\n};\n\n"))
+)
+
+; Generate the insn format table.
+
+(define (-gen-ifmt-table)
+  (string-write
+   "/* Instruction formats.  */\n\n"
+   "#define F(f) & @arch@_cgen_ifld_table[CONCAT2 (@ARCH@_,f)]\n\n"
+   (string-list-map -gen-ifmt-table-1 (current-ifmt-list))
+   "#undef F\n\n"
+   )
+)
+\f
+; Parse/insert/extract/print handlers.
+; Each handler type is recorded in the assembler/disassembler as an array of
+; pointers to functions.  The value recorded in the operand table is the index
+; into this array. The first element in the array is reserved as index 0 is
+; special (the "default").
+;
+; The handlers are recorded here as associative lists in case we ever want
+; to record more than just the name.
+;
+; Adding a new handler involves
+; - specifying its name in the .cpu file
+; - getting its name appended to these tables
+; - writing the C code
+;
+; ??? It might be useful to define the handler in Scheme.  Later.
+
+(define opc-parse-handlers '((insn-normal)))
+(define opc-insert-handlers '((insn-normal)))
+(define opc-extract-handlers '((insn-normal)))
+(define opc-print-handlers '((insn-normal)))
+
+; FIXME: There currently isn't a spot for specifying special handlers for
+; each instruction.  For now assume we always use the same ones.
+
+(define (insn-handlers insn)
+  (string-append
+   (number->string (lookup-index 'insn-normal opc-parse-handlers 0))
+   ", "
+   (number->string (lookup-index 'insn-normal opc-insert-handlers 0))
+   ", "
+   (number->string (lookup-index 'insn-normal opc-extract-handlers 0))
+   ", "
+   (number->string (lookup-index 'insn-normal opc-print-handlers 0))
+   )
+)
+
+; Return C code to define the cgen_opcode_handler struct for INSN.
+; This is intended to be the ultimate escape hatch for the parse/insert/
+; extract/print handlers.  Each entry is an index into a table of handlers.
+; The escape hatch isn't used yet.
+
+(define (gen-insn-handlers insn)
+  (string-append
+   "{ "
+   (insn-handlers insn)
+   " }"
+   )
+)
+
+; Handler table support.
+; There are tables for each of parse/insert/extract/print.
+
+; Return C code to define the handler table for NAME with values VALUES.
+
+(define (gen-handler-table name values)
+  (string-append
+   "cgen_" name "_fn * const @arch@_cgen_" name "_handlers[] = \n{\n"
+   (string-map (lambda (elm)
+                (string-append "  " name "_"
+                               (gen-c-symbol (car elm))
+                               ",\n"))
+              values)
+   "};\n\n"
+   )
+)
+\f
+; Instruction table support.
+
+; Return a declaration of an enum for all insns.
+
+(define (-gen-insn-enum)
+  (logit 2 "Generating instruction enum ...\n")
+  (string-list
+   (gen-enum-decl 'cgen_insn_type "@arch@ instruction types"
+                 "@ARCH@_INSN_"
+                 (cons '(invalid)
+                       (append (gen-obj-list-enums (non-multi-insns (current-insn-list)))
+                               '((max)))))
+   "/* Index of `invalid' insn place holder.  */\n"
+   "#define CGEN_INSN_INVALID @ARCH@_INSN_INVALID\n\n"
+   "/* Total number of insns in table.  */\n"
+   "#define MAX_INSNS ((int) @ARCH@_INSN_MAX)\n\n"
+   )
+)
+
+; Return a reference to the format table entry of INSN.
+
+(define (gen-ifmt-entry insn)
+  (string-append "& " (gen-sym (insn-ifmt insn)))
+)
+
+; Return the definition of an instruction value entry.
+
+(define (gen-ivalue-entry insn)
+  (string-list "{ "
+              "0x" (number->string (insn-value insn) 16)
+              (if #f ; (ifmt-opcodes-beyond-base? (insn-ifmt insn))
+                  (string-list ", { "
+                               ; ??? wip: opcode values beyond the base insn
+                               "0 }")
+                  "")
+              " }")
+)
+
+; Generate an insn opcode entry for INSN.
+; ALL-ATTRS is a list of all instruction attributes.
+; NUM-NON-BOOLS is the number of non-boolean insn attributes.
+
+(define (-gen-insn-opcode-entry insn all-attrs num-non-bools)
+  (gen-obj-sanitize
+   insn
+   (string-list
+    "/* " (insn-syntax insn) " */\n"
+    "  {\n"
+    "    " (gen-insn-handlers insn) ",\n"
+    "    " (gen-syntax-entry "MNEM" "OP" (insn-syntax insn)) ",\n"
+    ; ??? 'twould save space to put a pointer here and record format separately
+    "    " (gen-ifmt-entry insn) ", "
+    ;"0x" (number->string (insn-value insn) 16) ",\n"
+    (gen-ivalue-entry insn) "\n"
+    "  },\n"))
+)
+
+; Generate insn table.
+
+(define (-gen-insn-opcode-table)
+  (logit 2 "Generating instruction opcode table ...\n")
+  (let* ((all-attrs (current-insn-attr-list))
+        (num-non-bools (attr-count-non-bools all-attrs)))
+    (string-write
+     "\
+#define A(a) (1 << CONCAT2 (CGEN_INSN_,a))
+#define MNEM CGEN_SYNTAX_MNEMONIC /* syntax value for mnemonic */
+#define OPERAND(op) CONCAT2 (@ARCH@_OPERAND_,op)
+#define OP(field) CGEN_SYNTAX_MAKE_FIELD (OPERAND (field))
+
+/* The instruction table.  */
+
+static const CGEN_OPCODE @arch@_cgen_insn_opcode_table[MAX_INSNS] =
+{
+  /* Special null first entry.
+     A `num' value of zero is thus invalid.
+     Also, the special `invalid' insn resides here.  */
+  { { 0, 0, 0, 0 }, {{0}}, 0, {0}},\n"
+
+     (lambda ()
+       (string-write-map (lambda (insn)
+                           (logit 3 "Generating insn opcode entry for " (obj:name insn) " ...\n")
+                           (-gen-insn-opcode-entry insn all-attrs
+                                                  num-non-bools))
+                         (non-multi-insns (current-insn-list))))
+
+     "\
+};
+
+#undef A
+#undef MNEM
+#undef OPERAND
+#undef OP
+
+"
+     )
+    )
+)
+\f
+; Return assembly/disassembly hashing support.
+
+(define (-gen-hash-fns)
+  (string-list
+   "\
+#ifndef CGEN_ASM_HASH_P
+#define CGEN_ASM_HASH_P(insn) 1
+#endif
+
+#ifndef CGEN_DIS_HASH_P
+#define CGEN_DIS_HASH_P(insn) 1
+#endif
+
+/* Return non-zero if INSN is to be added to the hash table.
+   Targets are free to override CGEN_{ASM,DIS}_HASH_P in the .opc file.  */
+
+static int
+asm_hash_insn_p (insn)
+     const CGEN_INSN *insn;
+{
+  return CGEN_ASM_HASH_P (insn);
+}
+
+static int
+dis_hash_insn_p (insn)
+     const CGEN_INSN *insn;
+{
+  /* If building the hash table and the NO-DIS attribute is present,
+     ignore.  */
+  if (CGEN_INSN_ATTR_VALUE (insn, CGEN_INSN_NO_DIS))
+    return 0;
+  return CGEN_DIS_HASH_P (insn);
+}
+
+#ifndef CGEN_ASM_HASH
+#define CGEN_ASM_HASH_SIZE 127
+#ifdef CGEN_MNEMONIC_OPERANDS
+#define CGEN_ASM_HASH(mnem) (*(unsigned char *) (mnem) % CGEN_ASM_HASH_SIZE)
+#else
+#define CGEN_ASM_HASH(mnem) (*(unsigned char *) (mnem) % CGEN_ASM_HASH_SIZE) /*FIXME*/
+#endif
+#endif
+
+/* It doesn't make much sense to provide a default here,
+   but while this is under development we do.
+   BUFFER is a pointer to the bytes of the insn, target order.
+   VALUE is the first base_insn_bitsize bits as an int in host order.  */
+
+#ifndef CGEN_DIS_HASH
+#define CGEN_DIS_HASH_SIZE 256
+#define CGEN_DIS_HASH(buf, value) (*(unsigned char *) (buf))
+#endif
+
+/* The result is the hash value of the insn.
+   Targets are free to override CGEN_{ASM,DIS}_HASH in the .opc file.  */
+
+static unsigned int
+asm_hash_insn (mnem)
+     const char * mnem;
+{
+  return CGEN_ASM_HASH (mnem);
+}
+
+/* BUF is a pointer to the bytes of the insn, target order.
+   VALUE is the first base_insn_bitsize bits as an int in host order.  */
+
+static unsigned int
+dis_hash_insn (buf, value)
+     const char * buf;
+     CGEN_INSN_INT value;
+{
+  return CGEN_DIS_HASH (buf, value);
+}
+\n"
+   )
+)
+
+; Hash support decls.
+
+(define (-gen-hash-decls)
+  (string-list
+   "\
+/* The hash functions are recorded here to help keep assembler code out of
+   the disassembler and vice versa.  */
+
+static int asm_hash_insn_p PARAMS ((const CGEN_INSN *));
+static unsigned int asm_hash_insn PARAMS ((const char *));
+static int dis_hash_insn_p PARAMS ((const CGEN_INSN *));
+static unsigned int dis_hash_insn PARAMS ((const char *, CGEN_INSN_INT));
+\n"
+   )
+)
+\f
+; Macro insn support.
+
+; Return a macro-insn expansion entry.
+
+(define (-gen-miexpn-entry entry)
+   ; FIXME: wip
+  "0, "
+)
+
+; Return a macro-insn table entry.
+; ??? wip, not currently used.
+
+(define (-gen-minsn-table-entry minsn all-attrs num-non-bools)
+  (gen-obj-sanitize
+   minsn
+   (string-list
+    "  /* " (minsn-syntax minsn) " */\n"
+    "  {\n"
+    "    "
+    "-1, " ; macro-insns are not currently enumerated, no current need to
+    "\"" (obj:name minsn) "\", "
+    "\"" (minsn-mnemonic minsn) "\",\n"
+    "    " (gen-syntax-entry "MNEM" "OP" (minsn-syntax minsn)) ",\n"
+    "    (PTR) & macro_" (gen-sym minsn) "_expansions[0],\n"
+    "    "
+    (gen-obj-attr-defn 'minsn minsn all-attrs num-non-bools gen-insn-attr-mask)
+    "\n"
+    "  },\n"))
+)
+
+; Return a macro-insn opcode table entry.
+; ??? wip, not currently used.
+
+(define (-gen-minsn-opcode-entry minsn all-attrs num-non-bools)
+  (gen-obj-sanitize
+   minsn
+   (string-list
+    "  /* " (minsn-syntax minsn) " */\n"
+    "  {\n"
+    "    "
+    "-1, " ; macro-insns are not currently enumerated, no current need to
+    "\"" (obj:name minsn) "\", "
+    "\"" (minsn-mnemonic minsn) "\",\n"
+    "    " (gen-syntax-entry "MNEM" "OP" (minsn-syntax minsn)) ",\n"
+    "    (PTR) & macro_" (gen-sym minsn) "_expansions[0],\n"
+    "    "
+    (gen-obj-attr-defn 'minsn minsn all-attrs num-non-bools gen-insn-attr-mask)
+    "\n"
+    "  },\n"))
+)
+
+; Macro insn expansion has one basic form, but we optimize the common case
+; of unconditionally expanding the input text to one instruction.
+; The general form is a Scheme expression that is interpreted at runtime to
+; decide how to perform the expansion.  Yes, that means having a (perhaps
+; minimal) Scheme interpreter in the assembler.
+; Another thing to do is have a builder for each real insn so instead of
+; expanding to text, the macro-expansion could invoke the builder for each
+; expanded-to insn.
+
+(define (-gen-macro-insn-table)
+  (logit 2 "Generating macro-instruction table ...\n")
+  (let* ((minsn-list (map (lambda (minsn)
+                           (if (has-attr? minsn 'ALIAS)
+                               (minsn-make-alias "gen-macro-insn-table" minsn)
+                               minsn))
+                         (current-minsn-list)))
+        (all-attrs (current-insn-attr-list))
+        (num-non-bools (attr-count-non-bools all-attrs)))
+    (string-write
+     "/* Formats for ALIAS macro-insns.  */\n\n"
+     "#define F(f) & @arch@_cgen_ifld_table[CONCAT2 (@ARCH@_,f)]\n\n"
+     (lambda ()
+       (string-write-map -gen-ifmt-table-1
+                        (map insn-ifmt (find (lambda (minsn)
+                                               (has-attr? minsn 'ALIAS))
+                                             minsn-list))))
+     "#undef F\n\n"
+     "/* Each non-simple macro entry points to an array of expansion possibilities.  */\n\n"
+     (lambda () 
+       (string-write-map (lambda (minsn)
+                          (if (has-attr? minsn 'ALIAS)
+                              ""
+                              (string-append
+                               "static const CGEN_MINSN_EXPANSION macro_" (gen-sym minsn) "_expansions[] =\n"
+                               "{\n"
+                               (string-map -gen-miexpn-entry
+                                           (minsn-expansions minsn))
+                               "  { 0, 0 }\n};\n\n")))
+                        minsn-list))
+     "\
+#define A(a) (1 << CONCAT2 (CGEN_INSN_,a))
+#define MNEM CGEN_SYNTAX_MNEMONIC /* syntax value for mnemonic */
+#define OPERAND(op) CONCAT2 (@ARCH@_OPERAND_,op)
+#define OP(field) CGEN_SYNTAX_MAKE_FIELD (OPERAND (field))
+
+/* The macro instruction table.  */
+
+static const CGEN_IBASE @arch@_cgen_macro_insn_table[] =
+{
+"
+     (lambda ()
+       (string-write-map (lambda (minsn)
+                          (logit 3 "Generating macro-insn table entry for " (obj:name minsn) " ...\n")
+                          ; Simple macro-insns are emitted as aliases of real insns.
+                          (if (has-attr? minsn 'ALIAS)
+                              (gen-insn-table-entry minsn all-attrs num-non-bools)
+                              (-gen-minsn-table-entry minsn all-attrs num-non-bools)))
+                        minsn-list))
+     "\
+};
+
+/* The macro instruction opcode table.  */
+
+static const CGEN_OPCODE @arch@_cgen_macro_insn_opcode_table[] =
+{\n"
+     (lambda ()
+       (string-write-map (lambda (minsn)
+                          (logit 3 "Generating macro-insn table entry for " (obj:name minsn) " ...\n")
+                          ; Simple macro-insns are emitted as aliases of real insns.
+                          (if (has-attr? minsn 'ALIAS)
+                              (-gen-insn-opcode-entry minsn all-attrs num-non-bools)
+                              (-gen-minsn-opcode-entry minsn all-attrs num-non-bools)))
+                        minsn-list))
+     "\
+};
+
+#undef A
+#undef MNEM
+#undef OPERAND
+#undef OP
+\n"
+    ))
+)
+\f
+; Emit a function to call to initialize the opcode table.
+
+(define (-gen-opcode-init-fn)
+  (string-write
+   "\
+/* Set the recorded length of the insn in the CGEN_FIELDS struct.  */
+
+static void
+set_fields_bitsize (fields, size)
+     CGEN_FIELDS *fields;
+     int size;
+{
+  CGEN_FIELDS_BITSIZE (fields) = size;
+}
+
+/* Function to call before using the operand instance table.
+   This plugs the opcode entries and macro instructions into the cpu table.  */
+
+void
+@arch@_cgen_init_opcode_table (cd)
+     CGEN_CPU_DESC cd;
+{
+  int i;
+  int num_macros = (sizeof (@arch@_cgen_macro_insn_table) /
+                   sizeof (@arch@_cgen_macro_insn_table[0]));
+  const CGEN_IBASE *ib = & @arch@_cgen_macro_insn_table[0];
+  const CGEN_OPCODE *oc = & @arch@_cgen_macro_insn_opcode_table[0];
+  CGEN_INSN *insns = (CGEN_INSN *) xmalloc (num_macros * sizeof (CGEN_INSN));
+  memset (insns, 0, num_macros * sizeof (CGEN_INSN));
+  for (i = 0; i < num_macros; ++i)
+    {
+      insns[i].base = &ib[i];
+      insns[i].opcode = &oc[i];
+    }
+  cd->macro_insn_table.init_entries = insns;
+  cd->macro_insn_table.entry_size = sizeof (CGEN_IBASE);
+  cd->macro_insn_table.num_init_entries = num_macros;
+
+  oc = & @arch@_cgen_insn_opcode_table[0];
+  insns = (CGEN_INSN *) cd->insn_table.init_entries;
+  for (i = 0; i < MAX_INSNS; ++i)
+    insns[i].opcode = &oc[i];
+
+  cd->sizeof_fields = sizeof (CGEN_FIELDS);
+  cd->set_fields_bitsize = set_fields_bitsize;
+
+  cd->asm_hash_p = asm_hash_insn_p;
+  cd->asm_hash = asm_hash_insn;
+  cd->asm_hash_size = CGEN_ASM_HASH_SIZE;
+
+  cd->dis_hash_p = dis_hash_insn_p;
+  cd->dis_hash = dis_hash_insn;
+  cd->dis_hash_size = CGEN_DIS_HASH_SIZE;
+}
+"
+   )
+)
+\f
+; Top level C code generators
+
+; FIXME: Create enum objects for all the enums we explicitly declare here.
+; Then they'd be usable and we wouldn't have to special case them here.
+
+(define (cgen-opc.h)
+  (logit 1 "Generating " (current-arch-name) "-opc.h ...\n")
+  (string-write
+   (gen-copyright "Instruction opcode header for @arch@."
+                 CURRENT-COPYRIGHT CURRENT-PACKAGE)
+   "\
+#ifndef @ARCH@_OPC_H
+#define @ARCH@_OPC_H
+
+"
+   (lambda () (gen-extra-opc.h srcdir (current-arch-name))) ; from <arch>.opc
+   -gen-insn-enum
+   -gen-ifield-decls
+   -gen-init-macros
+   "
+
+#endif /* @ARCH@_OPC_H */
+"
+   )
+)
+
+; This file contains the instruction opcode table.
+
+(define (cgen-opc.c)
+  (logit 1 "Generating " (current-arch-name) "-opc.c ...\n")
+  (string-write
+   (gen-copyright "Instruction opcode table for @arch@."
+                 CURRENT-COPYRIGHT CURRENT-PACKAGE)
+   "\
+#include \"sysdep.h\"
+#include \"ansidecl.h\"
+#include \"bfd.h\"
+#include \"symcat.h\"
+#include \"@prefix@-desc.h\"
+#include \"@prefix@-opc.h\"
+#include \"libiberty.h\"
+\n"
+   (lambda () (gen-extra-opc.c srcdir (current-arch-name))) ; from <arch>.opc
+   -gen-hash-decls
+   -gen-ifmt-table
+   -gen-insn-opcode-table
+   -gen-macro-insn-table
+   -gen-hash-fns
+   -gen-opcode-init-fn
+   )
+)
diff --git a/cgen/opc-opinst.scm b/cgen/opc-opinst.scm
new file mode 100644 (file)
index 0000000..b763928
--- /dev/null
@@ -0,0 +1,168 @@
+; Operand instance support.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+
+; Return C code to define one instance of operand object OP.
+; TYPE is one of "INPUT" or "OUTPUT".
+
+(define (-gen-operand-instance op type)
+  (let ((index (op:index op)))
+    (string-append "  { "
+                  type ", "
+                  "\"" (gen-sym op) "\", "
+                  (hw-enum (op:type op)) ", "
+                  ; FIXME: Revisit CGEN_ prefix, use MODE (FOO) instead.
+                  "CGEN_" (mode:enum (op:mode op)) ", "
+                  ; FIXME: We don't handle memory properly yet.  Later.
+                  (cond ((memory? (op:type op))
+                         "0, 0")
+                        ((has-attr? op 'SEM-ONLY)
+                         "0, 0")
+                        ((eq? (hw-index:type index) 'ifield)
+                         (if (= (ifld-length (hw-index:value index)) 0)
+                             "0, 0"
+                             (string-append "OP_ENT ("
+                                            (string-upcase (gen-sym op))
+                                            "), 0")))
+                        ((eq? (hw-index:type index) 'constant)
+                         (string-append "0, "
+                                        (number->string (hw-index:value index))))
+                        (else "0, 0"))
+                  ", " (if (op:cond? op) "COND_REF" "0")
+                  " },\n"))
+)
+
+; Return C code to define arrays of operand instances read from and written
+; to by <sformat> SFMT.
+; This is based on the semantics of the instruction.
+; ??? All runtime chosen values (e.g. a particular register in a register bank)
+; is assumed to be selected statically by the instruction.  When some cpu
+; violates this assumption (say because a previous instruction determines
+; which register(s) the next instruction operates on), this will need
+; additional support.
+
+(define (-gen-operand-instance-table sfmt)
+  (let ((ins (sfmt-in-ops sfmt))
+       (outs (sfmt-out-ops sfmt)))
+    ; This used to exclude outputing anything if there were no ins or outs.
+    (gen-obj-sanitize
+     (sfmt-eg-insn sfmt) ; sanitize based on the example insn
+     (string-append
+      "static const CGEN_OPINST "
+      (gen-sym sfmt) "_ops[] = {\n"
+      (string-map (lambda (op) (-gen-operand-instance op "INPUT"))
+                 ins)
+      (string-map (lambda (op)  (-gen-operand-instance op "OUTPUT"))
+                 outs)
+      "  { END }\n};\n\n")))
+)
+
+(define (-gen-operand-instance-tables)
+  (string-write
+   "\
+/* Operand references.  */
+
+#define INPUT CGEN_OPINST_INPUT
+#define OUTPUT CGEN_OPINST_OUTPUT
+#define END CGEN_OPINST_END
+#define COND_REF CGEN_OPINST_COND_REF
+#define OP_ENT(op) CONCAT2 (@ARCH@_OPERAND_,op)
+
+"
+   (lambda () (string-write-map -gen-operand-instance-table (current-sfmt-list)))
+   "\
+#undef INPUT
+#undef OUTPUT
+#undef END
+#undef COND_REF
+#undef OP_ENT
+
+"
+   )
+)
+
+; Return C code for INSN's operand instance table.
+
+(define (gen-operand-instance-ref insn)
+  (let* ((sfmt (insn-sfmt insn))
+        (ins (sfmt-in-ops sfmt))
+        (outs (sfmt-out-ops sfmt)))
+    (if (and (null? ins) (null? outs))
+       "0"
+       (string-append "& " (gen-sym sfmt) "_ops[0]")))
+)
+
+; Return C code to define a table to lookup an insn's operand instance table.
+
+(define (-gen-insn-opinst-lookup-table)
+  (string-list
+   "/* Operand instance lookup table.  */\n\n"
+   "static const CGEN_OPINST *@arch@_cgen_opinst_table[MAX_INSNS] = {\n"
+   "  0,\n" ; null first entry
+   (string-list-map
+    (lambda (insn)
+      (gen-obj-sanitize
+       insn
+       (string-append "  & " (gen-sym (insn-sfmt insn)) "_ops[0],\n")))
+    (current-insn-list))
+   "};\n\n"
+   "\
+/* Function to call before using the operand instance table.  */
+
+void
+@arch@_cgen_init_opinst_table (cd)
+     CGEN_CPU_DESC cd;
+{
+  int i;
+  const CGEN_OPINST **oi = & @arch@_cgen_opinst_table[0];
+  CGEN_INSN *insns = (CGEN_INSN *) cd->insn_table.init_entries;
+  for (i = 0; i < MAX_INSNS; ++i)
+    insns[i].opinst = oi[i];
+}
+"
+   )
+)
+
+; Return the maximum number of operand instances used by any insn.
+; If not generating the operand instance table, use a heuristic.
+
+(define (max-operand-instances)
+  (if -opcodes-build-operand-instance-table?
+      (apply max
+            (map (lambda (insn)
+                   (+ (length (sfmt-in-ops (insn-sfmt insn)))
+                      (length (sfmt-out-ops (insn-sfmt insn)))))
+                 (current-insn-list)))
+      8) ; FIXME: for now
+)
+
+; Generate $arch-opinst.c.
+
+(define (cgen-opinst.c)
+  (logit 1 "Generating " (current-arch-name) "-opinst.c ...\n")
+
+  ; If instruction semantics haven't been analyzed, do that now.
+  (if (not (arch-semantics-analyzed? CURRENT-ARCH))
+      (begin
+       (logit 1 "Instruction semantics weren't analyzed when .cpu file was loaded.\n")
+       (logit 1 "Doing so now ...\n")
+       (arch-analyze-insns! CURRENT-ARCH
+                            #t ; include aliases
+                            #t) ; -opcodes-build-operand-instance-table?
+       ))
+
+  (string-write
+   (gen-copyright "Semantic operand instances for @arch@."
+                 CURRENT-COPYRIGHT CURRENT-PACKAGE)
+   "\
+#include \"sysdep.h\"
+#include \"ansidecl.h\"
+#include \"bfd.h\"
+#include \"symcat.h\"
+#include \"@prefix@-desc.h\"
+#include \"@prefix@-opc.h\"
+\n"
+   -gen-operand-instance-tables
+   -gen-insn-opinst-lookup-table
+   )
+)
diff --git a/cgen/opcodes.scm b/cgen/opcodes.scm
new file mode 100644 (file)
index 0000000..f5ed26f
--- /dev/null
@@ -0,0 +1,804 @@
+; General cpu info generator support.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+
+; Global state variables.
+
+; Specify which application.
+(set! APPLICATION 'OPCODES)
+
+; Boolean indicating if we're to build the operand instance table.
+; The default is no, since only the m32r uses it at present.
+; ??? Simulator tracing support could use it.
+; ??? Might be lazily built at runtime by parsing the semantic code
+; (which would be recorded in the insn table).
+(define -opcodes-build-operand-instance-table? #f)
+
+; String containing copyright text.
+(define CURRENT-COPYRIGHT #f)
+
+; String containing text defining the package we're generating code for.
+(define CURRENT-PACKAGE #f)
+
+; Initialize the options.
+
+(define (option-init!)
+  (set! -opcodes-build-operand-instance-table? #f)
+  (set! CURRENT-COPYRIGHT copyright-fsf)
+  (set! CURRENT-PACKAGE package-gnu-binutils-gdb)
+  *UNSPECIFIED*
+)
+
+; Handle an option passed in from the command line.
+
+(define (option-set! name value)
+  (case name
+    ((opinst) (set! -opcodes-build-operand-instance-table? #t))
+    ((copyright) (cond ((equal?  value '("fsf"))
+                       (set! CURRENT-COPYRIGHT copyright-fsf))
+                      ((equal? value '("cygnus"))
+                       (set! CURRENT-COPYRIGHT copyright-cygnus))
+                      (else (error "invalid copyright value" value))))
+    ((package) (cond ((equal?  value '("binutils"))
+                     (set! CURRENT-PACKAGE package-gnu-binutils-gdb))
+                    ((equal?  value '("gnusim"))
+                     (set! CURRENT-PACKAGE package-gnu-simulators))
+                    ((equal? value '("cygsim"))
+                     (set! CURRENT-PACKAGE package-cygnus-simulators))
+                    (else (error "invalid package value" value))))
+    (else (error "unknown option" name))
+    )
+  *UNSPECIFIED*
+)
+\f
+; Instruction fields support code.
+
+; Default type of variable to use to hold ifield value.
+
+(define (gen-ifield-default-type)
+  ; FIXME: Use long for now.
+  "long"
+)
+
+; Given field F, return a C definition of a variable big enough to hold
+; its value.
+
+(define (gen-ifield-value-decl f)
+  (gen-obj-sanitize f (string-append "  "
+                                    (gen-ifield-default-type)
+                                    " " (gen-sym f) ";\n"))
+)
+
+; Return name of function to call to insert the value of <ifield> F
+; into an insn.
+
+(define (ifld-insert-fn-name f)
+  "insert_normal"
+)
+
+; Return name of function to call to extract the value of <ifield> F
+; into an insn.
+
+(define (ifld-extract-fn-name f)
+  "extract_normal"
+)
+
+; Default routine to emit C code to insert a field in an insn.
+
+(method-make!
+ <ifield> 'gen-insert
+ (lambda (self operand)
+   (let* ((encode (elm-get self 'encode))
+         (need-extra? encode) ; use to also handle operand's `insert' field
+         (varname (gen-operand-result-var self)))
+     (string-append
+      (if need-extra?
+         (string-append "      {\n"
+                        "        "
+                        (gen-ifield-default-type)
+                        " value = " varname ";\n")
+         "")
+      (if encode
+         (string-append "        value = "
+                        (let ((expr (cadr encode))
+                              (value (caar encode))
+                              (pc (cadar encode)))
+                          (rtl-c DFLT expr
+                                 (list (list value (obj:name (ifld-encode-mode self)) "value")
+                                       (list pc 'IAI "pc"))))
+                        ";\n")
+         "")
+      (if need-extra?
+         "  "
+         "")
+      "      errmsg = "
+      (ifld-insert-fn-name self)
+      " (cd, "
+      (if need-extra?
+         "value"
+         varname)
+      ", "
+      ; We explicitly pass the attributes here rather than look them up
+      ; to give the code more optimization opportunities.
+      ; ??? Maybe when fields are recorded in opc.c, stop doing this, and
+      ; pass a pointer to the recorded attributes instead.
+      (gen-bool-attrs (if (eq? (mode:class (ifld-mode self)) 'INT)
+                         (atlist-cons (bool-attr-make 'SIGNED #t)
+                                      (obj-atlist self))
+                         (obj-atlist self))
+                     gen-attr-mask)
+      ", " (number->string (ifld-word-offset self))
+      ", " (number->string (ifld-start self #f))
+      ", " (number->string (ifld-length self))
+      ", " (number->string (ifld-word-length self))
+      ", total_length"
+      ", buffer"
+      ");\n"
+      (if need-extra?
+         "      }\n"
+         "")
+      )))
+)
+
+; Default routine to emit C code to extract a field from an insn.
+
+(method-make!
+ <ifield> 'gen-extract
+ (lambda (self operand)
+   (let* ((decode (elm-get self 'decode))
+         (need-extra? decode) ; use to also handle operand's `extract' field
+         (varname (gen-operand-result-var self)))
+     (string-append
+      (if need-extra?
+         (string-append "      {\n        "
+                        (gen-ifield-default-type)
+                        " value;\n  ")
+         "")
+      "      length = "
+      (ifld-extract-fn-name self)
+      " (cd, ex_info, insn_value, "
+      ; We explicitly pass the attributes here rather than look them up
+      ; to give the code more optimization opportunities.
+      ; ??? Maybe when fields are recorded in opc.c, stop doing this, and
+      ; pass a pointer to the recorded attributes instead.
+      (gen-bool-attrs (if (eq? (mode:class (ifld-mode self)) 'INT)
+                         (atlist-cons (bool-attr-make 'SIGNED #t)
+                                      (obj-atlist self))
+                         (obj-atlist self))
+                     gen-attr-mask)
+      ", " (number->string (ifld-word-offset self))
+      ", " (number->string (ifld-start self #f))
+      ", " (number->string (ifld-length self))
+      ", " (number->string (ifld-word-length self))
+      ", total_length"
+      ", pc"
+      ", & "
+      (if need-extra?
+         "value"
+         varname)
+      ");\n"
+      (if decode
+         (string-append "        value = "
+                        (let ((expr (cadr decode))
+                              (value (caar decode))
+                              (pc (cadar decode)))
+                          (rtl-c DFLT expr
+                                 (list (list value (obj:name (ifld-decode-mode self)) "value")
+                                       (list pc 'IAI "pc"))))
+                        ";\n")
+         "")
+      (if need-extra?
+         (string-append "        " varname " = value;\n"
+                        "      }\n")
+         "")
+      )))
+)
+
+; gen-insert of multi-ifields
+
+(method-make!
+ <multi-ifield> 'gen-insert
+ (lambda (self operand)
+   (let* ((varname (gen-operand-result-var self))
+         (encode (elm-get self 'encode))
+         (need-extra? encode))
+     (string-list
+      "      {\n"
+      (if need-extra?
+         (string-append "        " varname " = "
+                        (let ((expr (cadr encode))
+                              (value (caar encode))
+                              (pc (cadar encode)))
+                          (rtl-c DFLT expr
+                                 (list (list value (obj:name (ifld-encode-mode self)) varname)
+                                       (list pc 'IAI "pc"))))
+                        ";\n")
+         "")
+      (let ((expr (elm-get self 'insert)))
+       (rtl-c VOID expr nil))
+      (string-list-map (lambda (subfld)
+                        (string-list
+                         "  "
+                         (send subfld 'gen-insert operand)
+                         "        if (errmsg)\n"
+                         "          break;\n"))
+                      (elm-get self 'subfields))
+      "      }\n"
+      )))
+)
+
+; gen-insert of derived-operands
+
+(method-make!
+ <derived-operand> 'gen-insert
+ (lambda (self operand)
+   "      abort();\n")
+)
+
+; gen-extract of multi-ifields
+
+(method-make!
+ <multi-ifield> 'gen-extract
+ (lambda (self operand)
+   (let* ((varname (gen-operand-result-var self))
+         (decode (elm-get self 'decode))
+         (need-extra? decode))
+     (string-list
+      "      {\n"
+      (string-list-map (lambda (subfld)
+                        (string-list
+                         "  "
+                         (send subfld 'gen-extract operand)
+                         "        if (length <= 0) break;\n"
+                         ))
+                      (elm-get self 'subfields))
+      (let ((expr (elm-get self 'extract)))
+       (rtl-c VOID expr nil))
+      (if need-extra?
+         (string-append "        " varname " = "
+                        (let ((expr (cadr decode))
+                              (value (caar decode))
+                              (pc (cadar decode)))
+                          (rtl-c DFLT expr
+                                 (list (list value (obj:name (ifld-decode-mode self)) varname)
+                                       (list pc 'IAI "pc"))))
+                        ";\n")
+         "")
+      "      }\n"
+      )))
+)
+
+
+(method-make!
+ <derived-operand> 'gen-extract
+ (lambda (self operand)
+   "      abort();\n")
+)
+
+;(method-make!
+; <derived-operand> 'gen-extract
+; (lambda (self operand)
+;   (string-list
+;    "      {\n"
+;    (string-list-map (lambda (subop)
+;                     (string-list
+;                      "  " (send subop 'gen-extract operand)
+;                      "        if (length <= 0)\n"
+;                      "          break;\n"))
+;                   (elm-get self 'args))
+;    "      }\n"
+;    ))
+;)
+
+\f
+; Hardware index support code.
+
+(method-make!
+ <hw-index> 'gen-insert
+ (lambda (self operand)
+   (case (hw-index:type self)
+     ((ifield)
+      (send (hw-index:value self) 'gen-insert operand))
+     (else
+      "")))
+)
+
+(method-make!
+ <hw-index> 'gen-extract
+ (lambda (self operand)
+   (case (hw-index:type self)
+     ((ifield)
+      (send (hw-index:value self) 'gen-extract operand))
+     (else
+      ""))))
+\f
+; HW-ASM is the base class for supporting hardware elements in the opcode table
+; (aka assembler/disassembler).
+
+; Utility to return C code to parse a number of <mode> MODE for an operand.
+; RESULT-VAR-NAME is a string containing the variable to store the
+; parsed number in.
+; PARSE-FN is the name of the function to call or #f to use the default.
+; OP-ENUM is the enum of the operand.
+
+(define (-gen-parse-number mode parse-fn op-enum result-var-name)
+  (string-append
+   "      errmsg = "
+   ; Use operand's special parse function if there is one, otherwise compute
+   ; the function's name from the mode.
+   (or parse-fn
+       (case (obj:name mode)
+        ((QI HI SI INT) "cgen_parse_signed_integer")
+        ((BI UQI UHI USI UINT) "cgen_parse_unsigned_integer")
+        (else (error "unsupported (as yet) mode for parsing"
+                     (obj:name mode)))))
+   " (cd, strp, "
+   op-enum
+   ", &" result-var-name
+   ");\n"
+   )
+)
+
+; Utility to return C code to parse an address.
+; RESULT-VAR-NAME is a string containing the variable to store the
+; parsed number in.
+; PARSE-FN is the name of the function to call or #f to use the default.
+; OP-ENUM is the enum of the operand.
+
+(define (-gen-parse-address parse-fn op-enum result-var-name)
+  (string-append
+   "      {\n"
+   "        bfd_vma value;\n"
+   "        errmsg = "
+   ; Use operand's special parse function if there is one.
+   (or parse-fn
+       "cgen_parse_address")
+   " (cd, strp, "
+   op-enum
+   ", 0, " ; opinfo arg
+   "NULL, " ; result_type arg (FIXME)
+   " & value);\n"
+   "        " result-var-name " = value;\n"
+   "      }\n"
+   )
+)
+
+; Return C code to parse an expression.
+
+(method-make!
+ <hw-asm> 'gen-parse
+ (lambda (self operand)
+   (let ((mode (elm-get self 'mode))
+        (result-var
+         (case (hw-index:type (op:index operand))
+           ((ifield) (gen-operand-result-var (op-ifield operand)))
+           (else "junk"))))
+     (if (address? (op:type operand))
+        (-gen-parse-address (send operand 'gen-function-name 'parse)
+                            (op-enum operand)
+                            result-var)
+        (-gen-parse-number mode (send operand 'gen-function-name 'parse)
+                           (op-enum operand)
+                           result-var))))
+)
+
+; Default method to emit C code to print a hardware element.
+
+(method-make!
+ <hw-asm> 'gen-print
+ (lambda (self operand)
+   (let ((value
+         (case (hw-index:type (op:index operand))
+           ((ifield) (gen-operand-result-var (op-ifield operand)))
+           (else "0"))))
+     (string-append
+      "      "
+      (or (send operand 'gen-function-name 'print)
+         (and (address? (op:type operand))
+              "print_address")
+         "print_normal")
+;    (or (send operand 'gen-function-name 'print)
+;      (case (obj:name (elm-get self 'mode))
+;        ((QI HI SI INT) "print_signed")
+;        ((BI UQI UHI USI UINT) "print_unsigned")
+;        (else (error "unsupported (as yet) mode for printing"
+;                     (obj:name (elm-get self 'mode))))))
+      " (cd, info, "
+      value
+      ", "
+      ; We explicitly pass the attributes here rather than look them up
+      ; to give the code more optimization opportunities.
+      (gen-bool-attrs (if (eq? (mode:class (elm-get self 'mode)) 'INT)
+                         (atlist-cons (bool-attr-make 'SIGNED #t)
+                                      (obj-atlist operand))
+                         (obj-atlist operand))
+                     gen-attr-mask)
+      ;(gen-bool-attrs (obj-atlist operand) gen-attr-mask)
+      ", pc, length"
+      ");\n"
+      )))
+)
+\f
+; Keyword support.
+
+; Return C code to parse a keyword.
+
+(method-make!
+ <keyword> 'gen-parse
+ (lambda (self operand)
+   (let ((result-var 
+         (case (hw-index:type (op:index operand))
+           ((ifield) (gen-operand-result-var (op-ifield operand)))
+           (else "junk"))))
+     (string-append
+      "      errmsg = "
+      (or (send operand 'gen-function-name 'parse)
+         "cgen_parse_keyword")
+      " (cd, strp, "
+      (send self 'gen-ref) ", "
+      ;(op-enum operand) ", "
+      "& " result-var
+      ");\n"
+      )))
+)
+
+; Return C code to print a keyword.
+
+(method-make!
+ <keyword> 'gen-print
+ (lambda (self operand)
+   (let ((value
+         (case (hw-index:type (op:index operand))
+           ((ifield) (gen-operand-result-var (op-ifield operand)))
+           (else "0"))))
+     (string-append
+      "      "
+      (or (send operand 'gen-function-name 'print)
+         "print_keyword")
+      " (cd, "
+      "info" ; The disassemble_info argument to print_insn.
+      ", "
+      (send self 'gen-ref)
+      ", " value
+      ", "
+      ; We explicitly pass the attributes here rather than look them up
+      ; to give the code more optimization opportunities.
+      (gen-bool-attrs (obj-atlist operand) gen-attr-mask)
+      ");\n"
+      )))
+)
+\f
+; Hardware support.
+
+; For registers, use the indices field.  Ignore values.
+; ??? Not that that will always be the case.
+
+(method-make-forward! <hw-register> 'indices '(gen-parse gen-print))
+
+; No such support for memory yet.
+
+(method-make!
+ <hw-memory> 'gen-parse
+ (lambda (self operand)
+   (error "gen-parse of memory not supported yet"))
+)
+
+(method-make!
+ <hw-memory> 'gen-print
+ (lambda (self operand)
+   (error "gen-print of memory not supported yet"))
+)
+
+; For immediates, use the values field.  Ignore indices.
+; ??? Not that that will always be the case.
+
+(method-make-forward! <hw-immediate> 'values '(gen-parse gen-print))
+
+; For addresses, use the values field.  Ignore indices.
+
+(method-make-forward! <hw-address> 'values '(gen-parse gen-print))
+\f
+; Generate the C code for dealing with operands.
+; This code is inserted into cgen-{ibld,asm,dis}.in above the insn routines
+; so that it can be inlined if desired.  ??? Actually this isn't always the
+; case but this is minutiae to be dealt with much later.
+
+; Generate the guts of a C switch to handle an operation for all operands.
+; WHAT is one of fget/fset/parse/insert/extract/print.
+;
+; The "f" prefix (e.g. set -> fset) is for "field" to distinguish the
+; operations from similar ones in other contexts.  ??? I'd prefer to come
+; up with better names for fget/fset but I haven't come up with anything
+; satisfactory yet.
+
+(define (gen-switch what)
+  (string-list-map
+   (lambda (ops)
+     ; OPS is a list of operands with the same name that for whatever reason
+     ; were defined separately.
+     (logit 3 (string-append "Processing " (obj:name (car ops)) " " what " ...\n"))
+     (if (= (length ops) 1)
+        (gen-obj-sanitize
+         (car ops)
+         (string-list
+          "    case @ARCH@_OPERAND_"
+          (string-upcase (gen-sym (car ops)))
+          " :\n"
+          (send (car ops) (symbol-append 'gen- what) (car ops))
+          "      break;\n"))
+        (string-list
+         ; FIXME: operand name doesn't get sanitized.
+         "    case @ARCH@_OPERAND_"
+         (string-upcase (gen-sym (car ops)))
+         " :\n"
+         ; There's more than one operand defined with this name, so we
+         ; have to distinguish them.
+         ; FIXME: Unfinished.
+         (string-list-map (lambda (op)
+                            (gen-obj-sanitize
+                             op
+                             (string-list
+                              (send op (symbol-append 'gen- what) op)
+                              )))
+                          ops)
+         "      break;\n"
+         )))
+   (op-sort (find (lambda (op) (and (not (has-attr? op 'SEM-ONLY))
+                                   (not (anyof-operand? op))
+                                   (not (derived-operand? op))))
+                 (current-op-list))))
+)
+\f
+; Operand support.
+
+; Return the function name to use for WHAT or #f if there isn't a special one.
+; WHAT is one of fget/fset/parse/insert/extract/print.
+
+(method-make!
+ <operand> 'gen-function-name
+ (lambda (self what)
+   (let ((handlers (elm-get self 'handlers)))
+     (let ((fn (assq-ref handlers what)))
+       (and fn (string-append what "_" (car fn))))))
+)
+
+; Interface fns.
+; The default is to forward the request onto TYPE.
+; OP is a copy of SELF so the method we forward to sees it.
+; There is one case in the fget/fset/parse/insert/extract/print
+; switches for each operand.
+; These are invoked via gen-switch.
+
+; Emit C code to get an operand value from the fields struct.
+; Operand values are stored in a struct "indexed" by field name.
+;
+; The "f" prefix (e.g. set -> fset) is for "field" to distinguish the
+; operations from similar ones in other contexts.  ??? I'd prefer to come
+; up with better names for fget/fset but I haven't come up with anything
+; satisfactory yet.
+
+(method-make!
+ <operand> 'gen-fget
+ (lambda (self operand)
+   (case (hw-index:type (op:index self))
+     ((ifield)
+      (string-append "      value = "
+                    (gen-operand-result-var (op-ifield self))
+                    ";\n"))
+     (else
+      "      value = 0;\n")))
+)
+
+(method-make!
+ <derived-operand> 'gen-fget
+ (lambda (self operand)
+   "      abort();\n") ; should never be called
+)
+
+; Emit C code to save an operand value in the fields struct.
+
+(method-make!
+ <operand> 'gen-fset
+ (lambda (self operand)
+   (case (hw-index:type (op:index self))
+     ((ifield)
+      (string-append "      "
+                    (gen-operand-result-var (op-ifield self))
+                    " = value;\n"))
+     (else
+      ""))) ; ignore
+)
+
+(method-make!
+ <derived-operand> 'gen-fset
+ (lambda (self operand)
+   "      abort();\n") ; should never be called
+)
+
+
+; Need to call op:type to resolve the hardware reference.
+;(method-make-forward! <operand> 'type '(gen-parse gen-print))
+
+(method-make!
+ <operand> 'gen-parse
+ (lambda (self operand)
+   (send (op:type self) 'gen-parse operand))
+)
+
+(method-make!
+ <derived-operand> 'gen-parse
+ (lambda (self operand)
+   "      abort();\n") ; should never be called
+)
+
+(method-make!
+ <operand> 'gen-print
+ (lambda (self operand)
+   (send (op:type self) 'gen-print operand))
+)
+
+(method-make!
+ <derived-operand> 'gen-print
+ (lambda (self operand)
+   "      abort();\n") ; should never be called
+)
+
+(method-make-forward! <operand> 'index '(gen-insert gen-extract))
+; But: <derived-operand> has its own gen-insert / gen-extract.
+
+
+; Return the value of PC.
+; Used by insert/extract fields.
+
+(method-make!
+ <pc> 'cxmake-get
+ (lambda (self estate mode index selector)
+   (cx:make IAI "pc"))
+)
+\f
+; Opcodes init,finish,analyzer support.
+
+; Initialize any opcodes specific things before loading the .cpu file.
+
+(define (opcodes-init!)
+  (desc-init!)
+  *UNSPECIFIED*
+)
+
+; Finish any opcodes specific things after loading the .cpu file.
+; This is separate from analyze-data! as cpu-load performs some
+; consistency checks in between.
+
+(define (opcodes-finish!)
+  (desc-finish!)
+  *UNSPECIFIED*
+)
+
+; Compute various needed globals and assign any computed fields of
+; the various objects.  This is the standard routine that is called after
+; a .cpu file is loaded.
+
+(define (opcodes-analyze!)
+  (desc-analyze!)
+
+  ; Initialize the rtl->c translator.
+  (rtl-c-config!)
+
+  ; Only include semantic operands when computing the format tables if we're
+  ; generating operand instance tables.
+  ; ??? Actually, may always be able to exclude the semantic operands.
+  ; Still need to traverse the semantics to derive machine computed attributes.
+  (arch-analyze-insns! CURRENT-ARCH
+                      #t ; include aliases
+                      -opcodes-build-operand-instance-table?)
+
+  *UNSPECIFIED*
+)
+\f
+; Extra target specific code generation.
+; For now, such code lives in <arch>.opc.
+
+; Pick out a section from the .opc file.
+; The section is delimited with:
+; /* -- name ... */
+; ...
+; /* -- ... */
+;
+; FIXME: This is a pretty involved bit of code.  'twould be nice to split
+; it up into manageable chunks.
+
+(define (read-cpu.opc srcdir cpu delim)
+  (let ((file (string-append srcdir "/" (current-arch-name) ".opc"))
+       (start-delim (string-append "/* -- " delim))
+       (end-delim "/* -- "))
+    (if (file-exists? file)
+       (let ((port (open-file file "r"))
+             ; Extra amount is added to SIZE so substring's to fetch possible
+             ; delim won't fail, even at end of file
+             (size (+ (file-size file) (string-length start-delim))))
+         (if port
+             (let ((result (make-string size #\space)))
+               (let loop ((start -1) (line 0) (index 0))
+                 (let ((char (read-char port)))
+                   (if (not (eof-object? char))
+                       (string-set! result index char))
+                   (cond ((eof-object? char)
+                          (begin
+                            (close-port port)
+                            ; End of file, did we find the text?
+                            (if (=? start -1)
+                                ""
+                                (substring result start index))))
+                         ((char=? char #\newline)
+                          ; Check for start delim or end delim?
+                          (if (=? start -1)
+                              (if (string=? (substring result line
+                                                       (+ (string-length start-delim)
+                                                          line))
+                                            start-delim)
+                                  (loop line (+ index 1) (+ index 1))
+                                  (loop -1 (+ index 1) (+ index 1)))
+                              (if (string=? (substring result line
+                                                       (+ (string-length end-delim)
+                                                          line))
+                                            end-delim)
+                                  (begin
+                                    (close-port port)
+                                    (substring result start (+ index 1)))
+                                  (loop start (+ index 1) (+ index 1)))))
+                         (else
+                          (loop start line (+ index 1)))))))
+               (error "Unable to open:" file)))
+       "" ; file doesn't exist
+       ))
+)
+
+; FIXME: collapse into one?
+(define (gen-extra-cpu.h srcdir arch)
+  (logit 2 "Generating extra cpu.h stuff from " arch ".opc ...\n")
+  (read-cpu.opc srcdir arch "cpu.h")
+)
+(define (gen-extra-cpu.c srcdir arch)
+  (logit 2 "Generating extra cpu.c stuff from " arch ".opc ...\n")
+  (read-cpu.opc srcdir arch "cpu.c")
+)
+(define (gen-extra-opc.h srcdir arch)
+  (logit 2 "Generating extra opc.h stuff from " arch ".opc ...\n")
+  (read-cpu.opc srcdir arch "opc.h")
+)
+(define (gen-extra-opc.c srcdir arch)
+  (logit 2 "Generating extra opc.c stuff from " arch ".opc ...\n")
+  (read-cpu.opc srcdir arch "opc.c")
+)
+(define (gen-extra-asm.c srcdir arch)
+  (logit 2 "Generating extra asm.c stuff from " arch ".opc ...\n")
+  (read-cpu.opc srcdir arch "asm.c")
+)
+(define (gen-extra-dis.c srcdir arch)
+  (logit 2 "Generating extra dis.c stuff from " arch ".opc ...\n")
+  (read-cpu.opc srcdir arch "dis.c")
+)
+(define (gen-extra-ibld.h srcdir arch)
+  (logit 2 "Generating extra ibld.h stuff from " arch ".opc ...\n")
+  (read-cpu.opc srcdir arch "ibld.h")
+)
+(define (gen-extra-ibld.c srcdir arch)
+  (logit 2 "Generating extra ibld.c stuff from " arch ".opc ...\n")
+  (read-cpu.opc srcdir arch "ibld.c")
+)
+\f
+; For debugging.
+
+(define (cgen-all)
+  (string-write
+   cgen-desc.h
+   cgen-desc.c
+   cgen-opinst.c
+   cgen-opc.h
+   cgen-opc.c
+   cgen-ibld.h
+   cgen-ibld.in
+   cgen-asm.in
+   cgen-dis.in
+   )
+)
diff --git a/cgen/operand.scm b/cgen/operand.scm
new file mode 100644 (file)
index 0000000..03a5217
--- /dev/null
@@ -0,0 +1,1559 @@
+; Operands
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; Operands map a set of values (registers, whatever) to an instruction field
+; or other indexing mechanism.  Operands are also how the semantic code refers
+; to hardware elements.
+
+; The `<operand>' class.
+;
+; ??? Need a new lighterweight version for instances in semantics.
+; This should only contain the static elements from the description file.
+;
+; ??? Derived operands don't use all the current class members.  Perhaps
+; split <operand> into two.
+
+(define <operand>
+  (class-make '<operand>
+             '(<ident>)
+             '(
+               ; Name as used in semantic code.
+               ; Generally this is the same as NAME.  It is changed by the
+               ; `operand:' rtx function.  One reason is to set a "pretty"
+               ; name in tracing output (most useful in memory operands).
+               ; A more important reason is to help match semantic operands
+               ; with function unit input/output arguments.
+               sem-name
+
+               ; Semantic name of hardware element refered to by this operand.
+               hw-name
+
+               ; Hardware type of operand, a subclass of <hardware-base>.
+               ; This is computed lazily from HW-NAME as many hardware
+               ; elements can have the same semantic name.  Applications
+               ; that require a unique hardware element to be refered to are
+               ; required to ensure duplicates are discarded (usually done
+               ; by keeping the appropriate machs).
+               ; FIXME: Rename to hw.
+               (type . #f)
+
+               ; Name of mode, as specified in description file.
+               ; This needn't be the actual mode, as WI will get coerced
+               ; to the actual word int mode.
+               mode-name
+
+               ; The mode TYPE is being referenced in.
+               ; This is also looked up lazily for the same reasons as TYPE.
+               (mode . #f)
+
+               ; Selector.
+               ; A number or #f used to select a variant of the hardware
+               ; element.  An example is ASI's on sparc.
+               ; ??? I really need to be better at picking names.
+               (selector . #f)
+
+               ; Index into type, class <hw-index>.
+               ; For example in the case of an array of registers
+               ; it can be an instruction field or in the case of a memory
+               ; reference it can be a register operand (or general rtx).
+               ; ??? At present <hw-index> is a facade over the real index
+               ; type.  Not sure what the best way to do this is.
+               (index . #f)
+
+               ; Code to run when the operand is read or #f meaning pass
+               ; the request on to the hardware object.
+               (getter . #f)
+
+               ; Code to run when the operand is written or #f meaning pass
+               ; the request on to the hardware object.
+               (setter . #f)
+
+               ; Associative list of (symbol . "handler") entries.
+               ; Each entry maps an operation to its handler (which is up to
+               ; the application but is generally a function name).
+               (handlers . ())
+
+               ; Ordinal number of the operand in an insn's semantic
+               ; description.  There is no relation between the number and
+               ; where in the semantics the operand appears.  An operand that
+               ; is both read and written are given separate ordinal numbers
+               ; (inputs are treated separately from outputs).
+               (num . -1)
+
+               ; Boolean indicating if the operand is conditionally
+               ; referenced.  #f means the operand is always referenced by
+               ; the instruction.
+               (cond? . #f)
+               )
+             nil)
+)
+
+; The default make! assigns the default h/w selector.
+
+(method-make!
+ <operand> 'make!
+ (lambda (self name comment attrs hw-name mode-name index handlers getter setter)
+   (elm-set! self 'name name)
+   (elm-set! self 'sem-name name)
+   (elm-set! self 'comment comment)
+   (elm-set! self 'attrs attrs)
+   (elm-set! self 'hw-name hw-name)
+   (elm-set! self 'mode-name mode-name)
+   (elm-set! self 'selector hw-selector-default)
+   (elm-set! self 'index index)
+   (elm-set! self 'handlers handlers)
+   (elm-set! self 'getter getter)
+   (elm-set! self 'setter setter)
+   self)
+)
+
+; FIXME: The prefix field- doesn't seem right.  Indices needn't be
+; ifields, though for operands defined in .cpu files they usually are.
+(method-make-forward! <operand> 'index '(field-start field-length))
+
+; Accessor fns
+
+(define op:sem-name (elm-make-getter <operand> 'sem-name))
+(define op:set-sem-name! (elm-make-setter <operand> 'sem-name))
+(define op:hw-name (elm-make-getter <operand> 'hw-name))
+(define op:mode-name (elm-make-getter <operand> 'mode-name))
+(define op:selector (elm-make-getter <operand> 'selector))
+; FIXME: op:index should be named op:hwindex.
+(define op:index (elm-make-getter <operand> 'index))
+(define op:handlers (elm-make-getter <operand> 'handlers))
+(define op:getter (elm-make-getter <operand> 'getter))
+(define op:setter (elm-make-getter <operand> 'setter))
+(define op:num (elm-make-getter <operand> 'num))
+(define op:set-num! (elm-make-setter <operand> 'num))
+(define op:cond? (elm-make-getter <operand> 'cond?))
+(define op:set-cond?! (elm-make-setter <operand> 'cond?))
+
+; Compute the hardware type lazily.
+; FIXME: op:type should be named op:hwtype or some such.
+
+(define op:type
+  (let ((getter (elm-make-getter <operand> 'type)))
+    (lambda (op)
+      (let ((type (getter op)))
+       (if type
+           type
+           (let* ((hw-name (op:hw-name op))
+                  (hw-objs (current-hw-sem-lookup hw-name)))
+             (if (!= (length hw-objs) 1)
+                 (error "can't resolve h/w reference" hw-name))
+             ((elm-make-setter <operand> 'type) op (car hw-objs))
+             (car hw-objs))))))
+)
+
+; Compute the operand's mode lazily (depends on hardware type which is
+; computed lazily).
+
+(define op:mode
+  (let ((getter (elm-make-getter <operand> 'mode)))
+    (lambda (op)
+      (let ((mode (getter op)))
+       (if mode
+           mode
+           (let ((mode-name (op:mode-name op))
+                 (type (op:type op)))
+             (let ((mode (if (eq? mode-name 'DFLT)
+                             (hw-default-mode type)
+                             (mode:lookup mode-name))))
+               ((elm-make-setter <operand> 'mode) op mode)
+               mode))))))
+)
+
+(method-make! <operand> 'get-mode (lambda (self) (op:mode self)))
+
+; FIXME: wip
+; Result is the <ifield> object or #f if there is none.
+
+(define (op-ifield op)
+  (logit 4 "op-ifield op=" (obj:name op) " indx=" (obj:name (op:index op)) "\n")
+  (let ((indx (op:index op)))
+    (if indx
+       (let ((maybe-ifld (hw-index:value (op:index op))))
+         (logit 4 " ifld=" (obj:name maybe-ifld) "\n")
+         (cond ((ifield? maybe-ifld) maybe-ifld)
+               ((derived-ifield? maybe-ifld) maybe-ifld)
+               ((ifield? indx) indx)
+               ((derived-ifield? indx) indx)
+               (else #f)))
+       #f))
+)
+
+; Return mode to use for index or #f if scalar.
+; This can't use method-make-forward! as we need to call op:type to
+; resolve the hardware reference.
+
+(method-make!
+ <operand> 'get-index-mode
+ (lambda (self) (send (op:type self) 'get-index-mode))
+)
+
+; Return the operand's enum.
+
+(define (op-enum op)
+  (string-upcase (string-append "@ARCH@_OPERAND_" (gen-sym op)))
+)
+
+; Return a boolean indicating if X is an operand.
+
+(define (operand? x) (class-instance? <operand> x))
+
+; Default gen-pretty-name method.
+; Return a C string of the name intended for users.
+;
+; FIXME: The current implementation is a quick hack.  Parallel execution
+; support can create operands with long names.  e.g. h-memory-add-WI-src2-slo16
+; The eventual way this will be handled is to record with each operand the
+; entry number (or some such) in the operand instance table so that for
+; registers we can compute the register's name.
+
+(method-make!
+ <operand> 'gen-pretty-name
+ (lambda (self mode)
+   (let* ((name (op:sem-name self))
+         (pname (cond ((string=? "h-memory" (string-take 8 name)) "memory")
+                      ((string=? "h-" (string-take 2 name)) (string-drop 2 name))
+                      (else name))))
+     (string-append "\"" pname "\"")))
+)
+\f
+; PC support.
+; This is a subclass of <operand>, used to give the simulator a place to
+; hang a couple of methods.
+; At the moment we only support one pc, a reasonable place to stop for now.
+
+(define <pc> (class-make '<pc> '(<operand>) nil nil))
+
+(method-make!
+ <pc> 'make!
+ (lambda (self)
+   (send-next self 'make! 'pc "program counter"
+             (atlist-parse '(SEM-ONLY) "cgen_operand" "make! of pc")
+             'h-pc
+             'DFLT
+             (make <hw-index> 'anonymous
+                   'ifield 'UINT (current-ifld-lookup 'f-nil))
+             nil ; handlers
+             #f #f) ; getter setter
+   self)
+)
+
+; Return a boolean indicating if operand op is the pc.
+; This must not call op:type.  op:type will try to resolve a hardware
+; element that may be multiply specified, and this is used in contexts
+; where that's not possible.
+
+(define (pc? op) (class-instance? <pc> op))
+\f
+; Mode support.
+
+; Create a copy of operand OP in mode NEW-MODE-NAME.
+; If OP has been subclassed the result must contain the complete class
+; (e.g. the behaviour of `object-copy-top').
+
+(define (op:new-mode op new-mode-name)
+  (let ((result (object-copy-top op)))
+    ; (logit 1 "op:new-mode op=" (op:sem-name op) 
+    ;   " class=" (object-class-name op)
+    ;   " hw-name=" (op:hw-name op)
+    ;   " mode=" (op:mode op)
+    ;   " newmode=" new-mode-name)
+    (if (or (eq? new-mode-name 'DFLT)
+           (eq? new-mode-name 'VOID) ; temporary: for upward compatibility
+           (mode:eq? new-mode-name (op:mode op)))
+       ; Mode isn't changing.
+       result
+       ; See if new mode is supported by the hardware.
+       (if (hw-mode-ok? (op:type op) new-mode-name (op:index op))
+           (let ((new-mode (mode:lookup new-mode-name)))
+             (if (not new-mode)
+                 (error "op:new-mode: internal error, bad mode"
+                        new-mode-name))
+             (elm-xset! result 'mode new-mode)
+             result)
+           (parse-error "op:new-mode"
+                        (string-append "invalid mode for operand `"
+                                       (obj:name op)
+                                       "'")
+                        new-mode-name))))
+)
+\f
+; Ifield support.
+
+; Return list of ifields used by OP.
+
+(define (op-iflds-used op)
+  (if (derived-operand? op)
+      (collect op-iflds-used (derived-args op))
+      ; else
+      (let ((indx (op:index op)))
+       (if (and (eq? (hw-index:type indx) 'ifield)
+                (not (= (ifld-length (hw-index:value indx)) 0)))
+           (ifld-needed-iflds (hw-index:value indx))
+           nil)))
+)
+\f
+; The `hw-index' class.
+; [Was named `index' but that conflicts with the C library function and caused
+; problems when using Hobbit.  And `index' is too generic a name anyway.]
+;
+; An operand combines a hardware object with its index.
+; e.g. in an array of registers an operand serves to combine the register bank
+; with the instruction field that chooses which one.
+; Hardware elements are accessed via other means as well besides instruction
+; fields so we need a way to designate something as being an index.
+; The `hw-index' class does that.  It serves as a facade to the underlying
+; details.
+; ??? Not sure whether this is the best way to handle this or not.
+;
+; NAME is the name of the index or 'anonymous.
+; This is used, for example, to give a name to the simulator extraction
+; structure member.
+; TYPE is a symbol that indicates what VALUE is.
+; scalar: the hardware object is a scalar, no index is required
+;         [MODE and VALUE are #f to denote "undefined" in this case]
+; constant: a (non-negative) integer
+; str-expr: a C expression as a string
+; rtx: an rtx to be expanded
+; ifield: an ifield object
+; operand: an operand object
+; ??? A useful simplification may be to always record the value as an rtx
+; [which may require extensions to rtl so is deferred].
+; ??? We could use runtime type identification, but doing things this way
+; adds more structure.
+;
+; MODE is the mode of VALUE.  If DFLT, mode must be obtained from VALUE.
+; DFLT is only allowable for rtx and operand types.
+
+(define <hw-index> (class-make '<hw-index> nil '(name type mode value) nil))
+
+; Accessors.
+; Use obj:name for `name'.
+(define hw-index:type (elm-make-getter <hw-index> 'type))
+(define hw-index:mode (elm-make-getter <hw-index> 'mode))
+(define hw-index:value (elm-make-getter <hw-index> 'value))
+
+; Allow the mode to be specified by its name.
+(method-make!
+ <hw-index> 'make!
+ (lambda (self name type mode value)
+   (elm-set! self 'name name)
+   (elm-set! self 'type type)
+   (elm-set! self 'mode (mode:lookup mode))
+   (elm-set! self 'value value)
+   self)
+)
+
+; get-name handler
+(method-make!
+ <hw-index> 'get-name
+ (lambda (self)
+   (elm-get self 'name))
+)
+
+; get-atlist handler
+(method-make!
+ <hw-index> 'get-atlist
+ (lambda (self)
+   (case (hw-index:type self)
+     ((ifield) (obj-atlist (hw-index:value self)))
+     (else atlist-empty)))
+)
+
+; ??? Until other things settle.
+(method-make!
+ <hw-index> 'field-start
+ (lambda (self word-len)
+   (if (eq? (hw-index:type self) 'ifield)
+       (send (hw-index:value self) 'field-start #f)
+       0))
+)
+(method-make!
+ <hw-index> 'field-length
+ (lambda (self)
+   (if (eq? (hw-index:type self) 'ifield)
+       (send (hw-index:value self) 'field-length)
+       0))
+)
+
+; There only ever needs to be one of these objects, so create one.
+
+(define hw-index-scalar
+  ; We can't use `make' here as the make! method calls mode:lookup which
+  ; (a) doesn't exist if we're compiled with Hobbit and mode.scm isn't
+  ; and (b) will fail anyway since #f isn't a valid mode.
+  (let ((scalar-index (new <hw-index>)))
+    (elm-xset! scalar-index 'type 'scalar)
+    (elm-xset! scalar-index 'mode #f)
+    (elm-xset! scalar-index 'value #f)
+    (lambda () scalar-index))
+)
+
+
+; Placeholder for indices of "anyof" operands.
+; There only needs to be one of these, so we create one and always use that.
+
+(define hw-index-anyof
+  ; We can't use `make' here as the make! method calls mode:lookup which
+  ; (a) doesn't exist if we're compiled with Hobbit and mode.scm isn't
+  ; and (b) will fail anyway since #f isn't a valid mode.
+  (let ((anyof-index (new <hw-index>)))
+    (elm-xset! anyof-index 'type 'scalar)
+    (elm-xset! anyof-index 'mode #f)
+    (elm-xset! anyof-index 'value #f)
+    (lambda () anyof-index))
+)
+
+(define hw-index-derived
+  ; We can't use `make' here as the make! method calls mode:lookup which
+  ; (a) doesn't exist if we're compiled with Hobbit and mode.scm isn't
+  ; and (b) will fail anyway since #f isn't a valid mode.
+  (let ((derived-index (new <hw-index>)))
+    (elm-xset! derived-index 'type 'scalar)
+    (elm-xset! derived-index 'mode #f)
+    (elm-xset! derived-index 'value #f)
+    (lambda () derived-index))
+)
+
+
+\f
+; Hardware selector support.
+;
+; A hardware "selector" is like an index except is along an atypical axis
+; and thus is rarely used.  It exists to support things like ASI's on Sparc.
+
+; What to pass to indicate "default selector".
+; (??? value is temporary choice to be revisited).
+(define hw-selector-default '(symbol NONE))
+
+(define (hw-selector-default? sel) (equal? sel hw-selector-default))
+\f
+; Hardware support.
+
+; Return list of hardware elements refered to in OP-LIST
+; with no duplicates.
+
+(define (op-nub-hw op-list)
+  ; Build a list of hw elements.
+  (let ((hw-list (map (lambda (op)
+                       (if (hw-ref? op) ; FIXME: hw-ref? is undefined
+                           op
+                           (op:type op)))
+                     op-list)))
+    ; Now build an alist of (name . obj) elements, take the nub, then the cdr.
+    ; ??? These lists tend to be small so sorting first is probably overkill.
+    (map cdr
+        (alist-nub (alist-sort (map (lambda (hw) (cons (obj:name hw) hw))
+                                    hw-list)))))
+)
+\f
+; Parsing support.
+
+; Utility of -operand-parse-[gs]etter to build the expected syntax,
+; for use in error messages.
+
+(define (-operand-g/setter-syntax rank setter?)
+  (string-append "("
+                (string-drop1
+                 (numbers->string (iota rank) " index"))
+                (if setter?
+                    (if (>= rank 1)
+                        " newval"
+                        "newval")
+                    "")
+                ") (expression)")
+)
+
+; Parse a getter spec.
+; The syntax is (([index-names]) (... code ...)).
+; Omit `index-names' for scalar objects.
+; {rank} is the required number of elements in {index-names}.
+
+(define (-operand-parse-getter context getter rank)
+  (if (null? getter)
+      #f ; use default
+      (let ()
+       (if (or (not (list? getter))
+               (!= (length getter) 2)
+               (not (and (list? (car getter))
+                         (= (length (car getter)) rank))))
+           (context-error context
+                          (string-append "invalid getter, should be "
+                                         (-operand-g/setter-syntax rank #f))
+                          getter))
+       (if (not (rtx? (cadr getter)))
+           (context-error context "invalid rtx expression" getter))
+       getter))
+)
+
+; Parse a setter spec.
+; The syntax is (([index-names] newval) (... code ...)).
+; Omit `index-names' for scalar objects.
+; {rank} is the required number of elements in {index-names}.
+
+(define (-operand-parse-setter context setter rank)
+  (if (null? setter)
+      #f ; use default
+      (let ()
+       (if (or (not (list? setter))
+               (!= (length setter) 2)
+               (not (and (list? (car setter))
+                         (= (+ 1 (length (car setter)) rank)))))
+           (context-error context
+                          (string-append "invalid setter, should be "
+                                         (-operand-g/setter-syntax rank #t))
+                          setter))
+       (if (not (rtx? (cadr setter)))
+           (context-error context "invalid rtx expression" setter))
+       setter))
+)
+
+; Parse an operand definition.
+; This is the main routine for building an operand object from a
+; description in the .cpu file.
+; All arguments are in raw (non-evaluated) form.
+; The result is the parsed object or #f if object isn't for selected mach(s).
+; ??? This only takes insn fields as the index.  May need another proc (or an
+; enhancement of this one) that takes other kinds of indices.
+
+(define (-operand-parse errtxt name comment attrs hw mode ifld handlers getter setter)
+  (logit 2 "Processing operand " name " ...\n")
+
+  (let ((name (parse-name name errtxt))
+       (atlist-obj (atlist-parse attrs "cgen_operand" errtxt)))
+
+    (if (keep-atlist? atlist-obj #f)
+
+       (let ((hw-objs (current-hw-sem-lookup hw))
+             (mode-obj (parse-mode-name mode errtxt))
+             (ifld-val (if (integer? ifld)
+                           ifld
+                           (current-ifld-lookup ifld)))
+             ; FIXME: quick hack
+             (context (context-make-reader errtxt)))
+
+         (if (not mode-obj)
+             (parse-error errtxt "unknown mode" mode))
+         (if (not ifld-val)
+             (parse-error errtxt "unknown insn field" ifld))
+         ; Disallow some obviously invalid numeric indices.
+         (if (and (integer? ifld-val)
+                  (< ifld-val 0))
+             (parse-error errtxt "invalid integer index" ifld-val))
+         ; Don't validate HW until we know whether this operand will be kept
+         ; or not.  If not, HW may have been discarded too.
+         (if (null? hw-objs)
+             (parse-error errtxt "unknown hardware element" hw))
+
+         ; At this point IFLD-VAL is either an integer or an <ifield> object.
+         ; Since we can't look up the hardware element at this time
+         ; [well, actually we should be able to with a bit of work],
+         ; we determine scalarness from the index.
+         (let* ((scalar? (or (integer? ifld-val) (ifld-nil? ifld-val)))
+                (hw-index
+                 (if (integer? ifld-val)
+                     (make <hw-index> (symbol-append 'i- name)
+                           ; FIXME: constant -> const
+                           'constant 'UINT ifld-val)
+                     (if scalar?
+                         (hw-index-scalar)
+                         (make <hw-index> (symbol-append 'i- name)
+                               'ifield 'UINT ifld-val)))))
+           (make <operand>
+             name
+             (parse-comment comment errtxt)
+             ; Copy FLD's attributes so one needn't duplicate attrs like
+             ; PCREL-ADDR, etc.  An operand inherits the attributes of
+             ; its field.  They are overridable of course, which is why we use
+             ; `atlist-append' here.
+             (if (integer? ifld-val)
+                 atlist-obj
+                 (atlist-append atlist-obj (obj-atlist ifld-val)))
+             hw   ; note that this is the hw's name, not an object
+             mode ; ditto, this is a name, not an object
+             hw-index
+             (parse-handlers errtxt '(parse print) handlers)
+             (-operand-parse-getter context getter (if scalar? 0 1))
+             (-operand-parse-setter context setter (if scalar? 0 1))
+             )))
+
+       (begin
+         (logit 2 "Ignoring " name ".\n")
+         #f)))
+)
+
+; Read an operand description.
+; This is the main routine for analyzing operands in the .cpu file.
+; ERRTXT is prepended to error messages to provide context.
+; ARG-LIST is an associative list of field name and field value.
+; -operand-parse is invoked to create the <operand> object.
+
+(define (-operand-read errtxt . arg-list)
+  (let (; Current operand elements:
+       (name nil)
+       (comment nil)
+       (attrs nil)
+       (type nil)
+       (mode 'DFLT)     ; use default mode of TYPE
+       (index nil)
+       (handlers nil)
+       (getter nil)
+       (setter nil)
+       )
+    (let loop ((arg-list arg-list))
+      (if (null? arg-list)
+         nil
+         (let ((arg (car arg-list))
+               (elm-name (caar arg-list)))
+           (case elm-name
+             ((name) (set! name (cadr arg)))
+             ((comment) (set! comment (cadr arg)))
+             ((attrs) (set! attrs (cdr arg)))
+             ((type) (set! type (cadr arg)))
+             ((mode) (set! mode (cadr arg)))
+             ((index) (set! index (cadr arg)))
+             ((handlers) (set! handlers (cdr arg)))
+             ((getter) (set! getter (cdr arg)))
+             ((setter) (set! setter (cdr arg)))
+             (else (parse-error errtxt "invalid operand arg" arg)))
+           (loop (cdr arg-list)))))
+    ; Now that we've identified the elements, build the object.
+    (-operand-parse errtxt name comment attrs type mode index handlers
+                   getter setter)
+    )
+)
+
+; Define an operand object, name/value pair list version.
+
+(define define-operand
+  (lambda arg-list
+    (let ((op (apply -operand-read (cons "define-operand" arg-list))))
+      (if op
+         (current-op-add! op))
+      op))
+)
+
+; Define an operand object, all arguments specified.
+
+(define (define-full-operand name comment attrs type mode index handlers getter setter)
+  (let ((op (-operand-parse "define-full-operand" name comment attrs
+                           type mode index handlers getter setter)))
+    (if op
+       (current-op-add! op))
+    op)
+)
+\f
+; Derived operands.
+;
+; Derived operands are used to implement operands more complex than just
+; the mapping of an instruction field to a register bank.  Their present
+; raison d'etre is to create a new axis on which to implement the complex
+; addressing modes of the i386 and m68k.  The brute force way of describing
+; these instruction sets would be to have one `dni' per addressing mode
+; per instruction.  What's needed is to abstract away the various addressing
+; modes within something like operands.
+;
+; ??? While internally we end up with the "brute force" approach, in and of
+; itself that's ok because it's an internal implementation issue.
+; See <multi-insn>.
+;
+; ??? Another way to go is to have one dni per addressing mode.  That seems
+; less clean though as one dni would be any of add, sub, and, or, xor, etc.
+;
+; ??? Some addressing modes have side-effects (e.g. pre-dec, etc. like insns).
+; This can be represented, but if two operands have side-effects special
+; trickery may be required to get the order of side-effects right.  Need to
+; avoid any "trickery" at all.
+;
+; ??? Not yet handled are modelling parameters.
+; ??? Not yet handled are the handlers,getter,setter spec of normal operands.
+;
+; ??? Division of class members b/w <operand> and <derived-operand> is wip.
+; ??? As is potential introduction of other classes to properly organize
+; things.
+
+(define <derived-operand>
+  (class-make '<derived-operand>
+             '(<operand>)
+             '(
+               ; Args (list of <operands> objects).
+               args
+
+               ; Syntax string.
+               syntax
+
+               ; Base ifield, common to all choices.
+               ; ??? experiment
+               base-ifield
+
+               ; <derived-ifield> object.
+               encoding
+
+               ; Assertions of any ifield values or #f if none.
+               (ifield-assertion . #f)
+               )
+             ())
+)
+
+(method-make-make! <derived-operand>
+                  '(name comment attrs mode
+                         args syntax base-ifield encoding ifield-assertion
+                         getter setter)
+)
+
+(define (derived-operand? x) (class-instance? <derived-operand> x))
+
+(define-getters <derived-operand> derived
+  (args syntax base-ifield encoding ifield-assertion)
+)
+
+; "anyof" operands are subclassed from derived operands.
+; They typically handle multiple addressing modes of CISC architectures.
+
+(define <anyof-operand>
+  (class-make '<anyof-operand>
+             '(<operand>)
+             '(
+               ; Base ifield, common to all choices.
+               ; FIXME: wip
+               base-ifield
+
+               ; List of <derived-operand> objects.
+               ; ??? Maybe allow <operand>'s too?
+               choices
+               )
+             ())
+)
+
+(define (anyof-operand? x) (class-instance? <anyof-operand> x))
+
+(method-make!
+ <anyof-operand> 'make!
+ (lambda (self name comment attrs mode base-ifield choices)
+   (elm-set! self 'name name)
+   (elm-set! self 'comment comment)
+   (elm-set! self 'attrs attrs)
+   (elm-set! self 'mode-name mode)
+   (elm-set! self 'base-ifield base-ifield)
+   (elm-set! self 'choices choices)
+   ; Set index to a special marker value.
+   (elm-set! self 'index (hw-index-anyof))
+   self)
+)
+
+(define-getters <anyof-operand> anyof (choices))
+\f
+; Derived/Anyof parsing support.
+
+; Subroutine of -derived-operand-parse to parse the encoding.
+; The result is a <derived-ifield> object.
+; The {owner} member still needs to be set!
+
+(define (-derived-parse-encoding context operand-name encoding)
+  (if (or (null? encoding)
+         (not (list? encoding)))
+      (context-error context "encoding not a list" encoding))
+  (if (not (eq? (car encoding) '+))
+      (context-error context "encoding must begin with `+'" encoding))
+
+  ; ??? Calling -parse-insn-format is a quick hack.
+  ; It's an internal routine of some other file.
+  (let ((iflds (-parse-insn-format "anyof encoding" encoding)))
+    (make <derived-ifield>
+         operand-name
+         (string-append "<derived-ifield> for " operand-name)
+         atlist-empty
+         #f ; owner
+         iflds ; subfields
+         ))
+)
+
+; Subroutine of -derived-operand-parse to parse the ifield assertion.
+; The ifield assertion is either () or an RTL expression asserting something
+; about the ifield values of the containing insn.
+; Operands are specified by name, but what is used is their indices (there's
+; an implicit `index-of' going on).
+
+(define (-derived-parse-ifield-assertion context args ifield-assertion)
+  ; FIXME: for now
+  (if (null? ifield-assertion)
+      #f
+      ifield-assertion)
+)
+
+; Parse a derived operand definition.
+; This is the main routine for building a derived operand object from a
+; description in the .cpu file.
+; All arguments are in raw (non-evaluated) form.
+; The result is the parsed object or #f if object isn't for selected mach(s).
+;
+; ??? Currently no support for handlers(,???) found in normal operands.
+; Later, when necessary.
+
+(define (-derived-operand-parse errtxt name comment attrs mode
+                               args syntax
+                               base-ifield encoding ifield-assertion
+                               getter setter)
+  (logit 2 "Processing derived operand " name " ...\n")
+
+  (let ((name (parse-name name errtxt))
+       (atlist-obj (atlist-parse attrs "cgen_operand" errtxt)))
+
+    (if (keep-atlist? atlist-obj #f)
+
+       (let* ((mode-obj (parse-mode-name mode errtxt))
+             ; FIXME: quick hack
+             (context (context-make-reader errtxt))
+             (parsed-encoding (-derived-parse-encoding context name encoding))
+             )
+         (if (not mode-obj)
+             (parse-error errtxt "unknown mode" mode))
+
+         (let ((result
+                (make <derived-operand>
+                      name
+                      (parse-comment comment errtxt)
+                      atlist-obj
+                      mode-obj
+                      (map (lambda (a)
+                             (if (not (symbol? a))
+                                 (parse-error errtxt "arg not a symbol" a))
+                             (let ((op (current-op-lookup a)))
+                               (if (not op)
+                                   (parse-error errtxt "not an operand" a))
+                               op))
+                           args)
+                      syntax
+                      base-ifield ; FIXME: validate
+                      parsed-encoding
+                      (-derived-parse-ifield-assertion context args ifield-assertion)
+                      (if (null? getter)
+                          #f
+                          (-operand-parse-getter context
+                                                 (list args
+                                                       (rtx-canonicalize context getter))
+                                                 (length args)))
+                      (if (null? setter)
+                          #f
+                          (-operand-parse-setter context
+                                                 (list (append args '(newval))
+                                                       (rtx-canonicalize context setter))
+                                                 (length args)))
+                      )))
+           (elm-set! result 'hw-name (obj:name (hardware-for-mode mode-obj)))
+           (elm-set! result 'index parsed-encoding)
+           ; (elm-set! result 'index (hw-index-derived)) ; A temporary dummy
+           (logit 1 "new derived-operand; name=" name " hw-name= " (op:hw-name result) 
+                  " index=" (obj:name parsed-encoding) "\n")
+           (derived-ifield-set-owner! parsed-encoding result)
+           result))
+
+       (begin
+         (logit 2 "Ignoring " name ".\n")
+         #f)))
+)
+
+; Read a derived operand description.
+; This is the main routine for analyzing derived operands in the .cpu file.
+; ERRTXT is prepended to error messages to provide context.
+; ARG-LIST is an associative list of field name and field value.
+; -derived-operand-parse is invoked to create the <derived-operand> object.
+
+(define (-derived-operand-read errtxt . arg-list)
+  (let (; Current derived-operand elements:
+       (name nil)
+       (comment nil)
+       (attrs nil)
+       (mode 'DFLT)     ; use default mode of TYPE
+       (args nil)
+       (syntax nil)
+       (base-ifield nil)
+       (encoding nil)
+       (ifield-assertion nil)
+       (getter nil)
+       (setter nil)
+       )
+    (let loop ((arg-list arg-list))
+      (if (null? arg-list)
+         nil
+         (let ((arg (car arg-list))
+               (elm-name (caar arg-list)))
+           (case elm-name
+             ((name) (set! name (cadr arg)))
+             ((comment) (set! comment (cadr arg)))
+             ((attrs) (set! attrs (cdr arg)))
+             ((mode) (set! mode (cadr arg)))
+             ((args) (set! args (cadr arg)))
+             ((syntax) (set! syntax (cadr arg)))
+             ((base-ifield) (set! base-ifield (cadr arg)))
+             ((encoding) (set! encoding (cadr arg)))
+             ((ifield-assertion) (set! ifield-assertion (cadr arg)))
+             ((getter) (set! getter (cadr arg)))
+             ((setter) (set! setter (cadr arg)))
+             (else (parse-error errtxt "invalid derived-operand arg" arg)))
+           (loop (cdr arg-list)))))
+    ; Now that we've identified the elements, build the object.
+    (-derived-operand-parse errtxt name comment attrs mode args
+                           syntax base-ifield encoding ifield-assertion
+                           getter setter)
+    )
+)
+
+; Define a derived operand object, name/value pair list version.
+
+(define define-derived-operand
+  (lambda arg-list
+    (let ((op (apply -derived-operand-read
+                    (cons "define-derived-operand" arg-list))))
+      (if op
+         (current-op-add! op))
+      op))
+)
+
+; Define a derived operand object, all arguments specified.
+; ??? Not supported (yet).
+;
+;(define (define-full-derived-operand name comment attrs mode ...)
+;  (let ((op (-derived-operand-parse "define-full-derived-operand"
+;                                  name comment attrs
+;                                  mode ...)))
+;    (if op
+;      (current-op-add! op))
+;    op)
+;)
+
+; Parse an "anyof" choice, which is a derived-operand name.
+; The result is {choice} unchanged.
+
+(define (-anyof-parse-choice context choice)
+  (if (not (symbol? choice))
+      (context-error context "anyof choice not a symbol" choice))
+  (let ((op (current-op-lookup choice)))
+    (if (not (derived-operand? op))
+       (context-error context "anyof choice not a derived-operand" choice))
+    op)
+)
+
+; Parse an "anyof" derived operand.
+; This is the main routine for building a derived operand object from a
+; description in the .cpu file.
+; All arguments are in raw (non-evaluated) form.
+; The result is the parsed object or #f if object isn't for selected mach(s).
+;
+; ??? Currently no support for handlers(,???) found in normal operands.
+; Later, when necessary.
+
+(define (-anyof-operand-parse errtxt name comment attrs mode
+                             base-ifield choices)
+  (logit 2 "Processing anyof operand " name " ...\n")
+
+  (let ((name (parse-name name errtxt))
+       (atlist-obj (atlist-parse attrs "cgen_operand" errtxt)))
+
+    (if (keep-atlist? atlist-obj #f)
+
+       (let ((mode-obj (parse-mode-name mode errtxt))
+             ; FIXME: quick hack
+             (context (context-make-reader errtxt)))
+         (if (not mode-obj)
+             (parse-error errtxt "unknown mode" mode))
+
+         (make <anyof-operand>
+               name
+               (parse-comment comment errtxt)
+               atlist-obj
+               mode
+               base-ifield
+               (map (lambda (c)
+                      (-anyof-parse-choice context c))
+                    choices)))
+
+       (begin
+         (logit 2 "Ignoring " name ".\n")
+         #f)))
+)
+
+; Read an anyof operand description.
+; This is the main routine for analyzing anyof operands in the .cpu file.
+; ERRTXT is prepended to error messages to provide context.
+; ARG-LIST is an associative list of field name and field value.
+; -anyof-operand-parse is invoked to create the <anyof-operand> object.
+
+(define (-anyof-operand-read errtxt . arg-list)
+  (let (; Current operand elements:
+       (name nil)
+       (comment nil)
+       (attrs nil)
+       (mode 'DFLT)     ; use default mode of TYPE
+       (base-ifield nil)
+       (choices nil)
+       )
+    (let loop ((arg-list arg-list))
+      (if (null? arg-list)
+         nil
+         (let ((arg (car arg-list))
+               (elm-name (caar arg-list)))
+           (case elm-name
+             ((name) (set! name (cadr arg)))
+             ((comment) (set! comment (cadr arg)))
+             ((attrs) (set! attrs (cdr arg)))
+             ((mode) (set! mode (cadr arg)))
+             ((base-ifield) (set! base-ifield (cadr arg)))
+             ((choices) (set! choices (cdr arg)))
+             (else (parse-error errtxt "invalid anyof-operand arg" arg)))
+           (loop (cdr arg-list)))))
+    ; Now that we've identified the elements, build the object.
+    (-anyof-operand-parse errtxt name comment attrs mode base-ifield choices)
+    )
+)
+
+; Define an anyof operand object, name/value pair list version.
+
+(define define-anyof-operand
+  (lambda arg-list
+    (let ((op (apply -anyof-operand-read
+                    (cons "define-anyof-operand" arg-list))))
+      (if op
+         (current-op-add! op))
+      op))
+)
+\f
+; Utilities to flatten out the <anyof-operand> derivation heirarchy.
+
+; Utility class used when instantiating insns with derived operands.
+; This collects together in one place all the appropriate data of an
+; instantiated "anyof" operand.
+
+(define <anyof-instance>
+  (class-make '<anyof-instance>
+             '(<derived-operand>)
+             '(
+               ; <anyof-operand> object we were instantiated from.
+               parent
+               )
+             nil)
+)
+
+(method-make-make! <anyof-instance>
+                  '(name comment attrs mode
+                         args syntax base-ifield encoding ifield-assertion
+                         getter setter parent)
+)
+
+(define-getters <anyof-instance> anyof-instance (parent))
+
+(define (anyof-instance? x) (class-instance? <anyof-instance> x))
+
+; Return initial list of known ifield values in {anyof-instance}.
+
+(define (-anyof-initial-known anyof-instance)
+  (assert (derived-operand? anyof-instance))
+  (let ((encoding (derived-encoding anyof-instance)))
+    (assert (derived-ifield? encoding))
+    (ifld-known-values (derived-ifield-subfields encoding)))
+)
+
+; Return true if {anyof-instance} satisfies its ifield assertions.
+; {known-values} is the {known} argument to rtx-solve.
+
+(define (anyof-satisfies-assertions? anyof-instance known-values)
+  (assert (derived-operand? anyof-instance))
+  (let ((assertion (derived-ifield-assertion anyof-instance)))
+    (if assertion
+       (rtx-solve #f ; FIXME: context
+                  anyof-instance ; owner
+                  assertion
+                  known-values)
+       #t))
+)
+
+; Subroutine of -anyof-merge-subchoices.
+; Merge syntaxes of VALUE-NAMES/VALUES into SYNTAX.
+;
+; Example:
+; If SYNTAX is "$a+$b", and VALUE-NAMES is (b), and VALUES is
+; ("$c+$d"-object), then return "$a+$c+$d".
+
+(define (-anyof-syntax anyof-instance)
+  (elm-get anyof-instance 'syntax)
+)
+
+(define (-anyof-name anyof-instance)
+  (elm-get anyof-instance 'name)
+)
+
+
+(define (-anyof-merge-syntax syntax value-names values)
+  (let ((syntax-elements (syntax-break-out syntax)))
+    (syntax-make (map (lambda (e)
+                       (if (anyof-operand? e)
+                           (let* ((name (obj:name e))
+                                  (indx (element-lookup-index name value-names 0)))
+                             (assert indx)
+                             (-anyof-syntax (list-ref values indx)))
+                           e))
+                     syntax-elements)))
+)
+
+; Subroutine of -anyof-merge-subchoices.
+; Merge syntaxes of {value-names}/{values} into <derived-ifield> {encoding}.
+; The result is a new <derived-ifield> object with subfields matching
+; {value-names} replaced with {values}.
+; {container} is the containing <anyof-operand>.
+;
+; Example:
+; If {encoding} is (a-ifield-object b-anyof-ifield-object), and {value-names}
+; is (b), and {values} is (c-choice-of-b-object), then return
+; (a-ifield-object c-choice-of-b-ifield-object).
+
+(define (-anyof-merge-encoding container encoding value-names values)
+  (assert (derived-ifield? encoding))
+  (let ((subfields (derived-ifield-subfields encoding))
+       (result (object-copy-top encoding)))
+    ; Delete all the elements that are being replaced with ifields from
+    ; {values} and add the new ifields.
+    (derived-ifield-set-subfields! result
+                                  (append
+                                   (find (lambda (f)
+                                           (not (memq (obj:name f) value-names)))
+                                         subfields)
+                                   (map derived-encoding values)))
+    result)
+)
+
+; Subroutine of -anyof-merge-subchoices.
+; Merge semantics of VALUE-NAMES/VALUES into GETTER.
+;
+; Example:
+; If GETTER is (mem QI foo), and VALUE-NAMES is (foo), and VALUES is
+; ((add a b)-object), then return (mem QI (add a b)).
+
+(define (-anyof-merge-getter getter value-names values)
+  ;(debug-repl-env getter value-names values)
+  ; ??? This implementation is a quick hack, intended to evolve or be replaced.
+  (cond ((not getter)
+        #f)
+       (else
+        (map (lambda (e)
+               (cond ((symbol? e)
+                      (let ((indx (element-lookup-index e value-names 0)))
+                        (if indx
+                            (op:getter (list-ref values indx))
+                            e)))
+                     ((pair? e) ; pair? -> cheap non-null-list?
+                      (-anyof-merge-getter e value-names values))
+                     (else
+                      e)))
+             getter)))
+)
+
+; Subroutine of -anyof-merge-subchoices.
+; Merge semantics of VALUE-NAMES/VALUES into SETTER.
+;
+; Example:
+; If SETTER is (set (mem QI foo) newval), and VALUE-NAMES is (foo),
+; and VALUES is ((add a b)-object), then return
+; (set (mem QI (add a b)) newval).
+;
+; ??? `newval' in this context is a reserved word.
+
+(define (-anyof-merge-setter setter value-names values)
+  ;(debug-repl-env setter value-names values)
+  ; ??? This implementation is a quick hack, intended to evolve or be replaced.
+  (cond ((not setter)
+        #f)
+       ((rtx-single-set? setter)
+        (let ((src (rtx-set-src setter))
+              (dest (rtx-set-dest setter))
+              (mode (rtx-mode setter))
+              (options (rtx-options setter)))
+          (if (rtx-kind 'mem dest)
+              (set! dest
+                    (rtx-change-address dest
+                                        (-anyof-merge-getter
+                                         (rtx-mem-addr dest)
+                                         value-names values))))
+          (set! src (-anyof-merge-getter src value-names values))
+          (rtx-make 'set options mode dest src)))
+       (else
+        (error "-anyof-merge-setter: unsupported form" (car setter))))
+)
+
+; Subroutine of -sub-insn-make!.
+; Merge semantics of VALUE-NAMES/VALUES into SEMANTICS.
+; Defined here and not in insn.scm to keep it with the getter/setter mergers.
+;
+; Example:
+; If SEMANTICS is (mem QI foo), and VALUE-NAMES is (foo), and VALUES is
+; ((add a b)-object), then return (mem QI (add a b)).
+
+(define (anyof-merge-semantics semantics value-names values)
+  ;(debug-repl-env semantics value-names values)
+  ; ??? This implementation is a quick hack, intended to evolve or be replaced.
+  (let ((result
+        (cond ((not semantics)
+               #f)
+              (else
+               (map (lambda (e)
+                      (cond ((symbol? e)
+                             (let ((indx (element-lookup-index e value-names 0)))
+                               (if indx
+                                   (-anyof-name (list-ref values indx))
+                                   ; (op:sem-name (list-ref values indx))
+                                   e)))
+                            ((pair? e) ; pair? -> cheap non-null-list?
+                             (anyof-merge-semantics e value-names values))
+                            (else
+                             e)))
+                    semantics)))))
+    (logit 4 "Merged semantics [" semantics "] -> [" result "]\n")
+    result)
+)
+
+; Subroutine of -anyof-merge-subchoices.
+; Merge assertion of VALUE-NAMES/VALUES into ASSERTION.
+;
+; Example:
+; If ASSERTION is (ne f-base-reg 5), and VALUE-NAMES is
+; (foo), and VALUES is ((ne f-mod 0)), then return
+; (andif (ne f-base-reg 5) (ne f-mod 0)).
+;
+; FIXME: Perform simplification pass, based on combined set of known
+; ifield values.
+
+(define (-anyof-merge-ifield-assertion assertion value-names values)
+  (let ((assertions (find identity
+                         (cons assertion
+                               (map derived-ifield-assertion values)))))
+    (if (null? assertions)
+       #f
+       (rtx-combine 'andif assertions)))
+)
+
+; Subroutine of -anyof-all-subchoices.
+; Return a copy of <derived-operand> CHOICE with NEW-ARGS from ANYOF-ARGS
+; merged in.  This is for when a derived operand is itself composed of
+; anyof operands.
+; ANYOF-ARGS is a list of <anyof-operand>'s to be replaced in CHOICE.
+; NEW-ARGS is a corresponding list of values (<derived-operands>'s) of each
+; element in ANYOF-ARGS.
+; CONTAINER is the <anyof-operand> containing CHOICE.
+
+(define (-anyof-merge-subchoices container choice anyof-args new-args)
+  (assert (all-true? (map anyof-operand? anyof-args)))
+  (assert (all-true? (map derived-operand? new-args)))
+
+  (let* ((arg-names (map obj:name anyof-args))
+        (encoding (-anyof-merge-encoding container (derived-encoding choice)
+                                         arg-names new-args))
+        (result
+         (make <anyof-instance>
+               (apply symbol-append
+                      (cons (obj:name choice)
+                            (map (lambda (anyof)
+                                   (symbol-append '- (obj:name anyof)))
+                                 new-args)))
+               (obj:comment choice)
+               (obj-atlist choice)
+               (op:mode choice)
+               (derived-args choice)
+               (-anyof-merge-syntax (derived-syntax choice)
+                                    arg-names new-args)
+               (derived-base-ifield choice)
+               encoding
+               (-anyof-merge-ifield-assertion (derived-ifield-assertion choice)
+                                              anyof-args new-args)
+               (-anyof-merge-getter (op:getter choice)
+                                    arg-names new-args)
+               (-anyof-merge-setter (op:setter choice)
+                                    arg-names new-args)
+               container)))
+    ;
+    (elm-set! result 'index encoding)
+    ; Creating the link from {encoding} to {result}.
+    (derived-ifield-set-owner! encoding result)
+    result)
+)
+
+; Subroutine of -anyof-all-choices-1.
+; Return a list of all possible subchoices of <derived-operand> ANYOF-CHOICE,
+; known to use <anyof-operand>'s itself.
+; CONTAINER is the containing <anyof-operand>.
+
+(define (-anyof-all-subchoices container anyof-choice)
+  ; Split args into anyof and non-anyof elements.
+  (let* ((args (derived-args anyof-choice))
+        (anyof-args (find anyof-operand? args)))
+
+    (assert (not (null? anyof-args)))
+
+    ; Iterate over all combinations.
+    ; {todo} is a list with one element for each anyof argument.
+    ; Each element is in turn a list of all <derived-operand> choices for the
+    ; <anyof-operand>.  The result we want is every possible combination.
+    ; Example:
+    ; If {todo} is ((1 2 3) (a) (B C)) the result we want is
+    ; ((1 a B) (1 a C) (2 a B) (2 a C) (3 a B) (3 a C)).
+    ;
+    ; Note that some of these values may be derived from nested
+    ; <anyof-operand>'s which is why we recursively call -anyof-all-choices-1.
+    ; ??? -anyof-all-choices-1 should cache the results.
+
+    (let* ((todo (map -anyof-all-choices-1 anyof-args))
+          (lengths (map length todo))
+          (total (apply * lengths))
+          (result nil))
+
+      ; ??? One might prefer a `do' loop here, but every time I see one I
+      ; have to spend too long remembering its syntax.
+      (let loop ((i 0))
+       (if (< i total)
+           (let* ((indices (split-value lengths i))
+                  (new-args (map list-ref todo indices)))
+             ;(display "new-args: " (current-error-port))
+             ;(display (map obj:name new-args) (current-error-port))
+             ;(newline (current-error-port))
+             (set! result
+                   (cons (-anyof-merge-subchoices container
+                                                  anyof-choice
+                                                  anyof-args
+                                                  new-args)
+                         result))
+             (loop (+ i 1)))))
+
+      result))
+)
+
+; Return an <anyof-instance> object from <derived-operand> {derop}, which is a
+; choice of {anyof-operand}.
+
+(define (-anyof-instance-from-derived anyof-operand derop)
+  (let* ((encoding (object-copy-top (derived-encoding derop)))
+        (result
+         (make <anyof-instance>
+               (obj:name derop)
+               (obj:comment derop)
+               (obj-atlist derop)
+               (op:mode derop)
+               (derived-args derop)
+               (derived-syntax derop)
+               (derived-base-ifield derop)
+               encoding
+               (derived-ifield-assertion derop)
+               (op:getter derop)
+               (op:setter derop)
+               anyof-operand)))
+    ; Creating the link from {encoding} to {result}.
+    (derived-ifield-set-owner! encoding result)
+    result)
+)
+
+; Return list of <anyof-instance> objects, one for each possible variant of
+; ANYOF-OPERAND.
+;
+; One could move this up into the cpu description file using pmacros.
+; However, that's not the right way to go.  How we currently implement
+; the notion of derived operands is separate from the notion of having them
+; in the description language.  pmacros are not "in" the language (to the
+; extent that the cpu description file reader "sees" them), they live
+; above it.  And the right way to do this is with something "in" the language.
+; Derived operands are the first cut at it.  They'll evolve or be replaced
+; (and it's the implementation of them that will evolve first).
+
+(define (-anyof-all-choices-1 anyof-operand)
+  (assert (anyof-operand? anyof-operand))
+
+  (let ((result nil))
+
+    ; For each choice, scan the operands for further derived operands.
+    ; If found, replace the choice with the list of its subchoices.
+    ; If not found, create an <anyof-instance> object for it.  This is basically
+    ; just a copy of the object, but {anyof-operand} is recorded with it so
+    ; that we can later resolve `follows' specs.
+
+    (let loop ((choices (anyof-choices anyof-operand)))
+      (if (not (null? choices))
+         (let* ((this (car choices))
+                (args (derived-args this)))
+
+           (if (any-true? (map anyof-operand? args))
+
+               ; This operand has "anyof" operands so we need to turn this
+               ; choice into a list of all possible subchoices.
+               (let ((subchoices (-anyof-all-subchoices anyof-operand this)))
+                 (set! result
+                       (append subchoices result)))
+
+               ; No <anyof-operand> arguments.
+               (set! result
+                     (cons (-anyof-instance-from-derived anyof-operand this)
+                           result)))
+
+           (loop (cdr choices)))))
+
+    (assert (all-true? (map anyof-instance? result)))
+    result)
+)
+
+; Cover fn of -anyof-all-choices-1.
+; Return list of <anyof-instance> objects, one for each possible variant of
+; ANYOF-OPERAND.
+; We want to delete choices that fail their ifield assertions, but since
+; -anyof-all-choices-1 can recursively call itself, assertion checking is
+; defered until it returns.
+
+(define (anyof-all-choices anyof-operand)
+  (let ((all-choices (-anyof-all-choices-1 anyof-operand)))
+
+    ; Delete ones that fail their ifield assertions.
+    ; Sometimes there isn't enough information yet to completely do this.
+    ; When that happens it is the caller's responsibility to deal with it.
+    ; However, it is our responsibility to assert as much as we can.
+    (find (lambda (op)
+           (anyof-satisfies-assertions? op
+                                        (-anyof-initial-known op)))
+         all-choices))
+)
+\f
+; Operand utilities.
+
+; Look up operand NAME in the operand table.
+; This proc isolates the strategy we use to record operand objects.
+
+; Look up an operand via SEM-NAME.
+
+(define (op:lookup-sem-name op-list sem-name)
+  (let loop ((op-list op-list))
+    (cond ((null? op-list) #f)
+         ((eq? sem-name (op:sem-name (car op-list))) (car op-list))
+         (else (loop (cdr op-list)))))
+)
+
+; Given an operand, return the starting bit number.
+; Note that the field isn't necessarily contiguous.
+
+(define (op:start operand) (send operand 'field-start #f))
+
+; Given an operand, return the total length in bits.
+; Note that the field isn't necessarily contiguous.
+
+(define (op:length operand) (send operand 'field-length))
+
+; Return the nub of a list of operands, base on their names.
+
+(define (op-nub op-list)
+  (nub op-list obj:name)
+)
+
+; Return a sorted list of operand lists.
+; Each element in the inner list is an operand with the same name, but for
+; whatever reason were defined separately.
+; The outer list is sorted by name.
+
+(define (op-sort op-list)
+  ; We assume there is at least one operand.
+  (if (null? op-list)
+      (error "op-sort: no operands!"))
+  ; First sort by name.
+  (let ((sorted-ops (sort op-list
+                         (lambda (a b)
+                            (string<? (obj:name a) (obj:name b)))))
+       )
+    (let loop ((result nil)
+              ; Current set of operands with same name.
+              (this-elm (list (car sorted-ops)))
+              (ops (cdr sorted-ops))
+              )
+      (if (null? ops)
+         ; Reverse things to keep them in file order (minimizes random
+         ; changes in generated files).
+         (reverse! (cons (reverse! this-elm) result))
+         ; Not done.  Check for new set.
+         (if (eq? (obj:name (car ops)) (obj:name (car this-elm)))
+             (loop result (cons (car ops) this-elm) (cdr ops))
+             (loop (cons (reverse! this-elm) result) (list (car ops))
+                   (cdr ops))))))
+)
+
+; FIXME: Not used anymore but leave in for now.
+; Objects used in assembler syntax ($0, $1, ...).
+;
+;(define <syntax-operand>
+;  (class-make '<syntax-operand> nil '(number value) nil))
+;(method-make-make! <syntax-operand> '(number))
+;
+;(define $0 (make <syntax-operand> 0))
+;(define $1 (make <syntax-operand> 1))
+;(define $2 (make <syntax-operand> 2))
+;(define $3 (make <syntax-operand> 3))
+\f
+; Called before/after loading the .cpu file to initialize/finalize.
+
+; Builtins.
+; The pc operand used in rtl expressions.
+(define pc nil)
+
+; Called before reading a .cpu file in.
+
+(define (operand-init!)
+  (reader-add-command! 'define-operand
+                      "\
+Define an operand, name/value pair list version.
+"
+                      nil 'arg-list define-operand)
+  (reader-add-command! 'define-full-operand
+                      "\
+Define an operand, all arguments specified.
+"
+                      nil '(name comment attrs hw-type mode hw-index handlers getter setter)
+                      define-full-operand)
+
+  (reader-add-command! 'define-derived-operand
+                      "\
+Define a derived operand, name/value pair list version.
+"
+                      nil 'arg-list define-derived-operand)
+
+  (reader-add-command! 'define-anyof-operand
+                      "\
+Define an anyof operand, name/value pair list version.
+"
+                      nil 'arg-list define-anyof-operand)
+
+  *UNSPECIFIED*
+)
+
+; Install builtin operands.
+
+(define (operand-builtin!)
+  ; Standard operand attributes.
+  ; ??? Some of these can be combined into one.
+
+  (define-attr '(for operand) '(type boolean) '(name NEGATIVE)
+    '(comment "value is negative"))
+  (define-attr '(for operand) '(type boolean) '(name RELAX)
+    '(comment "operand is relaxable"))
+
+  ; ??? Might be able to make SEM-ONLY go away (or machine compute it)
+  ; by scanning which operands are refered to by the insn syntax strings.
+  (define-attr '(for operand) '(type boolean) '(name SEM-ONLY)
+    '(comment "operand is for semantic use only"))
+
+  ; Also (defined elsewhere): PCREL-ADDR ABS-ADDR.
+
+  (set! pc (make <pc>))
+  (current-op-add! pc)
+
+  *UNSPECIFIED*
+)
+
+; Called after a .cpu file has been read in.
+
+(define (operand-finish!)
+  *UNSPECIFIED*
+)
diff --git a/cgen/pgmr-tools.scm b/cgen/pgmr-tools.scm
new file mode 100644 (file)
index 0000000..c945aea
--- /dev/null
@@ -0,0 +1,183 @@
+; Programmer development tools.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+;
+; This file contains a collection of programmer debugging tools.
+; They're mainly intended for using cgen to debug other things,
+; but any kind of debugging tool can go here.
+; All routines require the application independent part of cgen to be loaded
+; and the .cpu file to be loaded.  They do not require any particular
+; application though (opcodes, simulator, etc.).  If they do, that's a bug.
+; It may be that the appication has a generally useful routine that should
+; live elsewhere, but that's it.
+;
+; These tools don't have to be particularily efficient (within reason).
+; It's more important that they be simple and clear.
+;
+; Some tools require ifmt-compute! to be run.
+; They will run it if necessary.
+;
+; Table of contents:
+;
+; pgmr-pretty-print-insn-format
+;   cgen debugging tool, pretty prints the iformat of an <insn> object
+;
+; pgmr-pretty-print-insn-value
+;   break out an instruction's value into its component fields
+;
+; pgmr-lookup-insn
+;   given a random bit pattern for an instruction, lookup the insn and return
+;   its <insn> object
+\f
+; Pretty print the instruction's opcode value, for debugging.
+; INSN is an <insn> object.
+
+(define (pgmr-pretty-print-insn-format insn)
+
+  (define (to-width width n-str)
+    (string-take-with-filler (- width)
+                            n-str
+                            #\0))
+
+  (define (dump-insn-mask mask insn-length)
+    (string-append "0x" (to-width (quotient insn-length 4)
+                                 (number->string mask 16))
+                  ", "
+                  (string-map
+                   (lambda (n)
+                     (string-append " " (to-width 4 (number->string n 2))))
+                   (reverse
+                    (split-bits (make-list (quotient insn-length 4) 4)
+                                mask)))))
+
+  ; Print VALUE with digits not in MASK printed as "X".
+  (define (dump-insn-value value mask insn-length)
+    (string-append "0x" (to-width (quotient insn-length 4)
+                                 (number->string value 16))
+                  ", "
+                  (string-map
+                   (lambda (n mask)
+                     (string-append
+                      " "
+                      (list->string
+                       (map (lambda (char in-mask?)
+                              (if in-mask? char #\X))
+                            (string->list (to-width 4 (number->string n 2)))
+                            (bits->bools mask 4)))))
+                   (reverse
+                    (split-bits (make-list (quotient insn-length 4) 4)
+                                value))
+                   (reverse
+                    (split-bits (make-list (quotient insn-length 4) 4)
+                                mask)))))
+
+  (define (dump-ifield f)
+    (string-append " Name: "
+                  (obj:name f)
+                  ", "
+                  "Start: "
+                  (number->string
+                   (+ (bitrange-word-offset (-ifld-bitrange f))
+                      (bitrange-start (-ifld-bitrange f))))
+                  ", "
+                  "Length: "
+                  (number->string (ifld-length f))
+                  "\n"))
+
+  (let* ((iflds (sort-ifield-list (insn-iflds insn)
+                                 (not (current-arch-insn-lsb0?))))
+        (mask (compute-insn-base-mask iflds))
+        (mask-length (compute-insn-base-mask-length iflds)))
+
+    (display
+     (string-append
+      "Instruction: " (obj:name insn)
+      "\n"
+      "Syntax: "
+      (insn-syntax insn)
+      "\n"
+      "Fields:\n"
+      (string-map dump-ifield iflds)
+      "Instruction length (computed from ifield list): "
+      (number->string (apply + (map ifld-length iflds)))
+      "\n"
+      "Mask:  "
+      (dump-insn-mask mask mask-length)
+      "\n"
+      "Value: "
+      (let ((value (apply +
+                         (map (lambda (fld)
+                                (ifld-value fld mask-length
+                                            (ifld-get-value fld)))
+                              (find ifld-constant? (collect ifld-base-ifields (insn-iflds insn)))))))
+       (dump-insn-value value mask mask-length))
+      ; TODO: Print value spaced according to fields.
+      "\n"
+      )))
+)
+
+; Pretty print an instruction's value.
+
+(define (pgmr-pretty-print-insn-value insn value)
+  (define (dump-ifield ifld value name-width)
+    (string-append
+     (string-take name-width (obj:name ifld))
+     ": "
+     (number->string value)
+     ", 0x"
+     (number->hex value)
+     "\n"))
+
+  (let ((ifld-values (map (lambda (ifld)
+                           (ifld-extract ifld insn value))
+                         (insn-iflds insn)))
+       (max-name-length (apply max
+                               (map string-length
+                                    (map obj:name
+                                         (insn-iflds insn)))))
+       )
+
+    (display
+     (string-append
+      "Instruction: " (obj:name insn)
+      "\n"
+      "Fields:\n"
+      (string-map (lambda (ifld value)
+                   (dump-ifield ifld value max-name-length))
+                 (insn-iflds insn)
+                 ifld-values)
+      )))
+)
+\f
+; Return the <insn> object matching VALUE.
+; VALUE is either a single number of size base-insn-bitsize,
+; or a list of numbers for variable length ISAs.
+; LENGTH is the total length of VALUE in bits.
+
+(define (pgmr-lookup-insn length value)
+  (arch-analyze-insns! CURRENT-ARCH
+                      #t ; include aliases
+                      #f) ; don't need to analyze semantics
+
+  ; Return a boolean indicating if BASE matches the base part of <insn> INSN.
+  (define (match-base base insn)
+    (let ((mask (compute-insn-base-mask (insn-iflds insn)))
+         (ivalue (insn-value insn)))
+      ; return (value & mask) == ivalue
+      (= (logand base mask) ivalue)))
+
+  (define (match-rest value insn)
+    #t)
+
+  (let ((base (if (list? value) (car value) value)))
+    (let loop ((insns (current-insn-list)))
+      (if (null? insns)
+         #f
+         (let ((insn (car insns)))
+           (if (and (= length (insn-length insn))
+                    (match-base base insn)
+                    (match-rest value insn))
+               insn
+               (loop (cdr insns)))))))
+)
diff --git a/cgen/play.cpu b/cgen/play.cpu
new file mode 100644 (file)
index 0000000..3ef3775
--- /dev/null
@@ -0,0 +1,265 @@
+; cpu description for debugging and experimental purposes. -*- Scheme -*-
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+; Copyright (C) 2000 Red Hat, Inc.
+;
+; This file is for experimental purposes.  Don't expect it to be correct
+; or up to date.
+
+(include "simplify.inc")
+
+(define-arch
+  (name play) ; name of cpu
+  (comment "experimental .cpu file")
+  (insn-lsb0? #f)
+  (machs playb)
+  (isas play)
+)
+
+(define-isa
+  (name play)
+  (base-insn-bitsize 16)
+  (decode-assist (0 1 2 3))
+)
+  
+(define-cpu
+  (name cpuf)
+  (comment "experimental cpu family")
+  (endian little)
+  (word-bitsize 32)
+)
+
+(define-mach
+  (name playb)
+  (comment "experimental mach")
+  (cpu cpuf)
+)
+
+(define-model
+  (name test) (comment "test") (attrs)
+  (mach playb)
+  ;(pipeline all "" () ((fetch) (decode) (execute) (writeback)))
+  (unit u-exec "Execution Unit" () 1 1
+       () () () ())
+)
+\f
+; Instruction fields.
+
+(dnf f-op1       "op1"                 () 0 4)
+(dnf f-op2       "op2"                 () 4 4)
+(dnf f-op3       "op3"                 () 8 4)
+(dnf f-op4       "op4"                 () 12 4)
+(dnf f-r1        "r1"                  () 8 4)
+(dnf f-r2        "r2"                  () 12 4)
+(df  f-simm16     "simm16"             () 16 16 INT #f #f)
+
+(define-normal-insn-enum insn-op1 "insn format enums" () OP1_ f-op1
+  (.map .str (.iota 16))
+)
+
+(define-normal-insn-enum insn-op2 "insn format enums (2)" () OP2_ f-op2
+  (.map .str (.iota 16))
+)
+
+(define-normal-insn-enum insn-op3 "insn format enums (3)" () OP3_ f-op3
+  (.map .str (.iota 16))
+)
+
+(define-normal-insn-enum insn-op4 "insn format enums (4)" () OP4_ f-op4
+  (.map .str (.iota 16))
+)
+\f
+; Hardware.
+
+(dnh h-pc "program counter" (PC PROFILE) (pc) () () ())
+
+(define-hardware
+  (name h-gr)
+  (comment "general registers")
+  (attrs PROFILE );CACHE-ADDR)
+  (type register WI (16))
+  (indices keyword ""
+          ( (fp 13) (lr 14) (sp 15)
+            (r0 0) (r1 1) (r2 2) (r3 3) (r4 4) (r5 5) (r6 6) (r7 7)
+            (r8 8) (r9 9) (r10 10) (r11 11) (r12 12) (r13 13) (r14 14) (r15 15)
+            ))
+)
+
+(define-hardware
+  (name h-status)
+  (comment "status reg")
+  (type register SI)
+  (get () (const 0))
+  (set (newval) (nop))
+)
+
+; These bits are actualy part of the PS register
+(dsh h-nbit "negative bit" () (register BI))
+(dsh h-zbit "zero     bit" () (register BI))
+(dsh h-vbit "overflow bit" () (register BI))
+(dsh h-cbit "carry    bit" () (register BI))
+
+(dsh h-df "df test" () (register DF))
+(dsh h-tf "tf test" () (register TF))
+\f
+; Operand attributes.
+
+(define-attr
+  (for operand)
+  (type boolean)
+  (name HASH-PREFIX)
+  (comment "immediates have a '#' prefix")
+)
+\f
+; Operands.
+
+(dnop nbit "negative bit" (SEM-ONLY) h-nbit f-nil)
+(dnop vbit "overflow bit" (SEM-ONLY) h-vbit f-nil)
+(dnop zbit "zero     bit" (SEM-ONLY) h-zbit f-nil)
+(dnop cbit "carry    bit" (SEM-ONLY) h-cbit f-nil)
+
+(dnop dr     "destination register"    () h-gr   f-r1)
+(dnop sr     "source register"         () h-gr   f-r2)
+(dnop simm-16 "16 bit signed immediate" (HASH-PREFIX) h-sint f-simm16)
+
+; Note that `df' doesn't work as that is a pmacro.
+(dnop df-reg "df reg" () h-df f-nil)
+(dnop tf-reg "tf reg" () h-tf f-nil)
+\f
+; Instructions.
+
+(dni add "add"
+     ()
+     "add $dr,$sr"
+     (+ OP1_4 OP2_0 dr sr)
+     (sequence ()
+              (set vbit (add-oflag dr sr (const 0)))
+              (set cbit (add-cflag dr sr (const 0)))
+              (set dr (add dr sr))
+              (set zbit (zflag dr))
+              (set nbit (nflag dr)))
+     ()
+)
+
+(dni addv2 "add version 2"
+     ()
+     "add $dr,$sr"
+     (+ OP1_4 OP2_1 dr sr)
+     (sequence ((WI tmp1))
+              (parallel ()
+                        (set tmp1 (add dr sr))
+                        (set vbit (add-oflag dr sr (const 0)))
+                        (set cbit (add-cflag dr sr (const 0))))
+              (set zbit (zflag tmp1))
+              (set nbit (nflag tmp1))
+              (set dr tmp1)
+              )
+     ()
+)
+
+(dni addi "addi"
+     ()
+     "addi $dr,$sr,$simm-16"
+     (+ OP1_4 OP2_2 dr sr simm-16)
+     (set dr (add sr simm-16))
+     ()
+)
+
+(define-pmacro (reg+ oprnd n)
+  (reg h-gr (add (index-of oprnd) (const n)))
+)
+
+(dni ldm "ldm"
+     ()
+     "ldm $dr,$sr"
+     (+ OP1_5 OP2_2 dr sr)
+     (sequence ()
+              (set dr sr)
+              (set (reg+ dr 1) (reg+ sr 1))
+              )
+     ()
+)
+
+(dni use-ifield "use-ifield"
+     ()
+     "foo $dr,$sr"
+     (+ OP1_5 OP2_3 dr sr)
+     (sequence ()
+              (set dr (ifield f-r2))
+              )
+     ()
+)
+
+(dni use-index-of "index-of"
+     ()
+     "index-of $dr,$sr"
+     (+ OP1_5 OP2_4 dr sr)
+     (set dr (reg h-gr (add (index-of sr) (const 1))))
+     ()
+)
+
+(dni load-df "use df"
+     ()
+     "load-df df,[$sr]"
+     (+ OP1_6 OP2_0 OP3_0 sr)
+     (set df-reg (mem DF sr))
+     ()
+)
+
+(dni make-df "use df"
+     ()
+     "make-df df,[$sr]"
+     (+ OP1_6 OP2_1 OP3_0 sr)
+     (set df-reg (join DF SI (mem SI sr) (mem SI (add sr (const 4)))))
+     ()
+)
+
+(dni split-df "use df"
+     ()
+     "split-df df,[$sr]"
+     (+ OP1_6 OP2_2 OP3_0 sr)
+     (sequence ((DF temp))
+              (set temp df-reg)
+              (set (concat (SI SI)
+                            sr
+                            (reg h-gr (add (regno sr) (const 1))))
+                   (split DF SI temp))
+              )
+     ()
+)
+
+(dni load-tf "use tf"
+     ()
+     "load-tf tf,[$sr]"
+     (+ OP1_6 OP2_3 OP3_0 sr)
+     (set tf-reg (mem TF sr))
+     ()
+)
+
+(dni make-tf "use tf"
+     ()
+     "make-tf tf,[$sr]"
+     (+ OP1_6 OP2_4 OP3_0 sr)
+     (set tf-reg (join TF SI
+                   sr
+                   (reg h-gr (add (regno sr) (const 1)))
+                   (reg h-gr (add (regno sr) (const 2)))
+                   (reg h-gr (add (regno sr) (const 3)))))
+     ()
+)
+
+(dni split-tf "use tf"
+     ()
+     "split-tf tf,[$sr]"
+     (+ OP1_6 OP2_5 OP3_0 sr)
+     (sequence ((TF temp))
+              (set temp tf-reg)
+              (set (concat (SI SI SI SI)
+                            sr
+                            (reg h-gr (add (regno sr) (const 1)))
+                            (reg h-gr (add (regno sr) (const 2)))
+                            (reg h-gr (add (regno sr) (const 3))))
+                   (split TF SI temp))
+              )
+     ()
+)
diff --git a/cgen/pmacros.scm b/cgen/pmacros.scm
new file mode 100644 (file)
index 0000000..67e8480
--- /dev/null
@@ -0,0 +1,562 @@
+; Preprocessor-like macro support.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; TODO:
+; - Like C preprocessor macros, there is no scoping [one can argue
+;   there should be].  Maybe in time (??? Hmmm... done?)
+;   On the other hand these macros aren't intended for use outside
+;   the cpu description file.
+; - Support for multiple macro tables.
+; - Comments for .pmacros.
+
+; Required routines:
+; make-hash-table, hashq-ref, hashq-set!
+; string-append, symbol-append, map, apply, number?, number->string,
+; eval, num-args-ok?, *UNSPECIFIED*.
+; `num-args-ok?' and `*UNSPECIFIED*' are defined in cgen's utils.scm.
+
+; The convention we use says `-' begins "local" objects.
+; At some point this might also use the Guile module system.
+
+; Exported routines:
+;
+; pmacro-init! - initialize the pmacro system
+;
+; define-pmacro - define a symbolic or procedural macro
+;
+;      (define-pmacro symbol "comment" expansion)
+;      (define-pmacro (symbol [args]) "comment" (expansion))
+;
+; ARGS is a list of `symbol' or `(symbol default-value)' elements.
+;
+; pmacro-expand - expand all macros in an expression
+;
+;      (pmacro-expand expression)
+;
+; pmacro-trace - same as pmacro-expand, but print debugging messages
+;
+;      (pmacro-trace expression)
+
+; Builtin macros:
+;
+; (.sym symbol1 symbol2 ...)          - symbol-append
+; (.str string1 string2 ...)          - string-append
+; (.hex number)                       - convert to hex string
+; (.upcase string)                    - convert to uppercase
+; (.downcase string)                  - convert to lowercase
+; (.substring string start end)       - get part of a string
+; (.splice a b (.unsplice c) d e ...) - quasi-quote/unquote-splicing
+; (.iota count [start [increment]])   - number generator
+; (.map macro-name arg1 ...)          - map
+; (.apply macro-name arg)             - apply
+; (.pmacro (arg-list) expansion)      - lambda (??? call it .lambda?)
+; (.eval (expr))                      - eval (experimental)
+;
+; .sym and .str convert numbers to symbols/strings as necessary (base 10).
+;
+; .pmacro is for constructing pmacros on-the-fly, like lambda, and is currently
+; only valid as arguments to other macros.
+; ??? Nested pmacros don't bind their arguments the way nested lambda's do.
+; Should they?
+;
+; .eval is an experiment.  Ports that consider themselves to be of beta
+; quality or better don't use it.
+;
+; ??? Methinks .foo isn't a valid R5RS symbol.  May need to change 
+; to something else.  Where's Quad when you need it?! :-)
+
+(define -pmacro-trace? #f)
+
+(define -pmacro-table #f)
+(define (-pmacro-lookup name) (hashq-ref -pmacro-table name))
+(define (-pmacro-set! name val) (hashq-set! -pmacro-table name val))
+
+; Marker to indicate a value is a pmacro.
+(define -pmacro-marker '<pmacro>)
+
+; Utilities to create and access pmacros.
+(define (-pmacro-make name arg-spec default-values transformer comment)
+  (vector -pmacro-marker name arg-spec default-values transformer comment)
+)
+(define (-pmacro? x) (and (vector? x) (eq? (vector-ref x 0) -pmacro-marker)))
+(define (-pmacro-name pmac) (vector-ref pmac 1))
+(define (-pmacro-arg-spec pmac) (vector-ref pmac 2))
+(define (-pmacro-default-values pmac) (vector-ref pmac 3))
+(define (-pmacro-transformer pmac) (vector-ref pmac 4))
+(define (-pmacro-comment pmac) (vector-ref pmac 5))
+
+; Cover functions to manage an "environment" in case a need or desire for
+; another method arises.
+
+(define (-pmacro-env-make names values) (map cons names values))
+(define (-pmacro-env-ref env name) (assq name env))
+
+; Error message generator.
+
+(define (-pmacro-error msg expr)
+  (error (string-append
+         (or (port-filename (current-input-port)) "<input>")
+         ":"
+         (number->string (port-line (current-input-port)))
+         ":"
+         msg
+         ":")
+        expr)
+)
+
+; Process list of keyword/value specified arguments.
+
+(define (-pmacro-process-keyworded-args arg-spec default-values args)
+  ; Build a list of default values, then override ones specified in ARGS,
+  (let ((result-alist (alist-copy default-values)))
+    (let loop ((args args))
+      (cond ((null? args)
+            #f) ; done
+           ((and (pair? args) (keyword? (car args)))
+            (let ((elm (assq (car args) result-alist)))
+              (if (not elm)
+                  (-pmacro-error "not an argument name" (car args)))
+              (if (null? (cdr args))
+                  (-pmacro-error "missing argument to #:keyword" (car args)))
+              (set-cdr! elm (cadr args))
+              (loop (cddr args))))
+           (else
+            (-pmacro-error "bad keyword/value argument list" args))))
+
+    ; Ensure each element has a value.
+    (let loop ((to-scan result-alist))
+      (if (null? to-scan)
+         #f ; done
+         (begin
+           (if (not (cdar to-scan))
+               (-pmacro-error "argument value not specified" (caar to-scan)))
+           (loop (cdr to-scan)))))
+
+    ; If varargs pmacro, adjust result.
+    (if (list? arg-spec)
+       (map cdr result-alist) ; not varargs
+       (let ((nr-args (length (result-alist))))
+         (append! (map cdr (list-head result-alist (- nr-args 1)))
+                  (cdr (list-tail result-alist (- nr-args 1)))))))
+)
+
+; Process a pmacro argument list.
+; ARGS is either a fully specified position dependent argument list,
+; or is a list of keyword/value pairs with missing values coming from
+; DEFAULT-VALUES.
+
+(define (-pmacro-process-args arg-spec default-values args)
+  (if (and (pair? args) (keyword? (car args)))
+      (-pmacro-process-keyworded-args arg-spec default-values args)
+      args)
+)
+
+; Invoke a procedural macro.
+; ??? A better name might be -pmacro-apply but that is taken by the
+; .apply handler.
+
+(define (-pmacro-invoke macro args)
+  (let ((arg-spec (-pmacro-arg-spec macro))
+       (default-values (-pmacro-default-values macro)))
+    (let ((processed-args (-pmacro-process-args arg-spec default-values args)))
+      (if (not (num-args-ok? (length processed-args) arg-spec))
+         (-pmacro-error (string-append
+                         "wrong number of arguments to pmacro "
+                         (with-output-to-string
+                           (lambda ()
+                             (write (cons (-pmacro-name macro)
+                                          (-pmacro-arg-spec macro))))))
+                        args))
+      (apply (-pmacro-transformer macro) processed-args)))
+)
+
+; Expand expression EXP using ENV, an alist of variable assignments.
+
+(define (-pmacro-expand exp env)
+
+  (define cep (current-error-port))
+
+  ; If the symbol is in `env', return its value.
+  ; Otherwise see if symbol is a globally defined pmacro.
+  ; Otherwise return the symbol unchanged.
+  (define (scan-symbol sym)
+    (let ((val (-pmacro-env-ref env sym)))
+      (if val
+         (cdr val) ; cdr is value of (name . value) pair
+         (let ((val (-pmacro-lookup sym)))
+           (if val
+               ; Symbol is a macro.
+               ; If this is a procedural macro, let caller perform expansion.
+               ; Otherwise, return the macro's value.
+               (if (procedure? (-pmacro-transformer val))
+                   val
+                   (-pmacro-transformer val))
+               ; Return symbol unchanged.
+               sym)))))
+
+  ; See if (car exp) is a macro.
+  ; Return macro or #f.
+  (define (check-macro exp)
+    (if -pmacro-trace?
+       (begin
+         (display "macro?   " cep)
+         (write exp cep)
+         (newline cep)))
+    (and (-pmacro? (car exp)) (car exp)))
+
+  ; Scan each element in EXP and see if the result is a macro invocation.
+  (define (scan-list exp)
+    ; Check for syntactic forms.
+    (case (car exp)
+      ((.pmacro)
+       (if (not (= (length exp) 3))
+          (-pmacro-error "wrong number of arguments to .pmacro" exp))
+       (-pmacro-pmacro (cadr exp) (caddr exp)))
+      (else
+       (let ((scanned-exp (map scan exp)))
+        (let ((macro (check-macro scanned-exp)))
+          (if macro
+              (if (procedure? (-pmacro-transformer macro))
+                  (-pmacro-invoke macro (cdr scanned-exp))
+                  (cons (-pmacro-transformer macro) (cdr scanned-exp)))
+              scanned-exp))))))
+
+  ; Scan EXP, an arbitrary value.
+  (define (scan exp)
+    (let ((result (cond ((symbol? exp) (scan-symbol exp))
+                       ((and (list? exp) (not (null? exp))) (scan-list exp))
+                       ; Not a symbol or expression, return unchanged.
+                       (else exp))))
+      ; ??? We use to re-examine `result' to see if it was another pmacro
+      ; invocation.  This allowed doing things like ((.sym a b c) arg1 arg2)
+      ; where `abc' is a pmacro.  Scheme doesn't work this way, so it was
+      ; removed.  It can be put back should it ever be warranted.
+      result))
+
+  (if -pmacro-trace?
+      (begin
+       ; We use `write' to display `exp' to see strings quoted.
+       (display "expand: " cep) (write exp cep) (newline cep)
+       (display "   env: " cep) (display env cep) (newline cep)))
+
+  (let ((result (scan exp)))
+    (if -pmacro-trace?
+       (begin
+         (display "result:  " cep) (write result cep) (newline cep)))
+    result)
+)
+
+; Return the argument spec from ARGS.
+; ARGS is a [possibly improper] list of `symbol' or `(symbol default-value)'
+; elements.  For varargs pmacros, ARGS must be an improper list
+; (e.g. (a b . c)) with the last element being a symbol.
+
+(define (-pmacro-get-arg-spec args)
+  (let ((parse-arg
+        (lambda (arg)
+          (cond ((symbol? arg)
+                 arg)
+                ((and (pair? arg) (symbol? (car arg)))
+                 (car arg))
+                (else
+                 (-pmacro-error "argument not `symbol' or `(symbol . default-value)'"
+                                arg))))))
+    (if (list? args)
+       (map parse-arg args)
+       (letrec ((parse-improper-list
+                 (lambda (args)
+                   (cond ((symbol? args)
+                          args)
+                         ((pair? args)
+                          (cons (parse-arg (car args))
+                                (parse-improper-list (cdr args))))
+                         (else
+                          (-pmacro-error "argument not `symbol' or `(symbol . default-value)'"
+                                         args))))))
+         (parse-improper-list args))))
+)
+
+; Return the default values specified in ARGS.
+; The result is an alist of (#:arg-name . default-value) elements.
+; ARGS is a [possibly improper] list of `symbol' or `(symbol . default-value)'
+; elements.  For varargs pmacros, ARGS must be an improper list
+; (e.g. (a b . c)) with the last element being a symbol.
+; Unspecified default values are recorded as #f.
+
+(define (-pmacro-get-default-values args)
+  (let ((parse-arg
+        (lambda (arg)
+          (cond ((symbol? arg)
+                 (cons (symbol->keyword arg) #f))
+                ((and (pair? arg) (symbol? (car arg)))
+                 (cons (symbol->keyword (car arg)) (cdr arg)))
+                (else
+                 (-pmacro-error "argument not `symbol' or `(symbol . default-value)'"
+                                arg))))))
+    (if (list? args)
+       (map parse-arg args)
+       (letrec ((parse-improper-list
+                 (lambda (args)
+                   (cond ((symbol? args)
+                          (cons (parse-arg args) nil))
+                         ((pair? args)
+                          (cons (parse-arg (car args))
+                                (parse-improper-list (cdr args))))
+                         (else
+                          (-pmacro-error "argument not `symbol' or `(symbol . default-value)'"
+                                         args))))))
+         (parse-improper-list args))))
+)
+
+; Build a procedure that performs a pmacro expansion.
+
+(define (-pmacro-build-lambda params expansion)
+  (eval `(lambda ,params
+          (-pmacro-expand ',expansion (-pmacro-env-make ',params (list ,@params)))))
+)
+
+; ??? I'd prefer to use `define-macro', but boot-9.scm uses it and
+; I'd rather not risk a collision.  I could of course make the association
+; during parsing, maybe later.
+; ??? On the other hand, calling them pmacros removes all ambiguity.
+;
+; The syntax is one of:
+; (define (name args ...) expansion)
+; (define (name args ...) "documentation" expansion)
+;
+; If `expansion' is the name of a pmacro, its value is used (rather than its
+; name).
+; ??? The goal here is to follow Scheme's define/lambda, but not all variants
+; are supported yet.  There's also the difference that we treat undefined
+; symbols as being themselves.
+
+(define (define-pmacro header arg1 . arg-rest)
+  (let ((name (if (symbol? header) header (car header)))
+       (arg-spec (if (symbol? header) #f (-pmacro-get-arg-spec (cdr header))))
+       (default-values (if (symbol? header) #f (-pmacro-get-default-values (cdr header))))
+       (comment (if (null? arg-rest) "" arg1))
+       (expansion (if (null? arg-rest) arg1 (car arg-rest))))
+    (if (symbol? header)
+       (if (symbol? expansion)
+           (let ((maybe-pmacro (-pmacro-lookup expansion)))
+             (if maybe-pmacro
+                 (-pmacro-set! name
+                               (-pmacro-make name
+                                             (-pmacro-arg-spec maybe-pmacro)
+                                             (-pmacro-default-values maybe-pmacro)
+                                             (-pmacro-transformer maybe-pmacro)
+                                             comment))
+                 (-pmacro-set! name (-pmacro-make name #f #f expansion comment))))
+           (-pmacro-set! name (-pmacro-make name #f #f expansion comment)))
+       (-pmacro-set! name
+                     (-pmacro-make name arg-spec default-values
+                                   (-pmacro-build-lambda arg-spec expansion)
+                                   comment))))
+    *UNSPECIFIED*
+)
+
+; Expand any pmacros in EXPR.
+
+(define (pmacro-expand expr)
+  (-pmacro-expand expr '())
+)
+
+; Debugging routine to trace macro expansion.
+
+(define (pmacro-trace expr)
+  ; ??? Need unwind protection.
+  (let ((old -pmacro-trace?))
+    (set! -pmacro-trace? #t)
+    (let ((result (-pmacro-expand expr '())))
+      (set! -pmacro-trace? old)
+      result))
+)
+\f
+; Builtin macros.
+
+; .sym - symbol-append, auto-convert numbers
+
+(define -pmacro-sym
+  (lambda args
+    (apply symbol-append
+          (map (lambda (elm)
+                 (if (number? elm)
+                     (number->string elm)
+                     elm))
+               args)))
+)
+
+; .str - string-append, auto-convert numbers
+
+(define -pmacro-str
+  (lambda args
+    (apply string-append
+          (map (lambda (elm)
+                 (if (number? elm)
+                     (number->string elm)
+                     elm))
+               args)))
+)
+
+; .hex - convert number to hex string
+; WIDTH, if present, is the number of characters in the result, beginning
+; from the least significant digit.
+
+(define (-pmacro-hex num . width)
+  (if (> (length width) 1)
+      (-pmacro-error "wrong number of arguments to .hex"
+                    (cons '.hex (cons num width))))
+  (let ((str (number->string num 16)))
+    (if (null? width)
+       str
+       (let ((len (string-length str)))
+         (substring (string-append (make-string (car width) #\0) str)
+                    len (+ len (car width))))))
+)
+
+; .upcase - convert a string to uppercase
+
+(define (-pmacro-upcase str)
+  (string-upcase str)
+)
+
+; .downcase - convert a string to lowercase
+
+(define (-pmacro-downcase str)
+  (string-downcase str)
+)
+
+; .substring - get part of a string
+
+(define (-pmacro-substring str start end)
+  (substring str start end)
+)
+
+; .splice - splicing support
+; Splice lists into the outer list.
+;
+; E.g. (define-pmacro '(splice-test a b c) '(.splice a (.unsplice b) c))
+; (pmacro-expand '(splice-test (1 (2) 3))) --> (1 2 3)
+;
+; Similar to `(1 ,@'(2) 3) in Scheme, though the terminology is slightly
+; different (??? may need to revisit).  In Scheme we have quasi-quote,
+; unquote, unquote-splicing.  Here we have splice, unsplice.
+
+(define -pmacro-splice
+  (lambda arg-list
+    ; ??? Not the most efficient implementation, but will the difference
+    ; ever be measureable?
+    (let loop ((arg-list arg-list) (result '()))
+      (cond ((null? arg-list) result)
+           ((and (pair? (car arg-list)) (eq? '.unsplice (caar arg-list)))
+            (if (= (length (car arg-list)) 2)
+                (if (list? (cadar arg-list))
+                    (loop (cdr arg-list) (append result (cadar arg-list)))
+                    (-pmacro-error "argument to .unsplice must be a list"
+                                   (car arg-list)))
+                (-pmacro-error "wrong number of arguments to .unsplice"
+                               (car arg-list))))
+           (else
+            (loop (cdr arg-list) (append result (list (car arg-list))))))))
+)
+
+; .iota
+; Usage:
+; (.iota count)            ; start=0, incr=1
+; (.iota count start)      ; incr=1
+; (.iota count start incr)
+
+(define (-pmacro-iota count . start-incr)
+  (if (> (length start-incr) 2)
+      (-pmacro-error "wrong number of arguments to .iota"
+                    (cons '.iota (cons count start-incr))))
+  (if (< count 0)
+      (-pmacro-error "count must be non-negative"
+                    (cons '.iota (cons count start-incr))))
+  (let ((start (if (pair? start-incr) (car start-incr) 0))
+       (incr (if (= (length start-incr) 2) (cadr start-incr) 1)))
+    (let loop ((i start) (count count) (result '()))
+      (if (= count 0)
+         (reverse! result)
+         (loop (+ i incr) (- count 1) (cons i result)))))
+)
+
+; .map
+
+(define (-pmacro-map pmacro arg1 . arg-rest)
+  (if (not (-pmacro? pmacro))
+      (-pmacro-error "not a pmacro" pmacro))
+  (let ((transformer (-pmacro-transformer pmacro)))
+    (if (not (procedure? transformer))
+       (-pmacro-error "not a procedural macro" pmacro))
+    (apply map (cons transformer (cons arg1 arg-rest))))
+)
+
+; .apply
+
+(define (-pmacro-apply pmacro arg-list)
+  (if (not (-pmacro? pmacro))
+      (-pmacro-error "not a pmacro" pmacro))
+  (let ((transformer (-pmacro-transformer pmacro)))
+    (if (not (procedure? transformer))
+       (-pmacro-error "not a procedural macro" pmacro))
+    (apply transformer arg-list))
+)
+
+; .pmacro
+
+(define (-pmacro-pmacro params expansion)
+  (if (not (list? params))
+      (-pmacro-error "bad parameter list" params))
+  (-pmacro-make '.anonymous params #f (-pmacro-build-lambda params expansion) "")
+)
+\f
+; Initialization.
+
+(define (pmacros-init!)
+  (set! -pmacro-table (make-hash-table 127))
+
+  ; Some "predefined" macros.
+
+  (-pmacro-set! '.sym
+               (-pmacro-make '.sym 'symbols #f -pmacro-sym "symbol-append"))
+  (-pmacro-set! '.str
+               (-pmacro-make '.str 'strings #f -pmacro-str "string-append"))
+  (-pmacro-set! '.hex
+               (-pmacro-make '.hex '(number . width) #f -pmacro-hex
+                             "convert to hex, with optional width"))
+  (-pmacro-set! '.upcase
+               (-pmacro-make '.upcase '(string) #f
+                             -pmacro-upcase "string-upcase"))
+  (-pmacro-set! '.downcase
+               (-pmacro-make '.downcase '(string) #f
+                             -pmacro-downcase "string-downcase"))
+  (-pmacro-set! '.substring
+               (-pmacro-make '.substring '(string start end) #f
+                             -pmacro-substring "get part of a string"))
+  (-pmacro-set! '.splice
+               (-pmacro-make '.splice 'arg-list #f -pmacro-splice
+                             "splice lists into the outer list"))
+  (-pmacro-set! '.iota
+               (-pmacro-make '.iota '(count . start-incr) #f -pmacro-iota
+                             "iota number generator"))
+  (-pmacro-set! '.map
+               (-pmacro-make '.map '(macro-name arg1 . arg-rest) #f
+                             -pmacro-map
+                             "map a macro over a list of arguments"))
+  (-pmacro-set! '.apply
+               (-pmacro-make '.apply '(macro-name arg-list) #f -pmacro-apply
+                             "apply a macro, taking arguments from a list"))
+  (-pmacro-set! '.pmacro
+               (-pmacro-make '.pmacro '(params expansion) #f -pmacro-pmacro
+                             "create a pmacro on-the-fly"))
+
+  ; doesn't work, Hobbit creates "eval" variable
+  ;(-pmacro-set! '.eval (-pmacro-make '.eval '(expr) #f eval "eval"))
+  (-pmacro-set! '.eval (-pmacro-make '.eval '(expr) #f (eval 'eval) "eval"))
+)
+
+; Initialize so we're ready to use after loading.
+(pmacros-init!)
diff --git a/cgen/profile.scm b/cgen/profile.scm
new file mode 100644 (file)
index 0000000..02fdee8
--- /dev/null
@@ -0,0 +1,180 @@
+;;; {Profile}
+;;;
+;;; This code is just an experimental prototype (e. g., it is not
+;;; thread safe), but since it's at the same time useful, it's
+;;; included anyway.
+;;;
+;;; This is copied from the tracing support in debug.scm.
+;;; If merged into the main distribution it will need an efficiency
+;;; and layout cleanup pass.
+
+; FIXME: Prefix "proc-" added to not collide with cgen stuff.
+
+; Put this stuff in the debug module since we need the trace facilities.
+(define-module (ice-9 profile) :use-module (ice-9 debug))
+
+(define profiled-procedures '())
+
+(define-public (profile-enable . args)
+  (if (null? args)
+      (nameify profiled-procedures)
+      (begin
+       (for-each (lambda (proc)
+                   (if (not (procedure? proc))
+                       (error "profile: Wrong type argument:" proc))
+                   ; `trace' is a magic property understood by guile
+                   (set-procedure-property! proc 'trace #t)
+                   (if (not (memq proc profiled-procedures))
+                       (set! profiled-procedures
+                             (cons proc profiled-procedures))))
+                 args)
+       (set! apply-frame-handler profile-entry)
+       (set! exit-frame-handler profile-exit)
+       (debug-enable 'trace)
+       (nameify args))))
+
+(define-public (profile-disable . args)
+  (if (and (null? args)
+          (not (null? profiled-procedures)))
+      (apply profile-disable profiled-procedures)
+      (begin
+       (for-each (lambda (proc)
+                   (set-procedure-property! proc 'trace #f)
+                   (set! profiled-procedures (delq! proc profiled-procedures)))
+                 args)
+       (if (null? profiled-procedures)
+           (debug-disable 'trace))
+       (nameify args))))
+
+(define (nameify ls)
+  (map (lambda (proc)
+        (let ((name (procedure-name proc)))
+          (or name proc)))
+       ls))
+
+; Subroutine of profile-entry to find the calling procedure.
+; Result is name of calling procedure or #f.
+
+(define (find-caller frame)
+  (let ((prev (frame-previous frame)))
+    (if prev
+       ; ??? Not sure this is right.  The goal is to find the real "caller".
+       (if (and (frame-procedure? prev)
+                ;(or (frame-real? prev) (not (frame-evaluating-args? prev)))
+                (not (frame-evaluating-args? prev))
+                )
+           (let ((name (procedure-name (frame-procedure prev))))
+             (if name name 'lambda))
+           (find-caller prev))
+       'top-level))
+)
+
+; Return the current time.
+; The result is a black box understood only by elapsed-time.
+
+(define (current-time) (gettimeofday))
+
+; Return the elapsed time in milliseconds since START.
+
+(define (elapsed-time start)
+  (let ((now (gettimeofday)))
+    (+ (* (- (car now) (car start)) 1000)
+       (quotient (- (cdr now) (cdr start)) 1000)))
+)
+
+; Handle invocation of profiled procedures.
+
+(define (profile-entry key cont tail)
+  (if (eq? (stack-id cont) 'repl-stack)
+      (let* ((stack (make-stack cont))
+            (frame (stack-ref stack 0))
+            (proc (frame-procedure frame)))
+       (if proc
+           ; procedure-property returns #f if property not present
+           (let ((counts (procedure-property proc 'profile-count)))
+             (set-procedure-property! proc 'entry-time (current-time))
+             (if counts
+                 (let* ((caller (find-caller frame))
+                        (count-elm (assq caller counts)))
+                   (if count-elm
+                       (set-cdr! count-elm (1+ (cdr count-elm)))
+                       (set-procedure-property! proc 'profile-count
+                                                (acons caller 1 counts)))))))))
+
+  ; SCM_TRACE_P is reset each time by the interpreter
+  ;(display "entry\n" (current-error-port))
+  (debug-enable 'trace)
+  ;; It's not necessary to call the continuation since
+  ;; execution will continue if the handler returns
+  ;(cont #f)
+)
+
+; Handle exiting of profiled procedures.
+
+(define (profile-exit key cont retval)
+  ;(display "exit\n" (current-error-port))
+  (display (list key cont retval)) (newline)
+  (display (stack-id cont)) (newline)
+  (if (eq? (stack-id cont) 'repl-stack)
+      (let* ((stack (make-stack cont))
+            (frame (stack-ref stack 0))
+            (proc (frame-procedure frame)))
+       (display stack) (newline)
+       (display frame) (newline)
+       (if proc
+           (set-procedure-property!
+            proc 'total-time
+            (+ (procedure-property proc 'total-time)
+               (elapsed-time (procedure-property proc 'entry-time)))))))
+
+  ; ??? Need to research if we have to do this or not.
+  ; SCM_TRACE_P is reset each time by the interpreter
+  (debug-enable 'trace)
+)
+
+; Called before something is to be profiled.
+; All desired procedures to be profiled must have been previously selected.
+; Property `profile-count' is an association list of caller name and call
+; count.
+; ??? Will eventually want to use a hash table or some such.
+
+(define-public (profile-init)
+  (for-each (lambda (proc)
+             (set-procedure-property! proc 'profile-count '())
+             (set-procedure-property! proc 'total-time 0))
+           profiled-procedures)
+)
+
+; Called after execution to print profile counts.
+; If ARGS contains 'all, stats on all profiled procs are printed, not just
+; those that were actually called.
+
+(define-public (profile-stats . args)
+  (let ((stats (map (lambda (proc)
+                     (cons (procedure-name proc)
+                           (procedure-property proc 'profile-count)))
+                   profiled-procedures))
+       (all? (memq 'all args))
+       (sort (if (defined? 'sort) (local-ref '(sort)) (lambda args args))))
+
+    (display "Profiling results:\n\n")
+
+    ; Print the procs in sorted order.
+    (let ((stats (sort stats (lambda (a b) (string<? (car a) (car b))))))
+      (for-each (lambda (proc-stats)
+                 (if (or all? (not (null? (cdr proc-stats))))
+                     ; Print by decreasing frequency.
+                     (let ((calls (sort (cdr proc-stats) (lambda (a b) (> (cdr a) (cdr b))))))
+                       (display (string-append (car proc-stats) "\n"))
+                       (for-each (lambda (call)
+                                   (display (string-append "  "
+                                                           (number->string (cdr call))
+                                                           " "
+                                                           (car call)
+                                                           "\n")))
+                                 calls)
+                       (display "  ")
+                       (display (apply + (map cdr calls)))
+                       (display " -- total\n\n"))))
+               stats)))
+)
diff --git a/cgen/read.scm b/cgen/read.scm
new file mode 100644 (file)
index 0000000..2b2ef00
--- /dev/null
@@ -0,0 +1,1198 @@
+; Top level file for reading and recording .cpu file contents.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; This file [and its subordinates] contain no C code (well, as little as
+; possible).  That lives at a layer above us.
+
+; A .cpu file consists of several sections:
+;
+; - basic definitions (e.g. cpu variants, word size, endianness, etc.)
+; - enums (enums are used throughout so by convention there is a special
+;   section in which they're defined)
+; - attributes
+; - instruction fields and formats
+; - hardware descriptions (e.g. registers, allowable immediate values)
+; - model descriptions (e.g. pipelines, latencies, etc.)
+; - instruction operands (mapping of insn fields to associated hardware)
+; - instruction definitions
+; - macro instruction definitions
+
+; TODO:
+; - memory access, layout, etc.
+; - floating point quirks
+; - ability to describe an ABI
+; - anything else that comes along
+
+; Notes:
+; - by convention most objects are subclasses of <ident> (having name, comment,
+;   and attrs elements and they are the first three elements of any .cpu file
+;   entry
+
+; Guidelines:
+; - Try to conform to R5RS, try to limit guile-ness.
+;   The current code is undoubtedly off in many places.
+
+; Conventions:
+; [I want there to be a plethora of conventions and I want them strictly
+; adhered to.  ??? There's probably a few violations here and there.
+; No big deal - fix them!]
+; These conventions are subject to revision.
+;
+; - procs/vars local to a file are named "-foo"
+; - only routines that emit application code begin with "gen-"
+; - symbols beginning with "c-" are either variables containing C code
+;   or procedures that generate C code, similarily for C++ and "c++-"
+; - variables containing C code begin with "c-"
+; - only routines that emit an entire file begin with "cgen-"
+; - all .cpu file elements shall have -foo-parse and -foo-read procedures
+; - global vars containing class definitions shall be named "<class-name>"
+; - procs related to a particular class shall be named "class-name-proc-name",
+;   class-name may be abbreviated
+; - procs that test whether something is an object of a particular class
+;   shall be named "class-name?"
+; - in keeping with Scheme conventions, predicates shall have a "?" suffix
+; - in keeping with Scheme conventions, methods and procedures that modify an
+;   argument or have other side effects shall have a "!" suffix,
+;   usually these procs return "*UNSPECIFIED*"
+; - all -foo-parse,parse-foo procs shall have `context' as the first arg
+;   [FIXME: not all such procs have been converted]
+; - stay away from non-portable C symbols, it makes using hobbit more difficult
+;   e.g. don't have anything named `index', sigh.
+\f
+; Variables representing misc. global constants.
+
+; A list of three numbers designating the cgen version: major minor fixlevel.
+(define -CGEN-VERSION '(0 7 2))
+(define (cgen-major) (car -CGEN-VERSION))
+(define (cgen-minor) (cadr -CGEN-VERSION))
+(define (cgen-fixlevel) (caddr -CGEN-VERSION))
+
+; A list of three numbers designating the description language version.
+; Note that this is different from -CGEN-VERSION.
+(define -CGEN-LANG-VERSION '(0 7 2))
+(define (cgen-lang-major) (car -CGEN-LANG-VERSION))
+(define (cgen-lang-minor) (cadr -CGEN-LANG-VERSION))
+(define (cgen-lang-fixlevel) (caddr -CGEN-LANG-VERSION))
+
+; Which application is in use (UNKNOWN, DESC, OPCODES, SIMULATOR, ???).
+; This is mostly for descriptive purposes.
+(define APPLICATION 'UNKNOWN)
+\f
+; Things are organized so that files can be compiled with Hobbit for
+; experimentation.  Thus we need one file that loads all the other files.
+; This is that file, though it would make sense to move the code in this
+; file to another.
+
+; If a routine to initialize compiled-in code is defined, run it.
+(if (defined? 'cgen-init-c) (cgen-init-c))
+
+; Don't use the debugging evaluator unless asked for.
+(if (not (defined? 'DEBUG-EVAL))
+    (define DEBUG-EVAL #f))
+
+(if (and (not DEBUG-EVAL)
+        (memq 'debug-extensions *features*))
+    (begin
+      (debug-disable 'debug)
+      (read-disable 'positions)
+      ))
+
+; If this is set to #f, the file is always loaded.
+; Don't override any current setting, e.g. from dev.scm.
+(if (not (defined? 'CHECK-LOADED?))
+    (define CHECK-LOADED? #t))
+
+; Unlink file if we're reloaded (say in an interactive session).
+; Dynamic loading is enabled by setting LIBCPU.SO to the pathname of the .so.
+(if (and (defined? 'libcpu.so) (dynamic-object? libcpu.so))
+    (dynamic-unlink libcpu.so))
+(define libcpu.so #f)
+(if (and (defined? 'LIBCPU.SO)
+        (file-exists? LIBCPU.SO))
+    (set! libcpu.so (dynamic-link LIBCPU.SO))
+)
+
+; List of loaded files.
+
+(if (not (defined? '-loaded-file-list))
+    (define -loaded-file-list '()))
+
+; Return non-zero if FILE was loaded last time through.
+
+(define (-loaded-file? file)
+  (->bool (memq (string->symbol file) -loaded-file-list))
+)
+
+; Record FILE as compiled in.
+
+(define (-loaded-file-record! file)
+  (let ((file (string->symbol file)))
+    (if (not (memq file -loaded-file-list))
+       (set! -loaded-file-list (cons file -loaded-file-list))))
+)
+
+; Load FILE if SYM is not compiled in.
+
+(define (maybe-load file init-func sym)
+  ; Return non-#f if FUNC is present in DYNOBJ.
+  (define (dynamic-func? func dynobj)
+    (catch #t
+          (lambda () (dynamic-func func dynobj))
+          (lambda args #f))
+    )
+
+  (let ((init-func (string-append "init_" (if init-func init-func file))))
+    (cond ((and libcpu.so
+               (dynamic-func? init-func libcpu.so))
+          (dynamic-call init-func libcpu.so)
+          (display (string-append "Skipping " file ", dynamically loaded.\n")))
+         ((or (not CHECK-LOADED?)
+              (not (defined? sym))
+              (-loaded-file? file))
+          (-loaded-file-record! file)
+          (load file))
+         (else
+          (display (string-append "Skipping " file ", already loaded.\n")))))
+)
+
+(maybe-load "pmacros" #f 'define-pmacro)
+(maybe-load "cos" #f 'make)
+(maybe-load "slib/sort" #f 'sort)
+; Used to pretty-print debugging messages.
+(maybe-load "slib/pp" #f 'pretty-print)
+; Used by pretty-print.
+(maybe-load "slib/genwrite" #f 'generic-write)
+(maybe-load "utils" #f 'logit)
+(maybe-load "utils-cgen" "utils_cgen" 'obj:name)
+(maybe-load "attr" #f '<attribute>)
+(maybe-load "enum" #f '<enum>)
+(maybe-load "mach" #f '<mach>)
+(maybe-load "model" #f '<model>)
+(maybe-load "types" #f '<scalar>)
+(maybe-load "mode" #f '<mode>)
+(maybe-load "ifield" #f '<ifield>)
+(maybe-load "iformat" #f '<iformat>)
+(maybe-load "hardware" #f '<hardware-base>)
+(maybe-load "operand" #f '<operand>)
+(maybe-load "insn" #f '<insn>)
+(maybe-load "minsn" #f '<macro-insn>)
+(maybe-load "decode" #f 'decode-build-table)
+(maybe-load "rtl" "rtl" '<rtx-func>)
+(maybe-load "rtx-funcs" "rtx_funcs" 'def-rtx-funcs)
+(maybe-load "rtl-c" "rtl_c" '<c-expr>)
+(maybe-load "semantics" #f 'semantic-compile)
+(maybe-load "sem-frags" "sem_frags" 'gen-threaded-engine)
+(maybe-load "utils-gen" "utils_gen" 'attr-gen-decl)
+(maybe-load "pgmr-tools" "pgmr_tools" 'pgmr-pretty-print-insn-format)
+\f
+; Reader state data.
+; All state regarding the reading of a .cpu file is kept in an object of
+; class <reader>.
+
+; Class to record info for each top-level `command' (for lack of a better
+; word) in the description file.
+; Top level commands are things like define-*.
+
+(define <command>
+  (class-make '<command>
+             '(<ident>)
+             '(
+               ; argument spec to `lambda'
+               arg-spec
+               ; lambda that processes the entry
+               handler
+               )
+             nil)
+)
+
+(define command-arg-spec (elm-make-getter <command> 'arg-spec))
+(define command-handler (elm-make-getter <command> 'handler))
+
+; Return help text for COMMAND.
+
+(define (command-help cmd)
+  (string-append
+   (obj:comment cmd)
+   "Arguments: "
+   (with-output-to-string (lambda () (write (command-arg-spec cmd))))
+   "\n")
+)
+
+; A pair of two lists: machs to keep, machs to drop.
+; Keep all machs, drop none.
+
+(define -keep-all-machs '((all)))
+
+; Main reader state class.
+
+(define <reader>
+  (class-make '<reader>
+             nil
+             (list
+              ; Selected machs to keep.
+              ; A pair of two lists: the car lists the machs to keep, the cdr
+              ; lists the machs to drop.  Two special entries are `all' and
+              ; `base'.  Both are only valid in the keep list.  `base' is a
+              ; place holder for objects that are common to all machine
+              ; variants in the architecture, it is the default value of the
+              ; MACH attribute.  If `all' is present the drop list is still
+              ; processed.
+              (cons 'keep-mach -keep-all-machs)
+
+              ; Selected isas to keep or `all'.
+              '(keep-isa . (all))
+
+              ; Currently select cpu family, computed from `keep-mach'.
+              ; Some applications don't care, and this is moderately
+              ; expensive to compute so we use delay/force.
+              'current-cpu
+
+              ; Associative list of file entry commands
+              ; (e.g. define-insn, etc.).
+              ; Each entry is (name . command-object).
+              (cons 'commands nil)
+              )
+             nil)
+)
+
+; Accessors.
+
+(define-getters <reader> reader (keep-mach keep-isa current-cpu commands))
+(define-setters <reader> reader (keep-mach keep-isa current-cpu commands))
+
+(define (reader-add-command! name comment attrs arg-spec handler)
+  (reader-set-commands! CURRENT-READER
+                       (acons name
+                              (make <command> name comment attrs
+                                    arg-spec handler)
+                              (reader-commands CURRENT-READER)))
+)
+
+(define (reader-lookup-command name)
+  (assq-ref (reader-commands CURRENT-READER) name)
+)
+
+; Reader state for current .cpu file.
+
+(define CURRENT-READER #f)
+
+; Signal an error while reading a .cpu file.
+
+(define (reader-error msg expr help-text)
+  (let ((errmsg
+        (string-append (or (port-filename (current-input-port))
+                           "<input>")
+                       ":"
+                       (number->string (port-line (current-input-port)))
+                       ": "
+                       msg
+                       ":")))
+    (error (string-append errmsg "\n" help-text)
+          expr))
+)
+
+; Signal a parse error while reading a .cpu file.
+
+(define (parse-error errtxt message . args)
+  (reader-error (string-append errtxt ": " message ":") args "")
+)
+
+; Process a macro-expanded entry.
+
+(define (-reader-process-expanded-1 entry)
+  (logit 4 (with-output-to-string (lambda () (pretty-print entry))))
+  (let ((command (reader-lookup-command (car entry))))
+    (if command
+       (let* ((handler (command-handler command))
+              (arg-spec (command-arg-spec command))
+              (num-args (num-args arg-spec)))
+         (if (cdr num-args)
+             ; Variable number of trailing arguments.
+             (if (< (length (cdr entry)) (car num-args))
+                 (reader-error (string-append "Incorrect number of arguments to "
+                                              (car entry)
+                                              ", expecting at least "
+                                              (number->string (car num-args)))
+                               entry
+                               (command-help command))
+                 (apply handler (cdr entry)))
+             ; Fixed number of arguments.
+             (if (!= (length (cdr entry)) (car num-args))
+                 (reader-error (string-append "Incorrect number of arguments to "
+                                              (car entry)
+                                              ", expecting "
+                                              (number->string (car num-args)))
+                               entry
+                               (command-help command))
+                 (apply handler (cdr entry)))))
+       (reader-error "unknown entry type" entry "")))
+  *UNSPECIFIED*
+)
+
+; Process 1 or more macro-expanded entries.
+
+(define (-reader-process-expanded entry)
+  ; `begin' is used to group a collection of entries into one, since pmacro
+  ; can only return one expression (borrowed from Scheme of course).
+  ; ??? Maybe someday (begin ...) will be equivalent to (sequence () ...)
+  ; but not yet.
+  ; Recurse in case there are nested begins.
+  (if (eq? (car entry) 'begin)
+      (for-each -reader-process-expanded
+               (cdr entry))
+      (-reader-process-expanded-1 entry))
+)
+
+; Process file entry ENTRY.
+
+(define (reader-process entry)
+  (if (not (form? entry))
+      (reader-error "improperly formed entry" entry ""))
+
+  ; First do macro expansion, but not if define-pmacro of course.
+  (let ((expansion (if (eq? (car entry) 'define-pmacro)
+                      entry
+                      (pmacro-expand entry))))
+    (-reader-process-expanded expansion))
+)
+
+; Read in and process FILE.
+;
+; It would be nice to get the line number of the beginning of the object,
+; but that's extra work, so for now we do the simple thing and use
+; port-line after we've read an entry.
+
+(define (reader-read-file! file)
+  (let ((readit (lambda ()
+                 (let loop ((entry (read)))
+                   (if (eof-object? entry)
+                       #t ; done
+                       (begin
+                         (reader-process entry)
+                         (loop (read)))))))
+       )
+
+    (with-input-from-file file readit)
+    *UNSPECIFIED*)
+)
+\f
+; Cpu data is recorded in an object of class <arch>.
+; This is necessary as we need to allow recording of multiple cpu descriptions
+; simultaneously.
+; Class <arch> is defined in mach.scm.
+
+; Global containing all data of the currently selected architecture.
+
+(define CURRENT-ARCH #f)
+\f
+; `keep-mach' processing.
+
+; Return the currently selected cpu family.
+; If a specific cpu family has been selected, each machine that is kept must
+; be in that cpu family [so there's no ambiguity in the result].
+; This is a moderately expensive computation so use delay/force.
+
+(define (current-cpu) (force (reader-current-cpu CURRENT-READER)))
+
+; Return a boolean indicating if CPU-NAME is to be kept.
+; ??? Currently this is always true.  Note that this doesn't necessarily apply
+; to machs in CPU-NAME.
+
+(define (keep-cpu? cpu-name) #t)
+
+; Cover proc to set `keep-mach'.
+; MACH-NAME-LIST is a comma separated string of machines to keep and drop
+; (if prefixed with !).
+
+(define (-keep-mach-set! mach-name-list)
+  (let* ((mach-name-list (string-cut mach-name-list #\,))
+        (keep (find (lambda (name) (not (char=? (string-ref name 0) #\!)))
+                    mach-name-list))
+        (drop (map (lambda (name) (string->symbol (string-drop 1 name)))
+                   (find (lambda (name) (char=? (string-ref name 0) #\!))
+                         mach-name-list))))
+    (reader-set-keep-mach! CURRENT-READER
+                          (cons (map string->symbol keep)
+                                (map string->symbol drop)))
+    ; Reset current-cpu.
+    (reader-set-current-cpu!
+     CURRENT-READER
+     (delay (let ((selected-machs (find (lambda (mach)
+                                         (keep-mach? (list (obj:name mach))))
+                                       (current-mach-list))))
+             (if (= (length selected-machs) 0)
+                 (error "no machs selected"))
+             (if (not (all-true? (map (lambda (mach)
+                                        (eq? (obj:name (mach-cpu mach))
+                                             (obj:name (mach-cpu (car selected-machs)))))
+                                      selected-machs)))
+                 (error "machs from different cpu families selected"))
+             (mach-cpu (car selected-machs)))))
+
+    *UNSPECIFIED*)
+)
+
+; Validate the user-provided keep-mach list against the list of machs
+; specified in the .cpu file (in define-arch).
+
+(define (keep-mach-validate!)
+  (let ((mach-names (cons 'all (current-arch-mach-name-list)))
+       (keep-mach (reader-keep-mach CURRENT-READER)))
+    (for-each (lambda (mach)
+               (if (not (memq mach mach-names))
+                   (error "unknown mach to keep:" mach)))
+             (car keep-mach))
+    (for-each (lambda (mach)
+               (if (not (memq mach mach-names))
+                   (error "unknown mach to drop:" mach)))
+             (cdr keep-mach))
+    )
+  *UNSPECIFIED*
+)
+
+; Return #t if a machine in MACH-LIST, a list of symbols, is to be kept.
+; If any machine in MACH-LIST is to be kept, the result is #t.
+; If MACH-LIST is the empty list (no particular mach specified, thus the base
+; mach), the result is #t.
+
+(define (keep-mach? mach-list)
+  (if (null? mach-list)
+      #t
+      (let* ((keep-mach (reader-keep-mach CURRENT-READER))
+            (keep (cons 'base (car keep-mach)))
+            (drop (cdr keep-mach))
+            (keep? (map (lambda (m) (memq m keep)) mach-list))
+            (all? (memq 'all keep))
+            (drop? (map (lambda (m) (memq m drop)) mach-list)))
+       (any-true? (map (lambda (k d)
+                         ; keep if K(ept) or ALL? and not D(ropped)
+                         (->bool (and (or k all?) (not d))))
+                       keep? drop?))))
+)
+
+; Return non-#f if the object containing ATLIST is to be kept.
+; OBJ is the container object or #f if there is none.
+; The object is kept if its attribute list specifies a `MACH' that is
+; kept (and not dropped) or does not have the `MACH' attribute (which means
+; it has the default value which means it's for use with all machines).
+
+(define (keep-mach-atlist? atlist obj)
+  ; The MACH attribute is not created until the .cpu file is read in which
+  ; is too late for us [we will get called for builtin objects].
+  ; Thus we peek inside the attribute list directly.
+  ; ??? Maybe postpone creation of builtins until after define-arch?
+  (let ((machs (atlist-attr-value-no-default atlist 'MACH obj)))
+    (if (null? machs)
+       #t
+       (keep-mach? (map string->symbol (string-cut machs #\,)))))
+)
+
+; Return a boolean indicating if the object containing ATLIST is to be kept.
+; OBJ is the container object or #f if there is none.
+; The object is kept if both its isa and its mach are kept.
+
+(define (keep-atlist? atlist obj)
+  (and (keep-mach-atlist? atlist obj)
+       (keep-isa-atlist? atlist obj))
+)
+
+; Return a boolean indicating if multiple cpu families are being kept.
+
+(define (keep-multiple?)
+  (let ((selected-machs (find (lambda (mach)
+                               (keep-mach? (list (obj:name mach))))
+                             (current-mach-list))))
+    (not (all-true? (map (lambda (mach)
+                          (eq? (obj:name (mach-cpu mach))
+                               (obj:name (mach-cpu (car selected-machs)))))
+                        selected-machs))))
+)
+
+; Return a boolean indicating if everything is kept.
+
+(define (keep-all?)
+  (equal? (reader-keep-mach CURRENT-READER) -keep-all-machs)
+)
+
+; Ensure all cpu families were kept, necessary for generating files that
+; encompass the entire architecture.
+
+(define (assert-keep-all)
+  (if (not (keep-all?))
+      (error "no can do, all cpu families not selected"))
+  *UNSPECIFIED*
+)
+
+; Ensure exactly one cpu family was kept, necessary for generating files that
+; are specific to one cpu family.
+
+(define (assert-keep-one)
+  (if (keep-multiple?)
+      (error "no can do, multiple cpu families selected"))
+  *UNSPECIFIED*
+)
+\f
+; `keep-isa' processing.
+
+; Cover proc to set `keep-isa'.
+; ISA-NAME-LIST is a comma separated string of isas to keep.
+; ??? We don't support the !drop notation of keep-mach processing.
+; Perhaps we should as otherwise there are two different styles the user
+; has to remember.  On the other hand, !drop support is moderately complicated,
+; and it can be added in an upward compatible manner later.
+
+(define (-keep-isa-set! isa-name-list)
+  (let ((isa-name-list (map string->symbol (string-cut isa-name-list #\,))))
+    (reader-set-keep-isa! CURRENT-READER isa-name-list)
+    )
+  *UNSPECIFIED*
+)
+
+; Validate the user-provided keep-isa list against the list of isas
+; specified in the .cpu file (in define-arch).
+
+(define (keep-isa-validate!)
+  (let ((isa-names (cons 'all (current-arch-isa-name-list)))
+       (keep-isa (reader-keep-isa CURRENT-READER)))
+    (for-each (lambda (isa)
+               (if (not (memq isa isa-names))
+                   (error "unknown isa to keep:" isa)))
+             keep-isa)
+    )
+  *UNSPECIFIED*
+)
+
+; Return currently selected isa (there must be exactly one).
+
+(define (current-isa)
+  (let ((keep-isa (reader-keep-isa CURRENT-READER)))
+    (if (equal? keep-isa '(all))
+       (let ((isas (current-isa-list)))
+         (if (= (length isas) 1)
+             (car isas)
+             (error "multiple isas selected" keep-isa)))
+       (if (= (length keep-isa) 1)
+           (current-isa-lookup (car keep-isa))
+           (error "multiple isas selected" keep-isa))))
+)
+
+; Return #t if an isa in ISA-LIST, a list of symbols, is to be kept.
+; If any isa in ISA-LIST is to be kept, the result is #t.
+; If ISA-LIST is the empty list (no particular isa specified) use the default
+; isa.
+
+(define (keep-isa? isa-list)
+  (if (null? isa-list)
+      (set! isa-list (list (car (current-arch-isa-name-list)))))
+  (let* ((keep (reader-keep-isa CURRENT-READER))
+        (keep? (map (lambda (i)
+                      (or (memq i keep)
+                          (memq 'all keep)))
+                    isa-list)))
+    (any-true? keep?))
+)
+
+; Return #t if the object containing ATLIST is to be kept.
+; OBJ is the container object or #f if there is none.
+; The object is kept if its attribute list specifies an `ISA' that is
+; kept or does not have the `ISA' attribute (which means it has the default
+; value) and the default isa is being kept.
+
+(define (keep-isa-atlist? atlist obj)
+  (let ((isas (atlist-attr-value atlist 'ISA obj)))
+    (keep-isa? (map string->symbol (string-cut isas #\,))))
+)
+
+; Return non-#f if object OBJ is to be kept, according to its ISA attribute.
+
+(define (keep-isa-obj? obj)
+  (keep-isa-atlist? (obj-atlist obj) obj)
+)
+
+; Return a boolean indicating if multiple isas are being kept.
+
+(define (keep-isa-multiple?)
+  (let ((keep (reader-keep-isa CURRENT-READER)))
+    (or (> (length keep) 1)
+       (and (memq 'all keep)
+            (> (length (current-arch-isa-name-list)) 1))))
+)
+
+; Return list of isa names currently being kept.
+
+(define (current-keep-isa-name-list)
+  (reader-keep-isa CURRENT-READER)
+)
+\f
+; If #f, treat reserved fields as operands and extract them with the insn.
+; Code can then be emitted in the extraction routines to validate them.
+; If #t, treat reserved fields as part of the opcode.
+; This complicates the decoding process as these fields have to be
+; checked too.
+; ??? Unimplemented.
+
+(define option:reserved-as-opcode? #f)
+
+; Process options passed in on the command line.
+; OPTIONS is a space separated string of name=value values.
+; Each application is required to provide: option-init!, option-set!.
+
+(define (set-cgen-options! options)
+  (option-init!)
+  (for-each (lambda (opt)
+             (if (null? opt)
+                 #t ; ignore extraneous spaces
+                 (let ((name (string->symbol (car opt)))
+                       (value (cdr opt)))
+                   (logit 1 "Setting option `" name "' to \""
+                          (apply string-append value) "\".\n")
+                   (option-set! name value))))
+           (map (lambda (opt) (string-cut opt #\=))
+                (string-cut options #\space)))
+)
+\f
+; Application specific object creation support.
+;
+; Each entry in the .cpu file has a basic container class.
+; Each application adds functionality by subclassing the container
+; and registering with set-for-new! the proper class to create.
+; ??? Not sure this is the best way to handle this, but it does keep the
+; complexity down while not requiring as dynamic a language as I had before.
+; ??? Class local variables would provide a more efficient way to do this.
+; Assuming one wants to continue on this route.
+
+(define -cpu-new-class-list nil)
+
+(define (set-for-new! parent child)
+  (set! -cpu-new-class-list (acons parent child -cpu-new-class-list))
+)
+
+; Lookup the class registered with set-for-new!
+; If none registered, return PARENT.
+
+(define (lookup-for-new parent)
+  (let ((child (assq-ref -cpu-new-class-list parent)))
+    (if child
+       child
+       parent))
+)
+\f
+; .cpu file loader support
+
+; Prepare to parse a .cpu file.
+; This initializes the application independent tables.
+; KEEP-MACH specifies what machs to keep.
+; KEEP-ISA specifies what isas to keep.
+; OPTIONS is a list of options to control code generation.
+; The values are application dependent.
+
+(define (-init-parse-cpu! keep-mach keep-isa options)
+  (set! -cpu-new-class-list nil)
+
+  (set! CURRENT-READER (new <reader>))
+  (set! CURRENT-ARCH (new <arch>))
+  (-keep-mach-set! keep-mach)
+  (-keep-isa-set! keep-isa)
+  (set-cgen-options! options)
+
+  (reader-add-command! 'include
+                      "Include a file.\n"
+                      nil '(file) include
+  )
+  (reader-add-command! 'if
+                      "(if test then . else)\n"
+                      nil '(test then . else) cmd-if
+
+  )
+
+  ; Rather than add cgen specific stuff to pmacros.scm, we create
+  ; a define-pmacro command here.
+  (pmacros-init!)
+  (reader-add-command! 'define-pmacro
+                      "\
+Define a preprocessor-style macro.
+"
+                      nil '(name arg1 . arg-rest) define-pmacro)
+
+  ; The order here is important.
+  (arch-init!) ; Must be done first.
+  (enum-init!)
+  (attr-init!)
+  (types-init!)
+  (mach-init!)
+  (model-init!)
+  (mode-init!)
+  (ifield-init!)
+  (hardware-init!)
+  (operand-init!)
+  (insn-init!)
+  (minsn-init!)
+  (rtl-init!)
+  (rtl-c-init!)
+  (utils-init!)
+
+  *UNSPECIFIED*
+)
+
+; Install any builtin objects.
+; This is defered until define-arch is read.
+; One reason is that attributes MACH and ISA don't exist until then.
+
+(define (reader-install-builtin!)
+  ; The order here is important.
+  (attr-builtin!)
+  (mode-builtin!)
+  (ifield-builtin!)
+  (hardware-builtin!)
+  (operand-builtin!)
+  ; This is mainly for the insn attributes.
+  (insn-builtin!)
+  (rtl-builtin!)
+  *UNSPECIFIED*
+)
+
+; Do anything necessary for the application independent parts after parsing
+; a .cpu file.
+; The lists get cons'd in reverse order.  One thing this does is change them
+; back to file order, it makes things easier for the human viewer.
+
+(define (-finish-parse-cpu!)
+  ; The order here is generally the reverse of init-parse-cpu!.
+  (rtl-finish!)
+  (minsn-finish!)
+  (insn-finish!)
+  (operand-finish!)
+  (hardware-finish!)
+  (ifield-finish!)
+  (mode-finish!)
+  (model-finish!)
+  (mach-finish!)
+  (types-finish!)
+  (attr-finish!)
+  (enum-finish!)
+  (arch-finish!) ; Must be done last.
+
+  *UNSPECIFIED*
+)
+
+; Perform a global error checking pass after the .cpu file has been read in.
+
+(define (-global-error-checks)
+  ; ??? None yet.
+  ; TODO:
+  ; - all hardware elements with same name must have same rank and
+  ;   compatible modes (which for now means same float mode or all int modes)
+  #f
+)
+
+; .cpu file include mechanism
+
+(define (include file)
+  (display (string-append "Including file " file " ...\n"))
+  (reader-read-file! (string-append srcdir "/" file))
+  (logit 2 "Resuming previous file ...\n")
+)
+
+; Version of `if' invokable at the top level of a description file.
+; This is a work-in-progress.  Its presence in the description file is ok,
+; but the implementation will need to evolve.
+
+(define (cmd-if test then . else)
+  (if (> (length else) 1)
+      (reader-error "wrong number of arguments to `if'"
+                   (cons 'if (cons test (cons then else)))
+                   ""))
+  ; ??? rtx-eval test
+  (if (not (memq (car test) '(keep-isa? keep-mach?)))
+      (reader-error "only (if (keep-mach?|keep-isa? ...) ...) is currently supported"))
+  (case (car test)
+    ((keep-isa?)
+     (if (keep-isa? (cadr test))
+        (eval then)
+        (if (null? else)
+            #f
+            (eval (car else)))))
+    ((keep-mach?)
+     (if (keep-mach? (cadr test))
+        (eval then)
+        (if (null? else)
+            #f
+            (eval (car else))))))
+)
+
+; Top level routine for loading .cpu files.
+; FILE is the name of the .cpu file to load.
+; KEEP-MACH is a string of comma separated machines to keep
+; (or not keep if prefixed with !).
+; KEEP-ISA is a string of comma separated isas to keep.
+; OPTIONS is the OPTIONS argument to -init-parse-cpu!.
+; APP-INITER! is an application specific zero argument proc (thunk)
+; to call after -init-parse-cpu!
+; APP-FINISHER! is an application specific zero argument proc to call after
+; -finish-parse-cpu!
+; ANALYZER! is a zero argument proc to call after loading the .cpu file.
+; It is expected to set up various tables and things useful for the application
+; in question.
+
+(define (cpu-load file keep-mach keep-isa options
+                 app-initer! app-finisher! analyzer!)
+  (-init-parse-cpu! keep-mach keep-isa options)
+
+  (app-initer!)
+
+  ; This used to be done here, but is now defered until define-arch.
+  ;(reader-install-builtin!)
+
+  (display (string-append "Loading cpu file " file " ...\n"))
+
+  (reader-read-file! file)
+
+  (display (string-append "Processing cpu file " file " ...\n"))
+  (-finish-parse-cpu!)
+  (app-finisher!)
+  (-global-error-checks)
+  (analyzer!)
+  *UNSPECIFIED*
+)
+\f
+; Argument parsing utilities.
+
+; Generate a usage message.
+; ERRTYPE is one of 'help, 'unknown, 'missing.
+; OPTION is the option that had the error or "" if ERRTYPE is 'help.
+
+(define (cgen-usage errtype option arguments)
+  (let ((cep (current-error-port)))
+    (case errtype
+      ((help) #f)
+      ((unknown) (display (string-append "Unknown option: " option "\n") cep))
+      ((missing) (display (string-append "Missing argument: " option "\n") cep))
+      (else (display "Unknown error!\n" cep)))
+    (display "Usage: cgen arguments ...\n" cep)
+    (for-each (lambda (arg)
+               (display (string-append (car arg)
+                                       " " (if (cadr arg) (cadr arg) "")
+                                       "  - " (caddr arg)
+                                       "\n")
+                        cep))
+             arguments)
+    (display "...\n" cep)
+    (case errtype
+      ((help) (quit 0))
+      ((unknown missing) (quit 1))
+      (else (quit 2))))
+)
+
+; Poor man's getopt.
+; [We don't know where to find the real one until we've parsed the args,
+; and this isn't something we need to get too fancy about anyways.]
+; The result is always ((a . b) . c).
+; If the argument is valid, the result is ((opt-spec . arg) . remaining-argv),
+; or (('unknown . option) . remaining-argv) if `option' isn't recognized,
+; or (('missing . option) . remaining argv) if `option' is missing a required
+; argument,
+; or ((#f . #f) . #f) if there are no more arguments.
+; OPT-SPEC is a list of option specs.
+; Each element is an alist of at least 3 elements: option argument help-text.
+; `option' is a string or symbol naming the option.  e.g. -a, --help, "-i".
+; symbols are supported for backward compatibility, -i is a complex number.
+; `argument' is a string naming the argument or #f if the option takes no
+; arguments.
+; `help-text' is a string that is printed with the usage information.
+; Elements beyond `help-text' are ignored.
+
+(define (-getopt argv opt-spec)
+  (if (null? argv)
+      (cons (cons #f #f) #f)
+      (let ((opt (assoc (car argv) opt-spec)))
+       (cond ((not opt) (cons (cons 'unknown (car argv)) (cdr argv)))
+             ((and (cadr opt) (null? (cdr argv)))
+              (cons (cons 'missing (car argv)) (cdr argv)))
+             ((cadr opt) (cons (cons opt (cadr argv)) (cddr argv)))
+             (else ; must be option that doesn't take an argument
+              (cons (cons opt #f) (cdr argv))))))
+)
+
+; Convert old style option spec to new style.
+; This involves converting a symbol option name to a string.
+
+(define (-opt-spec-update spec-list)
+  (map (lambda (spec)
+        (if (symbol? (car spec))
+            (cons (symbol->string (car spec)) (cdr spec))
+            spec))
+       spec-list)
+)
+
+; Used to ensure backtraces are printed if an error occurs.
+
+(define (catch-with-backtrace thunk)
+  (lazy-catch #t thunk
+             (lambda args
+               ;(display args (current-error-port))
+               ;(newline (current-error-port))
+               ; display-error takes 6 arguments.
+               ; If `quit' is called from elsewhere, it may not have 6
+               ; arguments.  Not sure how best to handle this.
+               (if (= (length args) 5)
+                   (begin
+                     (apply display-error #f (current-error-port) (cdr args))
+                     (save-stack)
+                     (backtrace)))
+               (quit 1)))
+)
+
+; Return (cadr args) or print a pretty error message if not possible.
+
+(define (option-arg args)
+  (if (and (pair? args) (pair? (cdr args)))
+      (cadr args)
+      (parse-error "option processing" "missing argument to" (car args)))
+)
+
+; Record of arguments passed to debug-repl, so they can be accessed in
+; the repl loop.
+
+(define debug-env #f)
+
+; Return list of recorded variables for debugging.
+
+(define (debug-var-names) (map car debug-env))
+
+; Return value of recorded var NAME.
+
+(define (debug-var name) (assq-ref debug-env name))
+
+; Enter a repl loop for debugging purposes.
+; Use (quit) to exit cgen completely.
+; Use (debug-quit) or (quit 0) to exit the debugging session and
+; resume argument processing.
+;
+; ENV-ALIST can be anything, but it is intended to be an alist of values
+; the caller will want to be able to access in the repl loop.
+; It is stored in global `debug-env'.
+;
+; FIXME: Move to utils.scm.
+
+(define (debug-repl env-alist)
+  (set! debug-env env-alist)
+  (let loop ()
+    (let ((rc (top-repl)))
+      (if (null? rc)
+         (quit 1)) ; indicate error to `make'
+      (if (not (equal? rc '(0)))
+         (loop))))
+)
+
+; Utility for debug-repl.
+
+(define (debug-quit)
+  ; Keep around for later debugging.
+  ;(set! debug-env #f)
+
+  (quit 0)
+)
+
+; Macro to simplify calling debug-repl.
+; Usage: (debug-repl-env var-name1 var-name2 ...)
+
+(defmacro debug-repl-env var-names
+  (let ((env (map (lambda (var-name)
+                   (list 'cons (list 'quote var-name) var-name))
+                 var-names)))
+    (list 'debug-repl (cons 'list env)))
+)
+
+; List of common arguments.
+;
+; ??? Another useful arg would be one that says "do file generation with
+; arguments specified up til now, then continue with next batch of args".
+
+(define common-arguments
+  '(("-a" "arch"      "set arch, specifies name of .cpu file to load")
+    ("-b" #f          "use debugging evaluator, for backtraces")
+    ("-d" #f          "start interactive debugging session")
+    ("-f" "flags"     "specify a set of flags to control code generation")
+    ("-h" #f          "print usage information")
+    ("--help" #f      "print usage information")
+    ("-i" "isa-list"  "specify isa-list entries to keep")
+    ("-m" "mach-list" "specify mach-list entries to keep")
+    ("-s" "srcdir"    "set srcdir")
+    ("-v" #f          "increment verbosity level")
+    ("--version" #f   "print version info")
+    )
+)
+
+; Parse options and call generators.
+; ARGS is a #:keyword delimited list of arguments.
+; #:app-name name
+; #:arg-spec optspec ; FIXME: rename to #:opt-spec
+; #:init init-routine
+; #:finish finish-routine
+; #:analyze analysis-routine
+; #:argv command-line-arguments
+;
+; ARGSPEC is a list of (option option-arg comment option-handler) elements.
+; OPTION-HANDLER is either (lambda () ...) or (lambda (arg) ...) and
+; processes the option.
+
+(define -cgen
+  (lambda args
+    (let ((app-name "unknown")
+         (opt-spec nil)
+         (app-init! (lambda () #f))
+         (app-finish! (lambda () #f))
+         (app-analyze! (lambda () #f))
+         (argv (list "cgen"))
+         )
+      (let loop ((args args))
+       (if (not (null? args))
+           (case (car args)
+             ((#:app-name) (begin
+                             (set! app-name (option-arg args))
+                             (loop (cddr args))))
+             ((#:arg-spec) (begin
+                             (set! opt-spec (option-arg args))
+                             (loop (cddr args))))
+             ((#:init) (begin
+                         (set! app-init! (option-arg args))
+                         (loop (cddr args))))
+             ((#:finish) (begin
+                           (set! app-finish! (option-arg args))
+                           (loop (cddr args))))
+             ((#:analyze) (begin
+                            (set! app-analyze! (option-arg args))
+                            (loop (cddr args))))
+             ((#:argv) (begin
+                         (set! argv (option-arg args))
+                         (loop (cddr args))))
+             (else (error "cgen: unknown argument" (car args))))))
+
+      ; ARGS has been processed, now we can process ARGV.
+
+      (let (
+           (opt-spec (append common-arguments (-opt-spec-update opt-spec)))
+           (app-args nil)    ; application's args are queued here
+           (repl? #f)
+           (arch #f)
+           (keep-mach "all") ; default is all machs
+           (keep-isa "all")  ; default is all isas
+           (flags "")
+           (moreopts? #t)
+           (cep (current-error-port))
+           (str=? string=?)
+           )
+
+       (let loop ((argv (cdr argv)))
+         (let* ((new-argv (-getopt argv opt-spec))
+                (opt (caar new-argv))
+                (arg (cdar new-argv)))
+           (case opt
+             ((#f) (set! moreopts? #f))
+             ((unknown) (cgen-usage 'unknown arg opt-spec))
+             ((missing) (cgen-usage 'missing arg opt-spec))
+             (else
+              (cond ((str=? "-a" (car opt))
+                     (set! arch arg)
+                     )
+                    ((str=? "-b" (car opt))
+                     (if (memq 'debug-extensions *features*)
+                         (begin
+                           (debug-enable 'backtrace)
+                           (debug-enable 'debug)
+                           (debug-enable 'backwards)
+                           (debug-set! depth 200)
+                           (debug-set! frames 10)
+                           (read-enable 'positions)))
+                     )
+                    ((str=? "-d" (car opt))
+                     (let ((prompt (string-append "cgen-" app-name "> ")))
+                       (set! repl? #t)
+                       (set-repl-prompt! prompt)
+                       (if (feature? 'readline)
+                           (set-readline-prompt! prompt))
+                       ))
+                    ((str=? "-f" (car opt))
+                     (set! flags arg)
+                     )
+                    ((str=? "-h" (car opt))
+                     (cgen-usage 'help "" opt-spec)
+                     )
+                    ((str=? "--help" (car opt))
+                     (cgen-usage 'help "" opt-spec)
+                     )
+                    ((str=? "-i" (car opt))
+                     (set! keep-isa arg)
+                     )
+                    ((str=? "-m" (car opt))
+                     (set! keep-mach arg)
+                     )
+                    ((str=? "-s" (car opt))
+                     #f ; ignore, already processed by caller
+                     )
+                    ((str=? "-v" (car opt))
+                     (verbose-inc!)
+                     )
+                    ((str=? "--version" (car opt))
+                     (begin
+                       (display "Cpu tools GENerator version ")
+                       (display (cgen-major))
+                       (display ".")
+                       (display (cgen-minor))
+                       (display ".")
+                       (display (cgen-fixlevel))
+                       (newline)
+                       (quit 0)
+                       ))
+                    ; Else this is an application specific option.
+                    (else
+                     ; Record it for later processing.  Note that they're
+                     ; recorded in reverse order (easier).  This is undone
+                     ; later.
+                     (set! app-args (acons opt arg app-args)))
+                    )))
+           (if moreopts? (loop (cdr new-argv)))
+           )
+         ) ; end of loop
+
+       ; All arguments have been parsed.
+
+       (if (not arch)
+           (error "-a option missing, no architecture specified"))
+
+       (if repl?
+           (debug-repl nil))
+       (cpu-load (string-append srcdir "/" arch ".cpu")
+                 keep-mach keep-isa flags
+                 app-init! app-finish! app-analyze!)
+       ; Start another repl loop if -d.
+       ; Awkward.  Both places are useful, though this is more useful.
+       (if repl?
+           (debug-repl nil))
+
+       ; Done with processing the arguments.  Call the application's
+       ; file generators.
+
+       (for-each (lambda (opt-arg)
+                   (let ((opt (car opt-arg))
+                         (arg (cdr opt-arg)))
+                     (if (cadr opt)
+                         ((cadddr opt) arg)
+                         ((cadddr opt)))))
+                 (reverse app-args))
+       )
+      )
+    #f) ; end of lambda
+)
+
+; Main entry point called by application file generators.
+; Cover fn to -cgen that uses catch-with-backtrace.
+; ??? (debug-enable 'backtrace) might also work except I seem to remember
+; having problems with it.  They may be fixed now.
+
+(define cgen
+  (lambda args
+    (catch-with-backtrace (lambda () (apply -cgen args))))
+)
diff --git a/cgen/rtl-c.scm b/cgen/rtl-c.scm
new file mode 100644 (file)
index 0000000..0469c9b
--- /dev/null
@@ -0,0 +1,1662 @@
+; RTL->C translation support.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; Generating C from RTL
+; ---------------------
+; The main way to generate C code from an RTL expression is:
+;
+; (rtl-c mode '(func mode ...) nil)
+;
+; E.g.
+; (rtl-c DFLT '(add SI (const SI 1) (const SI 2)) nil)
+; -->
+; "ADDSI (1, 2)"
+; Mode `DFLT' (DEFAULTmode) means "use the default/natural mode".
+;
+; The expression is in source form or may be already compiled (with
+; rtx-compile).
+;
+; The `set' rtx needs to be handled a little carefully.
+; Both the dest and src are processed first, and then code to perform the
+; assignment is computed.  However, the dest may require more than a simple
+; C assignment.  Therefore set dests are converted to the specified object
+; (e.g. a hardware operand) and then a message is sent to this object to
+; perform the actual code generation.
+;
+; All interesting operands (e.g. regs, mem) are `operand' objects.
+; The following messages must be supported by operand objects.
+; - get-mode      - return mode of operand
+; - cxmake-get    - return <c-expr> object containing operand's value
+; - gen-set-quiet - return string of C code to set operand's value (no tracing)
+; - gen-set-trace - return string of C code to set operand's value
+;
+; Instruction fields are refered to by name.
+; (estate-owner estate) must be an instruction that has the field.
+; Instruction ifields must have these methods:
+; - get-mode
+; - cxmake-get
+;
+; Conventions used in this file:
+; - see rtl.scm
+\f
+; The <c-expr> object.
+; This is a fully translated expression (i.e. C code).
+
+(define <c-expr>
+  (class-make '<c-expr> nil
+             '(
+               ; The mode of C-CODE.
+               mode
+               ; The translated C code.
+               c-code
+               ; The source expression, for debugging.
+               expr
+               ; Attributes of the expression.
+               atlist
+               ; List of temporaries required to compute the expression.
+               ; ??? wip.  These would be combined as the expression is
+               ; built up.  Then in sets and other statements, the temporaries
+               ; would be declared.
+               ;(tmps . nil)
+               )
+             nil)
+)
+
+(method-make!
+ <c-expr> 'make!
+ (lambda (self mode c-code atlist)
+   ; FIXME: Extend COS to allow specifying member predicates.
+   (assert (mode? mode))
+   (assert (string? c-code))
+   ;(assert (atlist? atlist)) ; FIXME: What should this be?
+   (elm-set! self 'mode mode)
+   (elm-set! self 'c-code c-code)
+   (elm-set! self 'atlist atlist)
+   self)
+)
+
+; Accessor fns
+
+(define cx:mode (elm-make-getter <c-expr> 'mode))
+(define cx:c-code (elm-make-getter <c-expr> 'c-code))
+(define cx:expr (elm-make-getter <c-expr> 'expr))
+(define cx:atlist (elm-make-getter <c-expr> 'atlist))
+;(define cx:tmps (elm-make-getter <c-expr> 'tmps))
+
+; Any object with attributes requires the get-atlist method.
+
+(method-make! <c-expr> 'get-atlist (lambda (self) (elm-get self 'atlist)))
+
+; Respond to 'get-mode messages.
+
+(method-make! <c-expr> 'get-mode (lambda (self) (elm-get self 'mode)))
+
+; Respond to 'get-name messages for rtx-dump.
+
+(method-make!
+ <c-expr> 'get-name
+ (lambda (self)
+   (string-append "(" (obj:name (elm-get self 'mode)) ") "
+                 (cx:c self)))
+)
+
+; Return C code to perform an assignment.
+; NEWVAL is a <c-expr> object of the value to be assigned to SELF.
+
+(method-make! <c-expr> 'gen-set-quiet
+             (lambda (self estate mode indx selector newval)
+               (string-append "  " (cx:c self) " = " (cx:c newval) ";\n"))
+)
+
+(method-make! <c-expr> 'gen-set-trace
+             (lambda (self estate mode indx selector newval)
+               (string-append "  " (cx:c self) " = " (cx:c newval) ";\n"))
+)
+
+; Return the C code of CX.
+; ??? This used to handle lazy evaluation of the expression.
+; Maybe it will again, so it's left in, as a cover fn to cx:c-code.
+
+(define (cx:c cx)
+  (cx:c-code cx)
+)
+
+; Main routine to create a <c-expr> node object.
+; MODE is either the mode's symbol (e.g. 'QI) or a mode object.
+; CODE is a string of C code.
+
+(define (cx:make mode code)
+  (make <c-expr> (mode:lookup mode) code nil)
+)
+
+; Make copy of CX in new mode MODE.
+; MODE must be a <mode> object.
+
+(define (cx-new-mode mode cx)
+  (make <c-expr> mode (cx:c cx) (cx:atlist cx))
+)
+
+; Same as cx:make except with attributes.
+
+(define (cx:make-with-atlist mode code atlist)
+  (make <c-expr> (mode:lookup mode) code atlist)
+)
+
+; Return a boolean indicated if X is a <c-expr> object.
+
+(define (c-expr? x) (class-instance? <c-expr> x))
+\f
+; RTX environment support.
+
+(method-make!
+ <rtx-temp> 'cxmake-get
+ (lambda (self estate mode indx selector)
+   (cx:make mode (rtx-temp-value self)))
+)
+
+(method-make!
+ <rtx-temp> 'gen-set-quiet
+ (lambda (self estate mode indx selector src)
+   (string-append "  " (rtx-temp-value self) " = " (cx:c src) ";\n"))
+)
+
+(method-make!
+ <rtx-temp> 'gen-set-trace
+ (lambda (self estate mode indx selector src)
+   (string-append "  " (rtx-temp-value self) " = " (cx:c src) ";\n"))
+)
+
+(define (gen-temp-defs estate env)
+  (string-map (lambda (temp)
+               (let ((temp-obj (cdr temp)))
+                 (string-append "  " (mode:c-type (rtx-temp-mode temp-obj))
+                                " " (rtx-temp-value temp-obj) ";\n")))
+             env)
+)
+\f
+; Top level routines to handle rtl->c translation.
+
+; rtl->c configuration parameters
+
+; #t -> emit calls to rtl cover fns, otherwise emit plain C where possible.
+(define -rtl-c-rtl-cover-fns? #f)
+
+; Called before emitting code to configure the generator.
+; ??? I think this can go away now (since cover-fn specification is also
+; done at each call to rtl-c).
+
+(define (rtl-c-config! . args)
+  (set! -rtl-c-rtl-cover-fns? #f)
+  (let loop ((args args))
+    (if (null? args)
+       #f ; done
+       (begin
+         (case (car args)
+           ((#:rtl-cover-fns?)
+            (set! -rtl-c-rtl-cover-fns? (cadr args)))
+           (else (error "rtl-c-config: unknown option:" (car args))))
+         (loop (cddr args)))))
+  *UNSPECIFIED*
+)
+
+; Subclass of <eval-state> to record additional things needed for rtl->c.
+
+(define <rtl-c-eval-state>
+  (class-make '<rtl-c-eval-state> '(<eval-state>)
+             '(
+               ; #t -> emit calls to rtl cover fns.
+               (rtl-cover-fns? . #f)
+
+               ; name of output language, "c" or "c++"
+               (output-language . "c")
+
+               ; #t if generating code for a macro.
+               ; Each newline is then preceeded with '\\'.
+               (macro? . #f)
+
+               ; #f -> reference ifield values using FLD macro.
+               ; #t -> use C variables.
+               ; ??? This is only needed to get correct ifield references
+               ; in opcodes, decoder, and semantics.  Maybe a better way to
+               ; go would be to specify the caller's name so there'd be just
+               ; one of these, rather than an increasing number.  However,
+               ; for now either way is the same.
+               ; An alternative is to specify a callback to try first.
+               (ifield-var? . #f)
+               )
+             nil)
+)
+
+; FIXME: involves upcasting.
+(define-getters <rtl-c-eval-state> estate
+  (rtl-cover-fns? output-language macro? ifield-var?)
+)
+
+; Return booleans indicating if output language is C/C++.
+
+(define (estate-output-language-c? estate)
+  (string=? (estate-output-language estate) "c")
+)
+(define (estate-output-language-c++? estate)
+  (string=? (estate-output-language estate) "c++")
+)
+
+(method-make!
+ <rtl-c-eval-state> 'vmake!
+ (lambda (self args)
+   ; Initialize parent class first.
+   (let loop ((args (send-next self 'vmake! args)) (unrecognized nil))
+     (if (null? args)
+        (reverse! unrecognized) ; ??? Could invoke method to initialize here.
+        (begin
+          (case (car args)
+            ((#:rtl-cover-fns?)
+             (elm-set! self 'rtl-cover-fns? (cadr args)))
+            ((#:output-language)
+             (elm-set! self 'output-language (cadr args)))
+            ((#:macro?)
+             (elm-set! self 'macro? (cadr args)))
+            ((#:ifield-var?)
+             (elm-set! self 'ifield-var? (cadr args)))
+            (else
+             ; Build in reverse order, as we reverse it back when we're done.
+             (set! unrecognized
+                   (cons (cadr args) (cons (car args) unrecognized)))))
+          (loop (cddr args) unrecognized)))))
+)
+
+; Build an estate for use in generating C.
+; CONTEXT is a <context> object or #f if there is none.
+; OWNER is the owner of the expression or #f if there is none.
+; EXTRA-VARS-ALIST is an association list of (symbol <mode> value)
+; elements to be used during value lookup.
+; OVERRIDES is a #:keyword/value list of parameters to apply last.
+
+(define (estate-make-for-rtl-c context owner extra-vars-alist
+                              rtl-cover-fns? macro? overrides)
+  (apply vmake
+        (append!
+         (list
+          <rtl-c-eval-state>
+          #:context context
+          #:owner owner
+          #:expr-fn (lambda (rtx-obj expr mode estate)
+                      (rtl-c-generator rtx-obj))
+          #:env (rtx-env-init-stack1 extra-vars-alist)
+          #:rtl-cover-fns? rtl-cover-fns?
+          #:macro? macro?)
+          overrides))
+)
+
+(define (estate-make-for-normal-rtl-c extra-vars-alist overrides)
+  (estate-make-for-rtl-c
+   #f ; FIXME: context
+   #f ; FIXME: owner
+   extra-vars-alist
+   -rtl-c-rtl-cover-fns?
+   #f ; macro?
+   overrides)
+)
+
+; Translate RTL expression EXPR to C.
+; ESTATE is the current rtx evaluation state.
+
+(define (rtl-c-with-estate estate mode expr)
+  (cx:c (rtl-c-get estate mode (rtx-eval-with-estate expr mode estate)))
+)
+
+; Translate parsed RTL expression X to a string of C code.
+; X must have already been fed through rtx-parse/rtx-compile.
+; MODE is the desired mode of the value or DFLT for "natural mode".
+; EXTRA-VARS-ALIST is an association list of extra (symbol <mode> value)
+; elements to be used during value lookup.
+; OVERRIDES is a #:keyword/value list of arguments to build the eval state
+; with.
+; ??? Maybe EXTRA-VARS-ALIST should be handled this way.
+
+(define (rtl-c-parsed mode x extra-vars-alist . overrides)
+  (let ((estate (estate-make-for-normal-rtl-c extra-vars-alist overrides)))
+    (rtl-c-with-estate estate mode x))
+)
+
+; Same as rtl-c-parsed but X is unparsed.
+
+(define (rtl-c mode x extra-vars-alist . overrides)
+  ; ??? rtx-compile could return a closure, then we wouldn't have to
+  ; pass EXTRA-VARS-ALIST to two routines here.
+  (let ((estate (estate-make-for-normal-rtl-c extra-vars-alist overrides)))
+    (rtl-c-with-estate estate mode (rtx-compile #f x extra-vars-alist)))
+)
+\f
+; C++ versions of rtl-c routines.
+
+; Build an estate for use in generating C++.
+; EXTRA-VARS-ALIST is an association list of (symbol <mode> value)
+; elements to be used during value lookup.
+; OVERRIDES is a #:keyword/value list of parameters to apply last.
+
+(define (estate-make-for-normal-rtl-c++ extra-vars-alist overrides)
+  (estate-make-for-rtl-c
+   #f ; FIXME: context
+   #f ; FIXME: owner
+   extra-vars-alist
+   -rtl-c-rtl-cover-fns?
+   #f ; macro?
+   (cons #:output-language (cons "c++" overrides)))
+)
+
+; Translate parsed RTL expression X to a string of C++ code.
+; X must have already been fed through rtx-parse/rtx-compile.
+; MODE is the desired mode of the value or DFLT for "natural mode".
+; EXTRA-VARS-ALIST is an association list of extra (symbol <mode> value)
+; elements to be used during value lookup.
+; OVERRIDES is a #:keyword/value list of arguments to build the eval state
+; with.
+; ??? Maybe EXTRA-VARS-ALIST should be handled this way.
+
+(define (rtl-c++-parsed mode x extra-vars-alist . overrides)
+  (let ((estate (estate-make-for-normal-rtl-c++ extra-vars-alist overrides)))
+    (rtl-c-with-estate estate mode x))
+)
+
+; Same as rtl-c-parsed but X is unparsed.
+
+(define (rtl-c++ mode x extra-vars-alist . overrides)
+  ; ??? rtx-compile could return a closure, then we wouldn't have to
+  ; pass EXTRA-VARS-ALIST to two routines here.
+  (let ((estate (estate-make-for-normal-rtl-c++ extra-vars-alist overrides)))
+    (rtl-c-with-estate estate mode (rtx-compile #f x extra-vars-alist)))
+)
+\f
+; Top level routines for getting/setting values.
+
+; Return a <c-expr> node to get the value of SRC in mode MODE.
+; ESTATE is the current rtl evaluation state.
+; SRC is one of:
+; - <c-expr> node
+; - rtl expression (e.g. '(add WI dr sr))
+; - sequence's local variable name
+; - sequence's local variable object
+; - operand name
+; - operand object
+; - a string of C code
+; FIXME: Reduce acceptable values of SRC.
+; The result has mode MODE, unless MODE is the "default mode indicator"
+; (DFLT) in which case the mode of the result is derived from SRC.
+; If SRC is a string, MODE can't be VOID or DFLT.
+;
+; ??? mode compatibility checks are wip
+
+(define (rtl-c-get estate mode src)
+  (logit 4 "(rtl-c-get " (mode-real-name mode) " " (rtx-strdump src) ")\n")
+
+  (let ((mode (mode:lookup mode)))
+
+    (cond ((c-expr? src)
+          (cond ((or (mode:eq? 'VOID mode)
+                     (mode:eq? 'DFLT mode)
+                     (mode:eq? (cx:mode src) mode))
+                 src)
+                ((-rtx-mode-compatible? mode (cx:mode src))
+                 (cx-new-mode mode src))
+                (else
+                 (error (string-append "incompatible mode for "
+                                       "(" (obj:name (cx:mode src)) ") "
+                                       "\"" (cx:c src) "\""
+                                       ": ")
+                        (obj:name mode)))))
+
+         ; The recursive call to rtl-c-get is in case the result of rtx-eval
+         ; is a hardware object, rtx-func object, or another rtl expression.
+         ((rtx? src)
+          (let ((evald-src (rtx-eval-with-estate src mode estate)))
+            ; There must have been some change, otherwise we'll loop forever.
+            (assert (not (eq? src evald-src)))
+            (rtl-c-get estate mode evald-src)))
+
+         ((or (and (symbol? src) (current-op-lookup src))
+              (operand? src))
+          (begin
+            (if (symbol? src)
+                (set! src (current-op-lookup src)))
+            (cond ((mode:eq? 'DFLT mode)
+                   ; FIXME: If we fetch the mode here, operands can assume
+                   ; they never get called with "default mode".
+                   (send src 'cxmake-get estate mode #f #f))
+                  ((-rtx-mode-compatible? mode (op:mode src))
+                   (let ((mode (-rtx-lazy-sem-mode mode)))
+                     (send src 'cxmake-get estate mode #f #f)))
+                  (else
+                   (error (string-append "operand " (obj:name src)
+                                         " referenced in incompatible mode: ")
+                          (obj:name mode))))))
+
+         ((or (and (symbol? src) (rtx-temp-lookup (estate-env estate) src))
+              (rtx-temp? src))
+          (begin
+            (if (symbol? src)
+                (set! src (rtx-temp-lookup (estate-env estate) src)))
+            (cond ((mode:eq? 'DFLT mode)
+                   (send src 'cxmake-get estate (rtx-temp-mode src) #f #f))
+                  ((-rtx-mode-compatible? mode (rtx-temp-mode src))
+                   (let ((mode (-rtx-lazy-sem-mode mode)))
+                     (send src 'cxmake-get estate mode #f #f)))
+                  (else (error (string-append "sequence temp " (rtx-temp-name src)
+                                              " referenced in incompatible mode: ")
+                               (obj:name mode))))))
+
+         ((integer? src)
+          ; Default mode of string argument is INT.
+          (if (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode))
+              (cx:make INT (number->string src))
+              (cx:make mode (number->string src))))
+
+         ((string? src)
+          ; Default mode of string argument is INT.
+          (if (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode))
+              (cx:make INT src)
+              (cx:make mode src)))
+
+         (else (error "rtl-c-get: invalid argument:" src))))
+)
+
+; Return a <c-expr> object to set the value of DEST to SRC.
+; ESTATE is the current rtl evaluation state.
+; DEST is one of:
+; - <c-expr> node
+; - rtl expression (e.g. '(mem QI dr))
+; SRC is a <c-expr> object.
+; The mode of the result is always VOID (void).
+
+(define (rtl-c-set-quiet estate mode dest src)
+  ;(display (list 'rtl-c-set-quiet mode dest src)) (newline)
+  (let ((xdest (cond ((c-expr? dest)
+                     dest)
+                    ((rtx? dest)
+                     (rtx-eval-with-estate dest mode estate))
+                    (else
+                     (error "rtl-c-set-quiet: invalid dest:" dest)))))
+    (if (not (object? xdest))
+       (error "rtl-c-set-quiet: invalid dest:" dest))
+    (let ((mode (if (mode:eq? 'DFLT mode)
+                   (-rtx-obj-mode xdest)
+                   (-rtx-lazy-sem-mode mode))))
+      (assert (mode? mode))
+      (cx:make VOID (send xdest 'gen-set-quiet
+                       estate mode #f #f
+                       (rtl-c-get estate mode src)))))
+)
+
+; Same as rtl-c-set-quiet except also print TRACE_RESULT message.
+; ??? One possible change is to defer the (rtl-c-get src) call to dest's
+; set handler.  Such sources would be marked accordingly and rtl-c-get
+; would recognize them.  This would allow, for example, passing the address
+; of the result to the computation.
+
+(define (rtl-c-set-trace estate mode dest src)
+  ;(display (list 'rtl-c-set-trace mode dest src)) (newline)
+  (let ((xdest (cond ((c-expr? dest)
+                     dest)
+                    ((rtx? dest)
+                     (rtx-eval-with-estate dest mode estate))
+                    (else
+                     (error "rtl-c-set-trace: invalid dest:" dest)))))
+    (if (not (object? xdest))
+       (error "rtl-c-set-trace: invalid dest:" dest))
+    (let ((mode (if (mode:eq? 'DFLT mode)
+                   (-rtx-obj-mode xdest) ; FIXME: internal routines
+                   (-rtx-lazy-sem-mode mode))))
+      (assert (mode? mode))
+      (cx:make VOID (send xdest 'gen-set-trace
+                       estate mode #f #f
+                       (rtl-c-get estate mode src)))))
+)
+\f
+; Emit C code for each rtx function.
+
+; Table mapping rtx function to C generator.
+
+(define -rtl-c-gen-table #f)
+
+; Return the C generator for <rtx-func> F.
+
+(define (rtl-c-generator f)
+  (vector-ref -rtl-c-gen-table (rtx-num f))
+)
+\f
+; Support for explicit C/C++ code.
+; ??? Actually, "support for explicit foreign language code".
+; s-c-call needs a better name but "unspec" seems like obfuscation.
+; ??? Need to distinguish owner of call (cpu, ???).
+
+(define (s-c-call estate mode name . args)
+  (cx:make mode
+          (string-append
+           (if (estate-output-language-c++? estate)
+               (string-append "current_cpu->" name " (")
+               ; FIXME: Prepend @cpu@_ to name here, and delete @cpu@_ from
+               ; description file.
+               (string-append name " (current_cpu"))
+           (let ((c-args
+                  (string-map (lambda (arg)
+                                (string-append
+                                 ", "
+                                 (cx:c (rtl-c-get estate DFLT arg))))
+                              args)))
+             (if (estate-output-language-c++? estate)
+                 (string-drop 2 c-args)
+                 c-args))
+           ; If the mode is VOID, this is a statement.
+           ; Otherwise it's an expression.
+           (if (or (mode:eq? 'DFLT mode)
+                   (mode:eq? 'VOID mode))
+               ");\n"
+               ")")
+           ))
+)
+
+; Same as c-call except there is no particular owner of the call.
+; In general this means making a call to a non-member function,
+; whereas c-call makes calls to member functions (in C++ parlance).
+
+(define (s-c-raw-call estate mode name . args)
+  (cx:make mode
+          (string-append
+           name " ("
+           (string-drop 2
+                        (string-map (lambda (elm)
+                                      (string-append
+                                       ", " (cx:c (rtl-c-get estate DFLT elm))))
+                                    args))
+           ; If the mode is VOID, this is a statement.
+           ; Otherwise it's an expression.
+           (if (or (mode:eq? 'DFLT mode)
+                   (mode:eq? 'VOID mode))
+               ");\n"
+               ")")
+           ))
+)
+\f
+; Standard arithmetic operations.
+
+; Return a boolean indicating if a cover function/macro should be emitted
+; to perform an operation.
+; C-OP is a string containing the C operation or #f if there is none.
+; MODE is the mode of the operation.
+
+(define (-rtx-use-sem-fn? estate c-op mode)
+  ; If no C operation has been provided, use a macro, or
+  ; if this is the simulator and MODE is not a host mode, use a macro.
+;  (or (not c-op)
+;      (and (estate-rtl-cover-fns? estate)
+;         (not (mode:host? mode))))
+  ; FIXME: The current definition is a temporary hack while host/target-ness
+  ; of INT/UINT is unresolved.
+  (and (not (obj-has-attr? mode 'FORCE-C))
+       (or (not c-op)
+          (and (estate-rtl-cover-fns? estate)
+               (or (insn? (estate-owner estate))
+                   (not (mode:host? mode))))))
+)
+
+; One operand referenced, result is in same mode.
+
+(define (s-unop estate name c-op mode src)
+  (let* ((val (rtl-c-get estate mode src))
+        ; Refetch mode in case it was DFLT and ensure unsigned->signed.
+        (mode (cx:mode val))
+        (sem-mode (-rtx-sem-mode mode)))
+    ; FIXME: Argument checking.
+
+    (if (-rtx-use-sem-fn? estate c-op mode)
+       (if (mode-float? mode)
+           (cx:make sem-mode
+                    (string-append "(* CGEN_CPU_FPU (current_cpu)->ops->"
+                                   (string-downcase name)
+                                   (string-downcase (obj:name sem-mode))
+                                   ") (CGEN_CPU_FPU (current_cpu), "
+                                   (cx:c val) ")"))
+           (cx:make sem-mode
+                    (string-append name (obj:name sem-mode)
+                                   " (" (cx:c val) ")")))
+       (cx:make mode ; not sem-mode on purpose
+                (string-append "(" c-op " ("
+                               (cx:c val) "))"))))
+)
+
+; Two operands referenced in the same mode producing a result in the same mode.
+; If MODE is DFLT, use the mode of SRC1.
+;
+; ??? Will eventually want to handle floating point modes specially.  Since
+; bigger modes may get clumsily passed (there is no pass by reference in C) and
+; since we want to eventually handle lazy transformation, FP values could be
+; passed by reference.  This is easy in C++.  C requires more work and is
+; defered until it's warranted.
+; Implementing this should probably be via a new cxmake-get-ref method,
+; rather then complicating cxmake-get.  Ditto for rtl-c-get-ref/rtl-c-get.
+
+(define (s-binop estate name c-op mode src1 src2)
+  (let* ((val1 (rtl-c-get estate mode src1))
+        ; Refetch mode in case it was DFLT and ensure unsigned->signed.
+        (mode (cx:mode val1))
+        (sem-mode (-rtx-sem-mode mode))
+        (val2 (rtl-c-get estate mode src2)))
+    ; FIXME: Argument checking.
+
+    (if (-rtx-use-sem-fn? estate c-op mode)
+       (if (mode-float? mode)
+           (cx:make sem-mode
+                    (string-append "(* CGEN_CPU_FPU (current_cpu)->ops->"
+                                   (string-downcase name)
+                                   (string-downcase (obj:name sem-mode))
+                                   ") (CGEN_CPU_FPU (current_cpu), "
+                                   (cx:c val1) ", "
+                                   (cx:c val2) ")"))
+           (cx:make sem-mode
+                    (string-append name (obj:name sem-mode)
+                                   " (" (cx:c val1) ", "
+                                   (cx:c val2) ")")))
+       (cx:make mode ; not sem-mode on purpose
+                (string-append "(("
+                               (cx:c val1)
+                               ") " c-op " ("
+                               (cx:c val2)
+                               "))"))))
+)
+
+; Same as s-binop except there's a third argument which is always one bit.
+
+(define (s-binop-with-bit estate name mode src1 src2 src3)
+  (let* ((val1 (rtl-c-get estate mode src1))
+        ; Refetch mode in case it was DFLT and ensure unsigned->signed.
+        (mode (-rtx-sem-mode (cx:mode val1)))
+        (val2 (rtl-c-get estate mode src2))
+        (val3 (rtl-c-get estate 'BI src3)))
+    ; FIXME: Argument checking.
+    (cx:make mode
+         (string-append name (obj:name mode)
+                        " ("
+                        (cx:c val1) ", "
+                        (cx:c val2) ", "
+                        (cx:c val3)
+                        ")")))
+)
+
+; Shift operations are slightly different than binary operations:
+; the mode of src2 is any integral mode.
+; ??? Note that some cpus have a signed shift left that is semantically
+; different from a logical one.  May need to create `sla' some day.  Later.
+
+(define (s-shop estate name c-op mode src1 src2)
+  (let* ((val1 (rtl-c-get estate mode src1))
+        ; Refetch mode in case it was DFLT and ensure unsigned->signed
+        ; [sign of operation is determined from operation name, not mode].
+        (mode (cx:mode val1))
+        (sem-mode (-rtx-sem-mode mode))
+        (val2 (rtl-c-get estate mode src2)))
+    ; FIXME: Argument checking.
+
+    (if (-rtx-use-sem-fn? estate c-op mode)
+       (cx:make sem-mode
+                (string-append name (obj:name sem-mode)
+                               " (" (cx:c val1) ", "
+                               (cx:c val2) ")"))
+       (cx:make mode ; not sem-mode on purpose
+                (string-append "("
+                               ; Ensure correct sign of shift.
+                               (cond ((equal? name "SRL")
+                                      (string-append "("
+                                                     (if (eq? (mode:class mode) 'UINT)
+                                                         ""
+                                                         "unsigned ")
+                                                     (mode:non-mode-c-type mode)
+                                                     ") "))
+                                     ((equal? name "SRA")
+                                      (string-append "("
+                                                     (mode:non-mode-c-type mode)
+                                                     ") "))
+                                     (else ""))
+                               "(" (cx:c val1) ") "
+                               c-op
+                               " (" (cx:c val2) "))"))))
+)
+
+; Process andif, orif.
+; SRC1 and SRC2 have any arithmetic mode.
+; The result has mode BI.
+; ??? May want to use INT as BI may introduce some slowness
+; in the generated code.
+
+(define (s-boolifop estate name c-op src1 src2)
+  (let* ((val1 (rtl-c-get estate DFLT src1))
+        (val2 (rtl-c-get estate DFLT src2)))
+    ; FIXME: Argument checking.
+    ; If this is the simulator and MODE is not a host mode, use a macro.
+    ; ??? MODE here being the mode of SRC1.  Maybe later.
+    (if (estate-rtl-cover-fns? estate)
+       (cx:make (mode:lookup 'BI)
+                (string-append name ; "BI", leave off mode, no need for it
+                               " (" (cx:c val1) ", "
+                               (cx:c val2) ")"))
+       (cx:make (mode:lookup 'BI)
+                (string-append "(("
+                               (cx:c val1)
+                               ") " c-op " ("
+                               (cx:c val2)
+                               "))"))))
+)
+
+; Mode conversions.
+
+(define (s-convop estate name mode s1)
+  ; Get S1 in its normal mode, then convert.
+  (let ((s (rtl-c-get estate DFLT s1))
+       (mode (mode:lookup mode)))
+    (if (and (not (estate-rtl-cover-fns? estate))
+            (mode:host? (cx:mode s)))
+       (cx:make mode
+                (string-append "((" (obj:name mode) ")"
+                               " (" (obj:name (cx:mode s)) ")"
+                               " (" (cx:c s) "))"))
+       (if (or (mode-float? mode)
+               (mode-float? (cx:mode s)))
+           (cx:make mode
+                    (string-append "(* CGEN_CPU_FPU (current_cpu)->ops->"
+                                   (string-downcase name)
+                                   (string-downcase (obj:name (-rtx-sem-mode (cx:mode s))))
+                                   (string-downcase (obj:name (-rtx-sem-mode mode)))
+                                   ") (CGEN_CPU_FPU (current_cpu), "
+                                   (cx:c s) ")"))
+           (cx:make mode
+                    (string-append name
+                                   (obj:name (-rtx-sem-mode (cx:mode s)))
+                                   (obj:name (-rtx-sem-mode mode))
+                                   " (" (cx:c s) ")")))))
+)
+
+; Compare SRC1 and SRC2 in mode MODE.  The result has mode BI.
+; NAME is one of eq,ne,lt,le,gt,ge,ltu,leu,gtu,geu.
+; ??? May want a host int mode result as BI may introduce some slowness
+; in the generated code.
+
+(define (s-cmpop estate name c-op mode src1 src2)
+  (let* ((val1 (rtl-c-get estate mode src1))
+        ; Refetch mode in case it was DFLT.
+        (mode (cx:mode val1))
+        (val2 (rtl-c-get estate mode src2)))
+    ; FIXME: Argument checking.
+
+    ; If no C operation has been provided, use a macro, or
+    ; if this is the simulator and MODE is not a host mode, use a macro.
+    (if (-rtx-use-sem-fn? estate c-op mode)
+       (if (mode-float? mode)
+           (cx:make (mode:lookup 'BI)
+                    (string-append "(* CGEN_CPU_FPU (current_cpu)->ops->"
+                                   (string-downcase name)
+                                   (string-downcase (obj:name (-rtx-sem-mode mode)))
+                                   ") (CGEN_CPU_FPU (current_cpu), "
+                                   (cx:c val1) ", "
+                                   (cx:c val2) ")"))
+           (cx:make (mode:lookup 'BI)
+                    (string-append (string-upcase name)
+                                   (if (memq name '(eq ne))
+                                       (obj:name (-rtx-sem-mode mode))
+                                       (obj:name mode))
+                                   " (" (cx:c val1) ", "
+                                   (cx:c val2) ")")))
+       (cx:make (mode:lookup 'BI)
+                (string-append "(("
+                               (cx:c val1)
+                               ") " c-op " ("
+                               (cx:c val2)
+                               "))"))))
+)
+\f
+; Conditional execution.
+
+; `if' in RTL has a result, like ?: in C.
+; We support both: one with a result (non VOID mode), and one without (VOID mode).
+; The non-VOID case must have an else part.
+; MODE is the mode of the result, not the comparison.
+; The comparison is expected to return a zero/non-zero value.
+; ??? Perhaps this should be a syntax-expr.  Later.
+
+(define (s-if estate mode cond then . else)
+  (if (> (length else) 1)
+      (error "if: too many elements in `else' part" else))
+  (let ()
+    (if (or (mode:eq? 'DFLT mode)
+           (mode:eq? 'VOID mode))
+       (cx:make mode
+                (string-append "if (" (cx:c (rtl-c-get estate DFLT cond)) ")"
+                               " {\n" (cx:c (rtl-c-get estate mode then)) "}"
+                               (if (not (null? else))
+                                   (string-append " else {\n"
+                                                  (cx:c (rtl-c-get estate mode (car else)))
+                                                  "}\n")
+                                   "\n")
+                               ))
+       (if (= (length else) 1)
+           (cx:make mode
+                    (string-append "(("
+                                   (cx:c (rtl-c-get estate DFLT cond))
+                                   ") ? ("
+                                   (cx:c (rtl-c-get estate mode then))
+                                   ") : ("
+                                   (cx:c (rtl-c-get estate mode (car else)))
+                                   "))"))
+           (error "non-VoidMode `if' must have `else' part"))))
+)
+
+; A multiway `if'.
+; If MODE is VOID emit a series of if/else's.
+; If MODE is not VOID, emit a series of ?:'s.
+; COND-CODE-LIST is a list of lists, each sublist is a list of two elements:
+; condition, code.  The condition part must return a zero/non-zero value, and
+; the code part is treated as a `sequence'.
+; This defer argument evaluation, the syntax
+; ((... condition ...) ... action ...)
+; needs special parsing.
+; FIXME: Need more error checking of arguments.
+
+(define (s-cond estate mode . cond-code-list)
+  (let ((vm? (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode))))
+    (if (null? cond-code-list)
+       (error "empty `cond'"))
+    (let ((if-part (if vm?  "if (" "("))
+         (then-part (if vm? ") " ") ? "))
+         (elseif-part (if vm? " else if (" " : ("))
+         (else-part (if vm? " else " " : "))
+         (fi-part (if vm? "" ")")))
+      (let loop ((result
+                 (string-append
+                  if-part
+                  (cx:c (rtl-c-get estate DFLT (caar cond-code-list)))
+                  then-part
+                  (cx:c (apply s-sequence
+                               (cons estate
+                                     (cons mode
+                                           (cons nil
+                                                 (cdar cond-code-list))))))))
+                (ccl (cdr cond-code-list)))
+       (cond ((null? ccl) (cx:make mode result))
+             ((eq? (caar ccl) 'else)
+              (cx:make mode
+                       (string-append
+                        result
+                        else-part
+                        (cx:c (apply s-sequence
+                                     (cons estate
+                                           (cons mode
+                                                 (cons nil
+                                                       (cdar ccl)))))))))
+             (else (loop (string-append
+                          result
+                          elseif-part
+                          (cx:c (rtl-c-get estate DFLT (caar ccl)))
+                          then-part
+                          (cx:c (apply s-sequence
+                                       (cons estate
+                                             (cons mode
+                                                   (cons nil
+                                                         (cdar ccl)))))))
+                         (cdr ccl)))))))
+)
+
+; Utility of s-case to print a case prefix (for lack of a better term).
+
+(define (-gen-case-prefix val)
+  (string-append "  case "
+                (cond ((number? val)
+                       (number->string val))
+                      ((symbol? val)
+                       (string-upcase (gen-c-symbol val))) ; yes, upcase
+                      ((string? val) val)
+                      (else
+                       (parse-error "case:" "bad case" val)))
+                " : ")
+)
+
+; Utility of s-case to handle a void result.
+
+(define (s-case-vm estate test case-list)
+  (cx:make
+   VOID
+   (string-append
+    "  switch ("
+    (cx:c (rtl-c-get estate DFLT test))
+    ")\n"
+    "  {\n"
+    (string-map (lambda (case-entry)
+                 (let ((caseval (car case-entry))
+                       (code (cdr case-entry)))
+                   (string-append
+                    (cond ((list? caseval)
+                           (string-map -gen-case-prefix caseval))
+                          ((eq? 'else caseval)
+                           (string-append "  default : "))
+                          (else
+                           (-gen-case-prefix caseval)))
+                    (cx:c (apply s-sequence
+                                 (cons estate (cons VOID (cons nil code)))))
+                    "    break;\n")))
+               case-list)
+    "  }\n"))
+)
+
+; Utility of s-case-non-vm to generate code to perform the test.
+
+(define (-gen-non-vm-case-test estate mode test cases)
+  (assert (not (null? cases)))
+  (let loop ((result "") (cases cases))
+    (if (null? cases)
+       result
+       (let ((case (cond ((number? (car cases))
+                          (car cases))
+                         ((symbol? (car cases))
+                          (if (enum-lookup-val (car cases))
+                              (rtx-make 'enum mode (car cases))
+                              (context-error (estate-context estate)
+                                             "symbol not an enum"
+                                             (car cases))))
+                         (else (error "invalid case" (car cases))))))
+         (loop (string-append
+                result
+                (if (= (string-length result) 0)
+                    ""
+                    " || ")
+                (cx:c (rtl-c-get estate mode test))
+                " == "
+                (cx:c (rtl-c-get estate mode case)))
+               (cdr cases)))))
+)
+
+; Utility of s-case to handle a non-void result.
+; This is expanded as a series of ?:'s.
+
+(define (s-case-non-vm estate mode test case-list)
+  (let ((if-part "(")
+       (then-part ") ? ")
+       (elseif-part " : (")
+       (else-part " : ")
+       (fi-part ")"))
+    (let loop ((result
+               (string-append
+                if-part
+                (-gen-non-vm-case-test estate mode test (caar case-list))
+                then-part
+                (cx:c (apply s-sequence
+                             (cons estate
+                                   (cons mode
+                                         (cons nil
+                                               (cdar case-list))))))))
+              (cl (cdr case-list)))
+      (cond ((null? cl) (cx:make mode result))
+           ((eq? (caar cl) 'else)
+            (cx:make mode
+                     (string-append
+                      result
+                      else-part
+                      (cx:c (apply s-sequence
+                                   (cons estate
+                                         (cons mode
+                                               (cons nil
+                                                     (cdar cl)))))))))
+           (else (loop (string-append
+                        result
+                        elseif-part
+                        (-gen-non-vm-case-test estate mode test (caar cl))
+                        then-part
+                        (cx:c (apply s-sequence
+                                     (cons estate
+                                           (cons mode
+                                                 (cons nil
+                                                       (cdar cl)))))))
+                       (cdr cl))))))
+)
+
+; C switch statement
+; To follow convention, MODE is the first arg.
+; FIXME: What to allow for case choices is wip.
+
+(define (s-case estate mode test . case-list)
+  (if (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode))
+      (s-case-vm estate test case-list)
+      (s-case-non-vm estate mode test case-list))
+)
+\f
+; Parallels and Sequences
+
+; Temps for `parallel' are recorded differently than for `sequence'.
+; ??? I believe this is because there was an interaction between the two.
+
+(define -par-temp-list nil)
+
+; Record a temporary needed for a parallel in mode MODE.
+; We just need to record the mode with a unique name so we use a <c-expr>
+; object where the "expression" is the variable's name.
+
+(define (-par-new-temp! mode)
+  (set! -par-temp-list
+       (cons (cx:make mode (string-append "temp"
+                                          (number->string
+                                           (length -par-temp-list))))
+             -par-temp-list))
+  (car -par-temp-list)
+)
+
+; Return the next temp from the list, and leave the list pointing to the
+; next one.
+
+(define (-par-next-temp!)
+  (let ((result (car -par-temp-list)))
+    (set! -par-temp-list (cdr -par-temp-list))
+    result)
+)
+
+(define (-gen-par-temp-defns temp-list)
+  ;(display temp-list) (newline)
+  (string-append
+   "  "
+   ; ??? mode:c-type
+   (string-map (lambda (temp) (string-append (obj:name (cx:mode temp)) " " (cx:c temp) ";"))
+              temp-list)
+   "\n")
+)
+
+; Parallels are handled by converting them into two sequences.  The first has
+; all set destinations replaced with temps, and the second has all set sources
+; replaced with those temps.
+; ??? Revisit later to see if (if ...) and (set pc ...) is ok.
+; How about disallowing if's and jump's inside parallels?
+; One can still put a parallel inside an `if' however.
+
+(define (-par-replace-set-dests estate exprs)
+  (let ((sets (list 'set 'set-quiet
+                   (rtx-lookup 'set) (rtx-lookup 'set-quiet))))
+    (letrec ((replace
+             (lambda (expr)
+               (let ((name (car expr))
+                     (options (rtx-options expr))
+                     (mode (rtx-mode expr)))
+                 (if (memq name sets)
+                     (list name
+                           options
+                           mode
+                           (-par-new-temp! ; replace dest with temp
+                            (if (mode:eq? 'DFLT mode)
+                                (rtx-lvalue-mode-name estate (rtx-set-dest expr))
+                                mode))
+                           (rtx-set-src expr))
+                     (cons name
+                           (cons options
+                                 (cons mode (replace (rtx-args expr)))))))))
+            )
+      (map replace exprs)))
+)
+
+; This must process expressions in the same order as -par-replace-set-dests!
+
+(define (-par-replace-set-srcs estate exprs)
+  (let ((sets (list 'set 'set-quiet
+                   (rtx-lookup 'set) (rtx-lookup 'set-quiet))))
+    (letrec ((replace
+             (lambda (expr)
+               (let ((name (car expr))
+                     (options (rtx-options expr))
+                     (mode (rtx-mode expr)))
+                 (if (memq name sets)
+                     (list name
+                           options
+                           mode
+                           (rtx-set-dest expr)
+                           (-par-next-temp!)) ; the source's temp
+                     (cons name
+                           (cons options
+                                 (cons mode (replace (cddr expr)))))))))
+            )
+      (map replace exprs)))
+)
+
+; Return a <c-expr> node for a `parallel'.
+
+(define (s-parallel estate . exprs)
+  (begin
+    ; Initialize -par-temp-list for -par-replace-set-dests.
+    (set! -par-temp-list nil)
+    (let* ((set-dests (string-map (lambda (e)
+                                   (rtl-c-with-estate estate VOID e))
+                                 (-par-replace-set-dests estate exprs)))
+          (temps (reverse! -par-temp-list)))
+      ; Initialize -par-temp-list for -par-replace-set-srcs.
+      (set! -par-temp-list temps)
+      (cx:make VOID
+              (string-append
+               ; FIXME: do {} while (0); doesn't get "optimized out"
+               ; internally by gcc, meaning two labels and a loop are
+               ; created for it to have to process.  We can generate pretty
+               ; big files and can cause gcc to require *lots* of memory.
+               ; So let's try just {} ...
+               "{\n"
+               (-gen-par-temp-defns temps)
+               set-dests
+               (string-map (lambda (e)
+                             (rtl-c-with-estate estate VOID e))
+                           (-par-replace-set-srcs estate exprs))
+               "}\n")
+              )))
+)
+
+; Return a <c-expr> node for a `sequence'.
+
+(define (s-sequence estate mode env . exprs)
+  (let* ((env (rtx-env-make-locals env)) ; compile env
+        (estate (estate-push-env estate env)))
+    (if (or (mode:eq? 'DFLT mode)
+           (mode:eq? 'VOID mode))
+       (cx:make mode
+                (string-append 
+                 ; FIXME: do {} while (0); doesn't get "optimized out"
+                 ; internally by gcc, meaning two labels and a loop are
+                 ; created for it to have to process.  We can generate pretty
+                 ; big files and can cause gcc to require *lots* of memory.
+                 ; So let's try just {} ...
+                 "{\n"
+                 (gen-temp-defs estate env)
+                 (string-map (lambda (e)
+                               (rtl-c-with-estate estate DFLT e))
+                             exprs)
+                 "}\n"))
+       (cx:make mode
+                (string-append
+                 ; Don't use GCC extension unless necessary.
+                 (if (rtx-env-empty? env) "(" "({ ")
+                 (gen-temp-defs estate env)
+                 (string-drop 2
+                              (string-map
+                               (lambda (e)
+                                 (string-append
+                                  ", "
+                                  (rtl-c-with-estate estate DFLT e)))
+                               exprs))
+                 (if (rtx-env-empty? env) ")" "; })")))))
+)
+\f
+; *****************************************************************************
+;
+; RTL->C generators for each rtx function.
+
+; Return code to set FN as the generator for RTX.
+
+(defmacro define-fn (rtx args expr . rest)
+  `(begin
+     (assert (rtx-lookup (quote ,rtx)))
+     (vector-set! table (rtx-num (rtx-lookup (quote ,rtx)))
+                 (lambda ,args ,@(cons expr rest))))
+)
+
+(define (rtl-c-init!)
+  (set! -rtl-c-gen-table (rtl-c-build-table))
+  *UNSPECIFIED*
+)
+
+; The rest of this file is one big function to return the rtl->c lookup table.
+
+(define (rtl-c-build-table)
+  (let ((table (make-vector (rtx-max-num) #f)))
+
+; Error generation
+
+(define-fn error (estate options mode message)
+  (let ((c-call (s-c-call estate mode "cgen_rtx_error"
+                         (string-append "\""
+                                        (backslash "\"" message)
+                                        "\""))))
+    (if (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode))
+       c-call
+       (cx:make mode (string-append "(" (cx:c c-call) ", 0)"))))
+)
+
+; Enum support
+
+(define-fn enum (estate options mode name)
+  (cx:make mode (string-upcase (gen-c-symbol name)))
+)
+
+; Instruction field support.
+; ??? This should build an operand object like -build-ifield-operand! does
+; in semantics.scm.
+; ??? Mode support is wip.
+
+(define-fn ifield (estate options mode ifld-name)
+  (if (estate-ifield-var? estate)
+      (cx:make 'UINT (gen-c-symbol ifld-name))
+      (cx:make 'UINT (string-append "FLD (" (gen-c-symbol ifld-name) ")")))
+;  (let ((f (current-ifld-lookup ifld-name)))
+;    (make <operand> ifld-name ifld-name
+;        (atlist-cons (bool-attr-make 'SEM-ONLY #t)
+;                     (obj-atlist f))
+;        (obj:name (ifld-hw-type f))
+;        (obj:name (ifld-mode f))
+;        (make <hw-index> 'anonymous
+;              'ifield (ifld-mode f) f)
+;        nil #f #f))
+)
+
+; Operand support
+
+(define-fn operand (estate options mode object-or-name)
+  (cond ((operand? object-or-name)
+        object-or-name)
+       ((symbol? object-or-name)
+        (let ((object (current-op-lookup object-or-name)))
+          (if (not object)
+              (context-error (estate-context estate)
+                             "undefined operand" object-or-name))
+          object))
+       (else
+        (context-error (estate-context estate)
+                       "bad arg to `operand'" object-or-name)))
+)
+
+(define-fn xop (estate options mode object) object)
+
+(define-fn local (estate options mode object-or-name)
+  (cond ((rtx-temp? object-or-name)
+        object-or-name)
+       ((symbol? object-or-name)
+        (let ((object (rtx-temp-lookup (estate-env estate) object-or-name)))
+          (if (not object)
+              (context-error (estate-context estate)
+                             "undefined local" object-or-name))
+          object))
+       (else
+        (context-error (estate-context estate)
+                       "bad arg to `local'" object-or-name)))
+)
+
+(define-fn reg (estate options mode hw-elm . indx-sel)
+  (let ((indx (or (list-maybe-ref indx-sel 0) 0))
+       (sel (or (list-maybe-ref indx-sel 1) hw-selector-default)))
+    (s-hw estate mode hw-elm indx sel))
+)
+
+(define-fn raw-reg (estate options mode hw-elm . indx-sel)
+  (let ((indx (or (list-maybe-ref indx-sel 0) 0))
+       (sel (or (list-maybe-ref indx-sel 1) hw-selector-default)))
+    (let ((result (s-hw estate mode hw-elm indx sel)))
+      (obj-cons-attr! result (bool-attr-make 'RAW #t))
+      result))
+)
+
+(define-fn mem (estate options mode addr . sel)
+  (s-hw estate mode 'h-memory addr
+       (if (pair? sel) (car sel) hw-selector-default))
+)
+
+(define-fn pc (estate options mode)
+  s-pc
+)
+
+(define-fn ref (estate options mode name)
+  (if (not (insn? (estate-owner estate)))
+      (error "ref: not processing an insn"))
+  (cx:make 'UINT
+          (string-append
+           "(referenced & (1 << "
+           (number->string
+            (op:num (insn-lookup-op (estate-owner estate) name)))
+           "))"))
+)
+
+; ??? Maybe this should return an operand object.
+(define-fn index-of (estate options mode op)
+  (send (op:index (rtx-eval-with-estate op 'DFLT estate)) 'cxmake-get estate 'DFLT)
+)
+
+(define-fn clobber (estate options mode object)
+  (cx:make VOID "; /*clobber*/\n")
+)
+
+(define-fn delay (estate options mode n rtx)
+  (s-sequence (estate-with-modifiers estate '((#:delay))) VOID '() rtx) ; wip!
+)
+
+; Gets expanded as a macro.
+;(define-fn annul (estate yes?)
+;  (s-c-call estate 'VOID "SEM_ANNUL_INSN" "pc" yes?)
+;)
+
+(define-fn skip (estate options mode yes?)
+  (send pc 'cxmake-skip estate yes?)
+  ;(s-c-call estate 'VOID "SEM_SKIP_INSN" "pc" yes?)
+)
+
+(define-fn eq-attr (estate options mode obj attr-name value)
+  (cx:make 'INT
+          (string-append "(GET_ATTR ("
+                         (gen-c-symbol attr-name)
+                         ") == "
+                         (gen-c-symbol value)
+                         ")"))
+)
+
+(define-fn attr (estate options mode owner attr-name)
+  (cond ((equal? owner '(current-insn () DFLT))
+        (s-c-raw-call estate 'INT "GET_ATTR"
+                      (string-upcase (gen-c-symbol attr-name))))
+       (else (error "attr: unsupported object type:" owner)))
+)
+
+(define-fn const (estate options mode c)
+  (assert (not (mode:eq? 'VOID mode)))
+  (if (mode:eq? 'DFLT mode)
+      (set! mode 'INT))
+  (let ((mode (mode:lookup mode)))
+    (cx:make mode
+            (cond ((or (mode:eq? 'DI mode)
+                       (mode:eq? 'UDI mode))
+                   (string-append "MAKEDI ("
+                                  (gen-integer (high-part c)) ", "
+                                  (gen-integer (low-part c))
+                                  ")"))
+                  ((and (<= #x-80000000 c) (> #x80000000 c))
+                   (number->string c))
+                  ((and (<= #x80000000 c) (>= #xffffffff c))
+                   ; ??? GCC complains if not affixed with "U" but that's not k&r.
+                   ;(string-append (number->string val) "U"))
+                   (string-append "0x" (number->string c 16)))
+                  ; Else punt.
+                  (else (number->string c)))))
+)
+
+(define-fn join (estate options out-mode in-mode arg1 . arg-rest)
+  ; FIXME: Endianness issues undecided.
+  ; FIXME: Ensure correct number of args for in/out modes.
+  ; Ensure compatible modes.
+  (apply s-c-raw-call (cons estate
+                           (cons out-mode
+                                 (cons (string-append "JOIN"
+                                                      in-mode
+                                                      out-mode)
+                                       (cons arg1 arg-rest)))))
+)
+
+(define-fn subword (estate options mode value word-num)
+  (let* ((mode (mode:lookup mode))
+        (val (rtl-c-get estate DFLT value))
+        ; Refetch mode in case it was DFLT.
+        (val-mode (cx:mode val)))
+    (cx:make mode
+            (string-append "SUBWORD" (obj:name val-mode) (obj:name mode)
+                           " (" (cx:c val)
+                           (if (mode-bigger? val-mode mode)
+                               (string-append
+                                ", "
+                                (if (number? word-num)
+                                    (number->string word-num)
+                                    (cx:c (rtl-c-get estate DFLT word-num))))
+                               "")
+                           ")")))
+)
+
+(define-fn c-code (estate options mode text)
+  (cx:make mode text)
+)
+
+(define-fn c-call (estate options mode name . args)
+  (apply s-c-call (cons estate (cons mode (cons name args))))
+)
+
+(define-fn c-raw-call (estate options mode name . args)
+  (apply s-c-raw-call (cons estate (cons mode (cons name args))))
+)
+
+(define-fn nop (estate options mode)
+  (cx:make VOID "((void) 0); /*nop*/\n")
+)
+
+(define-fn set (estate options mode dst src)
+  (if (insn? (estate-owner estate))
+      (rtl-c-set-trace estate mode dst (rtl-c-get estate mode src))
+      (rtl-c-set-quiet estate mode dst (rtl-c-get estate mode src)))
+)
+
+(define-fn set-quiet (estate options mode dst src)
+  (rtl-c-set-quiet estate mode dst (rtl-c-get estate mode src))
+)
+
+(define-fn neg (estate options mode s1)
+  (s-unop estate "NEG" "-" mode s1)
+)
+
+(define-fn abs (estate options mode s1)
+  (s-unop estate "ABS" #f mode s1)
+)
+
+(define-fn inv (estate options mode s1)
+  (s-unop estate "INV" "~" mode s1)
+)
+
+(define-fn not (estate options mode s1)
+  (s-unop estate "NOT" "!" mode s1)
+)
+
+(define-fn add (estate options mode s1 s2)
+  (s-binop estate "ADD" "+" mode s1 s2)
+)
+(define-fn sub (estate options mode s1 s2)
+  (s-binop estate "SUB" "-" mode s1 s2)
+)
+
+(define-fn addc (estate options mode s1 s2 s3)
+  (s-binop-with-bit estate "ADDC" mode s1 s2 s3)
+)
+(define-fn add-cflag (estate options mode s1 s2 s3)
+  (s-binop-with-bit estate "ADDCF" mode s1 s2 s3)
+)
+(define-fn add-oflag (estate options mode s1 s2 s3)
+  (s-binop-with-bit estate "ADDOF" mode s1 s2 s3)
+)
+(define-fn subc (estate options mode s1 s2 s3)
+  (s-binop-with-bit estate "SUBC" mode s1 s2 s3)
+)
+(define-fn sub-cflag (estate options mode s1 s2 s3)
+  (s-binop-with-bit estate "SUBCF" mode s1 s2 s3)
+)
+(define-fn sub-oflag (estate options mode s1 s2 s3)
+  (s-binop-with-bit estate "SUBOF" mode s1 s2 s3)
+)
+
+;(define-fn zflag (estate options mode value)
+;  (list 'eq mode value (list 'const mode 0))
+;)
+
+;(define-fn nflag (estate options mode value)
+;  (list 'lt mode value (list 'const mode 0))
+;)
+
+(define-fn mul (estate options mode s1 s2)
+  (s-binop estate "MUL" "*" mode s1 s2)
+)
+(define-fn div (estate options mode s1 s2)
+  (s-binop estate "DIV" "/" mode s1 s2)
+)
+(define-fn udiv (estate options mode s1 s2)
+  (s-binop estate "UDIV" "/" mode s1 s2)
+)
+(define-fn mod (estate options mode s1 s2)
+  (s-binop estate "MOD" "%" mode s1 s2)
+)
+(define-fn umod (estate options mode s1 s2)
+  (s-binop estate "UMOD" "%" mode s1 s2)
+)
+
+(define-fn sqrt (estate options mode s1)
+  (s-unop estate "SQRT" #f mode s1)
+)
+(define-fn cos (estate options mode s1)
+  (s-unop estate "COS" #f mode s1)
+)
+(define-fn sin (estate options mode s1)
+  (s-unop estate "SIN" #f mode s1)
+)
+
+(define-fn min (estate options mode s1 s2)
+  (s-binop estate "MIN" #f mode s1 s2)
+)
+(define-fn max (estate options mode s1 s2)
+  (s-binop estate "MAX" #f mode s1 s2)
+)
+(define-fn umin (estate options mode s1 s2)
+  (s-binop estate "UMIN" #f mode s1 s2)
+)
+(define-fn umax (estate options mode s1 s2)
+  (s-binop estate "UMAX" #f mode s1 s2)
+)
+
+(define-fn and (estate options mode s1 s2)
+  (s-binop estate "AND" "&" mode s1 s2)
+)
+(define-fn or (estate options mode s1 s2)
+  (s-binop estate "OR" "|" mode s1 s2)
+)
+(define-fn xor (estate options mode s1 s2)
+  (s-binop estate "XOR" "^" mode s1 s2)
+)
+
+(define-fn sll (estate options mode s1 s2)
+  (s-shop estate "SLL" "<<" mode s1 s2)
+)
+(define-fn srl (estate options mode s1 s2)
+  (s-shop estate "SRL" ">>" mode s1 s2)
+)
+(define-fn sra (estate options mode s1 s2)
+  (s-shop estate "SRA" ">>" mode s1 s2)
+)
+(define-fn ror (estate options mode s1 s2)
+  (s-shop estate "ROR" #f mode s1 s2)
+)
+(define-fn rol (estate options mode s1 s2)
+  (s-shop estate "ROL" #f mode s1 s2)
+)
+
+(define-fn andif (estate options mode s1 s2)
+  (s-boolifop estate "ANDIF" "&&" s1 s2)
+)
+(define-fn orif (estate options mode s1 s2)
+  (s-boolifop estate "ORIF" "||" s1 s2)
+)
+
+(define-fn ext (estate options mode s1)
+  (s-convop estate "EXT" mode s1)
+)
+(define-fn zext (estate options mode s1)
+  (s-convop estate "ZEXT" mode s1)
+)
+(define-fn trunc (estate options mode s1)
+  (s-convop estate "TRUNC" mode s1)
+)
+(define-fn fext (estate options mode s1)
+  (s-convop estate "FEXT" mode s1)
+)
+(define-fn ftrunc (estate options mode s1)
+  (s-convop estate "FTRUNC" mode s1)
+)
+(define-fn float (estate options mode s1)
+  (s-convop estate "FLOAT" mode s1)
+)
+(define-fn ufloat (estate options mode s1)
+  (s-convop estate "UFLOAT" mode s1)
+)
+(define-fn fix (estate options mode s1)
+  (s-convop estate "FIX" mode s1)
+)
+(define-fn ufix (estate options mode s1)
+  (s-convop estate "UFIX" mode s1)
+)
+
+(define-fn eq (estate options mode s1 s2)
+  (s-cmpop estate 'eq "==" mode s1 s2)
+)
+(define-fn ne (estate options mode s1 s2)
+  (s-cmpop estate 'ne "!=" mode s1 s2)
+)
+
+(define-fn lt (estate options mode s1 s2)
+  (s-cmpop estate 'lt "<" mode s1 s2)
+)
+(define-fn le (estate options mode s1 s2)
+  (s-cmpop estate 'le "<=" mode s1 s2)
+)
+(define-fn gt (estate options mode s1 s2)
+  (s-cmpop estate 'gt ">" mode s1 s2)
+)
+(define-fn ge (estate options mode s1 s2)
+  (s-cmpop estate 'ge ">=" mode s1 s2)
+)
+
+(define-fn ltu (estate options mode s1 s2)
+  (s-cmpop estate 'ltu "<" mode s1 s2)
+)
+(define-fn leu (estate options mode s1 s2)
+  (s-cmpop estate 'leu "<=" mode s1 s2)
+)
+(define-fn gtu (estate options mode s1 s2)
+  (s-cmpop estate 'gtu ">" mode s1 s2)
+)
+(define-fn geu (estate options mode s1 s2)
+  (s-cmpop estate 'geu ">=" mode s1 s2)
+)
+
+(define-fn member (estate options mode value set)
+  ; FIXME: Multiple evalutions of VALUE.
+  (let ((c-value (rtl-c-get estate 'DFLT value))
+       (set (rtx-number-list-values set)))
+    (let loop ((set (cdr set))
+              (code (string-append "(" (cx:c c-value)
+                                   " == "
+                                   (gen-integer (car set))
+                                   ")")))
+      (if (null? set)
+         (cx:make (mode:lookup 'BI) (string-append "(" code ")"))
+         (loop (cdr set)
+               (string-append code
+                              " || ("
+                              (cx:c c-value)
+                              " == "
+                              (gen-integer (car set))
+                              ")")))))
+)
+
+(define-fn if (estate options mode cond then . else)
+  (apply s-if (append! (list estate mode cond then) else))
+)
+
+(define-fn cond (estate options mode . cond-code-list)
+  (apply s-cond (cons estate (cons mode cond-code-list)))
+)
+
+(define-fn case (estate options mode test . case-list)
+  (apply s-case (cons estate (cons mode (cons test case-list))))
+)
+
+(define-fn parallel (estate options mode ignore expr . exprs)
+  (apply s-parallel (cons estate (cons expr exprs)))
+)
+
+(define-fn sequence (estate options mode locals expr . exprs)
+  (apply s-sequence
+        (cons estate (cons mode (cons locals (cons expr exprs)))))
+)
+
+(define-fn closure (estate options mode expr env)
+  ; ??? estate-push-env?
+  (rtl-c-with-estate (estate-new-env estate env) DFLT expr)
+)
+\f
+; The result is the rtl->c generator table.
+table
+)) ; End of rtl-c-build-table
diff --git a/cgen/rtl.scm b/cgen/rtl.scm
new file mode 100644 (file)
index 0000000..c6c55b4
--- /dev/null
@@ -0,0 +1,2205 @@
+; Basic RTL support.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; The name for the description language has been changed a couple of times.
+; RTL isn't my favorite because of perceived confusion with GCC
+; (and perceived misinterpretation of intentions!).
+; On the other hand my other choices were taken (and believed to be
+; more confusing).
+;
+; RTL functions are described by class <rtx-func>.
+; The complete list of rtl functions is defined in doc/rtl.texi.
+
+; Conventions used in this file:
+; - procs that perform the basic rtl or semantic expression manipulation that
+;   is for public use shall be prefixed with "s-" or "rtl-" or "rtx-"
+; - no other procs shall be so prefixed
+; - rtl globals and other rtx-func object support shall be prefixed with
+;   "-rtx[-:]"
+; - no other procs shall be so prefixed
+\f
+; Class for defining rtx nodes.
+
+; FIXME: Add new members that are lambda's to perform the argument checking
+; specified by `arg-types' and `arg-modes'.  This will save a lookup during
+; traversing.  It will also allow custom versions for oddballs (e.g. for
+; `member' we want to verify the 2nd arg is a `number-list' rtx).
+; ??? Still useful?
+
+(define <rtx-func>
+  (class-make '<rtx-func> nil
+             '(
+               ; name as it appears in RTL
+               name
+
+               ; argument list
+               args
+
+               ; types of each argument, as symbols
+               ; This is #f for macros.
+               ; Possible values:
+               ; OPTIONS - optional list of :-prefixed options.
+               ; ANYMODE - any mode
+               ; INTMODE - any integer mode
+               ; FLOATMODE - any floating point mode
+               ; NUMMODE - any numeric mode
+               ; EXPLNUMMODE - explicit numeric mode, can't be DFLT or VOID
+               ; NONVOIDMODE - can't be `VOID'
+               ; VOIDMODE - must be `VOID'
+               ; DFLTMODE - must be `DFLT', used when any mode is inappropriate
+               ; RTX - any rtx
+               ; SETRTX - any rtx allowed to be `set'
+               ; TESTRTX - the test of an `if'
+               ; CONDRTX - a cond expression ((test) rtx ... rtx)
+               ; CASERTX - a case expression ((symbol .. symbol) rtx ... rtx)
+               ; LOCALS - the locals list of a sequence
+               ; ENV - environment stack
+               ; ATTRS - attribute list
+               ; SYMBOL - operand must be a symbol
+               ; STRING - operand must be a string
+               ; NUMBER - operand must be a number
+               ; SYMORNUM - operand must be a symbol or number
+               ; OBJECT - operand is an object
+               arg-types
+
+               ; required mode of each argument
+               ; This is #f for macros.
+               ; Possible values include any mode name and:
+               ; ANY - any mode
+               ; NA - not applicable
+               ; OP0 - mode is specified in operand 0
+               ;       unless it is DFLT in which case use the default mode
+               ;       of the operand
+               ; MATCH1 - must match mode of operand 1
+               ;          which will have OP0 for its mode spec
+               ; MATCH2 - must match mode of operand 2
+               ;          which will have OP0 for its mode spec
+               ; <MODE-NAME> - must match specified mode
+               arg-modes
+
+               ; The class of rtx.
+               ; This is #f for macros.
+               ; ARG - operand, local, const
+               ; SET - set
+               ; UNARY - not, inv, etc.
+               ; BINARY - add, sub, etc.
+               ; TRINARY - addc, subc, etc.
+               ; IF - if
+               ; COND - cond, case
+               ; SEQUENCE - sequence, parallel
+               ; UNSPEC - c-call
+               ; MISC - everything else
+               class
+
+               ; A symbol indicating the flavour of rtx node this is.
+               ; function - normal function
+               ; syntax - don't pre-eval arguments
+               ; operand - result is an operand
+               ; macro - converts one rtx expression to another
+               ; The word "style" was chosen to be sufficiently different
+               ; from "type", "kind", and "class".
+               style
+
+               ; A function to perform the rtx.
+               evaluator
+
+               ; Ordinal number of rtx.  Used to index into tables.
+               num
+               )
+             nil)
+)
+
+; Predicate.
+
+(define (rtx-func? x) (class-instance? <rtx-func> x))
+
+; Accessor fns
+
+(define-getters <rtx-func> rtx
+  (name args arg-types arg-modes class style evaluator num)
+)
+
+(define (rtx-class-arg? rtx) (eq? (rtx-class rtx) 'ARG))
+(define (rtx-class-set? rtx) (eq? (rtx-class rtx) 'SET)) 
+(define (rtx-class-unary? rtx) (eq? (rtx-class rtx) 'UNARY))
+(define (rtx-class-binary? rtx) (eq? (rtx-class rtx) 'BINARY))
+(define (rtx-class-trinary? rtx) (eq? (rtx-class rtx) 'TRINARY))
+(define (rtx-class-if? rtx) (eq? (rtx-class rtx) 'IF))
+(define (rtx-class-cond? rtx) (eq? (rtx-class rtx) 'COND))
+(define (rtx-class-sequence? rtx) (eq? (rtx-class rtx) 'SEQUENCE))
+(define (rtx-class-unspec? rtx) (eq? (rtx-class rtx) 'UNSPEC))
+(define (rtx-class-misc? rtx) (eq? (rtx-class rtx) 'MISC))
+
+(define (rtx-style-function? rtx) (eq? (rtx-style rtx) 'function))
+(define (rtx-style-syntax? rtx) (eq? (rtx-style rtx) 'syntax))
+(define (rtx-style-operand? rtx) (eq? (rtx-style rtx) 'operand))
+(define (rtx-style-macro? rtx) (eq? (rtx-style rtx) 'macro))
+
+; Add standard `get-name' method since this isn't a subclass of <ident>.
+
+(method-make! <rtx-func> 'get-name (lambda (self) (elm-get self 'name)))
+
+; List of valid values for arg-types, not including mode names.
+
+(define -rtx-valid-types
+  '(OPTIONS
+    ANYMODE INTMODE FLOATMODE NUMMODE EXPLNUMMODE NONVOIDMODE VOIDMODE DFLTMODE
+    RTX TESTRTX CONDRTX CASERTX
+    LOCALS ENV ATTRS SYMBOL STRING NUMBER SYMORNUM OBJECT)
+)
+
+; List of valid mode matchers, excluding mode names.
+
+(define -rtx-valid-matches
+  '(ANY NA OP0 MATCH1 MATCH2)
+)
+
+; List of all defined rtx names.  This can be map'd over without having
+; to know the innards of -rtx-func-table (which is a hash table).
+
+(define -rtx-name-list nil)
+(define (rtx-name-list) -rtx-name-list)
+
+; Table of rtx function objects.
+; This is set in rtl-init!.
+
+(define -rtx-func-table nil)
+
+; Look up the <rtx-func> object for RTX-KIND.
+; Returns the object or #f if not found.
+; RTX-KIND may already be an <rtx-func> object.  FIXME: delete?
+
+(define (rtx-lookup rtx-kind)
+  (cond ((symbol? rtx-kind)
+        (hashq-ref -rtx-func-table rtx-kind))
+       ((rtx-func? rtx-kind)
+        rtx-kind)
+       (else #f))
+)
+
+; Table of rtx macro objects.
+; This is set in rtl-init!.
+
+(define -rtx-macro-table nil)
+
+; Table of operands, modes, and other non-functional aspects of RTL.
+; This is defined in rtl-finish!, after all operands have been read in.
+
+(define -rtx-operand-table nil)
+
+; Number of next rtx to be defined.
+
+(define -rtx-num-next #f)
+
+; Return the number of rtx's.
+
+(define (rtx-max-num)
+  -rtx-num-next
+)
+\f
+; Define Rtx Node
+;
+; Add an entry to the rtx function table.
+; NAME-ARGS is a list of the operation name and arguments.
+; The mode of the result must be the first element in `args' (if there are
+; any arguments).
+; ARG-TYPES is a list of argument types (-rtx-valid-types).
+; ARG-MODES is a list of mode matchers (-rtx-valid-matches).
+; ACTION is a list of Scheme expressions to perform the operation.
+;
+; ??? Note that we can support variables.  Not sure it should be done.
+
+(define (def-rtx-node name-args arg-types arg-modes class action)
+  (let ((name (car name-args))
+       (args (cdr name-args)))
+    (let ((rtx (make <rtx-func> name args
+                    arg-types arg-modes
+                    class
+                    'function
+                    (if action
+                        (eval (list 'lambda (cons '*estate* args) action))
+                        #f)
+                    -rtx-num-next)))
+      ; Add it to the table of rtx handlers.
+      (hashq-set! -rtx-func-table name rtx)
+      (set! -rtx-num-next (+ -rtx-num-next 1))
+      (set! -rtx-name-list (cons name -rtx-name-list))
+      *UNSPECIFIED*))
+)
+
+(define define-rtx-node
+  ; Written this way so Hobbit can handle it.
+  (defmacro:syntax-transformer (lambda arg-list
+                                (apply def-rtx-node arg-list)
+                                nil))
+)
+
+; Same as define-rtx-node but don't pre-evaluate the arguments.
+; Remember that `mode' must be the first argument.
+
+(define (def-rtx-syntax-node name-args arg-types arg-modes class action)
+  (let ((name (car name-args))
+       (args (cdr name-args)))
+    (let ((rtx (make <rtx-func> name args
+                    arg-types arg-modes
+                    class
+                    'syntax
+                    (if action
+                        (eval (list 'lambda (cons '*estate* args) action))
+                        #f)
+                    -rtx-num-next)))
+      ; Add it to the table of rtx handlers.
+      (hashq-set! -rtx-func-table name rtx)
+      (set! -rtx-num-next (+ -rtx-num-next 1))
+      (set! -rtx-name-list (cons name -rtx-name-list))
+      *UNSPECIFIED*))
+)
+
+(define define-rtx-syntax-node
+  ; Written this way so Hobbit can handle it.
+  (defmacro:syntax-transformer (lambda arg-list
+                                (apply def-rtx-syntax-node arg-list)
+                                nil))
+)
+
+; Same as define-rtx-node but return an operand (usually an <operand> object).
+; ??? `mode' must be the first argument?
+
+(define (def-rtx-operand-node name-args arg-types arg-modes class action)
+  ; Operand nodes must specify an action.
+  (assert action)
+  (let ((name (car name-args))
+       (args (cdr name-args)))
+    (let ((rtx (make <rtx-func> name args
+                    arg-types arg-modes
+                    class
+                    'operand
+                    (eval (list 'lambda (cons '*estate* args) action))
+                    -rtx-num-next)))
+      ; Add it to the table of rtx handlers.
+      (hashq-set! -rtx-func-table name rtx)
+      (set! -rtx-num-next (+ -rtx-num-next 1))
+      (set! -rtx-name-list (cons name -rtx-name-list))
+      *UNSPECIFIED*))
+)
+
+(define define-rtx-operand-node
+  ; Written this way so Hobbit can handle it.
+  (defmacro:syntax-transformer (lambda arg-list
+                                (apply def-rtx-operand-node arg-list)
+                                nil))
+)
+
+; Convert one rtx expression into another.
+; NAME-ARGS is a list of the operation name and arguments.
+; ACTION is a list of Scheme expressions to perform the operation.
+; The result of ACTION must be another rtx expression (a list).
+
+(define (def-rtx-macro-node name-args action)
+  ; macro nodes must specify an action
+  (assert action)
+  (let ((name (car name-args))
+       (args (cdr name-args)))
+    (let ((rtx (make <rtx-func> name args #f #f
+                    #f ; class
+                    'macro
+                    (eval (list 'lambda args action))
+                    -rtx-num-next)))
+      ; Add it to the table of rtx macros.
+      (hashq-set! -rtx-macro-table name rtx)
+      (set! -rtx-num-next (+ -rtx-num-next 1))
+      (set! -rtx-name-list (cons name -rtx-name-list))
+      *UNSPECIFIED*))
+)
+
+(define define-rtx-macro-node
+  ; Written this way so Hobbit can handle it.
+  (defmacro:syntax-transformer (lambda arg-list
+                                (apply def-rtx-macro-node arg-list)
+                                nil))
+)
+\f
+; RTL macro expansion.
+; RTL macros are different than pmacros.  The difference is that the expansion
+; happens internally, RTL macros are part of the language.
+
+; Lookup MACRO-NAME and return its <rtx-func> object or #f if not found.
+
+(define (-rtx-macro-lookup macro-name)
+  (hashq-ref -rtx-macro-table macro-name)
+)
+
+; Lookup (car exp) and return the macro's lambda if it is one or #f.
+
+(define (-rtx-macro-check exp fn-getter)
+  (let ((macro (hashq-ref -rtx-macro-table (car exp))))
+    (if macro
+       (fn-getter macro)
+       #f))
+)
+
+; Expand a list.
+
+(define (-rtx-macro-expand-list exp fn-getter)
+  (let ((macro (-rtx-macro-check exp fn-getter)))
+    (if macro
+       (apply macro (map (lambda (x) (-rtx-macro-expand x fn-getter))
+                         (cdr exp)))
+       (map (lambda (x) (-rtx-macro-expand x fn-getter))
+            exp)))
+)
+
+; Main entry point to expand a macro invocation.
+
+(define (-rtx-macro-expand exp fn-getter)
+  (if (pair? exp) ; pair? -> cheap (and (not (null? exp)) (list? exp))
+      (let ((result (-rtx-macro-expand-list exp fn-getter)))
+       ; If the result is a new macro invocation, recurse.
+       (if (pair? result)
+           (let ((macro (-rtx-macro-check result fn-getter)))
+             (if macro
+                 (-rtx-macro-expand (apply macro (cdr result)) fn-getter)
+                 result))
+           result))
+      exp)
+)
+
+; Publically accessible version.
+
+(define rtx-macro-expand -rtx-macro-expand)
+\f
+; RTX canonicalization.
+; ??? wip
+
+; Subroutine of rtx-canonicalize.
+; Return canonical form of rtx expression EXPR.
+; CONTEXT is a <context> object or #f if there is none.
+; It is used for error message.
+; RTX-OBJ is the <rtx-func> object of (car expr).
+
+(define (-rtx-canonicalize-expr context rtx-obj expr)
+  #f
+)
+
+; Return canonical form of EXPR.
+; CONTEXT is a <context> object or #f if there is none.
+; It is used for error message.
+;
+; Does:
+; - operand shortcuts expanded
+;   - numbers -> (const number)
+;   - operand-name -> (operand operand-name)
+;   - ifield-name -> (ifield ifield-name)
+; - no options -> null option list
+; - absent result mode of those that require a mode -> DFLT
+; - rtx macros are expanded
+;
+; EXPR is returned in source form.  We could speed up future processing by
+; transforming it into a more compiled form, but that makes debugging more
+; difficult, so for now we don't.
+
+(define (rtx-canonicalize context expr)
+  ; FIXME: wip
+  (cond ((integer? expr)
+        (rtx-make-const 'INT expr))
+       ((symbol? expr)
+        (let ((op (current-op-lookup expr)))
+          (if op
+              (rtx-make-operand expr)
+              (context-error context "can't canonicalize" expr))))
+       ((pair? expr)
+        expr)
+       (else
+        (context-error context "can't canonicalize" expr)))
+)
+\f
+; RTX mode support.
+
+; Get implied mode of X, either an operand expression, sequence temp, or
+; a hardware reference expression.
+; The result is the name of the mode.
+
+(define (rtx-lvalue-mode-name estate x)
+  (assert (rtx? x))
+  (case (car x)
+;    ((operand) (obj:name (op:mode (current-op-lookup (cadr x)))))
+    ((xop) (obj:name (send (rtx-xop-obj x) 'get-mode)))
+;    ((opspec)
+;     (if (eq? (rtx-opspec-mode x) 'VOID)
+;       (rtx-lvalue-mode-name estate (rtx-opspec-hw-ref x))
+;       (rtx-opspec-mode x)))
+;    ((reg mem) (cadr x))
+;    ((local) (obj:name (rtx-temp-mode (rtx-temp-lookup (estate-env estate)
+;                                                     (cadr x)))))
+    (else
+     (error "rtx-lvalue-mode-name: not an operand or hardware reference:" x)))
+)
+
+; Lookup the mode to use for semantic operations (unsigned modes aren't
+; allowed since we don't have ANDUSI, etc.).
+; ??? I have actually implemented both ways (full use of unsigned modes
+; and mostly hidden use of unsigned modes).  Neither makes me real
+; comfortable, though I liked bringing unsigned modes out into the open
+; even if it doubled the number of semantic operations.
+
+(define (-rtx-sem-mode m) (or (mode:sem-mode m) m))
+
+; MODE is a mode name or <mode> object.
+(define (-rtx-lazy-sem-mode mode) (-rtx-sem-mode (mode:lookup mode)))
+
+; Return the mode of object OBJ.
+
+(define (-rtx-obj-mode obj) (send obj 'get-mode))
+
+; Return a boolean indicating of modes M1,M2 are compatible.
+
+(define (-rtx-mode-compatible? m1 m2)
+  (let ((mode1 (-rtx-lazy-sem-mode m1))
+       (mode2 (-rtx-lazy-sem-mode m2)))
+    ;(eq? (obj:name mode1) (obj:name mode2)))
+    ; ??? This is more permissive than is perhaps proper.
+    (mode-compatible? 'sameclass mode1 mode2))
+)
+\f
+; Environments (sequences with local variables).
+
+; Temporaries are created within a sequence.
+; e.g. (sequence ((WI tmp)) (set tmp reg0) ...)
+; ??? Perhaps what we want here is `let' but for now I prefer `sequence'.
+; This isn't exactly `let' either as no initial value is specified.
+; Environments are also used to specify incoming values from the top level.
+
+(define <rtx-temp> (class-make '<rtx-temp> nil '(name mode value) nil))
+
+;(define cx-temp:name (elm-make-getter <c-expr-temp> 'name))
+;(define cx-temp:mode (elm-make-getter <c-expr-temp> 'mode))
+;(define cx-temp:value (elm-make-getter <c-expr-temp> 'value))
+
+(define-getters <rtx-temp> rtx-temp (name mode value))
+
+(method-make!
+ <rtx-temp> 'make!
+ (lambda (self name mode value)
+   (elm-set! self 'name name)
+   (elm-set! self 'mode mode)
+   (elm-set! self 'value (if value value (gen-temp name)))
+   self)
+)
+
+(define (gen-temp name)
+  ; ??? calls to gen-c-symbol don't belong here
+  (string-append "tmp_" (gen-c-symbol name))
+)
+
+; Return a boolean indicating if X is an <rtx-temp>.
+
+(define (rtx-temp? x) (class-instance? <rtx-temp> x))
+
+; Respond to 'get-mode messages.
+
+(method-make! <rtx-temp> 'get-mode (lambda (self) (elm-get self 'mode)))
+
+; Respond to 'get-name messages.
+
+(method-make! <rtx-temp> 'get-name (lambda (self) (elm-get self 'name)))
+
+; An environment is a list of <rtx-temp> objects.
+; An environment stack is a list of environments.
+
+(define (rtx-env-stack-empty? env-stack) (null? env-stack))
+(define (rtx-env-stack-head env-stack) (car env-stack))
+(define (rtx-env-var-list env) env)
+(define (rtx-env-empty-stack) nil)
+(define (rtx-env-init-stack1 vars-alist)
+  (if (null? vars-alist)
+      nil
+      (cons (rtx-env-make vars-alist) nil))
+)
+(define (rtx-env-empty? env) (null? env))
+
+; Create an initial environment.
+; VAR-LIST is a list of (name <mode> value) elements.
+
+(define (rtx-env-make var-list)
+  ; Convert VAR-LIST to an associative list of <rtx-temp> objects.
+  (map (lambda (var-spec)
+        (cons (car var-spec)
+              (make <rtx-temp>
+                (car var-spec) (cadr var-spec) (caddr var-spec))))
+       var-list)
+)
+
+; Create an initial environment with local variables.
+; VAR-LIST is a list of (mode-name name) elements (the argument to `sequence').
+
+(define (rtx-env-make-locals var-list)
+  ; Convert VAR-LIST to an associative list of <rtx-temp> objects.
+  (map (lambda (var-spec)
+        (cons (cadr var-spec)
+              (make <rtx-temp>
+                (cadr var-spec) (mode:lookup (car var-spec)) #f)))
+       var-list)
+)
+
+; Push environment ENV onto the front of environment stack ENV-STACK,
+; returning a new object.  ENV-STACK is not modified.
+
+(define (rtx-env-push env-stack env)
+  (cons env env-stack)
+)
+
+(define (rtx-temp-lookup env name)
+  ;(display "looking up:") (display name) (newline)
+  (let loop ((stack (rtx-env-var-list env)))
+    (if (null? stack)
+       #f
+       (let ((temp (assq-ref (car stack) name)))
+         (if temp
+             temp
+             (loop (cdr stack))))))
+)
+
+; Create a "closure" of EXPR using the current temp stack.
+
+(define (-rtx-closure-make estate expr)
+  (rtx-make 'closure expr (estate-env estate))
+)
+
+(define (rtx-env-dump env)
+  (let ((stack env))
+    (if (rtx-env-stack-empty? stack)
+       (display "rtx-env stack (empty):\n")
+       (let loop ((stack stack) (level 0))
+         (if (null? stack)
+             #f ; done
+             (begin
+               (display "rtx-env stack, level ")
+               (display level)
+               (display ":\n")
+               (for-each (lambda (var)
+                           (display "  ")
+                           ;(display (obj:name (rtx-temp-mode (cdr var))))
+                           ;(display " ")
+                           (display (rtx-temp-name (cdr var)))
+                           (newline))
+                         (car stack))
+               (loop (cdr stack) (+ level 1)))))))
+)
+\f
+; Build, test, and analyze various kinds of rtx's.
+; ??? A lot of this could be machine generated except that I don't yet need
+; that much.
+
+(define (rtx-make kind . args)
+  (cons kind (-rtx-munge-mode&options args))
+)
+
+(define rtx-name car)
+(define (rtx-kind? kind rtx) (eq? kind (rtx-name rtx)))
+
+(define (rtx-make-const mode value) (rtx-make 'const mode value))
+(define (rtx-make-enum mode value) (rtx-make 'enum mode value))
+
+(define (rtx-constant? rtx) (memq (rtx-name rtx) '(const enum)))
+
+; Return value of constant RTX (either const or enum).
+(define (rtx-constant-value rtx)
+  (case (rtx-name rtx)
+    ((const) (rtx-const-value rtx))
+    ((enum) (enum-lookup-val (rtx-enum-value rtx)))
+    (else (error "rtx-constant-value: not const or enum" rtx)))
+)
+
+(define rtx-options cadr)
+(define rtx-mode caddr)
+(define rtx-args cdddr)
+(define rtx-arg1 cadddr)
+(define (rtx-arg2 rtx) (car (cddddr rtx)))
+
+(define rtx-const-value rtx-arg1)
+(define rtx-enum-value rtx-arg1)
+
+(define rtx-reg-name rtx-arg1)
+
+; Return register number or #f if absent.
+; (reg options mode hw-name [regno [selector]])
+(define (rtx-reg-number rtx) (list-maybe-ref rtx 4))
+
+; Return register selector or #f if absent.
+(define (rtx-reg-selector rtx) (list-maybe-ref rtx 5))
+
+; Return both register number and selector.
+(define rtx-reg-index-sel cddddr)
+
+; Return memory address.
+(define rtx-mem-addr rtx-arg1)
+
+; Return memory selector or #f if absent.
+(define (rtx-mem-sel mem) (list-maybe-ref mem 4))
+
+; Return both memory address and selector.
+(define rtx-mem-index-sel cdddr)
+
+; Return MEM with new address NEW-ADDR.
+; ??? Complicate as necessary.
+(define (rtx-change-address mem new-addr)
+  (rtx-make 'mem
+           (rtx-options mem)
+           (rtx-mode mem)
+           new-addr
+           (rtx-mem-sel mem))
+)
+
+; Return argument to `symbol' rtx.
+(define rtx-symbol-name rtx-arg1)
+
+(define (rtx-make-ifield ifield-name) (rtx-make 'ifield ifield-name))
+(define (rtx-ifield? rtx) (eq? 'ifield (rtx-name rtx)))
+(define (rtx-ifield-name rtx)
+  (let ((ifield (rtx-arg1 rtx)))
+    (if (symbol? ifield)
+       ifield
+       (obj:name ifield)))
+)
+(define (rtx-ifield-obj rtx)
+  (let ((ifield (rtx-arg1 rtx)))
+    (if (symbol? ifield)
+       (current-ifield-lookup ifield)
+       ifield))
+)
+
+(define (rtx-make-operand op-name) (rtx-make 'operand op-name))
+(define (rtx-operand? rtx) (eq? 'operand (rtx-name rtx)))
+(define (rtx-operand-name rtx)
+  (let ((operand (rtx-arg1 rtx)))
+    (if (symbol? operand)
+       operand
+       (obj:name operand)))
+)
+(define (rtx-operand-obj rtx)
+  (let ((operand (rtx-arg1 rtx)))
+    (if (symbol? operand)
+       (current-op-lookup operand)
+       operand))
+)
+
+(define (rtx-make-local local-name) (rtx-make 'local local-name))
+(define (rtx-local? rtx) (eq? 'local (rtx-name rtx)))
+(define (rtx-local-name rtx)
+  (let ((local (rtx-arg1 rtx)))
+    (if (symbol? local)
+       local
+       (obj:name local)))
+)
+(define (rtx-local-obj rtx)
+  (let ((local (rtx-arg1 rtx)))
+    (if (symbol? local)
+       (error "can't use rtx-local-obj on local name")
+       local))
+)
+
+(define rtx-xop-obj rtx-arg1)
+
+;(define (rtx-opspec? rtx) (eq? 'opspec (rtx-name rtx)))
+;(define (rtx-opspec-mode rtx) (rtx-mode rtx))
+;(define (rtx-opspec-hw-ref rtx) (list-ref rtx 5))
+;(define (rtx-opspec-set-op-num! rtx num) (set-car! (cddddr rtx) num))
+
+(define rtx-index-of-value rtx-arg1)
+
+(define (rtx-make-set dest src) (rtx-make 'set dest src))
+(define rtx-set-dest rtx-arg1)
+(define rtx-set-src rtx-arg2)
+(define (rtx-single-set? rtx) (eq? (car rtx) 'set))
+
+(define rtx-alu-op-mode rtx-mode)
+(define (rtx-alu-op-arg rtx n) (list-ref rtx (+ n 3)))
+
+(define (rtx-boolif-op-arg rtx n) (list-ref rtx (+ n 3)))
+
+(define rtx-cmp-op-mode rtx-mode)
+(define (rtx-cmp-op-arg rtx n) (list-ref rtx (+ n 3)))
+
+(define rtx-number-list-values cdddr)
+
+(define rtx-member-value rtx-arg1)
+(define (rtx-member-set rtx) (list-ref rtx 4))
+
+(define rtx-if-mode rtx-mode)
+(define (rtx-if-test rtx) (rtx-arg1 rtx))
+(define (rtx-if-then rtx) (list-ref rtx 4))
+; If `else' clause is missing the result is #f.
+(define (rtx-if-else rtx) (list-maybe-ref rtx 5))
+
+(define (rtx-eq-attr-owner rtx) (list-ref rtx 3))
+(define (rtx-eq-attr-attr rtx) (list-ref rtx 4))
+(define (rtx-eq-attr-value rtx) (list-ref rtx 5))
+
+(define (rtx-sequence-locals rtx) (cadddr rtx))
+(define (rtx-sequence-exprs rtx) (cddddr rtx))
+
+; Same as rtx-sequence-locals except return in assq'able form.
+
+(define (rtx-sequence-assq-locals rtx)
+  (let ((locals (rtx-sequence-locals rtx)))
+    (map (lambda (local)
+          (list (cadr local) (car local)))
+        locals))
+)
+
+; Return a semi-pretty symbol describing RTX.
+; This is used by hw to include the index in the element's name.
+
+(define (rtx-pretty-name rtx)
+  (if (pair? rtx)
+      (case (car rtx)
+       ((const) (number->string (rtx-const-value rtx)))
+       ((operand) (obj:name (rtx-operand-obj rtx)))
+       ((local) (rtx-local-name rtx))
+       ((xop) (obj:name (rtx-xop-obj rtx)))
+       (else
+        (if (null? (cdr rtx))
+            (car rtx)
+            (apply string-append
+                   (cons (car rtx)
+                         (map (lambda (elm)
+                                (string-append "-" (rtx-pretty-name elm)))
+                              (cdr rtx)))))))
+      (stringize rtx "-"))
+)
+\f
+; RTL expression traversal support.
+; Traversal (and compilation) involves validating the source form and
+; converting it to internal form.
+; ??? At present the internal form is also the source form (easier debugging).
+
+; Set to #t to debug rtx traversal.
+
+(define -rtx-traverse-debug? #f)
+
+; Container to record the current state of traversal.
+; This is initialized before traversal, and modified (in a copy) as the
+; traversal state changes.
+; This doesn't record all traversal state, just the more static elements.
+; There's no point in recording things like the parent expression and operand
+; position as they change for every sub-traversal.
+; The main raison d'etre for this class is so we can add more state without
+; having to modify all the traversal handlers.
+; ??? At present it's not a proper "class" as there's no real need.
+;
+; CONTEXT is a <context> object or #f if there is none.
+; It is used for error messages.
+;
+; EXPR-FN is a dual-purpose beast.  The first purpose is to just process
+; the current expression and return the result.  The second purpose is to
+; lookup the function which will then process the expression.
+; It is applied recursively to the expression and each sub-expression.
+; It must be defined as
+; (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff) ...).
+; If the result of EXPR-FN is a lambda, it is applied to
+; (cons TSTATE (cdr EXPR)).  TSTATE is prepended to the arguments.
+; For syntax expressions if the result of EXPR-FN is #f, the operands are
+; processed using the builtin traverser.
+; So to repeat: EXPR-FN can process the expression, and if its result is a
+; lambda then it also processes the expression.  The arguments to EXPR-FN
+; are (rtx-obj expr mode parent-expr op-pos tstate appstuff).  The format
+; of the result of EXPR-FN are (cons TSTATE (cdr EXPR)).
+; The reason for the duality is that when trying to understand EXPR (e.g. when
+; computing the insn format) EXPR-FN processes the expression itself, and
+; when evaluating EXPR it's the result of EXPR-FN that computes the value.
+;
+; ENV is the current environment.  This is a stack of sequence locals.
+;
+; COND? is a boolean indicating if the current expression is on a conditional
+; execution path.  This is for optimization purposes only and it is always ok
+; to pass #t, except for the top-level caller which must pass #f (since the top
+; level expression obviously isn't subject to any condition).
+; It is used, for example, to speed up the simulator: there's no need to keep
+; track of whether an operand has been assigned to (or potentially read from)
+; if it's known it's always assigned to.
+;
+; SET? is a boolean indicating if the current expression is an operand being
+; set.
+;
+; OWNER is the owner of the expression or #f if there is none.
+; Typically it is an <insn> object.
+;
+; KNOWN is an alist of known values.  This is used by rtx-simplify.
+; Each element is (name . value) where
+; NAME is either an ifield or operand name (in the future it might be a
+; sequence local name), and
+; VALUE is either (const mode value) or (numlist mode value1 value2 ...).
+;
+; DEPTH is the current traversal depth.
+
+(define (tstate-make context owner expr-fn env cond? set? known depth)
+  (vector context owner expr-fn env cond? set? known depth)
+)
+
+(define (tstate-context state)             (vector-ref state 0))
+(define (tstate-set-context! state newval) (vector-set! state 0 newval))
+(define (tstate-owner state)               (vector-ref state 1))
+(define (tstate-set-owner! state newval)   (vector-set! state 1 newval))
+(define (tstate-expr-fn state)             (vector-ref state 2))
+(define (tstate-set-expr-fn! state newval) (vector-set! state 2 newval))
+(define (tstate-env state)                 (vector-ref state 3))
+(define (tstate-set-env! state newval)     (vector-set! state 3 newval))
+(define (tstate-cond? state)               (vector-ref state 4))
+(define (tstate-set-cond?! state newval)   (vector-set! state 4 newval))
+(define (tstate-set? state)                (vector-ref state 5))
+(define (tstate-set-set?! state newval)    (vector-set! state 5 newval))
+(define (tstate-known state)               (vector-ref state 6))
+(define (tstate-set-known! state newval)   (vector-set! state 6 newval))
+(define (tstate-depth state)               (vector-ref state 7))
+(define (tstate-set-depth! state newval)   (vector-set! state 7 newval))
+
+; Create a copy of STATE.
+
+(define (tstate-copy state)
+  ; A fast vector-copy would be nice, but this is simple and portable.
+  (list->vector (vector->list state))
+)
+
+; Create a copy of STATE with a new environment ENV.
+
+(define (tstate-new-env state env)
+  (let ((result (tstate-copy state)))
+    (tstate-set-env! result env)
+    result)
+)
+
+; Create a copy of STATE with environment ENV pushed onto the existing
+; environment list.
+; There's no routine to pop the environment list as there's no current
+; need for it: we make a copy of the state when we push.
+
+(define (tstate-push-env state env)
+  (let ((result (tstate-copy state)))
+    (tstate-set-env! result (cons env (tstate-env result)))
+    result)
+)
+
+; Create a copy of STATE with a new COND? value.
+
+(define (tstate-new-cond? state cond?)
+  (let ((result (tstate-copy state)))
+    (tstate-set-cond?! result cond?)
+    result)
+)
+
+; Create a copy of STATE with a new SET? value.
+
+(define (tstate-new-set? state set?)
+  (let ((result (tstate-copy state)))
+    (tstate-set-set?! result set?)
+    result)
+)
+
+; Lookup NAME in the known value table.  Returns the value or #f if not found.
+
+(define (tstate-known-lookup tstate name)
+  (let ((known (tstate-known tstate)))
+    (assq-ref known name))
+)
+
+; Increment the recorded traversal depth of TSTATE.
+
+(define (tstate-incr-depth! tstate)
+  (tstate-set-depth! tstate (1+ (tstate-depth tstate)))
+)
+
+; Decrement the recorded traversal depth of TSTATE.
+
+(define (tstate-decr-depth! tstate)
+  (tstate-set-depth! tstate (1- (tstate-depth tstate)))
+)
+\f
+; Traversal/compilation support.
+
+; Return a boolean indicating if X is a mode.
+
+(define (-rtx-any-mode? x)
+  (->bool (mode:lookup x))
+)
+
+; Return a boolean indicating if X is a symbol or rtx.
+
+(define (-rtx-symornum? x)
+  (or (symbol? x) (number? x))
+)
+
+; Traverse a list of rtx's.
+
+(define (-rtx-traverse-rtx-list rtx-list mode expr op-num tstate appstuff)
+  (map (lambda (rtx)
+        ; ??? Shouldn't OP-NUM change for each element?
+        (-rtx-traverse rtx 'RTX mode expr op-num tstate appstuff))
+       rtx-list)
+)
+
+; Cover-fn to context-error for signalling an error during rtx traversal.
+
+(define (-rtx-traverse-error tstate errmsg expr op-num)
+;  (parse-error context (string-append errmsg ", operand number "
+;                                    (number->string op-num))
+;             (rtx-dump expr))
+  (context-error (tstate-context tstate)
+                (string-append errmsg ", operand #" (number->string op-num))
+                (rtx-strdump expr))
+)
+
+; Rtx traversers.
+; These are defined as individual functions that are then built into a table
+; so that we can use Hobbit's "fastcall" support.
+;
+; The result is either a pair of the parsed VAL and new TSTATE,
+; or #f meaning there is no change (saves lots of unnecessarying cons'ing).
+
+(define (-rtx-traverse-options val mode expr op-num tstate appstuff)
+  #f
+)
+
+(define (-rtx-traverse-anymode val mode expr op-num tstate appstuff)
+  (let ((val-obj (mode:lookup val)))
+    (if (not val-obj)
+       (-rtx-traverse-error tstate "expecting a mode"
+                            expr op-num))
+    #f)
+)
+
+(define (-rtx-traverse-intmode val mode expr op-num tstate appstuff)
+  (let ((val-obj (mode:lookup val)))
+    (if (and val-obj
+            (or (memq (mode:class val-obj) '(INT UINT))
+                (eq? val 'DFLT)))
+       #f
+       (-rtx-traverse-error tstate "expecting an integer mode"
+                            expr op-num)))
+)
+
+(define (-rtx-traverse-floatmode val mode expr op-num tstate appstuff)
+  (let ((val-obj (mode:lookup val)))
+    (if (and val-obj
+            (or (memq (mode:class val-obj) '(FLOAT))
+                (eq? val 'DFLT)))
+       #f
+       (-rtx-traverse-error tstate "expecting a float mode"
+                            expr op-num)))
+)
+
+(define (-rtx-traverse-nummode val mode expr op-num tstate appstuff)
+  (let ((val-obj (mode:lookup val)))
+    (if (and val-obj
+            (or (memq (mode:class val-obj) '(INT UINT FLOAT))
+                (eq? val 'DFLT)))
+       #f
+       (-rtx-traverse-error tstate "expecting a numeric mode"
+                            expr op-num)))
+)
+
+(define (-rtx-traverse-explnummode val mode expr op-num tstate appstuff)
+  (let ((val-obj (mode:lookup val)))
+    (if (not val-obj)
+       (-rtx-traverse-error tstate "expecting a mode"
+                            expr op-num))
+    (if (memq val '(DFLT VOID))
+       (-rtx-traverse-error tstate "DFLT and VOID not allowed here"
+                            expr op-num))
+    #f)
+)
+
+(define (-rtx-traverse-nonvoidmode val mode expr op-num tstate appstuff)
+  (if (eq? val 'VOID)
+      (-rtx-traverse-error tstate "mode can't be VOID"
+                          expr op-num))
+  #f
+)
+
+(define (-rtx-traverse-voidmode val mode expr op-num tstate appstuff)
+  (if (memq val '(DFLT VOID))
+      #f
+      (-rtx-traverse-error tstate "expecting mode VOID"
+                          expr op-num))
+)
+
+(define (-rtx-traverse-dfltmode val mode expr op-num tstate appstuff)
+  (if (eq? val 'DFLT)
+      #f
+      (-rtx-traverse-error tstate "expecting mode DFLT"
+                          expr op-num))
+)
+
+(define (-rtx-traverse-rtx val mode expr op-num tstate appstuff)
+; Commented out 'cus it doesn't quite work yet.
+; (if (not (rtx? val))
+;     (-rtx-traverse-error tstate "expecting an rtx"
+;                         expr op-num))
+  (cons (-rtx-traverse val 'RTX mode expr op-num tstate appstuff)
+       tstate)
+)
+
+(define (-rtx-traverse-setrtx val mode expr op-num tstate appstuff)
+  ; FIXME: Still need to turn it off for sub-exprs.
+  ; e.g. (mem (reg ...))
+; Commented out 'cus it doesn't quite work yet.
+; (if (not (rtx? val))
+;     (-rtx-traverse-error tstate "expecting an rtx"
+;                                expr op-num))
+  (cons (-rtx-traverse val 'SETRTX mode expr op-num
+                      (tstate-new-set? tstate #t)
+                      appstuff)
+       tstate)
+)
+
+; This is the test of an `if'.
+
+(define (-rtx-traverse-testrtx val mode expr op-num tstate appstuff)
+; Commented out 'cus it doesn't quite work yet.
+; (if (not (rtx? val))
+;     (-rtx-traverse-error tstate "expecting an rtx"
+;                                expr op-num))
+  (cons (-rtx-traverse val 'RTX mode expr op-num tstate appstuff)
+       (tstate-new-cond?
+        tstate
+        (not (rtx-compile-time-constant? val))))
+)
+
+(define (-rtx-traverse-condrtx val mode expr op-num tstate appstuff)
+  (if (not (pair? val))
+      (-rtx-traverse-error tstate "expecting an expression"
+                          expr op-num))
+  (if (eq? (car val) 'else)
+      (begin
+       (if (!= (+ op-num 2) (length expr))
+           (-rtx-traverse-error tstate
+                                "`else' clause not last"
+                                expr op-num))
+       (cons (cons 'else
+                   (-rtx-traverse-rtx-list
+                    (cdr val) mode expr op-num
+                    (tstate-new-cond? tstate #t)
+                    appstuff))
+             (tstate-new-cond? tstate #t)))
+      (cons (cons
+            ; ??? Entries after the first are conditional.
+            (-rtx-traverse (car val) 'RTX 'ANY expr op-num tstate appstuff)
+            (-rtx-traverse-rtx-list
+             (cdr val) mode expr op-num
+             (tstate-new-cond? tstate #t)
+             appstuff))
+           (tstate-new-cond? tstate #t)))
+)
+
+(define (-rtx-traverse-casertx val mode expr op-num tstate appstuff)
+  (if (or (not (list? val))
+         (< (length val) 2))
+      (-rtx-traverse-error tstate
+                          "invalid `case' expression"
+                          expr op-num))
+  ; car is either 'else or list of symbols/numbers
+  (if (not (or (eq? (car val) 'else)
+              (and (list? (car val))
+                   (not (null? (car val)))
+                   (all-true? (map -rtx-symornum?
+                                   (car val))))))
+      (-rtx-traverse-error tstate
+                          "invalid `case' choice"
+                          expr op-num))
+  (if (and (eq? (car val) 'else)
+          (!= (+ op-num 2) (length expr)))
+      (-rtx-traverse-error tstate "`else' clause not last"
+                          expr op-num))
+  (cons (cons (car val)
+             (-rtx-traverse-rtx-list
+              (cdr val) mode expr op-num
+              (tstate-new-cond? tstate #t)
+              appstuff))
+       (tstate-new-cond? tstate #t))
+)
+
+(define (-rtx-traverse-locals val mode expr op-num tstate appstuff)
+  (if (not (list? val))
+      (-rtx-traverse-error tstate "bad locals list"
+                          expr op-num))
+  (for-each (lambda (var)
+             (if (or (not (list? var))
+                     (!= (length var) 2)
+                     (not (-rtx-any-mode? (car var)))
+                     (not (symbol? (cadr var))))
+                 (-rtx-traverse-error tstate
+                                      "bad locals list"
+                                      expr op-num)))
+           val)
+  (let ((env (rtx-env-make-locals val)))
+    (cons val (tstate-push-env tstate env)))
+)
+
+(define (-rtx-traverse-env val mode expr op-num tstate appstuff)
+  ; VAL is an environment stack.
+  (if (not (list? val))
+      (-rtx-traverse-error tstate "environment not a list"
+                          expr op-num))
+  (cons val (tstate-new-env tstate val))
+)
+
+(define (-rtx-traverse-attrs val mode expr op-num tstate appstuff)
+;  (cons val ; (atlist-source-form (atlist-parse val "" "with-attr"))
+;      tstate)
+  #f
+)
+
+(define (-rtx-traverse-symbol val mode expr op-num tstate appstuff)
+  (if (not (symbol? val))
+      (-rtx-traverse-error tstate "expecting a symbol"
+                          expr op-num))
+  #f
+)
+
+(define (-rtx-traverse-string val mode expr op-num tstate appstuff)
+  (if (not (string? val))
+      (-rtx-traverse-error tstate "expecting a string"
+                          expr op-num))
+  #f
+)
+
+(define (-rtx-traverse-number val mode expr op-num tstate appstuff)
+  (if (not (number? val))
+      (-rtx-traverse-error tstate "expecting a number"
+                          expr op-num))
+  #f
+)
+
+(define (-rtx-traverse-symornum val mode expr op-num tstate appstuff)
+  (if (not (or (symbol? val) (number? val)))
+      (-rtx-traverse-error tstate
+                          "expecting a symbol or number"
+                          expr op-num))
+  #f
+)
+
+(define (-rtx-traverse-object val mode expr op-num tstate appstuff)
+  #f
+)
+
+; Table of rtx traversers.
+; This is a vector of size rtx-max-num.
+; Each entry is a list of (arg-type-name . traverser) elements
+; for rtx-arg-types.
+
+(define -rtx-traverser-table #f)
+
+; Return a hash table of standard operand traversers.
+; The result of each traverser is a pair of the compiled form of `val' and
+; a possibly new traversal state or #f if there is no change.
+
+(define (-rtx-make-traverser-table)
+  (let ((hash-tab (make-hash-table 31))
+       (traversers
+        (list
+         ; /fastcall-make is recognized by Hobbit and handled specially.
+         ; When not using Hobbit it is a macro that returns its argument.
+         (cons 'OPTIONS (/fastcall-make -rtx-traverse-options))
+         (cons 'ANYMODE (/fastcall-make -rtx-traverse-anymode))
+         (cons 'INTMODE (/fastcall-make -rtx-traverse-intmode))
+         (cons 'FLOATMODE (/fastcall-make -rtx-traverse-floatmode))
+         (cons 'NUMMODE (/fastcall-make -rtx-traverse-nummode))
+         (cons 'EXPLNUMMODE (/fastcall-make -rtx-traverse-explnummode))
+         (cons 'NONVOIDFLTODE (/fastcall-make -rtx-traverse-nonvoidmode))
+         (cons 'VOIDFLTODE (/fastcall-make -rtx-traverse-voidmode))
+         (cons 'DFLTMODE (/fastcall-make -rtx-traverse-dfltmode))
+         (cons 'RTX (/fastcall-make -rtx-traverse-rtx))
+         (cons 'SETRTX (/fastcall-make -rtx-traverse-setrtx))
+         (cons 'TESTRTX (/fastcall-make -rtx-traverse-testrtx))
+         (cons 'CONDRTX (/fastcall-make -rtx-traverse-condrtx))
+         (cons 'CASERTX (/fastcall-make -rtx-traverse-casertx))
+         (cons 'LOCALS (/fastcall-make -rtx-traverse-locals))
+         (cons 'ENV (/fastcall-make -rtx-traverse-env))
+         (cons 'ATTRS (/fastcall-make -rtx-traverse-attrs))
+         (cons 'SYMBOL (/fastcall-make -rtx-traverse-symbol))
+         (cons 'STRING (/fastcall-make -rtx-traverse-string))
+         (cons 'NUMBER (/fastcall-make -rtx-traverse-number))
+         (cons 'SYMORNUM (/fastcall-make -rtx-traverse-symornum))
+         (cons 'OBJECT (/fastcall-make -rtx-traverse-object))
+         )))
+
+    (for-each (lambda (traverser)
+               (hashq-set! hash-tab (car traverser) (cdr traverser)))
+             traversers)
+
+    hash-tab)
+)
+
+; Traverse the operands of EXPR, a canonicalized RTL expression.
+; Here "canonicalized" means that -rtx-munge-mode&options has been called to
+; insert an option list and mode if they were absent in the original
+; expression.
+
+(define (-rtx-traverse-operands rtx-obj expr tstate appstuff)
+  (if -rtx-traverse-debug?
+      (begin
+       (display (spaces (* 4 (tstate-depth tstate))))
+       (display "Traversing operands of: ")
+       (display (rtx-dump expr))
+       (newline)
+       (rtx-env-dump (tstate-env tstate))
+       (force-output)
+       ))
+
+  (let loop ((operands (cdr expr))
+            (op-num 0)
+            (arg-types (vector-ref -rtx-traverser-table (rtx-num rtx-obj)))
+            (arg-modes (rtx-arg-modes rtx-obj))
+            (result nil)
+            )
+
+    (let ((varargs? (and (pair? arg-types) (symbol? (car arg-types)))))
+
+      (if -rtx-traverse-debug?
+         (begin
+           (display (spaces (* 4 (tstate-depth tstate))))
+           (if (null? operands)
+               (display "end of operands")
+               (begin
+                 (display "op-num ") (display op-num) (display ": ")
+                 (display (rtx-dump (car operands)))
+                 (display ", ")
+                 (display (if varargs? (car arg-types) (caar arg-types)))
+                 (display ", ")
+                 (display (if varargs? arg-modes (car arg-modes)))
+                 ))
+           (newline)
+           (force-output)
+           ))
+
+      (cond ((null? operands)
+            ; Out of operands, check if we have the expected number.
+            (if (or (null? arg-types)
+                    varargs?)
+                (reverse! result)
+                (context-error (tstate-context tstate)
+                               "missing operands" (rtx-strdump expr))))
+
+           ((null? arg-types)
+            (context-error (tstate-context tstate)
+                           "too many operands" (rtx-strdump expr)))
+
+           (else
+            (let ((type (if varargs? arg-types (car arg-types)))
+                  (mode (let ((mode-spec (if varargs?
+                                             arg-modes
+                                             (car arg-modes))))
+                          ; This is small enough that this is fast enough,
+                          ; and the number of entries should be stable.
+                          ; FIXME: for now
+                          (case mode-spec
+                            ((ANY) 'DFLT)
+                            ((NA) #f)
+                            ((OP0) (rtx-mode expr))
+                            ((MATCH1)
+                             ; If there is an explicit mode, use it.
+                             ; Otherwise we have to look at operand 1.
+                             (if (eq? (rtx-mode expr) 'DFLT)
+                                 'DFLT
+                                 (rtx-mode expr)))
+                            ((MATCH2)
+                             ; If there is an explicit mode, use it.
+                             ; Otherwise we have to look at operand 2.
+                             (if (eq? (rtx-mode expr) 'DFLT)
+                                 'DFLT
+                                 (rtx-mode expr)))
+                            (else mode-spec))))
+                  (val (car operands))
+                  )
+
+              ; Look up the traverser for this kind of operand and perform it.
+              (let ((traverser (cdr type)))
+                (let ((traversed-val (fastcall6 traverser val mode expr op-num tstate appstuff)))
+                  (if traversed-val
+                      (begin
+                        (set! val (car traversed-val))
+                        (set! tstate (cdr traversed-val))))))
+
+              ; Done with this operand, proceed to the next.
+              (loop (cdr operands)
+                    (+ op-num 1)
+                    (if varargs? arg-types (cdr arg-types))
+                    (if varargs? arg-modes (cdr arg-modes))
+                    (cons val result)))))))
+)
+
+; Publically accessible version of -rtx-traverse-operands as EXPR-FN may
+; need to call it.
+
+(define rtx-traverse-operands -rtx-traverse-operands)
+
+; Subroutine of -rtx-munge-mode&options.
+; Return boolean indicating if X is an rtx option.
+
+(define (-rtx-option? x)
+  (and (symbol? x)
+       (char=? (string-ref x 0) #\:))
+)
+
+; Subroutine of -rtx-munge-mode&options.
+; Return boolean indicating if X is an rtx option list.
+
+(define (-rtx-option-list? x)
+  (or (null? x)
+      (and (pair? x)
+          (-rtx-option? (car x))))
+)
+
+; Subroutine of -rtx-traverse-expr to fill in the mode if absent and to
+; collect the options into one list.
+; ARGS is the list of arguments to the rtx function
+; (e.g. (1 2) in (add 1 2)).
+; ??? "munge" is an awkward name to use here, but I like it for now because
+; it's easy to grep for.
+; ??? An empty option list requires a mode to be present so that the empty
+; list in `(sequence () foo bar)' is unambiguously recognized as the locals
+; list.  Icky, sure, but less icky than the alternatives thus far.
+
+(define (-rtx-munge-mode&options args)
+  (let ((options nil)
+       (mode-name 'DFLT))
+    ; Pick off the option list if present.
+    (if (and (pair? args)
+            (-rtx-option-list? (car args))
+            ; Handle `(sequence () foo bar)'.  If empty list isn't followed
+            ; by a mode, it is not an option list.
+            (or (not (null? (car args)))
+                (and (pair? (cdr args))
+                     (mode-name? (cadr args)))))
+       (begin
+         (set! options (car args))
+         (set! args (cdr args))))
+    ; Pick off the mode if present.
+    (if (and (pair? args)
+            (mode-name? (car args)))
+       (begin
+         (set! mode-name (car args))
+         (set! args (cdr args))))
+    ; Now put option list and mode back.
+    (cons options (cons mode-name args)))
+)
+
+; Traverse an expression.
+; For syntax expressions arguments are not pre-evaluated before calling the
+; user's expression handler.  Otherwise they are.
+; If EXPR-FN wants to just scan the operands, rather than evaluating them,
+; one thing it can do is call back to rtx-traverse-operands.
+; If EXPR-FN returns #f, traverse the operands normally and return
+; (rtx's-name traversed-operand1 ...).
+; This is for semantic-compile's sake and all traversal handlers are
+; required to do this if EXPR-FN returns #f.
+
+(define (-rtx-traverse-expr rtx-obj expr mode parent-expr op-pos tstate appstuff)
+  (let* ((expr2 (cons (car expr)
+                     (-rtx-munge-mode&options (cdr expr))))
+        (fn (fastcall7 (tstate-expr-fn tstate)
+                       rtx-obj expr2 mode parent-expr op-pos tstate appstuff)))
+    (if fn
+       (if (procedure? fn)
+           ; Don't traverse operands for syntax expressions.
+           (if (rtx-style-syntax? rtx-obj)
+               (apply fn (cons tstate (cdr expr2)))
+               (let ((operands (-rtx-traverse-operands rtx-obj expr2 tstate appstuff)))
+                 (apply fn (cons tstate operands))))
+           fn)
+       (let ((operands (-rtx-traverse-operands rtx-obj expr2 tstate appstuff)))
+         (cons (car expr2) operands))))
+)
+
+; Main entry point for expression traversal.
+; (Actually rtx-traverse is, but it's just a cover function for this.)
+;
+; The result is the result of the lambda EXPR-FN looks up in the case of
+; expressions or an operand object (usually <operand>) in the case of operands.
+;
+; EXPR is the expression to be traversed.
+;
+; MODE is the name of the mode of EXPR.
+;
+; PARENT-EXPR is the expression EXPR is contained in.  The top-level
+; caller must pass #f for it.
+;
+; OP-POS is the position EXPR appears in PARENT-EXPR.  The
+; top-level caller must pass 0 for it.
+;
+; EXPECTED is one of `-rtx-valid-types' and indicates the expected rtx type
+; or #f if it doesn't matter.
+;
+; TSTATE is the current traversal state.
+;
+; APPSTUFF is for application specific use.
+;
+; All macros are expanded here.  User code never sees them.
+; All operand shortcuts are also expand here.  User code never sees them.
+; These are:
+; - operands, ifields, and numbers appearing where an rtx is expected are
+;   converted to use `operand', `ifield', or `const'.
+
+(define (-rtx-traverse expr expected mode parent-expr op-pos tstate appstuff)
+  (if -rtx-traverse-debug?
+      (begin
+       (display (spaces (* 4 (tstate-depth tstate))))
+       (display "Traversing expr: ")
+       (display expr)
+       (newline)
+       (display (spaces (* 4 (tstate-depth tstate))))
+       (display "-expected:       ")
+       (display expected)
+       (newline)
+       (display (spaces (* 4 (tstate-depth tstate))))
+       (display "-mode:           ")
+       (display mode)
+       (newline)
+       (force-output)
+       ))
+
+  (if (pair? expr) ; pair? -> cheap non-null-list?
+
+      (let ((rtx-obj (rtx-lookup (car expr))))
+       (tstate-incr-depth! tstate)
+       (let ((result
+              (if rtx-obj
+                  (-rtx-traverse-expr rtx-obj expr mode parent-expr op-pos tstate appstuff)
+                  (let ((rtx-obj (-rtx-macro-lookup (car expr))))
+                    (if rtx-obj
+                        (-rtx-traverse (-rtx-macro-expand expr rtx-evaluator)
+                                       expected mode parent-expr op-pos tstate appstuff)
+                        (context-error (tstate-context tstate) "unknown rtx function"
+                                       expr))))))
+         (tstate-decr-depth! tstate)
+         result))
+
+      ; EXPR is not a list.
+      ; See if it's an operand shortcut.
+      (if (memq expected '(RTX SETRTX))
+
+         (cond ((symbol? expr)
+                (cond ((current-op-lookup expr)
+                       (-rtx-traverse
+                        (rtx-make-operand expr) ; (current-op-lookup expr))
+                        expected mode parent-expr op-pos tstate appstuff))
+                      ((rtx-temp-lookup (tstate-env tstate) expr)
+                       (-rtx-traverse
+                        (rtx-make-local expr) ; (rtx-temp-lookup (tstate-env tstate) expr))
+                        expected mode parent-expr op-pos tstate appstuff))
+                      ((current-ifld-lookup expr)
+                       (-rtx-traverse
+                        (rtx-make-ifield expr)
+                        expected mode parent-expr op-pos tstate appstuff))
+                      ((enum-lookup-val expr)
+                       (-rtx-traverse
+                        (rtx-make-enum 'INT expr)
+                        expected mode parent-expr op-pos tstate appstuff))
+                      (else
+                       (context-error (tstate-context tstate)
+                                      "unknown operand" expr))))
+               ((integer? expr)
+                (-rtx-traverse (rtx-make-const 'INT expr)
+                               expected mode parent-expr op-pos tstate appstuff))
+               (else
+                (context-error (tstate-context tstate)
+                               "unexpected operand"
+                               expr)))
+
+         ; Not expecting RTX or SETRTX.
+         (context-error (tstate-context tstate)
+                        "unexpected operand"
+                        expr)))
+)
+
+; User visible procedures to traverse an rtl expression.
+; These calls -rtx-traverse to do most of the work.
+; See tstate-make for an explanation of EXPR-FN.
+; CONTEXT is a <context> object or #f if there is none.
+; LOCALS is a list of (mode . name) elements (the locals arg to `sequence').
+; APPSTUFF is for application specific use.
+
+(define (rtx-traverse context owner expr expr-fn appstuff)
+  (-rtx-traverse expr #f 'DFLT #f 0
+                (tstate-make context owner expr-fn (rtx-env-empty-stack)
+                             #f #f nil 0)
+                appstuff)
+)
+
+(define (rtx-traverse-with-locals context owner expr expr-fn locals appstuff)
+  (-rtx-traverse expr #f 'DFLT #f 0
+                (tstate-make context owner expr-fn
+                             (rtx-env-push (rtx-env-empty-stack)
+                                           (rtx-env-make-locals locals))
+                             #f #f nil 0)
+                appstuff)
+)
+
+; Traverser debugger.
+
+(define (rtx-traverse-debug expr)
+  (rtx-traverse
+   #f #f expr
+   (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff)
+     (display "-expr:    ")
+     (display (string-append "rtx=" (obj:name rtx-obj)))
+     (display " expr=")
+     (display expr)
+     (display " mode=")
+     (display mode)
+     (display " parent=")
+     (display parent-expr)
+     (display " op-pos=")
+     (display op-pos)
+     (display " cond?=")
+     (display (tstate-cond? tstate))
+     (newline)
+     #f)
+   #f
+   )
+)
+
+; Convert rtl expression EXPR from source form to compiled form.
+; The expression is validated and rtx macros are expanded as well.
+; CONTEXT is a <context> object or #f if there is none.
+; It is used in error messages.
+; EXTRA-VARS-ALIST is an association list of extra (symbol <mode> value)
+; elements to be used during value lookup.
+;
+; This does the same operation that rtx-traverse does, except that it provides
+; a standard value for EXPR-FN.
+;
+; ??? In the future the compiled form may be the same as the source form
+; except that all elements would be converted to their respective objects.
+
+(define (-compile-expr-fn rtx-obj expr mode parent-expr op-pos tstate appstuff)
+; (cond 
+; The intent of this is to handle sequences/closures, but is it needed?
+;  ((rtx-style-syntax? rtx-obj)
+;   ((rtx-evaluator rtx-obj) rtx-obj expr mode
+;                           parent-expr op-pos tstate))
+;  (else
+  (cons (car expr) ; rtx-obj
+       (-rtx-traverse-operands rtx-obj expr tstate appstuff))
+)
+
+(define (rtx-compile context expr extra-vars-alist)
+  (-rtx-traverse expr #f 'DFLT #f 0
+                (tstate-make context #f
+                             (/fastcall-make -compile-expr-fn)
+                             (rtx-env-init-stack1 extra-vars-alist)
+                             #f #f nil 0)
+                #f)
+)
+\f
+; Various rtx utilities.
+
+; Dump an rtx expression.
+
+(define (rtx-dump rtx)
+  (cond ((list? rtx) (map rtx-dump rtx))
+       ((object? rtx) (string-append "#<object "
+                                     (object-class-name rtx)
+                                     " "
+                                     (obj:name rtx)
+                                     ">"))
+       (else rtx))
+)
+
+; Dump an expression to a string.
+
+(define (rtx-strdump rtx)
+  (with-output-to-string
+    (lambda ()
+      (display (rtx-dump rtx))))
+)
+
+; Return a boolean indicating if EXPR is known to be a compile-time constant.
+
+(define (rtx-compile-time-constant? expr)
+  (cond ((pair? expr)
+        (case (car expr)
+          ((const enum) #t)
+          (else #f)))
+       ((memq expr '(FALSE TRUE)) #t)
+       (else #f))
+)
+
+; Return boolean indicating if EXPR has side-effects.
+; FIXME: for now punt.
+
+(define (rtx-side-effects? expr)
+  #f
+)
+
+; Return a boolean indicating if EXPR is a "true" boolean value.
+;
+; ??? In RTL, #t is a synonym for (const 1).  This is confusing for Schemers,
+; so maybe RTL's #t should be renamed to TRUE.
+
+(define (rtx-true? expr)
+  (cond ((pair? expr)
+        (case (car expr)
+          ((const enum) (!= (rtx-constant-value expr) 0))
+          (else #f)))
+       ((eq? expr 'TRUE) #t)
+       (else #f))
+)
+
+; Return a boolean indicating if EXPR is a "false" boolean value.
+;
+; ??? In RTL, #f is a synonym for (const 0).  This is confusing for Schemers,
+; so maybe RTL's #f should be renamed to FALSE.
+
+(define (rtx-false? expr)
+  (cond ((pair? expr)
+        (case (car expr)
+          ((const enum) (= (rtx-constant-value expr) 0))
+          (else #f)))
+       ((eq? expr 'FALSE) #t)
+       (else #f))
+)
+
+; Return canonical boolean values.
+
+(define (rtx-false) (rtx-make-const 'BI 0))
+(define (rtx-true) (rtx-make-const 'BI 1))
+
+; Convert EXPR to a canonical boolean if possible.
+
+(define (rtx-canonical-bool expr)
+  (cond ((rtx-side-effects? expr) expr)
+       ((rtx-false? expr) (rtx-false))
+       ((rtx-true? expr) (rtx-true))
+       (else expr))
+)
+
+; Return rtx values for #f/#t.
+
+(define (rtx-make-bool value)
+  (if value
+      (rtx-true)
+      (rtx-false))
+)
+
+; Return #t if X is an rtl expression.
+; e.g. '(add WI dr simm8);
+
+(define (rtx? x)
+  (->bool
+   (and (pair? x) ; pair? -> cheap non-null-list?
+       (or (hashq-ref -rtx-func-table (car x))
+           (hashq-ref -rtx-macro-table (car x)))))
+)
+\f
+; RTL evaluation state.
+; Applications may subclass <eval-state> if they need to add things.
+;
+; This is initialized before evaluation, and modified (in a copy) as the
+; evaluation state changes.
+; This doesn't record all evaluation state, just the less dynamic elements.
+; There's no point in recording things like the parent expression and operand
+; position as they change for every sub-eval.
+; The main raison d'etre for this class is so we can add more state without
+; having to modify all the eval handlers.
+
+(define <eval-state>
+  (class-make '<eval-state> nil
+             '(
+               ; <context> object or #f if there is none
+               (context . #f)
+
+               ; Current object rtl is being evaluated for.
+               ; We need to be able to access the current instruction while
+               ; generating semantic code.  However, the semantic description
+               ; doesn't specify it as an argument to anything (and we don't
+               ; want it to).  So we record the value here.
+               (owner . #f)
+
+               ; EXPR-FN is a dual-purpose beast.  The first purpose is to
+               ; just process the current expression and return the result.
+               ; The second purpose is to lookup the function which will then
+               ; process the expression.  It is applied recursively to the
+               ; expression and each sub-expression.  It must be defined as
+               ; (lambda (rtx-obj expr mode estate) ...).
+               ; If the result of EXPR-FN is a lambda, it is applied to
+               ; (cons ESTATE (cdr EXPR)).  ESTATE is prepended to the
+               ; arguments.
+               ; For syntax expressions if the result of EXPR-FN is #f,
+               ; the operands are processed using the builtin evaluator.
+               ; FIXME: This special handling of syntax expressions is
+               ; not currently done.
+               ; So to repeat: EXPR-FN can process the expression, and if its
+               ; result is a lambda then it also processes the expression.
+               ; The arguments to EXPR-FN are
+               ; (rtx-obj expr mode estate).
+               ; The arguments to the result of EXPR-FN are
+               ; (cons ESTATE (cdr EXPR)).
+               ; The reason for the duality is mostly history.
+               ; In time things should be simplified.
+               (expr-fn . #f)
+
+               ; Current environment.  This is a stack of sequence locals.
+               (env . ())
+
+               ; Current evaluation depth.  This is used, for example, to
+               ; control indentation in generated output.
+               (depth . 0)
+
+               ; Associative list of modifiers.
+               ; This is here to support things like `delay'.
+               (modifiers . ())
+               )
+             nil)
+)
+
+; Create an <eval-state> object using a list of keyword/value elements.
+; ARGS is a list of #:keyword/value elements.
+; The result is a list of the unrecognized elements.
+; Subclasses should override this method and send-next it first, then
+; see if they recognize anything in the result, returning what isn't
+; recognized.
+
+(method-make!
+ <eval-state> 'vmake!
+ (lambda (self args)
+   (let loop ((args args) (unrecognized nil))
+     (if (null? args)
+        (reverse! unrecognized) ; ??? Could invoke method to initialize here.
+        (begin
+          (case (car args)
+            ((#:context)
+             (elm-set! self 'context (cadr args)))
+            ((#:owner)
+             (elm-set! self 'owner (cadr args)))
+            ((#:expr-fn)
+             (elm-set! self 'expr-fn (cadr args)))
+            ((#:env)
+             (elm-set! self 'env (cadr args)))
+            ((#:depth)
+             (elm-set! self 'depth (cadr args)))
+            ((#:modifiers)
+             (elm-set! self 'modifiers (cadr args)))
+            (else
+             ; Build in reverse order, as we reverse it back when we're done.
+             (set! unrecognized
+                   (cons (cadr args) (cons (car args) unrecognized)))))
+          (loop (cddr args) unrecognized)))))
+)
+
+; Accessors.
+
+(define-getters <eval-state> estate
+  (context owner expr-fn env depth modifiers)
+)
+(define-setters <eval-state> estate
+  (context owner expr-fn env depth modifiers)
+)
+
+; Build an estate for use in producing a value from rtl.
+; CONTEXT is a <context> object or #f if there is none.
+; OWNER is the owner of the expression or #f if there is none.
+
+(define (estate-make-for-eval context owner)
+  (vmake <eval-state>
+        #:context context
+        #:owner owner
+        #:expr-fn (lambda (rtx-obj expr mode estate)
+                    (rtx-evaluator rtx-obj)))
+)
+
+; Create a copy of ESTATE.
+
+(define (estate-copy estate)
+  (object-copy-top estate)
+)
+
+; Create a copy of STATE with a new environment ENV.
+
+(define (estate-new-env state env)
+  (let ((result (estate-copy state)))
+    (estate-set-env! result env)
+    result)
+)
+
+; Create a copy of STATE with environment ENV pushed onto the existing
+; environment list.
+; There's no routine to pop the environment list as there's no current
+; need for it: we make a copy of the state when we push.
+
+(define (estate-push-env state env)
+  (let ((result (estate-copy state)))
+    (estate-set-env! result (cons env (estate-env result)))
+    result)
+)
+
+; Create a copy of STATE with modifiers MODS.
+
+(define (estate-with-modifiers state mods)
+  (let ((result (estate-copy state)))
+    (estate-set-modifiers! result (append mods (estate-modifiers result)))
+    result)
+)
+
+; Convert a tstate to an estate.
+
+(define (tstate->estate t)
+  (vmake <eval-state>
+        #:context (tstate-context t)
+        #:env (tstate-env t))
+)
+\f
+; RTL expression evaluation.
+;
+; ??? These used eval2 at one point.  Not sure which is faster but I suspect
+; eval2 is by far.  On the otherhand this has yet to be compiled.  And this way
+; is more portable, more flexible, and works with guile 1.2 (which has
+; problems with eval'ing self referential vectors, though that's one reason to
+; use smobs).
+
+; Set to #t to debug rtx evaluation.
+
+(define -rtx-eval-debug? #f)
+
+; RTX expression evaluator.
+;
+; EXPR is the expression to be eval'd.  It must be in compiled form.
+; MODE is the mode of EXPR, a <mode> object or its name.
+; ESTATE is the current evaluation state.
+
+(define (rtx-eval-with-estate expr mode estate)
+  (if -rtx-eval-debug?
+      (begin
+       (display "Traversing ")
+       (display expr)
+       (newline)
+       (rtx-env-dump (estate-env estate))
+       ))
+
+  (if (pair? expr) ; pair? -> cheap non-null-list?
+
+      (let* ((rtx-obj (rtx-lookup (car expr)))
+            (fn ((estate-expr-fn estate) rtx-obj expr mode estate)))
+       (if fn
+           (if (procedure? fn)
+               (apply fn (cons estate (cdr expr)))
+;              ; Don't eval operands for syntax expressions.
+;              (if (rtx-style-syntax? rtx-obj)
+;                  (apply fn (cons estate (cdr expr)))
+;                  (let ((operands
+;                         (-rtx-eval-operands rtx-obj expr estate)))
+;                    (apply fn (cons estate operands))))
+               fn)
+           ; Leave expr unchanged.
+           expr))
+;          (let ((operands
+;                 (-rtx-traverse-operands rtx-obj expr estate)))
+;            (cons rtx-obj operands))))
+
+      ; EXPR is not a list
+      (error "argument to rtx-eval-with-estate is not a list" expr))
+)
+
+; Evaluate rtx expression EXPR and return the computed value.
+; EXPR must already be in compiled form (the result of rtx-compile).
+; OWNER is the owner of the value, used for attribute computation,
+; or #f if there isn't one.
+; FIXME: context?
+
+(define (rtx-value expr owner)
+  (rtx-eval-with-estate expr 'DFLT (estate-make-for-eval #f owner))
+)
+\f
+; Instruction field support.
+
+; Return list of ifield names refered to in EXPR.
+; Assumes EXPR is more than just (ifield x).
+
+(define (rtl-find-ifields expr)
+  (let ((ifields nil))
+    (letrec ((scan! (lambda (arg-list)
+                     (for-each (lambda (arg)
+                                 (if (pair? arg)
+                                     (if (eq? (car arg) 'ifield)
+                                         (set! ifields
+                                               (cons (rtx-ifield-name arg)
+                                                     ifields))
+                                         (scan! (cdr arg)))))
+                               arg-list))))
+      (scan! (cdr expr))
+      (nub ifields identity)))
+)
+\f
+; Hardware rtx handlers.
+
+; Subroutine of hw to compute the object's name.
+; The name of the operand must include the index so that multiple copies
+; of a hardware object (e.g. h-gr[0], h-gr[14]) can be distinguished.
+; We make some attempt to make the name pretty as it appears in generated
+; files.
+
+(define (-rtx-hw-name hw hw-name index-arg)
+  (cond ((hw-scalar? hw)
+        hw-name)
+       ((rtx? index-arg)
+        (symbol-append hw-name '- (rtx-pretty-name index-arg)))
+       (else
+        (symbol-append hw-name ; (obj:name (op:type self))
+                       '-
+                       ; (obj:name (op:index self)))))
+                       (stringize index-arg "-"))))
+)
+
+; Return the <operand> object described by
+; HW-NAME/MODE-NAME/SELECTOR/INDEX-ARG.
+;
+; HW-NAME is the name of the hardware element.
+; INDEX-ARG is an rtx or number of the index.
+; In the case of scalar hardware elements, pass 0 for INDEX-ARG.
+; MODE-NAME is the name of the mode.
+; In the case of a vector of registers, INDEX-ARG is the vector index.
+; In the case of a scalar register, the value is ignored, but pass 0 (??? #f?).
+; SELECTOR is an rtx or number and is passed to HW-NAME to allow selection of a
+; particular variant of the hardware.  It's kind of like an INDEX, but along
+; an atypical axis.  An example is memory ASI's on Sparc.  Pass
+; hw-selector-default if there is no selector.
+; ESTATE is the current rtx evaluation state.
+;
+; e.g. (hw estate WI h-gr #f (const INT 14))
+; selects register 14 of the h-gr set of registers.
+;
+; *** The index is passed unevaluated because for parallel execution support
+; *** a variable is created with a name based on the hardware element and
+; *** index, and we want a reasonably simple and stable name.  We get this by
+; *** stringize-ing it.
+; *** ??? Though this needs to be redone anyway.
+;
+; ??? The specified hardware element must be either a scalar or a vector.
+; Maybe in the future allow arrays although there's significant utility in
+; allowing only at most a scalar index.
+
+(define (hw estate mode-name hw-name index-arg selector)
+  ; Enforce some rules to keep things in line with the current design.
+  (if (not (symbol? mode-name))
+      (parse-error "hw" "invalid mode name" mode-name))
+  (if (not (symbol? hw-name))
+      (parse-error "hw" "invalid hw name" hw-name))
+  (if (not (or (number? index-arg)
+              (rtx? index-arg)))
+      (parse-error "hw" "invalid index" index-arg))
+  (if (not (or (number? selector)
+              (rtx? selector)))
+      (parse-error "hw" "invalid selector" selector))
+
+  (let ((hw (current-hw-sem-lookup-1 hw-name)))
+    (if (not hw)
+       (parse-error "hw" "invalid hardware element" hw-name))
+
+    (let ((mode (if (eq? mode-name 'DFLT) (hw-mode hw) (mode:lookup mode-name)))
+         (result (new <operand>))) ; ??? lookup-for-new?
+
+      (if (not mode)
+         (parse-error "hw" "invalid mode" mode-name))
+
+      ; Record the selector.
+      (elm-xset! result 'selector selector)
+
+      ; Create the index object.
+      (elm-xset! result 'index
+                (cond ((number? index-arg)
+                       (make <hw-index> 'anonymous 'constant UINT index-arg))
+                      ((rtx? index-arg)
+                       ; For the simulator the following could be done which
+                       ; would save having to create a closure.
+                       ; ??? Old code, left in for now.
+                       ; (rtx-get estate DFLT
+                       ;          (rtx-eval (estate-context estate)
+                       ;                    (estate-econfig estate)
+                       ;                    index-arg rtx-evaluator))
+                       ; Make sure constant indices are recorded as such.
+                       (if (rtx-constant? index-arg)
+                           (make <hw-index> 'anonymous 'constant UINT
+                                 (rtx-constant-value index-arg))
+                           (make <hw-index> 'anonymous 'rtx DFLT
+                                 (-rtx-closure-make estate index-arg))))
+                      (else (parse-error "hw" "invalid index" index-arg))))
+
+      (if (not (hw-mode-ok? hw (obj:name mode) (elm-xget result 'index)))
+         (parse-error "hw" "invalid mode for hardware" mode-name))
+
+      (elm-xset! result 'type hw)
+      (elm-xset! result 'mode mode)
+
+      ; The name of the operand must include the index so that multiple copies
+      ; of a hardware object (e.g. h-gr[0], h-gr[14]) can be distinguished.
+      (let ((name (-rtx-hw-name hw hw-name index-arg)))
+       (send result 'set-name! name)
+       (op:set-sem-name! result name))
+
+      ; Empty comment and attribute.
+      ; ??? Stick the arguments in the comment for debugging purposes?
+      (send result 'set-comment! "")
+      (send result 'set-atlist! atlist-empty)
+
+      result))
+)
+
+; This is shorthand for (hw estate mode hw-name regno selector).
+; ESTATE is the current rtx evaluation state.
+; INDX-SEL is an optional register number and possible selector.
+; The register number, if present, is (car indx-sel) and must be a number or
+; unevaluated RTX expression.
+; The selector, if present, is (cadr indx-sel) and must be a number or
+; unevaluated RTX expression.
+; ??? A register selector isn't supported yet.  It's just an idea that's
+; been put down on paper for future reference.
+
+(define (reg estate mode hw-name . indx-sel)
+  (s-hw estate mode hw-name
+       (if (pair? indx-sel) (car indx-sel) 0)
+       (if (and (pair? indx-sel) (pair? (cdr indx-sel)))
+           (cadr indx-sel)
+           hw-selector-default))
+)
+
+; This is shorthand for (hw estate mode h-memory addr selector).
+; ADDR must be an unevaluated RTX expression.
+; If present (car sel) must be a number or unevaluated RTX expression.
+
+(define (mem estate mode addr . sel)
+  (s-hw estate mode 'h-memory addr
+       (if (pair? sel) (car sel) hw-selector-default))
+)
+
+; For the rtx nodes to use.
+
+(define s-hw hw)
+
+; The program counter.
+; When this code is loaded, global `pc' is nil, it hasn't been set to the
+; pc operand yet (see operand-init!).  We can't use `pc' inside the drn as the
+; value is itself.  So we use s-pc.  rtl-finish! must be called after
+; operand-init!.
+
+(define s-pc pc)
+\f
+; Conditional execution.
+
+; `if' in RTL has a result, like ?: in C.
+; We support both: one with a result (non VOID mode), and one without (VOID mode).
+; The non-VOID case must have an else part.
+; MODE is the mode of the result, not the comparison.
+; The comparison is expected to return a zero/non-zero value.
+; ??? Perhaps this should be a syntax-expr.  Later.
+
+(define (e-if estate mode cond then . else)
+  (if (> (length else) 1)
+      (error "if: too many elements in `else' part" else))
+  (if (null? else)
+      (if cond then)
+      (if cond then (car else)))
+)
+\f
+; Subroutines.
+; ??? Not sure this should live here.
+
+(define (-subr-read errtxt . arg-list)
+  #f
+)
+
+(define define-subr
+  (lambda arg-list
+    (let ((s (apply -subr-read (cons "define-subr" arg-list))))
+      (if s
+         (current-subr-add! s))
+      s))
+)
+\f
+; Misc. utilities.
+
+; The argument to drn,drmn,drsn must be Scheme code (or a fixed subset
+; thereof).  .str/.sym are used in pmacros so it makes sense to include them
+; in the subset.
+(define .str string-append)
+(define .sym symbol-append)
+
+; Given (expr1 expr2 expr3 expr4), for example,
+; return (fn (fn (fn expr1 expr2) expr3) expr4).
+
+(define (rtx-combine fn exprs)
+  (assert (not (null? exprs)))
+  (letrec ((-rtx-combine (lambda (fn exprs result)
+                          (if (null? exprs)
+                              result
+                              (-rtx-combine fn
+                                            (cdr exprs)
+                                            (rtx-make fn
+                                                      result
+                                                      (car exprs)))))))
+    (-rtx-combine fn (cdr exprs) (car exprs)))
+)
+\f
+; Called before a .cpu file is read in.
+
+(define (rtl-init!)
+  (set! -rtx-func-table (make-hash-table 127))
+  (set! -rtx-macro-table (make-hash-table 127))
+  (set! -rtx-num-next 0)
+  (def-rtx-funcs)
+  (reader-add-command! 'define-subr
+                      "\
+Define an rtx subroutine, name/value pair list version.
+"
+                      nil 'arg-list define-subr)
+  *UNSPECIFIED*
+)
+
+; Install builtins
+
+(define (rtl-builtin!)
+  *UNSPECIFIED*
+)
+
+; Called after cpu files are loaded to add misc. remaining entries to the
+; rtx handler table for use during evaluation.
+; rtl-finish! must be done before ifmt-compute!, the latter will
+; construct hardware objects which is done by rtx evaluation.
+
+(define (rtl-finish!)
+  (logit 2 "Building rtx operand table ...\n")
+
+  ; Update s-pc, must be called after operand-init!.
+  (set! s-pc pc)
+
+  ; Table of traversers for the various rtx elements.
+  (let ((hash-table (-rtx-make-traverser-table)))
+    (set! -rtx-traverser-table (make-vector (rtx-max-num) #f))
+    (for-each (lambda (rtx-name)
+               (let ((rtx (rtx-lookup rtx-name)))
+                 (if rtx
+                     (vector-set! -rtx-traverser-table (rtx-num rtx)
+                                  (map1-improper
+                                   (lambda (arg-type)
+                                     (cons arg-type
+                                           (hashq-ref hash-table arg-type)))
+                                   (rtx-arg-types rtx))))))
+             (rtx-name-list)))
+
+  ; Initialize the operand hash table.
+  (set! -rtx-operand-table (make-hash-table 127))
+
+  ; Add the operands to the eval symbol table.
+  (for-each (lambda (op)
+             (hashq-set! -rtx-operand-table (obj:name op) op)
+             )
+           (current-op-list))
+
+  ; Add ifields to the eval symbol table.
+  (for-each (lambda (f)
+             (hashq-set! -rtx-operand-table (obj:name f) f)
+             )
+           (non-derived-ifields (current-ifld-list)))
+
+  *UNSPECIFIED*
+)
diff --git a/cgen/rtx-funcs.scm b/cgen/rtx-funcs.scm
new file mode 100644 (file)
index 0000000..47bd058
--- /dev/null
@@ -0,0 +1,1002 @@
+; Standard RTL functions.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; THIS FILE CONTAINS ONE BIG FUNCTION: def-rtx-funcs.
+;
+; It is ok for this file to use procs "internal" to rtl.scm.
+;
+; Each rtx functions has two leading operands: &options, &mode;
+; though `&mode' may be spelled differently.
+; The "&" prefix is to indicate that the parsing of these operands is handled
+; differently.  They are optional and are written with leading colons
+; (e.g. :SI).  The leading ":" is to help the parser - all leading optional
+; operands begin with ":".  The order of the arguments is &options then &mode
+; though there is no imposed order in written RTL.
+
+(define (def-rtx-funcs)
+
+; Do not change the indentation here.
+(let
+(
+ ; These are defined in rtl.scm.
+ (drn define-rtx-node)
+ (drsn define-rtx-syntax-node)
+ (dron define-rtx-operand-node)
+ (drmn define-rtx-macro-node)
+)
+
+; The reason for the odd indenting above is so that emacs begins indenting the
+; following code at column 1.
+\f
+; Error reporting.
+; MODE is present for use in situations like non-VOID mode cond's.
+
+(drn (error &options &mode message)
+     (OPTIONS ANYMODE STRING) (NA NA NA)
+     MISC
+     (context-error (estate-context *estate*) message)
+)
+
+; Enums
+; Default mode is INT.
+
+(drn (enum &options &mode enum-name)
+     (OPTIONS NUMMODE SYMBOL) (NA NA NA)
+     ARG
+     ; When computing a value, return the enum's value.
+     (enum-lookup-val enum-name)
+)
+
+; Instruction fields
+; These are used in the encode/decode specs of other ifields as well as in
+; instruction semantics.
+; Ifields are normally specified by name, but they are subsequently wrapped
+; in this.
+
+(dron (ifield &options &mode ifld-name)
+      (OPTIONS DFLTMODE SYMBOL) (NA NA NA)
+      ARG
+      (let ((f (current-ifld-lookup ifld-name)))
+       (make <operand> ifld-name (string-append ifld-name " used as operand")
+             (atlist-cons (bool-attr-make 'SEM-ONLY #t)
+                          (obj-atlist f))
+             (obj:name (ifld-hw-type f))
+             (obj:name (ifld-mode f))
+             (make <hw-index> 'anonymous 'ifield (ifld-mode f) f)
+             nil #f #f))
+)
+
+; Specify an operand.
+; Operands are normally specified by name, but they are subsequently wrapped
+; in this.
+
+(dron (operand &options &mode op-name)
+      (OPTIONS DFLTMODE SYMBOL) (NA NA NA)
+      ARG
+      (current-op-lookup op-name)
+)
+
+; Operand naming/numbering.
+; Operands are given names so that the operands as used in the semantics can
+; be matched with arguments of function units.  With good name choices of
+; operands and function unit arguments, this is rarely necessary, but
+; sometimes it is.
+;
+; ??? This obfuscates the semantic code a fair bit.  Another way to do this
+; would be to add new elements to <insn> to specify operands outside of
+; the semantic code.  E.g.
+; (define-insn ...
+;   (inputs (in-gr1 src1) (in-gr2 src2))
+;   (outputs (out-pc pc) (out-gr dr) (reg-14 (reg WI h-gr 14)))
+;   ...)
+; The intent here is to continue to allow the semantic code to use names
+; of operands, and not overly complicate the input/output description.
+;
+; In instructions, operand numbers are recorded as well, to implement
+; profiling and result writeback of parallel insns.
+
+; Rename operand VALUE to NEW-NAME.
+; VALUE is an expression whose result is an object of type <operand>.
+; It can be the name of an existing operand.
+; ??? Might also support numbering by allowing NEW-NAME to be a number.
+
+(drsn (name &options &mode new-name value)
+      (OPTIONS DFLTMODE SYMBOL RTX) (NA NA NA ANY)
+      ARG
+      (let ((result (object-copy (rtx-get 'DFLT value))))
+       (op:set-sem-name! result new-name)
+       result)
+)
+
+; Operands are generally compiled to an internal form first.
+; There is a fair bit of state associated with them, and it's easier to
+; work with an object than source [which might get fairly complicated if
+; it expresses all the state].
+; Compiled operands are wrapped in this so that they still look like rtx.
+
+(dron (xop &options &mode object)
+      (OPTIONS DFLTMODE OBJECT) (NA NA NA)
+      ARG
+      object
+)
+
+;(dron (opspec: &options &mode op-name op-num hw-ref attrs)
+;      (OPTIONS ANYMODE SYMBOL NUMBER RTX ATTRS) (NA NA NA NA ANY NA)
+;      ARG
+;      (let ((opval (rtx-eval-with-estate hw-ref mode *estate*)))
+;      (assert (operand? opval))
+;      ; Set the specified mode, ensuring it's ok.
+;      ; This also makes a copy as we don't want to modify predefined
+;      ; operands.
+;      (let ((operand (op:new-mode opval mode)))
+;        (op:set-sem-name! operand op-name)
+;        (op:set-num! operand op-num)
+;        (op:set-cond?! operand (attr-value attrs 'COND-REF #f))
+;        operand))
+;)
+
+; Specify a reference to a local variable.
+; Local variables are normally specified by name, but they are subsequently
+; wrapped in this.
+
+(dron (local &options &mode local-name)
+      (OPTIONS DFLTMODE SYMBOL) (NA NA NA)
+      ARG
+      (rtx-temp-lookup (tstate-env *tstate*) local-name)
+)
+
+; FIXME: This doesn't work.  See s-operand.
+;(define (s-dup estate op-name)
+;  (if (not (insn? (estate-owner estate)))
+;      (error "dup: not processing an insn"))
+;  (vector-ref (insn:operands (current-current-context))
+;             (op:lookup-num (insn:operands (estate-owner estate)) op-name))
+;)
+;
+; ??? Since operands are given names and not numbers this isn't currently used.
+;
+;(drsn (dup &options &mode op-name)
+;     (OPTIONS DFLTMODE SYMBOL) (NA NA NA)
+;     ;(s-dup *estate* op-name)
+;     (begin
+;       (if (not (insn? (estate-owner *estate*)))
+;         (error "dup: not processing an insn"))
+;       (vector-ref (insn:operands (estate-owner *estate*))
+;                 (op:lookup-num (insn:operands (estate-owner *estate*)) op-name)))
+;     #f
+;)
+
+; Returns non-zero if operand NAME was referenced (read if input operand
+; and written if output operand).
+; ??? What about input/output operands.
+
+(drsn (ref &options &mode name)
+      (OPTIONS DFLTMODE SYMBOL) (NA NA NA)
+      ARG
+      #f
+)
+
+; Return the index of an operand.
+; For registers this is the register number.
+; ??? Mode handling incomplete.
+
+(dron (index-of &options &mode op-rtx)
+      (OPTIONS DFLTMODE RTX) (NA NA ANY)
+      ARG
+      (let* ((operand (rtx-eval-with-estate op-rtx 'DFLT *estate*))
+            (f (hw-index:value (op:index operand)))
+            (f-name (obj:name f)))
+       (make <operand> f-name f-name
+             (atlist-cons (bool-attr-make 'SEM-ONLY #t)
+                          (obj-atlist f))
+             (obj:name (ifld-hw-type f))
+             (obj:name (ifld-mode f))
+             (make <hw-index> 'anonymous
+                   'ifield
+                   (ifld-mode f)
+                   ; (send (op:type op) 'get-index-mode)
+                   f)
+             nil #f #f))
+)
+
+; Same as index-of, but improves readability for registers.
+
+(drmn (regno reg)
+      (list 'index-of reg)
+)
+\f
+; Hardware elements.
+
+; Describe a random hardware object.
+; If INDX is missing, assume the element is a scalar.  We pass 0 so s-hw
+; doesn't have to unpack the list that would be passed if it were defined as
+; (hw mode hw-name . indx).  This is an internal implementation detail
+; and thus harmless to the description language.
+; These are implemented as syntax nodes as we must pass INDX to `s-hw'
+; unevaluated.
+; ??? Not currently supported.  Not sure whether it should be.
+;(drsn (hw &options &mode hw-elm . indx-sel)
+;      (OPTIONS ANYMODE SYMBOL . RTX) (NA NA NA . INT)
+;      ARG
+;      (let ((indx (if (pair? indx-sel) (car indx-sel) 0))
+;            (selector (if (and (pair? indx-sel) (pair? (cdr indx-sel)))
+;                          (cadr indx-sel)
+;                          hw-selector-default))))
+;      (s-hw *estate* mode hw-elm indx selector)
+;)
+
+; Register accesses.
+; INDX-SEL is an optional index and possible selector.
+(dron (reg &options &mode hw-elm . indx-sel)
+      (OPTIONS ANYMODE SYMBOL . RTX) (NA NA NA . INT)
+      ARG
+      (let ((indx (if (pair? indx-sel) (car indx-sel) 0))
+           (selector (if (and (pair? indx-sel) (pair? (cdr indx-sel)))
+                         (cadr indx-sel)
+                         hw-selector-default)))
+       (s-hw *estate* mode hw-elm indx selector))          
+)
+
+; A raw-reg bypasses the getter/setter stuff.  It's usually used in
+; getter/setter definitions.
+
+(dron (raw-reg &options &mode hw-elm . indx-sel)
+      (OPTIONS ANYMODE SYMBOL . RTX) (NA NA NA . INT)
+      ARG
+      (let ((indx (if (pair? indx-sel) (car indx-sel) 0))
+           (selector (if (and (pair? indx-sel) (pair? (cdr indx-sel)))
+                         (cadr indx-sel)
+                         hw-selector-default)))
+       (let ((result (s-hw *estate* mode hw-elm indx selector)))
+         (obj-cons-attr! result (bool-attr-make 'RAW #t))
+         result))
+)
+
+; Memory accesses.
+(dron (mem &options &mode addr . sel)
+      (OPTIONS EXPLNUMMODE RTX . RTX) (NA NA AI . INT)
+      ARG
+      (s-hw *estate* mode 'h-memory addr
+           (if (pair? sel) (car sel) hw-selector-default))
+)
+\f
+; Instruction execution support.
+; There are no jumps, per se.  A jump is a set of `pc'.
+
+; The program counter.
+; ??? Hmmm... needed?  The pc is usually specified as `pc' which is shorthand
+; for (operand pc).
+(dron (pc) () () ARG s-pc)
+
+; Fetch bytes from the instruction stream of size MODE.
+; FIXME: Later need to augment this by passing an indicator to the mem-fetch
+; routines that we're doing an ifetch.
+; ??? wip!
+
+(drmn (ifetch mode pc)
+      (list 'mem mode pc) ; hw-selector-ispace
+)
+
+; NUM is the instruction number.  Generally it is zero but if more than one
+; insn is decoded at a time, it is non-zero.  This is used, for example, to
+; index into the scache [as an offset from the first insn].
+; ??? wip!
+
+(drmn (decode mode pc insn num)
+      (list 'c-call mode 'EXTRACT pc insn num)
+)
+
+; NUM is the same number passed to `decode'.
+; ??? wip!
+
+(drmn (execute mode num)
+      (list 'c-call mode 'EXECUTE num)
+)
+\f
+; Control Transfer Instructions
+
+; Sets of pc are handled like other sets so there are no branch rtx's.
+
+; Indicate there are N delay slots in the processing of RTX.
+; N is a `const' node.
+; ??? wip!
+
+(drn (delay &options &mode n rtx)
+     (OPTIONS DFLTMODE RTX RTX) (NA NA INT ANY)
+     MISC
+     #f ; (s-sequence *estate* VOID '() rtx) ; wip!
+)
+
+; Annul the following insn if YES? is non-zero.
+; PC is the address of the annuling insn.
+; The target is required to define SEM_ANNUL_INSN.
+; ??? wip!
+
+(drmn (annul yes?)
+      ; The pc reference here is hidden in c-code to not generate a spurious
+      ; pc input operand.
+      (list 'c-call 'VOID "SEM_ANNUL_INSN" (list 'c-code 'AI "pc") yes?)
+)
+
+; Skip the following insn if YES? is non-zero.
+; The target is required to define SEM_SKIP_INSN.
+; ??? This is similar to annul.  Deletion of one of them defered.
+; ??? wip!
+
+(drn (skip &options &mode yes?)
+     (OPTIONS DFLTMODE RTX) (NA NA INT)
+     MISC
+     #f
+)
+\f
+; Attribute support.
+
+; Return a boolean indicating if attribute named ATTR is VALUE in OWNER.
+; If VALUE is a list, return "true" if ATTR is any of the listed values.
+; ??? Don't yet support !VALUE.
+; OWNER is the result of either (current-insn) or (current-mach)
+; [note that canonicalization will turn them into
+; (current-{insn,mach} () DFLT)].
+; The result is always of mode INT.
+; FIXME: wip
+;
+; This is a syntax node so the args are not pre-evaluated.
+; We just want the symbols.
+; FIXME: Hmmm... it currently isn't a syntax node.
+
+(drn (eq-attr &options &mode owner attr value)
+      (OPTIONS DFLTMODE RTX SYMBOL SYMORNUM) (NA NA ANY NA NA)
+      MISC
+      (let ((atval (if owner
+                      (obj-attr-value owner attr)
+                      (attr-lookup-default attr #f))))
+       (if (list? value)
+           (->bool (memq atval value))
+           (eq? atval value)))
+)
+
+; Get the value of attribute ATTR-NAME.
+; OBJ is the result of either (current-insn) or (current-mach)
+; [note that canonicalization will turn them into
+; (current-{insn,mach} () DFLT)].
+; FIXME:wip
+
+(drn (attr &options &mode obj attr-name)
+     (OPTIONS DFLTMODE RTX SYMBOL) (NA NA NA NA)
+     MISC
+     #f
+)
+
+; Same as `quote', for use in attributes cus "quote" sounds too jargonish.
+; [Ok, not a strong argument for using "symbol", but so what?]
+
+(drsn (symbol &options &mode name)
+      (OPTIONS DFLTMODE SYMBOL) (NA NA NA)
+      ARG
+      name
+)
+
+; Return the current instruction.
+
+(drn (current-insn &options &mode)
+     (OPTIONS DFLTMODE) (NA NA)
+     MISC
+     (let ((obj (estate-owner *estate*)))
+       (if (not (insn? obj))
+          (error "current context not an insn"))
+       obj)
+)
+
+; Return the currently selected machine.
+; This can either be a compile-time or run-time value.
+
+(drn (current-mach &options &mode)
+     (OPTIONS DFLTMODE) (NA NA)
+     MISC
+     -rtx-current-mach
+)
+\f
+; Constants.
+
+; FIXME: Need to consider 64 bit hosts.
+(drn (const &options &mode c)
+     (OPTIONS NUMMODE NUMBER) (NA NA NA)
+     ARG
+     ; When computing a value, just return the constant unchanged.
+     c
+)
+\f
+; Large mode support.
+
+; Combine smaller modes into a larger one.
+; Arguments are specified most significant to least significant.
+; ??? May also want an endian dependent argument order.  That can be
+; implemented on top of or beside this.
+; ??? Not all of the combinations are supported in the simulator.
+; They'll get added as necessary.
+(drn (join &options &out-mode in-mode arg1 . arg-rest)
+     (OPTIONS NUMMODE NUMMODE RTX . RTX) (NA NA NA ANY . ANY)
+     MISC
+     ; FIXME: Ensure correct number of args for in/out modes.
+     ; FIXME: Ensure compatible modes.
+     #f
+)
+
+; GCC's subreg.
+; Called subword 'cus it's not exactly subreg.
+; Word numbering is from most signficant (word 0) to least (word N-1).
+; ??? May also want an endian dependent word ordering.  That can be
+; implemented on top of or beside this.
+; ??? GCC plans to switch to SUBREG_BYTE.  Keep an eye out for the switch
+; (which is extensive so probably won't happen anytime soon).
+
+(drn (subword &options &mode value word-num)
+     (OPTIONS NUMMODE RTX RTX) (NA NA OP0 INT)
+     ARG
+     #f
+)
+
+; ??? The split and concat stuff is just an experiment and should not be used.
+; What's there now is just "thoughts put down on paper."
+
+(drmn (split split-mode in-mode di)
+      ; FIXME: Ensure compatible modes
+      ;(list 'c-raw-call 'BLK (string-append "SPLIT" in-mode split-mode) di)
+      '(const 0)
+)
+
+(drmn (concat modes arg1 . arg-rest)
+      ; FIXME: Here might be the place to ensure
+      ; (= (length modes) (length (cons arg1 arg-rest))).
+      ;(cons 'c-raw-call (cons modes (cons "CONCAT" (cons arg1 arg-rest))))
+      '(const 0)
+)
+\f
+; Support for explicit C code.
+; ??? GCC RTL calls this "unspec" which is arguably a more application
+; independent name.
+
+(drn (c-code &options &mode text)
+     (OPTIONS ANYMODE STRING) (NA NA NA)
+     UNSPEC
+     #f
+)
+
+; Invoke C functions passing them arguments from the semantic code.
+; The arguments are passed as is, no conversion is done here.
+; Usage is:
+;           (c-call mode name arg1 arg2 ...)
+; which is converted into a C function call:
+;           name (current_cpu, arg1, arg2, ...)
+; Mode is the mode of the result.
+; If it is VOID this call is a statement and ';' is appended.
+; Otherwise it is part of an expression.
+
+(drn (c-call &options &mode name . args)
+     (OPTIONS ANYMODE STRING . RTX) (NA NA NA . ANY)
+     UNSPEC
+     #f
+)
+
+; Same as c-call but without implicit first arg of `current_cpu'.
+
+(drn (c-raw-call &options &mode name . args)
+     (OPTIONS ANYMODE STRING . RTX) (NA NA NA . ANY)
+     UNSPEC
+     #f
+)
+\f
+; Set/get/miscellaneous
+
+(drn (nop &options &mode)
+     (OPTIONS VOIDFLTODE) (NA NA)
+     MISC
+     #f
+)
+
+; Clobber - mark an object as modified without explaining why or how.
+
+(drn (clobber &options &mode object)
+     (OPTIONS ANYMODE RTX) (NA NA OP0)
+     MISC
+     #f
+)
+
+; The `set' rtx.
+; MODE is the mode of DST.  If DFLT, use DST's default mode.
+; The mode of the result is always VOID.
+;
+; ??? It might be more consistent to rename set -> set-trace, but that's
+; too wordy.  The `set' rtx is the normal one and we want the normal one to
+; be the verbose one (prints result tracing messages).  `set-quiet' is the
+; atypical one, it doesn't print tracing messages.  It may also turn out that
+; a different mechanism (rather than the name "set-quiet") is used some day.
+; One way would be to record the "quietness" state with the traversal state and
+; use something like (with-quiet (set foo bar)) akin to with-output-to-string
+; in Guile.
+;
+; i.e. set -> gen-set-trace
+;      set-quiet -> gen-set-quiet
+;
+; ??? One might want a `!' suffix as in `set!', but methinks that's following
+; Scheme too closely.
+
+(drn (set &options &mode dst src)
+     (OPTIONS ANYMODE SETRTX RTX) (NA NA OP0 MATCH1)
+     SET
+     #f
+)
+
+(drn (set-quiet &options &mode dst src)
+     (OPTIONS ANYMODE SETRTX RTX) (NA NA OP0 MATCH1)
+     SET
+     #f
+)
+\f
+; Standard arithmetic operations.
+
+; It's nice emitting macro calls to the actual C operation in that the RTX
+; expression is preserved, albeit in C.  On the one hand it's one extra thing
+; the programmer has to know when looking at the code.  But on the other it's
+; trivial stuff, and having a layer between RTX and C allows the
+; macros/functions to be modified to handle unexpected situations.
+; 
+; We do emit C directly for cases other than cpu semantics
+; (e.g. the assembler).
+;
+; The language is defined such that we assume ANSI C semantics while avoiding
+; implementation defined areas, with as few exceptions as possible.
+;
+; Current exceptions:
+; - signed shift right assumes the sign bit is replicated.
+;
+; Additional notes [perhaps repeating what's in ANSI C for emphasis]:
+; - callers of division and modulus fns must test for 0 beforehand
+;   if necessary
+; - division and modulus fns have unspecified behavior for negative args
+;   [yes I know the C standard says implementation defined, here its
+;   unspecified]
+; - later add versions of div/mod that have an explicit behaviour for -ve args
+; - signedness is part of the rtx operation name, and is not determined
+;   from the arguments [elsewhere is a description of the tradeoffs]
+; - ???
+
+(drn (neg &options &mode s1)
+     (OPTIONS ANYMODE RTX) (NA NA OP0)
+     UNARY
+     #f
+)
+
+(drn (abs &options &mode s1)
+     (OPTIONS ANYMODE RTX) (NA NA OP0)
+     UNARY
+     #f
+)
+
+; For integer values this is a bitwise operation (each bit inverted).
+; For floating point values this produces 1/x.
+; ??? Might want different names.
+(drn (inv &options &mode s1)
+     (OPTIONS ANYMODE RTX) (NA NA OP0)
+     UNARY
+     #f
+)
+
+; This is a boolean operation.
+; MODE is the mode of S1.  The result always has mode BI.
+; ??? Perhaps `mode' shouldn't be here.
+(drn (not &options &mode s1)
+     (OPTIONS ANYMODE RTX) (NA NA OP0)
+     UNARY
+     #f
+)
+
+(drn (add &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+(drn (sub &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+
+; "OF" for "overflow flag", "CF" for "carry flag",
+; "s3" here must have type BI.
+; For the *flag rtx's, MODE is the mode of S1,S2; the result always has
+; mode BI.
+(drn (addc &options &mode s1 s2 s3)
+     (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI)
+     TRINARY
+     #f
+)
+(drn (add-cflag &options &mode s1 s2 s3) ; FIXME: rename to addc-cflag
+     (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI)
+     TRINARY
+     #f
+)
+(drn (add-oflag &options &mode s1 s2 s3) ; FIXME: rename to addc-vflag
+     (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI)
+     TRINARY
+     #f
+)
+(drn (subc &options &mode s1 s2 s3)
+     (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI)
+     TRINARY
+     #f
+)
+(drn (sub-cflag &options &mode s1 s2 s3) ; FIXME: rename to subc-cflag
+     (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI)
+     TRINARY
+     #f
+)
+(drn (sub-oflag &options &mode s1 s2 s3) ; FIXME: rename to subc-vflag
+     (OPTIONS ANYMODE RTX RTX RTX) (NA NA OP0 MATCH1 BI)
+     TRINARY
+     #f
+)
+
+; Usurp these names so that we have consistent rtl should a program generator
+; ever want to infer more about what the semantics are doing.
+; For now these are just macros that expand to real rtl to perform the
+; operation.
+
+; Return bit indicating if VALUE is zero/non-zero.
+(drmn (zflag arg1 . rest) ; mode value)
+      (if (null? rest) ; mode missing?
+         (list 'eq 'DFLT arg1 0)
+         (list 'eq arg1 (car rest) 0))
+)
+
+; Return bit indicating if VALUE is negative/non-negative.
+(drmn (nflag arg1 . rest) ; mode value)
+      (if (null? rest) ; mode missing?
+         (list 'lt 'DFLT arg1 0)
+         (list 'lt arg1 (car rest) 0))
+)
+
+; Multiply/divide.
+
+(drn (mul &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+; ??? In non-sim case, ensure s1,s2 is in right C type for right result.
+; ??? Need two variants, one that avoids implementation defined situations
+; [both host and target], and one that specifies implementation defined
+; situations [target].
+(drn (div &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+(drn (udiv &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+(drn (mod &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+(drn (umod &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+
+; wip: mixed mode mul/div
+
+; various floating point routines
+
+(drn (sqrt &options &mode s1)
+     (OPTIONS FLOATMODE RTX) (NA NA OP0)
+     UNARY
+     #f
+)
+
+(drn (cos &options &mode s1)
+     (OPTIONS FLOATMODE RTX) (NA NA OP0)
+     UNARY
+     #f
+)
+
+(drn (sin &options &mode s1)
+     (OPTIONS FLOATMODE RTX) (NA NA OP0)
+     UNARY
+     #f
+)
+
+; min/max
+
+(drn (min &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+
+(drn (max &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+
+(drn (umin &options &mode s1 s2)
+     (OPTIONS INTMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+
+(drn (umax &options &mode s1 s2)
+     (OPTIONS INTMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+
+; These are bitwise operations.
+(drn (and &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+(drn (or &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+(drn (xor &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+
+; Shift operations.
+
+(drn (sll &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 INT)
+     BINARY
+     #f
+)
+(drn (srl &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 INT)
+     BINARY
+     #f
+)
+; ??? In non-sim case, ensure s1 is in right C type for right result.
+(drn (sra &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 INT)
+     BINARY
+     #f
+)
+; Rotates don't really have a sign, so doesn't matter what we say.
+(drn (ror &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 INT)
+     BINARY
+     #f
+)
+(drn (rol &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 INT)
+     BINARY
+     #f
+)
+; ??? Will also need rotate-with-carry [duh...].
+
+; These are boolean operations (e.g. C &&, ||).
+; The result always has mode BI.
+; ??? 'twould be more Schemey to take a variable number of args.
+; ??? 'twould also simplify several .cpu description entries.
+; On the other hand, handling an arbitrary number of args isn't supported by
+; ISA's, which the main goal of what we're trying to represent.
+(drn (andif &options &mode s1 s2)
+     (OPTIONS DFLTMODE RTX RTX) (NA NA ANY ANY)
+     BINARY ; IF?
+     #f
+)
+(drn (orif &options &mode s1 s2)
+     (OPTIONS DFLTMODE RTX RTX) (NA NA ANY ANY)
+     BINARY ; IF?
+     #f
+)
+\f
+; `bitfield' is an experimental operation.
+; It's not really needed but it might help simplify some things.
+;
+;(drn (bitfield mode src start length)
+;     ...
+;     ...
+;)
+\f
+; Conversions.
+
+(drn (ext &options &mode s1)
+     (OPTIONS INTMODE RTX) (NA NA ANY)
+     UNARY
+     #f
+)
+(drn (zext &options &mode s1)
+     (OPTIONS INTMODE RTX) (NA NA ANY)
+     UNARY
+     #f
+)
+(drn (trunc &options &mode s1)
+     (OPTIONS INTMODE RTX) (NA NA ANY)
+     UNARY
+     #f
+)
+(drn (fext &options &mode s1)
+     (OPTIONS FLOATMODE RTX) (NA NA ANY)
+     UNARY
+     #f
+)
+(drn (ftrunc &options &mode s1)
+     (OPTIONS FLOATMODE RTX) (NA NA ANY)
+     UNARY
+     #f
+)
+(drn (float &options &mode s1)
+     (OPTIONS FLOATMODE RTX) (NA NA ANY)
+     UNARY
+     #f
+)
+(drn (ufloat &options &mode s1)
+     (OPTIONS FLOATMODE RTX) (NA NA ANY)
+     UNARY
+     #f
+)
+(drn (fix &options &mode s1)
+     (OPTIONS INTMODE RTX) (NA NA ANY)
+     UNARY
+     #f
+)
+(drn (ufix &options &mode s1)
+     (OPTIONS INTMODE RTX) (NA NA ANY)
+     UNARY
+     #f
+)
+\f
+; Comparisons.
+; MODE is the mode of S1,S2.  The result always has mode BI.
+
+(drn (eq &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+(drn (ne &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+; ??? In non-sim case, ensure s1,s2 is in right C type for right result.
+(drn (lt &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+(drn (le &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+(drn (gt &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+(drn (ge &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+; ??? In non-sim case, ensure s1,s2 is in right C type for right result.
+(drn (ltu &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+(drn (leu &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+(drn (gtu &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+(drn (geu &options &mode s1 s2)
+     (OPTIONS ANYMODE RTX RTX) (NA NA OP0 MATCH1)
+     BINARY
+     #f
+)
+\f
+; Set membership.
+; Useful in ifield assertions.
+
+; Return a boolean (BI mode) indicating if VALUE is in SET.
+; VALUE is any constant rtx.  SET is a `number-list' rtx.
+
+(drn (member &options &mode value set)
+     (OPTIONS DFLTMODE RTX RTX) (NA NA INT INT)
+     MISC
+     (begin
+       (if (not (rtx-constant? value))
+          (context-error (estate-context *estate*) "value is not a constant" value))
+       (if (not (rtx-kind? 'number-list set))
+          (context-error (estate-context *estate*) "set is not a `number-list' rtx" set))
+       (if (memq (rtx-constant-value value) (rtx-number-list-values set))
+          (rtx-true)
+          (rtx-false)))
+)
+
+(drn (number-list &options &mode value-list)
+     (OPTIONS INTMODE NUMBER . NUMBER) (NA NA NA . NA)
+     MISC
+     #f
+)
+\f
+; Conditional execution.
+
+; FIXME: make syntax node?
+(drn (if &options &mode cond then . else)
+     (OPTIONS ANYMODE TESTRTX RTX . RTX) (NA NA ANY OP0 . MATCH2)
+     IF
+     (apply e-if (append! (list *estate* mode cond then) else))
+)
+
+; ??? The syntax here isn't quite that of Scheme.  A condition must be
+; followed by a result expression.
+; ??? Intermediate expressions (the ones before the last one) needn't have
+; the same mode as the result.
+(drsn (cond &options &mode . cond-code-list)
+      (OPTIONS ANYMODE . CONDRTX) (NA NA . OP0)
+      COND
+      #f
+)
+
+; ??? Intermediate expressions (the ones before the last one) needn't have
+; the same mode as the result.
+(drn (case &options &mode test . case-list)
+     (OPTIONS ANYMODE RTX . CASERTX) (NA NA ANY . OP0)
+     COND
+     #f
+)
+\f
+; Parallels and Sequences
+
+; This has to be a syntax node as we don't want EXPRS to be pre-evaluated.
+; All semantic ops must have a mode, though here it must be VOID.
+; IGNORE is for consistency with sequence.  ??? Delete some day.
+; ??? There's no real need for mode either.
+
+(drsn (parallel &options &mode ignore expr . exprs)
+      (OPTIONS VOIDFLTODE LOCALS RTX . RTX) (NA NA NA VOID . VOID)
+      SEQUENCE
+      #f
+)
+
+; This has to be a syntax node to handle locals properly: they're not defined
+; yet and thus pre-evaluating the expressions doesn't work.
+; ??? This should create a closure.
+
+(drsn (sequence &options &mode locals expr . exprs)
+      (OPTIONS ANYMODE LOCALS RTX . RTX) (NA NA NA OP0 . OP0)
+      SEQUENCE
+      #f
+)
+\f
+; Internal rtx to create a closure.
+; Internal, so it does not appear in rtl.texi.
+
+(drsn (closure &options &mode expr env)
+      (OPTIONS DFLTMODE RTX ENV) (NA NA NA NA)
+      MISC
+      #f
+)
+\f
+)) ; End of def-rtx-funcs
diff --git a/cgen/sem-frags.scm b/cgen/sem-frags.scm
new file mode 100644 (file)
index 0000000..7e50bd0
--- /dev/null
@@ -0,0 +1,1236 @@
+; Semantic fragments.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; Background info:
+; Some improvement in pbb simulator efficiency is obtained in cases like
+; the ARM where for example operand2 computation is expensive in terms of
+; cpu cost, code size, and subroutine call overhead if the code is put in
+; a subroutine.  It could be inlined, but there are numerous occurences
+; resulting in poor icache usage.
+; If the computation is put in its own fragment then code size is reduced
+; [improving icache usage] and subroutine call overhead is removed in a
+; computed-goto simulator [arguments are passed in machine generated local
+; variables].
+;
+; The basic procedure here is to:
+; - break all insns up into a set of statements
+;   This is either one statement in the case of insns that don't begin with a
+;   sequence, or a list of statements, one for each element in the sequence.
+; - find a profitable set of common leading statements (called the "header")
+;   and a profitable set of common trailing statements (called the "trailer")
+;   What is "profitable" depends on
+;   - how expensive the statement is
+;   - how long the statement is
+;   - the number of insns using the statement
+;   - what fraction of the total insn the statement is
+; - rewrite insn semantics in terms of the new header and trailer fragments
+;   plus a "middle" part that is whatever is left over
+;   - there is always a header, the middle and trailer parts are optional
+;   - cti insns require a header and trailer, though they can be the same
+;     fragment
+;
+; TODO:
+; - check ARM orr insns which come out as header, tiny middle, trailer
+;   - the tiny middle seems like a waste (combine with trailer?)
+; - there are 8 trailers consisting of just `nop' for ARM
+; - rearranging statements to increase number and length of common sets
+; - combine common middle fragments
+; - parallel's not handled yet (only have to handle parallel's at the
+;   top level)
+; - insns can also be split on timing-sensitive boundaries (pipeline, memory,
+;   whatever) though that is not implemented yet.  This may involve rtl
+;   additions.
+;
+; Usage:
+; - call sim-sfrag-init! first, to initialize
+; - call sim-sfrag-analyze-insns! to create the semantic fragments
+; - afterwards, call
+;   - sim-sfrag-insn-list
+;   - sim-sfrag-frag-table
+;   - sim-sfrag-usage-table
+;   - sim-sfrag-locals-list
+\f
+; Statement computation.
+
+; Set to #t to collect various statistics.
+
+(define -stmt-stats? #f)
+
+; Collection of computed stats.  Only set if -stmt-stats? = #t.
+
+(define -stmt-stats #f)
+
+; Collection of computed statement data.  Only set if -stmt-stats? = #t.
+
+(define -stmt-stats-data #f)
+
+; Create a structure recording data of all statements.
+; A pair of (next-ordinal . table).
+
+(define (-stmt-data-make hash-size)
+  (cons 0 (make-vector hash-size nil))
+)
+
+; Accessors.
+
+(define (-stmt-data-table data) (cdr data))
+(define (-stmt-data-next-num data) (car data))
+(define (-stmt-data-set-next-num! data newval) (set-car! data newval))
+(define (-stmt-data-hash-size data) (vector-length (cdr data)))
+
+; A single statement.
+; INSN semantics either consist of a single statement or a sequence of them.
+
+(define <statement>
+  (class-make '<statement> nil
+             '(
+               ; RTL code
+               expr
+
+               ; Local variables of the sequence `expr' is in.
+               locals
+
+               ; Ordinal of the statement.
+               num
+
+               ; Costs.
+               ; SPEED-COST is the cost of executing fragment, relative to a
+               ; simple add.
+               ; SIZE-COST is the size of the fragment, relative to a simple
+               ; add.
+               ; ??? The cost numbers are somewhat arbitrary and subject to
+               ; review.
+               speed-cost
+               size-cost
+
+               ; Users of this statement.
+               ; Each element is (owner-number . owner-object),
+               ; where owner-number is an index into the initial insn table
+               ; (e.g. insn-list arg of sfrag-create-cse-mapping), and
+               ; owner-object is the corresponding object.
+               users
+               )
+             nil)
+)
+
+(define-getters <statement> -stmt (expr locals num speed-cost size-cost users))
+
+(define-setters <statement> -stmt (users))
+
+; Make a <statement> object of EXPR.
+; LOCALS is a list of local variables of the sequence EXPR is in.
+; NUM is the ordinal of EXPR.
+; SPEED-COST is the cost of executing the statement, relative to a simple add.
+; SIZE-COST is the size of the fragment, relative to a simple add.
+; ??? The cost numbers are somewhat arbitrary and subject to review.
+;
+; The user list is set to nil.
+
+(define (-stmt-make expr locals num speed-cost size-cost)
+  (make <statement> expr locals num speed-cost size-cost nil)
+)
+
+; Add a user of STMT.
+
+(define (-stmt-add-user! stmt user-num user-obj)
+  (-stmt-set-users! stmt (cons (cons user-num user-obj) (-stmt-users stmt)))
+  *UNSPECIFIED*
+)
+
+; Lookup STMT in DATA.
+; CHAIN-NUM is an argument so it need only be computed once.
+; The result is the found <statement> object or #f.
+
+(define (-frag-lookup-stmt data chain-num stmt)
+  (let ((table (-stmt-data-table data)))
+    (let loop ((stmts (vector-ref table chain-num)))
+      (cond ((null? stmts)
+            #f)
+           ; ??? equal? should be appropriate rtx-equal?, blah blah blah.
+           ((equal? (-stmt-expr (car stmts)) stmt)
+            (car stmts))
+           (else
+            (loop (cdr stmts))))))
+)
+
+; Hash a statement.
+
+; Computed hash value.
+; Global 'cus -frag-hash-compute! is defined globally so we can use
+; /fastcall (FIXME: Need /fastcall to work on non-global procs).
+
+(define -frag-hash-value-tmp 0)
+
+(define (-frag-hash-string str)
+  (let loop ((chars (map char->integer (string->list str))) (result 0))
+    (if (null? chars)
+       result
+       (loop (cdr chars) (modulo (+ (* result 7) (car chars)) #xfffffff))))
+)
+
+(define (-frag-hash-compute! rtx-obj expr mode parent-expr op-pos tstate appstuff)
+  (let ((h 0))
+    (case (rtx-name expr)
+      ((operand)
+       (set! h (-frag-hash-string (symbol->string (rtx-operand-name expr)))))
+      ((local)
+       (set! h (-frag-hash-string (symbol->string (rtx-local-name expr)))))
+      ((const)
+       (set! h (rtx-const-value expr)))
+      (else
+       (set! h (rtx-num rtx-obj))))
+    (set! -frag-hash-value-tmp
+         ; Keep number small.
+         (modulo (+ (* -frag-hash-value-tmp 3) h op-pos)
+                 #xfffffff)))
+
+  ; #f -> "continue with normal traversing"
+  #f
+)
+
+(define (-frag-hash-stmt stmt locals size)
+  (set! -frag-hash-value-tmp 0)
+  (rtx-traverse-with-locals #f #f stmt -frag-hash-compute! locals #f) ; FIXME: (/fastcall-make -frag-hash-compute!))
+  (modulo -frag-hash-value-tmp size)
+)
+
+; Compute the speed/size costs of a statement.
+
+; Compute speed/size costs.
+; Global 'cus -frag-cost-compute! is defined globally so we can use
+; /fastcall (FIXME: Need /fastcall to work on non-global procs).
+
+(define -frag-speed-cost-tmp 0)
+(define -frag-size-cost-tmp 0)
+
+(define (-frag-cost-compute! rtx-obj expr mode parent-expr op-pos tstate appstuff)
+  ; FIXME: wip
+  (let ((speed 0)
+       (size 0))
+    (case (rtx-class rtx-obj)
+      ((ARG)
+       #f) ; these don't contribute to costs (at least for now)
+      ((SET)
+       ; FIXME: speed/size = 0?
+       (set! speed 1)
+       (set! size 1))
+      ((UNARY BINARY TRINARY)
+       (set! speed 1)
+       (set! size 1))
+      ((IF)
+       (set! speed 2)
+       (set! size 2))
+      (else
+       (set! speed 4)
+       (set! size 4)))
+    (set! -frag-speed-cost-tmp (+ -frag-speed-cost-tmp speed))
+    (set! -frag-size-cost-tmp (+ -frag-size-cost-tmp size)))
+
+  ; #f -> "continue with normal traversing"
+  #f
+)
+
+(define (-frag-stmt-cost stmt locals)
+  (set! -frag-speed-cost-tmp 0)
+  (set! -frag-size-cost-tmp 0)
+  (rtx-traverse-with-locals #f #f stmt -frag-cost-compute! locals #f) ; FIXME: (/fastcall-make -frag-cost-compute!))
+  (cons -frag-speed-cost-tmp -frag-size-cost-tmp)
+)
+
+; Add STMT to statement table DATA.
+; CHAIN-NUM is the chain in the hash table to add STMT to.
+; {SPEED,SIZE}-COST are passed through to -stmt-make.
+; The result is the newly created <statement> object.
+
+(define (-frag-add-stmt! data chain-num stmt locals speed-cost size-cost)
+  (let ((stmt (-stmt-make stmt locals (-stmt-data-next-num data) speed-cost size-cost))
+       (table (-stmt-data-table data)))
+    (vector-set! table chain-num (cons stmt (vector-ref table chain-num)))
+    (-stmt-data-set-next-num! data (+ 1 (-stmt-data-next-num data)))
+    stmt)
+)
+
+; Return the locals in EXPR.
+; If a sequence, return locals.
+; Otherwise, return nil.
+; The result is in assq'able form.
+
+(define (-frag-expr-locals expr)
+  (if (rtx-kind? 'sequence expr)
+      (rtx-sequence-assq-locals expr)
+      nil)
+)
+
+; Return the statements in EXPR.
+; If a sequence, return the sequence's expressions.
+; Otherwise, return (list expr).
+
+(define (-frag-expr-stmts expr)
+  (if (rtx-kind? 'sequence expr)
+      (rtx-sequence-exprs expr)
+      (list expr))
+)
+
+; Analyze statement STMT.
+; If STMT is already in STMT-DATA increment its frequency count.
+; Otherwise add it.
+; LOCALS are locals of the sequence STMT is in.
+; USAGE-TABLE is a vector of statement index lists for each expression.
+; USAGE-INDEX is the index of USAGE-TABLE to use.
+; OWNER is the object of the owner of the statement.
+
+(define (-frag-analyze-expr-stmt! locals stmt stmt-data usage-table expr-num owner)
+  (logit 3 "Analyzing statement: " (rtx-strdump stmt) "\n")
+  (let* ((chain-num
+         (-frag-hash-stmt stmt locals (-stmt-data-hash-size stmt-data)))
+        (stmt-obj (-frag-lookup-stmt stmt-data chain-num stmt)))
+
+    (logit 3 "  chain #" chain-num  "\n")
+
+    (if (not stmt-obj)
+       (let* ((costs (-frag-stmt-cost stmt locals))
+              (speed-cost (car costs))
+              (size-cost (cdr costs)))
+         (set! stmt-obj (-frag-add-stmt! stmt-data chain-num stmt locals
+                                         speed-cost size-cost))
+         (logit 3 "  new statement, #" (-stmt-num stmt-obj) "\n"))
+       (logit 3   "  existing statement, #" (-stmt-num stmt-obj) "\n"))
+
+    (-stmt-add-user! stmt-obj expr-num owner)
+
+    ; If first entry, initialize list, otherwise append to existing list.
+    (if (null? (vector-ref usage-table expr-num))
+       (vector-set! usage-table expr-num (list (-stmt-num stmt-obj)))
+       (append! (vector-ref usage-table expr-num)
+                (list (-stmt-num stmt-obj)))))
+
+  *UNSPECIFIED*
+)
+
+; Analyze each statement in EXPR and add it to STMT-DATA.
+; OWNER is the object of the owner of the expression.
+; USAGE-TABLE is a vector of statement index lists for each expression.
+; USAGE-INDEX is the index of the USAGE-TABLE entry to use.
+; As each statement's ordinal is computed it is added to the usage list.
+
+(define (-frag-analyze-expr! expr owner stmt-data usage-table usage-index)
+  (logit 3 "Analyzing " (obj:name owner) ": " (rtx-strdump expr) "\n")
+  (let ((locals (-frag-expr-locals expr))
+       (stmt-list (-frag-expr-stmts expr)))
+    (for-each (lambda (stmt)
+               (-frag-analyze-expr-stmt! locals stmt stmt-data
+                                         usage-table usage-index owner))
+             stmt-list))
+  *UNSPECIFIED*
+)
+
+; Compute statement data from EXPRS, a list of expressions.
+; OWNERS is a vector of objects that "own" each corresponding element in EXPRS.
+; The owner is usually an <insn> object.  Actually it'll probably always be
+; an <insn> object but for now I want the disassociation.
+;
+; The result contains:
+; - vector of statement lists of each expression
+;   - each element is (stmt1-index stmt2-index ...) where each stmtN-index is
+;     an index into the statement table
+; - vector of statements (the statement table of the previous item)
+;   - each element is a <statement> object
+
+(define (-frag-compute-statements exprs owners)
+  (logit 2 "Computing statement table ...\n")
+  (let* ((num-exprs (length exprs))
+        (hash-size
+         ; FIXME: This is just a quick hack to put something down on paper.
+         ; blah blah blah.  Revisit as necessary.
+         (cond ((> num-exprs 300) 1019)
+               ((> num-exprs 100) 511)
+               (else 127))))
+
+    (let (; Hash table of expressions.
+         (stmt-data (-stmt-data-make hash-size))
+         ; Statement index lists for each expression.
+         (usage-table (make-vector num-exprs nil)))
+
+      ; Scan each expr, filling in stmt-data and usage-table.
+      (let loop ((exprs exprs) (exprnum 0))
+       (if (not (null? exprs))
+           (let ((expr (car exprs))
+                 (owner (vector-ref owners exprnum)))
+             (-frag-analyze-expr! expr owner stmt-data usage-table exprnum)
+             (loop (cdr exprs) (+ exprnum 1)))))
+
+      ; Convert statement hash table to vector.
+      (let ((stmt-hash-table (-stmt-data-table stmt-data))
+           (end (vector-length (-stmt-data-table stmt-data)))
+           (stmt-table (make-vector (-stmt-data-next-num stmt-data) #f)))
+       (let loop ((i 0))
+         (if (< i end)
+             (begin
+               (map (lambda (stmt)
+                      (vector-set! stmt-table (-stmt-num stmt) stmt))
+                    (vector-ref stmt-hash-table i))
+               (loop (+ i 1)))))
+
+       ; All done.  Compute stats if asked to.
+       (if -stmt-stats?
+           (begin
+             ; See how well the hashing worked.
+             (set! -stmt-stats-data stmt-data)
+             (set! -stmt-stats
+                   (make-vector (vector-length stmt-hash-table) #f))
+             (let loop ((i 0))
+               (if (< i end)
+                   (begin
+                     (vector-set! -stmt-stats i
+                                  (length (vector-ref stmt-hash-table i)))
+                     (loop (+ i 1)))))))
+
+       ; Result.
+       (cons usage-table stmt-table))))
+)
+\f
+; Semantic fragment selection.
+;
+; "semantic fragment" is the name assigned to each header/middle/trailer
+; "fragment" as each may consist of more than one statement, though not
+; necessarily all statements of the original sequence.
+
+(define <sfrag>
+  (class-make '<sfrag> '(<ident>)
+             '(
+               ; List of insn's using this frag.
+               users
+
+               ; Ordinal's of each element of `users'.
+               user-nums
+
+               ; Semantic format of insns using this fragment.
+               sfmt
+
+               ; List of statement numbers that make up `semantics'.
+               ; Each element is an index into the stmt-table arg of
+               ; -frag-pick-best.
+               ; This is #f if the sfrag wasn't derived from some set of
+               ; statements.
+               stmt-numbers
+
+               ; Raw rtl source of fragment.
+               semantics
+
+               ; Compiled source.
+               compiled-semantics
+
+               ; Boolean indicating if this frag is for parallel exec support.
+               parallel?
+
+               ; Boolean indicating if this is a header frag.
+               ; This includes all frags that begin a sequence.
+               header?
+
+               ; Boolean indicating if this is a trailer frag.
+               ; This includes all frags that end a sequence.
+               trailer?
+               )
+             nil)
+)
+
+(define-getters <sfrag> sfrag
+  (users user-nums sfmt stmt-numbers semantics compiled-semantics
+        parallel? header? trailer?)
+)
+
+(define-setters <sfrag> sfrag
+  (header? trailer?)
+)
+
+; Sorter to merge common fragments together.
+; A and B are lists of statement numbers.
+
+(define (-frag-sort a b)
+  (cond ((null? a)
+        (not (null? b)))
+       ((null? b)
+        #f)
+       ((< (car a) (car b))
+        #t)
+       ((> (car a) (car b))
+        #f)
+       (else ; =
+        (-frag-sort (cdr a) (cdr b))))
+)
+
+; Return a boolean indicating if L1,L2 match in the first LEN elements.
+; Each element is an integer.
+
+(define (-frag-list-match? l1 l2 len)
+  (cond ((= len 0)
+        #t)
+       ((or (null? l1) (null? l2))
+        #f)
+       ((= (car l1) (car l2))
+        (-frag-list-match? (cdr l1) (cdr l2) (- len 1)))
+       (else
+        #f))
+)
+
+; Return the number of expressions that match in the first LEN statements.
+
+(define (-frag-find-matching expr-table indices stmt-list len)
+  (let loop ((num-exprs 0) (indices indices))
+    (cond ((null? indices)
+          num-exprs)
+         ((-frag-list-match? stmt-list
+                             (vector-ref expr-table (car indices)) len)
+          (loop (+ num-exprs 1) (cdr indices)))
+         (else
+          num-exprs)))
+)
+
+; Return a boolean indicating if making STMT-LIST a common fragment
+; among several owners is profitable.
+; STMT-LIST is a list of statement numbers, indices into STMT-TABLE.
+; NUM-EXPRS is the number of expressions with STMT-LIST in common.
+
+(define (-frag-merge-profitable? stmt-table stmt-list num-exprs)
+  ; FIXME: wip
+  (and (>= num-exprs 2)
+       (or ; No need to include speed costs yet.
+          ;(>= (-frag-list-speed-cost stmt-table stmt-list) 10)
+          (>= (-frag-list-size-cost stmt-table stmt-list) 4)))
+)
+
+; Return the cost of executing STMT-LIST.
+; STMT-LIST is a list of statment numbers, indices into STMT-TABLE.
+;
+; FIXME: The yardstick to use is wip.  Currently we measure things relative
+; to a simple add insn which is given the value 1.
+
+(define (-frag-list-speed-cost stmt-table stmt-list)
+  ; FIXME: wip
+  (apply + (map (lambda (stmt-num)
+                 (-stmt-speed-cost (vector-ref stmt-table stmt-num)))
+               stmt-list))
+)
+
+(define (-frag-list-size-cost stmt-table stmt-list)
+  ; FIXME: wip
+  (apply + (map (lambda (stmt-num)
+                 (-stmt-size-cost (vector-ref stmt-table stmt-num)))
+               stmt-list))
+)
+
+; Compute the longest set of fragments it is desirable/profitable to create.
+; The result is (number-of-matching-exprs . stmt-number-list)
+; or #f if there isn't one (the longest set is the empty set).
+;
+; What is desirable depends on a few things:
+; - how often is it used?
+; - how expensive is it (size-wise and speed-wise)
+; - relationship to other frags
+;
+; STMT-TABLE is a vector of all statements.
+; STMT-USAGE-TABLE is a vector of all expressions.  Each element is a list of
+; statement numbers (indices into STMT-TABLE).
+; INDICES is a sorted list of indices into STMT-USAGE-TABLE.
+; STMT-USAGE-TABLE is processed in the order specified by INDICES.
+;
+; FIXME: Choosing a statement list should depend on whether there are existing
+; chosen statement lists only slightly shorter.
+
+(define (-frag-longest-desired stmt-table stmt-usage-table indices)
+  ; STMT-LIST is the list of statements in the first expression.
+  (let ((stmt-list (vector-ref stmt-usage-table (car indices))))
+
+    (let loop ((len 1) (prev-num-exprs 0))
+
+      ; See how many subsequent expressions match at length LEN.
+      (let ((num-exprs (-frag-find-matching stmt-usage-table (cdr indices)
+                                           stmt-list len)))
+       ; If there aren't any, we're done.
+       ; If LEN-1 is usable, return that.
+       ; Otherwise there is no profitable list of fragments.
+       (if (= num-exprs 0)
+
+           (let ((matching-stmt-list (list-take (- len 1) stmt-list)))
+             (if (-frag-merge-profitable? stmt-table matching-stmt-list
+                                          prev-num-exprs)
+                 (cons prev-num-exprs matching-stmt-list)
+                 #f))
+
+           ; Found at least 1 subsequent matching expression.
+           ; Extend LEN and see if we still find matching expressions.
+           (loop (+ len 1) num-exprs)))))
+)
+
+; Return list of lists of objects for each unique <sformat-argbuf> in
+; USER-LIST.
+; Each element of USER-LIST is (insn-num . <insn> object).
+; The result is a list of lists.  Each element in the top level list is
+; a list of elements of USER-LIST that have the same <sformat-argbuf>.
+; Insns are also distinguished by being a CTI insn vs a non-CTI insn.
+; CTI insns require special handling in the semantics.
+
+(define (-frag-split-by-sbuf user-list)
+  ; Sanity check.
+  (if (not (elm-bound? (cdar user-list) 'sfmt))
+      (error "sformats not computed"))
+  (if (not (elm-bound? (insn-sfmt (cdar user-list)) 'sbuf))
+      (error "sformat argbufs not computed"))
+
+  (let ((result nil)
+       ; Find INSN in SFMT-LIST.  The result is the list INSN belongs in
+       ; or #f.
+       (find-obj (lambda (sbuf-list insn)
+                   (let ((name (obj:name (sfmt-sbuf (insn-sfmt insn)))))
+                     (let loop ((sbuf-list sbuf-list))
+                       (cond ((null? sbuf-list)
+                              #f)
+                             ((and (eq? name
+                                        (obj:name (sfmt-sbuf (insn-sfmt (cdaar sbuf-list)))))
+                                   (eq? (insn-cti? insn)
+                                        (insn-cti? (cdaar sbuf-list))))
+                              (car sbuf-list))
+                             (else
+                              (loop (cdr sbuf-list))))))))
+       )
+    (let loop ((users user-list))
+      (if (not (null? users))
+         (let ((try (find-obj result (cdar users))))
+           (if try
+               (append! try (list (car users)))
+               (set! result (cons (list (car users)) result)))
+           (loop (cdr users)))))
+
+    ; Done
+    result)
+)
+
+; Return a list of desired fragments to create.
+; These consist of the longest set of profitable leading statements in EXPRS.
+; Each element of the result is an <sfrag> object.
+;
+; STMT-TABLE is a vector of all statements.
+; STMT-USAGE-TABLE is a vector of statement number lists of each expression.
+; OWNER-TABLE is a vector of owner objects of each corresponding expression
+; in STMT-USAGE-TABLE.
+; KIND is one of 'header or 'trailer.
+;
+; This works for trailing fragments too as we do the computation based on the
+; reversed statement lists.
+
+(define (-frag-compute-desired-frags stmt-table stmt-usage-table owner-table kind)
+  (logit 2 "Computing desired " kind " frags ...\n")
+
+  (let* (
+        (stmt-usage-list
+         (if (eq? kind 'header)
+             (vector->list stmt-usage-table)
+             (map reverse (vector->list stmt-usage-table))))
+        ; Sort STMT-USAGE-TABLE.  That will bring exprs with common fragments
+        ; together.
+        (sorted-indices (sort-grade stmt-usage-list -frag-sort))
+        ; List of statement lists that together yield the fragment to create,
+        ; plus associated users.
+        (desired-frags nil)
+        )
+
+    ; Update STMT-USAGE-TABLE in case we reversed the contents.
+    (set! stmt-usage-table (list->vector stmt-usage-list))
+
+    (let loop ((indices sorted-indices) (iteration 1))
+      (logit 3 "Iteration " iteration "\n")
+      (if (not (null? indices))
+         (let ((longest (-frag-longest-desired stmt-table stmt-usage-table indices)))
+
+           (if longest
+
+               ; Found an acceptable frag to create.
+               (let* ((num-exprs (car longest))
+                      ; Reverse statement numbers back if trailer.
+                      (stmt-list (if (eq? kind 'header)
+                                     (cdr longest)
+                                     (reverse (cdr longest))))
+                      (picked-indices (list-take num-exprs indices))
+                      ; Need one copy of the frag for each sbuf, as structure
+                      ; offsets will be different in generated C/C++ code.
+                      (sfmt-users (-frag-split-by-sbuf
+                                   (map (lambda (expr-num)
+                                          (cons expr-num
+                                                (vector-ref owner-table
+                                                            expr-num)))
+                                        picked-indices))))
+
+                 (logit 3 "Creating frag of length " (length stmt-list) ", " num-exprs " users\n")
+                 (logit 3 "Indices: " picked-indices "\n")
+
+                 ; Create an sfrag for each sbuf.
+                 (for-each
+                  (lambda (users)
+                    (let* ((first-owner (cdar users))
+                           (sfrag
+                            (make <sfrag>
+                              (symbol-append (obj:name first-owner)
+                                             (if (eq? kind 'header)
+                                                 '-hdr
+                                                 '-trlr))
+                              ""
+                              atlist-empty
+                              (map cdr users)
+                              (map car users)
+                              (insn-sfmt first-owner)
+                              stmt-list
+                              (apply
+                               rtx-make
+                               (cons 'sequence
+                                     (cons 'VOID
+                                           (cons nil
+                                                 (map (lambda (stmt-num)
+                                                        (-stmt-expr
+                                                         (vector-ref stmt-table
+                                                                     stmt-num)))
+                                                      stmt-list)))))
+                              #f ; compiled-semantics
+                              #f ; parallel?
+                              (eq? kind 'header)
+                              (eq? kind 'trailer)
+                              )))
+                      (set! desired-frags (cons sfrag desired-frags))))
+                  sfmt-users)
+
+                 ; Continue, dropping statements we've put into the frag.
+                 (loop (list-drop num-exprs indices) (+ iteration 1)))
+
+               ; Couldn't find an acceptable statement list.
+               ; Try again with next one.
+               (begin
+                 (logit 3 "No acceptable frag found.\n")
+                 (loop (cdr indices) (+ iteration 1)))))))
+
+    ; Done.
+    desired-frags)
+)
+
+; Return the set of desired fragments to create.
+; STMT-TABLE is a vector of each statement.
+; STMT-USAGE-TABLE is a vector of (stmt1-index stmt2-index ...) elements for
+; each expression, where each stmtN-index is an index into STMT-TABLE.
+; OWNER-TABLE is a vector of owner objects of each corresponding expression
+; in STMT-USAGE-TABLE.
+;
+; Each expression is split in up to three pieces: header, middle, trailer.
+; This computes pseudo-optimal headers and trailers (if they exist).
+; The "middle" part is whatever is leftover.
+;
+; The result is a vector of 4 elements:
+; - vector of (header middle trailer) semantic fragments for each expression
+;   - each element is an index into the respective table or #f if not present
+; - list of header fragments, each element is an <sfrag> object
+; - same but for trailer fragments
+; - same but for middle fragments
+;
+; ??? While this is a big function, each piece is simple and straightforward.
+; It's kept as one big function so we can compute each expression's sfrag list
+; as we go.  Though it's not much extra expense to not do this.
+
+(define (-frag-pick-best stmt-table stmt-usage-table owner-table)
+  (let (
+       (num-stmts (vector-length stmt-table))
+       (num-exprs (vector-length stmt-usage-table))
+       ; FIXME: Shouldn't have to do vector->list.
+       (stmt-usage-list (vector->list stmt-usage-table))
+       ; Specify result holders here, simplifies code.
+       (desired-header-frags #f)
+       (desired-trailer-frags #f)
+       (middle-frags #f)
+       ; Also allocate space for expression sfrag usage table.
+       ; We compute it as we go to save scanning the header and trailer
+       ; lists twice.
+       ; copy-tree is needed to avoid shared storage.
+       (expr-sfrags (copy-tree (make-vector (vector-length stmt-usage-table)
+                                            #(#f #f #f))))
+       )
+
+    ; Compute desired headers.
+    (set! desired-header-frags
+         (-frag-compute-desired-frags stmt-table stmt-usage-table owner-table
+                                      'header))
+
+    ; Compute the header used by each expression.
+    (let ((expr-hdrs-v (make-vector num-exprs #f))
+         (num-hdrs (length desired-header-frags)))
+      (let loop ((hdrs desired-header-frags) (hdrnum 0))
+       (if (< hdrnum num-hdrs)
+           (let ((hdr (car hdrs)))
+             (for-each (lambda (expr-num)
+                         (vector-set! (vector-ref expr-sfrags expr-num) 0
+                                      hdrnum)
+                         (vector-set! expr-hdrs-v expr-num hdr))
+                       (sfrag-user-nums hdr))
+             (loop (cdr hdrs) (+ hdrnum 1)))))
+
+      ; Truncate each expression by the header it will use and then find
+      ; the set of desired trailers.
+      (let ((expr-hdrs (vector->list expr-hdrs-v)))
+
+       (set! desired-trailer-frags
+             (-frag-compute-desired-frags
+              stmt-table
+              ; FIXME: Shouldn't have to use list->vector.
+              ; [still pass a vector, but use vector-map here instead of map]
+              (list->vector
+               (map (lambda (expr hdr)
+                      (if hdr
+                          (list-drop (length (sfrag-stmt-numbers hdr)) expr)
+                          expr))
+                    stmt-usage-list expr-hdrs))
+              owner-table
+              'trailer))
+
+       ; Record the trailer used by each expression.
+       (let ((expr-trlrs-v (make-vector num-exprs #f))
+             (num-trlrs (length desired-trailer-frags)))
+         (let loop ((trlrs desired-trailer-frags) (trlrnum 0))
+           (if (< trlrnum num-trlrs)
+               (let ((trlr (car trlrs)))
+                 (for-each (lambda (expr-num)
+                             (vector-set! (vector-ref expr-sfrags expr-num) 2
+                                          trlrnum)
+                             (vector-set! expr-trlrs-v expr-num trlr))
+                           (sfrag-user-nums trlr))
+                 (loop (cdr trlrs) (+ trlrnum 1)))))
+
+         ; We have the desired headers and trailers, now compute the middle
+         ; part for each expression.  This is just what's left over.
+         ; ??? We don't try to cse the middle part.  Though we can in the
+         ; future should it prove useful enough.
+         (logit 2 "Computing middle frags ...\n")
+         (let* ((expr-trlrs (vector->list expr-trlrs-v))
+                (expr-middle-stmts
+                 (map (lambda (expr hdr trlr)
+                        (list-tail-drop
+                         (if trlr (length (sfrag-stmt-numbers trlr)) 0)
+                         (list-drop
+                          (if hdr (length (sfrag-stmt-numbers hdr)) 0)
+                          expr)))
+                      stmt-usage-list expr-hdrs expr-trlrs)))
+
+           ; Finally, record the middle sfrags used by each expression.
+           (let loop ((tmp-middle-frags nil)
+                      (next-middle-frag-num 0)
+                      (expr-num 0)
+                      (expr-middle-stmts expr-middle-stmts))
+
+             (if (null? expr-middle-stmts)
+
+                 ; Done!
+                 ; [The next statement executed after this is the one at the
+                 ; end that builds the result.  Maybe it should be built here
+                 ; and this should be the last statement, but I'm trying this
+                 ; style out for awhile.]
+                 (set! middle-frags (reverse! tmp-middle-frags))
+
+                 ; Does this expr have a middle sfrag?
+                 (if (null? (car expr-middle-stmts))
+                     ; Nope.
+                     (loop tmp-middle-frags
+                           next-middle-frag-num
+                           (+ expr-num 1)
+                           (cdr expr-middle-stmts))
+                     ; Yep.
+                     (let ((owner (vector-ref owner-table expr-num)))
+                       (vector-set! (vector-ref expr-sfrags expr-num)
+                                    1 next-middle-frag-num)
+                       (loop (cons (make <sfrag>
+                                     (symbol-append (obj:name owner) '-mid)
+                                     (string-append (obj:comment owner)
+                                                    ", middle part")
+                                     (obj-atlist owner)
+                                     (list owner)
+                                     (list expr-num)
+                                     (insn-sfmt owner)
+                                     (car expr-middle-stmts)
+                                     (apply
+                                      rtx-make
+                                      (cons 'sequence
+                                            (cons 'VOID
+                                                  (cons nil
+                                                        (map (lambda (stmt-num)
+                                                               (-stmt-expr
+                                                                (vector-ref stmt-table stmt-num)))
+                                                             (car expr-middle-stmts))))))
+                                     #f ; compiled-semantics
+                                     #f ; parallel?
+                                     #f ; header?
+                                     #f ; trailer?
+                                     )
+                                   tmp-middle-frags)
+                             (+ next-middle-frag-num 1)
+                             (+ expr-num 1)
+                             (cdr expr-middle-stmts))))))))))
+
+    ; Result.
+    (vector expr-sfrags
+           desired-header-frags
+           desired-trailer-frags
+           middle-frags))
+)
+\f
+; Given a list of expressions, return list of locals in top level sequences.
+; ??? Collisions will be handled by rewriting rtl (renaming locals).
+;
+; This has to be done now as the cse pass must (currently) take into account
+; the rewritten rtl.
+; ??? This can be done later, with an appropriate enhancement to rtx-equal?
+; ??? cse can be improved by ignoring local variable name (of course).
+
+(define (-frag-compute-locals! expr-list)
+  (logit 2 "Computing common locals ...\n")
+  (let ((result nil)
+       (lookup-local (lambda (local local-list)
+                       (assq (car local) local-list)))
+       (local-equal? (lambda (l1 l2)
+                       (and (eq? (car l1) (car l2))
+                            (mode:eq? (cadr l1) (cadr l2)))))
+       )
+    (for-each (lambda (expr)
+               (let ((locals (-frag-expr-locals expr)))
+                 (for-each (lambda (local)
+                             (let ((entry (lookup-local local result)))
+                               (if (and entry
+                                        (local-equal? local entry))
+                                   #f ; already present
+                                   (set! result (cons local result)))))
+                           locals)))
+             expr-list)
+    ; Done.
+    result)
+)
+\f
+; Common subexpression computation.
+
+; Given a list of rtl expressions and their owners, return a pseudo-optimal
+; set of fragments and a usage list for each owner.
+; Common fragments are combined and the original expressions become a sequence
+; of these fragments.  The result is "pseudo-optimal" in the sense that the
+; desired result is somewhat optimal, though no attempt is made at precise
+; optimality.
+;
+; OWNERS is a list of objects that "own" each corresponding element in EXPRS.
+; The owner is usually an <insn> object.  Actually it'll probably always be
+; an <insn> object but for now I want the disassociation.
+;
+; The result is a vector of six elements:
+; - sfrag usage table for each owner #(header middle trailer)
+; - statement table (vector of all statements, made with -stmt-make)
+; - list of sequence locals used by header sfrags
+;   - these locals are defined at the top level so that all fragments have
+;     access to them
+;   - ??? Need to handle collisions among incompatible types.
+; - header sfrags
+; - trailer sfrags
+; - middle sfrags
+
+(define (-sem-find-common-frags-1 exprs owners)
+  ; Sanity check.
+  (if (not (elm-bound? (car owners) 'sfmt))
+      (error "sformats not computed"))
+
+  ; A simple procedure that calls, in order:
+  ; -frag-compute-locals!
+  ; -frag-compute-statements
+  ; -frag-pick-best
+  ; The rest is shuffling of results.
+
+  ; Internally it's easier if OWNERS is a vector.
+  (let ((owners (list->vector owners))
+       (locals (-frag-compute-locals! exprs)))
+
+    ; Collect statement usage data.
+    (let ((stmt-usage (-frag-compute-statements exprs owners)))
+      (let ((stmt-usage-table (car stmt-usage))
+           (stmt-table (cdr stmt-usage)))
+
+       ; Compute the frags we want to create.
+       ; These are in general sequences of statements.
+       (let ((desired-frags
+              (-frag-pick-best stmt-table stmt-usage-table owners)))
+         (let (
+               (expr-sfrags (vector-ref desired-frags 0))
+               (headers (vector-ref desired-frags 1))
+               (trailers (vector-ref desired-frags 2))
+               (middles (vector-ref desired-frags 3))
+               )
+           ; Result.
+           (vector expr-sfrags stmt-table locals
+                   headers trailers middles))))))
+)
+
+; Cover proc of -sem-find-common-frags-1.
+; See its documentation.
+
+(define (sem-find-common-frags insn-list)
+  (-sem-find-common-frags-1
+   (begin
+     (logit 2 "Simplifying/canonicalizing rtl ...\n")
+     (map (lambda (insn)
+           ; Must pass canonicalized and macro-expanded rtl.
+           (rtx-simplify #f insn (insn-semantics insn)
+                         (-build-known-values insn)))
+         insn-list))
+   insn-list)
+)
+
+; Subroutine of sfrag-create-cse-mapping to compute INSN's fragment list.
+; FRAG-USAGE is a vector of 3 elements: #(header middle trailer).
+; Each element is a fragment number or #f if not present.
+; Numbers in FRAG-USAGE are indices relative to their respective subtables
+; of FRAG-TABLE (which is a vector of all 3 tables concatenated together).
+; NUM-HEADERS,NUM-TRAILERS are used to compute absolute indices.
+;
+; No header may have been created.  This happens when
+; it's not profitable (or possible) to merge this insn's
+; leading statements with other insns.  Ditto for
+; trailer.  However, each cti insn must have a header
+; and a trailer (for pc handling setup and change).
+; Try to use the middle fragment if present.  Otherwise,
+; use the x-header,x-trailer virtual insns.
+
+(define (-sfrag-compute-frag-list! insn frag-usage frag-table num-headers num-trailers x-header-relnum x-trailer-relnum)
+  ; `(list #f)' is so append! works.  The #f is deleted before returning.
+  (let ((result (list #f))
+       (header (vector-ref frag-usage 0))
+       (middle (and (vector-ref frag-usage 1)
+                    (+ (vector-ref frag-usage 1)
+                       num-headers num-trailers)))
+       (trailer (and (vector-ref frag-usage 2)
+                     (+ (vector-ref frag-usage 2)
+                        num-headers)))
+       (x-header-num x-header-relnum)
+       (x-trailer-num (+ x-trailer-relnum num-headers))
+       )
+
+    ; cse'd header created?
+    (if header
+       ; Yep.
+       (append! result (list header))
+       ; Nope.  Use the middle frag if present, otherwise use x-header.
+       ; Can't use the trailer fragment because by definition it is shared
+       ; among several insns.
+       (if middle
+           ; Mark the middle frag as the header frag.
+           (sfrag-set-header?! (vector-ref frag-table middle) #t)
+           ; No middle, use x-header.
+           (append! result (list x-header-num))))
+
+    ; middle fragment present?
+    (if middle
+       (append! result (list middle)))
+
+    ; cse'd trailer created?
+    (if trailer
+       ; Yep.
+       (append! result (list trailer))
+       ; Nope.  Use the middle frag if present, otherwise use x-trailer.
+       ; Can't use the header fragment because by definition it is shared
+       ; among several insns.
+       (if middle
+           ; Mark the middle frag as the trailer frag.
+           (sfrag-set-trailer?! (vector-ref frag-table middle) #t)
+           ; No middle, use x-trailer.
+           (append! result (list x-trailer-num))))
+
+    ; Done.
+    (cdr result))
+)
+
+; Subroutine of sfrag-create-cse-mapping to find the fragment number of the
+; x-header/x-trailer virtual frags.
+
+(define (-frag-lookup-virtual frag-list name)
+  (let loop ((i 0) (frag-list frag-list))
+    (if (null? frag-list)
+       (assert (not "expected virtual insn not present"))
+       (if (eq? name (obj:name (car frag-list)))
+           i
+           (loop (+ i 1) (cdr frag-list)))))
+)
+
+; Handle complex case, find set of common header and trailer fragments.
+; The result is a vector of:
+; - fragment table (a vector)
+; - table mapping used fragments for each insn (a list)
+; - locals list
+
+(define (sfrag-create-cse-mapping insn-list)
+  (logit 1 "Creating semantic fragments for pbb engine ...\n")
+
+  (let ((cse-data (sem-find-common-frags insn-list)))
+
+    ; Extract the results of sem-find-common-frags.
+    (let ((sfrag-usage-table (vector-ref cse-data 0))
+         (stmt-table (vector-ref cse-data 1))
+         (locals-list (vector-ref cse-data 2))
+         (header-list1 (vector-ref cse-data 3))
+         (trailer-list1 (vector-ref cse-data 4))
+         (middle-list (vector-ref cse-data 5)))
+
+      ; Create two special frags: x-header, x-trailer.
+      ; These are used by insns that don't have one or the other.
+      ; Header/trailer table indices are already computed for each insn
+      ; so append x-header/x-trailer to the end.
+      (let ((header-list
+            (append header-list1
+                    (list
+                     (make <sfrag>
+                       'x-header
+                       "header fragment for insns without one"
+                       (atlist-parse '(VIRTUAL) "" "semantic frag computation")
+                       nil ; users
+                       nil ; user ordinals
+                       (insn-sfmt (current-insn-lookup 'x-before))
+                       #f ; stmt-numbers
+                       (rtx-make 'nop)
+                       #f ; compiled-semantics
+                       #f ; parallel?
+                       #t ; header?
+                       #f ; trailer?
+                       ))))
+           (trailer-list
+            (append trailer-list1
+                    (list
+                     (make <sfrag>
+                       'x-trailer
+                       "trailer fragment for insns without one"
+                       (atlist-parse '(VIRTUAL) "" "semantic frag computation")
+                       nil ; users
+                       nil ; user ordinals
+                       (insn-sfmt (current-insn-lookup 'x-before))
+                       #f ; stmt-numbers
+                       (rtx-make 'nop)
+                       #f ; compiled-semantics
+                       #f ; parallel?
+                       #f ; header?
+                       #t ; trailer?
+                       )))))
+
+       (let ((num-headers (length header-list))
+             (num-trailers (length trailer-list))
+             (num-middles (length middle-list)))
+
+         ; Combine the three sfrag tables (headers, trailers, middles) into
+         ; one big one.
+         (let ((frag-table (list->vector (append header-list
+                                                 trailer-list
+                                                 middle-list)))
+               (x-header-relnum (-frag-lookup-virtual header-list 'x-header))
+               (x-trailer-relnum (-frag-lookup-virtual trailer-list 'x-trailer))
+               )
+           ; Convert sfrag-usage-table to one that refers to the one big
+           ; sfrag table.
+           (logit 2 "Computing insn frag usage ...\n")
+           (let ((insn-frags
+                  (map (lambda (insn frag-usage)
+                         (-sfrag-compute-frag-list! insn frag-usage
+                                                    frag-table
+                                                    num-headers num-trailers
+                                                    x-header-relnum
+                                                    x-trailer-relnum))
+                       insn-list
+                       ; FIXME: vector->list
+                       (vector->list sfrag-usage-table)))
+                 )
+             (logit 1 "Done fragment creation.\n")
+             (vector frag-table insn-frags locals-list)))))))
+)
+\f
+; Data analysis interface.
+
+(define -sim-sfrag-init? #f)
+(define (sim-sfrag-init?) -sim-sfrag-init?)
+
+; Keep in globals for now, simplifies debugging.
+; evil globals, blah blah blah.
+(define -sim-sfrag-insn-list #f)
+(define -sim-sfrag-frag-table #f)
+(define -sim-sfrag-usage-table #f)
+(define -sim-sfrag-locals-list #f)
+
+(define (sim-sfrag-insn-list)
+  (assert -sim-sfrag-init?)
+  -sim-sfrag-insn-list
+)
+(define (sim-sfrag-frag-table)
+  (assert -sim-sfrag-init?)
+  -sim-sfrag-frag-table
+)
+(define (sim-sfrag-usage-table)
+  (assert -sim-sfrag-init?)
+  -sim-sfrag-usage-table
+)
+(define (sim-sfrag-locals-list)
+  (assert -sim-sfrag-init?)
+  -sim-sfrag-locals-list
+)
+
+(define (sim-sfrag-init!)
+  (set! -sim-sfrag-init? #f)
+  (set! -sim-sfrag-insn-list #f)
+  (set! -sim-sfrag-frag-table #f)
+  (set! -sim-sfrag-usage-table #f)
+  (set! -sim-sfrag-locals-list #f)
+)
+
+(define (sim-sfrag-analyze-insns!)
+  (if (not -sim-sfrag-init?)
+      (begin
+       (set! -sim-sfrag-insn-list (non-multi-insns (non-alias-insns (current-insn-list))))
+       (let ((frag-data (sfrag-create-cse-mapping -sim-sfrag-insn-list)))
+         (set! -sim-sfrag-frag-table (vector-ref frag-data 0))
+         (set! -sim-sfrag-usage-table (vector-ref frag-data 1))
+         (set! -sim-sfrag-locals-list (vector-ref frag-data 2)))
+       (set! -sim-sfrag-init? #t)))
+
+  *UNSPECIFIED*
+)
+\f
+; Testing support.
+
+(define (-frag-small-test-data)
+  '(
+    (a . (sequence VOID ((SI tmp)) (set DFLT tmp rm) (set DFLT rd rm)))
+    (b . (sequence VOID ((SI tmp)) (set DFLT tmp rm) (set DFLT rd rm)))
+    (c . (set DFLT rd rm))
+    )
+)
+
+(define (-frag-test-data)
+  (cons
+   (map (lambda (insn)
+         ; Must pass canonicalized and macro-expanded rtl.
+         (rtx-simplify #f insn (insn-semantics insn)
+                       (-build-known-values insn)))
+       (non-multi-insns (non-alias-insns (current-insn-list))))
+   (non-multi-insns (non-alias-insns (current-insn-list))))
+)
+
+(define test-sfrag-table #f)
+(define test-stmt-table #f)
+(define test-locals-list #f)
+(define test-header-list #f)
+(define test-trailer-list #f)
+(define test-middle-list #f)
+
+(define (frag-test-run)
+  (let* ((test-data (-frag-test-data))
+        (frag-data (sem-find-common-frags (car test-data) (cdr test-data))))
+    (set! test-sfrag-table (vector-ref frag-data 0))
+    (set! test-stmt-table (vector-ref frag-data 1))
+    (set! test-locals-list (vector-ref frag-data 2))
+    (set! test-header-list (vector-ref frag-data 3))
+    (set! test-trailer-list (vector-ref frag-data 4))
+    (set! test-middle-list (vector-ref frag-data 5))
+    )
+  *UNSPECIFIED*
+)
diff --git a/cgen/semantics.scm b/cgen/semantics.scm
new file mode 100644 (file)
index 0000000..1159587
--- /dev/null
@@ -0,0 +1,879 @@
+; Routines for instruction semantic analysis (including rtx-simplify).
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; Semantic expression compilation.
+; This is more involved than normal rtx compilation as we need to keep
+; track of the inputs and outputs.  Various attributes that can be derived
+; from the code are also computed.
+\f
+; Subroutine of -simplify-expr-fn to compare two values for equality.
+; If both are constants and they're equal return #f/#t.
+; INVERT? = #f -> return #t if equal, #t -> return #f if equal.
+; Returns 'unknown if either argument is not a constant.
+
+(define (rtx-const-equal arg0 arg1 invert?)
+  (if (and (rtx-constant? arg0)
+          (rtx-constant? arg1))
+      (if invert?
+         (!= (rtx-constant-value arg0)
+             (rtx-constant-value arg1))
+         (= (rtx-constant-value arg0)
+            (rtx-constant-value arg1)))
+      'unknown)
+)
+
+; Subroutine of -simplify-expr-fn to see if MAYBE-CONST is one of NUMBER-LIST.
+; NUMBER-LIST is a `number-list' rtx.
+; INVERT? is #t if looking for non-membership.
+; #f/#t is only returned for definitive answers.
+; If INVERT? is #f:
+; - return #f if MAYBE-CONST is not in NUMBER-LIST
+; - return #t if MAYBE-CONST is in NUMBER-LIST and it has only one member
+; - return 'member if MAYBE-CONST is in NUMBER-LIST and it has many members
+; - otherwise return 'unknown
+; If INVERT? is #t:
+; - return #t if MAYBE-CONST is not in NUMBER-LIST
+; - return #f if MAYBE-CONST is in NUMBER-LIST and it has only one member
+; - return 'member if MAYBE-CONST is in NUMBER-LIST and it has many members
+; - otherwise return 'unknown
+
+(define (rtx-const-list-equal maybe-const number-list invert?)
+  (assert (rtx-kind? 'number-list number-list))
+  (if (rtx-constant? maybe-const)
+      (let ((values (rtx-number-list-values number-list)))
+       (if invert?
+           (if (memq (rtx-constant-value maybe-const) values)
+               (if (= (length values) 1)
+                   #f
+                   'member)
+               #t)
+           (if (memq (rtx-constant-value maybe-const) values)
+               (if (= (length values) 1)
+                   #t
+                   'member)
+               #f)))
+      'unknown)
+)
+
+; Subroutine of -simplify-expr-fn to simplify an eq-attr of (current-mach).
+; CONTEXT is a <context> object or #f if there is none.
+
+(define (rtx-simplify-eq-attr-mach rtx context)
+  (let ((attr (rtx-eq-attr-attr rtx))
+       (value (rtx-eq-attr-value rtx)))
+    ; If all currently selected machs will yield the same value
+    ; for the attribute, we can simplify.
+    (let ((values (map (lambda (m)
+                        (obj-attr-value m attr))
+                      (current-mach-list))))
+      ; Ensure at least one mach is selected.
+      (if (null? values)
+         (context-error context "rtx simplification, no machs selected"
+                        (rtx-strdump rtx)))
+      ; All values equal to the first one?
+      (if (all-true? (map (lambda (val)
+                           (equal? val (car values)))
+                         values))
+         (if (equal? value
+                     ; Convert internal boolean attribute value
+                     ; #f/#t to external value FALSE/TRUE.
+                     ; FIXME:revisit.
+                     (case (car values)
+                       ((#f) 'FALSE)
+                       ((#t) 'TRUE)
+                       (else (car values))))
+             (rtx-true)
+             (rtx-false))
+         ; couldn't simplify
+         rtx)))
+)
+
+; Subroutine of -simplify-expr-fn to simplify an eq-attr of (current-insn).
+
+(define (rtx-simplify-eq-attr-insn rtx insn context)
+  (let ((attr (rtx-eq-attr-attr rtx))
+       (value (rtx-eq-attr-value rtx)))
+    (if (not (insn? insn))
+       (context-error context
+                      "No current insn for `(current-insn)'"
+                      (rtx-strdump rtx)))
+    (let ((attr-value (obj-attr-value insn attr)))
+      (if (eq? value attr-value)
+         (rtx-true)
+         (rtx-false))))
+)
+
+; Subroutine of rtx-simplify.
+; This is the EXPR-FN argument to rtx-traverse.
+
+(define (-simplify-expr-fn rtx-obj expr mode parent-expr op-pos tstate appstuff)
+
+  ;(display "Processing ") (display (rtx-dump expr)) (newline)
+
+  (case (rtx-name expr)
+
+    ((not)
+     (let* ((arg (-rtx-traverse (rtx-alu-op-arg expr 0)
+                               'RTX
+                               (rtx-alu-op-mode expr)
+                               expr 1 tstate appstuff))
+           (no-side-effects? (not (rtx-side-effects? arg))))
+       (cond ((and no-side-effects? (rtx-false? arg))
+             (rtx-true))
+            ((and no-side-effects? (rtx-true? arg))
+             (rtx-false))
+            (else (rtx-make 'not (rtx-alu-op-mode expr) arg)))))
+
+    ((orif)
+     (let ((arg0 (-rtx-traverse (rtx-boolif-op-arg expr 0)
+                               'RTX 'DFLT expr 0 tstate appstuff))
+          (arg1 (-rtx-traverse (rtx-boolif-op-arg expr 1)
+                               'RTX 'DFLT expr 1 tstate appstuff)))
+       (let ((no-side-effects-0? (not (rtx-side-effects? arg0)))
+            (no-side-effects-1? (not (rtx-side-effects? arg1))))
+        (cond ((and no-side-effects-0? (rtx-true? arg0))
+               (rtx-true))
+              ((and no-side-effects-0? (rtx-false? arg0))
+               (rtx-canonical-bool arg1))
+              ; Value of arg0 is unknown or has side-effects.
+              ((and no-side-effects-1? (rtx-true? arg1))
+               (if no-side-effects-0?
+                   (rtx-true)
+                   (rtx-make 'orif arg0 (rtx-true))))
+              ((and no-side-effects-1? (rtx-false? arg1))
+               arg0)
+              (else
+               (rtx-make 'orif arg0 arg1))))))
+
+    ((andif)
+     (let ((arg0 (-rtx-traverse (rtx-boolif-op-arg expr 0)
+                               'RTX 'DFLT expr 0 tstate appstuff))
+          (arg1 (-rtx-traverse (rtx-boolif-op-arg expr 1)
+                               'RTX 'DFLT expr 1 tstate appstuff)))
+       (let ((no-side-effects-0? (not (rtx-side-effects? arg0)))
+            (no-side-effects-1? (not (rtx-side-effects? arg1))))
+        (cond ((and no-side-effects-0? (rtx-false? arg0))
+               (rtx-false))
+              ((and no-side-effects-0? (rtx-true? arg0))
+               (rtx-canonical-bool arg1))
+              ; Value of arg0 is unknown or has side-effects.
+              ((and no-side-effects-1? (rtx-false? arg1))
+               (if no-side-effects-0?
+                   (rtx-false)
+                   (rtx-make 'andif arg0 (rtx-false))))
+              ((and no-side-effects-1? (rtx-true? arg1))
+               arg0)
+              (else
+               (rtx-make 'andif arg0 arg1))))))
+
+    ; Fold if's to their then or else part if we can determine the
+    ; result of the test.
+    ((if)
+     (let ((test
+           ; ??? Was this but that calls rtx-traverse again which
+           ; resets the temp stack!
+           ; (rtx-simplify context (caddr expr))))
+           (-rtx-traverse (rtx-if-test expr) 'RTX 'DFLT expr 1 tstate appstuff)))
+       (cond ((rtx-true? test)
+             (-rtx-traverse (rtx-if-then expr) 'RTX mode expr 2 tstate appstuff))
+            ((rtx-false? test)
+             (if (rtx-if-else expr)
+                 (-rtx-traverse (rtx-if-else expr) 'RTX mode expr 3 tstate appstuff)
+                 ; Sanity check, mode must be VOID.
+                 (if (or (mode:eq? 'DFLT (rtx-mode expr))
+                         (mode:eq? 'VOID (rtx-mode expr)))
+                     (rtx-make 'nop)
+                     (error "rtx-simplify: non-void-mode `if' missing `else' part" expr))))
+            ; Can't simplify.
+            ; We could traverse the then/else clauses here, but it's simpler
+            ; to have our caller do it.  The cost is retraversing `test'.
+            (else #f))))
+
+    ((eq ne)
+     (let ((name (rtx-name expr))
+          (cmp-mode (rtx-cmp-op-mode expr))
+          (arg0 (-rtx-traverse (rtx-cmp-op-arg expr 0) 'RTX
+                               (rtx-cmp-op-mode expr)
+                               expr 1 tstate appstuff))
+          (arg1 (-rtx-traverse (rtx-cmp-op-arg expr 1) 'RTX
+                               (rtx-cmp-op-mode expr)
+                               expr 2 tstate appstuff)))
+       (if (or (rtx-side-effects? arg0) (rtx-side-effects? arg1))
+          (rtx-make name cmp-mode arg0 arg1)
+          (case (rtx-const-equal arg0 arg1 (rtx-kind? 'ne expr))
+            ((#f) (rtx-false))
+            ((#t) (rtx-true))
+            (else
+             ; That didn't work.  See if we have an ifield/operand with a
+             ; known range of values.
+             (case (rtx-name arg0)
+               ((ifield)
+                (let ((known-val (tstate-known-lookup tstate
+                                                      (rtx-ifield-name arg0))))
+                  (if (and known-val (rtx-kind? 'number-list known-val))
+                      (case (rtx-const-list-equal arg1 known-val (rtx-kind? 'ne expr))
+                        ((#f) (rtx-false))
+                        ((#t) (rtx-true))
+                        (else
+                         (rtx-make name cmp-mode arg0 arg1)))
+                      (rtx-make name cmp-mode arg0 arg1))))
+               ((operand)
+                (let ((known-val (tstate-known-lookup tstate
+                                                      (rtx-operand-name arg0))))
+                  (if (and known-val (rtx-kind? 'number-list known-val))
+                      (case (rtx-const-list-equal arg1 known-val (rtx-kind? 'ne expr))
+                        ((#f) (rtx-false))
+                        ((#t) (rtx-true))
+                        (else
+                         (rtx-make name cmp-mode arg0 arg1)))
+                      (rtx-make name cmp-mode arg0 arg1))))
+               (else
+                (rtx-make name cmp-mode arg0 arg1))))))))
+
+    ; Recognize attribute requests of current-insn, current-mach.
+    ((eq-attr)
+     (cond ((rtx-kind? 'current-mach (rtx-eq-attr-owner expr))
+           (rtx-simplify-eq-attr-mach expr (tstate-context tstate)))
+          ((rtx-kind? 'current-insn (rtx-eq-attr-owner expr))
+           (rtx-simplify-eq-attr-insn expr (tstate-owner tstate) (tstate-context tstate)))
+          (else expr)))
+
+    ((ifield)
+     (let ((known-val (tstate-known-lookup tstate (rtx-ifield-name expr))))
+       ; If the value is a single number, return that.
+       ; It can be one of several, represented as a number list.
+       (if (and known-val (rtx-constant? known-val))
+          known-val ; (rtx-make 'const 'INT known-val)
+          #f)))
+
+    ((operand)
+     (let ((known-val (tstate-known-lookup tstate (rtx-operand-name expr))))
+       ; If the value is a single number, return that.
+       ; It can be one of several, represented as a number list.
+       (if (and known-val (rtx-constant? known-val))
+          known-val ; (rtx-make 'const 'INT known-val)
+          #f)))
+
+    ; Leave EXPR unchanged and continue.
+    (else #f))
+)
+
+; Simplify an rtl expresion.
+; EXPR must be in source form.
+; The result is a possibly simplified EXPR, still in source form.
+;
+; CONTEXT is a <context> object, used for error messages.
+; OWNER is the owner of the expression (e.g. <insn>) or #f if there is none.
+;
+; KNOWN is an alist of known values.  Each element is (name . value) where
+; NAME is an ifield/operand name and VALUE is a const/number-list rtx.
+; FIXME: Need ranges, later.
+;
+; The following operations are performed:
+; - unselected machine dependent code is removed (eq-attr of (current-mach))
+; - if's are reduced to either then/else if we can determine that the test is
+;   a compile-time constant
+; - orif/andif
+; - eq/ne
+; - not
+;
+; ??? Will become more intelligent as needed.
+
+(define (rtx-simplify context owner expr known)
+  (-rtx-traverse expr #f 'DFLT #f 0
+                (tstate-make context owner
+                             (/fastcall-make -simplify-expr-fn)
+                             (rtx-env-empty-stack)
+                             #f #f known 0)
+                #f)
+)
+\f
+; Utilities for equation solving.
+; ??? At the moment this is only focused on ifield assertions.
+; ??? That there exist more sophisticated versions than this one can take
+; as a given.  This works for the task at hand and will evolve or be replaced
+; as necessary.
+; ??? This makes the simplifying assumption that no expr has side-effects.
+
+; Subroutine of rtx-solve.
+; This is the EXPR-FN argument to rtx-traverse.
+
+(define (-solve-expr-fn rtx-obj expr mode parent-expr op-pos tstate appstuff)
+  #f ; wip
+)
+
+; Return a boolean indicating if {expr} equates to "true".
+; If the expression can't be reduced to #f/#t, return '?.
+; ??? Use rtx-eval instead of rtx-traverse?
+;
+; EXPR must be in source form.
+; CONTEXT is a <context> object, used for error messages.
+; OWNER is the owner of the expression (e.g. <insn>) or #f if there is none.
+; KNOWN is an alist of known values.  Each element is (name . value) where
+; NAME is an ifield/operand name and VALUE is a const/number-list rtx.
+; FIXME: Need ranges, later.
+;
+; This is akin to rtx-simplify except it's geared towards solving ifield
+; assertions.  It's not unreasonable to combine them.  The worry is the
+; efficiency lost.
+; ??? Will become more intelligent as needed.
+
+(define (rtx-solve context owner expr known)
+  ; First simplify, then solve.
+  (let* ((simplified-expr (rtx-simplify context owner expr known))
+        (maybe-solved-expr
+         simplified-expr) ; FIXME: for now
+;        (-rtx-traverse simplified-expr #f 'DFLT #f 0
+;                       (tstate-make context owner
+;                                    (/fastcall-make -solve-expr-fn)
+;                                    (rtx-env-empty-stack)
+;                                    #f #f known 0)
+;                       #f))
+        )
+    (cond ((rtx-true? maybe-solved-expr) #t)
+         ((rtx-false? maybe-solved-expr) #f)
+         (else '?)))
+)
+\f
+; Subroutine of -rtx-find-op to determine if two modes are equivalent.
+; Two modes are equivalent if they're equal, or if their sem-mode fields
+; are equal.
+
+(define (-rtx-mode-equiv? m1 m2)
+  (or (eq? m1 m2)
+      (let ((mode1 (mode:lookup m1))
+           (mode2 (mode:lookup m2)))
+       (let ((s1 (mode:sem-mode mode1))
+             (s2 (mode:sem-mode mode2)))
+         (eq? (if s1 (obj:name s1) m1) (if s2 (obj:name s2) m2)))))
+)
+
+; Subroutine of semantic-compile to find OP in OP-LIST.
+; OP-LIST is a list of operand expressions: (type expr mode name indx-sel).
+; The result is the list element or #f if not found.
+; TYPE is one of -op- reg mem.
+; EXPR is the constructed `xop' rtx expression for the operand,
+;   ignored in the search.
+; MODE must match, as defined by -rtx-mode-equiv?.
+; NAME is the hardware element name, ifield name, or '-op-'.
+; INDX-SEL must match if present in either.
+;
+; ??? Does this need to take "conditionally-referenced" into account?
+
+(define (-rtx-find-op op op-list)
+  (let ((type (car op))
+       (mode (caddr op))
+       (name (cadddr op))
+       (indx-sel (car (cddddr op))))
+    ; The first cdr is to drop the dummy first arg.
+    (let loop ((op-list (cdr op-list)))
+      (cond ((null? op-list) #f)
+           ((eq? type (caar op-list))
+            (let ((try (car op-list)))
+              (if (and (eq? name (cadddr try))
+                       (-rtx-mode-equiv? mode (caddr try))
+                       (equal? indx-sel (car (cddddr try))))
+                  try
+                  (loop (cdr op-list)))))
+           (else (loop (cdr op-list))))))
+)
+
+; Subroutine of semantic-compile to determine how the operand in
+; position OP-POS of EXPR is used.
+; The result is one of 'use, 'set, 'set-quiet.
+; "use" means "input operand".
+
+(define (-rtx-ref-type expr op-pos)
+  ; operand 0 is the option list, operand 1 is the mode
+  ; (if you want to complain, fine, it's not like it would be unexpected)
+  (if (= op-pos 2)
+      (case (car expr)
+       ((set) 'set)
+       ((set-quiet clobber) 'set-quiet)
+       (else 'use))
+      'use)
+)
+
+; Subroutine of semantic-compile:process-expr!, to simplify it.
+; Looks up the operand in the current set, returns it if found,
+; otherwise adds it.
+; REF-TYPE is one of 'use, 'set, 'set-quiet.
+; Adds COND-CTI/UNCOND-CTI to SEM-ATTRS if the operand is a set of the pc.
+
+(define (-build-operand! op-name op mode tstate ref-type op-list sem-attrs)
+  ;(display (list op-name mode ref-type)) (newline) (force-output)
+  (let* ((mode (mode-real-name (if (eq? mode 'DFLT)
+                                  (op:mode op)
+                                  mode)))
+         ; The first #f is a placeholder for the object.
+        (try (list '-op- #f mode op-name #f))
+        (existing-op (-rtx-find-op try op-list)))
+
+    (if (and (pc? op)
+            (memq ref-type '(set set-quiet)))
+       (append! sem-attrs
+                (list (if (tstate-cond? tstate) 'COND-CTI 'UNCOND-CTI))))
+
+    ; If already present, return the object, otherwise add it.
+    (if existing-op
+
+       (cadr existing-op)
+
+       ; We can't set the operand number yet 'cus we don't know it.
+       ; However, when it's computed we'll need to set all associated
+       ; operands.  This is done by creating shared rtx (a la gcc) - the
+       ; operand number then need only be updated in one place.
+
+       (let ((xop (op:new-mode op mode)))
+         (op:set-cond?! xop (tstate-cond? tstate))
+         ; Set the object rtx in `try', now that we have it.
+         (set-car! (cdr try) (rtx-make 'xop xop))
+         ; Add the operand to in/out-ops.
+         (append! op-list (list try))
+         (cadr try))))
+)
+
+; Subroutine of semantic-compile:process-expr!, to simplify it.
+
+(define (-build-reg-operand! expr tstate op-list)
+  (let* ((hw-name (rtx-reg-name expr))
+        (hw (current-hw-sem-lookup-1 hw-name)))
+
+    (if hw
+       ; If the mode is DFLT, use the object's natural mode.
+       (let* ((mode (mode-real-name (if (eq? (rtx-mode expr) 'DFLT)
+                                        (obj:name (hw-mode hw))
+                                        (rtx-mode expr))))
+              (indx-sel (rtx-reg-index-sel expr))
+              ; #f is a place-holder for the object (filled in later)
+              (try (list 'reg #f mode hw-name indx-sel))
+              (existing-op (-rtx-find-op try op-list)))
+
+         ; If already present, return the object, otherwise add it.
+         (if existing-op
+
+             (cadr existing-op)
+
+             (let ((xop (apply reg (cons (tstate->estate tstate)
+                                         (cons mode
+                                               (cons hw-name indx-sel))))))
+               (op:set-cond?! xop (tstate-cond? tstate))
+               ; Set the object rtx in `try', now that we have it.
+               (set-car! (cdr try) (rtx-make 'xop xop))
+               ; Add the operand to in/out-ops.
+               (append! op-list (list try))
+               (cadr try))))
+
+       (parse-error "FIXME" "unknown reg" expr)))
+)
+
+; Subroutine of semantic-compile:process-expr!, to simplify it.
+
+(define (-build-mem-operand! expr tstate op-list)
+  (let ((mode (rtx-mode expr))
+       (indx-sel (rtx-mem-index-sel expr)))
+
+    (if (memq mode '(DFLT VOID))
+       (parse-error "FIXME" "memory must have explicit mode" expr))
+
+    (let* ((try (list 'mem #f mode 'h-memory indx-sel))
+          (existing-op (-rtx-find-op try op-list)))
+
+      ; If already present, return the object, otherwise add it.
+      (if existing-op
+
+         (cadr existing-op)
+
+         (let ((xop (apply mem (cons (tstate->estate tstate)
+                                     (cons mode indx-sel)))))
+           (op:set-cond?! xop (tstate-cond? tstate))
+           ; Set the object in `try', now that we have it.
+           (set-car! (cdr try) (rtx-make 'xop xop))
+           ; Add the operand to in/out-ops.
+           (append! op-list (list try))
+           (cadr try)))))
+)
+
+; Subroutine of semantic-compile:process-expr!, to simplify it.
+
+(define (-build-ifield-operand! expr tstate op-list)
+  (let* ((f-name (rtx-ifield-name expr))
+        (f (current-ifld-lookup f-name)))
+
+    (if (not f)
+       (parse-error "FIXME" "unknown ifield" f-name))
+
+    (let* ((mode (obj:name (ifld-mode f)))
+          (try (list '-op- #f mode f-name #f))
+          (existing-op (-rtx-find-op try op-list)))
+
+      ; If already present, return the object, otherwise add it.
+      (if existing-op
+
+         (cadr existing-op)
+
+         (let ((xop (make <operand> f-name f-name
+                          (atlist-cons (bool-attr-make 'SEM-ONLY #t)
+                                       (obj-atlist f))
+                          (obj:name (ifld-hw-type f))
+                          mode
+                          (make <hw-index> 'anonymous
+                                'ifield (ifld-mode f) f)
+                          nil #f #f)))
+           (set-car! (cdr try) (rtx-make 'xop xop))
+           (append! op-list (list try))
+           (cadr try)))))
+)
+
+; Subroutine of semantic-compile:process-expr!, to simplify it.
+;
+; ??? There are various optimizations (both space usage in ARGBUF and time
+; spent in semantic code) that can be done on code that uses index-of
+; (see i960's movq insn).  Later.
+
+(define (-build-index-of-operand! expr tstate op-list)
+  (if (not (and (rtx? (rtx-index-of-value expr))
+               (rtx-kind? 'operand (rtx-index-of-value expr))))
+      (parse-error "FIXME" "only `(index-of operand)' is currently supported"
+                  expr))
+
+  (let ((op (rtx-operand-obj (rtx-index-of-value expr))))
+    (let ((indx (op:index op)))
+      (if (not (eq? (hw-index:type indx) 'ifield))
+         (parse-error "FIXME" "only ifield indices are currently supported"
+                      expr))
+      (let* ((f (hw-index:value indx))
+            (f-name (obj:name f)))
+       ; The rest of this is identical to -build-ifield-operand!.
+       (let* ((mode (obj:name (ifld-mode f)))
+              (try (list '-op- #f mode f-name #f))
+              (existing-op (-rtx-find-op try op-list)))
+
+         ; If already present, return the object, otherwise add it.
+         (if existing-op
+
+             (cadr existing-op)
+
+             (let ((xop (make <operand> f-name f-name
+                              (atlist-cons (bool-attr-make 'SEM-ONLY #t)
+                                           (obj-atlist f))
+                              (obj:name (ifld-hw-type f))
+                              mode
+                              (make <hw-index> 'anonymous
+                                    'ifield
+                                    (ifld-mode f)
+                                    ; (send (op:type op) 'get-index-mode)
+                                    f)
+                              nil #f #f)))
+               (set-car! (cdr try) (rtx-make 'xop xop))
+               (append! op-list (list try))
+               (cadr try)))))))
+)
+
+; Build the tstate known value list for INSN.
+; This built from the ifield-assertion list.
+
+(define (-build-known-values insn)
+  (let ((expr (insn-ifield-assertion insn)))
+    (if expr
+       (case (rtx-name expr)
+         ((eq)
+          (if (and (rtx-kind? 'ifield (rtx-cmp-op-arg expr 0))
+                   (rtx-constant? (rtx-cmp-op-arg expr 1)))
+              (list (cons (rtx-ifield-name (rtx-cmp-op-arg expr 0))
+                          (rtx-cmp-op-arg expr 1)))
+              nil))
+         ((member)
+          (if (rtx-kind? 'ifield (rtx-member-value expr))
+              (list (cons (rtx-ifield-name (rtx-member-value expr))
+                          (rtx-member-set expr)))
+              nil))
+         (else nil))
+       nil))
+)
+
+; Structure to record the result of semantic-compile.
+
+(define (csem-make compiled-code inputs outputs attributes)
+  (vector compiled-code inputs outputs attributes)
+)
+
+; Accessors.
+
+(define (csem-code csem) (vector-ref csem 0))
+(define (csem-inputs csem) (vector-ref csem 1))
+(define (csem-outputs csem) (vector-ref csem 2))
+(define (csem-attrs csem) (vector-ref csem 3))
+\f
+; Traverse each element in SEM-CODE-LIST, converting them to canonical form,
+; and computing the input and output operands.
+; The result is an object of four elements (built with csem-make).
+; The first is a list of the canonical form of each element in SEM-CODE-LIST:
+; operand and ifield elements specified without `operand' or `ifield' have it
+; prepended, and operand numbers are computed for each operand.
+; Operand numbers are needed when emitting "write" handlers for LIW cpus.
+; Having the operand numbers available is also useful for efficient
+; modeling: recording operand references can be done with a bitmask (one host
+; insn), and the code to do the modeling can be kept out of the code that
+; performs the insn.
+; The second is the list of input <operand> objects.
+; The third is the list of output <operand> objects.
+; The fourth is an <attr-list> object of attributes that can be computed from
+; the semantics.
+; The possibilities are: UNCOND-CTI, COND-CTI, SKIP-CTI, DELAY-SLOT.
+; ??? Combine *-CTI into an enum attribute.
+;
+; CONTEXT is a <context> object or #f if there is none.
+; INSN is the <insn> object.
+;
+; ??? Specifying operand ordinals in the source would simplify this and speed
+; it up.  On the other hand that makes the source form more complex.  Maybe the
+; complexity will prove necessary, but following the goal of "incremental
+; complication", we don't do this yet.
+; Another way to simplify this and speed it up would be to add lists of
+; input/output operands to the instruction description.
+;
+; ??? This calls rtx-simplify which calls rtx-traverse as it's simpler to
+; simplify EXPR first, and then compile it.  On the other hand it's slower
+; (two calls to rtx-traverse!).
+
+(define (semantic-compile context insn sem-code-list)
+  (for-each (lambda (rtx) (assert (rtx? rtx)))
+           sem-code-list)
+
+  (let*
+      ; String for error messages.
+      ((errtxt "semantic compilation")
+
+       ; These record the result of traversing SEM-CODE-LIST.
+       ; They're lists of (type object mode name [args ...]).
+       ; TYPE is one of: -op- reg mem.
+       ; `-op-' is just something unique and is only used internally.
+       ; OBJECT is the constructed <operand> object.
+       ; The first element is just a dummy so that append! always works.
+       (in-ops (list (list #f)))
+       (out-ops (list (list #f)))
+
+       ; List of attributes computed from SEM-CODE-LIST.
+       ; The first element is just a dummy so that append! always works.
+       (sem-attrs (list #f))
+
+       ; Called for expressions encountered in SEM-CODE-LIST.
+       ; Don't waste cpu here, this is part of the slowest piece in CGEN.
+       (process-expr!
+       (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff)
+         (case (car expr)
+
+           ; Registers.
+           ((reg) (let ((ref-type (-rtx-ref-type parent-expr op-pos))
+                        ; ??? could verify reg is a scalar
+                        (regno (or (rtx-reg-number expr) 0)))
+                    ; The register number is either a number or an
+                    ; expression.
+                    ; ??? This is a departure from GCC RTL that might have
+                    ; significant ramifications.  On the other hand in cases
+                    ; where it matters the expression could always be
+                    ; required to reduce to a constant (or some such).
+                    (cond ((number? regno) #t)
+                          ((form? regno)
+                           (rtx-traverse-operands rtx-obj expr tstate appstuff))
+                          (else (parse-error errtxt
+                                             "invalid register number"
+                                             regno)))
+                    (-build-reg-operand! expr tstate
+                                         (if (eq? ref-type 'use)
+                                             in-ops
+                                             out-ops))))
+
+           ; Memory.
+           ((mem) (let ((ref-type (-rtx-ref-type parent-expr op-pos)))
+                    (rtx-traverse-operands rtx-obj expr tstate appstuff)
+                    (-build-mem-operand! expr tstate
+                                         (if (eq? ref-type 'use)
+                                             in-ops
+                                             out-ops))))
+
+           ; Operands.
+           ((operand) (let ((op (rtx-operand-obj expr))
+                            (ref-type (-rtx-ref-type parent-expr op-pos)))
+                        (-build-operand! (obj:name op) op mode tstate ref-type
+                                         (if (eq? ref-type 'use)
+                                             in-ops
+                                             out-ops)
+                                         sem-attrs)))
+
+           ; Give operand new name.
+           ((name) (let ((result (-rtx-traverse (caddr expr) 'RTX mode
+                                                parent-expr op-pos tstate appstuff)))
+                     (if (not (operand? result))
+                         (error "name: invalid argument:" expr result))
+                     (op:set-sem-name! result (cadr expr))
+                     ; (op:set-num! result (caddr expr))
+                     result))
+
+           ; Specify a reference to a local variable
+           ((local) expr) ; nothing to do
+
+           ; Instruction fields.
+           ((ifield) (let ((ref-type (-rtx-ref-type parent-expr op-pos)))
+                       (if (not (eq? ref-type 'use))
+                           (parse-error errtxt "can't set an `ifield'" expr))
+                       (-build-ifield-operand! expr tstate in-ops)))
+
+           ; Hardware indices.
+           ; For registers this is the register number.
+           ; For memory this is the address.
+           ; For constants, this is the constant.
+           ((index-of) (let ((ref-type (-rtx-ref-type parent-expr op-pos)))
+                         (if (not (eq? ref-type 'use))
+                             (parse-error errtxt "can't set an `index-of'" expr))
+                         (-build-index-of-operand! expr tstate in-ops)))
+
+           ; Machine generate the SKIP-CTI attribute.
+           ((skip) (append! sem-attrs (list 'SKIP-CTI)) #f)
+
+           ; Machine generate the DELAY-SLOT attribute.
+           ((delay) (append! sem-attrs (list 'DELAY-SLOT)) #f)
+
+           ; If this is a syntax expression, the operands won't have been
+           ; processed, so tell our caller we want it to by returning #f.
+           ; We do the same for non-syntax expressions to keep things
+           ; simple.  This requires collaboration with the traversal
+           ; handlers which are defined to do what we want if we return #f.
+           (else #f))))
+
+       ; Whew.  We're now ready to traverse the expression.
+       ; Traverse the expression recording the operands and building objects
+       ; for most elements in the source representation.
+       ; This also performs various simplifications.
+       ; In particular machine dependent code for non-selected machines
+       ; is discarded.
+       (compiled-exprs (map (lambda (expr)
+                             (rtx-traverse
+                              context
+                              insn
+                              (rtx-simplify context insn expr
+                                            (-build-known-values insn))
+                              process-expr!
+                              #f))
+                           sem-code-list))
+       )
+
+    ;(display "in:  ") (display in-ops) (newline)
+    ;(display "out: ") (display out-ops) (newline)
+    ;(force-output)
+
+    ; Now that we have the nub of all input and output operands,
+    ; we can assign operand numbers.  Inputs and outputs are not defined
+    ; separately, output operand numbers follow inputs.  This simplifies the
+    ; code which keeps track of such things: it can use one variable.
+    ; The assignment is defined to be arbitrary.  If there comes a day
+    ; when we need to prespecify operand numbers, revisit.
+    ; The operand lists are sorted to avoid spurious differences in generated
+    ; code (for example unnecessary extra entries can be created in the
+    ; ARGBUF struct).
+
+    ; Drop dummy first arg and sort operand lists.
+    (let ((sorted-ins
+          (sort (map (lambda (op)
+                       (rtx-xop-obj (cadr op)))
+                     (cdr in-ops))
+                (lambda (a b) (string<? (obj:name a) (obj:name b)))))
+         (sorted-outs
+          (sort (map (lambda (op)
+                       (rtx-xop-obj (cadr op)))
+                     (cdr out-ops))
+                (lambda (a b) (string<? (obj:name a) (obj:name b)))))
+         (sem-attrs (cdr sem-attrs)))
+
+      (let ((in-op-nums (iota (length sorted-ins)))
+           (out-op-nums (iota (length sorted-ins) (length sorted-outs))))
+
+       (for-each (lambda (op num) (op:set-num! op num))
+                 sorted-ins in-op-nums)
+       (for-each (lambda (op num) (op:set-num! op num))
+                 sorted-outs out-op-nums)
+
+       (let ((dump (lambda (op)
+                     (string-append "  "
+                                    (obj:name op)
+                                    " "
+                                    (number->string (op:num op))
+                                    "\n"))))
+         (logit 4
+                "Input operands:\n"
+                (map dump sorted-ins)
+                "Output operands:\n"
+                (map dump sorted-outs)
+                "End of operands.\n"))
+
+       (csem-make compiled-exprs sorted-ins sorted-outs
+                  (atlist-parse sem-attrs "" "semantic attributes")))))
+)
+\f
+; Traverse SEM-CODE-LIST, computing attributes derivable from it.
+; The result is an <attr-list> object of attributes that can be computed from
+; the semantics.
+; The possibilities are: UNCOND-CTI, COND-CTI, SKIP-CTI, DELAY-SLOT.
+; This computes the same values as semantic-compile, but for speed is
+; focused on attributes only.
+; ??? Combine *-CTI into an enum attribute.
+;
+; CONTEXT is a <context> object or #f if there is none.
+; INSN is the <insn> object.
+
+(define (semantic-attrs context insn sem-code-list)
+  (for-each (lambda (rtx) (assert (rtx? rtx)))
+           sem-code-list)
+
+  (let*
+      ; String for error messages.
+      ((errtxt "semantic attribute computation")
+
+       ; List of attributes computed from SEM-CODE-LIST.
+       ; The first element is just a dummy so that append! always works.
+       (sem-attrs (list #f))
+
+       ; Called for expressions encountered in SEM-CODE-LIST.
+       (process-expr!
+       (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff)
+         (case (car expr)
+
+           ((operand) (if (and (eq? 'pc (obj:name (rtx-operand-obj expr)))
+                               (memq (-rtx-ref-type parent-expr op-pos)
+                                     '(set set-quiet)))
+                          (append! sem-attrs
+                                   (if (tstate-cond? tstate)
+                                       ; Don't change these to '(FOO), since
+                                       ; we use append!.
+                                       (list 'COND-CTI)
+                                       (list 'UNCOND-CTI)))))
+           ((skip) (append! sem-attrs (list 'SKIP-CTI)) #f)
+           ((delay) (append! sem-attrs (list 'DELAY-SLOT)) #f)
+
+           ; If this is a syntax expression, the operands won't have been
+           ; processed, so tell our caller we want it to by returning #f.
+           ; We do the same for non-syntax expressions to keep things
+           ; simple.  This requires collaboration with the traversal
+           ; handlers which are defined to do what we want if we return #f.
+           (else #f))))
+
+       ; Traverse the expression recording the attributes.
+       (traversed-exprs (map (lambda (expr)
+                              (rtx-traverse
+                               context
+                               insn
+                               (rtx-simplify context insn expr
+                                             (-build-known-values insn))
+                               process-expr!
+                               #f))
+                            sem-code-list))
+       )
+
+    (let
+       ; Drop dummy first arg.
+       ((sem-attrs (cdr sem-attrs)))
+      (atlist-parse sem-attrs "" "semantic attributes")))
+)
diff --git a/cgen/sim-arch.scm b/cgen/sim-arch.scm
new file mode 100644 (file)
index 0000000..394f68c
--- /dev/null
@@ -0,0 +1,181 @@
+; Simulator generator support routines.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+
+; Utilities of cgen-arch.h.
+
+; Return C macro definitions of the various supported cpus.
+
+(define (-gen-cpuall-defines)
+  "" ; nothing yet
+)
+
+; Return C declarations of misc. support stuff.
+; ??? Modes are now defined in sim/common/cgen-types.h but we will need
+; target specific modes.
+
+(define (-gen-support-decls)
+  (string-append
+;   (gen-enum-decl 'mode_type "mode types"
+;                "MODE_"
+;                ; Aliases are not distinct from their real mode so ignore
+;                ; them here.
+;                (append (map list (map obj:name
+;                                       (mode-list-non-alias-values)))
+;                        '((max))))
+;   "#define MAX_MODES ((int) MODE_MAX)\n\n"
+   )
+)
+\f
+; Utilities of cgen-cpuall.h.
+
+; Subroutine of -gen-cpuall-includes.
+
+(define (-gen-cpu-header cpu prefix)
+  (string-append "#include \"" prefix (cpu-file-transform cpu) ".h\"\n")
+)
+
+; Return C code to include all the relevant headers for each cpu family,
+; conditioned on ifdef WANT_CPU_@CPU@.
+
+(define (-gen-cpuall-includes)
+  (string-list
+   "/* Include files for each cpu family.  */\n\n"
+   (string-list-map (lambda (cpu)
+                     (let* ((cpu-name (gen-sym cpu))
+                            (CPU-NAME (string-upcase cpu-name)))
+                       (string-list "#ifdef WANT_CPU_" CPU-NAME "\n"
+                                    (-gen-cpu-header cpu "eng")
+                                    "#include \"cgen-engine.h\"\n"
+                                    (-gen-cpu-header cpu "cpu")
+                                    ; FIXME: Shorten "decode" to "dec".
+                                    (-gen-cpu-header cpu "decode")
+                                    "#endif\n\n")))
+                   (current-cpu-list))
+   )
+)
+
+; Subroutine of -gen-cpuall-decls to generate cpu-specific structure entries.
+; The result is "struct <cpu>_<type-name> <member-name>;".
+; INDENT is the amount to indent by.
+; CPU is the cpu object.
+
+(define (-gen-cpu-specific-decl indent cpu type-name member-name)
+  (let* ((cpu-name (gen-sym cpu))
+        (CPU-NAME (string-upcase cpu-name)))
+    (string-append
+     "#ifdef WANT_CPU_" CPU-NAME "\n"
+     (spaces indent)
+     "struct " cpu-name "_" type-name " " member-name ";\n"
+     "#endif\n"))
+)
+
+; Return C declarations of cpu-specific structs.
+; These are defined here to achieve a simple and moderately type-safe
+; inheritance.  In the non-cpu-specific files, these structs consist of
+; just the baseclass.  In cpu-specific files, the baseclass is augmented
+; with the cpu-specific data.
+
+(define (-gen-cpuall-decls)
+  (string-list
+   (gen-argbuf-type #f)
+   (gen-scache-type #f)
+   )
+)
+\f
+; Top level generators for non-cpu-specific files.
+
+; Generate arch.h
+; This file defines non cpu family specific data about the architecture
+; and also data structures that combine all variants (e.g. cpu struct).
+; It is intended to be included before sim-basics.h and sim-base.h.
+
+(define (cgen-arch.h)
+  (logit 1 "Generating arch.h ...\n")
+
+  (string-write
+   (gen-copyright "Simulator header for @arch@."
+                 CURRENT-COPYRIGHT CURRENT-PACKAGE)
+   "#ifndef @ARCH@_ARCH_H\n"
+   "#define @ARCH@_ARCH_H\n"
+   "\n"
+   "#define TARGET_BIG_ENDIAN 1\n\n" ; FIXME
+   ;(gen-mem-macros)
+   ;"/* FIXME: split into 32/64 parts */\n"
+   ;"#define WI SI\n"
+   ;"#define UWI USI\n"
+   ;"#define AI USI\n\n"
+   -gen-cpuall-defines
+   -gen-support-decls
+   -gen-arch-model-decls
+   "#endif /* @ARCH@_ARCH_H */\n"
+   )
+)
+
+; Generate arch.c
+; This file defines non cpu family specific data about the architecture.
+
+(define (cgen-arch.c)
+  (logit 1 "Generating arch.c ...\n")
+
+  (string-write
+   (gen-copyright "Simulator support for @arch@."
+                 CURRENT-COPYRIGHT CURRENT-PACKAGE)
+   "\
+#include \"sim-main.h\"
+#include \"bfd.h\"
+
+"
+   -gen-mach-data
+   )
+)
+
+; Generate cpuall.h
+; This file pulls together all of the cpu variants .h's.
+; It is intended to be included after sim-base.h/cgen-sim.h.
+
+(define (cgen-cpuall.h)
+  (logit 1 "Generating cpuall.h ...\n")
+
+  (string-write
+   (gen-copyright "Simulator CPU header for @arch@."
+                 CURRENT-COPYRIGHT CURRENT-PACKAGE)
+   "#ifndef @ARCH@_CPUALL_H\n"
+   "#define @ARCH@_CPUALL_H\n"
+   "\n"
+   -gen-cpuall-includes
+   -gen-mach-decls
+   -gen-cpuall-decls
+   "#endif /* @ARCH@_CPUALL_H */\n"
+   )
+)
+
+; Generate ops.c
+; No longer used.
+
+(define (cgen-ops.c)
+  (logit 1 "Generating ops.c ...\n")
+
+  (string-write
+   (gen-copyright "Simulator operational support for @arch@."
+                 CURRENT-COPYRIGHT CURRENT-PACKAGE)
+   "\
+#define MEMOPS_DEFINE_INLINE
+
+#include \"config.h\"
+#include <signal.h>
+#include \"ansidecl.h\"
+#include \"bfd.h\"
+#include \"tconfig.h\"
+#include \"cgen-sim.h\"
+#include \"memops.h\"
+
+/* FIXME: wip */
+int pow2masks[] = {
+  0, 0, 1, -1, 3, -1, -1, -1, 7, -1, -1, -1, -1, -1, -1, -1, 15
+};
+
+"
+   gen-mode-defs
+   )
+)
diff --git a/cgen/sim-cpu.scm b/cgen/sim-cpu.scm
new file mode 100644 (file)
index 0000000..a8e50ba
--- /dev/null
@@ -0,0 +1,1231 @@
+; CPU family related simulator generator, excluding decoding and model support.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+
+; Notes:
+; - Add support to generate copies of semantic code and perform constant
+;   folding based on selected mach.  This would collapse out untaken branches
+;   of tests on (current-mach).
+
+; Utilities of cgen-cpu.h.
+
+; Print various parameters of the cpu family.
+; A "cpu family" here is a collection of variants of a particular architecture
+; that share sufficient commonality that they can be handled together.
+
+(define (-gen-cpu-defines)
+  (string-append
+   "\
+/* Maximum number of instructions that are fetched at a time.
+   This is for LIW type instructions sets (e.g. m32r).  */
+#define MAX_LIW_INSNS " (number->string (state-liw-insns))
+   "\n\
+
+/* Maximum number of instructions that can be executed in parallel.  */
+#define MAX_PARALLEL_INSNS " (number->string (state-parallel-insns))
+   "\n\n"
+;   (gen-enum-decl '@cpu@_virtual
+;                "@cpu@ virtual insns"
+;                "@ARCH@_INSN_" ; not @CPU@ to match CGEN_INSN_TYPE in opc.h
+;                '((x-invalid 0)
+;                  (x-before -1) (x-after -2)
+;                  (x-begin -3) (x-chain -4) (x-cti-chain -5)))
+   )
+)
+
+; Return a boolean indicating if hardware element HW needs storage allocated
+; for it in the SIM_CPU struct.
+
+(define (hw-need-storage? hw)
+  (and (register? hw) (not (obj-has-attr? hw 'VIRTUAL)))
+)
+
+; Return C type declarations of all of the hardware elements.
+; The name of the type is prepended with the cpu family name.
+
+(define (-gen-hardware-types)
+  (string-list
+   "/* CPU state information.  */\n"
+   "typedef struct {\n"
+   "  /* Hardware elements.  */\n"
+   "  struct {\n"
+   (string-list-map (lambda (hw)
+                     (string-list
+                      (gen-decl hw)
+                      (gen-obj-sanitize hw
+                                        (string-list
+                                         (send hw 'gen-get-macro)
+                                         (send hw 'gen-set-macro)))
+                      ))
+                   (find hw-need-storage? (current-hw-list)))
+   "  } hardware;\n"
+   "#define CPU_CGEN_HW(cpu) (& (cpu)->cpu_data.hardware)\n"
+   ;"  /* CPU profiling state information.  */\n"
+   ;"  struct {\n"
+   ;(string-list-map (lambda (hw) (send hw 'gen-profile-decl))
+   ;               (find hw-profilable? (current-hw-list)))
+   ;"  } profile;\n"
+   ;"#define CPU_CGEN_PROFILE(cpu) (& (cpu)->cpu_data.profile)\n"
+   "} @CPU@_CPU_DATA;\n\n"
+   ; If there are any virtual regs, output get/set macros for them.
+   (let ((virtual-regs (find (lambda (hw)
+                              (and (register? hw)
+                                   (obj-has-attr? hw 'VIRTUAL)))
+                            (current-hw-list)))
+        (orig-with-parallel? (with-parallel?))
+        (result ""))
+     (set-with-parallel?! #f)
+     (if (not (null? virtual-regs))
+        (set! result
+              (string-list
+               "/* Virtual regs.  */\n\n"
+               (string-list-map (lambda (hw)
+                                  (logit 3 "Generating get/set for " (obj:name hw)
+                                         " ...\n")
+                                  (gen-obj-sanitize hw
+                                                    (string-list
+                                                     (send hw 'gen-get-macro)
+                                                     (send hw 'gen-set-macro))))
+                                virtual-regs)
+               "\n"
+               )))
+     (set-with-parallel?! orig-with-parallel?)
+     result)
+   )
+)
+
+; Return the declaration of register access functions.
+
+(define (-gen-cpu-reg-access-decls)
+  (string-list
+   "/* Cover fns for register access.  */\n"
+   (string-list-map (lambda (hw)
+                     (gen-reg-access-decl hw
+                                          "@cpu@"
+                                          (gen-type hw)
+                                          (hw-scalar? hw)))
+                   (find register? (current-hw-list)))
+   "\n"
+   "/* These must be hand-written.  */\n"
+   "extern CPUREG_FETCH_FN @cpu@_fetch_register;\n"
+   "extern CPUREG_STORE_FN @cpu@_store_register;\n"
+   "\n")
+)
+
+; Generate type of struct holding model state while executing.
+
+(define (-gen-model-decls)
+  (logit 2 "Generating model decls ...\n")
+  (string-list
+   (string-list-map
+    (lambda (model)
+      (string-list
+       "typedef struct {\n"
+       (if (null? (model:state model))
+          "  int empty;\n" ; ensure struct isn't empty so it compiles
+          (string-map (lambda (var)
+                        (string-append "  "
+                                       (mode:c-type (mode:lookup (cadr var)))
+                                       " "
+                                       (gen-c-symbol (car var))
+                                       ";\n"))
+                      (model:state model)))
+       "} MODEL_" (string-upcase (gen-sym model)) "_DATA;\n\n"
+       ))
+    (current-model-list))
+   )
+)
+
+; Utility of -gen-extract-macros to generate a macro to define the local
+; vars to contain extracted field values and the code to assign them
+; for <iformat> IFMT.
+
+(define (-gen-extract-ifmt-macro ifmt)
+  (logit 2 "Processing format " (obj:name ifmt) " ...\n")
+  (string-list
+   (gen-define-ifmt-ifields ifmt "" #t #f)
+   (gen-extract-ifmt-ifields ifmt "" #t #f)
+   ; We don't need an extra blank line here as gen-extract-ifields adds one.
+   )
+)
+
+; Generate macros to extract instruction fields.
+
+(define (-gen-extract-macros)
+  (logit 2 "Generating extraction macros ...\n")
+  (string-list
+   "\
+/* Macros to simplify extraction, reading and semantic code.
+   These define and assign the local vars that contain the insn's fields.  */
+\n"
+   (string-list-map -gen-extract-ifmt-macro (current-ifmt-list))
+   )
+)
+
+; Utility of -gen-parallel-exec-type to generate the definition of one
+; structure in PAREXEC.
+; SFMT is an <sformat> object.
+
+(define (-gen-parallel-exec-elm sfmt)
+  (string-append
+   "    struct { /* " (obj:comment sfmt) " */\n"
+   (let ((sem-ops
+         ((if (with-parallel-write?) sfmt-out-ops sfmt-in-ops) sfmt)))
+     (if (null? sem-ops)
+        "      int empty;\n" ; ensure struct isn't empty so it compiles
+        (string-map
+         (lambda (op)
+           (logit 2 "Processing operand " (obj:name op) " of format "
+                  (obj:name sfmt) " ...\n")
+             (if (with-parallel-write?)
+                 (let ((index-type (and (op-save-index? op)
+                                        (gen-index-type op sfmt))))
+                   (string-append "      " (gen-type op)
+                                  " " (gen-sym op) ";\n"
+                                  (if index-type
+                                      (string-append "      " index-type 
+                                                     " " (gen-sym op) "_idx;\n")
+                                      "")))
+                 (string-append "      "
+                                (gen-type op)
+                                " "
+                                (gen-sym op)
+                                ";\n")))
+         sem-ops)))
+   "    } " (gen-sym sfmt) ";\n"
+   )
+)
+
+; Generate the definition of the structure that holds register values, etc.
+; for use during parallel execution.  When instructions are executed parallelly
+; either
+; - their inputs are read before their outputs are written.  Thus we have to
+; fetch the input values of several instructions before executing any of them.
+; - or their outputs are queued here first and then written out after all insns
+; have executed.
+; The fetched/queued values are stored in an array of PAREXEC structs, one
+; element per instruction.
+
+(define (-gen-parallel-exec-type)
+  (logit 2 "Generating PAREXEC type ...\n")
+  (string-append
+   (if (with-parallel-write?)
+       "/* Queued output values of an instruction.  */\n"
+       "/* Fetched input values of an instruction.  */\n")
+   "\
+
+struct parexec {
+  union {\n"
+   (string-map -gen-parallel-exec-elm (current-sfmt-list))
+   "\
+  } operands;
+  /* For conditionally written operands, bitmask of which ones were.  */
+  int written;
+};\n\n"
+   )
+)
+
+; Generate the TRACE_RECORD struct definition.
+; This struct will hold all necessary data for doing tracing and profiling
+; (e.g. register numbers).  The goal is to remove all tracing code from the
+; semantic code.  Then the fast/full distinction needn't use conditionals to
+; discard/include the tracing/profiling code.
+
+(define (-gen-trace-record-type)
+  (string-list
+   "\
+/* Collection of various things for the trace handler to use.  */
+
+typedef struct trace_record {
+  IADDR pc;
+  /* FIXME:wip */
+} TRACE_RECORD;
+\n"
+   )
+)
+\f
+; Utilities of cgen-cpu.c
+
+; Get/set fns for every register.
+
+(define (-gen-cpu-reg-access-defns)
+  (string-list-map
+   (lambda (hw)
+     (let ((scalar? (hw-scalar? hw))
+          (name (obj:name hw))
+          (getter (hw-getter hw))
+          (setter (hw-setter hw)))
+       (gen-reg-access-defn hw
+                           "@cpu@"
+                           (gen-type hw)
+                           scalar?
+                           (if getter
+                               (string-append
+                                "  return GET_"
+                                (string-upcase (gen-c-symbol name))
+                                " ("
+                                (if scalar? "" "regno")
+                                ");\n")
+                               (string-append
+                                "  return CPU ("
+                                (gen-c-symbol name)
+                                (if scalar? "" "[regno]")
+                                ");\n"))
+                           (if setter
+                               (string-append
+                                "  SET_"
+                                (string-upcase (gen-c-symbol name))
+                                " ("
+                                (if scalar? "" "regno, ")
+                                "newval);\n")
+                               (string-append
+                                "  CPU ("
+                                (gen-c-symbol name)
+                                (if scalar? "" "[regno]")
+                                ") = newval;\n")))))
+   (find (lambda (hw) (register? hw))
+        (current-hw-list)))
+)
+
+; Generate a function to record trace results in a trace record.
+
+(define (-gen-cpu-record-results)
+  (string-list
+   "\
+/* Record trace results for INSN.  */
+
+void
+@cpu@_record_trace_results (SIM_CPU *current_cpu, CGEN_INSN *insn,
+                           int *indices, TRACE_RECORD *tr)
+{\n"
+   "}\n"
+   )
+)
+\f
+; Utilities of cgen-read.c.
+; Parallel-read support is not currently used by any port and this code
+; has been left to bitrot.  Don't delete it just yet.
+
+; Return C code to fetch and save all input operands to instructions with
+; <sformat> SFMT.
+
+(define (-gen-read-args sfmt)
+  (string-map (lambda (op) (op:read op sfmt))
+             (sfmt-in-ops sfmt))
+)
+
+; Utility of -gen-read-switch to generate a switch case for <sformat> SFMT.
+
+(define (-gen-read-case sfmt)
+  (logit 2 "Processing read switch case for \"" (obj:name sfmt) "\" ...\n")
+  (string-list
+   "    CASE (read, READ_" (string-upcase (gen-sym sfmt)) ") : "
+   "/* " (obj:comment sfmt) " */\n"
+   "    {\n"
+   (if (with-scache?)
+       (gen-define-field-macro sfmt)
+       "")
+   (gen-define-parallel-operand-macro sfmt)
+   (gen-define-ifields (sfmt-iflds sfmt) (sfmt-length sfmt) "      " #f)
+   (gen-extract-ifields (sfmt-iflds sfmt) (sfmt-length sfmt) "      " #f)
+   (-gen-read-args sfmt)
+   (gen-undef-parallel-operand-macro sfmt)
+   (if (with-scache?)
+       (gen-undef-field-macro sfmt)
+       "")
+   "    }\n"
+   "    BREAK (read);\n\n"
+   )
+)
+
+; Generate the guts of a C switch statement to read insn operands.
+; The switch is based on instruction formats.
+
+(define (-gen-read-switch)
+  (logit 2 "Processing readers ...\n")
+  (string-write-map -gen-read-case (current-sfmt-list))
+)
+\f
+; Utilities of cgen-write.c.
+
+; This is the other way of implementing parallel execution support.
+; Instead of fetching all the input operands first, write all the output
+; operands and their addresses to holding variables, and then run a
+; post-processing pass to update the cpu state.
+;
+; There are separate implementations for semantics as functions and semantics
+; as one big switch.  For the function case we create a function that is a
+; switch on each semantic format and loops writing each insn's results back.
+; For the switch case we add cases to the switch to handle the write back,
+; and it is up to the pbb compiler to include them in the generated "code".
+
+; Return C code to fetch and save all output operands to instructions with
+; <sformat> SFMT.
+
+(define (-gen-write-args sfmt)
+  (string-map (lambda (op) (op:write op sfmt))
+             (sfmt-out-ops sfmt))
+)
+
+; Utility of gen-write-switch to generate a switch case for <sformat> SFMT.
+; If INSN is non-#f, it is the <insn> object of the insn in which case
+; the case is named after the insn not the format.  This is done because
+; current sem-switch support emits one handler per insn instead of per sfmt.
+
+(define (-gen-write-case sfmt insn)
+  (logit 2 "Processing write switch case for \"" (obj:name sfmt) "\" ...\n")
+  (string-list
+   (if insn
+       (string-list /indent
+                   "CASE (sem, INSN_WRITE_"
+                   (string-upcase (gen-sym insn)) ") : ")
+       (string-list /indent
+                   "case @CPU@_"
+                   (string-upcase (gen-sym sfmt)) " : "))
+   "/* "
+   (if insn
+       (string-list (insn-syntax insn))
+       (obj:comment sfmt))
+   " */\n"
+   /indent "  {\n"
+   (if insn
+       (string-list
+       /indent
+       "    SEM_ARG sem_arg = SEM_SEM_ARG (vpc, sc);\n"
+       /indent
+       "    const ARGBUF *abuf = SEM_ARGBUF (sem_arg)->fields.write.abuf;\n")
+       "")
+   (if (with-scache?)
+       (gen-define-field-macro sfmt)
+       "")
+   (gen-define-parallel-operand-macro sfmt)
+   /indent
+   "    int UNUSED written = abuf->written;\n"
+   ;(gen-define-ifields (sfmt-iflds sfmt) (sfmt-length sfmt) "  " #f) - used by cgen-read.c
+   ;(gen-extract-ifields (sfmt-iflds sfmt) (sfmt-length sfmt) "  " #f) - used by cgen-read.c
+   (if insn
+       (string-list /indent "    IADDR UNUSED pc = abuf->addr;\n")
+       "")
+   (if (and insn (insn-cti? insn))
+       (string-list /indent
+                   "    SEM_BRANCH_INIT\n") ; no trailing `;' on purpose
+       "")
+   (if insn
+       (string-list /indent "    vpc = SEM_NEXT_VPC (sem_arg, pc, 0);\n")
+       "")
+   "\n"
+   (/indent-add 4)
+   (-gen-write-args sfmt)
+   (/indent-add -4)
+   "\n"
+   (if (and insn (insn-cti? insn))
+       (string-list /indent "  SEM_BRANCH_FINI (vpc);\n")
+       "")
+   (gen-undef-parallel-operand-macro sfmt)
+   (if (with-scache?)
+       (gen-undef-field-macro sfmt)
+       "")
+   /indent "  }\n"
+   (if insn
+       (string-list /indent "  NEXT (vpc);\n")
+       (string-list /indent "  break;\n"))
+   "\n"
+   )
+)
+
+; Generate the guts of a C switch statement to write insn operands.
+; The switch is based on instruction formats.
+; ??? This will generate cases for formats that don't need it.
+; E.g. on the m32r all 32 bit insns can't be executed in parallel.
+; It's easier to generate the code anyway so we do.
+
+(define (-gen-write-switch)
+  (logit 2 "Processing writers ...\n")
+  (string-write-map (lambda (sfmt)
+                     (-gen-write-case sfmt #f))
+                   (current-sfmt-list))
+)
+\f
+; Utilities of cgen-semantics.c.
+
+; Return name of semantic fn for INSN.
+
+(define (-gen-sem-fn-name insn)
+  ;(string-append "sem_" (gen-sym insn))
+  (gen-sym insn)
+)
+
+; Return semantic fn table entry for INSN.
+
+(define (-gen-sem-fn-table-entry insn)
+  (string-list
+   "  { "
+   "@CPU@_INSN_"
+   (string-upcase (gen-sym insn))
+   ", "
+   "SEM_FN_NAME (@cpu@," (-gen-sem-fn-name insn) ")"
+   " },\n"
+   )
+)
+
+; Return C code to define a table of all semantic fns and a function to
+; add the info to the insn descriptor table.
+
+(define (-gen-semantic-fn-table)
+  (string-write
+   "\
+/* Table of all semantic fns.  */
+
+static const struct sem_fn_desc sem_fns[] = {\n"
+
+   (lambda ()
+     (string-write-map -gen-sem-fn-table-entry
+                      (non-alias-insns (current-insn-list))))
+
+   "\
+  { 0, 0 }
+};
+
+/* Add the semantic fns to IDESC_TABLE.  */
+
+void
+SEM_FN_NAME (@cpu@,init_idesc_table) (SIM_CPU *current_cpu)
+{
+  IDESC *idesc_table = CPU_IDESC (current_cpu);
+  const struct sem_fn_desc *sf;
+  int mach_num = MACH_NUM (CPU_MACH (current_cpu));
+
+  for (sf = &sem_fns[0]; sf->fn != 0; ++sf)
+    {
+      const CGEN_INSN *insn = idesc_table[sf->index].idata;
+      int valid_p = (CGEN_INSN_VIRTUAL_P (insn)
+                    || CGEN_INSN_MACH_HAS_P (insn, mach_num));
+#if FAST_P
+      if (valid_p)
+       idesc_table[sf->index].sem_fast = sf->fn;
+      else
+       idesc_table[sf->index].sem_fast = SEM_FN_NAME (@cpu@,x_invalid);
+#else
+      if (valid_p)
+       idesc_table[sf->index].sem_full = sf->fn;
+      else
+       idesc_table[sf->index].sem_full = SEM_FN_NAME (@cpu@,x_invalid);
+#endif
+    }
+}
+\n"
+   )
+)
+
+; Return C code to perform the semantics of INSN.
+
+(define (gen-semantic-code insn)
+  ; Indicate generating code for INSN.
+  ; Use the compiled form if available.
+  ; The case when they're not available is for virtual insns.
+  (let ((sem (insn-compiled-semantics insn)))
+    (if sem
+       (rtl-c-parsed VOID sem nil
+                     #:rtl-cover-fns? #t #:owner insn)
+       (rtl-c VOID (insn-semantics insn) nil
+              #:rtl-cover-fns? #t #:owner insn)))
+)
+
+; Return definition of C function to perform INSN.
+; This version handles the with-scache case.
+
+(define (-gen-scache-semantic-fn insn)
+  (logit 2 "Processing semantics for " (obj:name insn) ": \"" (insn-syntax insn) "\" ...\n")
+  (set! -with-profile? -with-profile-fn?)
+  (let ((profile? (and (with-profile?)
+                      (not (obj-has-attr? insn 'VIRTUAL))))
+       (parallel? (with-parallel?))
+       (cti? (insn-cti? insn))
+       (insn-len (insn-length-bytes insn)))
+    (string-list
+     "/* " (obj:name insn) ": " (insn-syntax insn) " */\n\n"
+     "static SEM_PC\n"
+     "SEM_FN_NAME (@cpu@," (gen-sym insn) ")"
+     (if (and parallel? (not (with-generic-write?)))
+        " (SIM_CPU *current_cpu, SEM_ARG sem_arg, PAREXEC *par_exec)\n"
+        " (SIM_CPU *current_cpu, SEM_ARG sem_arg)\n")
+     "{\n"
+     (gen-define-field-macro (insn-sfmt insn))
+     (if (and parallel? (not (with-generic-write?)))
+        (gen-define-parallel-operand-macro (insn-sfmt insn))
+        "")
+     "  ARGBUF *abuf = SEM_ARGBUF (sem_arg);\n"
+     ; Unconditionally written operands are not recorded here.
+     "  int UNUSED written = 0;\n"
+     ; The address of this insn, needed by extraction and semantic code.
+     ; Note that the address recorded in the cpu state struct is not used.
+     ; For faster engines that copy will be out of date.
+     "  IADDR UNUSED pc = abuf->addr;\n"
+     (if (and cti? (not parallel?))
+        "  SEM_BRANCH_INIT\n" ; no trailing `;' on purpose
+        "")
+     (string-list "  SEM_PC vpc = SEM_NEXT_VPC (sem_arg, pc, "
+                 (number->string insn-len)
+                 ");\n")
+     "\n"
+     (gen-semantic-code insn) "\n"
+     ; Only update what's been written if some are conditionally written.
+     ; Otherwise we know they're all written so there's no point in
+     ; keeping track.
+     (if (-any-cond-written? (insn-sfmt insn))
+        "  abuf->written = written;\n"
+        "")
+     (if (and cti? (not parallel?))
+        "  SEM_BRANCH_FINI (vpc);\n"
+        "")
+     "  return vpc;\n"
+     (if (and parallel? (not (with-generic-write?)))
+        (gen-undef-parallel-operand-macro (insn-sfmt insn))
+        "")
+     (gen-undef-field-macro (insn-sfmt insn))
+     "}\n\n"
+     ))
+)
+
+; Return definition of C function to perform INSN.
+; This version handles the without-scache case.
+; ??? TODO: multiword insns.
+
+(define (-gen-no-scache-semantic-fn insn)
+  (logit 2 "Processing semantics for " (obj:name insn) ": \"" (insn-syntax insn) "\" ...\n")
+  (set! -with-profile? -with-profile-fn?)
+  (let ((profile? (and (with-profile?)
+                      (not (obj-has-attr? insn 'VIRTUAL))))
+       (parallel? (with-parallel?))
+       (cti? (insn-cti? insn))
+       (insn-len (insn-length-bytes insn)))
+    (string-list
+     "/* " (obj:name insn) ": " (insn-syntax insn) " */\n\n"
+     "static SEM_STATUS\n"
+     "SEM_FN_NAME (@cpu@," (gen-sym insn) ")"
+     (if (and parallel? (not (with-generic-write?)))
+        " (SIM_CPU *current_cpu, SEM_ARG sem_arg, PAREXEC *par_exec, CGEN_INSN_INT insn)\n"
+        " (SIM_CPU *current_cpu, SEM_ARG sem_arg, CGEN_INSN_INT insn)\n")
+     "{\n"
+     (if (and parallel? (not (with-generic-write?)))
+        (gen-define-parallel-operand-macro (insn-sfmt insn))
+        "")
+     "  SEM_STATUS status = 0;\n" ; ??? wip
+     "  ARGBUF *abuf = SEM_ARGBUF (sem_arg);\n"
+     ; Unconditionally written operands are not recorded here.
+     "  int UNUSED written = 0;\n"
+     "  IADDR UNUSED pc = GET_H_PC ();\n"
+     (if (and cti? (not parallel?))
+        "  SEM_BRANCH_INIT\n" ; no trailing `;' on purpose
+        "")
+     (string-list "  SEM_PC vpc = SEM_NEXT_VPC (sem_arg, pc, "
+                 (number->string insn-len)
+                 ");\n")
+     (string-list (gen-define-ifmt-ifields (insn-ifmt insn) "  " #f #t)
+                 (gen-sfmt-op-argbuf-defns (insn-sfmt insn))
+                 (gen-extract-ifmt-ifields (insn-ifmt insn) "  " #f #t)
+                 (gen-sfmt-op-argbuf-assigns (insn-sfmt insn)))
+     "\n"
+     (gen-semantic-code insn) "\n"
+     ; Only update what's been written if some are conditionally written.
+     ; Otherwise we know they're all written so there's no point in
+     ; keeping track.
+     (if (-any-cond-written? (insn-sfmt insn))
+        "  abuf->written = written;\n"
+        "")
+     ; SEM_{,N}BRANCH_FINI are user-supplied macros.
+     (if (not parallel?)
+        (string-list
+         (if cti?
+             "  SEM_BRANCH_FINI (vpc, "
+             "  SEM_NBRANCH_FINI (vpc, ")
+         (gen-bool-attrs (obj-atlist insn) gen-attr-mask)
+         ");\n")
+        "")
+     "  return status;\n"
+     (if (and parallel? (not (with-generic-write?)))
+        (gen-undef-parallel-operand-macro (insn-sfmt insn))
+        "")
+     "}\n\n"
+     ))
+)
+
+(define (-gen-all-semantic-fns)
+  (logit 2 "Processing semantics ...\n")
+  (let ((insns (non-alias-insns (current-insn-list))))
+    (if (with-scache?)
+       (string-write-map -gen-scache-semantic-fn insns)
+       (string-write-map -gen-no-scache-semantic-fn insns)))
+)
+
+; Utility of -gen-sem-case to return the mask of operands always written
+; to in <sformat> SFMT.
+; ??? Not currently used.
+
+(define (-uncond-written-mask sfmt)
+  (apply + (map (lambda (op)
+                 (if (op:cond? op)
+                     0
+                     (logsll 1 (op:num op))))
+               (sfmt-out-ops sfmt)))
+)
+
+; Utility of -gen-sem-case to return #t if any operand in <sformat> SFMT is
+; conditionally written to.
+
+(define (-any-cond-written? sfmt)
+  (any-true? (map op:cond? (sfmt-out-ops sfmt)))
+)
+
+; Generate a switch case to perform INSN.
+
+(define (-gen-sem-case insn parallel?)
+  (logit 2 "Processing "
+        (if parallel? "parallel " "")
+        "semantic switch case for \"" (insn-syntax insn) "\" ...\n")
+  (set! -with-profile? -with-profile-sw?)
+  (let ((cti? (insn-cti? insn))
+       (insn-len (insn-length-bytes insn)))
+    (string-list
+     ; INSN_ is prepended here and not elsewhere to avoid name collisions
+     ; with symbols like AND, etc.
+     "  CASE (sem, "
+     "INSN_"
+     (if parallel? "PAR_" "")
+     (string-upcase (gen-sym insn)) ") : "
+     "/* " (insn-syntax insn) " */\n"
+     "{\n"
+     "  SEM_ARG sem_arg = SEM_SEM_ARG (vpc, sc);\n"
+     "  ARGBUF *abuf = SEM_ARGBUF (sem_arg);\n"
+     (if (with-scache?)
+        (gen-define-field-macro (insn-sfmt insn))
+        "")
+     (if (and parallel? (not (with-generic-write?)))
+        (gen-define-parallel-operand-macro (insn-sfmt insn))
+        "")
+     ; Unconditionally written operands are not recorded here.
+     "  int UNUSED written = 0;\n"
+     ; The address of this insn, needed by extraction and semantic code.
+     ; Note that the address recorded in the cpu state struct is not used.
+     "  IADDR UNUSED pc = abuf->addr;\n"
+     (if (and cti? (not parallel?))
+        "  SEM_BRANCH_INIT\n" ; no trailing `;' on purpose
+        "")
+     (if (with-scache?)
+        ""
+        (string-list (gen-define-ifmt-ifields (insn-ifmt insn) "  " #f #t)
+                     (gen-extract-ifmt-ifields (insn-ifmt insn) "  " #f #t)
+                     "\n"))
+     (string-list "  vpc = SEM_NEXT_VPC (sem_arg, pc, "
+                 (number->string insn-len)
+                 ");\n")
+     "\n"
+     (gen-semantic-code insn) "\n"
+     ; Only update what's been written if some are conditionally written.
+     ; Otherwise we know they're all written so there's no point in
+     ; keeping track.
+     (if (-any-cond-written? (insn-sfmt insn))
+        "  abuf->written = written;\n"
+        "")
+     (if (and cti? (not parallel?))
+        "  SEM_BRANCH_FINI (vpc);\n"
+        "")
+     (if (and parallel? (not (with-generic-write?)))
+        (gen-undef-parallel-operand-macro (insn-sfmt insn))
+        "")
+     (if (with-scache?)
+        (gen-undef-field-macro (insn-sfmt insn))
+        "")
+     "}\n"
+     "  NEXT (vpc);\n\n"
+     ))
+)
+
+(define (-gen-sem-switch)
+  (logit 2 "Processing semantic switch ...\n")
+  ; Turn parallel execution support off.
+  (let ((orig-with-parallel? (with-parallel?)))
+    (set-with-parallel?! #f)
+    (let ((result
+          (string-write-map (lambda (insn) (-gen-sem-case insn #f))
+                            (non-alias-insns (current-insn-list)))))
+      (set-with-parallel?! orig-with-parallel?)
+      result))
+)
+
+; Generate the guts of a C switch statement to execute parallel instructions.
+; This switch is included after the non-parallel instructions in the semantic
+; switch.
+;
+; ??? We duplicate the writeback case for each insn, even though we only need
+; one case per insn format.  The former keeps the code for each insn
+; together and might improve cache usage.  On the other hand the latter
+; reduces the amount of code, though it is believed that in this particular
+; instance the win isn't big enough.
+
+(define (-gen-parallel-sem-switch)
+  (logit 2 "Processing parallel insn semantic switch ...\n")
+  ; Turn parallel execution support on.
+  (let ((orig-with-parallel? (with-parallel?)))
+    (set-with-parallel?! #t)
+    (let ((result
+          (string-write-map (lambda (insn)
+                              (string-list (-gen-sem-case insn #t)
+                                           (-gen-write-case (insn-sfmt insn) insn)))
+                            (parallel-insns (current-insn-list)))))
+      (set-with-parallel?! orig-with-parallel?)
+      result))
+)
+\f
+; Top level file generators.
+
+; Generate cpu-<cpu>.h
+
+(define (cgen-cpu.h)
+  (logit 1 "Generating " (gen-cpu-name) " cpu.h ...\n")
+
+  (sim-analyze-insns!)
+
+  ; Turn parallel execution support on if cpu needs it.
+  (set-with-parallel?! (state-parallel-exec?))
+
+  ; Tell the rtl->c translator we're not the simulator.
+  ; ??? Minimizes changes in generated code until this is changed.
+  ; RTL->C happens for field decoding.
+  (rtl-c-config! #:rtl-cover-fns? #f)
+
+  (string-write
+   (gen-copyright "CPU family header for @cpu@."
+                 CURRENT-COPYRIGHT CURRENT-PACKAGE)
+   "\
+#ifndef CPU_@CPU@_H
+#define CPU_@CPU@_H
+
+"
+   -gen-cpu-defines
+   -gen-hardware-types
+   -gen-cpu-reg-access-decls
+   -gen-model-decls
+   (lambda () (gen-argbuf-type #t))
+   (lambda () (gen-scache-type #t))
+   -gen-extract-macros
+   (if (and (with-parallel?) (not (with-generic-write?)))
+       -gen-parallel-exec-type
+       "")
+   -gen-trace-record-type
+   "#endif /* CPU_@CPU@_H */\n"
+   )
+)
+
+; Generate cpu-<cpu>.c
+
+(define (cgen-cpu.c)
+  (logit 1 "Generating " (gen-cpu-name) " cpu.c ...\n")
+
+  (sim-analyze-insns!)
+
+  ; Turn parallel execution support on if cpu needs it.
+  (set-with-parallel?! (state-parallel-exec?))
+
+  ; Initialize rtl generation.
+  (rtl-c-config! #:rtl-cover-fns? #t)
+
+  (string-write
+   (gen-copyright "Misc. support for CPU family @cpu@."
+                 CURRENT-COPYRIGHT CURRENT-PACKAGE)
+   "\
+#define WANT_CPU @cpu@
+#define WANT_CPU_@CPU@
+
+#include \"sim-main.h\"
+#include \"cgen-ops.h\"
+
+"
+   -gen-cpu-reg-access-defns
+   -gen-cpu-record-results
+   )
+)
+
+; Generate read.c
+
+(define (cgen-read.c)
+  (logit 1 "Generating " (gen-cpu-name) " read.c ...\n")
+
+  (sim-analyze-insns!)
+
+  ; Turn parallel execution support off.
+  (set-with-parallel?! #f)
+
+  ; Tell the rtx->c translator we are the simulator.
+  (rtl-c-config! #:rtl-cover-fns? #t)
+
+  (string-write
+   (gen-copyright (string-append "Simulator instruction operand reader for "
+                                (current-arch-name) ".")
+                 CURRENT-COPYRIGHT CURRENT-PACKAGE)
+   "\
+#ifdef DEFINE_LABELS
+
+  /* The labels have the case they have because the enum of insn types
+     is all uppercase and in the non-stdc case the fmt symbol is built
+     into the enum name.  */
+
+  static struct {
+    int index;
+    void *label;
+  } labels[] = {\n"
+
+   (lambda ()
+     (string-write-map (lambda (insn)
+                        (string-append "    { "
+                                       "@CPU@_INSN_"
+                                       (string-upcase (gen-sym insn))
+                                       ", && case_read_READ_"
+                                       (string-upcase (gen-sym (insn-sfmt insn)))
+                                       " },\n"))
+                      (non-alias-insns (current-insn-list))))
+
+   "    { 0, 0 }
+  };
+  int i;
+
+  for (i = 0; labels[i].label != 0; ++i)
+    CPU_IDESC (current_cpu) [labels[i].index].read = labels[i].label;
+
+#undef DEFINE_LABELS
+#endif /* DEFINE_LABELS */
+
+#ifdef DEFINE_SWITCH
+
+{\n"
+   (if (with-scache?)
+       "\
+  SEM_ARG sem_arg = sc;
+  ARGBUF *abuf = SEM_ARGBUF (sem_arg);
+
+  SWITCH (read, sem_arg->read)\n"
+       "\
+  SWITCH (read, decode->read)\n")
+   "\
+    {
+
+"
+
+   -gen-read-switch
+
+   "\
+    }
+  ENDSWITCH (read) /* End of read switch.  */
+}
+
+#undef DEFINE_SWITCH
+#endif /* DEFINE_SWITCH */
+"
+   )
+)
+
+; Generate write.c
+
+(define (cgen-write.c)
+  (logit 1 "Generating " (gen-cpu-name) " write.c ...\n")
+
+  (sim-analyze-insns!)
+
+  ; Turn parallel execution support off.
+  (set-with-parallel?! #f)
+
+  ; Tell the rtx->c translator we are the simulator.
+  (rtl-c-config! #:rtl-cover-fns? #t)
+
+  (string-write
+   (gen-copyright (string-append "Simulator instruction operand writer for "
+                                (current-arch-name) ".")
+                 CURRENT-COPYRIGHT CURRENT-PACKAGE)
+   "\
+/* Write cached results of 1 or more insns executed in parallel.  */
+
+void
+@cpu@_parallel_write (SIM_CPU *cpu, SCACHE *sbufs, PAREXEC *pbufs, int ninsns)
+{\n"
+   (if (with-scache?)
+       "\
+  SEM_ARG sem_arg = sc;
+  ARGBUF *abuf = SEM_ARGBUF (sem_arg);\n"
+       "")
+   "\
+
+  do
+    {
+      ARGBUF *abuf = SEM_ARGBUF (sbufs);
+
+      switch (abuf->idesc->write)
+       {
+\n"
+
+   ;(/indent-add 8)
+   -gen-write-switch
+   ;(/indent-add -8)
+
+   "\
+       }
+    }
+  while (--ninsns > 0);
+}
+"
+   )
+)
+
+; Generate semantics.c
+; Each instruction is implemented in its own function.
+
+(define (cgen-semantics.c)
+  (logit 1 "Generating " (gen-cpu-name) " semantics.c ...\n")
+
+  (sim-analyze-insns!)
+
+  ; Turn parallel execution support on if cpu needs it.
+  (set-with-parallel?! (state-parallel-exec?))
+
+  ; Tell the rtx->c translator we are the simulator.
+  (rtl-c-config! #:rtl-cover-fns? #t)
+
+  (string-write
+   (gen-copyright "Simulator instruction semantics for @cpu@."
+                 CURRENT-COPYRIGHT CURRENT-PACKAGE)
+   "\
+#define WANT_CPU @cpu@
+#define WANT_CPU_@CPU@
+
+#include \"sim-main.h\"
+#include \"cgen-mem.h\"
+#include \"cgen-ops.h\"
+
+#undef GET_ATTR
+#define GET_ATTR(cpu, num, attr) \
+CGEN_ATTR_VALUE (NULL, abuf->idesc->attrs, CGEN_INSN_##attr)
+
+/* This is used so that we can compile two copies of the semantic code,
+   one with full feature support and one without that runs fast(er).
+   FAST_P, when desired, is defined on the command line, -DFAST_P=1.  */
+#if FAST_P
+#define SEM_FN_NAME(cpu,fn) XCONCAT3 (cpu,_semf_,fn)
+#undef TRACE_RESULT
+#define TRACE_RESULT(cpu, abuf, name, type, val)
+#else
+#define SEM_FN_NAME(cpu,fn) XCONCAT3 (cpu,_sem_,fn)
+#endif
+\n"
+
+   -gen-all-semantic-fns
+   ; Put the table at the end so we don't have to declare all the sem fns.
+   -gen-semantic-fn-table
+   )
+)
+
+; Generate sem-switch.c.
+; Each instruction is a case in a switch().
+; This file consists of just the switch().  It is included by mainloop.c.
+
+(define (cgen-sem-switch.c)
+  (logit 1 "Generating " (gen-cpu-name) " sem-switch.c ...\n")
+
+  (sim-analyze-insns!)
+
+  ; Turn parallel execution support off.
+  ; It is later turned on/off when generating the actual semantic code.
+  (set-with-parallel?! #f)
+
+  ; Tell the rtx->c translator we are the simulator.
+  (rtl-c-config! #:rtl-cover-fns? #t)
+
+  (string-write
+   (gen-copyright "Simulator instruction semantics for @cpu@."
+                 CURRENT-COPYRIGHT CURRENT-PACKAGE)
+
+   "\
+#ifdef DEFINE_LABELS
+
+  /* The labels have the case they have because the enum of insn types
+     is all uppercase and in the non-stdc case the insn symbol is built
+     into the enum name.  */
+
+  static struct {
+    int index;
+    void *label;
+  } labels[] = {\n"
+
+   (lambda ()
+     (string-write-map (lambda (insn)
+                        (string-append "    { "
+                                       "@CPU@_INSN_"
+                                       (string-upcase (gen-sym insn))
+                                       ", && case_sem_INSN_"
+                                       (string-upcase (gen-sym insn))
+                                       " },\n"))
+                      (non-alias-insns (current-insn-list))))
+
+   (if (state-parallel-exec?)
+       (lambda ()
+        (string-write-map (lambda (insn)
+                            (string-append "    { "
+                                           "@CPU@_INSN_PAR_"
+                                           (string-upcase (gen-sym insn))
+                                           ", && case_sem_INSN_PAR_"
+                                           (string-upcase (gen-sym insn))
+                                           " },\n"
+                                           "    { "
+                                           "@CPU@_INSN_WRITE_"
+                                           (string-upcase (gen-sym insn))
+                                           ", && case_sem_INSN_WRITE_"
+                                           (string-upcase (gen-sym insn))
+                                           " },\n"))
+                          (parallel-insns (current-insn-list))))
+       "")
+
+   "    { 0, 0 }
+  };
+  int i;
+
+  for (i = 0; labels[i].label != 0; ++i)
+    {
+#if FAST_P
+      CPU_IDESC (current_cpu) [labels[i].index].sem_fast_lab = labels[i].label;
+#else
+      CPU_IDESC (current_cpu) [labels[i].index].sem_full_lab = labels[i].label;
+#endif
+    }
+
+#undef DEFINE_LABELS
+#endif /* DEFINE_LABELS */
+
+#ifdef DEFINE_SWITCH
+
+/* If hyper-fast [well not unnecessarily slow] execution is selected, turn
+   off frills like tracing and profiling.  */
+/* FIXME: A better way would be to have TRACE_RESULT check for something
+   that can cause it to be optimized out.  Another way would be to emit
+   special handlers into the instruction \"stream\".  */
+
+#if FAST_P
+#undef TRACE_RESULT
+#define TRACE_RESULT(cpu, abuf, name, type, val)
+#endif
+
+#undef GET_ATTR
+#define GET_ATTR(cpu, num, attr) \
+CGEN_ATTR_VALUE (NULL, abuf->idesc->attrs, CGEN_INSN_##attr)
+
+{
+
+#if WITH_SCACHE_PBB
+
+/* Branch to next handler without going around main loop.  */
+#define NEXT(vpc) goto * SEM_ARGBUF (vpc) -> semantic.sem_case
+SWITCH (sem, SEM_ARGBUF (vpc) -> semantic.sem_case)
+
+#else /* ! WITH_SCACHE_PBB */
+
+#define NEXT(vpc) BREAK (sem)
+#ifdef __GNUC__
+#if FAST_P
+  SWITCH (sem, SEM_ARGBUF (sc) -> idesc->sem_fast_lab)
+#else
+  SWITCH (sem, SEM_ARGBUF (sc) -> idesc->sem_full_lab)
+#endif
+#else
+  SWITCH (sem, SEM_ARGBUF (sc) -> idesc->num)
+#endif
+
+#endif /* ! WITH_SCACHE_PBB */
+
+    {
+
+"
+
+   -gen-sem-switch
+
+   (if (state-parallel-exec?)
+       -gen-parallel-sem-switch
+       "")
+
+   "
+    }
+  ENDSWITCH (sem) /* End of semantic switch.  */
+
+  /* At this point `vpc' contains the next insn to execute.  */
+}
+
+#undef DEFINE_SWITCH
+#endif /* DEFINE_SWITCH */
+"
+   )
+)
+
+; Generate mainloop.in.
+; ??? Not currently used.
+
+(define (cgen-mainloop.in)
+  (logit 1 "Generating mainloop.in ...\n")
+
+  (string-write
+   "cat <<EOF >/dev/null\n"
+   (gen-copyright "Simulator main loop for @arch@."
+                 CURRENT-COPYRIGHT CURRENT-PACKAGE)
+   "EOF\n"
+   "\
+
+# Syntax:
+# /bin/sh mainloop.in init|support|{full,fast}-{extract,exec}-{scache,nocache}
+
+# ??? There's lots of conditional compilation here.
+# After a few more ports are done, revisit.
+
+case \"x$1\" in
+
+xsupport)
+
+cat <<EOF
+/*xsupport*/
+EOF
+
+;;
+
+xinit)
+
+cat <<EOF
+/*xinit*/
+EOF
+
+;;
+
+xfull-extract-* | xfast-extract-*)
+
+cat <<EOF
+{
+"
+   (rtl-c VOID insn-extract nil #:rtl-cover-fns? #t)
+"}
+EOF
+
+;;
+
+xfull-exec-* | xfast-exec-*)
+
+cat <<EOF
+{
+"
+   (rtl-c VOID insn-execute nil #:rtl-cover-fns? #t)
+"}
+EOF
+
+;;
+
+*)
+  echo \"Invalid argument to mainloop.in: $1\" >&2
+  exit 1
+  ;;
+
+esac
+"
+   )
+)
diff --git a/cgen/sim-decode.scm b/cgen/sim-decode.scm
new file mode 100644 (file)
index 0000000..2285c28
--- /dev/null
@@ -0,0 +1,592 @@
+; Decoder generation.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+
+; Names of various global vars.
+
+; Name of insn descriptor table var.
+(define IDESC-TABLE-VAR "@cpu@_insn_data")
+
+; Return decode entries for each insn.
+; ??? At one point we generated one variable per instruction rather than one
+; big array.  It doesn't matter too much (yet).  Generating one big array is
+; simpler.
+
+(define (-gen-decode-insn-globals insn-list)
+  ; Print the higher detailed stuff at higher verbosity.
+  (logit 2 "Processing decode insn globals ...\n")
+
+  (string-write
+
+   (if (and (with-parallel?) (not (with-parallel-only?)))
+       "\
+/* Insn can't be executed in parallel.
+   Or is that \"do NOt Pass to Air defense Radar\"? :-) */
+#define NOPAR (-1)
+\n"
+       "")
+
+   "\
+/* The instruction descriptor array.
+   This is computed at runtime.  Space for it is not malloc'd to save a
+   teensy bit of cpu in the decoder.  Moving it to malloc space is trivial
+   but won't be done until necessary (we don't currently support the runtime
+   addition of instructions nor an SMP machine with different cpus).  */
+static IDESC " IDESC-TABLE-VAR "[@CPU@_INSN_MAX];
+
+/* Commas between elements are contained in the macros.
+   Some of these are conditionally compiled out.  */
+
+static const struct insn_sem @cpu@_insn_sem[] =
+{\n"
+
+   (string-list-map
+    (lambda (insn)
+      (let ((name (gen-sym insn))
+           (pbb? (obj-has-attr? insn 'PBB))
+           (virtual? (insn-virtual? insn)))
+       (string-list
+        "  { "
+        (if virtual?
+            (string-append "VIRTUAL_INSN_" (string-upcase name) ", ")
+            (string-append "@ARCH@_INSN_" (string-upcase name) ", "))
+        "@CPU@_INSN_" (string-upcase name) ", "
+        "@CPU@_" (-gen-fmt-enum (insn-sfmt insn))
+        (if (and (with-parallel?) (not (with-parallel-only?)))
+            (string-list
+             (if (insn-parallel? insn)
+                 (string-append ", @CPU@_INSN_PAR_"
+                                (string-upcase name)
+                                ", "
+                                (if (with-parallel-read?)
+                                    "@CPU@_INSN_READ_"
+                                    "@CPU@_INSN_WRITE_")
+                                (string-upcase name))
+                 ", NOPAR, NOPAR "))
+            "")
+        " },\n")))
+    insn-list)
+
+   "\
+};
+
+static const struct insn_sem @cpu@_insn_sem_invalid = {
+  VIRTUAL_INSN_X_INVALID, @CPU@_INSN_X_INVALID, @CPU@_SFMT_EMPTY"
+   (if (and (with-parallel?) (not (with-parallel-only?)))
+       ", NOPAR, NOPAR"
+       "")
+   "
+};
+\n"
+   )
+)
+
+; Return enum name of format FMT.
+
+(define (-gen-fmt-enum fmt)
+  (string-upcase (gen-sym fmt))
+)
+\f
+; Generate decls for the insn descriptor table type IDESC.
+
+(define (-gen-idesc-decls)
+  (string-append "\
+extern const IDESC *@cpu@_decode (SIM_CPU *, IADDR,
+                                  CGEN_INSN_INT,"
+  (if (adata-integral-insn? CURRENT-ARCH)
+      " CGEN_INSN_INT,\n"
+      "\n")
+  "\
+                                  ARGBUF *);
+extern void @cpu@_init_idesc_table (SIM_CPU *);
+extern void @cpu@_sem_init_idesc_table (SIM_CPU *);
+extern void @cpu@_semf_init_idesc_table (SIM_CPU *);
+\n")
+)
+
+; Return definition of C function to initialize the IDESC table.
+; @cpu@_init_idesc_table is defined here as it depends on with-parallel?
+; and thus can't be defined in sim/common.
+
+(define (-gen-idesc-init-fn)
+  (string-append "\
+/* Initialize an IDESC from the compile-time computable parts.  */
+
+static INLINE void
+init_idesc (SIM_CPU *cpu, IDESC *id, const struct insn_sem *t)
+{
+  const CGEN_INSN *insn_table = CGEN_CPU_INSN_TABLE (CPU_CPU_DESC (cpu))->init_entries;
+
+  id->num = t->index;
+  id->sfmt = t->sfmt;
+  if ((int) t->type <= 0)
+    id->idata = & cgen_virtual_insn_table[- (int) t->type];
+  else
+    id->idata = & insn_table[t->type];
+  id->attrs = CGEN_INSN_ATTRS (id->idata);
+  /* Oh my god, a magic number.  */
+  id->length = CGEN_INSN_BITSIZE (id->idata) / 8;
+
+#if WITH_PROFILE_MODEL_P
+  id->timing = & MODEL_TIMING (CPU_MODEL (cpu)) [t->index];
+  {
+    SIM_DESC sd = CPU_STATE (cpu);
+    SIM_ASSERT (t->index == id->timing->num);
+  }
+#endif
+
+  /* Semantic pointers are initialized elsewhere.  */
+}
+
+/* Initialize the instruction descriptor table.  */
+
+void
+@cpu@_init_idesc_table (SIM_CPU *cpu)
+{
+  IDESC *id,*tabend;
+  const struct insn_sem *t,*tend;
+  int tabsize = @CPU@_INSN_MAX;
+  IDESC *table = " IDESC-TABLE-VAR ";
+
+  memset (table, 0, tabsize * sizeof (IDESC));
+
+  /* First set all entries to the `invalid insn'.  */
+  t = & @cpu@_insn_sem_invalid;
+  for (id = table, tabend = table + tabsize; id < tabend; ++id)
+    init_idesc (cpu, id, t);
+
+  /* Now fill in the values for the chosen cpu.  */
+  for (t = @cpu@_insn_sem, tend = t + sizeof (@cpu@_insn_sem) / sizeof (*t);
+       t != tend; ++t)
+    {
+      init_idesc (cpu, & table[t->index], t);\n"
+
+   (if (and (with-parallel?) (not (with-parallel-only?)))
+       "\
+      if (t->par_index != NOPAR)
+       {
+         init_idesc (cpu, &table[t->par_index], t);
+         table[t->index].par_idesc = &table[t->par_index];
+       }\n"
+       "")
+
+   (if (and (with-parallel-write?) (not (with-parallel-only?)))
+       "\
+      if (t->par_index != NOPAR)
+       {
+         init_idesc (cpu, &table[t->write_index], t);
+         table[t->par_index].par_idesc = &table[t->write_index];
+       }\n"
+       "")
+
+   "\
+    }
+
+  /* Link the IDESC table into the cpu.  */
+  CPU_IDESC (cpu) = table;
+}
+
+")
+)
+\f
+; Instruction field extraction support.
+; Two implementations are provided, one for !with-scache and one for
+; with-scache.
+;
+; Extracting ifields is a three phase process.  First the ifields are
+; extracted and stored in local variables.  Then any ifields requiring
+; additional processing for operands are handled.  Then in the with-scache
+; case the results are stored in a struct for later retrieval by the semantic
+; code.
+;
+; The !with-scache case does this processing in the semantic function,
+; except it doesn't need the last step (it doesn't need to store the results
+; in a struct for later use).
+;
+; The with-scache case extracts the ifields in the decode function.
+; Furthermore, we use <sformat-argbuf> to reduce the quantity of structures
+; created (this helps semantic-fragment pbb engines).
+
+; Return C code to record <ifield> F for the semantic handler
+; in a local variable rather than an ARGBUF struct.
+
+(define (-gen-record-argbuf-ifld f sfmt)
+  (string-append "  " (gen-ifld-argbuf-ref f)
+                " = " (gen-extracted-ifld-value f) ";\n")
+)
+
+; Return three of arguments to TRACE:
+; string argument to fprintf, character indicating type of third arg, value.
+; The type is one of: x.
+
+(define (-gen-trace-argbuf-ifld f sfmt)
+  (string-append
+   ; FIXME: Add method to return fprintf format string.
+   ", \"" (gen-sym f) " 0x%x\""
+   ", 'x'"
+   ", " (gen-extracted-ifld-value f))
+)
+\f
+; Instruction field extraction support cont'd.
+; Hardware support.
+
+; gen-extract method.
+; For the default case we use the ifield as is, which is output elsewhere.
+
+(method-make!
+ <hardware-base> 'gen-extract
+ (lambda (self op sfmt local?)
+   "")
+)
+
+; gen-trace-extract method.
+; Return appropriate arguments for TRACE_EXTRACT.
+
+(method-make!
+ <hardware-base> 'gen-trace-extract
+ (lambda (self op sfmt)
+   "")
+)
+
+; Extract the necessary fields into ARGBUF.
+
+(method-make!
+ <hw-register> 'gen-extract
+ (lambda (self op sfmt local?)
+   (if (hw-cache-addr? self)
+       (string-append "  "
+                     (if local?
+                         (gen-hw-index-argbuf-name (op:index op))
+                         (gen-hw-index-argbuf-ref (op:index op)))
+                     " = & "
+                     (gen-cpu-ref (gen-sym (op:type op)))
+                     (gen-array-ref (gen-extracted-ifld-value (op-ifield op)))
+                     ";\n")
+       ""))
+)
+
+; Return appropriate arguments for TRACE_EXTRACT.
+
+(method-make!
+ <hw-register> 'gen-trace-extract
+ (lambda (self op sfmt)
+   (if (hw-cache-addr? self)
+       (string-append
+       ; FIXME: Add method to return fprintf format string.
+       ", \"" (gen-sym op) " 0x%x\""
+       ", 'x'"
+       ", " (gen-extracted-ifld-value (op-ifield op)))
+       ""))
+)
+
+; Extract the necessary fields into ARGBUF.
+
+(method-make!
+ <hw-address> 'gen-extract
+ (lambda (self op sfmt local?)
+   (string-append "  "
+                 (if local?
+                     (gen-hw-index-argbuf-name (op:index op))
+                     (gen-hw-index-argbuf-ref (op:index op)))
+                 " = "
+                 (gen-extracted-ifld-value (op-ifield op))
+                 ";\n"))
+)
+
+; Return appropriate arguments for TRACE_EXTRACT.
+
+(method-make!
+ <hw-address> 'gen-trace-extract
+ (lambda (self op sfmt)
+   (string-append
+    ; FIXME: Add method to return fprintf format string.
+    ", \"" (gen-sym op) " 0x%x\""
+    ", 'x'"
+    ", " (gen-extracted-ifld-value (op-ifield op))))
+)
+\f
+; Instruction field extraction support cont'd.
+; Operand support.
+
+; Return C code to record the field for the semantic handler.
+; In the case of a register, this is usually the address of the register's
+; value (if CACHE-ADDR).
+; LOCAL? indicates whether to record the value in a local variable or in
+; the ARGBUF struct.
+; ??? Later allow target to provide an `extract' expression.
+
+(define (-gen-op-extract op sfmt local?)
+  (send (op:type op) 'gen-extract op sfmt local?)
+)
+
+; Return three of arguments to TRACE_EXTRACT:
+; string argument to fprintf, character indicating type of third arg, value.
+; The type is one of: x.
+
+(define (-gen-op-trace-extract op sfmt)
+  (send (op:type op) 'gen-trace-extract op sfmt)
+)
+
+; Return C code to define local vars to hold processed ifield data for
+; <sformat> SFMT.
+; This is used when !with-scache.
+; Definitions of the extracted ifields is handled elsewhere.
+
+(define (gen-sfmt-op-argbuf-defns sfmt)
+  (let ((operands (sfmt-extracted-operands sfmt)))
+    (string-list-map (lambda (op)
+                      (let ((var-spec (sfmt-op-sbuf-elm op sfmt)))
+                        (if var-spec
+                            (string-append "  "
+                                           (cadr var-spec)
+                                           " "
+                                           (car var-spec)
+                                           ";\n")
+                            "")))
+                    operands))
+)
+
+; Return C code to assign values to the local vars that hold processed ifield
+; data for <sformat> SFMT.
+; This is used when !with-scache.
+; Assignment of the extracted ifields is handled elsewhere.
+
+(define (gen-sfmt-op-argbuf-assigns sfmt)
+  (let ((operands (sfmt-extracted-operands sfmt)))
+    (string-list-map (lambda (op)
+                      (-gen-op-extract op sfmt #t))
+                    operands))
+)
+\f
+; Instruction field extraction support cont'd.
+; Emit extraction section of decode function.
+
+; Return C code to record insn field data for <sformat> SFMT.
+; This is used when with-scache.
+
+(define (-gen-record-args sfmt)
+  (let ((operands (sfmt-extracted-operands sfmt))
+       (iflds (sfmt-needed-iflds sfmt)))
+    (string-list
+     "  /* Record the fields for the semantic handler.  */\n"
+     (string-list-map (lambda (f) (-gen-record-argbuf-ifld f sfmt))
+                     iflds)
+     (string-list-map (lambda (op) (-gen-op-extract op sfmt #f))
+                     operands)
+     "  TRACE_EXTRACT (current_cpu, abuf, (current_cpu, pc, "
+     "\"" (gen-sym sfmt) "\""
+     (string-list-map (lambda (f) (-gen-trace-argbuf-ifld f sfmt))
+                     iflds)
+     (string-list-map (lambda (op) (-gen-op-trace-extract op sfmt))
+                     operands)
+     ", (char *) 0));\n"
+     ))
+)
+
+; Return C code to record insn field data for profiling.
+; Also recorded are operands not mentioned in the fields but mentioned
+; in the semantic code.
+;
+; FIXME: Register usage may need to be tracked as an array of longs.
+; If there are more than 32 regs, we can't know which until build time.
+; ??? For now we only handle reg sets of 32 or less.
+;
+; ??? The other way to obtain register numbers is to defer computing them
+; until they're actually needed.  It will speed up execution when not doing
+; profiling, though the speed up is only for the extraction phase.
+; On the other hand the current way has one memory reference per register
+; number in the profiling routines.  For RISC this can be a lose, though for
+; more complicated instruction sets it could be a win as all the computation
+; is kept to the extraction phase.  If someone wants to put forth some real
+; data, this might then be changed (or at least noted).
+
+(define (-gen-record-profile-args sfmt)
+  (let ((in-ops (find op-profilable? (sfmt-in-ops sfmt)))
+       (out-ops (find op-profilable? (sfmt-out-ops sfmt)))
+       )
+    (if (and (null? in-ops) (null? out-ops))
+       ""
+       (string-list
+        "#if WITH_PROFILE_MODEL_P\n"
+        "  /* Record the fields for profiling.  */\n"
+        "  if (PROFILE_MODEL_P (current_cpu))\n"
+        "    {\n"
+        (string-list-map (lambda (op) (op:record-profile op sfmt #f))
+                         in-ops)
+        (string-list-map (lambda (op) (op:record-profile op sfmt #t))
+                         out-ops)
+        "    }\n"
+        "#endif\n"
+        )))
+)
+
+; Return C code that extracts the fields of <sformat> SFMT.
+;
+; Extraction is based on formats to reduce the amount of code generated.
+; However, we also need to emit code which records the hardware elements used
+; by the semantic code.  This is currently done by recording this information
+; with the format.
+
+(define (-gen-extract-case sfmt)
+  (logit 2 "Processing extractor for \"" (sfmt-key sfmt) "\" ...\n")
+  (string-list
+   " extract_" (gen-sym sfmt) ":\n"
+   "  {\n"
+   "    const IDESC *idesc = &" IDESC-TABLE-VAR "[itype];\n"
+   "    CGEN_INSN_INT insn = "
+   (if (adata-integral-insn? CURRENT-ARCH)
+       "entire_insn;\n"
+       "base_insn;\n")
+   (gen-define-field-macro sfmt)
+   (gen-define-ifields (sfmt-iflds sfmt) (sfmt-length sfmt) "    " #f)
+   "\n"
+   (gen-extract-ifields (sfmt-iflds sfmt) (sfmt-length sfmt) "    " #f)
+   "\n"
+   (-gen-record-args sfmt)
+   "\n"
+   (-gen-record-profile-args sfmt)
+   (gen-undef-field-macro sfmt)
+   "    return idesc;\n"
+   "  }\n\n"
+   )
+)
+
+; For each format, return its extraction function.
+
+(define (-gen-all-extractors)
+  (logit 2 "Processing extractors ...\n")
+  (string-list-map -gen-extract-case (current-sfmt-list))
+)
+\f
+; Generate top level decoder.
+; INITIAL-BITNUMS is a target supplied list of bit numbers to use to
+; build the first decode table.  If nil, we compute 8 bits of it (FIXME)
+; ourselves.
+; LSB0? is non-#f if bit number 0 is the least significant bit.
+; FIXME: Need to be perfect for every subtable, or allow target more control.
+; Leave for later (and don't give target more control until oodles of effort
+; have been spent trying to be perfect! ... or close enough).
+
+(define (-gen-decode-fn insn-list initial-bitnums lsb0?)
+
+  ; Compute the initial DECODE-BITSIZE as the minimum of all insn lengths.
+  ; The caller of @cpu@_decode must fetch and pass exactly this number of bits
+  ; of the instruction.
+  ; ??? Make this a parameter later but only if necessary.
+
+  (let ((decode-bitsize (apply min (map insn-base-mask-length insn-list))))
+
+    ; Compute INITIAL-BITNUMS if not supplied.
+    ; 0 is passed for the start bit (it is independent of lsb0?)
+    (if (null? initial-bitnums)
+       (set! initial-bitnums (decode-get-best-bits insn-list nil
+                                                   0 ; startbit
+                                                   8 ; max
+                                                   decode-bitsize
+                                                   lsb0?)))
+
+    ; All set.  gen-decoder does the hard part, we just print out the result. 
+    (let ((decode-code (gen-decoder insn-list initial-bitnums
+                                   decode-bitsize
+                                   "    " lsb0?
+                                   (current-insn-lookup 'x-invalid))))
+
+      (string-write
+       "\
+/* Given an instruction, return a pointer to its IDESC entry.  */
+
+const IDESC *
+@cpu@_decode (SIM_CPU *current_cpu, IADDR pc,
+              CGEN_INSN_INT base_insn,"
+       (if (adata-integral-insn? CURRENT-ARCH)
+          " CGEN_INSN_INT entire_insn,\n"
+          "\n")
+       "\
+              ARGBUF *abuf)
+{
+  /* Result of decoder.  */
+  @CPU@_INSN_TYPE itype;
+
+  {
+    CGEN_INSN_INT insn = base_insn;
+\n"
+
+       decode-code
+
+       "\
+  }
+\n"
+
+       (if (with-scache?)
+           (string-list "\
+  /* The instruction has been decoded, now extract the fields.  */\n\n"
+            -gen-all-extractors)
+          ; Without the scache, extraction is defered until the semantic code.
+          (string-list "\
+  /* Extraction is defered until the semantic code.  */
+
+ done:
+  return &" IDESC-TABLE-VAR "[itype];\n"))
+
+       "\
+}\n"
+       )))
+)
+\f
+; Entry point.  Generate decode.h.
+
+(define (cgen-decode.h)
+  (logit 1 "Generating " (gen-cpu-name) " decode.h ...\n")
+
+  (sim-analyze-insns!)
+
+  ; Turn parallel execution support on if cpu needs it.
+  (set-with-parallel?! (state-parallel-exec?))
+
+  (string-write
+   (gen-copyright "Decode header for @cpu@."
+                 CURRENT-COPYRIGHT CURRENT-PACKAGE)
+   "\
+#ifndef @CPU@_DECODE_H
+#define @CPU@_DECODE_H
+
+"
+   -gen-idesc-decls
+   (lambda () (gen-cpu-insn-enum-decl (current-cpu)
+                                     (non-multi-insns (non-alias-insns (current-insn-list)))))
+   (lambda () (gen-sfmt-enum-decl (current-sfmt-list)))
+   gen-model-fn-decls
+   "#endif /* @CPU@_DECODE_H */\n"
+   )
+)
+\f
+; Entry point.  Generate decode.c.
+
+(define (cgen-decode.c)
+  (logit 1 "Generating " (gen-cpu-name) " decode.c ...\n")
+
+  (sim-analyze-insns!)
+
+  ; Turn parallel execution support on if cpu needs it.
+  (set-with-parallel?! (state-parallel-exec?))
+
+  ; Tell the rtx->c translator we are the simulator.
+  (rtl-c-config! #:rtl-cover-fns? #t)
+
+  (string-write
+   (gen-copyright "Simulator instruction decoder for @cpu@."
+                 CURRENT-COPYRIGHT CURRENT-PACKAGE)
+   "\
+#define WANT_CPU @cpu@
+#define WANT_CPU_@CPU@
+
+#include \"sim-main.h\"
+#include \"sim-assert.h\"\n\n"
+
+   (lambda () (-gen-decode-insn-globals (non-multi-insns (non-alias-insns (current-insn-list)))))
+   -gen-idesc-init-fn
+   (lambda () (-gen-decode-fn (non-multi-insns (real-insns (current-insn-list)))
+                             (state-decode-assist)
+                             (current-arch-insn-lsb0?)))
+   )
+)
diff --git a/cgen/sim-model.scm b/cgen/sim-model.scm
new file mode 100644 (file)
index 0000000..eb42c93
--- /dev/null
@@ -0,0 +1,394 @@
+; Simulator model support, plus misc. things associated with a cpu family.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+
+; Return C code to define cpu implementation properties.
+
+(define (-gen-cpu-imp-properties)
+  (string-list
+   "\
+/* The properties of this cpu's implementation.  */
+
+static const MACH_IMP_PROPERTIES @cpu@_imp_properties =
+{
+  sizeof (SIM_CPU),
+#if WITH_SCACHE
+  sizeof (SCACHE)
+#else
+  0
+#endif
+};\n\n"
+   )
+)
+\f
+; Insn modeling support.
+
+; Generate code to profile hardware elements.
+; ??? Not currently used.
+
+(define (-gen-hw-profile-code)
+  ; Fetch profilable input and output operands of the semantic code.
+  (let ((in-ops (find op-profilable? (sfmt-in-ops (insn-sfmt insn))))
+       (out-ops (find op-profilable? (sfmt-out-ops (insn-sfmt insn)))))
+    (string-list
+     ; For each operand, record its being get/set.
+     (string-list-map (lambda (op) (send op 'gen-profile-code insn #f))
+                     in-ops)
+     (string-list-map (lambda (op) (send op 'gen-profile-code insn #t))
+                     out-ops)
+     ))
+)
+
+; Return decls of hardware element profilers.
+; ??? Not currently used.
+
+(define (-gen-hw-profile-decls)
+  (string-list
+   "/* Hardware profiling handlers.  */\n\n"
+   (string-list-map (lambda (hw)
+                     (string-append "extern void @cpu@_model_mark_get_"
+                                    (gen-sym hw) " (SIM_CPU *"
+                                    (if (hw-scalar? hw)
+                                        ""
+                                        ", int") ; FIXME: get index type
+                                    ");\n"
+                                    "extern void @cpu@_model_mark_set_"
+                                    (gen-sym hw) " (SIM_CPU *"
+                                    (if (hw-scalar? hw)
+                                        ""
+                                        ", int") ; FIXME: get index type
+                                    ");\n"))
+                   (find hw-profilable? (current-hw-list)))
+   "\n"
+   )
+)
+
+; Return name of profiling handler for MODEL, UNIT.
+; Also called by sim.scm.
+
+(define (gen-model-unit-fn-name model unit)
+  (string-append "@cpu@_model_" (gen-sym model) "_" (gen-sym unit))
+)
+
+; Return decls of all insn model handlers.
+; This is called from sim-decode.scm.
+
+(define (gen-model-fn-decls)
+  (let ((gen-args (lambda (args)
+                   (gen-c-args (map (lambda (arg)
+                                      (string-append
+                                       (mode:c-type (mode:lookup (cadr arg)))
+                                       " /*" (car arg) "*/"))
+                                    (find (lambda (arg)
+                                            ; Indices of scalars not passed.
+                                            (not (null? (cdr arg))))
+                                          args)))))
+       )
+
+    (string-list
+     ; -gen-hw-profile-decls
+     "/* Function unit handlers (user written).  */\n\n"
+     (string-list-map
+      (lambda (model)
+       (string-list-map (lambda (unit)
+                          (string-append
+                           "extern int "
+                           (gen-model-unit-fn-name model unit)
+                           " (SIM_CPU *, const IDESC *,"
+                           " int /*unit_num*/, int /*referenced*/"
+                           (gen-args (unit:inputs unit))
+                           (gen-args (unit:outputs unit))
+                           ");\n"))
+                        (model:units model)))
+      (current-model-list))
+     "\n"
+     "/* Profiling before/after handlers (user written) */\n\n"
+     "extern void @cpu@_model_insn_before (SIM_CPU *, int /*first_p*/);\n"
+     "extern void @cpu@_model_insn_after (SIM_CPU *, int /*last_p*/, int /*cycles*/);\n"
+     "\n"
+     ))
+)
+
+; Return name of profile handler for INSN, MODEL.
+
+(define (-gen-model-insn-fn-name model insn)
+  (string-append "model_" (gen-sym model) "_" (gen-sym insn))
+)
+
+; Return function to model INSN.
+
+(define (-gen-model-insn-fn model insn)
+  (logit 2 "Processing modeling for " (obj:name insn) ": \"" (insn-syntax insn) "\" ...\n")
+  (string-list
+   "static int\n"
+   (-gen-model-insn-fn-name model insn)
+   ; sem_arg is a void * to keep cgen specific stuff out of sim-model.h
+   " (SIM_CPU *current_cpu, void *sem_arg)\n"
+   "{\n"
+   (if (with-scache?)
+       (gen-define-field-macro (insn-sfmt insn))
+       "")
+   "  const ARGBUF * UNUSED abuf = SEM_ARGBUF ((SEM_ARG) sem_arg);\n"
+   "  const IDESC * UNUSED idesc = abuf->idesc;\n"
+   ; or: idesc = & CPU_IDESC (current_cpu) ["
+   ; (gen-cpu-insn-enum (mach-cpu (model:mach model)) insn)
+   ; "];\n"
+   "  int cycles = 0;\n"
+   (send insn 'gen-profile-locals model)
+   (if (with-scache?)
+       ""
+       (string-list
+       "  IADDR UNUSED pc = GET_H_PC ();\n"
+       "  CGEN_INSN_INT insn = abuf->insn;\n"
+       (gen-define-ifmt-ifields (insn-ifmt insn) "  " #f #t)
+       (gen-sfmt-op-argbuf-defns (insn-sfmt insn))
+       (gen-extract-ifmt-ifields (insn-ifmt insn) "  " #f #t)
+       (gen-sfmt-op-argbuf-assigns (insn-sfmt insn))))
+   ; Emit code to model the insn.  Function units are handled here.
+   (send insn 'gen-profile-code model "cycles")
+   "  return cycles;\n"
+   (if (with-scache?)
+       (gen-undef-field-macro (insn-sfmt insn))
+       "")
+   "}\n\n")
+)
+
+; Return insn modeling handlers.
+; ??? Might wish to reduce the amount of output by combining identical cases.
+; ??? Modelling of insns could be table driven, but that puts constraints on
+; generality.
+
+(define (-gen-model-insn-fns)
+  (string-write
+   "/* Model handlers for each insn.  */\n\n"
+   (lambda () (string-write-map
+              (lambda (model)
+                (string-write-map
+                 (lambda (insn) (-gen-model-insn-fn model insn))
+                 (real-insns (current-insn-list))))
+              (current-model-list)))
+   )
+)
+\f
+; Generate timing table entry for function unit U while executing INSN.
+; U is a <unit> object.
+; ARGS is a list of overriding arguments from INSN.
+
+(define (-gen-insn-unit-timing model insn u args)
+  (string-append
+   "{ "
+   "(int) " (unit:enum u) ", "
+   (number->string (unit:issue u)) ", "
+   (let ((cycles (assq-ref args 'cycles)))
+     (if cycles
+        (number->string (car cycles))
+        (number->string (unit:done u))))
+   " }, "
+   )
+)
+
+; Generate timing table entry for MODEL for INSN.
+
+(define (-gen-insn-timing model insn)
+  ; Instruction timing is stored as an associative list based on the model.
+  (let ((timing (assq (obj:name model) (insn-timing insn))))
+    ;(display timing) (newline)
+    (string-list
+     "  { "
+     (gen-cpu-insn-enum (mach-cpu (model:mach model)) insn)
+     ", "
+     (if (obj-has-attr? insn 'VIRTUAL)
+        "0"
+        (-gen-model-insn-fn-name model insn))
+     ", { "
+     (string-drop
+      -2
+      (if (not timing)
+         (-gen-insn-unit-timing model insn (model-default-unit model) nil)
+         (let ((units (timing:units (cdr timing))))
+           (string-map (lambda (iunit)
+                         (-gen-insn-unit-timing model insn
+                                                (iunit:unit iunit)
+                                                (iunit:args iunit)))
+                       units))))
+     " } },\n"
+     ))
+)
+
+; Generate model timing table for MODEL.
+
+(define (-gen-model-timing-table model)
+  (string-write
+   "/* Model timing data for `" (obj:name model) "'.  */\n\n"
+   "static const INSN_TIMING " (gen-sym model) "_timing[] = {\n"
+   (lambda () (string-write-map (lambda (insn) (-gen-insn-timing model insn))
+                               (non-alias-insns (current-insn-list))))
+   "};\n\n"
+   )
+)
+
+; Return C code to define model profiling support stuff.
+
+(define (-gen-model-profile-data)
+  (string-write
+   "/* We assume UNIT_NONE == 0 because the tables don't always terminate\n"
+   "   entries with it.  */\n\n"
+   (lambda () (string-write-map -gen-model-timing-table (current-model-list)))
+   )
+)
+
+; Return C code to define the model table for MACH.
+
+(define (-gen-mach-model-table mach)
+  (string-list
+   "\
+static const MODEL " (gen-sym mach) "_models[] =\n{\n"
+   (string-list-map (lambda (model)
+                     (string-list "  { "
+                                  "\"" (obj:name model) "\", "
+                                  "& " (gen-sym (model:mach model)) "_mach, "
+                                  (model:enum model) ", "
+                                  "TIMING_DATA (& "
+                                  (gen-sym model)
+                                  "_timing[0]), "
+                                  (gen-sym model) "_model_init"
+                                  " },\n"))
+                   (find (lambda (model) (eq? (obj:name mach)
+                                              (obj:name (model:mach model))))
+                         (current-model-list)))
+   "  { 0 }\n"
+   "};\n\n"
+   )
+)
+
+; Return C code to define model init fn.
+
+(define (-gen-model-init-fn model)
+  (string-list "\
+static void\n"
+(gen-sym model) "_model_init (SIM_CPU *cpu)
+{
+  CPU_MODEL_DATA (cpu) = (void *) zalloc (sizeof (MODEL_"
+   (string-upcase (gen-sym model))
+   "_DATA));
+}\n\n"
+   )
+)
+
+; Return C code to define model data and support fns.
+
+(define (-gen-model-defns)
+  (string-write
+   (lambda () (string-write-map -gen-model-init-fn (current-model-list)))
+   "#if WITH_PROFILE_MODEL_P
+#define TIMING_DATA(td) td
+#else
+#define TIMING_DATA(td) 0
+#endif\n\n"
+   (lambda () (string-write-map -gen-mach-model-table (current-mach-list)))
+   )
+)
+
+; Return C definitions for this cpu family variant.
+
+(define (-gen-cpu-defns)
+  (string-list "\
+
+static void
+@cpu@_prepare_run (SIM_CPU *cpu)
+{
+  if (CPU_IDESC (cpu) == NULL)
+    @cpu@_init_idesc_table (cpu);
+}
+
+static const CGEN_INSN *
+@cpu@_get_idata (SIM_CPU *cpu, int inum)
+{
+  return CPU_IDESC (cpu) [inum].idata;
+}
+
+")
+)
+
+; Return C code to define the machine data.
+
+(define (-gen-mach-defns)
+  (string-list-map
+   (lambda (mach)
+     (gen-obj-sanitize
+      mach
+      (string-list "\
+static void\n"
+(gen-sym mach) "_init_cpu (SIM_CPU *cpu)
+{
+  CPU_REG_FETCH (cpu) = " (gen-sym (mach-cpu mach)) "_fetch_register;
+  CPU_REG_STORE (cpu) = " (gen-sym (mach-cpu mach)) "_store_register;
+  CPU_PC_FETCH (cpu) = " (gen-sym (mach-cpu mach)) "_h_pc_get;
+  CPU_PC_STORE (cpu) = " (gen-sym (mach-cpu mach)) "_h_pc_set;
+  CPU_GET_IDATA (cpu) = @cpu@_get_idata;
+  CPU_MAX_INSNS (cpu) = @CPU@_INSN_MAX;
+  CPU_INSN_NAME (cpu) = cgen_insn_name;
+  CPU_FULL_ENGINE_FN (cpu) = @cpu@_engine_run_full;
+#if WITH_FAST
+  CPU_FAST_ENGINE_FN (cpu) = @cpu@_engine_run_fast;
+#else
+  CPU_FAST_ENGINE_FN (cpu) = @cpu@_engine_run_full;
+#endif
+}
+
+const MACH " (gen-sym mach) "_mach =
+{
+  \"" (obj:name mach) "\", "
+  "\"" (mach-bfd-name mach) "\", "
+  (mach-enum mach) ",\n"
+  "  " (number->string (cpu-word-bitsize (mach-cpu mach))) ", "
+  ; FIXME: addr-bitsize: delete
+  (number->string (cpu-word-bitsize (mach-cpu mach))) ", "
+  "& " (gen-sym mach) "_models[0], "
+  "& " (gen-sym (mach-cpu mach)) "_imp_properties,
+  " (gen-sym mach) "_init_cpu,
+  @cpu@_prepare_run
+};
+
+")))
+
+   (current-mach-list))
+)
+\f
+; Top level file generators.
+
+; Generate model.c
+
+(define (cgen-model.c)
+  (logit 1 "Generating " (gen-cpu-name) " model.c ...\n")
+
+  (sim-analyze-insns!)
+
+  ; Turn parallel execution support on if cpu needs it.
+  (set-with-parallel?! (state-parallel-exec?))
+
+  (string-write
+   (gen-copyright "Simulator model support for @cpu@."
+                 CURRENT-COPYRIGHT CURRENT-PACKAGE)
+   "\
+#define WANT_CPU @cpu@
+#define WANT_CPU_@CPU@
+
+#include \"sim-main.h\"
+
+/* The profiling data is recorded here, but is accessed via the profiling
+   mechanism.  After all, this is information for profiling.  */
+
+#if WITH_PROFILE_MODEL_P
+
+"
+   -gen-model-insn-fns
+   -gen-model-profile-data
+"#endif /* WITH_PROFILE_MODEL_P */\n\n"
+
+   -gen-model-defns
+   -gen-cpu-imp-properties
+   -gen-cpu-defns
+   -gen-mach-defns
+   )
+)
diff --git a/cgen/sim-test.scm b/cgen/sim-test.scm
new file mode 100644 (file)
index 0000000..42cf2fa
--- /dev/null
@@ -0,0 +1,244 @@
+; CPU description file generator for the simulator testsuite.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; This is invoked to build allinsn.exp and a script to run to
+; generate allinsn.s and allinsn.d.
+
+; Specify which application.
+(set! APPLICATION 'SIM-TEST)
+\f
+; Called before/after the .cpu file has been read.
+
+(define (sim-test-init!) (opcodes-init!))
+(define (sim-test-finish!) (opcodes-finish!))
+
+; Called after .cpu file has been read and global error checks are done.
+; We use the `tmp' member to record the syntax split up into its components.
+
+(define (sim-test-analyze!)
+  (opcodes-analyze!)
+  (map (lambda
+          (insn) (elm-xset! insn 'tmp (syntax-break-out (insn-syntax insn))))
+       (current-insn-list))
+  *UNSPECIFIED*
+)
+\f
+; Methods to compute test data.
+; The result is a list of strings to be inserted in the assembler
+; in the operand's position.
+
+(method-make!
+ <hw-asm> 'test-data
+ (lambda (self n)
+   ; FIXME: floating point support
+   (let ((signed (list 0 1 -1 2 -2))
+        (unsigned (list 0 1 2 3 4))
+        (mode (elm-get self 'mode)))
+     (map number->string
+         (list-take n
+                    (if (eq? (mode:class mode) 'UINT)
+                        unsigned
+                        signed)))))
+)
+
+(method-make!
+ <keyword> 'test-data
+ (lambda (self n)
+   (let* ((values (elm-get self 'values))
+         (n (min n (length values))))
+     ; FIXME: Need to handle mach variants.
+     (map car (list-take n values))))
+)
+
+(method-make!
+ <hw-address> 'test-data
+ (lambda (self n)
+   (let ((test-data '("foodata" "4" "footext" "-4")))
+     (list-take n test-data)))
+)
+
+(method-make!
+ <hw-iaddress> 'test-data
+ (lambda (self n)
+   (let ((test-data '("footext" "4" "foodata" "-4")))
+     (list-take n test-data)))
+)
+
+(method-make-forward! <hw-register> 'indices '(test-data))
+(method-make-forward! <hw-immediate> 'values '(test-data))
+
+; This can't use method-make-forward! as we need to call op:type to
+; resolve the hardware reference.
+
+(method-make!
+ <operand> 'test-data
+ (lambda (self n)
+   (send (op:type self) 'test-data n))
+)
+
+; Given an operand, return a set of N test data.
+; e.g. For a keyword operand, return a random subset.
+; For a number, return N numbers.
+
+(define (operand-test-data op n)
+  (send op 'test-data n)
+)
+
+; Given the broken out assembler syntax string, return the list of operand
+; objects.
+
+(define (extract-operands syntax-list)
+  (let loop ((result nil) (l syntax-list))
+    (cond ((null? l) (reverse result))
+         ((object? (car l)) (loop (cons (car l) result) (cdr l)))
+         (else (loop result (cdr l)))))
+)
+
+; Given a list of operands for an instruction, return the test set
+; (all possible combinations).
+; N is the number of testcases for each operand.
+; The result has N to-the-power (length OP-LIST) elements.
+
+(define (build-test-set op-list n)
+  (let ((test-data (map (lambda (op) (operand-test-data op n)) op-list))
+       (len (length op-list)))
+    ; FIXME: Make slicker later.
+    (cond ((=? len 0) (list (list)))
+         ((=? len 1) test-data)
+         (else (list (map car test-data)))))
+)
+
+; Given an assembler expression and a set of operands build a testcase.
+; SYNTAX-LIST is a list of syntax elements (characters) and <operand> objects.
+; TEST-DATA is a list of strings, one element per operand.
+; FIXME: wip
+
+(define (build-sim-testcase syntax-list test-data)
+  (logit 3 "Building a testcase for: "
+        (map (lambda (sl)
+               (string-append " "
+                              (cond ((string? sl)
+                                     sl)
+                                    ((operand? sl)
+                                     (obj:name sl))
+                                    (else
+                                     (with-output-to-string
+                                       (lambda () (display sl)))))))
+             syntax-list)
+        ", test data: "
+        (map (lambda (td) (list " " td))
+             test-data)
+        "\n")
+  (let loop ((result nil) (sl syntax-list) (td test-data))
+    ;(display (list result sl td "\n"))
+    (cond ((null? sl)
+          (string-append "\t"
+                         (apply string-append (reverse result))
+                         "\n"))
+         ((string? (car sl))
+          (loop (cons (car sl) result) (cdr sl) td))
+         (else (loop (cons (car td) result) (cdr sl) (cdr td)))))
+)
+
+; Generate a set of testcases for INSN.
+; FIXME: wip
+
+(define (gen-sim-test insn)
+  (logit 2 "Generating sim test set for " (obj:name insn) " ...\n")
+  (string-append
+   "\t.global " (gen-sym insn) "\n"
+   (gen-sym insn) ":\n"
+   (let* ((syntax-list (insn-tmp insn))
+         (op-list (extract-operands syntax-list))
+         (test-set (build-test-set op-list 2)))
+     (string-map (lambda (test-data)
+                  (build-sim-testcase syntax-list test-data))
+                test-set))
+   )
+)
+\f
+; Generate the shell script that builds the .cgs files.
+; .cgs are .s files except that there may be other .s files in the directory
+; and we want the .exp driver script to easily find the files.
+;
+; Eventually it would be nice to generate as much of the testcase as possible.
+; For now we just generate the template and leave the programmer to fill in
+; the guts of the test (i.e. set up various registers, execute the insn to be
+; tested, and then verify the results).
+; Clearly some hand generated testcases will also be needed, but this
+; provides a good start for each instruction.
+
+(define (cgen-build.sh)
+  (logit 1 "Generating sim-build.sh ...\n")
+  (string-append
+   "\
+#/bin/sh
+# Generate test result data for " (current-arch-name) " simulator testing.
+# This script is machine generated.
+# It is intended to be run in the testsuite source directory.
+#
+# Syntax: /bin/sh sim-build.sh
+
+# Put results here, so we preserve the existing set for comparison.
+rm -rf tmpdir
+mkdir tmpdir
+cd tmpdir
+\n"
+
+    (string-map (lambda (insn)
+                 (string-append
+                  "cat <<EOF > " (gen-file-name (obj:name insn)) ".cgs\n"
+                  ; FIXME: Need to record assembler line comment char in .cpu.
+                  "# " (current-arch-name) " testcase for " (backslash "$" (insn-syntax insn)) "\n"
+                  "# mach: "
+                  (let ((machs (insn-machs insn)))
+                    (if (null? machs)
+                        "all"
+                        (string-drop1 (string-map (lambda (mach)
+                                                    (string-append "," mach))
+                                                  machs))))
+                  "\n\n"
+                  "\t.include \"testutils.inc\"\n\n"
+                  "\tstart\n\n"
+                  (gen-sim-test insn)
+                  "\n\tpass\n"
+                  "EOF\n\n"))
+               (non-alias-insns (current-insn-list)))
+   )
+)
+
+; Generate the dejagnu allinsn.exp file that drives the tests.
+
+(define (cgen-allinsn.exp)
+  (logit 1 "Generating sim-allinsn.exp ...\n")
+  (string-append
+   "\
+# " (string-upcase (current-arch-name)) " simulator testsuite.
+
+if [istarget " (current-arch-name) "*-*-*] {
+    # load support procs (none yet)
+    # load_lib cgen.exp
+
+    # all machines
+    set all_machs \""
+   (string-drop1 (string-map (lambda (m)
+                              (string-append " "
+                                             (gen-sym m)))
+                            (current-mach-list)))
+   "\"
+
+    # The .cgs suffix is for \"cgen .s\".
+    foreach src [lsort [glob -nocomplain $srcdir/$subdir/*.cgs]] {
+       # If we're only testing specific files and this isn't one of them,
+       # skip it.
+       if ![runtest_file_p $runtests $src] {
+           continue
+       }
+
+       run_sim_test $src $all_machs
+    }
+}\n"
+   )
+)
diff --git a/cgen/sim.scm b/cgen/sim.scm
new file mode 100644 (file)
index 0000000..7f2b6b0
--- /dev/null
@@ -0,0 +1,2019 @@
+; Simulator generator support routines.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+
+; One goal of this file is to provide cover functions for all methods.
+; i.e. this file fills in the missing pieces of the interface between
+; the application independent part of CGEN (i.e. the code loaded by read.scm)
+; and the application dependent part (i.e. sim-*.scm).
+; `send' is not intended to appear in sim-*.scm.
+; [It still does but that's to be fixed.]
+
+; Specify which application.
+(set! APPLICATION 'SIMULATOR)
+\f
+; Cover functions for various methods.
+
+; Return the C type of something.  This isn't always a mode.
+
+(define (gen-type self) (send self 'gen-type))
+
+; Return the C type of an index's value or #f if not needed (scalar).
+
+(define (gen-index-type op sfmt)
+  (let ((index-mode (send op 'get-index-mode)))
+    (if index-mode
+       (mode:c-type index-mode)
+       #f))
+)
+\f
+; Misc. state info.
+
+; Currently supported options:
+; with-scache
+;      generate code to use the scache
+;      This is an all or nothing option, either scache is used or it's not.
+; with-profile fn|sw
+;      generate code to do profiling in the semantic function
+;      code (fn) or in the semantic switch (sw)
+; with-generic-write
+;      For architectures that have parallel execution.
+;      Execute the semantics by recording the results in a generic buffer,
+;      and doing a post-semantics writeback pass.
+; with-parallel-only
+;      Only generate parallel versions of each insn.
+; copyright fsf|cygnus
+;      emit an FSF or Cygnus copyright (temporary, pending decision)
+; package gnusim|cygsim
+;      indicate the software package
+
+; #t if the scache is being used
+(define -with-scache? #f)
+(define (with-scache?) -with-scache?)
+
+; #t if we're generating profiling code
+; Each of the function and switch semantic code can have profiling.
+; The options as passed are stored in -with-profile-{fn,sw}?, and
+; -with-profile? is set at code generation time.
+(define -with-profile-fn? #f)
+(define -with-profile-sw? #f)
+(define -with-profile? #f)
+(define (with-profile?) -with-profile?)
+(define (with-any-profile?) (or -with-profile-fn? -with-profile-sw?))
+
+; Handle parallel execution with generic writeback pass.
+(define -with-generic-write? #f)
+(define (with-generic-write?) -with-generic-write?)
+
+; Only generate parallel versions of each insn.
+(define -with-parallel-only? #f)
+(define (with-parallel-only?) -with-parallel-only?)
+
+; String containing copyright text.
+(define CURRENT-COPYRIGHT #f)
+
+; String containing text defining the package we're generating code for.
+(define CURRENT-PACKAGE #f)
+
+; Initialize the options.
+
+(define (option-init!)
+  (set! -with-scache? #f)
+  (set! -with-profile-fn? #f)
+  (set! -with-profile-sw? #f)
+  (set! -with-generic-write? #f)
+  (set! -with-parallel-only? #f)
+  (set! CURRENT-COPYRIGHT copyright-fsf)
+  (set! CURRENT-PACKAGE package-gnu-simulators)
+  *UNSPECIFIED*
+)
+
+; Handle an option passed in from the command line.
+
+(define (option-set! name value)
+  (case name
+    ((with-scache) (set! -with-scache? #t))
+    ((with-profile) (cond ((equal? value '("fn"))
+                          (set! -with-profile-fn? #t))
+                         ((equal? value '("sw"))
+                          (set! -with-profile-sw? #t))
+                         (else (error "invalid with-profile value" value))))
+    ((with-generic-write) (set! -with-generic-write? #t))
+    ((with-parallel-only) (set! -with-parallel-only? #t))
+    ((copyright) (cond ((equal?  value '("fsf"))
+                       (set! CURRENT-COPYRIGHT copyright-fsf))
+                      ((equal? value '("cygnus"))
+                       (set! CURRENT-COPYRIGHT copyright-cygnus))
+                      (else (error "invalid copyright value" value))))
+    ((package) (cond ((equal?  value '("gnusim"))
+                     (set! CURRENT-PACKAGE package-gnu-simulators))
+                    ((equal? value '("cygsim"))
+                     (set! CURRENT-PACKAGE package-cygnus-simulators))
+                    (else (error "invalid package value" value))))
+    (else (error "unknown option" name))
+    )
+  *UNSPECIFIED*
+)
+
+; #t if the cpu can execute insns parallely.
+; This one isn't passed on the command line, but we follow the convention
+; of prefixing these things with `with-'.
+; While processing operand reading (or writing), parallel execution support
+; needs to be turned off, so it is up to the appropriate cgen-foo.c proc to
+; set-with-parallel?! appropriately.
+(define -with-parallel? #f)
+(define (with-parallel?) -with-parallel?)
+(define (set-with-parallel?! flag) (set! -with-parallel? flag))
+
+; Kind of parallel support.
+; If 'read, read pre-processing is done.
+; If 'write, write post-processing is done.
+; ??? At present we always use write post-processing, though the previous
+; version used read pre-processing.  Not sure supporting both is useful
+; in the long run.
+(define -with-parallel-kind 'write)
+; #t if parallel support is provided by read pre-processing.
+(define (with-parallel-read?)
+  (and -with-parallel? (eq? -with-parallel-kind 'read))
+)
+; #t if parallel support is provided by write post-processing.
+(define (with-parallel-write?)
+  (and -with-parallel? (eq? -with-parallel-kind 'write))
+)
+\f
+; Misc. utilities.
+
+; All machine generated cpu elements are accessed through a cover macro
+; to hide the details of the underlying implementation.
+
+(define c-cpu-macro "CPU")
+
+(define (gen-cpu-ref sym)
+  (string-append c-cpu-macro " (" sym ")")
+)
+\f
+; Instruction field support code.
+
+; Return a <c-expr> object of the value of an ifield.
+
+(define (-cxmake-ifld-val mode f)
+  (if (with-scache?)
+      ; ??? Perhaps a better way would be to defer evaluating the src of a
+      ; set until the method processing the dest.
+      (cx:make-with-atlist mode (gen-ifld-argbuf-ref f)
+                          (atlist-make "" (bool-attr-make 'CACHED #t)))
+      (cx:make mode (gen-extracted-ifld-value f)))
+)
+\f
+; Type system.
+
+; Methods:
+; gen-type - return C code representing the type
+; gen-sym-decl - generate decl using the provided symbol
+; gen-sym-get-macro - generate GET macro for accessing CPU elements
+; gen-sym-set-macro - generate SET macro for accessing CPU elements
+
+; Scalar type
+
+(method-make!
+ <scalar> 'gen-type
+ (lambda (self) (mode:c-type (elm-get self 'mode)))
+)
+
+(method-make!
+ <scalar> 'gen-sym-decl
+ (lambda (self sym comment)
+   (string-append
+    "  /* " comment " */\n"
+    "  " (send self 'gen-type) " "
+    (gen-c-symbol sym) ";\n"))
+)
+
+(method-make!
+ <scalar> 'gen-sym-get-macro
+ (lambda (self sym comment)
+   (let ((sym (gen-c-symbol sym)))
+     (gen-get-macro sym "" (gen-cpu-ref sym))))
+)
+
+(method-make!
+ <scalar> 'gen-sym-set-macro
+ (lambda (self sym comment)
+   (let ((sym (gen-c-symbol sym)))
+     (gen-set-macro sym "" (gen-cpu-ref sym))))
+)
+
+(method-make! <scalar> 'gen-ref (lambda (self sym index estate) sym))
+
+; Array type
+
+(method-make!
+ <array> 'gen-type
+ (lambda (self) (mode:c-type (elm-get self 'mode)))
+)
+
+(method-make!
+ <array> 'gen-sym-decl
+ (lambda (self sym comment)
+   (string-append
+    "  /* " comment " */\n"
+    "  " (send self 'gen-type) " "
+    (gen-c-symbol sym)
+    (gen-array-ref (elm-get self 'dimensions))
+    ";\n")
+   )
+)
+
+(method-make!
+ <array> 'gen-sym-get-macro
+ (lambda (self sym comment)
+   (let ((sym (gen-c-symbol sym))
+        (rank (length (elm-get self 'dimensions))))
+     (string-append
+      "#define GET_" (string-upcase sym)
+      "(" (string-drop 2 (gen-macro-args rank)) ") "
+      (gen-cpu-ref sym) (gen-array-ref (macro-args rank)) "\n"
+      )))
+)
+
+(method-make!
+ <array> 'gen-sym-set-macro
+ (lambda (self sym comment)
+   (let ((sym (gen-c-symbol sym))
+        (rank (length (elm-get self 'dimensions))))
+     (string-append
+      "#define SET_" (string-upcase sym)
+      "(" (string-drop 2 (gen-macro-args rank)) ", x) "
+      "(" (gen-cpu-ref sym) (gen-array-ref (macro-args rank))
+      " = (x))\n"
+      )))
+)
+
+; Return a reference to the array.
+; SYM is the name of the array.
+; INDEX is either a single index object or a (possibly empty) list of objects,
+; one object per dimension.
+
+(method-make!
+ <array> 'gen-ref
+ (lambda (self sym index estate)
+   (let ((gen-index1 (lambda (idx)
+                      (string-append "["
+                                     (-gen-hw-index idx estate)
+                                     "]"))))
+     (string-append sym
+                   (cond ((list? index) (string-map gen-index1 index))
+                         (else (gen-index1 index))))))
+)
+
+; Integers
+;
+;(method-make!
+; <integer> 'gen-type
+; (lambda (self)
+;   (mode:c-type (mode-find (elm-get self 'bits)
+;                         (if (has-attr? self 'UNSIGNED)
+;                             'UINT 'INT)))
+;   )
+;)
+;
+;(method-make! <integer> 'gen-sym-decl (lambda (self sym comment) ""))
+;(method-make! <integer> 'gen-sym-get-macro (lambda (self sym comment) ""))
+;(method-make! <integer> 'gen-sym-set-macro (lambda (self sym comment) ""))
+\f
+; Hardware descriptions support code.
+;
+; Various operations are required for each h/w object to support the various
+; things the simulator will want to do with it.
+;
+; Methods:
+; gen-decl
+; gen-get-macro - Generate definition of the GET access macro.
+; gen-set-macro - Generate definition of the SET access macro.
+; gen-write     - Same as gen-read except done on output operands
+; cxmake-get    - Return a <c-expr> object to fetch the value.
+; gen-set-quiet - Set the value.
+;                 ??? Could just call this gen-set as there is no gen-set-trace
+;                 but for consistency with the messages passed to operands
+;                 we use this same.
+; gen-type      - C type to use to record value.
+;                 ??? Delete and just use get-mode?
+; save-index?   - return #t if an index needs to be saved for parallel
+;                 execution post-write processing
+; gen-profile-decl
+; gen-record-profile
+; get-mode
+; gen-profile-locals
+; gen-sym-decl  - Return a C declaration using the provided symbol.
+; gen-sym-get-macro - Generate default GET access macro.
+; gen-sym-set-macro - Generate default SET access macro.
+; gen-ref       - Return a C reference to the object.
+
+; Generate CPU state struct entries.
+
+(method-make!
+ <hardware-base> 'gen-decl
+ (lambda (self)
+   (send self 'gen-sym-decl (obj:name self) (obj:comment self)))
+)
+
+(method-make-virtual! <hardware-base> 'gen-sym-decl (lambda (self sym comment) ""))
+
+; Return a C reference to a hardware object.
+
+(method-make! <hardware-base> 'gen-ref (lambda (self sym index estate) sym))
+
+; Each hardware type must provide its own gen-write method.
+
+(method-make!
+ <hardware-base> 'gen-write
+ (lambda (self estate index mode sfmt op access-macro)
+   (error "gen-write method not overridden:" self))
+)
+
+; gen-type handler, must be overridden
+
+(method-make-virtual!
+ <hardware-base> 'gen-type
+ (lambda (self) (error "gen-type not overridden:" self))
+)
+
+(method-make! <hardware-base> 'gen-profile-decl (lambda (self) ""))
+
+; Default gen-record-profile method.
+
+(method-make!
+ <hardware-base> 'gen-record-profile
+ (lambda (self index sfmt estate)
+   "") ; nothing to do
+)
+
+; Default cxmake-get method.
+; Return a <c-expr> object of the value of SELF.
+; ESTATE is the current rtl evaluator state.
+; INDEX is a <hw-index> object.  It must be an ifield.
+; SELECTOR is a hardware selector RTX.
+
+(method-make!
+ <hardware-base> 'cxmake-get
+ (lambda (self estate mode index selector)
+   (if (not (eq? 'ifield (hw-index:type index)))
+       (error "not an ifield hw-index" index))
+   (-cxmake-ifld-val mode (hw-index:value index)))
+)
+
+; Handle gen-get-macro/gen-set-macro.
+
+(method-make!
+ <hardware-base> 'gen-get-macro
+ (lambda (self)
+   "")
+)
+
+(method-make!
+ <hardware-base> 'gen-set-macro
+ (lambda (self)
+   "")
+)
+\f
+; PC support
+
+; 'gen-set-quiet helper for PC values.
+; NEWVAL is a <c-expr> object of the value to be assigned.
+; If OPTIONS contains #:direct, set the PC directly, bypassing semantic
+; code considerations.
+; ??? OPTIONS support wip.  Probably want a new form (or extend existing form)
+; of rtx: that takes a variable number of named arguments.
+; ??? Another way to get #:direct might be (raw-reg h-pc).
+
+(define (-hw-gen-set-quiet-pc self estate mode index selector newval . options)
+  (if (not (send self 'pc?)) (error "Not a PC:" self))
+  (cond ((memq #:direct options)
+        (-hw-gen-set-quiet self estate mode index selector newval))
+       ((has-attr? newval 'CACHED)
+        (string-append "SEM_BRANCH_VIA_CACHE (current_cpu, sem_arg, "
+                       (cx:c newval)
+                       ", vpc);\n"))
+       (else
+        (string-append "SEM_BRANCH_VIA_ADDR (current_cpu, sem_arg, "
+                       (cx:c newval)
+                       ", vpc);\n")))
+)
+
+(method-make! <hw-pc> 'gen-set-quiet -hw-gen-set-quiet-pc)
+
+; Handle updates of the pc during parallel execution.
+; This is done in a post-processing pass after semantic evaluation.
+; SFMT is the <sformat>.
+; OP is the operand.
+; ACCESS-MACRO is the runtime C macro to use to fetch indices computed
+; during semantic evaluation.
+;
+; ??? This wouldn't be necessary if gen-set-quiet were a virtual method.
+; At this point I'm reluctant to willy nilly make methods virtual.
+
+(method-make!
+ <hw-pc> 'gen-write
+ (lambda (self estate index mode sfmt op access-macro)
+   (string-append "  "
+                 (send self 'gen-set-quiet estate VOID index hw-selector-default
+                       (cx:make DFLT (string-append access-macro
+                                                  " (" (gen-sym op) ")")))))
+)
+
+(method-make!
+ <hw-pc> 'cxmake-skip
+ (lambda (self estate yes?)
+   (cx:make VOID
+           (string-append "if ("
+                          yes?
+                          ")\n"
+                          "  SEM_SKIP_INSN (current_cpu, sem_arg, vpc);\n")))
+)
+\f
+; Registers.
+
+; Forward these methods onto TYPE.
+(method-make-virtual-forward! <hw-register> 'type '(gen-type gen-sym-decl))
+(method-make-forward! <hw-register> 'type '(gen-ref
+                                           gen-sym-get-macro
+                                           gen-sym-set-macro))
+
+; For parallel instructions supported by queueing outputs for later update,
+; return a boolean indicating if an index needs to be recorded.
+; An example of when the index isn't needed is if the index can be determined
+; during extraction.
+
+(method-make!
+ <hw-register> 'save-index?
+ (lambda (self op)
+   ; FIXME: Later handle case where register number is determined at runtime.
+   #f)
+)
+
+; Handle updates of registers during parallel execution.
+; This is done in a post-processing pass after semantic evaluation.
+; SFMT is the <sformat>.
+; OP is the <operand>.
+; ACCESS-MACRO is the runtime C macro to use to fetch indices computed
+; during semantic evaluation.
+; FIXME: May need mode of OP.
+
+(method-make!
+ <hw-register> 'gen-write
+ (lambda (self estate index mode sfmt op access-macro)
+   ; First get a hw-index object to use during indexing.
+   ; Some indices, e.g. memory addresses, are computed during semantic
+   ; evaluation.  Others are computed during the extraction phase.
+   (let ((index (send index 'get-write-index self sfmt op access-macro)))
+     (string-append "  "
+                   (send self 'gen-set-quiet estate mode index hw-selector-default
+                         (cx:make DFLT (string-append access-macro
+                                                    " (" (gen-sym op) ")"))))))
+)
+
+(method-make!
+ <hw-register> 'gen-profile-decl
+ (lambda (self)
+   (string-append
+    "  /* " (obj:comment self) " */\n"
+    "  unsigned long " (gen-c-symbol (obj:name self)) ";\n"))
+)
+
+(method-make!
+ <hw-register> 'gen-record-profile
+ (lambda (self index sfmt estate)
+   ; FIXME: Need to handle scalars.
+   (-gen-hw-index-raw index estate))
+)
+
+(method-make!
+ <hw-register> 'gen-get-macro
+ (lambda (self)
+   (let ((getter (elm-get self 'get))
+        (mode (send self 'get-mode)))
+     (if getter
+        (let ((args (car getter))
+              (expr (cadr getter)))
+          (gen-get-macro (gen-sym self)
+                         (if (hw-scalar? self) "" "index")
+                         (rtl-c mode expr
+                                (if (hw-scalar? self)
+                                    nil
+                                    (list (list (car args) 'UINT "index")))
+                                #:rtl-cover-fns? #t)))
+        (send self 'gen-sym-get-macro
+              (obj:name self) (obj:comment self)))))
+)
+
+(method-make!
+ <hw-register> 'gen-set-macro
+ (lambda (self)
+   (let ((setter (elm-get self 'set))
+        (mode (send self 'get-mode)))
+     (if setter
+        (let ((args (car setter))
+              (expr (cadr setter)))
+          (gen-set-macro2 (gen-sym self)
+                          (if (hw-scalar? self)
+                              ""
+                              "index")
+                          "x"
+                          (rtl-c VOID ; not `mode', sets have mode VOID
+                                 expr
+                                 (if (hw-scalar? self)
+                                     (list (list (car args) (hw-mode self) "(x)"))
+                                     (list (list (car args) 'UINT "(index)")
+                                           (list (cadr args) (hw-mode self) "(x)")))
+                                 #:rtl-cover-fns? #t #:macro? #t)))
+        (send self 'gen-sym-set-macro
+              (obj:name self) (obj:comment self)))))
+)
+
+; Utility to build a <c-expr> object to fetch the value of a register.
+
+(define (-hw-cxmake-get hw estate mode index selector)
+  (let ((mode (if (mode:eq? 'DFLT mode)
+                 (send hw 'get-mode)
+                 mode))
+       (getter (hw-getter hw)))
+    ; If the register is accessed via a cover function/macro, do it.
+    ; Otherwise fetch the value from the cached address or from the CPU struct.
+    (cx:make mode
+            (cond (getter
+                   (let ((scalar? (hw-scalar? hw))
+                         (c-index (-gen-hw-index index estate)))
+                     (string-append "GET_"
+                                    (string-upcase (gen-sym hw))
+                                    " ("
+                                    (if scalar? "" c-index)
+                                    ")")))
+                  ((and (hw-cache-addr? hw) ; FIXME: redo test
+                        (eq? 'ifield (hw-index:type index)))
+                   (string-append
+                    "* "
+                    (if (with-scache?)
+                        (gen-hw-index-argbuf-ref index)
+                        (gen-hw-index-argbuf-name index))))
+                  (else (gen-cpu-ref (send hw 'gen-ref
+                                           (gen-sym hw) index estate))))))
+)
+
+(method-make! <hw-register> 'cxmake-get -hw-cxmake-get)
+
+; raw-reg: support
+; ??? raw-reg: support is wip
+
+(method-make!
+ <hw-register> 'cxmake-get-raw
+ (lambda (self estate mode index selector)
+  (let ((mode (if (mode:eq? 'DFLT mode)
+                 (send self 'get-mode)
+                 mode)))
+    (cx:make mode (gen-cpu-ref (send self 'gen-ref
+                                    (gen-sym self) index estate)))))
+)
+
+; Utilities to generate C code to assign a variable to a register.
+
+(define (-hw-gen-set-quiet hw estate mode index selector newval)
+  (let ((setter (hw-setter hw)))
+    (cond (setter
+          (let ((scalar? (hw-scalar? hw))
+                (c-index (-gen-hw-index index estate)))
+            (string-append "SET_"
+                           (string-upcase (gen-sym hw))
+                           " ("
+                           (if scalar? "" (string-append c-index ", "))
+                           (cx:c newval)
+                           ");\n")))
+         ((and (hw-cache-addr? hw) ; FIXME: redo test
+               (eq? 'ifield (hw-index:type index)))
+          (string-append "* "
+                         (if (with-scache?)
+                             (gen-hw-index-argbuf-ref index)
+                             (gen-hw-index-argbuf-name index))
+                         " = " (cx:c newval) ";\n"))
+         (else (string-append (gen-cpu-ref (send hw 'gen-ref
+                                                 (gen-sym hw) index estate))
+                              " = " (cx:c newval) ";\n"))))
+)
+
+(method-make! <hw-register> 'gen-set-quiet -hw-gen-set-quiet)
+
+; raw-reg: support
+; ??? wip
+
+(method-make!
+ <hw-register> 'gen-set-quiet-raw
+ (lambda (self estate mode index selector newval)
+   (string-append (gen-cpu-ref (send self 'gen-ref
+                                    (gen-sym self) index estate))
+                 " = " (cx:c newval) ";\n"))
+)
+
+; Return name of C access function for getting/setting a register.
+
+(define (gen-reg-getter-fn hw prefix)
+  (string-append prefix "_" (gen-sym hw) "_get")
+)
+
+(define (gen-reg-setter-fn hw prefix)
+  (string-append prefix "_" (gen-sym hw) "_set")
+)
+
+; Generate decls for access fns of register HW, beginning with
+; PREFIX, using C type TYPE.
+; SCALAR? is #t if the register is a scalar.  Otherwise it is #f and the
+; register is a bank of registers.
+
+(define (gen-reg-access-decl hw prefix type scalar?)
+  (string-append
+   type " "
+   (gen-reg-getter-fn hw prefix)
+   " (SIM_CPU *"
+   (if scalar? "" ", UINT")
+   ");\n"
+   "void "
+   (gen-reg-setter-fn hw prefix)
+   " (SIM_CPU *, "
+   (if scalar? "" "UINT, ")
+   type ");\n"
+   )
+)
+
+; Generate defns of access fns of register HW, beginning with
+; PREFIX, using C type TYPE.
+; SCALAR? is #t if the register is a scalar.  Otherwise it is #f and the
+; register is a bank of registers.
+; GET/SET-CODE are C fragments to get/set the value.
+; ??? Inlining left for later.
+
+(define (gen-reg-access-defn hw prefix type scalar? get-code set-code)
+  (string-append
+   "/* Get the value of " (obj:name hw) ".  */\n\n"
+   type "\n"
+   (gen-reg-getter-fn hw prefix)
+   " (SIM_CPU *current_cpu"
+   (if scalar? "" ", UINT regno")
+   ")\n{\n"
+   get-code
+   "}\n\n"
+   "/* Set a value for " (obj:name hw) ".  */\n\n"
+   "void\n"
+   (gen-reg-setter-fn hw prefix)
+   " (SIM_CPU *current_cpu, "
+   (if scalar? "" "UINT regno, ")
+   type " newval)\n"
+   "{\n"
+   set-code
+   "}\n\n")
+)
+\f
+; Memory support.
+
+(method-make!
+ <hw-memory> 'cxmake-get
+ (lambda (self estate mode index selector)
+   (let ((mode (if (mode:eq? 'DFLT mode)
+                  (hw-mode self)
+                  mode))
+        (default-selector? (hw-selector-default? selector)))
+     (cx:make mode
+             (string-append "GETMEM" (obj:name mode)
+                            (if default-selector? "" "ASI")
+                            " ("
+                            "current_cpu, pc, "
+                            (-gen-hw-index index estate)
+                            (if default-selector?
+                                ""
+                                (string-append ", "
+                                               (-gen-hw-selector selector)))
+                            ")"))))
+)
+
+(method-make!
+ <hw-memory> 'gen-set-quiet
+ (lambda (self estate mode index selector newval)
+   (let ((mode (if (mode:eq? 'DFLT mode)
+                  (hw-mode self)
+                  mode))
+        (default-selector? (hw-selector-default? selector)))
+     (string-append "SETMEM" (obj:name mode)
+                   (if default-selector? "" "ASI")
+                   " ("
+                   "current_cpu, pc, "
+                   (-gen-hw-index index estate)
+                   (if default-selector?
+                       ""
+                       (string-append ", "
+                                      (-gen-hw-selector selector)))
+                   ", " (cx:c newval) ");\n")))
+)
+
+(method-make-virtual-forward! <hw-memory> 'type '(gen-type))
+(method-make-virtual! <hw-memory> 'gen-sym-decl (lambda (self sym comment) ""))
+(method-make! <hw-memory> 'gen-sym-get-macro (lambda (self sym comment) ""))
+(method-make! <hw-memory> 'gen-sym-set-macro (lambda (self sym comment) ""))
+
+; For parallel instructions supported by queueing outputs for later update,
+; return the type of the index or #f if not needed.
+
+(method-make!
+ <hw-memory> 'save-index?
+ (lambda (self op)
+   ; In the case of the complete memory address being an immediate
+   ; argument, we can return #f (later).
+   AI)
+)
+
+(method-make!
+ <hw-memory> 'gen-write
+ (lambda (self estate index mode sfmt op access-macro)
+   (let ((index (send index 'get-write-index self sfmt op access-macro)))
+     (string-append "  "
+                   (send self 'gen-set-quiet estate mode index
+                         hw-selector-default
+                         (cx:make DFLT (string-append access-macro " ("
+                                                    (gen-sym op)
+                                                    ")"))))))
+)
+\f
+; Immediates, addresses.
+
+; Forward these methods onto TYPE.
+(method-make-virtual-forward! <hw-immediate> 'type '(gen-type gen-sym-decl))
+(method-make-forward! <hw-immediate> 'type '(gen-sym-get-macro
+                                            gen-sym-set-macro))
+
+(method-make!
+ <hw-immediate> 'gen-write
+ (lambda (self estate index mode sfmt op access-macro)
+   (error "gen-write of <hw-immediate> shouldn't happen"))
+)
+
+; FIXME.
+(method-make-virtual! <hw-address> 'gen-type (lambda (self) "ADDR"))
+(method-make-virtual! <hw-address> 'gen-sym-decl (lambda (self sym comment) ""))
+(method-make! <hw-address> 'gen-sym-get-macro (lambda (self sym comment) ""))
+(method-make! <hw-address> 'gen-sym-set-macro (lambda (self sym comment) ""))
+
+; Return a <c-expr> object of the value of SELF.
+; ESTATE is the current rtl evaluator state.
+; INDEX is a hw-index object.  It must be an ifield.
+; Needed because we record our own copy of the ifield in ARGBUF.
+; SELECTOR is a hardware selector RTX.
+
+(method-make!
+ <hw-address> 'cxmake-get
+ (lambda (self estate mode index selector)
+   (if (not (eq? 'ifield (hw-index:type index)))
+       (error "not an ifield hw-index" index))
+   (if (with-scache?)
+       (cx:make mode (gen-hw-index-argbuf-ref index))
+       (cx:make mode (gen-hw-index-argbuf-name index))))
+)
+
+(method-make!
+ <hw-address> 'gen-write
+ (lambda (self estate index mode sfmt op access-macro)
+   (error "gen-write of <hw-address> shouldn't happen"))
+)
+
+; FIXME: revisit.
+(method-make-virtual! <hw-iaddress> 'gen-type (lambda (self) "IADDR"))
+
+; Return a <c-expr> object of the value of SELF.
+; ESTATE is the current rtl evaluator state.
+; INDEX is a <hw-index> object.  It must be an ifield.
+; Needed because we record our own copy of the ifield in ARGBUF,
+; *and* because we want to record in the result the 'CACHED attribute
+; since instruction addresses based on ifields are fixed [and thus cacheable].
+; SELECTOR is a hardware selector RTX.
+
+(method-make!
+ <hw-iaddress> 'cxmake-get
+ (lambda (self estate mode index selector)
+   (if (not (eq? 'ifield (hw-index:type index)))
+       (error "not an ifield hw-index" index))
+   (if (with-scache?)
+       ; ??? Perhaps a better way would be to defer evaluating the src of a
+       ; set until the method processing the dest.
+       (cx:make-with-atlist mode (gen-hw-index-argbuf-ref index)
+                           (atlist-make "" (bool-attr-make 'CACHED #t)))
+       (cx:make mode (gen-hw-index-argbuf-name index))))
+)
+\f
+; Hardware index support code.
+
+; Return the index to use by the gen-write method.
+; In the cases where this is needed (the index isn't known until insn
+; execution time), the index is computed along with the value to be stored,
+; so this is easy.
+
+(method-make!
+ <hw-index> 'get-write-index
+ (lambda (self hw sfmt op access-macro)
+   (if (memq (hw-index:type self) '(scalar constant str-expr ifield))
+       self
+       (let ((index-mode (send hw 'get-index-mode)))
+        (if index-mode
+            (make <hw-index> 'anonymous 'str-expr index-mode
+                  (string-append access-macro " (" (-op-index-name op) ")"))
+            (hw-index-scalar)))))
+)
+
+; Return the name of the PAREXEC structure member holding a hardware index
+; for operand OP.
+
+(define (-op-index-name op)
+  (string-append (gen-sym op) "_idx")
+)
+
+; Cover fn to hardware indices to generate the actual C code.
+; INDEX is the hw-index object (i.e. op:index).
+; The result is a string of C code.
+; FIXME:wip
+
+(define (-gen-hw-index-raw index estate)
+  (let ((type (hw-index:type index))
+       (mode (hw-index:mode index))
+       (value (hw-index:value index)))
+    (case type
+      ((scalar) "")
+      ; special case UINT to cut down on unnecessary verbosity.
+      ; ??? May wish to handle more similarily.
+      ((constant) (if (mode:eq? 'UINT mode)
+                     (number->string value)
+                     (string-append "((" (mode:c-type mode) ") "
+                                    (number->string value)
+                                    ")")))
+      ((str-expr) value)
+      ((rtx) (rtl-c-with-estate estate mode value))
+      ((ifield) (if (= (ifld-length value) 0)
+                   ""
+                   (gen-extracted-ifld-value value)))
+      ((operand) (cx:c (send value 'cxmake-get estate mode (op:index value)
+                            (op:selector value) #f)))
+      (else (error "-gen-hw-index-raw: invalid index:" index))))
+)
+
+; Same as -gen-hw-index-raw except used where speedups are possible.
+; e.g. doing array index calcs at extraction time.
+
+(define (-gen-hw-index index estate)
+  (let ((type (hw-index:type index))
+       (mode (hw-index:mode index))
+       (value (hw-index:value index)))
+    (case type
+      ((scalar) "")
+      ((constant) (string-append "((" (mode:c-type mode) ") "
+                                (number->string value)
+                                ")"))
+      ((str-expr) value)
+      ((rtx) (rtl-c-with-estate estate mode value))
+      ((ifield) (if (= (ifld-length value) 0)
+                   ""
+                   (cx:c (-cxmake-ifld-val mode value))))
+      ((operand) (cx:c (send value 'cxmake-get estate mode (op:index value)
+                            (op:selector value))))
+      (else (error "-gen-hw-index: invalid index:" index))))
+)
+
+; Return address where HW is stored.
+
+(define (-gen-hw-addr hw estate index)
+  (let ((setter (hw-setter hw)))
+    (cond ((and (hw-cache-addr? hw) ; FIXME: redo test
+               (eq? 'ifield (hw-index:type index)))
+          (if (with-scache?)
+              (gen-hw-index-argbuf-ref index)
+              (gen-hw-index-argbuf-name index)))
+         (else
+          (string-append "& "
+                         (gen-cpu-ref (send hw 'gen-ref
+                                            (gen-sym hw) index estate))))))
+)
+
+; Return a <c-expr> object of the value of a hardware index.
+
+(method-make!
+ <hw-index> 'cxmake-get
+ (lambda (self estate mode)
+   (let ((mode (if (mode:eq? 'DFLT mode) (elm-get self 'mode) mode)))
+     ; If MODE is VOID, abort.
+     (if (mode:eq? 'VOID mode)
+        (error "hw-index:cxmake-get: result needs a mode" self))
+     (cx:make (if (mode:host? mode)
+                 ; FIXME: Temporary hack to generate same code as before.
+                 (let ((xmode (object-copy-top mode)))
+                   (obj-cons-attr! xmode (bool-attr-make 'FORCE-C #t))
+                   xmode)
+                 mode)
+             (-gen-hw-index self estate))))
+)
+\f
+; Hardware selector support code.
+
+; Generate C code for SEL.
+
+(define (-gen-hw-selector sel)
+  (rtl-c 'INT sel nil)
+)
+\f
+; Instruction operand support code.
+
+; Methods:
+; gen-type      - Return C type to use to hold operand's value.
+; gen-read      - Record an operand's value prior to parallely executing
+;                 several instructions.  Not used if gen-write used.
+; gen-write     - Write back an operand's value after parallely executing
+;                 several instructions.  Not used if gen-read used.
+; cxmake-get    - Return C code to fetch the value of an operand.
+; gen-set-quiet - Return C code to set the value of an operand.
+; gen-set-trace - Return C code to set the value of an operand, and print
+;                 a result trace message.  ??? Ideally this will go away when
+;                 trace record support is complete.
+
+; Return the C type of an operand.
+; Generally we forward things on to TYPE, but for the actual type we need to
+; use the get-mode method.
+
+;(method-make-forward! <operand> 'type '(gen-type))
+(method-make!
+ <operand> 'gen-type
+ (lambda (self)
+   ; First get the mode.
+   (let ((mode (send self 'get-mode)))
+     ; If it's VOID use the type's type.
+     (if (mode:eq? 'DFLT mode)
+        (send (op:type self) 'gen-type)
+        (mode:c-type mode))))
+)
+
+; Extra pc operand methods.
+
+(method-make!
+ <pc> 'cxmake-get
+ (lambda (self estate mode index selector)
+   (let ((mode (if (mode:eq? 'DFLT mode)
+                  (send self 'get-mode)
+                  mode)))
+     ; The enclosing function must set `pc' to the correct value.
+     (cx:make mode "pc")))
+)
+
+(method-make!
+ <pc> 'cxmake-skip
+ (lambda (self estate yes?)
+   (send (op:type self) 'cxmake-skip estate
+        (rtl-c INT yes? nil #:rtl-cover-fns? #t)))
+)
+
+; For parallel write post-processing, we don't want to defer setting the pc.
+; ??? Not sure anymore.
+;(method-make!
+; <pc> 'gen-set-quiet
+; (lambda (self estate mode index selector newval)
+;   (-op-gen-set-quiet self estate mode index selector newval)))
+;(method-make!
+; <pc> 'gen-set-trace
+; (lambda (self estate mode index selector newval)
+;   (-op-gen-set-trace self estate mode index selector newval)))
+
+; Name of C macro to access parallel execution operand support.
+
+(define -par-operand-macro "OPRND")
+
+; Return C code to fetch an operand's value and save it away for the
+; semantic handler.  This is used to handle parallel execution of several
+; instructions where all inputs of all insns are read before any outputs are
+; written.
+; For operands, the word `read' is only used in this context.
+
+(define (op:read op sfmt)
+  (let ((estate (estate-make-for-normal-rtl-c nil nil)))
+    (send op 'gen-read estate sfmt -par-operand-macro))
+)
+
+; Return C code to write an operand's value.
+; This is used to handle parallel execution of several instructions where all
+; outputs are written to temporary spots first, and then a final
+; post-processing pass is run to update cpu state.
+; For operands, the word `write' is only used in this context.
+
+(define (op:write op sfmt)
+  (let ((estate (estate-make-for-normal-rtl-c nil nil)))
+    (send op 'gen-write estate sfmt -par-operand-macro))
+)
+
+; Default gen-read method.
+; This is used to help support targets with parallel insns.
+; Either this or gen-write (but not both) is used.
+
+(method-make!
+ <operand> 'gen-read
+ (lambda (self estate sfmt access-macro)
+   (string-append "  "
+                 access-macro " ("
+                 (gen-sym self)
+                 ") = "
+                 ; Pass #f for the index -> use the operand's builtin index.
+                 ; Ditto for the selector.
+                 (cx:c (send self 'cxmake-get estate DFLT #f #f))
+                 ";\n"))
+)
+
+; Forward gen-write onto the <hardware> object.
+
+(method-make!
+ <operand> 'gen-write
+ (lambda (self estate sfmt access-macro)
+   (let ((write-back-code (send (op:type self) 'gen-write estate
+                               (op:index self) (op:mode self)
+                               sfmt self access-macro)))
+     ; If operand is conditionally written, we have to check that first.
+     ; ??? If two (or more) operands are written based on the same condition,
+     ; all the tests can be collapsed together.  Not sure that's a big
+     ; enough win yet.
+     (if (op:cond? self)
+        (string-append "  if (written & (1 << "
+                       (number->string (op:num self))
+                       "))\n"
+                       "    {\n"
+                       "    " write-back-code
+                       "    }\n")
+        write-back-code)))
+)
+
+; Return <c-expr> object to get the value of an operand.
+; ESTATE is the current rtl evaluator state.
+; If INDEX is non-#f use it, otherwise use (op:index self).
+; This special handling of #f for INDEX is *only* supported for operands
+; in cxmake-get, gen-set-quiet, and gen-set-trace.
+; Ditto for SELECTOR.
+
+(method-make!
+ <operand> 'cxmake-get
+ (lambda (self estate mode index selector)
+   (let ((mode (if (mode:eq? 'DFLT mode)
+                  (send self 'get-mode)
+                  mode))
+        (index (if index index (op:index self)))
+        (selector (if selector selector (op:selector self))))
+     ; If the instruction could be parallely executed with others and we're
+     ; doing read pre-processing, the operand has already been fetched, we
+     ; just have to grab the cached value.
+     ; ??? reg-raw: support wip
+     (cond ((obj-has-attr? self 'RAW)
+           (send (op:type self) 'cxmake-get-raw estate mode index selector))
+          ((with-parallel-read?)
+           (cx:make-with-atlist mode
+                                (string-append -par-operand-macro
+                                               " (" (gen-sym self) ")")
+                                nil)) ; FIXME: want CACHED attr if present
+          ((op:getter self)
+           (let ((args (car (op:getter self)))
+                 (expr (cadr (op:getter self))))
+             (rtl-c mode expr
+                    (if (= (length args) 0)
+                        nil
+                        (list (list (car args) 'UINT index)))
+                    #:rtl-cover-fns? #t)))
+          (else
+           (send (op:type self) 'cxmake-get estate mode index selector)))))
+)
+
+; Utilities to implement gen-set-quiet/gen-set-trace.
+
+(define (-op-gen-set-quiet op estate mode index selector newval)
+  (send (op:type op) 'gen-set-quiet estate mode index selector newval)
+)
+
+; Return C code to call the appropriate queued-write handler.
+; ??? wip
+
+(define (-op-gen-queued-write op estate mode index selector newval)
+  (let* ((hw (op:type op))
+        (setter (hw-setter hw))
+        (sem-mode (mode:sem-mode mode)))
+    (string-append
+     "    "
+     "sim_queue_"
+     ; FIXME: clean up (pc? op) vs (memory? hw)
+     ; FIXME: (send 'pc?) is a temporary hack, (pc? op) didn't work
+     (cond ((send hw 'pc?)
+           (string-append
+            (if setter
+                "fn_"
+                "")
+            "pc"))
+          (else
+           (string-append
+            (cond ((memory? hw)
+                   "mem_")
+                  ((hw-scalar? hw)
+                   "scalar_")
+                  (else ""))
+            (if setter
+                "fn_"
+                "")
+            (string-downcase (if sem-mode
+                                 (mode-real-name sem-mode)
+                                 (mode-real-name mode))))))
+     "_write (current_cpu"
+     ; ??? May need to include h/w id some day.
+     (if setter
+        (string-append ", " (gen-reg-setter-fn hw "@cpu@"))
+        "")
+     (cond ((hw-scalar? hw)
+           "")
+          (setter
+           (string-append ", " (-gen-hw-index index estate)))
+          ((memory? hw)
+           (string-append ", " (-gen-hw-index index estate)))
+          (else
+           (string-append ", " (-gen-hw-addr (op:type op) estate index))))
+     ", "
+     newval
+     ");\n"))
+)
+
+(define (-op-gen-set-quiet-parallel op estate mode index selector newval)
+  (if (with-generic-write?)
+      (-op-gen-queued-write op estate mode index selector (cx:c newval))
+      (string-append
+       (if (op-save-index? op)
+          (string-append "    "
+                         -par-operand-macro " (" (-op-index-name op) ")"
+                         " = " (-gen-hw-index index estate) ";\n")
+          "")
+       "    "
+       -par-operand-macro " (" (gen-sym op) ")"
+       " = " (cx:c newval) ";\n"))
+)
+
+(define (-op-gen-set-trace op estate mode index selector newval)
+  (string-append
+   "  {\n"
+   "    " (mode:c-type mode) " opval = " (cx:c newval) ";\n"
+   "    " (send (op:type op) 'gen-set-quiet estate mode index selector
+               (cx:make-with-atlist mode "opval" (cx:atlist newval)))
+   (if (op:cond? op)
+       (string-append "    written |= (1 << "
+                     (number->string (op:num op))
+                     ");\n")
+       "")
+; TRACE_RESULT_<MODE> (cpu, abuf, hwnum, opnum, value);
+; For each insn record array of operand numbers [or indices into
+; operand instance table].
+; Could just scan the operand table for the operand or hardware number,
+; assuming the operand number is stored in `op'.
+   "    TRACE_RESULT (current_cpu, abuf"
+   ", " (send op 'gen-pretty-name mode)
+   ", " (mode:printf-type mode)
+   ", opval);\n"
+   "  }\n")
+)
+
+(define (-op-gen-set-trace-parallel op estate mode index selector newval)
+  (string-append
+   "  {\n"
+   "    " (mode:c-type mode) " opval = " (cx:c newval) ";\n"
+   (if (with-generic-write?)
+       (-op-gen-queued-write op estate mode index selector "opval")
+       (string-append
+       (if (op-save-index? op)
+           (string-append "    "
+                          -par-operand-macro " (" (-op-index-name op) ")"
+                          " = " (-gen-hw-index index estate) ";\n")
+           "")
+       "    " -par-operand-macro " (" (gen-sym op) ")"
+       " = opval;\n"))
+   (if (op:cond? op)
+       (string-append "    written |= (1 << "
+                     (number->string (op:num op))
+                     ");\n")
+       "")
+; TRACE_RESULT_<MODE> (cpu, abuf, hwnum, opnum, value);
+; For each insn record array of operand numbers [or indices into
+; operand instance table].
+; Could just scan the operand table for the operand or hardware number,
+; assuming the operand number is stored in `op'.
+   "    TRACE_RESULT (current_cpu, abuf"
+   ", " (send op 'gen-pretty-name mode)
+   ", " (mode:printf-type mode)
+   ", opval);\n"
+   "  }\n")
+)
+
+; Return C code to set the value of an operand.
+; NEWVAL is a <c-expr> object of the value to store.
+; If INDEX is non-#f use it, otherwise use (op:index self).
+; This special handling of #f for INDEX is *only* supported for operands
+; in cxmake-get, gen-set-quiet, and gen-set-trace.
+; Ditto for SELECTOR.
+
+(method-make!
+ <operand> 'gen-set-quiet
+ (lambda (self estate mode index selector newval)
+   (let ((mode (if (mode:eq? 'DFLT mode)
+                  (send self 'get-mode)
+                  mode))
+        (index (if index index (op:index self)))
+        (selector (if selector selector (op:selector self))))
+     ; ??? raw-reg: support wip
+     (cond ((obj-has-attr? self 'RAW)
+           (send (op:type self) 'gen-set-quiet-raw estate mode index selector newval))
+          ((with-parallel-write?)
+           (-op-gen-set-quiet-parallel self estate mode index selector newval))
+          (else
+           (-op-gen-set-quiet self estate mode index selector newval)))))
+)
+
+; Return C code to set the value of an operand and print TRACE_RESULT message.
+; NEWVAL is a <c-expr> object of the value to store.
+; If INDEX is non-#f use it, otherwise use (op:index self).
+; This special handling of #f for INDEX is *only* supported for operands
+; in cxmake-get, gen-set-quiet, and gen-set-trace.
+; Ditto for SELECTOR.
+
+(method-make!
+ <operand> 'gen-set-trace
+ (lambda (self estate mode index selector newval)
+   (let ((mode (if (mode:eq? 'DFLT mode)
+                  (send self 'get-mode)
+                  mode))
+        (index (if index index (op:index self)))
+        (selector (if selector selector (op:selector self))))
+     ; ??? raw-reg: support wip
+     (cond ((obj-has-attr? self 'RAW)
+           (send (op:type self) 'gen-set-quiet-raw estate mode index selector newval))
+          ((with-parallel-write?)
+           (-op-gen-set-trace-parallel self estate mode index selector newval))
+          (else
+           (-op-gen-set-trace self estate mode index selector newval)))))
+)
+
+; Define and undefine C macros to tuck away details of instruction format used
+; in the parallel execution functions.  See gen-define-field-macro for a
+; similar thing done for extraction/semantic functions.
+
+(define (gen-define-parallel-operand-macro sfmt)
+  (string-append "#define " -par-operand-macro "(f) "
+                "par_exec->operands."
+                (gen-sym sfmt)
+                ".f\n")
+)
+
+(define (gen-undef-parallel-operand-macro sfmt)
+  (string-append "#undef " -par-operand-macro "\n")
+)
+\f
+; Operand profiling and parallel execution support.
+
+(method-make!
+ <operand> 'save-index?
+ (lambda (self) (send (op:type self) 'save-index? self))
+)
+
+; Return boolean indicating if operand OP needs its index saved
+; (for parallel write post-processing support).
+
+(define (op-save-index? op)
+  (send op 'save-index?)
+)
+
+; Return C code to record profile data for modeling use.
+; In the case of a register, this is usually the register's number.
+; This shouldn't be called in the case of a scalar, the code should be
+; smart enough to know there is no need.
+
+(define (op:record-profile op sfmt out?)
+  (let ((estate (estate-make-for-normal-rtl-c nil nil)))
+    (send op 'gen-record-profile sfmt out? estate))
+)
+
+; Return C code to record the data needed for profiling operand SELF.
+; This is done during extraction.
+
+(method-make!
+ <operand> 'gen-record-profile
+ (lambda (self sfmt out? estate)
+   (if (hw-scalar? (op:type self))
+       ""
+       (string-append "      "
+                     (gen-argbuf-ref (string-append (if out? "out_" "in_")
+                                                     (gen-sym self)))
+                     " = "
+                     (send (op:type self) 'gen-record-profile
+                           (op:index self) sfmt estate)
+                     ";\n")))
+)
+
+; Return C code to track profiling of operand SELF.
+; This is usually called by the x-after handler.
+
+(method-make!
+ <operand> 'gen-profile-code
+ (lambda (self insn out?)
+   (string-append "  "
+                 "@cpu@_model_mark_"
+                 (if out? "set_" "get_")
+                 (gen-sym (op:type self))
+                 " (current_cpu"
+                 (if (hw-scalar? (op:type self))
+                     ""
+                     (string-append ", "
+                                    (gen-argbuf-ref
+                                     (string-append (if out? "out_" "in_")
+                                                    (gen-sym self)))))
+                 ");\n"))
+)
+\f
+; CPU, mach, model support.
+
+; Return the declaration of the cpu/insn enum.
+
+(define (gen-cpu-insn-enum-decl cpu insn-list)
+  (gen-enum-decl "@cpu@_insn_type"
+                "instructions in cpu family @cpu@"
+                "@CPU@_INSN_"
+                (append! (map (lambda (i)
+                                (cons (obj:name i)
+                                      (cons '-
+                                            (atlist-attrs (obj-atlist i)))))
+                              insn-list)
+                         (if (with-parallel?)
+                             (apply append!
+                                    (map (lambda (i)
+                                           (list
+                                            (cons (symbol-append 'par- (obj:name i))
+                                                  (cons '-
+                                                        (atlist-attrs (obj-atlist i))))
+                                            (cons (symbol-append 'write- (obj:name i))
+                                                  (cons '-
+                                                        (atlist-attrs (obj-atlist i))))))
+                                         (parallel-insns insn-list)))
+                             nil)
+                         (list '(max))))
+)
+
+; Return the enum of INSN in cpu family CPU.
+; In addition to CGEN_INSN_TYPE, an enum is created for each insn in each
+; cpu family.  This collapses the insn enum space for each cpu to increase
+; cache efficiently (since the IDESC table is similarily collapsed).
+
+(define (gen-cpu-insn-enum cpu insn)
+  (string-upcase (string-append "@CPU@_INSN_" (gen-sym insn)))
+)
+
+; Return C code to declare the machine data.
+
+(define (-gen-mach-decls)
+  (string-append
+   (string-map (lambda (mach)
+                (gen-obj-sanitize mach
+                                  (string-append "extern const MACH "
+                                                 (gen-sym mach)
+                                                 "_mach;\n")))
+              (current-mach-list))
+   "\n")
+)
+
+; Return C code to define the machine data.
+
+(define (-gen-mach-data)
+  (string-append
+   "const MACH *sim_machs[] =\n{\n"
+   (string-map (lambda (mach)
+                (gen-obj-sanitize
+                 mach
+                 (string-append "#ifdef " (gen-have-cpu (mach-cpu mach)) "\n"
+                                "  & " (gen-sym mach) "_mach,\n"
+                                "#endif\n")))
+              (current-mach-list))
+   "  0\n"
+   "};\n\n"
+   )
+)
+
+; Return C declarations of cpu model support stuff.
+; ??? This goes in arch.h but a better place is each cpu.h.
+
+(define (-gen-arch-model-decls)
+  (string-append
+   (gen-enum-decl 'model_type "model types"
+                 "MODEL_"
+                 (append (map (lambda (model)
+                                (cons (obj:name model)
+                                      (cons '-
+                                            (atlist-attrs (obj-atlist model)))))
+                              (current-model-list))
+                         '((max))))
+   "#define MAX_MODELS ((int) MODEL_MAX)\n\n"
+   (gen-enum-decl 'unit_type "unit types"
+                 "UNIT_"
+                 (cons '(none)
+                       (append
+                        ; "apply append" squeezes out nils.
+                        (apply append
+                               ; create <model_name>-<unit-name> for each unit
+                               (map (lambda (model)
+                                      (let ((units (model:units model)))
+                                        (if (null? units)
+                                            nil
+                                            (map (lambda (unit)
+                                                   (cons (symbol-append (obj:name model) '-
+                                                                        (obj:name unit))
+                                                         (cons '- (atlist-attrs (obj-atlist model)))))
+                                                 units))))
+                                    (current-model-list)))
+                        '((max)))))
+   ; FIXME: revisit MAX_UNITS
+   "#define MAX_UNITS ("
+   (number->string
+    (apply max
+          (map (lambda (lengths) (apply max lengths))
+               (map (lambda (insn)
+                      (let ((timing (insn-timing insn)))
+                        (if (null? timing)
+                            '(1)
+                            (map (lambda (insn-timing)
+                                   (length (timing:units (cdr insn-timing))))
+                                 timing))))
+                    (current-insn-list)))))
+   ")\n\n"
+   )
+)
+\f
+; Function units.
+
+(method-make! <unit> 'gen-decl (lambda (self) ""))
+
+; Lookup operand named OP-NAME in INSN.
+; Returns #f if OP-NAME is not an operand of INSN.
+; IN-OUT is 'in to request an input operand, 'out to request an output operand,
+; and 'in-out to request either (though if an operand is used for input and
+; output then the input version is returned).
+; FIXME: Move elsewhere.
+
+(define (insn-op-lookup op-name insn in-out)
+  (letrec ((lookup (lambda (op-list)
+                    (cond ((null? op-list) #f)
+                          ((eq? op-name (op:sem-name (car op-list))) (car op-list))
+                          (else (lookup (cdr op-list)))))))
+    (case in-out
+      ((in) (lookup (sfmt-in-ops (insn-sfmt insn))))
+      ((out) (lookup (sfmt-out-ops (insn-sfmt insn))))
+      ((in-out) (or (lookup (sfmt-in-ops (insn-sfmt insn)))
+                   (lookup (sfmt-out-ops (insn-sfmt insn)))))
+      (else (error "insn-op-lookup: bad arg:" in-out))))
+)
+
+; Return C code to profile a unit's usage.
+; UNIT-NUM is number of the unit in INSN.
+; OVERRIDES is a list of (name value) pairs, where
+; - NAME is a spec name, one of cycles, pred, in, out.
+;   The only ones we're concerned with are in,out.  They map operand names
+;   as they appear in the semantic code to operand names as they appear in
+;   the function unit spec.
+; - VALUE is the operand to NAME.  For in,out it is (NAME VALUE) where
+;   - NAME is the name of an input/output arg of the unit.
+;   - VALUE is the name of the operand as it appears in semantic code.
+;
+; ??? This is a big sucker, though half of it is just the definitions
+; of utility fns.
+
+(method-make!
+ <unit> 'gen-profile-code
+ (lambda (self unit-num insn overrides cycles-var-name)
+   (let (
+        (inputs (unit:inputs self))
+        (outputs (unit:outputs self))
+
+         ; Return C code to initialize UNIT-REFERENCED-VAR to be a bit mask
+         ; of operands of UNIT that were read/written by INSN.
+         ; INSN-REFERENCED-VAR is a bitmask of operands read/written by INSN.
+         ; All we have to do is map INSN-REFERENCED-VAR to
+         ; UNIT-REFERENCED-VAR.
+         ; ??? For now we assume all input operands are read.
+         (gen-ref-arg (lambda (arg num in-out)
+                        (let* ((op-name (assq-ref overrides (car arg)))
+                               (op (insn-op-lookup (if op-name
+                                                       (car op-name)
+                                                       (car arg))
+                                                   insn in-out))
+                               (insn-referenced-var "insn_referenced")
+                               (unit-referenced-var "referenced"))
+                          (if op
+                              (if (op:cond? op)
+                                  (string-append "    "
+                                                 "if ("
+                                                 insn-referenced-var
+                                                 " & (1 << "
+                                                 (number->string (op:num op))
+                                                 ")) "
+                                                 unit-referenced-var
+                                                 " |= 1 << "
+                                                 (number->string num)
+                                                 ";\n")
+                                  (string-append "    "
+                                                 unit-referenced-var
+                                                 " |= 1 << "
+                                                 (number->string num)
+                                                 ";\n"))
+                              ""))))
+
+         ; Initialize unit argument ARG.
+         ; OUT? is #f for input args, #t for output args.
+         (gen-arg-init (lambda (arg out?)
+                         (if (or
+                              ; Ignore scalars.
+                              (null? (cdr arg))
+                              ; Ignore remapped arg, handled elsewhere.
+                              (assq (car arg) overrides)
+                              ; Ignore operands not in INSN.
+                              (not (insn-op-lookup (car arg) insn
+                                                   (if out? 'out 'in))))
+                             ""
+                             (string-append "    "
+                                            (if out? "out_" "in_")
+                                            (gen-c-symbol (car arg))
+                                            " = "
+                                            (gen-argbuf-ref
+                                             (string-append (if out? "out_" "in_")
+                                                            (gen-c-symbol (car arg))))
+                                            ";\n"))))
+
+         ; Return C code to declare variable to hold unit argument ARG.
+         ; OUT? is #f for input args, #t for output args.
+         (gen-arg-decl (lambda (arg out?)
+                         (if (null? (cdr arg)) ; ignore scalars
+                             ""
+                             (string-append "    "
+                                            (mode:c-type (mode:lookup (cadr arg)))
+                                            " "
+                                            (if out? "out_" "in_")
+                                            (gen-c-symbol (car arg))
+                                            " = "
+                                            (if (null? (cddr arg))
+                                                "0"
+                                                (number->string (caddr arg)))
+                                            ";\n"))))
+
+         ; Return C code to pass unit argument ARG to the handler.
+         ; OUT? is #f for input args, #t for output args.
+         (gen-arg-arg (lambda (arg out?)
+                        (if (null? (cdr arg)) ; ignore scalars
+                            ""
+                            (string-append ", "
+                                           (if out? "out_" "in_")
+                                           (gen-c-symbol (car arg))))))
+         )
+
+     (string-list
+      "  {\n"
+      "    int referenced = 0;\n"
+      "    int UNUSED insn_referenced = abuf->written;\n"
+      ; Declare variables to hold unit arguments.
+      (string-map (lambda (arg) (gen-arg-decl arg #f))
+                 inputs)
+      (string-map (lambda (arg) (gen-arg-decl arg #t))
+                 outputs)
+      ; Initialize 'em, being careful not to initialize an operand that
+      ; has an override.
+      (let (; Make a list of names of in/out overrides.
+           (in-overrides (find-apply cadr
+                                     (lambda (elm) (eq? (car elm) 'in))
+                                     overrides))
+           (out-overrides (find-apply cadr
+                                     (lambda (elm) (eq? (car elm) 'out))
+                                     overrides)))
+       (string-list
+        (string-map (lambda (arg)
+                      (if (memq (car arg) in-overrides)
+                          ""
+                          (gen-arg-init arg #f)))
+                    inputs)
+        (string-map (lambda (arg)
+                      (if (memq (car arg) out-overrides)
+                          ""
+                          (gen-arg-init arg #t)))
+                    outputs)))
+      (string-map (lambda (arg)
+                   (case (car arg)
+                     ((pred) "")
+                     ((cycles) "")
+                     ((in)
+                      (if (caddr arg)
+                          (string-append "    in_"
+                                         (gen-c-symbol (cadr arg))
+                                         " = "
+                                         (gen-argbuf-ref
+                                          (string-append
+                                           "in_"
+                                           (gen-c-symbol (caddr arg))))
+                                         ";\n")
+                          ""))
+                     ((out)
+                      (if (caddr arg)
+                          (string-append "    out_"
+                                         (gen-c-symbol (cadr arg))
+                                         " = "
+                                         (gen-argbuf-ref
+                                          (string-append
+                                           "out_"
+                                           (gen-c-symbol (caddr arg))))
+                                         ";\n")
+                          ""))
+                     (else
+                      (parse-error "insn function unit spec"
+                                   "invalid spec" arg))))
+                 overrides)
+      ; Create bitmask indicating which args were referenced.
+      (string-map (lambda (arg num) (gen-ref-arg arg num 'in))
+                 inputs
+                 (iota (length inputs)))
+      (string-map (lambda (arg num) (gen-ref-arg arg num 'out))
+                 outputs
+                 (iota (length inputs)
+                       (length outputs)))
+      ; Emit the call to the handler.
+      "    " cycles-var-name " += "
+      (gen-model-unit-fn-name (unit:model self) self)
+      " (current_cpu, idesc"
+      ", " (number->string unit-num)
+      ", referenced"
+      (string-map (lambda (arg) (gen-arg-arg arg #f))
+                 inputs)
+      (string-map (lambda (arg) (gen-arg-arg arg #t))
+                 outputs)
+      ");\n"
+      "  }\n"
+      )))
+)
+
+; Return C code to profile an insn-specific unit's usage.
+; UNIT-NUM is number of the unit in INSN.
+
+(method-make!
+ <iunit> 'gen-profile-code
+ (lambda (self unit-num insn cycles-var-name)
+   (let ((args (iunit:args self))
+        (unit (iunit:unit self)))
+     (send unit 'gen-profile-code unit-num insn args cycles-var-name)))
+)
+\f
+; ARGBUF generation.
+; ARGBUF support is put in cpuall.h, which doesn't depend on sim-cpu.scm,
+; so this support is here.
+
+; Utility of -gen-argbuf-fields-union to generate the definition for
+; <sformat-abuf> SBUF.
+
+(define (-gen-argbuf-elm sbuf)
+  (logit 2 "Processing sbuf format " (obj:name sbuf) " ...\n")
+  (string-list
+   "  struct { /* " (obj:comment sbuf) " */\n"
+   (let ((elms (sbuf-elms sbuf)))
+     (if (null? elms)
+        "    int empty;\n"
+        (string-list-map (lambda (elm)
+                           (string-append "    "
+                                          (cadr elm)
+                                          " "
+                                          (car elm)
+                                          ";\n"))
+                         (sbuf-elms sbuf))))
+   "  } " (gen-sym sbuf) ";\n")
+)
+
+; Utility of gen-argbuf-type to generate the union of extracted ifields.
+
+(define (-gen-argbuf-fields-union)
+  (string-list
+   "\
+/* Instruction argument buffer.  */
+
+union sem_fields {\n"
+   (string-list-map -gen-argbuf-elm (current-sbuf-list))
+   "\
+#if WITH_SCACHE_PBB
+  /* Writeback handler.  */
+  struct {
+    /* Pointer to argbuf entry for insn whose results need writing back.  */
+    const struct argbuf *abuf;
+  } write;
+  /* x-before handler */
+  struct {
+    /*const SCACHE *insns[MAX_PARALLEL_INSNS];*/
+    int first_p;
+  } before;
+  /* x-after handler */
+  struct {
+    int empty;
+  } after;
+  /* This entry is used to terminate each pbb.  */
+  struct {
+    /* Number of insns in pbb.  */
+    int insn_count;
+    /* Next pbb to execute.  */
+    SCACHE *next;
+    SCACHE *branch_target;
+  } chain;
+#endif
+};\n\n"
+   )
+)
+
+; Generate the definition of the structure that records arguments.
+; This is a union of structures with one structure for each insn format.
+; It also includes hardware profiling information and miscellaneous
+; administrivia.
+; CPU-DATA? is #t if data for the currently selected cpu is to be included.
+
+(define (gen-argbuf-type cpu-data?)
+  (logit 2 "Generating ARGBUF type ...\n")
+  (string-list
+   (if (and cpu-data? (with-scache?))
+       (-gen-argbuf-fields-union)
+       "")
+   (if cpu-data? "" "#ifndef WANT_CPU\n")
+   "\
+/* The ARGBUF struct.  */
+struct argbuf {
+  /* These are the baseclass definitions.  */
+  IADDR addr;
+  const IDESC *idesc;
+  char trace_p;
+  char profile_p;
+  /* ??? Temporary hack for skip insns.  */
+  char skip_count;
+  char unused;
+  /* cpu specific data follows */\n"
+   (if cpu-data?
+       (if (with-scache?)
+           "\
+  union sem semantic;
+  int written;
+  union sem_fields fields;\n"
+           "\
+  CGEN_INSN_INT insn;
+  int written;\n")
+       "")
+   "};\n"
+   (if cpu-data? "" "#endif\n")
+   "\n"
+   )
+)
+
+; Generate the definition of the structure that records a cached insn.
+; This is cpu family specific (member `argbuf' is) so it is machine generated.
+; CPU-DATA? is #t if data for the currently selected cpu is to be included.
+
+(define (gen-scache-type cpu-data?)
+  (logit 2 "Generating SCACHE type ...\n")
+  (string-append
+   (if cpu-data? "" "#ifndef WANT_CPU\n")
+   "\
+/* A cached insn.
+
+   ??? SCACHE used to contain more than just argbuf.  We could delete the
+   type entirely and always just use ARGBUF, but for future concerns and as
+   a level of abstraction it is left in.  */
+
+struct scache {
+  struct argbuf argbuf;\n"
+   (if (with-generic-write?) "\
+  int first_insn_p;
+  int last_insn_p;\n" "")
+   "};\n"
+   (if cpu-data? "" "#endif\n")
+   "\n"
+  )
+)
+\f
+; Mode support.
+
+; Generate a table of mode data.
+; For now all we need is the names.
+
+(define (gen-mode-defs)
+  (string-append
+   "const char *mode_names[] = {\n"
+   (string-map (lambda (m)
+                (string-append "  \"" (string-upcase (obj:name m)) "\",\n"))
+              ; We don't treat aliases as being different from the real
+              ; mode here, so ignore them.
+              (mode-list-non-alias-values))
+   "};\n\n"
+   )
+)
+\f
+; Insn profiling support.
+
+; Generate declarations for local variables needed for modelling code.
+
+(method-make!
+ <insn> 'gen-profile-locals
+ (lambda (self model)
+;   (let ((cti? (or (has-attr? self 'UNCOND-CTI)
+;                 (has-attr? self 'COND-CTI))))
+;     (string-append
+;      (if cti? "  int UNUSED taken_p = 0;\n" "")
+;      ))
+   "")
+)
+
+; Generate C code to profile INSN.
+
+(method-make!
+ <insn> 'gen-profile-code
+ (lambda (self model cycles-var-name)
+   (string-list
+    (let ((timing (assq-ref (insn-timing self) (obj:name model))))
+      (if timing
+         (string-list-map (lambda (iunit unit-num)
+                            (send iunit 'gen-profile-code unit-num self cycles-var-name))
+                          (timing:units timing)
+                          (iota (length (timing:units timing))))
+         (send (model-default-unit model) 'gen-profile-code 0 self nil cycles-var-name)))
+    ))
+)
+\f
+; .cpu file loading support
+
+; Only run sim-analyze-insns! once.
+(define -sim-insns-analyzed? #f)
+
+; List of computed sformat argument buffers.
+(define -sim-sformat-abuf-list #f)
+(define (current-sbuf-list) -sim-sformat-abuf-list)
+
+; Called before/after the .cpu file has been read in.
+
+(define (sim-init!)
+  (set! -sim-insns-analyzed? #f)
+  (set! -sim-sformat-abuf-list #f)
+  *UNSPECIFIED*
+)
+
+(define (sim-finish!)
+  ; Add begin,chain,before,after,invalid handlers if not provided.
+  ; The code generators should first look for x-foo-@cpu@, then for x-foo.
+  ; ??? This is good enough for the first pass.  Will eventually need to use
+  ; less C and more RTL.
+
+  (let ((all (stringize (current-arch-isa-name-list) ",")))
+
+    (define-full-insn 'x-begin "pbb begin handler"
+      `(VIRTUAL PBB (ISA ,all))
+      "--begin--" () () '(c-code VOID "\
+  {
+#if WITH_SCACHE_PBB_@CPU@
+#ifdef DEFINE_SWITCH
+    /* In the switch case FAST_P is a constant, allowing several optimizations
+       in any called inline functions.  */
+    vpc = @cpu@_pbb_begin (current_cpu, FAST_P);
+#else
+    vpc = @cpu@_pbb_begin (current_cpu, STATE_RUN_FAST_P (CPU_STATE (current_cpu)));
+#endif
+#endif
+  }
+") nil)
+
+    (define-full-insn 'x-chain "pbb chain handler"
+      `(VIRTUAL PBB (ISA ,all))
+      "--chain--" () () '(c-code VOID "\
+  {
+#if WITH_SCACHE_PBB_@CPU@
+    vpc = @cpu@_pbb_chain (current_cpu, sem_arg);
+#ifdef DEFINE_SWITCH
+    BREAK (sem);
+#endif
+#endif
+  }
+") nil)
+
+    (define-full-insn 'x-cti-chain "pbb cti-chain handler"
+      `(VIRTUAL PBB (ISA ,all))
+      "--cti-chain--" () () '(c-code VOID "\
+  {
+#if WITH_SCACHE_PBB_@CPU@
+#ifdef DEFINE_SWITCH
+    vpc = @cpu@_pbb_cti_chain (current_cpu, sem_arg,
+                              pbb_br_type, pbb_br_npc);
+    BREAK (sem);
+#else
+    /* FIXME: Allow provision of explicit ifmt spec in insn spec.  */
+    vpc = @cpu@_pbb_cti_chain (current_cpu, sem_arg,
+                              CPU_PBB_BR_TYPE (current_cpu),
+                              CPU_PBB_BR_NPC (current_cpu));
+#endif
+#endif
+  }
+") nil)
+
+    (define-full-insn 'x-before "pbb begin handler"
+      `(VIRTUAL PBB (ISA ,all))
+      "--before--" () () '(c-code VOID "\
+  {
+#if WITH_SCACHE_PBB_@CPU@
+    @cpu@_pbb_before (current_cpu, sem_arg);
+#endif
+  }
+") nil)
+
+    (define-full-insn 'x-after "pbb after handler"
+      `(VIRTUAL PBB (ISA ,all))
+      "--after--" () () '(c-code VOID "\
+  {
+#if WITH_SCACHE_PBB_@CPU@
+    @cpu@_pbb_after (current_cpu, sem_arg);
+#endif
+  }
+") nil)
+
+    (define-full-insn 'x-invalid "invalid insn handler"
+      `(VIRTUAL (ISA ,all))
+      "--invalid--" () () (list 'c-code 'VOID (string-append "\
+  {
+    /* Update the recorded pc in the cpu state struct.
+       Only necessary for WITH_SCACHE case, but to avoid the
+       conditional compilation ....  */
+    SET_H_PC (pc);
+    /* Virtual insns have zero size.  Overwrite vpc with address of next insn
+       using the default-insn-bitsize spec.  When executing insns in parallel
+       we may want to queue the fault and continue execution.  */
+    vpc = SEM_NEXT_VPC (sem_arg, pc, " (number->string (bits->bytes (state-default-insn-bitsize))) ");
+    vpc = sim_engine_invalid_insn (current_cpu, pc, vpc);
+  }
+")) nil))
+  
+  *UNSPECIFIED*
+)
+
+; Called after file is read in and global error checks are done
+; to initialize tables.
+
+(define (sim-analyze!)
+  *UNSPECIFIED*
+)
+
+; Scan insns, analyzing semantics and computing instruction formats.
+; 'twould be nice to do this in sim-analyze! but it doesn't know whether this
+; needs to be done or not (which is determined by what files are being
+; generated).  Since this is an expensive operation, we defer doing this
+; to the files that need it.
+
+(define (sim-analyze-insns!)
+  ; This can only be done if one isa and one cpu family is being kept.
+  (assert-keep-one)
+
+  (if (not -sim-insns-analyzed?)
+
+      (begin
+       (arch-analyze-insns! CURRENT-ARCH
+                            #f ; don't include aliases
+                            #t) ; do analyze the semantics
+
+       ; Compute the set of sformat argument buffers.
+       (set! -sim-sformat-abuf-list (compute-sformat-argbufs! (current-sfmt-list)))
+
+       (set! -sim-insns-analyzed? #t)))
+
+  ; Do our own error checking.
+  (assert (current-insn-lookup 'x-invalid))
+
+  *UNSPECIFIED*
+)
+\f
+; For debugging.
+
+(define (cgen-all-arch)
+  (string-write
+   cgen-arch.h
+   cgen-arch.c
+   cgen-cpuall.h
+   ;cgen-mem-ops.h
+   ;cgen-sem-ops.h
+   ;cgen-ops.c
+   )
+)
+
+(define (cgen-all-cpu)
+  (string-write
+   cgen-cpu.h
+   cgen-cpu.c
+   cgen-decode.h
+   cgen-decode.c
+   ;cgen-extract.c
+   cgen-read.c
+   cgen-write.c
+   cgen-semantics.c
+   cgen-sem-switch.c
+   cgen-model.c
+   ;cgen-mainloop.in
+   )
+)
diff --git a/cgen/simplify.inc b/cgen/simplify.inc
new file mode 100644 (file)
index 0000000..7ccd6fd
--- /dev/null
@@ -0,0 +1,198 @@
+; Collection of macros to simplify .cpu file writing. -*- Scheme -*-
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+\f
+; Enums.
+
+; Define a normal enum without using name/value pairs.
+; This is currently the same as define-full-enum but it needn't remain
+; that way (it's define-full-enum that would change).
+
+(define-pmacro (define-normal-enum name comment attrs prefix vals)
+  "\
+Define a normal enum, fixed number of arguments.
+"
+  (define-full-enum name comment attrs prefix vals)
+)
+
+; Define a normal insn enum.
+
+(define-pmacro (define-normal-insn-enum name comment attrs prefix fld vals)
+  "\
+Define a normal instruction opcode enum.
+"
+  (define-full-insn-enum name comment attrs prefix fld vals)
+)
+\f
+; Instruction fields.
+
+; Normally, fields are unsigned have no encode/decode needs.
+
+(define-pmacro (define-normal-ifield name comment attrs start length)
+  "Define a normal instruction field.\n"
+  (define-full-ifield name comment attrs start length UINT #f #f)
+)
+
+; For those who don't like typing.
+
+(define-pmacro df
+  "Shorthand form of define-full-ifield.\n"
+  define-full-ifield
+)
+(define-pmacro dnf
+  "Shorthand form of define-normal-ifield.\n"
+  define-normal-ifield
+)
+
+; Define a normal multi-ifield.
+; FIXME: The define-normal version for ifields doesn't include the mode.
+
+(define-pmacro (define-normal-multi-ifield name comment attrs
+                mode subflds insert extract)
+  "Define a normal multi-part instruction field.\n"
+  (define-full-multi-ifield name comment attrs mode subflds insert extract)
+)
+
+; For those who don't like typing.
+
+(define-pmacro dnmf
+  "Shorthand form of define-normal-multi-ifield.\n"
+  define-normal-multi-ifield
+)
+
+; Simple multi-ifields: mode is UINT, default insert/extract support.
+
+(define-pmacro (dsmf name comment attrs subflds)
+  "Define a simple multi-part instruction field.\n"
+  (define-full-multi-ifield name comment attrs UINT subflds #f #f)
+)
+\f
+; Hardware.
+
+; Simpler version for most hardware elements.
+; Allow special assembler support specification but no semantic-name or
+; get/set specs.
+
+(define-pmacro (define-normal-hardware name comment attrs type
+                indices values handlers)
+  "\
+Define a normal hardware element.
+"
+  (define-full-hardware name comment attrs name type
+    indices values handlers () () ())
+)
+
+; For those who don't like typing.
+
+(define-pmacro dnh
+  "Shorthand form of define-normal-hardware.\n"
+  define-normal-hardware
+)
+
+; Simpler version of dnh that leaves out the indices, values, handlers,
+; get, set, and layout specs.
+; This is useful for 1 bit registers.
+; ??? While dsh and dnh aren't that distinguishable when perusing a .cpu file,
+; they both take a fixed number of positional arguments, and dsh is a proper
+; subset of dnh with all arguments in the same positions, so methinks things
+; are ok.
+
+(define-pmacro (define-simple-hardware name comment attrs type)
+  "\
+Define a simple hardware element (usually a scalar register).
+"
+  (define-full-hardware name comment attrs name type () () () () () ())
+)
+
+(define-pmacro dsh
+  "Shorthand form of define-simple-hardware.\n"
+  define-simple-hardware
+)
+\f
+; Operands.
+
+(define-pmacro (define-normal-operand name comment attrs type index)
+  "Define a normal operand.\n"
+  (define-full-operand name comment attrs type DFLT index () () ())
+)
+
+; For those who don't like typing.
+; FIXME: dno?
+
+(define-pmacro dnop
+  "Shorthand form of define-normal-operand.\n"
+  define-normal-operand
+)
+
+(define-pmacro (dndo x-name x-mode x-args
+                    x-syntax x-base-ifield x-encoding x-ifield-assertion
+                    x-getter x-setter)
+  "Define a normal derived operand."
+  (define-derived-operand
+    (name x-name)
+    (mode x-mode)
+    (args x-args)
+    (syntax x-syntax)
+    (base-ifield x-base-ifield)
+    (encoding x-encoding)
+    (ifield-assertion x-ifield-assertion)
+    (getter x-getter)
+    (setter x-setter)
+    )
+)
+\f
+; Instructions.
+
+; Define an instruction object, normal version.
+; At present all fields must be specified.
+; Fields ifield-assertion is absent.
+
+(define-pmacro (define-normal-insn name comment attrs syntax fmt semantics timing)
+  "Define a normal instruction.\n"
+  (define-full-insn name comment attrs syntax fmt () semantics timing)
+)
+
+; To reduce the amount of typing.
+; Note that this is the same name as the D'ni in MYST.  Oooohhhh.....
+; this must be the right way to go. :-)
+
+(define-pmacro dni
+  "Shorthand form of define-normal-insn.\n"
+  define-normal-insn
+)
+\f
+; Macro instructions.
+
+; Define a macro-insn object, normal version.
+; This only supports expanding to one real insn.
+
+(define-pmacro (define-normal-macro-insn name comment attrs syntax expansion)
+  "Define a normal macro instruction.\n"
+  (define-full-minsn name comment attrs syntax expansion)
+)
+
+; To reduce the amount of typing.
+
+(define-pmacro dnmi
+  "Shorthand form of define-normal-macro-insn.\n"
+  define-normal-macro-insn
+)
+\f
+; Modes.
+; ??? Not currently available for use.
+;
+; Define Normal Mode
+;
+;(define-pmacro (define-normal-mode name comment attrs bits bytes
+;               non-mode-c-type printf-type sem-mode ptr-to host?)
+;  "Define a normal mode.\n"
+;  (define-full-mode name comment attrs bits bytes
+;    non-mode-c-type printf-type sem-mode ptr-to host?)
+;)
+;
+; For those who don't like typing.
+;(define-pmacro dnm
+;  "Shorthand form of define-normal-mode.\n"
+;  define-normal-mode
+;)
diff --git a/cgen/slib/genwrite.scm b/cgen/slib/genwrite.scm
new file mode 100644 (file)
index 0000000..f57d773
--- /dev/null
@@ -0,0 +1,270 @@
+;;"genwrite.scm" generic write used by pretty-print and truncated-print.
+;; Copyright (c) 1991, Marc Feeley
+;; Author: Marc Feeley (feeley@iro.umontreal.ca)
+;; Distribution restrictions: none
+
+(define (generic-write obj display? width output)
+
+  (define (read-macro? l)
+    (define (length1? l) (and (pair? l) (null? (cdr l))))
+    (let ((head (car l)) (tail (cdr l)))
+      (case head
+        ((QUOTE QUASIQUOTE UNQUOTE UNQUOTE-SPLICING) (length1? tail))
+        (else                                        #f))))
+
+  (define (read-macro-body l)
+    (cadr l))
+
+  (define (read-macro-prefix l)
+    (let ((head (car l)) (tail (cdr l)))
+      (case head
+        ((QUOTE)            "'")
+        ((QUASIQUOTE)       "`")
+        ((UNQUOTE)          ",")
+        ((UNQUOTE-SPLICING) ",@"))))
+
+  (define (out str col)
+    (and col (output str) (+ col (string-length str))))
+
+  (define (wr obj col)
+
+    (define (wr-expr expr col)
+      (if (read-macro? expr)
+        (wr (read-macro-body expr) (out (read-macro-prefix expr) col))
+        (wr-lst expr col)))
+
+    (define (wr-lst l col)
+      (if (pair? l)
+         (let loop ((l (cdr l))
+                    (col (and col (wr (car l) (out "(" col)))))
+           (cond ((not col) col)
+                 ((pair? l)
+                  (loop (cdr l) (wr (car l) (out " " col))))
+                 ((null? l) (out ")" col))
+                 (else      (out ")" (wr l (out " . " col))))))
+         (out "()" col)))
+
+    (cond ((pair? obj)        (wr-expr obj col))
+          ((null? obj)        (wr-lst obj col))
+          ((vector? obj)      (wr-lst (vector->list obj) (out "#" col)))
+          ((boolean? obj)     (out (if obj "#t" "#f") col))
+          ((number? obj)      (out (number->string obj) col))
+          ((symbol? obj)      (out (symbol->string obj) col))
+          ((procedure? obj)   (out "#[procedure]" col))
+          ((string? obj)      (if display?
+                                (out obj col)
+                                (let loop ((i 0) (j 0) (col (out "\"" col)))
+                                  (if (and col (< j (string-length obj)))
+                                    (let ((c (string-ref obj j)))
+                                      (if (or (char=? c #\\)
+                                              (char=? c #\"))
+                                        (loop j
+                                              (+ j 1)
+                                              (out "\\"
+                                                   (out (substring obj i j)
+                                                        col)))
+                                        (loop i (+ j 1) col)))
+                                    (out "\""
+                                         (out (substring obj i j) col))))))
+          ((char? obj)        (if display?
+                                (out (make-string 1 obj) col)
+                                (out (case obj
+                                       ((#\space)   "space")
+                                       ((#\newline) "newline")
+                                       (else        (make-string 1 obj)))
+                                     (out "#\\" col))))
+          ((input-port? obj)  (out "#[input-port]" col))
+          ((output-port? obj) (out "#[output-port]" col))
+          ((eof-object? obj)  (out "#[eof-object]" col))
+          ((keyword? obj)  (let* ((o (symbol->string 
+                                        (keyword-dash-symbol obj)))
+                                  (oo (list->string 
+                                       (append (list #\# #\:)
+                                               (cdr (string->list o))))))
+                                (out oo col)))
+          (else               (out "#[unknown]" col))))
+
+  (define (pp obj col)
+
+    (define (spaces n col)
+      (if (> n 0)
+        (if (> n 7)
+          (spaces (- n 8) (out "        " col))
+          (out (substring "        " 0 n) col))
+        col))
+
+    (define (indent to col)
+      (and col
+           (if (< to col)
+             (and (out (make-string 1 #\newline) col) (spaces to 0))
+             (spaces (- to col) col))))
+
+    (define (pr obj col extra pp-pair)
+      (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
+        (let ((result '())
+              (left (min (+ (- (- width col) extra) 1) max-expr-width)))
+          (generic-write obj display? #f
+            (lambda (str)
+              (set! result (cons str result))
+              (set! left (- left (string-length str)))
+              (> left 0)))
+          (if (> left 0) ; all can be printed on one line
+            (out (reverse-string-append result) col)
+            (if (pair? obj)
+              (pp-pair obj col extra)
+              (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
+        (wr obj col)))
+
+    (define (pp-expr expr col extra)
+      (if (read-macro? expr)
+        (pr (read-macro-body expr)
+            (out (read-macro-prefix expr) col)
+            extra
+            pp-expr)
+        (let ((head (car expr)))
+          (if (symbol? head)
+            (let ((proc (style head)))
+              (if proc
+                (proc expr col extra)
+                (if (> (string-length (symbol->string head))
+                       max-call-head-width)
+                  (pp-general expr col extra #f #f #f pp-expr)
+                  (pp-call expr col extra pp-expr))))
+            (pp-list expr col extra pp-expr)))))
+
+    ; (head item1
+    ;       item2
+    ;       item3)
+    (define (pp-call expr col extra pp-item)
+      (let ((col* (wr (car expr) (out "(" col))))
+        (and col
+             (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
+
+    ; (item1
+    ;  item2
+    ;  item3)
+    (define (pp-list l col extra pp-item)
+      (let ((col (out "(" col)))
+        (pp-down l col col extra pp-item)))
+
+    (define (pp-down l col1 col2 extra pp-item)
+      (let loop ((l l) (col col1))
+        (and col
+             (cond ((pair? l)
+                    (let ((rest (cdr l)))
+                      (let ((extra (if (null? rest) (+ extra 1) 0)))
+                        (loop rest
+                              (pr (car l) (indent col2 col) extra pp-item)))))
+                   ((null? l)
+                    (out ")" col))
+                   (else
+                    (out ")"
+                         (pr l
+                             (indent col2 (out "." (indent col2 col)))
+                             (+ extra 1)
+                             pp-item)))))))
+
+    (define (pp-general expr col extra named? pp-1 pp-2 pp-3)
+
+      (define (tail1 rest col1 col2 col3)
+        (if (and pp-1 (pair? rest))
+          (let* ((val1 (car rest))
+                 (rest (cdr rest))
+                 (extra (if (null? rest) (+ extra 1) 0)))
+            (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
+          (tail2 rest col1 col2 col3)))
+
+      (define (tail2 rest col1 col2 col3)
+        (if (and pp-2 (pair? rest))
+          (let* ((val1 (car rest))
+                 (rest (cdr rest))
+                 (extra (if (null? rest) (+ extra 1) 0)))
+            (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
+          (tail3 rest col1 col2)))
+
+      (define (tail3 rest col1 col2)
+        (pp-down rest col2 col1 extra pp-3))
+
+      (let* ((head (car expr))
+             (rest (cdr expr))
+             (col* (wr head (out "(" col))))
+        (if (and named? (pair? rest))
+          (let* ((name (car rest))
+                 (rest (cdr rest))
+                 (col** (wr name (out " " col*))))
+            (tail1 rest (+ col indent-general) col** (+ col** 1)))
+          (tail1 rest (+ col indent-general) col* (+ col* 1)))))
+
+    (define (pp-expr-list l col extra)
+      (pp-list l col extra pp-expr))
+
+    (define (pp-LAMBDA expr col extra)
+      (pp-general expr col extra #f pp-expr-list #f pp-expr))
+
+    (define (pp-IF expr col extra)
+      (pp-general expr col extra #f pp-expr #f pp-expr))
+
+    (define (pp-COND expr col extra)
+      (pp-call expr col extra pp-expr-list))
+
+    (define (pp-CASE expr col extra)
+      (pp-general expr col extra #f pp-expr #f pp-expr-list))
+
+    (define (pp-AND expr col extra)
+      (pp-call expr col extra pp-expr))
+
+    (define (pp-LET expr col extra)
+      (let* ((rest (cdr expr))
+             (named? (and (pair? rest) (symbol? (car rest)))))
+        (pp-general expr col extra named? pp-expr-list #f pp-expr)))
+
+    (define (pp-BEGIN expr col extra)
+      (pp-general expr col extra #f #f #f pp-expr))
+
+    (define (pp-DO expr col extra)
+      (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
+
+    ; define formatting style (change these to suit your style)
+
+    (define indent-general 2)
+
+    (define max-call-head-width 5)
+
+    (define max-expr-width 50)
+
+    (define (style head)
+      (case head
+        ((LAMBDA LET* LETREC DEFINE) pp-LAMBDA)
+        ((IF SET!)                   pp-IF)
+        ((COND)                      pp-COND)
+        ((CASE)                      pp-CASE)
+        ((AND OR)                    pp-AND)
+        ((LET)                       pp-LET)
+        ((BEGIN)                     pp-BEGIN)
+        ((DO)                        pp-DO)
+        (else                        #f)))
+
+    (pr obj col 0 pp-expr))
+
+  (if width
+    (out (make-string 1 #\newline) (pp obj 0))
+    (wr obj 0)))
+
+; (reverse-string-append l) = (apply string-append (reverse l))
+
+(define (reverse-string-append l)
+
+  (define (rev-string-append l i)
+    (if (pair? l)
+      (let* ((str (car l))
+             (len (string-length str))
+             (result (rev-string-append (cdr l) (+ i len))))
+        (let loop ((j 0) (k (- (- (string-length result) i) len)))
+          (if (< j len)
+            (begin
+              (string-set! result k (string-ref str j))
+              (loop (+ j 1) (+ k 1)))
+            result)))
+      (make-string i)))
+
+  (rev-string-append l 0))
diff --git a/cgen/slib/pp.scm b/cgen/slib/pp.scm
new file mode 100644 (file)
index 0000000..4b245a3
--- /dev/null
@@ -0,0 +1,10 @@
+;"pp.scm" Pretty-print
+
+; (pretty-print obj port) pretty prints 'obj' on 'port'.  The current
+; output port is used if 'port' is not specified.
+
+(define (pp:pretty-print obj . opt)
+  (let ((port (if (pair? opt) (car opt) (current-output-port))))
+    (generic-write obj #f 79 (lambda (s) (display s port) #t))))
+
+(define pretty-print pp:pretty-print)
diff --git a/cgen/slib/sort.scm b/cgen/slib/sort.scm
new file mode 100644 (file)
index 0000000..782f075
--- /dev/null
@@ -0,0 +1,151 @@
+;;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort!
+;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
+
+;;; Updated: 11 June 1991
+;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
+
+;;; (sorted? sequence less?)
+;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
+;;; such that for all 1 <= i <= m,
+;;;    (not (less? (list-ref list i) (list-ref list (- i 1)))).
+
+(define (sort:sorted? seq less?)
+    (cond
+       ((null? seq)
+           #t)
+       ((vector? seq)
+           (let ((n (vector-length seq)))
+               (if (<= n 1)
+                   #t
+                   (do ((i 1 (+ i 1)))
+                       ((or (= i n)
+                            (less? (vector-ref seq (- i 1))
+                                   (vector-ref seq i)))
+                           (= i n)) )) ))
+       (else
+           (let loop ((last (car seq)) (next (cdr seq)))
+               (or (null? next)
+                   (and (not (less? (car next) last))
+                        (loop (car next) (cdr next)) )) )) ))
+
+
+;;; (merge a b less?)
+;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
+;;; and returns a new list in which the elements of a and b have been stably
+;;; interleaved so that (sorted? (merge a b less?) less?).
+;;; Note:  this does _not_ accept vectors.  See below.
+
+(define (sort:merge a b less?)
+    (cond
+       ((null? a) b)
+       ((null? b) a)
+       (else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b)))
+           ;; The loop handles the merging of non-empty lists.  It has
+           ;; been written this way to save testing and car/cdring.
+           (if (less? y x)
+               (if (null? b)
+                   (cons y (cons x a))
+                   (cons y (loop x a (car b) (cdr b)) ))
+               ;; x <= y
+               (if (null? a)
+                   (cons x (cons y b))
+                   (cons x (loop (car a) (cdr a) y b)) )) )) ))
+
+
+;;; (merge! a b less?)
+;;; takes two sorted lists a and b and smashes their cdr fields to form a
+;;; single sorted list including the elements of both.
+;;; Note:  this does _not_ accept vectors.
+
+(define (sort:merge! a b less?)
+    (define (loop r a b)
+       (if (less? (car b) (car a))
+           (begin
+               (set-cdr! r b)
+               (if (null? (cdr b))
+                   (set-cdr! b a)
+                   (loop b a (cdr b)) ))
+           ;; (car a) <= (car b)
+           (begin
+               (set-cdr! r a)
+               (if (null? (cdr a))
+                   (set-cdr! a b)
+                   (loop a (cdr a) b)) )) )
+    (cond
+       ((null? a) b)
+       ((null? b) a)
+       ((less? (car b) (car a))
+           (if (null? (cdr b))
+               (set-cdr! b a)
+               (loop b a (cdr b)))
+           b)
+       (else ; (car a) <= (car b)
+           (if (null? (cdr a))
+               (set-cdr! a b)
+               (loop a (cdr a) b))
+           a)))
+
+
+
+;;; (sort! sequence less?)
+;;; sorts the list or vector sequence destructively.  It uses a version
+;;; of merge-sort invented, to the best of my knowledge, by David H. D.
+;;; Warren, and first used in the DEC-10 Prolog system.  R. A. O'Keefe
+;;; adapted it to work destructively in Scheme.
+
+(define (sort:sort! seq less?)
+    (define (step n)
+       (cond
+           ((> n 2)
+               (let* ((j (quotient n 2))
+                      (a (step j))
+                      (k (- n j))
+                      (b (step k)))
+                   (sort:merge! a b less?)))
+           ((= n 2)
+               (let ((x (car seq))
+                     (y (cadr seq))
+                     (p seq))
+                   (set! seq (cddr seq))
+                   (if (less? y x) (begin
+                       (set-car! p y)
+                       (set-car! (cdr p) x)))
+                   (set-cdr! (cdr p) '())
+                   p))
+           ((= n 1)
+               (let ((p seq))
+                   (set! seq (cdr seq))
+                   (set-cdr! p '())
+                   p))
+           (else
+               '()) ))
+    (if (vector? seq)
+       (let ((n (vector-length seq))
+             (vec seq))
+         (set! seq (vector->list seq))
+         (do ((p (step n) (cdr p))
+              (i 0 (+ i 1)))
+             ((null? p) vec)
+           (vector-set! vec i (car p)) ))
+       ;; otherwise, assume it is a list
+       (step (length seq)) ))
+
+;;; (sort sequence less?)
+;;; sorts a vector or list non-destructively.  It does this by sorting a
+;;; copy of the sequence.  My understanding is that the Standard says
+;;; that the result of append is always "newly allocated" except for
+;;; sharing structure with "the last argument", so (append x '()) ought
+;;; to be a standard way of copying a list x.
+
+(define (sort:sort seq less?)
+    (if (vector? seq)
+       (list->vector (sort:sort! (vector->list seq) less?))
+       (sort:sort! (append seq '()) less?)))
+
+;;; eof
+
+(define sorted? sort:sorted?)
+(define merge sort:merge)
+(define merge! sort:merge!)
+(define sort sort:sort)
+(define sort! sort:sort!)
diff --git a/cgen/sparc.cpu b/cgen/sparc.cpu
new file mode 100644 (file)
index 0000000..e60f9d9
--- /dev/null
@@ -0,0 +1,612 @@
+; SPARC CPU description.  -*- Scheme -*-
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; Notes:
+; - sparc64 support wip
+; - fp support todo
+; - source file layout wip
+; - cpu family layout wip
+; - page numbers refered to here are to the sparc architecture reference
+;   manuals (v8,v9).
+
+(include "simplify.inc")
+
+(define-arch
+  (name sparc)
+  (comment "Sun SPARC architecture")
+  (insn-lsb0? #t)
+  ; This list isn't currently intended to be identical to BFD's sparc mach
+  ; list.  In time if and when there's a need.
+  ; While following the goal of incremental complication, v6,v7,sparclet don't
+  ; appear here either.
+  (machs sparc-v8 sparclite sparc-v9 sparc-v9a)
+  ;(default-mach sparc-v8)
+  (isas sparc)
+)
+
+; Macros to simplify MACH attribute specification.
+(define-pmacro (MACH32) (MACH sparc-v8,sparclite))
+(define-pmacro (MACH64) (MACH sparc-v9,sparc-v9a))
+
+; Attribute to simplify machine specific RTL.
+(define-attr
+  (type boolean)
+  (name ARCH64)
+  (comment "`true' for sparc64 machs")
+)
+
+(define-isa
+  (name sparc)
+  (base-insn-bitsize 32) ; number of bits that can be initially fetched
+  ; Initial bitnumbers to decode insns by.
+  (decode-assist (31 30 24 23 22 21 20 19)) ; 0 1 7 8 9 10 11 12
+)
+\f
+; The instruction fetch/execute cycle.
+; This is split into two parts as sometimes more than one instruction is
+; decoded at once.
+; The `const 0' argument to decode/execute is used to distinguish
+; multiple instructions processed at the same time (e.g. m32r).
+;
+; ??? This is wip, and not currently used.
+; ??? To be moved into define-arch and define-cpu.
+; ??? It might simplify things to separate the execute process from the
+; one that updates the PC.
+
+; This is how to fetch and extract the fields of an instruction.
+
+;(define-extract
+;  (sequence ((USI insn))
+;          (set-quiet insn (ifetch: USI pc))
+;          (decode pc insn (const 0))
+;          )
+;)
+
+; This is how to execute an extracted instruction.
+
+;(define-execute
+;  (sequence ((AI new_pc))
+;          (set-quiet new_pc (execute AI (const 0)))
+;          ; QI mode means just do an assignment, not a jump.
+;          ; FIXME: VOID also means something special.  Perhaps there's a way
+;          ; to use a mode other than QI (WI?) and have something cleaner?
+;          (if (attr: HOSTINT insn (const 0) DELAY-SLOT)
+;              (if (andif (attr: BI insn (const 0) ANNUL) h-annul-p)
+;                  (c-call "do_annul")
+;                  (sequence () ; in delay slot
+;                            (set-quiet QI pc h-npc)
+;                            (set-quiet AI h-npc new_pc)))
+;              (sequence () ; not in delay slot
+;                        (set-quiet QI pc h-npc)
+;                        (set-quiet AI h-npc (add new_pc (const 4))))
+;          ))
+;)
+\f
+; Instruction fields.
+
+(dnf f-op        "op"        () 31 2)
+(dnf f-op2       "op2"       () 24 3)
+(dnf f-op3       "op3"       () 24 6)
+(dnf f-rs1       "rs1"       () 18 5)
+(dnf f-rs2       "rs2"       () 4 5)
+(dnf f-rd        "rd"        () 29 5)
+(dnf f-rd-res    "rd"        (RESERVED) 29 5)
+(dnf f-i         "i"         () 13 1)
+(df  f-simm13    "simm13"    () 12 13 INT #f #f)
+(dnf f-imm22     "imm22"     () 21 22)
+(define-ifield (name f-hi22) (comment "hi22") (attrs)
+  (start 21) (length 22)
+  ; shifting done elsewhere
+  ;(encode (value pc) (srl WI value (const 10)))
+  ;(decode (value pc) (sll WI value (const 10)))
+)
+(dnf f-a         "a"         () 29 1)
+(dnf f-fmt2-cond "fmt2 cond" () 28 4)
+(df f-disp22     "disp22"    (PCREL-ADDR) 21 22 INT
+    ((value pc) (sra WI (sub WI value pc) (const WI 2)))
+    ((value pc) (add WI (sll WI value (const WI 2)) pc)))
+(df f-disp30     "disp30"    (PCREL-ADDR) 29 30 INT
+    ((value pc) (sra WI (sub WI value pc) (const WI 2)))
+    ((value pc) (add WI (sll WI value (const WI 2)) pc)))
+(dnf f-opf       "opf"       () 13 9)
+(dnf f-res-12-8  "reserved bits of simm13 field when i=0" (RESERVED) 12 8)
+(dnf f-simm10    "simm10"    () 9 10)
+(dnf f-fmt2-cc   "cc"        () 21 2)
+(dnf f-fmt3-cc   "fmt3 cc"   () 26 2)
+(dnf f-x         "x"         () 12 1)
+(dnf f-shcnt32   "shcnt32"   () 4 5)
+(dnf f-fcn       "fcn"       () 29 5)
+(dnf f-imm-asi   "asi"       () 12 8)
+(dnf f-asi       "asi"       () 12 8)
+(dnf f-res-asi   "reserved bits in asi position" (RESERVED) 12 8)
+(dnf f-fmt4-cc   "fmt4 cc"   () 12 2)
+(dnf f-soft-trap "soft trap" () 6 7)
+(dnf f-opf-low5  "opf low5"  () 9 5)
+(dnf f-opf-low6  "opf low6"  () 10 6)
+(dnf f-opf-cc    "cc"        () 13 3)
+\f
+; Enums of opcodes, special insn values, etc.
+; ??? Some of this to be moved and/or split up into sparc{32,64}.cpu.
+
+(define-normal-insn-enum insn-op
+  "main insn opcode field, v8 page ???, v9 page 267"
+  () OP_ f-op
+  ; order is important, the numbers here are actually part of symbols
+  ; (e.g. OP_0, OP_1, OP_2, OP_3) so they must be strings.
+  ("0" "1" "2" "3")
+)
+
+(define-normal-insn-enum insn-op2
+  "op2 insn type, v8 page ???, v9 page 267"
+  () OP2_ f-op2
+  ; order is important
+  ; ??? some of these are for v9 only (ok?)
+  (UNIMP BPCC BICC BPR SETHI FBPFCC FBFCC RESERVED)
+)
+
+(define-normal-insn-enum insn-fmt2
+  "op=2 op3 values, v8 page ??, v9 page 268"
+  () OP3_ f-op3
+  (
+   (ADD 0) (ADDCC 16) ; v9 page 135
+   (ADDX 8) (ADDXCC 24) ; v8 page ??
+   (ADDC 8 ARCH64) (ADDCCC 24 ARCH64) ; v9 page 135
+   (SUB 4) (SUBCC 20) ; v9 page 230
+   (SUBX 12) (SUBXCC 28) ; v8 page ??
+   (SUBC 12 ARCH64) (SUBCCC 28 ARCH64) ; v9 page 230
+   (AND 1) (ANDCC 17) (ANDN 5) (ANDNCC 21)
+   (OR 2) (ORCC 18) (ORN 6) (ORNCC 22)
+   (XOR 3) (XORCC 19) (XNOR 7) (XNORCC 23)
+   (SLL #x25) (SRL #x26) (SRA #x27)
+   (MULSCC #x24 !ARCH64) ; v8 page 112
+   (UMUL #xa) (SMUL #xb) (UMULCC #x1a) (SMULCC #x1b) ; v8 page 113
+   (UDIV #xe) (SDIV #xf) (UDIVCC #x1e) (SDIVCC #x1f)
+
+   (FPOPS1 #x34) (FPOPS2 #x35)
+
+   (SAVE #x3c) (RESTORE #x3d) ; v8 page 117
+   (RETT #x39) ; v8 page 127
+   (JMPL #x38) ; v8 page 126
+
+   (RDY #x28) (RDASR #x28) ; v8 page 131
+   (WRY #x30) (WRASR #x30) ; v8 page 133
+
+   ; v8 page 131
+   (RDPSR #x29 !ARCH64) (RDWIM #x2a !ARCH64) (RDTBR #x2b !ARCH64)
+   ; v8 page 133
+   (WRPSR #x31 !ARCH64) (WRWIM #x32 !ARCH64) (WRTBR #x33 !ARCH64)
+
+   ; v9 page 155
+   (DONE_RETRY #x3e ARCH64)
+   ; v9 page 165
+   (FLUSH #x3b ARCH64)
+   ; v9 page 167
+   (FLUSHW #x2b ARCH64)
+   ; v9 page 169
+   (IMPDEP1 #x36 ARCH64) (IMPDEP2 #x37 ARCH64)
+   ; v9 page 183
+   (MEMBAR #x28 ARCH64)
+   ; v9 page 191
+   (MOVCC #x2c ARCH64)
+   )
+)
+
+(define-normal-insn-enum insn-fmt3
+  "op=3 op3 values, v8 page ???, v9 page 269"
+  () OP3_ f-op3
+  (; order is important
+   LDUW LDUB LDUH LDD
+   STW STB STH STD
+   (LDSW - ARCH64) LDSB LDSH (LDX - ARCH64)
+   RES12 LDSTUB (STX - ARCH64) SWAP
+
+   LDUWA LDUBA LDUHA LDDA
+   STWA STBA STHA STDA
+   (LDSWA - ARCH64) LDSBA LDSHA (LDXA - ARCH64)
+   RES28 LDSTUBA (STXA - ARCH64) SWAPA
+
+   LDF (LDFSR #x21) (LDXFSR #x21) LDQF LDDF
+   STF (STFSR #x25) (STXFSR #x25) STQF STDF
+   RES40 RES41 RES42 RES43
+   RES44 PREFETCH RES46 RES47
+
+   LDFA RES49 LDQFA LDDFA
+   STFA RES53 STQFA STDFA
+   RES56 RES57 RES58 RES59
+   (CASA - ARCH64) (PREFETCHA - ARCH64) (CASXA - ARCH64) RES63
+   )
+)
+
+(define-normal-insn-enum rd-insn
+  "rd insn type"
+  () RD_ f-rd
+  (; order is important
+   Y RES1 CCR ASI TICK PC FPRS ASR7
+   ASR8 ASR9 ASR10 ASR11 ASR12 ASR13 ASR14 MEMBAR_STBAR
+   )
+)
+
+(define-normal-insn-enum wr-insn
+  "wr insn type"
+  () WR_ f-rd
+  (; order is important
+   Y RES1 CCR ASI ASR4 ASR5 FPRS ASR7
+   ASR8 ASR9 ASR10 ASR11 ASR12 ASR13 ASR14 SIGM
+   )
+)
+
+; The standard condition code tests.
+
+(define-normal-insn-enum cc-tests
+  "condition code tests, v8 page ???, v9 page 144"
+  () "" f-fmt2-cond
+  (
+   (CC_A 8) ; always
+   (CC_N 0) ; never
+   (CC_NE 9) ; not equal
+   (CC_NZ 9) ; not zero
+   (CC_E 1) ; equal
+   (CC_Z 1) ; zero
+   (CC_G 10) ; greater
+   (CC_LE 2) ; less or equal
+   (CC_GE 11) ; greater or equal
+   (CC_L 3) ; less
+   (CC_GU 12) ; unsigned greater
+   (CC_LEU 4) ; unsigned less or equal
+   (CC_CC 13) ; carry clear
+   (CC_GEU 13) ; unsigned greater or equal
+   (CC_CS 5) ; carry set
+   (CC_LU 5) ; unsigned less than
+   (CC_POS 14) ; positive
+   (CC_NEG 6) ; negative
+   (CC_VC 15) ; overflow clear
+   (CC_VS 7) ; overflow set
+   )
+)
+
+; Floating point condition code tests.
+
+(define-normal-insn-enum fcc-tests
+  "condition code tests, v8 page ???, v9 page 138"
+  () "FCOND_" f-fmt2-cond
+  (
+   (A 8) ; always
+   (N 0) ; never
+   (U 7) ; unordered
+   (G 6) ; greater
+   (UG 5) ; unordered or greater
+   (L 4) ; less
+   (UL 3) ; unordered or less
+   (LG 2) ; less or greater
+   (NE 1) ; less or greater or unordered (not equal)
+   (E 9) ; equal
+   (UE 10) ; unordered or equal
+   (GE 11) ; greater or equal
+   (UGE 12) ; unordered or greater or equal
+   (LE 13) ; less or equal
+   (ULE 14) ; unordered or less or equal
+   (O 15) ; equal or less or greater (ordered)
+   )
+)
+
+(define-normal-insn-enum fcc-value "fcc value" () FCC_ f-fmt2-cc
+  (EQ LT GT UN)
+)
+
+(define-normal-insn-enum fpop1
+  "fp op 1, v8 page ???, v9 page 270"
+  () FPOPS1_ f-opf
+  (
+   (FMOVS 1) (FMOVD 2) (FMOVQ 3)
+   (FNEGS 5) (FNEGD 6) (FNEGQ 7)
+   (FABSS 9) (FABSD 10) (FABSQ 11)
+   (FSQRTS #x29) (FSQRTD #x2a) (FSQRTQ #x2b)
+   (FADDS #x41) (FADDD #x42) (FADDQ #x43)
+   (FSUBS #x45) (FSUBD #x46) (FSUBQ #x47)
+   (FMULS #x49) (FMULD #x4a) (FMULQ #x4b)
+   (FDIVS #x4d) (FDIVD #x4e) (FDIVQ #x4f)
+   (FSMULD #x69) (FDMULQ #x6e)
+   (FSTOX #x81) (FDTOX #x82) (FQTOX #x83)
+   (FXTOS #x84) (FXTOD #x88) (FXTOQ #x8c)
+   (FITOS #xc4) (FDTOS #xc6) (FQTOS #xc7)
+   (FITOD #xc8) (FSTOD #xc9) (FQTOD #xcb)
+   (FITOQ #xcc) (FSTOQ #xcd) (FDTOQ #xce)
+   (FSTOI #xd1) (FDTOI #xd2) (FQTOI #xd3)
+   (MAX 511)
+   )
+)
+
+; ??? check MACH64, are all v9 only?
+
+(define-normal-insn-enum fpop2
+  "fp op 2, v9 page 271"
+  (ARCH64) FPOPS2_ f-opf
+  (
+   (FCMPS #x51) (FCMPD #x52) (FCMPQ #x53)
+   (FCMPSE #x55) (FCMPDE #x56) (FCMPQE #x57)
+   (FMOVSFCC0 #x01) (FMOVDFCC0 #x02) (FMOVQFCC0 #x03)
+   (FMOVSFCC1 #x41) (FMOVDFCC1 #x42) (FMOVQFCC1 #x43)
+   (FMOVSFCC2 #x81) (FMOVDFCC2 #x82) (FMOVQFCC2 #x83)
+   (FMOVSFCC3 #xc1) (FMOVDFCC3 #xc2) (FMOVQFCC3 #xc3)
+   (FMOVSICC #x101) (FMOVDICC #x102) (FMOVQICC #x103)
+   (FMOVSXCC #x181) (FMOVDXCC #x182) (FMOVQXCC #x183)
+   (FMOVRZS #x25) (FMOVRZD #x26) (FMOVRZQ #x27)
+   (FMOVRLEZS #x45) (FMOVRLEZD #x46) (FMOVRLEZQ #x47)
+   (FMOVRLZS #x65) (FMOVRLZD #x66) (FMOVRLZQ #x67)
+   (FMOVRNZS #xa5) (FMOVRNZD #xa6) (FMOVRNZQ #xa7)
+   (FMOVRGZS #xc5) (FMOVRGZD #xc6) (FMOVRGZQ #xc7)
+   (FMOVRGEZS #xe5) (FMOVRGEZD #xe6) (FMOVRGEZQ #xe7)
+   (MAX 511)
+   )
+)
+\f
+; Hardware pieces.
+; These are common to all (or most all) machs.
+
+(dnh h-pc "program counter" (PC PROFILE) (pc) () () ())
+
+(define-hardware
+  (name h-npc)
+  (comment "next pc")
+  (attrs PC)
+  (type register WI)
+)
+
+(define-keyword
+  (name gr-names)
+  (print-name h-gr)
+  (prefix "%")
+  (values (fp 30) (sp 14)
+         (g0 0) (g1 1) (g2 2) (g3 3) (g4 4) (g5 5) (g6 6) (g7 7)
+         (o0 8) (o1 9) (o2 10) (o3 11) (o4 12) (o5 13) (o6 14) (o7 15)
+         (l0 16) (l1 17) (l2 18) (l3 19) (l4 20) (l5 21) (l6 22) (l7 23)
+         (i0 24) (i1 25) (i2 26) (i3 27) (i4 28) (i5 29) (i6 30) (i7 31)
+         )
+)
+
+; The general registers are accessed via a level of indirection to handle
+; the register windows.  h-gr provides the top level entry point which is
+; indirected through various means depending upon the register window
+; implementation of the day.  To be solidified in time.
+;
+; ??? Separation of h-gr for sparc32/64 is currently an experiment.
+
+(define-hardware
+  (name h-gr) ; h-gr32
+  ;(semantic-name h-gr)
+  (comment "sparc32 general registers")
+  (attrs PROFILE VIRTUAL (MACH32))
+  (type register SI (32))
+  (indices extern-keyword gr-names) ; keyword "%" (h-gr-indices))
+  (get (index) (c-call SI "GET_H_GR_RAW" index))
+  (set (index newval) (c-call VOID "SET_H_GR_RAW" index newval))
+)
+
+(define-hardware
+  (name h-gr) ; h-gr64
+  ;(semantic-name h-gr)
+  (comment "sparc64 general registers")
+  (attrs PROFILE VIRTUAL (MACH64))
+  (type register DI (32))
+  (indices extern-keyword gr-names) ; keyword "%" (h-gr-indices))
+  (get (index) (c-call SI "GET_H_GR_RAW" index))
+  (set (index newval) (c-call VOID "SET_H_GR_RAW" index newval))
+)
+
+(define-hardware
+  (name h-a)
+  (comment "annul bit")
+  (type immediate (UINT 1))
+  (values keyword "" (("" 0) (",a" 1)))
+)
+
+; The condition code bits.
+(dsh h-icc-c "icc carry bit"    () (register BI))
+(dsh h-icc-n "icc negative bit" () (register BI))
+(dsh h-icc-v "icc overflow bit" () (register BI))
+(dsh h-icc-z "icc zero bit"     () (register BI))
+
+; The extended condition code bits of v9.
+(dsh h-xcc-c "xcc carry bit"    (ARCH64) (register BI))
+(dsh h-xcc-n "xcc negative bit" (ARCH64) (register BI))
+(dsh h-xcc-v "xcc overflow bit" (ARCH64) (register BI))
+(dsh h-xcc-z "xcc zero bit"     (ARCH64) (register BI))
+
+; Misc. regs.
+
+; h-y is virtual because the real value is kept in the asr array.
+; ??? wip is get/set fields
+(define-hardware
+  (name h-y)
+  (comment "y register")
+  (attrs VIRTUAL)
+  (type register WI)
+  (get () (reg WI h-asr 0))
+  (set (newval) (set (reg WI h-asr 0) newval))
+)
+
+(dnh h-asr "ancilliary state registers" ()
+     (register WI (32))
+     (keyword "%" 
+             (
+              (y 0)
+              (asr0 0) (asr1 1) (asr2 2) (asr3 3)
+              (asr4 4) (asr5 5) (asr6 6) (asr7 7)
+              (asr8 8) (asr9 9) (asr10 10) (asr11 11)
+              (asr12 12) (asr13 13) (asr14 14) (asr15 15)
+              (asr16 16) (asr17 17) (asr18 18) (asr19 19)
+              (asr20 20) (asr21 21) (asr22 22) (asr23 23)
+              (asr24 24) (asr25 25) (asr26 26) (asr27 27)
+              (asr28 28) (asr29 29) (asr30 30) (asr31 31)
+              ))
+     ()
+     ()
+) ; FIXME:wip
+
+; This assists the simulator engine, not part of the architecture.
+; ??? There should be an attribute for these critters.
+(dsh h-annul-p "annul next insn? - assists execution" () (register BI))
+
+; %lo,%hi,etc.
+
+(dnh h-lo10 "signed low 10 bits" ()
+     (immediate (UINT 10)) ; integer (UNSIGNED) 10))
+     () () ()
+)
+
+(dnh h-lo13 "signed low 13 bits" ()
+     (immediate (INT 13)) ; integer (SIGNED) 13))
+     () () ()
+)
+
+(dnh h-hi22 "unsigned high 22 bits" ()
+     (immediate (UINT 22)) ; integer (UNSIGNED) 22))
+     () () ()
+)
+\f
+; Instruction Operands.
+
+(dnop rs1 "source register 1" () h-gr f-rs1)
+(dnop rs2 "source register 2" () h-gr f-rs2)
+(dnop rd "destination register" () h-gr f-rd)
+
+; double-reg args to ldd,std
+
+(define-operand
+  (name rdd)
+  (comment "rd as two registers")
+  (type h-gr)
+  (index f-rd)
+;  (get (args self index)
+;       (mode (DI)
+;       (eq (and index (const 1)) (const 0)) ; predicate, even regs only
+;       (make: DI SI
+;              (reg h-gr index)
+;              (reg h-gr (add index (const 1)))))
+;       )
+;  (set (args self index newval)
+;       (mode (DI)
+;       (eq (and index (const 1)) (const 0)) ; predicate, even regs only
+;       (sequence ()
+;                 (set (reg h-gr index)
+;                      (slice: SI DI newval (const 0)))
+;                 (set (reg h-gr (add index (const 1)))
+;                      (slice: SI DI newval (const 1)))))
+;       )
+;  (asm (parse "rdd"))
+)
+
+(dnop simm13 "13 bit signed immediate" () h-lo13 f-simm13)
+(dnop imm22 "22 bit unsigned immediate" () h-uint f-imm22)
+
+(dnop a "annul bit" () h-a f-a)
+
+(dnop icc-c "carry flag"    (SEM-ONLY) h-icc-c f-nil)
+(dnop icc-v "overflow flag" (SEM-ONLY) h-icc-v f-nil)
+(dnop icc-n "negative flag" (SEM-ONLY) h-icc-n f-nil)
+(dnop icc-z "zero flag"     (SEM-ONLY) h-icc-z f-nil)
+
+(dnop xcc-c "extended carry flag"    (SEM-ONLY) h-xcc-c f-nil)
+(dnop xcc-v "extended overflow flag" (SEM-ONLY) h-xcc-v f-nil)
+(dnop xcc-n "extended negative flag" (SEM-ONLY) h-xcc-n f-nil)
+(dnop xcc-z "extended zero flag"     (SEM-ONLY) h-xcc-z f-nil)
+
+; These two map h-asr to f-rs1 and f-rd so we have something to use in
+; the assembler spec, insn format, and semantic fields.
+; FIXME: 'twould be nice if we could do this mapping on the fly in the
+; define-insn (i.e. the old (%0,%1 stuff)).
+(dnop rdasr "read asr operand" () h-asr f-rs1)
+(dnop wrasr "write asr operand" () h-asr f-rd)
+
+(dnop asi "asi field" () h-uint f-asi)
+
+(dnop disp22 "22 bit displacement" () h-iaddr f-disp22)
+(dnop disp30 "30 bit displacement" () h-iaddr f-disp30)
+
+(define-operand
+  (name lo10)
+  (comment "10 bit signed immediate, for %lo()")
+  (type h-lo10)
+  (index f-simm10)
+  (handlers (parse "lo10"))
+)
+(define-operand
+  (name lo13)
+  (comment "13 bit signed immediate, for %lo()")
+  (type h-lo13)
+  (index f-simm13)
+  (handlers (parse "lo13"))
+)
+(define-operand
+  (name hi22)
+  (comment "22 bit unsigned immediate, for %hi()")
+  (type h-hi22)
+  (index f-hi22)
+  (handlers (parse "hi22") (print "hi22"))
+)
+\f
+; SPARC specific instruction attributes used:
+
+(define-attr
+  (for insn)
+  (type boolean)
+  (name TRAP)
+  (comment "insn is a trap insn")
+)
+
+(define-attr
+  (for insn)
+  (type boolean)
+  (name V9-DEPRECATED)
+  (comment "insn is deprecated in v9")
+)
+\f
+; Globally useful macros.
+
+; CC is one of icc,xcc.
+; ??? Might want canonical forms of these.
+; ??? Maybe move this to a library.
+; ??? bitfields still on todo list
+(define-pmacro (test-always cc) (const 1))
+(define-pmacro (test-never cc)  (const 0))
+(define-pmacro (test-ne cc)     (not (.sym cc -z)))
+(define-pmacro (test-eq cc)     (.sym cc -z))
+(define-pmacro (test-gt cc)     (not (or (.sym cc -z) (xor (.sym cc -n) (.sym cc -v)))))
+(define-pmacro (test-le cc)     (or (.sym cc -z) (xor (.sym cc -n) (.sym cc -v))))
+(define-pmacro (test-ge cc)     (not (xor (.sym cc -n) (.sym cc -v))))
+(define-pmacro (test-lt cc)     (xor (.sym cc -n) (.sym cc -v)))
+(define-pmacro (test-gtu cc)    (not (or (.sym cc -c) (.sym cc -z))))
+(define-pmacro (test-leu cc)    (or (.sym cc -c) (.sym cc -z)))
+(define-pmacro (test-geu cc)    (not (.sym cc -c)))
+(define-pmacro (test-ltu cc)    (.sym cc -c))
+(define-pmacro (test-pos cc)    (not (.sym cc -n)))
+(define-pmacro (test-neg cc)    (.sym cc -n))
+(define-pmacro (test-vc cc)     (not (.sym cc -v)))
+(define-pmacro (test-vs cc)     (.sym cc -v))
+
+(define-pmacro (uncond-br-sem test cc)
+  (delay (const 1)
+        (sequence ()
+                  (if (test cc)
+                      (set pc disp22))
+                  (annul a)))
+)
+(define-pmacro (cond-br-sem test cc)
+  (delay (const 1)
+        (if (test cc)
+            (set pc disp22)
+            (annul a)))
+)
+\f
+; The rest is broken out into various files.
+
+(if (keep-mach? (sparc-v8 sparclite))
+    (include "sparc32.cpu"))
+
+(if (keep-mach? (sparc-v9 sparc-v9a))
+    (include "sparc64.cpu"))
+
+(include "sparccom.cpu")
+(include "sparcfpu.cpu")
diff --git a/cgen/sparc.opc b/cgen/sparc.opc
new file mode 100644 (file)
index 0000000..cbc025b
--- /dev/null
@@ -0,0 +1,180 @@
+/* SPARC opcode support.  -*- C -*-
+   Copyright (C) 2000 Red Hat, Inc.
+   This file is part of CGEN.
+   This file is copyrighted with the GNU General Public License.
+   See file COPYING for details.  */
+
+/* This file is an addendum to sparc.cpu.  Heavy use of C code isn't
+   appropriate in .cpu files, so it resides here.  This especially applies
+   to assembly/disassembly where parsing/printing can be quite involved.
+   Such things aren't really part of the specification of the cpu, per se,
+   so .cpu files provide the general framework and .opc files handle the
+   nitty-gritty details as necessary.
+
+   Each section is delimited with start and end markers.
+
+   <cpu>-opc.h additions use: "-- opc.h"
+   <cpu>-opc.c additions use: "-- opc.c"
+   <cpu>-asm.c additions use: "-- asm.c"
+   <cpu>-dis.c additions use: "-- dis.c"
+*/
+\f
+/* -- opc.h */
+
+#undef CGEN_DIS_HASH_SIZE
+#define CGEN_DIS_HASH_SIZE 256
+#undef CGEN_DIS_HASH
+extern const unsigned int sparc_cgen_opcode_bits[];
+#define CGEN_DIS_HASH(buffer, insn) \
+((((insn) >> 24) & 0xc0) \
+ | (((insn) & sparc_cgen_opcode_bits[((insn) >> 30) & 3]) >> 19))
+
+/* -- */
+\f
+/* -- asm.c */
+
+/* It is important that we only look at insn code bits as that is how the
+   opcode table is hashed.  OPCODE_BITS is a table of valid bits for each
+   of the main types (0,1,2,3).  */
+const unsigned int sparc_cgen_opcode_bits[4] = {
+  0x01c00000, 0x0, 0x01f80000, 0x01f80000
+};
+
+/* Handle %lo().  */
+
+static const char *
+parse_lo10 (cd, strp, opindex, valuep)
+     CGEN_CPU_DESC cd;
+     const char **strp;
+     int opindex;
+     long *valuep;
+{
+  const char *errmsg;
+  enum cgen_parse_operand_result result_type;
+  bfd_vma value;
+
+  if (strncasecmp (*strp, "%lo(", 4) == 0)
+    {
+      *strp += 4;
+      errmsg = cgen_parse_address (od, strp, opindex, BFD_RELOC_LO10,
+                                  &result_type, &value);
+      if (**strp != ')')
+       return "missing `)'";
+      ++*strp;
+      value &= 0x3ff;
+      *valuep = value;
+      return errmsg;
+    }
+
+  return cgen_parse_unsigned_integer (od, strp, opindex, valuep);
+}
+
+static const char *
+parse_lo13 (cd, strp, opindex, valuep)
+     CGEN_CPU_DESC cd;
+     const char **strp;
+     int opindex;
+     long *valuep;
+{
+  const char *errmsg;
+  enum cgen_parse_operand_result result_type;
+  bfd_vma value;
+
+  if (strncasecmp (*strp, "%lo(", 4) == 0)
+    {
+      *strp += 4;
+      errmsg = cgen_parse_address (od, strp, opindex, BFD_RELOC_LO10,
+                                  &result_type, &value);
+      if (**strp != ')')
+       return "missing `)'";
+      ++*strp;
+      value &= 0x3ff;
+      *valuep = value;
+      return errmsg;
+    }
+
+  return cgen_parse_unsigned_integer (od, strp, opindex, valuep);
+}
+
+/* Handle %hi().  */
+
+static const char *
+parse_hi22 (cd, strp, opindex, valuep)
+     CGEN_CPU_DESC cd;
+     const char **strp;
+     int opindex;
+     unsigned long *valuep;
+{
+  const char *errmsg;
+  enum cgen_parse_operand_result result_type;
+  bfd_vma value;
+
+  if (strncasecmp (*strp, "%hi(", 4) == 0)
+    {
+      *strp += 4;
+      errmsg = cgen_parse_address (od, strp, opindex, BFD_RELOC_HI22,
+                                  &result_type, &value);
+      if (**strp != ')')
+       return "missing `)'";
+      ++*strp;
+      if (result_type == CGEN_PARSE_OPERAND_RESULT_NUMBER)
+       value >>= 10;
+      *valuep = value;
+      return errmsg;
+    }
+
+  return cgen_parse_unsigned_integer (od, strp, opindex, valuep);
+}
+
+/* -- */
+\f
+/* -- dis.c */
+
+/* Include "%hi(foo)" in sethi output.  */
+
+static void
+print_hi22 (cd, dis_info, value, attrs, pc, length)
+     CGEN_CPU_DESC cd;
+     PTR dis_info;
+     long value;
+     unsigned int attrs;
+     bfd_vma pc;
+     int length;
+{
+  disassemble_info *info = (disassemble_info *) dis_info;
+  (*info->fprintf_func) (info->stream, "%%hi(0x%lx)", value << 10);
+}
+
+#undef CGEN_PRINT_INSN
+#define CGEN_PRINT_INSN my_print_insn
+
+static int
+my_print_insn (cd, pc, info)
+     CGEN_CPU_DESC cd;
+     bfd_vma pc;
+     disassemble_info *info;
+{
+  char buffer[CGEN_MAX_INSN_SIZE];
+  char *buf = buffer;
+  int status;
+  unsigned long insn_value;
+  int len;
+
+  /* Read the base part of the insn.  */
+
+  status = (*info->read_memory_func) (pc, buf, 4, info);
+  if (status != 0)
+    {
+      (*info->memory_error_func) (status, pc, info);
+      return -1;
+    }
+
+  len = print_insn (od, pc, info, buf, 4);
+  if (len != 0)
+    return len;
+
+  /* CGEN doesn't handle this insn yet.  Fall back on old way.  */
+  return old_print_insn_sparc (pc, info);
+}
+
+/* -- */
diff --git a/cgen/sparc32.cpu b/cgen/sparc32.cpu
new file mode 100644 (file)
index 0000000..7634223
--- /dev/null
@@ -0,0 +1,170 @@
+; SPARC32 CPU description.  -*- Scheme -*-
+; This file contains elements specific to sparc32.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; Notes:
+; - sparc64 support wip
+; - fp support todo
+; - source file layout wip
+; - cpu family layout wip
+
+; ??? For the nonce there is one cpu family to cover all 32 bit sparcs.
+; It's not clear this will work, but following the goal of incremental
+; complication ....
+
+(define-cpu
+  (name sparc32)
+  (comment "SPARC 32 bit architecture")
+  (endian big)
+  (word-bitsize 32)
+  ; Generated files have a "32" suffix.
+  (file-transform "32")
+)
+
+(define-mach
+  (name sparc-v8)
+  (comment "sparc v8")
+  (cpu sparc32)
+  (bfd-name "sparc")
+)
+
+(define-mach
+  (name sparclite)
+  (comment "Fujitsu sparclite")
+  (cpu sparc32)
+  (bfd-name "sparc_sparclite")
+)
+
+; sparc32 models
+
+(define-model
+  (name sparc32-def)
+  (comment "sparc32 default")
+  (attrs)
+  (mach sparc-v8)
+  ; wip
+  (pipeline p-foo "" () ((fetch) (decode) (execute) (memory) (writeback)))
+  (unit u-exec "Execution Unit" ()
+       1 1 ; issue done
+       () () () ())
+)
+\f
+; sparc32 enums of opcodes, special insn values, etc.
+\f
+; sparc32 hardware pieces.
+
+; ??? impl,ver are left as part of h-psr (change maybe later)
+(define-hardware
+  (name h-psr)
+  (comment "psr register")
+  (type register USI)
+  (get () (c-call USI "@cpu@_get_h_psr_handler"))
+  (set (newval) (c-call VOID "@cpu@_set_h_psr_handler" newval))
+)
+
+(dsh h-s "supervisor bit" () (register BI))
+(dsh h-ps "previous supervisor bit" () (register BI))
+
+(dsh h-pil "processor interrupt level" () (register UQI))
+
+(dsh h-et "enable traps bit" () (register BI))
+
+(define-hardware
+  (name h-tbr)
+  (comment "trap base register")
+  (type register WI)
+  ;CPU (h_tbr) = (CPU (h_tbr) & 0xff0) | ((newval) & 0xfffff000);
+  (set (newval) (set (raw-reg WI h-tbr)
+                    (or WI (and WI (raw-reg WI h-tbr) (const #xff0))
+                         (and WI newval (const #xfffff000)))))
+)
+
+(define-hardware
+  (name h-cwp)
+  (comment "current window pointer")
+  (type register UQI)
+  (set (newval) (c-call VOID "@cpu@_set_h_cwp_handler" newval))
+)
+
+(define-hardware
+  (name h-wim)
+  (comment "window invalid mask")
+  (type register USI)
+  ; ??? These just put ideas down so I can play with them.  Ignore.
+  ;(get (value index) (and SI value (c-code SI "((1 << NWINDOWS) - 1)")))
+  ;(get (self mode index insn)
+  ;     (c-code USI "(CPU (h_wim) & ((1 << NWINDOWS) - 1))"))
+  ;(set (self mode index insn newval)
+  ;    (s-eval `(set SI ,self (and SI ,newval (const #xff)))))
+  (get () (and (raw-reg USI h-wim)
+              (sub (sll (const 1) (c-raw-call SI "GET_NWINDOWS")) (const 1))))
+)
+
+(dsh h-ag "alternate global indicator" () (register QI))
+
+; Coprocessor support.
+
+(dsh h-ec "enable coprocessor bit" () (register BI))
+
+; Floating point support.
+; wip.
+; - currently evaluating the various possibilities
+
+(dsh h-ef "enable fpu bit" () (register BI))
+
+(dsh h-fsr "floating point status register" () (register USI))
+\f
+; sparc32 instruction definitions.
+
+; Special register move operations.
+
+; %y is handled by the asr insns
+
+(dni rd-asr "read asr" ()
+     "rd $rdasr,$rd" ; note: `rdasr' is for ReaD asr, `rd' is for Reg Dest.
+     (+ OP_2 OP3_RDASR rd rdasr (f-i 0) (f-simm13 0))
+     (set rd rdasr)
+     ())
+(dni wr-asr "write asr" ()
+     "wr $rs1,$rs2,$wrasr"
+     (+ OP_2 OP3_WRASR wrasr rs1 rs2 (f-i 0) (f-res-asi 0))
+     (set wrasr (xor rs1 rs2))
+     ())
+(dni wr-asr-imm "write-imm asr" ()
+     "wr $rs1,$simm13,$wrasr"
+     (+ OP_2 OP3_WRASR wrasr rs1 (f-i 1) simm13)
+     (set wrasr (xor rs1 simm13))
+     ())
+
+(define-pmacro (rdwr-op name op3 asm-name reg-name)
+  (begin
+     (dni (.sym rd- name) (.str "read " name) ()
+         (.str "rd " asm-name ",$rd")
+         (+ OP_2 (.sym OP3_RD op3) rd (f-rs1 0) (f-i 0) (f-simm13 0))
+         (set rd (reg WI reg-name))
+         ())
+     (dni (.sym wr- name) (.str "write " name) ()
+         (.str "wr $rs1,$rs2," asm-name)
+         (+ OP_2 (.sym OP3_WR op3) (f-rd 0) rs1 rs2 (f-i 0) (f-res-asi 0))
+         (set (reg WI reg-name) (xor rs1 rs2))
+         ())
+     (dni (.sym wr- name -imm) (.str "write-imm " name) ()
+         (.str "wr $rs1,$simm13," asm-name)
+         (+ OP_2 (.sym OP3_WR op3) (f-rd 0) rs1 (f-i 1) simm13)
+         (set (reg WI reg-name) (xor rs1 simm13))
+         ())
+     )
+)
+
+(rdwr-op psr PSR "%psr" h-psr)
+(rdwr-op wim WIM "%wim" h-wim)
+(rdwr-op tbr TBR "%tbr" h-tbr)
+\f
+; TODO:
+; - rdy,wry
+; - stbar
+; - flush
+; - ldc, lddc, ldcsr, stc, stdc, stcsr, stdcq
+; - cbccc, cpop
diff --git a/cgen/sparc64.cpu b/cgen/sparc64.cpu
new file mode 100644 (file)
index 0000000..1c4301b
--- /dev/null
@@ -0,0 +1,422 @@
+; SPARC64 CPU description.  -*- Scheme -*-
+; This file contains elements specific to sparc64.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; Notes:
+; - sparc64 support wip
+; - fp support todo
+; - source file layout wip
+; - cpu family layout wip
+
+; ??? For the nonce there is one cpu family to cover all 64 bit sparcs.
+; It's not clear this will work, but following the goal of incremental
+; complication ....
+
+(define-cpu
+  (name sparc64)
+  (comment "SPARC 64 bit architecture")
+  (endian big) ; ??? big insn, either data
+  (word-bitsize 64)
+  ; Generated files have a "64" suffix.
+  (file-transform "64")
+)
+
+(define-mach
+  (name sparc-v9)
+  (comment "sparc v9")
+  ;(attrs S64-P)
+  (cpu sparc64)
+  (bfd-name "sparc_v9")
+)
+
+(define-mach
+  (name sparc-v9a)
+  (comment "sparc v9a (sparc-v9 + vis)")
+  ;(attrs S64-P)
+  (cpu sparc64)
+  (bfd-name "sparc_v9a")
+)
+
+; sparc64 models
+
+(define-model
+  (name sparc64-def)
+  (comment "sparc64 default")
+  (attrs)
+  (mach sparc-v9)
+  ; wip (Meaning, yes I know this is inaccurate, duh ...
+  ; When I have time I'll finish this up right.
+  ; Support for some of this isn't even implemented yet and support for the
+  ; rest will be rewritten.)
+  (pipeline p-foo "" () ((fetch) (decode) (execute) (memory) (writeback)))
+  (unit u-exec "Execution Unit" ()
+       1 1 ; issue done
+       () () () ())
+)
+\f
+; sparc64 instruction fields
+
+(dnf f-fmt2-cc1     "cc"           ((MACH64)) 21 1)
+(dnf f-fmt2-cc0     "cc"           ((MACH64)) 20 1)
+(dnf f-p            "p"            ((MACH64)) 19 1)
+(dnf f-fmt2-rcond   "fmt2 rcond"   ((MACH64)) 27 3)
+(df  f-disp19       "disp19"       (PCREL-ADDR (MACH64)) 13 19 INT #f #f)
+(dnf f-fmt3-rcond   "fmt3 rcond"   ((MACH64)) 19 3)
+(dnf f-shcnt64      "shcnt64"      ((MACH64)) 5 6)
+(dnf f-fmt4-cond    "cond"         ((MACH64)) 14 4)
+(dnf f-fmt4-ccx-hi  "ccx hi"       ((MACH64)) 13 1)
+(dnf f-fmt4-ccx-lo  "ccx lo"       ((MACH64)) 19 2)
+(dnf f-fmt4-rcond   "fmt4 rcond"   ((MACH64)) 19 3)
+(dnf f-fmt4-cc2     "fmt4 cc2"     ((MACH64)) 18 1)
+(dnf f-fmt4-cc1-0   "fmt4 cc1,cc0" ((MACH64)) 12 2)
+(dnf f-fmt4-res10-6 "reserved bits in movcc insns" (RESERVED (MACH64)) 10 6)
+
+; The disp16 field requires a bit of special handling as it is split in two.
+(df  f-disp16-hi    "disp16 hi"    ((MACH64)) 10 2 INT #f #f)
+(dnf f-disp16-lo    "disp16 lo"    ((MACH64)) 18 14)
+(dnmf f-disp16      "disp16"       (PCREL-ADDR (MACH64)) INT
+      (f-disp16-hi f-disp16-lo)
+      (sequence () ; insert
+               (set (ifield f-disp16-hi) (srl (ifield f-disp16) (const 14)))
+               (set (ifield f-disp16-lo) (and (ifield f-disp16) (const #x3fff)))
+               )
+      (sequence () ; extract
+               ; ??? where will pc be added?
+               (set (ifield f-disp16) (or (sll (ifield f-disp16-hi) (const 14))
+                                          (ifield f-disp16-low)))
+               )
+)
+
+(dnf f-res-18-19    "reserved bits in done/retry" (RESERVED (MACH64)) 18 19)
+\f
+; sparc64 enums of opcodes, special insn values, etc.
+
+(define-normal-insn-enum insn-rcond "rcond op values" () RCOND_ f-fmt2-rcond
+  (
+   (BRZ 1)
+   (BRLEZ 2)
+   (BRLZ 3)
+   (BRNZ 5)
+   (BRGZ 6)
+   (BRGEZ 7)
+   )
+)
+\f
+; sparc64 hardware pieces.
+
+(dsh h-ver "version" ((MACH64)) (register UDI))
+
+(dsh h-pstate "processor state" ((MACH64)) (register UDI))
+
+(dsh h-tba "trap base address" ((MACH64)) (register UDI))
+
+; FIXME: These are a stack of values.
+(dsh h-tt "trap type" ((MACH64)) (register UDI))
+(dsh h-tpc "trap pc" ((MACH64)) (register UDI))
+(dsh h-tnpc "trap npc" ((MACH64)) (register UDI))
+(dsh h-tstate "trap state" ((MACH64)) (register UDI))
+
+(dsh h-tl "trap level" ((MACH64)) (register UQI))
+
+(dsh h-asi "address space identifier" ((MACH64)) (register UQI))
+
+(dsh h-tick "tick counter" ((MACH64)) (register UDI))
+
+(dsh h-cansave "savable window registers" ((MACH64)) (register UDI))
+(dsh h-canrestore "restorable window registers" ((MACH64)) (register UDI))
+(dsh h-otherwin "other window registers" ((MACH64)) (register UDI))
+(dsh h-cleanwin "clean window registers" ((MACH64)) (register UDI))
+
+(dsh h-wstate "window state" ((MACH64)) (register UDI))
+
+(define-hardware
+  (name h-ixcc)
+  (comment "condition code selector")
+  (attrs (MACH64))
+  (type immediate (UINT 1))
+  (values keyword "%" (("icc" 0) ("xcc" 1)))
+)
+
+(define-hardware
+  (name h-p)
+  (comment "prediction bit")
+  (attrs (MACH64))
+  (type immediate (UINT 1))
+  (values keyword "" (("" 0) (",pf" 0) (",pt" 1)))
+)
+\f
+; sparc64 operands
+
+(dnop ixcc "%icc,%xcc arg to bpcc insns" ((MACH64)) h-ixcc f-fmt2-cc1)
+
+(dnop p "prediction bit" ((MACH64)) h-p f-p)
+
+(dnop disp16 "16 bit displacement" ((MACH64)) h-iaddr f-disp16)
+(dnop disp19 "19 bit displacement" ((MACH64)) h-iaddr f-disp19)
+\f
+; sparc64 branches
+
+(dnf f-bpr-res28-1 "reserved bit 28 in bpr insn" (RESERVED (MACH64)) 28 1)
+
+(define-pmacro (bpr-cbranch name comment rcond-op comp-op)
+  (dni name (.str comment ", v9 page 136")
+       ((MACH64))
+       (.str name "$a$p $rs1,$disp16")
+       (+ OP_0 a (f-bpr-res28-1 0) (.sym RCOND_ rcond-op)
+         OP2_BPR p rs1 disp16)
+       (delay (const 1)
+             (if (comp-op rs1 (const 0))
+                 (set pc disp16)
+                 (annul a)))
+       ())
+)
+(bpr-cbranch beqz "beqz" BRZ eq)
+(bpr-cbranch bgez "bgez" BRGEZ ge)
+(bpr-cbranch bgtz "bgtz" BRGZ gt)
+(bpr-cbranch blez "blez" BRLEZ le)
+(bpr-cbranch bltz "bltz" BRLZ lt)
+(bpr-cbranch bnez "bnez" BRNZ ne)
+
+(define-pmacro (bpcc-branch bname comment cond test br-sem)
+  (dni (.sym bpcc- bname)
+       (.str "branch with prediction %icc " comment ", v9 page 146")
+       ((MACH64))
+       (.str bname "$a$p %icc,$disp19")
+       (+ OP_0 a cond OP2_BPCC (f-fmt2-cc1 0) (f-fmt2-cc0 0) p disp19)
+       (br-sem test icc)
+       ())
+  (dni (.sym bpcc- bname)
+       (.str "branch with prediction %xcc " comment ", v9 page 146")
+       ((MACH64))
+       (.str bname "$a$p %xcc,$disp19")
+       (+ OP_0 a cond OP2_BPCC (f-fmt2-cc1 1) (f-fmt2-cc0 0) p disp19)
+       (br-sem test xcc)
+       ())
+)
+; test-*,uncond-br-sem,cond-br-sem are defined in sparc.cpu.
+(bpcc-branch ba   "always" CC_A   test-always uncond-br-sem)
+(bpcc-branch bn   "never"  CC_N   test-never uncond-br-sem)
+(bpcc-branch bne  "ne"     CC_NE  test-ne cond-br-sem)
+(bpcc-branch be   "eq"     CC_E   test-eq cond-br-sem)
+(bpcc-branch bg   "gt"     CC_G   test-gt cond-br-sem)
+(bpcc-branch ble  "le"     CC_LE  test-le cond-br-sem)
+(bpcc-branch bge  "ge"     CC_GE  test-ge cond-br-sem)
+(bpcc-branch bl   "lt"     CC_L   test-lt cond-br-sem)
+(bpcc-branch bgu  "gtu"    CC_GU  test-gtu cond-br-sem)
+(bpcc-branch bleu "leu"    CC_LEU test-leu cond-br-sem)
+(bpcc-branch bcc  "geu"    CC_CC  test-geu cond-br-sem)
+(bpcc-branch bcs  "ltu"    CC_CS  test-ltu cond-br-sem)
+(bpcc-branch bpos "pos"    CC_POS test-pos cond-br-sem)
+(bpcc-branch bneg "neg"    CC_NEG test-neg cond-br-sem)
+(bpcc-branch bvc  "vc"     CC_VC  test-vc cond-br-sem)
+(bpcc-branch bvs  "vs"     CC_VS  test-vs cond-br-sem)
+\f
+; Misc.
+
+(dni done "done, v9 page 155" ((MACH64))
+     "done"
+     (+ OP_2 (f-fcn 0) OP3_DONE_RETRY (f-res-18-19 0))
+     (c-call "@cpu@_done" pc)
+     ()
+)
+(dni retry "retry, v9 page 155" ((MACH64))
+     "done"
+     (+ OP_2 (f-fcn 1) OP3_DONE_RETRY (f-res-18-19 0))
+     (c-call "@cpu@_retry" pc)
+     ()
+)
+
+(dni flush "flush instruction memory rs1+rs2, v9 page 165" ((MACH64))
+     "flush"
+     (+ OP_2 (f-rd 0) OP3_FLUSH rs1 (f-i 0) (f-res-asi 0) rs2)
+     (c-call "@cpu@_flush" pc (add rs1 rs2))
+     ()
+)
+(dni flush-imm "flush instruction memory rs1+simm13, v9 page 165" ((MACH64))
+     "flush"
+     (+ OP_2 (f-rd 0) OP3_FLUSH rs1 (f-i 1) simm13)
+     (c-call "@cpu@_flush" pc (add rs1 simm13))
+     ()
+)
+
+(dni flushw "flush register windows, v9 page 167" ((MACH64))
+     "flushw"
+     (+ OP_2 (f-rd 0) OP3_FLUSHW (f-rs1 0) (f-i 0) (f-simm13 0))
+     (c-call "@cpu@_flushw" pc)
+     ()
+)
+
+; On sparc64 unimp is called illtrap.
+
+(dnmi illtrap "illegal instruction trap, v9 page 168" ((MACH64))
+      "illtrap $imm22"
+      (emit unimp imm22)
+)
+\f
+; Impdep insns
+
+(dnf f-impdep5  "5 bit field in impdep insns"  ((MACH64)) 29 5)
+(dnf f-impdep19 "19 bit field in impdep insns" ((MACH64)) 18 19)
+
+(dnop impdep5   "5 bit arg in impdep insns"    ((MACH64)) h-uint f-impdep5)
+(dnop impdep19  "19 bit arg in impdep insns"   ((MACH64)) h-uint f-impdep19)
+
+(dni impdep1 "implementation dependent instruction 1, v9 page 169"
+     ((MACH64))
+     "impdep1 $impdep5,$impdep19"
+     (+ OP_2 impdep5 OP3_IMPDEP1 impdep19)
+     (c-call "@cpu@_impdep1" pc impdep5 impdep19)
+     ()
+)
+(dni impdep2 "implementation dependent instruction 1, v9 page 169"
+     ((MACH64))
+     "impdep2 $impdep5,$impdep19"
+     (+ OP_2 impdep5 OP3_IMPDEP2 impdep19)
+     (c-call "@cpu@_impdep2" pc impdep5 impdep19)
+     ()
+)
+\f
+; Memory barrier insn
+
+(dnf f-membar-res12-6 "reserved bits 12-7 in membar insn"
+     (RESERVED (MACH64)) 12 6)
+(dnf f-cmask          "cmask field in membar insn"       ((MACH64)) 6 3)
+(dnf f-mmask          "mmask field in membar insn"       ((MACH64)) 3 4)
+(dnf f-membarmask     "cmask+mmask field in membar insn" ((MACH64)) 6 7)
+
+(define-hardware
+  (name h-membarmask)
+  (comment "membar mask")
+  (attrs (MACH64))
+  (type immediate (UINT 7))
+  (values keyword "" (
+                     ("#StoreStore" #x8)
+                     ("#LoadStore" #x4)
+                     ("#StoreLoad" #x2)
+                     ("#LoadLoad" #x1)
+                     ("#Sync" #x40)
+                     ("#MemIssue" #x20)
+                     ("#Lookaside" #x10)
+                     ))
+)
+
+(define-operand
+  (name membarmask)
+  (comment "cmask+mmask arg in membar insn")
+  (attrs (MACH64))
+  (type h-membarmask)
+  (index f-membarmask)
+  (handlers (parse "membar_mask")
+           (print "membar_mask"))
+)
+
+(dni membar "memory barrier, v9 page 183"
+     ((MACH64))
+     "member $membarmask" ; ${membar-mask}
+     (+ OP_2 (f-rd 0) OP3_MEMBAR (f-rs1 15) (f-i 1) (f-membar-res12-6 0)
+       membarmask)
+     (c-call "@cpu@_membar" pc membarmask)
+     ()
+)
+\f
+; Conditional move insns
+
+(df f-simm11 "11 bit signed immediate field" ((MACH64)) 10 11 INT #f #f)
+
+(dnop simm11 "11 bit signed immediate arg to condition move insns"
+      ((MACH64)) h-sint f-simm11)
+
+(define-pmacro (cond-move-1 name comment mnemonic cc-prefix cc-name cc-opcode
+                           src-name src-opcode cond test)
+  (dni name
+       (.str "move %" cc-name " " comment ", v9 page 191")
+       ((MACH64))
+       (.str mnemonic " " cc-prefix cc-name ",$" src-name ",$rd")
+       (.splice + OP_2 rd OP3_MOVCC cond
+               (.unsplice cc-opcode) (.unsplice src-opcode))
+       (if (test cc-name)
+          (set rd src-name))
+       ())
+)
+
+(define-pmacro (cond-move name comment cond test)
+  (begin
+    (cond-move-1 (.sym name -icc) comment
+                name "%" icc ((f-fmt4-cc2 1) (f-fmt4-cc1-0 0))
+                rs2 ((f-i 0) (f-fmt4-res10-6 0) rs2)
+                cond test)
+    (cond-move-1 (.sym name -imm-icc) comment
+                name "%" icc ((f-fmt4-cc2 1) (f-fmt4-cc1-0 0))
+                simm11 ((f-i 1) simm11)
+                cond test)
+    (cond-move-1 (.sym name -xcc) comment
+                name "%" xcc ((f-fmt4-cc2 1) (f-fmt4-cc1-0 2))
+                rs2 ((f-i 0) (f-fmt4-res10-6 0) rs2)
+                cond test)
+    (cond-move-1 (.sym name -imm-xcc) comment
+                name "%" xcc ((f-fmt4-cc2 1) (f-fmt4-cc1-0 2))
+                simm11 ((f-i 1) simm11)
+                cond test)
+    )
+)
+; test-* are defined in sparc.cpu.
+(cond-move mova   "always" CC_A   test-always)
+(cond-move movn   "never"  CC_N   test-never)
+(cond-move movne  "ne"     CC_NE  test-ne)
+(cond-move move   "eq"     CC_E   test-eq)
+(cond-move movg   "gt"     CC_G   test-gt)
+(cond-move movle  "le"     CC_LE  test-le)
+(cond-move movge  "ge"     CC_GE  test-ge)
+(cond-move movl   "lt"     CC_L   test-lt)
+(cond-move movgu  "gtu"    CC_GU  test-gtu)
+(cond-move movleu "leu"    CC_LEU test-leu)
+(cond-move movcc  "geu"    CC_CC  test-geu)
+(cond-move movcs  "ltu"    CC_CS  test-ltu)
+(cond-move movpos "pos"    CC_POS test-pos)
+(cond-move movneg "neg"    CC_NEG test-neg)
+(cond-move movvc  "vc"     CC_VC  test-vc)
+(cond-move movvs  "vs"     CC_VS  test-vs)
+\f
+; Arithmetic binary ops
+
+(define-pmacro (v8-addx-rename old new)
+  (begin
+    (dnmi new
+         (.str old " in v8 is " new " in v9, v9 page 135") ()
+         (.str new " $rs1,$rs2,$rd")
+         (emit old rs1 rs2 rd))
+    (dnmi (.sym new -imm)
+         (.str old " in v8 is " new " in v9, v9 page 135") ()
+         (.str new " $rs1,$simm13,$rd")
+         (emit old rs1 simm13 rd))
+    )
+)
+(v8-addx-rename addx addc)
+(v8-addx-rename addxcc addccc)
+\f
+; Binary boolean ops
+
+(define-pmacro (s64-set-bool-flags x)
+  (sequence ()
+           (set icc-z (zflag (trunc SI x)))
+           (set icc-n (nflag (trunc SI x)))
+           (set icc-c (const 0))
+           (set icc-v (const 0))
+           (set xcc-z (zflag x))
+           (set xcc-n (nflag x))
+           (set xcc-c (const 0))
+           (set xcc-v (const 0))
+           )
+)
+\f
+; Multiply/Divide
+
+; FIXME: flags handling incomplete
+; FIXME: div-binop is in sparccom.cpu which is included later.
+;(div-binop s64-sdiv "sdiv" MACH64 SDIV div ext: (s64-set-bool-flags rd))
+;(div-binop s64-udiv "udiv" MACH64 UDIV div zext: (s64-set-bool-flags rd))
+\f
+; TODO
+; - casa, casxa
diff --git a/cgen/sparccom.cpu b/cgen/sparccom.cpu
new file mode 100644 (file)
index 0000000..2c8e7fc
--- /dev/null
@@ -0,0 +1,766 @@
+; SPARC 32/64 CPU description.  -*- Scheme -*-
+; This file contains instructions common to both sparc32/sparc64.
+; It also contains sparc32/64 specific insns, but only when they are a variant
+; of a collection of common ones.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; Notes:
+; - sparc64 support wip
+; - fp support todo
+; - source file layout wip
+; - cpu family layout wip
+
+; Lots of sparc insns have either reg/reg or reg/simm13 cases.  */
+
+(define-pmacro (op3-reg-fmt op3-code)
+  (+ OP_2 op3-code rd rs1 rs2 (f-i 0) (f-res-asi 0))
+)
+(define-pmacro (op3-imm-fmt op3-code)
+  (+ OP_2 op3-code rd rs1 (f-i 1) simm13)
+)
+\f
+; Load/Store ops
+
+(define-pmacro (ld-op name comment attrs op3 mode dest)
+  (begin
+    (dnmi (.sym name "-reg+g0") comment attrs
+         (.str name " [$rs1],$" dest)
+         (emit (.sym name -reg+reg) rs1 (rs2 0) dest))
+    (dnmi (.sym name "-reg+0") comment attrs
+         (.str name " [$rs1],$" dest)
+         (emit (.sym name -reg+imm) rs1 (simm13 0) dest))
+    (dni (.sym name "-reg+reg") comment attrs
+        (.str name " [$rs1+$rs2],$" dest)
+        (+ OP_3 op3 dest rs1 (f-i 0) (f-res-asi 0) rs2)
+        (set mode dest (mem mode (add WI rs1 rs2)))
+        ())
+    (dni (.sym name "-reg+imm") comment attrs
+        (.str name " [$rs1+$simm13],$" dest)
+        (+ OP_3 op3 dest rs1 (f-i 1) simm13)
+        (set mode dest (mem mode (add WI rs1 simm13)))
+        ())
+    (dnmi (.sym name "-reg/asi") comment attrs
+         (.str name " [$rs1]$asi,$" dest)
+         (emit (.sym name -reg+reg/asi) rs1 (rs2 0) asi dest))
+    (dni (.sym name "-reg+reg/asi") comment attrs
+        (.str name " [$rs1+$rs2]$asi,$" dest)
+        (+ OP_3 (.sym op3 A) dest rs1 (f-i 0) asi rs2)
+        (set mode dest (mem mode (add WI rs1 rs2)))
+        ())
+    )
+)
+(ld-op ldsb "load signed byte"       ()         OP3_LDSB QI  rd)
+(ld-op ldub "load unsigned byte"     ()         OP3_LDUB UQI rd)
+(ld-op ldsh "load signed halfword"   ()         OP3_LDSH HI  rd)
+(ld-op lduh "load unsigned halfword" ()         OP3_LDUH UHI rd)
+(ld-op ldsw "load signed word"       ()         OP3_LDSW SI  rd)
+(ld-op lduw "load unsigned word"     ()         OP3_LDUW USI rd)
+(ld-op ldx  "load extended word"     ((MACH64)) OP3_LDX  DI  rd)
+
+; Aliases are treated as such (ALIAS attribute) so we can use ld-op.
+; ??? Perhaps lduw should be the alias.  Let's leave it like this for now.
+(ld-op ld   "load word"              (ALIAS)  OP3_LDUW SI  rd)
+
+; ??? This would work with special operand get/set support but
+; it's not clear this case justifies implementing that yet.
+;(ld-op ldd  "load double reg"        ()       OP3_LDD  DI  rdd)
+
+(dnmi ldd-reg+g0 "load double reg, reg+g0" ()
+      "ldd [$rs1],$rdd"
+      (emit ldd-reg+reg rs1 (rs2 0) rdd)
+)
+(dnmi ldd-reg+0 "load double reg, reg+0" ()
+      "ldd [$rs1],$rdd"
+      (emit ldd-reg+imm rs1 (simm13 0) rdd)
+)
+(dni ldd-reg+reg "load double reg, reg+reg" ()
+     "ldd [$rs1+$rs2],$rdd"
+     (+ OP_3 OP3_LDD rdd rs1 (f-i 0) (f-res-asi 0) rs2)
+     (sequence ((DI temp))
+              (set temp (mem DI (add WI rs1 rs2)))
+              (set rdd (subword SI temp (const 0)))
+              (set (reg h-gr (add (regno rdd) (const 1)))
+                   (subword SI temp (const 1))))
+     ()
+)
+(dni ldd-reg+imm "load double reg, reg+imm" ()
+     "ldd [$rs1+$simm13],$rdd"
+     (+ OP_3 OP3_LDD rdd rs1 (f-i 1) simm13)
+     (sequence ()
+              (set rdd (mem SI (add WI rs1 simm13)))
+              (set (reg h-gr (add (regno rdd) (const 1)))
+                   (mem SI (add rs1 (add simm13 (const 4))))))
+     ()
+)
+(dnmi ldd-reg/asi "load double reg, reg+g0/asi" ()
+      "ldd [$rs1]$asi,$rdd"
+      (emit ldd-reg+reg/asi rs1 (rs2 0) asi rdd)
+)
+(dni ldd-reg+reg/asi "load double reg, reg+reg/asi" ()
+     "ldd [$rs1+$rs2]$asi,$rdd"
+     (+ OP_3 OP3_LDDA rdd rs1 (f-i 0) asi rs2)
+     (sequence ()
+              (set rdd (mem SI (add WI rs1 rs2)))
+              (set (reg h-gr (add (regno rdd) (const 1)))
+                   (mem SI (add rs1 (add rs2 (const 4))))))
+     ()
+)
+
+(define-pmacro (st-op name comment attrs op3 mode src)
+  (begin
+    (dnmi (.sym name "-reg+g0") comment attrs
+         (.str name " $" src ",[$rs1]")
+         (emit (.sym name -reg+reg) src rs1 (rs2 0)))
+    (dnmi (.sym name "-reg+0") comment attrs
+         (.str name " $" src ",[$rs1]")
+         (emit (.sym name -reg+imm) src rs1 (simm13 0)))
+    (dni (.sym name "-reg+reg") comment attrs
+        (.str name " $" src ",[$rs1+$rs2]")
+        (+ OP_3 op3 src rs1 (f-i 0) (f-res-asi 0) rs2)
+        (set mode (mem mode (add WI rs1 rs2)) src)
+        ())
+    (dni (.sym name "-reg+imm") comment attrs
+        (.str name " $" src ",[$rs1+$simm13]")
+        (+ OP_3 op3 src rs1 (f-i 1) simm13)
+        (set mode (mem mode (add WI rs1 simm13)) src)
+        ())
+    (dnmi (.sym name "-reg/asi") comment attrs
+         (.str name " $" src ",[$rs1]$asi")
+         (emit (.sym name -reg+reg/asi) src rs1 (rs2 0) asi))
+    (dni (.sym name "-reg+reg/asi") comment attrs
+        (.str name " $" src ",[$rs1+$rs2]$asi")
+        (+ OP_3 (.sym op3 A) src rs1 (f-i 0) asi rs2)
+        (set mode (mem mode (add WI rs1 rs2)) src)
+        ())
+    )
+)
+(st-op stb "store byte"          ()       OP3_STB QI rd)
+(st-op sth "store halfword"      ()       OP3_STH HI rd)
+(st-op st  "store word"          ()       OP3_STW SI rd)
+(st-op stx "store extended word" ((MACH64)) OP3_STX DI rd)
+
+; ??? This would work with special operand get/set support but
+; it's not clear this case justifies implementing that yet.
+;(st-op std "store double reg"    ()       OP3_STD DI rdd)
+
+(dnmi std-reg+g0 "store double reg, reg+g0" ()
+      "std $rdd,[$rs1]"
+      (emit std-reg+reg rdd rs1 (rs2 0))
+)
+(dnmi std-reg+0 "store double reg, reg+0" ()
+      "std $rdd,[$rs1]"
+      (emit std-reg+imm rdd rs1 (simm13 0))
+)
+(dni std-reg+reg "store double reg, reg+reg" ()
+     "std $rdd,[$rs1+$rs2]"
+     (+ OP_3 OP3_STD rdd rs1 (f-i 0) (f-res-asi 0) rs2)
+     (sequence ()
+              (set (mem SI (add rs1 rs2)) rdd)
+              (set (mem SI (add rs1 (add rs2 (const 4))))
+                   (reg h-gr (add (regno rdd) (const 1)))))
+     ()
+)
+(dni std-reg+imm "store double reg, reg+imm" ()
+     "std $rdd,[$rs1+$simm13]"
+     (+ OP_3 OP3_STD rdd rs1 (f-i 1) simm13)
+     (sequence ()
+              (set (mem SI (add rs1 simm13)) rdd)
+              (set (mem SI (add rs1 (add simm13 (const 4))))
+                   (reg h-gr (add (regno rdd) (const 1)))))
+     ()
+)
+(dnmi std-reg/asi "store double reg, reg+g0/asi" ()
+      "std $rdd,[$rs1]$asi"
+      (emit std-reg+reg/asi rdd rs1 (rs2 0) asi)
+)
+(dni std-reg+reg/asi "store double reg, reg+reg/asi" ()
+     "std $rdd,[$rs1+$rs2]$asi"
+     (+ OP_3 OP3_STDA rdd rs1 (f-i 0) asi rs2)
+     (sequence ()
+              (set (mem SI (add rs1 rs2)) rdd)
+              (set (mem SI (add rs1 (add rs2 (const 4))))
+                   (reg h-gr (add (regno rdd) (const 1)))))
+     ()
+)
+\f
+; nop
+; A nop is defined to be a sethi of %g0.
+; This needn't be a macro-insn, but making it one greatly simplifies decode.c
+; as code needn't be generated to confirm hi22 == 0.
+; On the other hand spending a little time in the decoder is often worth it.
+
+(dnmi nop "nop"
+      ()
+      "nop"
+      (emit sethi (rd 0) (hi22 0))
+)
+
+; sethi
+
+(dni sethi "sethi" ()
+     "sethi $hi22,$rd"
+     (+ OP_0 rd OP2_SETHI hi22)
+     (set rd (sll USI hi22 (const 10))) ; (set SI rd hi22)
+     ()
+)
+\f
+; Add/Subtract
+
+(define-pmacro (s32-set-addc-flags a b carry)
+  (sequence ((SI x))
+           (set x (addc a b carry))
+           (set icc-c (add-cflag a b carry))
+           (set icc-v (add-oflag a b carry))
+           (set icc-n (nflag x))
+           (set icc-z (zflag x)))
+)
+(define-pmacro (s32-set-subc-flags a b carry)
+  (sequence ((SI x))
+           (set x (subc a b carry))
+           (set icc-c (sub-cflag a b carry))
+           (set icc-v (sub-oflag a b carry))
+           (set icc-n (nflag x))
+           (set icc-z (zflag x)))
+)
+
+(define-pmacro (s64-set-addc-flags a b carry)
+  (sequence ((SI x32) (DI x))
+           (set x (addc a b carry))
+           (set x32 x)
+           (set icc-c (add-cflag SI a b carry))
+           (set icc-v (add-oflag SI a b carry))
+           (set icc-n (nflag x32))
+           (set icc-z (zflag x32))
+           (set xcc-c (add-cflag a b carry))
+           (set xcc-v (add-oflag a b carry))
+           (set xcc-n (nflag x))
+           (set xcc-z (zflag x)))
+)
+(define-pmacro (s64-set-subc-flags a b carry)
+  (sequence ((SI x32) (DI x))
+           (set x (subc a b carry))
+           (set x32 x)
+           (set icc-c (sub-cflag SI a b carry))
+           (set icc-v (sub-oflag SI a b carry))
+           (set icc-n (nflag x32))
+           (set icc-z (zflag x32))
+           (set xcc-c (sub-cflag a b carry))
+           (set xcc-v (sub-oflag a b carry))
+           (set xcc-n (nflag x))
+           (set xcc-z (zflag x)))
+)
+
+(define-pmacro (arith-binop name comment page attrs op3 sem-op)
+  (begin
+    (dni name
+        (.str comment ", " page)
+        attrs
+        (.str name " $rs1,$rs2,$rd")
+        (+ OP_2 op3 rd rs1 rs2 (f-i 0) (f-res-asi 0))
+        (set rd (sem-op rs1 rs2))
+        ())
+    (dni (.sym name -imm)
+        (.str comment " immediate, " page)
+        attrs
+        (.str name " $rs1,$simm13,$rd")
+        (+ OP_2 op3 rd rs1 (f-i 1) simm13)
+        (set rd (sem-op rs1 simm13))
+        ())
+    )
+)
+(define-pmacro (arith-cc-binop name comment page attrs op3 sem-op
+                              s32-set-flags s64-set-flags)
+  (begin
+    (dni name
+        (.str comment ", setting cc, " page)
+        attrs
+        (.str name " $rs1,$rs2,$rd")
+        (+ OP_2 op3 rd rs1 rs2 (f-i 0) (f-res-asi 0))
+        (sequence ()
+                  (if (eq-attr (current-mach) ARCH64 TRUE)
+                      (s64-set-flags rs1 rs2 (const 0))
+                      (s32-set-flags rs1 rs2 (const 0)))
+                  (set rd (sem-op rs1 rs2))
+                  )
+        ())
+    (dni (.sym name -imm)
+        (.str comment " immediate, setting cc, " page)
+        attrs
+        (.str name " $rs1,$simm13,$rd")
+        (+ OP_2 op3 rd rs1 (f-i 1) simm13)
+        (sequence ()
+                  (if (eq-attr (current-mach) ARCH64 TRUE)
+                      (s64-set-flags rs1 simm13 (const 0))
+                      (s32-set-flags rs1 simm13 (const 0)))
+                  (set rd (sem-op rs1 simm13))
+                  )
+        ())
+    )
+)
+(arith-binop add "add" "v8 page ??, v9 page 135" () OP3_ADD add)
+(arith-binop sub "subtract" "v8 page ??, v9 page 230" () OP3_SUB sub)
+(arith-cc-binop addcc "add" "v8 page ??, v9 page 135" () OP3_ADDCC add
+               s32-set-addc-flags s64-set-addc-flags)
+(arith-cc-binop subcc "subtract" "v8 page ??, v9 page 230" () OP3_SUBCC sub
+               s32-set-subc-flags s64-set-subc-flags)
+
+; Same except include carry bit.
+
+(define-pmacro (arith-carry-binop name comment page attrs op3 sem-op)
+  (begin
+    (dni name
+        (.str comment " with carry, " page)
+        attrs
+        (.str name " $rs1,$rs2,$rd")
+        (+ OP_2 op3 rd rs1 rs2 (f-i 0) (f-res-asi 0))
+        (set rd (sem-op rs1 rs2 icc-c))
+        ())
+    (dni (.sym name -imm)
+        (.str comment " immediate with carry, " page)
+        attrs
+        (.str name " $rs1,$simm13,$rd")
+        (+ OP_2 op3 rd rs1 (f-i 1) simm13)
+        (set rd (sem-op rs1 simm13 icc-c))
+        ())
+    )
+)
+(define-pmacro (arith-carry-cc-binop name comment page attrs op3 sem-op set-flags)
+  (begin
+    (dni name
+        (.str comment " with carry, setting cc, " page)
+        attrs
+        (.str name " $rs1,$rs2,$rd")
+        (+ OP_2 op3 rd rs1 rs2 (f-i 0) (f-res-asi 0))
+        (sequence ()
+                  (set-flags rs1 rs2 icc-c)
+                  (set rd (sem-op rs1 rs2 icc-c))
+                  )
+        ())
+    (dni (.sym name -imm)
+        (.str comment " immediate with carry, setting cc, " page)
+        attrs
+        (.str name " $rs1,$simm13,$rd")
+        (+ OP_2 op3 rd rs1 (f-i 1) simm13)
+        (sequence ()
+                  (set-flags rs1 simm13 icc-c)
+                  (set rd (sem-op rs1 simm13 icc-c))
+                  )
+        ())
+    )
+)
+; mach32 versions
+(arith-carry-binop addx "add" "v8 page ??" ((MACH32)) OP3_ADDX addc)
+(arith-carry-binop subx "subtract" "v8 page ??" ((MACH32)) OP3_SUBX subc)
+(arith-carry-cc-binop addxcc "add" "v8 page ??" ((MACH32)) OP3_ADDXCC addc
+                     s32-set-addc-flags)
+(arith-carry-cc-binop subxcc "subtract" "v8 page ??" ((MACH32)) OP3_SUBXCC subc
+                     s32-set-subc-flags)
+; mach64 versions
+; same as mach32 except mnemonic is different
+(arith-carry-binop addc "add" "v9 page 135" ((MACH64)) OP3_ADDC addc)
+(arith-carry-binop subc "subtract" "v9 page 230" ((MACH64)) OP3_SUBC subc)
+(arith-carry-cc-binop addccc "add" "v9 page 135" ((MACH64)) OP3_ADDCCC addc
+                     s64-set-addc-flags)
+(arith-carry-cc-binop subccc "subtract" "v9 page 230" ((MACH64)) OP3_SUBCCC subc
+                     s64-set-subc-flags)
+\f
+; Binary boolean ops
+
+(define-pmacro (s32-set-bool-flags x)
+  (sequence ()
+           (set icc-z (zflag x))
+           (set icc-n (nflag x))
+           (set icc-c (const 0))
+           (set icc-v (const 0))
+           )
+)
+(define-pmacro (s64-set-bool-flags x)
+  (sequence ()
+           (set icc-z (zflag (trunc SI x)))
+           (set icc-n (nflag (trunc SI x)))
+           (set icc-c (const 0))
+           (set icc-v (const 0))
+           (set xcc-z (zflag x))
+           (set xcc-n (nflag x))
+           (set xcc-c (const 0))
+           (set xcc-v (const 0))
+           )
+)
+
+(define-pmacro (bool-binop name page op3 sem-op)
+  (begin
+    (dni name (.str name ", " page) ()
+        (.str name " $rs1,$rs2,$rd")
+        (+ OP_2 op3 rd rs1 rs2 (f-i 0) (f-res-asi 0))
+        (set rd (sem-op rs1 rs2))
+        ())
+    (dni (.sym name -imm) (.str name " immediate, " page) ()
+        (.str name " $rs1,$simm13,$rd")
+        (+ OP_2 op3 rd rs1 (f-i 1) simm13)
+        (set rd (sem-op rs1 simm13))
+        ())
+    (dni (.sym name cc) (.str name ", setting cc, " page) ()
+        (.str name "cc $rs1,$rs2,$rd")
+        (+ OP_2 (.sym op3 CC) rd rs1 rs2 (f-i 0) (f-res-asi 0))
+        (sequence ()
+                  (if (eq-attr (current-mach) ARCH64 TRUE)
+                      (s64-set-bool-flags (sem-op rs1 rs2))
+                      (s32-set-bool-flags (sem-op rs1 rs2)))
+                  (set rd (sem-op rs1 rs2))
+                  )
+        ())
+    (dni (.sym name cc-imm) (.str name " immediate, setting cc, " page) ()
+        (.str name "cc $rs1,$simm13,$rd")
+        (+ OP_2 (.sym op3 CC) rd rs1 (f-i 1) simm13)
+        (sequence ()
+                  (if (eq-attr (current-mach) ARCH64 TRUE)
+                      (s64-set-bool-flags (sem-op rs1 simm13))
+                      (s32-set-bool-flags (sem-op rs1 simm13)))
+                  (set rd (sem-op rs1 simm13))
+                  )
+        ())
+    )
+)
+(bool-binop and "v9 page 181" OP3_AND and)
+(bool-binop or  "v9 page 181" OP3_OR  or)
+(bool-binop xor "v9 page 181" OP3_XOR xor)
+
+; Early experiments.
+;(dsmn (andn a b) (list 'and a (list 'inv b)))
+;(dsmn (orn a b) (list 'or a (list 'inv b)))
+;(dsmn (xorn a b) (list 'xor a (list 'inv b)))
+
+(define-pmacro (sem-andn a b) (and a (inv b)))
+(define-pmacro (sem-orn a b) (or a (inv b)))
+(define-pmacro (sem-xorn a b) (xor a (inv b)))
+
+(bool-binop andn "v9 page 181" OP3_ANDN sem-andn)
+(bool-binop orn  "v9 page 181" OP3_ORN  sem-orn)
+(bool-binop xnor "v9 page 181" OP3_XNOR sem-xorn)
+\f
+; Shifts
+
+(define-pmacro (shift-binop name comment op3 sem-op)
+  (begin
+     (dni name comment ()
+         (.str name " $rs1,$rs2,$rd")
+         (+ OP_2 op3 rd rs1 rs2 (f-i 0) (f-res-asi 0))
+         (set rd (sem-op rs1 (and rs2 (const 31))))
+         ())
+     (dni (.sym name -imm) (.str comment -imm) ()
+         (.str name " $rs1,$simm13,$rd")
+         (+ OP_2 op3 rd rs1 (f-i 1) simm13)
+         ; ??? v9 uses only the low bits.  v8?
+         (set rd (sem-op rs1 (and simm13 (const 31))))
+         ())
+     )
+)
+(shift-binop sll "shift left logical" OP3_SLL sll)
+(shift-binop srl "shift right logical" OP3_SRL srl)
+(shift-binop sra "shift right arithmetic" OP3_SRA sra)
+\f
+; Multiply/Divide
+
+(define-pmacro (mult-binop name comment op3 sem-op ext-op)
+  (begin
+     (dni name comment ()
+         (.str name " $rs1,$rs2,$rd")
+         (+ OP_2 op3 rd rs1 rs2 (f-i 0) (f-res-asi 0))
+         (sequence ((DI res))
+                   (set res (sem-op (ext-op DI rs1) (ext-op DI rs2)))
+                   (set (reg WI h-y) (trunc SI (srl res (const 32))))
+                   (set rd (trunc SI res))
+                   )
+         ())
+     (dni (.sym name -imm) (.str comment -imm) ()
+         (.str name " $rs1,$simm13,$rd")
+         (+ OP_2 op3 rd rs1 (f-i 1) simm13)
+         (sequence ((DI res))
+                   (set res (sem-op (ext-op DI rs1) (ext-op DI simm13)))
+                   (set (reg WI h-y) (trunc SI (srl res (const 32))))
+                   (set rd (trunc SI res))
+                   )
+         ())
+     (dni (.sym name -cc) (.str comment -cc) ()
+         (.str name "cc $rs1,$rs2,$rd")
+         (+ OP_2 (.sym op3 CC) rd rs1 rs2 (f-i 0) (f-res-asi 0))
+         (sequence ((DI res))
+                   (set res (sem-op (ext-op DI rs1) (ext-op DI rs2)))
+                   (set (reg WI h-y) (trunc SI (srl res (const 32))))
+                   (set rd (trunc SI res))
+                   ; We use bool-flags here 'cus it works (FIXME:revisit).
+                   ; We can't use rd here 'cus it might be %g0.
+                   (s32-set-bool-flags (trunc SI res))
+                   )
+         ())
+     (dni (.sym name -cc-imm) (.str comment -cc-imm) ()
+         (.str name "cc $rs1,$simm13,$rd")
+         (+ OP_2 (.sym op3 CC) rd rs1 (f-i 1) simm13)
+         (sequence ((DI res))
+                   (set res (sem-op (ext-op DI rs1) (ext-op DI simm13)))
+                   (set (reg WI h-y) (trunc SI (srl res (const 32))))
+                   (set rd (trunc SI res))
+                   ; We use bool-flags here 'cus it works (FIXME:revisit).
+                   ; We can't use rd here 'cus it might be %g0.
+                   (s32-set-bool-flags (trunc SI res))
+                   )
+         ())
+     )
+)
+(mult-binop smul "smul" OP3_SMUL mul ext)
+(mult-binop umul "umul" OP3_UMUL mul zext)
+
+(define-pmacro (div-binop name comment mach-attrs op3 sem-op ext-op set-flags)
+  (begin
+    (dni name (.str comment ", v9 page 152") ((mach-attrs))
+        (.str name " $rs1,$rs2,$rd")
+        (+ OP_2 op3 rd rs1 rs2 (f-i 0) (f-res-asi 0))
+        (sequence ((DI dividend))
+                  (set dividend (join DI SI (reg SI h-y) rs1))
+                  (set rd (trunc SI (sem-op dividend (ext-op DI rs2))))
+                  ; FIXME: Overflow,etc. handling.
+                  )
+        ())
+    (dni (.sym name -imm) (.str comment -imm ", v9 page 152") ((mach-attrs))
+        (.str name " $rs1,$simm13,$rd")
+        (+ OP_2 op3 rd rs1 (f-i 1) simm13)
+        (sequence ((DI dividend))
+                  (set dividend (join DI SI (reg SI h-y) rs1))
+                  (set rd (trunc SI (sem-op dividend (ext-op DI simm13))))
+                  ; FIXME: Overflow,etc. handling.
+                  )
+        ())
+    (dni (.sym name -cc) (.str comment -cc ", v9 page 152") ((mach-attrs))
+        (.str name "cc $rs1,$rs2,$rd")
+        (+ OP_2 (.sym op3 CC) rd rs1 rs2 (f-i 0) (f-res-asi 0))
+        (sequence ((DI dividend))
+                  (set dividend (join DI SI (reg SI h-y) rs1))
+                  (set rd (trunc SI (sem-op dividend (ext-op DI rs2))))
+                  ; FIXME: Overflow,etc. handling.
+                  set-flags
+                  )
+        ())
+    (dni (.sym name -cc-imm) (.str comment -cc-imm ", v9 page 152") ((mach-attrs))
+        (.str name "cc $rs1,$simm13,$rd")
+        (+ OP_2 (.sym op3 CC) rd rs1 (f-i 1) simm13)
+        (sequence ((DI dividend))
+                  (set dividend (join DI SI (reg SI h-y) rs1))
+                  (set rd (trunc SI (sem-op dividend (ext-op DI simm13))))
+                  ; FIXME: Overflow,etc. handling.
+                  set-flags
+                  )
+        ())
+    )
+)
+(div-binop sdiv "sdiv" MACH32 OP3_SDIV div ext (s32-set-bool-flags rd))
+(div-binop udiv "udiv" MACH32 OP3_UDIV div zext (s32-set-bool-flags rd))
+\f
+; Multiply/Step
+
+(dni mulscc "multiply step" ()
+     "mulscc $rs1,$rs2,$rd"
+     (+ OP_2 OP3_MULSCC rd rs1 rs2 (f-i 0) (f-res-asi 0))
+     (sequence ((SI tmp) (SI add-tmp) (SI rd-tmp))
+              ; v8 page 112, step 2
+              (set tmp (srl SI rs1 (const 1)))
+              (if (ne (xor BI (reg BI h-icc-n) (reg BI h-icc-v))
+                      (const 0))
+                  (set tmp (or SI tmp (const SI #x80000000))))
+              ; step 3
+              (if (ne (and SI (reg SI h-y) (const 1)) (const 0))
+                  (set add-tmp rs2)
+                  (set add-tmp (const 0)))
+              ; step 4
+              (set rd-tmp (add tmp add-tmp))
+              ; step 5
+              (s32-set-addc-flags tmp add-tmp (const 0))
+              ;(set (reg UQI h-cc) (addc-cc tmp add-tmp (const 0)))
+              ; step 6
+              (set (reg SI h-y) (srl SI (reg SI h-y) (const 1)))
+              (if (ne (and SI rs1 (const 1)) (const 0))
+                  (set (reg SI h-y) (or SI (reg SI h-y) (const SI #x80000000))))
+              ; rd first created in rd-tmp so step 6 gets right value for rs1
+              (set SI rd rd-tmp)
+              )
+     ()
+)
+\f
+; Window ops
+; V8 page 117
+
+(define-pmacro (window-binop name comment op3 handler)
+  (begin
+     (dni name comment ()
+         (.str name " $rs1,$rs2,$rd")
+         (+ OP_2 op3 rd rs1 rs2 (f-i 0) (f-res-asi 0))
+         (set rd (c-call WI handler pc rs1 rs2))
+         ())
+     (dni (.sym name -imm) (.str comment -imm) ()
+         (.str name " $rs1,$simm13,$rd")
+         (+ OP_2 op3 rd rs1 (f-i 1) simm13)
+         (set rd (c-call WI handler pc rs1 simm13))
+         ())
+     )
+)
+(window-binop save "save caller's window" OP3_SAVE "@cpu@_do_save")
+(window-binop restore "restore caller's window" OP3_RESTORE "@cpu@_do_restore")
+
+; Trap stuff
+
+(dni rett "return from trap" ()
+     "rett $rs1,$rs2"
+     (+ OP_2 OP3_RETT (f-rd 0) rs1 rs2 (f-i 0) (f-res-asi 0))
+     (delay (const 1)
+           (set pc (c-call WI "@cpu@_do_rett" pc rs1 rs2)))
+     ()
+)
+(dni rett-imm "return from trap, immediate" ()
+     "rett $rs1,$simm13"
+     (+ OP_2 OP3_RETT (f-rd 0) rs1 (f-i 1) simm13)
+     (delay (const 1)
+           (set pc (c-call WI "@cpu@_do_rett" pc rs1 simm13)))
+     ()
+)
+\f
+; Misc.
+
+(dni unimp "unimplemented" ()
+     "unimp $imm22"
+     (+ OP_0 (f-rd-res 0) OP2_UNIMP imm22)
+     (c-call VOID "@arch@_do_unimp" pc imm22)
+     ()
+)
+\f
+; Subroutine calls, returns.
+
+(dnmi call-reg,0 "call reg,0" ()
+     "call $rs1,0" ; FIXME: what's the ,0 suffix for?
+     (emit jmpl rs1 (rd 15) (rs2 0))
+)
+
+(dnmi call-reg "call reg" ()
+     "call $rs1"
+     (emit jmpl rs1 (rd 15) (rs2 0))
+)
+
+(dnmi call,0 "call,0" ()
+     "call $disp30,0" ; FIXME: what's the ,0 suffix for?
+     (emit call disp30)
+)
+
+(dni call "call" (DELAY-SLOT)
+     "call $disp30"
+     (+ OP_1 disp30)
+     (sequence ()
+              (set (reg h-gr 15) pc)
+              (delay (const 1)
+                     (set pc disp30)))
+     ()
+)
+
+(dni jmpl "jmpl" (DELAY-SLOT)
+     "jmpl $rs1+$rs2,$rd"
+     (op3-reg-fmt OP3_JMPL)
+     (sequence ()
+              (set rd pc)
+              (delay (const 1)
+                     (set pc (add WI rs1 rs2))))
+     ()
+)
+
+(dni jmpl-imm "jmpl" (DELAY-SLOT)
+     "jmpl $rs1+$simm13,$rd"
+     (op3-imm-fmt OP3_JMPL)
+     (sequence ()
+              (set rd pc)
+              (delay (const 1)
+                     (set pc (add WI rs1 simm13))))
+     ()
+)
+\f
+;(dsn (icc-op op) (cx:make BI (string-append "icc (" op ")")))
+;(dsn (icc-op op) (list 'c-call: 'BI "icc" (reg UQI h-cc) (.str op)))
+;(dsmn (icc-op op) (list 'c-call: 'BI "icc" '(reg UQI h-cc) (.str op)))
+;(define-pmacro (icc-op op) (c-call BI "icc" (reg UQI h-cc) (.str op)))
+\f
+; Branches
+
+(define-pmacro (bicc-branch bname tname comment cond test br-sem)
+  (begin
+    (dni bname (.str "branch " comment) (V9-DEPRECATED)
+        (.str bname "$a $disp22")
+        (+ OP_0 a cond OP2_BICC disp22)
+        (br-sem test icc)
+        ())
+    (dni tname (.str "trap " comment) (TRAP)
+        (.str tname " $rs1,$rs2")
+        (+ OP_2 (f-a 0) cond (f-op3 #x3a) rs1 (f-i 0) (f-res-asi 0) rs2)
+        (if (test icc)
+            (set pc (c-call IAI "@cpu@_sw_trap" pc rs1 rs2)))
+         ())
+    (dni (.sym tname -imm) (.str "trap-imm " comment) (TRAP)
+         (.str tname " $rs1,$simm13")
+         (+ OP_2 (f-a 0) cond (f-op3 #x3a) rs1 (f-i 1) simm13)
+         (if (test icc)
+             (set pc (c-call IAI "@cpu@_sw_trap" pc rs1 simm13)))
+         ())
+    )
+)
+; test-*,uncond-br-sem,cond-br-sem are defined in sparc.cpu.
+(bicc-branch ba   ta   "always" CC_A   test-always uncond-br-sem)
+(bicc-branch bn   tn   "never"  CC_N   test-never uncond-br-sem)
+(bicc-branch bne  tne  "ne"     CC_NE  test-ne cond-br-sem)
+(bicc-branch be   te   "eq"     CC_E   test-eq cond-br-sem)
+(bicc-branch bg   tg   "gt"     CC_G   test-gt cond-br-sem)
+(bicc-branch ble  tle  "le"     CC_LE  test-le cond-br-sem)
+(bicc-branch bge  tge  "ge"     CC_GE  test-ge cond-br-sem)
+(bicc-branch bl   tl   "lt"     CC_L   test-lt cond-br-sem)
+(bicc-branch bgu  tgu  "gtu"    CC_GU  test-gtu cond-br-sem)
+(bicc-branch bleu tleu "leu"    CC_LEU test-leu cond-br-sem)
+(bicc-branch bcc  tcc  "geu"    CC_CC  test-geu cond-br-sem)
+(bicc-branch bcs  tcs  "ltu"    CC_CS  test-ltu cond-br-sem)
+(bicc-branch bpos tpos "pos"    CC_POS test-pos cond-br-sem)
+(bicc-branch bneg tneg "neg"    CC_NEG test-neg cond-br-sem)
+(bicc-branch bvc  tvc  "vc"     CC_VC  test-vc cond-br-sem)
+(bicc-branch bvs  tvs  "vs"     CC_VS  test-vs cond-br-sem)
+\f
+; Atomic load/stores.
+
+(define-pmacro (atomic-op name comment attrs op3 do_fn)
+  (begin
+    (dnmi (.sym name "-reg") comment attrs
+         (.str name " [$rs1],$rd")
+         (emit (.sym name -reg+reg) rs1 (rs2 0) rd))
+    (dnmi (.sym name "-reg+0") comment attrs
+         (.str name " [$rs1],$rd")
+         (emit (.sym name -reg+imm) rs1 (simm13 0) rd))
+    (dni (.sym name "-reg+reg") comment attrs
+        (.str name " [$rs1+$rs2],$rd")
+        (+ OP_3 op3 rd rs1 (f-i 0) (f-res-asi 0) rs2)
+        (c-call do_fn pc (regno rd) rs1 rs2 (const -1))
+        ())
+    (dni (.sym name "-reg+imm") comment attrs
+        (.str name " [$rs1+$simm13],$rd")
+        (+ OP_3 op3 rd rs1 (f-i 1) simm13)
+        (c-call do_fn pc (regno rd) rs1 simm13 (const -1))
+        ())
+    (dnmi (.sym name "-reg/asi") comment attrs
+         (.str name " [$rs1]$asi,$rd")
+         (emit (.sym name "-reg+reg/asi") rs1 (rs2 0) asi rd))
+    (dni (.sym name "-reg+reg/asi") comment attrs
+        (.str name " [$rs1+$rs2]$asi,$rd")
+        (+ OP_3 (.sym op3 A) rd rs1 (f-i 0) asi rs2)
+        (c-call do_fn pc (regno rd) rs1 rs2 asi)
+        ())
+    )
+)
+(atomic-op ldstub "atomic load-store unsigned byte, v9 page 179" ()
+        OP3_LDSTUB "@cpu@_do_ldstub")
+(atomic-op swap "atomic swap reg with mem" (V9-DEPRECATED)
+        OP3_SWAP "@cpu@_do_swap")
+\f
+; TODO:
+; - tagged add/sub
+; - synthetic insns
diff --git a/cgen/sparcfpu.cpu b/cgen/sparcfpu.cpu
new file mode 100644 (file)
index 0000000..dbbd10e
--- /dev/null
@@ -0,0 +1,527 @@
+; SPARC 32/64 FPU description.  -*- Scheme -*-
+; This file contains fpu instructions common to both sparc32/sparc64.
+; It also contains sparc32/64 specific insns, but only when they are a variant
+; of a collection of common ones (at least that's the current theory).
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; FP support is defined even for cpu's without an fpu as the instructions
+; still have to be assembled and the simulator still has to recognize them
+; so that the appropriate trap can be generated.
+;
+; The physical registers are stored as an array of SI values: here `SI'
+; denotes "set of 32 bits" rather than "32 bit signed integer".
+;
+; wip: currently evaluating the various possibilities
+
+; Floating point hardware.
+
+; The description needs to know whether the fpu is present.
+; Creating a utility register for this purposes seems reasonable.
+; Might want an attribute to denote it as such.
+
+(dsh h-fpu? "h/w fpu present?" () (register BI))
+(dnop fpu? "h/w fpu present?" () h-fpu? f-nil)
+
+(define-pmacro (build-freg-name n) ((.sym f n) n))
+
+(define-hardware
+  (name h-fr32)
+  (semantic-name h-fr)
+  (comment "sparc32 floating point regs")
+  (attrs (MACH32))
+  (type register SI (32))
+  (indices keyword "%" (.map build-freg-name (.iota 32)))
+)
+(define-hardware
+  (name h-fr64)
+  (semantic-name h-fr)
+  (comment "sparc64 floating point regs")
+  (attrs (MACH64))
+  (type register SI (64))
+  (indices keyword "%" (.map build-freg-name (.iota 64)))
+)
+
+(define-hardware
+  (name h-frd32)
+  (semantic-name h-frd)
+  (comment "sparc32 double precision floating point regs")
+  (attrs VIRTUAL (MACH32))
+  (type register DI (16))
+  ; ??? This works, but multiple copies of all the register names might be
+  ; unpalatable.  Another way is to specify a register table plus a constraint.
+  ;(indices keyword "%" (.map build-freg-name (.iota 16 0 2)))
+  (get (index) (join DI SI
+                     (reg h-fr index)
+                     (reg h-fr (add index 1))))
+  (set (index newval)
+       (sequence ()
+                (set (reg h-fr index) (subword SI newval 0))
+                (set (reg h-fr (add index 1)) (subword SI newval 1))))
+)
+
+(define-hardware
+  (name h-frq32)
+  (semantic-name h-frq)
+  (comment "sparc32 quad precision floating point regs")
+  (attrs VIRTUAL (MACH32))
+  (type register TF (8))
+  (indices keyword "%" (.map build-freg-name (.iota 8 0 4)))
+  (get (index) (join TF SI
+                     (reg h-fr index)
+                     (reg h-fr (add index (const 1)))
+                     (reg h-fr (add index (const 2)))
+                     (reg h-fr (add index (const 3)))))
+  (set (index newval)
+       (sequence ()
+                (set (reg h-fr index) (subword SI newval 0))
+                (set (reg h-fr (add index (const 1))) (subword SI newval 1))
+                (set (reg h-fr (add index (const 2))) (subword SI newval 2))
+                (set (reg h-fr (add index (const 3))) (subword SI newval 3))))
+)
+
+(define-hardware
+  (name h-frd64)
+  (semantic-name h-frd)
+  (comment "sparc64 double precision floating point regs")
+  (attrs VIRTUAL (MACH64))
+  (type register DF (32))
+  (indices keyword "%" (.map build-freg-name (.iota 32 0 2)))
+  (get (index) (join DF SI
+                     (reg h-fr index)
+                     (reg h-fr (add index (const 1)))))
+  (set (index newval)
+       (sequence ()
+                (set (reg h-fr index) (subword SI newval 0))
+                (set (reg h-fr (add index (const 1))) (subword SI newval 1))))
+)
+
+(define-hardware
+  (name h-frq64)
+  (semantic-name h-frq)
+  (comment "sparc64 quad precision floating point regs")
+  (attrs VIRTUAL (MACH64))
+  (type register TF (16))
+  (indices keyword "%" (.map build-freg-name (.iota 16 0 4)))
+  (get (index) (join TF SI
+                     (reg h-fr index)
+                     (reg h-fr (add index (const 1)))
+                     (reg h-fr (add index (const 2)))
+                     (reg h-fr (add index (const 3)))))
+  (set (index newval)
+       (sequence ()
+                (set (reg h-fr index) (subword SI newval 0))
+                (set (reg h-fr (add index (const 1))) (subword SI newval 1))
+                (set (reg h-fr (add index (const 2))) (subword SI newval 2))
+                (set (reg h-fr (add index (const 3))) (subword SI newval 3))))
+)
+
+; fp condition codes
+
+(dsh h-fcc0 "%fcc0" ()         (register (UINT 2)))
+(dsh h-fcc1 "%fcc1" ((MACH64)) (register (UINT 2)))
+(dsh h-fcc2 "%fcc2" ((MACH64)) (register (UINT 2)))
+(dsh h-fcc3 "%fcc3" ((MACH64)) (register (UINT 2)))
+\f
+; sparc64 fpu control regs
+
+(dsh h-fsr-rd "fsr rounding direction" ((MACH64)) (register UQI))
+(dsh h-fsr-tem "fsr trap enable mask" ((MACH64)) (register UQI))
+(dsh h-fsr-ns "fsr nonstandard fp" ((MACH64)) (register BI))
+(dsh h-fsr-ver "fsr version" ((MACH64)) (register UQI))
+(dsh h-fsr-ftt "fsr fp trap type" ((MACH64)) (register UQI))
+(dsh h-fsr-qne "fsr queue not empty" ((MACH64)) (register BI))
+(dsh h-fsr-aexc "fsr accrued exception" ((MACH64)) (register UQI))
+(dsh h-fsr-cexc "fsr current exception" ((MACH64)) (register UQI))
+;(dsh h-fsr "floating point state" ((MACH64)) (register UDI))
+
+(dsh h-fpsr-fef "fpsr enable fp" ((MACH64)) (register BI))
+(dsh h-fpsr-du "fpsr dirty upper" ((MACH64)) (register BI))
+(dsh h-fpsr-dl "fpsr dirty lower" ((MACH64)) (register BI))
+
+(define-hardware
+  (name h-fpsr)
+  (comment "fp regs state")
+  (attrs VIRTUAL (MACH64))
+  (type register UQI)
+  (get () (const 0)) ; FIXME
+  (set (newval) (set (raw-reg UQI h-fpsr) (const 0))) ; FIXME
+)
+\f
+; Floating point operands.
+
+(define-operand
+  (name frs1s)
+  (comment "single precision floating point source register 1")
+  (type h-fr)
+  (index f-rs1)
+  (mode SF)
+)
+(define-operand
+  (name frs2s)
+  (comment "single precision floating point source register 2")
+  (type h-fr)
+  (index f-rs2)
+  (mode SF)
+)
+(define-operand
+  (name frds)
+  (comment "single precision floating point dest'n register")
+  (type h-fr)
+  (index f-rd)
+  (mode SF)
+)
+
+(define-operand
+  (name frs1d)
+  (comment "double precision floating point source register 1")
+  (attrs (MACH32))
+  (type h-frd)
+  (index f-rs1)
+  (mode DF)
+)
+(define-operand
+  (name frs2d)
+  (comment "double precision floating point source register 2")
+  (attrs (MACH32))
+  (type h-frd)
+  (index f-rs2)
+  (mode DF)
+)
+(define-operand
+  (name frdd)
+  (comment "double precision floating point dest'n register")
+  (attrs (MACH32))
+  (type h-frd)
+  (index f-rd)
+  (mode DF)
+)
+
+(dnop frs1q "quad precision floating point source register 1" ((MACH32))
+      h-frq f-rs1)
+(dnop frs2q "quad precision floating point source register 2" ((MACH32))
+      h-frq f-rs2)
+(dnop frdq  "quad precision floating point dest'n register"   ((MACH32))
+      h-frq f-rd)
+
+; Encoding/decoding of field for sparc64 requires extra effort.
+; See v9 page 40: 5.1.4.1 Floating-Point Register Number Encoding.
+(df   f-frs1d-64 "rs1 field for sparc64 DF regs" ((MACH64)) 18 5 UINT
+      ((value pc) (or INT (srl value (const 5)) (and value (const #x1e))))
+      ((value pc) (or INT (sll (and value (const 1)) (const 5))
+                      (and value (const #x1e))))
+)
+(df   f-frs2d-64 "rs2 field for sparc64 DF regs" ((MACH64)) 4 5 UINT
+      ((value pc) (or INT (srl value (const 5)) (and value (const #x1e))))
+      ((value pc) (or INT (sll (and value (const 1)) (const 5))
+                      (and value (const #x1e))))
+)
+(df   f-frdd-64  "rd field for sparc64 DF regs" ((MACH64)) 29 5 UINT
+      ((value pc) (or INT (srl value (const 5)) (and value (const #x1e))))
+      ((value pc) (or INT (sll (and value (const 1)) (const 5))
+                      (and value (const #x1e))))
+)
+(dnop frs1d "double precision floating point source register 1" ((MACH64))
+      h-frd f-frs1d-64)
+(dnop frs2d "double precision floating point source register 2" ((MACH64))
+      h-frd f-frs2d-64)
+(dnop frdd  "double precision floating point dest'n register"   ((MACH64))
+      h-frd f-frdd-64)
+
+; Encoding/decoding of field for sparc64 requires extra effort.
+; See v9 page 40: 5.1.4.1 Floating-Point Register Number Encoding.
+(df   f-frs1q-64 "rs1 field for sparc64 TF regs" ((MACH64)) 18 5 UINT
+      ((value pc) (or INT (srl value (const 5)) (and value (const #x1e))))
+      ((value pc) (or INT (sll (and value (const 1)) (const 5))
+                      (and value (const #x1e))))
+)
+(df   f-frs2q-64 "rs2 field for sparc64 TF regs" ((MACH64)) 4 5 UINT
+      ((value pc) (or INT (srl value (const 5)) (and value (const #x1e))))
+      ((value pc) (or INT (sll (and value (const 1)) (const 5))
+                      (and value (const #x1e))))
+)
+(df   f-frdq-64  "rd field for sparc64 TF regs" ((MACH64)) 29 5 UINT
+      ((value pc) (or INT (srl value (const 5)) (and value (const #x1e))))
+      ((value pc) (or INT (sll (and value (const 1)) (const 5))
+                      (and value (const #x1e))))
+)
+(dnop frs1q "quad precision floating point source register 1" ((MACH64))
+      h-frq f-frs1q-64)
+(dnop frs2q "quad precision floating point source register 2" ((MACH64))
+      h-frq f-frs2q-64)
+(dnop frdq  "quad precision floating point dest'n register"   ((MACH64))
+      h-frq f-frdq-64)
+
+(dnop fcc0 "%fcc0" () h-fcc0 f-nil)
+\f
+; Misc. support macros.
+; FIXME: TRAP32 wip
+; FIXME: sparc32/sparc64 differences
+; FIXME: trap handling in general (c-call's used until more thought invested)
+
+; Check if fpu is present and enabled.
+
+(define-pmacro (check-fp-enabled)
+  ; FIXME: more things to check
+  (if (not fpu?)
+      (c-call VOID "@cpu@_hw_trap" pc (c-code INT "TRAP32_FP_DIS")))
+)
+
+; Return pointer to FPU.
+; ??? wip.  maybe move `snan?' to language proper?
+
+(define-pmacro (current-fpu) (c-call PTR "CGEN_CPU_FPU"))
+
+; Issue appropriate trap if x is an snan.
+
+(define-pmacro (check-sf-snan x)
+  (if (c-raw-call BI "cgen_sf_snan_p" (current-fpu) x)
+      (c-call VOID "@cpu@_hw_trap" pc (c-code INT "TRAP32_FP_DIS"))) ; FIXME
+)
+
+(define-pmacro (check-df-snan x)
+  (if (c-raw-call BI "cgen_df_snan_p" (current-fpu) x)
+      (c-call VOID "@cpu@_hw_trap" pc (c-code INT "TRAP32_FP_DIS"))) ; FIXME
+)
+\f
+; Floating point memory ops.
+
+; Note: the startup code uses a load to %f0 to see if an fpu is present.
+; Other startup code tries to set the EF bit in the PSR.
+
+(define-pmacro (fp-ld-op name comment op3 mode dest)
+  (begin
+    (dnmi (.sym name "f-reg") comment ()
+         (.str name " [$rs1],$" dest)
+         (emit (.sym name f-reg+reg) rs1 (rs2 0) dest))
+    (dnmi (.sym name "f-reg+0") comment ()
+         (.str name " [$rs1],$" dest)
+         (emit (.sym name f-reg+imm) rs1 (simm13 0) dest))
+    (dni (.sym name "f-reg+reg") comment ()
+        (.str name " [$rs1+$rs2],$" dest)
+        (+ OP_3 op3 dest rs1 (f-i 0) (f-res-asi 0) rs2)
+        (sequence ()
+                  (check-fp-enabled)
+                  (set dest (mem mode (add WI rs1 rs2))))
+        ())
+    (dni (.sym name "f-reg+imm") comment ()
+        (.str name " [$rs1+$simm13],$" dest)
+        (+ OP_3 op3 dest rs1 (f-i 1) simm13)
+        (sequence ()
+                  (check-fp-enabled)
+                  (set dest (mem mode (add WI rs1 simm13))))
+        ())
+    (dnmi (.sym name "f-reg/asi") comment ()
+         (.str name " [$rs1]$asi,$" dest)
+         (emit (.sym name f-reg+reg/asi) rs1 (rs2 0) asi dest))
+    (dni (.sym name "f-reg+reg/asi") comment ()
+        (.str name " [$rs1+$rs2]$asi,$" dest)
+        (+ OP_3 (.sym op3 A) dest rs1 (f-i 0) asi rs2)
+        (sequence ()
+                  (check-fp-enabled)
+                  (set dest (mem mode (add WI rs1 rs2))))
+        ())
+    )
+)
+(fp-ld-op ld "fp SF load" OP3_LDF SF frds)
+(fp-ld-op ldd "fp DF load" OP3_LDDF DF frdd)
+
+(define-pmacro (fp-st-op name comment op3 mode src)
+  (begin
+    (dnmi (.sym name "f-reg") comment ()
+         (.str name " $" src ",[$rs1]")
+         (emit (.sym name f-reg+reg) rs1 (rs2 0) src))
+    (dnmi (.sym name "f-reg+0") comment ()
+         (.str name " $" src ",[$rs1]")
+         (emit (.sym name f-reg+imm) rs1 (simm13 0) src))
+    (dni (.sym name "f-reg+reg") comment ()
+        (.str name " $" src ",[$rs1+$rs2]")
+        (+ OP_3 op3 src rs1 (f-i 0) (f-res-asi 0) rs2)
+        (sequence ()
+                  (check-fp-enabled)
+                  (set (mem mode (add WI rs1 rs2)) src))
+        ())
+    (dni (.sym name "f-reg+imm") comment ()
+        (.str name " $" src ",[$rs1+$simm13]")
+        (+ OP_3 op3 src rs1 (f-i 1) simm13)
+        (sequence ()
+                  (check-fp-enabled)
+                  (set (mem mode (add WI rs1 simm13)) src))
+        ())
+    (dnmi (.sym name "f-reg/asi") comment ()
+         (.str name " $" src ",[$rs1]$asi")
+         (emit (.sym name -reg+reg/asi) rs1 (rs2 0) asi src))
+    (dni (.sym name "f-reg+reg/asi") comment ()
+        (.str name " $" src ",[$rs1+$rs2]$asi")
+        (+ OP_3 (.sym op3 A) src rs1 (f-i 0) asi rs2)
+        (sequence ()
+                  (check-fp-enabled)
+                  (set (mem mode (add WI rs1 rs2)) src))
+        ())
+    )
+)
+(fp-st-op st "fp SF store" OP3_STF SF frds)
+(fp-st-op std "fp DF store" OP3_STDF DF frdd)
+\f
+; SF mode arithmetic ops.
+
+(define-pmacro (sf-unary-op name comment op3 fpop1 fn)
+  (begin
+    (dni name comment ()
+        (.str name " $frs1s,$frds")
+        (+ OP_2 op3 fpop1 frds frs1s (f-rs2 0))
+        (sequence ()
+                  (check-fp-enabled)
+                  (set frds (fn frs1s))
+                  ; ??? dest is modified if snan, assign to tmp first?
+                  ; [grep for all check-*-snan's]
+                  (check-sf-snan frds))
+        ())
+    )
+)
+
+(define-pmacro (sf-binary-op name comment op3 fpop1 fn)
+  (begin
+    (dni name comment ()
+        (.str name " $frs1s,$frs2s,$frds")
+        (+ OP_2 op3 fpop1 frds frs1s frs2s)
+        (sequence ()
+                  (check-fp-enabled)
+                  (set frds (fn frs1s frs2s))
+                  (check-sf-snan frds))
+        ())
+    )
+)
+
+(sf-unary-op fnegs "32 bit fp neg" OP3_FPOPS1 FPOPS1_FNEGS neg)
+(sf-unary-op fabss "32 bit fp abs" OP3_FPOPS1 FPOPS1_FABSS abs)
+
+(sf-binary-op fadds "32 bit fp add" OP3_FPOPS1 FPOPS1_FADDS add)
+(sf-binary-op fsubs "32 bit fp sub" OP3_FPOPS1 FPOPS1_FSUBS sub)
+(sf-binary-op fmuls "32 bit fp mul" OP3_FPOPS1 FPOPS1_FMULS mul)
+(sf-binary-op fdivs "32 bit fp div" OP3_FPOPS1 FPOPS1_FDIVS div)
+
+; ??? floating point compares are wip
+
+(dni fp-fcmps "32 bit compare" ()
+     "fcmps $frs1s,$frs2s"
+     (+ OP_2 OP3_FPOPS2 FPOPS2_FCMPS (f-rd 0) frs1s frs2s)
+     (sequence ()
+              (check-fp-enabled)
+              (set fcc0 (c-call UINT "SFCMP" frs1s frs2s)))
+     ()
+)
+
+(dni fp-fcmpse "32 bit compare, signal if any nans" ()
+     "fcmpse $frs1s,$frs2s"
+     (+ OP_2 OP3_FPOPS2 FPOPS2_FCMPSE (f-rd 0) frs1s frs2s)
+     (sequence ()
+              (check-fp-enabled)
+              (check-sf-snan frs1s)
+              (check-sf-snan frs2s)
+              (set fcc0 (c-call UINT "SFCMP" frs1s frs2s)))
+     ()
+)
+\f
+; DF mode arithmetic ops.
+
+(define-pmacro (df-unary-op name comment op3 fpop1 fn)
+  (begin
+    (dni name comment ()
+        (.str name " $frs1d,$frdd")
+        (+ OP_2 op3 fpop1 frdd frs1d (f-rs2 0))
+        (sequence ()
+                  (check-fp-enabled)
+                  (set frdd (fn frs1d))
+                  (check-df-snan frdd))
+        ())
+    )
+)
+
+(define-pmacro (df-binary-op name comment op3 fpop1 fn)
+  (begin
+    (dni name comment ()
+        (.str name " $frs1d,$frs2d,$frdd")
+        (+ OP_2 op3 fpop1 frdd frs1d frs2d)
+        (sequence ()
+                  (check-fp-enabled)
+                  (set frdd (fn frs1d frs2d))
+                  (check-df-snan frdd))
+        ())
+    )
+)
+
+(df-unary-op fnegd "64 bit fp neg" OP3_FPOPS1 FPOPS1_FNEGD neg)
+(df-unary-op fabsd "64 bit fp abs" OP3_FPOPS1 FPOPS1_FABSD abs)
+
+(df-binary-op faddd "64 bit fp add" OP3_FPOPS1 FPOPS1_FADDD add)
+(df-binary-op fsubd "64 bit fp sub" OP3_FPOPS1 FPOPS1_FSUBD sub)
+(df-binary-op fmuld "64 bit fp mul" OP3_FPOPS1 FPOPS1_FMULD mul)
+(df-binary-op fdivd "64 bit fp div" OP3_FPOPS1 FPOPS1_FDIVD div)
+
+; ??? floating point compares are wip
+
+(dni fp-fcmpd "64 bit compare" ()
+     "fcmpd $frs1d,$frs2d"
+     (+ OP_2 OP3_FPOPS2 FPOPS2_FCMPD (f-rd 0) frs1d frs2d)
+     (sequence ()
+              (check-fp-enabled)
+              (set fcc0 (c-call UINT "DFCMP" frs1d frs2d)))
+     ()
+)
+
+(dni fp-fcmpde "64 bit compare, signal if any nans" ()
+     "fcmpde $frs1d,$frs2d"
+     (+ OP_2 OP3_FPOPS2 FPOPS2_FCMPDE (f-rd 0) frs1d frs2d)
+     (sequence ()
+              (check-fp-enabled)
+              (check-df-snan frs1d)
+              (check-df-snan frs2d)
+              (set fcc0 (c-call UINT "DFCMP" frs1d frs2d)))
+     ()
+)
+\f
+; Branches
+
+; CC is one of fcc0,fcc
+(define-pmacro (ftest-u cc) (eq cc FCC_UN))
+(define-pmacro (ftest-g cc) (eq cc FCC_GT))
+(define-pmacro (ftest-ug cc) (orif (eq cc FCC_UN) (eq cc FCC_GT)))
+(define-pmacro (ftest-l cc)  (eq cc FCC_LT))
+(define-pmacro (ftest-ul cc) (orif (eq cc FCC_UN) (eq cc FCC_LT)))
+(define-pmacro (ftest-lg cc) (orif (eq cc FCC_LT) (eq cc FCC_GT)))
+(define-pmacro (ftest-ne cc) (ne cc FCC_EQ))
+(define-pmacro (ftest-e cc) (eq cc FCC_EQ))
+(define-pmacro (ftest-ue cc) (orif (eq cc FCC_UN) (eq cc FCC_EQ)))
+(define-pmacro (ftest-ge cc) (orif (eq cc FCC_GT) (eq cc FCC_EQ)))
+(define-pmacro (ftest-uge cc) (ne cc FCC_LT))
+(define-pmacro (ftest-le cc) (orif (eq cc FCC_LT) (eq cc FCC_EQ)))
+(define-pmacro (ftest-ule cc) (ne cc FCC_GT))
+(define-pmacro (ftest-o cc) (ne cc FCC_UN))
+
+(define-pmacro (fbfcc-branch bname comment cond test br-sem)
+  (begin
+    (dni bname (.str "fp branch " comment) (V9-DEPRECATED)
+        (.str bname "$a $disp22")
+        (+ OP_0 a cond OP2_FBFCC disp22)
+        (br-sem test fcc0)
+        ())
+    )
+)
+(fbfcc-branch fba   "always"               FCOND_A  test-always uncond-br-sem)
+(fbfcc-branch fbn   "never"                FCOND_N  test-never uncond-br-sem)
+(fbfcc-branch fbu   "unordered"            FCOND_U  ftest-u cond-br-sem)
+(fbfcc-branch fbg   "greater"              FCOND_G  ftest-g cond-br-sem)
+(fbfcc-branch fbug  "unordered or greater" FCOND_UG ftest-ug cond-br-sem)
+(fbfcc-branch fbl   "less"                 FCOND_L  ftest-l cond-br-sem)
+(fbfcc-branch fbul  "unordered or less"    FCOND_UL ftest-ul cond-br-sem)
+(fbfcc-branch fblg  "less or greater"      FCOND_LG ftest-lg cond-br-sem)
+(fbfcc-branch fbne  "not equal"            FCOND_NE ftest-ne cond-br-sem)
+(fbfcc-branch fbe   "equal"                FCOND_E  ftest-e cond-br-sem)
+(fbfcc-branch fbue  "unordered or equal"   FCOND_UE ftest-ue cond-br-sem)
+(fbfcc-branch fbge  "greater or equal"     FCOND_GE ftest-ge cond-br-sem)
+(fbfcc-branch fbuge "unordered or greater or equal" FCOND_UGE ftest-uge cond-br-sem)
+(fbfcc-branch fble  "less or equal"        FCOND_LE ftest-le cond-br-sem)
+(fbfcc-branch fbule "unordered or less or equal" FCOND_ULE  ftest-ule cond-br-sem)
+(fbfcc-branch fbo   "ordered"              FCOND_O  ftest-o cond-br-sem)
diff --git a/cgen/stamp-h.in b/cgen/stamp-h.in
new file mode 100644 (file)
index 0000000..9788f70
--- /dev/null
@@ -0,0 +1 @@
+timestamp
diff --git a/cgen/thumb.cpu b/cgen/thumb.cpu
new file mode 100644 (file)
index 0000000..343a9ca
--- /dev/null
@@ -0,0 +1,842 @@
+; ARM/Thumb instructions.  -*- Scheme -*-
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+;
+; This file is included by arm.cpu.
+
+; Hardware elements.
+
+(define-hardware 
+  (name h-gr-t)
+  (comment "Thumb's general purpose registers")
+  (attrs (ISA thumb) VIRTUAL) ; ??? CACHE-ADDR should be doable
+  (type register WI (8))
+  (indices keyword ""
+          ((r0 0) (r1 1) (r2 2) (r3 3) (r4 4) (r5 5) (r6 6) (r7 7)))
+  (get (regno) (reg h-gr regno))
+  (set (regno newval) (set (reg h-gr regno) newval))
+)
+
+(define-hardware
+  (name h-lr-t)
+  (comment "Thumb's access to the LR register")
+  (attrs (ISA thumb) VIRTUAL)
+  (type register WI)
+  (get () (reg h-gr 14))
+  (set (newval) (set (reg h-gr 14) newval))
+)
+
+(define-hardware
+  (name h-sp-t)
+  (comment "Thumb's access to the SP register")
+  (attrs (ISA thumb) VIRTUAL)
+  (type register WI)
+  (get () (reg h-gr 13))
+  (set (newval) (set (reg h-gr 13) newval))
+)
+\f
+; Instruction fields.
+
+; define-normal-thumb-field
+(define-pmacro (dntf name comment attrs start length)
+  (dnf name comment (.splice (.unsplice attrs) (ISA thumb)) start length)
+)
+
+; Main opcode fields.
+(dntf f-op3 "First 3 bits of opcode"   () 15 3)
+(dntf f-op4 "First 4 bits of opcode"   () 15 4)
+(dntf f-op5 "First 5 bits of opcode"   () 15 5)
+(dntf f-op6 "First 6 bits of opcode"   () 15 6)
+(dntf f-op8 "First 8 bits of opcode"   () 15 8)
+
+; Other opcode like fields with special names.
+(dntf f-h1 "h1 field in hireg insns" () 7 1)
+(dntf f-h2 "h2 field in hireg insns" () 6 1)
+(dntf f-l  "load/store indicator" () 11 1)
+(dntf f-b  "byte/word indicator" () 10 1)
+(dntf f-h  "byte/halfword indicator" () 11 1)
+
+; Misc. remaining opcode fields (constant values but unnamed).
+(dntf f-bit9 "bit 9" () 9 1)
+
+; Data fields.
+(dntf f-offset5  "5 bit unsigned immediate" () 10 5)
+(dntf f-rs       "Rs (source reg)" () 5 3)
+(dntf f-rd       "Rd (dest reg)" () 2 3)
+(dntf f-rn       "Rn (2nd source reg in add/sub insns" () 8 3)
+(dntf f-offset3  "3 bit unsigned immediate in add/sub insns" () 8 3)
+(dntf f-bit10-rd "Rd (dest reg) at bit 10" () 10 3)
+(dntf f-offset8  "8 bit unsigned immediate" () 7 8)
+(dntf f-ro       "Ro (offset register)" () 8 3)
+(dntf f-rb       "Rb (base register)" () 5 3)
+\f
+; Instruction operands.
+
+; define-normal-thumb-operand
+(define-pmacro (dntop name comment attrs hw indx)
+  (dnop name comment (.splice (.unsplice attrs) (ISA thumb)) hw indx)
+)
+
+(dntop sp "stack pointer" () h-sp-t f-nil)
+(dntop lr "link register" () h-lr-t f-nil)
+
+(dntop rd      "destination register"      () h-gr-t f-rd)
+(dntop rs      "source register"           () h-gr-t f-rs)
+(dntop offset5 "5 bit unsigned immediate"  () h-uint f-offset5)
+(dntop rn      "2nd source register"       () h-gr-t f-rn)
+(dntop offset3 "3 bit unsigned immediate"  () h-uint f-offset3)
+(dntop offset8 "8 bit unsigned immediate"  () h-uint f-offset8)
+
+(dntop bit10-rd "rd in bits 10,9,8"        () h-gr-t f-bit10-rd)
+
+(dntop ro      "offset register"           () h-gr-t f-ro)
+(dntop rb      "base register"             () h-gr-t f-rb)
+\f
+; Instruction definitions.
+
+; Cover macro to dni to indicate these are all Thumb insns.
+; dnti: define-normal-thumb-insn
+
+(define-pmacro (dnti xname xcomment xattrs xsyntax xformat xsemantics)
+  (define-insn
+    (name xname)
+    (comment xcomment)
+    (.splice attrs (.unsplice xattrs) (ISA thumb))
+    (syntax xsyntax)
+    (format xformat)
+    (semantics xsemantics)
+    )
+)
+
+; Move shifted register insns.
+
+(dntf f-shift-op "Move shifted register opcode" () 12 2)
+
+(dnti lsl "logical shift left"
+      ()
+      "lsl $rd,$rs,#$offset5"
+      (+ (f-op3 0) (f-shift-op 0) offset5 rs rd)
+      (sequence ((BI carry-out))
+               (set carry-out
+                    (c-call BI "compute_carry_out_immshift" rs
+                            SHIFT-TYPE-lsl offset5 cbit))
+               (set rd (sll rs offset5))
+               (set-logical-cc rd carry-out))
+)
+(dnti lsr "logical shift right"
+      ()
+      "lsr $rd,$rs,#$offset5"
+      (+ (f-op3 0) (f-shift-op 1) offset5 rs rd)
+      (sequence ((BI carry-out))
+               (set carry-out
+                    (c-call BI "compute_carry_out_immshift" rs
+                            SHIFT-TYPE-lsr offset5 cbit))
+               (set rd (srl rs offset5))
+               (set-logical-cc rd carry-out))
+)
+(dnti asr "arithmetic shift right"
+      ()
+      "asr $rd,$rs,#$offset5"
+      (+ (f-op3 0) (f-shift-op 2) offset5 rs rd)
+      (sequence ((BI carry-out))
+               (set carry-out
+                    (c-call BI "compute_carry_out_immshift" rs
+                            SHIFT-TYPE-asr offset5 cbit))
+               (set rd (sra rs offset5))
+               (set-logical-cc rd carry-out))
+)
+\f
+; Add/subtract insns.
+
+(dntf f-i "immediate indicator in add/sub insns" () 10 1)
+
+(dntf f-addsub-op "Add/subtract opcode" () 9 1)
+
+(dnti add "add reg+reg"
+      ()
+      "add $rd,$rs,$rn"
+      (+ (f-op5 3) (f-i 0) (f-addsub-op 0) rn rs rd)
+      (sequence ()
+               (set-add-flags rs rn 0)
+               (set rd (add rs rn)))
+)
+(dnti addi "add reg+imm"
+      ()
+      "add $rd,$rs,#$offset3"
+      (+ (f-op5 3) (f-i 1) (f-addsub-op 0) offset3 rs rd)
+      (sequence ()
+               (set-add-flags rs offset3 0)
+               (set rd (add rs offset3)))
+)
+(dnti sub "sub reg+reg"
+      ()
+      "sub $rd,$rs,$rn"
+      (+ (f-op5 3) (f-i 0) (f-addsub-op 1) rn rs rd)
+      (sequence ()
+               (set-sub-flags rs rn 1)
+               (set rd (sub rs rn)))
+)
+(dnti subi "sub reg+imm"
+      ()
+      "sub $rd,$rs,#$offset3"
+      (+ (f-op5 3) (f-i 1) (f-addsub-op 1) offset3 rs rd)
+      (sequence ()
+               (set-sub-flags rs offset3 1)
+               (set rd (sub rs offset3)))
+)
+\f
+; Move/compare/add/subtract immediate insns.
+
+(dntf f-mcasi-op "Move/compare/add/subtract immediate opcode" () 12 2)
+
+(dnti mov "move imm->reg"
+      ()
+      "mov ${bit10-rd},#$offset8"
+      (+ (f-op3 1) (f-mcasi-op 0) bit10-rd offset8)
+      (sequence ()
+               (set bit10-rd offset8)
+               (set-zn-flags bit10-rd))
+)
+(dnti cmp "cmp reg,imm"
+      ()
+      "cmp ${bit10-rd},#$offset8"
+      (+ (f-op3 1) (f-mcasi-op 1) bit10-rd offset8)
+      (set-sub-flags bit10-rd offset8 1)
+)
+(dnti addi8 "add 8 bit immediate"
+      ()
+      "add ${bit10-rd},#$offset8"
+      (+ (f-op3 1) (f-mcasi-op 2) bit10-rd offset8)
+      (sequence ()
+               (set-add-flags bit10-rd offset8 0)
+               (set bit10-rd (add bit10-rd offset8)))
+)
+(dnti subi8 "sub 8 bit immediate"
+      ()
+      "sub ${bit10-rd},#$offset8"
+      (+ (f-op3 1) (f-mcasi-op 3) bit10-rd offset8)
+      (sequence ()
+               (set-sub-flags bit10-rd offset8 1)
+               (set bit10-rd (sub bit10-rd offset8)))
+)
+\f
+; ALU operations.
+
+(dntf f-alu-op "ALU opcode" () 9 4)
+
+(define-pmacro (alu-logical-op mnemonic comment alu-opcode sem-fn)
+  (dnti (.sym alu- mnemonic) comment
+       ()
+       (.str mnemonic " $rd,$rs")
+       (+ (f-op6 #x10) (f-alu-op alu-opcode) rs rd)
+       (sequence ()
+                 (set rd (sem-fn rd rs))
+                 (set-zn-flags rd))
+       )
+)
+
+(define-pmacro (alu-arith-op mnemonic comment alu-opcode sem-fn set-flags)
+  (dnti (.sym alu- mnemonic) comment
+       ()
+       (.str mnemonic " $rd,$rs")
+       (+ (f-op6 #x10) (f-alu-op alu-opcode) rs rd)
+       (sequence ((SI result))
+                 (set result (sem-fn rd rs cbit))
+                 (set-flags rd rs cbit)
+                 (set rd result))
+       )
+)
+
+(define-pmacro (alu-shift-op mnemonic comment alu-opcode sem-fn shift-type)
+  (dnti (.sym alu- mnemonic) comment
+       ()
+       (.str mnemonic " $rd,$rs")
+       (+ (f-op6 #x10) (f-alu-op alu-opcode) rs rd)
+       (sequence ((BI carry-out) (SI result))
+                 (set carry-out
+                      (c-call BI "compute_carry_out_regshift"
+                              rd shift-type rs cbit))
+                 (set result (sem-fn rd rs))
+                 (set rd result)
+                 (set-logical-cc result carry-out))
+       )
+)
+
+(alu-logical-op and "and" 0 and)
+(alu-logical-op eor "xor" 1 xor)
+
+(alu-shift-op lsl "logical shift left" 2 sll SHIFT-TYPE-lsl)
+(alu-shift-op lsr "logical shift right" 3 srl SHIFT-TYPE-lsr)
+(alu-shift-op asr "arithmetic shift right" 4 sra SHIFT-TYPE-asr)
+(alu-shift-op ror "rotate right" 7 ror SHIFT-TYPE-ror)
+
+(alu-arith-op adc "add with carry" 5
+       (.pmacro (rd rs cbit) (addc rd rs cbit))
+       (.pmacro (rd rs cbit) (set-add-flags rd rs cbit)))
+(alu-arith-op sbc "subtract with carry (borrow)" 6
+       (.pmacro (rd rs cbit) (subc rd rs (not cbit)))
+       (.pmacro (rd rs cbit) (set-sub-flags rd rs cbit)))
+
+(dnti alu-tst "test"
+      ()
+      "tst $rd,$rs"
+      (+ (f-op6 #x10) (f-alu-op 8) rs rd)
+      (sequence ((SI x))
+               (set x (and rd rs))
+               (set-zn-flags x))
+)
+
+(alu-arith-op neg "negate" 9
+             (.pmacro (rd rs cbit) (neg rs))
+             (.pmacro (rd rs cbit) (set-sub-flags 0 rs 1)))
+
+(dnti alu-cmp "compare"
+      ()
+      "cmp $rd,$rs"
+      (+ (f-op6 #x10) (f-alu-op 10) rs rd)
+      (set-sub-flags rd rs 1)
+)
+(dnti alu-cmn "compare negative"
+      ()
+      "cmn $rd,$rs"
+      (+ (f-op6 #x10) (f-alu-op 11) rs rd)
+      (set-add-flags rd rs 0)
+)
+
+(alu-logical-op orr "or" 12 or)
+
+; use alu-logical-op 'cus it sets the condition codes the way we want
+(alu-logical-op mul "multiply" 13 mul)
+
+(alu-logical-op bic "bit clear" 14 (.pmacro (rd rs) (and rd (inv rs))))
+
+(alu-logical-op mvn "invert" 15 (.pmacro (rd rs) (inv rs)))
+\f
+; Hi register operations.
+;
+; R15 and PC are treated as two distinct registers.  It is assumed that the
+; execution environment ensures R15 = PC+4.  All reads are taken from R15.
+; All writes are written to PC.
+
+(define-hardware
+  (name h-hiregs)
+  (comment "High registers (R8-R15)")
+  (attrs (ISA thumb) VIRTUAL)
+  (type register WI (8))
+  (indices keyword ""
+          ((r8 0) (r9 1) (r10 2) (r11 3) (r12 4) (r13 5) (r14 6) (r15 7)))
+  ; ??? Accesses won't be as efficient as possible as +8 calculation will
+  ; get done at exec time (could be defered to extract phase), but that's an
+  ; optimization that can be generally useful in the extract phase.
+  (get (regno) (reg h-gr (add regno (const 8))))
+  (set (regno newval) (set (reg h-gr (add regno (const 8))) newval))
+)
+
+
+(dntf f-hireg-op  "Hi register opcode" () 9 2)
+
+(dntop hs "high source register"      () h-hiregs f-rs)
+(dntop hd "high destination register" () h-hiregs f-rd)
+
+(define-pmacro (hireg-op mnemonic
+                        lo-op-hi-comment
+                        hi-op-lo-comment
+                        hi1-op-hi2-comment
+                        opcode
+                        lo-dest-sem-fn
+                        hi-dest-sem-fn)
+  (begin
+    (dnti (.sym mnemonic -rd-hs)
+         lo-op-hi-comment
+         ()
+         (.str mnemonic " $rd,$hs")
+         (+ (f-op6 #x11) (f-hireg-op opcode) (f-h1 0) (f-h2 1) hs rd)
+         (lo-dest-sem-fn rd hs)
+         )
+    (dnti (.sym mnemonic -hd-rs)
+         hi-op-lo-comment
+         ()
+         (.str mnemonic " $hd,$rs")
+         (+ (f-op6 #x11) (f-hireg-op opcode) (f-h1 1) (f-h2 0) hd rs)
+         (hi-dest-sem-fn hd rs)
+         )
+    (dnti (.sym mnemonic -hd-hs)
+         hi1-op-hi2-comment
+         ()
+         (.str mnemonic " $hd,$hs")
+         (+ (f-op6 #x11) (f-hireg-op opcode) (f-h1 1) (f-h2 1) hd hs)
+         (hi-dest-sem-fn hd hs)
+         )
+    )
+)
+
+(hireg-op add "lo = lo + hi" "hi = hi + lo" "hi = hi + hi2" 0
+         (.pmacro (src1-dest src2) (set src1-dest (add src1-dest src2)))
+         (.pmacro (src1-dest src2)
+                  (if (eq (regno src1-dest) 7)
+                      (set pc (add src1-dest src2))
+                      (set src1-dest (add src1-dest src2))))
+)
+
+(hireg-op cmp "compare lo,hi" "compare hi,lo" "compare hi1,hi2" 1
+         (.pmacro (src1 src2) (set-sub-flags src1 src2 1))
+         (.pmacro (src1 src2) (set-sub-flags src1 src2 1))
+)
+
+(hireg-op mov "lo = hi" "hi = lo" "hi1 = hi2" 2
+         (.pmacro (dest src) (set dest src))
+         (.pmacro (dest src)
+                  (if (eq (regno dest) 7)
+                      (set pc src)
+                      (set dest src)))
+)
+
+(dnti bx-rs "bx on lo reg"
+      ()
+      "bx $rs"
+      (+ (f-op6 #x11) (f-hireg-op 3) (f-h1 0) (f-h2 0) (f-rd 0) rs)
+      (sequence ()
+               (set pc rs)
+               (if (not (and rs 1))
+                   (set (reg h-tbit) 0)))
+)
+(dnti bx-hs "bx on hi reg"
+      ()
+      "bx $hs"
+      (+ (f-op6 #x11) (f-hireg-op 3) (f-h1 0) (f-h2 1) (f-rd 0) hs)
+      (sequence ()
+               (set pc hs)
+               (if (not (and hs 1))
+                   (set (reg h-tbit) 0)))
+)
+\f
+; PC relative load.
+
+(df f-word8 "10 bit unsigned offset, right shifted by 2"
+    ((ISA thumb))
+    7 8 UINT
+    ((value pc) (srl WI value (const 2)))
+    ((value pc) (sll WI value (const 2)))
+)
+
+(dntop word8 "10 bit unsigned immediate" () h-uint f-word8)
+
+(dnti ldr-pc "pc relative load"
+      ()
+      "ldr ${bit10-rd},[pc,#$word8]"
+      (+ (f-op5 9) bit10-rd word8)
+      (set bit10-rd
+          (mem WI (add (and (add pc (const 4)) (const WI -4)) word8)))
+)
+\f
+; Load/store with register offset.
+
+(dnti str "store word"
+      ()
+      "str $rd,[$rb,$ro]"
+      (+ (f-op4 5) (f-l 0) (f-b 0) (f-bit9 0) ro rb rd)
+      (set (mem WI (add rb ro)) rd)
+)
+(dnti strb "store byte"
+      ()
+      "strb $rd,[$rb,$ro]"
+      (+ (f-op4 5) (f-l 0) (f-b 1) (f-bit9 0) ro rb rd)
+      (set (mem QI (add rb ro)) rd)
+)
+(dnti ldr "load word"
+      ()
+      "ldr $rd,[$rb,$ro]"
+      (+ (f-op4 5) (f-l 1) (f-b 0) (f-bit9 0) ro rb rd)
+      (set rd (mem WI (add rb ro)))
+)
+(dnti ldrb "load zero extended byte"
+      ()
+      "ldrb $rd,[$rb,$ro]"
+      (+ (f-op4 5) (f-l 1) (f-b 1) (f-bit9 0) ro rb rd)
+      (set rd (zext SI (mem QI (add rb ro))))
+)
+\f
+; Load/store sign-extended byte/halfword.
+
+(dntf f-s  "signed/unsigned indicator" () 10 1)
+
+(dnti strh "store halfword"
+      ()
+      "strh $rd,[$rb,$ro]"
+      (+ (f-op4 5) (f-h 0) (f-s 0) (f-bit9 1) ro rb rd)
+      (set (mem HI (add rb ro)) rd)
+)
+(dnti ldrh "load zero extended halfword"
+      ()
+      "ldrh $rd,[$rb,$ro]"
+      (+ (f-op4 5) (f-h 1) (f-s 0) (f-bit9 1) ro rb rd)
+      (set rd (zext SI (mem HI (add rb ro))))
+)
+(dnti ldsb "load sign extended byte"
+      ()
+      "ldsb $rd,[$rb,$ro]"
+      (+ (f-op4 5) (f-h 0) (f-s 1) (f-bit9 1) ro rb rd)
+      (set rd (ext SI (mem QI (add rb ro))))
+)
+(dnti ldsh "load sign extended halfword"
+      ()
+      "ldsh $rd,[$rb,$ro]"
+      (+ (f-op4 5) (f-h 1) (f-s 1) (f-bit9 1) ro rb rd)
+      (set rd (ext SI (mem HI (add rb ro))))
+)
+\f
+; Load/store with immediate offset.
+
+(dntf f-b-imm "byte/word indicator in load/store with immediate offset insns" () 12 1)
+
+(df f-offset5-7 "offset5 field as 7 bit unsigned immediate"
+    ((ISA thumb))
+    10 5 UINT
+    ((value pc) (srl WI value (const 2)))
+    ((value pc) (sll WI value (const 2)))
+)
+
+(dntop offset5-7 "offset5 as 7 bit unsigned immediate" () h-uint f-offset5-7)
+
+(dnti str-imm "store word with immediate offset"
+      ()
+      "str $rd,[$rb,#${offset5-7}]"
+      (+ (f-op3 3) (f-b-imm 0) (f-l 0) offset5-7 rb rd)
+      (set (mem WI (add rb offset5-7)) rd)
+)
+(dnti ldr-imm "load word with immediate offset"
+      ()
+      "ldr $rd,[$rb,#${offset5-7}]"
+      (+ (f-op3 3) (f-b-imm 0) (f-l 1) offset5-7 rb rd)
+      (set rd (mem WI (add rb offset5-7)))
+)
+(dnti strb-imm "store byte with immediate offset"
+      ()
+      "strb $rd,[$rb,#$offset5]"
+      (+ (f-op3 3) (f-b-imm 1) (f-l 0) offset5 rb rd)
+      (set (mem QI (add rb offset5)) rd)
+)
+(dnti ldrb-imm "load zero extended byte with immediate offset"
+      ()
+      "ldrb $rd,[$rb,#$offset5]"
+      (+ (f-op3 3) (f-b-imm 1) (f-l 1) offset5 rb rd)
+      (set rd (zext SI (mem QI (add rb offset5))))
+)
+\f
+; Load/store halfword with immediate offset.
+
+(df f-offset5-6 "offset5 field as 6 bit unsigned immediate"
+    ((ISA thumb))
+    10 5 UINT
+    ((value pc) (srl WI value (const 1)))
+    ((value pc) (sll WI value (const 1)))
+)
+
+(dntop offset5-6 "offset5 as 7 bit unsigned immediate" () h-uint f-offset5-6)
+
+(dnti strh-imm "store halfword with immediate offset"
+      ()
+      "strh $rd,[$rb,#${offset5-6}]"
+      (+ (f-op4 8) (f-l 0) offset5-6 rb rd)
+      (set (mem HI (add rb offset5-6)) rd)
+)
+(dnti ldrh-imm "load zero extended halfword with immediate offset"
+      ()
+      "ldrh $rd,[$rb,#${offset5-6}]"
+      (+ (f-op4 8) (f-l 1) offset5-6 rb rd)
+      (set rd (zext WI (mem HI (add rb offset5-6))))
+)
+\f
+; SP-relative load/store
+
+(dnti str-sprel "store word, sp-relative"
+      ()
+      "str ${bit10-rd},[sp,#$word8]"
+      (+ (f-op4 9) (f-l 0) bit10-rd word8)
+      (set (mem WI (add sp word8)) bit10-rd)
+)
+(dnti ldr-sprel "load word, sp-relative"
+      ()
+      "ldr ${bit10-rd},[sp,#$word8]"
+      (+ (f-op4 9) (f-l 1) bit10-rd word8)
+      (set bit10-rd (mem WI (add sp word8)))
+)
+\f
+; Load address
+
+(dntf f-sp "sp/pc indicator" () 11 1)
+
+(dnti lda-pc "load address from pc"
+      ()
+      "add ${bit10-rd},pc,$word8"
+      (+ (f-op4 10) (f-sp 0) bit10-rd word8)
+      (set bit10-rd (add (and (add pc (const 4)) (const WI -4)) word8))
+)
+(dnti lda-sp "load address from sp"
+      ()
+      "add ${bit10-rd},sp,$word8"
+      (+ (f-op4 10) (f-sp 1) bit10-rd word8)
+      (set bit10-rd (add sp word8))
+)
+\f
+; Add offset to stack pointer.
+; FIXME: Handling of sign+magnitude needs revisiting.
+; If expressions are allowed here we can't assume "-" follows "#".
+
+(dntf f-addoff-s "s bit in add offset to sp insns" () 7 1)
+
+(df f-sword7 "7 bit magnitude, accompanies sign bit"
+    ((ISA thumb))
+    6 7 UINT
+    ((value pc) (srl WI value (const 2)))
+    ((value pc) (sll WI value (const 2)))
+)
+
+(dntop sword7 "7 bit magnitude, accompanies sign bit" () h-uint f-sword7)
+
+(dnti add-sp "add offset to sp"
+      ()
+      "add sp,#$sword7"
+      (+ (f-op8 #xb0) (f-addoff-s 0) sword7)
+      (set sp (add sp sword7))
+)
+(dnti sub-sp "subtract offset from sp"
+      ()
+      "add sp,#-$sword7"
+      (+ (f-op8 #xb0) (f-addoff-s 1) sword7)
+      (set sp (sub sp sword7))
+)
+\f
+; Push/pop registers.
+
+; FIXME: Might be better to use sequence temp as address reg.
+
+(define-pmacro (push-reg regno)
+  (if (and rlist (sll 1 regno))
+      (sequence ()
+               (set sp (sub sp 4))
+               (set (mem WI sp) (reg WI h-gr-t regno))
+               ))
+)
+(define-pmacro (pop-reg regno)
+  (if (and rlist (sll 1 regno))
+      (sequence ()
+               (set (reg WI h-gr-t regno) (mem WI sp))
+               (set sp (add sp 4))
+               ))
+)
+
+(dntf f-pushpop-op "opcode bits 10,9 in push/pop insns" () 10 2)
+
+(dntf f-r "register indicator in push/pop insns" () 8 1)
+
+(dntf f-rlist "register list" () 7 8)
+
+; ??? Print/parse handler specs missing.  Later.
+(dntop rlist "register list" () h-uint f-rlist)
+(dntop rlist-lr "register list with lr" () h-uint f-rlist)
+(dntop rlist-pc "register list with pc" () h-uint f-rlist)
+
+(dnti push "push registers"
+      ()
+      "push {$rlist}"
+      (+ (f-op4 11) (f-l 0) (f-pushpop-op 2) (f-r 0) rlist)
+      (.splice sequence () (.unsplice (.map push-reg (.iota 8 7 -1))))
+)
+(dnti push-lr "push registers and lr"
+      ()
+      "push {${rlist-lr}}"
+      (+ (f-op4 11) (f-l 0) (f-pushpop-op 2) (f-r 1) rlist)
+      (.splice sequence ()
+              (set sp (sub sp 4))
+              (set (mem WI sp) lr)
+              (.unsplice (.map push-reg (.iota 8 7 -1)))
+              )
+)
+
+(dnti pop "pop registers"
+      ()
+      "pop {$rlist}"
+      (+ (f-op4 11) (f-l 1) (f-pushpop-op 2) (f-r 0) rlist)
+      (.splice sequence () (.unsplice (.map pop-reg (.iota 8))))
+)
+(dnti pop-pc "pop registers and pc"
+      ()
+      "pop {${rlist-pc}}"
+      (+ (f-op4 11) (f-l 1) (f-pushpop-op 2) (f-r 1) rlist)
+      (.splice sequence ()
+              (.unsplice (.map pop-reg (.iota 8)))
+              (set pc (mem WI sp))
+              (set sp (add sp 4))
+              )
+)
+\f
+; Multiple load/store.
+
+; FIXME: Might be better to use sequence temp as address reg.
+
+(dntf f-bit10-rb "Rb at bit 10" () 10 3)
+
+(dntop bit10-rb "base reg at bit 10" () h-gr-t f-bit10-rb)
+
+(define-pmacro (save-reg-inc regno)
+  (if (and rlist (sll 1 regno))
+      (sequence ()
+               (set (mem WI bit10-rb) (reg WI h-gr-t regno))
+               (set bit10-rb (add bit10-rb 4))
+               ))
+)
+(define-pmacro (load-reg-inc regno)
+  (if (and rlist (sll 1 regno))
+      (sequence ()
+               (set (reg WI h-gr-t regno) (mem WI bit10-rb))
+               (set bit10-rb (add bit10-rb 4))
+               ))
+)
+
+(dnti stmia "store multiple"
+      ()
+      "stmia $rb!,{$rlist}"
+      (+ (f-op4 12) (f-l 0) bit10-rb rlist)
+      (.splice sequence () (.unsplice (.map save-reg-inc (.iota 8))))
+)
+(dnti ldmia "load multiple"
+      ()
+      "ldmia $rb!,{$rlist}"
+      (+ (f-op4 12) (f-l 1) bit10-rb rlist)
+      (.splice sequence () (.unsplice (.map load-reg-inc (.iota 8))))
+)
+\f
+; Conditional branches.
+
+(dntf f-cond "condition code spec" () 11 4)
+
+; The standard condition code tests.
+
+(define-normal-insn-enum cc-tests
+  "condition code tests"
+  () "" f-cond
+  (
+   (CC_EQ 0)   ; equal
+   (CC_NE 1)   ; not equal
+   (CC_CS 2)   ; carry set (unsigned greater or equal)
+   (CC_CC 3)   ; carry clear (unsigned less than)
+   (CC_MI 4)   ; minus (negative)
+   (CC_PL 5)   ; positive or zero
+   (CC_VS 6)   ; overflow set
+   (CC_VC 7)   ; overflow clear
+   (CC_HI 8)   ; higher (unsigned greater)
+   (CC_LS 9)   ; less or same (unsigned less or equal)
+   (CC_GE 10)  ; greater or equal
+   (CC_LT 11)  ; less
+   (CC_GT 12)  ; greater
+   (CC_LE 13)  ; less or equal
+   )
+)
+
+(df  f-soffset8 "8 bit pc relative branch address"
+     (PCREL-ADDR (ISA thumb))
+     7 8 INT
+     ((value pc) (sra WI (sub WI value (add WI pc (const 4))) (const 1)))
+     ((value pc) (add WI (sll WI value (const 1)) (add WI pc (const 4))))
+)
+
+(dntop soffset8 "8 bit pc relative branch address" () h-iaddr f-soffset8)
+
+(define-pmacro (cbranch bname comment cond test)
+  (dnti bname (.str "branch if " comment)
+       ()
+       (.str bname " $soffset8")
+       (+ (f-op4 13) cond soffset8)
+       (if (test)
+           (set pc soffset8))
+       )
+)
+(cbranch beq  "eq"                    CC_EQ test-eq)
+(cbranch bne  "ne"                    CC_NE test-ne)
+(cbranch bcs  "cs (ltu)"              CC_CS test-cs)
+(cbranch bcc  "cc (geu)"              CC_CC test-cc)
+(cbranch bmi  "mi (negative)"         CC_MI test-mi)
+(cbranch bpl  "pl (positive or zero)" CC_PL test-pl)
+(cbranch bvs  "vs (overflow set)"     CC_VS test-vs)
+(cbranch bvc  "vc (overflow clear)"   CC_VC test-vc)
+(cbranch bhi  "hi (gtu)"              CC_HI test-hi)
+(cbranch bls  "ls (leu)"              CC_LS test-ls)
+(cbranch bge  "ge"                    CC_GE test-ge)
+(cbranch blt  "lt"                    CC_LT test-lt)
+(cbranch bgt  "gt"                    CC_GT test-gt)
+(cbranch ble  "le"                    CC_LE test-le)
+\f
+; Software interrupt.
+
+(dntf f-value8 "8 bit value for swi" () 7 8)
+
+(dntop value8 "8 bit value for swi" () h-uint f-value8)
+
+(dnti swi "software interrupt"
+      ()
+      "swi $value8"
+      (+ (f-op8 #xdf) value8)
+      ; FIXME: for now
+      (set pc (c-call WI "thumb_swi" pc value8))
+)
+\f
+; Unconditional branch.
+
+(df f-offset11 "11 bit pc relative branch address"
+    (PCREL-ADDR (ISA thumb))
+    10 11 INT
+    ((value pc) (sra WI (sub value (add pc (const 4))) (const 1)))
+    ((value pc) (add WI (sll value (const 1)) (add pc (const 4))))
+)
+
+(dntop offset11 "11 bit pc relative branch address" () h-iaddr f-offset11)
+
+(dnti b "unconditional branch"
+      ()
+      "b $offset11"
+      (+ (f-op5 #x1c) offset11)
+      (set pc offset11)
+)
+\f
+; Long branch with link.
+; Two instructions that make up a subroutine call.
+; FIXME: Assembler access is via one insn - macro-insn?
+; Left for later, as is all assembly considerations.
+
+(dntf f-lbwl-h "long branch with link `h' field"   () 11 1)
+
+; This one is signed.
+(define-ifield
+  (name f-lbwl-hi)
+  (comment "long branch with link offset, high part")
+  (attrs (ISA thumb))
+  (mode INT)
+  (start 10)
+  (length 11)
+)
+(dntop lbwl-hi "long branch with link offset, high part" ()
+       h-sint f-lbwl-hi)
+
+; This one is unsigned.
+(dntf f-lbwl-lo "long branch with link offset, low part" () 10 11)
+(dntop lbwl-lo "long branch with link offset, low part" ()
+       h-uint f-lbwl-lo)
+
+(dnti bl-hi "branch link, high offset"
+      ()
+      "bl-hi ${lbwl-hi}"
+      (+ (f-op4 15) (f-lbwl-h 0) lbwl-hi)
+      (set lr (add (add pc 4) (sll lbwl-hi 12)))
+)
+
+(dnti bl-lo "branch link, low offset"
+      ()
+      "bl-lo ${lbwl-lo}"
+      (+ (f-op4 15) (f-lbwl-h 1) lbwl-lo)
+      (sequence ((WI cur-pc))
+               (set cur-pc pc)
+               (set pc (add lr (sll lbwl-lo 1)))
+               (set lr (or (add cur-pc 2) 1)))
+)
diff --git a/cgen/types.scm b/cgen/types.scm
new file mode 100644 (file)
index 0000000..dec4142
--- /dev/null
@@ -0,0 +1,278 @@
+; Type system.
+; This provides the low level classes for describing data, except for
+; the actual type (confusingly enough) which is described in mode.scm.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; Array type.
+; DIMENSIONS has a suitable initial value so (new <scalar>) to works.
+
+(define <array> (class-make '<array> nil '(mode (dimensions . ())) nil))
+
+; Return number of elements in array.
+
+(method-make!
+ <array> 'get-num-elms
+ (lambda (self)
+   (apply * (elm-get self 'dimensions)))
+)
+
+; Return mode of the array.
+
+(method-make! <array> 'get-mode (lambda (self) (elm-get self 'mode)))
+
+; Return the rank of the array (number of dimensions).
+
+(method-make! <array> 'get-rank (lambda (self) (length (elm-get self 'dimensions)))
+)
+
+; Return shape of array
+
+(method-make! <array> 'get-shape (lambda (self) (elm-get self 'dimensions))
+)
+
+; Return #t if X is an array.
+
+(define (array? x) (class-instance? <array> x))
+
+; Scalar type.
+
+(define <scalar> (class-make '<scalar> '(<array>) nil nil))
+
+(method-make-make! <scalar> '(mode))
+
+; Return #t if X is a scalar.
+
+(define (scalar? x) (and (array? x) (= (send x 'get-rank) 0)))
+
+; Return number of bits in an element of TYPE.
+
+(define (type-bits type)
+  (mode:bits (send type 'get-mode))
+)
+\f
+; Integers.
+; These are like scalars but are specified in bits.
+; BITS is the size in bits.
+; ATTRS contains !UNSIGNED [or nothing] or UNSIGNED.
+;
+; A mode is needed so we know how big a field is needed to record the value.
+; It might be more appropriate to use a host mode though.
+;
+; FIXME: Need to separate rank from type.  scalar/array are not types.
+;
+;(define <integer> (class-make '<integer> nil '(attrs bits) nil))
+;
+;(method-make! <integer> 'get-atlist (lambda (self) (elm-get self 'attrs)))
+;
+;(method-make!
+; <integer> 'get-mode 
+; (lambda (self)
+;   (mode-find (elm-get self 'bits)
+;            (if (has-attr? self 'UNSIGNED) 'UINT 'INT))
+;   )
+;)
+;
+; FIXME: Quick hack.  Revisit.
+;
+;(method-make! <integer> 'get-rank (lambda (self) 0))
+
+; Structures.
+; FIXME: Unfinished.
+
+(define <struct> (class-make '<struct> nil '(members) nil))
+
+; Parse a type spec.
+; TYPE-SPEC is: (mode [(dimensions ...)])
+;           or: ((mode bits) [(dimensions ...)])
+
+(define (parse-type errtxt type-spec)
+  ; Preliminary error checking.
+  (if (and (list? (car type-spec))
+          (not (= (length (car type-spec)) 2)))
+      (parse-error errtxt "invalid type spec" type-spec))
+
+  ; Pick out the arguments.
+  (let ((mode (if (list? (car type-spec)) (caar type-spec) (car type-spec)))
+       (bits (if (list? (car type-spec)) (cadar type-spec) #f))
+       (dims (if (> (length type-spec) 1) (cadr type-spec) nil)))
+
+    ; FIXME: Need more error checking here.
+    ; Validate the mode and bits.
+    (let ((mode-obj
+          (case mode
+            ((INT)
+             (if (integer? bits)
+                 (mode-make-int bits)
+                 (parse-error errtxt "invalid number of bits" bits)))
+            ((UINT)
+             (if (integer? bits)
+                 (mode-make-uint bits)
+                 (parse-error errtxt "invalid number of bits" bits)))
+            ((BI QI HI SI DI WI UQI UHI USI UDI UWI SF DF XF TF)
+             (let ((x (parse-mode-name mode errtxt)))
+               (if (and bits (not (= bits (mode:bits x))))
+                   (parse-error errtxt "wrong number of bits for mode" bits))
+               x))
+            (else (parse-error errtxt "unknown/unsupported mode" mode)))))
+
+      ; Validate the dimension spec.
+      (if (or (not (list? dims))
+             (not (all-true? (map integer? dims))))
+         (parse-error errtxt "invalid dimension spec" dims))
+
+      ; All done, create the <array> object.
+      ; ??? Special casing scalars is a concession for apps that think
+      ; scalars aren't arrays.  Not sure it should stay.
+      (if (null? dims)
+         (make <scalar> mode-obj)
+         (make <array> mode-obj dims))))
+)
+\f
+; Bit ranges.
+; ??? Perhaps this should live in a different source file, but for now
+; it's here.
+;
+; Endianness is not recorded with the bitrange.
+; Values are operated on a "word" at a time.
+; This is to handle bi-endian systems: we don't want two copies of
+; every bitrange.
+;
+; Instruction word sizes are based on the "base insn length" which is the
+; number of bytes the cpu first looks at to decode an insn.  In cases where
+; the total length is longer than the base insn length, the word length
+; for the rest of the insn is the base insn length replicated as many times
+; as necessary.  The trailing part [last few bytes] of the insn may not fill
+; the entire word, in which case the numbering is adjusted for it.
+; ??? Might need to have an insn-base-length and an insn-word-length.
+;
+; Instructions that have words of one endianness and sub-words of a different
+; endianness are handled at a higher level.
+;
+; Bit numbering examples:
+; [each byte is represented MSB to LSB, low address to high address]
+;
+; lsb0? = #f
+; insn-word-length = 2
+; endian = little
+; | 8 ... 15 | 0 ... 7 | 24 ... 31 | 16 ... 23 | 40 ... 47 | 32 ... 39 |
+;
+; lsb0? = #t
+; insn-word-length = 2
+; endian = little
+; [note that this is the little endian canonical form
+;  - word length is irrelevant]
+; | 7 ... 0 | 15 ... 8 | 23 ... 16 | 31 ... 24 | 39 ... 32 | 47 ... 40 |
+;
+; lsb0? = #f
+; insn-word-length = 2
+; endian = big
+; [note that this is the big endian canonical form
+;  - word length is irrelevant]
+; | 0 ... 7 | 8 ... 15 | 16 ... 23 | 24 ... 31 | 32 ... 39 | 40 ... 47 |
+;
+; lsb0? = #t
+; insn-word-length = 2
+; endian = big
+; | 15 ... 8 | 7 ... 0 | 31 ... 24 | 23 ... 16 | 47 ... 40 | 39 ... 32 |
+;
+; While there are no current examples, the intent is to not preclude
+; situations where each "word" in an insn isn't the same size.  For example a
+; 48 bit insn with a 16 bit opcode and a 32 bit immediate value might [but not
+; necessarily] consist of one 16 bit "word" and one 32 bit "word".
+; Bitranges support this situation, however none of the rest of the code does.
+;
+; Examples:
+;
+; lsb0? = #f
+; insn-word-length = 2, 4
+; endian = little
+; | 8 ... 15 | 0 ... 7 | 40 ... 47 | 32 ... 39 | 24 ... 31 | 16 ... 23 |
+;
+; lsb0? = #t
+; insn-word-length = 2, 4
+; endian = little
+; | 7 ... 0 | 15 ... 8 | 23 ... 16 | 31 ... 24 | 39 ... 32 | 47 ... 40 |
+;
+; lsb0? = #f
+; insn-word-length = 2, 4
+; endian = big
+; | 0 ... 7 | 8 ... 15 | 16 ... 23 | 24 ... 31 | 32 ... 39 | 40 ... 47 |
+;
+; lsb0? = #t
+; insn-word-length = 2, 4
+; endian = big
+; | 15 ... 8 | 7 ... 0 | 47 ... 40 | 39 ... 32 | 31 ... 24 | 23 ... 16 |
+
+(define <bitrange>
+  (class-make '<bitrange>
+             nil
+             '(
+               ; offset in bits from the start of the insn of the word
+               ; in which the value resides [must be divisible by 8]
+               ; [this allows the bitrange to be independent of the lengths
+               ; of words preceding this one]
+               word-offset
+               ; starting bit number within the word
+               ; [externally, = word-offset + start]
+               start
+               ; number of bits in the value
+               length
+               ; length of word in which the value resides
+               word-length
+               ; lsb = bit number 0?
+               lsb0?
+               )
+             nil)
+)
+
+; Accessor fns.
+
+(define-getters <bitrange> bitrange
+  (word-offset start length word-length lsb0?)
+)
+
+(define-setters <bitrange> bitrange
+  ; lsb0? left out on purpose: not sure changing it should be allowed
+  (word-offset start length word-length)
+)
+
+; Return a boolean indicating if two bitranges overlap.
+
+(define (bitrange-overlap? start1 length1 start2 length2 lsb0?)
+  ; ??? lsb0?
+  (let ((end1 (+ start1 length1))
+       (end2 (+ start2 length2)))
+    (not (or (<= end1 start2)
+            (>= start1 end2))))
+)
+
+; Return a boolean indicating if BITPOS is beyond bitrange START,LEN.
+; ??? This needs more thought.
+
+(define (bitpos-beyond? bitpos start length word-length lsb0?)
+  (>= bitpos (+ start length))
+)
+
+; Return the offset of the word after <bitrange> br.
+
+(define (bitrange-next-word br)
+  (let ((word-offset (bitrange-word-offset br))
+       (start (bitrange-start br))
+       (length (bitrange-length br))
+       (word-length (bitrange-word-length br))
+       (lsb0? (bitrange-lsb0? br)))
+    ; ??? revisit
+    (+ word-offset word-length))
+)
+\f
+; Initialize/finalize support.
+
+(define (types-init!)
+  *UNSPECIFIED*
+)
+
+(define (types-finish!)
+  *UNSPECIFIED*
+)
diff --git a/cgen/utils-cgen.scm b/cgen/utils-cgen.scm
new file mode 100644 (file)
index 0000000..5d3f24c
--- /dev/null
@@ -0,0 +1,654 @@
+; CGEN Utilities.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+;
+; This file contains utilities specific to cgen.
+; Generic utilities should go in utils.scm.
+
+; True if text of sanitize markers are to be emitted.
+; This is a debugging tool only, though it could have use in sanitized trees.
+(define include-sanitize-marker? #t)
+
+; Utility to display command line invocation for debugging purposes.
+
+(define (display-argv argv)
+  (let ((cep (current-error-port)))
+    (display "cgen -s " cep)
+    (for-each (lambda (arg)
+               ; Output double-quotes if string has a space for better
+               ; correspondence to how to specify string to shell.
+               (if (string-index arg #\space)
+                   (write arg cep)
+                   (display arg cep))
+               (display " " cep))
+             argv)
+    (newline cep))
+)
+\f
+; COS utilities.
+; Perhaps these should be provided with cos (cgen-object-system), but for
+; now they live here.
+
+; Define the getter for a list of elements of a class.
+
+(defmacro define-getters (class class-prefix elm-names)
+  (cons 'begin
+       (map (lambda (elm-name)
+              (if (pair? elm-name)
+                  `(define ,(symbol-append class-prefix '- (cdr elm-name))
+                     (elm-make-getter ,class (quote ,(car elm-name))))
+                  `(define ,(symbol-append class-prefix '- elm-name)
+                     (elm-make-getter ,class (quote ,elm-name)))))
+            elm-names))
+)
+
+; Define the setter for a list of elements of a class.
+
+(defmacro define-setters (class class-prefix elm-names)
+  (cons 'begin
+       (map (lambda (elm-name)
+              (if (pair? elm-name)
+                  `(define ,(symbol-append class-prefix '-set- (cdr elm-name) '!)
+                     (elm-make-setter ,class (quote ,(car elm-name))))
+                  `(define ,(symbol-append class-prefix '-set- elm-name '!)
+                     (elm-make-setter ,class (quote ,elm-name)))))
+            elm-names))
+)
+
+; Make an object, specifying values for particular elements.
+; ??? Eventually move to cos.scm/cos.c.
+
+(define (vmake class . args)
+  (let ((obj (new class)))
+    (let ((unrecognized (send obj 'vmake! args)))
+      (if (null? unrecognized)
+         obj
+         (error "vmake: unknown options:" unrecognized))))
+)
+\f
+; Each named entry in the description file typically has these three members:
+; name, comment attrs.
+
+(define <ident> (class-make '<ident> () '(name comment attrs) ()))
+
+(method-make! <ident> 'get-name (lambda (self) (elm-get self 'name)))
+(method-make! <ident> 'get-comment (lambda (self) (elm-get self 'comment)))
+(method-make! <ident> 'get-atlist (lambda (self) (elm-get self 'attrs)))
+
+(method-make! <ident> 'set-name!
+             (lambda (self newval) (elm-set! self 'name newval)))
+(method-make! <ident> 'set-comment!
+             (lambda (self newval) (elm-set! self 'comment newval)))
+(method-make! <ident> 'set-atlist!
+             (lambda (self newval) (elm-set! self 'attrs newval)))
+
+; All objects defined in the .cpu file have these elements.
+; Where in the class hierarchy they're recorded depends on the object.
+; Additionally most objects have `name', `comment' and `attrs' elements.
+
+(define (obj:name obj) (send obj 'get-name))
+(define (obj-set-name! obj name) (send obj 'set-name! name))
+(define (obj:comment obj) (send obj 'get-comment))
+
+; Utility to add standard access methods for name, comment, attrs.
+; ??? Old.  Using <ident> baseclass now.
+
+(define (add-ident-methods! class)
+  (method-make! class 'get-name (lambda (self) (elm-get self 'name)))
+  (method-make! class 'set-name! (lambda (self name) (elm-set! self 'name name)))
+
+  (method-make! class 'get-comment (lambda (self) (elm-get self 'comment)))
+  (method-make! class 'set-comment! (lambda (self comment) (elm-set! self 'comment comment)))
+
+  (method-make! class 'get-atlist (lambda (self) (elm-get self 'attrs)))
+  (method-make! class 'set-atlist! (lambda (self attrs) (elm-set! self 'attrs attrs)))
+
+  *UNSPECIFIED*
+)
+\f
+; Parsing utilities
+
+; Parsing context, used to give better error messages.
+
+(define <context>
+  (class-make '<context> nil
+             '(
+               ; Name of file containing object being processed.
+               (file . #f)
+               ; Line number in the file.
+               (lineno . #f)
+               ; Error message prefix
+               (prefix . "")
+               )
+             nil)
+)
+
+; Accessors.
+
+(define-getters <context> context (file lineno prefix))
+
+; Create a <context> object that is just a prefix.
+
+(define (context-make-prefix prefix)
+  (make <context> #f #f prefix)
+)
+
+; Create a <context> object for the reader.
+; This sets file,lineno from (current-input-port).
+
+(define (context-make-reader prefix)
+  (make <context>
+    (or (port-filename (current-input-port))
+       "<input>")
+    (port-line (current-input-port))
+    prefix)
+)
+
+; Call this to issue an error message.
+; CONTEXT is a <context> object or #f if there is none.
+; ARG is the value that had the error if there is one.
+
+(define (context-error context errmsg . arg)
+  (cond ((and context (context-file context))
+        (let ((msg (string-append
+                    (context-file context) ":"
+                    (number->string (context-lineno context)) ": "
+                    (context-prefix context) ": "
+                    errmsg ": ")))
+          (apply error (cons msg arg))))
+       (context (let ((msg (string-append (context-prefix context) ": "
+                                          errmsg ": ")))
+                  (apply error (cons msg arg))))
+       (else (apply error (cons (string-append errmsg ": ") arg))))
+)
+
+; Parse an object name.
+; NAME is either a symbol or a list of symbols which are concatenated
+; together.  Each element can in turn be a list of symbols, and so on.
+; This supports symbol concatenation in the description file without having
+; to using string-append or some such.
+; FIXME: Isn't the plan to move ERRTXT to the 1st arg?
+
+(define (parse-name name errtxt)
+  (cond ((list? name)
+        (string->symbol (string-map (lambda (elm) (parse-name elm errtxt)) name)))
+       ((symbol? name) name)
+       ((string? name) (string->symbol name))
+       (else (parse-error errtxt "improper name" name)))
+)
+
+; Parse an object comment.
+; COMMENT is either a string or a list of strings, each element of which may
+; in turn be a list of strings.
+; FIXME: Isn't the plan to move ERRTXT to the 1st arg?
+
+(define (parse-comment comment errtxt)
+  (cond ((list? comment)
+        (string-map (lambda (elm) (parse-comment elm errtxt)) comment))
+       ((or (string? comment) (symbol? comment))
+        comment)
+       (else (parse-error errtxt "improper comment" comment)))
+)
+
+; Parse a symbol.
+
+(define (parse-symbol context value)
+  (if (and (not (symbol? value)) (not (string? value)))
+      (parse-error context "not a symbol" value))
+  value
+)
+
+; Parse a string.
+
+(define (parse-string context value)
+  (if (and (not (symbol? value)) (not (string? value)))
+      (parse-error context "not a string" value))
+  value
+)
+
+; Parse a number.
+; VALID-VALUES is a list of numbers and (min . max) pairs.
+
+(define (parse-number errtxt value . valid-values)
+  (if (not (number? value))
+      (parse-error errtxt "not a number" value))
+  (if (any-true? (map (lambda (test)
+                       (if (pair? test)
+                           (and (>= value (car test))
+                                (<= value (cdr test)))
+                           (= value test)))
+                     valid-values))
+      value
+      (parse-error errtxt "invalid number" value valid-values))
+)
+
+; Parse a boolean value
+
+(define (parse-boolean context value)
+  (if (boolean? value)
+      value
+      (parse-error context "not a boolean (#f/#t)" value))
+)
+
+; Parse a list of handlers.
+; Each entry is (symbol "string").
+; These map function to a handler for it.
+; The meaning is up to the application but generally the handler is a
+; C/C++ function name.
+; ALLOWED is a list valid values for the symbol or #f if anything is allowed.
+; The result is handlers unchanged.
+
+(define (parse-handlers context allowed handlers)
+  (if (not (list? handlers))
+      (parse-error context "bad handler spec" handlers))
+  (for-each (lambda (arg)
+             (if (not (list-elements-ok? arg (list symbol? string?)))
+                 (parse-error context "bad handler spec" arg))
+             (if (and allowed (not (memq (car arg) allowed)))
+                 (parse-error context "unknown handler type" (car arg))))
+           handlers)
+  handlers
+)
+
+; Return a boolean indicating if X is a keyword.
+; This also handles symbols named :foo because Guile doesn't stablely support
+; :keywords (how does one enable :keywords? read-options doesn't appear to
+; work).
+
+(define (keyword-list? x)
+  (and (list? x)
+       (not (null? x))
+       (or (keyword? (car x))
+          (and (symbol? (car x))
+               (char=? (string-ref (car x) 0) #\:))))
+)
+
+; Convert a list like (#:key1 val1 #:key2 val2 ...) to
+; ((#:key1 val1) (#:key2 val2) ...).
+; Missing values are specified with an empty list.
+; This also supports (:sym1 val1 ...) because Guile doesn't stablely support
+; :keywords (#:keywords work, but #:foo shouldn't appear in the description
+; language).
+
+(define (keyword-list->arg-list kl)
+  ; Scan KL backwards, building up each element as we go.
+  (let loop ((result nil) (current nil) (rkl (reverse kl)))
+    (cond ((null? rkl)
+          result)
+         ((keyword? (car rkl))
+          (loop (acons (keyword->symbol (car rkl)) current result)
+                nil
+                (cdr rkl)))
+         ((and (symbol? (car rkl))
+               (char=? (string-ref (car rkl) 0) #\:))
+          (loop (acons (string->symbol
+                        (substring (car rkl) 1 (string-length (car rkl))))
+                       current result)
+                nil
+                (cdr rkl)))
+         (else
+          (loop result
+                (cons (car rkl) current)
+                (cdr rkl)))))
+)
+
+; Signal an error if the argument name is not a symbol.
+; This is done by each of the argument validation routines so the caller
+; doesn't need to make two calls.
+
+(define (arg-list-validate-name errtxt arg-spec)
+  (if (null? arg-spec)
+      (parse-error errtxt "empty argument spec"))
+  (if (not (symbol? (car arg-spec)))
+      (parse-error errtxt "argument name not a symbol" arg-spec))
+  *UNSPECIFIED*
+)
+
+; Signal a parse error if an argument was specified with a value.
+; ARG-SPEC is (name value).
+
+(define (arg-list-check-no-args errtxt arg-spec)
+  (arg-list-validate-name errtxt arg-spec)
+  (if (not (null? (cdr arg-spec)))
+      (parse-error errtxt (string-append (car arg-spec)
+                                        " takes zero arguments")))
+  *UNSPECIFIED*
+)
+
+; Validate and return a symbol argument.
+; ARG-SPEC is (name value).
+
+(define (arg-list-symbol-arg errtxt arg-spec)
+  (arg-list-validate-name errtxt arg-spec)
+  (if (or (!= (length (cdr arg-spec)) 1)
+         (not (symbol? (cadr arg-spec))))
+      (parse-error errtxt (string-append (car arg-spec)
+                                        ": argument not a symbol")))
+  (cadr arg-spec)
+)
+\f
+; Sanitization
+
+; Sanitization is handled via attributes.  Anything that must be sanitized
+; has a `sanitize' attribute with the value being the keyword to sanitize on.
+; Ideally most, if not all, of the guts of the generated sanitization is here.
+
+; Utility to simplify expression in .cpu file.
+; Usage: (sanitize keyword entry-type entry-name1 [entry-name2 ...])
+; Enum attribute `(sanitize keyword)' is added to the entry.
+; It's written this way so Hobbit can handle it.
+
+(define (sanitize keyword entry-type . entry-names)
+  (for-each (lambda (entry-name)
+             (let ((entry #f))
+               (case entry-type
+                 ((attr) (set! entry (current-attr-lookup entry-name)))
+                 ((enum) (set! entry (current-enum-lookup entry-name)))
+                 ((isa) (set! entry (current-isa-lookup entry-name)))
+                 ((cpu) (set! entry (current-cpu-lookup entry-name)))
+                 ((mach) (set! entry (current-mach-lookup entry-name)))
+                 ((model) (set! entry (current-model-lookup entry-name)))
+                 ((ifield) (set! entry (current-ifld-lookup entry-name)))
+                 ((hardware) (set! entry (current-hw-lookup entry-name)))
+                 ((operand) (set! entry (current-op-lookup entry-name)))
+                 ((insn) (set! entry (current-insn-lookup entry-name)))
+                 ((macro-insn) (set! entry (current-minsn-lookup entry-name)))
+                 (else (parse-error "sanitize" "unknown entry type" entry-type)))
+
+               ; ENTRY is #f in the case where the element was discarded
+               ; because its mach wasn't selected.  But in the case where
+               ; we're keeping everything, ensure ENTRY is not #f to
+               ; catch spelling errors.
+
+               (if entry
+
+                   (begin
+                     (obj-cons-attr! entry (enum-attr-make 'sanitize keyword))
+                     ; Propagate the sanitize attribute to class members
+                     ; as necessary.
+                     (case entry-type
+                       ((hardware)
+                        (if (hw-indices entry)
+                            (obj-cons-attr! (hw-indices entry)
+                                            (enum-attr-make 'sanitize
+                                                            keyword)))
+                        (if (hw-values entry)
+                            (obj-cons-attr! (hw-values entry)
+                                            (enum-attr-make 'sanitize
+                                                            keyword))))
+                       ))
+
+                   (if (and (eq? APPLICATION 'OPCODES) (keep-all?))
+                       (parse-error "sanitize"
+                                    (string-append "unknown " entry-type)
+                                    entry-name)))))
+           entry-names)
+
+  #f ; caller eval's our result, so return a no-op
+)
+
+; Return TEXT sanitized with KEYWORD.
+; TEXT must exist on a line (or lines) by itself.
+; i.e. it is assumed that it begins at column 1 and ends with a newline.
+; If KEYWORD is #f, no sanitization is generated.
+
+(define (gen-sanitize keyword text)
+  (cond ((null? text) "")
+       ((pair? text) ; pair? -> cheap list?
+        (if (and keyword include-sanitize-marker?)
+            (string-list
+             ; split string to avoid removal
+             "/* start-"
+             "sanitize-" keyword " */\n"
+             text
+             "/* end-"
+             "sanitize-" keyword " */\n")
+            text))
+       (else
+        (if (= (string-length text) 0)
+            ""
+            (if (and keyword include-sanitize-marker?)
+                (string-append
+                 ; split string to avoid removal
+                 "/* start-"
+                 "sanitize-" keyword " */\n"
+                 text
+                 "/* end-"
+                 "sanitize-" keyword " */\n")
+                text))))
+)
+
+; Return TEXT sanitized with OBJ's sanitization, if it has any.
+; OBJ may be #f.
+
+(define (gen-obj-sanitize obj text)
+  (if obj
+      (let ((san (obj-attr-value obj 'sanitize)))
+       (gen-sanitize (if (or (not san) (eq? san 'none)) #f san)
+                     text))
+      (gen-sanitize #f text))
+)
+\f
+; Cover procs to handle generation of object declarations and definitions.
+; All object output should be routed through gen-decl and gen-defn.
+
+; Send the gen-decl message to OBJ, and sanitize the output if necessary.
+
+(define (gen-decl obj)
+  (logit 3 "Generating decl for "
+        (cond ((method-present? obj 'get-name) (send obj 'get-name))
+              ((elm-present? obj 'name) (elm-get obj 'name))
+              (else "unknown"))
+        " ...\n")
+  (cond ((and (method-present? obj 'gen-decl) (not (has-attr? obj 'META)))
+        (gen-obj-sanitize obj (send obj 'gen-decl)))
+       (else ""))
+)
+
+; Send the gen-defn message to OBJ, and sanitize the output if necessary.
+
+(define (gen-defn obj)
+  (logit 3 "Generating defn for "
+        (cond ((method-present? obj 'get-name) (send obj 'get-name))
+              ((elm-present? obj 'name) (elm-xget obj 'name))
+              (else "unknown"))
+        " ...\n")
+  (cond ((and (method-present? obj 'gen-defn) (not (has-attr? obj 'META)))
+        (gen-obj-sanitize obj (send obj 'gen-defn)))
+       (else ""))
+)
+\f
+; Attributes
+
+; Return C code to declare an enum of attributes ATTRS.
+; PREFIX is one of "cgen_ifld", "cgen_hw", "cgen_operand", "cgen_insn".
+; ATTRS is an alist of attribute values.  The value is unimportant except that
+; it is used to determine bool/non-bool.
+; Non-bools need to be separated from bools as they're each recorded
+; differently.  Non-bools are recorded in an int for each.  All bools are
+; combined into one int to save space.
+; ??? We assume there is at least one bool.
+
+(define (gen-attr-enum-decl prefix attrs)
+  (string-append
+   (gen-enum-decl (string-append prefix "_attr")
+                 (string-append prefix " attrs")
+                 (string-append prefix "_")
+                 (attr-list-enum-list attrs))
+   "/* Number of non-boolean elements in " prefix "_attr.  */\n"
+   "#define " (string-upcase prefix) "_NBOOL_ATTRS "
+   "(" (string-upcase prefix) "_END_NBOOLS - "
+   (string-upcase prefix) "_START_NBOOLS - 1)\n"
+   "\n")
+)
+
+; Return name of symbol ATTR-NAME.
+; PREFIX is the prefix arg to gen-attr-enum-decl.
+
+(define (gen-attr-name prefix attr-name)
+  (string-upcase (gen-c-symbol (string-append prefix "_" attr-name)))
+)
+
+; Normal gen-mask argument to gen-bool-attrs.
+; Returns "(1<< PREFIX_NAME)" where PREFIX is from atlist-prefix and
+; NAME is the name of the attribute.
+; ??? This used to return PREFIX_NAME-CGEN_ATTR_BOOL_OFFSET.
+; The tradeoff is simplicity vs perceived maximum number of boolean attributes
+; needed.  In the end the maximum number needn't be fixed, and the simplicity
+; of the current way is good.
+
+(define (gen-attr-mask prefix name)
+  (string-append "(1<<" (gen-attr-name prefix name) ")")
+)
+
+; Return C expression of bitmasks of boolean attributes in ATTRS.
+; ATTRS is an <attr-list> object, it need not be pre-sorted.
+; GEN-MASK is a procedure that returns the C code of the mask.
+
+(define (gen-bool-attrs attrs gen-mask)
+  (let loop ((result "0")
+            (alist (attr-remove-meta-attrs-alist
+                    (attr-nub (atlist-attrs attrs)))))
+    (cond ((null? alist) result)
+         ((and (boolean? (cdar alist)) (cdar alist))
+          (loop (string-append result
+                               ; `|' is used here instead of `+' so we don't
+                               ; have to care about duplicates.
+                               "|" (gen-mask (atlist-prefix attrs)
+                                             (caar alist)))
+                (cdr alist)))
+         (else (loop result (cdr alist)))))
+)
+
+; Return the C definition of OBJ's attributes.
+; TYPE is one of 'ifld, 'hw, 'operand, 'insn.
+; [Other objects have attributes but these are the only ones we currently
+; emit definitions for.]
+; OBJ is any object that supports the 'get-atlist message.
+; ALL-ATTRS is an ordered alist of all attributes.
+; "ordered" means all the non-boolean attributes are at the front and
+; duplicate entries have been removed.
+; GEN-MASK is the gen-mask arg to gen-bool-attrs.
+
+(define (gen-obj-attr-defn type obj all-attrs num-non-bools gen-mask)
+  (let* ((attrs (obj-atlist obj))
+        (non-bools (attr-non-bool-attrs (atlist-attrs attrs)))
+        (all-non-bools (list-take num-non-bools all-attrs)))
+  (string-append
+   "{ "
+   (gen-bool-attrs attrs gen-mask)
+   ", {"
+   ; For the boolean case, we can (currently) get away with only specifying
+   ; the attributes that are used since they all fit in one int and the
+   ; default is currently always #f (and won't be changed without good
+   ; reason).  In the non-boolean case order is important since each value
+   ; has a specific spot in an array, all of them must be specified.
+   (if (null? all-non-bools)
+       " 0"
+       (string-drop1 ; drop the leading ","
+       (string-map (lambda (attr)
+                     (let ((val (or (assq-ref non-bools (obj:name attr))
+                                    (attr-default attr))))
+                       ; FIXME: Are we missing attr-prefix here?
+                       (string-append ", "
+                                      (send attr 'gen-value-for-defn val))))
+                   all-non-bools)))
+   " } }"
+   ))
+)
+
+; Return a boolean indicating if ATLIST indicates a CTI insn.
+
+(define (atlist-cti? atlist)
+  (or (atlist-has-attr? atlist 'UNCOND-CTI)
+      (atlist-has-attr? atlist 'COND-CTI))
+)
+\f
+; Misc. gen-* procs
+
+; Return name of obj as a C symbol.
+
+(define (gen-sym obj) (gen-c-symbol (obj:name obj)))
+
+; Return the name of the selected cpu family.
+; An error is signalled if more than one has been selected.
+
+(define (gen-cpu-name)
+  ; FIXME: error checking
+  (gen-sym (current-cpu))
+)
+
+; Return HAVE_CPU_<CPU>.
+
+(define (gen-have-cpu cpu)
+  (string-append "HAVE_CPU_"
+                (string-upcase (gen-sym cpu)))
+)
+
+; Return the bfd mach name for MACH.
+
+(define (gen-mach-bfd-name mach)
+  (string-append "bfd_mach_" (gen-c-symbol (mach-bfd-name mach)))
+)
+
+; Return definition of C macro to get the value of SYM.
+
+(define (gen-get-macro sym index-args expr)
+  (string-append
+   "#define GET_" (string-upcase sym) "(" index-args ") " expr "\n")
+)
+
+; Return definition of C macro to set the value of SYM.
+
+(define (gen-set-macro sym index-args lvalue)
+  (string-append
+   "#define SET_" (string-upcase sym)
+   "(" index-args
+   (if (equal? index-args "") "" ", ")
+   "x) (" lvalue " = (x))\n")
+)
+
+; Return definition of C macro to set the value of SYM, version 2.
+; EXPR is one or more C statements *without* proper \newline handling,
+; we prepend \ to each line.
+
+(define (gen-set-macro2 sym index-args newval-arg expr)
+  (string-append
+   "#define SET_" (string-upcase sym)
+   "(" index-args
+   (if (equal? index-args "") "" ", ")
+   newval-arg ") \\\n"
+   "do { \\\n"
+   (backslash "\n" expr)
+   ";} while (0)\n")
+)
+
+; Return C code to fetch a value from instruction memory.
+; PC-VAR is the C expression containing the address of the start of the
+; instruction.
+; ??? Aligned/unaligned support?
+
+(define (gen-ifetch pc-var bitoffset bitsize)
+  (string-append "GETIMEM"
+                (case bitsize
+                  ((8) "UQI")
+                  ((16) "UHI")
+                  ((32) "USI")
+                  (else (error "bad bitsize argument to gen-ifetch" bitsize)))
+                " (current_cpu, "
+                pc-var " + " (number->string (quotient bitoffset 8))
+                ")")
+)
+\f
+; Called before loading the .cpu file to initialize.
+
+(define (utils-init!)
+  (reader-add-command! 'sanitize
+                      "\
+Mark an entry as being sanitized.
+"
+                      nil '(keyword entry-type . entry-names) sanitize)
+
+  *UNSPECIFIED*
+)
diff --git a/cgen/utils-gen.scm b/cgen/utils-gen.scm
new file mode 100644 (file)
index 0000000..b96c0ef
--- /dev/null
@@ -0,0 +1,506 @@
+; Application independent utilities for C/C++ code generation.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; Attributes.
+
+(define (attr-bool-gen-decl attr) "")
+
+(define (attr-bool-gen-defn attr) "")
+
+(define (attr-int-gen-decl attr) "")
+
+(define (attr-int-gen-defn attr) "")
+
+(define (attr-gen-decl attr)
+  (gen-enum-decl (symbol-append (obj:name attr) '-attr)
+                (obj:comment attr)
+                (string-append (obj:name attr) "_")
+                (attr-values attr))
+)
+
+(define (attr-gen-defn attr)
+  (string-append
+   "static const CGEN_ATTR_ENTRY "
+   (gen-sym attr) "_attr"
+   "[] =\n{\n"
+   (string-map (lambda (elm)
+                (let* ((san (and (pair? elm) (pair? (cdr elm))
+                                 (attr-value (cddr elm) 'sanitize #f))))
+                  (gen-sanitize
+                   (if (and san (not (eq? san 'none)))
+                       san
+                       #f)
+                   (string-append "  { "
+                                  "\""
+                                  (gen-c-symbol (car elm))
+                                  "\", "
+                                  (string-upcase (gen-sym attr))
+                                  "_"
+                                  (string-upcase (gen-c-symbol (car elm)))
+                                  " },\n"))))
+              (attr-values attr))
+   "  { 0, 0 }\n"
+   "};\n\n")
+)
+
+(method-make! <boolean-attribute> 'gen-decl attr-bool-gen-decl)
+(method-make! <bitset-attribute> 'gen-decl attr-gen-decl)
+(method-make! <integer-attribute> 'gen-decl attr-int-gen-decl)
+(method-make! <enum-attribute> 'gen-decl attr-gen-decl)
+
+(method-make! <boolean-attribute> 'gen-defn attr-bool-gen-defn)
+(method-make! <bitset-attribute> 'gen-defn attr-gen-defn)
+(method-make! <integer-attribute> 'gen-defn attr-int-gen-defn)
+(method-make! <enum-attribute> 'gen-defn attr-gen-defn)
+\f
+; Ifield extraction utilities.
+
+; Return the C data type to use to hold an extracted and decoded
+; <ifield> from an insn.  Usually this is just an int, but for register
+; numbers or large unsigned immediates, an unsigned int may be preferable.
+; Then there's floats (??? which aren't handled yet).
+
+(define (gen-ifld-type f)
+  (mode:c-type (ifld-decode-mode f))
+)
+
+; Return C declaration of variable(s) to hold <ifield> F.
+; MACRO? is #t if the result is part of a macro.
+
+(define (gen-ifld-extract-decl f indent macro?)
+  (string-append indent (gen-ifld-type f) " " (gen-sym f) ";"
+                (if macro? " \\\n" "\n"))
+)
+
+; Return C code to extract a field from the base part of an insn.
+;
+; TOTAL-LENGTH is the total length of the value in VAL.
+; BASE-VALUE is a C expression (string) containing the base part of the insn.
+
+(define (-gen-ifld-extract-base f total-length base-value)
+  (let ((extraction
+        (string-append "EXTRACT_"
+                       (if (current-arch-insn-lsb0?) "LSB0_" "MSB0_")
+                       (case (mode:class (ifld-mode f))
+                         ((INT) "INT")
+                         ((UINT) "UINT")
+                         (else (error "unsupported mode class"
+                                      (mode:class (ifld-mode f)))))
+                       " ("
+                       base-value ", "
+                       (number->string total-length) ", "
+                       ; ??? Is passing total-length right here?
+                       (number->string (ifld-start f total-length)) ", "
+                       (number->string (ifld-length f))
+                       ")"))
+       (decode (ifld-decode f)))
+    ; If the field doesn't have a special decode expression,
+    ; just return the raw extracted value.  Otherwise, emit
+    ; the expression.
+    (if (not decode)
+       extraction
+       ; cadr: fetches expression to be evaluated
+       ; caar: fetches symbol in arglist
+       ; cadar: fetches `pc' symbol in arglist
+       (rtl-c VOID (cadr decode)
+              (list (list (caar decode) 'UINT extraction)
+                    (list (cadar decode) 'IAI "pc"))
+              #:rtl-cover-fns? #f #:ifield-var? #t)))
+)
+
+; Subroutine of -gen-ifld-extract-beyond to extract the relevant value
+; from WORD-NAME and move it into place.
+
+(define (-gen-extract-word word-name word-start word-length start length
+                          unsigned? lsb0?)
+  ; ??? lsb0?
+  (let ((word-end (+ word-start word-length))
+       (end (+ start length)))
+    (string-append "("
+                  "EXTRACT_"
+                  (if (current-arch-insn-lsb0?) "LSB0" "MSB0")
+                  (if (and (not unsigned?)
+                           ; Only want sign extension for word with sign bit.
+                           (bitrange-overlap? start 1 word-start word-length
+                                              lsb0?))
+                      "_INT ("
+                      "_UINT (")
+                  word-name
+                  ", "
+                  (number->string word-length)
+                  ", "
+                  (number->string (if (< start word-start)
+                                      0
+                                      (- start word-start)))
+                  ", "
+                  (number->string (if (< end word-end)
+                                      (- word-end end)
+                                      word-length))
+                  ") << "
+                  (number->string (if (> end word-end)
+                                      (- end word-end)
+                                      0))
+                  ")"))
+)
+
+; Return C code to extract a field that extends beyond the base insn.
+;
+; Things get tricky in the non-integral-insn case (no kidding).
+; This case includes every architecture with at least one insn larger
+; than 32 bits, and all architectures where insns smaller than 32 bits
+; can't be interpreted as an int.
+; ??? And maybe other architectures not considered yet.
+; We want to handle these reasonably fast as this includes architectures like
+; the ARC and I960 where 99% of the insns are 32 bits, with a few insns that
+; take a 32 bit immediate.  It would be a real shame to unnecessarily slow down
+; handling of 99% of the instruction set just for a few insns.  Fortunately
+; for these chips base-insn includes these insns, so things fall out naturally.
+;
+; BASE-LENGTH is base-insn-bitsize.
+; TOTAL-LENGTH is the total length of the insn.
+; VAR-LIST is a list of variables containing the insn.
+; Each element in VAR-LIST is (name start length).
+; The contents of the insn are in several variables: insn, word_[123...],
+; where `insn' contains the "base insn" and `word_N' is a set of variables
+; recording the rest of the insn, 32 bits at a time (with the last one
+; containing whatever is left over).
+
+(define (-gen-ifld-extract-beyond f base-length total-length var-list)
+   ; First compute the list of variables that contains pieces of the
+   ; desired value.
+   (let ((start (+ (ifld-start f total-length) (ifld-word-offset f)))
+        (length (ifld-length f))
+        ;(word-start (ifld-word-offset f))
+        ;(word-length (ifld-word-length f))
+        ; extraction code
+        (extraction #f)
+         ; extra processing to perform on extracted value
+        (decode (ifld-decode f))
+        (lsb0? (current-arch-insn-lsb0?)))
+     ; Find which vars are needed and move the value into place.
+     (let loop ((var-list var-list) (result (list ")")))
+       (if (null? var-list)
+          (set! extraction (apply string-append (cons "(0" result)))
+          (let ((var-name (caar var-list))
+                (var-start (cadar var-list))
+                (var-length (caddar var-list)))
+            (if (bitrange-overlap? start length
+                                   var-start var-length
+                                   lsb0?)
+                (loop (cdr var-list)
+                      (cons "|"
+                            (cons (-gen-extract-word var-name
+                                                     var-start
+                                                     var-length
+                                                     start length
+                                                     (eq? (mode:class (ifld-mode f))
+                                                          'UINT)
+                                                     lsb0?)
+                                  result)))
+                (loop (cdr var-list) result)))))
+     ; If the field doesn't have a special decode expression, just return the
+     ; raw extracted value.  Otherwise, emit the expression.
+     (if (not decode)
+        extraction
+        ; cadr: fetches expression to be evaluated
+        ; caar: fetches symbol in arglist
+        ; cadar: fetches `pc' symbol in arglist
+        (rtl-c VOID (cadr decode)
+               (list (list (caar decode) 'UINT extraction)
+                     (list (cadar decode) 'IAI "pc"))
+               #:rtl-cover-fns? #f #:ifield-var? #t)))
+)
+
+; Return C code to extract <ifield> F.
+
+(define (gen-ifld-extract f indent base-length total-length base-value var-list macro?)
+  (string-append
+   indent
+   (gen-sym f)
+   " = "
+   (if (ifld-beyond-base? f base-length total-length)
+       (-gen-ifld-extract-beyond f base-length total-length var-list)
+       (-gen-ifld-extract-base f (min base-length total-length) base-value))
+   ";"
+   (if macro? " \\\n" "\n")
+   )
+)
+
+; Return C code to extract a <multi-ifield> from an insn.
+; This must have the same signature as gen-ifld-extract as both can be
+; made methods in application code.
+
+(define (gen-multi-ifld-extract f indent base-length total-length base-value var-list macro?)
+  ; The subfields must have already been extracted.
+  (let* ((extract (rtl-c VOID (multi-ifld-extract f) nil
+                        #:rtl-cover-fns? #f #:ifield-var? #t))
+        (decode-proc (ifld-decode f))
+        (decode (if decode-proc
+                    (rtl-c VOID (cadr decode-proc)
+                           (list (list (caar decode-proc) 'UINT extract)
+                                 (list (cadar decode-proc) 'IAI "pc"))
+                           #:rtl-cover-fns? #f #:ifield-var? #t)
+                    extract)))
+    (if macro?
+       (backslash "\n" decode)
+       decode))
+)
+
+; Return C symbol of variable containing the extracted field value
+; in the extraction code.  E.g. f_rd = EXTRACT_UINT (insn, ...).
+
+(define (gen-extracted-ifld-value f)
+  (gen-sym f)
+)
+
+; Subroutine of gen-extract-ifields to compute arguments for -extract-chunk
+; to extract values beyond the base insn.
+; This is also used by gen-define-ifields to know how many vars are needed.
+;
+; The result is a list of (offset . length) pairs.
+;
+; ??? Here's a case where explicitly defined instruction formats can
+; help - without them we can only use heuristics (which must evolve).
+; At least all the details are tucked away here.
+
+(define (-extract-chunk-specs base-length total-length alignment)
+  (let ((chunk-length
+        (case alignment
+          ; For the aligned and forced case split the insn up into base-insn
+          ; sized chunks.  For the unaligned case, use a chunk-length of 32.
+          ; 32 was chosen because the values are extracted into portable ints.
+          ((aligned forced) (min base-length 32))
+          ((unaligned) 32)
+          (else (error "unknown alignment" alignment)))))
+    (let loop ((start base-length)
+              (remaining (- total-length base-length))
+              (result nil))
+      (if (<= remaining 0)
+         (reverse! result)
+         (loop (+ start chunk-length)
+               (- remaining chunk-length)
+               (cons (cons start (min chunk-length remaining))
+                     result)))))
+)
+
+; Subroutine of gen-define-ifmt-ifields and gen-extract-ifmt-ifields to
+; insert the subfields of any multi-ifields present into IFLDS.
+; Subfields are inserted before their corresponding multi-ifield as they
+; are initialized in order.
+
+(define (-extract-insert-subfields iflds)
+  (let loop ((result nil) (iflds iflds))
+    (cond ((null? iflds)
+          (reverse! result))
+         ((multi-ifield? (car iflds))
+          (loop (cons (car iflds)
+                      ; There's no real need to reverse the subfields here
+                      ; other than to keep them in order.
+                      (append (reverse (multi-ifld-subfields (car iflds)))
+                              result))
+                (cdr iflds)))
+         (else
+          (loop (cons (car iflds) result) (cdr iflds)))))
+)
+
+; Return C code to define local vars to contain IFIELDS.
+; All insns using the result have the same TOTAL-LENGTH (in bits).
+; INDENT is a string prepended to each line.
+; MACRO? is #t if the code is part of a macro (and thus '\\' must be appended
+; to each line).
+
+(define (gen-define-ifields ifields total-length indent macro?)
+  (let* ((base-length (state-base-insn-bitsize))
+        (chunk-specs (-extract-chunk-specs base-length total-length
+                                           (current-arch-default-alignment))))
+    (string-list
+     (string-list-map (lambda (f)
+                       (gen-ifld-extract-decl f indent macro?))
+                     ifields)
+     ; Define enough ints to hold the trailing part of the insn,
+     ; N bits at a time.
+     ; ??? This could be more intelligent of course.  Later.
+     ; ??? Making these global to us would allow filling them during
+     ; decoding.
+     (if (> total-length base-length)
+        (string-list
+         indent
+         "/* Contents of trailing part of insn.  */"
+         (if macro? " \\\n" "\n")
+         (string-list-map (lambda (chunk-num)
+                            (string-list indent
+                                         "UINT word_"
+                                         (number->string chunk-num)
+                                         (if macro? "; \\\n" ";\n")))
+                          (iota 1 (length chunk-specs))))
+        "")))
+)
+
+; Return C code to define local vars to contain IFIELDS of <iformat> IFMT.
+; INDENT is a string prepended to each line.
+; MACRO? is #t if the code is part of a macro (and thus '\\' must be appended
+; to each line).
+; USE-MACRO? is #t if instead of generating the fields, we return the macro
+; that does that.
+
+(define (gen-define-ifmt-ifields ifmt indent macro? use-macro?)
+  (let ((macro-name (string-append
+                    "EXTRACT_" (string-upcase (gen-sym ifmt))
+                    "_VARS"))
+       (ifields (-extract-insert-subfields (ifmt-ifields ifmt))))
+    (if use-macro?
+       (string-list indent macro-name
+                    " /*"
+                    (string-list-map (lambda (fld)
+                                       (string-append " " (obj:name fld)))
+                                     ifields)
+                    " */\n")
+       (let ((indent (if macro? (string-append indent "  ") indent)))
+         (string-list
+          (if macro?
+              (string-list "#define " macro-name " \\\n")
+              (string-list indent "/* Instruction fields.  */\n"))
+          (gen-define-ifields ifields (ifmt-length ifmt) indent macro?)
+          indent "unsigned int length;"
+          ; The last line doesn't have a trailing '\\'.
+          "\n"
+          ))))
+)
+
+; Subroutine of gen-extract-ifields to fetch one value into VAR-NAME.
+
+(define (-extract-chunk offset bits var-name macro?)
+  (string-append
+   "  "
+   var-name
+   " = "
+   (gen-ifetch "pc" offset bits)
+   ";"
+   (if macro? " \\\n" "\n"))
+)
+
+; Subroutine of gen-extract-ifields to compute the var-list arg to
+; gen-ifld-extract-beyond.
+; The result is a list of `(name start length)' elements describing the
+; variables holding the parts of the insn.
+; CHUNK-SPECS is a list of (offset . length) pairs.
+
+(define (-gen-extract-beyond-var-list base-length var-prefix chunk-specs lsb0?)
+  ; ??? lsb0? support ok?
+  (cons (list "insn" 0 base-length)
+       (map (lambda (chunk-num chunk-spec)
+              (list (string-append var-prefix (number->string chunk-num))
+                    (car chunk-spec)
+                    (cdr chunk-spec)))
+            (iota 1 (length chunk-specs))
+            chunk-specs))
+)
+
+; Return C code to extract IFIELDS.
+; All insns using the result have the same TOTAL-LENGTH (in bits).
+; MACRO? is #t if the code is part of a macro (and thus '\\' must be appended
+; to each line).
+;
+; Here is where we handle integral-insn vs non-integeral-insn architectures.
+;
+; Examples of architectures that can be handled as integral-insns are:
+; sparc, m32r, mips, etc.
+;
+; Examples of architectures that can't be handled as integral insns are:
+; arc, i960, fr30, i386, m68k.
+; [i386,m68k are only mentioned for completeness.  cgen ports of these
+; would be great, but more thought is needed first]
+;
+; C variable `insn' is assumed to contain the base part of the insn
+; (max base-insn-bitsize insn-bitsize).  In the m32r case insn-bitsize
+; can be less than base-insn-bitsize.
+;
+; ??? Need to see how well gcc optimizes this.
+;
+; ??? Another way to do this is to put this code in an inline function that
+; gets passed pointers to each ifield variable.  GCC is smart enough to
+; produce optimal code for this, but other compilers may not have inlining
+; or the indirection removal.  I think the slowdown for a non-scache simulator
+; would be phenomenal and while one can say "too bad, use gcc", I'm defering
+; doing this for now.
+
+(define (gen-extract-ifields ifields total-length indent macro?)
+  (let* ((base-length (state-base-insn-bitsize))
+        (chunk-specs (-extract-chunk-specs base-length total-length
+                                           (current-arch-default-alignment))))
+    (string-list
+     ; If the insn has a trailing part, fetch it.
+     ; ??? Could have more intelligence here.  Later.
+     (if (> total-length base-length)
+        (let ()
+          (string-list-map (lambda (chunk-spec chunk-num)
+                             (-extract-chunk (car chunk-spec)
+                                             (cdr chunk-spec)
+                                             (string-append
+                                              "word_"
+                                              (number->string chunk-num))
+                                             macro?))
+                           chunk-specs
+                           (iota 1 (length chunk-specs))))
+        "")
+     (string-list-map
+      (lambda (f)
+       ; Dispatching on a method works better, as would a generic fn.
+       ; ??? Written this way to pass through Hobbit, doesn't handle
+       ; ((if foo a b) (arg1 arg2)).
+       (if (multi-ifield? f)
+           (gen-multi-ifld-extract
+            f indent base-length total-length "insn"
+            (-gen-extract-beyond-var-list base-length "word_"
+                                          chunk-specs
+                                          (current-arch-insn-lsb0?))
+            macro?)
+           (gen-ifld-extract
+            f indent base-length total-length "insn"
+            (-gen-extract-beyond-var-list base-length "word_"
+                                          chunk-specs
+                                          (current-arch-insn-lsb0?))
+            macro?)))
+      ifields)
+     ))
+)
+
+; Return C code to extract the fields of <iformat> IFMT.
+; MACRO? is #t if the code is part of a macro (and thus '\\' must be appended
+; to each line).
+; USE-MACRO? is #t if instead of generating the fields, we return the macro
+; that does that.
+
+(define (gen-extract-ifmt-ifields ifmt indent macro? use-macro?)
+  (let ((macro-name (string-append
+                    "EXTRACT_" (string-upcase (gen-sym ifmt))
+                    "_CODE"))
+       (ifields (-extract-insert-subfields (ifmt-ifields ifmt))))
+    (if use-macro?
+       (string-list indent macro-name "\n")
+       (let ((indent (if macro? (string-append indent "  ") indent)))
+         (string-list
+          (if macro?
+              (string-list "#define " macro-name " \\\n")
+              "")
+          indent "length = "
+          (number->string (bits->bytes (ifmt-length ifmt)))
+          ";"
+          (if macro? " \\\n" "\n")
+          (gen-extract-ifields ifields (ifmt-length ifmt) indent macro?)
+          ; The last line doesn't have a trailing '\\'.
+          "\n"
+          ))))
+)
+\f
+; Instruction format utilities.
+
+(define (gen-sfmt-enum-decl sfmt-list)
+  (gen-enum-decl "@cpu@_sfmt_type"
+                "semantic formats in cpu family @cpu@"
+                "@CPU@_"
+                (map (lambda (sfmt) (cons (obj:name sfmt) nil))
+                     sfmt-list))
+)
diff --git a/cgen/utils-sim.scm b/cgen/utils-sim.scm
new file mode 100644 (file)
index 0000000..e0951ad
--- /dev/null
@@ -0,0 +1,955 @@
+; Generic simulator application utilities.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; The cache-addr? method.
+; Return #t if the hardware element's address is stored in the scache buffer.
+; This saves doing the index calculation during semantic processing.
+
+(method-make!
+ <hardware-base> 'cache-addr?
+ (lambda (self)
+   (and (with-scache?)
+       (has-attr? self 'CACHE-ADDR)))
+)
+
+(define (hw-cache-addr? hw) (send hw 'cache-addr?))
+\f
+; The needed-iflds method.
+; Return list of ifields needed during semantic execution by hardware element
+; SELF referenced by <operand> OP in <sformat> SFMT.
+
+(method-make!
+ <hardware-base> 'needed-iflds
+ (lambda (self op sfmt)
+   (list (op-ifield op)))
+)
+
+(method-make!
+ <hw-register> 'needed-iflds
+ (lambda (self op sfmt)
+   (list (op-ifield op)))
+; Instead of the following, we now arrange to store the ifield in the
+; argbuf, even for CACHE-ADDR operands.  This way, the ifield values 
+; (register numbers, etc.) remain available during semantics tracing.
+;   (if (hw-cache-addr? self)
+;       nil
+;       (list (op-ifield op))))
+)
+
+; For addresses this is none because we make our own copy of the ifield
+; [because we want to use a special type].
+
+(method-make!
+ <hw-address> 'needed-iflds
+ (lambda (self op sfmt)
+   nil)
+)
+
+(define (hw-needed-iflds hw op sfmt) (send hw 'needed-iflds op sfmt))
+
+; Return a list of ifields of <operand> OP that must be recorded in ARGBUF
+; for <sformat> SFMT.
+; ??? At the moment there can only be at most one, but callers must not
+; assume this.
+
+(define (op-needed-iflds op sfmt)
+  (let ((indx (op:index op)))
+    (if (and (eq? (hw-index:type indx) 'ifield)
+            (not (= (ifld-length (hw-index:value indx)) 0)))
+       (hw-needed-iflds (op:type op) op sfmt)
+       nil))
+)
+\f
+; Operand extraction (ARGBUF) support code.
+;
+; Any operand that uses a non-empty ifield needs extraction support.
+; Normally we just record the ifield's value.  However, in cases where
+; hardware elements have CACHE-ADDR specified or where the mode of the
+; hardware index isn't compatible with the mode of the decoded ifield
+; (this can happen for pc-relative instruction address), we need to record
+; something else.
+
+; Return a boolean indicating if <operand> OP needs any extraction processing.
+
+(define (op-extract? op)
+  (let* ((indx (op:index op))
+        (extract?
+         (if (derived-operand? op)
+             (any-true? (map op-extract? (derived-args op)))
+             (and (eq? (hw-index:type indx) 'ifield)
+                  (not (= (ifld-length (hw-index:value indx)) 0))))))
+    (logit 4 "op-extract? op=" (obj:name op) " =>" extract? "\n")
+    extract?)
+)
+
+; Return a list of operands that need special extraction processing.
+; SFMT is an <sformat> object.
+
+(define (sfmt-extracted-operands sfmt)
+  (let ((in-ops (sfmt-in-ops sfmt))
+       (out-ops (sfmt-out-ops sfmt)))
+    (let ((ops (append (find op-extract? in-ops)
+                      (find op-extract? out-ops))))
+      (nub ops obj:name)))
+)
+
+; Return a list of ifields that are needed by the semantic code.
+; SFMT is an <sformat> object.
+; ??? This redoes a lot of the calculation that sfmt-extracted-operands does.
+
+(define (sfmt-needed-iflds sfmt)
+  (let ((in-ops (sfmt-in-ops sfmt))
+       (out-ops (sfmt-out-ops sfmt)))
+    (let ((ops (append (find op-extract? in-ops)
+                      (find op-extract? out-ops))))
+      (nub (apply append (map (lambda (op)
+                               (op-needed-iflds op sfmt))
+                             ops))
+          obj:name)))
+)
+\f
+; Sformat argument buffer.
+;
+; This contains the details needed to create an argument buffer `fields' union
+; entry for the containing sformats.
+
+(define <sformat-argbuf>
+  (class-make '<sformat-argbuf>
+             '(<ident>)
+             ; From <ident>:
+             ; - NAME is derived from one of the containing sformats.
+             '(
+               ; List of structure elements.
+               ; Each element is ("var name" "C type" bitsize).
+               ; The list is sorted by decreasing size, then C type,
+               ; then var name.
+               elms
+               )
+             nil)
+)
+
+(define-getters <sformat-argbuf> sbuf (sfmts elms))
+
+; Subroutine of -sfmt-contents to return an ifield element.
+; The result is ("var-name" "C-type" bitsize).
+
+(define (-sfmt-ifld-elm f sfmt)
+  (let ((real-mode (mode-real-mode (ifld-decode-mode f))))
+    (list (gen-sym f)
+         (mode:c-type real-mode)
+         (mode:bits real-mode)))
+)
+
+; sbuf-elm method.
+; The result is ("var-name" "C-type" approx-bitsize) or #f if unneeded.
+; For the default case we use the ifield as is, which is computed elsewhere.
+
+(method-make!
+ <hardware-base> 'sbuf-elm
+ (lambda (self op ifmt)
+   #f)
+)
+
+(method-make!
+ <hw-register> 'sbuf-elm
+ (lambda (self op ifmt)
+   (if (hw-cache-addr? self)
+       (list (gen-sym (op:index op))
+            (string-append (gen-type self) "*")
+            ; Use 64 bits for size.  Doesn't really matter, just put them
+            ; near the front.
+            64)
+       #f))
+)
+
+; We want to use ADDR/IADDR in ARGBUF for addresses
+
+(method-make!
+ <hw-address> 'sbuf-elm
+ (lambda (self op ifmt)
+   (list (gen-sym (op:index op))
+        "ADDR"
+        ; Use 64 bits for size.  Doesn't really matter, just put them
+        ; near the front.
+        64))
+)
+
+(method-make!
+ <hw-iaddress> 'sbuf-elm
+ (lambda (self op ifmt)
+   (list (gen-sym (op:index op))
+        "IADDR"
+        ; Use 64 bits for size.  Doesn't really matter, just put them
+        ; near the front.
+        64))
+)
+
+; Subroutine of -sfmt-contents to return an operand element.
+; These are in addition (or instead of) the actual ifields.
+; This is also used to compute definitions of local vars needed in the
+; !with-scache case.
+; The result is ("var-name" "C-type" approx-bitsize) or #f if unneeded.
+
+(define (sfmt-op-sbuf-elm op sfmt)
+  (send (op:type op) 'sbuf-elm op sfmt)
+)
+
+; Subroutine of compute-sformat-bufs! to compute list of structure elements
+; needed by <sformat> SFMT.
+; The result is
+; (SFMT ("var-name1" "C-type1" size1) ("var-name2" "C-type2" size2) ...)
+; and is sorted by decreasing size, then C type, then variable name
+; (as <sformat-argbuf> wants it).
+
+(define (-sfmt-contents sfmt)
+  (let ((needed-iflds (sfmt-needed-iflds sfmt))
+       (extracted-ops (sfmt-extracted-operands sfmt))
+       (in-ops (sfmt-in-ops sfmt))
+       (out-ops (sfmt-out-ops sfmt))
+       (sort-elms (lambda (a b)
+                    ; Sort by descending size, then ascending C type, then
+                    ; ascending name.
+                    (cond ((> (caddr a) (caddr b))
+                           #t)
+                          ((= (caddr a) (caddr b))
+                           (cond ((string<? (cadr a) (cadr b))
+                                  #t)
+                                 ((string=? (cadr a) (cadr b))
+                                  (string<? (car a) (car b)))
+                                 (else
+                                  #f)))
+                          (else
+                           #f))))
+       )
+    (cons sfmt
+         (sort
+          ; Compute list of all things we need to record at extraction time.
+          (find (lambda (x)
+                  ; Discard #f entries, they indicate "unneeded".
+                  x)
+                (append
+                 (map (lambda (f)
+                        (-sfmt-ifld-elm f sfmt))
+                      needed-iflds)
+                 (map (lambda (op)
+                        (sfmt-op-sbuf-elm op sfmt))
+                      extracted-ops)
+                 (cond ((with-any-profile?)
+                        (append
+                         ; Profiling support.  ??? This stuff is in flux.
+                         (map (lambda (op)
+                                (sfmt-op-profile-elm op sfmt #f))
+                              (find op-profilable? in-ops))
+                         (map (lambda (op)
+                                (sfmt-op-profile-elm op sfmt #t))
+                              (find op-profilable? out-ops))))
+                       (else 
+                        (append)))))
+          sort-elms)))
+)
+
+; Return #t if ELM-LIST is a subset of SBUF.
+; SBUF is an <sformat-argbuf> object.
+
+(define (-sbuf-subset? elm-list sbuf)
+  ; We take advantage of the fact that elements in each are already sorted.
+  ; FIXME: Can speed up.
+  (let loop ((elm-list elm-list) (sbuf-elm-list (sbuf-elms sbuf)))
+    (cond ((null? elm-list)
+          #t)
+         ((null? sbuf-elm-list)
+          #f)
+         ((equal? (car elm-list) (car sbuf-elm-list))
+          (loop (cdr elm-list) (cdr sbuf-elm-list)))
+         (else
+          (loop elm-list (cdr sbuf-elm-list)))))
+)
+
+; Subroutine of compute-sformat-bufs!.
+; Lookup ELM-LIST in SBUF-LIST.  A match is found if ELM-LIST
+; is a subset of one in SBUF-LIST.
+; Return the containing <sformat-argbuf> object if found, otherwise return #f.
+; SBUF-LIST is a list of <sformat-argbuf> objects.
+; ELM-LIST is (elm1 elm2 ...).
+
+(define (-sbuf-lookup elm-list sbuf-list)
+  (let loop ((sbuf-list sbuf-list))
+    (cond ((null? sbuf-list)
+          #f)
+         ((-sbuf-subset? elm-list (car sbuf-list))
+          (car sbuf-list))
+         (else
+          (loop (cdr sbuf-list)))))
+)
+
+; Compute and record the set of <sformat-argbuf> objects needed for SFMT-LIST,
+; a list of all sformats.
+; The result is the computed list of <sformat-argbuf> objects.
+;
+; This is used to further reduce the number of entries in the argument buffer's
+; `fields' union.  Some sformats have structs with the same contents or one is
+; a subset of another's, thus there is no need to distinguish them as far as
+; the struct is concerned (there may be other reasons to distinguish them of
+; course).
+; The consequence of this is fewer semantic fragments created in with-sem-frags
+; pbb engines.
+
+(define (compute-sformat-argbufs! sfmt-list)
+  (logit 1 "Computing sformat argument buffers ...\n")
+
+  (let ((sfmt-contents
+        ; Sort by descending length.  This helps building the result: while
+        ; iterating over each element, its sbuf is either a subset of a
+        ; previous entry or requires a new entry.
+        (sort (map -sfmt-contents sfmt-list)
+              (lambda (a b)
+                (> (length a) (length b)))))
+       ; Build an <sformat-argbuf> object.
+       (build-sbuf (lambda (sfmt-data)
+                     (make <sformat-argbuf>
+                       (obj:name (car sfmt-data))
+                       ""
+                       atlist-empty
+                       (cdr sfmt-data))))
+       )
+    ; Start off with the first sfmt.
+    ; Also build an empty sbuf.  Which sbuf to use for an empty argument list
+    ; is rather arbitrary.  Rather than pick one, keep the empty sbuf unto
+    ; itself.
+    (let ((nub-sbufs (list (build-sbuf (car sfmt-contents))))
+         (empty-sbuf (make <sformat-argbuf>
+                       'fmt-empty "no operands" atlist-empty
+                       nil))
+         )
+      (sfmt-set-sbuf! (caar sfmt-contents) (car nub-sbufs))
+
+      ; Now loop over the remaining sfmts.
+      (let loop ((sfmt-contents (cdr sfmt-contents)))
+       (if (not (null? sfmt-contents))
+           (let ((sfmt-data (car sfmt-contents)))
+             (if (null? (cdr sfmt-data))
+                 (sfmt-set-sbuf! (car sfmt-data) empty-sbuf)
+                 (let ((sbuf (-sbuf-lookup (cdr sfmt-data) nub-sbufs)))
+                   (if (not sbuf)
+                       (begin
+                         (set! sbuf (build-sbuf sfmt-data))
+                         (set! nub-sbufs (cons sbuf nub-sbufs))))
+                   (sfmt-set-sbuf! (car sfmt-data) sbuf)))
+             (loop (cdr sfmt-contents)))))
+
+      ; Done.
+      ; Note that the result will be sorted by ascending number of elements
+      ; (because the search list was sorted by descending length and the result
+      ; is built up in reverse order of that).
+      ; Not that it matters, but that's kinda nice.
+      (cons empty-sbuf nub-sbufs)))
+)
+\f
+; Profiling support.
+
+; By default hardware elements are not profilable.
+
+(method-make! <hardware-base> 'profilable? (lambda (self) #f))
+
+(method-make!
+ <hw-register> 'profilable?
+ (lambda (self) (has-attr? self 'PROFILE))
+)
+
+; Return boolean indicating if HW is profilable.
+
+(define (hw-profilable? hw) (send hw 'profilable?))
+
+; Return a boolean indicating if OP is profilable.
+
+(define (op-profilable? op)
+  (hw-profilable? (op:type op))
+)
+
+; sbuf-profile-data method.
+; Return a list of C type and size to use in an sformat's argument buffer.
+
+(method-make!
+ <hardware-base> 'sbuf-profile-data
+ (lambda (self)
+   (error "sbuf-profile-elm not supported for this hw type"))
+)
+
+(method-make!
+ <hw-register> 'sbuf-profile-data
+ (lambda (self)
+   ; Don't unnecessarily bloat size of argument buffer.
+   (if (<= (hw-num-elms self) 255)
+       (list "unsigned char" 8)
+       (list "unsigned short" 16)))
+)
+
+; sbuf-profile-elm method.
+; Return the ARGBUF member needed for profiling SELF in <sformat> SFMT.
+; The result is (var-name "C-type" approx-bitsize) or #f if unneeded.
+
+(method-make!
+ <operand> 'sbuf-profile-elm
+ (lambda (self sfmt out?)
+   (if (hw-scalar? (op:type self))
+       #f
+       (cons (string-append (if out? "out_" "in_")
+                           (gen-sym self))
+            (send (op:type self) 'sbuf-profile-data))))
+)
+
+; Subroutine of -sfmt-contents to return an operand's profile element.
+; The result is (var-name "C-type" approx-bitsize) or #f if unneeded.
+
+(define (sfmt-op-profile-elm op sfmt out?)
+  (send op 'sbuf-profile-elm sfmt out?)
+)
+\f
+; ARGBUF accessor support.
+
+; Define and undefine C macros to tuck away details of instruction format used
+; in the extraction and semantic code.  Instruction format names can
+; change frequently and this can result in unnecessarily large diffs from one
+; generated version of the file to the next.  Secondly, tucking away details of
+; the extracted argument structure from the extraction code is a good thing.
+
+; Name of macro to access fields in ARGBUF.
+(define c-argbuf-macro "FLD")
+
+(define (gen-define-argbuf-macro sfmt)
+  (string-append "#define " c-argbuf-macro "(f) "
+                "abuf->fields."
+                (gen-sym (sfmt-sbuf sfmt))
+                ".f\n")
+)
+
+(define (gen-undef-argbuf-macro sfmt)
+  (string-append "#undef " c-argbuf-macro "\n")
+)
+
+; For old code.  Delete in time.
+(define gen-define-field-macro gen-define-argbuf-macro)
+(define gen-undef-field-macro gen-undef-argbuf-macro)
+
+; Return a C reference to an ARGBUF field value.
+
+(define (gen-argbuf-ref name)
+  (string-append c-argbuf-macro " (" name ")")
+)
+
+; Return name of ARGBUF member for extracted <field> F.
+
+(define (gen-ifld-argbuf-name f)
+  (gen-sym f)
+)
+
+; Return the C reference to a cached ifield.
+
+(define (gen-ifld-argbuf-ref f)
+  (gen-argbuf-ref (gen-ifld-argbuf-name f))
+)
+
+; Return name of ARGBUF member holding processed from of extracted
+; ifield value for <hw-index> index.
+
+(define (gen-hw-index-argbuf-name index)
+  (gen-sym index)
+)
+
+; Return C reference to a processed <hw-index> in ARGBUF.
+
+(define (gen-hw-index-argbuf-ref index)
+  (gen-argbuf-ref (gen-hw-index-argbuf-name index))
+)
+\f
+; Decode support.
+
+; Main procedure call tree:
+; cgen-decode.{c,cxx}
+;     -gen-decode-fn
+;         gen-decoder [our entry point]
+;             decode-build-table
+;             -gen-decoder-switch
+;                 -gen-decoder-switch
+;
+; decode-build-table is called to construct a tree of "table-guts" elements
+; (??? Need better name obviously),
+; and then gen-decoder is recursively called on each of these elements.
+
+; Return C/C++ code that fetches the desired decode bits from C value VAL.
+; SIZE is the size in bits of val (the MSB is 1 << (size - 1)) which we
+; treat as bitnum 0.
+; BITNUMS must be monotonically increasing.
+; LSB0? is non-#f if bit number 0 is the least significant bit.
+; FIXME: START may not be handled right in words beyond first.
+;
+; e.g. (-gen-decode-bits '(0 1 2 3 8 9 10 11) 0 16 "insn" #f)
+; --> "(((insn >> 8) & 0xf0) | ((insn >> 4) & 0xf))"
+; FIXME: The generated code has some inefficiencies in edge cases.  Later.
+
+(define (-gen-decode-bits bitnums start size val lsb0?)
+
+  ; Compute a list of lists of three numbers:
+  ; (first bitnum in group, position in result (0=LSB), bits in result)
+
+  (let ((groups
+        ; POS = starting bit position of current group.
+        ; COUNT = number of bits in group.
+        ; Work from least to most significant bit so reverse bitnums.
+        (let loop ((result nil) (pos 0) (count 0) (bitnums (reverse bitnums)))
+          ;(display (list result pos count bitnums)) (newline)
+          (if (null? bitnums)
+              result
+              (if (or (= (length bitnums) 1)
+                      ; Are numbers not next to each other?
+                      (not (= (- (car bitnums) (if lsb0? -1 1))
+                              (cadr bitnums))))
+                  (loop (cons (list (car bitnums) pos (+ 1 count))
+                              result)
+                        (+ pos count 1) 0
+                        (cdr bitnums))
+                  (loop result
+                        pos (+ 1 count)
+                        (cdr bitnums)))))))
+    (string-append
+     "("
+     (string-drop 3
+                 (string-map
+                  (lambda (group)
+                    (let* ((first (car group))
+                           (pos (cadr group))
+                           (bits (caddr group))
+                           ; Difference between where value is and where
+                           ; it needs to be.
+                           ; FIXME: Need to handle left (-ve) shift.
+                           (shift (- (if lsb0?
+                                         (- first bits -1)
+                                         (- (+ start size) (+ first bits)))
+                                     pos)))
+                    (string-append
+                     " | ((" val " >> " (number->string shift)
+                     ") & ("
+                     (number->string (- (integer-expt 2 bits) 1))
+                     " << " (number->string pos) "))")))
+                  groups))
+     ")"))
+)
+
+; Convert decoder table into C code.
+
+; Return code for one insn entry.
+; REST is the remaining entries.
+
+(define (-gen-decode-insn-entry entry rest indent)
+  (assert (eq? 'insn (dtable-entry-type entry)))
+  (logit 3 "Generating decode insn entry for " (obj:name (dtable-entry-value entry)) " ...\n")
+
+  (let ((insn (dtable-entry-value entry)))
+
+    (cond
+
+     ; Leave invalids to the default case.
+     ((eq? (obj:name insn) 'x-invalid)
+      "")
+
+     ; If same contents as next case, fall through.
+     ; FIXME: Can reduce more by sorting cases.  Much later.
+     ((and (not (null? rest))
+          ; Ensure both insns.
+          (eq? 'insn (dtable-entry-type (car rest)))
+          ; Ensure same insn.
+          (eq? (obj:name insn)
+               (obj:name (dtable-entry-value (car rest)))))
+      (string-append indent "  case "
+                    (number->string (dtable-entry-index entry))
+                    " : /* fall through */\n"))
+
+     (else
+      (string-append indent "  case "
+                    (number->string (dtable-entry-index entry))
+                    " : itype = "
+                    (gen-cpu-insn-enum (current-cpu) insn)
+                    "; "
+                    (if (with-scache?)
+                        (string-append "goto "
+                                       "extract_"
+                                       (gen-sym (insn-sfmt insn))
+                                       ";\n")
+                        "goto done;\n")))))
+)
+
+; Subroutine of -decode-expr-ifield-tracking.
+; Return a list of all possible values for ifield IFLD-NAME.
+; FIXME: Quick-n-dirty implementation.  Should use bit arrays.
+
+(define (-decode-expr-ifield-values ifld-name)
+  (let* ((ifld (current-ifld-lookup ifld-name))
+        (bits (ifld-length ifld)))
+    (if (mode-unsigned? (ifld-mode ifld))
+       (iota (logsll 1 bits))
+       (iota (- (logsll 1 (- bits 1))) (logsll 1 bits))))
+)
+
+; Subroutine of -decode-expr-ifield-tracking,-decode-expr-ifield-mark-used.
+; Create the search key for tracking table lookup.
+
+(define (-decode-expr-ifield-tracking-key insn ifld-name)
+  (symbol-append (obj:name (insn-ifmt insn)) '-x- ifld-name)
+)
+
+; Subroutine of -gen-decode-expr-entry.
+; Return a table to track used ifield values.
+; The table is an associative list of (key . value-list).
+; KEY is "iformat-name-x-ifield-name".
+; VALUE-LIST is a list of the unused values.
+
+(define (-decode-expr-ifield-tracking expr-list)
+  (let ((table1
+        (apply append
+               (map (lambda (entry)
+                      (map (lambda (ifld-name)
+                             (cons (exprtable-entry-insn entry)
+                                   (cons ifld-name
+                                         (-decode-expr-ifield-values ifld-name))))
+                           (exprtable-entry-iflds entry)))
+                    expr-list))))
+    ; TABLE1 is a list of (insn ifld-name value1 value2 ...).
+    (nub (map (lambda (elm)
+               (cons
+                (-decode-expr-ifield-tracking-key (car elm) (cadr elm))
+                (cddr elm)))
+             table1)
+        car))
+)
+
+; Subroutine of -decode-expr-ifield-mark-used!.
+; Return list of values completely used for ifield IFLD-NAME in EXPR.
+; "completely used" here means the value won't appear elsewhere.
+; e.g. in (andif (eq f-rd 15) (eq f-rx 14)) we don't know what happens
+; for the (ne f-rx 14) case.
+
+(define (-decode-expr-ifield-values-used ifld-name expr)
+  (case (rtx-name expr)
+    ((eq)
+     (if (and (rtx-kind? 'ifield (rtx-cmp-op-arg expr 0))
+             (rtx-constant? (rtx-cmp-op-arg expr 1)))
+        (list (rtx-constant-value (rtx-cmp-op-arg expr 1)))
+        nil))
+    ((member)
+     (if (rtx-kind? 'ifield (rtx-member-value expr))
+        (rtx-member-set expr)
+        nil))
+    ; FIXME: more needed
+    (else nil))
+)
+
+; Subroutine of -gen-decode-expr-entry.
+; Mark ifield values used by EXPR-ENTRY in TRACKING-TABLE.
+
+(define (-decode-expr-ifield-mark-used! tracking-table expr-entry)
+  (let ((insn (exprtable-entry-insn expr-entry))
+       (expr (exprtable-entry-expr expr-entry))
+       (ifld-names (exprtable-entry-iflds expr-entry)))
+    (for-each (lambda (ifld-name)
+               (let ((table-entry
+                      (assq (-decode-expr-ifield-tracking-key insn ifld-name)
+                            tracking-table))
+                     (used (-decode-expr-ifield-values-used ifld-name expr)))
+                 (for-each (lambda (value)
+                             (delq! value table-entry))
+                           used)
+                 ))
+             ifld-names))
+  *UNSPECIFIED*
+)
+
+; Subroutine of -gen-decode-expr-entry.
+; Return code to set `itype' and branch to the extraction phase.
+
+(define (-gen-decode-expr-set-itype indent insn-enum fmt-name)
+  (string-append
+   indent
+   "{ itype = "
+   insn-enum
+   "; "
+   (if (with-scache?)
+       (string-append "goto "
+                     "extract_"
+                     fmt-name
+                     ";")
+       "goto done;")
+   " }\n"
+   )
+)
+
+; Generate code to decode the expression table in ENTRY.
+; INVALID-INSN is the <insn> object of the pseudo insn to handle invalid ones.
+
+(define (-gen-decode-expr-entry entry indent invalid-insn)
+  (assert (eq? 'expr (dtable-entry-type entry)))
+  (logit 3 "Generating decode expr entry for " (exprtable-name (dtable-entry-value entry)) " ...\n")
+
+  (let ((expr-list (exprtable-insns (dtable-entry-value entry))))
+    (string-list
+     indent "  case "
+     (number->string (dtable-entry-index entry))
+     " :\n"
+
+     (let ((iflds-tracking (-decode-expr-ifield-tracking expr-list))
+          (indent (string-append indent "    ")))
+
+       (let loop ((expr-list expr-list) (code nil))
+
+        (if (null? expr-list)
+
+            ; All done.  If we used up all field values we don't need to
+            ; "fall through" and select the invalid insn marker.
+
+            (if (all-true? (map null? (map cdr iflds-tracking)))
+                code
+                (append! code
+                         (list
+                          (-gen-decode-expr-set-itype
+                           indent
+                           (gen-cpu-insn-enum (current-cpu) invalid-insn)
+                           "sfmt_empty"))))
+
+            ; Not all done, process next expr.
+
+            (let ((insn (exprtable-entry-insn (car expr-list)))
+                  (expr (exprtable-entry-expr (car expr-list)))
+                  (ifld-names (exprtable-entry-iflds (car expr-list))))
+
+              ; Mark of those ifield values we use first.
+              ; If there are none left afterwards, we can unconditionally
+              ; choose this insn.
+              (-decode-expr-ifield-mark-used! iflds-tracking (car expr-list))
+
+              (let ((next-code
+                     ; If this is the last expression, and it uses up all
+                     ; remaining ifield values, there's no need to perform any
+                     ; test.
+                     (if (and (null? (cdr expr-list))
+                              (all-true? (map null? (map cdr iflds-tracking))))
+
+                         ; Need this in a list for a later append!.
+                         (string-list
+                          (-gen-decode-expr-set-itype
+                           indent
+                           (gen-cpu-insn-enum (current-cpu) insn)
+                           (gen-sym (insn-sfmt insn))))
+
+                         ; We don't use up all ifield values, so emit a test.
+                          (let ((iflds (map current-ifld-lookup ifld-names)))
+                            (string-list
+                             indent "{\n"
+                             (gen-define-ifields iflds
+                                                 (insn-length insn)
+                                                 (string-append indent "  ")
+                                                 #f)
+                             (gen-extract-ifields iflds
+                                                  (insn-length insn)
+                                                  (string-append indent "  ")
+                                                  #f)
+                             indent "  if ("
+                             (rtl-c 'BI expr nil #:ifield-var? #t)
+                             ")\n"
+                             (-gen-decode-expr-set-itype
+                              (string-append indent "    ")
+                              (gen-cpu-insn-enum (current-cpu) insn)
+                              (gen-sym (insn-sfmt insn)))
+                             indent "}\n")))))
+
+                (loop (cdr expr-list)
+                      (append! code next-code)))))))
+     ))
+)
+
+; Generate code to decode TABLE.
+; REST is the remaining entries.
+; SWITCH-NUM, STARTBIT, DECODE-BITSIZE, INDENT, LSB0?, INVALID-INSN are same
+; as for -gen-decoder-switch.
+
+(define (-gen-decode-table-entry table rest switch-num startbit decode-bitsize indent lsb0? invalid-insn)
+  (assert (eq? 'table (dtable-entry-type table)))
+  (logit 3 "Generating decode table entry for case " (dtable-entry-index table) " ...\n")
+
+  (string-list
+   indent "  case "
+   (number->string (dtable-entry-index table))
+   " :"
+   ; If table is same as next, just emit a "fall through" to cut down on
+   ; generated code.
+   (if (and (not (null? rest))
+           ; Ensure both tables.
+           (eq? 'table (dtable-entry-type (car rest)))
+           ; Ensure same table.
+           (eqv? (subdtable-key (dtable-entry-value table))
+                 (subdtable-key (dtable-entry-value (car rest)))))
+       " /* fall through */\n"
+       (string-list
+       "\n"
+       (-gen-decoder-switch switch-num
+                            startbit
+                            decode-bitsize
+                            (subdtable-table (dtable-entry-value table))
+                            (string-append indent "    ")
+                            lsb0?
+                            invalid-insn))))
+)
+
+; Subroutine of -decode-sort-entries.
+; Return a boolean indicating if A,B are equivalent entries.
+
+(define (-decode-equiv-entries? a b)
+  (let ((a-type (dtable-entry-type a))
+       (b-type (dtable-entry-type b)))
+    (if (eq? a-type b-type)
+       (case a-type
+         ((insn)
+          (let ((a-name (obj:name (dtable-entry-value a)))
+                (b-name (obj:name (dtable-entry-value b))))
+           (eq? a-name b-name)))
+         ((expr)
+          ; Ignore expr entries for now.
+          #f)
+         ((table)
+          (let ((a-name (subdtable-key (dtable-entry-value a)))
+                (b-name (subdtable-key (dtable-entry-value b))))
+            (eq? a-name b-name))))
+       ; A and B are not the same type.
+       #f))
+)
+
+; Subroutine of -gen-decoder-switch, sort ENTRIES according to desired
+; print order (maximizes amount of fall-throughs, but maintains numerical
+; order as much as possible).
+; ??? This is an O(n^2) algorithm.  An O(n Log(n)) algorithm can be done
+; but it seemed more complicated than necessary for now.
+
+(define (-decode-sort-entries entries)
+  (let ((find-equiv!
+        ; Return list of entries in non-empty list L that have the same decode
+        ; entry as the first entry.  Entries found are marked with #f so
+        ; they're not processed again.
+        (lambda (l)
+          ; Start off the result with the first entry, then see if the
+          ; remaining ones match it.
+          (let ((first (car l)))
+            (let loop ((l (cdr l)) (result (cons first nil)))
+              (if (null? l)
+                  (reverse! result)
+                  (if (and (car l) (-decode-equiv-entries? first (car l)))
+                      (let ((lval (car l)))
+                        (set-car! l #f)
+                        (loop (cdr l) (cons lval result)))
+                      (loop (cdr l) result)))))))
+       )
+    (let loop ((entries (list-copy entries)) (result nil))
+      (if (null? entries)
+         (apply append (reverse! result))
+         (if (car entries)
+             (loop (cdr entries)
+                   (cons (find-equiv! entries)
+                         result))
+             (loop (cdr entries) result)))))
+)
+
+; Generate switch statement to decode TABLE-GUTS.
+; SWITCH-NUM is for compatibility with the computed goto decoder and
+; isn't used.
+; STARTBIT is the bit offset of the instruction value that C variable `insn'
+; holds (note that this is independent of LSB0?).
+; DECODE-BITSIZE is the number of bits of the insn that `insn' holds.
+; LSB0? is non-#f if bit number 0 is the least significant bit.
+; INVALID-INSN is the <insn> object of the pseudo insn to handle invalid ones.
+
+(define (-gen-decoder-switch switch-num startbit decode-bitsize table-guts indent lsb0? invalid-insn)
+  ; For entries that are a single insn, we're done, otherwise recurse.
+
+  (string-list
+   indent "{\n"
+   ; Are we at the next word?
+   (if (not (= startbit (dtable-guts-startbit table-guts)))
+       (begin
+        (set! startbit (dtable-guts-startbit table-guts))
+        (set! decode-bitsize (dtable-guts-bitsize table-guts))
+        ; FIXME: Bits may get fetched again during extraction.
+        (string-append indent "  unsigned int val;\n"
+                       indent "  /* Must fetch more bits.  */\n"
+                       indent "  insn = "
+                       (gen-ifetch "pc" startbit decode-bitsize)
+                       ";\n"
+                       indent "  val = "))
+       (string-append indent "  unsigned int val = "))
+   (-gen-decode-bits (dtable-guts-bitnums table-guts)
+                    (dtable-guts-startbit table-guts)
+                    (dtable-guts-bitsize table-guts) "insn" lsb0?)
+   ";\n"
+   indent "  switch (val)\n"
+   indent "  {\n"
+
+   ; The code is more readable, and icache use is improved, if we collapse
+   ; common code into one case and use "fall throughs" for all but the last of
+   ; a set of common cases.
+   ; FIXME: We currently rely on -gen-decode-foo-entry to recognize the fall
+   ; through.  We should take care of it ourselves.
+
+   (let loop ((entries (-decode-sort-entries (dtable-guts-entries table-guts)))
+             (result nil))
+     (if (null? entries)
+        (reverse! result)
+        (loop
+         (cdr entries)
+         (cons (case (dtable-entry-type (car entries))
+                 ((insn)
+                  (-gen-decode-insn-entry (car entries) (cdr entries) indent))
+                 ((expr)
+                  (-gen-decode-expr-entry (car entries) indent invalid-insn))
+                 ((table)
+                  (-gen-decode-table-entry (car entries) (cdr entries)
+                                           switch-num startbit decode-bitsize
+                                           indent lsb0? invalid-insn))
+                 )
+               result))))
+
+   ; ??? Can delete if all cases are present.
+   indent "  default : itype = "
+   (gen-cpu-insn-enum (current-cpu) invalid-insn)
+   ";"
+   (if (with-scache?)
+       " goto extract_sfmt_empty;\n"
+       " goto done;\n")
+   indent "  }\n"
+   indent "}\n"
+   )
+)
+
+; Decoder generation entry point.
+; Generate code to decode INSN-LIST.
+; BITNUMS is the set of bits to initially key off of.
+; DECODE-BITSIZE is the number of bits of the instruction that `insn' holds.
+; LSB0? is non-#f if bit number 0 is the least significant bit.
+; INVALID-INSN is the <insn> object of the pseudo insn to handle invalid ones.
+
+(define (gen-decoder insn-list bitnums decode-bitsize indent lsb0? invalid-insn)
+  (logit 3 "Building decode tree.\n"
+        "bitnums = " (stringize bitnums " ") "\n"
+        "decode-bitsize = " (number->string decode-bitsize) "\n"
+        "lsb0? = " (if lsb0? "#t" "#f") "\n"
+        )
+
+  ; First build a table that decodes the instruction set.
+
+  (let ((table-guts (decode-build-table insn-list bitnums
+                                       decode-bitsize lsb0?
+                                       invalid-insn)))
+
+    ; Now print it out.
+
+    (-gen-decoder-switch "0" 0 decode-bitsize table-guts indent lsb0?
+                        invalid-insn)
+    )
+)
diff --git a/cgen/utils.scm b/cgen/utils.scm
new file mode 100644 (file)
index 0000000..84e871e
--- /dev/null
@@ -0,0 +1,1268 @@
+; Generic Utilities.
+; Copyright (C) 2000 Red Hat, Inc.
+; This file is part of CGEN.
+; See file COPYING.CGEN for details.
+
+; These utilities are neither object nor cgen centric.
+; They're generic, non application-specific utilities.
+; There are a few exceptions, keep them to a minimum.
+;
+; Conventions:
+; - the prefix "gen-" comes from cgen's convention that procs that return C
+;   code, and only those procs, are prefixed with "gen-"
+
+(define nil '())
+
+; Hobbit support code; for when not using hobbit.
+; FIXME: eliminate this stuff ASAP.
+
+(defmacro /fastcall-make (proc) proc)
+
+(defmacro fastcall4 (proc arg1 arg2 arg3 arg4)
+  (list proc arg1 arg2 arg3 arg4)
+)
+
+(defmacro fastcall5 (proc arg1 arg2 arg3 arg4 arg5)
+  (list proc arg1 arg2 arg3 arg4 arg5)
+)
+
+(defmacro fastcall6 (proc arg1 arg2 arg3 arg4 arg5 arg6)
+  (list proc arg1 arg2 arg3 arg4 arg5 arg6)
+)
+
+(defmacro fastcall7 (proc arg1 arg2 arg3 arg4 arg5 arg6 arg7)
+  (list proc arg1 arg2 arg3 arg4 arg5 arg6 arg7)
+)
+
+; ??? value doesn't matter too much here, just check if portable
+; Name was `UNSPECIFIED' but that conflicts with hobbit.
+(define *UNSPECIFIED* (if #f 1))
+
+; Define as global to avoid multiple copies in hobbit generated code.
+(define assert-fail-msg "assertion failure:")
+
+(defmacro assert (expr)
+  `(if (not ,expr)
+       (error assert-fail-msg ',expr))
+)
+
+(define verbose-level 0)
+
+(define (verbose-inc!)
+  (set! verbose-level (+ verbose-level 1))
+)
+
+(define (verbose? level) (>= verbose-level level))
+
+; Print to stderr, takes an arbitrary number of strings, possibly nested.
+
+(define message
+  (lambda args
+    (for-each (lambda (str)
+               (if (pair? str)
+                   (apply message str)
+                   (display str (current-error-port))))
+             args))
+)
+
+; Print a message if the verbosity level calls for it.
+; This is a macro as a bit of cpu may be spent computing args,
+; and we only want to spend it if the result will be printed.
+; Macro's can't be used in hobbit-compiled code, so instead there use:
+; (if (verbose? level) (message ...)).
+
+(defmacro logit (level . args)
+  `(if (>= verbose-level ,level) (message ,@args))
+)
+
+; Return a string of N spaces.
+
+(define (spaces n) (make-string n #\space))
+
+; Write N spaces to PORT, or the current output port if elided.
+
+(define (write-spaces n . port)
+  (let ((port (if (null? port) (current-output-port) (car port))))
+    (write (spaces n) port))
+)
+
+; Often used idiom.
+
+(define (string-map fn . args) (apply string-append (apply map (cons fn args))))
+
+; Collect a flat list of returned sublists from the lambda fn applied over args.
+
+(define (collect fn . args) (apply append (apply map (cons fn args))))
+
+
+; Map over value entries in an alist.
+; 'twould be nice if this were a primitive.
+
+(define (amap fn args)
+  (map fn (map cdr args))
+)
+
+; Like map but accept a proper or improper list.
+; An improper list is (a b c . d).
+; FN must be a proc of one argument.
+
+(define (map1-improper fn l)
+  (let ((result nil))
+    (let loop ((last #f) (l l))
+      (cond ((null? l)
+            result)
+           ((pair? l)
+            (if last
+                (begin
+                  (set-cdr! last (cons (fn (car l)) nil))
+                  (loop (cdr last) (cdr l)))
+                (begin
+                  (set! result (cons (fn (car l)) nil))
+                  (loop result (cdr l)))))
+           (else
+            (if last
+                (begin
+                  (set-cdr! last (fn l))
+                  result)
+                (fn l))))))
+)
+
+; Turn STR into a proper C symbol.
+; We assume STR has no leading digits.
+; All invalid characters are turned into '_'.
+; FIXME: Turn trailing "?" into "_p".
+
+(define (gen-c-symbol str)
+  (if (not (or (string? str) (symbol? str)))
+      (error "gen-c-symbol: not symbol or string:" str))
+  (map-over-string (lambda (c) (if (id-char? c) c #\_)) str)
+)
+
+; Turn STR into a proper file name, which is defined to be the same
+; as gen-c-symbol except use -'s instead of _'s.
+
+(define (gen-file-name str)
+  (if (not (or (string? str) (symbol? str)))
+      (error "gen-file-name: not symbol or string:" str))
+  (map-over-string (lambda (c) (if (id-char? c) c #\-)) str)
+)
+
+; Turn STR into lowercase.
+
+(define (string-downcase str)
+  (map-over-string (lambda (c) (char-downcase c)) str)
+)
+
+; Turn STR into uppercase.
+
+(define (string-upcase str)
+  (map-over-string (lambda (c) (char-upcase c)) str)
+)
+
+; Drop N chars from string S.
+; If N is negative, drop chars from the end.
+; It is ok to drop more characters than are in the string, the result is "".
+
+(define (string-drop n s)
+  (cond ((>= n (string-length s)) "")
+       ((< n 0) (substring s 0 (+ (string-length s) n)))
+       (else (substring s n (string-length s))))
+)
+
+; Drop the leading char from string S (assumed to have at least 1 char).
+
+(define (string-drop1 s)
+  (string-drop 1 s)
+)
+
+; Return the leading N chars from string STR.
+; This has APL semantics:
+; N > length: FILLER chars are appended
+; N < 0: take from the end of the string and prepend FILLER if necessary
+
+(define (string-take-with-filler n str filler)
+  (let ((len (string-length str)))
+    (if (< n 0)
+       (let ((n (- n)))
+         (string-append (if (> n len)
+                            (make-string (- n len) filler)
+                            "")
+                        (substring str (max 0 (- len n)) len)))
+       (string-append (substring str 0 (min len n))
+                      (if (> n len)
+                          (make-string (- n len) filler)
+                          ""))))
+)
+
+(define (string-take n str)
+  (string-take-with-filler n str #\space)
+)
+
+; Return the leading char from string S (assumed to have at least 1 char).
+
+(define (string-take1 s)
+  (substring s 0 1)
+)
+
+; Return the index of char C in string S or #f if not found.
+
+(define (string-index s c)
+  (let loop ((i 0))
+    (cond ((= i (string-length s)) #f)
+         ((char=? c (string-ref s i)) i)
+         (else (loop (1+ i)))))
+)
+
+; Cut string S into a list of strings using delimiter DELIM (a character).
+
+(define (string-cut s delim)
+  (let loop ((start 0)
+            (end 0)
+            (length (string-length s))
+            (result nil))
+    (cond ((= end length)
+          (if (> end start)
+              (reverse! (cons (substring s start end) result))
+              (reverse! result)))
+         ((char=? (string-ref s end) delim)
+          (loop (1+ end) (1+ end) length (cons (substring s start end) result)))
+         (else (loop start (1+ end) length result))))
+)
+
+; Convert a list of elements to a string, inserting DELIM (a string)
+; between elements.
+; L can also be a string or a number.
+
+(define (stringize l delim)
+  (cond ((string? l) l)
+       ((number? l) (number->string l))
+       ((symbol? l) (symbol->string l))
+       ((list? l)
+        (string-drop
+         (string-length delim)
+         (string-map (lambda (elm)
+                       (string-append delim
+                                      (stringize elm delim)))
+                     l)))
+       (else (error "stringize: can't handle:" l)))
+)
+\f
+; Output routines.
+
+; Extension to the current-output-port.
+; Only valid inside string-write.
+
+(define -current-print-state #f)
+
+; Create a print-state object.
+; This is written in portable Scheme so we don't use COS objects, etc.
+
+(define (make-print-state)
+  (vector 'print-state 0)
+)
+
+; print-state accessors.
+
+(define (pstate-indent pstate) (vector-ref pstate 1))
+(define (pstate-set-indent! pstate indent) (vector-set! pstate 1 indent))
+
+; Special print commands (embedded in args).
+
+(define (pstate-cmd? x) (and (vector? x) (eq? (vector-ref x 0) 'pstate)))
+
+;(define /endl (vector 'pstate '/endl)) ; ??? needed?
+(define /indent (vector 'pstate '/indent))
+(define (/indent-set n) (vector 'pstate '/indent-set n))
+(define (/indent-add n) (vector 'pstate '/indent-add n))
+
+; Process a pstate command.
+
+(define (pstate-cmd-do pstate cmd)
+  (assert (pstate-cmd? cmd))
+  (case (vector-ref cmd 1)
+    ((/endl)
+     "\n")
+    ((/indent)
+     (let ((indent (pstate-indent pstate)))
+       (string-append (make-string (quotient indent 8) #\tab)
+                     (make-string (remainder indent 8) #\space))))
+    ((/indent-set)
+     (pstate-set-indent! pstate (vector-ref cmd 2))
+     "")
+    ((/indent-add)
+     (pstate-set-indent! pstate (+ (pstate-indent pstate)
+                                  (vector-ref cmd 2)))
+     "")
+    (else
+     (error "unknown pstate command" (vector-ref cmd 1))))
+)
+
+; Write STRINGS to current-output-port.
+; STRINGS is a list of things to write.  Supported types are strings, symbols,
+; lists, procedures.  Lists are printed by applying string-write recursively.
+; Procedures are thunks that return the string to write.
+;
+; The result is the empty string.  This is for debugging where this
+; procedure is modified to return its args, rather than write them out.
+
+(define string-write
+  (lambda strings
+    (let ((pstate (make-print-state)))
+      (set! -current-print-state pstate)
+      (for-each (lambda (elm) (-string-write pstate elm))
+               strings)
+      (set! -current-print-state #f)
+      ""))
+)
+
+; Subroutine of string-write and string-write-map.
+
+(define (-string-write pstate expr)
+  (cond ((string? expr) (display expr)) ; not write, we want raw text
+       ((symbol? expr) (display expr))
+       ((procedure? expr) (-string-write pstate (expr)))
+       ((pstate-cmd? expr) (display (pstate-cmd-do pstate expr)))
+       ((list? expr) (for-each (lambda (x) (-string-write pstate x)) expr))
+       (else (error "string-write: bad arg:" expr)))
+  *UNSPECIFIED*
+)
+
+; Combination of string-map and string-write.
+
+(define (string-write-map proc arglist)
+  (let ((pstate -current-print-state))
+    (for-each (lambda (arg) (-string-write pstate (proc arg)))
+             arglist))
+  ""
+)
+
+; Build up an argument for string-write.
+
+(define string-list list)
+(define string-list-map map)
+
+; Subroutine of string-list->string.  Does same thing -string-write does.
+
+(define (-string-list-flatten pstate strlist)
+  (cond ((string? strlist) strlist)
+       ((symbol? strlist) strlist)
+       ((procedure? strlist) (-string-list-flatten pstate (strlist)))
+       ((pstate-cmd? strlist) (pstate-cmd-do pstate strlist))
+       ((list? strlist) (apply string-append
+                               (map (lambda (str)
+                                      (-string-list-flatten pstate str))
+                                    strlist)))
+       (else (error "string-list->string: bad arg:" strlist)))
+)
+
+; Flatten out a string list.
+
+(define (string-list->string strlist)
+  (-string-list-flatten (make-print-state) strlist)
+)
+\f
+; Prefix CHARS, a string of characters, with backslash in STR.
+; STR is either a string or list of strings (to any depth).
+; ??? Quick-n-dirty implementation.
+
+(define (backslash chars str)
+  (if (string? str)
+      ; quick check for any work to do
+      (if (any-true? (map (lambda (c)
+                           (string-index str c))
+                         (string->list chars)))
+         (let loop ((result "") (str str))
+           (if (= (string-length str) 0)
+               result
+               (loop (string-append result
+                                    (if (string-index chars (string-ref str 0))
+                                        "\\"
+                                        "")
+                                    (substring str 0 1))
+                     (substring str 1 (string-length str)))))
+         str)
+      ; must be a list
+      (if (null? str)
+         nil
+         (cons (backslash chars (car str))
+               (backslash chars (cdr str)))))
+)
+
+; Return a boolean indicating if S is bound to a value.
+;(define old-symbol-bound? symbol-bound?)
+;(define (symbol-bound? s) (old-symbol-bound? #f s))
+
+; Return a boolean indicating if S is a symbol and is bound to a value.
+
+(define (bound-symbol? s)
+  (and (symbol? s)
+       (or (symbol-bound? #f s)
+          ;(module-bound? cgen-module s)
+          ))
+)
+
+; Return X.
+
+(define (identity x) x)
+
+; Test whether X is a `form' (non-empty list).
+; ??? Is `form' the right word to use here?
+; One can argue we should also test for a valid car.  If so, it's the
+; name that's wrong not the code (because the code is what I want).
+
+(define (form? x) (and (not (null? x)) (list? x)))
+
+; Return the number of arguments to ARG-SPEC, a valid argument list
+; of `lambda'.
+; The result is a pair: number of fixed arguments, varargs indicator (#f/#t).
+
+(define (num-args arg-spec)
+  (if (symbol? arg-spec)
+      '(0 . #t)
+      (let loop ((count 0) (arg-spec arg-spec))
+       (cond ((null? arg-spec) (cons count #f))
+             ((null? (cdr arg-spec)) (cons (+ count 1) #f))
+             ((pair? (cdr arg-spec)) (loop (+ count 1) (cdr arg-spec)))
+             (else (cons (+ count 1) #t)))))
+)
+
+; Return a boolean indicating if N args is ok to pass to a proc with
+; an argument specification of ARG-SPEC (a valid argument list of `lambda').
+
+(define (num-args-ok? n arg-spec)
+  (let ((processed-spec (num-args arg-spec)))
+    (and
+     ; Ensure enough fixed arguments.
+     (>= n (car processed-spec))
+     ; If more args than fixed args, ensure varargs.
+     (or (= n (car processed-spec))
+        (cdr processed-spec))))
+)
+
+; Take N elements from list L.
+; If N is negative, take elements from the end.
+; If N is larger than the length, the extra elements are NIL.
+; FIXME: incomplete
+; FIXME: list-tail has args reversed (we should conform)
+
+(define (list-take n l)
+  (let ((len (length l)))
+    (if (< n 0)
+       (list-tail l (+ len n))
+       (let loop ((result nil) (l l) (i 0))
+         (if (= i n)
+             (reverse! result)
+             (loop (cons (car l) result) (cdr l) (+ i 1))))))
+)
+
+; Drop N elements from list L.
+; FIXME: list-tail has args reversed (we should conform)
+
+(define (list-drop n l)
+  (let loop ((n n) (l l))
+    (if (> n 0)
+       (loop (- n 1) (cdr l))
+       l))
+)
+
+; Drop N elements from the end of L.
+; FIXME: list-tail has args reversed (we should conform)
+
+(define (list-tail-drop n l)
+  (reverse! (list-drop n (reverse l)))
+)
+
+; APL's +\ operation on a vector of numbers.
+
+(define (plus-scan l)
+  (letrec ((-plus-scan (lambda (l result)
+                        (if (null? l)
+                            result
+                            (-plus-scan (cdr l)
+                                        (cons (if (null? result)
+                                                  (car l)
+                                                  (+ (car l) (car result)))
+                                              result))))))
+    (reverse! (-plus-scan l nil)))
+)
+
+; Remove duplicate elements from sorted list L.
+; Currently supported elements are symbols (a b c) and lists ((a) (b) (c)).
+
+(define (remove-duplicates l)
+  (let loop ((l l) (result nil))
+    (cond ((null? l) (reverse! result))
+         ((null? result) (loop (cdr l) (cons (car l) result)))
+         ((equal? (car l) (car result)) (loop (cdr l) result))
+         (else (loop (cdr l) (cons (car l) result)))
+         )
+    )
+)
+
+; Return a boolean indicating if each element of list satisfies its
+; corresponding predicates.  The length of L must be equal to the length
+; of PREDS.
+
+(define (list-elements-ok? l preds)
+  (and (list? l)
+       (= (length l) (length preds))
+       (all-true? (map (lambda (pred elm) (pred elm)) preds l)))
+)
+
+; Remove duplicates from unsorted list L.
+; KEY-GENERATOR is a lambda that takes a list element as input and returns
+; an equal? key to use to determine duplicates.
+; The first instance in a set of duplicates is always used.
+; This is not intended to be applied to large lists with an expected large
+; result (where sorting the list first would be faster), though one could
+; add such support later.
+
+(define (nub l key-generator)
+  (let loop ((l l) (keys (map key-generator l)) (result nil))
+    (if (null? l)
+       (reverse! (map cdr result))
+       (if (assv (car keys) result)
+           (loop (cdr l) (cdr keys) result)
+           (loop (cdr l) (cdr keys) (acons (car keys) (car l)
+                                            result)))))
+)
+
+; Return a boolean indicating if list L1 is a subset of L2.
+; Uses memq.
+
+(define (subset? l1 l2)
+  (let loop ((l1 l1))
+    (if (null? l1)
+       #t
+       (if (memq (car l1) l2)
+           (loop (cdr l1))
+           #f)))
+)
+
+; Return intersection of two lists.
+
+(define (intersection l1 l2)
+  (cond ((null? l1) l1)
+       ((null? l2) l2)
+       ((memq (car l1) l2) (cons (car l1) (intersection (cdr l1) l2)))
+       (else (intersection (cdr l1) l2)))
+)
+
+; Return a count of the number of elements of list L1 that are in list L2.
+; Uses memq.
+
+(define (count-common l1 l2)
+  (let loop ((result 0) (l1 l1))
+    (if (null? l1)
+       result
+       (if (memq (car l1) l2)
+           (loop (+ result 1) (cdr l1))
+           (loop result (cdr l1)))))
+)
+
+; Remove duplicate elements from sorted alist L.
+; L must be sorted by name.
+
+(define (alist-nub l)
+  (let loop ((l l) (result nil))
+    (cond ((null? l) (reverse! result))
+         ((null? result) (loop (cdr l) (cons (car l) result)))
+         ((eq? (caar l) (caar result)) (loop (cdr l) result))
+         (else (loop (cdr l) (cons (car l) result)))
+         )
+    )
+)
+
+; Return a copy of alist L.
+
+(define (alist-copy l)
+  ; (map cons (map car l) (map cdr l)) ; simple way
+  ; presumably more efficient way (less cons cells created)
+  (map (lambda (elm)
+        (cons (car elm) (cdr elm)))
+       l)
+)
+
+; Return the order in which to select elements of L sorted by SORT-FN.
+; The result is origin 0.
+
+(define (sort-grade l sort-fn)
+  (let ((sorted (sort (map cons (iota (length l)) l)
+                     (lambda (a b) (sort-fn (cdr a) (cdr b))))))
+    (map car sorted))
+)
+
+; Return ALIST sorted on the name in ascending order.
+
+(define (alist-sort alist)
+  (sort alist
+       (lambda (a b)
+         (string<? (symbol->string (car a))
+                   (symbol->string (car b)))))
+)
+
+; Return a boolean indicating if C is a leading id char.
+; '@' is treated as an id-char as it's used to delimit something that
+; sed will alter.
+
+(define (leading-id-char? c)
+  (or (char-alphabetic? c)
+      (char=? c #\_)
+      (char=? c #\@))
+)
+
+; Return a boolean indicating if C is an id char.
+; '@' is treated as an id-char as it's used to delimit something that
+; sed will alter.
+
+(define (id-char? c)
+  (or (leading-id-char? c)
+      (char-numeric? c))
+)
+
+; Return the length of the identifier that begins S.
+; Identifiers are any of letter, digit, _, @.
+; The first character must not be a digit.
+; ??? The convention is to use "-" between cgen symbols, not "_".
+; Try to handle "-" here as well.
+
+(define (id-len s)
+  (if (leading-id-char? (string-ref s 0))
+      (let ((len (string-length s)))
+       (let loop ((n 0))
+         (if (and (< n len)
+                  (id-char? (string-ref s n)))
+             (loop (1+ n))
+             n)))
+      0)
+)
+
+; Return number of characters in STRING until DELIMITER.
+; Returns #f if DELIMITER not present.
+; FIXME: Doesn't yet support \-prefixed delimiter (doesn't terminate scan).
+
+(define (chars-until-delimiter string delimiter)
+  (let loop ((str string) (result 0))
+    (cond ((= (string-length str) 0)
+          #f)
+         ((char=? (string-ref str 0) delimiter)
+          result)
+         (else (loop (string-drop1 str) (1+ result)))))
+)
+
+; Apply FN to each char of STR.
+
+(define (map-over-string fn str)
+  (do ((tmp (string-copy (if (symbol? str) (symbol->string str) str)))
+       (i (- (string-length str) 1) (- i 1)))
+      ((< i 0) tmp)
+    (string-set! tmp i (fn (string-ref tmp i)))
+    )
+)
+
+; Return a range.
+; It must be distinguishable from a list of numbers.
+
+(define (minmax min max) (cons min max))
+
+; Move VALUE of LENGTH bits to position START in a word of SIZE bits.
+; LSB0? is non-#f if bit numbering goes LSB->MSB.
+; Otherwise it goes MSB->LSB.
+; START-LSB? is non-#f if START denotes the least significant bit.
+; Otherwise START denotes the most significant bit.
+; N is assumed to fit in the field.
+
+(define (word-value start length size lsb0? start-lsb? value)
+  (if lsb0?
+      (if start-lsb?
+         (logsll value start)
+         (logsll value (+ (- start length) 1)))
+      (if start-lsb?
+         (logsll value (- size start 1))
+         (logsll value (- size (+ start length)))))
+)
+
+; Return a bit mask of LENGTH bits in a word of SIZE bits starting at START.
+; LSB0? is non-#f if bit numbering goes LSB->MSB.
+; Otherwise it goes MSB->LSB.
+; START-LSB? is non-#f if START denotes the least significant bit.
+; Otherwise START denotes the most significant bit.
+
+(define (word-mask start length size lsb0? start-lsb?)
+  (if lsb0?
+      (if start-lsb?
+         (logsll (mask length) start)
+         (logsll (mask length) (+ (- start length) 1)))
+      (if start-lsb?
+         (logsll (mask length) (- size start 1))
+         (logsll (mask length) (- size (+ start length)))))
+)
+
+; Extract LENGTH bits at bit number START in a word of SIZE bits from VALUE.
+; LSB0? is non-#f if bit numbering goes LSB->MSB.
+; Otherwise it goes MSB->LSB.
+; START-LSB? is non-#f if START denotes the least significant bit.
+; Otherwise START denotes the most significant bit.
+;
+; ??? bit-extract takes a big-number argument but still uses logand
+; which doesn't so we don't use it
+
+(define (word-extract start length size lsb0? start-lsb? value)
+  (if lsb0?
+      (if start-lsb?
+         (remainder (logslr value start) (integer-expt 2 length))
+         (remainder (logslr value (+ (- start length) 1)) (integer-expt 2 length)))
+      (if start-lsb?
+         (remainder (logslr value (- size start 1)) (integer-expt 2 length))
+         (remainder (logslr value (- size (+ start length))) (integer-expt 2 length))))
+)
+
+; Return a bit mask of size SIZE beginning at the LSB.
+
+(define (mask size)
+  (- (logsll 1 size) 1)
+)
+
+; Split VAL into pieces of bit size LENGTHS.
+; e.g. (split-bits '(8 2) 997) -> (229 3)
+; There are as many elements in the result as there are in LENGTHS.
+; Note that this can result in a loss of information.
+
+(define (split-bits lengths val)
+  (letrec ((split1
+           (lambda (lengths val result)
+             (if (null? lengths)
+                 result
+                 (split1 (cdr lengths)
+                         (quotient val (integer-expt 2 (car lengths)))
+                         (cons (remainder val (integer-expt 2 (car lengths)))
+                               result))))))
+    (reverse! (split1 lengths val nil)))
+)
+
+; Generalized version of split-bits.
+; e.g. (split-value '(10 10 10) 1234) -> (4 3 2 1) ; ??? -> (1 2 3 4) ?
+; (split-value '(10 10) 1234) -> (4 3)
+; There are as many elements in the result as there are in BASES.
+; Note that this can result in a loss of information.
+
+(define (split-value bases val)
+  (letrec ((split1
+           (lambda (bases val result)
+             (if (null? bases)
+                 result
+                 (split1 (cdr bases)
+                         (quotient val (car bases))
+                         (cons (remainder val (car bases))
+                               result))))))
+    (reverse! (split1 bases val nil)))
+)
+
+; Convert bits to bytes.
+
+(define (bits->bytes bits) (quotient (+ 7 bits) 8))
+
+; Convert bytes to bits.
+
+(define (bytes->bits bytes) (* bytes 8))
+
+; Return a list of integers.
+; ARGS is either a list of one integer (N) meaning return a list from 0 to N-1,
+; or a list of two integers (START N) meaning return a list from START to
+; START+N-1.
+; FIXME: change to (iota n . start).
+
+(define (iota . args)
+  (case (length args)
+    ((1) (let loop ((n (car args)) (z nil))
+          (if (<= n 0) z (loop (1- n) (cons (1- n) z)))))
+    ((2) (let ((start (car args)))
+          (let loop ((n (cadr args)) (z nil))
+            (if (<= n 0) z (loop (1- n) (cons (+ start (1- n)) z))))))
+    (else (error "iota: wrong number of arguments:" args)))
+)
+
+; Return a list of the first N powers of 2.
+
+(define (powers-of-2 n)
+  (cond ((= n 0) nil)
+       (else (cons (integer-expt 2 (1- n)) (powers-of-2 (1- n))))
+       )
+  ; Another way: (map (lambda (n) (ash 1 n)) (iota n))
+)
+
+; I'm tired of writing (not (= foo bar)).
+
+(define (!= a b) (not (= a b)))
+
+; Return #t if BIT-NUM (which is starting from LSB), is set in the binary
+; representation of non-negative integer N.
+
+(define (bit-set? n bit-num)
+  ; ??? Quick hack to work around missing bignum support.
+  ;(= 1 (cg-logand (logslr n bit-num) 1))
+  (if (>= n #x20000000)
+      (if (>= bit-num 16)
+         (logbit? (- bit-num 16) (logslr n 16))
+         (logbit? bit-num (remainder n 65536)))
+      (logbit? bit-num n))
+)
+
+; Return #t if each element of bools is #t.  Since Scheme considers any
+; non-#f value as #t we do too.
+; (all-true? ()) is #t since that is the identity element.
+
+(define (all-true? bools)
+  (cond ((null? bools) #t)
+       ((car bools) (all-true? (cdr bools)))
+       (else #f))
+)
+
+; Return #t if any element of BOOLS is #t.
+; If BOOLS is empty, return #f.
+
+(define (any-true? bools)
+  (cond ((null? bools) #f)
+       ((car bools) #t)
+       (else (any-true? (cdr bools))))
+)
+
+; Return count of true values.
+
+(define (count-true flags)
+  (let loop ((result 0) (flags flags))
+    (if (null? flags)
+       result
+       (loop (+ result (if (car flags) 1 0))
+             (cdr flags))))
+)
+
+; Return count of all ones in BITS.
+
+(define (count-bits bits)
+  (let loop ((result 0) (bits bits))
+    (if (= bits 0)
+       result
+       (loop (+ result (remainder bits 2)) (quotient bits 2))))
+)
+
+; Convert bits in N #f/#t.
+; LENGTH is the length of N in bits.
+
+(define (bits->bools n length)
+  (do ((result (make-list length #f))
+       (i 0 (+ i 1)))
+      ((= i length) (reverse! result))
+    (list-set! result i (if (bit-set? n i) #t #f))
+    )
+)
+
+; Print a C integer.
+
+(define (gen-integer val)
+  (cond ((and (<= #x-80000000 val) (> #x80000000 val))
+        (number->string val))
+       ((and (<= #x80000000 val) (>= #xffffffff val))
+        ; ??? GCC complains if not affixed with "U" but that's not k&r.
+        ;(string-append (number->string val) "U"))
+        (string-append "0x" (number->string val 16)))
+       (else (error "Number too large for gen-integer:" val)))
+)
+
+; Return higher/lower part of double word integer.
+
+(define (high-part val)
+  (logslr val 32)
+)
+(define (low-part val)
+  (remainder val #x100000000)
+)
+
+; Logical operations.
+
+(define (logslr val shift) (ash val (- shift)))
+(define logsll ash) ; (logsll val shift) (ash val shift))
+; logand, logior, logxor defined by guile so we don't need to
+; (define (logand a b) ...)
+; (define (logxor a b) ...)
+; (define (logior a b) ...)
+;
+; On the other hand they didn't support bignums, so the cgen-binary
+; defines cg-log* that does.  These are just a quick hack that only
+; handle what currently needs handling.
+
+(define (cg-logand a b)
+  (if (or (>= a #x20000000)
+         (>= b #x20000000))
+      (+ (logsll (logand (logslr a 16) (logslr b 16)) 16)
+        (logand (remainder a 65536) (remainder b 65536)))
+      (logand a b))
+)
+
+(define (cg-logxor a b)
+  (if (or (>= a #x20000000)
+         (>= b #x20000000))
+      (+ (logsll (logxor (logslr a 16) (logslr b 16)) 16)
+        (logxor (remainder a 65536) (remainder b 65536)))
+      (logxor a b))
+)
+
+; Return list of bit values for the 1's in X.
+
+(define (bit-vals x)
+  (let loop ((result nil) (mask 65536))
+    (cond ((= mask 0) result)
+         ((> (logand x mask) 0) (loop (cons mask result) (logslr mask 1)))
+         (else (loop result (logslr mask 1)))))
+)
+
+; Return bit representation of N in LEN bits.
+; e.g. (bit-rep 6 3) -> (1 1 0)
+
+(define (bit-rep n len)
+  (cond ((= len 0) nil)
+       ((> (logand n (logsll 1 (- len 1))) 0)
+        (cons 1 (bit-rep n (- len 1))))
+       (else (cons 0 (bit-rep n (- len 1))))))
+
+; Return list of all bit values from 0 to N.
+; e.g. (bit-patterns 3) -> ((0 0 0) (0 0 1) (0 1 0) ... (1 1 1))
+
+(define (bit-patterns len)
+  (map (lambda (x) (bit-rep x len)) (iota (logsll 1 len)))
+)
+
+; Compute the list of all indices from bits missing in MASK.
+; e.g. (missing-bit-indices #xff00 #xffff) -> (0 1 2 3 ... 255)
+;
+; Hobbit emits two functions named `missing_bit_indices_fn31' for this.
+;(define (missing-bit-indices mask full-mask)
+;  (let* ((bitvals (bit-vals (logxor mask full-mask)))
+;       (selectors (bit-patterns (length bitvals))))
+;    (map (lambda (sel) (apply + (map * sel bitvals))) selectors))
+;)
+; So it's rewritten to this ...
+
+(define (missing-bit-indices mask full-mask)
+  (let* ((bitvals (bit-vals (logxor mask full-mask)))
+        (selectors (bit-patterns (length bitvals)))
+        (map-star (lambda (sel) (map * sel bitvals)))
+        (compute-indices (lambda (sel) (apply + (map-star sel)))))
+    (map compute-indices selectors))
+)
+
+; Convert a list of numbers to a string, separated by SEP.
+; The result is prefixed by SEP too.
+
+(define (numbers->string nums sep)
+  (string-map (lambda (elm) (string-append sep (number->string elm))) nums)
+)
+
+; Convert a number to a hex string.
+
+(define (number->hex num)
+  (number->string num 16)
+)
+
+; Given a list of numbers NUMS, generate text to pass them as arguments to a
+; C function.  We assume they're not the first argument and thus have a
+; leading comma.
+
+(define (gen-int-args nums)
+  (numbers->string nums ", ")
+)
+
+; Given a C expression or a list of C expressions, return a comma separated
+; list of them.
+; In the case of more than 0 elements the leading ", " is present so that
+; there is no edge case in the case of 0 elements when the caller is appending
+; the result to an initial set of arguments (the number of commas equals the
+; number of elements).  The caller is responsible for dropping the leading
+; ", " if necessary.  Note that `string-drop' can handle the case where more
+; characters are dropped than are present.
+
+(define (gen-c-args exprs)
+  (cond ((null? exprs) "")
+       ((pair? exprs) (string-map (lambda (elm) (string-append ", " elm))
+                                  exprs))
+       ((equal? exprs "") "")
+       (else (string-append ", " exprs)))
+)
+
+; Return a list of N macro argument names.
+
+(define (macro-args n)
+  (map (lambda (i) (string-append "a" (number->string i)))
+       (map 1+ (iota n)))
+)
+
+; Return C code for N macro argument names.
+; (gen-macro-args 4) -> ", a1, a2, a3, a4"
+
+(define (gen-macro-args n)
+  (gen-c-args (macro-args n))
+)
+
+; Return a string to reference an array.
+; INDICES is either a (possibly empty) list of indices or a single index.
+; The values can either be numbers or strings (/symbols).
+
+(define (gen-array-ref indices)
+  (let ((gen-index (lambda (idx)
+                    (string-append "["
+                                   (cond ((number? idx) (number->string idx))
+                                         (else idx))
+                                   "]"))))
+    (cond ((null? indices) "")
+         ((pair? indices) ; list of indices?
+          (string-map gen-index indices))
+         (else (gen-index indices))))
+)
+
+; Return list element N or #f if list L is too short.
+
+(define (list-maybe-ref l n)
+  (if (> (length l) n)
+      (list-ref l n)
+      #f)
+)
+
+; Return list of index numbers of elements in list L that satisfy PRED.
+; I is usually 0.
+
+(define (find-index i pred l)
+  (define (find1 i pred l result)
+    (cond ((null? l) result)
+         ((pred (car l)) (find1 (+ 1 i) pred (cdr l) (cons i result)))
+         (else (find1 (+ 1 i) pred (cdr l) result))))
+  (reverse! (find1 i pred l nil))
+)
+
+; Return list of elements of L that satisfy PRED.
+
+(define (find pred l)
+  (define (find1 pred l result)
+    (cond ((null? l) result)
+         ((pred (car l)) (find1 pred (cdr l) (cons (car l) result)))
+         (else (find1 pred (cdr l) result))))
+  (reverse! (find1 pred l nil))
+)
+
+; Return first element of L that satisfies PRED or #f if there is none.
+
+(define (find-first pred l)
+  (cond ((null? l) #f)
+       ((pred (car l)) (car l))
+       (else (find-first pred (cdr l))))
+)
+
+; Return list of FN applied to elements of L that satisfy PRED.
+
+(define (find-apply fn pred l)
+  (cond ((null? l) nil)
+       ((pred (car l)) (cons (fn (car l)) (find-apply fn pred (cdr l))))
+       (else (find-apply fn pred (cdr l))))
+)
+
+; Given a list of lists L such that the first element in each list names the
+; entry, look up symbol S in that and return its index.  If not found,
+; return #f.
+; Eg: (lookup 'element2 '((element1 1) (element2 2)))
+; Granted, linear searching isn't efficient.  If it ever becomes a problem we
+; can do something about it then.
+; I is added to the result.
+
+(define (lookup-index s l i)
+  (cond ((null? l) #f)
+       ((eqv? s (caar l)) i)
+       (else (lookup-index s (cdr l) (1+ i))))
+)
+
+; Return the index of element ELM in list L or #f if not found.
+; If found, I is added to the result.
+; (Yes, in one sense I is present to simplify the implementation.  Sue me.)
+
+(define (element-lookup-index elm l i)
+  (cond ((null? l) #f)
+       ((equal? elm (car l)) i)
+       (else (element-lookup-index elm (cdr l) (1+ i))))
+)
+
+; Return #t if ELM is in ELM-LIST.
+
+(define (element? elm elm-list)
+  (->bool (member elm elm-list))
+)
+
+; Return the set of all possible combinations of elements in list L
+; according to the following rules:
+; - each element of L is either an atom (non-list) or a list
+; - each list element is (recursively) interpreted as a set of choices
+; - the result is a list of all possible combinations of elements
+;
+; Example: (list-expand '(a b (1 2 (3 4)) c (5 6)))
+; --> ((a b 1 c d 5)
+;      (a b 1 c d 6)
+;      (a b 2 c d 5)
+;      (a b 2 c d 6)
+;      (a b 3 c d 5)
+;      (a b 3 c d 6)
+;      (a b 4 c d 5)
+;      (a b 4 c d 6))
+
+(define (list-expand l)
+  #f ; ??? wip
+)
+
+; Given X, a number or symbol, reduce it to a constant if possible.
+; Numbers always reduce to themselves.
+; Symbols are reduced to a number if they're defined as such,
+; or to an enum constant if one exists; otherwise X is returned unchanged.
+; Requires: symbol-bound? enum-lookup-val
+
+(define (reduce x)
+  (if (number? x)
+      x
+      ; A symbol bound to a number?
+      (if (and (symbol? x) (symbol-bound? #f x) (number? (eval x)))
+         (eval x)
+         ; An enum value that has a known numeric value?
+         (let ((e (enum-lookup-val x)))
+           (if (number? (car e))
+               (car e)
+               ; Otherwise return X unchanged.
+               x))))
+)
+
+; If OBJ has a dump method call it, otherwise return OBJ untouched.
+
+(define (dump obj)
+  (if (method-present? obj 'dump)
+      (send obj 'dump)
+      obj)
+)
+\f
+; Copyright messages.
+
+; Pair of header,trailer parts of copyright.
+
+(define copyright-fsf
+  (cons "\
+THIS FILE IS MACHINE GENERATED WITH CGEN.
+
+Copyright (C) 1996, 1997, 1998, 1999 Free Software Foundation, Inc.
+"
+       "\
+This program 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, or (at your option)
+any later version.
+
+This program 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 this program; if not, write to the Free Software Foundation, Inc.,
+59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+"
+))
+
+; Pair of header,trailer parts of copyright.
+
+(define copyright-cygnus
+  (cons "\
+THIS FILE IS MACHINE GENERATED WITH CGEN.
+
+Copyright (C) 2000 Red Hat, Inc.
+"
+       "\
+"))
+
+; Set this to one of copyright-fsf, copyright-cygnus.
+
+(define CURRENT-COPYRIGHT copyright-fsf)
+
+; Packages.
+
+(define package-gnu-binutils-gdb "\
+This file is part of the GNU Binutils and/or GDB, the GNU debugger.
+")
+
+(define package-gnu-simulators "\
+This file is part of the GNU Simulators.
+")
+
+(define package-cygnus-simulators "\
+This file is part of the Cygnus Simulators.
+")
+
+; Return COPYRIGHT, with FILE-DESC as the first line
+; and PACKAGE as the name of the package which the file belongs in.
+; COPYRIGHT is a pair of (header . trailer).
+
+(define (gen-copyright file-desc copyright package)
+  (string-append "/* " file-desc "\n\n"
+                (car copyright)
+                "\n" package "\n"
+                (cdr copyright)
+                "\n*/\n\n")
+)
+\f
+; File operations.
+
+; Delete FILE, handling the case where it doesn't exist.
+
+(define (delete-file-noerr file)
+  ; This could also use file-exists?, but it's nice to have a few examples
+  ; of how to use `catch' lying around.
+  (catch 'system-error (lambda () (delete-file file))
+        (lambda args #f))
+)
+
+; Create FILE, point current-output-port to it, and call WRITE-FN.
+; FILE is always overwritten.
+; GEN-FN either writes output to stdout or returns the text to write,
+; the last thing we do is write the text returned by WRITE-FN to FILE.
+
+(define (file-write file write-fn)
+  (delete-file-noerr file)
+  (let ((left-over-text (with-output-to-file file write-fn)))
+    (let ((port (open-file file "a")))
+      (display left-over-text port)
+      (close-port port))
+    #t)
+)
+
+; Return the size in bytes of FILE.
+
+(define (file-size file)
+  (let ((stat (%stat file)))
+    (if stat
+       (vector-ref (%stat file) 7)
+       -1))
+)
+\f
+; Time operations.
+
+; Return the current time.
+; The result is a black box understood only by time-elapsed.
+
+(define (time-current) (gettimeofday))
+
+; Return the elapsed time in milliseconds since START.
+
+(define (time-elapsed start)
+  (let ((now (gettimeofday)))
+    (+ (* (- (car now) (car start)) 1000)
+       (quotient (- (cdr now) (cdr start)) 1000)))
+)
+
+; Run PROC and return the number of milliseconds it took to execute it N times.
+
+(define (time-proc n proc)
+  (let ((now (time-current)))
+    (do ((i 0 (+ i 1))) ((= i n) (time-elapsed now))
+      (proc)))
+)