Includes all unsupported compiler back ends; pcsample; rcs; sicp; swat; wabbit.
LIARC_BOOT_BUNDLES = compiler cref sf star-parser
LIARC_BUNDLES = $(LIARC_BOOT_BUNDLES) edwin ffi imail sos ssp xml
-SUBDIRS = $(INSTALLED_SUBDIRS) 6001 rcs win32 xdoc
+SUBDIRS = $(INSTALLED_SUBDIRS) 6001 win32 xdoc
INSTALLED_SUBDIRS = microcode runtime $(LIARC_BUNDLES)
MIT_SCHEME_EXE = @MIT_SCHEME_EXE@
* "6001" is extra code used here at MIT for teaching 6.001, our
introductory computer-science course based on "Structure and
- Interpretation of Computer Programs". "sicp" contains an older
- version of this code that is no longer in use (and probably no
- longer works).
+ Interpretation of Computer Programs".
* "etc" contains miscellaneous files for building the program.
-* "rcs" is a parser for RCS files. It also contains a program for
- generating merged log files, in RCS or ChangeLog format, for
- directory trees under RCS or CVS control.
-
* "ssp" is an implementation of "Scheme Server Pages" that supports
server-side web programming. It works in conjunction with Apache
and mod-lisp.
experimental electronics circuit course during spring term 2004.
This language is no longer in active use and will not be supported.
But it is a good example of "ssp" usage.
-
-These directories are no longer actively in use and the code they
-contain may not work:
-
-* "pcsample" contains a profiling extension.
-
-* "swat" contains an extension that interfaces MIT/GNU Scheme to the
- Tk graphical toolkit.
-
-* "wabbit" contains program for finding all of the objects that
- contain pointers to a given object.
\f
Building from source on unix systems
====================================
. etc/functions.sh
INSTALLED_SUBDIRS="cref edwin ffi imail sf sos ssp star-parser xml"
-OTHER_SUBDIRS="6001 compiler rcs runtime win32 xdoc microcode"
+OTHER_SUBDIRS="6001 compiler runtime win32 xdoc microcode"
# lib
maybe_mkdir lib
md5 \
mhash \
microcode \
- rcs \
runtime \
sf \
sos \
maybe_rm machines/svm/svm1-opcodes.scm
;;
esac
-
-case ${1} in
-maintainer-clean)
- for N in 1 2 3; do
- maybe_unlink machines/vax/dinstr${N}.scm instr${N}.scm
- done
- ;;
-esac
. ../etc/functions.sh
../etc/Setup.sh ${@:+"${@}"}
-
-for N in 1 2 3; do
- maybe_link machines/vax/dinstr${N}.scm instr${N}.scm
-done
+++ /dev/null
--*-Text-*-
-
- Installation Notes for Liar version 4.9
-
-
-Liar, the CScheme compiler, is available for the following computers:
-
- Sun 3
- HP 9000 series 300 (except model 310)
-
-These are 68020 based machines. Ports for 68000/68010 machines and
-the Vax will be available in the future.
-
-For bug reports send computer mail to
-
- BUG-LIAR@ZURICH.AI.MIT.EDU (on the Arpanet/Internet)
-
-or US Snail to
-
- Scheme Team
- c/o Prof. Hal Abelson
- 545 Technology Sq. rm 410
- Cambridge MA 02139
-
-* The compiler is distributed as four compressed tar files, as
-follows:
-
-** "dist6.2.1-tar.Z" is release 6.2.1 of CScheme. This is required
-for using the compiler. It is installed in the usual way except for
-one small change to the microcode needed to support compiled code.
-This tar file contains about 5.1 Mbyte of data when unloaded.
-
-** "liar4.9b-tar.Z" contains the binary files for the compiler. This
-includes a ".bin" file (SCode binary, for the interpreter) and a
-".com" file (native code compiler output) for each source file in the
-compiler. It also contains a few other files used to construct the
-compiler from the binary files. This tar file contains about 3 Mbyte
-of data when unloaded.
-
-** "liar4.9s-tar.Z" contains the source files for the compiler. It
-also includes a TAGS table. This tar file contains about 1.2 Mbyte of
-data when unloaded.
-
-** "liar4.9d-tar.Z" contains some debugging files. There is one
-".binf" file corresponding to each ".com" file in the compiler. Given
-both of these files, the compiler can generate a symbolic assembly
-language listing of the compiled code. In future releases, these
-debugging files will also support debugging tools for parsing the
-stack and examining compiled code environment structures. This tar
-file contains about 4.5 Mbyte of data when unloaded.
-\f
-* Installation of the compiler. Installation requires about 17-20
-Mbyte of disk space. This is conservative and could be reduced with
-some knowledge of what is needed and what is not.
-
-** The first step in installation is building CScheme. Follow the
-instructions included in the release, except that the file
-"makefiles/sun" or "makefiles/hp200" (as appropriate) must be edited
-as follows. Look for the following lines in that file:
-
- # Compiled code interface files.
- # These defaults are just stubs.
-
- CSRC = compiler.c
- CFILE = compiler.oo
- D_CFILE = compiler.do
- F_CFILE = compiler.fo
- CFLAG =
- GC_HEAD_FILES= gccode.h
-
-edit these lines to read as follows:
-
- # Compiled code interface files.
-
- CSRC = cmp68020.s
- CFILE = cmp68020.o
- D_CFILE = cmp68020.o
- F_CFILE = cmp68020.o
- CFLAG = -DCMPGCFILE=\"cmp68kgc.h\"
- GC_HEAD_FILES= gccode.h cmp68kgc.h
-
- .s.o: ; as -o $*.o $*.s
-
-After this is done, connect to the microcode subdirectory and execute
-the following
-
- cp cmp68020.s-<sys> cmp68020.s
-
-where <sys> is "sun" if you are running on a Sun 3, or "hp" if you are
-running on an HP 9000 series 300. NOTE: the file "cmp68020.s-src" is
-the source file from which the other two were built. It was processed
-by m4 on an HP machine to create "cmp68020.s-hp", then that file was
-processed by a custom conversion program (courtesy of the
-butterfly-lisp hackers at BBN) to produce "cmp68020.s-sun".
-
-Once these changes have been made, finish the installation process in
-the normal way.
-
-**** Note that on Sun workstations, assembling "cmp68020.s" will
-produce the following harmless warning messages:
-
-as: error (cmp68020.s:1432): Unqualified forward reference
-as: error (cmp68020.s:1435): Unqualified forward reference
-as: error (cmp68020.s:1444): Unqualified forward reference
-
-Also, on older versions of Sun software (before release 3.4) you may
-not be able to assemble this file at all. For that case, we have
-included the file "cmp68020.o-sun" which is the output of the
-assembler on a 3.4 system. Copy that file to "cmp68020.o" and touch
-it to make sure it is newer than the source file.
-\f
-** The next step in installation is unloading the Liar tar files. The
-tar files may be unloaded wherever you like. When unloaded, they will
-create a directory "liar4.9" under the directory to which you are
-connected.
-
-Note that only "liar4.9b-tar.Z" need be unloaded in order to perform
-the rest of the installation.
-
-In what follows, let $LIAR stand for the name of the directory in
-which the compiler is loaded, and let $SCHEME stand for the name of
-the directory in which the interpreter is loaded.
-
-** After having unloaded the files, and after CScheme has been built
-and installed, do the following:
-
- cd $SCHEME
- mv $LIAR/runtime/* runtime
- mv $LIAR/sf/* sf
- cd runtime
- scheme -fasl cmp-runmd.bin < $LIAR/etc/mkrun.scm
-
-This transfers a number of compiled files to the Scheme runtime system
-directory, and constructs a new version of the runtime system, named
-"scheme.com", which is partially compiled. After this has been done,
-you may discard all of the ".com" files in the runtime system
-directory. If you want the new runtime system to be the default,
-rename it to "scheme.bin".
-
-**** Note: because this is a beta release, the compiled runtime system
-"scheme.com" is likely to have bugs. If you intend to use it by
-default, we suggest you retain the original (interpreted) runtime
-system "scheme.bin" by renaming it to something else.
-
-** Next, do the following:
-
- scheme -constant 510 -heap 500 -band $SCHEME/runtime/scheme.com
-
-This starts up the scheme interpreter with a large constant space and
-heap, using the partially compiled runtime system. After the
-interpreter has started, type the following expression at it:
-
- (begin (%cd "$LIAR")
- (load "machines/bobcat/make" system-global-environment)
- (disk-save "$SCHEME/runtime/compiler.com"))
-
-it will load two files, then ask the question "Load compiled?". Type
-Y, which means to build the compiler using compiled code. If you type
-N, the compiler will be run interpretively, which is about a factor of
-10 slower than the compiled version.
-
-After you answer the question, it will load and evaluate approximately
-100 files. This will take several minutes. When it is done, you are
-returned to the interpreter. At this point, a new band will have been
-created, called "$SCHEME/runtime/compiler.com", which contains the
-compiler. All the other files in the $LIAR directory may be
-discarded, if you wish, since only "compiler.com" is needed to run the
-compiler.
-\f
-* Using the compiler.
-
-** Loading. The compiler band, "compiler.com", is used by starting
-Scheme and specifying that file using the "-band" option. You must
-also use the "-constant" option to specify that the constant space is
-at least 510, and it is recommended that the "-heap" be specified at
-least 500. For medium to large compilations, a heap size of 700 or
-more may be needed; at MIT we typically use 1000 to be safe.
-
-Alternatively, the switch "-compiler" specifies constant 510, heap
-500, and the compiler band.
-
-** Memory usage. Note that the total memory used by Scheme in this
-configuration is substantial! With a heap of 1000 and a constant
-space of 510, the memory used is (* 4 (+ 510 (* 2 1000))), or about 10
-Mbyte. For many computers this is a ridiculous figure, and Scheme
-will die a slow death due to paging. Using a heap of 500 reduces this
-to about 6 Mbytes, but that is still quite alot.
-
-For machines with small memories, using the `bchscheme' version of the
-microcode will be helpful. This program, which is made by connecting
-to "$SCHEME/microcode" and typing "make bchscheme", does its garbage
-collection to a disk file, thus requiring only one heap in the virtual
-address space. This reduces the overall memory requirements for the
-above examples to 6 Mbyte and 4 Mbyte, respectively. The savings of 4
-and 2 Mbytes (respective) will be allocated in the file system rather
-than in virtual memory.
-
-This may seem like a complicated way of doing virtual memory
-management, but in fact it performs significantly better than paging
-on machines with small amounts of RAM. This is because the GC
-algorithm uses the disk much more efficiently than the paging system
-will be able to.
-
-** Compilation. The following global definitions are available for
-calling the compiler:
-
-
-(COMPILE-BIN-FILE FILENAME #!OPTIONAL OUTPUT-FILENAME)
-
-Compiles a binary SCode file, producing a native code file. FILENAME
-should refer to a file which is the output of the SF program (see
-"$SCHEME/documentation/user.txt" for a description of SF). The type
-of the input file defaults to ".bin".
-
-OUTPUT-FILENAME, if given, is where to put the output file. If no
-output filename is given, the output filename defaults to the input
-filename, except with type ".com". If it is a directory specification
-(on unix, this means if it has a trailing "/"), then the output
-filename defaults as usual, except that it goes in that directory.
-
-This is similar to the operation of SF. Also, like SF, the input
-filename may be a list of filenames, in which case they are all
-compiled in order.
-\f
-
-(COMPILE-PROCEDURE PROCEDURE)
-
-Compiles a compound procedure, given as its argument, and returns a
-new procedure which is the compiled form. This does not perform side
-effects on the environment, so if one wished to compile MAP, for
-example, and install the compiled form, it would be necessary to say
-
- (set! map (compile-procedure map))
-
-
-(COMPILER:WRITE-LAP-FILE FILENAME)
-
-This procedure generates a "LAP" disassembly file (LAP stands for Lisp
-Assembly Program, a traditional name for assembly language written in
-a list notation) from the output of COMPILE-BIN-FILE. If filename is
-"foo", then it looks for "foo.com" and disassembles that, producing a
-file "foo.lap". If, in addition, the file "foo.binf" exists, it will
-use that information to produce a disassembly which contains symbolic
-names for all of the labels. This second form is extremely useful for
-debugging.
-
-
-(COMPILE-DIRECTORY DIRECTORY #!OPTIONAL OUTPUT-DIRECTORY FORCE?)
-
-Finds all of the ".bin" files in DIRECTORY whose corresponding ".com"
-files either do not exist or are older, and recompiles them.
-OUTPUT-DIRECTORY, if given, specifies a different directory to look in
-for the ".com" files. FORCE?, if given and not #F, means recompile
-even if the output files appear up to date.
-\f
-* Debugging compiled code. At present the debugging tools are
-practically nonexistent. What follows is a description of the lowest
-level support, which is clumsy to use but which is adequate if you
-have a moderate understanding of the compiled code. This is one of
-the prices of beta test! Before release we will have user-level
-debugging tools.
-
-There are two basic kinds of errors: fatal and non-fatal. Fatal
-errors are things like segmentation violations and bus errors, and
-when these occur the only method of debugging is to use an assembly
-language debugger such as `adb' or `gdb'. Debugging these errors is
-complicated and will not be described here.
-
-** Non-fatal errors can be debugged from Scheme. Here is the method:
-the file "$LIAR/etc/stackp.bin" contains a simple stack parser that
-will allow you to display the Scheme stack, and refer to any of the
-items in the stack by offset number. Loading this file (into the
-global environment, for example), defines two useful procedures:
-
-(RCD FILENAME) writes a file containing a description of the current
-stack. When an error has occurred, the current stack contains the
-continuation of the error, which is the information you want to see.
-Each line of the file contains an offset number and the printed
-representation of an object (the latter is truncated to fit on one
-line).
-
-(RCR OFFSET) returns the object corresponding to OFFSET from the
-current stack. Thus, after using RCD to see the stack, RCR will get
-you pointers to any of the objects.
-
-Given these procedures, you can look at the compiled code stack
-frames, and possibly (with some skill) figure out what is happening.
-\f
-** Compiled code objects manipulators. Another set of useful
-procedures, built into the runtime system and defined in the file
-"$SCHEME/runtime/ustruc.scm", will allow you to manipulate various
-compiled code objects:
-
-(COMPILED-PROCEDURE-ENTRY PROCEDURE) returns the entry point of the
-compiled procedure PROCEDURE. This entry point is an object whose
-type is COMPILED-EXPRESSION.
-
-(COMPILED-CODE-ADDRESS? OBJECT) is true of both COMPILED-EXPRESSION
-objects as well as COMPILER-RETURN-ADDRESS objects.
-
-(COMPILED-CODE-ADDRESS->BLOCK COMPILED-CODE-ADDRESS) returns the
-compiled code block to which that address refers. The procedure
-COMPILED-CODE-BLOCK/DEBUGGING-INFO will tell you the name of the
-".binf" file corresponding to that compiled code block, if the
-compiled code was generated by COMPILE-BIN-FILE.
-
-(COMPILED-CODE-ADDRESS->OFFSET COMPILED-CODE-ADDRESS) returns the
-offset, in bytes, of that address from the beginning of the compiled
-code block. NOTE: this offset is the SAME offset as that shown in the
-disassembly listing! Thus, given any compiled code address, you can
-figure out both what file it corresponds to, plus what label in the
-disassembly file it points at. This is the basic information you need
-to understand the stack.
-
-There are several other procedures defined for manipulating these
-objects -- see the source code for details. What follows is a brief
-description of the object formats to aid debugging.
-\f
-** Compiled Code Blocks. Compiled code blocks are "partially marked"
-vectors. The first part of a compiled code block is "non-marked",
-which means that the GC copies it but does not look through it for
-pointers. This part is used to hold the compiled code. The second
-part is "marked", and contains constants that are referred to by the
-compiled code. These constants are ordinary Scheme objects and must
-be traced by the GC in the usual way.
-
-The disassembly listing shows the compiled code block in the same
-format that it is laid out in memory, with offsets in bytes from the
-beginning of the block. The header of the block is 8 bytes, so the
-disassembly listing starts at offset 8. The code and constants
-sections are displayed separately, in slightly different formats.
-
-** Procedure Entry Points. The entry point of a procedure can be
-found in the LAP file by looking for a label with the same name as the
-procedure, concatenated with some positive integer. Unnamed lambda
-expressions will be lambda-<n> for some <n>. Closed procedures (i.e.
-those procedures which have an external representation) have two entry
-points, whose labels differ only in the concatenated integer. The
-first entry point is responsible for checking the number of arguments,
-and transfers control to the second entry point if that is correct.
-
-** Stack Frames. The normal stack frame for a closed procedure is
-constructed by pushing the return address, then all the arguments
-right to left, then the procedure. If the procedure has internal
-definitions, then these are pushed on the stack on top of that in some
-unspecified order. Internal procedures, when invoked, may either
-extend the closure's frame or create new frames. The rules for this
-are complicated and far beyond the scope of this document. However,
-two special types of stack pointers may be used when the closure's
-frame is extended.
-
-The first of these is a "static link". This is a pointer into the
-stack which is used when a sub-frame needs to refer to bindings in
-some parent frame, but the compiler was unable to determine where that
-parent frame was at compile time. The other type is a "dynamic link",
-which points to where the return address for the current procedure is
-located in the stack. Because of tail recursion considerations, the
-compiler cannot always determine this at compile time, and in those
-cases dynamic links are used. The dynamic link is normally kept in
-register A4, and pushed and popped off the stack at appropriate times.
-
-Note that internal procedures evaluate and push their arguments in a
-completely unspecified order. Thus if your program depends on the
-fact that the interpreter evaluates arguments from right to left, you
-might be screwed, since the compiler chooses whatever order seems most
-efficient or convenient.
The package structure of the compiler reflects the pass structure and
is specified in compiler/machines/port/comp.pkg, where port is the
-name of a machine (bobcat, vax, spectrum, mips, i386, alpha, etc.).
+name of a machine (i386, x86-64, C, svm, etc.).
The major packages are:
(COMPILER):
+++ /dev/null
-- Debug disassembler.
-
-- Update disassembler to match structure of others (not so many
- assignments in dassm2.).
-
-- Eliminate warning from lapgen about 64-bit constants.
-
-- Teach lapgen how to generate #x1A00000000010000 and similar things.
-
-- Add stack check option.
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Assembler Machine Dependencies
-;;; Package: (compiler assembler)
-
-(declare (usual-integrations))
-\f
-(let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form))))))
-
-(define-integrable maximum-padding-length
- ;; Instruction length is always a multiple of 32 bits
- 32)
-
-(define padding-string
- ;; Pad with `DIAG SCM' instructions
- (unsigned-integer->bit-string maximum-padding-length
- #b00010100010100110100001101001101))
-
-(define-integrable block-offset-width
- ;; Block offsets are always 16 bit words
- 16)
-
-(define-integrable maximum-block-offset
- ;; PC always aligned on halfword (32 bits) boundary.
- (- (expt 2 (1+ block-offset-width)) 4))
-
-(define (block-offset->bit-string offset start?)
- (unsigned-integer->bit-string block-offset-width
- (+ (quotient offset 2)
- (if start? 0 1))))
-
-(define (make-nmv-header n)
- (bit-string-append (unsigned-integer->bit-string scheme-datum-width n)
- nmv-type-string))
-
-(define nmv-type-string
- (unsigned-integer->bit-string scheme-type-width
- (ucode-type manifest-nm-vector)))
-
-(define (object->bit-string object)
- (bit-string-append
- (unsigned-integer->bit-string scheme-datum-width
- (careful-object-datum object))
- (unsigned-integer->bit-string scheme-type-width (object-type object))))
-
-;;; Machine dependent instruction order
-
-(define (instruction-initial-position block) 0)
-
-(define (instruction-insert! bits block position receiver)
- (let ((l (bit-string-length bits)))
- (bit-substring-move-right! bits 0 l block position)
- (receiver (+ position l))))
-
-(define (instruction-append x y)
- (bit-string-append x y))
-
-;;; end let-syntax
-)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-(declare (usual-integrations))
-\f
-;;;; Alpha coercions
-;;; Package: (compiler lap-syntaxer)
-
-;;; Coercion top level
-
-(define make-coercion
- (coercion-maker
- `((UNSIGNED . ,coerce-unsigned-integer)
- (SIGNED . ,coerce-signed-integer))))
-
-(define coerce-1-bit-unsigned (make-coercion 'UNSIGNED 1))
-(define coerce-2-bit-unsigned (make-coercion 'UNSIGNED 2))
-(define coerce-3-bit-unsigned (make-coercion 'UNSIGNED 3))
-(define coerce-5-bit-unsigned (make-coercion 'UNSIGNED 5))
-(define coerce-6-bit-unsigned (make-coercion 'UNSIGNED 6))
-(define coerce-7-bit-unsigned (make-coercion 'UNSIGNED 7))
-(define coerce-8-bit-unsigned (make-coercion 'UNSIGNED 8))
-(define coerce-11-bit-unsigned (make-coercion 'UNSIGNED 11))
-(define coerce-16-bit-unsigned (make-coercion 'UNSIGNED 16))
-(define coerce-26-bit-unsigned (make-coercion 'UNSIGNED 26))
-(define coerce-32-bit-unsigned (make-coercion 'UNSIGNED 32))
-
-(define coerce-14-bit-signed (make-coercion 'SIGNED 14))
-(define coerce-16-bit-signed (make-coercion 'SIGNED 16))
-(define coerce-21-bit-signed (make-coercion 'SIGNED 21))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Script to incrementally compile the compiler (from .bins)
-
-(fluid-let ((compiler:coalescing-constant-warnings? #f))
- (for-each compile-directory
- '("back"
- "base"
- "fggen"
- "fgopt"
- "machines/alpha"
- "rtlbase"
- "rtlgen"
- "rtlopt")))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Compiler Packaging
-\f
-(global-definitions "../runtime/runtime")
-(global-definitions "../sf/sf")
-
-(define-package (compiler)
- (files "base/switch"
- "base/object" ;tagged object support
- "base/enumer" ;enumerations
- "base/sets" ;set abstraction
- "base/mvalue" ;multiple-value support
- "base/scode" ;SCode abstraction
- "rtlbase/valclass" ;RTL: value classes
- "machines/alpha/machin" ;machine dependent stuff
- "back/asutl" ;back-end odds and ends
- "base/utils" ;odds and ends
-
- "base/cfg1" ;control flow graph
- "base/cfg2"
- "base/cfg3"
-
- "base/ctypes" ;CFG datatypes
-
- "base/rvalue" ;Right hand values
- "base/lvalue" ;Left hand values
- "base/blocks" ;rvalue: blocks
- "base/proced" ;rvalue: procedures
- "base/contin" ;rvalue: continuations
-
- "base/subprb" ;subproblem datatype
-
- "rtlbase/rgraph" ;program graph abstraction
- "rtlbase/rtlty1" ;RTL: type definitions
- "rtlbase/rtlty2" ;RTL: type definitions
- "rtlbase/rtlexp" ;RTL: expression operations
- "rtlbase/rtlcon" ;RTL: complex constructors
- "rtlbase/rtlreg" ;RTL: registers
- "rtlbase/rtlcfg" ;RTL: CFG types
- "rtlbase/rtlobj" ;RTL: CFG objects
- "rtlbase/regset" ;RTL: register sets
-
- "back/insseq" ;LAP instruction sequences
- )
- (parent ())
- (export ()
- compiler:analyze-side-effects?
- compiler:cache-free-variables?
- compiler:coalescing-constant-warnings?
- compiler:code-compression?
- compiler:compile-by-procedures?
- compiler:cse?
- compiler:default-top-level-declarations
- compiler:enable-integration-declarations?
- compiler:generate-lap-files?
- compiler:generate-range-checks?
- compiler:generate-rtl-files?
- compiler:generate-type-checks?
- compiler:implicit-self-static?
- compiler:intersperse-rtl-in-lap?
- compiler:noisy?
- compiler:open-code-flonum-checks?
- compiler:open-code-primitives?
- compiler:optimize-environments?
- compiler:package-optimization-level
- compiler:preserve-data-structures?
- compiler:show-phases?
- compiler:show-procedures?
- compiler:show-subphases?
- compiler:show-time-reports?
- compiler:use-multiclosures?)
- (import (runtime system-macros)
- ucode-primitive
- ucode-type)
- (import ()
- (scode/access-components access-components)
- (scode/access-environment access-environment)
- (scode/access-name access-name)
- (scode/access? access?)
- (scode/assignment-components assignment-components)
- (scode/assignment-name assignment-name)
- (scode/assignment-value assignment-value)
- (scode/assignment? assignment?)
- (scode/combination-components combination-components)
- (scode/combination-operands combination-operands)
- (scode/combination-operator combination-operator)
- (scode/combination? combination?)
- (scode/comment-components comment-components)
- (scode/comment-expression comment-expression)
- (scode/comment-text comment-text)
- (scode/comment? comment?)
- (scode/conditional-alternative conditional-alternative)
- (scode/conditional-components conditional-components)
- (scode/conditional-consequent conditional-consequent)
- (scode/conditional-predicate conditional-predicate)
- (scode/conditional? conditional?)
- (scode/constant? scode-constant?)
- (scode/declaration-components declaration-components)
- (scode/declaration-expression declaration-expression)
- (scode/declaration-text declaration-text)
- (scode/declaration? declaration?)
- (scode/definition-components definition-components)
- (scode/definition-name definition-name)
- (scode/definition-value definition-value)
- (scode/definition? definition?)
- (scode/delay-components delay-components)
- (scode/delay-expression delay-expression)
- (scode/delay? delay?)
- (scode/disjunction-alternative disjunction-alternative)
- (scode/disjunction-components disjunction-components)
- (scode/disjunction-predicate disjunction-predicate)
- (scode/disjunction? disjunction?)
- (scode/lambda-components lambda-components)
- (scode/lambda? lambda?)
- (scode/make-access make-access)
- (scode/make-assignment make-assignment)
- (scode/make-combination make-combination)
- (scode/make-comment make-comment)
- (scode/make-conditional make-conditional)
- (scode/make-declaration make-declaration)
- (scode/make-definition make-definition)
- (scode/make-delay make-delay)
- (scode/make-disjunction make-disjunction)
- (scode/make-lambda make-lambda)
- (scode/make-open-block make-open-block)
- (scode/make-quotation make-quotation)
- (scode/make-sequence make-sequence)
- (scode/make-the-environment make-the-environment)
- (scode/make-unassigned? make-unassigned?)
- (scode/make-variable make-variable)
- (scode/open-block-components open-block-components)
- (scode/open-block? open-block?)
- (scode/primitive-procedure? primitive-procedure?)
- (scode/procedure? procedure?)
- (scode/quotation-expression quotation-expression)
- (scode/quotation? quotation?)
- (scode/sequence-actions sequence-actions)
- (scode/sequence-components sequence-components)
- (scode/sequence-immediate-first sequence-immediate-first)
- (scode/sequence-immediate-second sequence-immediate-second)
- (scode/sequence-first sequence-first)
- (scode/sequence-second sequence-second)
- (scode/sequence? sequence?)
- (scode/symbol? symbol?)
- (scode/the-environment? the-environment?)
- (scode/unassigned?-name unassigned?-name)
- (scode/unassigned?? unassigned??)
- (scode/variable-components variable-components)
- (scode/variable-name variable-name)
- (scode/variable? variable?)))
-\f
-(define-package (compiler reference-contexts)
- (files "base/refctx")
- (parent (compiler))
- (export (compiler)
- add-reference-context/adjacent-parents!
- initialize-reference-contexts!
- make-reference-context
- modify-reference-contexts!
- reference-context/adjacent-parent?
- reference-context/block
- reference-context/offset
- reference-context/procedure
- reference-context?
- set-reference-context/offset!))
-
-(define-package (compiler macros)
- (files "base/macros")
- (parent ())
- (import (runtime macros)
- parse-define-syntax)
- (initialization (initialize-package!)))
-
-(define-package (compiler declarations)
- (files "machines/alpha/decls")
- (parent (compiler))
- (export (compiler)
- sc
- syntax-files!)
- (import (scode-optimizer top-level)
- sf/internal)
- (initialization (initialize-package!)))
-
-(define-package (compiler top-level)
- (files "base/toplev"
- "base/crstop"
- "base/asstop")
- (parent (compiler))
- (export ()
- cbf
- cf
- compile-directory
- compile-bin-file
- compile-procedure
- compile-scode
- compiler:reset!
- cross-compile-bin-file
- cross-compile-bin-file-end)
- (export (compiler)
- canonicalize-label-name)
- (export (compiler fg-generator)
- compile-recursively)
- (export (compiler rtl-generator)
- *ic-procedure-headers*
- *rtl-continuations*
- *rtl-expression*
- *rtl-graphs*
- *rtl-procedures*)
- (export (compiler lap-syntaxer)
- *block-label*
- *external-labels*
- label->object)
- (export (compiler debug)
- *root-expression*
- *rtl-procedures*
- *rtl-graphs*)
- (import (runtime compiler-info)
- make-dbg-info-vector
- split-inf-structure!)
- (import (runtime unparser)
- param:unparse-uninterned-symbols-by-name?)
- (import (scode-optimizer build-utilities)
- directory-processor))
-\f
-(define-package (compiler debug)
- (files "base/debug")
- (parent (compiler))
- (export ()
- debug/find-continuation
- debug/find-entry-node
- debug/find-procedure
- debug/where
- dump-rtl
- po
- show-bblock-rtl
- show-fg
- show-fg-node
- show-rtl
- write-rtl-instructions)
- (import (runtime unparser)
- param:unparse-uninterned-symbols-by-name?))
-
-(define-package (compiler pattern-matcher/lookup)
- (files "base/pmlook")
- (parent (compiler))
- (export (compiler)
- make-pattern-variable
- pattern-lookup
- pattern-variable-name
- pattern-variable?
- pattern-variables))
-
-(define-package (compiler pattern-matcher/parser)
- (files "base/pmpars")
- (parent (compiler))
- (export (compiler)
- parse-rule
- rule-result-expression)
- (export (compiler macros)
- parse-rule
- rule-result-expression))
-
-(define-package (compiler pattern-matcher/early)
- (files "base/pmerly")
- (parent (compiler))
- (export (compiler)
- early-parse-rule
- early-pattern-lookup
- early-make-rule
- make-database-transformer
- make-symbol-transformer
- make-bit-mask-transformer))
-\f
-(define-package (compiler debugging-information)
- (files "base/infnew")
- (parent (compiler))
- (export (compiler top-level)
- info-generation-phase-1
- info-generation-phase-2
- info-generation-phase-3)
- (export (compiler rtl-generator)
- generated-dbg-continuation)
- (import (runtime compiler-info)
- make-dbg-info
-
- make-dbg-expression
- dbg-expression/block
- dbg-expression/label
- set-dbg-expression/label!
-
- make-dbg-procedure
- dbg-procedure/block
- dbg-procedure/label
- set-dbg-procedure/label!
- dbg-procedure/name
- dbg-procedure/required
- dbg-procedure/optional
- dbg-procedure/rest
- dbg-procedure/auxiliary
- dbg-procedure/external-label
- set-dbg-procedure/external-label!
- dbg-procedure<?
-
- make-dbg-continuation
- dbg-continuation/block
- dbg-continuation/label
- set-dbg-continuation/label!
- dbg-continuation<?
-
- make-dbg-block
- dbg-block/parent
- dbg-block/layout
- dbg-block/stack-link
- set-dbg-block/procedure!
-
- make-dbg-variable
- dbg-variable/value
- set-dbg-variable/value!
-
- dbg-block-name/dynamic-link
- dbg-block-name/ic-parent
- dbg-block-name/normal-closure
- dbg-block-name/return-address
- dbg-block-name/static-link
-
- make-dbg-label-2
- dbg-label/offset
- set-dbg-label/external?!))
-
-(define-package (compiler constraints)
- (files "base/constr")
- (parent (compiler))
- (export (compiler)
- make-constraint
- constraint/element
- constraint/graph-head
- constraint/afters
- constraint/closed?
- constraint-add!
- add-constraint-element!
- add-constraint-set!
- make-constraint-graph
- constraint-graph/entry-nodes
- constraint-graph/closed?
- close-constraint-graph!
- close-constraint-node!
- order-per-constraints
- order-per-constraints/extracted
- legal-ordering-per-constraints?
- with-new-constraint-marks
- constraint-marked?
- constraint-mark!
- transitively-close-dag!
- reverse-postorder))
-\f
-(define-package (compiler fg-generator)
- (files "fggen/canon" ;SCode canonicalizer
- "fggen/fggen" ;SCode->flow-graph converter
- "fggen/declar" ;Declaration handling
- )
- (parent (compiler))
- (export (compiler top-level)
- canonicalize/top-level
- construct-graph)
- (import (runtime scode-data)
- &pair-car
- &pair-cdr
- &triple-first
- &triple-second
- &triple-third))
-
-(define-package (compiler fg-optimizer)
- (files "fgopt/outer" ;outer analysis
- "fgopt/sideff" ;side effect analysis
- )
- (parent (compiler))
- (export (compiler top-level)
- clear-call-graph!
- compute-call-graph!
- outer-analysis
- side-effect-analysis))
-
-(define-package (compiler fg-optimizer fold-constants)
- (files "fgopt/folcon")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) fold-constants))
-
-(define-package (compiler fg-optimizer operator-analysis)
- (files "fgopt/operan")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) operator-analysis))
-
-(define-package (compiler fg-optimizer variable-indirection)
- (files "fgopt/varind")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) initialize-variable-indirections!))
-
-(define-package (compiler fg-optimizer environment-optimization)
- (files "fgopt/envopt")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) optimize-environments!))
-
-(define-package (compiler fg-optimizer closure-analysis)
- (files "fgopt/closan")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) identify-closure-limits!))
-
-(define-package (compiler fg-optimizer continuation-analysis)
- (files "fgopt/contan")
- (parent (compiler fg-optimizer))
- (export (compiler top-level)
- continuation-analysis
- setup-block-static-links!))
-
-(define-package (compiler fg-optimizer compute-node-offsets)
- (files "fgopt/offset")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) compute-node-offsets))
-\f
-(define-package (compiler fg-optimizer connectivity-analysis)
- (files "fgopt/conect")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) connectivity-analysis))
-
-(define-package (compiler fg-optimizer delete-integrated-parameters)
- (files "fgopt/delint")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) delete-integrated-parameters))
-
-(define-package (compiler fg-optimizer design-environment-frames)
- (files "fgopt/desenv")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) design-environment-frames!))
-
-(define-package (compiler fg-optimizer setup-block-types)
- (files "fgopt/blktyp")
- (parent (compiler fg-optimizer))
- (export (compiler top-level)
- setup-block-types!
- setup-closure-contexts!)
- (export (compiler)
- indirection-block-procedure))
-
-(define-package (compiler fg-optimizer simplicity-analysis)
- (files "fgopt/simple")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) simplicity-analysis)
- (export (compiler fg-optimizer subproblem-ordering)
- new-subproblem/compute-simplicity!))
-
-(define-package (compiler fg-optimizer simulate-application)
- (files "fgopt/simapp")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) simulate-application))
-
-(define-package (compiler fg-optimizer subproblem-free-variables)
- (files "fgopt/subfre")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) compute-subproblem-free-variables)
- (export (compiler fg-optimizer) map-union)
- (export (compiler fg-optimizer subproblem-ordering)
- new-subproblem/compute-free-variables!))
-
-(define-package (compiler fg-optimizer subproblem-ordering)
- (files "fgopt/order")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) subproblem-ordering))
-
-(define-package (compiler fg-optimizer subproblem-ordering reuse-frames)
- (files "fgopt/reord" "fgopt/reuse")
- (parent (compiler fg-optimizer subproblem-ordering))
- (export (compiler top-level) setup-frame-adjustments)
- (export (compiler fg-optimizer subproblem-ordering)
- order-subproblems/maybe-overwrite-block))
-
-(define-package (compiler fg-optimizer subproblem-ordering parameter-analysis)
- (files "fgopt/param")
- (parent (compiler fg-optimizer subproblem-ordering))
- (export (compiler fg-optimizer subproblem-ordering)
- parameter-analysis))
-
-(define-package (compiler fg-optimizer return-equivalencing)
- (files "fgopt/reteqv")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) find-equivalent-returns!))
-\f
-(define-package (compiler rtl-generator)
- (files "rtlgen/rtlgen" ;RTL generator
- "rtlgen/rgstmt" ;statements
- "rtlgen/fndvar" ;find variables
- "machines/alpha/rgspcm" ;special close-coded primitives
- "rtlbase/rtline" ;linearizer
- )
- (parent (compiler))
- (export (compiler)
- make-linearizer)
- (export (compiler top-level)
- generate/top-level
- linearize-rtl
- setup-bblock-continuations!)
- (export (compiler debug)
- linearize-rtl)
- (import (compiler top-level)
- label->object))
-
-(define-package (compiler rtl-generator generate/procedure-header)
- (files "rtlgen/rgproc")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator) generate/procedure-header))
-
-(define-package (compiler rtl-generator combination/inline)
- (files "rtlgen/opncod")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator) combination/inline)
- (export (compiler top-level) open-coding-analysis))
-
-(define-package (compiler rtl-generator find-block)
- (files "rtlgen/fndblk")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator) find-block))
-
-(define-package (compiler rtl-generator generate/rvalue)
- (files "rtlgen/rgrval")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator)
- generate/rvalue
- load-closure-environment
- make-cons-closure-indirection
- make-cons-closure-redirection
- make-closure-redirection
- make-ic-cons
- make-non-trivial-closure-cons
- make-trivial-closure-cons
- redirect-closure))
-
-(define-package (compiler rtl-generator generate/combination)
- (files "rtlgen/rgcomb")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator)
- generate/combination
- rtl:bump-closure)
- (export (compiler rtl-generator combination/inline)
- generate/invocation-prefix))
-
-(define-package (compiler rtl-generator generate/return)
- (files "rtlgen/rgretn")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator)
- make-return-operand
- generate/return
- generate/return*
- generate/trivial-return))
-\f
-(define-package (compiler rtl-cse)
- (files "rtlopt/rcse1" ;RTL common subexpression eliminator
- "rtlopt/rcse2"
- "rtlopt/rcseep" ;CSE expression predicates
- "rtlopt/rcseht" ;CSE hash table
- "rtlopt/rcserq" ;CSE register/quantity abstractions
- "rtlopt/rcsesr" ;CSE stack references
- )
- (parent (compiler))
- (export (compiler top-level) common-subexpression-elimination))
-
-(define-package (compiler rtl-optimizer)
- (files "rtlopt/rdebug")
- (parent (compiler)))
-
-(define-package (compiler rtl-optimizer invertible-expression-elimination)
- (files "rtlopt/rinvex")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) invertible-expression-elimination))
-
-(define-package (compiler rtl-optimizer common-suffix-merging)
- (files "rtlopt/rtlcsm")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) merge-common-suffixes!))
-
-(define-package (compiler rtl-optimizer rtl-dataflow-analysis)
- (files "rtlopt/rdflow")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) rtl-dataflow-analysis))
-
-(define-package (compiler rtl-optimizer rtl-rewriting)
- (files "rtlopt/rerite")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level)
- rtl-rewriting:post-cse
- rtl-rewriting:pre-cse)
- (export (compiler lap-syntaxer) add-rewriting-rule!))
-
-(define-package (compiler rtl-optimizer lifetime-analysis)
- (files "rtlopt/rlife")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) lifetime-analysis)
- (export (compiler rtl-optimizer code-compression) mark-set-registers!))
-
-(define-package (compiler rtl-optimizer code-compression)
- (files "rtlopt/rcompr")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) code-compression))
-
-(define-package (compiler rtl-optimizer register-allocation)
- (files "rtlopt/ralloc")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) register-allocation))
-\f
-(define-package (compiler lap-syntaxer)
- (files "back/lapgn1" ;LAP generator
- "back/lapgn2" ; " "
- "back/lapgn3" ; " "
- "back/regmap" ;Hardware register allocator
- "machines/alpha/lapgen" ;code generation rules
- "machines/alpha/rules1" ; " " "
- "machines/alpha/rules2" ; " " "
- "machines/alpha/rules3" ; " " "
- "machines/alpha/rules4" ; " " "
- "machines/alpha/rulfix" ; " " "
- "machines/alpha/rulflo" ; " " "
- "machines/alpha/rulrew" ;code rewriting rules
- "back/syntax" ;Generic syntax phase
- "back/syerly" ;Early binding version
- "machines/alpha/coerce" ;Coercions: integer -> bit string
- "back/asmmac" ;Macros for hairy syntax
- "machines/alpha/insmac" ;Macros for hairy syntax
- "machines/alpha/instr1" ;Alpha instruction set
- "machines/alpha/instr2" ;branch tensioning: branches
- "machines/alpha/instr3" ;floating point
- )
- (parent (compiler))
- (export (compiler)
- available-machine-registers
- fits-in-16-bits-signed?
- fits-in-16-bits-unsigned?
- top-16-of-32-bits-only?
- lap-generator/match-rtl-instruction
- lap:make-entry-point
- lap:make-label-statement
- lap:make-unconditional-branch
- lap:syntax-instruction)
- (export (compiler top-level)
- *block-associations*
- *interned-assignments*
- *interned-constants*
- *interned-global-links*
- *interned-static-variables*
- *interned-uuo-links*
- *interned-variables*
- *next-constant*
- generate-lap)
- (import (scode-optimizer expansion)
- scode->scode-expander))
-
-(define-package (compiler lap-syntaxer map-merger)
- (files "back/mermap")
- (parent (compiler lap-syntaxer))
- (export (compiler lap-syntaxer)
- merge-register-maps))
-
-(define-package (compiler lap-syntaxer linearizer)
- (files "back/linear")
- (parent (compiler lap-syntaxer))
- (export (compiler lap-syntaxer)
- add-end-of-block-code!
- add-extra-code!
- bblock-linearize-lap
- extra-code-block/xtra
- declare-extra-code-block!
- find-extra-code-block
- linearize-lap
- set-current-branches!
- set-extra-code-block/xtra!)
- (export (compiler top-level)
- *end-of-block-code*
- linearize-lap))
-\f
-(define-package (compiler lap-optimizer)
- (files "machines/alpha/lapopt")
- (parent (compiler))
- (export (compiler top-level)
- optimize-linear-lap))
-
-(define-package (compiler assembler)
- (files "machines/alpha/assmd" ;Machine dependent
- "back/symtab" ;Symbol tables
- "back/bitutl" ;Assembly blocks
- "back/bittop" ;Assembler top level
- )
- (parent (compiler))
- (export (compiler)
- instruction-append)
- (export (compiler top-level)
- assemble))
-
-#|
-(define-package (compiler disassembler)
- (files "machines/alpha/dassm1"
- "machines/alpha/dassm2"
- "machines/alpha/dassm3")
- (parent (compiler))
- (export ()
- compiler:write-lap-file
- compiler:disassemble)
- (import (runtime compiler-info)
- compiled-code-block/dbg-info
- dbg-info-vector/blocks-vector
- dbg-info-vector?
- dbg-info/labels
- dbg-label/external?
- dbg-label/name
- dbg-labels/find-offset))
-|#
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Script to incrementally syntax the compiler
-\f
-(load-option 'CREF)
-
-;; Guarantee that the compiler's package structure exists.
-(if (not (name->package '(COMPILER)))
- (let ((package-set (package-set-pathname "compiler")))
- (if (not (file-exists? package-set))
- (cref/generate-trivial-constructor "compiler"))
- (construct-packages-from-file (fasload package-set))))
-
-;; Guarantee that the necessary syntactic transforms and optimizers
-;; are loaded.
-(if (lexical-unreferenceable? (->environment '(COMPILER)) 'SYNTAX-FILES!)
- (let ((sf-and-load
- (lambda (files package)
- (sf-conditionally files)
- (for-each (lambda (file)
- (load (string-append file ".bin") package))
- files))))
- (load-option 'HASH-TABLE)
- (fresh-line)
- (newline)
- (write-string "---- Loading compile-time files ----")
- (newline)
- (sf-and-load '("base/switch") '(COMPILER))
- (sf-and-load '("base/macros") '(COMPILER MACROS))
- ((access initialize-package! (->environment '(COMPILER MACROS))))
- (sf-and-load '("machines/alpha/decls") '(COMPILER DECLARATIONS))
- (let ((environment (->environment '(COMPILER DECLARATIONS))))
- (set! (access source-file-expression environment) "*.scm")
- ((access initialize-package! environment)))
- (sf-and-load '("base/pmlook") '(COMPILER PATTERN-MATCHER/LOOKUP))
- (sf-and-load '("base/pmpars") '(COMPILER PATTERN-MATCHER/PARSER))
- (sf-and-load '("rtlbase/valclass") '(COMPILER))
- (fluid-let ((sf/default-syntax-table (->environment '(COMPILER))))
- (sf-and-load '("machines/alpha/machin") '(COMPILER)))
- (set! (access endianness (->environment '(COMPILER))) 'LITTLE)
- (fluid-let ((sf/default-declarations
- '((integrate-external "insseq")
- (integrate-external "machin")
- (usual-definition (set expt)))))
- (sf-and-load '("machines/alpha/assmd") '(COMPILER ASSEMBLER)))
- (sf-and-load '("back/syntax") '(COMPILER LAP-SYNTAXER))
- (sf-and-load '("machines/alpha/coerce"
- "back/asmmac"
- "machines/alpha/insmac")
- '(COMPILER LAP-SYNTAXER))
- (sf-and-load '("base/scode") '(COMPILER))
- (sf-and-load '("base/pmerly") '(COMPILER PATTERN-MATCHER/EARLY))
- (sf-and-load '("back/syerly") '(COMPILER LAP-SYNTAXER))))
-
-;; Resyntax any files that need it.
-((access syntax-files! (->environment '(COMPILER))))
-
-;; Rebuild the package constructors and cref.
-(cref/generate-constructors "compiler")
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Disassembler: User Level
-;;; Package: (compiler disassembler)
-
-(declare (usual-integrations))
-\f
-;;; Flags that control disassembler behavior
-
-(define disassembler/symbolize-output? true)
-(define disassembler/compiled-code-heuristics?
- ;; Not used for anything! (Reserved for future use?)
- true)
-(define disassembler/write-offsets? true)
-(define disassembler/write-addresses? false)
-
-;;;; Top level entries
-
-(define (compiler:write-lap-file filename #!optional symbol-table?)
- (let ((pathname (->pathname filename)))
- (with-output-to-file (pathname-new-type pathname "lap")
- (lambda ()
- (let ((com-file (pathname-new-type pathname "com")))
- (let ((object (fasload com-file))
- (info
- (let ((pathname (pathname-new-type pathname "binf")))
- (and (if (default-object? symbol-table?)
- (file-exists? pathname)
- symbol-table?)
- (fasload pathname)))))
- (if (compiled-code-address? object)
- (disassembler/write-compiled-code-block
- (compiled-code-address->block object)
- info)
- (begin
- (if (not
- (and (scode/comment? object)
- (dbg-info-vector? (scode/comment-text object))))
- (error "Not a compiled file" com-file))
- (let ((items
- (vector->list
- (dbg-info-vector/blocks-vector
- (scode/comment-text object)))))
- (if (not (null? items))
- (if (false? info)
- (let loop ((items items))
- (disassembler/write-compiled-code-block
- (car items)
- false)
- (if (not (null? (cdr items)))
- (begin
- (write-char #\page)
- (loop (cdr items)))))
- (let loop
- ((items items) (info (vector->list info)))
- (disassembler/write-compiled-code-block
- (car items)
- (car info))
- (if (not (null? (cdr items)))
- (begin
- (write-char #\page)
- (loop (cdr items) (cdr info))))))))))))))))
-
-(define disassembler/base-address)
-
-(define (compiler:disassemble entry)
- (let ((block (compiled-entry/block entry)))
- (let ((info (compiled-code-block/dbg-info block true)))
- (fluid-let ((disassembler/write-offsets? true)
- (disassembler/write-addresses? true)
- (disassembler/base-address (object-datum block)))
- (newline)
- (newline)
- (disassembler/write-compiled-code-block block info)))))
-\f
-;;; Operations exported from the disassembler package
-
-(define disassembler/instructions)
-(define disassembler/instructions/null?)
-(define disassembler/instructions/read)
-(define disassembler/lookup-symbol)
-(define disassembler/read-variable-cache)
-(define disassembler/read-procedure-cache)
-(define compiled-code-block/objects-per-procedure-cache)
-(define compiled-code-block/objects-per-variable-cache)
-
-(define (disassembler/write-compiled-code-block block info)
- (let ((symbol-table (and info (dbg-info/labels info))))
- (write-string "Disassembly of ")
- (write block)
- (write-string ":\n")
- (write-string "Code:\n\n")
- (disassembler/write-instruction-stream
- symbol-table
- (disassembler/instructions/compiled-code-block block symbol-table))
- (write-string "\nConstants:\n\n")
- (disassembler/write-constants-block block symbol-table)
- (newline)))
-
-(define (disassembler/instructions/compiled-code-block block symbol-table)
- (disassembler/instructions block
- (compiled-code-block/code-start block)
- (compiled-code-block/code-end block)
- symbol-table))
-
-(define (disassembler/instructions/address start-address end-address)
- (disassembler/instructions false start-address end-address false))
-
-(define (disassembler/write-instruction-stream symbol-table instruction-stream)
- (parameterize* (list (cons param:unparser-radix 16))
- (lambda ()
- (disassembler/for-each-instruction instruction-stream
- (lambda (offset instruction)
- (disassembler/write-instruction symbol-table
- offset
- (lambda () (display instruction))))))))
-
-(define (disassembler/for-each-instruction instruction-stream procedure)
- (let loop ((instruction-stream instruction-stream))
- (if (not (disassembler/instructions/null? instruction-stream))
- (disassembler/instructions/read instruction-stream
- (lambda (offset instruction instruction-stream)
- (procedure offset instruction)
- (loop (instruction-stream)))))))
-\f
-(define (disassembler/write-constants-block block symbol-table)
- (parameterize* (list (cons param:unparser-radix 16))
- (lambda ()
- (let ((end (system-vector-length block)))
- (let loop ((index (compiled-code-block/constants-start block)))
- (cond ((not (< index end)) 'DONE)
- ((object-type?
- ((sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form))))
- linkage-section)
- (system-vector-ref block index))
- (loop (disassembler/write-linkage-section block
- symbol-table
- index)))
- (else
- (disassembler/write-instruction
- symbol-table
- (compiled-code-block/index->offset index)
- (lambda ()
- (write-constant block
- symbol-table
- (system-vector-ref block index))))
- (loop (1+ index)))))))))
-
-(define (write-constant block symbol-table constant)
- (write-string (cdr (write-to-string constant 60)))
- (cond ((lambda? constant)
- (let ((expression (lambda-body constant)))
- (if (and (compiled-code-address? expression)
- (eq? (compiled-code-address->block expression) block))
- (begin
- (write-string " (")
- (let ((offset (compiled-code-address->offset expression)))
- (let ((label
- (disassembler/lookup-symbol symbol-table offset)))
- (if label
- (write-string label)
- (write offset))))
- (write-string ")")))))
- ((compiled-code-address? constant)
- (write-string " (offset ")
- (write (compiled-code-address->offset constant))
- (write-string " in ")
- (write (compiled-code-address->block constant))
- (write-string ")"))
- (else false)))
-\f
-(define (disassembler/write-linkage-section block symbol-table index)
- (define (write-caches index size how-many writer)
- (let loop ((index index) (how-many how-many))
- (if (zero? how-many)
- 'DONE
- (begin
- (disassembler/write-instruction
- symbol-table
- (compiled-code-block/index->offset index)
- (lambda ()
- (writer block index)))
- (loop (+ size index) (-1+ how-many))))))
-
- (let* ((field (object-datum (system-vector-ref block index)))
- (descriptor (integer-divide field #x10000)))
- (let ((kind (integer-divide-quotient descriptor))
- (length (integer-divide-remainder descriptor)))
- (disassembler/write-instruction
- symbol-table
- (compiled-code-block/index->offset index)
- (lambda ()
- (write-string "#[LINKAGE-SECTION ")
- (write field)
- (write-string "]")))
- (write-caches
- (1+ index)
- compiled-code-block/objects-per-procedure-cache
- (quotient length compiled-code-block/objects-per-procedure-cache)
- (case kind
- ((0)
- disassembler/write-procedure-cache)
- ((1)
- (lambda (block index)
- (disassembler/write-variable-cache "Reference" block index)))
- ((2)
- (lambda (block index)
- (disassembler/write-variable-cache "Assignment" block index)))
- (else
- (error "disassembler/write-linkage-section: Unknown section kind"
- kind))))
- (1+ (+ index length)))))
-\f
-(define-integrable (variable-cache-name cache)
- ((ucode-primitive primitive-object-ref 2) cache 1))
-
-(define (disassembler/write-variable-cache kind block index)
- (write-string kind)
- (write-string " cache to ")
- (write (variable-cache-name (disassembler/read-variable-cache block index))))
-
-(define (disassembler/write-procedure-cache block index)
- (let ((result (disassembler/read-procedure-cache block index)))
- (write (vector-ref result 2))
- (write-string " argument procedure cache to ")
- (case (vector-ref result 0)
- ((COMPILED INTERPRETED)
- (write (vector-ref result 1)))
- ((VARIABLE)
- (write-string "variable ")
- (write (vector-ref result 1)))
- (else
- (error "disassembler/write-procedure-cache: Unknown cache kind"
- (vector-ref result 0))))))
-
-(define (disassembler/write-instruction symbol-table offset write-instruction)
- (if symbol-table
- (let ((label (dbg-labels/find-offset symbol-table offset)))
- (if label
- (begin
- (write-char #\Tab)
- (write-string (dbg-label/name label))
- (write-char #\:)
- (newline)))))
-
- (if disassembler/write-addresses?
- (begin
- (write-string
- (number->string (+ offset disassembler/base-address) 16))
- (write-char #\Tab)))
-
- (if disassembler/write-offsets?
- (begin
- (write-string (number->string offset 16))
- (write-char #\Tab)))
-
- (if symbol-table
- (write-string " "))
- (write-instruction)
- (newline))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Alpha Disassembler: Top Level
-;;; Package: (compiler disassembler)
-
-(declare (usual-integrations))
-\f
-(set! compiled-code-block/bytes-per-object 4)
-(set! compiled-code-block/objects-per-procedure-cache 2)
-(set! compiled-code-block/objects-per-variable-cache 1)
-
-(set! disassembler/read-variable-cache
- (lambda (block index)
- (let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form)))))
- (ucode-primitive
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply make-primitive-procedure (cdr form))))))
- ((ucode-primitive primitive-object-set-type 2)
- (ucode-type quad)
- (system-vector-ref block index)))))
-
-(set! disassembler/read-procedure-cache
- (lambda (block index)
- (fluid-let ((*block block))
- (let* ((offset (compiled-code-block/index->offset index)))
- offset
- ;; For now
- (error "disassembler/read-procedure-cache: Not written")))))
-\f
-(set! disassembler/instructions
- (lambda (block start-offset end-offset symbol-table)
- (let loop ((offset start-offset) (state (disassembler/initial-state)))
- (if (and end-offset (< offset end-offset))
- (disassemble-one-instruction block offset symbol-table state
- (lambda (offset* instruction state)
- (make-instruction offset
- instruction
- (lambda () (loop offset* state)))))
- '()))))
-
-(set! disassembler/instructions/null?
- null?)
-
-(set! disassembler/instructions/read
- (lambda (instruction-stream receiver)
- (receiver (instruction-offset instruction-stream)
- (instruction-instruction instruction-stream)
- (instruction-next instruction-stream))))
-
-(define-structure (instruction (type vector))
- (offset false read-only true)
- (instruction false read-only true)
- (next false read-only true))
-
-(define *block)
-(define *current-offset)
-(define *symbol-table)
-(define *ir)
-(define *valid?)
-
-(define (disassemble-one-instruction block offset symbol-table state receiver)
- (if (not (eq? state 'INSTRUCTION))
- (error "Unexpected disassembler state" state))
- (fluid-let ((*block block)
- (*current-offset offset)
- (*symbol-table symbol-table)
- (*ir)
- (*valid? true))
- (set! *ir (get-longword))
- (let ((start-offset *current-offset))
- (if (external-label-marker? symbol-table offset state)
- (receiver *current-offset
- (make-external-label *ir)
- 'INSTRUCTION)
- (let ((instruction (disassemble-word *ir)))
- (if (not *valid?)
- (let ((inst (make-word *ir)))
- (receiver start-offset
- inst
- (disassembler/next-state inst state)))
- (let ((next-state (disassembler/next-state instruction state)))
- (receiver
- *current-offset
- instruction
- next-state))))))))
-\f
-(define (disassembler/initial-state)
- 'INSTRUCTION-NEXT)
-
-(define (disassembler/next-state instruction state)
- instruction state
- 'INSTRUCTION)
-\f
-(set! disassembler/lookup-symbol
- (lambda (symbol-table offset)
- (and symbol-table
- (let ((label (dbg-labels/find-offset symbol-table offset)))
- (and label
- (dbg-label/name label))))))
-
-(define (external-label-marker? symbol-table offset state)
- (if symbol-table
- (let ((label (dbg-labels/find-offset symbol-table (+ offset 4))))
- (and label
- (dbg-label/external? label)))
- (and *block
- (not (eq? state 'INSTRUCTION))
- (let loop ((offset (+ offset 4)))
- (let ((contents (read-bits (- offset 2) 16)))
- (if (bit-string-clear! contents 0)
- (let ((offset
- (- offset
- (* 2 (bit-string->unsigned-integer contents)))))
- (and (positive? offset)
- (loop offset)))
- (= offset
- (* 2 (bit-string->unsigned-integer contents)))))))))
-
-(define (make-word bit-string)
- `(UWORD ,(bit-string->unsigned-integer bit-string)))
-
-(define (make-external-label bit-string)
- (let ((do-it
- (lambda (format-word offset)
- `(EXTERNAL-LABEL (FORMAT ,format-word)
- ,(offset->@pcr (* 2 offset))))))
- (if (eq? endianness 'LITTLE)
- (do-it (extract bit-string 0 16)
- (extract bit-string 16 32))
- (do-it (extract bit-string 16 32)
- (extract bit-string 0 16)))))
-
-(define (read-bits offset size-in-bits)
- (let ((word (bit-string-allocate size-in-bits))
- (bit-offset (* offset addressing-granularity)))
- (with-absolutely-no-interrupts
- (lambda ()
- (if *block
- (read-bits! *block bit-offset word)
- (read-bits! offset 0 word))))
- word))
-
-(define (invalid-instruction)
- (set! *valid? false)
- false)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;; Alpha Disassembler: Internals
-;;; Package: (compiler disassembler)
-
-(declare (usual-integrations))
-\f
-;;;; Utilities
-
-(define (get-longword)
- (let ((word (read-bits *current-offset 32)))
- (set! *current-offset (+ *current-offset 4))
- word))
-
-(declare (integrate-operator extract))
-(declare (integrate-operator extract-signed))
-
-(define (extract bit-string start end)
- (declare (integrate bit-string start end))
- (bit-string->unsigned-integer (bit-substring bit-string start end)))
-
-(define (extract-signed bit-string start end)
- (declare (integrate bit-string start end))
- (bit-string->signed-integer (bit-substring bit-string start end)))
-
-;; Debugging assistance
-
-(define (verify-instruction instruction)
- (let ((bits (car (lap:syntax-instruction instruction))))
- (if (bit-string? bits)
- (begin
- (let ((disassembly (disassemble bits)))
- (if (and (null? (cdr disassembly))
- (equal? (car disassembly) instruction))
- #T
- disassembly)))
- (error "Assember oddity" bits))))
-
-(define (v i) (verify-instruction i))
-\f
-;;;; The disassembler proper
-
-(define (handle-bad-instruction word)
- word
- (invalid-instruction))
-
-(define (disassemble bit-string)
- (let ((stop (bit-string-length bit-string)))
- (let loop ((from 0)
- (to 32)
- (result '()))
- (if (> to stop)
- result
- (loop to (+ to 32) (cons (disassemble-word (bit-substring bit-string from to))
- result))))))
-
-(define disassemblers (make-vector (expt 2 6) handle-bad-instruction))
-
-(define (disassemble-word word)
- (let ((op-code (extract word 26 32)))
- ((vector-ref disassemblers op-code) word)))
-\f
-;;;; instr1.scm
-
-(define (disassemble-memory-format op-name word)
- `(,op-name ,(extract word 21 26)
- (OFFSET ,(extract-signed word 0 16) ,(extract word 16 21))))
-
-(vector-set! disassemblers #x08
- (lambda (word)
- (let ((base (extract word 16 21)))
- (if (zero? base)
- `(MOVEI ,(extract word 21 26)
- (& ,(extract-signed word 0 16)))
- `(LDA ,(extract word 21 26)
- (OFFSET ,(extract-signed word 0 16)
- ,(extract word 16 21)))))))
-(vector-set! disassemblers #x09
- (lambda (word) (disassemble-memory-format 'LDAH word)))
-(vector-set! disassemblers #x20
- (lambda (word) (disassemble-memory-format 'LDF word)))
-(vector-set! disassemblers #x21
- (lambda (word) (disassemble-memory-format 'LDG word)))
-(vector-set! disassemblers #x28
- (lambda (word) (disassemble-memory-format 'LDL word)))
-(vector-set! disassemblers #x2A
- (lambda (word) (disassemble-memory-format 'LDL_L word)))
-(vector-set! disassemblers #x29
- (lambda (word) (disassemble-memory-format 'LDQ word)))
-(vector-set! disassemblers #x2B
- (lambda (word) (disassemble-memory-format 'LDQ_L word)))
-(vector-set! disassemblers #x0B
- (lambda (word) (disassemble-memory-format 'LDQ_U word)))
-(vector-set! disassemblers #x22
- (lambda (word) (disassemble-memory-format 'LDS word)))
-(vector-set! disassemblers #x23
- (lambda (word) (disassemble-memory-format 'LDT word)))
-(vector-set! disassemblers #x24
- (lambda (word) (disassemble-memory-format 'STF word)))
-(vector-set! disassemblers #x25
- (lambda (word) (disassemble-memory-format 'STG word)))
-(vector-set! disassemblers #x2C
- (lambda (word) (disassemble-memory-format 'STL word)))
-(vector-set! disassemblers #x2E
- (lambda (word) (disassemble-memory-format 'STL_C word)))
-(vector-set! disassemblers #x2D
- (lambda (word) (disassemble-memory-format 'STQ word)))
-(vector-set! disassemblers #x2F
- (lambda (word) (disassemble-memory-format 'STQ_C word)))
-(vector-set! disassemblers #x0F
- (lambda (word) (disassemble-memory-format 'STQ_U word)))
-(vector-set! disassemblers #x26
- (lambda (word) (disassemble-memory-format 'STS word)))
-(vector-set! disassemblers #x27
- (lambda (word) (disassemble-memory-format 'STT word)))
-
-(define operate-10-disassemblers (make-vector #x6D handle-bad-instruction))
-(vector-set! disassemblers #x10
- (lambda (word)
- ((vector-ref operate-10-disassemblers (extract word 12 5))
- word)))
-(define operate-11-disassemblers (make-vector #x66 handle-bad-instruction))
-(vector-set! disassemblers #x11
- (lambda (word)
- ((vector-ref operate-11-disassemblers (extract word 12 5))
- word)))
-(define operate-12-disassemblers (make-vector #x7A handle-bad-instruction))
-(vector-set! disassemblers #x12
- (lambda (word)
- ((vector-ref operate-12-disassemblers (extract word 12 5))
- word)))
-(define operate-13-disassemblers (make-vector #x60 handle-bad-instruction))
-(vector-set! disassemblers #x13
- (lambda (word)
- ((vector-ref operate-13-disassemblers (extract word 5 12))
- word)))
-
-(vector-set! operate-11-disassemblers #x20
- (lambda (word)
- (let ((Ra (extract word 21 26))
- (Rc (extract word 0 5)))
- (if (bit-string-ref word 12)
- (invalid-instruction)
- (let ((sbz (extract word 13 16))
- (Rb (extract word 16 21)))
- (if (not (zero? sbz))
- (invalid-instruction))
- (if (not (= Ra Rb))
- (invalid-instruction))
- `(COPY ,Ra ,Rc))))))
-
-(vector-set! disassemblers #x18
- (lambda (word)
- (case (extract word 0 16)
- ((#x0000) '(TRAPB))
- ((#x4000) '(MB))
- ((#x8000) `(FETCH ,(extract word 16 21)))
- ((#xA000) `(FETCH_M ,(extract word 16 21)))
- ((#xC000) `(RPCC ,(extract word 21 26)))
- ((#xE000) `(RC ,(extract word 21 26)))
- ((#xF000) `(RS ,(extract word 21 26))))))
-
-(define ((disassemble-operate-format op-name) word)
- (let ((Ra (extract word 21 26))
- (Rc (extract word 0 5)))
- (if (bit-string-ref word 12)
- (let ((lit (extract word 13 21)))
- `(,op-name ,Ra (& ,lit) ,Rc))
- (let ((sbz (extract word 13 16))
- (Rb (extract word 16 21)))
- (if (not (zero? sbz))
- (invalid-instruction))
- `(,op-name ,Ra ,Rb ,Rc)))))
-
-(vector-set! operate-10-disassemblers #x00
- (disassemble-operate-format 'ADDL))
-(vector-set! operate-10-disassemblers #x40
- (disassemble-operate-format 'ADDLV))
-(vector-set! operate-10-disassemblers #x20
- (disassemble-operate-format 'ADDQ))
-(vector-set! operate-10-disassemblers #x60
- (disassemble-operate-format 'ADDQV))
-(vector-set! operate-11-disassemblers #x00
- (disassemble-operate-format 'AND))
-(vector-set! operate-11-disassemblers #x08
- (disassemble-operate-format 'BIC))
-(vector-set! operate-11-disassemblers #x20
- (disassemble-operate-format 'BIS))
-(vector-set! operate-11-disassemblers #x24
- (disassemble-operate-format 'CMOVEQ))
-(vector-set! operate-11-disassemblers #x46
- (disassemble-operate-format 'CMOVGE))
-(vector-set! operate-11-disassemblers #x66
- (disassemble-operate-format 'CMOVGT))
-(vector-set! operate-11-disassemblers #x16
- (disassemble-operate-format 'CMOVLBC))
-(vector-set! operate-11-disassemblers #x14
- (disassemble-operate-format 'CMOVLBS))
-(vector-set! operate-11-disassemblers #x64
- (disassemble-operate-format 'CMOVLE))
-(vector-set! operate-11-disassemblers #x44
- (disassemble-operate-format 'CMOVLT))
-(vector-set! operate-11-disassemblers #x26
- (disassemble-operate-format 'CMOVNE))
-(vector-set! operate-10-disassemblers #x2D
- (disassemble-operate-format 'CMPEQ))
-(vector-set! operate-10-disassemblers #x6D
- (disassemble-operate-format 'CMPLE))
-(vector-set! operate-10-disassemblers #x4D
- (disassemble-operate-format 'CMPLT))
-(vector-set! operate-10-disassemblers #x3D
- (disassemble-operate-format 'CMPULE))
-(vector-set! operate-10-disassemblers #x1D
- (disassemble-operate-format 'CMPULT))
-(vector-set! operate-11-disassemblers #x48
- (disassemble-operate-format 'EQV))
-(vector-set! operate-12-disassemblers #x06
- (disassemble-operate-format 'EXTBL))
-(vector-set! operate-12-disassemblers #x6A
- (disassemble-operate-format 'EXTLH))
-(vector-set! operate-12-disassemblers #x26
- (disassemble-operate-format 'EXTLL))
-(vector-set! operate-12-disassemblers #x7A
- (disassemble-operate-format 'EXTQH))
-(vector-set! operate-12-disassemblers #x36
- (disassemble-operate-format 'EXTQL))
-(vector-set! operate-12-disassemblers #x5A
- (disassemble-operate-format 'EXTWH))
-(vector-set! operate-12-disassemblers #x16
- (disassemble-operate-format 'EXTWL))
-(vector-set! operate-12-disassemblers #x0B
- (disassemble-operate-format 'INSBL))
-(vector-set! operate-12-disassemblers #x67
- (disassemble-operate-format 'INSLH))
-(vector-set! operate-12-disassemblers #x2B
- (disassemble-operate-format 'INSLL))
-(vector-set! operate-12-disassemblers #x77
- (disassemble-operate-format 'INSQH))
-(vector-set! operate-12-disassemblers #x3B
- (disassemble-operate-format 'INSQL))
-(vector-set! operate-12-disassemblers #x57
- (disassemble-operate-format 'INSWH))
-(vector-set! operate-12-disassemblers #x1B
- (disassemble-operate-format 'INSWL))
-(vector-set! operate-12-disassemblers #x02
- (disassemble-operate-format 'MSKBL))
-(vector-set! operate-12-disassemblers #x62
- (disassemble-operate-format 'MSKLH))
-(vector-set! operate-12-disassemblers #x22
- (disassemble-operate-format 'MSKLL))
-(vector-set! operate-12-disassemblers #x72
- (disassemble-operate-format 'MSKQH))
-(vector-set! operate-12-disassemblers #x32
- (disassemble-operate-format 'MSKQL))
-(vector-set! operate-12-disassemblers #x52
- (disassemble-operate-format 'MSKWH))
-(vector-set! operate-12-disassemblers #x12
- (disassemble-operate-format 'MSKWL))
-(vector-set! operate-13-disassemblers #x00
- (disassemble-operate-format 'MULL))
-(vector-set! operate-13-disassemblers #x40
- (disassemble-operate-format 'MULLV))
-(vector-set! operate-13-disassemblers #x20
- (disassemble-operate-format 'MULQ))
-(vector-set! operate-13-disassemblers #x60
- (disassemble-operate-format 'MULQV))
-(vector-set! operate-11-disassemblers #x28
- (disassemble-operate-format 'ORNOT))
-(vector-set! operate-10-disassemblers #x02
- (disassemble-operate-format 'S4ADDL))
-(vector-set! operate-10-disassemblers #x22
- (disassemble-operate-format 'S4ADDQ))
-(vector-set! operate-10-disassemblers #x0B
- (disassemble-operate-format 'S4SUBL))
-(vector-set! operate-10-disassemblers #x2B
- (disassemble-operate-format 'S4SUBQ))
-(vector-set! operate-10-disassemblers #x12
- (disassemble-operate-format 'S8ADDL))
-(vector-set! operate-10-disassemblers #x32
- (disassemble-operate-format 'S8ADDQ))
-(vector-set! operate-10-disassemblers #x1B
- (disassemble-operate-format 'S8SUBL))
-(vector-set! operate-10-disassemblers #x3B
- (disassemble-operate-format 'S8SUBQ))
-(vector-set! operate-12-disassemblers #x39
- (disassemble-operate-format 'SLL))
-(vector-set! operate-12-disassemblers #x3C
- (disassemble-operate-foramt 'SRA))
-(vector-set! operate-12-disassemblers #x34
- (disassemble-operate-foramt 'SRL))
-(vector-set! operate-10-disassemblers #x09
- (disassemble-operate-format 'SUBL))
-(vector-set! operate-10-disassemblers #x49
- (disassemble-operate-format 'SUBLV))
-(vector-set! operate-10-disassemblers #x29
- (disassemble-operate-format 'SUBQ))
-(vector-set! operate-10-disassemblers #x69
- (disassemble-operate-format 'SUBQV))
-(vector-set! operate-13-disassemblers #x30
- (disassemble-operate-format 'UMULH))
-(vector-set! operate-11-disassemblers #x40
- (disassemble-operate-format 'XOR))
-(vector-set! operate-12-disassemblers #x30
- (disassemble-operate-format 'ZAP))
-(vector-set! operate-12-disassemblers #x31
- (disassemble-operate-format 'ZAPNOT))
-
-;;; Punt PAL code for now!!!
-(define pal-op-codes (make-vector #x1E handle-bad-instruction))
-
-(vector-set! disassemblers #x00
- (lambda (word)
- (let ((function-code (extract word 0 26)))
- (cond ((zero? function-code)
- '(HALT))
- ((and (<= function-code #x9D)
- (<= #x80 function-code))
- (vector-ref pal-op-codes (- function-code #x80)))
- (else (invalid-instruction))))))
-
-(vector-set! pal-op-codes #x00 '(BPT))
-(vector-set! pal-op-codes #x01 '(BUGCHK))
-(vector-set! pal-op-codes #x02 '(CHME))
-(vector-set! pal-op-codes #x03 '(CHMK))
-(vector-set! pal-op-codes #x04 '(CHMS))
-(vector-set! pal-op-codes #x05 '(CHMU))
-(vector-set! pal-op-codes #x06 '(IMB))
-(vector-set! pal-op-codes #x07 '(INSQHIL))
-(vector-set! pal-op-codes #x08 '(INSQTIL))
-(vector-set! pal-op-codes #x09 '(INSQHIQ))
-(vector-set! pal-op-codes #x0A '(INSQTIQ))
-(vector-set! pal-op-codes #x0B '(INSQUEL))
-(vector-set! pal-op-codes #x0C '(INSQUEQ))
-(vector-set! pal-op-codes #x0D '(INSQUELD))
-(vector-set! pal-op-codes #x0E '(INSQUEQD))
-(vector-set! pal-op-codes #x0F '(PROBER))
-(vector-set! pal-op-codes #x10 '(PROBEW))
-(vector-set! pal-op-codes #x11 '(RD_PS))
-(vector-set! pal-op-codes #x12 '(REI))
-(vector-set! pal-op-codes #x13 '(REMQHIL))
-(vector-set! pal-op-codes #x14 '(REMQTIL))
-(vector-set! pal-op-codes #x15 '(REMQHIQ))
-(vector-set! pal-op-codes #x16 '(REMQTIQ))
-(vector-set! pal-op-codes #x17 '(REMQUEL))
-(vector-set! pal-op-codes #x18 '(REMQUEQ))
-(vector-set! pal-op-codes #x19 '(REMQUELD))
-(vector-set! pal-op-codes #x1A '(REMQUEQD))
-(vector-set! pal-op-codes #x1B '(SWASTEN))
-(vector-set! pal-op-codes #x1C '(WR_PS_SW))
-(vector-set! pal-op-codes #x1D '(RSCC))
-\f
-;;;; instr2.scm
-
-(vector-set! disassemblers #x1A
- (lambda (word)
- (let ((Ra (extract word 26 21))
- (Rb (extract word 21 16))
- (disp (extract-signed word 14 0))
- (op-name (vector-ref #(JMP JSR RET COROUTINE)
- (extract word 16 14))))
- (if (zero? disp)
- (if (= Ra regnum:came-from)
- `(,op-name ,Rb)
- `(,op-name ,Ra ,Rb))
- `(,op-name ,Ra ,Rb ,(relative-offset
- (extract-signed word 0 14)))))))
-
-(define ((disassemble-branch op-name) word)
- `(,op-name ,(extract word 21 26) ,(relative-offset
- (extract-signed word 0 21))))
-
-(define (relative-offset offset)
- (offset->@pcr (+ *current-offset (* 4 offset))))
-
-(define (offset->@pcr offset)
- `(@PCR ,(or (and disassembler/symbolize-output?
- (disassembler/lookup-symbol *symbol-table offset))
- offset)))
-
-(vector-set! disassemblers #x39 (disassemble-branch 'BEQ))
-(vector-set! disassemblers #x3E (disassemble-branch 'BGE))
-(vector-set! disassemblers #x3F (disassemble-branch 'BGT))
-(vector-set! disassemblers #x38 (disassemble-branch 'BLBC))
-(vector-set! disassemblers #x3C (disassemble-branch 'BLBS))
-(vector-set! disassemblers #x3B (disassemble-branch 'BLE))
-(vector-set! disassemblers #x3A (disassemble-branch 'BLT))
-(vector-set! disassemblers #x3D (disassemble-branch 'BNE))
-(vector-set! disassemblers #x31 (disassemble-branch 'FBEQ))
-(vector-set! disassemblers #x36 (disassemble-branch 'FBGE))
-(vector-set! disassemblers #x37 (disassemble-branch 'FBGT))
-(vector-set! disassemblers #x33 (disassemble-branch 'FBLE))
-(vector-set! disassemblers #x32 (disassemble-branch 'FBLT))
-(vector-set! disassemblers #x35 (disassemble-branch 'FBNE))
-
-(vector-set! disassemblers #x30 (disassemble-branch 'BR))
-(vector-set! disassemblers #x34 (disassemble-branch 'BSR))
-\f
-;;;; instr3.scm
-
-(define ((disassemble-float op-name) word)
- `(,op-name ,(extract word 21 26) ,(extract word 16 21) ,(extract word 0 5)))
-
-(define float-disassemblers (make-vector #x31 handle-bad-instruction))
-
-(vector-set! disassemblers #x17
- (lambda (word)
- (let ((function-code (extract word 5 16)))
- (cond ((< function-code #x31)
- ((vector-ref float-disassemblers function-code)
- word))
- ((= function-code #x530)
- ((disassemble-float 'CVTQLSV) word))
- ((= function-code #x130)
- ((disassemble-float 'CVTQLV) word))
- (else (invalid-instruction))))))
-
-(vector-set! float-disassemblers #x20 (disassemble-float 'CPYS))
-(vector-set! float-disassemblers #x22 (disassemble-float 'CPYSE))
-(vector-set! float-disassemblers #x21 (disassemble-float 'CPYSN))
-(vector-set! float-disassemblers #x10 (disassemble-float 'CVTLQ))
-(vector-set! float-disassemblers #x30 (disassemble-float 'CVTQL))
-(vector-set! float-disassemblers #x2A (disassemble-float 'FCMOVEQ))
-(vector-set! float-disassemblers #x2D (disassemble-float 'FCMOVGE))
-(vector-set! float-disassemblers #x2F (disassemble-float 'FCMOVGT))
-(vector-set! float-disassemblers #x2E (disassemble-float 'FCMOVLE))
-(vector-set! float-disassemblers #x2C (disassemble-float 'FCMOVLT))
-(vector-set! float-disassemblers #x2B (disassemble-float 'FCMOVNE))
-(vector-set! float-disassemblers #x25 (disassemble-float 'MF_FPCR))
-(vector-set! float-disassemblers #x24 (disassemble-float 'MT_FPCR))
-
-(define (setup-float-disassemblers-table vector options table)
- (let row-loop ((rows table))
- (if (pair? rows)
- (let ((row (car rows)))
- (let ((op-name (car row)))
- (let column-loop
- ((cols (cdr row))
- (options options))
- (if (pair? cols)
- (begin
- (if (not (null? (car cols)))
- (vector-set! vector (car cols)
- (if (null? (car options))
- (lambda (word)
- `(,op-name ,(extract word 21 26)
- ,(extract word 16 21)
- ,(extract word 0 5)))
- (lambda (word)
- `(,op-name (/ . ,(car options))
- ,(extract word 21 26)
- ,(extract word 16 21)
- ,(extract word 0 5))))))
- (column-loopf (cdr cols) (cdr options))))))
- (row-loop (cdr rows))))))
-
-(define ieee-float-disassemblers (make-vector #x7FF handle-bad-instruction))
-
-(vector-set! disassemblers #x16
- (lambda (word)
- (let ((function-code (extract word 5 16)))
- ((vector-ref ieee-float-disassemblers function-code) word))))
-
-(setup-float-disassemblers-table
- ieee-float-disassemblers
- '( () (C) (M) (D) (U) (U C) (U M) (U D))
- '((ADDS #x080 #x000 #x040 #x0C0 #x180 #x100 #x140 #x1C0)
- (ADDT #x0A0 #x020 #x060 #x0E0 #x1A0 #x120 #x160 #x1E0)
- (CMPTEQ #x0A5)
- (CMPTLT #x0A6)
- (CMPTLE #x0A7)
- (CMPTUN #x0A4)
- (CVTQS #x0BC #x03C #x07C #x0FC)
- (CVTQT #x0BE #x03E #x07E #x0FE)
- (CVTTS #x0AC #x02C #x06C #x0EC #x1AC #x12C #x16C #x1EC)
- (DIVS #x083 #x003 #x043 #x0C3 #x183 #x103 #x143 #x1C3)
- (DIVT #x0A3 #x023 #x063 #x0E3 #x1A3 #x123 #x163 #x1E3)
- (MULS #x082 #x002 #x042 #x0C2 #x182 #x102 #x142 #x1C2)
- (MULT #x0A2 #x022 #x062 #x0E2 #x1A2 #x122 #x162 #x1E2)
- (SUBS #x081 #x001 #x041 #x0C1 #x181 #x101 #x141 #x1C1)
- (SUBT #x0A1 #x021 #x061 #x0E1 #x1A1 #x121 #x161 #x1E1)))
-
-(setup-float-disassemblers-table
- ieee-float-disassemblers
- '( (S U)(S U C)(S U M)(S U D)(S U I)(S U I C)(S U I M)(S U I D))
- '((ADDS #x580 #x500 #x540 #x5C0 #x780 #x700 #x740 #x7C0)
- (ADDT #x5A0 #x520 #x560 #x5E0 #x7A0 #x720 #x760 #x7E0)
- (CMPTEQ #x5A5)
- (CMPTLT #x5A6)
- (CMPTLE #x5A7)
- (CMPTUN #x5A4)
- (CVTQS () () () () #x7BC #x73C #x77C #x7FC)
- (CVTQT () () () () #x7BE #x73E #x77E #x7FE)
- (CVTTS #x5AC #x52C #x56C #x5EC #x7AC #x72C #x76C #x7EC)
- (DIVS #x583 #x503 #x543 #x5C3 #x783 #x703 #x743 #x7C3)
- (DIVT #x5A3 #x523 #x563 #x5E3 #x7A3 #x723 #x763 #x7E3)
- (MULS #x582 #x502 #x542 #x5C2 #x782 #x702 #x742 #x7C2)
- (MULT #x5A2 #x522 #x562 #x5E2 #x7A2 #x722 #x762 #x7E2)
- (SUBS #x581 #x501 #x541 #x5C1 #x781 #x701 #x741 #x7C1)
- (SUBT #x5A1 #x521 #x561 #x5E1 #x7A1 #x721 #x761 #x7E1)))
-
-(setup-float-disassemblers-table
- ieee-float-disassemblers
- '( () (C) (V) (V C) (S V) (S V C) (S V I) (S V I C))
- '((CVTTQ #x0AF #x02F #x1AF #x12F #x5AF #x52F #x7AF #x72F)))
-
-(setup-float-disasemblers-table
- ieee-float-disassemblers
- '( (D) (V D) (S V D)(S V I D)(M) (V M) (S V M) (S V I M))
- '((CVTTQ #x0EF #x1EF #x5EF #x7EF #x06F #x16F #x56F #x76F)))
-
-(define vax-float-disassemblers (make-vector #x7FF handle-bad-instruction))
-
-(vector-set! disassemblers #x15
- (lambda (word)
- (let ((function-code (extract word 5 16)))
- ((vector-ref vax-float-disassemblers function-code) word))))
-
-
-(setup-float-disassemblers-table
- vax-float-disassemblers
- '( () (C) (U) (U C) (S) (S C) (S U) (S U C))
- '((ADDF #x080 #x000 #x180 #x100 #x480 #x400 #x580 #x500)
- (CVTDG #x09E #x01E #x19E #x11E #x49E #x41E #x59E #x51E)
- (ADDG #x0A0 #x020 #x1A0 #x120 #x4A0 #x420 #x5A0 #x520)
- (CMPGEQ #x0A5 () () () #x4A5)
- (CMPGLT #x0A6 () () () #x4A6)
- (CMPGLE #x0A7 () () () #x4A7)
- (CVTGF #x0AC #x02C #x1AC #x12C #x4AC #x42C #x5AC #x52C)
- (CVTGD #x0AD #x02D #x1AD #x12D #x4AD #x42D #x5AD #x52D)
- (CVTQF #x0BC #x03C)
- (CVTQG #x0BE #x03E)
- (DIVF #x083 #x003 #x183 #x103 #x483 #x403 #x583 #x503)
- (DIVG #x0A3 #x023 #x1A3 #x123 #x4A3 #x423 #x5A3 #x523)
- (MULF #x082 #x002 #x182 #x102 #x482 #x402 #x582 #x502)
- (MULG #x0A2 #x022 #x1A2 #x122 #x4A2 #x422 #x5A2 #x522)
- (SUBF #x081 #x001 #x181 #x101 #x481 #x401 #x581 #x501)
- (SUBG #x0A1 #x021 #x1A1 #x121 #x4A1 #x421 #x5A1 #x521)))
-
-(setup-float-disassemblers-table
- vax-float-disassemblers
- '( () (C) (V) (V C) (S) (S C) (S V) (S V C))
- '((CVTGQ #x0AF #x02F #x1AF #x12F #x4AF #X42F #x5AF #x52F)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Compiler File Dependencies
-;;; package: (compiler declarations)
-
-(declare (usual-integrations))
-\f
-(define (initialize-package!)
- (add-event-receiver! event:after-restore reset-source-nodes!)
- (reset-source-nodes!))
-
-(define (reset-source-nodes!)
- (set! source-filenames '())
- (set! source-hash)
- (set! source-nodes)
- (set! source-nodes/by-rank)
- unspecific)
-
-(define (maybe-setup-source-nodes!)
- (if (null? source-filenames)
- (setup-source-nodes!)))
-
-(define (setup-source-nodes!)
- (let ((filenames
- (append-map!
- (lambda (subdirectory)
- (map (lambda (pathname)
- (string-append subdirectory
- "/"
- (pathname-name pathname)))
- (directory-read
- (string-append subdirectory
- "/"
- source-file-expression))))
- '("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt"
- "machines/alpha"))))
- (if (null? filenames)
- (error "Can't find source files of compiler"))
- (set! source-filenames filenames))
- (set! source-hash (make-string-hash-table))
- (set! source-nodes
- (map (lambda (filename)
- (let ((node (make/source-node filename)))
- (hash-table/put! source-hash filename node)
- node))
- source-filenames))
- (initialize/syntax-dependencies!)
- (initialize/integration-dependencies!)
- (source-nodes/rank!))
-
-(define source-file-expression "*.scm")
-(define source-filenames)
-(define source-hash)
-(define source-nodes)
-(define source-nodes/by-rank)
-
-(define (filename/append directory . names)
- (map (lambda (name) (string-append directory "/" name)) names))
-\f
-(define-structure (source-node
- (conc-name source-node/)
- (constructor %make/source-node (filename pathname)))
- (filename #f read-only #t)
- (pathname #f read-only #t)
- (forward-links '())
- (backward-links '())
- (forward-closure '())
- (backward-closure '())
- (dependencies '())
- (dependents '())
- (rank #f)
- (syntax-table #f)
- (declarations '())
- (modification-time #f))
-
-(define (make/source-node filename)
- (%make/source-node filename (->pathname filename)))
-
-(define (filename->source-node filename)
- (let ((node (hash-table/get source-hash filename #f)))
- (if (not node)
- (error "Unknown source file:" filename))
- node))
-
-(define (source-node/circular? node)
- (memq node (source-node/backward-closure node)))
-
-(define (source-node/link! node dependency)
- (if (not (memq dependency (source-node/backward-links node)))
- (begin
- (set-source-node/backward-links!
- node
- (cons dependency (source-node/backward-links node)))
- (set-source-node/forward-links!
- dependency
- (cons node (source-node/forward-links dependency)))
- (source-node/close! node dependency))))
-
-(define (source-node/close! node dependency)
- (if (not (memq dependency (source-node/backward-closure node)))
- (begin
- (set-source-node/backward-closure!
- node
- (cons dependency (source-node/backward-closure node)))
- (set-source-node/forward-closure!
- dependency
- (cons node (source-node/forward-closure dependency)))
- (for-each (lambda (dependency)
- (source-node/close! node dependency))
- (source-node/backward-closure dependency))
- (for-each (lambda (node)
- (source-node/close! node dependency))
- (source-node/forward-closure node)))))
-\f
-;;;; Rank
-
-(define (source-nodes/rank!)
- (compute-dependencies! source-nodes)
- (compute-ranks! source-nodes)
- (set! source-nodes/by-rank (source-nodes/sort-by-rank source-nodes))
- unspecific)
-
-(define (compute-dependencies! nodes)
- (for-each (lambda (node)
- (set-source-node/dependencies!
- node
- (list-transform-negative (source-node/backward-closure node)
- (lambda (node*)
- (memq node (source-node/backward-closure node*)))))
- (set-source-node/dependents!
- node
- (list-transform-negative (source-node/forward-closure node)
- (lambda (node*)
- (memq node (source-node/forward-closure node*))))))
- nodes))
-
-(define (compute-ranks! nodes)
- (let loop ((nodes nodes) (unranked-nodes '()))
- (if (null? nodes)
- (if (not (null? unranked-nodes))
- (loop unranked-nodes '()))
- (loop (cdr nodes)
- (let ((node (car nodes)))
- (let ((rank (source-node/rank* node)))
- (if rank
- (begin
- (set-source-node/rank! node rank)
- unranked-nodes)
- (cons node unranked-nodes))))))))
-
-(define (source-node/rank* node)
- (let loop ((nodes (source-node/dependencies node)) (rank -1))
- (if (null? nodes)
- (1+ rank)
- (let ((rank* (source-node/rank (car nodes))))
- (and rank*
- (loop (cdr nodes) (max rank rank*)))))))
-
-(define (source-nodes/sort-by-rank nodes)
- (sort nodes (lambda (x y) (< (source-node/rank x) (source-node/rank y)))))
-\f
-;;;; File Syntaxer
-
-(define (syntax-files!)
- (maybe-setup-source-nodes!)
- (for-each
- (lambda (node)
- (let ((modification-time
- (let ((source (modification-time node "scm"))
- (binary (modification-time node "bin")))
- (if (not source)
- (error "Missing source file" (source-node/filename node)))
- (and binary (< source binary) binary))))
- (set-source-node/modification-time! node modification-time)
- (if (not modification-time)
- (begin (write-string "\nSource file newer than binary: ")
- (write (source-node/filename node))))))
- source-nodes)
- (if compiler:enable-integration-declarations?
- (begin
- (for-each
- (lambda (node)
- (let ((time (source-node/modification-time node)))
- (if (and time
- (there-exists? (source-node/dependencies node)
- (lambda (node*)
- (let ((newer?
- (let ((time*
- (source-node/modification-time node*)))
- (or (not time*)
- (> time* time)))))
- (if newer?
- (begin
- (write-string "\nBinary file ")
- (write (source-node/filename node))
- (write-string " newer than dependency ")
- (write (source-node/filename node*))))
- newer?))))
- (set-source-node/modification-time! node #f))))
- source-nodes)
- (for-each
- (lambda (node)
- (if (not (source-node/modification-time node))
- (for-each (lambda (node*)
- (if (source-node/modification-time node*)
- (begin
- (write-string "\nBinary file ")
- (write (source-node/filename node*))
- (write-string " depends on ")
- (write (source-node/filename node))))
- (set-source-node/modification-time! node* #f))
- (source-node/forward-closure node))))
- source-nodes)))
- (for-each (lambda (node)
- (if (not (source-node/modification-time node))
- (pathname-delete!
- (pathname-new-type (source-node/pathname node) "ext"))))
- source-nodes/by-rank)
- (write-string "\n\nBegin pass 1:")
- (for-each (lambda (node)
- (if (not (source-node/modification-time node))
- (source-node/syntax! node)))
- source-nodes/by-rank)
- (if (there-exists? source-nodes/by-rank
- (lambda (node)
- (and (not (source-node/modification-time node))
- (source-node/circular? node))))
- (begin
- (write-string "\n\nBegin pass 2:")
- (for-each (lambda (node)
- (if (not (source-node/modification-time node))
- (if (source-node/circular? node)
- (source-node/syntax! node)
- (source-node/touch! node))))
- source-nodes/by-rank))))
-\f
-(define (source-node/touch! node)
- (with-values
- (lambda ()
- (sf/pathname-defaulting (source-node/pathname node) "" #f))
- (lambda (input-pathname bin-pathname spec-pathname)
- input-pathname
- (pathname-touch! bin-pathname)
- (pathname-touch! (pathname-new-type bin-pathname "ext"))
- (if spec-pathname (pathname-touch! spec-pathname)))))
-
-(define (pathname-touch! pathname)
- (if (file-exists? pathname)
- (begin
- (write-string "\nTouch file: ")
- (write (enough-namestring pathname))
- (file-touch pathname))))
-
-(define (pathname-delete! pathname)
- (if (file-exists? pathname)
- (begin
- (write-string "\nDelete file: ")
- (write (enough-namestring pathname))
- (delete-file pathname))))
-
-(define (sc filename)
- (maybe-setup-source-nodes!)
- (source-node/syntax! (filename->source-node filename)))
-
-(define (source-node/syntax! node)
- (with-values
- (lambda ()
- (sf/pathname-defaulting (source-node/pathname node) "" #f))
- (lambda (input-pathname bin-pathname spec-pathname)
- (sf/internal
- input-pathname bin-pathname spec-pathname
- (source-node/syntax-table node)
- ((if compiler:enable-integration-declarations?
- identity-procedure
- (lambda (declarations)
- (list-transform-negative declarations
- integration-declaration?)))
- (source-node/declarations node))))))
-
-(define-integrable (modification-time node type)
- (file-modification-time
- (pathname-new-type (source-node/pathname node) type)))
-\f
-;;;; Syntax dependencies
-
-(define (initialize/syntax-dependencies!)
- (let ((file-dependency/syntax/join
- (lambda (filenames syntax-table)
- (for-each (lambda (filename)
- (set-source-node/syntax-table!
- (filename->source-node filename)
- syntax-table))
- filenames))))
- (file-dependency/syntax/join
- (append (filename/append "base"
- "toplev" "asstop" "crstop"
- "blocks" "cfg1" "cfg2" "cfg3" "constr"
- "contin" "ctypes" "debug" "enumer"
- "infnew" "lvalue" "object" "pmerly" "proced"
- "refctx" "rvalue" "scode" "sets" "subprb"
- "switch" "utils")
- (filename/append "back"
- "asmmac" "bittop" "bitutl" "insseq" "lapgn1"
- "lapgn2" "lapgn3" "linear" "regmap" "symtab"
- "syntax")
- (filename/append "machines/alpha"
- "dassm1" "insmac" "lapopt" "machin" "rgspcm"
- "rulrew")
- (filename/append "fggen"
- "declar" "fggen" "canon")
- (filename/append "fgopt"
- "blktyp" "closan" "conect" "contan" "delint"
- "desenv" "envopt" "folcon" "offset" "operan"
- "order" "outer" "param" "reord" "reteqv" "reuse"
- "sideff" "simapp" "simple" "subfre" "varind")
- (filename/append "rtlbase"
- "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp"
- "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2"
- "valclass")
- (filename/append "rtlgen"
- "fndblk" "fndvar" "opncod" "rgcomb" "rgproc"
- "rgretn" "rgrval" "rgstmt" "rtlgen")
- (filename/append "rtlopt"
- "ralloc" "rcompr" "rcse1" "rcse2" "rcseep"
- "rcseht" "rcserq" "rcsesr" "rdebug" "rdflow"
- "rerite" "rinvex" "rlife" "rtlcsm"))
- (->environment '(COMPILER)))
- (file-dependency/syntax/join
- (filename/append "machines/alpha"
- "lapgen"
- "rules1" "rules2" "rules3" "rules4" "rulfix" "rulflo"
- "instr1" "instr2" "instr3")
- (->environment '(COMPILER LAP-SYNTAXER)))))
-\f
-;;;; Integration Dependencies
-
-(define (initialize/integration-dependencies!)
-
- (define (add-declaration! declaration filenames)
- (for-each (lambda (filenames)
- (let ((node (filename->source-node filenames)))
- (set-source-node/declarations!
- node
- (cons declaration
- (source-node/declarations node)))))
- filenames))
-
- (let* ((front-end-base
- (filename/append "base"
- "blocks" "cfg1" "cfg2" "cfg3"
- "contin" "ctypes" "enumer" "lvalue"
- "object" "proced" "rvalue"
- "scode" "subprb" "utils"))
- (alpha-base
- (append (filename/append "machines/alpha" "machin")
- (filename/append "back" "asutl")))
- (rtl-base
- (filename/append "rtlbase"
- "regset" "rgraph" "rtlcfg" "rtlobj"
- "rtlreg" "rtlty1" "rtlty2"))
- (cse-base
- (filename/append "rtlopt"
- "rcse1" "rcseht" "rcserq" "rcsesr"))
- (cse-all
- (append (filename/append "rtlopt"
- "rcse2" "rcseep")
- cse-base))
- (instruction-base
- (filename/append "machines/alpha" "assmd" "machin"))
- (lapgen-base
- (append (filename/append "back" "linear" "regmap")
- (filename/append "machines/alpha" "lapgen")))
- (assembler-base
- (filename/append "back" "symtab"))
- (lapgen-body
- (append
- (filename/append "back" "lapgn1" "lapgn2" "syntax")
- (filename/append "machines/alpha"
- "rules1" "rules2" "rules3" "rules4"
- "rulfix" "rulflo"
- )))
- (assembler-body
- (append
- (filename/append "back" "bittop")
- (filename/append "machines/alpha"
- "instr1" "instr2" "instr3"))))
-
- (define (file-dependency/integration/join filenames dependencies)
- (for-each (lambda (filename)
- (file-dependency/integration/make filename dependencies))
- filenames))
-
- (define (file-dependency/integration/make filename dependencies)
- (let ((node (filename->source-node filename)))
- (for-each (lambda (dependency)
- (let ((node* (filename->source-node dependency)))
- (if (not (eq? node node*))
- (source-node/link! node node*))))
- dependencies)))
-
- (define (define-integration-dependencies directory name directory* . names)
- (file-dependency/integration/make
- (string-append directory "/" name)
- (apply filename/append directory* names)))
-
- (define-integration-dependencies "machines/alpha" "machin" "back" "asutl")
- (define-integration-dependencies "base" "object" "base" "enumer")
- (define-integration-dependencies "base" "enumer" "base" "object")
- (define-integration-dependencies "base" "utils" "base" "scode")
- (define-integration-dependencies "base" "cfg1" "base" "object")
- (define-integration-dependencies "base" "cfg2" "base"
- "cfg1" "cfg3" "object")
- (define-integration-dependencies "base" "cfg3" "base" "cfg1" "cfg2")
- (define-integration-dependencies "base" "ctypes" "base"
- "blocks" "cfg1" "cfg2" "cfg3" "contin" "lvalue" "object" "subprb")
- (define-integration-dependencies "base" "rvalue" "base"
- "blocks" "cfg1" "cfg2" "cfg3" "enumer" "lvalue" "object" "utils")
- (define-integration-dependencies "base" "lvalue" "base"
- "blocks" "object" "proced" "rvalue" "utils")
- (define-integration-dependencies "base" "blocks" "base"
- "enumer" "lvalue" "object" "proced" "rvalue" "scode")
- (define-integration-dependencies "base" "proced" "base"
- "blocks" "cfg1" "cfg2" "cfg3" "contin" "enumer" "lvalue" "object"
- "rvalue" "utils")
- (define-integration-dependencies "base" "contin" "base"
- "blocks" "cfg3" "ctypes")
- (define-integration-dependencies "base" "subprb" "base"
- "cfg3" "contin" "enumer" "object" "proced")
-
- (define-integration-dependencies "machines/alpha" "machin" "rtlbase"
- "rtlreg" "rtlty1" "rtlty2")
-
- (define-integration-dependencies "rtlbase" "regset" "base")
- (define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2")
- (define-integration-dependencies "rtlbase" "rgraph" "machines/alpha"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlcfg" "base"
- "cfg1" "cfg2" "cfg3")
- (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils")
- (define-integration-dependencies "rtlbase" "rtlcon" "machines/alpha"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlexp" "rtlbase"
- "rtlreg" "rtlty1")
- (define-integration-dependencies "rtlbase" "rtline" "base" "cfg1" "cfg2")
- (define-integration-dependencies "rtlbase" "rtline" "rtlbase"
- "rtlcfg" "rtlty2")
- (define-integration-dependencies "rtlbase" "rtlobj" "base"
- "cfg1" "object" "utils")
- (define-integration-dependencies "rtlbase" "rtlreg" "machines/alpha"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlreg" "rtlbase"
- "rgraph" "rtlty1")
- (define-integration-dependencies "rtlbase" "rtlty1" "rtlbase" "rtlcfg")
- (define-integration-dependencies "rtlbase" "rtlty2" "base" "scode")
- (define-integration-dependencies "rtlbase" "rtlty2" "machines/alpha"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlty2" "rtlbase" "rtlty1")
-
- (file-dependency/integration/join
- (append
- (filename/append "base" "refctx")
- (filename/append "fggen"
- "declar" "fggen") ; "canon" needs no integrations
- (filename/append "fgopt"
- "blktyp" "closan" "conect" "contan" "delint" "desenv"
- "envopt" "folcon" "offset" "operan" "order" "param"
- "outer" "reuse" "reteqv" "sideff" "simapp" "simple"
- "subfre" "varind"))
- (append alpha-base front-end-base))
-
- (define-integration-dependencies "fgopt" "reuse" "fgopt" "reord")
-
- (file-dependency/integration/join
- (filename/append "rtlgen"
- "fndblk" "fndvar" "opncod" "rgcomb" "rgproc" "rgretn"
- "rgrval" "rgstmt" "rtlgen")
- (append alpha-base front-end-base rtl-base))
-
- (file-dependency/integration/join
- (append cse-all
- (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow"
- "rerite" "rinvex" "rlife" "rtlcsm")
- (filename/append "machines/alpha" "rulrew"))
- (append alpha-base rtl-base))
-
- (file-dependency/integration/join cse-all cse-base)
-
- (file-dependency/integration/join
- (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife")
- (filename/append "rtlbase" "regset"))
-
- (file-dependency/integration/join
- (filename/append "rtlopt" "rcseht" "rcserq")
- (filename/append "base" "object"))
-
- (define-integration-dependencies "rtlopt" "rlife" "base" "cfg2")
-
- (let ((dependents
- (append instruction-base
- lapgen-base
- lapgen-body
- assembler-base
- assembler-body
- (filename/append "back" "linear" "syerly"))))
- (add-declaration! '(USUAL-DEFINITION (SET EXPT)) dependents)
- (file-dependency/integration/join dependents instruction-base))
-
- (file-dependency/integration/join (append lapgen-base lapgen-body)
- lapgen-base)
-
- (file-dependency/integration/join (append assembler-base assembler-body)
- assembler-base)
-
- (define-integration-dependencies "back" "lapgn1" "base"
- "cfg1" "cfg2" "utils")
- (define-integration-dependencies "back" "lapgn1" "rtlbase"
- "regset" "rgraph" "rtlcfg")
- (define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg")
- (define-integration-dependencies "back" "linear" "base" "cfg1" "cfg2")
- (define-integration-dependencies "back" "linear" "rtlbase" "rtlcfg")
- (define-integration-dependencies "back" "mermap" "back" "regmap")
- (define-integration-dependencies "back" "regmap" "base" "utils")
- (define-integration-dependencies "back" "symtab" "base" "utils"))
-
- (for-each (lambda (node)
- (let ((links (source-node/backward-links node)))
- (if (not (null? links))
- (set-source-node/declarations!
- node
- (cons (make-integration-declaration
- (source-node/pathname node)
- (map source-node/pathname links))
- (source-node/declarations node))))))
- source-nodes))
-
-(define (make-integration-declaration pathname integration-dependencies)
- `(INTEGRATE-EXTERNAL
- ,@(map (let ((default
- (make-pathname
- #f
- #f
- (cons 'RELATIVE
- (make-list
- (length (cdr (pathname-directory pathname)))
- 'UP))
- #f
- #f
- #f)))
- (lambda (pathname)
- (merge-pathnames pathname default)))
- integration-dependencies)))
-
-(define-integrable (integration-declaration? declaration)
- (eq? (car declaration) 'INTEGRATE-EXTERNAL))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;; Alpha Instruction Set Macros. Early version
-;;; Package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-
-(define-syntax define-instruction
- (non-hygienic-macro-transformer
- (lambda (opcode . patterns)
- `(SET! EARLY-INSTRUCTIONS
- (CONS
- (LIST ',opcode
- ,@(map (lambda (pattern)
- `(early-parse-rule
- ',(car pattern)
- (lambda (pat vars)
- (early-make-rule
- pat
- vars
- (scode-quote
- (instruction->instruction-sequence
- ,(parse-instruction (cadr pattern)
- (cddr pattern)
- #t)))))))
- patterns))
- EARLY-INSTRUCTIONS)))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Alpha Instruction Set Macros
-;;; Package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Definition macros
-
-(define-syntax define-symbol-transformer
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INTEGRABLE (,(cadr form) SYMBOL)
- (LET ((PLACE (ASSQ SYMBOL ',(cddr form))))
- (IF (PAIR? PLACE)
- (CDR PLACE)
- #F))))))
-
-(define-syntax define-transformer
- (rsc-macro-transformer
- (lambda (form environment)
- `(,(close-syntax 'DEFINE environment) ,@(cdr form)))))
-
-;;;; Fixed width instruction parsing
-
-(define (parse-instruction first-word tail early? environment)
- (if (not (null? tail))
- (error "Unknown format:" (cons first-word tail)))
- (let loop ((first-word first-word))
- (case (car first-word)
- ((LONG)
- (process-fields (cdr first-word) early? environment))
- ((VARIABLE-WIDTH)
- (process-variable-width first-word early? environment))
- ((IF)
- `(,(close-syntax 'IF environment)
- ,(cadr first-word)
- ,(loop (caddr first-word))
- ,(loop (cadddr first-word))))
- (else
- (error "Unknown format:" first-word)))))
-
-(define (process-variable-width descriptor early? environment)
- (let ((binding (cadr descriptor))
- (clauses (cddr descriptor)))
- `(,(close-syntax 'LIST environment)
- ,(variable-width-expression-syntaxer
- (car binding) ; name
- (cadr binding) ; expression
- environment
- (map (lambda (clause)
- (call-with-values
- (lambda ()
- (expand-fields (cdadr clause) early? environment))
- (lambda (code size)
- (if (not (zero? (remainder size 32)))
- (error "Bad clause size:" size))
- `((,(close-syntax 'LIST environment)
- ,(optimize-group-syntax code early? environment))
- ,size
- ,@(car clause)))))
- clauses)))))
-\f
-(define (process-fields fields early? environment)
- (call-with-values (lambda () (expand-fields fields early? environment))
- (lambda (code size)
- (if (not (zero? (remainder size 32)))
- (error "process-fields: bad syllable size" size))
- `(,(close-syntax 'LIST environment)
- ,(optimize-group-syntax code early? environment)))))
-
-(define (expand-fields fields early? environment)
- (let expand ((first-word '()) (word-size 0) (fields fields))
- (if (pair? fields)
- (call-with-values
- (lambda () (expand-field (car fields) early? environment))
- (lambda (car-field car-size)
- (if (= 32 (+ word-size car-size))
- (call-with-values (lambda () (expand '() 0 (cdr fields)))
- (lambda (tail tail-size)
- (values (append (cons car-field first-word) tail)
- (+ car-size tail-size))))
- (call-with-values
- (lambda ()
- (expand (cons car-field first-word)
- (+ car-size word-size)
- (cdr fields)))
- (lambda (tail tail-size)
- (values (if (zero? car-size)
- (cons car-field tail)
- tail)
- (+ car-size tail-size)))))))
- (values '() 0))))
-
-(define (expand-field field early? environment)
- early? ; ignored for now
- (let ((size (car field))
- (expression (cadr field)))
-
- (define (default type)
- (values (integer-syntaxer expression environment type size)
- size))
-
- (if (pair? (cddr field))
- (case (caddr field)
- ((PC-REL)
- (values (integer-syntaxer ``(,',(close-syntax '- environment)
- ,,expression
- (,',(close-syntax '+ environment)
- ,',(close-syntax '*PC* environment)
- 4))
- environment
- (cadddr field)
- size)
- size))
- ((BLOCK-OFFSET)
- (values `(,(close-syntax 'LIST environment)
- 'BLOCK-OFFSET
- ,expression)
- size))
- (else
- (default (caddr field))))
- (default 'UNSIGNED))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Alpha instruction set
-;;; Package: (compiler lap-syntaxer)
-
-;; Branch-tensioned instructions are in instr2.scm
-;; Floating point instructions are in instr3.scm
-
-(declare (usual-integrations))
-\f
-(let-syntax
- ((memory-format-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? destination) (OFFSET (? offset) (? base)))
- (VARIABLE-WIDTH (offset offset)
- ((#x-8000 #x7FFF)
- (LONG (6 ,(caddr form))
- (5 destination)
- (5 base)
- (16 offset SIGNED)))
- ((#x-80000000 #x7FFFFFFF)
- ;; LDAH temp, left[offset](base)
- ;; LDx/STx destination, right[offset](temp)
- (LONG (6 #x09) ; LDAH
- (5 regnum:volatile-scratch) ; destination = temp
- (5 base) ; base
- (16 (adjusted:high offset) SIGNED)
- (6 ,(caddr form)) ; LDx/STx
- (5 destination) ; destination
- (5 regnum:volatile-scratch) ; base = temp
- (16 (adjusted:low offset) SIGNED))))))))))
- (memory-format-instruction LDA #x08) ; Load Address
- (memory-format-instruction LDAH #x09) ; Load Address High
- (memory-format-instruction LDF #x20) ; Load F floating from memory
- (memory-format-instruction LDG #x21) ; Load G floating from memory
- (memory-format-instruction LDL #x28) ; Load sext long
- (memory-format-instruction LDL_L #x2A) ; Load sext long, locked
- (memory-format-instruction LDQ #x29) ; Load quadword
- (memory-format-instruction LDQ_L #x2B) ; Load quadword, locked
- (memory-format-instruction LDQ_U #x0B) ; Load quadword unaligned
- (memory-format-instruction LDS #x22) ; Load S floating from memory
- (memory-format-instruction LDT #x23) ; Load IEEE T floating from memory
- (memory-format-instruction STF #x24) ; Store F floating to memory
- (memory-format-instruction STG #x25) ; Store G floating to memory
- (memory-format-instruction STL #x2C) ; Store long
- (memory-format-instruction STL_C #x2E) ; Store long, conditional
- (memory-format-instruction STQ #x2D) ; Store quadword
- (memory-format-instruction STQ_C #x2F) ; Store quadword, conditional
- (memory-format-instruction STQ_U #x0F) ; Store quadword unaligned
- (memory-format-instruction STS #x26) ; Store S floating to memory
- (memory-format-instruction STT #x27) ; Store IEEE T floating to memory
- )
-
-(define-instruction MOVEI
- (((? destination) (& (? constant)))
- (LONG (6 #x08) ; LDA
- (5 destination)
- (5 regnum:zero)
- (16 constant SIGNED))))
-\f
-(define-instruction COPY
- (((? source) (? destination))
- (LONG (6 #x11) ; Arithmetic/Logical
- (5 source)
- (5 source)
- (3 0) ; Should be zero
- (1 0) ; Must be zero
- (7 #x20) ; BIS
- (5 destination))))
-
-(let-syntax
- ((special-memory-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (()
- (LONG (6 #x18)
- (5 #x0)
- (5 #x0)
- (16 ,(caddr form))))))))
- (special-memory-instruction-Ra
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? Ra))
- (LONG (6 #x18)
- (5 Ra)
- (5 #x0)
- (16 ,(caddr form))))))))
- (special-memory-instruction-Rb
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? Rb))
- (LONG (6 #x18)
- (5 #x0)
- (5 Rb)
- (16 ,(caddr form)))))))))
- (special-memory-instruction DRAINT #x0000) ; Drain instruction pipe
- (special-memory-instruction-Rb FETCH #x8000) ; Prefetch data
- (special-memory-instruction-Rb FETCH_M #xA000); Prefetch data, modify intent
- (special-memory-instruction MB #x4000) ; Memory barrier
- (special-memory-instruction-Ra RC #xE000) ; Read and clear (VAX converter)
- (special-memory-instruction-Ra RPCC #xC000) ; Read process cycle counter
- (special-memory-instruction-Ra RS #xF000) ; Read and set (VAX converter)
- (special-memory-instruction TRAPB #x0000) ; Trap barrier
- )
-\f
-(let-syntax
- ((operate-format
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? source-1) (& (? constant)) (? destination))
- (LONG (6 ,(caddr form))
- (5 source-1)
- (8 constant UNSIGNED)
- (1 1) ; Must be one
- (7 ,(cadddr form))
- (5 destination)))
- (((? source-1) (? source-2) (? destination))
- (LONG (6 ,(caddr form))
- (5 source-1)
- (5 source-2)
- (3 0) ; Should be zero
- (1 0) ; Must be zero
- (7 ,(cadddr form))
- (5 destination))))))))
- (operate-format ADDL #x10 #x00) ; Add longword
- (operate-format ADDLV #x10 #x40) ; Add longword, enable oflow trap
- (operate-format ADDQ #x10 #x20) ; Add quadword
- (operate-format ADDQV #x10 #x60) ; Add quadword, enable oflow trap
- (operate-format AND #x11 #x00) ; Logical product
- (operate-format BIC #x11 #x08) ; Bit clear
- (operate-format BIS #x11 #x20) ; Bit set (logical sum, OR)
- (operate-format CMOVEQ #x11 #x24) ; Rc <- Rb if Ra = 0
- (operate-format CMOVGE #x11 #x46) ; Rc <- Rb if Ra >= 0
- (operate-format CMOVGT #x11 #x66) ; Rc <- Rb if Ra > 0
- (operate-format CMOVLBC #x11 #x16) ; Rc <- Rb if Ra low bit clear
- (operate-format CMOVLBS #x11 #x14) ; Rc <- Rb if Ra low bit set
- (operate-format CMOVLE #x11 #x64) ; Rc <- Rb if Ra <= 0
- (operate-format CMOVLT #x11 #x44) ; Rc <- Rb if Ra < 0
- (operate-format CMOVNE #x11 #x26) ; Rc <- Rb if Ra != 0
- (operate-format CMPBGE #x10 #x0f) ; Compare 8 bytes in parallel
- (operate-format CMPEQ #x10 #x2d) ; Compare quadwords for equal
- (operate-format CMPLE #x10 #x6d) ; Compare quadwords for <=
- (operate-format CMPLT #x10 #x4d) ; Compare quadwords for <
- (operate-format CMPULE #x10 #x3d) ; Unsigned compare quadwords for <=
- (operate-format CMPULT #x10 #x1d) ; Unsigned compare quadwords for <
- (operate-format EQV #x11 #x48) ; Bitwise logical equivalence
- (operate-format EXTBL #x12 #x06) ; Extract byte low
- (operate-format EXTLH #x12 #x6a) ; Extract longword high
- (operate-format EXTLL #x12 #x26) ; Extract longword low
- (operate-format EXTQH #x12 #x7a) ; Extract quadword high
- (operate-format EXTQL #x12 #x36) ; Extract quadword low
- (operate-format EXTWH #x12 #x5a) ; Extract word high
- (operate-format EXTWL #x12 #x16) ; Extract word low
- (operate-format INSBL #x12 #x0b) ; Insert byte low
- (operate-format INSLH #x12 #x67) ; Insert longword high
- (operate-format INSLL #x12 #x2b) ; Insert longword low
- (operate-format INSQH #x12 #x77) ; Insert quadword high
- (operate-format INSQL #x12 #x3b) ; Insert quadword low
- (operate-format INSWH #x12 #x57) ; Insert word high
- (operate-format INSWL #x12 #x1b) ; Insert word low
- (operate-format MSKBL #x12 #x02) ; Mask byte low
- (operate-format MSKLH #x12 #x62) ; Mask longword high
- (operate-format MSKLL #x12 #x22) ; Mask longword low
- (operate-format MSKQH #x12 #x72) ; Mask quadword high
- (operate-format MSKQL #x12 #x32) ; Mask quadword low
- (operate-format MSKWH #x12 #x52) ; Mask word high
- (operate-format MSKWL #x12 #x12) ; Mask word low
- (operate-format MULL #x13 #x00) ; Multiply longword
- (operate-format MULLV #x13 #x40) ; Multiply longword, enable oflow trap
- (operate-format MULQ #x13 #x20) ; Multiply quadword
- (operate-format MULQV #x13 #x60) ; Multiply quadword, enable oflow trap
- (operate-format ORNOT #x11 #x28) ; Ra v ~Rb
- (operate-format S4ADDL #x10 #x02) ; Shift Ra by 4 and longword add to Rb
- (operate-format S4ADDQ #x10 #x22) ; Shift Ra by 4 and quadword add to Rb
- (operate-format S4SUBL #x10 #x0b) ; Shift Ra and longword subtract Rb
- (operate-format S4SUBQ #x10 #x2b) ; Shift Ra and quadword subtract Rb
- (operate-format S8ADDL #x10 #x12) ; Shift Ra by 8 and longword add to Rb
- (operate-format S8ADDQ #x10 #x32) ; Shift Ra by 8 and quadword add to Rb
- (operate-format S8SUBL #x10 #x1b) ; Shift Ra and longword subtract Rb
- (operate-format S8SUBQ #x10 #x3b) ; Shift Ra and quadword subtract Rb
- (operate-format SLL #x12 #x39) ; Shift left logical
- (operate-format SRA #x12 #x3c) ; Shift right arithmetic
- (operate-format SRL #x12 #x34) ; Shift right logical
- (operate-format SUBL #x10 #x09) ; Subtract longword
- (operate-format SUBLV #x10 #x49) ; Subtract longword, enable oflow trap
- (operate-format SUBQ #x10 #x29) ; Subtract quadword
- (operate-format SUBQV #x10 #x69) ; Subtract quadword, enable oflow trap
- (operate-format UMULH #x13 #x30) ; Unsigned multiply quadword high
- (operate-format XOR #x11 #x40) ; Logical difference (xor)
- (operate-format ZAP #x12 #x30) ; Zero bytes
- (operate-format ZAPNOT #x12 #x31) ; Zero bytes not
- )
-\f
-(let-syntax
- ((pal-format
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (()
- (LONG (6 0)
- (26 ,(caddr form)))))))))
-
- (pal-format BPT #x0080) ; Initiate program debugging
- (pal-format BUGCHK #x0081) ; Initiate program exception
- (pal-format CHME #x0082) ; Change mode to emulator
- (pal-format CHMK #x0083) ; Change mode to kernel
- (pal-format CHMS #x0084) ; Change mode to supervisor
- (pal-format CHMU #x0085) ; Change mode to user
- (pal-format IMB #x0086) ; Instruction memory barrier
- (pal-format INSQHIL #x0087) ; Insert into longword queue at head, interlocked
- (pal-format INSQHIQ #x0089) ; ... quadword ... head
- (pal-format INSQTIL #x0088) ; ... longword ... tail
- (pal-format INSQTIQ #x008a) ; ... quadword ... tail
- (pal-format INSQUEL #x008b) ; Insert into longword queue
- (pal-format INSQUELD #x008d) ;
- (pal-format INSQUEQ #x008c) ; Insert into quadword queue
- (pal-format INSQUEQD #x008e) ;
- (pal-format PROBER #x008f) ; Probe for read access
- (pal-format PROBEW #x0090) ; Probe for write access
- (pal-format RD_PS #x0091) ; Move processor status
- (pal-format REI #x0092) ; Return from exception or interrupt
- (pal-format REMQHIL #x0093) ; Remove from longword queue at head, interlocked
- (pal-format REMQHIQ #x0095) ; ... quadword ... head
- (pal-format REMQTIL #x0094) ; ... longword ... tail
- (pal-format REMQTIQ #x0096) ; ... quadword ... tail
- (pal-format REMQUEL #x0097) ; Remove from longword queue
- (pal-format REMQUELD #x0099) ;
- (pal-format REMQUEQ #x0098) ; Remove from quadword queue
- (pal-format REMQUEQD #x009a) ;
- (pal-format RSCC #x009d) ;
- (pal-format SWASTEN #x009b) ; Swap AST enable
- (pal-format WR_PS_SW #x009c) ; Write processor status s'ware field
-
- ;; Privileged PALcode instructions.
- (pal-format HALT #x0000)
- )
-
-;;;; Assembler pseudo-ops
-
-(define-instruction EXTERNAL-LABEL
- ;; External labels provide the garbage collector with header
- ;; information and the runtime system with type, arity, and
- ;; debugging information.
- (((? format-word) (@PCR (? label)))
- (LONG (16 label BLOCK-OFFSET)
- (16 format-word UNSIGNED))))
-
-(define-instruction NOP
- ;; BIS R31 R31 R31
- (()
- (LONG (6 #x11) (5 31) (5 31) (3 0) (1 0) (7 #x20) (5 31))))
-
-(define-instruction UWORD
- ;; Directly insert 32 bit word into output stream
- (((? expression))
- (LONG (32 expression UNSIGNED))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Alpha instruction set, part 2
-;;; Instructions that require branch tensioning
-;;; Package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;; Unconditional jump instructions
-
-(let-syntax
- ((memory-branch
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? link-register) (? base))
- (LONG (6 #x1a)
- (5 link-register)
- (5 base)
- (2 ,(caddr form))
- (14 0 SIGNED)))
- (((? base))
- (LONG (6 #x1a)
- (5 regnum:came-from)
- (5 base)
- (2 ,(caddr form))
- (14 0 SIGNED)))
- (((? link-register) (? base) (@PCR (? probable-target)))
- (LONG (6 #x1a)
- (5 link-register)
- (5 base)
- (2 ,(caddr form))
- (14 `(/ (remainder (- ,probable-target (+ *PC* 4))
- #x10000)
- 4)
- SIGNED)))
- (((? link-register) (? base) (@PCO (? probable-target-address)))
- (LONG (6 #x1a)
- (5 link-register)
- (5 base)
- (2 ,(caddr form))
- (14 `(/ (remainder ,probable-target-address
- #x10000)
- 4)
- SIGNED))))))))
- (memory-branch JMP #x0)
- (memory-branch JSR #x1)
- (memory-branch RET #x2)
- (memory-branch COROUTINE #x3))
-\f
-;;; Conditional branch instructions
-
-(let-syntax
- ((branch
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? reg) (@PCO (? offset)))
- (LONG (6 ,(caddr form))
- (5 reg)
- (21 (quotient offset 4) SIGNED)))
- (((? reg) (@PCR (? label)))
- (VARIABLE-WIDTH (offset `(/ (- ,label (+ *PC* 4)) 4))
- ((#x-100000 #xFFFFF)
- (LONG (6 ,(caddr form))
- (5 reg)
- (21 offset SIGNED)))
- ((#x-1FFFFFFE #x20000001)
- ;; -1: <reverse> xxx
- ;; 0: LDAH temp, left[4*(offset-2)](R31)
- ;; +1: BR link, yyy
- ;; 2: yyy: ADDQ temp, link, temp
- ;; 3: LDA temp, right[4*(offset-2)](temp)
- ;; 4: JMP came_from, temp, hint
- ;; 5: xxx:
- (LONG (6 ,(cadddr form)) ; reverse branch to (.+1)+4
- (5 reg) ; register
- (21 5 SIGNED) ; offset = +5 instructions
- (6 #x09) ; LDAH
- (5 regnum:assembler-temp) ; destination = temp
- (5 31) ; base = zero
- (16 (adjusted:high (* (- offset 2) 4)) SIGNED)
- (6 #x30) ; BR
- (5 26) ; return address to link
- (21 0 SIGNED) ; (.+4) + 0
- (6 #x10) ; ADDQ
- (5 regnum:assembler-temp) ; source = temp
- (5 26) ; source = link
- (3 0) ; should be 0
- (1 0) ; must be 0
- (7 #x20) ; function=ADDQ
- (5 regnum:assembler-temp) ; destination = temp
- (6 #x08) ; LDA
- (5 regnum:assembler-temp) ; destination = temp
- (5 regnum:assembler-temp) ; base = temp
- (16 (adjusted:low (* (- offset 2) 4)) SIGNED)
- (6 #x1a) ; JMP
- (5 regnum:assembler-temp) ; return address to "came from"
- (5 regnum:assembler-temp) ; base = temp
- (2 #x0) ; jump hint
- (14 (/ (adjusted:low (* (- offset 5) 4)) 4)
- SIGNED))))))))))
- (branch beq #x39 #x3d)
- (branch bge #x3e #x3a)
- (branch bgt #x3f #x3b)
- (branch blbc #x38 #x3c)
- (branch blbs #x3c #x38)
- (branch ble #x3b #x3f)
- (branch blt #x3a #x3e)
- (branch bne #x3d #x39)
- (branch fbeq #x31 #x35)
- (branch fbge #x36 #x32)
- (branch fbgt #x37 #x33)
- (branch fble #x33 #x37)
- (branch fblt #x32 #x36)
- (branch fbne #x35 #x31))
-\f
-;;; Unconditional branch instructions
-
-(let-syntax
- ((unconditional-branch
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? reg) (@PCO (? offset)))
- (LONG (6 ,(caddr form))
- (5 reg)
- (21 (quotient offset 4) SIGNED)))
- (((? reg) (@PCR (? label)))
- (VARIABLE-WIDTH (offset `(/ (- ,label (+ *PC* 4)) 4))
- ((#x-100000 #xFFFFF)
- (LONG (6 ,(caddr form))
- (5 reg)
- (21 offset SIGNED)))
- ((#x-1FFFFFFF #x20000000)
- ;; -1: LDAH temp, left[4*(offset-1)](R31)
- ;; 0: BR link, yyy
- ;; 1: yyy: ADDQ temp, link, temp
- ;; 2: LDA temp, right[4*(offset-1)](temp)
- ;; 3: JMP came_from, temp, hint
- ;; 4: xxx:
- (LONG (6 #x09) ; LDAH
- (5 regnum:assembler-temp) ; destination = temp
- (5 31) ; base = zero
- (16 (adjusted:high (* (- offset 1) 4)) SIGNED)
- (6 #x30) ; BR
- (5 26) ; return address to link
- (21 0 SIGNED) ; (.+4) + 0
- (6 #x10) ; ADDQ
- (5 regnum:assembler-temp) ; source = temp
- (5 26) ; source = link
- (3 0) ; should be 0
- (1 0) ; must be 0
- (7 #x20) ; function=ADDQ
- (5 regnum:assembler-temp) ; destination = temp
- (6 #x08) ; LDA
- (5 regnum:assembler-temp) ; destination = temp
- (5 regnum:assembler-temp) ; base = temp
- (16 (adjusted:low (* (- offset 1) 4)) SIGNED)
- (6 #x1a) ; JMP
- (5 reg) ; return address register
- (5 regnum:assembler-temp) ; base = temp
- (2 ,(cadddr form)) ; jump hint
- (14 (/ (adjusted:low (* (- offset 4) 4)) 4) SIGNED)))))
- (((? reg) (OFFSET (? offset) (@PCR (? label))))
- (VARIABLE-WIDTH (offset `(/ (- (+ ,offset ,label)
- (+ *PC* 4))
- 4))
- ((#x-100000 #xFFFFF)
- (LONG (6 ,(caddr form))
- (5 reg)
- (21 offset SIGNED)))
- ((#x-1FFFFFFF #x20000000)
- ;; -1: LDAH temp, left[4*(offset-1)](R31)
- ;; 0: BR link, yyy
- ;; 1: yyy: ADDQ temp, link, temp
- ;; 2: LDQ temp, right[4*(offset-1)]
- ;; 2: JMP came_from, temp, hint
- (LONG (6 #x09) ; LDAH
- (5 regnum:assembler-temp) ; destination = temp
- (5 31) ; base = zero
- (16 (adjusted:high (* (- offset 1) 4)) SIGNED)
- (6 #x30) ; BR
- (5 26) ; return address to link
- (21 0 SIGNED) ; (.+4) + 0
- (6 #x10) ; ADDQ
- (5 regnum:assembler-temp) ; source = temp
- (5 26) ; source = link
- (3 0) ; should be 0
- (1 0) ; must be 0
- (7 #x20) ; function=ADDQ
- (5 regnum:assembler-temp) ; destination = temp
- (6 #x08) ; LDA
- (5 regnum:assembler-temp) ; destination = temp
- (5 regnum:assembler-temp) ; base = temp
- (16 (adjusted:low (* (- offset 1) 4)) SIGNED)
- (6 #x1a) ; JMP
- (5 reg) ; return address register
- (5 regnum:assembler-temp) ; base = temp
- (2 ,(cadddr form)) ; jump hint
- (14 (/ (adjusted:low (* (- offset 4) 4)) 4)
- SIGNED))))))))))
- (unconditional-branch br #x30 #x0)
- (unconditional-branch bsr #x34 #x1))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Alpha instruction set, part 3
-;;; Floating point instructions
-;;; Package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-(define (encode-fp-qualifier qualifier)
- (define (translate symbol)
- (case symbol
- ((C) #x-080) ; Chopped (round toward 0)
- ((M) #x-040) ; Round to minus infinity
- ((D) #x040) ; Round from state bits (dynamic)
- ((U) #x100) ; Underflow enabled
- ((V) #x100) ; Integer overflow enabled (CVTTQ only)
- ((I) #x200) ; Inexact enabled
- ((S) #x400) ; Software
- (else (error "ENCODE-FP-QUALIFIER: unknown qualifier" symbol))))
- (if (symbol? qualifier)
- (translate qualifier)
- (apply + (map translate qualifier))))
-
-(let-syntax
- ((floating-operate
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? src-1) (? src-2) (? dest))
- (LONG (6 #x17) ; Opcode
- (5 src-1)
- (5 src-2)
- (11 ,(caddr form))
- (5 dest))))))))
- (floating-operate CPYS #x20)
- (floating-operate CPYSE #x22)
- (floating-operate CPYSN #x21)
- (floating-operate CVTLQ #x10)
- (floating-operate CVTQL #x30)
- (floating-operate CVTQLSV #x330)
- (floating-operate CVTQLV #x130)
- (floating-operate FCMOVEQ #x2a)
- (floating-operate FCMOVGE #x2d)
- (floating-operate FCMOVGT #x2f)
- (floating-operate FCMOVLE #x2e)
- (floating-operate FCMOVLT #x2c)
- (floating-operate FCMOVNE #x2b)
- (floating-operate MF_FPCR #x25)
- (floating-operate MT_FPCR #x24))
-\f
-(let-syntax
- ((ieee
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? src-1) (? src-2) (? dest))
- (LONG (6 #x16) ; Opcode
- (5 src-1)
- (5 src-2)
- (11 ,(caddr form))
- (5 dest)))
- ((/ (? qualifier) (? src-1) (? src-2) (? dest))
- (LONG (6 #x16) ; Opcode
- (5 src-1)
- (5 src-2)
- (11 (+ ,(caddr form) (encode-fp-qualifier qualifier)))
- (5 dest))))))))
- (ieee ADDS #x80)
- (ieee ADDT #xA0)
- (ieee CMPTEQ #xA5)
- (ieee CMPTLE #xA7)
- (ieee CMPTLT #xA6)
- (ieee CMPTUN #xA4)
- (ieee CVTQS #xBC)
- (ieee CVTQT #xBE)
- (ieee CVTTQ #xAF)
- (ieee CVTTS #xAC)
- (ieee DIVS #x83)
- (ieee DIVT #xA3)
- (ieee MULS #x82)
- (ieee MULT #xA2)
- (ieee SUBS #x81)
- (ieee SUBT #xA1))
-
-(let-syntax
- ((vax
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? src-1) (? src-2) (? dest))
- (LONG (6 #x15) ; Opcode
- (5 src-1)
- (5 src-2)
- (11 ,(caddr form))
- (5 dest)))
- ((/ (? qualifier) (? src-1) (? src-2) (? dest))
- (LONG (6 #x15) ; Opcode
- (5 src-1)
- (5 src-2)
- (11 (+ ,(caddr form) (encode-fp-qualifier qualifier)))
- (5 dest))))))))
- (vax ADDF #x80)
- (vax ADDG #xa0)
- (vax CMPGEQ #xa5)
- (vax CMPGLE #xa7)
- (vax CMPGLT #xa6)
- (vax CVTDG #x9e)
- (vax CVTGD #xad)
- (vax CVTGF #xac)
- (vax CVTGQ #xaf)
- (vax CVTQF #xbc)
- (vax CVTQG #xbe)
- (vax DIVF #x83)
- (vax DIVG #xa3)
- (vax MULF #xb2)
- (vax MULG #x81)
- (vax SUBF #x81)
- (vax SUBG #xa1))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RTL Rules for Alpha. Shared utilities.
-;; Package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Register-Allocator Interface
-
-(define (register->register-transfer source target)
- (guarantee-registers-compatible source target)
- (case (register-type source)
- ((GENERAL) (copy source target))
- ((FLOAT) (fp-copy source target))
- (else (error "unknown register type" source))))
-
-(define (home->register-transfer source target)
- (memory->register-transfer (pseudo-register-displacement source)
- regnum:regs-pointer
- target))
-
-(define (register->home-transfer source target)
- (register->memory-transfer source
- (pseudo-register-displacement target)
- regnum:regs-pointer))
-
-(define (reference->register-transfer source target)
- (case (ea/mode source)
- ((GR)
- (copy (register-ea/register source) target))
- ((FPR)
- (fp-copy (fpr->float-register (register-ea/register source)) target))
- ((OFFSET)
- (memory->register-transfer (offset-ea/offset source)
- (offset-ea/register source)
- target))
- (else
- (error "unknown effective-address mode" source))))
-
-(define (pseudo-register-home register)
- ;; Register block consists of 16 8-byte registers followed by 256
- ;; 8-byte temporaries.
- (INST-EA (OFFSET ,(pseudo-register-displacement register)
- ,regnum:regs-pointer)))
-\f
-(define-integrable (sort-machine-registers registers)
- registers)
-
-(define available-machine-registers
- (list
- ;; r0 -- return value
- r1 ;; -- utility index
- ;; r2 -- stack pointer
- ;; r3 -- memtop
- ;; r4 -- free
- ;; r5 -- dynamic link
- r6 r7 r8
- ;; r9 -- register pointer
- ;; r10 -- scheme-to-interface
- ;; r11 -- closure hook
- ;; r12 -- scheme-to-interface-jsr
- ;; r13 -- compiled-entry type bits
- ;; r14 -- closure free
- r15 r16 r17 r18 r19 r20 r21 r22 r23 r24 r25 r26 r27
- ;; r28 -- assembler temp / came from
- r29
- ;; r30 -- C stack pointer
- ;; r31 -- ZERO
- f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15
- f16 f17 f18 f19 f20 f21 f22 f23 f24 f25 f26 f27 f28
- f29 f30
- ;; f31 -- ZERO.
- ))
-
-(define-integrable (float-register? register)
- (eq? (register-type register) 'FLOAT))
-
-(define-integrable (general-register? register)
- (eq? (register-type register) 'GENERAL))
-
-(define-integrable (word-register? register)
- (eq? (register-type register) 'GENERAL))
-
-(define (register-type register)
- (cond ((machine-register? register)
- (vector-ref
- '#(; 0 1 2 3 4 5 6 7
- GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
- GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
- GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
- GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
- FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
- FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
- FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
- FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT)
- register))
- ((register-value-class=word? register) 'GENERAL)
- ((register-value-class=float? register) 'FLOAT)
- (else (error "unable to determine register type" register))))
-
-(define register-reference
- ; Needed by standard-register-reference in lapgn2
- (let ((references (make-vector number-of-machine-registers)))
- (let loop ((register 0))
- (if (< register 32)
- (begin
- (vector-set! references register (INST-EA (GR ,register)))
- (loop (1+ register)))))
- (let loop ((register 32) (fpr 0))
- (if (< register 64)
- (begin
- (vector-set! references register (INST-EA (FPR ,fpr)))
- (loop (1+ register) (1+ fpr)))))
- (lambda (register)
- (vector-ref references register))))
-\f
-;;;; Utilities for the rules
-
-(define (require-register! machine-reg)
- (flush-register! machine-reg)
- (need-register! machine-reg))
-
-(define-integrable (flush-register! machine-reg)
- (prefix-instructions! (clear-registers! machine-reg)))
-
-(define (rtl-target:=machine-register! rtl-reg machine-reg)
- (if (machine-register? rtl-reg)
- (begin
- (require-register! machine-reg)
- (if (not (= rtl-reg machine-reg))
- (suffix-instructions!
- (register->register-transfer machine-reg rtl-reg))))
- (begin
- (delete-register! rtl-reg)
- (flush-register! machine-reg)
- (add-pseudo-register-alias! rtl-reg machine-reg))))
-
-;;;; Useful Cliches
-
-(define (memory->register-transfer offset base target)
- (case (register-type target)
- ((GENERAL) (LAP (LDQ ,target (OFFSET ,offset ,base))))
- ((FLOAT) (fp-load-doubleword offset base target))
- (else (error "unknown register type" target))))
-
-(define (register->memory-transfer source offset base)
- (case (register-type source)
- ((GENERAL) (LAP (STQ ,source (OFFSET ,offset ,base))))
- ((FLOAT) (fp-store-doubleword offset base source))
- (else (error "unknown register type" source))))
-
-(define (load-constant target constant record?)
- ;; Load a Scheme constant into a machine register.
- (if (non-pointer-object? constant)
- (load-immediate target (non-pointer->literal constant) record?)
- (load-pc-relative target
- 'CONSTANT
- (constant->label constant))))
-
-(define (deposit-type-address type source target)
- (if (= type (ucode-type compiled-entry))
- (LAP (BIS ,regnum:compiled-entry-type-bits ,source ,target))
- (deposit-type-datum type source target)))
-
-(define (deposit-type-datum type source target)
- (with-values
- (lambda ()
- (immediate->register (make-non-pointer-literal type 0)))
- (lambda (prefix alias)
- (LAP ,@prefix
- (BIS ,alias ,source ,target)))))
-
-(define (non-pointer->literal constant)
- (make-non-pointer-literal (object-type constant)
- (careful-object-datum constant)))
-
-(define-integrable (make-non-pointer-literal type datum)
- (+ (* type (expt 2 scheme-datum-width)) datum))
-\f
-;;;; Regularized Machine Instructions
-
-(define-integrable (fits-in-8-bits-unsigned? value)
- (<= #x0 value #xff))
-
-(define-integrable (fits-in-16-bits-signed? value)
- (<= #x-8000 value #x7fff))
-
-(define-integrable (fits-in-16-bits-unsigned? value)
- (<= #x0 value #xffff))
-
-(define-integrable (fits-in-32-bits-signed? value)
- (fits-in-16-bits-signed? (quotient value #x10000)))
-
-(define (top-16-of-32-bits-only? value)
- (let ((result (integer-divide value #x10000)))
- (and (zero? (integer-divide-remainder result))
- (fits-in-16-bits-signed? (integer-divide-quotient result)))))
-
-; The adjustments are only good when n is 32 bits long.
-
-(define (adjusted:high n)
- (let ((n (->unsigned n 32)))
- (if (< (remainder n #x10000) #x8000)
- (->signed (quotient n #x10000) 16)
- (->signed (+ (quotient n #x10000) 1) 16))))
-
-(define (adjusted:low n)
- (let ((remainder (remainder (->unsigned n 32) #x10000)))
- (if (< remainder #x8000)
- remainder
- (- remainder #x10000))))
-
-(define (split-64-bits n)
- (let* ((n (->unsigned n 64))
- (split (integer-divide n #x100000000)))
- (let ((rem (integer-divide-remainder split))
- (quo (integer-divide-quotient split)))
- (if (or (>= rem #x80000000)
- (negative? (adjusted:high rem)))
- (values (->signed (1+ quo) 32)
- (->signed (- rem #x100000000) 32))
- (values (->signed quo 32)
- (->signed rem 32))))))
-
-(define (->unsigned n nbits)
- (if (negative? n)
- (+ (expt 2 nbits) n)
- n))
-
-(define (->signed n nbits)
- (if (>= n (expt 2 (- nbits 1)))
- (- n (expt 2 nbits))
- n))
-
-(define (copy r t)
- (if (= r t)
- (LAP)
- (LAP (COPY ,r ,t))))
-
-(define (fp-copy from to)
- (if (= to from)
- (LAP)
- (LAP (CPYS ,(float-register->fpr from)
- ,(float-register->fpr from)
- ,(float-register->fpr to)))))
-
-(define (fp-load-doubleword offset base target)
- (LAP (LDT ,(float-register->fpr target)
- (OFFSET ,offset ,base))))
-
-(define (fp-store-doubleword offset base source)
- (LAP (STT ,(float-register->fpr source)
- (OFFSET ,offset ,base))))
-\f
-;;;; PC-relative addresses
-
-(define (load-pc-relative target type label)
- ;; Load a pc-relative location's contents into a machine register.
- ;; Optimization: if there is a register that contains the value of
- ;; another label, use that register as the base register.
- ;; Otherwise, allocate a temporary and load it with the value of the
- ;; label, then use the temporary as the base register. This
- ;; strategy of loading a temporary wins if the temporary is used
- ;; again, but loses if it isn't, since loading the temporary takes
- ;; one instruction in addition to the LDQ instruction, while doing a
- ;; pc-relative LDQ instruction takes only two instructions total.
- ;; But pc-relative loads of various kinds are quite common, so this
- ;; should almost always be advantageous.
- (with-values (lambda () (get-typed-label type))
- (lambda (label* alias type-of-label*)
- (cond ((not label*) ; No labels of any kind
- (let ((temporary (standard-temporary!))
- (here (generate-label)))
- (set-typed-label! 'CODE here temporary)
- (LAP (BR ,temporary (@PCO 0))
- (LABEL ,here)
- ,@(if (eq? type 'CODE)
- (LAP (LDQ ,target
- (OFFSET (- ,label ,here) ,temporary)))
- (let ((temp2 (standard-temporary!)))
- (set-typed-label! type label temp2)
- (LAP (LDA ,temp2
- (OFFSET (- ,label ,here) ,temporary))
- (LDQ ,target (OFFSET 0 ,temp2))))))))
- ((eq? type type-of-label*) ; We got what we wanted
- (LAP (LDQ ,target (OFFSET (- ,label ,label*) ,alias))))
- ((eq? type 'CODE) ; Cheap to generate
- (let ((temporary (standard-temporary!))
- (here (generate-label)))
- (set-typed-label! 'CODE here temporary)
- (LAP (BR ,temporary (@PCO 0))
- (LABEL ,here)
- (LDQ ,target (OFFSET (- ,label ,here) ,temporary)))))
- (else ; Wrong type of label, and what
- ; we need may be expensive
- (let ((temporary (standard-temporary!)))
- (set-typed-label! type label temporary)
- (LAP (LDA ,temporary (OFFSET (- ,label ,label*) ,alias))
- (LDQ ,target (OFFSET 0 ,temporary)))))))))
-
-(define (load-pc-relative-address target type label)
- ;; Load address of a pc-relative location into a machine register.
- ;; Optimization: if there is another register that contains the
- ;; value of another label, add the difference between the labels to
- ;; that register's contents instead. The ADDI takes one
- ;; instruction, while the %LOAD-PC-RELATIVE-ADDRESS takes two, so
- ;; this is always advantageous.
- ;;
- ;; IMPORTANT: the target can't be clobbered by the current RTL rule
- ;; (except by this code) since we are remembering its contents in
- ;; the register map. This implies that the rule better not be
- ;; matching target with a machine register (use pseudo-register? to
- ;; test it).
- (with-values (lambda () (get-typed-label type))
- (lambda (label* alias type-of-label*)
- (cond ((not label*) ; No labels of any kind
- (let ((temporary (standard-temporary!))
- (here (generate-label)))
- (set-typed-label! 'CODE here temporary)
- (if (not (eq? type 'CODE))
- (set-typed-label! type label target))
- (LAP (BR ,temporary (@PCO 0))
- (LABEL ,here)
- (LDA ,target
- (OFFSET (- ,label ,here) ,temporary)))))
- ((eq? type type-of-label*) ; We got what we wanted
- (LAP (LDA ,target (OFFSET (- ,label ,label*) ,alias))))
- ((eq? type 'CODE) ; Cheap to generate
- (let ((temporary (standard-temporary!))
- (here (generate-label)))
- (set-typed-label! 'CODE here temporary)
- (LAP (BR ,temporary (@PCO 0))
- (LABEL ,here)
- (LDA ,target (OFFSET (- ,label ,here) ,temporary)))))
- (else ; Wrong type of label, and what
- ; we need may be expensive
- (set-typed-label! type label target)
- (LAP (LDA ,target (OFFSET (- ,label ,label*) ,alias))))))))
-
-;;; Typed labels provide further optimization. There are two types,
-;;; CODE and CONSTANT, that say whether the label is located in the
-;;; code block or the constants block of the output. Statistically,
-;;; a label is likely to be closer to another label of the same type
-;;; than to a label of the other type.
-
-(define (get-typed-label type)
- (let ((entries (register-map-labels *register-map* 'GENERAL)))
- (let loop ((entries* entries))
- (cond ((null? entries*)
- ;; If no entries of the given type, use any entry that is
- ;; available.
- (let loop ((entries entries))
- (cond ((null? entries)
- (values false false false))
- ((pair? (caar entries))
- (values (cdaar entries) (cadar entries) (caaar entries)))
- (else
- (loop (cdr entries))))))
- ((and (pair? (caar entries*))
- (eq? type (caaar entries*)))
- (values (cdaar entries*) (cadar entries*) type))
- (else
- (loop (cdr entries*)))))))
-
-(define (set-typed-label! type label alias)
- (set! *register-map*
- (set-machine-register-label *register-map* alias (cons type label)))
- unspecific)
-\f
-(define (immediate->register immediate)
- (with-values (lambda () (get-immediate-alias immediate))
- (lambda (register bumper) ; Bumper = #T -> exact hit
- (cond ((not register)
- (let* ((temporary (standard-temporary!))
- (code (%load-immediate temporary immediate)))
- (set! *register-map*
- (set-machine-register-label *register-map*
- temporary
- immediate))
- (values code temporary)))
- ((eq? bumper #T) (values (LAP) register))
- (else
- (let* ((temporary (standard-temporary!))
- (code (bumper register temporary)))
- (set! *register-map*
- (set-machine-register-label *register-map*
- temporary
- immediate))
- (values code temporary)))))))
-
-(define (bump old-value desired-value)
- (define (zappable? old new)
- (do ((i 8
- (- i 1))
- (old (->unsigned old 64)
- (quotient old 256))
- (new (->unsigned new 64)
- (quotient new 256))
- (bit 1
- (* bit 2))
- (mask 0
- (let ((old (remainder old 256))
- (new (remainder new 256)))
- (cond ((= old new) mask)
- ((zero? new) (+ mask bit))
- (else #F)))))
- ((or (not mask) (= i 0)) mask)))
-
- (define (differs-in-contiguous-bits? old-value desired-value)
- ; 16 bits at the top end, 15 bits elsewhere
- (let ((difference-bits
- (bit-string-xor
- (signed-integer->bit-string 64 old-value)
- (signed-integer->bit-string 64 desired-value))))
- (let ((low-differing-bit
- (bit-substring-find-next-set-bit
- difference-bits 0 64)))
- (cond ((not low-differing-bit) (values #F #F))
- ((>= low-differing-bit 48)
- (values (bit-string->signed-integer
- (bit-substring difference-bits 48 64))
- 48))
- ((bit-substring-find-next-set-bit
- difference-bits (+ low-differing-bit 15)
- 64)
- (values #F #F))
- (else
- (values (bit-string->unsigned-integer
- (bit-substring difference-bits
- low-differing-bit
- (+ low-differing-bit 15)))
- low-differing-bit))))))
-
- (define (try-high-and-low value)
- (let ((bits (signed-integer->bit-string 64 value)))
- (let ((low-16 (bit-string->signed-integer
- (bit-substring bits 0 16))))
- (if (not (= low-16 (bit-string->signed-integer
- (bit-substring bits 0 48))))
- (values false false)
- (let* ((high-16 (bit-string->signed-integer
- (bit-substring bits 48 64)))
- (adjusted (cond ((not (negative? low-16)) high-16)
- ((= high-16 #x7FFF) #x-8000)
- (else (+ high-16 1)))))
- (values 3
- (lambda (source target)
- source ; ignored
- (LAP (MOVEI ,target (& ,adjusted))
- (SLL ,target (& 48) ,target)
- (LDA ,target (OFFSET ,low-16 ,target))))))))))
-
- (let ((desired-value (->signed desired-value 64))
- (old-value (->signed old-value 64)))
- (let ((delta (- desired-value old-value)))
- (cond ((fits-in-16-bits-signed? delta)
- (values 1
- (lambda (source target)
- (LAP (LDA ,target (OFFSET ,delta ,source))))))
- ((top-16-of-32-bits-only? delta)
- (values 1
- (lambda (source target)
- (LAP (LDAH ,target (OFFSET ,(quotient delta #x10000)
- ,source))))))
- ((eqv? old-value (- desired-value))
- (values 1
- (lambda (source target)
- (LAP (SUBQ ,regnum:zero ,source ,target)))))
- ((eqv? desired-value (- (+ 1 old-value)))
- (values 1
- (lambda (source target)
- (LAP (EQV ,regnum:zero ,source ,target)))))
- ((zappable? old-value desired-value)
- => (lambda (mask)
- (values 1
- (lambda (source target)
- (LAP (ZAP ,source (& ,mask) ,target))))))
- ((fits-in-32-bits-signed? delta)
- (values 2
- (lambda (source target)
- (LAP (LDA ,target (OFFSET ,(adjusted:low delta) ,source))
- (LDAH ,target (OFFSET ,(adjusted:high delta)
- ,target))))))
- (else
- (with-values
- (lambda ()
- (differs-in-contiguous-bits? old-value desired-value))
- (lambda (constant shift)
- (cond ((and (not constant) (eqv? old-value 0))
- (try-high-and-low desired-value))
- ((not constant) (values #F #F))
- ((eqv? old-value 0)
- (values 2
- (lambda (source target)
- source ; Unused
- (LAP (MOVEI ,target (& ,constant))
- (SLL ,target (& ,shift) ,target)))))
- (else
- (values 3
- (lambda (source target)
- source ; Unused
- (LAP
- (MOVEI ,target (& ,constant))
- (SLL ,target (& ,shift) ,target)
- (XOR ,target ,source ,target)))))))))))))
-
-(define (get-immediate-alias immediate)
- (let loop ((entries
- (cons (list 0 regnum:zero)
- (register-map-labels *register-map* 'GENERAL)))
- (best-bumper #T)
- (least-cost #F)
- (best-register #F))
- (cond ((null? entries)
- (values best-register best-bumper))
- ((eqv? (caar entries) immediate)
- (values (cadar entries) #T)) ; Exact match
- ((not (number? (caar entries)))
- (loop (cdr entries) best-bumper least-cost best-register))
- (else
- (with-values (lambda () (bump (caar entries) immediate))
- (lambda (cost bumper)
- (cond ((not cost)
- (loop (cdr entries) best-bumper
- least-cost best-register))
- ((or (not least-cost) (< cost least-cost))
- (loop (cdr entries) bumper
- cost (cadar entries)))
- (else (loop (cdr entries) best-bumper
- least-cost best-register)))))))))
-
-(define (load-immediate target immediate record?)
- (let ((registers (get-immediate-aliases immediate)))
- (cond ((memv target registers)
- (LAP))
- ((not (null? registers))
- (if record?
- (set! *register-map*
- (set-machine-register-label *register-map*
- target
- immediate)))
- (LAP (COPY ,(car registers) ,target)))
- (else
- (with-values (lambda () (get-immediate-alias immediate))
- (lambda (register bumper)
- (let ((result
- (if register
- (bumper register target)
- (%load-immediate target immediate))))
- (if record?
- (set! *register-map*
- (set-machine-register-label *register-map*
- target
- immediate)))
- result)))))))
-
-(define (get-immediate-aliases immediate)
- (let loop ((entries
- (cons (list 0 regnum:zero)
- (register-map-labels *register-map* 'GENERAL))))
- (cond ((null? entries)
- '())
- ((eqv? (caar entries) immediate)
- (append (cdar entries) (loop (cdr entries))))
- (else
- (loop (cdr entries))))))
-
-(define (%load-immediate target immediate)
- ; All simple cases are handled above this level.
- #|
- (let ((label (immediate->label immediate)))
- (load-pc-relative target 'IMMEDIATE label))
- |#
- #|
- (warn "%load-immediate: generating 64-bit constant"
- (number->string immediate 16))
- |#
- (with-values (lambda () (split-64-bits immediate))
- (lambda (high low)
- (let ((left-half (load-immediate target high false)))
- (LAP ,@left-half
- (SLL ,target (& 32) ,target)
- ,@(add-immediate low target target))))))
-
-(define (add-immediate immediate source target)
- (cond ((fits-in-16-bits-signed? immediate)
- (LAP (LDA ,target (OFFSET ,immediate ,source))))
- ((top-16-of-32-bits-only? immediate)
- (LAP (LDAH ,target (OFFSET ,(->signed (quotient immediate #x10000) 16)
- ,source))))
- ((fits-in-32-bits-signed? immediate)
- (LAP (LDA ,target (OFFSET ,(adjusted:low immediate) ,source))
- (LDAH ,target (OFFSET ,(adjusted:high immediate) ,target))))
- (else (with-values (lambda () (immediate->register immediate))
- (lambda (prefix alias)
- (LAP ,@prefix
- (ADDQ ,source ,alias ,target)))))))
-\f
-;;;; Comparisons
-
-(define (compare-immediate condition immediate source)
- ; Branch if immediate <condition> source
- (let ((cc (invert-condition-noncommutative condition)))
- ;; This machine does register <op> immediate; you can
- ;; now think of cc in this way
- (cond ((zero? immediate)
- (branch-generator! cc
- `(BEQ ,source) `(BLT ,source) `(BGT ,source)
- `(BNE ,source) `(BGE ,source) `(BLE ,source))
- (LAP))
- ((fits-in-8-bits-unsigned? immediate)
- (let ((temp (standard-temporary!)))
- (branch-generator! condition
- `(BNE ,temp) `(BNE ,temp) `(BEQ ,temp)
- `(BEQ ,temp) `(BEQ ,temp) `(BNE ,temp))
- (case condition
- ((= <>) (LAP (CMPEQ ,source (& ,immediate) ,temp)))
- ((< >=) (LAP (CMPLT ,source (& ,immediate) ,temp)))
- ((> <=) (LAP (CMPLE ,source (& ,immediate) ,temp))))))
- (else (with-values (lambda () (immediate->register immediate))
- (lambda (prefix alias)
- (LAP ,@prefix
- ,@(compare condition alias source))))))))
-
-(define (compare condition r1 r2)
- ; Branch if r1 <cc> r2
- (if (= r1 r2)
- (let ((branch
- (lambda (label) (LAP (BR ,regnum:came-from (@PCR ,label)))))
- (dont-branch
- (lambda (label) label (LAP))))
- (if (memq condition '(< > <>))
- (set-current-branches! dont-branch branch)
- (set-current-branches! branch dont-branch))
- (LAP))
- (let ((temp (standard-temporary!)))
- (branch-generator! condition
- `(BNE ,temp) `(BNE ,temp) `(BNE ,temp)
- `(BEQ ,temp) `(BEQ ,temp) `(BEQ ,temp))
- (case condition
- ((= <>) (LAP (CMPEQ ,r1 ,r2 ,temp)))
- ((< >=) (LAP (CMPLT ,r1 ,r2 ,temp)))
- ((> <=) (LAP (CMPLT ,r2 ,r1 ,temp)))))))
-
-(define (branch-generator! cc = < > <> >= <=)
- (let ((forward
- (case cc
- ((=) =) ((<) <) ((>) >)
- ((<>) <>) ((>=) >=) ((<=) <=)))
- (inverse
- (case cc
- ((=) <>) ((<) >=) ((>) <=)
- ((<>) =) ((>=) <) ((<=) >))))
- (set-current-branches!
- (lambda (label)
- (LAP (,@forward (@PCR ,label))))
- (lambda (label)
- (LAP (,@inverse (@PCR ,label)))))))
-
-(define (invert-condition condition)
- (let ((place (assq condition condition-inversion-table)))
- (if (not place)
- (error "unknown condition" condition))
- (cadr place)))
-
-(define (invert-condition-noncommutative condition)
- (let ((place (assq condition condition-inversion-table)))
- (if (not place)
- (error "unknown condition" condition))
- (caddr place)))
-
-(define condition-inversion-table
- ; A OP B NOT (A OP B) B OP A
- ; invert invert non-comm.
- '((= <> =)
- (< >= >)
- (> <= <)
- (<> = <>)
- (<= > >=)
- (>= < <=)))
-\f
-;;;; Miscellaneous
-
-(define-integrable (object->type source target)
- ; Type extraction
- (LAP (EXTBL ,source (& 7) ,target)))
-
-(define-integrable (object->datum source target)
- ; Zero out the type field
- (LAP (ZAP ,source (& 128) ,target)))
-
-(define-integrable (object->address source target)
- (object->datum source target))
-
-(define (standard-unary-conversion source target conversion)
- ;; `source' is any register, `target' a pseudo register.
- (let ((source (standard-source! source)))
- (conversion source (standard-target! target))))
-
-(define (standard-binary-conversion source1 source2 target conversion)
- (let ((source1 (standard-source! source1))
- (source2 (standard-source! source2)))
- (conversion source1 source2 (standard-target! target))))
-
-(define (standard-source! register)
- (load-alias-register! register (register-type register)))
-
-(define (standard-target! register)
- (delete-dead-registers!)
- (allocate-alias-register! register (register-type register)))
-
-(define-integrable (standard-temporary!)
- (allocate-temporary-register! 'GENERAL))
-
-(define (new-temporary! . avoid)
- (let loop ()
- (let ((result (allocate-temporary-register! 'GENERAL)))
- (if (memq result avoid)
- (loop)
- result))))
-
-(define (standard-move-to-target! source target)
- (move-to-alias-register! source (register-type source) target))
-
-(define (standard-move-to-temporary! source)
- (move-to-temporary-register! source (register-type source)))
-
-(Define (register-expression expression)
- (case (rtl:expression-type expression)
- ((REGISTER)
- (rtl:register-number expression))
- ((CONSTANT)
- (let ((object (rtl:constant-value expression)))
- (and (zero? (object-type object))
- (zero? (object-datum object))
- regnum:zero)))
- ((CONS-NON-POINTER)
- (and (let ((type (rtl:cons-non-pointer-type expression)))
- (and (rtl:machine-constant? type)
- (zero? (rtl:machine-constant-value type))))
- (let ((datum (rtl:cons-non-pointer-datum expression)))
- (and (rtl:machine-constant? datum)
- (zero? (rtl:machine-constant-value datum))))
- regnum:zero))
- ((MACHINE-CONSTANT)
- (and (zero? (rtl:machine-constant-value expression))
- regnum:zero))
- (else false)))
-\f
-(define (define-arithmetic-method operator methods method)
- (let ((entry (assq operator (cdr methods))))
- (if entry
- (set-cdr! entry method)
- (set-cdr! methods (cons (cons operator method) (cdr methods)))))
- operator)
-
-(define (lookup-arithmetic-method operator methods)
- (cdr (or (assq operator (cdr methods))
- (error "Unknown operator" operator))))
-
-(define-integrable (ea/mode ea) (car ea))
-(define-integrable (register-ea/register ea) (cadr ea))
-(define-integrable (offset-ea/offset ea) (cadr ea))
-(define-integrable (offset-ea/register ea) (caddr ea))
-
-(define (pseudo-register-displacement register)
- ;; Register block consists of 16 8-byte registers followed by 256
- ;; 8-byte temporaries.
- (+ (* 8 16) ; 16 machine independent, microcode
- (* 8 8) ; 8 Alpha, compiled code interface
- (* 8 (register-renumber register))))
-
-(define-integrable (float-register->fpr register)
- ;; Float registers are represented by 32 through 63 in the RTL,
- ;; corresponding to floating point registers 0 through 31 in the machine.
- (- register 32))
-
-(define-integrable (fpr->float-register register)
- (+ register 32))
-
-(define-integrable reg:memtop
- (INST-EA (OFFSET #x0000 ,regnum:regs-pointer)))
-
-(define-integrable reg:environment
- (INST-EA (OFFSET #x0018 ,regnum:regs-pointer)))
-
-(define-integrable reg:lexpr-primitive-arity
- (INST-EA (OFFSET #x0038 ,regnum:regs-pointer)))
-
-(define-integrable reg:closure-limit
- (INST-EA (OFFSET #x0050 ,regnum:regs-pointer)))
-
-(define-integrable reg:stack-guard
- (INST-EA (OFFSET #x0058 ,regnum:regs-pointer)))
-
-(define-integrable reg:divq
- (INST-EA (OFFSET #x00A0 ,regnum:regs-pointer)))
-
-(define-integrable reg:remq
- (INST-EA (OFFSET #x00A8 ,regnum:regs-pointer)))
-
-(define (lap:make-label-statement label)
- (LAP (LABEL ,label)))
-
-(define (lap:make-unconditional-branch label)
- (LAP (BR ,regnum:came-from (@PCR ,label))))
-
-(define (lap:make-entry-point label block-start-label)
- block-start-label
- (LAP (ENTRY-POINT ,label)
- ,@(make-external-label expression-code-word label)))
-\f
-;;;; Codes and Hooks
-
-(let-syntax ((define-codes
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(BEGIN
- ,@(let loop ((names (cddr form)) (index (cadr form)))
- (if (pair? names)
- (cons `(DEFINE-INTEGRABLE
- ,(symbol-append 'CODE:COMPILER-
- (car names))
- ,index)
- (loop (cdr names) (+ index 1)))
- '())))))))
- (define-codes #x012
- primitive-apply primitive-lexpr-apply
- apply error lexpr-apply link
- interrupt-closure interrupt-dlink interrupt-procedure
- interrupt-continuation interrupt-ic-procedure
- assignment-trap cache-reference-apply
- reference-trap safe-reference-trap unassigned?-trap
- -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero?
- access lookup safe-lookup unassigned? unbound?
- set! define lookup-apply))
-
-(let-syntax ((define-codes
- (sc-macro-transformer
- (lambda (start . names)
- `(BEGIN
- ,@(let loop ((names (cddr form)) (offset (cadr form)))
- (if (pair? names)
- (cons `(DEFINE-INTEGRABLE
- ,(symbol-append 'ASSEMBLY-HOOK:
- (car names))
- ,offset)
- (loop (cdr names) (+ offset 16)))
- '())))))))
- (define-codes #x0
- long-jump
- allocate-closure))
-
-(define (invoke-assembly-hook which-hook)
- (LAP (LDA ,regnum:assembler-temp (OFFSET ,which-hook ,regnum:closure-hook))
- (JSR ,regnum:assembler-temp ,regnum:assembler-temp (@PCO ,which-hook))))
-
-(define-integrable (link-to-interface code)
- ;; Jump, with link in regnum:first-arg, to link_to_interface
- (LAP (MOVEI ,regnum:interface-index (& ,code))
- (JMP ,regnum:first-arg ,regnum:scheme-to-interface-jsr)))
-
-(define-integrable (invoke-interface code)
- ;; Jump to scheme-to-interface
- (LAP (MOVEI ,regnum:interface-index (& ,code))
- (JMP ,regnum:linkage ,regnum:scheme-to-interface)))
-
-(define (load-interface-args! first second third fourth)
- (let ((clear-regs
- (apply clear-registers!
- (append (if first (list regnum:first-arg) '())
- (if second (list regnum:second-arg) '())
- (if third (list regnum:third-arg) '())
- (if fourth (list regnum:fourth-arg) '()))))
- (load-reg
- (lambda (reg arg)
- (if reg (load-machine-register! reg arg) (LAP)))))
- (let ((load-regs
- (LAP ,@(load-reg first regnum:first-arg)
- ,@(load-reg second regnum:second-arg)
- ,@(load-reg third regnum:third-arg)
- ,@(load-reg fourth regnum:fourth-arg))))
- (LAP ,@clear-regs
- ,@load-regs
- ,@(clear-map!)))))
-
-(define (pre-lapgen-analysis rgraphs)
- rgraphs
- unspecific)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Optimizer for Alpha.
-;;; Package: (compiler lap-optimizer)
-
-(declare (usual-integrations))
-
-(define (optimize-linear-lap instructions)
- instructions)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-;;; Machine Model for Alpha
-;;; Package: (compiler)
-
-(declare (usual-integrations))
-\f
-;;;; Architecture Parameters
-
-(define use-pre/post-increment? false)
-(define-integrable endianness 'LITTLE)
-(define-integrable addressing-granularity 8)
-(define-integrable scheme-object-width 64)
-(define-integrable scheme-type-width 8) ; or 6
-
-(define-integrable scheme-datum-width
- (- scheme-object-width scheme-type-width))
-
-(define-integrable type-scale-factor
- (expt 2 (- 8 scheme-type-width)))
-
-(define-integrable float-width 64)
-(define-integrable float-alignment 64)
-;; Number of address units (bytes) in a floating point value
-(define-integrable address-units-per-float
- (quotient float-width addressing-granularity))
-
-;;; It is currently required that both packed characters and objects
-;;; be integrable numbers of address units. Furthermore, the number
-;;; of address units per object must be an integral multiple of the
-;;; number of address units per character. This will cause problems
-;;; on a machine that is word addressed, in which case we will have to
-;;; rethink the character addressing strategy.
-
-(define-integrable address-units-per-object
- (quotient scheme-object-width addressing-granularity))
-
-(define-integrable address-units-per-gc&format-word
- (quotient 32 addressing-granularity))
-
-(define-integrable address-units-per-packed-char 1)
-
-(define-integrable signed-fixnum/upper-limit (expt 2 (-1+ scheme-datum-width)))
-(define-integrable signed-fixnum/lower-limit (- signed-fixnum/upper-limit))
-(define-integrable unsigned-fixnum/upper-limit (* 2 signed-fixnum/upper-limit))
-
-(define-integrable (stack->memory-offset offset) offset)
-(define-integrable ic-block-first-parameter-offset 2)
-(define-integrable execute-cache-size 2) ; Long words per UUO link slot
-(define-integrable closure-entry-size
- ;; Long words in a single closure entry:
- ;; Padding / Format and GC offset word
- ;; SUBQ / BR or JMP
- ;; absolute target address
- 3)
-
-;; Given: the number of entry points in a closure, return: the
-;; distance in objects from the gc header word of the closure
-;; block to the location of the first free variable.
-
-(define (closure-object-first-offset nentries)
- (case nentries
- ((0)
- ;; Vector header only
- 1)
- (else
- ;; Manifest closure header, then entries.
- (+ 1 (* closure-entry-size nentries)))))
-
-;; Given: the number of entry points in a closure, and a particular
-;; entry point number. Return: the distance from that entry point to
-;; the first variable slot in the closure (in words).
-
-(define (closure-first-offset nentries entry)
- (if (zero? nentries)
- 1 ; Strange boundary case
- (- (* closure-entry-size (- nentries entry)) 1)))
-
-;; Bump from one entry point to another -- distance in BYTES
-
-(define (closure-entry-distance nentries entry entry*)
- nentries ; ignored
- (* (* closure-entry-size address-units-per-object)
- (- entry* entry)))
-
-;; Bump to the canonical entry point. Since every closure entry point
-;; on the Alpha is aligned on an object boundary, there is no need to
-;; canonicalize.
-
-(define (closure-environment-adjustment nentries entry)
- nentries entry ; ignored
- 0)
-\f
-;;;; Machine Registers
-
-(define-integrable r0 0)
-(define-integrable r1 1)
-(define-integrable r2 2)
-(define-integrable r3 3)
-(define-integrable r4 4)
-(define-integrable r5 5)
-(define-integrable r6 6)
-(define-integrable r7 7)
-(define-integrable r8 8)
-(define-integrable r9 9)
-(define-integrable r10 10)
-(define-integrable r11 11)
-(define-integrable r12 12)
-(define-integrable r13 13)
-(define-integrable r14 14)
-(define-integrable r15 15)
-(define-integrable r16 16)
-(define-integrable r17 17)
-(define-integrable r18 18)
-(define-integrable r19 19)
-(define-integrable r20 20)
-(define-integrable r21 21)
-(define-integrable r22 22)
-(define-integrable r23 23)
-(define-integrable r24 24)
-(define-integrable r25 25)
-(define-integrable r26 26)
-(define-integrable r27 27)
-(define-integrable r28 28)
-(define-integrable r29 29)
-(define-integrable r30 30)
-(define-integrable r31 31)
-
-;; Floating point general registers -- the odd numbered ones are
-;; only used when transferring to/from the CPU
-(define-integrable f0 32)
-(define-integrable f1 33)
-(define-integrable f2 34)
-(define-integrable f3 35)
-(define-integrable f4 36)
-(define-integrable f5 37)
-(define-integrable f6 38)
-(define-integrable f7 39)
-(define-integrable f8 40)
-(define-integrable f9 41)
-(define-integrable f10 42)
-(define-integrable f11 43)
-(define-integrable f12 44)
-(define-integrable f13 45)
-(define-integrable f14 46)
-(define-integrable f15 47)
-(define-integrable f16 48)
-(define-integrable f17 49)
-(define-integrable f18 50)
-(define-integrable f19 51)
-(define-integrable f20 52)
-(define-integrable f21 53)
-(define-integrable f22 54)
-(define-integrable f23 55)
-(define-integrable f24 56)
-(define-integrable f25 57)
-(define-integrable f26 58)
-(define-integrable f27 59)
-(define-integrable f28 60)
-(define-integrable f29 61)
-(define-integrable f30 62)
-(define-integrable f31 63)
-
-(define-integrable number-of-machine-registers 64)
-(define-integrable number-of-temporary-registers 256)
-\f
-; Number .dis C Scheme
-; ====== ==== ======= ======
-; 0 v0 Return Value Return Value
-; 1 t0 caller saves <free, but utility index (not shifted)>
-; 2 t1 caller saves Stack-Pointer
-; 3 t2 caller saves MemTop
-; 4 t3 caller saves Free
-; 5 t4 caller saves Dynamic Link
-; 6 t5 caller saves <free>
-; 7 t6 caller saves <free>
-; 8 t7 caller saves <free>
-; 9 s0 callee saves Regs-Pointer
-; 10 s1 callee saves Scheme-To-Interface
-; 11 s2 callee saves Closure Hook (jump ind. for full addresse)
-; 12 s3 callee saves Scheme-To-Interface-JSR
-; 13 s4 callee saves Compiled-Entry-Type-Bits
-; 14 s5 callee saves Closure-Free
-; 15 fp? frame base <free>
-; 16 a0 argument 1 <free, but for utilities>
-; 17 a1 argument 2 <free, but for utilities>
-; 18 a2 argument 3 <free, but for utilities>
-; 19 a3 argument 4 <free, but for utilities>
-; 20 a4 argument 5 <free, but for utilities>
-; 21 a5 argument 6 <free>
-; 22 t8 caller saves <free>
-; 23 t9 caller saves <free>
-; 24 t10 caller saves <free>
-; 25 t11 caller saves <free>
-; 26 ra return address <free, but used for closure linkage>
-; 27 t12 proc. descript. <free>
-; 28 at? volatile scratch Assembler Temporary (tensioning)
-; 29 gp global pointer <free>
-; 30 sp stack pointer C Stack Pointer (do not use!)
-; 31 zero Z E R O Z E R O
-
-;;; Fixed-use registers due to architecture or OS calling conventions.
-;; Callee saves: r9-r15, r30 (stack pointer), f2-9 all others are caller saves
-(define-integrable regnum:C-return-value r0)
-(define-integrable regnum:C-frame-pointer r15)
-(define-integrable regnum:first-C-arg r16)
-(define-integrable regnum:second-C-arg r17)
-(define-integrable regnum:third-C-arg r18)
-(define-integrable regnum:fourth-C-arg r19)
-(define-integrable regnum:fifth-C-arg r20)
-(define-integrable regnum:sixth-C-arg r21)
-(define-integrable regnum:linkage r26)
-(define-integrable regnum:C-procedure-descriptor r27)
-(define-integrable regnum:volatile-scratch r28)
-(define-integrable regnum:C-global-pointer r29)
-(define-integrable regnum:C-stack-pointer r30)
-(define-integrable regnum:zero r31)
-\f
-(define-integrable regnum:fp-return-1 f0)
-(define-integrable regnum:fp-return-2 f1)
-(define-integrable regnum:first-fp-arg f16)
-(define-integrable regnum:second-fp-arg f17)
-(define-integrable regnum:third-fp-arg f18)
-(define-integrable regnum:fourth-fp-arg f19)
-(define-integrable regnum:fifth-fp-arg f20)
-(define-integrable regnum:sixth-fp-arg f21)
-(define-integrable regnum:fp-zero f31)
-
-;;; Fixed-use registers for Scheme compiled code.
-(define-integrable regnum:return-value regnum:C-return-value) ; 0
-(define-integrable regnum:interface-index r1) ; 1
-(define-integrable regnum:stack-pointer r2) ; 2
-(define-integrable regnum:memtop r3) ; 3
-(define-integrable regnum:free r4) ; 4
-(define-integrable regnum:dynamic-link r5) ; 5
- ; (6, 7, 8)
-(define-integrable regnum:regs-pointer r9) ; 9
-(define-integrable regnum:scheme-to-interface r10) ; 10
-(define-integrable regnum:closure-hook r11) ; 11
-(define-integrable regnum:scheme-to-interface-jsr r12) ; 12
-(define-integrable regnum:compiled-entry-type-bits r13) ; 13
-(define-integrable regnum:closure-free r14) ; 14
- ; (15, 16)
-;;;;;;; Note: regnum:first-C-arg is where the address for structure
-;;;;;;; return values is passed. Since all of the Scheme utilities
-;;;;;;; return structure values, we "hide" this register to correspond
-;;;;;;; to the C view of the argument number rather than the assembly
-;;;;;;; language view.
-(define-integrable regnum:first-arg regnum:second-C-arg) ; 17
-(define-integrable regnum:second-arg regnum:third-C-arg) ; 18
-(define-integrable regnum:third-arg regnum:fourth-C-arg) ; 19
-(define-integrable regnum:fourth-arg regnum:fifth-C-arg) ; 20
- ; (21, 22, 23, 24, 25)
-(define-integrable regnum:closure-linkage regnum:linkage) ; 26
- ; (27)
-(define-integrable regnum:assembler-temp regnum:volatile-scratch) ; 28
-(define-integrable regnum:came-from regnum:volatile-scratch) ; 28
- ; (29)
-
-(define machine-register-value-class
- (let ((special-registers
- `((,regnum:return-value . ,value-class=object)
- (,regnum:regs-pointer . ,value-class=unboxed)
- (,regnum:scheme-to-interface . ,value-class=unboxed)
- (,regnum:closure-hook . ,value-class=unboxed)
- (,regnum:scheme-to-interface-jsr . ,value-class=unboxed)
- (,regnum:dynamic-link . ,value-class=address)
- (,regnum:free . ,value-class=address)
- (,regnum:memtop . ,value-class=address)
- (,regnum:assembler-temp . ,value-class=unboxed)
- (,regnum:stack-pointer . ,value-class=address)
- (,regnum:c-stack-pointer . ,value-class=unboxed))))
- (lambda (register)
- (let ((lookup (assv register special-registers)))
- (cond
- ((not (null? lookup)) (cdr lookup))
- ((<= r0 register r31) value-class=word)
- ((<= f0 register f31) value-class=float)
- (else (error "illegal machine register" register)))))))
-
-(define-integrable (machine-register-known-value register)
- register ;ignore
- false)
-\f
-;;;; Interpreter Registers
-
-(define-integrable (interpreter-free-pointer)
- (rtl:make-machine-register regnum:free))
-
-(define (interpreter-free-pointer? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:free)))
-
-(define-integrable (interpreter-regs-pointer)
- (rtl:make-machine-register regnum:regs-pointer))
-
-(define (interpreter-regs-pointer? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:regs-pointer)))
-
-(define-integrable (interpreter-value-register)
- (rtl:make-machine-register regnum:return-value))
-
-(define (interpreter-value-register? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:return-value)))
-
-(define-integrable (interpreter-stack-pointer)
- (rtl:make-machine-register regnum:stack-pointer))
-
-(define (interpreter-stack-pointer? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:stack-pointer)))
-
-(define-integrable (interpreter-dynamic-link)
- (rtl:make-machine-register regnum:dynamic-link))
-
-(define (interpreter-dynamic-link? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:dynamic-link)))
-
-(define-integrable (interpreter-environment-register)
- (rtl:make-offset (interpreter-regs-pointer) 3))
-
-(define (interpreter-environment-register? expression)
- (and (rtl:offset? expression)
- (interpreter-regs-pointer? (rtl:offset-base expression))
- (let ((offset (rtl:offset-offset expression)))
- (and (rtl:machine-constant? offset)
- (= 3 (rtl:machine-constant-value offset))))))
-
-(define-integrable (interpreter-register:access)
- (rtl:make-machine-register regnum:C-return-value))
-
-(define-integrable (interpreter-register:cache-reference)
- (rtl:make-machine-register regnum:C-return-value))
-
-(define-integrable (interpreter-register:cache-unassigned?)
- (rtl:make-machine-register regnum:C-return-value))
-
-(define-integrable (interpreter-register:lookup)
- (rtl:make-machine-register regnum:C-return-value))
-
-(define-integrable (interpreter-register:unassigned?)
- (rtl:make-machine-register regnum:C-return-value))
-
-(define-integrable (interpreter-register:unbound?)
- (rtl:make-machine-register regnum:C-return-value))
-\f
-;;;; RTL Registers, Constants, and Primitives
-
-(define (rtl:machine-register? rtl-register)
- (case rtl-register
- ((STACK-POINTER)
- (interpreter-stack-pointer))
- ((DYNAMIC-LINK)
- (interpreter-dynamic-link))
- ((VALUE)
- (interpreter-value-register))
- ((FREE)
- (interpreter-free-pointer))
- ((MEMORY-TOP)
- (rtl:make-machine-register regnum:memtop))
- ((INTERPRETER-CALL-RESULT:ACCESS)
- (interpreter-register:access))
- ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
- (interpreter-register:cache-reference))
- ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
- (interpreter-register:cache-unassigned?))
- ((INTERPRETER-CALL-RESULT:LOOKUP)
- (interpreter-register:lookup))
- ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
- (interpreter-register:unassigned?))
- ((INTERPRETER-CALL-RESULT:UNBOUND?)
- (interpreter-register:unbound?))
- (else false)))
-
-(define (rtl:interpreter-register? rtl-register)
- (case rtl-register
- ((INT-MASK) 1)
- ((ENVIRONMENT) 3)
- ((TEMPORARY) 4)
- (else false)))
-
-(define (rtl:interpreter-register->offset locative)
- (or (rtl:interpreter-register? locative)
- (error "Unknown register type" locative)))
-\f
-(define (rtl:constant-cost expression)
- ;; Magic numbers. Cycles needed to generate value in specified
- ;; register.
- ;; Note: the 6 here is really two instructions (one to calculate the
- ;; PC-relative address, the other to load from memory) that require
- ;; 6 cycles worst case without cache miss.
- (let ((if-integer
- (lambda (value)
- (if (or (zero? value)
- (fits-in-16-bits-signed? value)
- (top-16-of-32-bits-only? value))
- 1
- 6))))
- (let ((if-synthesized-constant
- (lambda (type datum)
- (if-integer (make-non-pointer-literal type datum)))))
- (case (rtl:expression-type expression)
- ((CONSTANT)
- (let ((value (rtl:constant-value expression)))
- (if (non-pointer-object? value)
- (if-synthesized-constant (object-type value)
- (object-datum value))
- 6)))
- ((MACHINE-CONSTANT)
- (if-integer (rtl:machine-constant-value expression)))
- ((ENTRY:PROCEDURE ENTRY:CONTINUATION
- ASSIGNMENT-CACHE VARIABLE-CACHE
- OFFSET-ADDRESS BYTE-OFFSET-ADDRESS FLOAT-OFFSET-ADDRESS)
- 6)
- ((CONS-NON-POINTER)
- (and (rtl:machine-constant? (rtl:cons-non-pointer-type expression))
- (rtl:machine-constant? (rtl:cons-non-pointer-datum expression))
- (if-synthesized-constant
- (rtl:machine-constant-value
- (rtl:cons-non-pointer-type expression))
- (rtl:machine-constant-value
- (rtl:cons-non-pointer-datum expression)))))
- (else false)))))
-
-(define compiler:open-code-floating-point-arithmetic?
- true)
-
-(define compiler:primitives-with-no-open-coding
- '(DIVIDE-FIXNUM GCD-FIXNUM
- ; FIXNUM-QUOTIENT FIXNUM-REMAINDER
- INTEGER-QUOTIENT INTEGER-REMAINDER &/
- FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN FLONUM-ACOS FLONUM-ATAN2
- FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-REMAINDER FLONUM-SQRT
- FLONUM-TRUNCATE FLONUM-ROUND FLONUM-CEILING FLONUM-FLOOR
- VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS
- FLOATING-VECTOR-REF FLOATING-VECTOR-SET! FLONUM-EXPM1 FLONUM-LOG1P))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Compiler: System Construction
-
-(declare (usual-integrations))
-
-(let ((value ((load "base/make") "alpha")))
- (set! (access compiler:compress-top-level? (->environment '(compiler))) #t)
- value)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RTL Generation: Special primitive combinations. Alpha version.
-;;; Package: (compiler rtl-generator)
-
-(declare (usual-integrations))
-\f
-(define (define-special-primitive-handler name handler)
- (let ((primitive (make-primitive-procedure name true)))
- (let ((entry (assq primitive special-primitive-handlers)))
- (if entry
- (set-cdr! entry handler)
- (set! special-primitive-handlers
- (cons (cons primitive handler)
- special-primitive-handlers)))))
- name)
-
-(define (special-primitive-handler primitive)
- (let ((entry (assq primitive special-primitive-handlers)))
- (and entry
- (cdr entry))))
-
-(define special-primitive-handlers
- '())
-
-(define (define-special-primitive/standard primitive)
- (define-special-primitive-handler primitive
- rtl:make-invocation:special-primitive))
-
-(define-special-primitive/standard '&+)
-(define-special-primitive/standard '&-)
-;; (define-special-primitive/standard '&*)
-(define-special-primitive/standard '&/)
-(define-special-primitive/standard '&=)
-(define-special-primitive/standard '&<)
-(define-special-primitive/standard '&>)
-(define-special-primitive/standard '1+)
-(define-special-primitive/standard '-1+)
-(define-special-primitive/standard 'zero?)
-(define-special-primitive/standard 'positive?)
-(define-special-primitive/standard 'negative?)
-
-
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Data Transfers
-;; Package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Simple Operations
-
-;;; All assignments to pseudo registers are required to delete the
-;;; dead registers BEFORE performing the assignment. However, it is
-;;; necessary to derive the effective address of the source
-;;; expression(s) before deleting the dead registers. Otherwise any
-;;; source expression containing dead registers might refer to aliases
-;;; which have been reused.
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
- (standard-move-to-target! source target)
- (LAP))
-
-(define-rule statement
- ;; tag the contents of a register
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum))))
- (rules1-make-object target type datum))
-
-(define-rule statement
- ;; tag the contents of a register
- (ASSIGN (REGISTER (? target))
- (CONS-NON-POINTER (REGISTER (? type)) (REGISTER (? datum))))
- (rules1-make-object target type datum))
-
-(define (rules1-make-object target type datum)
- (let* ((type (standard-source! type))
- (datum (standard-source! datum))
- (target (standard-target! target)))
- (LAP (SLL ,type (& ,scheme-datum-width) ,target)
- (BIS ,datum ,target ,target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source))))
- (standard-unary-conversion source target
- (lambda (source target)
- (deposit-type-address type source target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source))))
- (standard-unary-conversion source target
- (lambda (source target)
- (deposit-type-datum type source target))))
-
-(define-rule statement
- ;; extract the type part of a register's contents
- (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
- (standard-unary-conversion source target object->type))
-
-(define-rule statement
- ;; extract the datum part of a register's contents
- (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
- (standard-unary-conversion source target object->datum))
-
-(define-rule statement
- ;; convert the contents of a register to an address
- (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
- (standard-unary-conversion source target object->address))
-\f
-(define-rule statement
- ;; add a distance (in longwords) to a register's contents
- (ASSIGN (REGISTER (? target))
- (OFFSET-ADDRESS (REGISTER (? source))
- (REGISTER (? offset))))
- (address-add target source offset address-units-per-object))
-
-(define-rule statement
- ;; add a distance (in longwords) to a register's contents
- (ASSIGN (REGISTER (? target))
- (OFFSET-ADDRESS (REGISTER (? source))
- (MACHINE-CONSTANT (? offset))))
- (standard-unary-conversion source target
- (lambda (source target)
- (add-immediate (* address-units-per-object offset)
- source target))))
-
-(define-rule statement
- ;; add a distance (in bytes) to a register's contents
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET-ADDRESS (REGISTER (? source))
- (REGISTER (? offset))))
- (address-add target source offset 1))
-
-(define-rule statement
- ;; add a distance (in bytes) to a register's contents
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET-ADDRESS (REGISTER (? source))
- (MACHINE-CONSTANT (? offset))))
- (standard-unary-conversion source target
- (lambda (source target)
- (add-immediate offset source target))))
-
-(define-rule statement
- ;; add a distance (in "size of floating point constants") to a
- ;; register's contents.
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET-ADDRESS (REGISTER (? base))
- (REGISTER (? index))))
- (address-add target base index address-units-per-float))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET-ADDRESS (REGISTER (? source))
- (MACHINE-CONSTANT (? offset))))
- (standard-unary-conversion source target
- (lambda (source target)
- (add-immediate (* address-units-per-float offset)
- source target))))
-
-(define (address-add target base index size-in-address-units)
- (case size-in-address-units
- ((1) (standard-binary-conversion base index target
- (lambda (base index target)
- (LAP (ADDQ ,index ,base ,target)))))
- ((4) (standard-binary-conversion base index target
- (lambda (base index target)
- (LAP (S4ADDQ ,index ,base ,target)))))
- ((8) (standard-binary-conversion base index target
- (lambda (base index target)
- (LAP (S8ADDQ ,index ,base ,target)))))
- (else (error "address-add: size of object isn't 1, 4, or 8 bytes"
- size-in-address-units))))
-
-(define (with-indexed-address base index size-in-address-units recvr)
- (let ((base (standard-source! base))
- (index (standard-source! index))
- (temp (standard-temporary!)))
- (case size-in-address-units
- ((0) (LAP (ADDQ ,base ,index ,temp)
- ,@(recvr temp)))
- ((4) (LAP (S4ADDQ ,index ,base ,temp)
- ,@(recvr temp)))
- ((8) (LAP (S8ADDQ ,index ,base ,temp)
- ,@(recvr temp)))
- (else
- (error
- "with-indexed-address: size of object isn't 1, 4,or 8 bytes"
- size-in-address-units)))))
-\f
-;;;; Loading of Constants
-
-(define-rule statement
- ;; load a machine constant
- (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? source)))
- (load-immediate (standard-target! target) source #T))
-
-(define-rule statement
- ;; load a Scheme constant
- (ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
- (load-constant (standard-target! target) source #T))
-
-(define-rule statement
- ;; load the type part of a Scheme constant
- (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (CONSTANT (? constant))))
- (load-immediate (standard-target! target)
- (make-non-pointer-literal 0 (object-type constant))
- #T))
-
-(define-rule statement
- ;; load the datum part of a Scheme constant
- (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant))))
- (QUALIFIER (non-pointer-object? constant))
- (load-immediate (standard-target! target)
- (make-non-pointer-literal 0 (careful-object-datum constant))
- #T))
-
-(define-rule statement
- ;; load a synthesized constant
- (ASSIGN (REGISTER (? target))
- (CONS-NON-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum))))
- (load-immediate (standard-target! target)
- (make-non-pointer-literal type datum)
- #T))
-\f
-(define-rule statement
- ;; load the address of a variable reference cache
- (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
- (load-pc-relative (standard-target! target)
- 'CONSTANT
- (free-reference-label name)))
-
-(define-rule statement
- ;; load the address of an assignment cache
- (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name)))
- (load-pc-relative (standard-target! target)
- 'CONSTANT
- (free-assignment-label name)))
-
-(define-rule statement
- ;; load the address of a procedure's entry point
- (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label)))
- (load-pc-relative-address (standard-target! target) 'CODE label))
-
-(define-rule statement
- ;; load the address of a continuation
- (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label)))
- (load-pc-relative-address (standard-target! target) 'CODE label))
-
-(define-rule statement
- ;; load a procedure object
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (ENTRY:PROCEDURE (? label))))
- (load-entry target type label))
-
-(define-rule statement
- ;; load a return address object
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (ENTRY:CONTINUATION (? label))))
- (load-entry target type label))
-
-(define (load-entry target type label)
- (let ((temporary (standard-temporary!))
- (target (standard-target! target)))
- ;; Loading the address into a temporary makes it more useful,
- ;; because it can be reused later.
- (LAP ,@(load-pc-relative-address temporary 'CODE label)
- ,@(deposit-type-address type temporary target))))
-\f
-;;;; Transfers from memory
-
-(define-rule statement
- ;; read an object from memory
- (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address))
- (MACHINE-CONSTANT (? offset))))
- (standard-unary-conversion address target
- (lambda (address target)
- (LAP (LDQ ,target
- (OFFSET ,(* address-units-per-object offset)
- ,address))))))
-
-;; Note: we don't seem to need
-;; (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? base))
-;; (REGISTER (? index))))
-
-(define-rule statement
- ;; Pop stack to register
- (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER (? stack)) 1))
- (QUALIFIER (= stack regnum:stack-pointer))
- (LAP (LDQ ,(standard-target! target) (OFFSET 0 ,regnum:stack-pointer))
- (ADDQ ,regnum:stack-pointer (& ,address-units-per-object)
- ,regnum:stack-pointer)))
-
-;;;; Transfers to memory
-
-(define-rule statement
- ;; store an object in memory
- (ASSIGN (OFFSET (REGISTER (? address)) (MACHINE-CONSTANT (? offset)))
- (? source register-expression))
- (QUALIFIER (word-register? source))
- (LAP (STQ ,(standard-source! source)
- (OFFSET ,(* address-units-per-object offset)
- ,(standard-source! address)))))
-
-;; Note: we don't seem to need
-;; (ASSIGN (OFFSET (REGISTER (? base)) (REGISTER (? index)))
-;; (? source register-expression))
-
-(define-rule statement
- ;; Push an object register on the heap
- (ASSIGN (POST-INCREMENT (REGISTER (? Free)) 1)
- (? source register-expression))
- (QUALIFIER (and (= free regnum:free) (word-register? source)))
- (LAP (STQ ,(standard-source! source) (OFFSET 0 ,regnum:free))
- (ADDQ ,regnum:free (& ,address-units-per-object) ,regnum:free)))
-
-(define-rule statement
- ;; Push an object register on the stack
- (ASSIGN (PRE-INCREMENT (REGISTER (? stack)) -1)
- (? source register-expression))
- (QUALIFIER (and (= stack regnum:stack-pointer) (word-register? source)))
- (LAP (STQ ,(standard-source! source)
- (OFFSET ,(- address-units-per-object) ,regnum:stack-pointer))
- (SUBQ ,regnum:stack-pointer (& ,address-units-per-object)
- ,regnum:stack-pointer)))
-
-;; Cheaper, common patterns.
-
-;; We don't need
-;; (ASSIGN (OFFSET (REGISTER (? base)) (REGISTER (? index)))
-;; (MACHINE-CONSTANT 0))
-;; since it simplifies to (... (OFFSET REGISTER MACHINE-CONSTANT) ...)
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? address)) (MACHINE-CONSTANT (? offset)))
- (MACHINE-CONSTANT 0))
- (LAP (STQ ,regnum:zero (OFFSET ,(* address-units-per-object offset)
- ,(standard-source! address)))))
-
-(define-rule statement
- ; Push NIL (or whatever is represented by a machine 0) on heap
- (ASSIGN (POST-INCREMENT (REGISTER (? free)) 1) (MACHINE-CONSTANT 0))
- (QUALIFIER (= free regnum:free))
- (LAP (STQ ,regnum:zero (OFFSET 0 ,regnum:free))
- (ADDQ ,regnum:free (& ,address-units-per-object) ,regnum:free)))
-
-(define-rule statement
- ; Ditto, but on stack
- (ASSIGN (PRE-INCREMENT (REGISTER (? stack)) -1) (MACHINE-CONSTANT 0))
- (QUALIFIER (= stack regnum:stack-pointer))
- (LAP (STQ ,regnum:zero
- (OFFSET ,(- address-units-per-object) ,regnum:stack-pointer))
- (SUBQ ,regnum:stack-pointer (& ,address-units-per-object)
- ,regnum:stack-pointer)))
-\f
-;;;; CHAR->ASCII/BYTE-OFFSET
-
-(define-rule statement
- ;; convert char object to ASCII byte
- (ASSIGN (REGISTER (? target))
- (CHAR->ASCII (REGISTER (? source))))
- (standard-unary-conversion source target
- (lambda (source target)
- (LAP (AND ,source (& #xFF) ,target)))))
-
-(define-rule statement
- ;; store null byte in memory
- (ASSIGN (BYTE-OFFSET (REGISTER (? source))
- (MACHINE-CONSTANT (? offset)))
- (CHAR->ASCII (CONSTANT #\NUL)))
- (modify-byte (standard-source! source) offset
- (lambda (data-register offset-register)
- data-register ; Ignored
- offset-register ; Ignored
- (LAP))))
-
-(define-rule statement
- ;; load ASCII byte from memory
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET (REGISTER (? address))
- (MACHINE-CONSTANT (? offset))))
- (load-byte address offset target))
-
-(define-rule statement
- ;; store ASCII byte in memory. There may be a FIXNUM typecode.
- (ASSIGN (BYTE-OFFSET (REGISTER (? address))
- (MACHINE-CONSTANT (? offset)))
- (REGISTER (? source)))
- (let ((source (standard-source! source))
- (address (standard-source! address)))
- (store-byte address offset source)))
-
-(define-rule statement
- ;; convert char object to ASCII byte and store it in memory
- ;; register + byte offset <- contents of register (clear top bits)
- (ASSIGN (BYTE-OFFSET (REGISTER (? address))
- (MACHINE-CONSTANT (? offset)))
- (CHAR->ASCII (REGISTER (? source))))
- (let ((source (standard-source! source))
- (address (standard-source! address)))
- (store-byte address offset source)))
-
-(define (modify-byte source offset update-byte)
- (let* ((temp (standard-temporary!))
- (byte-offset (modulo offset address-units-per-object)))
- (if (and (zero? byte-offset) (fits-in-16-bits-signed? byte-offset))
- (LAP (LDQ_U ,temp (OFFSET ,offset ,source))
- (MSKBL ,temp ,source ,temp) ; Zero byte to modify
- ,@(update-byte temp source)
- (STQ_U ,temp (OFFSET ,offset ,source)))
- (let ((address-temp (standard-temporary!)))
- (LAP (LDA ,address-temp (OFFSET ,offset ,source))
- (LDQ_U ,temp (OFFSET 0 ,address-temp))
- (MSKBL ,temp ,address-temp ,temp) ; Zero byte to modify
- ,@(update-byte temp address-temp)
- (STQ_U ,temp (OFFSET 0 ,address-temp)))))))
-
-(define (store-byte address offset source)
- (let ((temp (standard-temporary!)))
- (modify-byte address offset
- (lambda (data-register offset-register)
- ;; data-register has the contents of memory with the desired
- ;; byte set to zero; offset-register has the number of the
- ;; machine register that holds the byte offset within word.
- ;; INSBL moves the byte to be stored into the correct position
- ;; BIS ORs the two together, completing the byte insert
- (LAP (INSBL ,source ,offset-register ,temp)
- (BIS ,data-register ,temp ,data-register))))))
-
-(define (load-byte address offset target)
- (let* ((source (standard-source! address))
- (target (standard-target! target))
- (byte-offset (modulo offset address-units-per-object)))
- (if (zero? byte-offset)
- (LAP (LDQ_U ,target (OFFSET ,offset ,source))
- (EXTBL ,target ,source ,target))
- (let ((temp (standard-temporary!)))
- (LAP (LDQ_U ,target (OFFSET ,offset ,source))
- (LDA ,temp (OFFSET ,byte-offset ,source))
- (EXTBL ,target ,temp ,target))))))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Predicates
-;; Package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-(define-rule predicate
- ;; test for two registers EQ?
- (EQ-TEST (REGISTER (? source1)) (REGISTER (? source2)))
- (compare '= (standard-source! source1) (standard-source! source2)))
-
-(define-rule predicate
- ;; test for register EQ? to constant
- (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register)))
- (eq-test/constant*register constant register))
-
-(define-rule predicate
- ;; test for register EQ? to constant
- (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant)))
- (eq-test/constant*register constant register))
-
-(define (eq-test/constant*register constant source)
- (let ((source (standard-source! source)))
- (if (non-pointer-object? constant)
- (compare-immediate '= (non-pointer->literal constant) source)
- (let ((temp (standard-temporary!)))
- (LAP ,@(load-pc-relative temp
- 'CONSTANT (constant->label constant))
- ,@(compare '= temp source))))))
-
-(define-rule predicate
- ;; test for register EQ? to synthesized constant
- (EQ-TEST (CONS-NON-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum)))
- (REGISTER (? register)))
- (eq-test/synthesized-constant*register type datum register))
-
-(define-rule predicate
- ;; test for register EQ? to synthesized constant
- (EQ-TEST (REGISTER (? register))
- (CONS-NON-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum))))
- (eq-test/synthesized-constant*register type datum register))
-
-(define (eq-test/synthesized-constant*register type datum source)
- (compare-immediate '=
- (make-non-pointer-literal type datum)
- (standard-source! source)))
-
-(define-rule predicate
- ;; Branch if virtual register contains the specified type number
- (TYPE-TEST (REGISTER (? register)) (? type))
- (compare-immediate '= type (standard-source! register)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Invocations and Entries (Alpha)
-;; Package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Invocations
-
-(define-rule statement
- (POP-RETURN)
- (pop-return))
-
-(define (pop-return)
- (let ((temp (standard-temporary!)))
- (LAP ,@(clear-map!)
- (LDQ ,temp (OFFSET 0 ,regnum:stack-pointer))
- (ADDQ ,regnum:stack-pointer (& 8) ,regnum:stack-pointer)
- (XOR ,temp ,regnum:compiled-entry-type-bits ,temp)
- ; XOR instead of ,@(object->address temp temp)
- (RET ,temp))))
-
-(define-rule statement
- (INVOCATION:APPLY (? frame-size) (? continuation))
- continuation ;ignore
- (LAP ,@(clear-map!)
- ,@(load-immediate regnum:second-arg frame-size #F)
- (LDQ ,regnum:first-arg (OFFSET 0 ,regnum:stack-pointer))
- (ADDQ ,regnum:stack-pointer (& 8) ,regnum:stack-pointer)
- ,@(invoke-interface code:compiler-apply)))
-
-(define-rule statement
- (INVOCATION:JUMP (? frame-size) (? continuation) (? label))
- frame-size continuation ;ignore
- (LAP ,@(clear-map!)
- (BR ,regnum:came-from (@PCR ,label))))
-
-(define-rule statement
- (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation))
- frame-size continuation ;ignore
- ;; It expects the procedure at the top of the stack
- (pop-return))
-
-(define-rule statement
- (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
- continuation ;ignore
- (let* ((clear-first-arg (clear-registers! regnum:first-arg))
- (load-first-arg
- (load-pc-relative-address regnum:first-arg 'CODE label)))
- (LAP ,@clear-first-arg
- ,@load-first-arg
- ,@(clear-map!)
- ,@(load-immediate regnum:second-arg number-pushed #F)
- ,@(invoke-interface code:compiler-lexpr-apply))))
-
-(define-rule statement
- (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation))
- continuation ;ignore
- ;; Destination address is at TOS; pop it into first-arg
- (LAP ,@(clear-map!)
- (LDQ ,regnum:first-arg (OFFSET 0 ,regnum:stack-pointer))
- (ADDQ ,regnum:stack-pointer (& 8) ,regnum:stack-pointer)
- ,@(object->address regnum:first-arg regnum:first-arg)
- ,@(load-immediate regnum:second-arg number-pushed #F)
- ,@(invoke-interface code:compiler-lexpr-apply)))
-\f
-(define-rule statement
- (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
- continuation ;ignore
- (LAP ,@(clear-map!)
- (BR ,regnum:came-from
- (OFFSET 4 (@PCR ,(free-uuo-link-label name frame-size))))))
-
-(define-rule statement
- (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
- continuation ;ignore
- (LAP ,@(clear-map!)
- (BR ,regnum:came-from
- (OFFSET 4 (@PCR ,(global-uuo-link-label name frame-size))))))
-
-(define-rule statement
- (INVOCATION:CACHE-REFERENCE (? frame-size)
- (? continuation)
- (? extension register-expression))
- continuation ;ignore
- (let* ((clear-second-arg (clear-registers! regnum:second-arg))
- (load-second-arg
- (load-pc-relative-address regnum:second-arg 'CODE *block-label*)))
- (LAP ,@clear-second-arg
- ,@load-second-arg
- ,@(load-interface-args! extension false false false)
- ,@(load-immediate regnum:third-arg frame-size #F)
- ,@(invoke-interface code:compiler-cache-reference-apply))))
-
-(define-rule statement
- (INVOCATION:LOOKUP (? frame-size)
- (? continuation)
- (? environment register-expression)
- (? name))
- continuation ;ignore
- (LAP ,@(load-interface-args! environment false false false)
- ,@(load-constant regnum:second-arg name #F)
- ,@(load-immediate regnum:third-arg frame-size #F)
- ,@(invoke-interface code:compiler-lookup-apply)))
-\f
-(define-rule statement
- (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
- continuation ;ignore
- (if (eq? primitive compiled-error-procedure)
- (LAP ,@(clear-map!)
- ,@(load-immediate regnum:first-arg frame-size #F)
- ,@(invoke-interface code:compiler-error))
- (let* ((clear-first-arg (clear-registers! regnum:first-arg))
- (load-first-arg
- (load-pc-relative regnum:first-arg
- 'CONSTANT
- (constant->label primitive))))
- (LAP ,@clear-first-arg
- ,@load-first-arg
- ,@(clear-map!)
- ,@(let ((arity (primitive-procedure-arity primitive)))
- (cond ((not (negative? arity))
- (invoke-interface code:compiler-primitive-apply))
- ((= arity -1)
- (LAP ,@(load-immediate regnum:assembler-temp
- (-1+ frame-size)
- #F)
- (STQ ,regnum:assembler-temp
- ,reg:lexpr-primitive-arity)
- ,@(invoke-interface
- code:compiler-primitive-lexpr-apply)))
- (else
- ;; Unknown primitive arity. Go through apply.
- (LAP ,@(load-immediate regnum:second-arg frame-size #F)
- ,@(invoke-interface code:compiler-apply)))))))))
-
-(let-syntax
- ((define-special-primitive-invocation
- (sc-macro-transformer
- (lambda (form environment)
- `(DEFINE-RULE STATEMENT
- (INVOCATION:SPECIAL-PRIMITIVE
- (? FRAME-SIZE)
- (? CONTINUATION)
- ,(make-primitive-procedure (cadr form) #t))
- FRAME-SIZE CONTINUATION
- ,(list 'LAP
- (list 'UNQUOTE-SPLICING '(CLEAR-MAP!))
- (list 'UNQUOTE-SPLICING
- `(INVOKE-INTERFACE
- ,(close-syntax (symbol-append 'CODE:COMPILER-
- (cadr form))
- environment)))))))))
- (define-special-primitive-invocation &+)
- (define-special-primitive-invocation &-)
- (define-special-primitive-invocation &*)
- (define-special-primitive-invocation &/)
- (define-special-primitive-invocation &=)
- (define-special-primitive-invocation &<)
- (define-special-primitive-invocation &>)
- (define-special-primitive-invocation 1+)
- (define-special-primitive-invocation -1+)
- (define-special-primitive-invocation zero?)
- (define-special-primitive-invocation positive?)
- (define-special-primitive-invocation negative?))
-\f
-;;;; Invocation Prefixes
-
-;;; (INVOCATION-PREFIX:MOVE-FRAME-UP frame-size address)
-
-;;; Move the topmost <frame-size> words of the stack downward so that
-;;; the bottommost of these words is at location <address>, and set
-;;; the stack pointer to the topmost of the moved words. That is,
-;;; discard the words between <address> and SP+<frame-size>, close the
-;;; resulting gap by shifting down the words from above the gap, and
-;;; adjust SP to point to the new topmost word.
-
-(define-rule statement
- ;; Move up 0 words back to top of stack : a No-Op
- (INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER (? stack)))
- (QUALIFIER (= stack regnum:stack-pointer))
- (LAP))
-
-(define-rule statement
- ;; Move <frame-size> words back to dynamic link marker
- (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER (? dlink)))
- (QUALIFIER (= dlink regnum:dynamic-link))
- (generate/move-frame-up frame-size
- (lambda (reg) (LAP (COPY ,regnum:dynamic-link ,reg)))))
-
-(define-rule statement
- ;; Move <frame-size> words back to SP+offset
- (INVOCATION-PREFIX:MOVE-FRAME-UP
- (? frame-size) (OFFSET-ADDRESS (REGISTER (? stack))
- (MACHINE-CONSTANT (? offset))))
- (QUALIFIER (= stack regnum:stack-pointer))
- (let ((how-far (* 8 (- offset frame-size))))
- (cond ((zero? how-far)
- (LAP))
- ((negative? how-far)
- (error "invocation-prefix:move-frame-up: bad specs"
- frame-size offset))
- ((zero? frame-size)
- (add-immediate how-far regnum:stack-pointer regnum:stack-pointer))
- ((= frame-size 1)
- (let ((temp (standard-temporary!)))
- (LAP (LDQ ,temp (OFFSET 0 ,regnum:stack-pointer))
- (ADDQ ,regnum:stack-pointer (& ,how-far)
- ,regnum:stack-pointer)
- (STQ ,temp (OFFSET 0 ,regnum:stack-pointer)))))
- ((= frame-size 2)
- (let ((temp1 (standard-temporary!))
- (temp2 (standard-temporary!)))
- (LAP (LDQ ,temp1 (OFFSET 0 ,regnum:stack-pointer))
- (LDQ ,temp2 (OFFSET 8 ,regnum:stack-pointer))
- (ADDQ ,regnum:stack-pointer (& ,how-far)
- ,regnum:stack-pointer)
- (STQ ,temp1 (OFFSET 0 ,regnum:stack-pointer))
- (STQ ,temp2 (OFFSET 8 ,regnum:stack-pointer)))))
- (else
- (generate/move-frame-up frame-size
- (lambda (reg)
- (add-immediate (* 8 offset) regnum:stack-pointer reg)))))))
-
-(define-rule statement
- ;; Move <frame-size> words back to base virtual register + offset
- (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size)
- (OFFSET-ADDRESS (REGISTER (? base)) (MACHINE-CONSTANT (? offset))))
- (QUALIFIER (not (= base 20)))
- (generate/move-frame-up frame-size
- (lambda (reg)
- (add-immediate (* 8 offset) (standard-source! base) reg))))
-
-(define (generate/move-frame-up frame-size destination-generator)
- (let ((temp (standard-temporary!)))
- (LAP ,@(destination-generator temp)
- ,@(generate/move-frame-up* frame-size temp))))
-\f
-;;; DYNAMIC-LINK instructions have a <frame-size>, <new frame end>,
-;;; and <current dynamic link> as arguments. They pop the stack by
-;;; removing the lesser of the amount needed to move the stack pointer
-;;; back to the <new frame end> or <current dynamic link>. The last
-;;; <frame-size> words on the stack (the stack frame for the procedure
-;;; about to be called) are then put back onto the newly adjusted
-;;; stack.
-
-(define-rule statement
- (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
- (REGISTER (? source))
- (REGISTER (? dlink)))
- (QUALIFIER (= dlink regnum:dynamic-link))
- (if (and (zero? frame-size)
- (= source regnum:stack-pointer))
- (LAP)
- (let ((env-reg (standard-move-to-temporary! source)))
- (LAP (CMPULT ,env-reg ,regnum:dynamic-link ,regnum:assembler-temp)
- (CMOVEQ ,regnum:assembler-temp ,regnum:dynamic-link ,env-reg)
- ,@(generate/move-frame-up* frame-size env-reg)))))
-
-(define (generate/move-frame-up* frame-size destination)
- ;; Destination is guaranteed to be a machine register number; that
- ;; register has the destination base address for the frame. The stack
- ;; pointer is reset to the top end of the copied area.
- (LAP ,@(case frame-size
- ((0)
- (LAP))
- ((1)
- (let ((temp (standard-temporary!)))
- (LAP (LDQ ,temp (OFFSET 0 ,regnum:stack-pointer))
- (SUBQ ,destination (& 8) ,destination)
- (STQ ,temp (OFFSET 0 ,destination)))))
- (else
- (let ((from (standard-temporary!))
- (temp1 (standard-temporary!))
- (temp2 (standard-temporary!)))
- (LAP ,@(add-immediate (* 8 frame-size) regnum:stack-pointer from)
- ,@(if (<= frame-size 3)
- ;; This code can handle any number > 1
- ;; (handled above), but we restrict it to 3
- ;; for space reasons.
- (let loop ((n frame-size))
- (case n
- ((0)
- (LAP))
- ((3)
- (let ((temp3 (standard-temporary!)))
- (LAP (LDQ ,temp1 (OFFSET -8 ,from))
- (LDQ ,temp2 (OFFSET -16 ,from))
- (LDQ ,temp3 (OFFSET -24 ,from))
- (SUBQ ,from (& 24) ,from)
- (STQ ,temp1 (OFFSET -8 ,destination))
- (STQ ,temp2 (OFFSET -16 ,destination))
- (STQ ,temp3 (OFFSET -24 ,destination))
- (SUBQ ,destination (& 24) ,destination))))
- (else
- (LAP (LDQ ,temp1 (OFFSET -8 ,from))
- (LDQ ,temp2 (OFFSET -16 ,from))
- (SUBQ ,from (& 16) ,from)
- (STQ ,temp1 (OFFSET -8 ,destination))
- (STQ ,temp2 (OFFSET -16 ,destination))
- (SUBQ ,destination (& 16) ,destination)
- ,@(loop (- n 2))))))
- (let ((label (generate-label)))
- (LAP ,@(load-immediate temp2 frame-size #F)
- (LABEL ,label)
- (LDQ ,temp1 (OFFSET -8 ,from))
- (SUBQ ,from (& 8) ,from)
- (SUBQ ,temp2 (& 1) ,temp2)
- (SUBQ ,destination (& 8) ,destination)
- (STQ ,temp1 (OFFSET 0 ,destination))
- (BNE ,temp2 (@PCR ,label)))))))))
- (COPY ,destination ,regnum:stack-pointer)))
-\f
-;;;; External Labels
-
-(define (make-external-label code label)
- (set! *external-labels* (cons label *external-labels*))
- (LAP (EXTERNAL-LABEL ,code (@PCR ,label))
- (LABEL ,label)))
-
-;;; Entry point types
-
-(define-integrable (make-code-word min max)
- (+ (* #x100 min) max))
-
-(define (make-procedure-code-word min max)
- ;; The "min" byte must be less than #x80; the "max" byte may not
- ;; equal #x80 but can take on any other value.
- (if (or (negative? min) (>= min #x80))
- (error "MAKE-PROCEDURE-CODE-WORD: minimum out of range" min))
- (if (>= (abs max) #x80)
- (error "MAKE-PROCEDURE-CODE-WORD: maximum out of range" max))
- (make-code-word min (if (negative? max) (+ #x100 max) max)))
-
-(define expression-code-word
- (make-code-word #xff #xff))
-
-(define internal-entry-code-word
- (make-code-word #xff #xfe))
-
-(define internal-continuation-code-word
- (make-code-word #xff #xfc))
-
-(define (continuation-code-word label)
- (frame-size->code-word
- (if label
- (rtl-continuation/next-continuation-offset (label->object label))
- 0)
- internal-continuation-code-word))
-
-(define (internal-procedure-code-word rtl-proc)
- ;; represented as return addresses so the debugger will
- ;; not barf when it sees them (on the stack if interrupted).
- (frame-size->code-word
- (rtl-procedure/next-continuation-offset rtl-proc)
- internal-entry-code-word))
-
-(define (frame-size->code-word offset default)
- (cond ((not offset)
- default)
- ((< offset #x2000)
- ;; This uses up through (#xff #xdf).
- (let ((qr (integer-divide offset #x80)))
- (make-code-word (+ #x80 (integer-divide-remainder qr))
- (+ #x80 (integer-divide-quotient qr)))))
- (else
- (error "Unable to encode continuation offset" offset))))
-\f
-;;;; Procedure headers
-
-;;; The following calls MUST appear as the first thing at the entry
-;;; point of a procedure. They assume that the register map is clear
-;;; and that no register contains anything of value.
-;;;
-;;; The only reason that this is true is that no register is live
-;;; across calls. If that were not true, then we would have to save
-;;; any such registers on the stack so that they would be GC'ed
-;;; appropriately.
-;;;
-;;; The only exception is the dynamic link register, handled
-;;; specially. Procedures that require a dynamic link use a different
-;;; interrupt handler that saves and restores the dynamic link
-;;; register.
-
-(define (simple-procedure-header code-word label code)
- (let ((gc-label (generate-label)))
- (LAP
- (LABEL ,gc-label)
- ,@(link-to-interface code)
- ,@(make-external-label code-word label)
- ,@(interrupt-check label gc-label))))
-
-(define (dlink-procedure-header code-word label)
- (let ((gc-label (generate-label)))
- (LAP
- (LABEL ,gc-label)
- (COPY ,regnum:dynamic-link ,regnum:second-arg)
- ,@(link-to-interface code:compiler-interrupt-dlink)
- ,@(make-external-label code-word label)
- ,@(interrupt-check label gc-label))))
-
-(define (interrupt-check procedure-label gc-label)
- ;; Code sequence 2 in cmpint-alpha.h
- ;; Interrupt/Stack checks always done in line.
- (let ((Interrupt (generate-label))
- (temp (standard-temporary!)))
- ;; The following trick makes branch prediction work.
- ;; The interrupt branch (taken very rarely) is guaranteed to
- ;; be a forward branch, so it is predicted NOT taken.
- (add-end-of-block-code!
- (lambda ()
- (LAP (LABEL ,Interrupt)
- (BR ,regnum:came-from (@PCR ,gc-label)))))
- (if (not (let ((object (label->object procedure-label)))
- (and (rtl-procedure? object)
- (not (rtl-procedure/stack-leaf? object))
- compiler:generate-stack-checks?)))
- (LAP (CMPLT ,regnum:free ,regnum:memtop ,temp)
- (LDQ ,regnum:memtop ,reg:memtop)
- (BEQ ,temp (@PCR ,Interrupt)))
- (let ((temp2 (standard-temporary!)))
- (LAP (LDQ ,temp2 ,reg:stack-guard)
- (CMPLT ,regnum:free ,regnum:memtop ,temp)
- (LDQ ,regnum:memtop ,reg:memtop)
- (BEQ ,temp (@PCR ,Interrupt))
- (CMPLE ,regnum:stack-pointer ,temp2 ,temp)
- (BNE ,temp (@PCR ,Interrupt)))))))
-
-(define-rule statement
- (CONTINUATION-ENTRY (? internal-label))
- (make-external-label (continuation-code-word internal-label)
- internal-label))
-
-(define-rule statement
- (CONTINUATION-HEADER (? internal-label))
- (simple-procedure-header (continuation-code-word internal-label)
- internal-label
- code:compiler-interrupt-continuation))
-
-(define-rule statement
- (IC-PROCEDURE-HEADER (? internal-label))
- (let ((procedure (label->object internal-label)))
- (let ((external-label (rtl-procedure/external-label procedure)))
- (LAP (ENTRY-POINT ,external-label)
- (EQUATE ,external-label ,internal-label)
- ,@(simple-procedure-header expression-code-word
- internal-label
- code:compiler-interrupt-ic-procedure)))))
-
-(define-rule statement
- (OPEN-PROCEDURE-HEADER (? internal-label))
- (let ((rtl-proc (label->object internal-label)))
- (LAP (EQUATE ,(rtl-procedure/external-label rtl-proc) ,internal-label)
- ,@((if (rtl-procedure/dynamic-link? rtl-proc)
- dlink-procedure-header
- (lambda (code-word label)
- (simple-procedure-header code-word label
- code:compiler-interrupt-procedure)))
- (internal-procedure-code-word rtl-proc)
- internal-label))))
-
-(define-rule statement
- (PROCEDURE-HEADER (? internal-label) (? min) (? max))
- (LAP (EQUATE ,(rtl-procedure/external-label (label->object internal-label))
- ,internal-label)
- ,@(simple-procedure-header (make-procedure-code-word min max)
- internal-label
- code:compiler-interrupt-procedure)))
-\f
-;;;; Closures.
-
-;; Magic for compiled entries.
-
-(define-rule statement
- (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
- entry ; Ignored
- (if (zero? nentries)
- (error "Closure header for closure with no entries!"
- internal-label))
- (let ((Interrupt (generate-label))
- (merge (generate-label))
- (interrupt-boolean (standard-temporary!))
- (stack-check?
- (let ((object (label->object internal-label)))
- (and (rtl-procedure? object)
- (not (rtl-procedure/stack-leaf? object))
- compiler:generate-stack-checks?))))
- (let ((stack-guard (and stack-check? (standard-temporary!))))
- ;; Interrupt/Stack checks always done in line.
- (add-end-of-block-code!
- (if (not stack-check?)
- (lambda ()
- (LAP
- (LABEL ,internal-label)
- ;; Code seq. 4 from cmpint-alpha.h
- (CMPLT ,regnum:free ,regnum:memtop ,interrupt-boolean)
- (LDQ ,regnum:memtop ,reg:memtop)
- (BNE ,interrupt-boolean (@PCR ,merge))
- (LABEL ,Interrupt)
- ;; Code seq. 5 from cmpint-alpha.h
- ,@(invoke-interface code:compiler-interrupt-closure)))
- (lambda ()
- (LAP
- (LABEL ,internal-label)
- ;; Code seq. 4 from cmpint-alpha.h
- (LDQ ,stack-guard ,reg:stack-guard)
- (CMPLT ,regnum:free ,regnum:memtop ,interrupt-boolean)
- (LDQ ,regnum:memtop ,reg:memtop)
- (BEQ ,interrupt-boolean (@PCR ,Interrupt))
- (CMPLE ,regnum:stack-pointer ,stack-guard ,interrupt-boolean)
- (BEQ ,interrupt-boolean (@PCR ,merge))
- (LABEL ,Interrupt)
- ;; Code seq. 5 from cmpint-alpha.h
- ,@(invoke-interface code:compiler-interrupt-closure)))))
-
- (let ((rtl-proc (label->object internal-label)))
- (let ((label (rtl-procedure/external-label rtl-proc))
- (reconstructed-closure (standard-temporary!)))
- (if (not stack-check?)
- (LAP
- ;; Code seq. 3 from cmpint-alpha.h
- ,@(make-external-label (internal-procedure-code-word rtl-proc)
- label)
- ;; (SUBQ ,regnum:stack-pointer (& 8) ,regnum:stack-pointer)
- (SUBQ ,regnum:linkage (& 8) ,reconstructed-closure)
- (CMPLT ,regnum:free ,regnum:memtop ,interrupt-boolean)
- (LDQ ,regnum:memtop ,reg:memtop)
- (BIS ,regnum:compiled-entry-type-bits
- ,reconstructed-closure ,reconstructed-closure)
- (STQ ,reconstructed-closure (OFFSET 0 ,regnum:stack-pointer))
- (BEQ ,interrupt-boolean (@PCR ,Interrupt))
- (LABEL ,merge))
- (LAP
- ;; Code seq. 3 from cmpint-alpha.h
- ,@(make-external-label (internal-procedure-code-word rtl-proc)
- label)
- ;; (SUBQ ,regnum:stack-pointer (& 8) ,regnum:stack-pointer)
- (SUBQ ,regnum:linkage (& 8) ,reconstructed-closure)
- (LDQ ,stack-guard ,reg:stack-guard)
- (CMPLT ,regnum:free ,regnum:memtop ,interrupt-boolean)
- (LDQ ,regnum:memtop ,reg:memtop)
- (BIS ,regnum:compiled-entry-type-bits
- ,reconstructed-closure ,reconstructed-closure)
- (STQ ,reconstructed-closure (OFFSET 0 ,regnum:stack-pointer))
- (BEQ ,interrupt-boolean (@PCR ,Interrupt))
- (CMPLE ,regnum:stack-pointer ,stack-guard ,interrupt-boolean)
- (BNE ,interrupt-boolean (@PCR ,Interrupt))
- (LABEL ,merge))))))))
-\f
-(define (build-gc-offset-word offset code-word)
- (let ((encoded-offset (quotient offset 2)))
- (+ (* encoded-offset #x10000) code-word)))
-
-(define (allocate-closure rtl-target nentries n-free-vars)
- (let ((target regnum:second-C-arg))
- (require-register! regnum:first-C-arg)
- (rtl-target:=machine-register! rtl-target target)
- (let ((total-size
- (+ 1 ; Closure header word
- (* closure-entry-size nentries)
- n-free-vars))
- (limit (standard-temporary!))
- (label (generate-label))
- (forward-label (generate-label)))
- (add-end-of-block-code!
- (lambda ()
- (LAP (LABEL ,forward-label)
- (MOVEI ,regnum:first-C-arg (& ,total-size))
- ; second-C-arg was set up because target==second-C-arg!
- ,@(invoke-assembly-hook assembly-hook:allocate-closure)
- (BR ,regnum:came-from (@PCR ,label)))))
- (values
- target
- (LAP (LDA ,target (OFFSET 16 ,regnum:closure-free))
- ;; Optional code (to reduce out-of-line calls):
- (LDQ ,limit ,reg:closure-limit)
- (LDA ,regnum:closure-free (OFFSET ,(* 8 total-size)
- ,regnum:closure-free))
- (CMPLT ,limit ,regnum:closure-free ,limit)
- (BNE ,limit (@PCR ,forward-label))
- ;; End of optional code -- convert BNE to BR to flush
- (LABEL ,label)
- ,@(with-values
- (lambda ()
- (immediate->register
- (make-non-pointer-literal
- (ucode-type manifest-closure) (- total-size 1))))
- (lambda (prefix header)
- (LAP ,@prefix
- (STQ ,header (OFFSET -16 ,target)))))
- ,@(with-values
- (lambda ()
- (immediate->register
- (build-gc-offset-word 0 nentries)))
- (lambda (prefix register)
- (LAP ,@prefix
- (STL ,register (OFFSET -8 ,target))))))))))
-
-(define (cons-closure target label min max size)
- (with-values (lambda () (allocate-closure target 1 size))
- (lambda (target prefix)
- (let ((temp (standard-temporary!)))
- (LAP ,@prefix
- ,@(with-values (lambda ()
- (immediate->register
- (build-gc-offset-word
- 16 (make-procedure-code-word min max))))
- (lambda (code reg)
- (LAP ,@code
- (STL ,reg (OFFSET -4 ,target)))))
- ,@(load-pc-relative-address
- temp 'CODE
- (rtl-procedure/external-label (label->object label)))
- (STQ ,temp (OFFSET 8 ,target)))))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
- (? min) (? max) (? size)))
- (cons-closure target procedure-label min max size))
-\f
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-MULTICLOSURE (? nentries) (? size) (? entries)))
- ;; entries is a vector of all the entry points
- (case nentries
- ((0)
- (let ((dest (standard-target! target))
- (temp (standard-temporary!)))
- (LAP (COPY ,regnum:free ,dest)
- ,@(load-immediate
- temp
- (make-non-pointer-literal (ucode-type manifest-vector) size)
- #T)
- (STQ ,temp (OFFSET 0 ,regnum:free))
- (LDA ,regnum:free (OFFSET ,(* 8 (+ size 1))
- ,regnum:free)))))
- ((1)
- (let ((entry (vector-ref entries 0)))
- (cons-closure target (car entry) (cadr entry) (caddr entry) size)))
- (else
- (cons-multiclosure target nentries size (vector->list entries)))))
-
-(define (cons-multiclosure target nentries size entries)
- (with-values (lambda () (allocate-closure target nentries size))
- (lambda (target prefix)
- (let ((temp (standard-temporary!)))
- (LAP ,@prefix
- ,@(let loop ((offset 16)
- (entries entries))
- (if (null? entries)
- (LAP)
- (let* ((entry (car entries))
- (label (car entry))
- (min (cadr entry))
- (max (caddr entry)))
- (let* ((this-value
- (load-immediate
- temp
- (build-gc-offset-word
- offset (make-procedure-code-word min max)) #F))
- (this-entry
- (load-pc-relative-address
- temp 'CODE
- (rtl-procedure/external-label
- (label->object label)))))
- (LAP
- ,@this-value
- (STL ,temp (OFFSET ,(- offset 20) ,target))
- ,@this-entry
- (STQ ,temp (OFFSET ,(- offset 8) ,target))
- ,@(loop (+ offset 24)
- (cdr entries))))))))))))
-\f
-;;;; Entry Header
-;;; This is invoked by the top level of the LAP generator.
-
-(define (generate/quotation-header environment-label free-ref-label n-sections)
- ;; Calls the linker
- ;; On MIPS, regnum:first-arg is used as a temporary here since
- ;; load-pc-relative-address uses the assembler temporary.
- (in-assembler-environment (empty-register-map)
- (list regnum:first-arg regnum:second-arg
- regnum:third-arg regnum:fourth-arg)
- (lambda ()
- (let* ((i1
- (load-pc-relative-address regnum:fourth-arg
- 'CONSTANT environment-label))
- (i2 (load-pc-relative-address regnum:second-arg
- 'CODE *block-label*))
- (i3 (load-pc-relative-address regnum:third-arg
- 'CONSTANT free-ref-label)))
- (LAP
- ;; Grab interp's env. and store in code block at environment-label
- (LDQ ,regnum:first-arg ,reg:environment)
- ,@i1
- (STQ ,regnum:first-arg (OFFSET 0 ,regnum:fourth-arg))
- ;; Now invoke the linker
- ;; (arg1 is return address, supplied by interface)
- ,@i2
- ,@i3
- (MOVEI ,regnum:fourth-arg (& ,n-sections))
- ,@(link-to-interface code:compiler-link)
- ,@(make-external-label (continuation-code-word false)
- (generate-label)))))))
-
-(define (generate/remote-link code-block-label
- environment-offset
- free-ref-offset
- n-sections)
- ;; Link all of the top level procedures within the file
- (in-assembler-environment (empty-register-map)
- (list regnum:first-arg regnum:second-arg
- regnum:third-arg regnum:fourth-arg)
- (lambda ()
- (LAP ,@(load-pc-relative regnum:second-arg 'CODE code-block-label)
- (LDQ ,regnum:first-arg ,reg:environment) ; first-arg is a temp here
- ,@(object->address regnum:second-arg regnum:second-arg)
- ,@(add-immediate environment-offset
- regnum:second-arg
- regnum:fourth-arg) ; fourth-arg is a temp here...
- (STQ ,regnum:first-arg (OFFSET 0 ,regnum:fourth-arg))
- ,@(add-immediate free-ref-offset regnum:second-arg regnum:third-arg)
- (MOVEI ,regnum:fourth-arg (& ,n-sections))
- ,@(link-to-interface code:compiler-link)
- ,@(make-external-label (continuation-code-word false)
- (generate-label))))))
-
-(define (in-assembler-environment map needed-registers thunk)
- (fluid-let ((*register-map* map)
- (*prefix-instructions* (LAP))
- (*suffix-instructions* (LAP))
- (*needed-registers* needed-registers))
- (let ((instructions (thunk)))
- (LAP ,@*prefix-instructions*
- ,@instructions
- ,@*suffix-instructions*))))
-\f
-\f
-(define (generate/remote-links n-code-blocks code-blocks-label n-sections)
- (if (= n-code-blocks 0)
- (LAP)
- (let ((loop (generate-label))
- (bytes (generate-label))
- (after-bytes (generate-label)))
- (LAP
- ;; Push room for the block counter on the stack
- (SUBQ ,regnum:stack-pointer (& ,address-units-per-object)
- ,regnum:stack-pointer)
- (COPY ,regnum:zero ,regnum:first-arg)
-(LABEL ,loop)
- ;; Increment block counter (into arg 2 and stack)
- (ADDQ ,regnum:first-arg (& 1) ,regnum:second-arg)
- (STQ ,regnum:second-arg (OFFSET 0 ,regnum:stack-pointer))
- ;; Load address of bytes into arg 3 and skip over them
- (BR ,regnum:third-arg (@PCR ,after-bytes))
-(LABEL ,bytes)
- ;; Dump the vector of constant data here in the code stream
- ;; There is one byte per linkage block and the byte contains
- ;; the number of linkage sections in that block
- ,@(sections->bytes n-code-blocks n-sections)
-(LABEL ,after-bytes)
- ;; Code to load the correct byte out of the vector at BYTES into arg 4
- (ADDQ ,regnum:first-arg ,regnum:third-arg ,regnum:volatile-scratch)
- (LDQ_U ,regnum:fourth-arg (OFFSET 0 ,regnum:volatile-scratch))
- (EXTBL ,regnum:fourth-arg ,regnum:volatile-scratch ,regnum:fourth-arg)
- ;; Load the vector of our compiled subblocks from our constant area
- (LDQ ,regnum:third-arg (OFFSET (- ,code-blocks-label ,bytes)
- ,regnum:third-arg))
- ,@(object->address regnum:third-arg regnum:third-arg)
- ;; Load the subblock of interest
- (S8ADDQ ,regnum:second-arg ,regnum:third-arg ,regnum:second-arg)
- (LDQ ,regnum:second-arg (OFFSET 0 ,regnum:second-arg))
- ,@(object->address regnum:second-arg regnum:second-arg)
- ;; Get length of code area from subblock header
- (LDQ ,regnum:third-arg
- (OFFSET ,address-units-per-object ,regnum:second-arg))
- ;; Get length of entire code [sub]block
- (LDQ ,regnum:first-arg (OFFSET 0 ,regnum:second-arg))
- (LDQ ,regnum:first-C-arg ,reg:environment)
- ,@(object->datum regnum:third-arg regnum:third-arg)
- ,@(object->datum regnum:first-arg regnum:first-arg)
- ;; Start calculating addr. of 1st linkage sect. of this [sub]block
- (S8ADDQ ,regnum:third-arg ,regnum:second-arg ,regnum:third-arg)
- ;; Calculate address of the end of the [sub]block to be linked
- (S8ADDQ ,regnum:first-arg ,regnum:second-arg ,regnum:first-arg)
- ;; Finish the address calculation for 1st linkage section
- (LDA ,regnum:third-arg (OFFSET ,(* 2 address-units-per-object)
- ,regnum:third-arg))
- ;; Store environment at the end of the [sub]block
- (STQ ,regnum:first-C-arg (OFFSET 0 ,regnum:first-arg))
- ;; Call the linker! Arguments are:
- ;; first-arg: return address
- ;; second-arg: address of [sub]block to link
- ;; third-arg: address of first linkage are in [sub]block
- ;; fourth-arg: number of linkage areas
- ,@(link-to-interface code:compiler-link)
-,@(make-external-label (continuation-code-word false) (generate-label))
- ;; Reload the section counter and maybe loop back
- (LDQ ,regnum:first-arg (OFFSET 0 ,regnum:stack-pointer))
- ,@(add-immediate (- n-code-blocks)
- regnum:first-arg regnum:second-arg)
- (BLT ,regnum:second-arg (@PCR ,loop))
- ;; Pop the section counter off the stack
- (ADDQ ,regnum:stack-pointer (& ,address-units-per-object)
- ,regnum:stack-pointer)))))
-
-(define (sections->bytes n-code-blocks section-count-vector)
- ;; Generate a vector of bytes, padded to a multiple of 4. The
- ;; vector holds the counts of the number of linkage sections in each
- ;; subblock.
- (let walk ((bytes ; Pad to multiple of 4
- (append (vector->list section-count-vector)
- (let ((left (remainder n-code-blocks 4)))
- (if (zero? left)
- '()
- (make-list (- 4 left) 0))))))
- (if (null? bytes)
- (LAP)
- (let ((lo (car bytes))
- (midlo (cadr bytes))
- (midhi (caddr bytes))
- (hi (cadddr bytes)))
- (LAP
- (UWORD ,(+ lo (* 256 (+ midlo (* 256 (+ midhi (* 256 hi)))))))
- ,@(walk (cddddr bytes)))))))
-\f
-(define (generate/constants-block constants references assignments uuo-links
- global-links static-vars)
- (let ((constant-info
- (declare-constants 0 (transmogrifly uuo-links)
- (declare-constants 1 references
- (declare-constants 2 assignments
- (declare-constants 3 (transmogrifly global-links)
- (declare-constants false
- (map (lambda (pair)
- (cons false (cdr pair)))
- static-vars)
- (declare-constants false constants
- (cons false (LAP))))))))))
- (let ((free-ref-label (car constant-info))
- (constants-code (cdr constant-info))
- (debugging-information-label (allocate-constant-label))
- (environment-label (allocate-constant-label))
- (n-sections
- (+ (if (null? uuo-links) 0 1)
- (if (null? references) 0 1)
- (if (null? assignments) 0 1)
- (if (null? global-links) 0 1))))
- (values
- (LAP ,@constants-code
- ;; Place holder for the debugging info filename
- (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO)
- ;; Place holder for the load time environment if needed
- (SCHEME-OBJECT ,environment-label
- ,(if (null? free-ref-label) 0 'ENVIRONMENT)))
- environment-label
- free-ref-label
- n-sections))))
-
-(define (declare-constants tag constants info)
- (define (inner constants)
- (if (null? constants)
- (cdr info)
- (let ((entry (car constants)))
- (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry))
- ,@(inner (cdr constants))))))
- (if (and tag (not (null? constants)))
- (let ((label (allocate-constant-label)))
- (cons label
- (inner
- `((,(let ((datum (length constants)))
- (if (> datum #xffff)
- (error "datum too large" datum))
- (+ (* tag #x10000) datum))
- . ,label)
- ,@constants))))
- (cons (car info) (inner constants))))
-
-(define (transmogrifly uuos)
- ; uuos == list of
- ; (name (frame-size-1 . label-1) (frame-size-2 . label-2) ...)
- ; produces ((frame-size-1 . label-1) (name . dummy-label)
- ; (frame-size-2 . label-2) (name . dummy-label) ...)
- (define (inner name assoc)
- (if (null? assoc)
- (transmogrifly (cdr uuos))
- `((,(caar assoc) . ,(cdar assoc)) ; uuo-label
- (,name . ,(allocate-constant-label))
- ,@(inner name (cdr assoc)))))
- (if (null? uuos)
- '()
- (inner (caar uuos) (cdar uuos))))
-\f
-;;; Local Variables: ***
-;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
-;;; End: ***
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Interpreter Calls
-;; Package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Variable cache trap handling.
-
-(define-rule statement
- (INTERPRETER-CALL:CACHE-REFERENCE (? cont)
- (REGISTER (? extension))
- (? safe?))
- cont ; ignored
- (LAP ,@(load-interface-args! false extension false false)
- ,@(link-to-interface
- (if safe?
- code:compiler-safe-reference-trap
- code:compiler-reference-trap))))
-
-(define-rule statement
- (INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont)
- (REGISTER (? extension))
- (? value register-expression))
- cont ; ignored
- (LAP ,@(load-interface-args! false extension value false)
- ,@(link-to-interface code:compiler-assignment-trap)))
-
-(define-rule statement
- (INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont)
- (REGISTER (? extension)))
- cont ; ignored
- (LAP ,@(load-interface-args! false extension false false)
- ,@(link-to-interface code:compiler-unassigned?-trap)))
-\f
-;;;; Interpreter Calls
-
-;;; All the code that follows is obsolete. It hasn't been used in a while.
-;;; It is provided in case the relevant switches are turned off, but there
-;;; is no real reason to do this. Perhaps the switches should be removed.
-
-(define-rule statement
- (INTERPRETER-CALL:ACCESS (? cont)
- (? environment register-expression)
- (? name))
- cont ; ignored
- (lookup-call code:compiler-access environment name))
-
-(define-rule statement
- (INTERPRETER-CALL:LOOKUP (? cont)
- (? environment register-expression)
- (? name)
- (? safe?))
- cont ; ignored
- (lookup-call (if safe? code:compiler-safe-lookup code:compiler-lookup)
- environment
- name))
-
-(define-rule statement
- (INTERPRETER-CALL:UNASSIGNED? (? cont)
- (? environment register-expression)
- (? name))
- cont ; ignored
- (lookup-call code:compiler-unassigned? environment name))
-
-(define-rule statement
- (INTERPRETER-CALL:UNBOUND? (? cont)
- (? environment register-expression)
- (? name))
- cont ; ignored
- (lookup-call code:compiler-unbound? environment name))
-
-(define (lookup-call code environment name)
- (LAP ,@(load-interface-args! false environment false false)
- ,@(load-constant regnum:third-arg name #F)
- ,@(link-to-interface code)))
-
-(define-rule statement
- (INTERPRETER-CALL:DEFINE (? cont)
- (? environment register-expression)
- (? name)
- (? value register-expression))
- cont ; ignored
- (assignment-call code:compiler-define environment name value))
-
-(define-rule statement
- (INTERPRETER-CALL:SET! (? cont)
- (? environment register-expression)
- (? name)
- (? value register-expression))
- cont ; ignored
- (assignment-call code:compiler-set! environment name value))
-
-(define (assignment-call code environment name value)
- (LAP ,@(load-interface-args! false environment false value)
- ,@(load-constant regnum:third-arg name #F #F)
- ,@(link-to-interface code)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Fixnum Rules
-;; Package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Conversions
-
-(define-rule statement
- ;; convert a fixnum object to a "fixnum integer"
- (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source))))
- (standard-unary-conversion source target object->fixnum))
-
-(define-rule statement
- ;; load a fixnum constant as a "fixnum integer"
- (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant))))
- (load-immediate (standard-target! target) (* constant fixnum-1) #T))
-
-(define-rule statement
- ;; convert a memory address to a "fixnum integer"
- (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source))))
- (standard-unary-conversion source target address->fixnum))
-
-(define-rule statement
- ;; convert an object's address to a "fixnum integer"
- (ASSIGN (REGISTER (? target))
- (ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source)))))
- (standard-unary-conversion source target object->fixnum))
-
-(define-rule statement
- ;; convert a "fixnum integer" to a fixnum object
- (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source))))
- (standard-unary-conversion source target fixnum->object))
-
-(define-rule statement
- ;; convert a "fixnum integer" to a memory address
- (ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source))))
- (standard-unary-conversion source target fixnum->address))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (OBJECT->FIXNUM (CONSTANT (? value)))
- (OBJECT->FIXNUM (REGISTER (? source)))
- #F))
- (QUALIFIER (power-of-2 value))
- (standard-unary-conversion source target (object-scaler value)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (OBJECT->FIXNUM (REGISTER (? source)))
- (OBJECT->FIXNUM (CONSTANT (? value)))
- #F))
- (QUALIFIER (power-of-2 value))
- (standard-unary-conversion source target (object-scaler value)))
-\f
-;; "Fixnum" in this context means an integer left shifted so that
-;; the sign bit is the leftmost bit of the word, i.e., the datum
-;; has been left shifted by scheme-type-width bits.
-
-(define (power-of-2 value)
- (and (positive? value)
- (let loop ((n value)
- (exp 0))
- (if (= n 1)
- exp
- (let ((division (integer-divide n 2)))
- (and (zero? (integer-divide-remainder division))
- (loop (integer-divide-quotient division)
- (+ exp 1))))))))
-
-(define-integrable (object-scaler value)
- (lambda (source target)
- (scaled-object->fixnum (power-of-2 value) source target)))
-
-(define-integrable (datum->fixnum src tgt)
- ; Shift left by scheme-type-width
- (LAP (SLL ,src (& ,scheme-type-width) ,tgt)))
-
-(define-integrable (fixnum->datum src tgt)
- (LAP (SRL ,src (& ,scheme-type-width) ,tgt)))
-
-(define-integrable (object->fixnum src tgt)
- (datum->fixnum src tgt))
-
-(define-integrable (scaled-object->fixnum shift src tgt)
- (LAP (SLL ,src (& ,(+ shift scheme-type-width)) ,tgt)))
-
-(define-integrable (address->fixnum src tgt)
- ; Strip off type bits, just like object->fixnum
- (datum->fixnum src tgt))
-
-(define-integrable (fixnum->object src tgt)
- ; Move right by type code width and put on fixnum type code
- (LAP ,@(fixnum->datum src tgt)
- ,@(deposit-type-datum (ucode-type fixnum) tgt tgt)))
-
-(define (fixnum->address src tgt)
- ; Move right by type code width; no address bits
- (fixnum->datum src tgt))
-
-(define-integrable fixnum-1
- (expt 2 scheme-type-width))
-
-(define-integrable -fixnum-1
- (- fixnum-1))
-
-(define (no-overflow-branches!)
- (set-current-branches!
- (lambda (if-overflow)
- if-overflow ; ignored
- (LAP))
- (lambda (if-no-overflow)
- (LAP (BR ,regnum:came-from (@PCR ,if-no-overflow))))))
-
-(define (guarantee-signed-fixnum n)
- (if (not (signed-fixnum? n)) (error "Not a signed fixnum" n))
- n)
-
-(define (signed-fixnum? n)
- (and (exact-integer? n)
- (>= n signed-fixnum/lower-limit)
- (< n signed-fixnum/upper-limit)))
-\f
-;;;; Arithmetic Operations
-
-(define-rule statement
- ;; execute a unary fixnum operation
- (ASSIGN (REGISTER (? target))
- (FIXNUM-1-ARG (? operation)
- (REGISTER (? source))
- (? overflow?)))
- (standard-unary-conversion source target
- (lambda (source target)
- ((fixnum-1-arg/operator operation) target source overflow?))))
-
-(define (fixnum-1-arg/operator operation)
- (lookup-arithmetic-method operation fixnum-methods/1-arg))
-
-(define fixnum-methods/1-arg
- (list 'FIXNUM-METHODS/1-ARG))
-
-(define-arithmetic-method 'FIXNUM-NOT fixnum-methods/1-arg
- (lambda (tgt src overflow?)
- (if overflow?
- (error "FIXNUM-NOT: overflow test requested"))
- (LAP (EQV ,src (& ,(-1+ fixnum-1)) ,tgt))))
-
-(define-arithmetic-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
- (lambda (tgt src overflow?)
- (fixnum-add-constant tgt src 1 overflow?)))
-
-(define-arithmetic-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg
- (lambda (tgt src overflow?)
- (fixnum-add-constant tgt src -1 overflow?)))
-
-(define (fixnum-add-constant tgt src constant overflow?)
- (let ((constant (* fixnum-1 constant)))
- (cond ((not overflow?)
- (add-immediate constant src tgt))
- ((zero? constant)
- (no-overflow-branches!)
- (LAP (COPY ,src ,tgt)))
- (else
- (with-values
- (lambda ()
- (cond
- ((fits-in-16-bits-signed? constant)
- (values (LAP)
- (lambda (target)
- (LAP (LDA ,target (OFFSET ,constant ,src))))))
- ((top-16-of-32-bits-only? constant)
- (values (LAP)
- (lambda (target)
- (LAP (LDAH ,target (OFFSET ,constant ,src))))))
- (else
- (with-values (lambda () (immediate->register constant))
- (lambda (prefix alias)
- (values prefix
- (lambda (target)
- (LAP (ADDQ ,src ,alias ,target)))))))))
- (lambda (prefix add-code)
- (let ((temp (new-temporary! src)))
- (cond
- ((positive? constant)
- (begin
- (set-current-branches!
- (lambda (overflow-label)
- (LAP (BLT ,temp (@PCR ,overflow-label))))
- (lambda (no-overflow-label)
- (LAP (BGE ,temp (@PCR ,no-overflow-label)))))
- (LAP ,@prefix
- ,@(add-code temp) ; Add, result to temp
- (CMOVLT ,src ,regnum:zero ,temp)
- ; sgn(src) != sgn(const) ->
- ; no overflow
- ,@(add-code tgt) ; Real result
- ; (BLT ,temp (@PCR ,overflow-label))
- )))
- ((not (= src tgt))
- (set-current-branches!
- (lambda (overflow-label)
- (LAP (BLT ,temp (@PCR ,overflow-label))))
- (lambda (no-overflow-label)
- (LAP (BGE ,temp (@PCR ,no-overflow-label)))))
- (LAP ,@prefix
- ,@(add-code tgt) ; Add, result to target
- (XOR ,src ,tgt ,temp) ; Compare result and source sign
- (CMOVGE ,src ,regnum:zero ,temp)
- ; sgn(src) != sgn(const) ->
- ; no overflow
- ; (BLT ,temp (@PCR ,overflow-label))
- ))
- (else
- (set-current-branches!
- (lambda (overflow-label)
- (LAP (BGE ,temp (@PCR ,overflow-label))))
- (lambda (no-overflow-label)
- (LAP (BLT ,temp (@PCR ,no-overflow-label)))))
- (with-values
- (lambda () (immediate->register -1))
- (lambda (prefix2 reg:minus-1)
- (LAP ,@prefix
- ,@prefix2
- ,@(add-code temp) ; Add, result to temp
- (CMOVGE ,src ,reg:minus-1 ,temp)
- ; sgn(src) != sgn(const) ->
- ; no overflow
- ,@(add-code tgt) ; Add, result to target
- ; (BGE ,temp (@PCR ,overflow-label))
- ))))))))))))
-\f
-(define-rule statement
- ;; execute a binary fixnum operation
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS (? operation)
- (REGISTER (? source1))
- (REGISTER (? source2))
- (? overflow?)))
- (standard-binary-conversion source1 source2 target
- (lambda (source1 source2 target)
- ((fixnum-2-args/operator operation) target source1 source2 overflow?))))
-
-(define (fixnum-2-args/operator operation)
- (lookup-arithmetic-method operation fixnum-methods/2-args))
-
-(define fixnum-methods/2-args
- (list 'FIXNUM-METHODS/2-ARGS))
-
-(define-arithmetic-method 'FIXNUM-AND fixnum-methods/2-args
- (lambda (tgt src1 src2 overflow?)
- (if overflow?
- (error "FIXNUM-AND: overflow test requested"))
- (LAP (AND ,src1 ,src2 ,tgt))))
-
-(define-arithmetic-method 'FIXNUM-OR fixnum-methods/2-args
- (lambda (tgt src1 src2 overflow?)
- (if overflow?
- (error "FIXNUM-OR: overflow test requested"))
- (LAP (BIS ,src1 ,src2 ,tgt))))
-
-(define-arithmetic-method 'FIXNUM-XOR fixnum-methods/2-args
- (lambda (tgt src1 src2 overflow?)
- (if overflow?
- (error "FIXNUM-XOR: overflow test requested"))
- (LAP (XOR ,src1 ,src2 ,tgt))))
-
-(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args
- (lambda (tgt src1 src2 overflow?)
- (if overflow?
- (do-overflow-addition tgt src1 src2)
- (LAP (ADDQ ,src1 ,src2 ,tgt)))))
-
-(define (do-overflow-addition tgt src1 src2)
- (let ((temp1 (new-temporary! src1 src2)))
- (set-current-branches!
- (lambda (overflow-label)
- (LAP (BLT ,temp1 (@PCR ,overflow-label))))
- (lambda (no-overflow-label)
- (LAP (BGE ,temp1 (@PCR ,no-overflow-label)))))
- (cond ((not (= src1 src2))
- (let ((temp2 (new-temporary! src1 src2))
- (src (if (= src1 tgt) src2 src1))) ; Non-clobbered source
- (LAP (XOR ,src1 ,src2 ,temp2) ; Sign compare sources
- (ADDQ ,src1 ,src2 ,tgt) ; Add them ...
- (XOR ,src ,tgt ,temp1) ; Result sign OK?
- (CMOVLT ,temp2 ,regnum:zero ,temp1)
- ; Looks like sgn(result)=sgn(src)
- ; if sgn(src1) != sgn(src2)
- ; (BLT ,temp1 (@PCR ,overflow-label))
- ; Sign differs -> overflow
- )))
- ((not (= src1 tgt))
- (LAP (ADDQ ,src1 ,src2 ,tgt) ; Add
- (XOR ,src1 ,tgt ,temp1))) ; Sign compare result
- (else ; Don't test source signs
- (LAP (ADDQ ,src1 ,src2 ,temp1) ; Interim sum
- (XOR ,src1 ,temp1 ,temp1) ; Compare result & source signs
- (ADDQ ,src1 ,src2 ,tgt) ; Final addition
- ; (BLT ,temp1 (@PCR ,overflow-label))
- ; Sign differs -> overflow
- )))))
-\f
-(define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args
- (lambda (tgt src1 src2 overflow?)
- (if overflow?
- (error "FIXNUM-ANDC: overflow test requested"))
- (LAP (BIC ,src1 ,src2 ,tgt))))
-
-(define (with-different-source-and-target src tgt handler)
- (if (not (= tgt src))
- (handler src tgt)
- (let ((temp (standard-temporary!)))
- (LAP (COPY ,src ,temp)
- ,@(handler temp tgt)))))
-
-(define-arithmetic-method 'FIXNUM-LSH fixnum-methods/2-args
- (lambda (tgt value shift-amount overflow?)
- (if overflow?
- (error "FIXNUM-LSH: overflow test requested"))
- (let* ((temp (standard-temporary!))
- (temp-right (standard-temporary!)))
- (with-different-source-and-target
- value tgt
- (lambda (value tgt)
- (LAP (SRA ,shift-amount (& ,scheme-type-width) ,temp)
- (SLL ,value ,temp ,tgt)
- (SUBQ ,regnum:zero ,temp ,temp-right)
- (SRL ,value ,temp-right ,temp-right)
- (BIC ,temp-right (& ,(-1+ fixnum-1)) ,temp-right)
- (CMOVLT ,shift-amount ,temp-right ,tgt)))))))
-
-(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args
- (lambda (tgt src1 src2 overflow?)
- (if overflow?
- (if (= src1 src2) ;probably won't ever happen.
- (begin
- (no-overflow-branches!)
- (LAP (SUBQ ,src1 ,src1 ,tgt)))
- (do-overflow-subtraction tgt src1 src2))
- (LAP (SUBQ ,src1 ,src2 ,tgt)))))
-
-(define (do-overflow-subtraction tgt src1 src2)
- ; Requires src1 != src2
- (let ((temp1 (new-temporary! src1 src2))
- (temp2 (new-temporary! src1 src2)))
- (set-current-branches!
- (lambda (overflow-label)
- (LAP (BLT ,temp1 (@PCR ,overflow-label))))
- (lambda (no-overflow-label)
- (LAP (BGE ,temp1 (@PCR ,no-overflow-label)))))
- (LAP (XOR ,src1 ,src2 ,temp2) ; Compare source signs
- (SUBQ ,src1 ,src2 ,tgt) ; Subtract
- ,@(if (= src1 tgt) ; Compare result and source sign
- (LAP (EQV ,src2 ,tgt ,temp1))
- (LAP (XOR ,src1 ,tgt ,temp1)))
- (CMOVGE ,temp2 ,regnum:zero ,temp1) ; Same source signs ->
- ; no overflow
- ; (BLT ,temp1 (@PCR ,overflow-label))
- )))
-
-(define (do-multiply tgt src1 src2 overflow?)
- (let ((temp (new-temporary! src1 src2)))
- (LAP (SRA ,src1 (& ,scheme-type-width) ,temp) ; unscale source 1
- ,@(if overflow?
- (let ((abs1 (new-temporary! src1 src2))
- (abs2 (new-temporary! src1 src2))
- (oflow? (new-temporary! src1 src2)))
- (set-current-branches!
- (lambda (overflow-label)
- (LAP (BNE ,oflow? (@PCR ,overflow-label))))
- (lambda (no-overflow-label)
- (LAP (BEQ ,oflow? (@PCR ,no-overflow-label)))))
- (LAP
- (SUBQ ,regnum:zero ,temp ,abs1) ; ABS(unscaled(source1))
- (CMOVGE ,temp ,temp ,abs1) ; ""
- (SUBQ ,regnum:zero ,src2 ,abs2) ; ABS(source2)
- (CMOVGE ,src2 ,src2 ,abs2) ; ""
- ; high of abs(source2)*
- (UMULH ,abs1 ,abs2 ,oflow?) ; abs(unscaled(source1))
- (MULQ ,abs1 ,abs2 ,abs1) ; low of same
- (CMOVLT ,abs1 ,src2 ,oflow?) ; If low end oflowed, make
- ; sure that high end <> 0
- ;; (BNE ,oflow? (@PCR overflow-label))
- ; If high end <> 0 oflow
- ))
- (LAP))
- (MULQ ,temp ,src2 ,tgt)))) ; Compute result
-
-(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args do-multiply)
-\f
-;;;; Division operations, unknown arguments
-
-#| ; This doesn't work because we get physical register numbers, not
- ; rtl register numbers.
-
-(define (special-binary-operation operation hook end-code)
- (lambda (target source1 source2 ovflw?)
- (define (->machine-register source machine-reg)
- (let ((code (load-machine-register! source machine-reg)))
- ;; Prevent it from being allocated again.
- (need-register! machine-reg)
- code))
- (require-register! r23)
- (let* ((load-1 (->machine-register source1 r24))
- (load-2 (->machine-register source2 r25))
- (target (standard-target! target)))
- (LAP ,@load-1
- ,@load-2
- (LDQ ,r23 ,hook)
- (JSR ,r23 ,r23 (@PCO 0))
- ,@(end-code ovflw? r24 target)))))
-|#
-
-(define (special-binary-operation operation hook end-code)
- (lambda (target source1 source2 ovflw?)
- (if (not (= target r23)) (require-register! r23))
- (if (not (= target r24)) (require-register! r24))
- (if (not (= target r25)) (require-register! r25))
- (if (not (= target r27)) (require-register! r27))
- (LAP
- ,@(cond ((and (= source1 r25) (= source2 r24))
- (LAP (COPY ,r24 ,r23)
- (COPY ,r25 ,r24)
- (COPY ,r23 ,r25)))
- ((= source1 r25)
- (LAP (COPY ,r25 ,r24)
- ,@(copy source2 r25)))
- (else
- (LAP ,@(copy source2 r25)
- ,@(copy source1 r24))))
- (LDQ ,r27 ,hook)
- (JSR ,r23 ,r27 (@PCO 0))
- ,@(end-code ovflw? r27 target))))
-
-(define-arithmetic-method 'FIXNUM-QUOTIENT fixnum-methods/2-args
- (special-binary-operation
- 'FIXNUM-QUOTIENT
- reg:divq
- (lambda (overflow? source target)
- (if (not overflow?)
- (LAP (SLL ,source (& ,scheme-type-width) ,target))
- (with-different-source-and-target
- source target
- (lambda (source target)
- (let ((temp (standard-temporary!)))
- (set-current-branches!
- (lambda (if-overflow)
- (LAP (BEQ ,temp (@PCR ,if-overflow))))
- (lambda (if-no-overflow)
- (LAP (BNE ,temp (@PCR ,if-no-overflow)))))
- (LAP (SLL ,source (& ,scheme-type-width) ,target)
- (SRA ,target (& ,scheme-type-width) ,temp)
- (CMPEQ ,temp ,target ,temp)))))))))
-
-(define-arithmetic-method 'FIXNUM-REMAINDER fixnum-methods/2-args
- (special-binary-operation 'FIXNUM-REMAINDER reg:remq
- (lambda (overflow? src tgt)
- (if overflow? (no-overflow-branches!))
- (copy src tgt))))
-\f
-(define-rule statement
- ;; execute binary fixnum operation with constant second arg
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS (? operation)
- (REGISTER (? source))
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (? overflow?)))
- (QUALIFIER (case operation
- ((FIXNUM-AND FIXNUM-OR FIXNUM-ANDC FIXNUM-XOR)
- #F)
- ((FIXNUM-REMAINDER)
- (power-of-2 (abs constant)))
- (else #T)))
- (standard-unary-conversion source target
- (lambda (source target)
- ((fixnum-2-args/operator/register*constant operation)
- target source constant overflow?))))
-
-(define-rule statement
- ;; execute binary fixnum operation with constant first arg
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS (? operation)
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (REGISTER (? source))
- (? overflow?)))
- (QUALIFIER (not (memq operation
- '(FIXNUM-AND FIXNUM-OR FIXNUM-ANDC
- FIXNUM-XOR FIXNUM-LSH FIXNUM-REMAINDER
- FIXNUM-QUOTIENT))))
- (standard-unary-conversion source target
- (lambda (source target)
- (if (fixnum-2-args/commutative? operation)
- ((fixnum-2-args/operator/register*constant operation)
- target source constant overflow?)
- ((fixnum-2-args/operator/constant*register operation)
- target constant source overflow?)))))
-
-(define (fixnum-2-args/commutative? operator)
- (memq operator '(PLUS-FIXNUM
- MULTIPLY-FIXNUM
- FIXNUM-AND
- FIXNUM-OR
- FIXNUM-XOR)))
-
-(define (fixnum-2-args/operator/register*constant operation)
- (lookup-arithmetic-method operation fixnum-methods/2-args/register*constant))
-
-(define fixnum-methods/2-args/register*constant
- (list 'FIXNUM-METHODS/2-ARGS/REGISTER*CONSTANT))
-
-(define (fixnum-2-args/operator/constant*register operation)
- (lookup-arithmetic-method operation
- fixnum-methods/2-args/constant*register))
-
-(define fixnum-methods/2-args/constant*register
- (list 'FIXNUM-METHODS/2-ARGS/CONSTANT*REGISTER))
-\f
-(define-arithmetic-method 'PLUS-FIXNUM
- fixnum-methods/2-args/register*constant
- (lambda (tgt src constant overflow?)
- (guarantee-signed-fixnum constant)
- (fixnum-add-constant tgt src constant overflow?)))
-
-(define-arithmetic-method 'FIXNUM-LSH
- fixnum-methods/2-args/register*constant
- (lambda (tgt source constant-shift-amount overflow?)
- (if overflow?
- (error "FIXNUM-LSH: overflow test requested"))
- (guarantee-signed-fixnum constant-shift-amount)
- (let ((nbits (abs constant-shift-amount)))
- (cond ((zero? constant-shift-amount)
- (copy source tgt))
- ((>= nbits scheme-datum-width)
- (LAP (COPY ,regnum:zero ,tgt)))
- ((negative? constant-shift-amount)
- (LAP (SRL ,source (& ,(fix:and nbits 63)) ,tgt)
- (BIC ,tgt (& ,(-1+ fixnum-1)) ,tgt)))
- (else
- (LAP (SLL ,source (& ,(fix:and nbits 63)) ,tgt)))))))
-
-(define-arithmetic-method 'MINUS-FIXNUM
- fixnum-methods/2-args/register*constant
- (lambda (tgt src constant overflow?)
- (guarantee-signed-fixnum constant)
- (fixnum-add-constant tgt src (- constant) overflow?)))
-
-;;;; Division operators with constant denominator
-
-(define-arithmetic-method 'FIXNUM-QUOTIENT
- fixnum-methods/2-args/register*constant
- (lambda (tgt src constant ovflw?)
- (guarantee-signed-fixnum constant)
- (case constant
- ((0) (error "FIXNUM-QUOTIENT: Divide by zero"))
- ((1) (if ovflw? (no-overflow-branches!)) (copy src tgt))
- ((-1) (if (not ovflw?)
- (LAP (SUBQ ,regnum:zero ,src ,tgt))
- (let ((temp (standard-temporary!)))
- (set-current-branches!
- (lambda (if-overflow)
- (LAP (BNE ,temp (@PCR ,if-overflow))))
- (lambda (if-no-overflow)
- (LAP (BEQ ,temp (@PCR ,if-no-overflow)))))
- (with-different-source-and-target
- src tgt
- (lambda (src tgt)
- (LAP (SUBQ ,regnum:zero ,src ,tgt)
- (CMPEQ ,src ,tgt ,temp)
- (CMOVEQ ,src ,regnum:zero ,temp)))))))
- (else
- (if ovflw? (no-overflow-branches!))
- (let* ((factor (abs constant))
- (xpt (power-of-2 factor)))
- (cond ((> factor signed-fixnum/upper-limit)
- (copy regnum:zero tgt))
- (xpt ; A power of 2
- (let ((temp (standard-temporary!)))
- (LAP ,@(add-immediate (* (-1+ factor) fixnum-1) src temp)
- (CMOVGE ,src ,src ,temp)
- (SRA ,temp (& ,xpt) ,tgt)
- (BIC ,tgt (& ,(-1+ fixnum-1)) ,tgt)
- ,@(if (negative? constant)
- (LAP (SUBQ ,regnum:zero ,tgt ,tgt))
- (LAP)))))
- (else
- (with-different-source-and-target
- src tgt
- (lambda (src tgt)
- (define max-word (expt 2 scheme-object-width))
- (define (find-shift denom recvr)
- (let loop ((shift 1)
- (factor (ceiling (/ max-word denom))))
- (let ((next
- (ceiling
- (/ (expt 2 (+ scheme-object-width shift))
- denom))))
- (if (>= next max-word)
- (normalize (-1+ shift) factor recvr)
- (loop (1+ shift) next)))))
- (define (normalize shift factor recvr)
- (do ((shift shift (-1+ shift))
- (factor factor (quotient factor 2)))
- ((or (zero? shift) (odd? factor))
- (recvr shift factor))))
- (let ((abs-val (standard-temporary!)))
- (find-shift factor
- (lambda (shift multiplier)
- (with-values
- (lambda () (immediate->register multiplier))
- (lambda (prefix temp)
- (LAP
- ,@prefix
- (SUBQ ,regnum:zero ,src ,abs-val)
- (CMOVGE ,src ,src ,abs-val)
- (SRL ,abs-val (& ,scheme-type-width) ,abs-val)
- (UMULH ,abs-val ,temp ,abs-val)
- ,@(if (= shift 0)
- (LAP)
- (LAP (SRL ,abs-val (& ,shift) ,abs-val)))
- (SLL ,abs-val (& ,scheme-type-width) ,abs-val)
- (SUBQ ,regnum:zero ,abs-val ,tgt)
- ,@(if (positive? constant)
- (LAP (CMOVGE ,src ,abs-val ,tgt))
- (LAP
- (CMOVLT ,src
- ,abs-val
- ,tgt))))))))))))))))))
-
-(define-arithmetic-method 'FIXNUM-REMAINDER
- fixnum-methods/2-args/register*constant
- (lambda (tgt src constant ovflw?)
- (guarantee-signed-fixnum constant)
- (if ovflw? (no-overflow-branches!))
- (case constant
- ((1 -1) (copy regnum:zero tgt))
- (else
- (let* ((keep-bits (+ scheme-type-width (power-of-2 (abs constant))))
- (flush-bits (- scheme-object-width keep-bits))
- (temp (standard-temporary!))
- (sign (standard-temporary!)))
- (LAP (SLL ,src (& ,flush-bits) ,temp)
- (SRA ,src (& ,(- scheme-object-width 1)) ,sign)
- (SRL ,temp (& ,flush-bits) ,temp)
- (SLL ,sign (& ,keep-bits) ,sign)
- (BIS ,sign ,temp ,tgt)
- (CMOVEQ ,temp ,regnum:zero ,tgt)))))))
-
-;;;; Other operators with constant second argument
-
-(define-arithmetic-method 'MULTIPLY-FIXNUM
- fixnum-methods/2-args/register*constant
- (lambda (tgt src constant overflow?)
- (cond ((zero? constant)
- (if overflow? (no-overflow-branches!))
- (LAP (COPY ,regnum:zero ,tgt)))
- ((= constant 1)
- (if overflow? (no-overflow-branches!))
- (LAP (COPY ,src ,tgt)))
- ((power-of-2 constant)
- => (lambda (power-of-two)
- (if overflow?
- (do-left-shift-overflow tgt src power-of-two)
- (LAP (SLL ,src (& ,power-of-two) ,tgt)))))
- (else
- (with-values (lambda () (immediate->register (* constant fixnum-1)))
- (lambda (prefix alias)
- (LAP ,@prefix
- ,@(do-multiply tgt src alias overflow?))))))))
-
-(define (do-left-shift-overflow tgt src power-of-two)
- (let ((temp (new-temporary! src)))
- (set-current-branches!
- (lambda (overflow-label)
- (LAP (BEQ ,temp (@PCR ,overflow-label))))
- (lambda (no-overflow-label)
- (LAP (BNE ,temp (@PCR ,no-overflow-label)))))
- (with-different-source-and-target
- src tgt
- (lambda (src tgt)
- (LAP (SLL ,src (& ,power-of-two) ,tgt)
- (SRA ,tgt (& ,power-of-two) ,temp)
- (CMPEQ ,src ,temp ,temp))))))
-
-(define-arithmetic-method 'MINUS-FIXNUM
- fixnum-methods/2-args/constant*register
- (lambda (tgt constant src overflow?)
- (guarantee-signed-fixnum constant)
- (with-values (lambda () (immediate->register (* constant fixnum-1)))
- (lambda (prefix alias)
- (LAP ,@prefix
- ,@(if overflow?
- (do-overflow-subtraction tgt alias src)
- (LAP (SUBQ ,alias ,src ,tgt))))))))
-\f
-;;;; Predicates
-
-(define-rule predicate
- (OVERFLOW-TEST)
- ;; The RTL code generate guarantees that this instruction is always
- ;; immediately preceded by a fixnum operation with the OVERFLOW?
- ;; flag turned on. Furthermore, it also guarantees that there are
- ;; no other fixnum operations with the OVERFLOW? flag set. So all
- ;; the processing of overflow tests has been moved into the fixnum
- ;; operations.
- (LAP))
-
-(define-rule predicate
- (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
- (compare (fixnum-pred-1->cc predicate)
- (standard-source! source)
- regnum:zero))
-
-(define (fixnum-pred-1->cc predicate)
- (case predicate
- ((ZERO-FIXNUM?) '=)
- ((NEGATIVE-FIXNUM?) '<)
- ((POSITIVE-FIXNUM?) '>)
- (else (error "unknown fixnum predicate" predicate))))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (REGISTER (? source1))
- (REGISTER (? source2)))
- (compare (fixnum-pred-2->cc predicate)
- (standard-source! source1)
- (standard-source! source2)))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (REGISTER (? source))
- (OBJECT->FIXNUM (CONSTANT (? constant))))
- (compare-fixnum/constant*register (invert-condition-noncommutative
- (fixnum-pred-2->cc predicate))
- constant
- (standard-source! source)))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (REGISTER (? source)))
- (compare-fixnum/constant*register (fixnum-pred-2->cc predicate)
- constant
- (standard-source! source)))
-
-(define-integrable (compare-fixnum/constant*register cc n r)
- (guarantee-signed-fixnum n)
- (compare-immediate cc (* n fixnum-1) r))
-
-(define (fixnum-pred-2->cc predicate)
- (case predicate
- ((EQUAL-FIXNUM?) '=)
- ((LESS-THAN-FIXNUM?) '<)
- ((GREATER-THAN-FIXNUM?) '>)
- (else (error "unknown fixnum predicate" predicate))))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Flonum rules
-;; Package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-(define fpr:zero (float-register->fpr regnum:fp-zero))
-
-(define (flonum-source! register)
- (float-register->fpr (load-alias-register! register 'FLOAT)))
-
-(define (flonum-target! pseudo-register)
- (delete-dead-registers!)
- (float-register->fpr (allocate-alias-register! pseudo-register 'FLOAT)))
-
-(define (flonum-temporary!)
- (float-register->fpr (allocate-temporary-register! 'FLOAT)))
-
-(define-integrable flonum-size
- (quotient float-width scheme-object-width))
-
-(define-rule statement
- ;; convert a floating-point number to a flonum object
- (ASSIGN (REGISTER (? target))
- (FLOAT->OBJECT (REGISTER (? source))))
- (let* ((source (flonum-source! source))
- (target (standard-target! target)))
- (LAP
- ,@(with-values
- (lambda ()
- (immediate->register
- (make-non-pointer-literal (ucode-type manifest-nm-vector)
- flonum-size)))
- (lambda (prefix alias)
- (LAP ,@prefix
- (STQ ,alias (OFFSET 0 ,regnum:free)))))
- ,@(deposit-type-address (ucode-type flonum) regnum:free target)
- (STT ,source (OFFSET ,address-units-per-object ,regnum:free))
- (ADDQ ,regnum:free (& ,(* address-units-per-object (+ 1 flonum-size)))
- ,regnum:free))))
-
-(define-rule statement
- ;; convert a flonum object to a floating-point number
- (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source))))
- (let* ((source (standard-source! source))
- (temp (standard-temporary!))
- (target (flonum-target! target)))
- (LAP ,@(object->address source temp)
- (LDT ,target (OFFSET ,address-units-per-object ,temp)))))
-\f
-;; Floating-point vector support
-
-(define-rule statement
- ;; Load an unboxed floating pointer number given a register and offset
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET (REGISTER (? base))
- (MACHINE-CONSTANT (? offset))))
- (let* ((base (standard-source! base))
- (target (fpr->float-register (flonum-target! target))))
- (LAP (LDT ,target (OFFSET ,(* address-units-per-float offset)
- ,base)))))
-
-(define-rule statement
- ;; Store an unboxed floating point number
- (ASSIGN (FLOAT-OFFSET (REGISTER (? base))
- (MACHINE-CONSTANT (? offset)))
- (REGISTER (? source)))
- (let ((base (standard-source! base))
- (source (fpr->float-register (flonum-source! source))))
- (LAP (STT ,source (OFFSET ,(* address-units-per-float offset) ,base)))))
-
-#| ********** Code from the MIPS back-end
-
-This isn't needed (we assume) on the Alpha because the front-end
-(rtlgen/opncod) notices that on the Alpha a floating point number and
-the vector length header are the same size.
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET (REGISTER (? base)) (REGISTER (? index))))
- (with-indexed-address base index 3
- (lambda (address)
- (fp-load-doubleword 0 address
- (fpr->float-register (flonum-target! target)) #T))))
-
-(define-rule statement
- (ASSIGN (FLOAT-OFFSET (REGISTER (? base)) (REGISTER (? index)))
- (REGISTER (? source)))
- (with-indexed-address base index 3
- (lambda (address)
- (fp-store-doubleword 0 address
- (fpr->float-register (flonum-source! source))))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? w-offset)))
- (MACHINE-CONSTANT (? f-offset))))
- (let* ((base (standard-source! base))
- (target (fpr->float-register (flonum-target! target))))
- (fp-load-doubleword (+ (* 4 w-offset) (* 8 f-offset)) base target #T)))
-
-(define-rule statement
- (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? w-offset)))
- (MACHINE-CONSTANT (? f-offset)))
- (REGISTER (? source)))
- (let ((base (standard-source! base))
- (source (fpr->float-register (flonum-source! source))))
- (fp-store-doubleword (+ (* 4 w-offset) (* 8 f-offset)) base source)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? w-offset)))
- (REGISTER (? index))))
- (with-indexed-address base index 3
- (lambda (address)
- (fp-load-doubleword (* 4 w-offset) address
- (fpr->float-register (flonum-target! target))
- #T))))
-
-(define-rule statement
- (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? w-offset)))
- (REGISTER (? index)))
- (REGISTER (? source)))
- (with-indexed-address base index 3
- (lambda (address)
- (fp-store-doubleword (* 4 w-offset) address
- (fpr->float-register (flonum-source! source))))))
-************************ MIPS |#
-\f
-;;;; Flonum Arithmetic
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?)))
- overflow? ;ignore
- (let ((source (flonum-source! source)))
- ((flonum-1-arg/operator operation) (flonum-target! target) source)))
-
-(define (flonum-1-arg/operator operation)
- (lookup-arithmetic-method operation flonum-methods/1-arg))
-
-(define flonum-methods/1-arg
- (list 'FLONUM-METHODS/1-ARG))
-
-(define-arithmetic-method 'FLONUM-ABS flonum-methods/1-arg
- (lambda (target source)
- (LAP (CPYS ,fpr:zero ,source ,target))))
-
-(define-arithmetic-method 'FLONUM-NEGATE flonum-methods/1-arg
- (lambda (target source)
- ; The following line is suggested by the Alpha instruction manual
- ; but it looks like it might generate a negative 0.0
- ; (LAP (CPYSN ,source ,source ,target))
- (LAP (SUBT ,fpr:zero ,source ,target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLONUM-2-ARGS (? operation)
- (REGISTER (? source1))
- (REGISTER (? source2))
- (? overflow?)))
- overflow? ;ignore
- (let ((source1 (flonum-source! source1))
- (source2 (flonum-source! source2)))
- ((flonum-2-args/operator operation) (flonum-target! target)
- source1
- source2)))
-
-(define (flonum-2-args/operator operation)
- (lookup-arithmetic-method operation flonum-methods/2-args))
-
-(define flonum-methods/2-args
- (list 'FLONUM-METHODS/2-ARGS))
-
-(let-syntax
- ((define-flonum-operation
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-ARITHMETIC-METHOD ',(cadr form) FLONUM-METHODS/2-ARGS
- (LAMBDA (TARGET SOURCE1 SOURCE2)
- (LAP (,(caddr form) ,',SOURCE1 ,',SOURCE2 ,',TARGET))))))))
- (define-flonum-operation flonum-add ADDT)
- (define-flonum-operation flonum-subtract SUBT)
- (define-flonum-operation flonum-multiply MULT)
- (define-flonum-operation flonum-divide DIVT))
-\f
-;;;; Flonum Predicates
-
-(define-rule predicate
- (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
- ;; No immediate zeros, easy to generate by subtracting from itself
- (let ((source (flonum-source! source)))
- (flonum-compare source
- (case predicate
- ((FLONUM-ZERO?) '(FBEQ FBNE))
- ((FLONUM-NEGATIVE?) '(FBLT FBGE))
- ((FLONUM-POSITIVE?) '(FBGT FBLE))
- (else (error "unknown flonum predicate" predicate))))
- (LAP)))
-
-(define-rule predicate
- (FLONUM-PRED-2-ARGS (? predicate)
- (REGISTER (? source1))
- (REGISTER (? source2)))
- (let* ((source1 (flonum-source! source1))
- (source2 (flonum-source! source2))
- (temp (flonum-temporary!)))
- (flonum-compare temp '(FBNE FBEQ))
- (case predicate
- ((FLONUM-EQUAL?) (LAP (CMPTEQ ,source1 ,source2 ,temp)))
- ((FLONUM-LESS?) (LAP (CMPTLT ,source1 ,source2 ,temp)))
- ((FLONUM-GREATER?) (LAP (CMPTLT ,source2 ,source1 ,temp)))
- (else (error "unknown flonum predicate" predicate)))))
-
-(define (flonum-compare source opcodes)
- (set-current-branches!
- (lambda (label)
- (LAP (,(car opcodes) ,source (@PCR ,label))))
- (lambda (label)
- (LAP (,(cadr opcodes) ,source (@PCR ,label))))))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RTL Rewrite Rules
-;;; Package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Synthesized Data
-
-(define-rule rewriting
- (CONS-NON-POINTER (REGISTER (? type register-known-value))
- (REGISTER (? datum register-known-value)))
- (QUALIFIER (and (rtl:machine-constant? type)
- (rtl:machine-constant? datum)))
- (rtl:make-cons-non-pointer type datum))
-
-(define-rule rewriting
- (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
- (QUALIFIER
- (and (rtl:object->type? type)
- (rtl:constant? (rtl:object->type-expression type))))
- (rtl:make-cons-pointer
- (rtl:make-machine-constant
- (object-type (rtl:object->type-expression datum)))
- datum))
-
-(define-rule rewriting
- (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
- (QUALIFIER (rtl:machine-constant? type))
- (rtl:make-cons-pointer type datum))
-
-(define-rule rewriting
- (CONS-NON-POINTER (REGISTER (? type register-known-value)) (? datum))
- (QUALIFIER (rtl:machine-constant? type))
- (rtl:make-cons-non-pointer type datum))
-
-(define-rule rewriting
- (CONS-NON-POINTER (REGISTER (? type register-known-value)) (? datum))
- (QUALIFIER
- (and (rtl:object->type? type)
- (rtl:constant? (rtl:object->type-expression type))))
- (rtl:make-cons-non-pointer
- (rtl:make-machine-constant
- (object-type (rtl:object->type-expression datum)))
- datum))
-
-(define-rule rewriting
- (CONS-NON-POINTER (? type) (REGISTER (? datum register-known-value)))
- (QUALIFIER
- (and (rtl:object->datum? datum)
- (rtl:constant-non-pointer? (rtl:object->datum-expression datum))))
- (rtl:make-cons-non-pointer
- type
- (rtl:make-machine-constant
- (careful-object-datum
- (rtl:constant-value (rtl:object->datum-expression datum))))))
-
-(define-rule rewriting
- (OBJECT->TYPE (REGISTER (? source register-known-value)))
- (QUALIFIER (rtl:constant? source))
- (rtl:make-machine-constant (object-type (rtl:constant-value source))))
-
-(define-rule rewriting
- (OBJECT->DATUM (REGISTER (? source register-known-value)))
- (QUALIFIER (rtl:constant-non-pointer? source))
- (rtl:make-machine-constant
- (careful-object-datum (rtl:constant-value source))))
-
-(define (rtl:constant-non-pointer? expression)
- (and (rtl:constant? expression)
- (non-pointer-object? (rtl:constant-value expression))))
-\f
-;;; These rules are losers because there's no abstract way to cons a
-;;; statement or a predicate without also getting some CFG structure.
-
-(define-rule rewriting
- (ASSIGN (? target) (REGISTER (? comparand register-known-value)))
- (QUALIFIER (rtl:immediate-zero-constant? comparand))
- (list 'ASSIGN target (rtl:make-machine-register regnum:zero)))
-
-(define-rule rewriting
- (EQ-TEST (? source) (REGISTER (? comparand register-known-value)))
- (QUALIFIER (rtl:immediate-zero-constant? comparand))
- (list 'EQ-TEST source (rtl:make-machine-register regnum:zero)))
-
-(define-rule rewriting
- (EQ-TEST (REGISTER (? comparand register-known-value)) (? source))
- (QUALIFIER (rtl:immediate-zero-constant? comparand))
- (list 'EQ-TEST source (rtl:make-machine-register regnum:zero)))
-
-(define (rtl:immediate-zero-constant? expression)
- (cond ((rtl:constant? expression)
- (let ((value (rtl:constant-value expression)))
- (and (non-pointer-object? value)
- (zero? (object-type value))
- (zero? (careful-object-datum value)))))
- ((rtl:cons-non-pointer? expression)
- (and (let ((expression (rtl:cons-non-pointer-type expression)))
- (and (rtl:machine-constant? expression)
- (zero? (rtl:machine-constant-value expression))))
- (let ((expression (rtl:cons-non-pointer-datum expression)))
- (and (rtl:machine-constant? expression)
- (zero? (rtl:machine-constant-value expression))))))
- (else false)))
-\f
-;;;; Fixnums
-
-;; I've copied this rule from the MC68020. -- Jinx
-;; It should probably be qualified to be in the immediate range.
-
-(define-rule rewriting
- (OBJECT->FIXNUM (REGISTER (? source register-known-value)))
- (QUALIFIER (rtl:constant-fixnum? source))
- (rtl:make-object->fixnum source))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS FIXNUM-LSH
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- #F)
- (QUALIFIER (and (rtl:register? operand-1)
- (rtl:constant-fixnum? operand-2)))
- (rtl:make-fixnum-2-args 'FIXNUM-LSH operand-1 operand-2 #F))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (REGISTER (? operand-1 register-known-value))
- (? operand-2)
- #F)
- (QUALIFIER (rtl:constant-fixnum-4? operand-1))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- #F)
- (QUALIFIER (rtl:constant-fixnum-4? operand-2))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (REGISTER (? operand-1 register-known-value))
- (? operand-2)
- #F)
- (QUALIFIER
- (and (rtl:object->fixnum-of-register? operand-1)
- (rtl:constant-fixnum-4? operand-2)))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- #F)
- (QUALIFIER
- (and (rtl:constant-fixnum-4? operand-1)
- (rtl:object->fixnum-of-register? operand-2)))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
-
-(define (rtl:constant-fixnum? expression)
- (and (rtl:constant? expression)
- (fix:fixnum? (rtl:constant-value expression))))
-
-(define (rtl:constant-fixnum-4? expression)
- (and (rtl:object->fixnum? expression)
- (let ((expression (rtl:object->fixnum-expression expression)))
- (and (rtl:constant? expression)
- (eqv? 4 (rtl:constant-value expression))))))
-
-(define (rtl:object->fixnum-of-register? expression)
- (and (rtl:object->fixnum? expression)
- (rtl:register? (rtl:object->fixnum-expression expression))))
-\f
-;;;; Closures and othe optimizations.
-
-;; These rules are Spectrum specific
-
-(define-rule rewriting
- (CONS-POINTER (REGISTER (? type register-known-value))
- (REGISTER (? datum register-known-value)))
- (QUALIFIER (and (rtl:machine-constant? type)
- (= (rtl:machine-constant-value type)
- (ucode-type compiled-entry))
- (or (rtl:entry:continuation? datum)
- (rtl:entry:procedure? datum)
- (rtl:cons-closure? datum))))
- (rtl:make-cons-pointer type datum))
-
-#|
-;; Not yet written.
-
-;; A type is compatible when a depi instruction can put it in assuming that
-;; the datum has the quad bits set.
-;; A register is a machine-address-register if it is a machine register and
-;; always contains an address (ie. free pointer, stack pointer, or dlink register)
-
-(define-rule rewriting
- (CONS-POINTER (REGISTER (? type register-known-value))
- (REGISTER (? datum machine-address-register)))
- (QUALIFIER (and (rtl:machine-constant? type)
- (spectrum-type-optimizable? (rtl:machine-constant-value type))))
- (rtl:make-cons-pointer type datum))
-|#
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Assembler Machine Dependencies
-
-(declare (usual-integrations))
-\f
-(let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form))))))
-
-(define-integrable maximum-padding-length
- ;; Instruction length is always a multiple of 16 bits
- 16)
-
-(define padding-string
- ;; Pad with ILLEGAL instructions
- (unsigned-integer->bit-string maximum-padding-length #b0100101011111100))
-
-(define-integrable block-offset-width
- ;; Block offsets are always 16 bit words
- 16)
-
-(define-integrable maximum-block-offset
- (- (expt 2 block-offset-width) 2))
-
-(define (block-offset->bit-string offset start?)
- (unsigned-integer->bit-string block-offset-width (+ offset (if start? 0 1))))
-
-(define (make-nmv-header n)
- (bit-string-append (unsigned-integer->bit-string scheme-datum-width n)
- nmv-type-string))
-
-(define nmv-type-string
- (unsigned-integer->bit-string scheme-type-width
- (ucode-type manifest-nm-vector)))
-
-(define (object->bit-string object)
- (bit-string-append
- (unsigned-integer->bit-string scheme-datum-width
- (careful-object-datum object))
- (unsigned-integer->bit-string scheme-type-width (object-type object))))
-
-;;; Machine dependent instruction order
-
-(define (instruction-insert! bits block position receiver)
- (let* ((l (bit-string-length bits))
- (new-position (- position l)))
- (bit-substring-move-right! bits 0 l block new-position)
- (receiver new-position)))
-
-(define instruction-initial-position bit-string-length)
-(define-integrable instruction-append bit-string-append-reversed)
-
-;;; end let-syntax
-)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; 68000 Specific Coercions
-
-(declare (usual-integrations))
-\f
-(define coerce-quick
- (standard-coercion
- (lambda (n)
- (cond ((< 0 n 8) n)
- ((= n 8) 0)
- (else (error "Bad quick immediate" n))))))
-
-(define coerce-short-label
- (standard-coercion
- (lambda (offset)
- (or (if (negative? offset)
- (and (>= offset -128) (+ offset 256))
- (and (< offset 128) offset))
- (error "Short label out of range" offset)))))
-
-(define coerce-bit-field-width
- (standard-coercion
- (lambda (w)
- (cond ((< 0 w 32) w)
- ((= w 32) 0)
- (else (error "Bad bit field width" w))))))
-
-(define coerce-index-scale
- (standard-coercion
- (lambda (sf)
- (case sf
- ((1) #b00)
- ((2) #b01)
- ((4) #b10)
- ((8) #b11)
- (else (error "Bad index scale" sf))))))
-\f
-;; *** NOTE ***
-;; If you add coercions here, remember to also add them to
-;; EXPAND-DESCRIPTOR in "insmac.scm".
-
-(define make-coercion
- (coercion-maker
- `((UNSIGNED . ,coerce-unsigned-integer)
- (SIGNED . ,coerce-signed-integer)
- (QUICK . ,coerce-quick)
- (SHIFT-NUMBER . ,coerce-quick)
- (SHORT-LABEL . ,coerce-short-label)
- (BFWIDTH . ,coerce-bit-field-width)
- (SCALE-FACTOR . ,coerce-index-scale))))
-
-(define coerce-1-bit-unsigned (make-coercion 'UNSIGNED 1))
-(define coerce-2-bit-unsigned (make-coercion 'UNSIGNED 2))
-(define coerce-3-bit-unsigned (make-coercion 'UNSIGNED 3))
-(define coerce-4-bit-unsigned (make-coercion 'UNSIGNED 4))
-(define coerce-5-bit-unsigned (make-coercion 'UNSIGNED 5))
-(define coerce-6-bit-unsigned (make-coercion 'UNSIGNED 6))
-(define coerce-7-bit-unsigned (make-coercion 'UNSIGNED 7))
-(define coerce-8-bit-unsigned (make-coercion 'UNSIGNED 8))
-(define coerce-9-bit-unsigned (make-coercion 'UNSIGNED 9))
-(define coerce-10-bit-unsigned (make-coercion 'UNSIGNED 10))
-(define coerce-11-bit-unsigned (make-coercion 'UNSIGNED 11))
-(define coerce-12-bit-unsigned (make-coercion 'UNSIGNED 12))
-(define coerce-13-bit-unsigned (make-coercion 'UNSIGNED 13))
-(define coerce-14-bit-unsigned (make-coercion 'UNSIGNED 14))
-(define coerce-15-bit-unsigned (make-coercion 'UNSIGNED 15))
-(define coerce-16-bit-unsigned (make-coercion 'UNSIGNED 16))
-(define coerce-32-bit-unsigned (make-coercion 'UNSIGNED 32))
-
-(define coerce-8-bit-signed (make-coercion 'SIGNED 8))
-(define coerce-16-bit-signed (make-coercion 'SIGNED 16))
-(define coerce-32-bit-signed (make-coercion 'SIGNED 32))
-
-(define coerce-3-bit-quick (make-coercion 'QUICK 3))
-(define coerce-5-bit-bfwidth (make-coercion 'BFWIDTH 5))
-(define coerce-3-bit-shift-number (make-coercion 'SHIFT-NUMBER 3))
-(define coerce-8-bit-short-label (make-coercion 'SHORT-LABEL 8))
-(define coerce-2-bit-scale-factor (make-coercion 'SCALE-FACTOR 2))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Script to incrementally compile the compiler (from .bins)
-
-(fluid-let ((compiler:coalescing-constant-warnings? #f))
- (for-each compile-directory
- '("back"
- "base"
- "fggen"
- "fgopt"
- "machines/bobcat"
- "rtlbase"
- "rtlgen"
- "rtlopt")))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Compiler Packaging
-\f
-(global-definitions "../runtime/runtime")
-(global-definitions "../sf/sf")
-
-(define-package (compiler)
- (files "base/switch"
- "base/object" ;tagged object support
- "base/enumer" ;enumerations
- "base/sets" ;set abstraction
- "base/mvalue" ;multiple-value support
- "base/scode" ;SCode abstraction
- "machines/bobcat/machin" ;machine dependent stuff
- "back/asutl" ;back-end odds and ends
- "base/utils" ;odds and ends
-
- "base/cfg1" ;control flow graph
- "base/cfg2"
- "base/cfg3"
-
- "base/ctypes" ;CFG datatypes
-
- "base/rvalue" ;Right hand values
- "base/lvalue" ;Left hand values
- "base/blocks" ;rvalue: blocks
- "base/proced" ;rvalue: procedures
- "base/contin" ;rvalue: continuations
-
- "base/subprb" ;subproblem datatype
-
- "rtlbase/rgraph" ;program graph abstraction
- "rtlbase/rtlty1" ;RTL: type definitions
- "rtlbase/rtlty2" ;RTL: type definitions
- "rtlbase/rtlexp" ;RTL: expression operations
- "rtlbase/rtlcon" ;RTL: complex constructors
- "rtlbase/rtlreg" ;RTL: registers
- "rtlbase/rtlcfg" ;RTL: CFG types
- "rtlbase/rtlobj" ;RTL: CFG objects
- "rtlbase/regset" ;RTL: register sets
- "rtlbase/valclass" ;RTL: value classes
-
- "back/insseq" ;LAP instruction sequences
- )
- (parent ())
- (export ()
- compiler:analyze-side-effects?
- compiler:cache-free-variables?
- compiler:coalescing-constant-warnings?
- compiler:code-compression?
- compiler:compile-by-procedures?
- compiler:cse?
- compiler:default-top-level-declarations
- compiler:enable-integration-declarations?
- compiler:generate-lap-files?
- compiler:generate-range-checks?
- compiler:generate-rtl-files?
- compiler:generate-stack-checks?
- compiler:generate-type-checks?
- compiler:implicit-self-static?
- compiler:intersperse-rtl-in-lap?
- compiler:noisy?
- compiler:open-code-flonum-checks?
- compiler:open-code-primitives?
- compiler:optimize-environments?
- compiler:package-optimization-level
- compiler:preserve-data-structures?
- compiler:show-phases?
- compiler:show-procedures?
- compiler:show-subphases?
- compiler:show-time-reports?
- compiler:use-multiclosures?)
- (import (runtime system-macros)
- ucode-primitive
- ucode-type)
- (import ()
- (scode/access-components access-components)
- (scode/access-environment access-environment)
- (scode/access-name access-name)
- (scode/access? access?)
- (scode/assignment-components assignment-components)
- (scode/assignment-name assignment-name)
- (scode/assignment-value assignment-value)
- (scode/assignment? assignment?)
- (scode/combination-components combination-components)
- (scode/combination-operands combination-operands)
- (scode/combination-operator combination-operator)
- (scode/combination? combination?)
- (scode/comment-components comment-components)
- (scode/comment-expression comment-expression)
- (scode/comment-text comment-text)
- (scode/comment? comment?)
- (scode/conditional-alternative conditional-alternative)
- (scode/conditional-components conditional-components)
- (scode/conditional-consequent conditional-consequent)
- (scode/conditional-predicate conditional-predicate)
- (scode/conditional? conditional?)
- (scode/constant? scode-constant?)
- (scode/declaration-components declaration-components)
- (scode/declaration-expression declaration-expression)
- (scode/declaration-text declaration-text)
- (scode/declaration? declaration?)
- (scode/definition-components definition-components)
- (scode/definition-name definition-name)
- (scode/definition-value definition-value)
- (scode/definition? definition?)
- (scode/delay-components delay-components)
- (scode/delay-expression delay-expression)
- (scode/delay? delay?)
- (scode/disjunction-alternative disjunction-alternative)
- (scode/disjunction-components disjunction-components)
- (scode/disjunction-predicate disjunction-predicate)
- (scode/disjunction? disjunction?)
- (scode/lambda-components lambda-components)
- (scode/lambda? lambda?)
- (scode/make-access make-access)
- (scode/make-assignment make-assignment)
- (scode/make-combination make-combination)
- (scode/make-comment make-comment)
- (scode/make-conditional make-conditional)
- (scode/make-declaration make-declaration)
- (scode/make-definition make-definition)
- (scode/make-delay make-delay)
- (scode/make-disjunction make-disjunction)
- (scode/make-lambda make-lambda)
- (scode/make-open-block make-open-block)
- (scode/make-quotation make-quotation)
- (scode/make-sequence make-sequence)
- (scode/make-the-environment make-the-environment)
- (scode/make-unassigned? make-unassigned?)
- (scode/make-variable make-variable)
- (scode/open-block-components open-block-components)
- (scode/open-block? open-block?)
- (scode/primitive-procedure? primitive-procedure?)
- (scode/procedure? procedure?)
- (scode/quotation-expression quotation-expression)
- (scode/quotation? quotation?)
- (scode/sequence-actions sequence-actions)
- (scode/sequence-components sequence-components)
- (scode/sequence-immediate-first sequence-immediate-first)
- (scode/sequence-immediate-second sequence-immediate-second)
- (scode/sequence-first sequence-first)
- (scode/sequence-second sequence-second)
- (scode/sequence? sequence?)
- (scode/symbol? symbol?)
- (scode/the-environment? the-environment?)
- (scode/unassigned?-name unassigned?-name)
- (scode/unassigned?? unassigned??)
- (scode/variable-components variable-components)
- (scode/variable-name variable-name)
- (scode/variable? variable?)))
-\f
-(define-package (compiler reference-contexts)
- (files "base/refctx")
- (parent (compiler))
- (export (compiler)
- add-reference-context/adjacent-parents!
- initialize-reference-contexts!
- make-reference-context
- modify-reference-contexts!
- reference-context/adjacent-parent?
- reference-context/block
- reference-context/offset
- reference-context/procedure
- reference-context?
- set-reference-context/offset!))
-
-(define-package (compiler macros)
- (files "base/macros")
- (parent ())
- (import (runtime macros)
- parse-define-syntax)
- (initialization (initialize-package!)))
-
-(define-package (compiler declarations)
- (files "machines/bobcat/decls")
- (parent (compiler))
- (export (compiler)
- sc
- syntax-files!)
- (import (scode-optimizer top-level)
- sf/internal)
- (initialization (initialize-package!)))
-
-(define-package (compiler top-level)
- (files "base/toplev"
- "base/crstop"
- "base/asstop")
- (parent (compiler))
- (export ()
- cbf
- cf
- compile-directory
- compile-bin-file
- compile-procedure
- compile-scode
- compiler:dump-bci-file
- compiler:dump-bci/bcs-files
- compiler:dump-bif/bsm-files
- compiler:dump-inf-file
- compiler:dump-info-file
- compiler:reset!
- cross-compile-bin-file
- cross-compile-bin-file-end)
- (export (compiler)
- canonicalize-label-name)
- (export (compiler fg-generator)
- compile-recursively)
- (export (compiler rtl-generator)
- *ic-procedure-headers*
- *rtl-continuations*
- *rtl-expression*
- *rtl-graphs*
- *rtl-procedures*)
- (export (compiler lap-syntaxer)
- *block-label*
- *external-labels*
- label->object)
- (export (compiler debug)
- *root-expression*
- *rtl-procedures*
- *rtl-graphs*)
- (import (runtime compiler-info)
- make-dbg-info-vector
- split-inf-structure!)
- (import (runtime unparser)
- param:unparse-uninterned-symbols-by-name?)
- (import (scode-optimizer build-utilities)
- directory-processor))
-\f
-(define-package (compiler debug)
- (files "base/debug")
- (parent (compiler))
- (export ()
- debug/find-continuation
- debug/find-entry-node
- debug/find-procedure
- debug/where
- dump-rtl
- po
- show-bblock-rtl
- show-fg
- show-fg-node
- show-rtl
- write-rtl-instructions)
- (import (runtime unparser)
- param:unparse-uninterned-symbols-by-name?))
-
-(define-package (compiler pattern-matcher/lookup)
- (files "base/pmlook")
- (parent (compiler))
- (export (compiler)
- make-pattern-variable
- pattern-lookup
- pattern-variable-name
- pattern-variable?
- pattern-variables))
-
-(define-package (compiler pattern-matcher/parser)
- (files "base/pmpars")
- (parent (compiler))
- (export (compiler)
- parse-rule
- rule-result-expression)
- (export (compiler macros)
- parse-rule
- rule-result-expression))
-
-(define-package (compiler pattern-matcher/early)
- (files "base/pmerly")
- (parent (compiler))
- (export (compiler)
- early-parse-rule
- early-pattern-lookup
- early-make-rule
- make-database-transformer
- make-symbol-transformer
- make-bit-mask-transformer))
-\f
-(define-package (compiler debugging-information)
- (files "base/infnew")
- (parent (compiler))
- (export (compiler top-level)
- info-generation-phase-1
- info-generation-phase-2
- info-generation-phase-3)
- (export (compiler rtl-generator)
- generated-dbg-continuation)
- (import (runtime compiler-info)
- make-dbg-info
-
- make-dbg-expression
- dbg-expression/block
- dbg-expression/label
- set-dbg-expression/label!
-
- make-dbg-procedure
- dbg-procedure/block
- dbg-procedure/label
- set-dbg-procedure/label!
- dbg-procedure/name
- dbg-procedure/required
- dbg-procedure/optional
- dbg-procedure/rest
- dbg-procedure/auxiliary
- dbg-procedure/external-label
- set-dbg-procedure/external-label!
- dbg-procedure<?
-
- make-dbg-continuation
- dbg-continuation/block
- dbg-continuation/label
- set-dbg-continuation/label!
- dbg-continuation<?
-
- make-dbg-block
- dbg-block/parent
- dbg-block/layout
- dbg-block/stack-link
- set-dbg-block/procedure!
-
- make-dbg-variable
- dbg-variable/value
- set-dbg-variable/value!
-
- dbg-block-name/dynamic-link
- dbg-block-name/ic-parent
- dbg-block-name/normal-closure
- dbg-block-name/return-address
- dbg-block-name/static-link
-
- make-dbg-label-2
- dbg-label/offset
- set-dbg-label/external?!))
-
-(define-package (compiler constraints)
- (files "base/constr")
- (parent (compiler))
- (export (compiler)
- make-constraint
- constraint/element
- constraint/graph-head
- constraint/afters
- constraint/closed?
- constraint-add!
- add-constraint-element!
- add-constraint-set!
- make-constraint-graph
- constraint-graph/entry-nodes
- constraint-graph/closed?
- close-constraint-graph!
- close-constraint-node!
- order-per-constraints
- order-per-constraints/extracted
- legal-ordering-per-constraints?
- with-new-constraint-marks
- constraint-marked?
- constraint-mark!
- transitively-close-dag!
- reverse-postorder))
-\f
-(define-package (compiler fg-generator)
- (files "fggen/canon" ;SCode canonicalizer
- "fggen/fggen" ;SCode->flow-graph converter
- "fggen/declar" ;Declaration handling
- )
- (parent (compiler))
- (export (compiler top-level)
- canonicalize/top-level
- construct-graph)
- (import (runtime scode-data)
- &pair-car
- &pair-cdr
- &triple-first
- &triple-second
- &triple-third))
-
-(define-package (compiler fg-optimizer)
- (files "fgopt/outer" ;outer analysis
- "fgopt/sideff" ;side effect analysis
- )
- (parent (compiler))
- (export (compiler top-level)
- clear-call-graph!
- compute-call-graph!
- outer-analysis
- side-effect-analysis))
-
-(define-package (compiler fg-optimizer fold-constants)
- (files "fgopt/folcon")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) fold-constants))
-
-(define-package (compiler fg-optimizer operator-analysis)
- (files "fgopt/operan")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) operator-analysis))
-
-(define-package (compiler fg-optimizer variable-indirection)
- (files "fgopt/varind")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) initialize-variable-indirections!))
-
-(define-package (compiler fg-optimizer environment-optimization)
- (files "fgopt/envopt")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) optimize-environments!))
-
-(define-package (compiler fg-optimizer closure-analysis)
- (files "fgopt/closan")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) identify-closure-limits!))
-
-(define-package (compiler fg-optimizer continuation-analysis)
- (files "fgopt/contan")
- (parent (compiler fg-optimizer))
- (export (compiler top-level)
- continuation-analysis
- setup-block-static-links!))
-
-(define-package (compiler fg-optimizer compute-node-offsets)
- (files "fgopt/offset")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) compute-node-offsets))
-\f
-(define-package (compiler fg-optimizer connectivity-analysis)
- (files "fgopt/conect")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) connectivity-analysis))
-
-(define-package (compiler fg-optimizer delete-integrated-parameters)
- (files "fgopt/delint")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) delete-integrated-parameters))
-
-(define-package (compiler fg-optimizer design-environment-frames)
- (files "fgopt/desenv")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) design-environment-frames!))
-
-(define-package (compiler fg-optimizer setup-block-types)
- (files "fgopt/blktyp")
- (parent (compiler fg-optimizer))
- (export (compiler top-level)
- setup-block-types!
- setup-closure-contexts!)
- (export (compiler)
- indirection-block-procedure))
-
-(define-package (compiler fg-optimizer simplicity-analysis)
- (files "fgopt/simple")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) simplicity-analysis)
- (export (compiler fg-optimizer subproblem-ordering)
- new-subproblem/compute-simplicity!))
-
-(define-package (compiler fg-optimizer simulate-application)
- (files "fgopt/simapp")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) simulate-application))
-
-(define-package (compiler fg-optimizer subproblem-free-variables)
- (files "fgopt/subfre")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) compute-subproblem-free-variables)
- (export (compiler fg-optimizer) map-union)
- (export (compiler fg-optimizer subproblem-ordering)
- new-subproblem/compute-free-variables!))
-
-(define-package (compiler fg-optimizer subproblem-ordering)
- (files "fgopt/order")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) subproblem-ordering))
-
-(define-package (compiler fg-optimizer subproblem-ordering reuse-frames)
- (files "fgopt/reord" "fgopt/reuse")
- (parent (compiler fg-optimizer subproblem-ordering))
- (export (compiler top-level) setup-frame-adjustments)
- (export (compiler fg-optimizer subproblem-ordering)
- order-subproblems/maybe-overwrite-block))
-
-(define-package (compiler fg-optimizer subproblem-ordering parameter-analysis)
- (files "fgopt/param")
- (parent (compiler fg-optimizer subproblem-ordering))
- (export (compiler fg-optimizer subproblem-ordering)
- parameter-analysis))
-
-(define-package (compiler fg-optimizer return-equivalencing)
- (files "fgopt/reteqv")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) find-equivalent-returns!))
-\f
-(define-package (compiler rtl-generator)
- (files "rtlgen/rtlgen" ;RTL generator
- "rtlgen/rgstmt" ;statements
- "rtlgen/fndvar" ;find variables
- "machines/bobcat/rgspcm" ;special close-coded primitives
- "rtlbase/rtline" ;linearizer
- )
- (parent (compiler))
- (export (compiler)
- make-linearizer)
- (export (compiler top-level)
- generate/top-level
- linearize-rtl
- setup-bblock-continuations!)
- (export (compiler debug)
- linearize-rtl)
- (import (compiler top-level)
- label->object))
-
-(define-package (compiler rtl-generator generate/procedure-header)
- (files "rtlgen/rgproc")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator) generate/procedure-header))
-
-(define-package (compiler rtl-generator combination/inline)
- (files "rtlgen/opncod")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator) combination/inline)
- (export (compiler top-level) open-coding-analysis))
-
-(define-package (compiler rtl-generator find-block)
- (files "rtlgen/fndblk")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator) find-block))
-
-(define-package (compiler rtl-generator generate/rvalue)
- (files "rtlgen/rgrval")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator)
- generate/rvalue
- load-closure-environment
- make-cons-closure-indirection
- make-cons-closure-redirection
- make-closure-redirection
- make-ic-cons
- make-non-trivial-closure-cons
- make-trivial-closure-cons
- redirect-closure))
-
-(define-package (compiler rtl-generator generate/combination)
- (files "rtlgen/rgcomb")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator)
- generate/combination
- rtl:bump-closure)
- (export (compiler rtl-generator combination/inline)
- generate/invocation-prefix))
-
-(define-package (compiler rtl-generator generate/return)
- (files "rtlgen/rgretn")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator)
- make-return-operand
- generate/return
- generate/return*
- generate/trivial-return))
-\f
-(define-package (compiler rtl-cse)
- (files "rtlopt/rcse1" ;RTL common subexpression eliminator
- "rtlopt/rcse2"
- "rtlopt/rcseep" ;CSE expression predicates
- "rtlopt/rcseht" ;CSE hash table
- "rtlopt/rcserq" ;CSE register/quantity abstractions
- "rtlopt/rcsesr" ;CSE stack references
- )
- (parent (compiler))
- (export (compiler top-level) common-subexpression-elimination))
-
-(define-package (compiler rtl-optimizer)
- (files "rtlopt/rdebug")
- (parent (compiler)))
-
-(define-package (compiler rtl-optimizer invertible-expression-elimination)
- (files "rtlopt/rinvex")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) invertible-expression-elimination))
-
-(define-package (compiler rtl-optimizer common-suffix-merging)
- (files "rtlopt/rtlcsm")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) merge-common-suffixes!))
-
-(define-package (compiler rtl-optimizer rtl-dataflow-analysis)
- (files "rtlopt/rdflow")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) rtl-dataflow-analysis))
-
-(define-package (compiler rtl-optimizer rtl-rewriting)
- (files "rtlopt/rerite")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level)
- rtl-rewriting:post-cse
- rtl-rewriting:pre-cse)
- (export (compiler lap-syntaxer) add-rewriting-rule!))
-
-(define-package (compiler rtl-optimizer lifetime-analysis)
- (files "rtlopt/rlife")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) lifetime-analysis)
- (export (compiler rtl-optimizer code-compression) mark-set-registers!))
-
-(define-package (compiler rtl-optimizer code-compression)
- (files "rtlopt/rcompr")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) code-compression))
-
-(define-package (compiler rtl-optimizer register-allocation)
- (files "rtlopt/ralloc")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) register-allocation))
-\f
-(define-package (compiler lap-syntaxer)
- (files "back/lapgn1" ;LAP generator
- "back/lapgn2" ; " "
- "back/lapgn3" ; " "
- "back/regmap" ;Hardware register allocator
- "machines/bobcat/lapgen" ;code generation rules
- "machines/bobcat/rules1" ; " " "
- "machines/bobcat/rules2" ; " " "
- "machines/bobcat/rules3" ; " " "
- "machines/bobcat/rules4" ; " " "
- "machines/bobcat/rulrew" ;code rewriting rules
- "back/syntax" ;Generic syntax phase
- "back/syerly" ;Early binding version
- "machines/bobcat/coerce" ;Coercions: integer -> bit string
- "back/asmmac" ;Macros for hairy syntax
- "machines/bobcat/insmac" ;Macros for hairy syntax
- "machines/bobcat/insutl" ;Utilities for instructions
- "machines/bobcat/instr1" ;68000 Effective addressing
- "machines/bobcat/instr2" ;68000 Instructions
- "machines/bobcat/instr3" ; " "
- "machines/bobcat/instr4" ; " "
- "machines/bobcat/flinstr1" ;68881 Floating Point Instructions
- "machines/bobcat/flinstr2" ; " " " "
- "machines/bobcat/mc68ktgl" ;68020/68040 selection
- )
- (parent (compiler))
- (export (compiler)
- available-machine-registers
- lap-generator/match-rtl-instruction
- lap:make-entry-point
- lap:make-label-statement
- lap:make-unconditional-branch
- lap:syntax-instruction)
- (export (compiler top-level)
- *block-associations*
- *interned-assignments*
- *interned-constants*
- *interned-global-links*
- *interned-uuo-links*
- *interned-static-variables*
- *interned-variables*
- *next-constant*
- generate-lap)
- (import (scode-optimizer expansion)
- scode->scode-expander))
-
-(define-package (compiler lap-syntaxer map-merger)
- (files "back/mermap")
- (parent (compiler lap-syntaxer))
- (export (compiler lap-syntaxer)
- merge-register-maps))
-
-(define-package (compiler lap-syntaxer linearizer)
- (files "back/linear")
- (parent (compiler lap-syntaxer))
- (export (compiler lap-syntaxer)
- add-end-of-block-code!
- add-extra-code!
- bblock-linearize-lap
- extra-code-block/xtra
- declare-extra-code-block!
- find-extra-code-block
- linearize-lap
- set-current-branches!
- set-extra-code-block/xtra!)
- (export (compiler top-level)
- *end-of-block-code*
- linearize-lap))
-
-(define-package (compiler lap-optimizer)
- (files "machines/bobcat/lapopt")
- (parent (compiler))
- (export (compiler top-level)
- optimize-linear-lap))
-
-(define-package (compiler assembler)
- (files "machines/bobcat/assmd" ;Machine dependent
- "back/symtab" ;Symbol tables
- "back/bitutl" ;Assembly blocks
- "back/bittop" ;Assembler top level
- )
- (parent (compiler))
- (export (compiler)
- instruction-append)
- (export (compiler top-level)
- assemble))
-
-#|
-(define-package (compiler disassembler)
- (files "machines/bobcat/dassm1"
- "machines/bobcat/dassm2"
- "machines/bobcat/dassm3")
- (parent (compiler))
- (export ()
- compiler:write-lap-file
- compiler:disassemble)
- (import (runtime compiler-info)
- compiled-code-block/dbg-info
- dbg-info-vector/blocks-vector
- dbg-info-vector?
- dbg-info/labels
- dbg-label/external?
- dbg-label/name
- dbg-labels/find-offset))
-|#
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Script to incrementally syntax the compiler
-\f
-(load-option 'CREF)
-
-;; Guarantee that the compiler's package structure exists.
-(if (not (name->package '(COMPILER)))
- (let ((package-set (package-set-pathname "compiler")))
- (if (not (file-exists? package-set))
- (cref/generate-trivial-constructor "compiler"))
- (construct-packages-from-file (fasload package-set))))
-
-;; Guarantee that the necessary syntactic transforms and optimizers
-;; are loaded.
-(if (lexical-unreferenceable? (->environment '(COMPILER)) 'SYNTAX-FILES!)
- (let ((sf-and-load
- (lambda (files package)
- (sf-conditionally files)
- (for-each (lambda (file)
- (load (string-append file ".bin") package))
- files))))
- (load-option 'HASH-TABLE)
- (fresh-line)
- (newline)
- (write-string "---- Loading compile-time files ----")
- (newline)
- (sf-and-load '("base/switch") '(COMPILER))
- (sf-and-load '("base/macros") '(COMPILER MACROS))
- ((access initialize-package! (->environment '(COMPILER MACROS))))
- (sf-and-load '("machines/bobcat/decls") '(COMPILER DECLARATIONS))
- (let ((environment (->environment '(COMPILER DECLARATIONS))))
- (set! (access source-file-expression environment) "*.scm")
- ((access initialize-package! environment)))
- (sf-and-load '("base/pmlook") '(COMPILER PATTERN-MATCHER/LOOKUP))
- (sf-and-load '("base/pmpars") '(COMPILER PATTERN-MATCHER/PARSER))
- (fluid-let ((sf/default-syntax-table (->environment '(COMPILER))))
- (sf-and-load '("machines/bobcat/machin") '(COMPILER)))
- (fluid-let ((sf/default-declarations
- '((integrate-external "insseq")
- (integrate-external "machin")
- (usual-definition (set expt)))))
- (sf-and-load '("machines/bobcat/assmd") '(COMPILER ASSEMBLER)))
- (sf-and-load '("back/syntax") '(COMPILER LAP-SYNTAXER))
- (sf-and-load '("machines/bobcat/coerce"
- "back/asmmac"
- "machines/bobcat/insmac")
- '(COMPILER LAP-SYNTAXER))
- (sf-and-load '("base/scode") '(COMPILER))
- (sf-and-load '("base/pmerly") '(COMPILER PATTERN-MATCHER/EARLY))
- (sf-and-load '("back/syerly") '(COMPILER LAP-SYNTAXER))))
-
-;; Resyntax any files that need it.
-((access syntax-files! (->environment '(COMPILER))))
-
-;; Rebuild the package constructors and cref.
-(cref/generate-constructors "compiler")
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Disassembler: User Level
-;;; package: (compiler disassembler)
-
-(declare (usual-integrations))
-\f
-;;; Flags that control disassembler behavior
-
-(define disassembler/symbolize-output? true)
-(define disassembler/compiled-code-heuristics? true)
-(define disassembler/write-offsets? true)
-(define disassembler/write-addresses? false)
-
-;;;; Top level entries
-
-(define (compiler:write-lap-file filename #!optional symbol-table?)
- (let ((pathname (->pathname filename))
- (symbol-table?
- (if (default-object? symbol-table?) true symbol-table?)))
- (with-output-to-file (pathname-new-type pathname "lap")
- (lambda ()
- (let ((com-file (pathname-new-type pathname "com")))
- (let ((object (fasload com-file)))
- (if (compiled-code-address? object)
- (let ((block (compiled-code-address->block object)))
- (disassembler/write-compiled-code-block
- block
- (compiled-code-block/dbg-info block symbol-table?)))
- (begin
- (if (not
- (and (scode/comment? object)
- (dbg-info-vector? (scode/comment-text object))))
- (error "Not a compiled file" com-file))
- (let ((blocks
- (vector->list
- (dbg-info-vector/blocks-vector
- (scode/comment-text object)))))
- (if (not (null? blocks))
- (do ((blocks blocks (cdr blocks)))
- ((null? blocks) unspecific)
- (disassembler/write-compiled-code-block
- (car blocks)
- (compiled-code-block/dbg-info (car blocks)
- symbol-table?))
- (if (not (null? (cdr blocks)))
- (begin
- (write-char #\page)
- (newline))))))))))))))
-
-(define disassembler/base-address)
-
-(define (compiler:disassemble entry)
- (let ((block (compiled-entry/block entry)))
- (let ((info (compiled-code-block/dbg-info block true)))
- (fluid-let ((disassembler/write-offsets? true)
- (disassembler/write-addresses? true)
- (disassembler/base-address (object-datum block)))
- (newline)
- (newline)
- (disassembler/write-compiled-code-block block info)))))
-\f
-(define (disassembler/write-compiled-code-block block info)
- (let ((symbol-table (and info (dbg-info/labels info))))
- (write-string "Disassembly of ")
- (write block)
- (call-with-values
- (lambda () (compiled-code-block/filename-and-index block))
- (lambda (filename index)
- (if filename
- (begin
- (write-string " (Block ")
- (write index)
- (write-string " in ")
- (write-string filename)
- (write-string ")")))))
- (write-string ":\n")
- (write-string "Code:\n\n")
- (disassembler/write-instruction-stream
- symbol-table
- (disassembler/instructions/compiled-code-block block symbol-table))
- (write-string "\nConstants:\n\n")
- (disassembler/write-constants-block block symbol-table)
- (newline)))
-
-(define (disassembler/instructions/compiled-code-block block symbol-table)
- (disassembler/instructions block
- (compiled-code-block/code-start block)
- (compiled-code-block/code-end block)
- symbol-table))
-
-(define (disassembler/instructions/address start-address end-address)
- (disassembler/instructions false start-address end-address false))
-
-(define (disassembler/write-instruction-stream symbol-table instruction-stream)
- (parameterize* (list (cons param:unparser-radix 16))
- (lambda ()
- (disassembler/for-each-instruction instruction-stream
- (lambda (offset instruction)
- (disassembler/write-instruction symbol-table
- offset
- (lambda () (display instruction))))))))
-
-(define (disassembler/for-each-instruction instruction-stream procedure)
- (let loop ((instruction-stream instruction-stream))
- (if (not (disassembler/instructions/null? instruction-stream))
- (disassembler/instructions/read instruction-stream
- (lambda (offset instruction instruction-stream)
- (procedure offset instruction)
- (loop (instruction-stream)))))))
-\f
-(define (disassembler/write-constants-block block symbol-table)
- (parameterize* (list (cons param:unparser-radix 16))
- (lambda ()
- (let ((end (system-vector-length block)))
- (let loop ((index (compiled-code-block/constants-start block)))
- (cond ((not (< index end)) 'DONE)
- ((object-type?
- (let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form))))))
- (ucode-type linkage-section))
- (system-vector-ref block index))
- (loop (disassembler/write-linkage-section block
- symbol-table
- index)))
- (else
- (disassembler/write-instruction
- symbol-table
- (compiled-code-block/index->offset index)
- (lambda ()
- (write-constant block
- symbol-table
- (system-vector-ref block index))))
- (loop (1+ index)))))))))
-
-(define (write-constant block symbol-table constant)
- (write-string (cdr (write-to-string constant 60)))
- (cond ((lambda? constant)
- (let ((expression (lambda-body constant)))
- (if (and (compiled-code-address? expression)
- (eq? (compiled-code-address->block expression) block))
- (begin
- (write-string " (")
- (let ((offset (compiled-code-address->offset expression)))
- (let ((label
- (disassembler/lookup-symbol symbol-table offset)))
- (if label
- (write-string label)
- (write offset))))
- (write-string ")")))))
- ((compiled-code-address? constant)
- (write-string " (offset ")
- (write (compiled-code-address->offset constant))
- (write-string " in ")
- (write (compiled-code-address->block constant))
- (write-string ")"))
- (else false)))
-\f
-(define (disassembler/write-linkage-section block symbol-table index)
- (let* ((field (object-datum (system-vector-ref block index)))
- (descriptor (integer-divide field #x10000)))
- (let ((kind (integer-divide-quotient descriptor))
- (length (integer-divide-remainder descriptor)))
-
- (define (write-caches offset size writer)
- (let loop ((index (1+ (+ offset index)))
- (how-many (quotient (- length offset) size)))
- (if (zero? how-many)
- 'DONE
- (begin
- (disassembler/write-instruction
- symbol-table
- (compiled-code-block/index->offset index)
- (lambda ()
- (writer block index)))
- (loop (+ size index) (-1+ how-many))))))
-
- (disassembler/write-instruction
- symbol-table
- (compiled-code-block/index->offset index)
- (lambda ()
- (write-string "#[LINKAGE-SECTION ")
- (write field)
- (write-string "]")))
- (case kind
- ((0 3)
- (write-caches
- compiled-code-block/procedure-cache-offset
- compiled-code-block/objects-per-procedure-cache
- disassembler/write-procedure-cache))
- ((1)
- (write-caches
- 0
- compiled-code-block/objects-per-variable-cache
- (lambda (block index)
- (disassembler/write-variable-cache "Reference" block index))))
- ((2)
- (write-caches
- 0
- compiled-code-block/objects-per-variable-cache
- (lambda (block index)
- (disassembler/write-variable-cache "Assignment" block index))))
- (else
- (error "disassembler/write-linkage-section: Unknown section kind"
- kind)))
- (1+ (+ index length)))))
-\f
-(define-integrable (variable-cache-name cache)
- ((ucode-primitive primitive-object-ref 2) cache 1))
-
-(define (disassembler/write-variable-cache kind block index)
- (write-string kind)
- (write-string " cache to ")
- (write (variable-cache-name (disassembler/read-variable-cache block index))))
-
-(define (disassembler/write-procedure-cache block index)
- (let ((result (disassembler/read-procedure-cache block index)))
- (write (vector-ref result 2))
- (write-string " argument procedure cache to ")
- (case (vector-ref result 0)
- ((COMPILED INTERPRETED)
- (write (vector-ref result 1)))
- ((VARIABLE)
- (write-string "variable ")
- (write (vector-ref result 1)))
- (else
- (error "disassembler/write-procedure-cache: Unknown cache kind"
- (vector-ref result 0))))))
-
-(define (disassembler/write-instruction symbol-table offset write-instruction)
- (if symbol-table
- (let ((label (dbg-labels/find-offset symbol-table offset)))
- (if label
- (begin
- (write-char #\Tab)
- (write-string (dbg-label/name label))
- (write-char #\:)
- (newline)))))
-
- (if disassembler/write-addresses?
- (begin
- (write-string
- (number->string (+ offset disassembler/base-address) 16))
- (write-char #\Tab)))
-
- (if disassembler/write-offsets?
- (begin
- (write-string (number->string offset 16))
- (write-char #\Tab)))
-
- (if symbol-table
- (write-string " "))
- (write-instruction)
- (newline))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; 68000 Disassembler: Top Level
-;;; package: (compiler disassembler)
-
-(declare (usual-integrations))
-\f
-(define (disassembler/read-variable-cache block index)
- (let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form)))))
- (ucode-primitive
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply make-primitive-procedure (cdr form))))))
- ((ucode-primitive primitive-object-set-type 2)
- (ucode-type quad)
- (system-vector-ref block index))))
-
-(define (disassembler/read-procedure-cache block index)
- (fluid-let ((*block block))
- (let* ((offset (compiled-code-block/index->offset index)))
- (let ((opcode (read-unsigned-integer offset 16))
- (arity (read-unsigned-integer (+ offset 6) 16)))
- (case opcode
- ((#x4ef9) ; JMP <value>.L
- ;; This should learn how to decode the new trampolines.
- (vector 'COMPILED
- (read-procedure (+ offset 2))
- arity))
- (else
- (error "disassembler/read-procedure-cache: Unknown opcode"
- opcode block index)))))))
-\f
-(define (disassembler/instructions block start-offset end-offset symbol-table)
- (let loop ((offset start-offset) (state (disassembler/initial-state)))
- (if (and end-offset (< offset end-offset))
- (disassemble-one-instruction
- block offset symbol-table state
- (lambda (offset* instruction state)
- (make-instruction offset
- instruction
- (lambda () (loop offset* state)))))
- '())))
-
-(define (disassembler/instructions/null? obj)
- (null? obj))
-
-(define (disassembler/instructions/read instruction-stream receiver)
- (receiver (instruction-offset instruction-stream)
- (instruction-instruction instruction-stream)
- (instruction-next instruction-stream)))
-
-(define-structure (instruction (type vector))
- (offset false read-only true)
- (instruction false read-only true)
- (next false read-only true))
-
-(define *block)
-(define *current-offset)
-(define *symbol-table)
-(define *ir)
-(define *valid?)
-
-(define (disassemble-one-instruction block offset symbol-table state receiver)
- (fluid-let ((*block block)
- (*current-offset offset)
- (*symbol-table symbol-table)
- (*ir)
- (*valid? true))
- (set! *ir (get-word))
- (let ((start-offset *current-offset))
- ;; External label markers come in two parts:
- ;; An entry type descriptor, and a gc offset.
- (cond ((eq? state 'EXTERNAL-LABEL-OFFSET)
- (receiver *current-offset
- (make-dc 'W *ir)
- 'INSTRUCTION))
- ((external-label-marker? symbol-table offset state)
- (receiver *current-offset
- (make-dc 'W *ir)
- 'EXTERNAL-LABEL-OFFSET))
- (else
- (let ((instruction
- (((vector-ref opcode-dispatch (extract *ir 12 16))))))
- (if *valid?
- (receiver *current-offset
- instruction
- (disassembler/next-state instruction state))
- (let ((inst (make-dc 'W *ir)))
- (receiver start-offset
- inst
- (disassembler/next-state inst state))))))))))
-\f
-(define (disassembler/initial-state)
- 'INSTRUCTION-NEXT)
-
-(define (disassembler/next-state instruction state)
- state ; ignored
- (if (and disassembler/compiled-code-heuristics?
- (or (memq (car instruction) '(BRA JMP RTS))
- (and (eq? (car instruction) 'JSR)
- (let ((entry
- (interpreter-register? (cadr instruction))))
- (and entry
- (eq? (car entry) 'ENTRY))))))
- 'EXTERNAL-LABEL
- 'INSTRUCTION))
-
-(define (disassembler/lookup-symbol symbol-table offset)
- (and symbol-table
- (let ((label (dbg-labels/find-offset symbol-table offset)))
- (and label
- (dbg-label/name label)))))
-
-(define (external-label-marker? symbol-table offset state)
- (if symbol-table
- (let ((label (dbg-labels/find-offset symbol-table (+ offset 4))))
- (and label
- (dbg-label/external? label)))
- (and *block
- (not (eq? state 'INSTRUCTION))
- (let loop ((offset (+ offset 4)))
- (let ((contents (read-bits (- offset 2) 16)))
- (if (bit-string-clear! contents 0)
- (let ((offset
- (- offset (bit-string->unsigned-integer contents))))
- (and (positive? offset)
- (loop offset)))
- (= offset (bit-string->unsigned-integer contents))))))))
-
-(define (make-dc wl bit-string)
- `(DC ,wl ,(bit-string->unsigned-integer bit-string)))
-
-(define (read-procedure offset)
- (with-absolutely-no-interrupts
- (lambda ()
- (let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form)))))
- (ucode-primitive
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply make-primitive-procedure (cdr form))))))
- ((ucode-primitive primitive-object-set-type 2)
- (ucode-type compiled-entry)
- ((ucode-primitive make-non-pointer-object 1)
- (read-unsigned-integer offset 32)))))))
-
-(define (read-unsigned-integer offset size)
- (bit-string->unsigned-integer (read-bits offset size)))
-
-(define (read-bits offset size-in-bits)
- (let ((word (bit-string-allocate size-in-bits))
- (bit-offset (* offset addressing-granularity)))
- (with-absolutely-no-interrupts
- (lambda ()
- (if *block
- (read-bits! *block bit-offset word)
- (read-bits! offset 0 word))))
- word))
-\f
-;;;; Compiler specific information
-
-(define make-data-register)
-(define make-address-register)
-(define make-address-offset)
-(define interpreter-register?)
-
-(let ()
-
-#|
-(define (register-maker assignments)
- (lambda (mode register)
- (list mode
- (if disassembler/symbolize-output?
- (cdr (assq register assignments))
- register))))
-|#
-
-(set! make-data-register
- (lambda (mode register)
- (list mode
- (if disassembler/symbolize-output?
- (cdr (assq register data-register-assignments))
- register))))
-
-(set! make-address-register
- (lambda (mode register)
- (if disassembler/symbolize-output?
- (or (and (eq? mode '@A)
- (= register interpreter-register-pointer)
- (let ((entry (assq 0 interpreter-register-assignments)))
- (and entry
- (cdr entry))))
- (list mode (cdr (assq register address-register-assignments))))
- (list mode register))))
-
-(define data-register-assignments
- '((0 . 0) ;serves multiple functions, not handled now
- (1 . 1)
- (2 . 2)
- (3 . 3)
- (4 . 4)
- (5 . 5)
- (6 . 6)
- (7 . REFERENCE-MASK)))
-
-(define address-register-assignments
- '((0 . 0)
- (1 . 1)
- (2 . 2)
- (3 . 3)
- (4 . DYNAMIC-LINK)
- (5 . FREE-POINTER)
- (6 . REGS-POINTER)
- (7 . STACK-POINTER)))
-\f
-(set! make-address-offset
- (lambda (register offset)
- (if disassembler/symbolize-output?
- (or (interpreter-register register offset)
- `(@AO ,(cdr (assq register address-register-assignments))
- ,offset))
- `(@AO ,register ,offset))))
-
-(set! interpreter-register?
- (lambda (effective-address)
- (case (car effective-address)
- ((@AO)
- (and (or (eq? (cadr effective-address) 'REGS-POINTER)
- (eqv? (cadr effective-address) interpreter-register-pointer))
- (interpreter-register interpreter-register-pointer
- (caddr effective-address))))
- ((REGISTER TEMPORARY ENTRY) effective-address)
- (else false))))
-
-(define (interpreter-register register offset)
- (and (= register interpreter-register-pointer)
- (let ((entry (assq offset interpreter-register-assignments)))
- (if entry
- (cdr entry)
- (let ((qr (integer-divide offset 2)))
- (let ((entry
- (assq (integer-divide-quotient qr)
- interpreter-register-assignments)))
- (and entry
- (if (= (integer-divide-quotient qr) 0)
- (cdr entry)
- `(,@(cdr entry)
- (,(integer-divide-quotient qr)))))))))))
-\f
-(define interpreter-register-pointer
- 6)
-
-(define interpreter-register-assignments
- (let* ((first-entry (* 4 16))
- (first-temp (+ first-entry (* 8 80))))
- (define (make-entries index names)
- (if (null? names)
- '()
- (cons `(,index . (ENTRY ,(car names)))
- (make-entries (+ index 8) (cdr names)))))
- `(;; Interpreter registers
- (0 . (REGISTER MEMORY-TOP))
- (4 . (REGISTER INT-MASK))
- (8 . (REGISTER VALUE))
- (12 . (REGISTER ENVIRONMENT))
- (16 . (REGISTER TEMPORARY))
- (44 . (REGISTER STACK-GUARD))
- ;; Interpreter entry points
- ,@(make-entries
- first-entry
- '(scheme-to-interface
- scheme-to-interface-jsr
- trampoline-to-interface
- shortcircuit-apply
- shortcircuit-apply-size-1
- shortcircuit-apply-size-2
- shortcircuit-apply-size-3
- shortcircuit-apply-size-4
- shortcircuit-apply-size-5
- shortcircuit-apply-size-6
- shortcircuit-apply-size-7
- shortcircuit-apply-size-8
- primitive-apply
- primitive-lexpr-apply
- error
- link
- interrupt-closure
- interrupt-dlink
- interrupt-procedure
- interrupt-continuation
- assignment-trap
- reference-trap
- safe-reference-trap
- &+
- &-
- &*
- &/
- &=
- &<
- &>
- 1+
- -1+
- zero?
- positive?
- negative?
- primitive-error
- allocate-closure
- closure-hook
- quotient
- remainder
- modulo
- stack-and-interrupt-check-12
- stack-and-interrupt-check-14
- stack-and-interrupt-check-18
- stack-and-interrupt-check-22
- stack-and-interrupt-check-24
- set-interrupt-enables
- ))
- ;; Compiled code temporaries
- ,@(let loop ((i 0) (index first-temp))
- (if (= i 256)
- '()
- (cons `(,index . (TEMPORARY ,i))
- (loop (1+ i) (+ index 12))))))))
-)
-\f
-(define (make-pc-relative thunk)
- (let ((reference-offset *current-offset))
- (let ((pco (thunk)))
- (offset->pc-relative pco reference-offset))))
-
-(define (offset->pc-relative pco reference-offset)
- (if disassembler/symbolize-output?
- `(@PCR ,(let ((absolute (+ pco reference-offset)))
- (or (disassembler/lookup-symbol *symbol-table absolute)
- absolute)))
- `(@PCO ,pco)))
-
-(define (undefined-instruction)
- ;; This losing assignment removes a 'cwcc'. Too bad.
- (set! *valid? false)
- '())
-
-(define (undefined)
- undefined-instruction)
-
-;; These are used by dassm1.scm
-
-(define compiled-code-block/procedure-cache-offset 0)
-(define compiled-code-block/objects-per-procedure-cache 2)
-(define compiled-code-block/objects-per-variable-cache 1)
-
-;; global variable used by runtime/udata.scm -- Moby yuck!
-
-(set! compiled-code-block/bytes-per-object 4)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; 68000 Disassembler: Internals
-
-(declare (usual-integrations))
-\f
-(define opcode-dispatch
- (vector (lambda ()
- ((vector-ref bit-manipulation/MOVEP/immediate-dispatch
- (extract *ir 8 12))))
- (lambda () %MOVE-byte)
- (lambda () %MOVE-long)
- (lambda () %MOVE-word)
- (lambda ()
- ((vector-ref miscellaneous-dispatch (extract *ir 8 12))))
- (lambda ()
- (if (= (extract *ir 6 8) #b11)
- (if (= (extract *ir 3 6) #b001)
- %DBcc
- %Scc)
- (if (= (extract *ir 8 9) #b0)
- %ADDQ
- %SUBQ)))
- (lambda () %Bcc/%BSR)
- (lambda ()
- (if (= (extract *ir 8 9) #b0)
- %MOVEQ
- undefined-instruction))
- (lambda ()
- (let ((size (extract *ir 6 8)))
- (cond ((= size #b00)
- (if (= (extract *ir 4 6) #b00)
- %SBCD
- %OR))
- ((= size #b11) %DIV)
- (else %OR))))
- (lambda ()
- (if (= (extract *ir 6 8) #b11)
- %SUBA
- (if (and (= (extract *ir 8 9) #b1)
- (= (extract *ir 4 6) #b00))
- %SUBX
- %SUB)))
- undefined
- (lambda ()
- (if (= (extract *ir 6 8) #b11)
- %CMPA
- (if (= (extract *ir 8 9) 0)
- %CMP
- (if (= (extract *ir 3 6) #b001)
- %CMPM
- %EOR))))
- (lambda ()
- (let ((size (extract *ir 6 8)))
- (cond ((= size #b00)
- (if (= (extract *ir 4 6) #b00)
- %ABCD
- %AND))
- ((= size #b01)
- (if (= (extract *ir 4 6) #b00)
- %EXG
- %AND))
- ((= size #b10)
- (if (= (extract *ir 3 6) #b001)
- %EXGM
- %AND))
- (else %MUL))))
- (lambda ()
- (if (= (extract *ir 6 8) #b11)
- %ADDA
- (if (and (= (extract *ir 8 9) #b1)
- (= (extract *ir 4 6) #b00))
- %ADDX
- %ADD)))
- (lambda () shift/rotate/bitop)
- (lambda () coprocessor)))
-\f
-;;;; Operations
-
-(define bit-manipulation/MOVEP/immediate-dispatch
- (let ((ORI (lambda () %ORI))
- (ANDI (lambda () %ANDI))
- (SUBI (lambda () %SUBI))
- (ADDI (lambda () %ADDI))
- (EORI (lambda () %EORI))
- (CMPI (lambda () %CMPI))
- (dynamic-bit/MOVEP
- (lambda ()
- (if (= (extract *ir 3 6) 1)
- %MOVEP
- dynamic-bit)))
- (static-bit (lambda () static-bit)))
- (vector ORI
- dynamic-bit/MOVEP
- ANDI
- dynamic-bit/MOVEP
- SUBI
- dynamic-bit/MOVEP
- ADDI
- dynamic-bit/MOVEP
- static-bit
- dynamic-bit/MOVEP
- EORI
- dynamic-bit/MOVEP
- CMPI
- dynamic-bit/MOVEP
- undefined
- dynamic-bit/MOVEP)))
-
-(define (dynamic-bit)
- `(,(decode-bit (extract *ir 6 8))
- ,(make-data-register 'D (extract *ir 9 12))
- ,(decode-ea-d&a)))
-
-(define (static-bit)
- (let ((ea (decode-ea-d&a)))
- `(,(decode-bit (extract *ir 6 8))
- (& ,(fetch-immediate 'B))
- ,ea)))
-
-(define (%MOVEP)
- `(MOVEP ,(decode-wl (extract *ir 6 7))
- ,@(let ((data-register (extract *ir 9 12))
- (address-register (extract *ir 0 3))
- (offset (bit-string->signed-integer (get-word))))
- (if (zero? (extract *ir 7 8))
- `(,(make-address-offset address-register offset)
- ,(make-data-register 'D data-register))
- `(,(make-data-register 'D data-register)
- ,(make-address-offset address-register offset))))))
-
-\f
-(define ((logical-immediate keyword))
- (let ((size (decode-bwl (extract *ir 6 8))))
- (cond ((null? size)
- (undefined-instruction))
- ((= (extract *ir 0 6) #b111100)
- (if (eq? size 'L)
- (undefined-instruction)
- `(,keyword ,size (& ,(fetch-immediate size)) (SR))))
- (else
- (let ((immediate (fetch-immediate size)))
- `(,keyword ,size (& ,immediate) ,(decode-ea-d&a)))))))
-
-(define %ORI (logical-immediate 'ORI))
-(define %ANDI (logical-immediate 'ANDI))
-(define %EORI (logical-immediate 'EORI))
-
-(define ((arithmetic-immediate keyword))
- (let ((size (decode-bwl (extract *ir 6 8))))
- (if (null? size)
- (undefined-instruction)
- (let ((immediate (fetch-immediate size)))
- `(,keyword ,size (& ,immediate) ,(decode-ea-d&a))))))
-
-(define %SUBI (arithmetic-immediate 'SUBI))
-(define %ADDI (arithmetic-immediate 'ADDI))
-(define %CMPI (arithmetic-immediate 'CMPI))
-
-(define ((%MOVE size))
- (let ((sea (decode-ea-b=>-A size)))
- (let ((dea (decode-ea-MOVE-destination size)))
- `(MOVE ,size ,sea ,dea))))
-
-(define %MOVE-byte (%MOVE 'B))
-(define %MOVE-word (%MOVE 'W))
-(define %MOVE-long (%MOVE 'L))
-\f
-(define miscellaneous-dispatch
- (let ((NEGX/MOVE<-SR
- (lambda ()
- (if (= (extract *ir 6 8) #b11) %MOVE<-SR %NEGX)))
- (CLR (lambda () %CLR))
- (NEG/MOVE->CCR
- (lambda ()
- (if (= (extract *ir 6 8) #b11) %MOVE->CCR %NEG)))
- (NOT/MOVE->SR
- (lambda ()
- (if (= (extract *ir 6 8) #b11) %MOVE->SR %NOT)))
- (NBCD/PEA/SWAP/MOVEM-registers->ea/EXT
- (lambda ()
- (if (= (extract *ir 7 8) 0)
- (if (= (extract *ir 6 7) 0)
- %NBCD
- (if (= (extract *ir 3 6) 0)
- %SWAP
- %PEA))
- (if (= (extract *ir 3 6) 0)
- %EXT
- %MOVEM-registers->ea))))
- (TST/TAS/illegal
- (lambda ()
- (if (not (= (extract *ir 6 8) #b11))
- %TST
- (if (not (= (extract *ir 0 6) #b111100))
- %TAS
- %ILLEGAL))))
- (MULL/DIVL/MOVEM-ea->registers
- (lambda ()
- (case (extract *ir 6 8)
- ((#b00) %MULL)
- ((#b01) %DIVL)
- ((#b11) %MOVEM-ea->registers)
- (else undefined-instruction))))
- (all-the-rest
- (lambda ()
- ((vector-ref all-the-rest-dispatch (extract *ir 6 8)))))
- (CHK/LEA
- (lambda ()
- ((vector-ref CHK/LEA-dispatch (extract *ir 6 8))))))
- (vector NEGX/MOVE<-SR
- CHK/LEA
- CLR
- CHK/LEA
- NEG/MOVE->CCR
- CHK/LEA
- NOT/MOVE->SR
- CHK/LEA
- NBCD/PEA/SWAP/MOVEM-registers->ea/EXT
- CHK/LEA
- TST/TAS/illegal
- CHK/LEA
- MULL/DIVL/MOVEM-ea->registers
- CHK/LEA
- all-the-rest
- CHK/LEA)))
-\f
-(define all-the-rest-dispatch
- (vector undefined
- (lambda () ((vector-ref all-the-rest-1-dispatch (extract *ir 3 6))))
- (lambda () %JSR)
- (lambda () %JMP)))
-
-(define all-the-rest-1-dispatch
- (vector (lambda () %TRAP)
- (lambda () %TRAP)
- (lambda () %LINK)
- (lambda () %UNLK)
- (lambda () %MOVE->USP)
- (lambda () %MOVE<-USP)
- (lambda ()
- (let ((register (extract *ir 0 3)))
- (if (= register #b100)
- undefined-instruction
- (lambda ()
- `(,(vector-ref #(RESET NOP STOP RTE () RTS TRAPV RTR)
- register))))))
- undefined))
-
-(define ((single-ea-d&a keyword))
- `(,keyword ,(decode-bwl (extract *ir 6 8))
- ,(decode-ea-d&a)))
-
-(define %NEGX (single-ea-d&a 'NEGX))
-(define %CLR (single-ea-d&a 'CLR))
-(define %NEG (single-ea-d&a 'NEG))
-(define %NOT (single-ea-d&a 'NOT))
-(define %TST (single-ea-d&a 'TST))
-
-\f
-(define (%MOVE<-SR)
- `(MOVE W (SR) ,(decode-ea-d&a)))
-
-(define (%MOVE->CCR)
- `(MOVE W ,(decode-ea-d 'W) (CCR)))
-
-(define (%MOVE->SR)
- `(MOVE W ,(decode-ea-d 'W) (SR)))
-
-(define (%NBCD)
- `(NBCD ,(decode-ea-d&a)))
-
-(define (%SWAP)
- `(SWAP ,(make-data-register 'D (extract *ir 0 3))))
-
-(define (%PEA)
- `(PEA ,(decode-ea-c)))
-
-(define (%EXT)
- `(EXT ,(decode-wl (extract *ir 6 7))
- ,(make-data-register 'D (extract *ir 0 3))))
-
-(define (%TAS)
- `(TAS B ,(decode-ea-d&a)))
-
-(define (%ILLEGAL)
- '(ILLEGAL))
-
-(define (%TRAP)
- `(TRAP (& ,(extract *ir 0 4))))
-
-(define (%LINK)
- `(LINK ,(make-address-register 'A (extract *ir 0 3))))
-
-(define (%UNLK)
- `(UNLK ,(make-address-register 'A (extract *ir 0 3))))
-
-(define (%MOVE->USP)
- `(MOVE L ,(make-address-register 'A (extract *ir 0 3)) (USP)))
-
-(define (%MOVE<-USP)
- `(MOVE L (USP) ,(make-address-register 'A (extract *ir 0 3))))
-
-(define (%JSR)
- `(JSR ,(decode-ea-c)))
-
-(define (%JMP)
- `(JMP ,(decode-ea-c)))
-\f
-(define (%MOVEM-registers->ea)
- (let ((mode (extract *ir 3 6))
- (size (decode-wl (extract *ir 6 7))))
- (if (= mode 4)
- `(MOVEM ,size
- ,(decode-@-aregister-list (get-word))
- (make-address-register '@-A (extract *ir 0 3)))
- (let ((ea (decode-ea-c)))
- `(MOVEM ,size
- ,(decode-c@a+register-list (get-word))
- ,ea)))))
-
-(define (%MOVEM-ea->registers)
- (let ((mode (extract *ir 3 6))
- (size (decode-wl (extract *ir 6 7))))
- (let ((ea (if (= mode #b011)
- (make-address-register '@A+ (extract *ir 0 3))
- (decode-ea-c&a size))))
- `(MOVEM ,size ,ea ,(decode-c@a+register-list (get-word))))))
-
-(define (decode-@-aregister-list word)
- (define (loop n registers)
- (if (null? registers)
- '()
- (if (zero? (bit-string-ref word n))
- (loop (1+ n) (cdr registers))
- (cons (car registers)
- (loop (1+ n) (cdr registers))))))
- (loop 0 '(A7 A6 A5 A4 A3 A2 A1 A0 D7 D6 D5 D4 D3 D2 D1 D0)))
-
-(define (decode-c@a+register-list word)
- (define (loop n registers)
- (if (null? registers)
- '()
- (if (zero? (bit-string-ref word n))
- (loop (1+ n) (cdr registers))
- (cons (car registers)
- (loop (1+ n) (cdr registers))))))
- (loop 0 '(D0 D1 D2 D3 D4 D5 D6 D7 A0 A1 A2 A3 A4 A5 A6 A7)))
-
-(define CHK/LEA-dispatch
- (vector undefined
- undefined
- (lambda () %CHK)
- (lambda () %LEA)))
-
-(define (%CHK)
- `(CHK ,(decode-ea-d 'W)
- ,(make-data-register 'D (extract *ir 9 12))))
-
-(define (%LEA)
- `(LEA ,(decode-ea-c)
- ,(make-address-register 'A (extract *ir 9 12))))
-\f
-(define (%Scc)
- `(S ,(decode-cc (extract *ir 8 12))
- ,(decode-ea-d&a)))
-
-(define (%DBcc)
- `(DB ,(decode-cc (extract *ir 8 12))
- ,(make-data-register 'D (extract *ir 0 3))
- ,(make-pc-relative (lambda () (fetch-immediate 'W)))))
-
-(define (%Bcc/%BSR)
- (let ((cc (decode-cc (extract *ir 8 12)))
- (displacement (extract+ *ir 0 8)))
- ((access append system-global-environment)
- (cond ((eq? cc 'T) '(BRA))
- ((eq? cc 'F) '(BSR))
- (else `(B , cc)))
- (cond ((= displacement 0)
- `(W ,(make-pc-relative (lambda () (fetch-immediate 'W)))))
- ((= displacement -1)
- `(L ,(make-pc-relative (lambda () (fetch-immediate 'L)))))
- (else
- `(B ,(make-pc-relative (lambda () displacement))))))))
-
-(define (%MOVEQ)
- `(MOVEQ (& ,(extract+ *ir 0 8))
- ,(make-data-register 'D (extract *ir 9 12))))
-
-(define ((logical keyword))
- (let ((size (decode-bwl (extract *ir 6 8)))
- (register (extract *ir 9 12)))
- (if (= (extract *ir 8 9) #b0)
- `(,keyword ,size
- ,(decode-ea-d size)
- ,(make-data-register 'D register))
- `(,keyword ,size
- ,(make-data-register 'D register)
- ,(decode-ea-m&a)))))
-
-(define %OR (logical 'OR))
-(define %AND (logical 'AND))
-
-(define (%EOR)
- `(EOR ,(decode-bwl (extract *ir 6 8))
- ,(make-data-register 'D (extract *ir 9 12))
- ,(decode-ea-d&a)))
-\f
-(define ((binary keyword))
- (let ((size (decode-bwl (extract *ir 6 8)))
- (register (extract *ir 9 12)))
- (if (= (extract *ir 8 9) #b0)
- `(,keyword ,size
- ,(decode-ea-b=>-A size)
- ,(make-data-register 'D register))
- `(,keyword ,size
- ,(make-data-register 'D register)
- ,(decode-ea-m&a)))))
-
-(define %ADD (binary 'ADD))
-(define %SUB (binary 'SUB))
-
-(define (%CMP)
- (let ((size (decode-bwl (extract *ir 6 8))))
- `(CMP ,size
- ,(decode-ea-b=>-A size)
- ,(make-data-register 'D (extract *ir 9 12)))))
-
-(define ((binary-address keyword))
- (let ((size (decode-wl (extract *ir 8 9))))
- `(,keyword ,size
- ,(decode-ea-all size)
- ,(make-address-register 'A (extract *ir 9 12)))))
-
-(define %ADDA (binary-address 'ADD))
-(define %SUBA (binary-address 'SUB))
-(define %CMPA (binary-address 'CMP))
-
-(define ((binary-extended keyword))
- (define (receiver mode maker)
- `(,keyword ,(decode-bwl (extract *ir 6 8))
- ,(maker mode (extract *ir 0 3))
- ,(maker mode (extract *ir 9 12))))
- (if (= (extract *ir 3 4) #b0)
- (receiver 'D make-data-register)
- (receiver '@-A make-address-register)))
-
-(define %ADDX (binary-extended 'ADDX))
-(define %SUBX (binary-extended 'SUBX))
-
-(define (%CMPM)
- `(CMPM ,(decode-bwl (extract *ir 6 8))
- ,(make-address-register '@A+ (extract *ir 0 3))
- ,(make-address-register '@A+ (extract *ir 9 12))))
-\f
-(define ((binary-quick keyword))
- (let ((size (decode-bwl (extract *ir 6 8))))
- `(,keyword ,size
- (& ,(let ((n (extract *ir 9 12)))
- (if (zero? n) 8 n)))
- ,(decode-ea-a&<b=>-A> size))))
-
-(define %ADDQ (binary-quick 'ADDQ))
-(define %SUBQ (binary-quick 'SUBQ))
-
-(define ((decimal keyword))
- (define (receiver mode maker)
- `(,keyword ,(maker mode (extract *ir 0 3))
- ,(maker mode (extract *ir 9 12))))
- (if (= (extract *ir 3 4) #b0)
- (receiver 'D make-data-register)
- (receiver '@A- make-address-register)))
-
-(define %ABCD (decimal 'ABCD))
-(define %SBCD (decimal 'SBCD))
-
-(define ((%MUL/%DIV keyword))
- `(,keyword ,(decode-us (extract *ir 8 9))
- W
- ,(decode-ea-d 'W)
- ,(make-data-register 'D (extract *ir 9 12))))
-
-(define %MUL (%MUL/%DIV 'MUL))
-(define %DIV (%MUL/%DIV 'DIV))
-
-(define ((%MULL/%DIVL force-short? keyword1 keyword2))
- (let ((next (get-word)))
- (let ((dr (extract next 0 3))
- (dq (extract next 12 15)))
- (cond ((= (extract next 10 11) #b1)
- `(,keyword1 ,(decode-us (extract next 11 12))
- L
- ,(decode-ea-d 'L)
- ,(make-data-register 'D dr)
- ,(make-data-register 'D dq)))
- ((or force-short? (= dr dq))
- `(,keyword1 ,(decode-us (extract next 11 12))
- L
- ,(decode-ea-d 'L)
- ,(make-data-register 'D dq)))
- (else
- `(,keyword2 ,(decode-us (extract next 11 12))
- L
- ,(decode-ea-d 'L)
- ,(make-data-register 'D dr)
- ,(make-data-register 'D dq)))))))
-
-(define %MULL (%MULL/%DIVL true 'MUL 'MULL))
-(define %DIVL (%MULL/%DIVL false 'DIV 'DIVL))
-\f
-(define (%EXG)
- (let ((mode (if (= (extract *ir 3 4) #b0) 'D 'A)))
- `(EXG (,mode ,(extract *ir 0 3))
- (,mode ,(extract *ir 9 12)))))
-
-(define (%EXGM)
- `(EXG ,(make-address-register 'A (extract *ir 0 3))
- ,(make-data-register 'D (extract *ir 9 12))))
-
-(define (shift/rotate/bitop)
- (if (= #b11 (extract *ir 6 8))
- (bit-extract)
- (shift-rotate)))
-
-(define (shift-rotate)
- (let ((size (decode-bwl (extract *ir 6 8)))
- (direction (decode-rl (extract *ir 8 9))))
- (if (null? size)
- `(,(decode-shift-type (extract *ir 9 11))
- ,direction
- ,(decode-ea-m&a))
- `(,(decode-shift-type (extract *ir 3 5))
- ,direction
- ,size
- ,(if (= (extract *ir 5 6) #b0)
- `(& ,(let ((n (extract *ir 9 12)))
- (if (zero? n) 8 n)))
- `,(make-data-register 'D (extract *ir 9 12)))
- ,(make-data-register 'D (extract *ir 0 3))))))
-
-(define (bit-extract)
- (let* ((opcode (decode-bf (extract *ir 8 11)))
- (extension (get-word))
- (source (decode-ea-m&d)))
- (let ((target (if (memq opcode '(BFEXTS BFEXTU BFFFO BFINS))
- `(,(make-data-register 'D
- (extract extension 12 15)))
- '()))
- (offset (if (= #b0 (extract extension 11 12))
- `(& ,(extract extension 6 11))
- (make-data-register 'D (extract extension 6 9))))
- (width (if (= #b0 (extract extension 5 6))
- `(& ,(extract extension 0 5))
- (make-data-register 'D (extract extension 0 3)))))
- `(,opcode ,source ,offset ,width ,@target))))
-\f
-;;;
-;;; COPROCESSOR
-;;;
-
-(define (coprocessor)
- (if (= (coprocessor-id) floating-point-coprocessor-id)
- (floating-point-coprocessor)
- (undefined-instruction)))
-
-;;;
-;;; FLOATING POINT INSTRUCTIONS
-;;;
-
-(define floating-point-coprocessor-id #b001)
-
-(define (coprocessor-id)
- (extract *ir 9 12))
-
-(define (floating-point-coprocessor)
- (let* ((op-class-indicator (extract *ir 6 9))
- (opcode (extract (peek-word) 0 7)))
- (cond ((and (= op-class-indicator #b000)
- (= opcode #b0000000))
- (let ((ext (get-word)))
- (let ((keyword (get-fmove-keyword *ir ext)))
- (if (null? keyword)
- (undefined-instruction)
- (case keyword
- (FMOVE-TO-FP
- (decode-ordinary-floating-instruction 'FMOVE ext))
- (FMOVE-FROM-FP
- (let ((dst-fmt (floating-specifier->mnemonic
- (extract ext 10 13)))
- (src-reg (extract ext 7 10)))
- (if (eq? dst-fmt 'P)
- '(FMOVE packed decimal)
- `(FMOVE ,dst-fmt
- (FP ,src-reg)
- ,(decode-ea-d 'L)))))
- (FMOVE-FPcr
- (let ((reg
- (cdr (assoc (extract ext 10 13)
- '((#b001 . FPIAR)
- (#b010 . FPSR)
- (#b100 . FPCR))))))
- (if (= (extract ext 13 14) 1)
- `(FMOVE ,reg ,(decode-ea-d 'L))
- `(FMOVE ,(decode-ea-d 'L) ,reg))))
- (FMOVECR
- `(FMOVECR X (& ,(extract ext 0 7))
- (FP ,(extract ext 7 10))))
- (FMOVEM-FPn
- '(FMOVEM to FP-s))
- (FMOVEM-FPcr
- '(FMOVEM to CR-s)))))))
- ((= op-class-indicator #b000)
- (let ((ext (get-word))
- (opcode-name (floating-opcode->mnemonic opcode)))
- (decode-ordinary-floating-instruction opcode-name ext)))
- ((= (extract *ir 7 9) #b01)
- (let ((float-cc (decode-float-cc (extract *ir 0 6)))
- (size (extract *ir 6 7)))
- ((access append system-global-environment)
- `(FB ,float-cc)
- (if (= size 0)
- `(W ,(make-pc-relative (lambda () (fetch-immediate 'W))))
- `(L ,(make-pc-relative (lambda () (fetch-immediate 'L))))))))
- (else
- (undefined-instruction)))))
-\f
-(define (decode-ordinary-floating-instruction opcode-name ext)
- (let ((src-spec (extract ext 10 13))
- (rm (extract ext 14 15))
- (dst-reg (extract ext 7 10)))
- (if (= rm 1)
- `(,opcode-name
- ,(floating-specifier->mnemonic src-spec)
- ,(decode-ea-d 'L)
- (FP ,dst-reg))
- `(,opcode-name (FP ,src-spec) (FP ,dst-reg)))))
-
-(define (floating-opcode->mnemonic n)
- (let ((entry (assoc n
- '((#b0011000 . FABS)
- (#b0011100 . FACOS)
- (#b0100010 . FADD)
- (#b0001100 . FASIN)
- (#b0001010 . FATAN)
- (#b0001101 . FATANH)
- (#b0111000 . FCMP)
- (#b0011101 . FCOS)
- (#b0011001 . FCOSH)
- (#b0100000 . FDIV)
- (#b0010000 . FETOX)
- (#b0001000 . FETOXM1)
- (#b0011110 . FGETEXP)
- (#b0011111 . FGETMAN)
- (#b0000001 . FINT)
- (#b0000011 . FINTRZ)
- (#b0010101 . FLOG10)
- (#b0010110 . FLOG2)
- (#b0010100 . FLOGN)
- (#b0000110 . FLOGNP1)
- (#b0100001 . FMOD)
- (#b0100011 . FMUL)
- (#b0011010 . FNEG)
- (#b0100101 . FREM)
- (#b0100110 . FSCALE)
- (#b0100100 . FSGLDIV)
- (#b0100111 . FSGLMUL)
- (#b0001110 . FSIN)
- (#b0000010 . FSINH)
- (#b0000100 . FSQRT)
- (#b0101000 . FSUB)
- (#b0001111 . FTAN)
- (#b0001001 . FTANH)
- (#b0010010 . FTENTOX)
- (#b0111010 . FTST)
- (#b0010001 . FTWOTOX)))))
- (and entry
- (cdr entry))))
-
-(define (floating-specifier->mnemonic n)
- (let ((entry (assoc n
- '((0 . L)
- (1 . S)
- (2 . X)
- (3 . P)
- (4 . W)
- (5 . D)
- (6 . B)))))
- (and entry
- (cdr entry))))
-
-(define (decode-float-cc bits)
- (cdr (or (assv bits
- '((1 . EQ) (14 . NE)
- (2 . GT) (13 . NGT)
- (3 . GE) (12 . NGE)
- (4 . LT) (11 . NLT)
- (5 . LE) (10 . NLE)
- (6 . GL) (9 . NGL)
- (4 . MI) (3 . PL)
- (7 . GLE) (8 . NGLE)
- (0 . F) (15 . T)))
- (error "DECODE-FLOAT-CC: Unrecognized floating point condition code"
- bits))))
-\f
-(define (match-bits? high low pattern-list)
- (let high-loop ((i 15) (l pattern-list))
- (cond ((< i 0)
- (let low-loop ((i 15) (l l))
- (cond ((< i 0) #t)
- ((or (eq? (car l) '?)
- (eq? (if (bit-string-ref low i) 1 0)
- (car l)))
- (low-loop (-1+ i) (cdr l)))
- (else
- #f))))
- ((or (eq? (car l) '?)
- (eq? (if (bit-string-ref high i) 1 0)
- (car l)))
- (high-loop (-1+ i) (cdr l)))
- (else #f))))
-
-(define (get-fmove-keyword high low)
- (let loop ((l fmove-patterns))
- (cond ((null? l) '())
- ((match-bits? high low (caar l))
- (cdar l))
- (else
- (loop (cdr l))))))
-
-(define fmove-patterns
- '(((1 1 1 1 0 0 1 0 0 0 ? ? ? ? ? ?
- 0 ? 0 ? ? ? ? ? ? 0 0 0 0 0 0 0) . FMOVE-TO-FP)
- ((1 1 1 1 0 0 1 0 0 0 ? ? ? ? ? ?
- 0 1 1 ? ? ? ? ? ? ? ? ? ? ? ? ?) . FMOVE-FROM-FP)
- ((1 1 1 1 0 0 1 0 0 0 ? ? ? ? ? ?
- 1 0 ? ? ? ? 0 0 0 0 0 0 0 0 0 0) . FMOVE-FPcr)
- ((1 1 1 1 0 0 1 0 0 0 0 0 0 0 0 0
- 0 1 0 1 1 1 ? ? ? ? ? ? ? ? ? ?) . FMOVECR)
- ((1 1 1 1 0 0 1 0 0 0 ? ? ? ? ? ?
- 1 1 ? ? ? ? 0 0 0 ? ? ? ? ? ? ?) . FMOVEM-FPn)
- ((1 1 1 1 0 0 1 0 0 0 ? ? ? ? ? ?
- 1 0 ? ? ? ? 0 0 0 0 0 0 0 0 0 0) . FMOVEM-FPcr)))
-\f
-;;;; Bit String Manipulation
-
-(define (fetch-immediate size)
- (cond ((eq? size 'B) (extract+ (get-word) 0 8))
- ((eq? size 'W) (bit-string->signed-integer (get-word)))
- ((eq? size 'L) (bit-string->signed-integer (get-longword)))
- (else (error "Unknown size" 'FETCH-IMMEDIATE size))))
-
-(define (make-fetcher size-in-bits)
- (let ((size-in-bytes (quotient size-in-bits 8)))
- (lambda ()
- (let ((word (read-bits *current-offset size-in-bits)))
- (set! *current-offset (+ *current-offset size-in-bytes))
- word))))
-
-(define get-word (make-fetcher 16))
-(define get-longword (make-fetcher 32))
-
-(define (make-peeker size-in-bits)
- (lambda ()
- (read-bits *current-offset size-in-bits)))
-
-(define peek-word (make-peeker 16))
-(define peek-longword (make-peeker 32))
-
-(declare (integrate-operator extract extract+))
-
-(define (extract bit-string start end)
- (declare (integrate bit-string start end))
- (bit-string->unsigned-integer (bit-substring bit-string start end)))
-
-(define (extract+ bit-string start end)
- (declare (integrate bit-string start end))
- (bit-string->signed-integer (bit-substring bit-string start end)))
-
-;;; Symbolic representation of bit strings
-
-(define ((symbol-decoder symbols) index)
- (vector-ref symbols index))
-
-(define decode-bwl (symbol-decoder #(B W L ())))
-(define decode-wl (symbol-decoder #(W L)))
-(define decode-rl (symbol-decoder #(R L)))
-(define decode-us (symbol-decoder #(U S)))
-(define decode-da (symbol-decoder #(D A)))
-(define decode-cc
- (symbol-decoder #(T F HI LS CC CS NE EQ VC VS PL MI GE LT GT LE)))
-(define decode-bit (symbol-decoder #(BTST BCHG BCLR BSET)))
-(define decode-shift-type (symbol-decoder #(AS LS ROX RO)))
-(define decode-ze (symbol-decoder #(E Z)))
-
-(define decode-bf
- (symbol-decoder #(BFTST BFEXTU BFCHG BFEXTS BFCLR BFFFO BFSET BFINS)))
-
-(define (decode-scale scale)
- (vector-ref '#(1 2 4 8) scale))
-\f
-;;;; Effective Addressing
-
-(define (decode-ea-<D> register size)
- size ; ignored
- (make-data-register 'D register))
-
-(define (decode-ea-<A> register size)
- size ; ignored
- (make-address-register 'A register))
-
-(define (decode-ea-<b=>-A> register size)
- size ; ignored
- (if (memq size '(W L))
- (make-address-register 'A register)
- (undefined-instruction)))
-
-(define (decode-ea-<@A> register size)
- size ; ignored
- (make-address-register '@A register))
-
-(define (decode-ea-<@A+> register size)
- size ; ignored
- (make-address-register '@A+ register))
-
-(define (decode-ea-<@-A> register size)
- size ; ignored
- (make-address-register '@-A register))
-
-(define (decode-ea-<@AO> register size)
- size ; ignored
- (make-address-offset register
- (bit-string->signed-integer (get-word))))
-
-(define (decode-ea-<W> size)
- size ; ignored
- `(W ,(bit-string->signed-integer (get-word))))
-
-(define (decode-ea-<L> size)
- size ; ignored
- `(L ,(bit-string->signed-integer (get-longword))))
-
-(define (decode-ea-<@PCO> size)
- size ; ignored
- (make-pc-relative (lambda () (bit-string->signed-integer (get-word)))))
-
-(define (decode-ea-<&> size)
- (cond ((eq? size 'B) `(& ,(extract+ (get-word) 0 8)))
- ((eq? size 'W) `(& ,(bit-string->signed-integer (get-word))))
- ((eq? size 'L) `(& ,(bit-string->signed-integer (get-longword))))
- (else (error "Unknown size" 'DECODE-EA-<&> size))))
-\f
-;;;; Extended 68020 effective addresses
-
-(define (decode-ea-<@AOX> register size)
- size ; ignored
- (decode-ea-extension
- (lambda (d/a xr w/l scale brs irs bd od operation)
- (cond ((eq? (cadr bd) 'B)
- (if (= scale 1)
- ;; This is the only possibility on a 68000/68010
- `(,@(make-address-register '@AOX register) ,(car bd)
- ,d/a
- ,xr
- ,w/l)
- `(,@(make-address-register '@AOXS register) ,(car bd)
- (,d/a ,xr)
- ,w/l
- ,scale)))
- ((and (eq? d/a 'D) (eq? w/l 'L) (= scale 1)
- (eq? brs 'Z) (eq? irs 'E)
- (eq? (cadr od) 'N) (false? operation)
- (memq (cadr bd) '(N W)))
- (if (eq? (cadr bd) 'N)
- (make-data-register '@D xr)
- `(,@(make-data-register '@DO xr) ,(car bd))))
- (else
- `(,@(make-address-register '@AOF register) ,brs ,bd ,operation
- ((,d/a ,xr) ,w/l ,scale)
- ,irs ,od))))))
-
-(define (decode-ea-<@PCOX> size)
- size ; ignored
- (let ((base-offset *current-offset))
- (decode-ea-extension
- (lambda (d/a xr w/l scale brs irs bd od operation)
- (cond ((eq? (cadr bd) 'B)
- (if (= scale 1)
- ;; This is the only possibility on a 68000/68010
- `(@PCOX ,(car bd) ,d/a ,xr ,w/l)
- `(@PCOXS ,(car bd) (,d/a ,xr) ,w/l ,scale)))
- ((and (eq? brs 'E) (eq? irs 'Z) (false? operation)
- (not (eq? (cadr bd) 'N)) (eq? (cadr od) 'N))
- (offset->pc-relative (car bd) base-offset))
- (else
- `(@PCOF ,brs ,bd ,operation
- ((,d/a ,xr) ,w/l ,scale)
- ,irs ,od)))))))
-\f
-(define (decode-ea-extension receiver)
- (let ((extension (get-word)))
- (let ((d/a (decode-da (extract extension 15 16)))
- (xr (extract extension 12 15))
- (w/l (decode-wl (extract extension 11 12)))
- (scale (decode-scale (extract extension 9 11))))
- (if (not (bit-string-ref extension 8))
- (receiver d/a xr w/l scale 'E 'E
- `(,(extract+ extension 0 8) B)
- '(0 N)
- #F)
- (let ((brs (decode-ze (extract extension 7 8)))
- (irs (decode-ze (extract extension 6 7)))
- (i/is (extract extension 0 3))
- (bd (case (extract extension 4 6)
- ((1) '(0 N))
- ((2) `(,(fetch-immediate 'W) W))
- ((3) `(,(fetch-immediate 'L) L))
- (else
- #| (error "decode-ea-extension: bad bd-size"
- (extract extension 4 6)) |#
- (undefined-instruction)))))
- (receiver d/a xr w/l scale brs irs bd
- (case (if (> i/is 3) (- i/is 4) i/is)
- ((0 1) '(0 N))
- ((2) `(,(fetch-immediate 'W) W))
- ((3) `(,(fetch-immediate 'L) L))
- (else
- #| (error "decode-ea-extension: bad i/is" i/is) |#
- (undefined-instruction)))
- (cond ((zero? i/is) #F)
- ((> i/is 3) 'POST)
- (else 'PRE))))))))
-\f
-(define make-ea-dispatch
- (let ()
- (define (kernel dispatch mode-7)
- (vector-set! dispatch 7
- (lambda (register size)
- ((vector-ref mode-7 register) size)))
- (lambda (mode register size)
- ((vector-ref dispatch mode) register size)))
-
- (lambda (d a @a @a+ @-a @ao @aox w l @pco @pcox &)
- (kernel (vector d a @a @a+ @-a @ao @aox '())
- (vector w l @pco @pcox &
- decode-ea-mode-7-undefined
- decode-ea-mode-7-undefined
- decode-ea-mode-7-undefined)))))
-
-(define (decode-ea-with-size d a @a @a+ @-a @ao @aox w l @pco @pcox &)
- (let ((kernel (make-ea-dispatch d a @a @a+ @-a @ao @aox w l @pco @pcox &)))
- (lambda (size)
- (kernel (extract *ir 3 6)
- (extract *ir 0 3)
- size))))
-
-(define (decode-ea-w/o-size d a @a @a+ @-a @ao @aox w l @pco @pcox &)
- (let ((kernel (make-ea-dispatch d a @a @a+ @-a @ao @aox w l @pco @pcox &)))
- (lambda ()
- (kernel (extract *ir 3 6)
- (extract *ir 0 3)
- '()))))
-
-(define (decode-ea-undefined register size)
- register size ; ignored
- (undefined-instruction))
-
-(define (decode-ea-mode-7-undefined size)
- size ; ignored
- (undefined-instruction))
-
-(define decode-ea-d
- (decode-ea-with-size decode-ea-<D>
- decode-ea-undefined
- decode-ea-<@A>
- decode-ea-<@A+>
- decode-ea-<@-A>
- decode-ea-<@AO>
- decode-ea-<@AOX>
- decode-ea-<W>
- decode-ea-<L>
- decode-ea-<@PCO>
- decode-ea-<@PCOX>
- decode-ea-<&>))
-
-(define decode-ea-m&d
- (decode-ea-w/o-size decode-ea-<D>
- decode-ea-undefined
- decode-ea-<@A>
- decode-ea-undefined
- decode-ea-undefined
- decode-ea-<@AO>
- decode-ea-<@AOX>
- decode-ea-<W>
- decode-ea-<L>
- decode-ea-<@PCO>
- decode-ea-<@PCOX>
- decode-ea-undefined))
-\f
-(define decode-ea-c
- (decode-ea-w/o-size decode-ea-undefined
- decode-ea-undefined
- decode-ea-<@A>
- decode-ea-undefined
- decode-ea-undefined
- decode-ea-<@AO>
- decode-ea-<@AOX>
- decode-ea-<W>
- decode-ea-<L>
- decode-ea-<@PCO>
- decode-ea-<@PCOX>
- decode-ea-mode-7-undefined))
-
-(define decode-ea-d&a
- (decode-ea-w/o-size decode-ea-<D>
- decode-ea-undefined
- decode-ea-<@A>
- decode-ea-<@A+>
- decode-ea-<@-A>
- decode-ea-<@AO>
- decode-ea-<@AOX>
- decode-ea-<W>
- decode-ea-<L>
- decode-ea-mode-7-undefined
- decode-ea-mode-7-undefined
- decode-ea-mode-7-undefined))
-
-(define decode-ea-c&a
- (decode-ea-with-size decode-ea-undefined
- decode-ea-undefined
- decode-ea-<@A>
- decode-ea-undefined
- decode-ea-undefined
- decode-ea-<@AO>
- decode-ea-<@AOX>
- decode-ea-<W>
- decode-ea-<L>
- decode-ea-mode-7-undefined
- decode-ea-mode-7-undefined
- decode-ea-mode-7-undefined))
-\f
-(define decode-ea-m&a
- (decode-ea-w/o-size decode-ea-undefined
- decode-ea-undefined
- decode-ea-<@A>
- decode-ea-<@A+>
- decode-ea-<@-A>
- decode-ea-<@AO>
- decode-ea-<@AOX>
- decode-ea-<W>
- decode-ea-<L>
- decode-ea-mode-7-undefined
- decode-ea-mode-7-undefined
- decode-ea-mode-7-undefined))
-
-(define decode-ea-all
- (decode-ea-with-size decode-ea-<D>
- decode-ea-<A>
- decode-ea-<@A>
- decode-ea-<@A+>
- decode-ea-<@-A>
- decode-ea-<@AO>
- decode-ea-<@AOX>
- decode-ea-<W>
- decode-ea-<L>
- decode-ea-<@PCO>
- decode-ea-<@PCOX>
- decode-ea-<&>))
-
-(define decode-ea-b=>-A
- (decode-ea-with-size decode-ea-<D>
- decode-ea-<b=>-A>
- decode-ea-<@A>
- decode-ea-<@A+>
- decode-ea-<@-A>
- decode-ea-<@AO>
- decode-ea-<@AOX>
- decode-ea-<W>
- decode-ea-<L>
- decode-ea-<@PCO>
- decode-ea-<@PCOX>
- decode-ea-<&>))
-\f
-(define decode-ea-a&<b=>-A>
- (decode-ea-with-size decode-ea-<D>
- decode-ea-<b=>-A>
- decode-ea-<@A>
- decode-ea-<@A+>
- decode-ea-<@-A>
- decode-ea-<@AO>
- decode-ea-<@AOX>
- decode-ea-<W>
- decode-ea-<L>
- decode-ea-mode-7-undefined
- decode-ea-mode-7-undefined
- decode-ea-mode-7-undefined))
-
-(define decode-ea-MOVE-destination
- (let ((kernel (make-ea-dispatch decode-ea-<D>
- decode-ea-<A>
- decode-ea-<@A>
- decode-ea-<@A+>
- decode-ea-<@-A>
- decode-ea-<@AO>
- decode-ea-<@AOX>
- decode-ea-<W>
- decode-ea-<L>
- decode-ea-mode-7-undefined
- decode-ea-mode-7-undefined
- decode-ea-mode-7-undefined)))
- (lambda (size)
- (kernel (extract *ir 6 9)
- (extract *ir 9 12)
- size))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Compiler File Dependencies
-;;; package: (compiler declarations)
-
-(declare (usual-integrations))
-\f
-(define (initialize-package!)
- (add-event-receiver! event:after-restore reset-source-nodes!)
- (reset-source-nodes!))
-
-(define (reset-source-nodes!)
- (set! source-filenames '())
- (set! source-hash)
- (set! source-nodes)
- (set! source-nodes/by-rank)
- unspecific)
-
-(define (maybe-setup-source-nodes!)
- (if (null? source-filenames)
- (setup-source-nodes!)))
-
-(define (setup-source-nodes!)
- (let ((filenames
- (append-map!
- (lambda (subdirectory)
- (map (lambda (pathname)
- (string-append subdirectory
- "/"
- (pathname-name pathname)))
- (directory-read
- (string-append subdirectory
- "/"
- source-file-expression))))
- '("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt"
- "machines/bobcat"))))
- (if (null? filenames)
- (error "Can't find source files of compiler"))
- (set! source-filenames filenames))
- (set! source-hash (make-string-hash-table))
- (set! source-nodes
- (map (lambda (filename)
- (let ((node (make/source-node filename)))
- (hash-table/put! source-hash filename node)
- node))
- source-filenames))
- (initialize/syntax-dependencies!)
- (initialize/integration-dependencies!)
- (source-nodes/rank!))
-
-(define source-file-expression "*.scm")
-(define source-filenames)
-(define source-hash)
-(define source-nodes)
-(define source-nodes/by-rank)
-
-(define (filename/append directory . names)
- (map (lambda (name) (string-append directory "/" name)) names))
-\f
-(define-structure (source-node
- (conc-name source-node/)
- (constructor %make/source-node (filename pathname)))
- (filename #f read-only #t)
- (pathname #f read-only #t)
- (forward-links '())
- (backward-links '())
- (forward-closure '())
- (backward-closure '())
- (dependencies '())
- (dependents '())
- (rank #f)
- (syntax-table #f)
- (declarations '())
- (modification-time #f))
-
-(define (make/source-node filename)
- (%make/source-node filename (->pathname filename)))
-
-(define (filename->source-node filename)
- (let ((node (hash-table/get source-hash filename #f)))
- (if (not node)
- (error "Unknown source file:" filename))
- node))
-
-(define (source-node/circular? node)
- (memq node (source-node/backward-closure node)))
-
-(define (source-node/link! node dependency)
- (if (not (memq dependency (source-node/backward-links node)))
- (begin
- (set-source-node/backward-links!
- node
- (cons dependency (source-node/backward-links node)))
- (set-source-node/forward-links!
- dependency
- (cons node (source-node/forward-links dependency)))
- (source-node/close! node dependency))))
-
-(define (source-node/close! node dependency)
- (if (not (memq dependency (source-node/backward-closure node)))
- (begin
- (set-source-node/backward-closure!
- node
- (cons dependency (source-node/backward-closure node)))
- (set-source-node/forward-closure!
- dependency
- (cons node (source-node/forward-closure dependency)))
- (for-each (lambda (dependency)
- (source-node/close! node dependency))
- (source-node/backward-closure dependency))
- (for-each (lambda (node)
- (source-node/close! node dependency))
- (source-node/forward-closure node)))))
-\f
-;;;; Rank
-
-(define (source-nodes/rank!)
- (compute-dependencies! source-nodes)
- (compute-ranks! source-nodes)
- (set! source-nodes/by-rank (source-nodes/sort-by-rank source-nodes))
- unspecific)
-
-(define (compute-dependencies! nodes)
- (for-each (lambda (node)
- (set-source-node/dependencies!
- node
- (list-transform-negative (source-node/backward-closure node)
- (lambda (node*)
- (memq node (source-node/backward-closure node*)))))
- (set-source-node/dependents!
- node
- (list-transform-negative (source-node/forward-closure node)
- (lambda (node*)
- (memq node (source-node/forward-closure node*))))))
- nodes))
-
-(define (compute-ranks! nodes)
- (let loop ((nodes nodes) (unranked-nodes '()))
- (if (null? nodes)
- (if (not (null? unranked-nodes))
- (loop unranked-nodes '()))
- (loop (cdr nodes)
- (let ((node (car nodes)))
- (let ((rank (source-node/rank* node)))
- (if rank
- (begin
- (set-source-node/rank! node rank)
- unranked-nodes)
- (cons node unranked-nodes))))))))
-
-(define (source-node/rank* node)
- (let loop ((nodes (source-node/dependencies node)) (rank -1))
- (if (null? nodes)
- (1+ rank)
- (let ((rank* (source-node/rank (car nodes))))
- (and rank*
- (loop (cdr nodes) (max rank rank*)))))))
-
-(define (source-nodes/sort-by-rank nodes)
- (sort nodes (lambda (x y) (< (source-node/rank x) (source-node/rank y)))))
-\f
-;;;; File Syntaxer
-
-(define (syntax-files!)
- (maybe-setup-source-nodes!)
- (for-each
- (lambda (node)
- (let ((modification-time
- (let ((source (modification-time node "scm"))
- (binary (modification-time node "bin")))
- (if (not source)
- (error "Missing source file" (source-node/filename node)))
- (and binary (< source binary) binary))))
- (set-source-node/modification-time! node modification-time)
- (if (not modification-time)
- (begin (write-string "\nSource file newer than binary: ")
- (write (source-node/filename node))))))
- source-nodes)
- (if compiler:enable-integration-declarations?
- (begin
- (for-each
- (lambda (node)
- (let ((time (source-node/modification-time node)))
- (if (and time
- (there-exists? (source-node/dependencies node)
- (lambda (node*)
- (let ((newer?
- (let ((time*
- (source-node/modification-time node*)))
- (or (not time*)
- (> time* time)))))
- (if newer?
- (begin
- (write-string "\nBinary file ")
- (write (source-node/filename node))
- (write-string " newer than dependency ")
- (write (source-node/filename node*))))
- newer?))))
- (set-source-node/modification-time! node #f))))
- source-nodes)
- (for-each
- (lambda (node)
- (if (not (source-node/modification-time node))
- (for-each (lambda (node*)
- (if (source-node/modification-time node*)
- (begin
- (write-string "\nBinary file ")
- (write (source-node/filename node*))
- (write-string " depends on ")
- (write (source-node/filename node))))
- (set-source-node/modification-time! node* #f))
- (source-node/forward-closure node))))
- source-nodes)))
- (for-each (lambda (node)
- (if (not (source-node/modification-time node))
- (pathname-delete!
- (pathname-new-type (source-node/pathname node) "ext"))))
- source-nodes/by-rank)
- (write-string "\n\nBegin pass 1:")
- (for-each (lambda (node)
- (if (not (source-node/modification-time node))
- (source-node/syntax! node)))
- source-nodes/by-rank)
- (if (there-exists? source-nodes/by-rank
- (lambda (node)
- (and (not (source-node/modification-time node))
- (source-node/circular? node))))
- (begin
- (write-string "\n\nBegin pass 2:")
- (for-each (lambda (node)
- (if (not (source-node/modification-time node))
- (if (source-node/circular? node)
- (source-node/syntax! node)
- (source-node/touch! node))))
- source-nodes/by-rank))))
-\f
-(define (source-node/touch! node)
- (with-values
- (lambda ()
- (sf/pathname-defaulting (source-node/pathname node) "" #f))
- (lambda (input-pathname bin-pathname spec-pathname)
- input-pathname
- (pathname-touch! bin-pathname)
- (pathname-touch! (pathname-new-type bin-pathname "ext"))
- (if spec-pathname (pathname-touch! spec-pathname)))))
-
-(define (pathname-touch! pathname)
- (if (file-exists? pathname)
- (begin
- (write-string "\nTouch file: ")
- (write (enough-namestring pathname))
- (file-touch pathname))))
-
-(define (pathname-delete! pathname)
- (if (file-exists? pathname)
- (begin
- (write-string "\nDelete file: ")
- (write (enough-namestring pathname))
- (delete-file pathname))))
-
-(define (sc filename)
- (maybe-setup-source-nodes!)
- (source-node/syntax! (filename->source-node filename)))
-
-(define (source-node/syntax! node)
- (with-values
- (lambda ()
- (sf/pathname-defaulting (source-node/pathname node) "" #f))
- (lambda (input-pathname bin-pathname spec-pathname)
- (sf/internal
- input-pathname bin-pathname spec-pathname
- (source-node/syntax-table node)
- ((if compiler:enable-integration-declarations?
- identity-procedure
- (lambda (declarations)
- (list-transform-negative declarations
- integration-declaration?)))
- (source-node/declarations node))))))
-
-(define-integrable (modification-time node type)
- (file-modification-time
- (pathname-new-type (source-node/pathname node) type)))
-\f
-;;;; Syntax dependencies
-
-(define (initialize/syntax-dependencies!)
- (let ((file-dependency/syntax/join
- (lambda (filenames syntax-table)
- (for-each (lambda (filename)
- (set-source-node/syntax-table!
- (filename->source-node filename)
- syntax-table))
- filenames))))
- (file-dependency/syntax/join
- (append (filename/append "base"
- "toplev" "asstop" "crstop"
- "blocks" "cfg1" "cfg2" "cfg3" "constr"
- "contin" "ctypes" "debug" "enumer"
- "infnew" "lvalue" "object" "pmerly" "proced"
- "refctx" "rvalue" "scode" "sets" "subprb"
- "switch" "utils")
- (filename/append "back"
- "asmmac" "bittop" "bitutl" "insseq" "lapgn1"
- "lapgn2" "lapgn3" "linear" "regmap" "symtab"
- "syntax")
- (filename/append "machines/bobcat"
- "dassm1" "insmac" "lapopt" "machin" "rgspcm"
- "rulrew")
- (filename/append "fggen"
- "declar" "fggen" "canon")
- (filename/append "fgopt"
- "blktyp" "closan" "conect" "contan" "delint"
- "desenv" "envopt" "folcon" "offset" "operan"
- "order" "outer" "param" "reord" "reteqv" "reuse"
- "sideff" "simapp" "simple" "subfre" "varind")
- (filename/append "rtlbase"
- "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp"
- "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2"
- "valclass")
- (filename/append "rtlgen"
- "fndblk" "fndvar" "opncod" "rgcomb" "rgproc"
- "rgretn" "rgrval" "rgstmt" "rtlgen")
- (filename/append "rtlopt"
- "ralloc" "rcompr" "rcse1" "rcse2" "rcseep"
- "rcseht" "rcserq" "rcsesr" "rdebug" "rdflow"
- "rerite" "rinvex" "rlife" "rtlcsm"))
- (->environment '(COMPILER)))
- (file-dependency/syntax/join
- (filename/append "machines/bobcat"
- "lapgen" "rules1" "rules2" "rules3" "rules4"
- "insutl" "instr1" "instr2" "instr3" "instr4"
- "flinstr1" "flinstr2")
- (->environment '(COMPILER LAP-SYNTAXER)))))
-\f
-;;;; Integration Dependencies
-
-(define (initialize/integration-dependencies!)
-
- (define (add-declaration! declaration filenames)
- (for-each (lambda (filenames)
- (let ((node (filename->source-node filenames)))
- (set-source-node/declarations!
- node
- (cons declaration
- (source-node/declarations node)))))
- filenames))
-
- (let* ((front-end-base
- (filename/append "base"
- "blocks" "cfg1" "cfg2" "cfg3"
- "contin" "ctypes" "enumer" "lvalue"
- "object" "proced" "rvalue"
- "scode" "subprb" "utils"))
- (bobcat-base
- (append (filename/append "machines/bobcat" "machin")
- (filename/append "back" "asutl")))
- (rtl-base
- (filename/append "rtlbase"
- "rgraph" "rtlcfg" "rtlobj" "rtlreg" "rtlty1"
- "rtlty2"))
- (cse-base
- (filename/append "rtlopt"
- "rcse1" "rcseht" "rcserq" "rcsesr"))
- (cse-all
- (append (filename/append "rtlopt"
- "rcse2" "rcseep")
- cse-base))
- (instruction-base
- (filename/append "machines/bobcat" "assmd" "machin"))
- (lapgen-base
- (append (filename/append "back" "linear" "regmap")
- (filename/append "machines/bobcat" "lapgen")))
- (assembler-base
- (append (filename/append "back" "symtab")
- (filename/append "machines/bobcat" "insutl")))
- (lapgen-body
- (append
- (filename/append "back" "lapgn1" "lapgn2" "syntax")
- (filename/append "machines/bobcat"
- "rules1" "rules2" "rules3" "rules4")))
- (assembler-body
- (append
- (filename/append "back" "bittop")
- (filename/append "machines/bobcat"
- "instr1" "instr2" "instr3" "instr4"
- "flinstr1" "flinstr2"))))
-
- (define (file-dependency/integration/join filenames dependencies)
- (for-each (lambda (filename)
- (file-dependency/integration/make filename dependencies))
- filenames))
-
- (define (file-dependency/integration/make filename dependencies)
- (let ((node (filename->source-node filename)))
- (for-each (lambda (dependency)
- (let ((node* (filename->source-node dependency)))
- (if (not (eq? node node*))
- (source-node/link! node node*))))
- dependencies)))
-
- (define (define-integration-dependencies directory name directory* . names)
- (file-dependency/integration/make
- (string-append directory "/" name)
- (apply filename/append directory* names)))
-
- (define-integration-dependencies "machines/bobcat" "machin" "back" "asutl")
- (define-integration-dependencies "base" "object" "base" "enumer")
- (define-integration-dependencies "base" "enumer" "base" "object")
- (define-integration-dependencies "base" "utils" "base" "scode")
- (define-integration-dependencies "base" "cfg1" "base" "object")
- (define-integration-dependencies "base" "cfg2" "base"
- "cfg1" "cfg3" "object")
- (define-integration-dependencies "base" "cfg3" "base" "cfg1" "cfg2")
- (define-integration-dependencies "base" "ctypes" "base"
- "blocks" "cfg1" "cfg2" "cfg3" "contin" "lvalue" "object" "subprb")
- (define-integration-dependencies "base" "rvalue" "base"
- "blocks" "cfg1" "cfg2" "cfg3" "enumer" "lvalue" "object" "utils")
- (define-integration-dependencies "base" "lvalue" "base"
- "blocks" "object" "proced" "rvalue" "utils")
- (define-integration-dependencies "base" "blocks" "base"
- "enumer" "lvalue" "object" "proced" "rvalue" "scode")
- (define-integration-dependencies "base" "proced" "base"
- "blocks" "cfg1" "cfg2" "cfg3" "contin" "enumer" "lvalue" "object"
- "rvalue" "utils")
- (define-integration-dependencies "base" "contin" "base"
- "blocks" "cfg3" "ctypes")
- (define-integration-dependencies "base" "subprb" "base"
- "cfg3" "contin" "enumer" "object" "proced")
-
- (define-integration-dependencies "machines/bobcat" "machin" "rtlbase"
- "rtlreg" "rtlty1" "rtlty2")
-
- (define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2")
- (define-integration-dependencies "rtlbase" "rgraph" "machines/bobcat"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlcfg" "base"
- "cfg1" "cfg2" "cfg3")
- (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils")
- (define-integration-dependencies "rtlbase" "rtlcon" "machines/bobcat"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlexp" "rtlbase"
- "rtlreg" "rtlty1")
- (define-integration-dependencies "rtlbase" "rtline" "base" "cfg1" "cfg2")
- (define-integration-dependencies "rtlbase" "rtline" "rtlbase"
- "rtlcfg" "rtlty2")
- (define-integration-dependencies "rtlbase" "rtlobj" "base"
- "cfg1" "object" "utils")
- (define-integration-dependencies "rtlbase" "rtlreg" "machines/bobcat"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlreg" "rtlbase"
- "rgraph" "rtlty1")
- (define-integration-dependencies "rtlbase" "rtlty1" "rtlbase" "rtlcfg")
- (define-integration-dependencies "rtlbase" "rtlty2" "base" "scode")
- (define-integration-dependencies "rtlbase" "rtlty2" "machines/bobcat"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlty2" "rtlbase" "rtlty1")
-
- (file-dependency/integration/join
- (append
- (filename/append "base" "refctx")
- (filename/append "fggen"
- "declar" "fggen") ; "canon" needs no integrations
- (filename/append "fgopt"
- "blktyp" "closan" "conect" "contan" "delint" "desenv"
- "envopt" "folcon" "offset" "operan" "order" "param"
- "outer" "reuse" "reteqv" "sideff" "simapp" "simple"
- "subfre" "varind"))
- (append bobcat-base front-end-base))
-
- (define-integration-dependencies "fgopt" "reuse" "fgopt" "reord")
-
- (file-dependency/integration/join
- (filename/append "rtlgen"
- "fndblk" "fndvar" "opncod" "rgcomb" "rgproc" "rgretn"
- "rgrval" "rgstmt" "rtlgen")
- (append bobcat-base front-end-base rtl-base))
-
- (file-dependency/integration/join
- (append cse-all
- (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow"
- "rerite" "rinvex" "rlife" "rtlcsm")
- (filename/append "machines/bobcat" "rulrew"))
- (append bobcat-base rtl-base))
-
- (file-dependency/integration/join cse-all cse-base)
-
- (file-dependency/integration/join
- (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife")
- (filename/append "rtlbase" "regset"))
-
- (file-dependency/integration/join
- (filename/append "rtlopt" "rcseht" "rcserq")
- (filename/append "base" "object"))
-
- (define-integration-dependencies "rtlopt" "rlife" "base" "cfg2")
-
- (let ((dependents
- (append instruction-base
- lapgen-base
- lapgen-body
- assembler-base
- assembler-body
- (filename/append "back" "linear" "syerly"))))
- (add-declaration! '(USUAL-DEFINITION (SET EXPT)) dependents)
- (file-dependency/integration/join dependents instruction-base))
-
- (file-dependency/integration/join (append lapgen-base lapgen-body)
- lapgen-base)
-
- (file-dependency/integration/join (append assembler-base assembler-body)
- assembler-base)
-
- (define-integration-dependencies "back" "lapgn1" "base"
- "cfg1" "cfg2" "utils")
- (define-integration-dependencies "back" "lapgn1" "rtlbase"
- "rgraph" "rtlcfg")
- (define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg")
- (define-integration-dependencies "back" "linear" "base" "cfg1" "cfg2")
- (define-integration-dependencies "back" "linear" "rtlbase" "rtlcfg")
- (define-integration-dependencies "back" "mermap" "back" "regmap")
- (define-integration-dependencies "back" "regmap" "base" "utils")
- (define-integration-dependencies "back" "symtab" "base" "utils"))
-
- (for-each (lambda (node)
- (let ((links (source-node/backward-links node)))
- (if (not (null? links))
- (set-source-node/declarations!
- node
- (cons (make-integration-declaration
- (source-node/pathname node)
- (map source-node/pathname links))
- (source-node/declarations node))))))
- source-nodes))
-
-(define (make-integration-declaration pathname integration-dependencies)
- `(INTEGRATE-EXTERNAL
- ,@(map (let ((default
- (make-pathname
- #f
- #f
- (cons 'RELATIVE
- (make-list
- (length (cdr (pathname-directory pathname)))
- 'UP))
- #f
- #f
- #f)))
- (lambda (pathname)
- (merge-pathnames pathname default)))
- integration-dependencies)))
-
-(define-integrable (integration-declaration? declaration)
- (eq? (car declaration) 'INTEGRATE-EXTERNAL))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Instruction set description for 68881 floating point processor
-;;; Originally provided courtesy of BBN ACI.
-
-;;; These instructions are not handled: FDBcc FMOVECR FMOVEM FNOP FRESTORE FSAVE
-;;; FScc FSINCOS FTRAPcc
-
-(declare (usual-integrations))
-\f
-(define FPC #b001) ; Floating point chip identifier for
- ; coprocessor instructions.
-(define-symbol-transformer
- float-source-format
- (L . 0) ; long word integer
- (S . 1) ; single precision real
- (X . 2) ; extended precision real
- (P . 3) ; packed decimal real
- (W . 4) ; word integer
- (D . 5) ; double precision real
- (B . 6)) ; byte integer
-
-(define-symbol-transformer
- float-destination-format
- (L . 0) ; long word integer
- (S . 1) ; single precision real
- (X . 2) ; extended precision real
- (W . 4) ; word integer
- (D . 5) ; double precision real
- (B . 6)) ; byte integer
-
-(define-symbol-transformer float-reg
- (FP0 . 0) (FP1 . 1) (FP2 . 2) (FP3 . 3)
- (FP4 . 4) (FP5 . 5) (FP6 . 6) (FP7 . 7))
-
-(define-symbol-transformer float-ctl-reg
- (FPCR . 4) (FPSR . 2) (FPIAR 1))
-
-(define-symbol-transformer float-cc
- (EQ . 1) (NE . 14) (GT . 2) (NGT . 13)
- (GE . 3) (NGE . 12) (LT . 4) (NLT . 11)
- (LE . 5) (NLE . 10) (GL . 6) (NGL . 9)
- (MI . 4) (PL . 3)
- (GLE . 7) (NGLE . 8) (F . 0) (T . 15))
-\f
-(define-instruction FMOVE
-
- (((? type float-source-format) (? source ea-d) (? destination float-reg))
- (WORD (4 #b1111)
- (3 FPC)
- (3 #b000)
- (6 source SOURCE-EA 'L))
- (EXTENSION-WORD (3 #b010)
- (3 type)
- (3 destination)
- (7 #b0000000)))
-
- (((? source float-reg) (? destination float-reg))
- (WORD (4 #b1111)
- (3 FPC)
- (3 #b000)
- (6 #b000000))
- (EXTENSION-WORD (3 #b000)
- (3 source)
- (3 destination)
- (7 #b0000000)))
-
- (((? type float-destination-format)
- (? source float-reg)
- (? destination ea-d&a))
- (WORD (4 #b1111)
- (3 FPC)
- (3 #b000)
- (6 destination DESTINATION-EA 'L))
- (EXTENSION-WORD (3 #b011)
- (3 type)
- (3 source)
- (7 #b0000000)))
-
- (((P (? k-factor)) (? source float-reg) (? destination ea-d&a))
- (WORD (4 #b1111)
- (3 FPC)
- (3 #b000)
- (6 destination DESTINATION-EA 'L))
- (EXTENSION-WORD (3 #b011)
- (3 #b011)
- (3 source)
- (7 k-factor)))
-
- (((PD (? k-reg)) (? source float-reg) (? destination ea-d&a))
- (WORD (4 #b1111)
- (3 FPC)
- (3 #b000)
- (6 destination DESTINATION-EA 'L))
- (EXTENSION-WORD (3 #b011)
- (3 #b111)
- (3 source)
- (3 k-reg)
- (4 #b0000)))
-
- ((L (? source ea-d) (? destination float-ctl-reg))
- (WORD (4 #b1111)
- (3 FPC)
- (3 #b000)
- (6 source SOURCE-EA 'L))
- (EXTENSION-WORD (3 #b100)
- (3 destination)
- (10 #b0000000000)))
-
- ((L (? source float-ctl-reg) (? destination ea-d))
- (WORD (4 #b1111)
- (3 FPC)
- (3 #b000)
- (6 destination DESTINATION-EA 'L))
- (EXTENSION-WORD (3 #b101)
- (3 source)
- (10 #b0000000000))))
-\f
-(let-syntax
- ((define-unary-flop
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
-
- (((? type float-source-format)
- (? source ea-d)
- (? destination float-reg))
- (WORD (4 #b1111)
- (3 FPC)
- (3 #b000)
- (6 source SOURCE-EA 'L))
- (EXTENSION-WORD (3 #b010)
- (3 type)
- (3 destination)
- (7 ,(caddr form))))
-
- (((? source float-reg) (? destination float-reg))
- (WORD (4 #b1111)
- (3 FPC)
- (3 #b000)
- (6 #b000000))
- (EXTENSION-WORD (3 #b000)
- (3 source)
- (3 destination)
- (7 ,(caddr form))))
-
- (((? reg float-reg))
- (WORD (4 #b1111)
- (3 FPC)
- (3 #b000)
- (6 #b000000))
- (EXTENSION-WORD (3 #b000)
- (3 reg)
- (3 reg)
- (7 ,(caddr form)))))))))
- (define-unary-flop FABS #b0011000)
- (define-unary-flop FACOS #b0011100)
- (define-unary-flop FASIN #b0001100)
- (define-unary-flop FATAN #b0001010)
- (define-unary-flop FATANH #b0001101)
- (define-unary-flop FCOS #b0011101)
- (define-unary-flop FCOSH #b0011001)
- (define-unary-flop FETOX #b0010000)
- (define-unary-flop FETOXM1 #b0001000)
- (define-unary-flop FGETEXP #b0011110)
- (define-unary-flop FGETMAN #b0011111)
- (define-unary-flop FINT #b0000001)
- (define-unary-flop FINTRZ #b0000011)
- (define-unary-flop FLOG10 #b0010101)
- (define-unary-flop FLOG2 #b0010110)
- (define-unary-flop FLOGN #b0010100)
- (define-unary-flop FLOGNP1 #b0000110)
- (define-unary-flop FNEG #b0011010)
- (define-unary-flop FSIN #b0001110)
- (define-unary-flop FSINH #b0000010)
- (define-unary-flop FSQRT #b0000100)
- (define-unary-flop FTAN #b0001111)
- (define-unary-flop FTANH #b0001001)
- (define-unary-flop FTENTOX #b0010010)
- (define-unary-flop FTWOTOX #b0010001))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Instruction set description for 68881 floating point processor
-;;; Originally provided courtesy of BBN ACI.
-
-(declare (usual-integrations))
-\f
-(let-syntax
- ((define-binary-flop
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
-
- (((? type float-source-format)
- (? source ea-d)
- (? destination float-reg))
- (WORD (4 #b1111)
- (3 FPC)
- (3 #b000)
- (6 source SOURCE-EA 'L))
- (EXTENSION-WORD (3 #b010)
- (3 type)
- (3 destination)
- (7 ,(caddr form))))
-
- (((? source float-reg) (? destination float-reg))
- (WORD (4 #b1111)
- (3 FPC)
- (3 #b000)
- (6 #b000000))
- (EXTENSION-WORD (3 #b000)
- (3 source)
- (3 destination)
- (7 ,(caddr form)))))))))
- (define-binary-flop FADD #b0100010)
- (define-binary-flop FCMP #b0111000)
- (define-binary-flop FDIV #b0100000)
- (define-binary-flop FMOD #b0100001)
- (define-binary-flop FMUL #b0100011)
- (define-binary-flop FREM #b0100101)
- (define-binary-flop FSCALE #b0100110)
- (define-binary-flop FSGLDIV #b0100100)
- (define-binary-flop FSGLMUL #b0100111)
- (define-binary-flop FSUB #b0101000))
-
-(define-instruction FTST
-
- (((? type float-source-format) (? ea ea-d))
- (WORD (4 #b1111)
- (3 FPC)
- (3 #b000)
- (6 ea SOURCE-EA 'L))
- (EXTENSION-WORD (3 #b010)
- (3 type)
- (3 #b000)
- (7 #b0111010)))
-
- (((? source float-reg))
- (WORD (4 #b1111)
- (3 FPC)
- (3 #b000)
- (6 #b000000))
- (EXTENSION-WORD (3 #b000)
- (3 source)
- (3 #b000)
- (7 #b0111010))))
-
-(define-instruction FB
-
- (((? cc float-cc) (@PCR (? target)))
- (GROWING-WORD (disp `(- ,target (+ *PC* 2)))
- ((-32768 32767)
- (WORD (4 #b1111)
- (3 FPC)
- (3 #b010)
- (6 cc)
- (16 disp SIGNED)))
- ((() ())
- (WORD (4 #b1111)
- (3 FPC)
- (3 #b011)
- (6 cc)
- (32 disp SIGNED))))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; 68000 Instruction Set Macros. Early version
-
-(declare (usual-integrations))
-\f
-;;;; Transformers and utilities
-
-(define early-ea-database)
-
-(define (define-early-transformer name transformer)
- (set! early-transformers
- (cons (cons name transformer)
- early-transformers))
- unspecific)
-
-(define (make-ea-transformer #!optional modes keywords)
- (make-database-transformer
- (append-map! (lambda (rule)
- (apply
- (lambda (pattern variables categories expression)
- (if (and (or (default-object? modes)
- (eq-subset? modes categories))
- (or (default-object? keywords)
- (not (memq (car pattern) keywords))))
- (list (early-make-rule pattern variables expression))
- '()))
- rule))
- early-ea-database)))
-
-(define (eq-subset? s1 s2)
- (or (null? s1)
- (and (memq (car s1) s2)
- (eq-subset? (cdr s1) s2))))
-
-(define-syntax define-ea-transformer
- (non-hygienic-macro-transformer
- (lambda (name . restrictions)
- `(DEFINE-EARLY-TRANSFORMER ',name
- (APPLY MAKE-EA-TRANSFORMER ',restrictions)))))
-
-(define-syntax define-symbol-transformer
- (non-hygienic-macro-transformer
- (lambda (name . assoc)
- `(DEFINE-EARLY-TRANSFORMER ',name (MAKE-SYMBOL-TRANSFORMER ',assoc)))))
-
-(define-syntax define-reg-list-transformer
- (non-hygienic-macro-transformer
- (lambda (name . assoc)
- `(DEFINE-EARLY-TRANSFORMER ',name
- (MAKE-BIT-MASK-TRANSFORMER 16 ',assoc)))))
-\f
-;;;; Instruction and addressing mode macros
-
-(define-syntax define-instruction
- (non-hygienic-macro-transformer
- (lambda (opcode . patterns)
- `(SET! EARLY-INSTRUCTIONS
- (CONS
- (LIST ',opcode
- ,@(map (lambda (pattern)
- `(early-parse-rule
- ',(car pattern)
- (lambda (pat vars)
- (early-make-rule
- pat
- vars
- (scode-quote
- (instruction->instruction-sequence
- ,(parse-instruction (cadr pattern)
- (cddr pattern)
- #t)))))))
- patterns))
- EARLY-INSTRUCTIONS)))))
-
-(define-syntax extension-word
- (non-hygienic-macro-transformer
- (lambda descriptors
- (expand-descriptors descriptors
- (lambda (instruction size source destination)
- (if (or source destination)
- (error "EXTENSION-WORD: Source or destination used"))
- (if (not (zero? (remainder size 16)))
- (error "EXTENSION-WORD: Extensions must be 16 bit multiples"
- size))
- (optimize-group-syntax instruction true))))))
-
-(define-syntax variable-extension
- (non-hygienic-macro-transformer
- (lambda (binding . clauses)
- (variable-width-expression-syntaxer
- (car binding)
- (cadr binding)
- (map (lambda (clause)
- `((LIST ,(caddr clause))
- ,(cadr clause) ; Size
- ,@(car clause))) ; Range
- clauses)))))
-\f
-;;;; Early effective address assembly.
-
-;;; *** NOTE: If this format changes, insutl.scm must also be changed! ***
-
-(define-syntax define-ea-database
- (non-hygienic-macro-transformer
- (lambda rules
- `(SET! EARLY-EA-DATABASE
- (LIST
- ,@(map (lambda (rule)
- (if (null? (cdddr rule))
- (apply make-position-dependent-early rule)
- (apply make-position-independent-early rule)))
- rules))))))
-
-(define (make-ea-selector-expander late-name index)
- (scode->scode-expander
- (lambda (operands if-expanded if-not-expanded)
- if-not-expanded
- (let ((default
- (lambda ()
- (if-expanded
- (scode/make-combination
- (scode/make-variable late-name)
- operands))))
- (operand (car operands)))
- (if (not (scode/combination? operand))
- (default)
- (scode/combination-components operand
- (lambda (operator operands)
- (if (or (not (scode/variable? operator))
- (not (eq? (scode/variable-name operator)
- 'MAKE-EFFECTIVE-ADDRESS)))
- (default)
- (if-expanded (list-ref operands index))))))))))
-
-;; The indices here are the argument number to MAKE-EFFECTIVE-ADDRESS.
-(define ea-keyword-expander (make-ea-selector-expander 'EA-KEYWORD 0))
-(define ea-mode-expander (make-ea-selector-expander 'EA-MODE 1))
-(define ea-register-expander (make-ea-selector-expander 'EA-REGISTER 2))
-(define ea-extension-expander (make-ea-selector-expander 'EA-EXTENSION 3))
-(define ea-categories-expander (make-ea-selector-expander 'EA-CATEGORIES 4))
-\f
-;;;; Utilities
-
-(define (make-position-independent-early pattern categories mode register
- . extension)
- (let ((keyword (car pattern)))
- `(EARLY-PARSE-RULE
- ',pattern
- (LAMBDA (PAT VARS)
- (LIST PAT
- VARS
- ',categories
- (SCODE-QUOTE
- (MAKE-EFFECTIVE-ADDRESS
- ',keyword
- ,(integer-syntaxer mode 'UNSIGNED 3)
- ,(integer-syntaxer register 'UNSIGNED 3)
- (LAMBDA (IMMEDIATE-SIZE INSTRUCTION-TAIL)
- (DECLARE (INTEGRATE IMMEDIATE-SIZE INSTRUCTION-TAIL))
- IMMEDIATE-SIZE ;ignore if not referenced
- ,(if (null? extension)
- 'INSTRUCTION-TAIL
- `(CONS-SYNTAX ,(car extension) INSTRUCTION-TAIL)))
- ',categories)))))))
-
-(define (make-position-dependent-early pattern categories code-list)
- (let ((keyword (car pattern))
- (code (cdr code-list)))
- (let ((name (car code))
- (mode (cadr code))
- (register (caddr code))
- (extension (cadddr code)))
- `(EARLY-PARSE-RULE
- ',pattern
- (LAMBDA (PAT VARS)
- (LIST PAT
- VARS
- ',categories
- (SCODE-QUOTE
- (LET ((,name (GENERATE-LABEL 'MARK)))
- (MAKE-EFFECTIVE-ADDRESS
- ',keyword
- ,(process-ea-field mode)
- ,(process-ea-field register)
- (LAMBDA (IMMEDIATE-SIZE INSTRUCTION-TAIL)
- (DECLARE (INTEGRATE IMMEDIATE-SIZE INSTRUCTION-TAIL))
- IMMEDIATE-SIZE ;ignore if not referenced
- ,(if (null? extension)
- 'INSTRUCTION-TAIL
- `(CONS (LIST 'LABEL ,name)
- (CONS-SYNTAX ,extension INSTRUCTION-TAIL))))
- ',categories)))))))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; 68000 Instruction Set Macros
-
-(declare (usual-integrations))
-\f
-;;;; Effective addressing
-
-(define ea-database-name
- 'EA-DATABASE)
-
-(define-syntax define-ea-database
- (rsc-macro-transformer
- (lambda (form environment)
- `(,(close-syntax 'DEFINE environment)
- ,ea-database-name
- ,(compile-database (cdr form) environment
- (lambda (pattern actions)
- (if (null? (cddr actions))
- (make-position-dependent pattern actions environment)
- (make-position-independent pattern actions environment))))))))
-
-(define-syntax extension-word
- (rsc-macro-transformer
- (lambda (form environment)
- environment
- (call-with-values (lambda () (expand-descriptors (cdr form) environment))
- (lambda (instruction size source destination)
- (if (or source destination)
- (error "Source or destination used:" form))
- (if (not (zero? (remainder size 16)))
- (error "Extensions must be 16 bit multiples:" size))
- (optimize-group-syntax instruction #f environment))))))
-
-(define-syntax variable-extension
- (rsc-macro-transformer
- (lambda (form environment)
- (let ((binding (cadr form))
- (clauses (cddr form)))
- (variable-width-expression-syntaxer
- (car binding)
- (cadr binding)
- environment
- (map (lambda (clause)
- `((,(close-syntax 'LIST environment)
- ,(caddr clause))
- ,(cadr clause)
- ,@(car clause)))
- clauses))))))
-\f
-(define (make-position-independent pattern actions environment)
- (let ((keyword (car pattern))
- (categories (car actions))
- (mode (cadr actions))
- (register (caddr actions))
- (extension (cdddr actions)))
- `(,(close-syntax 'MAKE-EFFECTIVE-ADDRESS environment)
- ',keyword
- ,(integer-syntaxer mode environment 'UNSIGNED 3)
- ,(integer-syntaxer register environment 'UNSIGNED 3)
- (,(close-syntax 'LAMBDA environment)
- (IMMEDIATE-SIZE INSTRUCTION-TAIL)
- IMMEDIATE-SIZE ;ignore if not referenced
- ,(if (pair? extension)
- `(,(close-syntax 'CONS-SYNTAX environment)
- ,(car extension)
- INSTRUCTION-TAIL)
- `INSTRUCTION-TAIL))
- ',categories)))
-
-(define (make-position-dependent pattern actions environment)
- (let ((keyword (car pattern))
- (categories (car actions))
- (code (cdr (cadr actions))))
- (let ((name (car code))
- (mode (cadr code))
- (register (caddr code))
- (extension (cadddr code)))
- `(,(close-syntax 'LET environment)
- ((,name (,(close-syntax 'GENERATE-LABEL environment) 'MARK)))
- (,(close-syntax 'MAKE-EFFECTIVE-ADDRESS environment)
- ',keyword
- ,(process-ea-field mode environment)
- ,(process-ea-field register environment)
- (,(close-syntax 'LAMBDA environment)
- (IMMEDIATE-SIZE INSTRUCTION-TAIL)
- IMMEDIATE-SIZE ;ignore if not referenced
- ,(if (pair? extension)
- `(,(close-syntax 'CONS environment)
- (,(close-syntax 'LIST environment) 'LABEL ,name)
- (,(close-syntax 'CONS-SYNTAX environment)
- ,extension
- INSTRUCTION-TAIL))
- `INSTRUCTION-TAIL))
- ',categories)))))
-
-(define (process-ea-field field environment)
- (if (exact-integer? field)
- (integer-syntaxer field environment 'UNSIGNED 3)
- (let ((binding (cadr field))
- (clauses (cddr field)))
- (variable-width-expression-syntaxer
- (car binding)
- (cadr binding)
- environment
- (map (lambda (clause)
- `((,(close-syntax 'LIST environment)
- ,(integer-syntaxer (cadr clause) environment 'UNSIGNED 3))
- 3
- ,@(car clause)))
- clauses)))))
-\f
-;;;; Transformers
-
-(define-syntax define-ea-transformer
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (let ((filter
- (lambda (items generator extraction)
- (if (pair? items)
- (if (pair? (cdr items))
- `((LET ((TEMP ,extraction))
- (AND
- ,@(map (lambda (item) (generator item 'TEMP))
- items))))
- `(,(generator (car items) extraction)))
- '()))))
- (let ((generate-definition
- (lambda (name generate-match)
- `(DEFINE (,name EXPRESSION)
- (LET ((MATCH-RESULT
- (PATTERN-LOOKUP ,ea-database-name EXPRESSION)))
- (AND MATCH-RESULT
- ,(generate-match `(MATCH-RESULT)))))))
- (filter-categories
- (lambda (categories)
- (filter categories
- (lambda (cat exp) `(MEMQ ',cat ,exp))
- `(EA-CATEGORIES EA))))
- (filter-keywords
- (lambda (keywords)
- (filter keywords
- (lambda (key exp) `(NOT (EQ? ',key ,exp)))
- `(EA-KEYWORD EA)))))
- (cond ((syntax-match? '(IDENTIFIER) (cdr form))
- (generate-definition (cadr form)
- (lambda (ea)
- ea)))
- ((syntax-match? '(IDENTIFIER (* DATUM)) (cdr form))
- (generate-definition (cadr form)
- (lambda (ea)
- `(LET ((EA ,ea))
- (AND ,@(filter-categories (caddr form))
- EA)))))
- ((syntax-match? '(IDENTIFIER (* DATUM) (* DATUM)) (cdr form))
- (generate-definition (cadr form)
- (lambda (ea)
- `(LET ((EA (MATCH-RESULT)))
- (AND ,@(filter-categories (caddr form))
- ,@(filter-keywords (cadddr form))
- EA)))))
- (else
- (ill-formed-syntax form))))))))
-
-(define-syntax define-symbol-transformer
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (if (syntax-match? '(IDENTIFIER * SYMBOL) (cdr form))
- `(DEFINE-INTEGRABLE (,(cadr form) SYMBOL)
- (LET ((PLACE (ASSQ SYMBOL ',(cddr form))))
- (IF (PAIR? PLACE)
- (CDR PLACE)
- #F)))
- (ill-formed-syntax form)))))
-
-(define-syntax define-reg-list-transformer
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (if (syntax-match? '(IDENTIFIER * DATUM) (cdr form))
- `(DEFINE-INTEGRABLE (,(cadr form) REG-LIST)
- (ENCODE-REGISTER-LIST REG-LIST ',(cddr form)))
- (ill-formed-syntax form)))))
-\f
-;;;; Utility procedures
-
-(define (parse-instruction expression tail early? environment)
- (define (kernel)
- (case (car expression)
- ((WORD) (parse-word expression tail environment))
- ((GROWING-WORD) (parse-growing-word expression tail environment))
- (else (error "Unknown expression:" expression))))
- (if (not early?)
- (with-normal-selectors kernel)
- (with-early-selectors kernel)))
-
-;;; Variable width instruction parsing
-
-(define (parse-growing-word expression tail environment)
- (if (not (null? tail))
- (error "PARSE-GROWING-WORD: non null tail" tail))
- (let ((binding (cadr expression)))
- `(LIST
- ,(variable-width-expression-syntaxer
- (car binding)
- (cadr binding)
- environment
- (map (lambda (clause)
- (if (pair? (cddr clause))
- (error "Extension found in clause:" clause))
- (call-with-values
- (lambda () (expand-descriptors (cdadr clause) environment))
- (lambda (instruction size src dst)
- (if (not (zero? (remainder size 16)))
- (error "Instructions must be 16 bit multiples:" size))
- `(,(collect-word instruction src dst '())
- ,size
- ,@(car clause))))) ; Range
- (cddr expression))))))
-\f
-;;;; Fixed width instruction parsing
-
-(define (parse-word expression tail environment)
- (call-with-values
- (lambda () (expand-descriptors (cdr expression) environment))
- (lambda (instruction size src dst)
- (if (not (zero? (remainder size 16)))
- (error "Instructions must be 16 bit multiples:" size))
- (collect-word instruction src dst tail))))
-
-(define (expand-descriptors descriptors environment)
- (if (pair? descriptors)
- (call-with-values
- (lambda () (expand-descriptors (cdr descriptors) environment))
- (lambda (instruction* size* source* destination*)
- (call-with-values
- (lambda () (expand-descriptor (car descriptors) environment))
- (lambda (instruction size source destination)
- (values (append! instruction instruction*)
- (+ size size*)
- (if source
- (begin
- (if source*
- (error "Multiple source definitions:"
- source source*))
- source)
- source*)
- (if destination
- (begin
- (if destination*
- (error "Multiple destination definitions:"
- destination destination*))
- destination)
- destination*))))))
- (values '() 0 #f #f)))
-
-(define (collect-word instruction src dst tail)
- (let ((code
- (let ((code
- (let ((code (if dst `(,@dst '()) '())))
- (if src
- `(,@src ,code)
- code))))
- (cond ((null? tail) code)
- ((null? (cdr tail))
- `(,(if (null? code) 'CONS 'CONS-SYNTAX)
- ,(car tail)
- ,code))
- (else
- (error "PARSE-WORD: multiple tail elements" tail))))))
- (if (pair? instruction)
- `(,(if (null? code) 'CONS 'CONS-SYNTAX)
- ,(optimize-group-syntax instruction
- early-instruction-parsing?
- environment)
- ,code)
- code)))
-\f
-;;;; Hooks for early instruction processing
-
-(define early-instruction-parsing? #f)
-(define ea-keyword-selector 'EA-KEYWORD)
-(define ea-categories-selector 'EA-CATEGORIES)
-(define ea-mode-selector 'EA-MODE)
-(define ea-register-selector 'EA-REGISTER)
-(define ea-extension-selector 'EA-EXTENSION)
-
-(define (with-normal-selectors handle)
- (fluid-let ((early-instruction-parsing? #f)
- (ea-keyword-selector 'EA-KEYWORD)
- (ea-categories-selector 'EA-CATEGORIES)
- (ea-mode-selector 'EA-MODE)
- (ea-register-selector 'EA-REGISTER)
- (ea-extension-selector 'EA-EXTENSION))
- (handle)))
-
-(define (with-early-selectors handle)
- (fluid-let ((early-instruction-parsing? #t)
- (ea-keyword-selector 'EA-KEYWORD-EARLY)
- (ea-categories-selector 'EA-CATEGORIES-EARLY)
- (ea-mode-selector 'EA-MODE-EARLY)
- (ea-register-selector 'EA-REGISTER-EARLY)
- (ea-extension-selector 'EA-EXTENSION-EARLY))
- (handle)))
-
-(define (expand-descriptor descriptor environment)
- (let ((size (car descriptor))
- (expression (close-syntax (cadr descriptor) environment))
- (coercion-type
- (if (pair? (cddr descriptor)) (caddr descriptor) 'UNSIGNED)))
- (case coercion-type
- ((UNSIGNED SIGNED SHIFT-NUMBER QUICK BFWIDTH SCALE-FACTOR)
- (values `(,(integer-syntaxer expression environment coercion-type size))
- size #f #f))
- ((SHORT-LABEL)
- (values `(,(integer-syntaxer ``(,',(close-syntax '- environment)
- ,,expression
- (,',(close-syntax '+ environment)
- ,',(close-syntax '*PC* environment)
- 2))
- environment
- 'SHORT-LABEL
- size))
- size #f #f))
- ((SOURCE-EA)
- (values `((,(close-syntax ea-mode-selector environment) ,expression)
- (,(close-syntax ea-register-selector environment)
- ,expression))
- size
- `((,(close-syntax ea-extension-selector environment)
- ,expression)
- ,(cadddr descriptor))
- #f))
- ((DESTINATION-EA)
- (values `((,(close-syntax ea-mode-selector environment) ,expression)
- (,(close-syntax ea-register-selector environment)
- ,expression))
- size
- #f
- `((,(close-syntax ea-extension-selector environment)
- ,expression)
- '())))
- ((DESTINATION-EA-REVERSED)
- (values `((,(close-syntax ea-register-selector environment) ,expression)
- (,(close-syntax ea-mode-selector environment) ,expression))
- size
- #f
- `((,(close-syntax ea-extension-selector environment)
- ,expression)
- '())))
- (else
- (error "Badly-formed descriptor:" descriptor)))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; 68000 Instruction Set Description
-;;; Originally from GJS (who did the hard part).
-
-(declare (usual-integrations))
-\f
-;;; Effective Address description database
-
-(define-ea-database
- ((D (? r)) (DATA ALTERABLE) #b000 r)
-
- ((A (? r)) (ALTERABLE) #b001 r)
-
- ((@A (? r)) (DATA MEMORY CONTROL ALTERABLE) #b010 r)
-
- ((@A+ (? r)) (DATA MEMORY ALTERABLE) #b011 r)
-
- ((@-A (? r)) (DATA MEMORY ALTERABLE) #b100 r)
-
- ((@AO (? r) (? o))
- (DATA MEMORY CONTROL ALTERABLE) #b101 r
- (output-16bit-offset o))
-
- ((@AR (? r) (? l))
- (DATA MEMORY CONTROL ALTERABLE) #b101 r
- (output-16bit-relative l))
-
- ((@AOX (? r) (? o) (? xtype da) (? xr) (? s wl))
- (DATA MEMORY CONTROL ALTERABLE) #b110 r
- (output-offset-index-register xtype xr s o))
-
- ((@ARX (? r) (? l) (? xtype da) (? xr) (? s wl))
- (DATA MEMORY CONTROL ALTERABLE) #b110 r
- (output-relative-index-register xtype xr s l))
-
- ((W (? a))
- (DATA MEMORY CONTROL ALTERABLE) #b111 #b000
- (output-16bit-address a))
-
- ((L (? a))
- (DATA MEMORY CONTROL ALTERABLE) #b111 #b001
- (output-32bit-address a))
-
- ((@PCO (? o))
- (DATA MEMORY CONTROL) #b111 #b010
- (output-16bit-offset o))
-
- ((@PCR.W (? l))
- (DATA MEMORY CONTROL) #b111 #b010
- (output-16bit-relative l))
-
- ((@PCOX (? o) (? xtype da) (? xr) (? s wl))
- (DATA MEMORY CONTROL) #b111 #b011
- (output-offset-index-register xtype xr s o))
-
- ((@PCRX (? l) (? xtype da) (? xr) (? s wl))
- (DATA MEMORY CONTROL) #b111 #b011
- (output-relative-index-register xtype xr s l))
-
- ((& (? i))
- (DATA MEMORY) #b111 #b100
- (output-immediate-data immediate-size i))
-\f
-;;; 68020 only
-
- ;; These are common special cases of the full extension word forms below
-
- ((@D (? r))
- (DATA MEMORY CONTROL ALTERABLE) #b110 #b000
- (output-@D-indirect r))
-
- ((@DO (? r) (? o))
- (DATA MEMORY CONTROL ALTERABLE) #b110 #b000
- (output-@DO-indirect r o))
-
- ;; Brief format extension word addressing modes
-
- ;; These 2 are like @AOX and @ARX but accept a scale factor.
- ;; The index register is collected into a spec like ((D 4) L 2).
-
- ((@AOXS (? r) (? l) (((? xtype da) (? xr)) (? s wl) (? factor)))
- (DATA MEMORY CONTROL ALTERABLE) #b110 r
- (output-brief-format-extension-word xtype xr s factor l))
-
- ((@ARXS (? r) (? l) (((? xtype da) (? xr)) (? s wl) (? factor)))
- (DATA MEMORY CONTROL ALTERABLE) #b110 r
- (output-brief-format-extension-word xtype xr s factor `(- ,l *PC*)))
-
- ;; Similarly for @PCOX and @PCRX.
-
- ((@PCOXS (? o) (((? xtype da) (? xr)) (? s wl) (? factor)))
- (DATA MEMORY CONTROL) #b111 #b011
- (output-brief-format-extension-word xtype xr s factor o))
-
- ((@PCRXS (? l) (((? xtype da) (? xr)) (? s wl) (? factor)))
- (DATA MEMORY CONTROL) #b111 #b011
- (output-brief-format-extension-word xtype xr s factor `(- ,l *PC*)))
-\f
-;;; Full format extension word addressing modes
-
- ((@AOF (? r) (? brs ze)
- ((? bd) (? bdtype nwl)) (? memtype)
- (((? xtype da) (? xr)) (? xsz wl) (? factor)) (? irs ze)
- ((? od) (? odtype nwl)))
- (DATA MEMORY CONTROL ALTERABLE) #b110 r
- (output-full-format-extension-word xtype xr xsz factor
- brs irs bdtype bd
- memtype odtype od))
-
- ((@ARF (? r) (? brs ze)
- ((? bd) (? bdtype nwl)) (? memtype)
- (((? xtype da) (? xr)) (? xsz wl) (? factor)) (? irs ze)
- ((? od) (? odtype nwl)))
- (DATA MEMORY CONTROL ALTERABLE) #b110 r
- (output-full-format-extension-word xtype xr xsz factor
- brs irs bdtype `(- ,bd *PC*)
- memtype odtype od))
-
- ((@PCOF (? pcs ze)
- ((? bd) (? bdtype nwl)) (? memtype)
- (((? xtype da) (? xr)) (? xsz wl) (? factor)) (? irs ze)
- ((? od) (? odtype nwl)))
- (DATA MEMORY CONTROL) #b111 #b011
- (output-full-format-extension-word xtype xr xsz factor
- pcs irs bdtype bd
- memtype odtype od))
-
- ((@PCRF (? pcs ze)
- ((? bd) (? bdtype nwl)) (? memtype)
- (((? xtype da) (? xr)) (? xsz wl) (? factor)) (? irs ze)
- ((? od) (? odtype nwl)))
- (DATA MEMORY CONTROL) #b111 #b011
- (output-full-format-extension-word xtype xr xsz factor
- pcs irs bdtype `(- ,bd *PC*)
- memtype odtype od))
-
-;;; Optimized addressing modes.
-;;; Only a subset of those that can be optimized.
-
- ((@PCR (? l))
- (DATA MEMORY CONTROL)
- (POSITION-DEPENDENT label
- #b111
- (FIELD (offset `(- ,l ,label))
- ((-32768 32767) #b010)
- ((() ()) #b011))
- (VARIABLE-EXTENSION (offset `(- ,l ,label))
- ((-32768 32767)
- 16
- (EXTENSION-WORD (16 offset SIGNED)))
- ((() ())
- 48
- (output-32bit-offset offset))))))
-\f
-;;;; Effective address transformers (restrictions)
-
-(define-ea-transformer ea-all)
-
-(define-ea-transformer ea-d (DATA))
-(define-ea-transformer ea-a (ALTERABLE))
-(define-ea-transformer ea-c (CONTROL))
-
-(define-ea-transformer ea-d&a (DATA ALTERABLE))
-(define-ea-transformer ea-c&a (CONTROL ALTERABLE))
-(define-ea-transformer ea-m&a (MEMORY ALTERABLE))
-
-(define-ea-transformer ea-d&-& (DATA) (&))
-(define-ea-transformer ea-all-A () (A))
-
-(define-ea-transformer ea-d/c () (A @A+ @-A &))
-(define-ea-transformer ea-d/c&a (ALTERABLE) (A @A+ @-A &))
-\f
-;;;; Special purpose transformers
-
-(define-symbol-transformer da (D . 0) (A . 1))
-(define-symbol-transformer nwl (N . 1) (W . 2) (L . 3))
-(define-symbol-transformer bwlq (B . 0) (W . 1) (L . 2) (Q . 3))
-(define-symbol-transformer bwl-b (W . 1) (L . 2))
-(define-symbol-transformer bwl
- (B . 0) (W . 1) (L . 2) (UB . 0) (UW . 1) (UL . 2))
-(define-symbol-transformer bw (B . 0) (W . 1))
-(define-symbol-transformer wl (W . 0) (L . 1))
-(define-symbol-transformer lw (W . 1) (L . 0) (UW . 1) (UL . 0))
-(define-symbol-transformer rl (R . 0) (L . 1))
-(define-symbol-transformer us (U . 0) (S . 1))
-(define-symbol-transformer chkwl (W . 6) (L . 4))
-(define-symbol-transformer bwl+1 (B . 1) (W . 2) (L . 3))
-(define-symbol-transformer wl+2 (W . 2) (L . 3))
-(define-symbol-transformer ze (Z . 1) (E . 0))
-
-(define-symbol-transformer cc
- (T . 0) (F . 1) (HI . 2) (LS . 3) (HS . 4) (LO . 5)
- (CC . 4) (CS . 5) (NE . 6) (EQ . 7) (VC . 8) (VS . 9)
- (PL . 10) (MI . 11) (GE . 12) (LT . 13) (GT . 14) (LE . 15))
-
-(define-reg-list-transformer @+reg-list
- (A7 . 0) (A6 . 1) (A5 . 2) (A4 . 3) (A3 . 4) (A2 . 5) (A1 . 6) (A0 . 7)
- (D7 . 8) (D6 . 9) (D5 . 10) (D4 . 11) (D3 . 12) (D2 . 13)
- (D1 . 14) (D0 . 15))
-
-(define-reg-list-transformer @-reg-list
- (D0 . 0) (D1 . 1) (D2 . 2) (D3 . 3) (D4 . 4) (D5 . 5) (D6 . 6) (D7 . 7)
- (A0 . 8) (A1 . 9) (A2 . 10) (A3 . 11) (A4 . 12) (A5 . 13)
- (A6 . 14) (A7 . 15))
-
-;; Control registers for 68010 and 68020
-
-(define-symbol-transformer cont-reg
- (SFC . #x000) (DFC . #x001) (USP . #x800) (VBR . #x801)
- ;; The ones below are for the 68020 only.
- (CACR . #x002) (CAAR . #x802) (MSP . #x803) (ISP . #x804))
-
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; 68000 Instruction Set Description
-;;; Originally from GJS (who did the hard part).
-
-(declare (usual-integrations))
-\f
-;;;; Pseudo ops
-
-(define-instruction DC
- ((W (? expression))
- (WORD (16 expression SIGNED)))
-
- ((L (? expression))
- (WORD (32 expression SIGNED)))
-
- ((UW (? expression))
- (WORD (16 expression UNSIGNED)))
-
- ((UL (? expression))
- (WORD (32 expression UNSIGNED))))
-
-;;;; BCD Arithmetic
-
-(let-syntax ((define-BCD-addition
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((D (? ry)) (D (? rx)))
- (WORD (4 ,(caddr form))
- (3 rx)
- (6 #b100000)
- (3 ry)))
-
- (((@-A (? ry)) (@-A (? rx)))
- (WORD (4 ,(caddr form))
- (3 rx)
- (6 #b100001)
- (3 ry))))))))
- (define-BCD-addition ABCD #b1100)
- (define-BCD-addition SBCD #b1000))
-
-(define-instruction NBCD
- ((? dea ea-d&a)
- (WORD (10 #b0100100000)
- (6 dea DESTINATION-EA))))
-\f
-;;;; Binary Arithmetic
-
-(let-syntax ((define-binary-addition
- (sc-macro-transformer
- (lambda (keyword Qkeyword Xkeyword opcode Qbit Iopcode)
- `(BEGIN
- (DEFINE-INSTRUCTION ,(caddr form) ;ADDQ/SUBQ
- ((B (& (? data)) (? ea ea-all-A))
- (WORD (4 #b0101)
- (3 data QUICK)
- (1 ,(list-ref form 5))
- (2 #b00)
- (6 ea DESTINATION-EA)))
-
- (((? s bwl-b) (& (? data)) (? ea ea-all))
- (WORD (4 #b0101)
- (3 data QUICK)
- (1 ,(list-ref form 5))
- (2 s)
- (6 ea DESTINATION-EA))))
-
- (DEFINE-INSTRUCTION ,(cadr form)
- (((? s bwl ssym) (& (? data)) (? ea ea-d&a)) ;ADDI/SUBI
- (WORD (4 #b0000)
- (4 ,(list-ref form 6))
- (2 s)
- (6 ea DESTINATION-EA))
- (immediate-words data ssym))
-
- ((B (? ea ea-all-A) (D (? rx)))
- (WORD (4 ,(list-ref form 4))
- (3 rx)
- (1 #b0)
- (2 #b00)
- (6 ea SOURCE-EA 'B)))
-
- (((? s bwl-b ssym) (? ea ea-all) (D (? rx)))
- (WORD (4 ,(list-ref form 4))
- (3 rx)
- (1 #b0)
- (2 s)
- (6 ea SOURCE-EA ssym)))
-
- (((? s bwl) (D (? rx)) (? ea ea-m&a))
- (WORD (4 ,(list-ref form 4))
- (3 rx)
- (1 #b1)
- (2 s)
- (6 ea DESTINATION-EA)))
-
- (((? s wl ssym) (? ea ea-all) (A (? rx))) ;ADDA/SUBA
- (WORD (4 ,(list-ref form 4))
- (3 rx)
- (1 s)
- (2 #b11)
- (6 ea SOURCE-EA ssym))))
-
- (DEFINE-INSTRUCTION ,(cadddr form)
- (((? s bwl) (D (? ry)) (D (? rx)))
- (WORD (4 ,(list-ref form 4))
- (3 rx)
- (1 #b1)
- (2 s)
- (3 #b000)
- (3 ry)))
-
- (((? s bwl) (@-A (? ry)) (@-A (? rx)))
- (WORD (4 ,(list-ref form 4))
- (3 rx)
- (1 #b1)
- (2 s)
- (3 #b001)
- (3 ry)))))))))
- (define-binary-addition ADD ADDQ ADDX #b1101 #b0 #b0110)
- (define-binary-addition SUB SUBQ SUBX #b1001 #b1 #b0100))
-\f
-(define-instruction EXT
- (((? s wl) (D (? rx)))
- (WORD (9 #b010010001)
- (1 s)
- (3 #b000)
- (3 rx))))
-
-(define-instruction NEG
- (((? s bwl) (? dea ea-d&a))
- (WORD (8 #b01000100)
- (2 s)
- (6 dea DESTINATION-EA))))
-
-(define-instruction NEGX
- (((? s bwl) (? dea ea-d&a))
- (WORD (8 #b01000000)
- (2 s)
- (6 dea DESTINATION-EA))))
-
-;;; Multiplication and division
-
-#|
-
-;; These are the 68000/68010 versions
-
-(define-instruction DIV
- (((? sgn us) (D (? rx)) (? ea ea-d))
- (WORD (4 #b1000)
- (3 rx)
- (1 sgn)
- (2 #b11)
- (6 ea SOURCE-EA 'W))))
-
-(define-instruction MUL
- (((? sgn us) (? ea ea-d) (D (? rx)))
- (WORD (4 #b1100)
- (3 rx)
- (1 sgn)
- (2 #b11)
- (6 ea SOURCE-EA 'W))))
-
-|#
-\f
-;; These are the 68020 versions
-
-(let-syntax ((define-mul-and-div
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? sgn us) W (? ea ea-d) (D (? n)))
- (WORD (1 #b1)
- (1 ,(caddr form))
- (2 #b00)
- (3 n)
- (1 sgn)
- (2 #b11)
- (6 ea SOURCE-EA 'W)))
-
- (((? sgn us) L (? ea ea-d) (D (? q)))
- (WORD (9 #b010011000)
- (1 ,(cadddr form))
- (6 ea SOURCE-EA 'L))
- (EXTENSION-WORD (1 #b0)
- (3 q)
- (1 sgn)
- (8 #b00000000)
- (3 q)))
-
- (((? sgn us) L (? ea ea-d) (D (? r)) (D (? q)))
- (WORD (9 #b010011000)
- (1 ,(cadddr form))
- (6 ea SOURCE-EA 'L))
- (EXTENSION-WORD (1 #b0)
- (3 q)
- (1 sgn)
- (8 #b10000000)
- (3 r))))))))
- (define-mul-and-div MUL #b1 #b0)
- (define-mul-and-div DIV #b0 #b1))
-
-(define-instruction DIVL
- (((? sgn us) L (? ea ea-d) (D (? r)) (D (? q)))
- (WORD (9 #b010011000)
- (1 #b1) ; DIV long-form-bit
- (6 ea SOURCE-EA 'L))
- (EXTENSION-WORD (1 #b0)
- (3 q)
- (1 sgn)
- (8 #b00000000)
- (3 r))))
-\f
-;;;; Comparisons
-
-(define-instruction CMP
- ((B (? ea ea-all-A) (D (? rx)))
- (WORD (4 #b1011)
- (3 rx)
- (1 #b0)
- (2 #b00)
- (6 ea SOURCE-EA 'B)))
-
- (((? s bwl-b ssym) (? ea ea-all) (D (? rx)))
- (WORD (4 #b1011)
- (3 rx)
- (1 #b0)
- (2 s)
- (6 ea SOURCE-EA ssym)))
-
- (((? s wl ssym) (? ea ea-all) (A (? rx))) ;CMPA
- (WORD (4 #b1011)
- (3 rx)
- (1 s)
- (2 #b11)
- (6 ea SOURCE-EA ssym)))
-
- (((? s bwl ssym) (& (? data)) (? ea ea-d&a)) ;CMPI
- (WORD (8 #b00001100)
- (2 s)
- (6 ea DESTINATION-EA))
- (immediate-words data ssym))
-
- (((? s bwl) (@A+ (? ry)) (@A+ (? rx))) ;CMPM
- (WORD (4 #b1011)
- (3 rx)
- (1 #b1)
- (2 s)
- (3 #b001)
- (3 ry))))
-
-;; Also provided for efficiency. Less rules to search.
-
-(define-instruction CMPI
- (((? s bwl ssym) (& (? data)) (? ea ea-d&a))
- (WORD (8 #b00001100)
- (2 s)
- (6 ea DESTINATION-EA))
- (immediate-words data ssym)))
-
-(define-instruction TST
- (((? s bwl) (? dea ea-d&a))
- (WORD (8 #b01001010)
- (2 s)
- (6 dea DESTINATION-EA))))
-\f
-;;;; Bitwise Logical
-
-(let-syntax ((define-bitwise-logical
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? s bwl ssym) (? ea ea-d) (D (? rx)))
- (WORD (4 ,(caddr form))
- (3 rx)
- (1 #b0)
- (2 s)
- (6 ea SOURCE-EA ssym)))
-
- (((? s bwl) (D (? rx)) (? ea ea-m&a))
- (WORD (4 ,(caddr form))
- (3 rx)
- (1 #b1)
- (2 s)
- (6 ea DESTINATION-EA)))
-
- (((? s bwl ssym) (& (? data)) (? ea ea-d&a)) ;fooI
- (WORD (4 #b0000)
- (4 ,(cadddr form))
- (2 s)
- (6 ea DESTINATION-EA))
- (immediate-unsigned-words data ssym))
-
- (((? s bwl ssym) (& (? data)) (SR)) ;fooI to CCR/SR
- (WORD (4 #b0000)
- (4 ,(cadddr form))
- (2 s)
- (6 #b111100))
- (immediate-unsigned-words data ssym)))))))
- (define-bitwise-logical AND #b1100 #b0010) ; and ANDI
- (define-bitwise-logical OR #b1000 #b0000)) ; and ORI
-
-(define-instruction EOR
- (((? s bwl) (D (? rx)) (? ea ea-d&a))
- (WORD (4 #b1011)
- (3 rx)
- (1 #b1)
- (2 s)
- (6 ea DESTINATION-EA)))
-
- (((? s bwl ssym) (& (? data)) (? ea ea-d&a)) ;EORI
- (WORD (8 #b00001010)
- (2 s)
- (6 ea DESTINATION-EA))
- (immediate-unsigned-words data ssym))
-
- (((? s bw ssym) (& (? data)) (SR)) ;EORI to CCR/SR
- (WORD (8 #b00001010)
- (2 s)
- (6 #b111100))
- (immediate-unsigned-words data ssym)))
-
-(define-instruction NOT
- (((? s bwl) (? dea ea-d&a))
- (WORD (8 #b01000110)
- (2 s)
- (6 dea DESTINATION-EA))))
-\f
-;;;; Shift
-
-(let-syntax ((define-shift-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? d rl) (? s bwl) (D (? rx)) (D (? ry)))
- (WORD (4 #b1110)
- (3 rx)
- (1 d)
- (2 s)
- (1 #b1)
- (2 ,(caddr form))
- (3 ry)))
-
- (((? d rl) (? s bwl) (& (? data)) (D (? ry)))
- (WORD (4 #b1110)
- (3 data SHIFT-NUMBER)
- (1 d)
- (2 s)
- (1 #b0)
- (2 ,(caddr form))
- (3 ry)))
-
- (((? d rl) (? ea ea-m&a))
- (WORD (5 #b11100)
- (2 ,(caddr form))
- (1 d)
- (2 #b11)
- (6 ea DESTINATION-EA))))))))
- (define-shift-instruction AS #b00)
- (define-shift-instruction LS #b01)
- (define-shift-instruction ROX #b10)
- (define-shift-instruction RO #b11))
-
-;;;; Bit Manipulation
-
-(let-syntax ((define-bit-manipulation
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((D (? rx)) (? ea ,(cadddr form)))
- (WORD (4 #b0000)
- (3 rx)
- (1 #b1)
- (2 ,(caddr form))
- (6 ea DESTINATION-EA)))
-
- (((& (? bitnum)) (? ea ,(list-ref form 4)))
- (WORD (8 #b00001000)
- (2 ,(caddr form))
- (6 ea DESTINATION-EA))
- (immediate-byte bitnum)))))))
- (define-bit-manipulation BTST #b00 ea-d ea-d&-&)
- (define-bit-manipulation BCHG #b01 ea-d&a ea-d&a)
- (define-bit-manipulation BCLR #b10 ea-d&a ea-d&a)
- (define-bit-manipulation BSET #b11 ea-d&a ea-d&a))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; 68000 Instruction Set Description
-;;; Originally from GJS (who did the hard part).
-
-(declare (usual-integrations))
-\f
-;;;; Control Transfer: Branch instructions
-
-;; No size suffix means that the assembler should choose the right
-;; size offset.
-
-;; When the displacement is 0 (a branch to the immediately following
-;; instruction), a NOP instruction is issued for non-subroutine
-;; branches (BRA and Bcc). The branch tensioner can't really handle
-;; instructions that disappear.
-
-;; For BSR instructions to the immediately following instruction,
-;; there is nothing that can be done. The branch tensioner assumes
-;; that the output does not decrease with increasing discriminator
-;; ranges, and the only two possibilities for this instruction would
-;; be to put a NOP after the BSR, or to change the BSR into a
-;; pc-relative PEA, but either of these options would make the code 32
-;; bits long, longer than the 16 bits used for short displacements.
-;; An error is generated if this situation arises.
-
-(let-syntax
- ((define-branch-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- ((,@(caddr form) B (@PCO (? o)))
- (WORD ,@(cadddr form)
- (8 o SIGNED)))
-
- ((,@(caddr form) B (@PCR (? l)))
- (WORD ,@(cadddr form)
- (8 l SHORT-LABEL)))
-
- ((,@(caddr form) W (@PCO (? o)))
- (WORD ,@(cadddr form)
- (8 #b00000000))
- (immediate-word o))
-
- ((,@(caddr form) W (@PCR (? l)))
- (WORD ,@(cadddr form)
- (8 #b00000000))
- (relative-word l))
-
- ;; 68020 only
-
- ((,@(caddr form) L (@PCO (? o)))
- (WORD ,@(cadddr form)
- (8 #b11111111))
- (immediate-long o))
-
- ((,@(caddr form) L (@PCR (? l)))
- (WORD ,@(cadddr form)
- (8 #b11111111))
- (relative-long l))
-
- ((,@(caddr form) (@PCO (? o)))
- (GROWING-WORD (disp o)
- ((0 0)
- ,@(cddddr form))
- ((-128 127)
- (WORD ,@(cadddr form)
- (8 disp SIGNED)))
- ((-32768 32767)
- (WORD ,@(cadddr form)
- (8 #b00000000)
- (16 disp SIGNED)))
- ((() ())
- (WORD ,@(cadddr form)
- (8 #b11111111)
- (32 disp SIGNED)))))
-
- ((,@(caddr form) (@PCR (? l)))
- (GROWING-WORD (disp `(- ,l (+ *PC* 2)))
- ((0 0)
- ,@(cddddr form))
- ((-128 127)
- (WORD ,@(cadddr form)
- (8 disp SIGNED)))
- ((-32768 32767)
- (WORD ,@(cadddr form)
- (8 #b00000000)
- (16 disp SIGNED)))
- ((() ())
- (WORD ,@(cadddr form)
- (8 #b11111111)
- (32 disp SIGNED))))))))))
-
- (define-branch-instruction B ((? c cc)) ((4 #b0110) (4 c))
- (WORD (16 #b0100111001110001)))
- (define-branch-instruction BRA () ((8 #b01100000))
- (WORD (16 #b0100111001110001)))
- (define-branch-instruction BSR () ((8 #b01100001))
- (WORD (16 (error "BSR to following instruction")))))
-\f
-(define-instruction DB
- (((? c cc) (D (? rx)) (@PCO (? o)))
- (WORD (4 #b0101)
- (4 c)
- (5 #b11001)
- (3 rx))
- (immediate-word o))
-
- (((? c cc) (D (? rx)) (@PCR (? l)))
- (WORD (4 #b0101)
- (4 c)
- (5 #b11001)
- (3 rx))
- (relative-word l)))
-
-(define-instruction JMP
- (((? ea ea-c))
- (WORD (10 #b0100111011)
- (6 ea DESTINATION-EA))))
-
-(define-instruction JSR
- (((? ea ea-c))
- (WORD (10 #b0100111010)
- (6 ea DESTINATION-EA))))
-
-;; 68010 and 68020 only
-
-(define-instruction RTD
- (((& (? offset)))
- (WORD (16 #b0100111001110100))
- (EXTENSION-WORD (16 offset))))
-
-(define-instruction RTE
- (()
- (WORD (16 #b0100111001110011))))
-
-(define-instruction RTR
- (()
- (WORD (16 #b0100111001110111))))
-
-(define-instruction RTS
- (()
- (WORD (16 #b0100111001110101))))
-
-(define-instruction TRAPV
- (()
- (WORD (16 #b0100111001110110))))
-\f
-;;;; Family member dependent miscellaneous instructions.
-
-#|
-
-;; These are the 68000/68010 versions
-
-(define-instruction TRAP
- (((& (? v)))
- (WORD (12 #b010011100100)
- (4 v))))
-
-(define-instruction CHK
- (((? ea ea-d) (D (? rx)))
- (WORD (4 #b0100)
- (3 rx)
- (3 #b110)
- (6 ea SOURCE-EA 'W))))
-
-(define-instruction LINK
- (((A (? rx)) (& (? d)))
- (WORD (13 #b0100111001010)
- (3 rx))
- (immediate-word d)))
-
-|#
-\f
-;;;; Family member dependent miscellaneous instructions (continued).
-
-;; These are the 68020 versions
-
-(define-instruction TRAP
- (((& (? v)))
- (WORD (12 #b010011100100)
- (4 v)))
-
- (((? c cc))
- (WORD (4 #b0101)
- (4 cc)
- (8 #b11111100)))
-
- (((? c cc) W (& (? data)))
- (WORD (4 #b0101)
- (4 cc)
- (8 #b11111010))
- (EXTENSION-WORD (16 data)))
-
- (((? c cc) L (& (? data)))
- (WORD (4 #b0101)
- (4 cc)
- (8 #b11111011))
- (EXTENSION-WORD (32 data))))
-
-(define-instruction CHK
- ;; This is for compatibility with older (68000/68010) syntax.
- ;; There is no size suffix to the opcode.
-
- (((? ea ea-d) (D (? rx)))
- (WORD (4 #b0100)
- (3 rx)
- (3 #b110)
- (6 ea SOURCE-EA 'W)))
-
- (((? size chkwl) (? ea ea-d) (D (? rx)))
- (WORD (4 #b0100)
- (3 rx)
- (3 size)
- (6 ea SOURCE-EA 'W))))
-
-(define-instruction LINK
- ((W (A (? rx)) (& (? d)))
- (WORD (13 #b0100111001010)
- (3 rx))
- (immediate-word d))
-
- ((L (A (? rx)) (& (? d)))
- (WORD (13 #b0100100000001)
- (3 rx))
- (immediate-long d)))
-\f
-;;;; Randomness
-
-(define-instruction ILLEGAL
- (()
- (WORD (16 #b0100101011111100))))
-
-(define-instruction NOP
- (()
- (WORD (16 #b0100111001110001))))
-
-(define-instruction RESET
- (()
- (WORD (16 #b0100111001110000))))
-
-(define-instruction STOP
- (((& (? data)))
- (WORD (16 #b0100111001110010))
- (immediate-word data)))
-
-(define-instruction SWAP
- (((D (? rx)))
- (WORD (13 #b0100100001000)
- (3 rx))))
-
-(define-instruction UNLK
- (((A (? rx)))
- (WORD (13 #b0100111001011)
- (3 rx))))
-\f
-;;;; Data Transfer
-
-(define-instruction CLR
- (((? s bwl) (? ea ea-d&a))
- (WORD (8 #b01000010)
- (2 s)
- (6 ea DESTINATION-EA))))
-
-(define-instruction EXG
- (((D (? rx)) (D (? ry)))
- (WORD (4 #b1100)
- (3 rx)
- (6 #b101000)
- (3 ry)))
-
- (((A (? rx)) (A (? ry)))
- (WORD (4 #b1100)
- (3 rx)
- (6 #b101001)
- (3 ry)))
-
- (((D (? rx)) (A (? ry)))
- (WORD (4 #b1100)
- (3 rx)
- (6 #b110001)
- (3 ry)))
-
- (((A (? ry)) (D (? rx)))
- (WORD (4 #b1100)
- (3 rx)
- (6 #b110001)
- (3 ry))))
-
-(define-instruction LEA
- (((? ea ea-c) (A (? rx)))
- (WORD (4 #b0100)
- (3 rx)
- (3 #b111)
- (6 ea DESTINATION-EA))))
-
-(define-instruction PEA
- (((? cea ea-c))
- (WORD (10 #b0100100001)
- (6 cea DESTINATION-EA))))
-
-(define-instruction S
- (((? c cc) (? dea ea-d&a))
- (WORD (4 #b0101)
- (4 c)
- (2 #b11)
- (6 dea DESTINATION-EA))))
-
-(define-instruction TAS
- (((? dea ea-d&a))
- (WORD (10 #b0100101011)
- (6 dea DESTINATION-EA))))
-\f
-(define-instruction MOVE
- ((B (? sea ea-all-A) (? dea ea-d&a))
- (WORD (3 #b000)
- (1 #b1)
- (6 dea DESTINATION-EA-REVERSED)
- (6 sea SOURCE-EA 'B)))
-
- ;; the following includes the MOVEA instruction
-
- (((? s lw ssym) (? sea ea-all) (? dea ea-all))
- (WORD (3 #b001)
- (1 s)
- (6 dea DESTINATION-EA-REVERSED)
- (6 sea SOURCE-EA ssym)))
-
- ;; Special MOVE instructions
-
- ((W (? ea ea-d) (CCR)) ;MOVE to CCR
- (WORD (10 #b0100010011)
- (6 ea SOURCE-EA 'W)))
-
- ((W (CCR) (? ea ea-d)) ;MOVE from CCR
- (WORD (10 #b0100001011)
- (6 ea DESTINATION-EA 'W)))
-
- ((W (? ea ea-d) (SR)) ;MOVE to SR
- (WORD (10 #b0100011011)
- (6 ea SOURCE-EA 'W)))
-
- ((W (SR) (? ea ea-d&a)) ;MOVE from SR
- (WORD (10 #b0100000011)
- (6 ea DESTINATION-EA)))
-
- ((L (A (? rx)) (USP)) ;MOVE to USP
- (WORD (13 #b0100111001100)
- (3 rx)))
-
- ((L (USP) (A (? rx))) ;MOVE from USP
- (WORD (13 #b0100111001101)
- (3 rx))))
-\f
-;; MOV is a special case, separated for efficiency so there are less
-;; rules to try.
-
-(define-instruction MOV
- ((B (? sea ea-all-A) (? dea ea-d&a))
- (WORD (3 #b000)
- (1 #b1)
- (6 dea DESTINATION-EA-REVERSED)
- (6 sea SOURCE-EA 'B)))
-
- ;; the following includes the MOVEA instruction
-
- (((? s lw ssym) (? sea ea-all) (? dea ea-all))
- (WORD (3 #b001)
- (1 s)
- (6 dea DESTINATION-EA-REVERSED)
- (6 sea SOURCE-EA ssym))))
-
-(define-instruction MOVEQ
- (((& (? data)) (D (? rx)))
- (WORD (4 #b0111)
- (3 rx)
- (1 #b0)
- (8 data SIGNED))))
-
-(define-instruction MOVEM
- (((? s wl) (? r @+reg-list) (? dea ea-c&a))
- (WORD (9 #b010010001)
- (1 s)
- (6 dea DESTINATION-EA))
- (output-bit-string r))
-
- (((? s wl) (? r @-reg-list) (@-a (? rx)))
- (WORD (9 #b010010001)
- (1 s)
- (3 #b100)
- (3 rx))
- (output-bit-string r))
-
- (((? s wl) (? sea ea-c) (? r @+reg-list))
- (WORD (9 #b010011001)
- (1 s)
- (6 sea SOURCE-EA s))
- (output-bit-string r))
-
- (((? s wl) (@A+ (? rx)) (? r @+reg-list))
- (WORD (9 #b010011001)
- (1 s)
- (3 #b011)
- (3 rx))
- (output-bit-string r)))
-\f
-(define-instruction MOVEP
- (((? s wl) (D (? rx)) (@AO (? ry) (? o)))
- (WORD (4 #b0000)
- (3 rx)
- (2 #b11)
- (1 s)
- (3 #b001)
- (3 ry))
- (offset-word o))
-
- (((? s wl) (D (? rx)) (@AR (? ry) (? l)))
- (WORD (4 #b0000)
- (3 rx)
- (2 #b11)
- (1 s)
- (3 #b001)
- (3 ry))
- (relative-word l))
-
- (((? s wl) (@AO (? ry) (? o)) (D (? rx)))
- (WORD (4 #b0000)
- (3 rx)
- (2 #b10)
- (1 s)
- (3 #b001)
- (3 ry))
- (offset-word o))
-
- (((? s wl) (@AR (? ry) (? l)) (D (? rx)))
- (WORD (4 #b0000)
- (3 rx)
- (2 #b10)
- (1 s)
- (3 #b001)
- (3 ry))
- (relative-word l)))
-\f
-;;;; 68010 and 68020 only privileged MOVE instructions.
-
-;;; move from/to control register.
-
-(define-instruction MOVEC
- ((((? creg cont-reg)) ((? rtype da) (? greg)))
- (WORD (15 #b010011100111101)
- (1 #b0))
- (EXTENSION-WORD (1 rtype)
- (3 greg)
- (12 creg)))
-
- ((((? rtype da) (? greg)) ((? creg cont-reg)))
- (WORD (15 #b010011100111101)
- (1 #b1))
- (EXTENSION-WORD (1 rtype)
- (3 greg)
- (12 creg))))
-
-(define-instruction MOVES
- (((? size bwl) ((? rtype da) (? reg)) (? dest ea-m&a))
- (WORD (8 #b00001110)
- (2 size)
- (6 dest DESTINATION-EA))
- (EXTENSION-WORD (1 rtype)
- (3 reg)
- (1 #b1)
- (11 #b00000000000)))
- (((? size bwl) (? dest ea-m&a) ((? rtype da) (? reg)))
- (WORD (8 #b00001110)
- (2 size)
- (6 dest DESTINATION-EA))
- (EXTENSION-WORD (1 rtype)
- (3 reg)
- (1 #b0)
- (11 #b00000000000))))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; 68020 Instruction Set Description (in addition to 68000)
-;;; Originally from arthur, patterned after GJS's.
-
-(declare (usual-integrations))
-\f
-;;;; Bit Field Instructions (1)
-
-(let-syntax
- ((define-bitfield-manipulation-1
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? ea ,(cadddr form)) (& (? offset)) (& (? width)) (D (? reg)))
- (WORD (4 #b1110)
- (4 ,(caddr form))
- (2 #b11)
- (6 ea DESTINATION-EA))
- (EXTENSION-WORD (1 #b0)
- (3 reg)
- (1 #b0)
- (5 offset)
- (1 #b0)
- (5 width BFWIDTH)))
-
- (((? ea ,(cadddr form)) (& (? offset))
- (D (? r-width))
- (D (? reg)))
- (WORD (4 #b1110)
- (4 ,(caddr form))
- (2 #b11)
- (6 ea DESTINATION-EA))
- (EXTENSION-WORD (1 #b0)
- (3 reg)
- (1 #b0)
- (5 offset)
- (3 #b100)
- (3 r-width)))
-
- (((? ea ,(cadddr form)) (D (? r-offset))
- (& (? width))
- (D (? reg)))
- (WORD (4 #b1110)
- (4 ,(caddr form))
- (2 #b11)
- (6 ea DESTINATION-EA))
- (EXTENSION-WORD (1 #b0)
- (3 reg)
- (3 #b100)
- (3 r-offset)
- (1 #b0)
- (5 width BFWIDTH)))
-
- (((? ea ,(cadddr form)) (D (? r-offset))
- (D (? r-width))
- (D (? reg)))
- (WORD (4 #b1110)
- (4 ,(caddr form))
- (2 #b11)
- (6 ea DESTINATION-EA))
- (EXTENSION-WORD (1 #b0)
- (3 reg)
- (3 #b100)
- (3 r-offset)
- (3 #b100)
- (3 r-width))))))))
-
- (define-bitfield-manipulation-1 BFEXTS #b1011 ea-d/c)
- (define-bitfield-manipulation-1 BFEXTU #b1001 ea-d/c)
- (define-bitfield-manipulation-1 BFFFO #b1101 ea-d/c)
- (define-bitfield-manipulation-1 BFINS #b1111 ea-d/c&a))
-\f
-;;;; Bit Field Instructions (2)
-
-(let-syntax
- ((define-bitfield-manipulation-2
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? ea ,(cadddr form)) (& (? offset)) (& (? width)))
- (WORD (4 #b1110)
- (4 ,(caddr form))
- (2 #b11)
- (6 ea DESTINATION-EA))
- (EXTENSION-WORD (4 #b0000)
- (1 #b0)
- (5 offset)
- (1 #b0)
- (5 width BFWIDTH)))
-
- (((? ea ,(cadddr form)) (& (? offset)) (D (? r-width)))
- (WORD (4 #b1110)
- (4 ,(caddr form))
- (2 #b11)
- (6 ea DESTINATION-EA))
- (EXTENSION-WORD (4 #b0000)
- (1 #b0)
- (5 offset)
- (3 #b100)
- (3 r-width)))
-
- (((? ea ,(cadddr form)) (D (? r-offset)) (& (? width)))
- (WORD (4 #b1110)
- (4 ,(caddr form))
- (2 #b11)
- (6 ea DESTINATION-EA))
- (EXTENSION-WORD (4 #b0000)
- (3 #b100)
- (3 r-offset)
- (1 #b0)
- (5 width BFWIDTH)))
-
- (((? ea ,(cadddr form)) (D (? r-offset)) (D (? r-width)))
- (WORD (4 #b1110)
- (4 ,(caddr form))
- (2 #b11)
- (6 ea DESTINATION-EA))
- (EXTENSION-WORD (4 #b0000)
- (3 #b100)
- (3 r-offset)
- (3 #b100)
- (3 r-width))))))))
-
- (define-bitfield-manipulation-2 BFCHG #b1010 ea-d/c&a)
- (define-bitfield-manipulation-2 BFCLR #b1100 ea-d/c&a)
- (define-bitfield-manipulation-2 BFSET #b1110 ea-d/c&a)
- (define-bitfield-manipulation-2 BFTST #b1000 ea-d/c))
-\f
-;;;; BCD instructions
-
-(define-instruction PACK
- (((- A (? x)) (- A (? y)) (& (? adjustment)))
- (WORD (4 #b1000)
- (3 y)
- (6 #b101001)
- (3 x))
- (immediate-word adjustment))
-
- (((D (? x)) (D (? y)) (& (? adjustment)))
- (WORD (4 #b1000)
- (3 y)
- (6 #b101000)
- (3 x))
- (immediate-word adjustment)))
-
-(define-instruction UNPK
- (((- A (? x)) (- A (? y)) (& (? adjustment)))
- (WORD (4 #b1000)
- (3 y)
- (6 #b110001)
- (3 x))
- (immediate-word adjustment))
-
- (((D (? x)) (D (? y)) (& (? adjustment)))
- (WORD (4 #b1000)
- (3 y)
- (6 #b110000)
- (3 x))
- (immediate-word adjustment)))
-\f
-;;;; Control
-
-;;; Call module instruction
-
-(define-instruction CALLM
- (((& (? argument-count)) (? ea ea-c))
- (WORD (10 #b0000011011)
- (6 ea DESTINATION-EA))
- (EXTENSION-WORD (8 #b00000000)
- (8 argument-count))))
-
-;;; Return from module instruction
-
-(define-instruction RTM
- ((((? rtype da) (? n)))
- (WORD (12 #b000001101100)
- (1 rtype)
- (3 n))))
-
-;;; Breakpoint instruction
-
-(define-instruction BKPT
- (((& (? data)))
- (WORD (13 #b0100100001001)
- (3 data))))
-\f
-;;; Compare and swap operand instructions
-
-(define-instruction CAS
- (((? size bwl+1) (D (? compare)) (D (? update)) (? ea ea-m&a))
- (WORD (5 #b00001)
- (2 size)
- (3 #b011)
- (6 ea DESTINATION-EA))
- (EXTENSION-WORD (7 #b0000000)
- (3 update)
- (3 #b000)
- (3 compare))))
-
-(define-instruction CAS2
- (((? size wl+2) (D (? c1)) (D (? c2)) (D (? u1)) (D (? u2))
- ((? Rtype1 da) (? n1))
- ((? Rtype2 da) (? n2)))
- (WORD (5 #b00001)
- (2 size)
- (9 #b011111100))
- (EXTENSION-WORD (1 Rtype1)
- (3 n1)
- (3 #b000)
- (3 u1)
- (3 #b000)
- (3 c1)
- (1 Rtype2)
- (3 n2)
- (3 #b000)
- (3 u2)
- (3 #b000)
- (3 c2))))
-\f
-;;;; Miscellaneous (continued)
-
-;;; Extend byte to longword instruction
-
-(define-instruction EXTB
- (((D (? n)))
- (WORD (7 #b0100100)
- (3 #b111)
- (3 #b000)
- (3 n))))
-
-;;; Range comparison instruction
-
-(define-instruction CMP2
- (((? size bwl) (? ea ea-c) ((? rtype da) (? n)))
- (WORD (5 #b00000)
- (2 size)
- (3 #b011)
- (6 ea SOURCE-EA size))
- (EXTENSION-WORD (1 rtype)
- (3 n)
- (12 #b000000000000))))
-
-;;; Range check instruction
-
-(define-instruction CHK2
- (((? size bwl) (? ea ea-c) ((? rtype da) (? n)))
- (WORD (5 #b00000)
- (2 size)
- (3 #b011)
- (6 ea SOURCE-EA size))
- (EXTENSION-WORD (1 rtype)
- (3 n)
- (12 #b100000000000))))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; 68000 utility procedures
-
-(declare (usual-integrations))
-\f
-;;;; Effective Addressing
-
-;;; *** NOTE: If this format changes, inerly.scm must also be changed! ***
-
-(define ea-tag
- "Effective-Address")
-
-(define (make-effective-address keyword mode register extension categories)
- (vector ea-tag keyword mode register extension categories))
-
-(define (effective-address? object)
- (and (vector? object)
- (not (zero? (vector-length object)))
- (eq? (vector-ref object 0) ea-tag)))
-
-(define-integrable (ea-keyword ea)
- (vector-ref ea 1))
-
-(define-integrable (ea-mode ea)
- (vector-ref ea 2))
-
-(define-integrable (ea-register ea)
- (vector-ref ea 3))
-
-(define-integrable (ea-extension ea)
- (vector-ref ea 4))
-
-(define-integrable (ea-categories ea)
- (vector-ref ea 5))
-
-(define-integrable (with-ea ea receiver)
- (receiver (ea-keyword ea)
- (ea-mode ea)
- (ea-register ea)
- (ea-extension ea)
- (ea-categories ea)))
-
-;; For completeness
-
-(define (ea-keyword-early ea)
- (vector-ref ea 1))
-
-(define (ea-mode-early ea)
- (vector-ref ea 2))
-
-(define (ea-register-early ea)
- (vector-ref ea 3))
-
-(define (ea-extension-early ea)
- (vector-ref ea 4))
-
-(define (ea-categories-early ea)
- (vector-ref ea 5))
-\f
-;;;; Effective Address Extensions
-
-(define-integrable (output-16bit-offset o)
- (EXTENSION-WORD (16 o SIGNED)))
-
-(define-integrable (output-16bit-relative l)
- (EXTENSION-WORD (16 `(- ,l *PC*) SIGNED)))
-
-(define-integrable (output-offset-index-register xtype xr s o)
- (EXTENSION-WORD (1 xtype)
- (3 xr)
- (1 s)
- (3 #b000)
- (8 o SIGNED)))
-
-(define-integrable (output-relative-index-register xtype xr s l)
- (EXTENSION-WORD (1 xtype)
- (3 xr)
- (1 s)
- (3 #b000)
- (8 `(- ,l *PC*) SIGNED)))
-
-(define-integrable (output-16bit-address a)
- (EXTENSION-WORD (16 a)))
-
-(define-integrable (output-32bit-address a)
- (EXTENSION-WORD (32 a)))
-
-(define (output-immediate-data immediate-size i)
- (case immediate-size
- ((B) (EXTENSION-WORD (8 #b00000000) (8 i SIGNED)))
- ((UB) (EXTENSION-WORD (8 #b00000000) (8 i UNSIGNED)))
- ((W) (EXTENSION-WORD (16 i SIGNED)))
- ((UW) (EXTENSION-WORD (16 i UNSIGNED)))
- ((L) (EXTENSION-WORD (32 i SIGNED)))
- ((UL) (EXTENSION-WORD (32 i UNSIGNED)))
- (else (error "illegal immediate size" immediate-size))))
-\f
-;;; Support for 68020 addressing modes
-
-(define-integrable (output-brief-format-extension-word
- index-register-type index-register
- index-size factor
- displacement)
- (EXTENSION-WORD (1 index-register-type)
- (3 index-register)
- (1 index-size)
- (2 factor SCALE-FACTOR)
- (1 #b0)
- (8 displacement SIGNED)))
-
-(define (output-full-format-extension-word index-register-type index-register
- index-size factor
- base-suppress index-suppress
- base-displacement-size
- base-displacement
- indirection-type
- outer-displacement-size
- outer-displacement)
- (let ((output-displacement
- (lambda (size displacement)
- (case size
- ((1) false)
- ((2) (EXTENSION-WORD (16 displacement SIGNED)))
- ((3) (EXTENSION-WORD (32 displacement SIGNED)))
- (else (error "illegal displacement-size" size))))))
- (apply
- optimize-group
- (let loop
- ((items
- (list
- (EXTENSION-WORD
- (1 index-register-type)
- (3 index-register)
- (1 index-size)
- (2 factor SCALE-FACTOR)
- (1 #b1)
- (1 base-suppress)
- (1 index-suppress)
- (2 base-displacement-size)
- (1 #b0)
- (3 (case indirection-type
- ((#F) #b000)
- ((PRE) outer-displacement-size)
- ((POST) (+ #b100 outer-displacement-size))
- (else (error "illegal indirection-type" indirection-type)))))
- (output-displacement base-displacement-size base-displacement)
- (output-displacement outer-displacement-size outer-displacement))))
- (if (null? items)
- '()
- (let ((rest (loop (cdr items))))
- (if (car items)
- (cons-syntax (car items) rest)
- rest)))))))
-\f
-;;;; Common special cases
-
-(define-integrable (output-@D-indirect register)
- (EXTENSION-WORD (1 #b0) ;index register = data
- (3 register)
- (1 #b1) ;index size = longword
- (2 #b00) ;scale factor = 1
- (1 #b1)
- (1 #b1) ;suppress base register
- (1 #b0) ;don't suppress index register
- (2 #b01) ;null base displacement
- (1 #b0)
- (3 #b000) ;no memory indirection
- ))
-
-(define (output-@DO-indirect register displacement)
- (EXTENSION-WORD (1 #b0) ;index register = data
- (3 register)
- (1 #b1) ;index size = 32 bits
- (2 #b00) ;scale factor = 1
- (1 #b1)
- (1 #b1) ;suppress base register
- (1 #b0) ;don't suppress index register
- (2 #b10) ;base displacement size = 16 bits
- (1 #b0)
- (3 #b000) ;no memory indirection
- (16 displacement SIGNED)))
-
-(define (output-32bit-offset offset)
- (EXTENSION-WORD (1 #b0) ;index register = data
- (3 #b000) ;register number = 0
- (1 #b0) ;index size = 32 bits
- (2 #b00) ;scale factor = 1
- (1 #b1)
- (1 #b0) ;use base register
- (1 #b1) ;suppress index register
- (2 #b11) ;base displacement size = 32 bits
- (1 #b0)
- (3 #b000) ;no memory indirection
- (32 offset SIGNED)))
-\f
-;;;; Operand Syntaxers.
-
-(define (immediate-words data size)
- (case size
- ((B) (immediate-byte data))
- ((W) (immediate-word data))
- ((L) (immediate-long data))
- ((UB) (immediate-unsigned-byte data))
- ((UW) (immediate-unsigned-word data))
- ((UL) (immediate-unsigned-long data))
- (else (error "Illegal size" size))))
-
-(define (immediate-unsigned-words data size)
- (case size
- ((B UB) (immediate-unsigned-byte data))
- ((W UW) (immediate-unsigned-word data))
- ((L UL) (immediate-unsigned-long data))
- (else (error "Illegal size" size))))
-
-(define-integrable (immediate-byte data)
- `(GROUP ,(make-bit-string 8 0)
- ,(syntax-evaluation data coerce-8-bit-signed)))
-
-(define-integrable (immediate-unsigned-byte data)
- `(GROUP ,(make-bit-string 8 0)
- ,(syntax-evaluation data coerce-8-bit-unsigned)))
-
-(define-integrable (immediate-word data)
- (syntax-evaluation data coerce-16-bit-signed))
-
-(define-integrable (immediate-unsigned-word data)
- (syntax-evaluation data coerce-16-bit-unsigned))
-
-(define-integrable (immediate-long data)
- (syntax-evaluation data coerce-32-bit-signed))
-
-(define-integrable (immediate-unsigned-long data)
- (syntax-evaluation data coerce-32-bit-unsigned))
-
-(define-integrable (relative-word address)
- (syntax-evaluation `(- ,address *PC*) coerce-16-bit-signed))
-
-(define-integrable (relative-long address)
- (syntax-evaluation `(- ,address *PC*) coerce-32-bit-signed))
-
-(define-integrable (offset-word data)
- (syntax-evaluation data coerce-16-bit-signed))
-
-(define-integrable (output-bit-string bit-string)
- bit-string)
-\f
-;;;; Randoms
-
-;; Auxiliary procedure for register list transformers
-
-(define (encode-register-list reg-list encoding)
- (let ((bit-string (make-bit-string 16 #!FALSE)))
- (define (loop regs)
- (if (null? regs)
- bit-string
- (let ((place (assq (car regs) encoding)))
- (if (null? place)
- #F
- (begin
- (bit-string-set! bit-string (cdr place))
- (loop (cdr regs)))))))
- (loop reg-list)))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RTL Rules for 68020. Part 1
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Register-Allocator Interface
-
-(define (reference->register-transfer source target)
- (cond ((or (and (effective-address/data-register? source)
- (= (lap:ea-operand-1 source) target))
- (and (effective-address/address-register? source)
- (= (+ 8 (lap:ea-operand-1 source)) target)))
- (LAP))
- ((effective-address/float-register? source)
- ;; Assume target is a float register
- (LAP (FMOVE ,source ,(register-reference target))))
- (else
- (memory->machine-register source target))))
-
-(define (register->register-transfer source target)
- (machine->machine-register source target))
-
-(define (home->register-transfer source target)
- (pseudo->machine-register source target))
-
-(define (register->home-transfer source target)
- (machine->pseudo-register source target))
-
-(define (pseudo-register-home register)
- (offset-reference regnum:regs-pointer (pseudo-register-offset register)))
-
-(define (sort-machine-registers registers)
- registers)
-
-(define available-machine-registers
- (list d0 d1 d2 d3 d4 d5 ;; d6 is now compiled code val
- a0 a1 a2 a3
- fp0 fp1 fp2 fp3 fp4 fp5 fp6 fp7))
-
-(define (register-type register)
- (cond ((machine-register? register)
- (vector-ref
- '#(DATA DATA DATA DATA DATA DATA DATA DATA
- ADDRESS ADDRESS ADDRESS ADDRESS ADDRESS ADDRESS ADDRESS ADDRESS
- FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT)
- register))
- ((register-value-class=word? register)
- (if (register-value-class=address? register)
- 'ADDRESS
- 'DATA))
- ((register-value-class=float? register)
- 'FLOAT)
- (else
- (error "unable to determine register type" register))))
-
-(define register-reference
- (let ((references (make-vector number-of-machine-registers)))
- (let loop ((i 0) (j 8))
- (if (< i 8)
- (begin
- (vector-set! references i (INST-EA (D ,i)))
- (vector-set! references j (INST-EA (A ,i)))
- (loop (1+ i) (1+ j)))))
- (subvector-move-right! '#(FP0 FP1 FP2 FP3 FP4 FP5 FP6 FP7) 0 8
- references 16)
- (lambda (register)
- (vector-ref references register))))
-
-(define mask-reference
- (register-reference 7))
-\f
-;;;; Basic Machine Instructions
-
-(define-integrable (pseudo->machine-register source target)
- (memory->machine-register (pseudo-register-home source) target))
-
-(define-integrable (machine->pseudo-register source target)
- (machine-register->memory source (pseudo-register-home target)))
-
-(define-integrable (pseudo-register-offset register)
- ;; Offset into register block for temporary registers
- (+ (+ (* 16 4) (* 80 8))
- (* 3 (register-renumber register))))
-
-(define (pseudo-float? register)
- (and (pseudo-register? register)
- (value-class=float? (pseudo-register-value-class register))))
-
-(define (pseudo-word? register)
- (and (pseudo-register? register)
- (value-class=word? (pseudo-register-value-class register))))
-
-(define (machine->machine-register source target)
- (guarantee-registers-compatible source target)
- (if (float-register? source)
- (LAP (FMOVE ,(register-reference source)
- ,(register-reference target)))
- (LAP (MOV L
- ,(register-reference source)
- ,(register-reference target)))))
-
-(define (machine-register->memory source target)
- (if (float-register? source)
- (LAP (FMOVE D ,(register-reference source) ,target))
- (LAP (MOV L ,(register-reference source) ,target))))
-
-(define (memory->machine-register source target)
- (if (float-register? target)
- (LAP (FMOVE D ,source ,(register-reference target)))
- (LAP (MOV L ,source ,(register-reference target)))))
-
-(define (offset-reference register offset)
- (byte-offset-reference register (* 4 offset)))
-
-(define (byte-offset-reference register offset)
- (if (zero? offset)
- (if (< register 8)
- (INST-EA (@D ,register))
- (INST-EA (@A ,(- register 8))))
- (if (< register 8)
- (INST-EA (@DO ,register ,offset))
- (INST-EA (@AO ,(- register 8) ,offset)))))
-\f
-(define (load-dnl n d)
- (cond ((zero? n)
- (LAP (CLR L (D ,d))))
- ((<= -128 n 127)
- (LAP (MOVEQ (& ,n) (D ,d))))
- (else
- (LAP (MOV L (& ,n) (D ,d))))))
-
-(define (load-dnw n d)
- (cond ((zero? n)
- (LAP (CLR W (D ,d))))
- ((<= -128 n 127)
- (LAP (MOVEQ (& ,n) (D ,d))))
- (else
- (LAP (MOV W (& ,n) (D ,d))))))
-
-(define (ea+=constant ea c)
- (cond ((zero? c)
- (LAP))
- ((<= 1 c 8)
- (LAP (ADDQ L (& ,c) ,ea)))
- ((>= -1 c -8)
- (LAP (SUBQ L (& (- 0 ,c)) ,ea)))
- ((eq? (lap:ea-keyword ea) 'A)
- (LAP (LEA (@AO ,(lap:ea-operand-1 ea) ,c) ,ea)))
- ((<= -128 c 127)
- (let ((temp (reference-temporary-register! 'DATA)))
- (LAP (MOVEQ (& ,c) ,temp)
- (ADD L ,temp ,ea))))
- (else
- (LAP (ADD L (& ,c) ,ea)))))
-
-(define (increment-machine-register register n)
- (ea+=constant (register-reference register) n))
-
-(define (load-constant constant target)
- (if (non-pointer-object? constant)
- (load-non-pointer-constant constant target)
- (LAP (MOV L
- (@PCR ,(constant->label constant))
- ,target))))
-
-(define (load-non-pointer-constant constant target)
- (load-non-pointer (object-type constant)
- (careful-object-datum constant)
- target))
-
-(define (load-non-pointer type datum target)
- (load-machine-constant (make-non-pointer-literal type datum) target))
-
-(define (load-machine-constant n target)
- (cond ((and (zero? n)
- (effective-address/data&alterable? target))
- (LAP (CLR L ,target)))
- ((not (effective-address/data-register? target))
- (LAP (MOV UL (& ,n) ,target)))
- ((<= -128 n 127)
- (LAP (MOVEQ (& ,n) ,target)))
- (else
- (find-zero-bits n
- (lambda (zero-bits datum)
- (cond ((> datum 127)
- (LAP (MOV UL (& ,n) ,target)))
- ((<= zero-bits 16)
- (LAP (MOVEQ (& ,datum) ,target)
- (LS L L (& ,zero-bits) ,target)))
- (else
- ;; This is useful for type-code or-masks.
- ;; It should be extended to handle and-masks.
- (LAP (MOVEQ (& ,datum) ,target)
- (RO R L (& ,(- 32 zero-bits)) ,target)))))))))
-
-(define (find-zero-bits n receiver)
- (let loop ((bits 0) (n n))
- (let ((result (integer-divide n 2)))
- (if (zero? (integer-divide-remainder result))
- (loop (1+ bits)
- (integer-divide-quotient result))
- (receiver bits n)))))
-
-(define (memory-set-type type target)
- (if (= 8 scheme-type-width)
- (LAP (MOV B (& ,type) ,target))
- (LAP (OR B (& ,(* type-scale-factor type)) ,target))))
-\f
-(define (test-byte n effective-address)
- ;; This is used to test actual bytes.
- ;; Type codes are "preprocessed" by the pertinent rule.
- (if (and (zero? n) (effective-address/data&alterable? effective-address))
- (LAP (TST B ,effective-address))
- (LAP (CMPI B (& ,n) ,effective-address))))
-
-(define (test-non-pointer-constant constant target)
- (test-non-pointer (object-type constant)
- (careful-object-datum constant)
- target))
-
-(define (test-non-pointer type datum effective-address)
- (if (and (zero? type)
- (zero? datum)
- (effective-address/data&alterable? effective-address))
- (LAP (TST L ,effective-address))
- (LAP (CMPI UL
- (& ,(make-non-pointer-literal type datum))
- ,effective-address))))
-
-(define (set-standard-branches! cc)
- (set-current-branches!
- (lambda (label)
- (LAP (B ,cc (@PCR ,label))))
- (lambda (label)
- (LAP (B ,(invert-cc cc) (@PCR ,label))))))
-
-(define (invert-cc cc)
- (cdr (or (assq cc
- '((T . F) (F . T)
- (HI . LS) (LS . HI)
- (HS . LO) (LO . HS)
- (CC . CS) (CS . CC)
- (NE . EQ) (EQ . NE)
- (VC . VS) (VS . VC)
- (PL . MI) (MI . PL)
- (GE . LT) (LT . GE)
- (GT . LE) (LE . GT)
- ))
- (error "INVERT-CC: Not a known CC" cc))))
-
-(define (invert-cc-noncommutative cc)
- ;; Despite the fact that the name of this procedure is similar to
- ;; that of `invert-cc', it is quite different. `invert-cc' is used
- ;; when the branches of a conditional are being exchanged, while
- ;; this is used when the arguments are being exchanged.
- (cdr (or (assq cc
- '((HI . LO) (LO . HI)
- (HS . LS) (LS . HS)
- (CC . LS) (CS . HI)
- (PL . MI) (MI . PL)
- (GE . LE) (LE . GE)
- (GT . LT) (LT . GT)
- (T . T) (F . F)
- (NE . NE) (EQ . EQ)
- (VC . VC) (VS . VS)
- ))
- (error "INVERT-CC-NONCOMMUTATIVE: Not a known CC" cc))))
-
-(define-integrable (cc-commutative? cc)
- (memq cc '(T F NE EQ)))
-
-(define-integrable (effective-address/data&alterable? ea)
- (memq (lap:ea-keyword ea) '(D @D @A @A+ @-A @AO @DO @AOX W L)))
-
-(define-integrable (effective-address/register? ea)
- (memq (lap:ea-keyword ea) '(A D)))
-
-(define-integrable (effective-address/data-register? ea)
- (eq? (lap:ea-keyword ea) 'D))
-
-(define-integrable (effective-address/address-register? ea)
- (eq? (lap:ea-keyword ea) 'A))
-
-(define (effective-address/float-register? ea)
- (memq ea '(FP0 FP1 FP2 FP3 FP4 FP5 FP6 FP7)))
-\f
-(define (standard-target-reference target)
- ;; Our preference for data registers here is a heuristic that works
- ;; reasonably well since if the value is a pointer, we will probably
- ;; want to dereference it, which requires that we first mask it.
- (delete-dead-registers!)
- (register-reference
- (or (register-alias target 'DATA)
- (register-alias target 'ADDRESS)
- (allocate-alias-register! target 'DATA))))
-
-(define (standard-move-to-target! source type target)
- (register-reference (move-to-alias-register! source type target)))
-
-(define (standard-move-to-temporary! source type)
- (register-reference (move-to-temporary-register! source type)))
-
-(define-integrable (preferred-data-register-reference register)
- (register-reference (preferred-data-register register)))
-
-(define (preferred-data-register register)
- (or (register-alias register 'DATA)
- (register-alias register 'ADDRESS)
- (load-alias-register! register 'DATA)))
-
-(define-integrable (preferred-address-register-reference register)
- (register-reference (preferred-address-register register)))
-
-(define (preferred-address-register register)
- (or (register-alias register 'ADDRESS)
- (register-alias register 'DATA)
- (load-alias-register! register 'ADDRESS)))
-
-(define (rtl:simple-byte-offset? expression)
- (and (rtl:byte-offset? expression)
- (let ((base (rtl:byte-offset-base expression))
- (offset (rtl:byte-offset-offset expression)))
- (if (rtl:register? base)
- (or (rtl:machine-constant? offset)
- (rtl:register? offset))
- (and (rtl:byte-offset-address? base)
- (rtl:machine-constant? offset)
- (rtl:register? (rtl:byte-offset-address-base base))
- (rtl:register? (rtl:byte-offset-address-offset base)))))
- expression))
-
-(define (byte-offset->reference! offset)
- ;; OFFSET must be a simple byte offset
- (let ((base (rtl:byte-offset-base offset))
- (offset (rtl:byte-offset-offset offset)))
- (cond ((not (rtl:register? base))
- (indexed-ea (rtl:register-number
- (rtl:byte-offset-address-base base))
- (rtl:register-number
- (rtl:byte-offset-address-offset base))
- 1
- (rtl:machine-constant-value offset)))
- ((rtl:machine-constant? offset)
- (indirect-byte-reference! (rtl:register-number base)
- (rtl:machine-constant-value offset)))
- (else
- (indexed-ea (rtl:register-number base)
- (rtl:register-number offset)
- 1
- 0)))))
-\f
-(define (rtl:simple-offset? expression)
- (and (rtl:offset? expression)
- (let ((base (rtl:offset-base expression))
- (offset (rtl:offset-offset expression)))
- (if (rtl:register? base)
- (or (rtl:machine-constant? offset)
- (rtl:register? offset))
- (and (rtl:offset-address? base)
- (rtl:machine-constant? offset)
- (rtl:register? (rtl:offset-address-base base))
- (rtl:register? (rtl:offset-address-offset base)))))
- expression))
-
-(define (offset->reference! offset)
- ;; OFFSET must be a simple offset
- (let ((base (rtl:offset-base offset))
- (offset (rtl:offset-offset offset)))
- (cond ((not (rtl:register? base))
- (indexed-ea (rtl:register-number (rtl:offset-address-base base))
- (rtl:register-number (rtl:offset-address-offset base))
- 4
- (* 4 (rtl:machine-constant-value offset))))
- ((rtl:machine-constant? offset)
- (indirect-reference! (rtl:register-number base)
- (rtl:machine-constant-value offset)))
- (else
- (indexed-ea (rtl:register-number base)
- (rtl:register-number offset)
- 4
- 0)))))
-
-(define (offset->reference!/char offset)
- ;; OFFSET must be a simple offset
- (let ((base (rtl:offset-base offset))
- (offset (rtl:offset-offset offset)))
- (cond ((not (rtl:register? base))
- (indexed-ea (rtl:register-number (rtl:offset-address-base base))
- (rtl:register-number (rtl:offset-address-offset base))
- 4
- (+ 3 (* 4 (rtl:machine-constant-value offset)))))
- ((rtl:machine-constant? offset)
- (indirect-byte-reference!
- (rtl:register-number base)
- (+ 3 (* 4 (rtl:machine-constant-value offset)))))
- (else
- (indexed-ea (rtl:register-number base)
- (rtl:register-number offset)
- 4
- 3)))))
-\f
-(define (rtl:simple-float-offset? expression)
- (and (rtl:float-offset? expression)
- (let ((base (rtl:float-offset-base expression))
- (offset (rtl:float-offset-offset expression)))
- (and (or (rtl:machine-constant? offset)
- (rtl:register? offset))
- (or (rtl:register? base)
- (and (rtl:offset-address? base)
- (rtl:register? (rtl:offset-address-base base))
- (rtl:machine-constant?
- (rtl:offset-address-offset base))))))
- expression))
-
-(define (float-offset->reference! offset)
- ;; OFFSET must be a simple float offset
- (let ((base (rtl:float-offset-base offset))
- (offset (rtl:float-offset-offset offset)))
- (cond ((not (rtl:register? base))
- (let ((base*
- (rtl:register-number (rtl:offset-address-base base)))
- (w-offset
- (rtl:machine-constant-value
- (rtl:offset-address-offset base))))
- (if (rtl:machine-constant? offset)
- (indirect-reference!
- base*
- (+ (* 2 (rtl:machine-constant-value offset))
- w-offset))
- (indexed-ea base*
- (rtl:register-number offset)
- 8
- (* 4 w-offset)))))
- ((rtl:machine-constant? offset)
- (indirect-reference! (rtl:register-number base)
- (* 2 (rtl:machine-constant-value offset))))
- (else
- (indexed-ea (rtl:register-number base)
- (rtl:register-number offset)
- 8
- 0)))))
-
-(define (indexed-ea base index scale offset)
- (let ((base (allocate-indirection-register! base))
- (index (preferred-data-register-reference index)))
- (INST-EA (@AOXS ,(->areg base) ,offset (,index L ,scale)))))
-
-(define (indirect-reference! register offset)
- (offset-reference (allocate-indirection-register! register) offset))
-
-(define (indirect-byte-reference! register offset)
- (byte-offset-reference (allocate-indirection-register! register) offset))
-
-(define-integrable (allocate-indirection-register! register)
- (load-alias-register! register 'ADDRESS))
-\f
-(define (generate-n-times n limit instruction-gen with-counter)
- (if (> n limit)
- (let ((loop (generate-label 'LOOP)))
- (with-counter
- (lambda (counter)
- (LAP ,@(load-dnw (-1+ n) counter)
- (LABEL ,loop)
- ,@(instruction-gen)
- (DB F (D ,counter) (@PCR ,loop))))))
- (let loop ((n n))
- (if (zero? n)
- (LAP)
- (LAP ,@(instruction-gen)
- ,@(loop (-1+ n)))))))
-
-#|
-
-;;; These seem to be fossils --- GJR 7/1/1993
-
-(define (standard-target-expression? target)
- (or (rtl:simple-offset? target)
- (rtl:free-push? target)
- (rtl:stack-push? target)))
-
-(define (standard-target-expression->ea target)
- (cond ((rtl:offset? target) (offset->reference! target))
- ((rtl:free-push? target) (INST-EA (@A+ 5)))
- ((rtl:stack-push? target) (INST-EA (@-A 7)))
- (else (error "STANDARD-TARGET->EA: Not a standard target" target))))
-|#
-
-(define (rtl:free-push? expression)
- (and (rtl:post-increment? expression)
- (interpreter-free-pointer? (rtl:post-increment-register expression))
- (= 1 (rtl:post-increment-number expression))))
-
-(define (rtl:stack-push? expression)
- (and (rtl:pre-increment? expression)
- (interpreter-stack-pointer? (rtl:pre-increment-register expression))
- (= -1 (rtl:pre-increment-number expression))))
-\f
-;;;; Machine Targets (actually, arithmetic targets)
-
-(define (reuse-and-load-machine-target! type target source operate-on-target)
- (reuse-machine-target! type target
- (lambda (target)
- (operate-on-target
- (register-reference (move-to-alias-register! source type target))))
- (lambda (target)
- (LAP
- ,@(if (eq? type 'FLOAT)
- (load-float-register
- (standard-register-reference source type false)
- target)
- (LAP (MOV L
- ,(standard-register-reference source type true)
- ,target)))
- ,@(operate-on-target target)))))
-
-(define (reuse-machine-target! type
- target
- operate-on-pseudo-target
- operate-on-machine-target)
- (let ((use-temporary
- (lambda (target)
- (let ((temp (reference-temporary-register! type)))
- (LAP ,@(operate-on-machine-target temp)
- ,@(if (eq? type 'FLOAT)
- (load-float-register temp target)
- (LAP (MOV L ,temp ,target))))))))
- (case (rtl:expression-type target)
- ((REGISTER)
- (let ((register (rtl:register-number target)))
- (if (pseudo-register? register)
- (operate-on-pseudo-target register)
- (let ((target (register-reference register)))
- (if (eq? type (register-type register))
- (operate-on-machine-target target)
- (use-temporary target))))))
- ((OFFSET)
- (use-temporary (offset->reference! target)))
- (else
- (error "Illegal machine target" target)))))
-
-(define (load-float-register source target)
- (if (effective-address/float-register? source)
- (LAP (FMOVE ,source ,target))
- (LAP (FMOVE D ,source ,target))))
-
-(define (reuse-and-operate-on-machine-target! type target operate-on-target)
- (reuse-machine-target! type target
- (lambda (target)
- (operate-on-target (reference-target-alias! target type)))
- operate-on-target))
-
-(define (machine-operation-target? expression)
- (or (rtl:register? expression)
- (rtl:simple-offset? expression)))
-\f
-(define (two-arg-register-operation
- operate commutative?
- target-type source-reference alternate-source-reference
- target source1 source2)
- (let ((worst-case
- (lambda (target source1 source2)
- (LAP ,@(if (eq? target-type 'FLOAT)
- (load-float-register source1 target)
- (LAP (MOV L ,source1 ,target)))
- ,@(operate target source2)))))
- (reuse-machine-target! target-type target
- (lambda (target)
- (reuse-pseudo-register-alias source1 target-type
- (lambda (alias)
- (let ((source2 (if (= source1 source2)
- (register-reference alias)
- (source-reference source2))))
- (delete-register! alias)
- (delete-dead-registers!)
- (add-pseudo-register-alias! target alias)
- (operate (register-reference alias) source2)))
- (lambda ()
- (let ((new-target-alias!
- (lambda ()
- (let ((source1 (alternate-source-reference source1))
- (source2 (source-reference source2)))
- (delete-dead-registers!)
- (worst-case (reference-target-alias! target target-type)
- source1
- source2)))))
- (if commutative?
- (reuse-pseudo-register-alias source2 target-type
- (lambda (alias2)
- (let ((source1 (source-reference source1)))
- (delete-register! alias2)
- (delete-dead-registers!)
- (add-pseudo-register-alias! target alias2)
- (operate (register-reference alias2) source1)))
- new-target-alias!)
- (new-target-alias!))))))
- (lambda (target)
- (worst-case target
- (alternate-source-reference source1)
- (source-reference source2))))))
-\f
-;;;; Fixnum Operators
-
-(define (signed-fixnum? n)
- (and (exact-integer? n)
- (>= n signed-fixnum/lower-limit)
- (< n signed-fixnum/upper-limit)))
-
-(define (unsigned-fixnum? n)
- (and (exact-integer? n)
- (not (negative? n))
- (< n unsigned-fixnum/upper-limit)))
-
-(define (guarantee-signed-fixnum n)
- (if (not (signed-fixnum? n)) (error "Not a signed fixnum" n))
- n)
-
-(define (guarantee-unsigned-fixnum n)
- (if (not (unsigned-fixnum? n)) (error "Not a unsigned fixnum" n))
- n)
-
-(define-integrable fixnum-1
- ;; (expt 2 scheme-type-width) ***
- 64)
-
-(define (load-fixnum-constant constant register-reference)
- (LAP (MOV L (& ,(* constant fixnum-1)) ,register-reference)))
-
-(define (object->fixnum reg-ref)
- (LAP (LS L L (& ,scheme-type-width) ,reg-ref)))
-
-(define (address->fixnum reg-ref)
- (LAP (LS L L (& ,scheme-type-width) ,reg-ref)))
-
-(define (fixnum->object reg-ref)
- (LAP (OR B (& ,(ucode-type fixnum)) ,reg-ref)
- (RO R L (& ,scheme-type-width) ,reg-ref)))
-
-(define (fixnum->address reg-ref)
- (LAP (LS R L (& ,scheme-type-width) ,reg-ref)))
-
-(define (test-fixnum effective-address)
- (if (effective-address/data&alterable? effective-address)
- (LAP (TST L ,effective-address))
- (LAP (CMPI L (& 0) ,effective-address))))
-
-(define (fixnum-predicate->cc predicate)
- (case predicate
- ((EQUAL-FIXNUM? ZERO-FIXNUM?) 'EQ)
- ((LESS-THAN-FIXNUM? NEGATIVE-FIXNUM?) 'LT)
- ((GREATER-THAN-FIXNUM? POSITIVE-FIXNUM?) 'GT)
- (else (error "FIXNUM-PREDICATE->CC: Unknown predicate" predicate))))
-
-(define (fixnum-2-args/commutative? operator)
- (memq operator '(PLUS-FIXNUM
- MULTIPLY-FIXNUM
- FIXNUM-AND
- FIXNUM-OR
- FIXNUM-XOR)))
-\f
-(define (define-fixnum-method operator methods method)
- (let ((entry (assq operator (cdr methods))))
- (if entry
- (set-cdr! entry method)
- (set-cdr! methods (cons (cons operator method) (cdr methods)))))
- operator)
-
-(define (lookup-fixnum-method operator methods)
- (cdr (or (assq operator (cdr methods))
- (error "Unknown operator" operator))))
-
-(define fixnum-methods/1-arg
- (list 'FIXNUM-METHODS/1-ARG))
-
-(define-integrable (fixnum-1-arg/operate operator)
- (lookup-fixnum-method operator fixnum-methods/1-arg))
-
-(define fixnum-methods/2-args
- (list 'FIXNUM-METHODS/2-ARGS))
-
-(define-integrable (fixnum-2-args/operate operator)
- (lookup-fixnum-method operator fixnum-methods/2-args))
-
-(define fixnum-methods/2-args-constant
- (list 'FIXNUM-METHODS/2-ARGS-CONSTANT))
-
-(define-integrable (fixnum-2-args/operate-constant operator)
- (lookup-fixnum-method operator fixnum-methods/2-args-constant))
-
-(define-integrable fixnum-bits-mask
- (fix:not scheme-type-mask))
-
-(define (word->fixnum target)
- ;; This renormalizes a fixnum after a bit-wise boolean operation.
- (cond ((= scheme-type-width 8)
- (LAP (CLR B ,target)))
- ((< scheme-type-width 8)
- (LAP (AND B (& ,fixnum-bits-mask) ,target)))
- (else
- (LAP (AND L (& ,fixnum-bits-mask) ,target)))))
-
-(define (integer-log-base-2? n)
- (let loop ((power 1) (exponent 0))
- (cond ((< n power) false)
- ((= n power) exponent)
- (else (loop (* 2 power) (1+ exponent))))))
-\f
-(define-fixnum-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
- (lambda (reference)
- (LAP (ADD L (& ,fixnum-1) ,reference))))
-
-(define-fixnum-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg
- (lambda (reference)
- (LAP (SUB L (& ,fixnum-1) ,reference))))
-
-(define-fixnum-method 'FIXNUM-NOT fixnum-methods/1-arg
- (lambda (reference)
- (LAP (NOT L ,reference)
- ,@(word->fixnum reference))))
-
-(let-syntax
- ((binary-fixnum
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(BEGIN
- (DEFINE-FIXNUM-METHOD ',(cadr form) FIXNUM-METHODS/2-ARGS
- (LAMBDA (TARGET SOURCE)
- (LAP (,(caddr form) L ,',SOURCE ,',TARGET))))
- (DEFINE-FIXNUM-METHOD ',(cadr form) FIXNUM-METHODS/2-ARGS-CONSTANT
- (LAMBDA (TARGET N)
- (IF (,(cadddr form) N)
- (LAP)
- (LAP (,(caddr form) L
- (& ,',(* N FIXNUM-1))
- ,',TARGET))))))))))
-
- (binary-fixnum PLUS-FIXNUM ADD zero?)
- (binary-fixnum FIXNUM-OR OR zero?)
- (binary-fixnum FIXNUM-AND AND
- (lambda (n)
- (declare (integrate n))
- (fix:= n -1))))
-
-;; XOR is weird because the first operand for an EOR instruction
-;; must be a D register!
-
-(define-fixnum-method 'FIXNUM-XOR fixnum-methods/2-args
- (lambda (target source)
- (if (effective-address/data-register? source)
- (LAP (EOR L ,source ,target))
- (let ((temp (reference-temporary-register! 'DATA)))
- (LAP (MOV L ,source ,temp)
- (EOR L ,temp ,target))))))
-
-(define-fixnum-method 'FIXNUM-XOR fixnum-methods/2-args-constant
- (lambda (target n)
- (if (zero? n)
- (LAP)
- (LAP (EOR L (& ,(* n fixnum-1)) ,target)))))
-\f
-;; Multiply is hairy, since numbers are shifted by the type code width.
-;; Rather than unshift, multiply, and shift, we unshift one and then
-;; multiply, but we have to be careful if the source is the same
-;; as the destination.
-
-(define-fixnum-method 'MULTIPLY-FIXNUM fixnum-methods/2-args
- (lambda (target source)
- (cond ((not (equal? target source))
- (LAP
- (AS R L (& ,scheme-type-width) ,target)
- (MUL S L ,source ,target)))
- ((even? scheme-type-width)
- (LAP
- (AS R L (& ,(quotient scheme-type-width 2)) ,target)
- (MUL S L ,source ,target)))
- (else
- #|
- ;; This is no good because the MUL instruction is
- ;; not last, and thus the overflow condition is
- ;; not set appropriately.
- (LAP
- (AS R L (& ,scheme-type-width) ,target)
- (MUL S L ,source ,target)
- (AS L L (& ,scheme-type-width) ,target))
- |#
- (let ((temp (reference-temporary-register! 'DATA)))
- (LAP
- (MOV L ,source ,temp)
- (AS R L (& ,scheme-type-width) ,target)
- (MUL S L ,temp ,target)))))))
-
-(define-fixnum-method 'MULTIPLY-FIXNUM fixnum-methods/2-args-constant
- (lambda (target n)
- (cond ((zero? n) (LAP (CLR L ,target)))
- ((= n 1) (LAP))
- ((= n -1) (LAP (NEG L ,target)))
- (else
- (let ((power-of-2 (integer-log-base-2? n)))
- (cond ((not power-of-2)
- (LAP (MUL S L (& ,n) ,target)))
- ((> power-of-2 8)
- (let ((temp (reference-temporary-register! 'DATA)))
- (LAP (MOV L (& ,power-of-2) ,temp)
- (AS L L ,temp ,target))))
- (else
- (LAP (AS L L (& ,power-of-2) ,target)))))))))
-\f
-(define-fixnum-method 'MINUS-FIXNUM fixnum-methods/2-args
- (lambda (target source)
- (LAP (SUB L ,source ,target))))
-
-(define-fixnum-method 'MINUS-FIXNUM fixnum-methods/2-args-constant
- (lambda (target n)
- (if (zero? n)
- (LAP)
- (LAP (SUB L (& ,(* n fixnum-1)) ,target)))))
-
-(define-fixnum-method 'FIXNUM-ANDC fixnum-methods/2-args
- (lambda (target source)
- (let ((temp (reference-temporary-register! 'DATA)))
- (LAP (MOV L ,source ,temp)
- (NOT L ,temp)
- (AND L ,temp ,target)))))
-
-(define-fixnum-method 'FIXNUM-ANDC fixnum-methods/2-args-constant
- (lambda (target n)
- (if (zero? n)
- (LAP)
- (LAP (AND L (& ,(* (fix:not n) fixnum-1)) ,target)))))
-
-(define-fixnum-method 'FIXNUM-LSH fixnum-methods/2-args
- (lambda (target source)
- (let ((temp (reference-temporary-register! 'DATA))
- (merge (generate-label 'LSH-MERGE))
- (nonneg (generate-label 'LSH-NONNEG)))
- (LAP (MOV L ,source ,temp)
- (AS R L (& ,scheme-type-width) ,temp)
- (B GE (@PCR ,nonneg))
- (NEG L ,temp)
- (LS R L ,temp ,target)
- ,@(word->fixnum target)
- (BRA (@PCR ,merge))
- (LABEL ,nonneg)
- (LS L L ,temp ,target)
- (LABEL ,merge)))))
-
-(define-fixnum-method 'FIXNUM-LSH fixnum-methods/2-args-constant
- (lambda (target n)
- (cond ((zero? n)
- (LAP))
- ((negative? n)
- (let ((m (- 0 n)))
- (if (< m 9)
- (LAP (LS R L (& ,m) ,target)
- ,@(word->fixnum target))
- (let ((temp (reference-temporary-register! 'DATA)))
- (LAP ,@(load-dnl m temp)
- (LS R L ,temp ,target)
- ,@(word->fixnum target))))))
- (else
- (if (< n 9)
- (LAP (LS L L (& ,n) ,target))
- (let ((temp (reference-temporary-register! 'DATA)))
- (LAP ,@(load-dnl n temp)
- (LS L L ,temp ,target))))))))
-\f
-;;; Quotient is weird because it must shift left the quotient,
-;;; to normalize it as a fixnum, and because arithmetic shifting
-;;; does not really do the right thing.
-
-(define-fixnum-method 'FIXNUM-QUOTIENT fixnum-methods/2-args
- (lambda (target source)
- (LAP
- (DIV S L ,source ,target)
- (AS L L (& ,scheme-type-width) ,target))))
-
-(define-fixnum-method 'FIXNUM-QUOTIENT fixnum-methods/2-args-constant
- (lambda (target n)
- (cond ((= n 1) (LAP))
- ((= n -1) (LAP (NEG L ,target)))
- ((integer-log-base-2? n)
- =>
- (lambda (power-of-2)
- (let ((label (generate-label 'QUO-SHIFT)))
- (LAP (TST L ,target)
- (B GE (@PCR ,label))
- (ADD L (& ,(* (-1+ n) fixnum-1)) ,target)
- (LABEL ,label)
- ,@(if (<= power-of-2 8)
- (LAP (AS R L (& ,power-of-2) ,target))
- (let ((temp (reference-temporary-register! 'DATA)))
- (LAP (MOV L (& ,power-of-2) ,temp)
- (AS R L ,temp ,target))))
- ,@(word->fixnum target)))))
- (else
- ;; This includes negative n
- (LAP (DIV S L (& ,(* n fixnum-1)) ,target)
- (AS L L (& ,scheme-type-width) ,target))))))
-
-(define-fixnum-method 'FIXNUM-REMAINDER fixnum-methods/2-args
- (lambda (target source)
- (let ((temp (reference-temporary-register! 'DATA)))
- (LAP (DIVL S L ,source ,temp ,target)
- (MOV L ,temp ,target)))))
-
-(define-fixnum-method 'FIXNUM-REMAINDER fixnum-methods/2-args-constant
- (lambda (target n)
- ;; (remainder x y) is 0 or has the sign of x.
- ;; Thus we can always "divide" by (abs y) to make things simpler.
- (let ((n (abs n)))
- (if (= n 1)
- (LAP (CLR L ,target))
- (let ((xpt (integer-log-base-2? n)))
- (if (or (not xpt) (not use-68020-instructions?))
- (let ((temp (reference-temporary-register! 'DATA)))
- (LAP (DIVL S L (& ,(* n fixnum-1)) ,temp ,target)
- (MOV L ,temp ,target)))
- (let ((sign (reference-temporary-register! 'DATA))
- (label (generate-label 'REM-MERGE))
- (shift (- scheme-datum-width xpt))
- (nbits (+ scheme-type-width xpt)))
- #|
- (LAP (CLR L ,sign)
- (BFTST ,target (& ,shift) (& ,xpt))
- (B EQ (@PCR ,label))
- (BFEXTS ,target (& 0) (& 1) ,sign)
- (LABEL ,label)
- (BFINS ,target (& 0) (& ,shift) ,sign))
- |#
- ;; This may produce a branch to a branch, but a
- ;; peephole optimizer should be able to fix this.
- (LAP (BFEXTS ,target (& 0) (& 1) ,sign)
- (BFEXTU ,target (& ,(- 32 nbits)) (& ,nbits) ,target)
- (B EQ (@PCR ,label))
- (BFINS ,target (& 0) (& ,shift) ,sign)
- (LABEL ,label)))))))))
-\f
-;;;; Flonum Operators
-
-(define (define-flonum-method operator methods method)
- (let ((entry (assq operator (cdr methods))))
- (if entry
- (set-cdr! entry method)
- (set-cdr! methods (cons (cons operator method) (cdr methods)))))
- operator)
-
-(define (lookup-flonum-method operator methods)
- (cdr (or (assq operator (cdr methods))
- (error "Unknown operator" operator))))
-
-(define flonum-methods/1-arg
- (list 'FLONUM-METHODS/1-ARG))
-
-(define-integrable (flonum-1-arg/operate operator)
- (lookup-flonum-method operator flonum-methods/1-arg))
-
-;;; Notice the weird ,', syntax here.
-;;; If LAP changes, this may also have to change.
-
-(let-syntax
- ((define-flonum-operation
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-FLONUM-METHOD ',(cadr form) FLONUM-METHODS/1-ARG
- (LAMBDA (SOURCE TARGET)
- (IF (EFFECTIVE-ADDRESS/FLOAT-REGISTER? SOURCE)
- (LAP (,(caddr form) ,',SOURCE ,',TARGET))
- (LAP (,(caddr form) D ,',SOURCE ,',TARGET)))))))))
- (define-flonum-operation flonum-negate fneg)
- (define-flonum-operation flonum-abs fabs)
- (define-flonum-operation flonum-sin fsin)
- (define-flonum-operation flonum-cos fcos)
- (define-flonum-operation flonum-tan ftan)
- (define-flonum-operation flonum-asin fasin)
- (define-flonum-operation flonum-acos facos)
- (define-flonum-operation flonum-atan fatan)
- (define-flonum-operation flonum-exp fetox)
- (define-flonum-operation flonum-log flogn)
- (define-flonum-operation flonum-sqrt fsqrt)
- (define-flonum-operation flonum-round fint)
- (define-flonum-operation flonum-truncate fintrz))
-\f
-(define flonum-methods/2-args
- (list 'FLONUM-METHODS/2-ARGS))
-
-(define-integrable (flonum-2-args/operate operator)
- (lookup-flonum-method operator flonum-methods/2-args))
-
-(let-syntax
- ((define-flonum-operation
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-FLONUM-METHOD ',(cadr form) FLONUM-METHODS/2-ARGS
- (LAMBDA (TARGET SOURCE)
- (IF (EFFECTIVE-ADDRESS/FLOAT-REGISTER? SOURCE)
- (LAP (,(caddr form) ,',SOURCE ,',TARGET))
- (LAP (,(caddr form) D ,',SOURCE ,',TARGET)))))))))
- (define-flonum-operation flonum-add fadd)
- (define-flonum-operation flonum-subtract fsub)
- (define-flonum-operation flonum-multiply fmul)
- (define-flonum-operation flonum-divide fdiv))
-
-(define (invert-float-cc cc)
- (cdr (or (assq cc
- '((EQ . NE) (NE . EQ)
- (GT . NGT) (NGT . GT)
- (GE . NGE) (NGE . GE)
- (LT . NLT) (NLT . LT)
- (LE . NLE) (NLE . LE)
- (GL . NGL) (NGL . GL)
- (MI . PL) (PL . MI)))
- (error "INVERT-FLOAT-CC: Not a known CC" cc))))
-
-(define (set-flonum-branches! cc)
- (set-current-branches!
- (lambda (label)
- (LAP (FB ,cc (@PCR ,label))))
- (lambda (label)
- (LAP (FB ,(invert-float-cc cc) (@PCR ,label))))))
-
-(define (flonum-predicate->cc predicate)
- (case predicate
- ((FLONUM-EQUAL? FLONUM-ZERO?) 'EQ)
- ((FLONUM-LESS? FLONUM-NEGATIVE?) 'LT)
- ((FLONUM-GREATER? FLONUM-POSITIVE?) 'GT)
- (else (error "FLONUM-PREDICATE->CC: Unknown predicate" predicate))))
-
-(define (flonum-2-args/commutative? operator)
- (memq operator '(FLONUM-ADD FLONUM-MULTIPLY)))
-\f
-;;;; OBJECT->DATUM rules - Mhwu
-;;; Similar to fixnum rules, but no sign extension
-
-#|
-
-;; *** This is believed to be a fossil. ***
-;; Left here until the first compilation to make sure that it really is.
-;; Can be removed the next time it is seen.
-
-(define (load-constant-datum constant register-ref)
- (if (non-pointer-object? constant)
- (LAP (MOV L (& ,(careful-object-datum constant)) ,register-ref))
- (LAP (MOV L
- (@PCR ,(constant->label constant))
- ,register-ref)
- ,@(object->address register-ref))))
-
-|#
-
-(define (object->address register-reference)
- (LAP (AND L ,mask-reference ,register-reference)))
-
-(define (object->datum register-reference)
- (LAP (AND L ,mask-reference ,register-reference)))
-
-(define-integrable scheme-type-mask
- ;; (-1+ (expt 2 scheme-type-width)) ***
- #x3f)
-
-(define-integrable use-68020-instructions? true)
-
-(define (object->type source target)
- ;; `Source' must be a data register or non-volatile memory reference.
- ;; `Target' must be a data register reference.
- ;; Guarantees that the condition codes are set for a zero-compare.
- (cond (use-68020-instructions?
- (LAP (BFEXTU ,source (& 0) (& ,scheme-type-width) ,target)))
- ((memq (lap:ea-keyword source) '(@D @A @AO @DO @AOX W L))
- (LAP (CLR L ,target)
- (MOVE B ,source ,target)
- ,@(if (= scheme-type-width 8)
- (LAP)
- (LAP (LS R B (& ,(- 8 scheme-type-width)) ,target)))))
- (else
- (LAP ,@(if (equal? source target)
- (LAP)
- (LAP (MOVE L ,source ,target)))
- (RO L L (& ,scheme-type-width) ,target)
- (AND L (& ,scheme-type-mask) ,target)))))
-\f
-;;;; CHAR->ASCII rules
-
-(define (coerce->any/byte-reference register)
- #|
- ;; This does not guarantee that the data is in a
- ;; D register, and A registers are no good.
- (if (machine-register? register)
- (register-reference register)
- (let ((alias (register-alias register false)))
- (if alias
- (register-reference alias)
- (indirect-char/ascii-reference!
- regnum:regs-pointer
- (pseudo-register-offset register)))))
- |#
- (let ((alias (register-alias register 'DATA)))
- (cond (alias
- (register-reference alias))
- ((register-alias register false)
- (reference-alias-register! register 'DATA))
- (else
- ;; Must be in home.
- (indirect-char/ascii-reference!
- regnum:regs-pointer
- (pseudo-register-offset register))))))
-
-(define (indirect-char/ascii-reference! register offset)
- (indirect-byte-reference! register (+ (* offset 4) 3)))
-
-(define (char->signed-8-bit-immediate character)
- (let ((ascii (char->ascii character)))
- (if (< ascii 128) ascii (- ascii 256))))
-\f
-;;;; Registers/Entries
-
-(define-integrable (data-register? register)
- (< register 8))
-
-(define (address-register? register)
- (and (< register 16)
- (>= register 8)))
-
-(define (float-register? register)
- (and (< register 24)
- (>= register 16)))
-
-(define-integrable (lap:ea-keyword expression)
- (car expression))
-
-(define-integrable (lap:ea-operand-1 expression)
- (cadr expression))
-
-(define-integrable (lap:ea-operand-2 expression)
- (caddr expression))
-
-(define (lap:make-label-statement label)
- (LAP (LABEL ,label)))
-
-(define (lap:make-unconditional-branch label)
- (LAP (BRA (@PCR ,label))))
-
-(define (lap:make-entry-point label block-start-label)
- block-start-label
- (LAP (ENTRY-POINT ,label)
- ,@(make-external-label expression-code-word label)))
-\f
-(define-integrable reg:compiled-memtop (INST-EA (@A 6)))
-(define-integrable reg:environment (INST-EA (@AO 6 #x000C)))
-(define-integrable reg:lexpr-primitive-arity (INST-EA (@AO 6 #x001C)))
-(define-integrable reg:closure-free (INST-EA (@AO 6 #x0024)))
-(define-integrable reg:closure-space (INST-EA (@AO 6 #X0028)))
-(define-integrable reg:stack-guard (INST-EA (@AO 6 #X002C)))
-
-(let-syntax ((define-codes
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(BEGIN
- ,@(let loop ((names (cddr form)) (index (cadr form)))
- (if (pair? names)
- (cons `(DEFINE-INTEGRABLE
- ,(symbol-append 'CODE:COMPILER-
- (car names))
- ,index)
- (loop (cdr names) (+ index 1)))
- '())))))))
- (define-codes #x012
- primitive-apply primitive-lexpr-apply
- apply error lexpr-apply link
- interrupt-closure interrupt-dlink interrupt-procedure
- interrupt-continuation interrupt-ic-procedure
- assignment-trap cache-reference-apply
- reference-trap safe-reference-trap unassigned?-trap
- -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero?
- access lookup safe-lookup unassigned? unbound?
- set! define lookup-apply primitive-error
- quotient remainder modulo))
-\f
-(let-syntax ((define-entries
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(BEGIN
- ,@(let loop ((names (cddr form)) (index (cadr form)))
- (if (pair? names)
- (cons `(DEFINE-INTEGRABLE
- ,(symbol-append 'ENTRY:COMPILER-
- (car names))
- (INST-EA (@AO 6 ,index)))
- (loop (cdr names) (+ index 8)))
- '())))))))
- (define-entries #x40
- scheme-to-interface ; Main entry point (only one necessary)
- scheme-to-interface-jsr ; Used by rules3&4, for convenience.
- trampoline-to-interface ; Used by trampolines, for convenience.
- shortcircuit-apply ; Used by rules3, for speed.
- shortcircuit-apply-size-1 ; Small frames, save time and space.
- shortcircuit-apply-size-2
- shortcircuit-apply-size-3
- shortcircuit-apply-size-4
- shortcircuit-apply-size-5
- shortcircuit-apply-size-6
- shortcircuit-apply-size-7
- shortcircuit-apply-size-8
- primitive-apply ; Common entries to save space.
- primitive-lexpr-apply
- error
- link
- interrupt-closure
- interrupt-dlink
- interrupt-procedure
- interrupt-continuation
- assignment-trap
- reference-trap
- safe-reference-trap
- &+
- &-
- &*
- &/
- &=
- &<
- &>
- 1+
- -1+
- zero?
- positive?
- negative?
- primitive-error
- allocate-closure ; This doesn't have a code: counterpart.
- closure-hook ; This doesn't have a code: counterpart.
- quotient
- remainder
- modulo
- stack-and-interrupt-check-12 ; This doesn't have a code: counterpart.
- stack-and-interrupt-check-14 ; This doesn't have a code: counterpart.
- stack-and-interrupt-check-18 ; This doesn't have a code: counterpart.
- stack-and-interrupt-check-22 ; This doesn't have a code: counterpart.
- stack-and-interrupt-check-24 ; This doesn't have a code: counterpart.
- set-interrupt-enables ; This doesn't have a code: counterpart.
- ))
-
-(define-integrable (invoke-interface code)
- (LAP (MOVEQ (& ,code) (D 0))
- (JMP ,entry:compiler-scheme-to-interface)))
-
-;; If the entry point scheme-to-interface-jsr were not available,
-;; this code should replace the definition below.
-;; The others can be handled similarly.
-#|
-(define-integrable (invoke-interface-jsr code)
- (LAP (MOVEQ (& ,code) (D 0))
- (LEA (@PCO 12) (A 0))
- (MOV L (A 0) (D 1))
- (JMP ,entry:compiler-scheme-to-interface)))
-|#
-
-(define-integrable (invoke-interface-jsr code)
- (LAP (MOVEQ (& ,code) (D 0))
- (JSR ,entry:compiler-scheme-to-interface-jsr)))
-
-
-(define (pre-lapgen-analysis rgraphs)
- rgraphs
- unspecific)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Optimizer for MC68000.
-
-(declare (usual-integrations))
-
-(define (optimize-linear-lap instructions)
- instructions)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Machine Model for the Motorola MC68K family
-;;; package: (compiler)
-
-(declare (usual-integrations))
-\f
-;;;; Architecture Parameters
-
-(define use-pre/post-increment? true)
-(define-integrable endianness 'BIG)
-(define-integrable addressing-granularity 8)
-(define-integrable scheme-object-width 32)
-(define-integrable scheme-type-width 6) ;or 8
-
-;; NOTE: expt is not being constant-folded now.
-;; For the time being, some of the parameters below are
-;; pre-computed and marked with ***
-;; There are similar parameters in lapgen.scm
-;; Change them if any of the parameters above do.
-
-(define-integrable scheme-datum-width
- (- scheme-object-width scheme-type-width))
-
-(define-integrable type-scale-factor
- ;; (expt 2 (- 8 scheme-type-width)) ***
- 4)
-
-(define-integrable float-width 64)
-(define-integrable float-alignment 32)
-
-(define-integrable address-units-per-float
- (quotient float-width addressing-granularity))
-
-;;; It is currently required that both packed characters and objects
-;;; be integrable numbers of address units. Furthermore, the number
-;;; of address units per object must be an integral multiple of the
-;;; number of address units per character. This will cause problems
-;;; on a machine that is word addressed: we will have to rethink the
-;;; character addressing strategy.
-
-(define-integrable address-units-per-object
- (quotient scheme-object-width addressing-granularity))
-
-(define-integrable address-units-per-packed-char 1)
-
-(define-integrable signed-fixnum/upper-limit
- ;; (expt 2 (-1+ scheme-datum-width)) ***
- 33554432)
-
-(define-integrable signed-fixnum/lower-limit
- (- signed-fixnum/upper-limit))
-
-(define-integrable unsigned-fixnum/upper-limit
- (* 2 signed-fixnum/upper-limit))
-
-(define-integrable (stack->memory-offset offset) offset)
-(define-integrable ic-block-first-parameter-offset 2)
-\f
-;;;; Closure format
-
-;; There are two versions of the closure format.
-;; The MC68040 format can be used by all processors in the family,
-;; irrelevant of cache operation, but is slower.
-;; The MC68020 format can be used by all processors except the MC68040
-;; unless its data cache is operating in write-through mode (instead
-;; of store-in or copyback).
-;; MC68020-format closure entry points are not long-word aligned, thus
-;; they are canonicalized to the first entry point at call time.
-;; MC68040-format closure entry points are long-word aligned, and
-;; there is no canonicalization.
-
-;; When using the MC68020 format, to save space, entries can be at 2
-;; mod 4 addresses, thus if we used the entry points for environments,
-;; the requirement that all environment pointers be long-word aligned
-;; would be violated. Instead, all closure entry points are bumped to
-;; the canonical entry point, which is always long-word aligned.
-
-#|
- An MC68020-format closure entry:
- DC.W <format word>, <GC offset word>
- JSR #target
-
- Entries are not padded to long-word length. The JSR-absolute
- instruction is 6 bytes long, so the total size per entry is
- 10 bytes.
-|#
-
-(define (MC68020/closure-first-offset nentries entry)
- entry ; ignored
- (if (zero? nentries)
- 1
- (quotient (+ (+ 3 1) (* 5 (- nentries 1))) 2)))
-
-(define (MC68020/closure-object-first-offset nentries)
- (case nentries
- ((0) 1)
- ((1) 4)
- (else
- (quotient (+ 5 (* 5 nentries)) 2))))
-
-(define (MC68020/closure-entry-distance nentries entry entry*)
- nentries ; ignored
- (* 10 (- entry* entry)))
-
-;; When using the MC68020 format, bump to the canonical entry point.
-
-(define (MC68020/closure-environment-adjustment nentries entry)
- (declare (integrate-operator MC68020/closure-entry-distance))
- (MC68020/closure-entry-distance nentries entry 0))
-\f
-(define-integrable MC68040/closure-entry-size
- #|
- Long-words in a single closure entry:
- DC.W <format word>, <GC offset word>
- JSR closure_hook(a6)
- DC.L target
- |#
- 3)
-
-(define (MC68040/closure-first-offset nentries entry)
- entry ; ignored
- (if (zero? nentries)
- 1
- (- (* MC68040/closure-entry-size (- nentries entry)) 1)))
-
-(define (MC68040/closure-object-first-offset nentries)
- (case nentries
- ((0)
- ;; Vector header only
- 1)
- ((1)
- ;; Manifest closure header followed by single entry point.
- (1+ MC68040/closure-entry-size))
- (else
- ;; Manifest closure header, number of entries, then entries.
- (+ 1 1 (* MC68040/closure-entry-size nentries)))))
-
-(define (MC68040/closure-entry-distance nentries entry entry*)
- nentries ; ignored
- (* (* MC68040/closure-entry-size 4) (- entry* entry)))
-
-;; With the 68040 layout, this is the entry point itself, no bumping.
-
-(define (MC68040/closure-environment-adjustment nentries entry)
- nentries entry ; ignored
- 0)
-\f
-;;;; Closure choices
-
-(define-integrable MC68K/closure-format 'MC68040) ; or MC68020
-
-(let-syntax
- ((define/format-dependent
- (sc-macro-transformer
- (lambda (form environment)
- (let ((name (cadr form)))
- `(DEFINE ,name
- (CASE MC68K/CLOSURE-FORMAT
- ((MC68020)
- ,(close-syntax (symbol-append 'MC68020/ name) environment))
- ((MC68040)
- ,(close-syntax (symbol-append 'MC68040/ name) environment))
- (ELSE
- (ERROR "Unknown closure format" CLOSURE-FORMAT)))))))))
-
-;; Given: the number of entry points in a closure, and a particular
-;; entry point number, compute the distance from that entry point to
-;; the first variable slot in the closure object (in long words).
-
-(define/format-dependent closure-first-offset)
-
-;; Like the above, but from the start of the complete closure object,
-;; viewed as a vector, and including the header word.
-
-(define/format-dependent closure-object-first-offset)
-
-;; Bump distance in bytes from one entry point to another.
-;; Used for invocation purposes.
-
-(define/format-dependent closure-entry-distance)
-
-;; Bump distance in bytes from one entry point to the entry point used
-;; for variable-reference purposes.
-
-(define/format-dependent closure-environment-adjustment)
-)
-\f
-(define-integrable d0 0)
-(define-integrable d1 1)
-(define-integrable d2 2)
-(define-integrable d3 3)
-(define-integrable d4 4)
-(define-integrable d5 5)
-(define-integrable d6 6)
-(define-integrable d7 7)
-(define-integrable a0 8)
-(define-integrable a1 9)
-(define-integrable a2 10)
-(define-integrable a3 11)
-(define-integrable a4 12)
-(define-integrable a5 13)
-(define-integrable a6 14)
-(define-integrable a7 15)
-(define-integrable fp0 16)
-(define-integrable fp1 17)
-(define-integrable fp2 18)
-(define-integrable fp3 19)
-(define-integrable fp4 20)
-(define-integrable fp5 21)
-(define-integrable fp6 22)
-(define-integrable fp7 23)
-
-(define-integrable number-of-machine-registers 24)
-(define-integrable number-of-temporary-registers 256)
-
-(define-integrable regnum:return-value d6)
-(define-integrable regnum:pointer-mask d7)
-(define-integrable regnum:dynamic-link a4)
-(define-integrable regnum:free-pointer a5)
-(define-integrable regnum:regs-pointer a6)
-(define-integrable regnum:stack-pointer a7)
-(define-integrable (machine-register-known-value register) register false)
-
-(define (machine-register-value-class register)
- (cond ((or (<= 0 register 6) (<= 8 register 11)) value-class=object)
- ((= 7 register) value-class=immediate)
- ((<= 12 register 15) value-class=address)
- ((<= 16 register 23) value-class=float)
- (else (error "illegal machine register" register))))
-\f
-;;;; RTL Generator Interface
-
-(define (interpreter-register:access)
- (rtl:make-machine-register d0))
-
-(define (interpreter-register:cache-reference)
- (rtl:make-machine-register d0))
-
-(define (interpreter-register:cache-unassigned?)
- (rtl:make-machine-register d0))
-
-(define (interpreter-register:lookup)
- (rtl:make-machine-register d0))
-
-(define (interpreter-register:unassigned?)
- (rtl:make-machine-register d0))
-
-(define (interpreter-register:unbound?)
- (rtl:make-machine-register d0))
-
-(define (interpreter-value-register)
- (rtl:make-machine-register regnum:return-value))
-
-(define (interpreter-value-register? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:return-value)))
-
-(define (interpreter-environment-register)
- (rtl:make-offset (interpreter-regs-pointer)
- (rtl:make-machine-constant 3)))
-
-(define (interpreter-environment-register? expression)
- (and (rtl:offset? expression)
- (interpreter-regs-pointer? (rtl:offset-base expression))
- (let ((offset (rtl:offset-offset expression)))
- (and (rtl:machine-constant? offset)
- (= 3 (rtl:machine-constant-value offset))))))
-
-(define (interpreter-free-pointer)
- (rtl:make-machine-register regnum:free-pointer))
-
-(define (interpreter-free-pointer? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:free-pointer)))
-
-(define (interpreter-regs-pointer)
- (rtl:make-machine-register regnum:regs-pointer))
-
-(define (interpreter-regs-pointer? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:regs-pointer)))
-
-(define (interpreter-stack-pointer)
- (rtl:make-machine-register regnum:stack-pointer))
-
-(define (interpreter-stack-pointer? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:stack-pointer)))
-
-(define (interpreter-dynamic-link)
- (rtl:make-machine-register regnum:dynamic-link))
-
-(define (interpreter-dynamic-link? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:dynamic-link)))
-\f
-(define (rtl:machine-register? rtl-register)
- (case rtl-register
- ((STACK-POINTER)
- (interpreter-stack-pointer))
- ((DYNAMIC-LINK)
- (interpreter-dynamic-link))
- ((VALUE)
- (interpreter-value-register))
- ((FREE)
- (interpreter-free-pointer))
- ((INTERPRETER-CALL-RESULT:ACCESS)
- (interpreter-register:access))
- ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
- (interpreter-register:cache-reference))
- ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
- (interpreter-register:cache-unassigned?))
- ((INTERPRETER-CALL-RESULT:LOOKUP)
- (interpreter-register:lookup))
- ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
- (interpreter-register:unassigned?))
- ((INTERPRETER-CALL-RESULT:UNBOUND?)
- (interpreter-register:unbound?))
- (else false)))
-
-(define (rtl:interpreter-register? rtl-register)
- (case rtl-register
- ((MEMORY-TOP) 0)
- ((INT-MASK) 1)
- ((ENVIRONMENT) 3)
- ((TEMPORARY) 4)
- (else false)))
-
-(define (rtl:interpreter-register->offset locative)
- (or (rtl:interpreter-register? locative)
- (error "Unknown register type" locative)))
-
-(define (rtl:constant-cost expression)
- ;; Magic numbers.
- (let ((if-integer
- (lambda (value)
- (if (and (not (negative? value)) (< value #x3F)) 2 3))))
- (let ((if-synthesized-constant
- (lambda (type datum)
- (if-integer (make-non-pointer-literal type datum)))))
- (case (rtl:expression-type expression)
- ((CONSTANT)
- (let ((value (rtl:constant-value expression)))
- (if (non-pointer-object? value)
- (if-synthesized-constant (object-type value)
- (careful-object-datum value))
- 3)))
- ((MACHINE-CONSTANT)
- (if-integer (rtl:machine-constant-value expression)))
- ((ENTRY:PROCEDURE
- ENTRY:CONTINUATION
- ASSIGNMENT-CACHE
- VARIABLE-CACHE
- OFFSET-ADDRESS
- BYTE-OFFSET-ADDRESS
- FLOAT-OFFSET-ADDRESS)
- 3)
- ((CONS-POINTER)
- (and (rtl:machine-constant? (rtl:cons-pointer-type expression))
- (rtl:machine-constant? (rtl:cons-pointer-datum expression))
- (if-synthesized-constant
- (rtl:machine-constant-value (rtl:cons-pointer-type expression))
- (rtl:machine-constant-value
- (rtl:cons-pointer-datum expression)))))
- (else false)))))
-
-(define compiler:open-code-floating-point-arithmetic?
- true)
-
-(define compiler:primitives-with-no-open-coding
- '(DIVIDE-FIXNUM GCD-FIXNUM &/
- VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS
- FLONUM-CEILING FLONUM-FLOOR FLONUM-ATAN2 FLONUM-EXPM1 FLONUM-LOG1P))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Compiler: System Construction
-
-(declare (usual-integrations))
-
-((load "base/make") "Motorola MC68020")
-((environment-lookup (->environment '(COMPILER LAP-SYNTAXER))
- 'MC68K/TOGGLE-CLOSURE-FORMAT)
- 'MC68020)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Compiler: System Construction
-
-(declare (usual-integrations))
-
-((load "base/make") "Motorola MC68040")
-(set! (access compiler:compress-top-level? (->environment '(compiler)))
- true)
-((environment-lookup (->environment '(COMPILER LAP-SYNTAXER))
- 'MC68K/TOGGLE-CLOSURE-FORMAT)
- 'MC68040)
\ No newline at end of file
+++ /dev/null
-#| -*- Scheme -*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-(declare (usual-integrations))
-
-(define (mc68k/toggle-closure-format #!optional new-format)
- (case (if (default-object? new-format)
- (if (eq? MC68K/closure-format 'MC68020)
- 'MC68040
- 'MC68020)
- new-format)
- ((MC68020)
- (set! closure-first-offset MC68020/closure-first-offset)
- (set! closure-object-first-offset MC68020/closure-object-first-offset)
- (set! closure-entry-distance MC68020/closure-entry-distance)
- (set! closure-environment-adjustment
- MC68020/closure-environment-adjustment)
- (set! generate/closure-header MC68020/closure-header)
- (set! generate/cons-closure MC68020/cons-closure)
- (set! generate/cons-multiclosure MC68020/cons-multiclosure)
- (set! mc68k/closure-format 'MC68020))
- ((MC68040)
- (set! closure-first-offset MC68040/closure-first-offset)
- (set! closure-object-first-offset MC68040/closure-object-first-offset)
- (set! closure-entry-distance MC68040/closure-entry-distance)
- (set! closure-environment-adjustment
- MC68040/closure-environment-adjustment)
- (set! generate/closure-header MC68040/closure-header)
- (set! generate/cons-closure MC68040/cons-closure)
- (set! generate/cons-multiclosure MC68040/cons-multiclosure)
- (set! mc68k/closure-format 'MC68040))
- (else
- (error "Unknown closure format:" new-format)))
- MC68K/closure-format)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RTL Generation: Special primitive combinations. 68020 version.
-
-(declare (usual-integrations))
-\f
-(define (define-special-primitive-handler name handler)
- (let ((primitive (make-primitive-procedure name true)))
- (let ((entry (assq primitive special-primitive-handlers)))
- (if entry
- (set-cdr! entry handler)
- (set! special-primitive-handlers
- (cons (cons primitive handler)
- special-primitive-handlers)))))
- name)
-
-(define (special-primitive-handler primitive)
- (let ((entry (assq primitive special-primitive-handlers)))
- (and entry
- (cdr entry))))
-
-(define special-primitive-handlers
- '())
-
-(define (define-special-primitive/standard primitive)
- (define-special-primitive-handler primitive
- rtl:make-invocation:special-primitive))
-
-(define-special-primitive/standard '&+)
-(define-special-primitive/standard '&-)
-(define-special-primitive/standard '&*)
-(define-special-primitive/standard '&/)
-(define-special-primitive/standard '&=)
-(define-special-primitive/standard '&<)
-(define-special-primitive/standard '&>)
-(define-special-primitive/standard '1+)
-(define-special-primitive/standard '-1+)
-(define-special-primitive/standard 'zero?)
-(define-special-primitive/standard 'positive?)
-(define-special-primitive/standard 'negative?)
-(define-special-primitive/standard 'quotient)
-(define-special-primitive/standard 'remainder)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Data Transfers
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Register Assignments
-
-;;; All assignments to pseudo registers are required to delete the
-;;; dead registers BEFORE performing the assignment. However, it is
-;;; necessary to derive the effective address of the source
-;;; expression(s) before deleting the dead registers. Otherwise any
-;;; source expression containing dead registers might refer to aliases
-;;; which have been reused.
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
- (assign-register->register target source))
-
-(define (assign-register->register target source)
- (standard-move-to-target! source (register-type target) target)
- (LAP))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OFFSET-ADDRESS (REGISTER (? base))
- (REGISTER (? index))))
- (load-indexed-address target base index 4 0))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET-ADDRESS (REGISTER (? base))
- (REGISTER (? index))))
- (load-indexed-address target base index 1 0))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET-ADDRESS (REGISTER (? base))
- (REGISTER (? index))))
- (load-indexed-address target base index 8 0))
-
-(define-integrable (->areg reg)
- (- reg 8))
-
-(define (load-indexed-address target base index scale offset)
- (let ((load-address
- (lambda (get-target-reference)
- (let ((ea (indexed-ea base index scale offset)))
- (LAP (LEA ,ea ,(get-target-reference)))))))
- (cond ((or (not (machine-register? target))
- (eq? (register-type target) 'ADDRESS))
- (load-address
- (lambda ()
- (target-register-reference target 'ADDRESS))))
- ((eq? (register-type target) 'DATA)
- (let ((temp
- (register-reference
- (allocate-temporary-register! 'ADDRESS))))
- (LAP ,@(load-address (lambda () temp))
- (MOV L ,temp ,(register-reference target)))))
- (else
- (error "load-indexed-address: Unknown register type"
- target)))))
-
-(define (target-register-reference target type)
- (delete-dead-registers!)
- (register-reference
- (or (register-alias target type)
- (allocate-alias-register! target type))))
-\f
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OFFSET-ADDRESS (REGISTER (? source))
- (MACHINE-CONSTANT (? n))))
- (load-static-link target source (* 4 n) false))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET-ADDRESS (REGISTER (? source))
- (MACHINE-CONSTANT (? n))))
- (load-static-link target source n false))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET-ADDRESS (REGISTER (? source))
- (MACHINE-CONSTANT (? n))))
- (load-static-link target source (* 8 n) false))
-
-(define-rule statement
- ;; This is an intermediate rule -- not intended to produce code.
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (OFFSET-ADDRESS (REGISTER (? source))
- (MACHINE-CONSTANT (? n)))))
- (load-static-link target source (* 4 n)
- (lambda (target)
- (LAP (OR UL (& ,(make-non-pointer-literal type 0)) ,target)))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (BYTE-OFFSET-ADDRESS (REGISTER (? source))
- (MACHINE-CONSTANT (? n)))))
- (load-static-link target source n
- (lambda (target)
- (LAP (OR UL (& ,(make-non-pointer-literal type 0)) ,target)))))
-
-(define (load-static-link target source n suffix)
- (cond ((and (not suffix) (zero? n))
- (assign-register->register target source))
- ((machine-register? target)
- (let ((do-data
- (lambda (target)
- (let ((source
- (standard-register-reference source false true)))
- (LAP (MOV L ,source ,target)
- ,@(ea+=constant target n)
- ,@(if suffix
- (suffix target)
- (LAP)))))))
- (case (register-type target)
- ((ADDRESS)
- (if (not suffix)
- (let ((source (allocate-indirection-register! source)))
- (LAP (LEA ,(byte-offset-reference source n)
- ,(register-reference target))))
- (let ((temp (reference-temporary-register! 'DATA)))
- (LAP ,(do-data temp)
- (MOV L ,temp ,(register-reference target))))))
- ((DATA)
- (do-data (register-reference target)))
- (else
- (error "load-static-link: Unknown register type"
- (register-type target))))))
-\f
- (else
- (let ((non-reusable
- (cond ((not suffix)
- (lambda ()
- (let ((source
- (allocate-indirection-register! source)))
- (delete-dead-registers!)
- (let ((target (allocate-alias-register! target
- 'ADDRESS)))
- (if (eqv? source target)
- (increment-machine-register target n)
- (LAP (LEA ,(byte-offset-reference source n)
- ,(register-reference target))))))))
- ((<= -128 n 127)
- (lambda ()
- (let ((source (register-reference source)))
- (delete-dead-registers!)
- (let ((target
- (reference-target-alias! target 'DATA)))
- (LAP (MOVEQ (& ,n) ,target)
- (ADD L ,source ,target)
- ,@(suffix target))))))
- (else
- (lambda ()
- (let ((source (indirect-byte-reference! source n)))
- (delete-dead-registers!)
- (let ((temp
- (reference-temporary-register! 'ADDRESS)))
- (let ((target (reference-target-alias! target
- 'DATA)))
- (LAP (LEA ,source ,temp)
- (MOV L ,temp ,target)
- ,@(suffix target))))))))))
- (if (machine-register? source)
- (non-reusable)
- (reuse-pseudo-register-alias!
- source 'DATA
- (lambda (reusable-alias)
- (delete-dead-registers!)
- (add-pseudo-register-alias! target reusable-alias)
- (LAP ,@(increment-machine-register reusable-alias n)
- ,@(if suffix
- (suffix (register-reference reusable-alias))
- (LAP))))
- non-reusable))))))
-\f
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
- ;; See if we can reuse a source alias, because `object->type' can
- ;; sometimes do a slightly better job when the source and target are
- ;; the same register.
- (let ((no-reuse
- (lambda ()
- (let ((source (standard-register-reference source 'DATA false)))
- (delete-dead-registers!)
- (object->type source (reference-target-alias! target 'DATA))))))
- (if (machine-register? target)
- (no-reuse)
- (reuse-pseudo-register-alias! source 'DATA
- (lambda (source)
- (delete-dead-registers!)
- (add-pseudo-register-alias! target source)
- (let ((source (register-reference source)))
- (object->type source source)))
- no-reuse))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum))))
- (let ((temp (standard-move-to-temporary! type 'DATA)))
- (LAP (RO R L (& ,scheme-type-width) ,temp)
- (OR L ,temp ,(standard-move-to-target! datum 'DATA target)))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum))))
- (LAP (OR UL
- (& ,(make-non-pointer-literal type 0))
- ,(standard-move-to-target! datum 'DATA target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
- (object->datum (standard-move-to-target! source 'DATA target)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
- (object->address (standard-move-to-target! source 'DATA target)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source)))))
- (address->fixnum (standard-move-to-target! source 'DATA target)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source))))
- (object->fixnum (standard-move-to-target! source 'DATA target)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source))))
- (address->fixnum (standard-move-to-target! source 'DATA target)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source))))
- (fixnum->object (standard-move-to-target! source 'DATA target)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source))))
- (fixnum->address (standard-move-to-target! source 'DATA target)))
-\f
-;;;; Loading Constants
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
- (load-constant source (standard-target-reference target)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? n)))
- (load-machine-constant n (standard-target-reference target)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum))))
- (load-non-pointer type datum (standard-target-reference target)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label)))
- (load-pc-relative-address
- target
- (rtl-procedure/external-label (label->object label))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label)))
- (load-pc-relative-address target label))
-
-(define (load-pc-relative-address target label)
- (delete-dead-registers!)
- (LAP (LEA (@PCR ,label) ,(reference-target-alias! target 'ADDRESS))))
-
-(define-rule statement
- ;; This is an intermediate rule -- not intended to produce code.
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (ENTRY:PROCEDURE (? label))))
- (load-pc-relative-address-with-type
- target
- type
- (rtl-procedure/external-label (label->object label))))
-
-(define-rule statement
- ;; This is an intermediate rule -- not intended to produce code.
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (ENTRY:CONTINUATION (? label))))
- (load-pc-relative-address-with-type target type label))
-
-(define (load-pc-relative-address-with-type target type label)
- (delete-dead-registers!)
- (let ((temp (reference-temporary-register! 'ADDRESS))
- (target (reference-target-alias! target 'DATA)))
- (LAP (LEA (@PCR ,label) ,temp)
- (MOV L ,temp ,target)
- (OR UL (& ,(make-non-pointer-literal type 0)) ,target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
- (load-pc-relative target (free-reference-label name)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name)))
- (load-pc-relative target (free-assignment-label name)))
-
-(define (load-pc-relative target label)
- (delete-dead-registers!)
- (LAP (MOV L (@PCR ,label) ,(reference-target-alias! target 'ADDRESS))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant))))
- (convert-object/constant->register target constant object->datum))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (CONSTANT (? constant))))
- (convert-object/constant->register target constant object->address))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (ADDRESS->FIXNUM (OBJECT->ADDRESS (CONSTANT (? constant)))))
- (convert-object/constant->register target constant address->fixnum))
-
-(define (convert-object/constant->register target constant conversion)
- (delete-dead-registers!)
- (let ((target (reference-target-alias! target 'DATA)))
- (if (non-pointer-object? constant)
- (load-non-pointer 0 (careful-object-datum constant) target)
- (LAP ,@(load-constant constant target)
- ,@(conversion target)))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant))))
- (delete-dead-registers!)
- (load-fixnum-constant constant (reference-target-alias! target 'DATA)))
-\f
-;;;; Transfers from Memory
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (? expression rtl:simple-offset?))
- (let ((source (offset->reference! expression)))
- (LAP (MOV L ,source ,(standard-target-reference target)))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 15) 1))
- (LAP (MOV L (@A+ 7) ,(standard-target-reference target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OBJECT->TYPE (? expression rtl:simple-offset?)))
- (let ((source (offset->reference! expression)))
- (delete-dead-registers!)
- (object->type source (reference-target-alias! target 'DATA))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OBJECT->DATUM (? expression rtl:simple-offset?)))
- (convert-object/offset->register target expression object->datum))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OBJECT->ADDRESS (? expression rtl:simple-offset?)))
- (convert-object/offset->register target expression object->address))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (ADDRESS->FIXNUM
- (OBJECT->ADDRESS (? expression rtl:simple-offset?))))
- (convert-object/offset->register target expression address->fixnum))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OBJECT->FIXNUM (? expression rtl:simple-offset?)))
- (convert-object/offset->register target expression object->fixnum))
-
-(define (convert-object/offset->register target expression conversion)
- (let ((source (offset->reference! expression)))
- (delete-dead-registers!)
- (let ((target (reference-target-alias! target 'DATA)))
- (LAP (MOV L ,source ,target)
- ,@(conversion target)))))
-\f
-;;;; Transfers to Memory
-
-(define-rule statement
- (ASSIGN (? expression rtl:simple-offset?)
- (REGISTER (? r)))
- (QUALIFIER (register-value-class=word? r))
- (LAP (MOV L
- ,(standard-register-reference r false true)
- ,(offset->reference! expression))))
-
-(define-rule statement
- (ASSIGN (? expression rtl:simple-offset?)
- (POST-INCREMENT (REGISTER 15) 1))
- (LAP (MOV L (@A+ 7) ,(offset->reference! expression))))
-
-(define-rule statement
- (ASSIGN (? expression rtl:simple-offset?)
- (CONSTANT (? object)))
- (load-constant object (offset->reference! expression)))
-
-(define-rule statement
- (ASSIGN (? expression rtl:simple-offset?)
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum))))
- (load-non-pointer type datum (offset->reference! expression)))
-
-(define-rule statement
- (ASSIGN (? expression rtl:simple-offset?)
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (REGISTER (? datum))))
- (let ((target (offset->reference! expression)))
- (LAP (MOV L ,(standard-register-reference datum 'DATA true) ,target)
- ,@(memory-set-type type target))))
-
-(define-rule statement
- (ASSIGN (? expression rtl:simple-offset?)
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (OFFSET-ADDRESS (REGISTER (? source))
- (MACHINE-CONSTANT (? n)))))
- (let ((temp (reference-temporary-register! 'ADDRESS))
- (target (offset->reference! expression)))
- (LAP (LEA ,(indirect-reference! source n) ,temp)
- (MOV L ,temp ,target)
- ,@(memory-set-type type target))))
-
-(define-rule statement
- (ASSIGN (? expression rtl:simple-offset?)
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (BYTE-OFFSET-ADDRESS (REGISTER (? source))
- (MACHINE-CONSTANT (? n)))))
- (let ((temp (reference-temporary-register! 'ADDRESS))
- (target (offset->reference! expression)))
- (LAP (LEA ,(indirect-byte-reference! source n) ,temp)
- (MOV L ,temp ,target)
- ,@(memory-set-type type target))))
-\f
-;; Common case that can be done cheaply:
-
-(define-rule statement
- (ASSIGN (? expression0 rtl:simple-offset?)
- (BYTE-OFFSET-ADDRESS (? expression rtl:simple-offset?)
- (MACHINE-CONSTANT (? n))))
- (QUALIFIER (equal? expression0 expression))
- (if (zero? n)
- (LAP)
- (let ((target (offset->reference! expression)))
- (cond ((<= 1 n 8)
- (LAP (ADDQ L (& ,n) ,target)))
- ((<= -8 n -1)
- (LAP (SUBQ L (& ,(- n)) ,target)))
- ((<= -128 n 127)
- (let ((temp (reference-temporary-register! 'DATA)))
- (LAP (MOVEQ (& ,n) ,temp)
- (ADD L ,temp ,target))))
- (else
- (LAP (ADD L (& ,n) ,target)))))))
-
-(define-rule statement
- (ASSIGN (? expression rtl:simple-offset?)
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (ENTRY:PROCEDURE (? label))))
- (let ((temp (reference-temporary-register! 'ADDRESS))
- (target (offset->reference! expression)))
- (LAP (LEA (@PCR ,(rtl-procedure/external-label (label->object label)))
- ,temp)
- (MOV L ,temp ,target)
- ,@(memory-set-type type target))))
-
-#|
-;; This is no better than assigning to a register and then assigning
-;; from the register
-
-(define-rule statement
- (ASSIGN (? expression rtl:simple-offset?)
- (FIXNUM->OBJECT (REGISTER (? source))))
- (let ((target (offset->reference! expression)))
- (let ((temporary (standard-move-to-temporary! source 'DATA)))
- (LAP ,@(fixnum->object temporary)
- (MOV L ,temporary ,target)))))
-|#
-
-(define-rule statement
- (ASSIGN (? expression0 rtl:simple-offset?)
- (? expression1 rtl:simple-offset?))
- (if (equal? expression0 expression1)
- (LAP)
- (LAP (MOV L ,(offset->reference! expression1)
- ,(offset->reference! expression0)))))
-\f
-;;;; Consing
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (CONSTANT (? object)))
- (load-constant object (INST-EA (@A+ 5))))
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 13) 1)
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum))))
- (load-non-pointer type datum (INST-EA (@A+ 5))))
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (REGISTER (? r)))
- (QUALIFIER (register-value-class=word? r))
- (LAP (MOV L ,(standard-register-reference r false true) (@A+ 5))))
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 13) 1)
- (? expression rtl:simple-offset?))
- (LAP (MOV L ,(offset->reference! expression) (@A+ 5))))
-
-#|
-;; This is no better than assigning to a register and then assigning
-;; from the register
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 13) 1)
- (FIXNUM->OBJECT (REGISTER (? r))))
- (let ((temporary (standard-move-to-temporary! r 'DATA)))
- (LAP ,@(fixnum->object temporary)
- (MOV L ,temporary (@A+ 5)))))
-|#
-
-(define-rule statement
- ;; This pops the top of stack into the heap
- (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (POST-INCREMENT (REGISTER 15) 1))
- (LAP (MOV L (@A+ 7) (@A+ 5))))
-\f
-;;;; Pushes
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (REGISTER (? r)))
- (QUALIFIER (register-value-class=word? r))
- (LAP (MOV L ,(standard-register-reference r false true) (@-A 7))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (CONSTANT (? object)))
- (load-constant object (INST-EA (@-A 7))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
- (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum))))
- (LAP (MOV L ,(standard-register-reference datum 'DATA true) (@-A 7))
- ,@(memory-set-type type (INST-EA (@A 7)))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum))))
- (load-non-pointer type datum (INST-EA (@-A 7))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (ENTRY:PROCEDURE (? label))))
- (LAP (PEA (@PCR ,(rtl-procedure/external-label (label->object label))))
- ,@(memory-set-type type (INST-EA (@A 7)))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (ENTRY:CONTINUATION (? label))))
- (LAP (PEA (@PCR ,label))
- ,@(memory-set-type type (INST-EA (@A 7)))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (OFFSET-ADDRESS (REGISTER (? r))
- (MACHINE-CONSTANT (? n)))))
- (LAP (PEA ,(indirect-reference! r n))
- ,@(memory-set-type type (INST-EA (@A 7)))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (BYTE-OFFSET-ADDRESS (REGISTER (? r))
- (MACHINE-CONSTANT (? n)))))
- (LAP (PEA ,(indirect-byte-reference! r n))
- ,@(memory-set-type type (INST-EA (@A 7)))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
- (? expression rtl:simple-offset?))
- (LAP (MOV L ,(offset->reference! expression) (@-A 7))))
-
-#|
-;; This is no better than assigning to a register and then assigning
-;; from the register
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
- (FIXNUM->OBJECT (REGISTER (? r))))
- (let ((temporary (standard-move-to-temporary! r 'DATA)))
- (LAP ,@(fixnum->object temporary)
- (MOV L ,temporary (@-A 7)))))
-|#
-\f
-;;;; Fixnum Operations
-
-(define-rule statement
- (ASSIGN (? target)
- (FIXNUM-1-ARG (? operator) (REGISTER (? source)) (? overflow?)))
- (QUALIFIER (machine-operation-target? target))
- overflow? ; ignored
- (reuse-and-load-machine-target! 'DATA
- target
- source
- (fixnum-1-arg/operate operator)))
-
-(define-rule statement
- (ASSIGN (? target)
- (FIXNUM-2-ARGS (? operator)
- (REGISTER (? source1))
- (REGISTER (? source2))
- (? overflow?)))
- (QUALIFIER (machine-operation-target? target))
- overflow? ; ignored
- (two-arg-register-operation (fixnum-2-args/operate operator)
- (fixnum-2-args/commutative? operator)
- 'DATA
- (standard-fixnum-source operator)
- (lambda (source)
- (standard-register-reference source
- 'DATA
- true))
- target
- source1
- source2))
-
-(define-rule statement
- (ASSIGN (? target)
- (FIXNUM-2-ARGS (? operator)
- (REGISTER (? source))
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (? overflow?)))
- (QUALIFIER (machine-operation-target? target))
- overflow? ; ignored
- (fixnum-2-args/register*constant operator target source constant))
-
-(define-rule statement
- (ASSIGN (? target)
- (FIXNUM-2-ARGS (? operator)
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (REGISTER (? source))
- (? overflow?)))
- (QUALIFIER (machine-operation-target? target))
- overflow? ; ignored
- (if (fixnum-2-args/commutative? operator)
- (fixnum-2-args/register*constant operator target source constant)
- (fixnum-2-args/constant*register operator target constant source)))
-
-(define (fixnum-2-args/register*constant operator target source constant)
- (reuse-and-load-machine-target! 'DATA target source
- (lambda (target)
- ((fixnum-2-args/operate-constant operator) target constant))))
-
-(define (fixnum-2-args/constant*register operator target constant source)
- (reuse-and-operate-on-machine-target! 'DATA target
- (lambda (target)
- (LAP ,@(load-fixnum-constant constant target)
- ,@((fixnum-2-args/operate operator)
- target
- ((standard-fixnum-source operator) source))))))
-
-(define (standard-fixnum-source operator)
- (let ((alternate-types?
- (not (memq operator
- '(MULTIPLY-FIXNUM FIXNUM-DIVIDE FIXNUM-REMAINDER)))))
- (lambda (source)
- (standard-register-reference source 'DATA alternate-types?))))
-\f
-;;; The maximum value for a shift constant is 8, so these rules can
-;;; only be used when the type width is 6 bits or less.
-
-(if (<= scheme-type-width 6)
- (begin
-
-(define-rule statement
- (ASSIGN (? target)
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (OBJECT->FIXNUM (CONSTANT 4))
- (OBJECT->FIXNUM (REGISTER (? source)))
- (? overflow?)))
- (QUALIFIER (machine-operation-target? target))
- overflow? ; ignored
- (convert-index->fixnum/register target source))
-
-(define-rule statement
- (ASSIGN (? target)
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (OBJECT->FIXNUM (REGISTER (? source)))
- (OBJECT->FIXNUM (CONSTANT 4))
- (? overflow?)))
- (QUALIFIER (machine-operation-target? target))
- overflow? ; ignored
- (convert-index->fixnum/register target source))
-
-(define-rule statement
- (ASSIGN (? target)
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (OBJECT->FIXNUM (CONSTANT 4))
- (OBJECT->FIXNUM (? expression rtl:simple-offset?))
- (? overflow?)))
- (QUALIFIER (machine-operation-target? target))
- overflow? ; ignored
- (convert-index->fixnum/offset target expression))
-
-(define-rule statement
- (ASSIGN (? target)
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (OBJECT->FIXNUM (? expression rtl:simple-offset?))
- (OBJECT->FIXNUM (CONSTANT 4))
- (? overflow?)))
- (QUALIFIER (machine-operation-target? target))
- overflow? ; ignored
- (convert-index->fixnum/offset target expression))
-
-;;; end (IF (<= SCHEME-TYPE-WIDTH 6) ...)
-))
-
-;;; It doesn't hurt for these to be defined when the above rules are
-;;; not in use.
-
-(define (convert-index->fixnum/register target source)
- (reuse-and-load-machine-target! 'DATA target source
- (lambda (target)
- (LAP (AS L L (& ,(+ scheme-type-width 2)) ,target)))))
-
-(define (convert-index->fixnum/offset target expression)
- (let ((source (offset->reference! expression)))
- (reuse-and-operate-on-machine-target! 'DATA target
- (lambda (target)
- (LAP (MOV L ,source ,target)
- (AS L L (& ,(+ scheme-type-width 2)) ,target))))))
-\f
-;;;; Flonum Operations
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT->OBJECT (REGISTER (? source))))
- (let ((source (reference-alias-register! source 'FLOAT)))
- (delete-dead-registers!)
- (let ((target (reference-target-alias! target 'DATA)))
- (LAP (MOV L (A 5) ,target)
- (OR L (& ,(make-non-pointer-literal (ucode-type flonum) 0)) ,target)
- ,@(load-non-pointer (ucode-type manifest-nm-vector)
- 2
- (INST-EA (@A+ 5)))
- (FMOVE D ,source (@A+ 5))))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source))))
- (let ((source (standard-move-to-temporary! source 'DATA))
- (temp (allocate-temporary-register! 'ADDRESS)))
- (LAP ,@(object->address source)
- (MOV L ,source ,(register-reference temp))
- (FMOVE D
- ,(offset-reference temp 1)
- ,(target-float-reference target)))))
-
-(define-rule statement
- (ASSIGN (? target)
- (FLONUM-1-ARG (? operator) (REGISTER (? source)) (? overflow?)))
- (QUALIFIER (machine-operation-target? target))
- overflow? ; ignored
- (let ((operate-on-target
- (lambda (target)
- ((flonum-1-arg/operate operator)
- (standard-register-reference source 'FLOAT false)
- target))))
- (reuse-machine-target! 'FLOAT target
- (lambda (target)
- (operate-on-target (reference-target-alias! target 'FLOAT)))
- operate-on-target)))
-
-(define-rule statement
- (ASSIGN (? target)
- (FLONUM-2-ARGS (? operator)
- (REGISTER (? source1))
- (REGISTER (? source2))
- (? overflow?)))
- (QUALIFIER (machine-operation-target? target))
- overflow? ; ignored
- (let ((source-reference
- (lambda (source) (standard-register-reference source 'FLOAT false))))
- (two-arg-register-operation (flonum-2-args/operate operator)
- (flonum-2-args/commutative? operator)
- 'FLOAT
- source-reference
- source-reference
- target
- source1
- source2)))
-\f
-;;;; CHAR->ASCII/BYTE-OFFSET
-
-(define (load-char-into-register type source target)
- (delete-dead-registers!)
- (let ((target (reference-target-alias! target 'DATA)))
- (LAP ,@(load-non-pointer type 0 target)
- (MOV B ,source ,target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CHAR->ASCII (REGISTER (? source))))
- (load-char-into-register 0
- (reference-alias-register! source 'DATA)
- target))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CHAR->ASCII (? expression rtl:simple-offset?)))
- (load-char-into-register 0
- (offset->reference!/char expression)
- target))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (? expression rtl:simple-byte-offset?))
- (load-char-into-register 0
- (byte-offset->reference! expression)
- target))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (? expression rtl:simple-byte-offset?)))
- (load-char-into-register type
- (byte-offset->reference! expression)
- target))
-
-(define-rule statement
- (ASSIGN (? expression rtl:simple-byte-offset?)
- (REGISTER (? source)))
- (LAP (MOV B ,(coerce->any/byte-reference source)
- ,(byte-offset->reference! expression))))
-
-(define-rule statement
- (ASSIGN (? expression rtl:simple-byte-offset?)
- (CHAR->ASCII (CONSTANT (? character))))
- (LAP (MOV B (& ,(char->signed-8-bit-immediate character))
- ,(byte-offset->reference! expression))))
-
-(define-rule statement
- (ASSIGN (? expression rtl:simple-byte-offset?)
- (CHAR->ASCII (REGISTER (? source))))
- (LAP (MOV B ,(coerce->any/byte-reference source)
- ,(byte-offset->reference! expression))))
-
-(define-rule statement
- (ASSIGN (? expression0 rtl:simple-byte-offset?)
- (CHAR->ASCII (? expression1 rtl:simple-offset?)))
- (LAP (MOV B ,(offset->reference!/char expression1)
- ,(byte-offset->reference! expression0))))
-
-(define-rule statement
- (ASSIGN (? expression0 rtl:simple-byte-offset?)
- (? expression1 rtl:simple-byte-offset?))
- (LAP (MOV B ,(byte-offset->reference! expression1)
- ,(byte-offset->reference! expression0))))
-\f
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (? expression rtl:simple-float-offset?))
- (let ((ea (float-offset->reference! expression)))
- (LAP (FMOVE D ,ea ,(target-float-reference target)))))
-
-(define-rule statement
- (ASSIGN (? expression rtl:simple-float-offset?)
- (REGISTER (? source)))
- (LAP (FMOVE D ,(source-float-reference source)
- ,(float-offset->reference! expression))))
-
-(define (target-float-reference target)
- (delete-dead-registers!)
- (reference-target-alias! target 'FLOAT))
-
-(define (source-float-reference source)
- (register-reference
- (or (register-alias source 'FLOAT)
- (allocate-alias-register! source 'FLOAT))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Predicates
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-(define (predicate/memory-operand? expression)
- (or (rtl:simple-offset? expression)
- (and (rtl:post-increment? expression)
- (interpreter-stack-pointer?
- (rtl:post-increment-register expression)))))
-
-(define (predicate/memory-operand-reference expression)
- (case (rtl:expression-type expression)
- ((OFFSET)
- (offset->reference! expression))
- ((POST-INCREMENT) (INST-EA (@A+ 7)))
- (else
- (error "Illegal memory operand" expression))))
-
-(define (compare/register*register register-1 register-2 cc)
- (let ((finish
- (lambda (reference-1 reference-2 cc)
- (set-standard-branches! cc)
- (LAP (CMP L ,reference-2 ,reference-1)))))
- (let ((finish-1
- (lambda (alias)
- (finish (register-reference alias)
- (standard-register-reference register-2 'DATA true)
- cc)))
- (finish-2
- (lambda (alias)
- (finish (register-reference alias)
- (standard-register-reference register-1 'DATA true)
- (invert-cc-noncommutative cc)))))
- (let ((try-type
- (lambda (type continue)
- (let ((alias (register-alias register-1 type)))
- (if alias
- (finish-1 alias)
- (let ((alias (register-alias register-2 type)))
- (if alias
- (finish-2 alias)
- (continue))))))))
- (try-type 'DATA
- (lambda ()
- (try-type 'ADDRESS
- (lambda ()
- (if (dead-register? register-1)
- (finish-2 (load-alias-register! register-2 'DATA))
- (finish-1 (load-alias-register! register-1 'DATA)))))))))))
-
-(define (compare/register*memory register memory cc)
- (let ((reference (standard-register-reference register 'DATA true)))
- (if (effective-address/register? reference)
- (begin
- (set-standard-branches! cc)
- (LAP (CMP L ,memory ,reference)))
- (compare/memory*memory reference memory cc))))
-
-(define (compare/memory*memory memory-1 memory-2 cc)
- (set-standard-branches! cc)
- (let ((temp (reference-temporary-register! 'DATA)))
- (LAP (MOV L ,memory-1 ,temp)
- (CMP L ,memory-2 ,temp))))
-\f
-(define-rule predicate
- (TYPE-TEST (REGISTER (? register)) (? type))
- (set-standard-branches! 'EQ)
- (test-byte type (reference-alias-register! register 'DATA)))
-
-(define-rule predicate
- (TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) (? type))
- (set-standard-branches! 'EQ)
- (if (and (zero? type) use-68020-instructions?)
- (LAP (BFTST ,(standard-register-reference register 'DATA false)
- (& 0)
- (& ,scheme-type-width)))
- ;; See if we can reuse a source alias, because `object->type'
- ;; can sometimes do a slightly better job when the source and
- ;; temp are the same register.
- (reuse-pseudo-register-alias! register 'DATA
- (lambda (source)
- (delete-dead-registers!)
- (need-register! source)
- (let ((source (register-reference source)))
- (normal-type-test source source type)))
- (lambda ()
- (let ((source (standard-register-reference register 'DATA false)))
- (delete-dead-registers!)
- (normal-type-test source
- (reference-temporary-register! 'DATA)
- type))))))
-
-(define-rule predicate
- (TYPE-TEST (OBJECT->TYPE (? expression rtl:simple-offset?))
- (? type))
- (set-standard-branches! 'EQ)
- (let ((source (offset->reference! expression)))
- (cond ((= scheme-type-width 8)
- (test-byte type source))
- ((and (zero? type) use-68020-instructions?)
- (LAP (BFTST ,source (& 0) (& ,scheme-type-width))))
- (else
- (normal-type-test source
- (reference-temporary-register! 'DATA)
- type)))))
-
-(define (normal-type-test source target type)
- (LAP ,@(object->type source target)
- ,@(if (zero? type)
- (LAP)
- (test-byte type target))))
-\f
-(define-rule predicate
- (EQ-TEST (REGISTER (? register-1)) (REGISTER (? register-2)))
- (compare/register*register register-1 register-2 'EQ))
-
-(define-rule predicate
- (EQ-TEST (REGISTER (? register)) (? memory))
- (QUALIFIER (predicate/memory-operand? memory))
- (compare/register*memory register
- (predicate/memory-operand-reference memory)
- 'EQ))
-
-(define-rule predicate
- (EQ-TEST (? memory) (REGISTER (? register)))
- (QUALIFIER (predicate/memory-operand? memory))
- (compare/register*memory register
- (predicate/memory-operand-reference memory)
- 'EQ))
-
-(define-rule predicate
- (EQ-TEST (? memory-1) (? memory-2))
- (QUALIFIER (and (predicate/memory-operand? memory-1)
- (predicate/memory-operand? memory-2)))
- (compare/memory*memory (predicate/memory-operand-reference memory-1)
- (predicate/memory-operand-reference memory-2)
- 'EQ))
-
-(define-rule predicate
- (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register)))
- (eq-test/constant*register constant register))
-
-(define-rule predicate
- (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant)))
- (eq-test/constant*register constant register))
-
-(define (eq-test/constant*register constant register)
- (if (non-pointer-object? constant)
- (begin
- (set-standard-branches! 'EQ)
- (test-non-pointer-constant
- constant
- (standard-register-reference register 'DATA true)))
- (compare/register*memory register
- (INST-EA (@PCR ,(constant->label constant)))
- 'EQ)))
-\f
-(define-rule predicate
- (EQ-TEST (CONSTANT (? constant)) (? memory))
- (QUALIFIER (predicate/memory-operand? memory))
- (eq-test/constant*memory constant memory))
-
-(define-rule predicate
- (EQ-TEST (? memory) (CONSTANT (? constant)))
- (QUALIFIER (predicate/memory-operand? memory))
- (eq-test/constant*memory constant memory))
-
-(define (eq-test/constant*memory constant memory)
- (let ((memory (predicate/memory-operand-reference memory)))
- (if (non-pointer-object? constant)
- (begin
- (set-standard-branches! 'EQ)
- (test-non-pointer-constant constant memory))
- (compare/memory*memory memory
- (INST-EA (@PCR ,(constant->label constant)))
- 'EQ))))
-
-(define-rule predicate
- (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum)))
- (REGISTER (? register)))
- (eq-test/synthesized-constant*register type datum register))
-
-(define-rule predicate
- (EQ-TEST (REGISTER (? register))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum))))
- (eq-test/synthesized-constant*register type datum register))
-
-(define (eq-test/synthesized-constant*register type datum register)
- (set-standard-branches! 'EQ)
- (test-non-pointer type
- datum
- (standard-register-reference register 'DATA true)))
-
-(define-rule predicate
- (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum)))
- (? memory))
- (QUALIFIER (predicate/memory-operand? memory))
- (eq-test/synthesized-constant*memory type datum memory))
-
-(define-rule predicate
- (EQ-TEST (? memory)
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum))))
- (QUALIFIER (predicate/memory-operand? memory))
- (eq-test/synthesized-constant*memory type datum memory))
-
-(define (eq-test/synthesized-constant*memory type datum memory)
- (set-standard-branches! 'EQ)
- (test-non-pointer type
- datum
- (predicate/memory-operand-reference memory)))
-\f
-;;;; Fixnum/Flonum Predicates
-
-(define-rule predicate
- (OVERFLOW-TEST)
- (set-standard-branches! 'VS)
- (LAP))
-
-(define-rule predicate
- (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? register)))
- (set-standard-branches! (fixnum-predicate->cc predicate))
- (test-fixnum (standard-register-reference register 'DATA true)))
-
-(define-rule predicate
- (FIXNUM-PRED-1-ARG (? predicate) (OBJECT->FIXNUM (REGISTER (? register))))
- (set-standard-branches! (fixnum-predicate->cc predicate))
- (object->fixnum (standard-move-to-temporary! register 'DATA)))
-
-(define-rule predicate
- (FIXNUM-PRED-1-ARG (? predicate) (? memory))
- (QUALIFIER (predicate/memory-operand? memory))
- (set-standard-branches! (fixnum-predicate->cc predicate))
- (test-fixnum (predicate/memory-operand-reference memory)))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (REGISTER (? register-1))
- (REGISTER (? register-2)))
- (compare/register*register register-1
- register-2
- (fixnum-predicate->cc predicate)))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate) (REGISTER (? register)) (? memory))
- (QUALIFIER (predicate/memory-operand? memory))
- (compare/register*memory register
- (predicate/memory-operand-reference memory)
- (fixnum-predicate->cc predicate)))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate) (? memory) (REGISTER (? register)))
- (QUALIFIER (predicate/memory-operand? memory))
- (compare/register*memory
- register
- (predicate/memory-operand-reference memory)
- (invert-cc-noncommutative (fixnum-predicate->cc predicate))))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate) (? memory-1) (? memory-2))
- (QUALIFIER (and (predicate/memory-operand? memory-1)
- (predicate/memory-operand? memory-2)))
- (compare/memory*memory (predicate/memory-operand-reference memory-1)
- (predicate/memory-operand-reference memory-2)
- (fixnum-predicate->cc predicate)))
-\f
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (REGISTER (? register))
- (OBJECT->FIXNUM (CONSTANT (? constant))))
- (fixnum-predicate/register*constant register
- constant
- (fixnum-predicate->cc predicate)))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (REGISTER (? register)))
- (fixnum-predicate/register*constant
- register
- constant
- (invert-cc-noncommutative (fixnum-predicate->cc predicate))))
-
-(define (fixnum-predicate/register*constant register constant cc)
- (set-standard-branches! cc)
- (guarantee-signed-fixnum constant)
- (let ((reference (standard-register-reference register 'DATA true)))
- (if (effective-address/register? reference)
- (LAP (CMP L (& ,(* constant fixnum-1)) ,reference))
- (LAP (CMPI L (& ,(* constant fixnum-1)) ,reference)))))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (? memory)
- (OBJECT->FIXNUM (CONSTANT (? constant))))
- (QUALIFIER (predicate/memory-operand? memory))
- (fixnum-predicate/memory*constant (predicate/memory-operand-reference memory)
- constant
- (fixnum-predicate->cc predicate)))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (? memory))
- (QUALIFIER (predicate/memory-operand? memory))
- (fixnum-predicate/memory*constant
- (predicate/memory-operand-reference memory)
- constant
- (invert-cc-noncommutative (fixnum-predicate->cc predicate))))
-
-(define (fixnum-predicate/memory*constant memory constant cc)
- (set-standard-branches! cc)
- (guarantee-signed-fixnum constant)
- (LAP (CMPI L (& ,(* constant fixnum-1)) ,memory)))
-
-(define-rule predicate
- (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? register)))
- (QUALIFIER (register-value-class=float? register))
- (set-flonum-branches! (flonum-predicate->cc predicate))
- (LAP (FTST ,(standard-register-reference register 'FLOAT false))))
-
-(define-rule predicate
- (FLONUM-PRED-2-ARGS (? predicate)
- (REGISTER (? register1))
- (REGISTER (? register2)))
- (QUALIFIER (and (register-value-class=float? register1)
- (register-value-class=float? register2)))
- (set-flonum-branches! (flonum-predicate->cc predicate))
- (LAP (FCMP ,(standard-register-reference register2 'FLOAT false)
- ,(standard-register-reference register1 'FLOAT false))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Invocations and Entries
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Invocations
-
-(define-integrable (clear-continuation-type-code)
- (if (= scheme-type-width 8)
- (LAP (CLR B (@A 7)))
- (LAP (AND L ,mask-reference (@A 7)))))
-
-(define-rule statement
- (POP-RETURN)
- (LAP ,@(clear-map!)
- ,@(clear-continuation-type-code)
- (RTS)))
-
-(define-rule statement
- (INVOCATION:APPLY (? frame-size) (? continuation))
- continuation
- (LAP ,@(clear-map!)
- ,@(case frame-size
- ((1) (LAP (JMP ,entry:compiler-shortcircuit-apply-size-1)))
- ((2) (LAP (JMP ,entry:compiler-shortcircuit-apply-size-2)))
- ((3) (LAP (JMP ,entry:compiler-shortcircuit-apply-size-3)))
- ((4) (LAP (JMP ,entry:compiler-shortcircuit-apply-size-4)))
- ((5) (LAP (JMP ,entry:compiler-shortcircuit-apply-size-5)))
- ((6) (LAP (JMP ,entry:compiler-shortcircuit-apply-size-6)))
- ((7) (LAP (JMP ,entry:compiler-shortcircuit-apply-size-7)))
- ((8) (LAP (JMP ,entry:compiler-shortcircuit-apply-size-8)))
- (else
- (LAP ,@(load-dnl frame-size 2)
- (JMP ,entry:compiler-shortcircuit-apply))))))
-
-(define-rule statement
- (INVOCATION:JUMP (? frame-size) (? continuation) (? label))
- frame-size continuation
- (LAP ,@(clear-map!)
- (BRA (@PCR ,label))))
-
-(define-rule statement
- (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation))
- frame-size continuation
- ;; It expects the procedure at the top of the stack
- (LAP ,@(clear-map!)
- ,@(clear-continuation-type-code)
- (RTS)))
-
-(define-rule statement
- (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
- continuation
- (LAP ,@(clear-map!)
- ,@(load-dnl number-pushed 2)
- (LEA (@PCR ,label) (A 0))
- (MOV L (A 0) (D 1))
- ,@(invoke-interface code:compiler-lexpr-apply)))
-
-(define-rule statement
- (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation))
- continuation
- ;; It expects the procedure at the top of the stack
- (LAP ,@(clear-map!)
- ,@(load-dnl number-pushed 2)
- ,@(clear-continuation-type-code)
- (MOV L (@A+ 7) (D 1))
- ,@(invoke-interface code:compiler-lexpr-apply)))
-
-(define-rule statement
- (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
- continuation
- (LAP ,@(clear-map!)
- ;; The following assumes that at label there is
- ;; (JMP (L <entry>))
- ;; The other possibility would be
- ;; (JMP (@@PCR ,(free-uuo-link-label name frame-size)))
- ;; and to have <entry> at label, but it is longer and slower.
- (BRA (@PCR ,(free-uuo-link-label name frame-size)))))
-
-(define-rule statement
- (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
- continuation
- (LAP ,@(clear-map!)
- ;; The following assumes that at label there is
- ;; (JMP (L <entry>))
- ;; The other possibility would be
- ;; (JMP (@@PCR ,(global-uuo-link-label name frame-size)))
- ;; and to have <entry> at label, but it is longer and slower.
- (BRA (@PCR ,(global-uuo-link-label name frame-size)))))
-\f
-(define-rule statement
- (INVOCATION:CACHE-REFERENCE (? frame-size) (? continuation) (? extension))
- (QUALIFIER (interpreter-call-argument? extension))
- continuation
- (let ((set-extension
- (interpreter-call-argument->machine-register! extension d1)))
- (delete-dead-registers!)
- (LAP ,@set-extension
- ,@(clear-map!)
- ,@(load-dnl frame-size 3)
- (LEA (@PCR ,*block-label*) (A 1))
- (MOV L (A 1) (D 2))
- ,@(invoke-interface code:compiler-cache-reference-apply))))
-
-(define-rule statement
- (INVOCATION:LOOKUP (? frame-size) (? continuation) (? environment) (? name))
- (QUALIFIER (interpreter-call-argument? environment))
- continuation
- (let ((set-environment
- (interpreter-call-argument->machine-register! environment d1)))
- (delete-dead-registers!)
- (LAP ,@set-environment
- ,@(clear-map!)
- ,@(load-constant name (INST-EA (D 2)))
- ,@(load-dnl frame-size 3)
- ,@(invoke-interface code:compiler-lookup-apply))))
-
-(define-rule statement
- (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
- continuation
- (LAP ,@(clear-map!)
- ,@(cond ((eq? primitive compiled-error-procedure)
- (LAP ,@(load-dnl frame-size 1)
- (JMP ,entry:compiler-error)))
- ((eq? primitive (ucode-primitive set-interrupt-enables! 1))
- (LAP (JMP ,entry:compiler-set-interrupt-enables)))
- (else
- (let ((arity (primitive-procedure-arity primitive)))
- (cond ((not (negative? arity))
- (LAP (MOV L (@PCR ,(constant->label primitive)) (D 1))
- (JMP ,entry:compiler-primitive-apply)))
- ((= arity -1)
- (LAP (MOV L (& ,(-1+ frame-size))
- ,reg:lexpr-primitive-arity)
- (MOV L (@PCR ,(constant->label primitive)) (D 1))
- (JMP ,entry:compiler-primitive-lexpr-apply)))
- (else
- ;; Unknown primitive arity. Go through apply.
- (LAP ,@(load-dnl frame-size 2)
- (MOV L (@PCR ,(constant->label primitive)) (D 1))
- ,@(invoke-interface code:compiler-apply)))))))))
-\f
-(let-syntax
- ((define-special-primitive-invocation
- (sc-macro-transformer
- (lambda (form environment)
- `(DEFINE-RULE STATEMENT
- (INVOCATION:SPECIAL-PRIMITIVE
- (? frame-size)
- (? continuation)
- ,(make-primitive-procedure (cadr form) #t))
- FRAME-SIZE CONTINUATION
- (SPECIAL-PRIMITIVE-INVOCATION
- ,(close-syntax (symbol-append 'CODE:COMPILER- (cadr form))
- environment))))))
-
- (define-optimized-primitive-invocation
- (sc-macro-transformer
- (lambda (form environment)
- `(DEFINE-RULE STATEMENT
- (INVOCATION:SPECIAL-PRIMITIVE
- (? frame-size)
- (? continuation)
- ,(make-primitive-procedure (cadr form) #t))
- FRAME-SIZE CONTINUATION
- (OPTIMIZED-PRIMITIVE-INVOCATION
- ,(close-syntax (symbol-append 'ENTRY:COMPILER- (cadr form))
- environment)))))))
-
- (define-optimized-primitive-invocation &+)
- (define-optimized-primitive-invocation &-)
- (define-optimized-primitive-invocation &*)
- (define-optimized-primitive-invocation &/)
- (define-optimized-primitive-invocation &=)
- (define-optimized-primitive-invocation &<)
- (define-optimized-primitive-invocation &>)
- (define-optimized-primitive-invocation 1+)
- (define-optimized-primitive-invocation -1+)
- (define-optimized-primitive-invocation zero?)
- (define-optimized-primitive-invocation positive?)
- (define-optimized-primitive-invocation negative?)
- (define-optimized-primitive-invocation quotient)
- (define-optimized-primitive-invocation remainder))
-
-(define (special-primitive-invocation code)
- (LAP ,@(clear-map!)
- ,@(invoke-interface code)))
-
-(define (optimized-primitive-invocation hook)
- (LAP ,@(clear-map!)
- (JMP ,hook)))
-\f
-;;;; Invocation Prefixes
-
-(define-rule statement
- (INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER 15))
- (LAP))
-
-(define-rule statement
- (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER 12))
- (let ((temp (allocate-temporary-register! 'ADDRESS)))
- (LAP (MOV L ,(register-reference 12) ,(register-reference temp))
- ,@(generate/move-frame-up* frame-size temp))))
-
-(define-rule statement
- (INVOCATION-PREFIX:MOVE-FRAME-UP
- (? frame-size)
- (OFFSET-ADDRESS (REGISTER 15)
- (MACHINE-CONSTANT (? offset))))
- (let ((how-far (- offset frame-size)))
- (cond ((zero? how-far)
- (LAP))
- ((zero? frame-size)
- (increment-machine-register 15 (* 4 how-far)))
- ((= frame-size 1)
- (LAP (MOV L (@A+ 7) ,(offset-reference a7 (-1+ how-far)))
- ,@(increment-machine-register 15 (* 4 (-1+ how-far)))))
- ((= frame-size 2)
- (if (= how-far 1)
- (LAP (MOV L (@AO 7 4) (@AO 7 8))
- (MOV L (@A+ 7) (@A 7)))
- (let ((i (lambda ()
- (LAP (MOV L (@A+ 7)
- ,(offset-reference a7 (-1+ how-far)))))))
- (LAP ,@(i)
- ,@(i)
- ,@(increment-machine-register 15 (* 4 (- how-far 2)))))))
- (else
- (generate/move-frame-up frame-size (offset-reference a7 offset))))))
-
-(define-rule statement
- (INVOCATION-PREFIX:MOVE-FRAME-UP
- (? frame-size)
- (OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? offset))))
- (generate/move-frame-up frame-size (indirect-reference! base offset)))
-\f
-(define-rule statement
- (INVOCATION-PREFIX:DYNAMIC-LINK 0 (REGISTER 15) (REGISTER 12))
- (LAP))
-
-(define-rule statement
- (INVOCATION-PREFIX:DYNAMIC-LINK
- (? frame-size)
- (OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? offset)))
- (REGISTER 12))
- (let ((label (generate-label))
- (temp (allocate-temporary-register! 'ADDRESS)))
- (let ((temp-ref (register-reference temp)))
- (LAP (LEA ,(indirect-reference! base offset) ,temp-ref)
- (CMP L ,temp-ref (A 4))
- (B HS B (@PCR ,label))
- (MOV L (A 4) ,temp-ref)
- (LABEL ,label)
- ,@(generate/move-frame-up* frame-size temp)))))
-
-(define-rule statement
- (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
- (OBJECT->ADDRESS (REGISTER (? source)))
- (REGISTER 12))
- (let ((dreg (standard-move-to-temporary! source 'DATA))
- (label (generate-label))
- (temp (allocate-temporary-register! 'ADDRESS)))
- (let ((areg (register-reference temp)))
- (LAP (AND L ,mask-reference ,dreg)
- (MOV L ,dreg ,areg)
- (CMP L ,areg (A 4))
- (B HS B (@PCR ,label))
- (MOV L (A 4) ,areg)
- (LABEL ,label)
- ,@(generate/move-frame-up* frame-size temp)))))
-
-(define-rule statement
- (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
- (REGISTER (? source))
- (REGISTER 12))
- (let ((areg (standard-move-to-temporary! source 'ADDRESS))
- (label (generate-label)))
- (LAP (CMP L ,areg (A 4))
- (B HS B (@PCR ,label))
- (MOV L (A 4) ,areg)
- (LABEL ,label)
- ,@(generate/move-frame-up* frame-size
- (+ (lap:ea-operand-1 areg) 8)))))
-
-(define (generate/move-frame-up frame-size destination)
- (let ((temp (allocate-temporary-register! 'ADDRESS)))
- (LAP (LEA ,destination ,(register-reference temp))
- ,@(generate/move-frame-up* frame-size temp))))
-
-(define (generate/move-frame-up* frame-size destination)
- (let ((temp (allocate-temporary-register! 'ADDRESS)))
- (LAP (LEA ,(offset-reference a7 frame-size) ,(register-reference temp))
- ,@(generate-n-times
- frame-size 5
- (lambda ()
- (LAP (MOV L
- (@-A ,(- temp 8))
- (@-A ,(- destination 8)))))
- (lambda (generator)
- (generator (allocate-temporary-register! 'DATA))))
- (MOV L ,(register-reference destination) (A 7)))))
-\f
-;;;; External Labels
-
-(define (make-external-label code label)
- (set! *external-labels* (cons label *external-labels*))
- (LAP (DC UW ,code)
- (BLOCK-OFFSET ,label)
- (LABEL ,label)))
-
-;;; Entry point types
-
-(define-integrable (make-code-word min max)
- (+ (* #x100 min) max))
-
-(define (make-procedure-code-word min max)
- ;; The "min" byte must be less than #x80; the "max" byte may not
- ;; equal #x80 but can take on any other value.
- (if (or (negative? min) (>= min #x80))
- (error "MAKE-PROCEDURE-CODE-WORD: minimum out of range" min))
- (if (>= (abs max) #x80)
- (error "MAKE-PROCEDURE-CODE-WORD: maximum out of range" max))
- (make-code-word min (if (negative? max) (+ #x100 max) max)))
-
-(define expression-code-word
- (make-code-word #xff #xff))
-
-(define internal-entry-code-word
- (make-code-word #xff #xfe))
-
-(define internal-continuation-code-word
- (make-code-word #xff #xfc))
-
-(define (frame-size->code-word offset default)
- (cond ((not offset)
- default)
- ((< offset #x2000)
- ;; This uses up through (#xff #xdf).
- (let ((qr (integer-divide offset #x80)))
- (make-code-word (+ #x80 (integer-divide-remainder qr))
- (+ #x80 (integer-divide-quotient qr)))))
- (else
- (error "Unable to encode continuation offset" offset))))
-
-(define (continuation-code-word label)
- (frame-size->code-word
- (if label
- (rtl-continuation/next-continuation-offset (label->object label))
- 0)
- internal-continuation-code-word))
-
-(define (internal-procedure-code-word rtl-proc)
- (frame-size->code-word
- (rtl-procedure/next-continuation-offset rtl-proc)
- internal-entry-code-word))
-\f
-;;;; Procedure headers
-
-;;; The following calls MUST appear as the first thing at the entry
-;;; point of a procedure. They assume that the register map is clear
-;;; and that no register contains anything of value.
-;;;
-;;; The only reason that this is true is that no register is live
-;;; across calls. If that were not true, then we would have to save
-;;; any such registers on the stack so that they would be GC'ed
-;;; appropriately.
-;;;
-;;; The only exception is the dynamic link register, handled
-;;; specially. Procedures that require a dynamic link use a different
-;;; interrupt handler that saves and restores the dynamic link
-;;; register.
-
-(define-integrable (simple-procedure-header code-word label entry)
- (let ((gc-label (generate-label)))
- (LAP (LABEL ,gc-label)
- (JSR ,entry)
- ,@(make-external-label code-word label)
- ,@(interrupt-check label gc-label -12))))
-
-(define (interrupt-check label gc-label gc-label-offset)
- (case (let ((object (label->object label)))
- (and (rtl-procedure? object)
- (not (rtl-procedure/stack-leaf? object))
- compiler:generate-stack-checks?))
- ((#F)
- (LAP (CMP L ,reg:compiled-memtop (A 5))
- (B GE B (@PCR ,gc-label))))
- ((OUT-OF-LINE)
- (LAP (JSR
- ,(case gc-label-offset
- ((-12) entry:compiler-stack-and-interrupt-check-12)
- ((-14) entry:compiler-stack-and-interrupt-check-14)
- ((-18) entry:compiler-stack-and-interrupt-check-18)
- ((-22) entry:compiler-stack-and-interrupt-check-22)
- ((-24) entry:compiler-stack-and-interrupt-check-24)
- (else (error "Illegal GC label offset:"
- gc-label-offset))))))
- (else
- (LAP (CMP L ,reg:compiled-memtop (A 5))
- (B GE B (@PCR ,gc-label))
- (CMP L ,reg:stack-guard (A 7))
- (B LE B (@PCR ,gc-label))))))
-
-(define-rule statement
- (CONTINUATION-ENTRY (? internal-label))
- (make-external-label (continuation-code-word internal-label)
- internal-label))
-
-(define-rule statement
- (CONTINUATION-HEADER (? internal-label))
- (simple-procedure-header (continuation-code-word internal-label)
- internal-label
- entry:compiler-interrupt-continuation))
-
-(define-rule statement
- (IC-PROCEDURE-HEADER (? internal-label))
- (let ((procedure (label->object internal-label)))
- (let ((external-label (rtl-procedure/external-label procedure))
- (gc-label (generate-label)))
- (LAP (ENTRY-POINT ,external-label)
- (EQUATE ,external-label ,internal-label)
- (LABEL ,gc-label)
- ,@(invoke-interface-jsr code:compiler-interrupt-ic-procedure)
- ,@(make-external-label expression-code-word internal-label)
- ,@(interrupt-check internal-label gc-label -14)))))
-
-(define-rule statement
- (OPEN-PROCEDURE-HEADER (? internal-label))
- (let ((rtl-proc (label->object internal-label)))
- (LAP (EQUATE ,(rtl-procedure/external-label rtl-proc) ,internal-label)
- ,@(simple-procedure-header (internal-procedure-code-word rtl-proc)
- internal-label
- (if (rtl-procedure/dynamic-link? rtl-proc)
- entry:compiler-interrupt-dlink
- entry:compiler-interrupt-procedure)))))
-
-(define-rule statement
- (PROCEDURE-HEADER (? internal-label) (? min) (? max))
- (LAP (EQUATE ,(rtl-procedure/external-label
- (label->object internal-label))
- ,internal-label)
- ,@(simple-procedure-header (make-procedure-code-word min max)
- internal-label
- entry:compiler-interrupt-procedure)))
-\f
-;;;; Closures:
-
-#|
-
-The closure headers and closure consing code are heavily interdependent.
-
-There are two different versions of the rules, depending on the closure format:
-
-The 68020 format can be used when there is no problem with
-inconsistency between the processor's I-cache and the D-cache. In
-this format, closures contain an absolute JSR instruction, stored by
-the closure consing code. The absolute address is the address of the
-labelled word in the closure header. Closures are allocated directly
-from the Scheme heap, and the instructions are stored by the
-cons-closure code. Multiple entry-point closures have their entry
-points tightly packed, and since the JSR instruction is 6 bytes long,
-entries are not, in general at longword boundaries. Because the rest
-of the compiler requires the closure object on the stack to be
-longword aligned, these objects always correspond to the first
-(canonical) entry point of a closure with multiple entry points. Thus
-there is a little shuffling around to maintain this, and the identity
-of the object.
-
-The 68040 format should be used when the D-cache is in copyback mode
-(ie. storing to an address may not be seen by the I-cache even if
-there was no previous association). In this format, closures contain
-a JSR instruction to a fixed piece of code, and the actual entry point
-is stored folling this fixed instruction. The garbage collector can
-change this to an absolute JSR instruction. Closures are allocated
-from a pool, renewed by out of line code that also pre-stores the
-instructions and synchronizes the caches. Entry points are always
-long-word aligned and there is no need for shuffling.
-
-|#
-
-(define (MC68020/closure-header internal-label nentries entry)
- nentries ; ignored
- (let ((rtl-proc (label->object internal-label)))
- (let ((gc-label (generate-label))
- (external-label (rtl-procedure/external-label rtl-proc)))
- (if (zero? nentries)
- (LAP (EQUATE ,external-label ,internal-label)
- ,@(simple-procedure-header
- (internal-procedure-code-word rtl-proc)
- internal-label
- entry:compiler-interrupt-procedure))
- (with-values
- (lambda ()
- (let ((distance (* 10 entry)))
- (cond ((zero? distance)
- (values (LAP)
- 0))
- ((< distance 128)
- (values (LAP (MOVEQ (& ,distance) (D 0))
- (ADD L (D 0) (@A 7)))
- 4))
- (else
- (values (LAP (ADD L (& ,distance) (@A 7)))
- 6)))))
- (lambda (adjustment adjustment-size)
- (LAP (LABEL ,gc-label)
- ,@adjustment
- (JMP ,entry:compiler-interrupt-closure)
- ,@(make-external-label internal-entry-code-word
- external-label)
- (ADD UL (& ,(MC68020/make-magic-closure-constant entry))
- (@A 7))
- (LABEL ,internal-label)
- ,@(interrupt-check internal-label
- gc-label
- (- -18 adjustment-size)))))))))
-\f
-(define (MC68020/cons-closure target procedure-label min max size)
- (let* ((target (reference-target-alias! target 'ADDRESS))
- (temporary (reference-temporary-register! 'ADDRESS)))
- (LAP (LEA (@PCR ,(rtl-procedure/external-label
- (label->object procedure-label)))
- ,temporary)
- ,@(load-non-pointer (ucode-type manifest-closure)
- (+ 3 size)
- (INST-EA (@A+ 5)))
- (MOV UL
- (& ,(+ (* (make-procedure-code-word min max) #x10000) 8))
- (@A+ 5))
- (MOV L (A 5) ,target)
- (MOV UW (& #x4eb9) (@A+ 5)) ; (JSR (L <entry>))
- (MOV L ,temporary (@A+ 5))
- (CLR W (@A+ 5))
- ,@(increment-machine-register 13 (* 4 size)))))
-
-(define (MC68020/cons-multiclosure target nentries size entries)
- (let ((target (reference-target-alias! target 'ADDRESS)))
- (let ((total-size (+ size
- (quotient (+ 3 (* 5 nentries))
- 2)))
- (temp1 (reference-temporary-register! 'ADDRESS))
- (temp2 (reference-temporary-register! 'DATA)))
-
- (define (generate-entries entries offset first?)
- (if (null? entries)
- (LAP)
- (let ((entry (car entries)))
- (LAP (MOV UL (& ,(+ (* (make-procedure-code-word (cadr entry)
- (caddr entry))
- #x10000)
- offset))
- (@A+ 5))
- ,@(if first?
- (LAP (MOV L (A 5) ,target))
- (LAP))
- (LEA (@PCR ,(rtl-procedure/external-label
- (label->object (car entry))))
- ,temp1)
- (MOV W ,temp2 (@A+ 5)) ; (JSR (L <entry>))
- (MOV L ,temp1 (@A+ 5))
- ,@(generate-entries (cdr entries)
- (+ 10 offset)
- false)))))
-
- (LAP ,@(load-non-pointer (ucode-type manifest-closure)
- total-size
- (INST-EA (@A+ 5)))
- (MOV UL (& ,(* nentries #x10000)) (@A+ 5))
- (MOV UW (& #x4eb9) ,temp2)
- ,@(generate-entries entries 12 true)
- ,@(if (odd? nentries)
- (LAP (CLR W (@A+ 5)))
- (LAP))
- ,@(increment-machine-register 13 (* 4 size))))))
-
-(define (MC68020/make-magic-closure-constant entry)
- (- (make-non-pointer-literal (ucode-type compiled-entry) 0)
- (+ (* entry 10) 6)))
-\f
-(define (MC68040/closure-header internal-label nentries entry)
- nentries entry ; ignored
- (let ((rtl-proc (label->object internal-label)))
- (let ((gc-label (generate-label))
- (external-label (rtl-procedure/external-label rtl-proc)))
- (if (zero? nentries)
- (LAP (EQUATE ,external-label ,internal-label)
- ,@(simple-procedure-header
- (internal-procedure-code-word rtl-proc)
- internal-label
- entry:compiler-interrupt-procedure))
- (LAP (LABEL ,gc-label)
- (JMP ,entry:compiler-interrupt-closure)
- ,@(make-external-label internal-entry-code-word
- external-label)
- (ADD UL (& ,(MC68040/make-magic-closure-constant entry)) (@A 7))
- (LABEL ,internal-label)
- ,@(interrupt-check internal-label gc-label -18))))))
-
-(define (MC68040/cons-closure target procedure-label min max size)
- (MC68040/with-allocated-closure target 1 size
- (lambda (an)
- (let ((temp (reference-temporary-register! 'ADDRESS)))
- (LAP ,@(load-non-pointer (ucode-type manifest-closure)
- (+ size MC68040/closure-entry-size)
- (INST-EA (@A+ ,an)))
- (MOV UL
- (& ,(+ (* (make-procedure-code-word min max) #x10000) 8))
- (@A+ ,an))
- (LEA (@PCR ,(rtl-procedure/external-label
- (label->object procedure-label)))
- ,temp)
- (MOV L ,temp (@AO ,an 4)))))))
-
-(define (MC68040/cons-multiclosure target nentries size entries)
- (MC68040/with-allocated-closure target nentries size
- (lambda (atarget)
- (let* ((atmp1 (areg->an (allocate-temporary-register! 'ADDRESS)))
- (atmp2 (areg->an (allocate-temporary-register! 'ADDRESS))))
- (define (store-entries offset entries)
- (if (null? entries)
- (LAP)
- (let ((entry (car entries)))
- (LAP (MOV UL (& ,(+ (* (make-procedure-code-word (cadr entry)
- (caddr entry))
- #x10000)
- offset))
- (@A+ ,atmp1))
- (ADDQ L (& 4) (A ,atmp1)) ; bump over JSR instr.
- (LEA (@PCR ,(rtl-procedure/external-label
- (label->object (car entry))))
- (A ,atmp2))
- (MOV L (A ,atmp2) (@A+ ,atmp1))
- ,@(store-entries (+ 12 offset) (cdr entries))))))
-
- (LAP ,@(load-non-pointer (ucode-type manifest-closure)
- (+ size 1
- (* nentries MC68040/closure-entry-size))
- (INST-EA (@A+ ,atarget)))
- (MOV UL (& ,(* nentries #x10000)) (@A+ ,atarget))
- (MOV L (A ,atarget) (A ,atmp1))
- (ADDQ L (& 4) (A ,atarget))
- ,@(store-entries 12 entries))))))
-\f
-;;;; Utilities for MC68040 closures.
-
-(define (MC68040/make-magic-closure-constant entry)
- entry ; ignored
- (- (make-non-pointer-literal (ucode-type compiled-entry) 0)
- 6))
-
-;; In what follows, entry:compiler-allocate-closure gets its parameter in d0
-;; and returns its value in a0.
-
-(define (MC68040/allocate-closure size)
- (LAP ,@(load-dnl size 0)
- (JSR ,entry:compiler-allocate-closure)))
-
-;; If this issues too much code, the optional code can be eliminated at
-;; some performace penalty in speed.
-
-(define (MC68040/with-allocated-closure target nentries size recvr)
- (require-register! d0)
- (rtl-target:=machine-register! target a0)
- (let ((total-size (+ 1
- (if (= nentries 1) 0 1)
- (* MC68040/closure-entry-size nentries)
- size))
- (label (generate-label)))
- (LAP
- ;; Optional code:
- (MOV L ,reg:closure-free (A 0))
- ,@(ea+=constant reg:closure-free (* 4 total-size))
- ,@(ea+=constant reg:closure-space (- 0 total-size))
- (B GE B (@PCR ,label))
- ;; End of optional code.
- ,@(MC68040/allocate-closure total-size)
- (LABEL ,label)
- ,@(recvr 0))))
-
-(define (rtl-target:=machine-register! rtl-reg machine-reg)
- (if (machine-register? rtl-reg)
- (begin
- (require-register! machine-reg)
- (if (not (= rtl-reg machine-reg))
- (suffix-instructions!
- (register->register-transfer machine-reg rtl-reg))))
- (begin
- (delete-register! rtl-reg)
- (flush-register! machine-reg)
- (add-pseudo-register-alias! rtl-reg machine-reg))))
-
-(define (require-register! machine-reg)
- (flush-register! machine-reg)
- (need-register! machine-reg))
-
-(define-integrable (flush-register! machine-reg)
- (prefix-instructions! (clear-registers! machine-reg)))
-
-(define-integrable (areg->an areg)
- (- areg 8))
-\f
-;;;; The rules themselves.
-
-(define-rule statement
- (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
- (generate/closure-header internal-label nentries entry))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
- (? min) (? max) (? size)))
- (generate/cons-closure target procedure-label min max size))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-MULTICLOSURE (? nentries) (? size) (? entries)))
- (case nentries
- ((0)
- (let ((target (reference-target-alias! target 'ADDRESS)))
- (LAP (MOV L (A 5) ,target)
- ,@(load-non-pointer (ucode-type manifest-vector)
- size
- (INST-EA (@A+ 5)))
- ,@(increment-machine-register 13 (* 4 size)))))
- ((1)
- (let ((entry (vector-ref entries 0)))
- (generate/cons-closure target
- (car entry) (cadr entry) (caddr entry)
- size)))
- (else
- (generate/cons-multiclosure target nentries size
- (vector->list entries)))))
-
-(let-syntax ((define/format-dependent
- (sc-macro-transformer
- (lambda (form environment)
- `(DEFINE ,(cadr form)
- (CASE MC68K/CLOSURE-FORMAT
- ((MC68020)
- ,(close-syntax (symbol-append 'MC68020/ (caddr form))
- environment))
- ((MC68040)
- ,(close-syntax (symbol-append 'MC68040/ (caddr form))
- environment))
- (ELSE
- (ERROR "Unknown closure format:" CLOSURE-FORMAT))))))))
-
-(define/format-dependent generate/closure-header closure-header)
-(define/format-dependent generate/cons-closure cons-closure)
-(define/format-dependent generate/cons-multiclosure cons-multiclosure)
-)
-\f
-;;;; Entry Header
-;;; This is invoked by the top level of the LAP generator.
-
-(define (generate/quotation-header environment-label free-ref-label n-sections)
- (LAP (LEA (@PCR ,environment-label) (A 0))
- (MOV L ,reg:environment (@A 0))
- (LEA (@PCR ,*block-label*) (A 0))
- (MOV L (A 0) (D 2))
- (LEA (@PCR ,free-ref-label) (A 0))
- (MOV L (A 0) (D 3))
- ,@(load-dnl n-sections 4)
- (JSR ,entry:compiler-link)
- ,@(make-external-label (continuation-code-word false)
- (generate-label))))
-
-(define (generate/remote-link code-block-label
- environment-offset
- free-ref-offset
- n-sections)
- (let ((load-offset
- (lambda (offset)
- (if (<= -32768 offset 32767)
- (LAP (LEA (@AO 0 ,offset) (A 1)))
- (LAP (LEA (@AOF 0 E (,offset L) #F
- ((D 0) L 1) Z
- (0 N))
- (A 1)))))))
- (LAP (MOV L (@PCR ,code-block-label) (D 2))
- (AND L ,mask-reference (D 2))
- (MOV L (D 2) (A 0))
- ,@(load-offset environment-offset)
- (MOV L ,reg:environment (@A 1))
- ,@(load-offset free-ref-offset)
- (MOV L (A 1) (D 3))
- ,@(load-dnl n-sections 4)
- (JSR ,entry:compiler-link)
- ,@(make-external-label (continuation-code-word false)
- (generate-label)))))
-\f
-(define (generate/remote-links n-code-blocks code-blocks-label n-sections)
- (if (= n-code-blocks 0)
- (LAP)
- (let ((loop (generate-label 'LOOP))
- (bytes (generate-label 'BYTES)))
- (LAP (CLR L (D 0))
- ;; Set up counter
- (MOV L (D 0) (@-A 7))
- (BRA (@PCR ,loop))
- (LABEL ,bytes)
- ,@(sections->bytes n-code-blocks n-sections)
- (LABEL ,loop)
- ;; Increment counter for next iteration
- (ADDQ L (& 1) (@A 7))
- ;; Get subblock
- (MOV L (@PCR ,code-blocks-label) (D 2))
- (AND L (D 7) (D 2))
- (MOV L (D 2) (A 0))
- (MOV L (@AOXS 0 4 ((D 0) L 4)) (D 2))
- ;; Get number of linkage sections
- (CLR L (D 4))
- ,@(if (<= n-code-blocks 100)
- ;; Approximate decision, to avoid extending the
- ;; branch tensioner.
- (LAP (MOV B (@PCRXS ,bytes ((D 0) L 1)) (D 4)))
- (LAP (LEA (@PCR ,bytes) (A 0))
- (MOV B (@AOXS 0 0 ((D 0) L 1)) (D 4))))
- ;; block -> address
- (AND L (D 7) (D 2))
- (MOV L (D 2) (A 0))
- ;; Get length and non-marked length
- (MOV L (@A 0) (D 3))
- (MOV L (@AO 0 4) (D 5))
- ;; Strip type tags
- (AND L (D 7) (D 3))
- (AND L (D 7) (D 5))
- ;; Store environment
- (MOV L ,reg:environment (@AOXS 0 0 ((D 3) L 4)))
- ;; Address of first constant (linkage area)
- (LEA (@AOXS 0 8 ((D 5) L 4)) (A 1))
- (MOV L (A 1) (D 3))
- (JSR ,entry:compiler-link)
- ,@(make-external-label (continuation-code-word false)
- (generate-label))
- ;; Counter value
- (MOV L (@A 7) (D 0))
- ;; Exit loop if we've done all
- (CMP L (& ,n-code-blocks) (D 0))
- (B NE (@PCR ,loop))
- ;; Pop counter off the stack
- (ADDQ L (& 4) (A 7))))))
-
-(define (sections->bytes n-code-blocks n-sections)
- (let walk ((bytes
- (append (vector->list n-sections)
- (let ((left (remainder n-code-blocks 2)))
- (if (zero? left)
- '()
- (make-list (- 2 left) 0))))))
- (if (null? bytes)
- (LAP)
- (let ((hi (car bytes))
- (lo (cadr bytes)))
- (LAP (DC UW ,(+ lo (* 256 hi)))
- ,@(walk (cddr bytes)))))))
-\f
-(define (generate/constants-block constants references assignments
- uuo-links global-links static-vars)
- (let ((constant-info
- (declare-constants 0 (transmogrifly uuo-links)
- (declare-constants 1 references
- (declare-constants 2 assignments
- (declare-constants 3 (transmogrifly global-links)
- (declare-constants false
- (map (lambda (pair)
- (cons false (cdr pair)))
- static-vars)
- (declare-constants false constants
- (cons false (LAP))))))))))
- (let ((free-ref-label (car constant-info))
- (constants-code (cdr constant-info))
- (debugging-information-label (allocate-constant-label))
- (environment-label (allocate-constant-label))
- (n-sections
- (+ (if (null? uuo-links) 0 1)
- (if (null? references) 0 1)
- (if (null? assignments) 0 1)
- (if (null? global-links) 0 1))))
- (values
- (LAP ,@constants-code
- ;; Place holder for the debugging info filename
- (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO)
- ;; Place holder for the load time environment if needed
- (SCHEME-OBJECT ,environment-label
- ,(if (null? free-ref-label) 0 'ENVIRONMENT)))
- environment-label
- free-ref-label
- n-sections))))
-
-(define (declare-constants tag constants info)
- (define (inner constants)
- (if (null? constants)
- (cdr info)
- (let ((entry (car constants)))
- (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry))
- ,@(inner (cdr constants))))))
- (if (and tag (not (null? constants)))
- (let ((label (allocate-constant-label)))
- (cons label
- (inner
- `((,(let ((datum (length constants)))
- (if (> datum #xffff)
- (error "datum too large" datum))
- (+ (* tag #x10000) datum))
- . ,label)
- ,@constants))))
- (cons (car info) (inner constants))))
-
-(define (transmogrifly uuos)
- (define (inner name assoc)
- (if (null? assoc)
- (transmogrifly (cdr uuos))
- (cons (cons name (cdar assoc)) ; uuo-label
- (cons (cons (caar assoc) ; frame-size
- (allocate-constant-label))
- (inner name (cdr assoc))))))
- (if (null? uuos)
- '()
- (inner (caar uuos) (cdar uuos))))
-\f
-;;; Local Variables: ***
-;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
-;;; End: ***
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Interpreter Calls
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Variable cache trap handling.
-
-(define-rule statement
- (INTERPRETER-CALL:CACHE-REFERENCE (? cont) (? extension) (? safe?))
- (QUALIFIER (interpreter-call-argument? extension))
- cont ; ignored
- (let ((set-extension
- (interpreter-call-argument->machine-register! extension d2)))
- (let ((clear-map (clear-map!)))
- (LAP ,@set-extension
- ,@clear-map
- (JSR ,(if safe?
- entry:compiler-safe-reference-trap
- entry:compiler-reference-trap))))))
-
-(define-rule statement
- (INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont) (? extension) (? value))
- (QUALIFIER (and (interpreter-call-argument? extension)
- (interpreter-call-argument? value)))
- cont ; ignored
- (let ((set-extension
- (interpreter-call-argument->machine-register! extension d2)))
- (let ((set-value (interpreter-call-argument->machine-register! value d3)))
- (let ((clear-map (clear-map!)))
- (LAP ,@set-extension
- ,@set-value
- ,@clear-map
- (JSR ,entry:compiler-assignment-trap))))))
-
-(define-rule statement
- (INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont) (? extension))
- (QUALIFIER (interpreter-call-argument? extension))
- cont ; ignored
- (let ((set-extension
- (interpreter-call-argument->machine-register! extension d2)))
- (let ((clear-map (clear-map!)))
- (LAP ,@set-extension
- ,@clear-map
- ,@(invoke-interface-jsr code:compiler-unassigned?-trap)))))
-\f
-;;;; Interpreter Calls
-
-;;; All the code that follows is obsolete. It hasn't been used in a while.
-;;; It is provided in case the relevant switches are turned off, but there
-;;; is no real reason to do this. Perhaps the switches should be removed.
-
-(define (interpreter-call-argument? expression)
- (or (rtl:register? expression)
- (rtl:constant? expression)
- (and (rtl:cons-pointer? expression)
- (rtl:machine-constant? (rtl:cons-pointer-type expression))
- (rtl:machine-constant? (rtl:cons-pointer-datum expression)))
- (rtl:simple-offset? expression)))
-
-(define (interpreter-call-argument->machine-register! expression register)
- (let ((target (register-reference register)))
- (case (car expression)
- ((REGISTER)
- (load-machine-register! (rtl:register-number expression) register))
- ((CONSTANT)
- (LAP ,@(clear-registers! register)
- ,@(load-constant (rtl:constant-value expression) target)))
- ((CONS-POINTER)
- (LAP ,@(clear-registers! register)
- ,@(load-non-pointer (rtl:machine-constant-value
- (rtl:cons-pointer-type expression))
- (rtl:machine-constant-value
- (rtl:cons-pointer-datum expression))
- target)))
- ((OFFSET)
- (let ((source-reference (offset->reference! expression)))
- (LAP ,@(clear-registers! register)
- (MOV L ,source-reference ,target))))
- (else
- (error "Unknown expression type" (car expression))))))
-
-(define-rule statement
- (INTERPRETER-CALL:ACCESS (? cont) (? environment) (? name))
- (QUALIFIER (interpreter-call-argument? environment))
- cont ; ignored
- (lookup-call code:compiler-access environment name))
-
-(define-rule statement
- (INTERPRETER-CALL:LOOKUP (? cont) (? environment) (? name) (? safe?))
- (QUALIFIER (interpreter-call-argument? environment))
- cont ; ignored
- (lookup-call (if safe? code:compiler-safe-lookup code:compiler-lookup)
- environment name))
-
-(define-rule statement
- (INTERPRETER-CALL:UNASSIGNED? (? cont) (? environment) (? name))
- (QUALIFIER (interpreter-call-argument? environment))
- cont ; ignored
- (lookup-call code:compiler-unassigned? environment name))
-
-(define-rule statement
- (INTERPRETER-CALL:UNBOUND? (? cont) (? environment) (? name))
- (QUALIFIER (interpreter-call-argument? environment))
- cont ; ignored
- (lookup-call code:compiler-unbound? environment name))
-
-(define (lookup-call code environment name)
- (let ((set-environment
- (interpreter-call-argument->machine-register! environment d2)))
- (let ((clear-map (clear-map!)))
- (LAP ,@set-environment
- ,@clear-map
- ,@(load-constant name (INST-EA (D 3)))
- ,@(invoke-interface-jsr code)))))
-\f
-(define-rule statement
- (INTERPRETER-CALL:DEFINE (? cont) (? environment) (? name) (? value))
- (QUALIFIER (and (interpreter-call-argument? environment)
- (interpreter-call-argument? value)))
- cont ; ignored
- (assignment-call code:compiler-define environment name value))
-
-(define-rule statement
- (INTERPRETER-CALL:SET! (? cont) (? environment) (? name) (? value))
- (QUALIFIER (and (interpreter-call-argument? environment)
- (interpreter-call-argument? value)))
- cont ; ignored
- (assignment-call code:compiler-set! environment name value))
-
-(define (assignment-call code environment name value)
- (let ((set-environment
- (interpreter-call-argument->machine-register! environment d2)))
- (let ((set-value (interpreter-call-argument->machine-register! value d4)))
- (let ((clear-map (clear-map!)))
- (LAP ,@set-environment
- ,@set-value
- ,@clear-map
- ,@(load-constant name (INST-EA (D 3)))
- ,@(invoke-interface-jsr code))))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RTL Rewrite Rules
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Synthesized Data
-
-(define-rule rewriting
- (CONS-NON-POINTER (? type) (? datum))
- ;; On 68000, there's no difference between an address and a datum,
- ;; so the rules for constructing non-pointer objects are the same as
- ;; those for pointer objects.
- (rtl:make-cons-pointer type datum))
-
-(define-rule rewriting
- (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
- (QUALIFIER (rtl:machine-constant? type))
- (rtl:make-cons-pointer type datum))
-
-(define-rule rewriting
- (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
- (QUALIFIER
- (and (rtl:object->type? type)
- (rtl:constant? (rtl:object->type-expression type))))
- (rtl:make-cons-pointer
- (rtl:make-machine-constant
- (object-type (rtl:constant-value (rtl:object->type-expression datum))))
- datum))
-
-(define-rule rewriting
- (CONS-POINTER (? type) (REGISTER (? datum register-known-value)))
- (QUALIFIER (rtl:machine-constant? datum))
- (rtl:make-cons-pointer type datum))
-
-(define-rule rewriting
- (CONS-POINTER (? type) (REGISTER (? datum register-known-value)))
- (QUALIFIER
- (and (rtl:object->datum? datum)
- (rtl:constant-non-pointer? (rtl:object->datum-expression datum))))
- (rtl:make-cons-pointer
- type
- (rtl:make-machine-constant
- (careful-object-datum
- (rtl:constant-value (rtl:object->datum-expression datum))))))
-
-(define-rule rewriting
- (OBJECT->TYPE (REGISTER (? source register-known-value)))
- (QUALIFIER (rtl:constant? source))
- (rtl:make-machine-constant (object-type (rtl:constant-value source))))
-
-(define-rule rewriting
- (OBJECT->DATUM (REGISTER (? source register-known-value)))
- (QUALIFIER (rtl:constant-non-pointer? source))
- (rtl:make-machine-constant
- (careful-object-datum (rtl:constant-value source))))
-
-(define (rtl:constant-non-pointer? expression)
- (and (rtl:constant? expression)
- (non-pointer-object? (rtl:constant-value expression))))
-\f
-;;; These rules are losers because there's no abstract way to cons a
-;;; statement or a predicate without also getting some CFG structure.
-
-;;; Shouldn't these rules use (rtl:make-machine-constant 0)
-;;; rather than comparand? Of course, there would have to
-;;; be more translation rules, but... -- Jinx
-
-(define-rule rewriting
- ;; CLR.L instruction
- (ASSIGN (? target) (REGISTER (? comparand register-known-value)))
- (QUALIFIER (rtl:immediate-zero-constant? comparand))
- (list 'ASSIGN target comparand))
-
-(define-rule rewriting
- ;; TST.L instruction
- (EQ-TEST (? source) (REGISTER (? comparand register-known-value)))
- (QUALIFIER (rtl:immediate-zero-constant? comparand))
- (list 'EQ-TEST source comparand))
-
-(define-rule rewriting
- ;; TST.L instruction
- (EQ-TEST (REGISTER (? comparand register-known-value)) (? source))
- (QUALIFIER (rtl:immediate-zero-constant? comparand))
- (list 'EQ-TEST source comparand))
-
-(define (rtl:immediate-zero-constant? expression)
- (cond ((rtl:constant? expression)
- (let ((value (rtl:constant-value expression)))
- (and (non-pointer-object? value)
- (zero? (object-type value))
- (zero? (careful-object-datum value)))))
- ((rtl:cons-pointer? expression)
- (and (let ((expression (rtl:cons-pointer-type expression)))
- (and (rtl:machine-constant? expression)
- (zero? (rtl:machine-constant-value expression))))
- (let ((expression (rtl:cons-pointer-datum expression)))
- (and (rtl:machine-constant? expression)
- (zero? (rtl:machine-constant-value expression))))))
- (else false)))
-\f
-;;;; Fixnums
-
-(define-rule rewriting
- (OBJECT->FIXNUM (REGISTER (? source register-known-value)))
- (QUALIFIER (rtl:constant-fixnum? source))
- (rtl:make-object->fixnum source))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (REGISTER (? operand-1 register-known-value))
- (? operand-2)
- (? overflow?))
- (QUALIFIER
- (rtl:constant-fixnum-test operand-1
- (lambda (n)
- (or (zero? n)
- (= -1 n)
- (integer-log-base-2? n)))))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 overflow?))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- (? overflow?))
- (QUALIFIER
- (rtl:constant-fixnum-test operand-2
- (lambda (n)
- (or (zero? n)
- (= -1 n)
- (integer-log-base-2? n)))))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 overflow?))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS (? operator)
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- (? overflow?))
- (QUALIFIER
- (and (memq operator '(PLUS-FIXNUM MINUS-FIXNUM))
- (rtl:constant-fixnum-test operand-2 zero?)))
- (rtl:make-fixnum-2-args operator operand-1 operand-2 overflow?))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS (? operator)
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- (? overflow?))
- (QUALIFIER
- (and (memq operator '(FIXNUM-QUOTIENT FIXNUM-REMAINDER))
- (rtl:constant-fixnum-test operand-2
- (lambda (n)
- (or (= -1 n)
- (integer-log-base-2? n))))))
- (rtl:make-fixnum-2-args operator operand-1 operand-2 overflow?))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS FIXNUM-LSH
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- (? overflow?))
- (QUALIFIER
- (rtl:constant-fixnum-test operand-2
- (lambda (n)
- n ; ignored
- true)))
- (rtl:make-fixnum-2-args 'FIXNUM-LSH operand-1 operand-2 overflow?))
-
-(define (rtl:constant-fixnum? expression)
- (and (rtl:constant? expression)
- (fix:fixnum? (rtl:constant-value expression))))
-
-(define (rtl:constant-fixnum-test expression predicate)
- (and (rtl:object->fixnum? expression)
- (let ((expression (rtl:object->fixnum-expression expression)))
- (and (rtl:constant? expression)
- (let ((n (rtl:constant-value expression)))
- (and (fix:fixnum? n)
- (predicate n)))))))
-\f
-;;;; Indexed addressing modes
-
-(define-rule rewriting
- (OFFSET (REGISTER (? base register-known-value))
- (MACHINE-CONSTANT (? value)))
- (QUALIFIER (and (rtl:offset-address? base)
- (rtl:simple-subexpressions? base)))
- (rtl:make-offset base (rtl:make-machine-constant value)))
-
-(define-rule rewriting
- (BYTE-OFFSET (REGISTER (? base register-known-value))
- (MACHINE-CONSTANT (? value)))
- (QUALIFIER (and (rtl:byte-offset-address? base)
- (rtl:simple-subexpressions? base)))
- (rtl:make-byte-offset base (rtl:make-machine-constant value)))
-
-(define-rule rewriting
- (FLOAT-OFFSET (REGISTER (? base register-known-value))
- (MACHINE-CONSTANT (? value)))
- (QUALIFIER (and (rtl:float-offset-address? base)
- (rtl:simple-subexpressions? base)))
- (if (zero? value)
- (rtl:make-float-offset
- (rtl:float-offset-address-base base)
- (rtl:float-offset-address-offset base))
- (rtl:make-float-offset base (rtl:make-machine-constant value))))
-
-(define-rule rewriting
- (FLOAT-OFFSET (REGISTER (? base register-known-value))
- (MACHINE-CONSTANT (? value)))
- (QUALIFIER
- (and (rtl:offset-address? base)
- (rtl:simple-subexpressions? base)
- (rtl:machine-constant? (rtl:offset-address-offset base))))
- (rtl:make-float-offset base (rtl:make-machine-constant value)))
-
-;; This is here to avoid generating things like
-;;
-;; (offset (offset-address (object->address (constant #(foo bar baz gack)))
-;; (register 29))
-;; (machine-constant 1))
-;;
-;; since the offset-address subexpression is constant, and therefore
-;; known!
-
-(define (rtl:simple-subexpressions? expr)
- (for-all? (cdr expr)
- (lambda (sub)
- (or (rtl:machine-constant? sub)
- (rtl:register? sub)))))
\ No newline at end of file
#| -*-Scheme-*-
-$MC68020-Header: coerce.scm,v 1.10 88/08/31 05:56:37 GMT cph Exp $
-
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
#| -*-Scheme-*-
-$MC68020-Header: /scheme/compiler/bobcat/RCS/rgspcm.scm,v 4.2 1991/05/06 23:17:03 jinx Exp $
-
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Assembler Machine Dependencies
-
-(declare (usual-integrations))
-\f
-(let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form))))))
-
-(define-integrable maximum-padding-length
- ;; Instruction length is always a multiple of 32 bits
- ;; Would 0 work here?
- 32)
-
-(define padding-string
- ;; Pad with `DIAG SCM' instructions
- (unsigned-integer->bit-string maximum-padding-length
- #b00010100010100110100001101001101))
-
-(define-integrable block-offset-width
- ;; Block offsets are always 16 bit words
- 16)
-
-(define-integrable maximum-block-offset
- ;; PC always aligned on longword boundary. Use the extra bit.
- (- (expt 2 (1+ block-offset-width)) 4))
-
-(define (block-offset->bit-string offset start?)
- (unsigned-integer->bit-string block-offset-width
- (+ (quotient offset 2)
- (if start? 0 1))))
-
-(define (make-nmv-header n)
- (bit-string-append (unsigned-integer->bit-string scheme-datum-width n)
- nmv-type-string))
-
-(define nmv-type-string
- (unsigned-integer->bit-string scheme-type-width
- (ucode-type manifest-nm-vector)))
-
-(define (object->bit-string object)
- (bit-string-append
- (unsigned-integer->bit-string scheme-datum-width
- (careful-object-datum object))
- (unsigned-integer->bit-string scheme-type-width (object-type object))))
-
-;;; Machine dependent instruction order
-
-(define (instruction-initial-position block)
- (if (eq? endianness 'LITTLE)
- 0
- (bit-string-length block)))
-
-(define (instruction-insert! bits block position receiver)
- (let ((l (bit-string-length bits)))
- (if (eq? endianness 'LITTLE)
- (begin
- (bit-substring-move-right! bits 0 l block position)
- (receiver (+ position l)))
- (let ((new-position (- position l)))
- (bit-substring-move-right! bits 0 l block new-position)
- (receiver new-position)))))
-
-(define (instruction-append x y)
- (if (eq? endianness 'LITTLE)
- (bit-string-append x y)
- (bit-string-append-reversed x y)))
-
-;;; end let-syntax
-)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$MC68020-Header: coerce.scm,v 1.10 88/08/31 05:56:37 GMT cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-(declare (usual-integrations))
-\f
-;;;; MIPS coercions
-
-;;; Coercion top level
-
-(define make-coercion
- (coercion-maker
- `((UNSIGNED . ,coerce-unsigned-integer)
- (SIGNED . ,coerce-signed-integer))))
-
-(define coerce-1-bit-unsigned (make-coercion 'UNSIGNED 1))
-(define coerce-4-bit-unsigned (make-coercion 'UNSIGNED 4))
-(define coerce-5-bit-unsigned (make-coercion 'UNSIGNED 5))
-(define coerce-6-bit-unsigned (make-coercion 'UNSIGNED 6))
-(define coerce-10-bit-unsigned (make-coercion 'UNSIGNED 10))
-(define coerce-11-bit-unsigned (make-coercion 'UNSIGNED 11))
-(define coerce-15-bit-unsigned (make-coercion 'UNSIGNED 15))
-(define coerce-16-bit-unsigned (make-coercion 'UNSIGNED 16))
-(define coerce-20-bit-unsigned (make-coercion 'UNSIGNED 20))
-(define coerce-25-bit-unsigned (make-coercion 'UNSIGNED 25))
-(define coerce-26-bit-unsigned (make-coercion 'UNSIGNED 26))
-(define coerce-32-bit-unsigned (make-coercion 'UNSIGNED 32))
-
-(define coerce-16-bit-signed (make-coercion 'SIGNED 16))
-(define coerce-26-bit-signed (make-coercion 'SIGNED 26))
-(define coerce-32-bit-signed (make-coercion 'SIGNED 32))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Script to incrementally compile the compiler (from .bins)
-
-(fluid-let ((compiler:coalescing-constant-warnings? #f))
- (for-each compile-directory
- '("back"
- "base"
- "fggen"
- "fgopt"
- "machines/mips"
- "rtlbase"
- "rtlgen"
- "rtlopt")))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Compiler Packaging
-\f
-(global-definitions "../runtime/runtime")
-(global-definitions "../sf/sf")
-
-(define-package (compiler)
- (files "base/switch"
- "base/object" ;tagged object support
- "base/enumer" ;enumerations
- "base/sets" ;set abstraction
- "base/mvalue" ;multiple-value support
- "base/scode" ;SCode abstraction
- "rtlbase/valclass" ;RTL: value classes
- "machines/mips/machin" ;machine dependent stuff
- "back/asutl" ;back-end odds and ends
- "base/utils" ;odds and ends
-
- "base/cfg1" ;control flow graph
- "base/cfg2"
- "base/cfg3"
-
- "base/ctypes" ;CFG datatypes
-
- "base/rvalue" ;Right hand values
- "base/lvalue" ;Left hand values
- "base/blocks" ;rvalue: blocks
- "base/proced" ;rvalue: procedures
- "base/contin" ;rvalue: continuations
-
- "base/subprb" ;subproblem datatype
-
- "rtlbase/rgraph" ;program graph abstraction
- "rtlbase/rtlty1" ;RTL: type definitions
- "rtlbase/rtlty2" ;RTL: type definitions
- "rtlbase/rtlexp" ;RTL: expression operations
- "rtlbase/rtlcon" ;RTL: complex constructors
- "rtlbase/rtlreg" ;RTL: registers
- "rtlbase/rtlcfg" ;RTL: CFG types
- "rtlbase/rtlobj" ;RTL: CFG objects
- "rtlbase/regset" ;RTL: register sets
-
- "back/insseq" ;LAP instruction sequences
- )
- (parent ())
- (export ()
- compiler:analyze-side-effects?
- compiler:cache-free-variables?
- compiler:coalescing-constant-warnings?
- compiler:code-compression?
- compiler:compile-by-procedures?
- compiler:cse?
- compiler:default-top-level-declarations
- compiler:enable-integration-declarations?
- compiler:generate-lap-files?
- compiler:generate-range-checks?
- compiler:generate-rtl-files?
- compiler:generate-stack-checks?
- compiler:generate-type-checks?
- compiler:implicit-self-static?
- compiler:intersperse-rtl-in-lap?
- compiler:noisy?
- compiler:open-code-flonum-checks?
- compiler:open-code-primitives?
- compiler:optimize-environments?
- compiler:package-optimization-level
- compiler:preserve-data-structures?
- compiler:show-phases?
- compiler:show-procedures?
- compiler:show-subphases?
- compiler:show-time-reports?
- compiler:use-multiclosures?)
- (import (runtime system-macros)
- ucode-primitive
- ucode-type)
- (import ()
- (scode/access-components access-components)
- (scode/access-environment access-environment)
- (scode/access-name access-name)
- (scode/access? access?)
- (scode/assignment-components assignment-components)
- (scode/assignment-name assignment-name)
- (scode/assignment-value assignment-value)
- (scode/assignment? assignment?)
- (scode/combination-components combination-components)
- (scode/combination-operands combination-operands)
- (scode/combination-operator combination-operator)
- (scode/combination? combination?)
- (scode/comment-components comment-components)
- (scode/comment-expression comment-expression)
- (scode/comment-text comment-text)
- (scode/comment? comment?)
- (scode/conditional-alternative conditional-alternative)
- (scode/conditional-components conditional-components)
- (scode/conditional-consequent conditional-consequent)
- (scode/conditional-predicate conditional-predicate)
- (scode/conditional? conditional?)
- (scode/constant? scode-constant?)
- (scode/declaration-components declaration-components)
- (scode/declaration-expression declaration-expression)
- (scode/declaration-text declaration-text)
- (scode/declaration? declaration?)
- (scode/definition-components definition-components)
- (scode/definition-name definition-name)
- (scode/definition-value definition-value)
- (scode/definition? definition?)
- (scode/delay-components delay-components)
- (scode/delay-expression delay-expression)
- (scode/delay? delay?)
- (scode/disjunction-alternative disjunction-alternative)
- (scode/disjunction-components disjunction-components)
- (scode/disjunction-predicate disjunction-predicate)
- (scode/disjunction? disjunction?)
- (scode/lambda-components lambda-components)
- (scode/lambda? lambda?)
- (scode/make-access make-access)
- (scode/make-assignment make-assignment)
- (scode/make-combination make-combination)
- (scode/make-comment make-comment)
- (scode/make-conditional make-conditional)
- (scode/make-declaration make-declaration)
- (scode/make-definition make-definition)
- (scode/make-delay make-delay)
- (scode/make-disjunction make-disjunction)
- (scode/make-lambda make-lambda)
- (scode/make-open-block make-open-block)
- (scode/make-quotation make-quotation)
- (scode/make-sequence make-sequence)
- (scode/make-the-environment make-the-environment)
- (scode/make-unassigned? make-unassigned?)
- (scode/make-variable make-variable)
- (scode/open-block-components open-block-components)
- (scode/open-block? open-block?)
- (scode/primitive-procedure? primitive-procedure?)
- (scode/procedure? procedure?)
- (scode/quotation-expression quotation-expression)
- (scode/quotation? quotation?)
- (scode/sequence-actions sequence-actions)
- (scode/sequence-components sequence-components)
- (scode/sequence-immediate-first sequence-immediate-first)
- (scode/sequence-immediate-second sequence-immediate-second)
- (scode/sequence-first sequence-first)
- (scode/sequence-second sequence-second)
- (scode/sequence? sequence?)
- (scode/symbol? symbol?)
- (scode/the-environment? the-environment?)
- (scode/unassigned?-name unassigned?-name)
- (scode/unassigned?? unassigned??)
- (scode/variable-components variable-components)
- (scode/variable-name variable-name)
- (scode/variable? variable?)))
-\f
-(define-package (compiler reference-contexts)
- (files "base/refctx")
- (parent (compiler))
- (export (compiler)
- add-reference-context/adjacent-parents!
- initialize-reference-contexts!
- make-reference-context
- modify-reference-contexts!
- reference-context/adjacent-parent?
- reference-context/block
- reference-context/offset
- reference-context/procedure
- reference-context?
- set-reference-context/offset!))
-
-(define-package (compiler macros)
- (files "base/macros")
- (parent ())
- (import (runtime macros)
- parse-define-syntax)
- (initialization (initialize-package!)))
-
-(define-package (compiler declarations)
- (files "machines/mips/decls")
- (parent (compiler))
- (export (compiler)
- sc
- syntax-files!)
- (import (scode-optimizer top-level)
- sf/internal)
- (initialization (initialize-package!)))
-
-(define-package (compiler top-level)
- (files "base/toplev"
- "base/crstop"
- "base/asstop")
- (parent (compiler))
- (export ()
- cbf
- cf
- compile-directory
- compile-bin-file
- compile-procedure
- compile-scode
- compiler:dump-bci-file
- compiler:dump-bci/bcs-files
- compiler:dump-bif/bsm-files
- compiler:dump-inf-file
- compiler:dump-info-file
- compiler:reset!
- cross-compile-bin-file
- cross-compile-bin-file-end)
- (export (compiler)
- canonicalize-label-name)
- (export (compiler fg-generator)
- compile-recursively)
- (export (compiler rtl-generator)
- *ic-procedure-headers*
- *rtl-continuations*
- *rtl-expression*
- *rtl-graphs*
- *rtl-procedures*)
- (export (compiler lap-syntaxer)
- *block-label*
- *external-labels*
- label->object)
- (export (compiler debug)
- *root-expression*
- *rtl-procedures*
- *rtl-graphs*)
- (import (runtime compiler-info)
- make-dbg-info-vector
- split-inf-structure!)
- (import (runtime unparser)
- param:unparse-uninterned-symbols-by-name?)
- (import (scode-optimizer build-utilities)
- directory-processor))
-\f
-(define-package (compiler debug)
- (files "base/debug")
- (parent (compiler))
- (export ()
- debug/find-continuation
- debug/find-entry-node
- debug/find-procedure
- debug/where
- dump-rtl
- po
- show-bblock-rtl
- show-fg
- show-fg-node
- show-rtl
- write-rtl-instructions)
- (import (runtime unparser)
- param:unparse-uninterned-symbols-by-name?))
-
-(define-package (compiler pattern-matcher/lookup)
- (files "base/pmlook")
- (parent (compiler))
- (export (compiler)
- make-pattern-variable
- pattern-lookup
- pattern-variable-name
- pattern-variable?
- pattern-variables))
-
-(define-package (compiler pattern-matcher/parser)
- (files "base/pmpars")
- (parent (compiler))
- (export (compiler)
- parse-rule
- rule-result-expression)
- (export (compiler macros)
- parse-rule
- rule-result-expression))
-
-(define-package (compiler pattern-matcher/early)
- (files "base/pmerly")
- (parent (compiler))
- (export (compiler)
- early-parse-rule
- early-pattern-lookup
- early-make-rule
- make-database-transformer
- make-symbol-transformer
- make-bit-mask-transformer))
-\f
-(define-package (compiler debugging-information)
- (files "base/infnew")
- (parent (compiler))
- (export (compiler top-level)
- info-generation-phase-1
- info-generation-phase-2
- info-generation-phase-3)
- (export (compiler rtl-generator)
- generated-dbg-continuation)
- (import (runtime compiler-info)
- make-dbg-info
-
- make-dbg-expression
- dbg-expression/block
- dbg-expression/label
- set-dbg-expression/label!
-
- make-dbg-procedure
- dbg-procedure/block
- dbg-procedure/label
- set-dbg-procedure/label!
- dbg-procedure/name
- dbg-procedure/required
- dbg-procedure/optional
- dbg-procedure/rest
- dbg-procedure/auxiliary
- dbg-procedure/external-label
- set-dbg-procedure/external-label!
- dbg-procedure<?
-
- make-dbg-continuation
- dbg-continuation/block
- dbg-continuation/label
- set-dbg-continuation/label!
- dbg-continuation<?
-
- make-dbg-block
- dbg-block/parent
- dbg-block/layout
- dbg-block/stack-link
- set-dbg-block/procedure!
-
- make-dbg-variable
- dbg-variable/value
- set-dbg-variable/value!
-
- dbg-block-name/dynamic-link
- dbg-block-name/ic-parent
- dbg-block-name/normal-closure
- dbg-block-name/return-address
- dbg-block-name/static-link
-
- make-dbg-label-2
- dbg-label/offset
- set-dbg-label/external?!))
-
-(define-package (compiler constraints)
- (files "base/constr")
- (parent (compiler))
- (export (compiler)
- make-constraint
- constraint/element
- constraint/graph-head
- constraint/afters
- constraint/closed?
- constraint-add!
- add-constraint-element!
- add-constraint-set!
- make-constraint-graph
- constraint-graph/entry-nodes
- constraint-graph/closed?
- close-constraint-graph!
- close-constraint-node!
- order-per-constraints
- order-per-constraints/extracted
- legal-ordering-per-constraints?
- with-new-constraint-marks
- constraint-marked?
- constraint-mark!
- transitively-close-dag!
- reverse-postorder))
-\f
-(define-package (compiler fg-generator)
- (files "fggen/canon" ;SCode canonicalizer
- "fggen/fggen" ;SCode->flow-graph converter
- "fggen/declar" ;Declaration handling
- )
- (parent (compiler))
- (export (compiler top-level)
- canonicalize/top-level
- construct-graph)
- (import (runtime scode-data)
- &pair-car
- &pair-cdr
- &triple-first
- &triple-second
- &triple-third))
-
-(define-package (compiler fg-optimizer)
- (files "fgopt/outer" ;outer analysis
- "fgopt/sideff" ;side effect analysis
- )
- (parent (compiler))
- (export (compiler top-level)
- clear-call-graph!
- compute-call-graph!
- outer-analysis
- side-effect-analysis))
-
-(define-package (compiler fg-optimizer fold-constants)
- (files "fgopt/folcon")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) fold-constants))
-
-(define-package (compiler fg-optimizer operator-analysis)
- (files "fgopt/operan")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) operator-analysis))
-
-(define-package (compiler fg-optimizer variable-indirection)
- (files "fgopt/varind")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) initialize-variable-indirections!))
-
-(define-package (compiler fg-optimizer environment-optimization)
- (files "fgopt/envopt")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) optimize-environments!))
-
-(define-package (compiler fg-optimizer closure-analysis)
- (files "fgopt/closan")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) identify-closure-limits!))
-
-(define-package (compiler fg-optimizer continuation-analysis)
- (files "fgopt/contan")
- (parent (compiler fg-optimizer))
- (export (compiler top-level)
- continuation-analysis
- setup-block-static-links!))
-
-(define-package (compiler fg-optimizer compute-node-offsets)
- (files "fgopt/offset")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) compute-node-offsets))
-\f
-(define-package (compiler fg-optimizer connectivity-analysis)
- (files "fgopt/conect")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) connectivity-analysis))
-
-(define-package (compiler fg-optimizer delete-integrated-parameters)
- (files "fgopt/delint")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) delete-integrated-parameters))
-
-(define-package (compiler fg-optimizer design-environment-frames)
- (files "fgopt/desenv")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) design-environment-frames!))
-
-(define-package (compiler fg-optimizer setup-block-types)
- (files "fgopt/blktyp")
- (parent (compiler fg-optimizer))
- (export (compiler top-level)
- setup-block-types!
- setup-closure-contexts!)
- (export (compiler)
- indirection-block-procedure))
-
-(define-package (compiler fg-optimizer simplicity-analysis)
- (files "fgopt/simple")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) simplicity-analysis)
- (export (compiler fg-optimizer subproblem-ordering)
- new-subproblem/compute-simplicity!))
-
-(define-package (compiler fg-optimizer simulate-application)
- (files "fgopt/simapp")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) simulate-application))
-
-(define-package (compiler fg-optimizer subproblem-free-variables)
- (files "fgopt/subfre")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) compute-subproblem-free-variables)
- (export (compiler fg-optimizer) map-union)
- (export (compiler fg-optimizer subproblem-ordering)
- new-subproblem/compute-free-variables!))
-
-(define-package (compiler fg-optimizer subproblem-ordering)
- (files "fgopt/order")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) subproblem-ordering))
-
-(define-package (compiler fg-optimizer subproblem-ordering reuse-frames)
- (files "fgopt/reord" "fgopt/reuse")
- (parent (compiler fg-optimizer subproblem-ordering))
- (export (compiler top-level) setup-frame-adjustments)
- (export (compiler fg-optimizer subproblem-ordering)
- order-subproblems/maybe-overwrite-block))
-
-(define-package (compiler fg-optimizer subproblem-ordering parameter-analysis)
- (files "fgopt/param")
- (parent (compiler fg-optimizer subproblem-ordering))
- (export (compiler fg-optimizer subproblem-ordering)
- parameter-analysis))
-
-(define-package (compiler fg-optimizer return-equivalencing)
- (files "fgopt/reteqv")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) find-equivalent-returns!))
-\f
-(define-package (compiler rtl-generator)
- (files "rtlgen/rtlgen" ;RTL generator
- "rtlgen/rgstmt" ;statements
- "rtlgen/fndvar" ;find variables
- "machines/mips/rgspcm" ;special close-coded primitives
- "rtlbase/rtline" ;linearizer
- )
- (parent (compiler))
- (export (compiler)
- make-linearizer)
- (export (compiler top-level)
- generate/top-level
- linearize-rtl
- setup-bblock-continuations!)
- (export (compiler debug)
- linearize-rtl)
- (import (compiler top-level)
- label->object))
-
-(define-package (compiler rtl-generator generate/procedure-header)
- (files "rtlgen/rgproc")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator) generate/procedure-header))
-
-(define-package (compiler rtl-generator combination/inline)
- (files "rtlgen/opncod")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator) combination/inline)
- (export (compiler top-level) open-coding-analysis))
-
-(define-package (compiler rtl-generator find-block)
- (files "rtlgen/fndblk")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator) find-block))
-
-(define-package (compiler rtl-generator generate/rvalue)
- (files "rtlgen/rgrval")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator)
- generate/rvalue
- load-closure-environment
- make-cons-closure-indirection
- make-cons-closure-redirection
- make-closure-redirection
- make-ic-cons
- make-non-trivial-closure-cons
- make-trivial-closure-cons
- redirect-closure))
-
-(define-package (compiler rtl-generator generate/combination)
- (files "rtlgen/rgcomb")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator)
- generate/combination
- rtl:bump-closure)
- (export (compiler rtl-generator combination/inline)
- generate/invocation-prefix))
-
-(define-package (compiler rtl-generator generate/return)
- (files "rtlgen/rgretn")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator)
- make-return-operand
- generate/return
- generate/return*
- generate/trivial-return))
-\f
-(define-package (compiler rtl-cse)
- (files "rtlopt/rcse1" ;RTL common subexpression eliminator
- "rtlopt/rcse2"
- "rtlopt/rcseep" ;CSE expression predicates
- "rtlopt/rcseht" ;CSE hash table
- "rtlopt/rcserq" ;CSE register/quantity abstractions
- "rtlopt/rcsesr" ;CSE stack references
- )
- (parent (compiler))
- (export (compiler top-level) common-subexpression-elimination))
-
-(define-package (compiler rtl-optimizer)
- (files "rtlopt/rdebug")
- (parent (compiler)))
-
-(define-package (compiler rtl-optimizer invertible-expression-elimination)
- (files "rtlopt/rinvex")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) invertible-expression-elimination))
-
-(define-package (compiler rtl-optimizer common-suffix-merging)
- (files "rtlopt/rtlcsm")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) merge-common-suffixes!))
-
-(define-package (compiler rtl-optimizer rtl-dataflow-analysis)
- (files "rtlopt/rdflow")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) rtl-dataflow-analysis))
-
-(define-package (compiler rtl-optimizer rtl-rewriting)
- (files "rtlopt/rerite")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level)
- rtl-rewriting:post-cse
- rtl-rewriting:pre-cse)
- (export (compiler lap-syntaxer) add-rewriting-rule!))
-
-(define-package (compiler rtl-optimizer lifetime-analysis)
- (files "rtlopt/rlife")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) lifetime-analysis)
- (export (compiler rtl-optimizer code-compression) mark-set-registers!))
-
-(define-package (compiler rtl-optimizer code-compression)
- (files "rtlopt/rcompr")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) code-compression))
-
-(define-package (compiler rtl-optimizer register-allocation)
- (files "rtlopt/ralloc")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) register-allocation))
-\f
-(define-package (compiler lap-syntaxer)
- (files "back/lapgn1" ;LAP generator
- "back/lapgn2" ; " "
- "back/lapgn3" ; " "
- "back/regmap" ;Hardware register allocator
- "machines/mips/lapgen" ;code generation rules
- "machines/mips/rules1" ; " " "
- "machines/mips/rules2" ; " " "
- "machines/mips/rules3" ; " " "
- "machines/mips/rules4" ; " " "
- "machines/mips/rulfix" ; " " "
- "machines/mips/rulflo" ; " " "
- "machines/mips/rulrew" ;code rewriting rules
- "back/syntax" ;Generic syntax phase
- "back/syerly" ;Early binding version
- "machines/mips/coerce" ;Coercions: integer -> bit string
- "back/asmmac" ;Macros for hairy syntax
- "machines/mips/insmac" ;Macros for hairy syntax
- "machines/mips/instr1" ;MIPS instruction set
- "machines/mips/instr2a"; branch tensioning: branches
- "machines/mips/instr2b"; branch tensioning: load/store
- "machines/mips/instr3" ; floating point
- )
- (parent (compiler))
- (export (compiler)
- available-machine-registers
- fits-in-16-bits-signed?
- fits-in-16-bits-unsigned?
- top-16-bits-only?
- lap-generator/match-rtl-instruction
- lap:make-entry-point
- lap:make-label-statement
- lap:make-unconditional-branch
- lap:syntax-instruction)
- (export (compiler top-level)
- *block-associations*
- *interned-assignments*
- *interned-constants*
- *interned-global-links*
- *interned-static-variables*
- *interned-uuo-links*
- *interned-variables*
- *next-constant*
- generate-lap)
- (import (scode-optimizer expansion)
- scode->scode-expander))
-
-(define-package (compiler lap-syntaxer map-merger)
- (files "back/mermap")
- (parent (compiler lap-syntaxer))
- (export (compiler lap-syntaxer)
- merge-register-maps))
-
-(define-package (compiler lap-syntaxer linearizer)
- (files "back/linear")
- (parent (compiler lap-syntaxer))
- (export (compiler lap-syntaxer)
- add-end-of-block-code!
- add-extra-code!
- bblock-linearize-lap
- extra-code-block/xtra
- declare-extra-code-block!
- find-extra-code-block
- linearize-lap
- set-current-branches!
- set-extra-code-block/xtra!)
- (export (compiler top-level)
- *end-of-block-code*
- linearize-lap))
-\f
-(define-package (compiler lap-optimizer)
- (files "machines/mips/lapopt")
- (parent (compiler))
- (export (compiler top-level)
- optimize-linear-lap))
-
-(define-package (compiler assembler)
- (files "machines/mips/assmd" ;Machine dependent
- "back/symtab" ;Symbol tables
- "back/bitutl" ;Assembly blocks
- "back/bittop" ;Assembler top level
- )
- (parent (compiler))
- (export (compiler)
- instruction-append)
- (export (compiler top-level)
- assemble))
-
-#|
-(define-package (compiler disassembler)
- (files "machines/mips/mips"
- "machines/mips/dassm1"
- "machines/mips/dassm2"
- "machines/mips/dassm3")
- (parent (compiler))
- (export ()
- compiler:write-lap-file
- compiler:disassemble)
- (import (runtime compiler-info)
- compiled-code-block/dbg-info
- dbg-info-vector/blocks-vector
- dbg-info-vector?
- dbg-info/labels
- dbg-label/external?
- dbg-label/name
- dbg-labels/find-offset))
-|#
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Script to incrementally syntax the compiler
-\f
-(load-option 'CREF)
-
-;; Guarantee that the compiler's package structure exists.
-(if (not (name->package '(COMPILER)))
- (let ((package-set (package-set-pathname "compiler")))
- (if (not (file-exists? package-set))
- (cref/generate-trivial-constructor "compiler"))
- (construct-packages-from-file (fasload package-set))))
-
-;; Guarantee that the necessary syntactic transforms and optimizers
-;; are loaded.
-(if (lexical-unreferenceable? (->environment '(COMPILER)) 'SYNTAX-FILES!)
- (let ((sf-and-load
- (lambda (files package)
- (sf-conditionally files)
- (for-each (lambda (file)
- (load (string-append file ".bin") package))
- files))))
- (load-option 'HASH-TABLE)
- (fresh-line)
- (newline)
- (write-string "---- Loading compile-time files ----")
- (newline)
- (sf-and-load '("base/switch") '(COMPILER))
- (sf-and-load '("base/macros") '(COMPILER MACROS))
- ((access initialize-package! (->environment '(COMPILER MACROS))))
- (sf-and-load '("machines/mips/decls") '(COMPILER DECLARATIONS))
- (let ((environment (->environment '(COMPILER DECLARATIONS))))
- (set! (access source-file-expression environment) "*.scm")
- ((access initialize-package! environment)))
- (sf-and-load '("base/pmlook") '(COMPILER PATTERN-MATCHER/LOOKUP))
- (sf-and-load '("base/pmpars") '(COMPILER PATTERN-MATCHER/PARSER))
- (sf-and-load '("rtlbase/valclass") '(COMPILER))
- (fluid-let ((sf/default-syntax-table (->environment '(COMPILER))))
- (sf-and-load '("machines/mips/machin") '(COMPILER)))
- (set! (access endianness (->environment '(COMPILER))) 'BIG)
- (fluid-let ((sf/default-declarations
- '((integrate-external "insseq")
- (integrate-external "machin")
- (usual-definition (set expt)))))
- (sf-and-load '("machines/mips/assmd") '(COMPILER ASSEMBLER)))
- (sf-and-load '("back/syntax") '(COMPILER LAP-SYNTAXER))
- (sf-and-load '("machines/mips/coerce"
- "back/asmmac"
- "machines/mips/insmac")
- '(COMPILER LAP-SYNTAXER))
- (sf-and-load '("base/scode") '(COMPILER))
- (sf-and-load '("base/pmerly") '(COMPILER PATTERN-MATCHER/EARLY))
- (sf-and-load '("back/syerly") '(COMPILER LAP-SYNTAXER))))
-
-;; Resyntax any files that need it.
-((access syntax-files! (->environment '(COMPILER))))
-
-;; Rebuild the package constructors and cref.
-(cref/generate-constructors "compiler")
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Script to incrementally syntax the compiler
-\f
-(load-option 'CREF)
-
-;; Guarantee that the compiler's package structure exists.
-(if (not (name->package '(COMPILER)))
- (let ((package-set (package-set-pathname "compiler")))
- (if (not (file-exists? package-set))
- (cref/generate-trivial-constructor "compiler"))
- (construct-packages-from-file (fasload package-set))))
-
-;; Guarantee that the necessary syntactic transforms and optimizers
-;; are loaded.
-(if (lexical-unreferenceable? (->environment '(COMPILER)) 'SYNTAX-FILES!)
- (let ((sf-and-load
- (lambda (files package)
- (sf-conditionally files)
- (for-each (lambda (file)
- (load (string-append file ".bin") package))
- files))))
- (load-option 'HASH-TABLE)
- (fresh-line)
- (newline)
- (write-string "---- Loading compile-time files ----")
- (newline)
- (sf-and-load '("base/switch") '(COMPILER))
- (sf-and-load '("base/macros") '(COMPILER MACROS))
- ((access initialize-package! (->environment '(COMPILER MACROS))))
- (sf-and-load '("machines/mips/decls") '(COMPILER DECLARATIONS))
- (let ((environment (->environment '(COMPILER DECLARATIONS))))
- (set! (access source-file-expression environment) "*.scm")
- ((access initialize-package! environment)))
- (sf-and-load '("base/pmlook") '(COMPILER PATTERN-MATCHER/LOOKUP))
- (sf-and-load '("base/pmpars") '(COMPILER PATTERN-MATCHER/PARSER))
- (sf-and-load '("rtlbase/valclass") '(COMPILER))
- (fluid-let ((sf/default-syntax-table (->environment '(COMPILER))))
- (sf-and-load '("machines/mips/machin") '(COMPILER)))
- (set! (access endianness (->environment '(COMPILER))) 'LITTLE)
- (fluid-let ((sf/default-declarations
- '((integrate-external "insseq")
- (integrate-external "machin")
- (usual-definition (set expt)))))
- (sf-and-load '("machines/mips/assmd") '(COMPILER ASSEMBLER)))
- (sf-and-load '("back/syntax") '(COMPILER LAP-SYNTAXER))
- (sf-and-load '("machines/mips/coerce"
- "back/asmmac"
- "machines/mips/insmac")
- '(COMPILER LAP-SYNTAXER))
- (sf-and-load '("base/scode") '(COMPILER))
- (sf-and-load '("base/pmerly") '(COMPILER PATTERN-MATCHER/EARLY))
- (sf-and-load '("back/syerly") '(COMPILER LAP-SYNTAXER))))
-
-;; Resyntax any files that need it.
-((access syntax-files! (->environment '(COMPILER))))
-
-;; Rebuild the package constructors and cref.
-(cref/generate-constructors "compiler")
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Disassembler: User Level
-;;; package: (compiler disassembler)
-
-(declare (usual-integrations))
-\f
-;;; Flags that control disassembler behavior
-
-(define disassembler/symbolize-output? true)
-(define disassembler/compiled-code-heuristics? true)
-(define disassembler/write-offsets? true)
-(define disassembler/write-addresses? false)
-
-;;;; Top level entries
-
-(define (compiler:write-lap-file filename #!optional symbol-table?)
- (let ((pathname (->pathname filename))
- (symbol-table?
- (if (default-object? symbol-table?) true symbol-table?)))
- (with-output-to-file (pathname-new-type pathname "lap")
- (lambda ()
- (let ((com-file (pathname-new-type pathname "com")))
- (let ((object (fasload com-file)))
- (if (compiled-code-address? object)
- (let ((block (compiled-code-address->block object)))
- (disassembler/write-compiled-code-block
- block
- (compiled-code-block/dbg-info block symbol-table?)))
- (begin
- (if (not
- (and (scode/comment? object)
- (dbg-info-vector? (scode/comment-text object))))
- (error "Not a compiled file" com-file))
- (let ((blocks
- (vector->list
- (dbg-info-vector/blocks-vector
- (scode/comment-text object)))))
- (if (not (null? blocks))
- (do ((blocks blocks (cdr blocks)))
- ((null? blocks) unspecific)
- (disassembler/write-compiled-code-block
- (car blocks)
- (compiled-code-block/dbg-info (car blocks)
- symbol-table?))
- (if (not (null? (cdr blocks)))
- (begin
- (write-char #\page)
- (newline))))))))))))))
-
-(define disassembler/base-address)
-
-(define (compiler:disassemble entry)
- (let ((block (compiled-entry/block entry)))
- (let ((info (compiled-code-block/dbg-info block true)))
- (fluid-let ((disassembler/write-offsets? true)
- (disassembler/write-addresses? true)
- (disassembler/base-address (object-datum block)))
- (newline)
- (newline)
- (disassembler/write-compiled-code-block block info)))))
-\f
-(define (disassembler/write-compiled-code-block block info)
- (let ((symbol-table (and info (dbg-info/labels info))))
- (write-string "Disassembly of ")
- (write block)
- (call-with-values
- (lambda () (compiled-code-block/filename-and-index block))
- (lambda (filename index)
- (if filename
- (begin
- (write-string " (Block ")
- (write index)
- (write-string " in ")
- (write-string filename)
- (write-string ")")))))
- (write-string ":\n")
- (write-string "Code:\n\n")
- (disassembler/write-instruction-stream
- symbol-table
- (disassembler/instructions/compiled-code-block block symbol-table))
- (write-string "\nConstants:\n\n")
- (disassembler/write-constants-block block symbol-table)
- (newline)))
-
-(define (disassembler/instructions/compiled-code-block block symbol-table)
- (disassembler/instructions block
- (compiled-code-block/code-start block)
- (compiled-code-block/code-end block)
- symbol-table))
-
-(define (disassembler/instructions/address start-address end-address)
- (disassembler/instructions false start-address end-address false))
-
-(define (disassembler/write-instruction-stream symbol-table instruction-stream)
- (parameterize* (list (cons param:unparser-radix 16))
- (lambda ()
- (disassembler/for-each-instruction instruction-stream
- (lambda (offset instruction)
- (disassembler/write-instruction symbol-table
- offset
- (lambda () (display instruction))))))))
-
-(define (disassembler/for-each-instruction instruction-stream procedure)
- (let loop ((instruction-stream instruction-stream))
- (if (not (disassembler/instructions/null? instruction-stream))
- (disassembler/instructions/read instruction-stream
- (lambda (offset instruction instruction-stream)
- (procedure offset instruction)
- (loop (instruction-stream)))))))
-\f
-(define (disassembler/write-constants-block block symbol-table)
- (parameterize* (list (cons param:unparser-radix 16))
- (lambda ()
- (let ((end (system-vector-length block)))
- (let loop ((index (compiled-code-block/constants-start block)))
- (cond ((not (< index end)) 'DONE)
- ((object-type?
- (let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form))))))
- (ucode-type linkage-section))
- (system-vector-ref block index))
- (loop (disassembler/write-linkage-section block
- symbol-table
- index)))
- (else
- (disassembler/write-instruction
- symbol-table
- (compiled-code-block/index->offset index)
- (lambda ()
- (write-constant block
- symbol-table
- (system-vector-ref block index))))
- (loop (1+ index)))))))))
-
-(define (write-constant block symbol-table constant)
- (write-string (cdr (write-to-string constant 60)))
- (cond ((lambda? constant)
- (let ((expression (lambda-body constant)))
- (if (and (compiled-code-address? expression)
- (eq? (compiled-code-address->block expression) block))
- (begin
- (write-string " (")
- (let ((offset (compiled-code-address->offset expression)))
- (let ((label
- (disassembler/lookup-symbol symbol-table offset)))
- (if label
- (write-string label)
- (write offset))))
- (write-string ")")))))
- ((compiled-code-address? constant)
- (write-string " (offset ")
- (write (compiled-code-address->offset constant))
- (write-string " in ")
- (write (compiled-code-address->block constant))
- (write-string ")"))
- (else false)))
-\f
-(define (disassembler/write-linkage-section block symbol-table index)
- (let* ((field (object-datum (system-vector-ref block index)))
- (descriptor (integer-divide field #x10000)))
- (let ((kind (integer-divide-quotient descriptor))
- (length (integer-divide-remainder descriptor)))
-
- (define (write-caches offset size writer)
- (let loop ((index (1+ (+ offset index)))
- (how-many (quotient (- length offset) size)))
- (if (zero? how-many)
- 'DONE
- (begin
- (disassembler/write-instruction
- symbol-table
- (compiled-code-block/index->offset index)
- (lambda ()
- (writer block index)))
- (loop (+ size index) (-1+ how-many))))))
-
- (disassembler/write-instruction
- symbol-table
- (compiled-code-block/index->offset index)
- (lambda ()
- (write-string "#[LINKAGE-SECTION ")
- (write field)
- (write-string "]")))
- (case kind
- ((0 3)
- (write-caches
- compiled-code-block/procedure-cache-offset
- compiled-code-block/objects-per-procedure-cache
- disassembler/write-procedure-cache))
- ((1)
- (write-caches
- 0
- compiled-code-block/objects-per-variable-cache
- (lambda (block index)
- (disassembler/write-variable-cache "Reference" block index))))
- ((2)
- (write-caches
- 0
- compiled-code-block/objects-per-variable-cache
- (lambda (block index)
- (disassembler/write-variable-cache "Assignment" block index))))
- (else
- (error "disassembler/write-linkage-section: Unknown section kind"
- kind)))
- (1+ (+ index length)))))
-\f
-(define-integrable (variable-cache-name cache)
- ((ucode-primitive primitive-object-ref 2) cache 1))
-
-(define (disassembler/write-variable-cache kind block index)
- (write-string kind)
- (write-string " cache to ")
- (write (variable-cache-name (disassembler/read-variable-cache block index))))
-
-(define (disassembler/write-procedure-cache block index)
- (let ((result (disassembler/read-procedure-cache block index)))
- (write (vector-ref result 2))
- (write-string " argument procedure cache to ")
- (case (vector-ref result 0)
- ((COMPILED INTERPRETED)
- (write (vector-ref result 1)))
- ((VARIABLE)
- (write-string "variable ")
- (write (vector-ref result 1)))
- (else
- (error "disassembler/write-procedure-cache: Unknown cache kind"
- (vector-ref result 0))))))
-
-(define (disassembler/write-instruction symbol-table offset write-instruction)
- (if symbol-table
- (let ((label (dbg-labels/find-offset symbol-table offset)))
- (if label
- (begin
- (write-char #\Tab)
- (write-string (dbg-label/name label))
- (write-char #\:)
- (newline)))))
-
- (if disassembler/write-addresses?
- (begin
- (write-string
- (number->string (+ offset disassembler/base-address) 16))
- (write-char #\Tab)))
-
- (if disassembler/write-offsets?
- (begin
- (write-string (number->string offset 16))
- (write-char #\Tab)))
-
- (if symbol-table
- (write-string " "))
- (write-instruction)
- (newline))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; MIPS Disassembler: Top Level
-;;; package: (compiler disassembler)
-
-(declare (usual-integrations))
-\f
-(define (disassembler/read-variable-cache block index)
- (let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form)))))
- (ucode-primitive
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply make-primitive-procedure (cdr form))))))
- ((ucode-primitive primitive-object-set-type 2)
- (ucode-type quad)
- (system-vector-ref block index))))
-
-(define (disassembler/read-procedure-cache block index)
- (fluid-let ((*block block))
- (let* ((offset (compiled-code-block/index->offset index)))
- (let ((JAL (read-bits offset 32))
- (ADDI (read-bits (+ offset 4) 32)))
- (let ((opcode
- (bit-string->unsigned-integer (bit-substring JAL 26 32))))
- (case opcode
- ((#x3) ; JAL
- ;; This should learn how to decode trampolines.
- (vector 'COMPILED
- (read-procedure offset)
- (bit-string->unsigned-integer
- (bit-substring ADDI 0 16))))
- (else
- (error "disassembler/read-procedure-cache: Unknown opcode"
- opcode block index))))))))
-
-(define (disassembler/instructions block start-offset end-offset symbol-table)
- (let loop ((offset start-offset) (state (disassembler/initial-state)))
- (if (and end-offset (< offset end-offset))
- (disassemble-one-instruction
- block offset symbol-table state
- (lambda (offset* instruction state)
- (make-instruction offset
- instruction
- (lambda () (loop offset* state)))))
- '())))
-
-(define (disassembler/instructions/null? obj)
- (null? obj))
-
-(define (disassembler/instructions/read instruction-stream receiver)
- (receiver (instruction-offset instruction-stream)
- (instruction-instruction instruction-stream)
- (instruction-next instruction-stream)))
-
-(define-structure (instruction (type vector))
- (offset false read-only true)
- (instruction false read-only true)
- (next false read-only true))
-
-(define *block)
-(define *current-offset)
-(define *symbol-table)
-(define *ir)
-(define *valid?)
-
-(define (disassemble-one-instruction block offset symbol-table state receiver)
- (fluid-let ((*block block)
- (*current-offset offset)
- (*symbol-table symbol-table)
- (*ir)
- (*valid? true))
- (set! *ir (get-longword))
- (let ((start-offset *current-offset))
- (if (external-label-marker? symbol-table offset state)
- (receiver *current-offset
- (make-external-label *ir)
- 'INSTRUCTION)
- (let ((instruction (disassemble-word *ir)))
- (if (not *valid?)
- (let ((inst (make-word *ir)))
- (receiver start-offset
- inst
- (disassembler/next-state inst state)))
- (let ((next-state (disassembler/next-state instruction state)))
- (receiver
- *current-offset
- (cond ((and (pair? state)
- (eq? (car state) 'PC-REL-LOW-OFFSET))
- (pc-relative-inst offset instruction (cadr state)))
- ((and (eq? 'PC-REL-OFFSET state)
- (not (pair? next-state)))
- (pc-relative-inst offset instruction false))
- (else
- instruction))
- next-state))))))))
-\f
-(define (pc-relative-inst start-address instruction left-side)
- (let ((opcode (car instruction)))
- (if (not (memq opcode '(LDO LDW)))
- instruction
- (let ((offset-exp (caddr instruction))
- (target (cadddr instruction)))
- (let ((offset (cadr offset-exp))
- (space-reg (caddr offset-exp))
- (base-reg (cadddr offset-exp)))
- (let* ((real-address
- (+ start-address
- offset
- (if (not left-side)
- 0
- (- (let ((val (* left-side #x800)))
- (if (>= val #x80000000)
- (- val #x100000000)
- val))
- 4))))
- (label
- (disassembler/lookup-symbol *symbol-table real-address)))
- (if (not label)
- instruction
- `(,opcode () (OFFSET ,(if left-side
- `(RIGHT (- ,label (- *PC* 4)))
- `(- ,label *PC*))
- ,space-reg
- ,base-reg)
- ,target))))))))
-
-(define (disassembler/initial-state)
- 'INSTRUCTION-NEXT)
-
-(define (disassembler/next-state instruction state)
- instruction state
- 'INSTRUCTION)
-\f
-(define (disassembler/lookup-symbol symbol-table offset)
- (and symbol-table
- (let ((label (dbg-labels/find-offset symbol-table offset)))
- (and label
- (dbg-label/name label)))))
-
-(define (external-label-marker? symbol-table offset state)
- (if symbol-table
- (let ((label (dbg-labels/find-offset symbol-table (+ offset 4))))
- (and label
- (dbg-label/external? label)))
- (and *block
- (not (eq? state 'INSTRUCTION))
- (let loop ((offset (+ offset 4)))
- (let ((contents (read-bits (- offset 2) 16)))
- (if (bit-string-clear! contents 0)
- (let ((offset
- (- offset
- (* 2 (bit-string->unsigned-integer contents)))))
- (and (positive? offset)
- (loop offset)))
- (= offset
- (* 2 (bit-string->unsigned-integer contents)))))))))
-
-(define (make-word bit-string)
- `(UWORD ,(bit-string->unsigned-integer bit-string)))
-
-(define (make-external-label bit-string)
- (let ((do-it
- (lambda (format-word offset)
- `(EXTERNAL-LABEL (FORMAT ,format-word)
- ,(offset->@pcr (* 2 offset))))))
- (if (eq? endianness 'LITTLE)
- (do-it (extract bit-string 0 16)
- (extract bit-string 16 32))
- (do-it (extract bit-string 16 32)
- (extract bit-string 0 16)))))
-
-(define (read-procedure offset)
- (with-absolutely-no-interrupts
- (lambda ()
- (let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form)))))
- (ucode-primitive
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply make-primitive-procedure (cdr form))))))
- ((ucode-primitive primitive-object-set-type 2)
- (ucode-type compiled-entry)
- ((ucode-primitive make-non-pointer-object 1)
- (bit-string->unsigned-integer
- (bit-substring (read-bits offset 32) 0 26))))))))
-
-(define (read-unsigned-integer offset size)
- (bit-string->unsigned-integer (read-bits offset size)))
-
-(define (read-bits offset size-in-bits)
- (let ((word (bit-string-allocate size-in-bits))
- (bit-offset (* offset addressing-granularity)))
- (with-absolutely-no-interrupts
- (lambda ()
- (if *block
- (read-bits! *block bit-offset word)
- (read-bits! offset 0 word))))
- word))
-
-(define (invalid-instruction)
- (set! *valid? false)
- false)
-
-(define compiled-code-block/procedure-cache-offset 0)
-(define compiled-code-block/objects-per-procedure-cache 2)
-(define compiled-code-block/objects-per-variable-cache 1)
-
-;; global variable used by runtime/udata.scm -- Moby yuck!
-
-(set! compiled-code-block/bytes-per-object 4)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;; MIPS Disassembler: Internals
-
-(declare (usual-integrations))
-\f
-;;;; Utilities
-
-(define (get-longword)
- (let ((word (read-bits *current-offset 32)))
- (set! *current-offset (+ *current-offset 4))
- word))
-
-(declare (integrate-operator extract))
-(declare (integrate-operator extract-signed))
-
-(define (extract bit-string start end)
- (declare (integrate bit-string start end))
- (bit-string->unsigned-integer (bit-substring bit-string start end)))
-
-(define (extract-signed bit-string start end)
- (declare (integrate bit-string start end))
- (bit-string->signed-integer (bit-substring bit-string start end)))
-
-;; Debugging assistance
-
-(define (verify-instruction instruction)
- (let ((bits (car (lap:syntax-instruction instruction))))
- (if (bit-string? bits)
- (begin
- (let ((disassembly (disassemble bits)))
- (if (and (null? (cdr disassembly))
- (equal? (car disassembly) instruction))
- #T
- disassembly)))
- (error "Assember oddity" bits))))
-
-(define (v i) (verify-instruction i))
-\f
-;;;; The disassembler proper
-
-(define (handle-bad-instruction word)
- word
- (invalid-instruction))
-
-(define (disassemble bit-string)
- (let ((stop (bit-string-length bit-string)))
- (let loop ((from 0)
- (to 32)
- (result '()))
- (if (> to stop)
- result
- (loop to (+ to 32) (cons (disassemble-word (bit-substring bit-string from to))
- result))))))
-
-(define disassemblers (make-vector (expt 2 6) handle-bad-instruction))
-
-(define (disassemble-word word)
- (let ((op-code (extract word 26 32)))
- ((vector-ref disassemblers op-code) word)))
-
-(vector-set! disassemblers special-op
- (lambda (word) (disassemble-special word)))
-(vector-set! disassemblers bcond-op
- (lambda (word) (disassemble-branch-zero word)))
-(vector-set! disassemblers j-op
- (lambda (word) (disassemble-jump word 'j)))
-(vector-set! disassemblers jal-op
- (lambda (word) (disassemble-jump word 'jal)))
-(vector-set! disassemblers beq-op
- (lambda (word) (disassemble-compare word 'beq)))
-(vector-set! disassemblers bne-op
- (lambda (word) (disassemble-compare word 'bne)))
-(vector-set! disassemblers blez-op
- (lambda (word) (disassemble-branch-zero-op word 'blez)))
-(vector-set! disassemblers bgtz-op
- (lambda (word) (disassemble-branch-zero-op word 'bgtz)))
-(vector-set! disassemblers addi-op
- (lambda (word) (disassemble-immediate word 'addi)))
-(vector-set! disassemblers addiu-op
- (lambda (word) (disassemble-immediate word 'addiu)))
-(vector-set! disassemblers slti-op
- (lambda (word) (disassemble-immediate word 'slti)))
-(vector-set! disassemblers sltiu-op
- (lambda (word) (disassemble-immediate word 'sltiu)))
-(vector-set! disassemblers andi-op
- (lambda (word) (disassemble-unsigned-immediate word 'andi)))
-(vector-set! disassemblers ori-op
- (lambda (word) (disassemble-unsigned-immediate word 'ori)))
-(vector-set! disassemblers xori-op
- (lambda (word) (disassemble-unsigned-immediate word 'xori)))
-(vector-set! disassemblers lui-op
- (lambda (word) (disassemble-lui word)))
-(vector-set! disassemblers cop0-op
- (lambda (word) (disassemble-coprocessor word 0)))
-(vector-set! disassemblers cop1-op
- (lambda (word) (disassemble-coprocessor word 1)))
-(vector-set! disassemblers cop2-op
- (lambda (word) (disassemble-coprocessor word 2)))
-(vector-set! disassemblers cop3-op
- (lambda (word) (disassemble-coprocessor word 3)))
-(vector-set! disassemblers lb-op
- (lambda (word) (disassemble-load/store word 'lb)))
-(vector-set! disassemblers lh-op
- (lambda (word) (disassemble-load/store word 'lh)))
-(vector-set! disassemblers lwl-op
- (lambda (word) (disassemble-load/store word 'lwl)))
-(vector-set! disassemblers lw-op
- (lambda (word) (disassemble-load/store word 'lw)))
-(vector-set! disassemblers lbu-op
- (lambda (word) (disassemble-load/store word 'lbu)))
-(vector-set! disassemblers lhu-op
- (lambda (word) (disassemble-load/store word 'lhu)))
-(vector-set! disassemblers lwr-op
- (lambda (word) (disassemble-load/store word 'lwr)))
-(vector-set! disassemblers sb-op
- (lambda (word) (disassemble-load/store word 'sb)))
-(vector-set! disassemblers sh-op
- (lambda (word) (disassemble-load/store word 'sh)))
-(vector-set! disassemblers swl-op
- (lambda (word) (disassemble-load/store word 'swl)))
-(vector-set! disassemblers sw-op
- (lambda (word) (disassemble-load/store word 'sw)))
-(vector-set! disassemblers swr-op
- (lambda (word) (disassemble-load/store word 'swr)))
-(vector-set! disassemblers lwc0-op
- (lambda (word) (disassemble-load/store word 'lwc0)))
-(vector-set! disassemblers lwc1-op
- (lambda (word) (disassemble-load/store word 'lwc1)))
-(vector-set! disassemblers lwc2-op
- (lambda (word) (disassemble-load/store word 'lwc2)))
-(vector-set! disassemblers lwc3-op
- (lambda (word) (disassemble-load/store word 'lwc3)))
-(vector-set! disassemblers swc0-op
- (lambda (word) (disassemble-load/store word 'swc0)))
-(vector-set! disassemblers swc1-op
- (lambda (word) (disassemble-load/store word 'swc1)))
-(vector-set! disassemblers swc2-op
- (lambda (word) (disassemble-load/store word 'swc2)))
-(vector-set! disassemblers swc3-op
- (lambda (word) (disassemble-load/store word 'swc3)))
-
-(define special-disassemblers (make-vector (expt 2 6) handle-bad-instruction))
-
-(define (disassemble-special word)
- (let ((function-code (extract word 0 6)))
- ((vector-ref special-disassemblers function-code) word)))
-
-(vector-set! special-disassemblers sll-funct (lambda (word) (shift word 'sll)))
-(vector-set! special-disassemblers srl-funct (lambda (word) (shift word 'srl)))
-(vector-set! special-disassemblers sra-funct (lambda (word) (shift word 'sra)))
-(vector-set! special-disassemblers sllv-funct (lambda (word) (shift-variable word 'sllv)))
-(vector-set! special-disassemblers srlv-funct (lambda (word) (shift-variable word 'srlv)))
-(vector-set! special-disassemblers srav-funct (lambda (word) (shift-variable word 'srav)))
-(vector-set! special-disassemblers jr-funct
- (lambda (word)
- (let ((MBZ (extract word 6 21))
- (rs (extract word 21 26)))
- (if (zero? MBZ)
- `(jr ,rs)
- (invalid-instruction)))))
-(vector-set! special-disassemblers jalr-funct
- (lambda (word)
- (let ((MBZ1 (extract word 16 21))
- (MBZ2 (extract word 6 11))
- (rs (extract word 21 26))
- (rd (extract word 11 16)))
- (if (and (zero? MBZ1) (zero? MBZ2))
- `(JALR ,rd ,rs)
- (invalid-instruction)))))
-(vector-set! special-disassemblers syscall-funct
- (lambda (word)
- (let ((MBZ (extract word 6 26)))
- (if (zero? MBZ)
- '(SYSCALL)
- (invalid-instruction)))))
-(vector-set! special-disassemblers break-funct (lambda (word) `(BREAK ,(extract word 6 26))))
-(vector-set! special-disassemblers mfhi-funct (lambda (word) (from-hi/lo word 'mfhi)))
-(vector-set! special-disassemblers mthi-funct (lambda (word) (to-hi/lo word 'mthi)))
-(vector-set! special-disassemblers mflo-funct (lambda (word) (from-hi/lo word 'mflo)))
-(vector-set! special-disassemblers mtlo-funct (lambda (word) (to-hi/lo word 'mtlo)))
-(vector-set! special-disassemblers mult-funct (lambda (word) (mul/div word 'mult)))
-(vector-set! special-disassemblers multu-funct (lambda (word) (mul/div word 'multu)))
-(vector-set! special-disassemblers div-funct (lambda (word) (mul/div word 'div)))
-(vector-set! special-disassemblers divu-funct (lambda (word) (mul/div word 'divu)))
-(vector-set! special-disassemblers add-funct (lambda (word) (arith word 'add)))
-(vector-set! special-disassemblers addu-funct (lambda (word) (arith word 'addu)))
-(vector-set! special-disassemblers sub-funct (lambda (word) (arith word 'sub)))
-(vector-set! special-disassemblers subu-funct (lambda (word) (arith word 'subu)))
-(vector-set! special-disassemblers and-funct (lambda (word) (arith word 'and)))
-(vector-set! special-disassemblers or-funct (lambda (word) (arith word 'or)))
-(vector-set! special-disassemblers xor-funct (lambda (word) (arith word 'xor)))
-(vector-set! special-disassemblers nor-funct (lambda (word) (arith word 'nor)))
-(vector-set! special-disassemblers slt-funct (lambda (word) (arith word 'slt)))
-(vector-set! special-disassemblers sltu-funct (lambda (word) (arith word 'sltu)))
-
-(define (shift word op)
- (let ((MBZ (extract word 21 26))
- (rt (extract word 16 21))
- (rd (extract word 11 16))
- (shamt (extract word 6 11)))
- (if (zero? MBZ)
- `(,op ,rd ,rt ,shamt)
- (invalid-instruction))))
-
-(define (shift-variable word op)
- (let ((MBZ (extract word 6 11))
- (rs (extract word 21 26))
- (rt (extract word 16 21))
- (rd (extract word 11 16)))
- (if (zero? MBZ)
- `(,op ,rd ,rt ,rs)
- (invalid-instruction))))
-
-(define (from-hi/lo word op)
- (let ((MBZ1 (extract word 16 26))
- (MBZ2 (extract word 6 11))
- (rd (extract word 11 16)))
- (if (and (zero? MBZ1) (zero? MBZ2))
- `(,op ,rd)
- (invalid-instruction))))
-
-(define (to-hi/lo word op)
- (let ((MBZ (extract word 6 21))
- (rs (extract word 21 26)))
- (if (zero? MBZ)
- `(,op ,rs)
- (invalid-instruction))))
-
-(define (mul/div word op)
- (let ((MBZ (extract word 6 16))
- (rs (extract word 21 26))
- (rt (extract word 16 21)))
- (if (zero? MBZ)
- `(,op ,rs ,rt)
- (invalid-instruction))))
-
-(define (arith word op)
- (let ((MBZ (extract word 6 11))
- (rs (extract word 21 26))
- (rt (extract word 16 21))
- (rd (extract word 11 16)))
- (if (zero? MBZ)
- `(,op ,rd ,rs ,rt)
- (invalid-instruction))))
-
-(define (disassemble-jump word op)
- `(,op ,(extract word 0 26)))
-
-(define (relative-offset word)
- (offset->@pcr (+ *current-offset (* 4 (extract-signed word 0 16)))))
-
-(define (offset->@pcr offset)
- `(@PCR ,(or (and disassembler/symbolize-output?
- (disassembler/lookup-symbol *symbol-table offset))
- offset)))
-
-(define (disassemble-branch-zero word)
- (let ((conditions (extract word 16 21))
- (rs (extract word 21 26))
- (offset (relative-offset word)))
- (cond ((= conditions bltz-cond) `(BLTZ ,rs ,offset))
- ((= conditions bltzal-cond) `(BLTZAL ,rs ,offset))
- ((= conditions bgez-cond) `(BGEZ ,rs ,offset))
- ((= conditions bgezal-cond) `(BGEZAL ,rs ,offset))
- (else (invalid-instruction)))))
-
-(define (disassemble-branch-zero-op word op)
- (let ((MBZ (extract word 16 21))
- (rs (extract word 21 26)))
- (if (zero? MBZ)
- `(,op ,rs ,(relative-offset word))
- (invalid-instruction))))
-
-(define (disassemble-compare word op)
- `(,op ,(extract word 21 26)
- ,(extract word 16 21)
- ,(relative-offset word)))
-
-(define (disassemble-immediate word op)
- `(,op ,(extract word 16 21)
- ,(extract word 21 26)
- ,(extract-signed word 0 16)))
-
-(define (disassemble-unsigned-immediate word op)
- `(,op ,(extract word 16 21)
- ,(extract word 21 26)
- ,(extract word 0 16)))
-
-(define (disassemble-lui word)
- (if (zero? (extract word 21 26))
- `(LUI ,(extract word 16 21)
- ,(extract word 0 16))
- (invalid-instruction)))
-
-(define (floating-point-cases code)
- (let ((format (extract code 21 25))
- (ft (extract code 16 21))
- (fs (extract code 11 16))
- (fd (extract code 6 11))
- (fp-code (extract code 0 6)))
- (let ((fmt (case format ((0) 'SINGLE) ((1) 'DOUBLE) (else '()))))
- (define (two-arg op-name)
- (if (zero? ft)
- (list op-name fmt fd fs)
- (invalid-instruction)))
- (define (compare op-name)
- (if (zero? fd)
- (list op-name fmt fs ft)
- (invalid-instruction)))
- (if fmt
- (cond
- ((= fp-code addf-op) `(FADD ,fmt ,fd ,fs ,ft))
- ((= fp-code subf-op) `(FSUB ,fmt ,fd ,fs ,ft))
- ((= fp-code mulf-op) `(FMUL ,fmt ,fd ,fs ,ft))
- ((= fp-code divf-op) `(FDIV ,fmt ,fd ,fs ,ft))
- ((= fp-code absf-op) (two-arg 'FABS))
- ((= fp-code movf-op) (two-arg 'FMOV))
- ((= fp-code negf-op) (two-arg 'FNEG))
- ((= fp-code cvt.sf-op) (two-arg 'CVT.S))
- ((= fp-code cvt.df-op) (two-arg 'CVT.D))
- ((= fp-code cvt.wf-op) (two-arg 'CVT.W))
- ((= fp-code c.ff-op) (compare 'C.F))
- ((= fp-code c.unf-op) (compare 'C.UN))
- ((= fp-code c.eqf-op) (compare 'C.EQ))
- ((= fp-code c.ueqf-op) (compare 'C.UEQ))
- ((= fp-code c.oltf-op) (compare 'C.OLT))
- ((= fp-code c.ultf-op) (compare 'C.ULT))
- ((= fp-code c.olef-op) (compare 'C.OLE))
- ((= fp-code c.ulef-op) (compare 'C.ULE))
- ((= fp-code c.sff-op) (compare 'C.SF))
- ((= fp-code c.nglef-op) (compare 'C.NGLE))
- ((= fp-code c.seqf-op) (compare 'C.SEQ))
- ((= fp-code c.nglf-op) (compare 'C.NGL))
- ((= fp-code c.ltf-op) (compare 'C.LT))
- ((= fp-code c.ngef-op) (compare 'C.NGE))
- ((= fp-code c.lef-op) (compare 'C.LE))
- ((= fp-code c.ngtf-op) (compare 'C.NGT))
- (else (invalid-instruction)))
- (invalid-instruction)))))
-
-(define (disassemble-coprocessor word op)
- (define (simple-cases op2)
- (if (zero? (extract word 0 11))
- `(,op2 ,(extract word 16 21) ,(extract word 11 16))))
- (define (branch-cases op2)
- `(,op2 ,(relative-offset word)))
- (define (cop0-cases code)
- (case code
- ((1) '(TLBR))
- ((2) '(TLBWI))
- ((6) '(TLBWR))
- ((8) '(TLBP))
- ((16) '(RFE))
- (else `(COP0 ,code))))
- (let ((code-high-bits (+ (* 4 (extract word 21 23))
- (extract word 16 17)))
- (code-low-bits (extract word 23 26)))
- (let ((code (+ (* code-high-bits 8) code-low-bits)))
- (case code
- ((0 8) ; MF
- (case op
- ((0) (simple-cases 'mfc0))
- ((1) (simple-cases 'mfc1))
- ((2) (simple-cases 'mfc2))
- ((3) (simple-cases 'mfc3))))
- ((1 9) ; MT
- (case op
- ((0) (simple-cases 'mtc0))
- ((1) (simple-cases 'mtc1))
- ((2) (simple-cases 'mtc2))
- ((3) (simple-cases 'mtc3))))
- ((2 3) ; BCF
- (case op
- ((0) (branch-cases 'bcf0))
- ((1) (branch-cases 'bcf1))
- ((2) (branch-cases 'bcf2))
- ((3) (branch-cases 'bcf3))))
- ((4 5 6 7 12 13 14 15 20 21 22 23 28 29 30 31
- 36 37 38 39 44 45 46 47 52 53 54 55 60 61 62 63) ; CO
- (case op
- ((0) (cop0-cases (extract word 0 25)))
- ((1) (floating-point-cases (bit-substring word 0 25)))
- ((2) `(cop2 ,(extract word 0 25)))
- ((3) `(cop3 ,(extract word 0 25)))))
- ((10 11) ; BCT
- (case op
- ((0) (branch-cases 'bct0))
- ((1) (branch-cases 'bct1))
- ((2) (branch-cases 'bct2))
- ((3) (branch-cases 'bct3))))
- ((32 40) ; CF
- (case op
- ((0) (simple-cases 'cfc0))
- ((1) (simple-cases 'cfc1))
- ((3) (simple-cases 'cfc2))
- ((3) (simple-cases 'cfc3))))
- ((33 41) ; CT
- (case op
- ((0) (simple-cases 'ctc0))
- ((1) (simple-cases 'ctc1))
- ((2) (simple-cases 'ctc2))
- ((3) (simple-cases 'ctc3))))
- (else (invalid-instruction))))))
-
-(define (disassemble-load/store word op)
- `(,op ,(extract word 16 21)
- (OFFSET ,(extract-signed word 0 16) ,(extract word 21 26))))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Compiler File Dependencies
-;;; package: (compiler declarations)
-
-(declare (usual-integrations))
-\f
-(define (initialize-package!)
- (add-event-receiver! event:after-restore reset-source-nodes!)
- (reset-source-nodes!))
-
-(define (reset-source-nodes!)
- (set! source-filenames '())
- (set! source-hash)
- (set! source-nodes)
- (set! source-nodes/by-rank)
- unspecific)
-
-(define (maybe-setup-source-nodes!)
- (if (null? source-filenames)
- (setup-source-nodes!)))
-
-(define (setup-source-nodes!)
- (let ((filenames
- (append-map!
- (lambda (subdirectory)
- (map (lambda (pathname)
- (string-append subdirectory
- "/"
- (pathname-name pathname)))
- (directory-read
- (string-append subdirectory
- "/"
- source-file-expression))))
- '("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt"
- "machines/mips"))))
- (if (null? filenames)
- (error "Can't find source files of compiler"))
- (set! source-filenames filenames))
- (set! source-hash (make-string-hash-table))
- (set! source-nodes
- (map (lambda (filename)
- (let ((node (make/source-node filename)))
- (hash-table/put! source-hash filename node)
- node))
- source-filenames))
- (initialize/syntax-dependencies!)
- (initialize/integration-dependencies!)
- (source-nodes/rank!))
-
-(define source-file-expression "*.scm")
-(define source-filenames)
-(define source-hash)
-(define source-nodes)
-(define source-nodes/by-rank)
-
-(define (filename/append directory . names)
- (map (lambda (name) (string-append directory "/" name)) names))
-\f
-(define-structure (source-node
- (conc-name source-node/)
- (constructor %make/source-node (filename pathname)))
- (filename #f read-only #t)
- (pathname #f read-only #t)
- (forward-links '())
- (backward-links '())
- (forward-closure '())
- (backward-closure '())
- (dependencies '())
- (dependents '())
- (rank #f)
- (syntax-table #f)
- (declarations '())
- (modification-time #f))
-
-(define (make/source-node filename)
- (%make/source-node filename (->pathname filename)))
-
-(define (filename->source-node filename)
- (let ((node (hash-table/get source-hash filename #f)))
- (if (not node)
- (error "Unknown source file:" filename))
- node))
-
-(define (source-node/circular? node)
- (memq node (source-node/backward-closure node)))
-
-(define (source-node/link! node dependency)
- (if (not (memq dependency (source-node/backward-links node)))
- (begin
- (set-source-node/backward-links!
- node
- (cons dependency (source-node/backward-links node)))
- (set-source-node/forward-links!
- dependency
- (cons node (source-node/forward-links dependency)))
- (source-node/close! node dependency))))
-
-(define (source-node/close! node dependency)
- (if (not (memq dependency (source-node/backward-closure node)))
- (begin
- (set-source-node/backward-closure!
- node
- (cons dependency (source-node/backward-closure node)))
- (set-source-node/forward-closure!
- dependency
- (cons node (source-node/forward-closure dependency)))
- (for-each (lambda (dependency)
- (source-node/close! node dependency))
- (source-node/backward-closure dependency))
- (for-each (lambda (node)
- (source-node/close! node dependency))
- (source-node/forward-closure node)))))
-\f
-;;;; Rank
-
-(define (source-nodes/rank!)
- (compute-dependencies! source-nodes)
- (compute-ranks! source-nodes)
- (set! source-nodes/by-rank (source-nodes/sort-by-rank source-nodes))
- unspecific)
-
-(define (compute-dependencies! nodes)
- (for-each (lambda (node)
- (set-source-node/dependencies!
- node
- (list-transform-negative (source-node/backward-closure node)
- (lambda (node*)
- (memq node (source-node/backward-closure node*)))))
- (set-source-node/dependents!
- node
- (list-transform-negative (source-node/forward-closure node)
- (lambda (node*)
- (memq node (source-node/forward-closure node*))))))
- nodes))
-
-(define (compute-ranks! nodes)
- (let loop ((nodes nodes) (unranked-nodes '()))
- (if (null? nodes)
- (if (not (null? unranked-nodes))
- (loop unranked-nodes '()))
- (loop (cdr nodes)
- (let ((node (car nodes)))
- (let ((rank (source-node/rank* node)))
- (if rank
- (begin
- (set-source-node/rank! node rank)
- unranked-nodes)
- (cons node unranked-nodes))))))))
-
-(define (source-node/rank* node)
- (let loop ((nodes (source-node/dependencies node)) (rank -1))
- (if (null? nodes)
- (1+ rank)
- (let ((rank* (source-node/rank (car nodes))))
- (and rank*
- (loop (cdr nodes) (max rank rank*)))))))
-
-(define (source-nodes/sort-by-rank nodes)
- (sort nodes (lambda (x y) (< (source-node/rank x) (source-node/rank y)))))
-\f
-;;;; File Syntaxer
-
-(define (syntax-files!)
- (maybe-setup-source-nodes!)
- (for-each
- (lambda (node)
- (let ((modification-time
- (let ((source (modification-time node "scm"))
- (binary (modification-time node "bin")))
- (if (not source)
- (error "Missing source file" (source-node/filename node)))
- (and binary (< source binary) binary))))
- (set-source-node/modification-time! node modification-time)
- (if (not modification-time)
- (begin (write-string "\nSource file newer than binary: ")
- (write (source-node/filename node))))))
- source-nodes)
- (if compiler:enable-integration-declarations?
- (begin
- (for-each
- (lambda (node)
- (let ((time (source-node/modification-time node)))
- (if (and time
- (there-exists? (source-node/dependencies node)
- (lambda (node*)
- (let ((newer?
- (let ((time*
- (source-node/modification-time node*)))
- (or (not time*)
- (> time* time)))))
- (if newer?
- (begin
- (write-string "\nBinary file ")
- (write (source-node/filename node))
- (write-string " newer than dependency ")
- (write (source-node/filename node*))))
- newer?))))
- (set-source-node/modification-time! node #f))))
- source-nodes)
- (for-each
- (lambda (node)
- (if (not (source-node/modification-time node))
- (for-each (lambda (node*)
- (if (source-node/modification-time node*)
- (begin
- (write-string "\nBinary file ")
- (write (source-node/filename node*))
- (write-string " depends on ")
- (write (source-node/filename node))))
- (set-source-node/modification-time! node* #f))
- (source-node/forward-closure node))))
- source-nodes)))
- (for-each (lambda (node)
- (if (not (source-node/modification-time node))
- (pathname-delete!
- (pathname-new-type (source-node/pathname node) "ext"))))
- source-nodes/by-rank)
- (write-string "\n\nBegin pass 1:")
- (for-each (lambda (node)
- (if (not (source-node/modification-time node))
- (source-node/syntax! node)))
- source-nodes/by-rank)
- (if (there-exists? source-nodes/by-rank
- (lambda (node)
- (and (not (source-node/modification-time node))
- (source-node/circular? node))))
- (begin
- (write-string "\n\nBegin pass 2:")
- (for-each (lambda (node)
- (if (not (source-node/modification-time node))
- (if (source-node/circular? node)
- (source-node/syntax! node)
- (source-node/touch! node))))
- source-nodes/by-rank))))
-\f
-(define (source-node/touch! node)
- (with-values
- (lambda ()
- (sf/pathname-defaulting (source-node/pathname node) "" #f))
- (lambda (input-pathname bin-pathname spec-pathname)
- input-pathname
- (pathname-touch! bin-pathname)
- (pathname-touch! (pathname-new-type bin-pathname "ext"))
- (if spec-pathname (pathname-touch! spec-pathname)))))
-
-(define (pathname-touch! pathname)
- (if (file-exists? pathname)
- (begin
- (write-string "\nTouch file: ")
- (write (enough-namestring pathname))
- (file-touch pathname))))
-
-(define (pathname-delete! pathname)
- (if (file-exists? pathname)
- (begin
- (write-string "\nDelete file: ")
- (write (enough-namestring pathname))
- (delete-file pathname))))
-
-(define (sc filename)
- (maybe-setup-source-nodes!)
- (source-node/syntax! (filename->source-node filename)))
-
-(define (source-node/syntax! node)
- (with-values
- (lambda ()
- (sf/pathname-defaulting (source-node/pathname node) "" #f))
- (lambda (input-pathname bin-pathname spec-pathname)
- (sf/internal
- input-pathname bin-pathname spec-pathname
- (source-node/syntax-table node)
- ((if compiler:enable-integration-declarations?
- identity-procedure
- (lambda (declarations)
- (list-transform-negative declarations
- integration-declaration?)))
- (source-node/declarations node))))))
-
-(define-integrable (modification-time node type)
- (file-modification-time
- (pathname-new-type (source-node/pathname node) type)))
-\f
-;;;; Syntax dependencies
-
-(define (initialize/syntax-dependencies!)
- (let ((file-dependency/syntax/join
- (lambda (filenames syntax-table)
- (for-each (lambda (filename)
- (set-source-node/syntax-table!
- (filename->source-node filename)
- syntax-table))
- filenames))))
- (file-dependency/syntax/join
- (append (filename/append "base"
- "toplev" "asstop" "crstop"
- "blocks" "cfg1" "cfg2" "cfg3" "constr"
- "contin" "ctypes" "debug" "enumer"
- "infnew" "lvalue" "object" "pmerly" "proced"
- "refctx" "rvalue" "scode" "sets" "subprb"
- "switch" "utils")
- (filename/append "back"
- "asmmac" "bittop" "bitutl" "insseq" "lapgn1"
- "lapgn2" "lapgn3" "linear" "regmap" "symtab"
- "syntax")
- (filename/append "machines/mips"
- "dassm1" "insmac" "lapopt" "machin" "rgspcm"
- "rulrew")
- (filename/append "fggen"
- "declar" "fggen" "canon")
- (filename/append "fgopt"
- "blktyp" "closan" "conect" "contan" "delint"
- "desenv" "envopt" "folcon" "offset" "operan"
- "order" "outer" "param" "reord" "reteqv" "reuse"
- "sideff" "simapp" "simple" "subfre" "varind")
- (filename/append "rtlbase"
- "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp"
- "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2"
- "valclass")
- (filename/append "rtlgen"
- "fndblk" "fndvar" "opncod" "rgcomb" "rgproc"
- "rgretn" "rgrval" "rgstmt" "rtlgen")
- (filename/append "rtlopt"
- "ralloc" "rcompr" "rcse1" "rcse2" "rcseep"
- "rcseht" "rcserq" "rcsesr" "rdebug" "rdflow"
- "rerite" "rinvex" "rlife" "rtlcsm"))
- (->environment '(COMPILER)))
- (file-dependency/syntax/join
- (filename/append "machines/mips"
- "lapgen"
- "rules1" "rules2" "rules3" "rules4" "rulfix" "rulflo"
- "instr1" "instr2a" "instr2b" "instr3")
- (->environment '(COMPILER LAP-SYNTAXER)))))
-\f
-;;;; Integration Dependencies
-
-(define (initialize/integration-dependencies!)
-
- (define (add-declaration! declaration filenames)
- (for-each (lambda (filenames)
- (let ((node (filename->source-node filenames)))
- (set-source-node/declarations!
- node
- (cons declaration
- (source-node/declarations node)))))
- filenames))
-
- (let* ((front-end-base
- (filename/append "base"
- "blocks" "cfg1" "cfg2" "cfg3"
- "contin" "ctypes" "enumer" "lvalue"
- "object" "proced" "rvalue"
- "scode" "subprb" "utils"))
- (mips-base
- (append (filename/append "machines/mips" "machin")
- (filename/append "back" "asutl")))
- (rtl-base
- (filename/append "rtlbase"
- "regset" "rgraph" "rtlcfg" "rtlobj"
- "rtlreg" "rtlty1" "rtlty2"))
- (cse-base
- (filename/append "rtlopt"
- "rcse1" "rcseht" "rcserq" "rcsesr"))
- (cse-all
- (append (filename/append "rtlopt"
- "rcse2" "rcseep")
- cse-base))
- (instruction-base
- (filename/append "machines/mips" "assmd" "machin"))
- (lapgen-base
- (append (filename/append "back" "linear" "regmap")
- (filename/append "machines/mips" "lapgen")))
- (assembler-base
- (filename/append "back" "symtab"))
- (lapgen-body
- (append
- (filename/append "back" "lapgn1" "lapgn2" "syntax")
- (filename/append "machines/mips"
- "rules1" "rules2" "rules3" "rules4"
- "rulfix" "rulflo"
- )))
- (assembler-body
- (append
- (filename/append "back" "bittop")
- (filename/append "machines/mips"
- "instr1" "instr2a" "instr2b" "instr3"))))
-
- (define (file-dependency/integration/join filenames dependencies)
- (for-each (lambda (filename)
- (file-dependency/integration/make filename dependencies))
- filenames))
-
- (define (file-dependency/integration/make filename dependencies)
- (let ((node (filename->source-node filename)))
- (for-each (lambda (dependency)
- (let ((node* (filename->source-node dependency)))
- (if (not (eq? node node*))
- (source-node/link! node node*))))
- dependencies)))
-
- (define (define-integration-dependencies directory name directory* . names)
- (file-dependency/integration/make
- (string-append directory "/" name)
- (apply filename/append directory* names)))
-
- (define-integration-dependencies "machines/mips" "machin" "back" "asutl")
- (define-integration-dependencies "base" "object" "base" "enumer")
- (define-integration-dependencies "base" "enumer" "base" "object")
- (define-integration-dependencies "base" "utils" "base" "scode")
- (define-integration-dependencies "base" "cfg1" "base" "object")
- (define-integration-dependencies "base" "cfg2" "base"
- "cfg1" "cfg3" "object")
- (define-integration-dependencies "base" "cfg3" "base" "cfg1" "cfg2")
- (define-integration-dependencies "base" "ctypes" "base"
- "blocks" "cfg1" "cfg2" "cfg3" "contin" "lvalue" "object" "subprb")
- (define-integration-dependencies "base" "rvalue" "base"
- "blocks" "cfg1" "cfg2" "cfg3" "enumer" "lvalue" "object" "utils")
- (define-integration-dependencies "base" "lvalue" "base"
- "blocks" "object" "proced" "rvalue" "utils")
- (define-integration-dependencies "base" "blocks" "base"
- "enumer" "lvalue" "object" "proced" "rvalue" "scode")
- (define-integration-dependencies "base" "proced" "base"
- "blocks" "cfg1" "cfg2" "cfg3" "contin" "enumer" "lvalue" "object"
- "rvalue" "utils")
- (define-integration-dependencies "base" "contin" "base"
- "blocks" "cfg3" "ctypes")
- (define-integration-dependencies "base" "subprb" "base"
- "cfg3" "contin" "enumer" "object" "proced")
-
- (define-integration-dependencies "machines/mips" "machin" "rtlbase"
- "rtlreg" "rtlty1" "rtlty2")
-
- (define-integration-dependencies "rtlbase" "regset" "base")
- (define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2")
- (define-integration-dependencies "rtlbase" "rgraph" "machines/mips"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlcfg" "base"
- "cfg1" "cfg2" "cfg3")
- (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils")
- (define-integration-dependencies "rtlbase" "rtlcon" "machines/mips"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlexp" "rtlbase"
- "rtlreg" "rtlty1")
- (define-integration-dependencies "rtlbase" "rtline" "base" "cfg1" "cfg2")
- (define-integration-dependencies "rtlbase" "rtline" "rtlbase"
- "rtlcfg" "rtlty2")
- (define-integration-dependencies "rtlbase" "rtlobj" "base"
- "cfg1" "object" "utils")
- (define-integration-dependencies "rtlbase" "rtlreg" "machines/mips"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlreg" "rtlbase"
- "rgraph" "rtlty1")
- (define-integration-dependencies "rtlbase" "rtlty1" "rtlbase" "rtlcfg")
- (define-integration-dependencies "rtlbase" "rtlty2" "base" "scode")
- (define-integration-dependencies "rtlbase" "rtlty2" "machines/mips"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlty2" "rtlbase" "rtlty1")
-
- (file-dependency/integration/join
- (append
- (filename/append "base" "refctx")
- (filename/append "fggen"
- "declar" "fggen") ; "canon" needs no integrations
- (filename/append "fgopt"
- "blktyp" "closan" "conect" "contan" "delint" "desenv"
- "envopt" "folcon" "offset" "operan" "order" "param"
- "outer" "reuse" "reteqv" "sideff" "simapp" "simple"
- "subfre" "varind"))
- (append mips-base front-end-base))
-
- (define-integration-dependencies "fgopt" "reuse" "fgopt" "reord")
-
- (file-dependency/integration/join
- (filename/append "rtlgen"
- "fndblk" "fndvar" "opncod" "rgcomb" "rgproc" "rgretn"
- "rgrval" "rgstmt" "rtlgen")
- (append mips-base front-end-base rtl-base))
-
- (file-dependency/integration/join
- (append cse-all
- (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow"
- "rerite" "rinvex" "rlife" "rtlcsm")
- (filename/append "machines/mips" "rulrew"))
- (append mips-base rtl-base))
-
- (file-dependency/integration/join cse-all cse-base)
-
- (file-dependency/integration/join
- (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife")
- (filename/append "rtlbase" "regset"))
-
- (file-dependency/integration/join
- (filename/append "rtlopt" "rcseht" "rcserq")
- (filename/append "base" "object"))
-
- (define-integration-dependencies "rtlopt" "rlife" "base" "cfg2")
-
- (let ((dependents
- (append instruction-base
- lapgen-base
- lapgen-body
- assembler-base
- assembler-body
- (filename/append "back" "linear" "syerly"))))
- (add-declaration! '(USUAL-DEFINITION (SET EXPT)) dependents)
- (file-dependency/integration/join dependents instruction-base))
-
- (file-dependency/integration/join (append lapgen-base lapgen-body)
- lapgen-base)
-
- (file-dependency/integration/join (append assembler-base assembler-body)
- assembler-base)
-
- (define-integration-dependencies "back" "lapgn1" "base"
- "cfg1" "cfg2" "utils")
- (define-integration-dependencies "back" "lapgn1" "rtlbase"
- "regset" "rgraph" "rtlcfg")
- (define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg")
- (define-integration-dependencies "back" "linear" "base" "cfg1" "cfg2")
- (define-integration-dependencies "back" "linear" "rtlbase" "rtlcfg")
- (define-integration-dependencies "back" "mermap" "back" "regmap")
- (define-integration-dependencies "back" "regmap" "base" "utils")
- (define-integration-dependencies "back" "symtab" "base" "utils"))
-
- (for-each (lambda (node)
- (let ((links (source-node/backward-links node)))
- (if (not (null? links))
- (set-source-node/declarations!
- node
- (cons (make-integration-declaration
- (source-node/pathname node)
- (map source-node/pathname links))
- (source-node/declarations node))))))
- source-nodes))
-
-(define (make-integration-declaration pathname integration-dependencies)
- `(INTEGRATE-EXTERNAL
- ,@(map (let ((default
- (make-pathname
- #f
- #f
- (cons 'RELATIVE
- (make-list
- (length (cdr (pathname-directory pathname)))
- 'UP))
- #f
- #f
- #f)))
- (lambda (pathname)
- (merge-pathnames pathname default)))
- integration-dependencies)))
-
-(define-integrable (integration-declaration? declaration)
- (eq? (car declaration) 'INTEGRATE-EXTERNAL))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;; MIPS Instruction Set Macros. Early version
-;;; NOPs for now.
-
-(declare (usual-integrations))
-
-(define-syntax define-instruction
- (non-hygienic-macro-transformer
- (lambda (opcode . patterns)
- `(SET! EARLY-INSTRUCTIONS
- (CONS
- (LIST ',opcode
- ,@(map (lambda (pattern)
- `(early-parse-rule
- ',(car pattern)
- (lambda (pat vars)
- (early-make-rule
- pat
- vars
- (scode-quote
- (instruction->instruction-sequence
- ,(parse-instruction (cadr pattern)
- (cddr pattern)
- #t)))))))
- patterns))
- EARLY-INSTRUCTIONS)))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; MIPS Instruction Set Macros
-
-(declare (usual-integrations))
-\f
-;;;; Definition macros
-
-(define-syntax define-symbol-transformer
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (if (syntax-match? '(IDENTIFIER * SYMBOL) (cdr form))
- `(DEFINE-INTEGRABLE (,(cadr form) SYMBOL)
- (LET ((PLACE (ASSQ SYMBOL ',(cddr form))))
- (IF (PAIR? PLACE)
- (CDR PLACE)
- #F)))
- (ill-formed-syntax form)))))
-
-(define-syntax define-transformer
- (rsc-macro-transformer
- (lambda (form environment)
- `(,(close-syntax 'DEFINE environment) ,@(cdr form)))))
-
-;;;; Fixed width instruction parsing
-
-(define (parse-instruction first-word tail early? environment)
- (if (not (null? tail))
- (error "Unknown format:" (cons first-word tail)))
- (let loop ((first-word first-word))
- (case (car first-word)
- ((LONG)
- (process-fields (cdr first-word) early? environment))
- ((VARIABLE-WIDTH)
- (process-variable-width first-word early? environment))
- ((IF)
- `(,(close-syntax 'IF environment)
- ,(cadr first-word)
- ,(loop (caddr first-word))
- ,(loop (cadddr first-word))))
- (else
- (error "Unknown format:" first-word)))))
-
-(define (process-variable-width descriptor early? environment)
- (let ((binding (cadr descriptor))
- (clauses (cddr descriptor)))
- `(,(close-syntax 'LIST environment)
- ,(variable-width-expression-syntaxer
- (car binding) ; name
- (cadr binding) ; expression
- environment
- (map (lambda (clause)
- (call-with-values
- (lambda ()
- (expand-fields (cdadr clause) early? environment))
- (lambda (code size)
- (if (not (zero? (remainder size 32)))
- (error "Bad clause size:" size))
- `((,(close-syntax 'LIST environment)
- ,(optimize-group-syntax code early? environment))
- ,size
- ,@(car clause)))))
- clauses)))))
-\f
-(define (process-fields fields early? environment)
- (call-with-values (lambda () (expand-fields fields early? environment))
- (lambda (code size)
- (if (not (zero? (remainder size 32)))
- (error "Bad syllable size:" size))
- `(,(close-syntax 'LIST environment)
- ,(optimize-group-syntax code early? environment)))))
-
-(define (expand-fields fields early? environment)
- (let expand ((first-word '()) (word-size 0) (fields fields))
- (if (pair? fields)
- (call-with-values
- (lambda () (expand-field (car fields) early? environment))
- (lambda (car-field car-size)
- (if (and (eq? endianness 'LITTLE)
- (= 32 (+ word-size car-size)))
- (call-with-values (lambda () (expand '() 0 (cdr fields)))
- (lambda (tail tail-size)
- (values (append (cons car-field first-word) tail)
- (+ car-size tail-size))))
- (call-with-values
- (lambda ()
- (expand (cons car-field first-word)
- (+ car-size word-size)
- (cdr fields)))
- (lambda (tail tail-size)
- (values (if (or (zero? car-size)
- (not (eq? endianness 'LITTLE)))
- (cons car-field tail)
- tail)
- (+ car-size tail-size)))))))
- (values '() 0))))
-
-(define (expand-field field early? environment)
- early? ; ignored for now
- (let ((size (car field))
- (expression (cadr field)))
-
- (define (default type)
- (values (integer-syntaxer expression environment type size)
- size))
-
- (if (pair? (cddr field))
- (case (caddr field)
- ((PC-REL)
- (values (integer-syntaxer ``(,',(close-syntax '- environment)
- ,,expression
- (,',(close-syntax '+ environment)
- ,',(close-syntax '*PC* environment)
- 4))
- environment
- (cadddr field)
- size)
- size))
- ((BLOCK-OFFSET)
- (values `(,(close-syntax 'LIST environment)
- 'BLOCK-OFFSET
- ,expression)
- size))
- (else
- (default (caddr field))))
- (default 'UNSIGNED))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; MIPS instruction set
-
-;; Branch-tensioned instructions are in instr2.scm
-;; Floating point instructions are in instr3.scm
-
-(declare (usual-integrations))
-\f
-(let-syntax
- ((arithmetic-immediate-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? destination) (? source) (? immediate))
- (VARIABLE-WIDTH (evaluated-immediate immediate)
- ((#x-8000 #x7fff)
- (LONG (6 ,(caddr form))
- (5 source)
- (5 destination)
- (16 evaluated-immediate SIGNED)))
- ((#x8000 #xffff)
- ;; ORI 1, 0, immediate
- ;; reg-op destination, source, 1
- (LONG (6 13) ; ORI
- (5 0)
- (5 1)
- (16 evaluated-immediate)
- (6 0) ; reg-op
- (5 source)
- (5 1)
- (5 destination)
- (5 0)
- (6 ,(cadddr form))))
- ((() ())
- ;; LUI 1, (top of immediate)
- ;; ORI 1, 1, (bottom of immediate)
- ;; reg-op destination, source, 1
- (LONG (6 15) ; LUI
- (5 0)
- (5 1)
- (16 (top-16-bits evaluated-immediate))
- (6 13) ; ORI
- (5 1)
- (5 1)
- (16 (bottom-16-bits evaluated-immediate))
- (6 0) ; reg-op
- (5 source)
- (5 1)
- (5 destination)
- (5 0)
- (6 ,(cadddr form)))))))))))
- (arithmetic-immediate-instruction addi 8 32)
- (arithmetic-immediate-instruction addiu 9 33)
- (arithmetic-immediate-instruction slti 10 42)
- (arithmetic-immediate-instruction sltiu 11 43))
-
-(let-syntax
- ((unsigned-immediate-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? destination) (? source) (? immediate))
- (VARIABLE-WIDTH (evaluated-immediate immediate)
- ((0 #xffff)
- (LONG (6 ,(caddr form))
- (5 source)
- (5 destination)
- (16 evaluated-immediate)))
- ((() ())
- ;; LUI 1, (top of immediate)
- ;; ORI 1, 1, (bottom of immediate)
- ;; reg-op destination, source, 1
- (LONG (6 15) ; LUI
- (5 0)
- (5 1)
- (16 (top-16-bits evaluated-immediate))
- (6 13) ; ORI
- (5 1)
- (5 1)
- (16 (bottom-16-bits evaluated-immediate))
- (6 0) ; reg-op
- (5 source)
- (5 1)
- (5 destination)
- (5 0)
- (6 ,(cadddr form)))))))))))
- (unsigned-immediate-instruction andi 12 36)
- (unsigned-immediate-instruction ori 13 37)
- (unsigned-immediate-instruction xori 14 38))
-\f
-(define-instruction lui
- (((? destination) (? immediate))
- (LONG (6 15)
- (5 0)
- (5 destination)
- (16 immediate))))
-
-(define-instruction li
- (((? destination) (? immediate))
- (VARIABLE-WIDTH (evaluated-immediate immediate)
- ((#x-8000 #x7fff)
- ;; ADDI destination, 0, immediate
- (LONG (6 8)
- (5 0)
- (5 destination)
- (16 evaluated-immediate SIGNED)))
- ((#x8000 #xffff)
- ;; ORI destination, 0, immediate
- (LONG (6 13)
- (5 0)
- (5 destination)
- (16 evaluated-immediate)))
- ((() ())
- ;; LUI destination, (top of immediate)
- ;; ORI destination, destination, (bottom of immediate)
- (LONG (6 15) ; LUI
- (5 0)
- (5 destination)
- (16 (top-16-bits evaluated-immediate))
- (6 13) ; ORI
- (5 destination)
- (5 destination)
- (16 (bottom-16-bits evaluated-immediate)))))))
-\f
-(let-syntax
- ((3-operand-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? destination) (? source-1) (? source-2))
- (LONG (6 0)
- (5 source-1)
- (5 source-2)
- (5 destination)
- (5 0)
- (6 ,(caddr form)))))))))
- (3-operand-instruction add 32)
- (3-operand-instruction addu 33)
- (3-operand-instruction sub 34)
- (3-operand-instruction subu 35)
- (3-operand-instruction and 36)
- (3-operand-instruction or 37)
- (3-operand-instruction xor 38)
- (3-operand-instruction nor 39)
- (3-operand-instruction slt 42)
- (3-operand-instruction sltu 43))
-
-(let-syntax
- ((shift-instruction
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? destination) (? source) (? amount))
- (LONG (6 0)
- (5 0)
- (5 source)
- (5 destination)
- (5 amount)
- (6 ,(caddr form))))))))
- (shift-instruction sll 0)
- (shift-instruction srl 2)
- (shift-instruction sra 3))
-
-(let-syntax
- ((shift-variable-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? destination) (? source) (? amount))
- (LONG (6 0)
- (5 amount)
- (5 source)
- (5 destination)
- (5 0)
- (6 ,(caddr form)))))))))
- (shift-variable-instruction sllv 4)
- (shift-variable-instruction srlv 6)
- (shift-variable-instruction srav 7))
-\f
-(let-syntax
- ((div/mul-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? source-1) (? source-2))
- (LONG (6 0)
- (5 source-1)
- (5 source-2)
- (5 0)
- (5 0)
- (6 ,(caddr form)))))))))
- (div/mul-instruction div 26)
- (div/mul-instruction divu 27)
- (div/mul-instruction mult 24)
- (div/mul-instruction multu 25))
-
-(let-syntax
- ((from-hi/lo-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? destination))
- (LONG (6 0)
- (5 0)
- (5 0)
- (5 destination)
- (5 0)
- (6 ,(caddr form)))))))))
- (from-hi/lo-instruction mfhi 16)
- (from-hi/lo-instruction mflo 18))
-#|
-(let-syntax
- ((to-hi/lo-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? source))
- (LONG (6 0)
- (5 source)
- (5 0)
- (5 0)
- (5 0)
- (6 ,(caddr form)))))))))
- (to-hi/lo-instruction mthi 17)
- (to-hi/lo-instruction mtlo 19))
-
-(let-syntax
- ((jump-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? address))
- (LONG (6 ,(caddr form))
- (26 (QUOTIENT address 2)))))))))
- (jump-instruction j 2)
- (jump-instruction jal 3))
-|#
-(define-instruction jalr
- (((? destination) (? source))
- (LONG (6 0)
- (5 source)
- (5 0)
- (5 destination)
- (5 0)
- (6 9))))
-
-(define-instruction jr
- (((? source))
- (LONG (6 0)
- (5 source)
- (5 0)
- (5 0)
- (5 0)
- (6 8))))
-\f
-(let-syntax
- ((move-coprocessor-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? rt-mci) (? rd-mci))
- (LONG (6 ,(caddr form))
- (5 ,(cadddr form))
- (5 rt-mci)
- (5 rd-mci)
- (11 0))))))))
- ;; (move-coprocessor-instruction mfc0 16 #x000)
- (move-coprocessor-instruction mfc1 17 #x000)
- ;; (move-coprocessor-instruction mfc2 18 #x000)
- ;; (move-coprocessor-instruction mfc3 19 #x000)
- ;; (move-coprocessor-instruction cfc0 16 #x002)
- (move-coprocessor-instruction cfc1 17 #x002)
- ;; (move-coprocessor-instruction cfc2 18 #x002)
- ;; (move-coprocessor-instruction cfc3 19 #x002)
- ;; (move-coprocessor-instruction mtc0 16 #x004)
- (move-coprocessor-instruction mtc1 17 #x004)
- ;; (move-coprocessor-instruction mtc2 18 #x004)
- ;; (move-coprocessor-instruction mtc3 19 #x004)
- ;; (move-coprocessor-instruction ctc0 16 #x006)
- (move-coprocessor-instruction ctc1 17 #x006)
- ;; (move-coprocessor-instruction ctc2 18 #x006)
- ;; (move-coprocessor-instruction ctc3 19 #x006)
- )
-#|
-(let-syntax
- ((coprocessor-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? cofun))
- (LONG (6 ,(caddr form))
- (1 1) ; CO bit
- (25 cofun))))))))
- (coprocessor-instruction cop0 16)
- (coprocessor-instruction cop1 17)
- (coprocessor-instruction cop2 18)
- (coprocessor-instruction cop3 19))
-
-(let-syntax
- ((cop0-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (()
- (LONG (6 16)
- (1 1) ; CO
- (20 0)
- (5 ,(caddr form)))))))))
- (cop0-instruction rfe 16)
- (cop0-instruction tlbp 8)
- (cop0-instruction tlbr 1)
- (cop0-instruction tlbwi 2)
- (cop0-instruction tlbwr 6))
-
-(define-instruction syscall
- (()
- (LONG (6 0) (20 0) (6 12))))
-
-(define-instruction break
- (((? code))
- (LONG (6 0) (20 code) (6 13))))
-|#
-\f
-;;;; Assembler pseudo-ops
-
-(define-instruction EXTERNAL-LABEL
- ;; External labels provide the garbage collector with header
- ;; information and the runtime system with type, arity, and
- ;; debugging information.
- (((? format-word) (@PCR (? label)))
- (if (eq? endianness 'LITTLE)
- (LONG (16 label BLOCK-OFFSET)
- (16 format-word UNSIGNED))
- (LONG (16 format-word UNSIGNED)
- (16 label BLOCK-OFFSET)))))
-
-(define-instruction NOP
- ;; (SLL 0 0 0)
- (()
- (LONG (6 0) (5 0) (5 0) (5 0) (5 0) (6 0))))
-
-(define-instruction LONG
- ((S (? value))
- (LONG (32 value SIGNED)))
- ((U (? value))
- (LONG (32 value UNSIGNED))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; MIPS instruction set, part 2a
-
-(declare (usual-integrations))
-\f
-;;;; Instructions that require branch tensioning: branch
-
-(let-syntax
- ((branch
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- ((,@(caddr form) (@PCO (? offset)))
- (LONG ,@(cadddr form)
- (16 (quotient offset 4) SIGNED)))
- ((,@(caddr form) (@PCR (? label)))
- (VARIABLE-WIDTH (offset `(/ (- ,label (+ *PC* 4)) 4))
- ((#x-8000 #x7fff)
- (LONG ,@(cadddr form) (16 offset SIGNED)))
- ((() ())
- ;; <reverse> xxx
- ;; LUI $1, left_adj(offset*4 - 12)
- ;; BGEZAL $0, yyy
- ;; ADDIU $1, $1, right(offset*4 - 12)
- ;; yyy: ADD $1, $1, $31
- ;; JR $1
- ;; xxx:
- (LONG ,@(list-ref form 4) ; reverse branch to (.+1)+5
- (16 5)
- (6 15) ; LUI
- (5 0)
- (5 1)
- (16 (adjusted:high (* (- offset 3) 4)))
- (6 1) ; BGEZAL
- (5 0)
- (5 17)
- (16 1)
- (6 9) ; ADDIU
- (5 1)
- (5 1)
- (16 (adjusted:low (* (- offset 3) 4)) SIGNED)
- (6 0) ; ADD
- (5 1)
- (5 31)
- (5 1)
- (5 0)
- (6 32)
- (6 0) ; JR
- (5 1)
- (15 0)
- (6 8))))))))))
- (branch beq
- ((? reg1) (? reg2))
- ((6 4) (5 reg1) (5 reg2))
- ((6 5) (5 reg1) (5 reg2)))
- (branch bne
- ((? reg1) (? reg2))
- ((6 5) (5 reg1) (5 reg2))
- ((6 4) (5 reg1) (5 reg2)))
- (branch bgez
- ((? reg))
- ((6 1) (5 reg) (5 1))
- ((6 1) (5 reg) (5 0)))
- (branch bgtz
- ((? reg))
- ((6 7) (5 reg) (5 0))
- ((6 6) (5 reg) (5 0)))
- (branch blez
- ((? reg))
- ((6 6) (5 reg) (5 0))
- ((6 7) (5 reg) (5 0)))
- (branch bltz
- ((? reg))
- ((6 1) (5 reg) (5 0))
- ((6 1) (5 reg) (5 1)))
- (branch bgezal
- ((? reg))
- ((6 1) (5 reg) (5 17))
- ((16 "can't branch tension a bgezal instruction")))
- (branch bltzal
- ((? reg))
- ((6 1) (5 reg) (5 16))
- ((16 "can't branch tension a bltzal instruction")))
- ;; (branch bc0f () ((6 16) (10 #x100)) ((6 16) (10 #x101)))
- (branch bc1f () ((6 17) (10 #x100)) ((6 17) (10 #x101)))
- ;; (branch bc2f () ((6 18) (10 #x100)) ((6 18) (10 #x101)))
- ;; (branch bc3f () ((6 19) (10 #x100)) ((6 19) (10 #x101)))
- ;; (branch bc0t () ((6 16) (10 #x101)) ((6 16) (10 #x100)))
- (branch bc1t () ((6 17) (10 #x101)) ((6 17) (10 #x100)))
- ;; (branch bc2t () ((6 18) (10 #x101)) ((6 18) (10 #x100)))
- ;; (branch bc3t () ((6 19) (10 #x101)) ((6 19) (10 #x100)))
- )
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; MIPS instruction set, part 2b
-
-(declare (usual-integrations))
-\f
-;;;; Instructions that require branch tensioning: load/store
-
-(let-syntax
- ((load/store-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? source/dest-reg) (OFFSET (? offset-ls) (? base-reg)))
- (VARIABLE-WIDTH (delta offset-ls)
- ((#x-8000 #x7fff)
- (LONG (6 ,(caddr form))
- (5 base-reg)
- (5 source/dest-reg)
- (16 delta SIGNED)))
- ((() ())
- ;; LUI 1,adjusted-left<offset>
- ;; ADDU 1,1,base-reg
- ;; LW source/dest-reg,right<offset>(1)
- (LONG (6 15) ; LUI
- (5 0)
- (5 1)
- (16 (adjusted:high delta))
- (6 0) ; ADD
- (5 1)
- (5 base-reg)
- (5 1)
- (5 0)
- (6 32)
- (6 ,(caddr form)); LW
- (5 1)
- (5 source/dest-reg)
- (16 (adjusted:low delta) SIGNED))))))))))
- (load/store-instruction lb 32)
- (load/store-instruction lbu 36)
- (load/store-instruction lh 33)
- (load/store-instruction lhu 37)
- (load/store-instruction lw 35)
- ;; (load/store-instruction lwc0 48)
- (load/store-instruction lwc1 49)
- ;; (load/store-instruction lwc2 50)
- ;; (load/store-instruction lwc3 51)
- ;; (load/store-instruction lwl 34)
- ;; (load/store-instruction lwr 38)
- (load/store-instruction sb 40)
- (load/store-instruction sh 41)
- (load/store-instruction sw 43)
- ;; (load/store-instruction swc0 56)
- (load/store-instruction swc1 57)
- ;; (load/store-instruction swc2 58)
- ;; (load/store-instruction swc3 59)
- ;; (load/store-instruction swl 42)
- ;; (load/store-instruction swr 46)
- )
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; MIPS instruction set, part 3
-;;; Floating point co-processor (R2010)
-
-(declare (usual-integrations))
-\f
-(let-syntax
- ((three-reg
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(BEGIN
- (DEFINE-INSTRUCTION ,(symbol-append (cadr form) '.S)
- (((? fd) (? fs) (? ft))
- (LONG (6 17)
- (1 1)
- (4 0) ; single precision
- (5 ft)
- (5 fs)
- (5 fd)
- (6 ,(caddr form)))))
- (DEFINE-INSTRUCTION ,(symbol-append (cadr form) '.D)
- (((? fd) (? fs) (? ft))
- (LONG (6 17)
- (1 1)
- (4 1) ; double precision
- (5 ft)
- (5 fs)
- (5 fd)
- (6 ,(caddr form))))))))))
-
- (three-reg add 0)
- (three-reg sub 1)
- (three-reg mul 2)
- (three-reg div 3))
-
-(let-syntax
- ((two-reg
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(BEGIN
- (DEFINE-INSTRUCTION ,(symbol-append (cadr form) '.S)
- (((? fd) (? fs))
- (LONG (6 17)
- (1 1)
- (4 0) ; single precision
- (5 0)
- (5 fs)
- (5 fd)
- (6 ,(caddr form)))))
- (DEFINE-INSTRUCTION ,(symbol-append (cadr form) '.D)
- (((? fd) (? fs))
- (LONG (6 17)
- (1 1)
- (4 1) ; double precision
- (5 0)
- (5 fs)
- (5 fd)
- (6 ,(caddr form))))))))))
- (two-reg abs 5)
- (two-reg mov 6)
- (two-reg neg 7))
-\f
-(define-instruction cvt.d.s
- (((? fd) (? fs))
- (LONG (6 17)
- (1 1)
- (4 0)
- (5 0)
- (5 fs)
- (5 fd)
- (6 33))))
-
-(define-instruction cvt.d.w
- (((? fd) (? fs))
- (LONG (6 17)
- (1 1)
- (4 4)
- (5 0)
- (5 fs)
- (5 fd)
- (6 33))))
-
-(define-instruction cvt.s.d
- (((? fd) (? fs))
- (LONG (6 17)
- (1 1)
- (4 1)
- (5 0)
- (5 fs)
- (5 fd)
- (6 32))))
-
-(define-instruction cvt.s.w
- (((? fd) (? fs))
- (LONG (6 17)
- (1 1)
- (4 4)
- (5 0)
- (5 fs)
- (5 fd)
- (6 32))))
-
-(define-instruction cvt.w.d
- (((? fd) (? fs))
- (LONG (6 17)
- (1 1)
- (4 1)
- (5 0)
- (5 fs)
- (5 fd)
- (6 36))))
-
-(define-instruction cvt.w.s
- (((? fd) (? fs))
- (LONG (6 17)
- (1 1)
- (4 0)
- (5 0)
- (5 fs)
- (5 fd)
- (6 36))))
-\f
-(let-syntax
- ((compare
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(BEGIN
- (DEFINE-INSTRUCTION ,(symbol-append (cadr form) '.S)
- (((? fs) (? ft))
- (LONG (6 17)
- (1 1)
- (4 0)
- (5 ft)
- (5 fs)
- (5 0)
- (6 ,(caddr form)))))
- (DEFINE-INSTRUCTION ,(symbol-append (cadr form) '.D)
- (((? fs) (? ft))
- (LONG (6 17)
- (1 1)
- (4 1)
- (5 ft)
- (5 fs)
- (5 0)
- (6 ,(caddr form))))))))))
- (compare c.f 48)
- (compare c.un 49)
- (compare c.eq 50)
- (compare c.ueq 51)
- (compare c.olt 52)
- (compare c.ult 53)
- (compare c.ole 54)
- (compare c.ule 55)
- (compare c.sf 56)
- (compare c.ngle 57)
- (compare c.seq 58)
- (compare c.ngl 59)
- (compare c.lt 60)
- (compare c.nge 61)
- (compare c.le 62)
- (compare c.ngt 63))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RTL Rules for MIPS. Shared utilities.
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Register-Allocator Interface
-
-(define (register->register-transfer source target)
- (guarantee-registers-compatible source target)
- (case (register-type source)
- ((GENERAL) (copy source target))
- ((FLOAT) (fp-copy source target))
- (else (error "unknown register type" source))))
-
-(define (home->register-transfer source target)
- (memory->register-transfer (pseudo-register-displacement source)
- regnum:regs-pointer
- target))
-
-(define (register->home-transfer source target)
- (register->memory-transfer source
- (pseudo-register-displacement target)
- regnum:regs-pointer))
-
-(define (reference->register-transfer source target)
- (case (ea/mode source)
- ((GR)
- (copy (register-ea/register source) target))
- ((FPR)
- (fp-copy (fpr->float-register (register-ea/register source)) target))
- ((OFFSET)
- (memory->register-transfer (offset-ea/offset source)
- (offset-ea/register source)
- target))
- (else
- (error "unknown effective-address mode" source))))
-
-(define (pseudo-register-home register)
- ;; Register block consists of 16 4-byte registers followed by 256
- ;; 8-byte temporaries.
- (INST-EA (OFFSET ,(pseudo-register-displacement register)
- ,regnum:regs-pointer)))
-\f
-(define-integrable (sort-machine-registers registers)
- registers)
-
-(define available-machine-registers
- (list
- ;; g0 g1 g2 g3
- ;; g8 g9 g10 g11
- g12 g13 g14 g15 g16 g17 g18
- ;; g19 g20 g21 g22 g23
- g24
- ;; g26 g27 g28 g29
- g30
- g7 g6 g5 g4 g25 ; Allocate last
- ;; g31 ; could be available if handled right
- fp0 fp2 fp4 fp6 fp8 fp10 fp12 fp14
- fp16 fp18 fp20 fp22 fp24 fp26 fp28 fp30
- ;; fp1 fp3 fp5 fp7 fp9 fp11 fp13 fp15
- ;; fp17 fp19 fp21 fp23 fp25 fp27 fp29 fp31
- ))
-
-(define-integrable (float-register? register)
- (eq? (register-type register) 'FLOAT))
-
-(define-integrable (general-register? register)
- (eq? (register-type register) 'GENERAL))
-
-(define-integrable (word-register? register)
- (eq? (register-type register) 'GENERAL))
-
-(define (register-type register)
- (cond ((machine-register? register)
- (vector-ref
- '#(GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
- GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
- GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
- GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
- FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
- FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
- FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
- FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT)
- register))
- ((register-value-class=word? register) 'GENERAL)
- ((register-value-class=float? register) 'FLOAT)
- (else (error "unable to determine register type" register))))
-
-(define register-reference
- (let ((references (make-vector number-of-machine-registers)))
- (let loop ((register 0))
- (if (< register 32)
- (begin
- (vector-set! references register (INST-EA (GR ,register)))
- (loop (1+ register)))))
- (let loop ((register 32) (fpr 0))
- (if (< register 48)
- (begin
- (vector-set! references register (INST-EA (FPR ,fpr)))
- (loop (1+ register) (1+ fpr)))))
- (lambda (register)
- (vector-ref references register))))
-\f
-;;;; Useful Cliches
-
-(define (memory->register-transfer offset base target)
- (case (register-type target)
- ((GENERAL) (LAP (LW ,target (OFFSET ,offset ,base)) (NOP)))
- ((FLOAT) (fp-load-doubleword offset base target #T))
- (else (error "unknown register type" target))))
-
-(define (register->memory-transfer source offset base)
- (case (register-type source)
- ((GENERAL) (LAP (SW ,source (OFFSET ,offset ,base))))
- ((FLOAT) (fp-store-doubleword offset base source))
- (else (error "unknown register type" source))))
-
-(define (load-constant target constant delay-slot? record?)
- ;; Load a Scheme constant into a machine register.
- (if (non-pointer-object? constant)
- (load-immediate target (non-pointer->literal constant) record?)
- (load-pc-relative target
- 'CONSTANT
- (constant->label constant)
- delay-slot?)))
-
-(define (deposit-type-address type source target)
- (deposit-type-datum (fix:xor (quotient #x10 type-scale-factor) type)
- source
- target))
-
-(define (deposit-type-datum type source target)
- (with-values
- (lambda ()
- (immediate->register (make-non-pointer-literal type 0)))
- (lambda (prefix alias)
- (LAP ,@prefix
- (XOR ,target ,alias ,source)))))
-
-(define (non-pointer->literal constant)
- (make-non-pointer-literal (object-type constant)
- (careful-object-datum constant)))
-
-(define-integrable (make-non-pointer-literal type datum)
- (+ (* type (expt 2 scheme-datum-width)) datum))
-\f
-;;;; Regularized Machine Instructions
-
-(define (adjusted:high n)
- (if (fits-in-16-bits-signed? n)
- 0
- (let ((n (->unsigned n)))
- (if (< (remainder n #x10000) #x8000)
- (quotient n #x10000)
- (+ (quotient n #x10000) 1)))))
-
-(define (adjusted:low n)
- (if (fits-in-16-bits-signed? n)
- n
- (let ((remainder (remainder (->unsigned n) #x10000)))
- (if (< remainder #x8000)
- remainder
- (- remainder #x10000)))))
-
-(define-integrable (top-16-bits n)
- (quotient (->unsigned n) #x10000))
-
-(define-integrable (bottom-16-bits n)
- (remainder (->unsigned n) #x10000))
-
-(define (->unsigned n)
- (if (negative? n) (+ #x100000000 n) n))
-
-(define-integrable (fits-in-16-bits-signed? value)
- (<= #x-8000 value #x7fff))
-
-(define-integrable (fits-in-16-bits-unsigned? value)
- (<= #x0 value #xffff))
-
-(define-integrable (top-16-bits-only? value)
- (zero? (bottom-16-bits value)))
-
-(define (copy r t)
- (if (= r t)
- (LAP)
- (LAP (ADD ,t 0 ,r))))
-
-(define (fp-copy from to)
- (if (= to from)
- (LAP)
- (LAP (MOV.D ,(float-register->fpr to)
- ,(float-register->fpr from)))))
-
-;; Handled by VARIABLE-WIDTH in instr1.scm
-
-(define (fp-load-doubleword offset base target NOP?)
- (let* ((least (float-register->fpr target))
- (most (+ least 1)))
- (if (eq? endianness 'LITTLE)
- (LAP (LWC1 ,least (OFFSET ,offset ,base))
- (LWC1 ,most (OFFSET ,(+ offset 4) ,base))
- ,@(if NOP? (LAP (NOP)) (LAP)))
- (LAP (LWC1 ,least (OFFSET ,(+ offset 4) ,base))
- (LWC1 ,most (OFFSET ,offset ,base))
- ,@(if NOP? (LAP (NOP)) (LAP))))))
-
-(define (fp-store-doubleword offset base source)
- (let* ((least (float-register->fpr source))
- (most (+ least 1)))
- (if (eq? endianness 'LITTLE)
- (LAP (SWC1 ,least (OFFSET ,offset ,base))
- (SWC1 ,most (OFFSET ,(+ offset 4) ,base)))
- (LAP (SWC1 ,least (OFFSET ,(+ offset 4) ,base))
- (SWC1 ,most (OFFSET ,offset ,base))))))
-\f
-;;;; PC-relative addresses
-
-(define (load-pc-relative target type label delay-slot?)
- ;; Load a pc-relative location's contents into a machine register.
- ;; Optimization: if there is a register that contains the value of
- ;; another label, use that register as the base register.
- ;; Otherwise, allocate a temporary and load it with the value of the
- ;; label, then use the temporary as the base register. This
- ;; strategy of loading a temporary wins if the temporary is used
- ;; again, but loses if it isn't, since loading the temporary takes
- ;; two instructions in addition to the LW instruction, while doing a
- ;; pc-relative LW instruction takes only two instructions total.
- ;; But pc-relative loads of various kinds are quite common, so this
- ;; should almost always be advantageous.
- (with-values (lambda () (get-typed-label type))
- (lambda (label* alias)
- (if label*
- (LAP (LW ,target (OFFSET (- ,label ,label*) ,alias))
- ,@(if delay-slot? (LAP (NOP)) (LAP)))
- (let ((temporary (standard-temporary!)))
- (set-typed-label! type label temporary)
- (LAP ,@(%load-pc-relative-address temporary label)
- (LW ,target (OFFSET 0 ,temporary))
- ,@(if delay-slot? (LAP (NOP)) (LAP))))))))
-
-(define (load-pc-relative-address target type label)
- ;; Load address of a pc-relative location into a machine register.
- ;; Optimization: if there is another register that contains the
- ;; value of another label, add the difference between the labels to
- ;; that register's contents instead. The ADDI takes one
- ;; instruction, while the %LOAD-PC-RELATIVE-ADDRESS takes two, so
- ;; this is always advantageous.
- (let ((instructions
- (with-values (lambda () (get-typed-label type))
- (lambda (label* alias)
- (if label*
- (LAP (ADDI ,target ,alias (- ,label ,label*)))
- (%load-pc-relative-address target label))))))
- (set-typed-label! type label target)
- instructions))
-
-(define (%load-pc-relative-address target label)
- (let ((label* (generate-label)))
- (LAP (BGEZAL 0 (@PCO 4))
- (LABEL ,label*)
- (ADDI ,target 31 (- ,label (+ ,label* 4))))))
-
-;;; Typed labels provide further optimization. There are two types,
-;;; CODE and CONSTANT, that say whether the label is located in the
-;;; code block or the constants block of the output. Statistically,
-;;; a label is likely to be closer to another label of the same type
-;;; than to a label of the other type.
-
-(define (get-typed-label type)
- (let ((entries (register-map-labels *register-map* 'GENERAL)))
- (let loop ((entries* entries))
- (cond ((null? entries*)
- ;; If no entries of the given type, use any entry that is
- ;; available.
- (let loop ((entries entries))
- (cond ((null? entries)
- (values false false))
- ((pair? (caar entries))
- (values (cdaar entries) (cadar entries)))
- (else
- (loop (cdr entries))))))
- ((and (pair? (caar entries*))
- (eq? type (caaar entries*)))
- (values (cdaar entries*) (cadar entries*)))
- (else
- (loop (cdr entries*)))))))
-
-(define (set-typed-label! type label alias)
- (set! *register-map*
- (set-machine-register-label *register-map* alias (cons type label)))
- unspecific)
-\f
-(define (immediate->register immediate)
- (let ((register (get-immediate-alias immediate)))
- (if register
- (values (LAP) register)
- (let ((temporary (standard-temporary!)))
- (set! *register-map*
- (set-machine-register-label *register-map*
- temporary
- immediate))
- (values (%load-immediate temporary immediate) temporary)))))
-
-(define (get-immediate-alias immediate)
- (let loop ((entries (register-map-labels *register-map* 'GENERAL)))
- (cond ((null? entries)
- false)
- ((eqv? (caar entries) immediate)
- (cadar entries))
- (else
- (loop (cdr entries))))))
-
-(define (load-immediate target immediate record?)
- (let ((registers (get-immediate-aliases immediate)))
- (if (memv target registers)
- (LAP)
- (begin
- (if record?
- (set! *register-map*
- (set-machine-register-label *register-map*
- target
- immediate)))
- (if (not (null? registers))
- (LAP (ADD ,target 0 ,(car registers)))
- (%load-immediate target immediate))))))
-
-(define (get-immediate-aliases immediate)
- (let loop ((entries (register-map-labels *register-map* 'GENERAL)))
- (cond ((null? entries)
- '())
- ((eqv? (caar entries) immediate)
- (append (cdar entries) (loop (cdr entries))))
- (else
- (loop (cdr entries))))))
-
-(define (%load-immediate target immediate)
- (cond ((fits-in-16-bits-signed? immediate)
- (LAP (ADDIU ,target 0 ,immediate)))
- ((fits-in-16-bits-unsigned? immediate)
- (LAP (ORI ,target 0 ,immediate)))
- ((top-16-bits-only? immediate)
- (LAP (LUI ,target ,(top-16-bits immediate))))
- (else
- (LAP (LUI ,target ,(top-16-bits immediate))
- (ORI ,target ,target ,(bottom-16-bits immediate))))))
-
-(define (add-immediate immediate source target)
- (if (fits-in-16-bits-signed? immediate)
- (LAP (ADDIU ,target ,source ,immediate))
- (with-values (lambda () (immediate->register immediate))
- (lambda (prefix alias)
- (LAP ,@prefix
- (ADDU ,target ,source ,alias))))))
-\f
-;;;; Comparisons
-
-(define (compare-immediate comp immediate source)
- ; Branch if immediate <comp> source
- (let ((cc (invert-condition-noncommutative comp)))
- ;; This machine does register <op> immediate; you can
- ;; now think of cc in this way.
- (if (zero? immediate)
- (let ((use-cc
- (lambda (cc)
- (branch-generator! cc
- `(BEQ 0 ,source) `(BLTZ ,source) `(BGTZ ,source)
- `(BNE 0 ,source) `(BGEZ ,source) `(BLEZ ,source))
- (LAP))))
- (case cc
- ((<<) (compare-false))
- ((>>=) (compare-true))
- ((<<=) (use-cc '=))
- ((>>) (use-cc '<>))
- (else (use-cc cc))))
- (with-values (lambda () (immediate->register immediate))
- (lambda (prefix alias)
- (LAP ,@prefix
- ,@(compare comp alias source)))))))
-
-(define (compare condition r1 r2)
- ; Branch if r1 <cc> r2
- (if (= r1 r2)
- (if (memq condition '(< > <> << >>))
- (compare-false)
- (compare-true))
- (let ((temp
- (and (memq condition '(< > <= >= << >> <<= >>=))
- (standard-temporary!))))
- (branch-generator! condition
- `(BEQ ,r1 ,r2) `(BNE ,temp 0) `(BNE ,temp 0)
- `(BNE ,r1 ,r2) `(BEQ ,temp 0) `(BEQ ,temp 0))
- (case condition
- ((= <>) (LAP))
- ((< >=) (LAP (SLT ,temp ,r1 ,r2)))
- ((> <=) (LAP (SLT ,temp ,r2 ,r1)))
- ((<< >>=) (LAP (SLTU ,temp ,r1 ,r2)))
- ((>> <<=) (LAP (SLTU ,temp ,r2 ,r1)))))))
-
-(define (compare-true)
- (set-current-branches!
- (lambda (label) (LAP (BGEZ 0 (@PCR ,label)) (NOP)))
- (lambda (label) label (LAP)))
- (LAP))
-
-(define (compare-false)
- (set-current-branches!
- (lambda (label) label (LAP))
- (lambda (label) (LAP (BGEZ 0 (@PCR ,label)) (NOP))))
- (LAP))
-\f
-(define (branch-generator! cc = < > <> >= <=)
- (let ((forward
- (case cc
- ((=) =)
- ((< <<) <)
- ((> >>) >)
- ((<>) <>)
- ((>= >>=) >=)
- ((<= <<=) <=)))
- (inverse
- (case cc
- ((=) <>)
- ((< <<) >=)
- ((> >>) <=)
- ((<>) =)
- ((>= >>=) <)
- ((<= <<=) >))))
- (set-current-branches!
- (lambda (label)
- (LAP (,@forward (@PCR ,label)) (NOP)))
- (lambda (label)
- (LAP (,@inverse (@PCR ,label)) (NOP))))))
-
-(define (invert-condition condition)
- (let ((place (assq condition condition-inversion-table)))
- (if (not place)
- (error "unknown condition" condition))
- (cadr place)))
-
-(define (invert-condition-noncommutative condition)
- (let ((place (assq condition condition-inversion-table)))
- (if (not place)
- (error "unknown condition" condition))
- (caddr place)))
-
-(define condition-inversion-table
- ; A OP B NOT (A OP B) B OP A
- ; invert invert non-comm.
- '((= <> =)
- (< >= >)
- (> <= <)
- (<> = <>)
- (<= > >=)
- (>= < <=)
- (<< >>= >>)
- (>> <<= <<)
- (<<= >> >>=)
- (>>= << <<=)))
-\f
-;;;; Miscellaneous
-
-(define-integrable (object->type source target)
- ; Type extraction
- (LAP (SRL ,target ,source ,(- 32 scheme-type-width))))
-
-(define-integrable (object->datum source target)
- ; Zero out the type field; don't put in the quad bits
- (LAP (AND ,target ,source ,regnum:address-mask)))
-
-(define (object->address source target)
- ; Drop in the segment bits
- (LAP (AND ,target ,source ,regnum:address-mask)
- (OR ,target ,target ,regnum:quad-bits)))
-
-(define (standard-unary-conversion source target conversion)
- ;; `source' is any register, `target' a pseudo register.
- (let ((source (standard-source! source)))
- (conversion source (standard-target! target))))
-
-(define (standard-binary-conversion source1 source2 target conversion)
- (let ((source1 (standard-source! source1))
- (source2 (standard-source! source2)))
- (conversion source1 source2 (standard-target! target))))
-
-(define (standard-source! register)
- (load-alias-register! register (register-type register)))
-
-(define (standard-target! register)
- (delete-dead-registers!)
- (allocate-alias-register! register (register-type register)))
-
-(define-integrable (standard-temporary!)
- (allocate-temporary-register! 'GENERAL))
-
-(define (standard-move-to-target! source target)
- (move-to-alias-register! source (register-type source) target))
-
-(define (standard-move-to-temporary! source)
- (move-to-temporary-register! source (register-type source)))
-
-(define (register-expression expression)
- (case (rtl:expression-type expression)
- ((REGISTER)
- (rtl:register-number expression))
- ((CONSTANT)
- (let ((object (rtl:constant-value expression)))
- (and (zero? (object-type object))
- (zero? (object-datum object))
- 0)))
- ((CONS-NON-POINTER)
- (and (let ((type (rtl:cons-non-pointer-type expression)))
- (and (rtl:machine-constant? type)
- (zero? (rtl:machine-constant-value type))))
- (let ((datum (rtl:cons-non-pointer-datum expression)))
- (and (rtl:machine-constant? datum)
- (zero? (rtl:machine-constant-value datum))))
- 0))
- (else false)))
-\f
-(define (define-arithmetic-method operator methods method)
- (let ((entry (assq operator (cdr methods))))
- (if entry
- (set-cdr! entry method)
- (set-cdr! methods (cons (cons operator method) (cdr methods)))))
- operator)
-
-(define (lookup-arithmetic-method operator methods)
- (cdr (or (assq operator (cdr methods))
- (error "Unknown operator" operator))))
-
-(define-integrable (arithmetic-method? operator methods)
- (assq operator (cdr methods)))
-
-(define-integrable (ea/mode ea) (car ea))
-(define-integrable (register-ea/register ea) (cadr ea))
-(define-integrable (offset-ea/offset ea) (cadr ea))
-(define-integrable (offset-ea/register ea) (caddr ea))
-
-(define (pseudo-register-displacement register)
- ;; Register block consists of 16 4-byte registers followed by 256
- ;; 8-byte temporaries.
- (+ (* 4 16) (* 8 (register-renumber register))))
-
-(define-integrable (float-register->fpr register)
- ;; Float registers are represented by 32 through 47 in the RTL,
- ;; corresponding to even registers 0 through 30 in the machine.
- (- register 32))
-
-(define-integrable (fpr->float-register register)
- (+ register 32))
-
-(define-integrable reg:memtop
- (INST-EA (OFFSET #x0000 ,regnum:regs-pointer)))
-
-(define-integrable reg:environment
- (INST-EA (OFFSET #x000C ,regnum:regs-pointer)))
-
-(define-integrable reg:lexpr-primitive-arity
- (INST-EA (OFFSET #x001C ,regnum:regs-pointer)))
-
-(define-integrable reg:closure-limit
- (INST-EA (OFFSET #x0024 ,regnum:regs-pointer)))
-
-(define-integrable reg:stack-guard
- (INST-EA (OFFSET #x002C ,regnum:regs-pointer)))
-
-(define (lap:make-label-statement label)
- (LAP (LABEL ,label)))
-
-(define (lap:make-unconditional-branch label)
- (LAP (BEQ 0 0 (@PCR ,label))
- (NOP)))
-
-(define (lap:make-entry-point label block-start-label)
- block-start-label
- (LAP (ENTRY-POINT ,label)
- ,@(make-external-label expression-code-word label)))
-\f
-;;;; Codes and Hooks
-
-(let-syntax ((define-codes
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(BEGIN
- ,@(let loop ((names (cddr form)) (index (cadr form)))
- (if (pair? names)
- (cons `(DEFINE-INTEGRABLE
- ,(symbol-append 'CODE:COMPILER-
- (car names))
- ,index)
- (loop (cdr names) (+ index 1)))
- '())))))))
- (define-codes #x012
- primitive-apply primitive-lexpr-apply
- apply error lexpr-apply link
- interrupt-closure interrupt-dlink interrupt-procedure
- interrupt-continuation interrupt-ic-procedure
- assignment-trap cache-reference-apply
- reference-trap safe-reference-trap unassigned?-trap
- -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero?
- access lookup safe-lookup unassigned? unbound?
- set! define lookup-apply))
-
-(define-integrable (link-to-interface code)
- ;; Jump, with link in 31, to link_to_interface
- (LAP (ADDI ,regnum:assembler-temp ,regnum:scheme-to-interface -100)
- (JALR ,regnum:linkage ,regnum:assembler-temp)
- (ADDI ,regnum:interface-index 0 ,(* 4 code))))
-
-(define-integrable (link-to-trampoline code)
- ;; Jump, with link in 31, to trampoline_to_interface
- (LAP (ADDI ,regnum:assembler-temp ,regnum:scheme-to-interface -96)
- (JALR ,regnum:linkage ,regnum:assembler-temp)
- (ADDI ,regnum:interface-index 0 ,(* 4 code))))
-
-(define-integrable (invoke-interface code)
- ;; Jump to scheme-to-interface
- (LAP (JR ,regnum:scheme-to-interface)
- (ADDI ,regnum:interface-index 0 ,(* 4 code))))
-\f
-(define (load-interface-args! first second third fourth)
- (let ((clear-regs
- (apply clear-registers!
- (append (if first (list regnum:first-arg) '())
- (if second (list regnum:second-arg) '())
- (if third (list regnum:third-arg) '()))))
- (load-reg
- (lambda (reg arg)
- (if reg (load-machine-register! reg arg) (LAP)))))
- (let ((load-regs
- (LAP ,@(load-reg first regnum:second-arg)
- ,@(load-reg second regnum:third-arg)
- ,@(load-reg third regnum:fourth-arg)
- ,@(if fourth
- (let ((temp (standard-temporary!)))
- (LAP
- ,@(load-machine-register! fourth temp)
- (SW ,temp
- (OFFSET 16 ,regnum:C-stack-pointer))))
- (LAP)))))
- (LAP ,@clear-regs
- ,@load-regs
- ,@(clear-map!)))))
-
-(define (require-register! machine-reg)
- (flush-register! machine-reg)
- (need-register! machine-reg))
-
-(define-integrable (flush-register! machine-reg)
- (prefix-instructions! (clear-registers! machine-reg)))
-
-(define (rtl-target:=machine-register! rtl-reg machine-reg)
- (if (machine-register? rtl-reg)
- (begin
- (require-register! machine-reg)
- (if (not (= rtl-reg machine-reg))
- (suffix-instructions!
- (register->register-transfer machine-reg rtl-reg))))
- (begin
- (delete-register! rtl-reg)
- (flush-register! machine-reg)
- (add-pseudo-register-alias! rtl-reg machine-reg))))
-
-
-(define (pre-lapgen-analysis rgraphs)
- rgraphs
- unspecific)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Optimizer for MIPS.
-
-(declare (usual-integrations))
-\f
-(define (optimize-linear-lap instructions)
- ;; Find occurrences of LW/LBU/LWC1 followed by NOP, and delete the
- ;; NOP if the instruction following it has no reference to the
- ;; target register of the load.
-
- ;; **** This is pretty fragile. ****
- (letrec
- ((find-load
- (lambda (instructions)
- (cond ((null? instructions) '())
- ((and (pair? (car instructions))
- (or (eq? 'LW (caar instructions))
- (eq? 'LBU (caar instructions))
- (eq? 'LWC1 (caar instructions))))
- instructions)
- (else (find-load (cdr instructions))))))
- (get-next
- (lambda (instructions)
- (let ((instructions (cdr instructions)))
- (cond ((null? instructions) '())
- ((or (not (pair? (car instructions)))
- (eq? 'LABEL (caar instructions))
- (eq? 'COMMENT (caar instructions)))
- (get-next instructions))
- (else instructions)))))
- (refers-to-register?
- (lambda (instruction register)
- (let loop ((x instruction))
- (if (pair? x)
- (or (loop (car x))
- (loop (cdr x)))
- (eqv? register x))))))
- (let loop ((instructions instructions))
- (let ((first (find-load instructions)))
- (if (not (null? first))
- (let ((second (get-next first)))
- (if (not (null? second))
- (let ((third (get-next second)))
- (if (not (null? third))
- (if (and (equal? '(NOP) (car second))
- ;; This is a crude way to test for a
- ;; reference to the target register
- ;; -- it will sometimes incorrectly
- ;; say that there is a reference, but
- ;; it will never incorrectly say that
- ;; there is no reference.
- (not (refers-to-register? (car third)
- (cadar first)))
- (or (not (and (eq? 'LWC1 (caar first))
- (odd? (cadar first))))
- (not (refers-to-register?
- (car third)
- (- (cadar first) 1)))))
- (begin
- (let loop ((this (cdr first)) (prev first))
- (if (eq? second this)
- (set-cdr! prev (cdr this))
- (loop (cdr this) this)))
- (loop (if (equal? '(NOP) (car third))
- first
- third)))
- (loop second))))))))))
- instructions)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Machine Model for MIPS
-;;; package: (compiler)
-
-(declare (usual-integrations))
-\f
-;;;; Architecture Parameters
-
-(define use-pre/post-increment? false)
-(define endianness 'LITTLE)
-(define-integrable addressing-granularity 8)
-(define-integrable scheme-object-width 32)
-(define-integrable scheme-type-width 6) ;or 8
-(define-integrable type-scale-factor (expt 2 (- 8 scheme-type-width)))
-
-(define-integrable scheme-datum-width
- (- scheme-object-width scheme-type-width))
-
-(define-integrable float-width 64)
-(define-integrable float-alignment 64)
-
-(define-integrable address-units-per-float
- (quotient float-width addressing-granularity))
-
-;;; It is currently required that both packed characters and objects
-;;; be integrable numbers of address units. Furthermore, the number
-;;; of address units per object must be an integral multiple of the
-;;; number of address units per character. This will cause problems
-;;; on a machine that is word addressed, in which case we will have to
-;;; rethink the character addressing strategy.
-
-(define-integrable address-units-per-object
- (quotient scheme-object-width addressing-granularity))
-
-(define-integrable address-units-per-packed-char 1)
-
-(define-integrable signed-fixnum/upper-limit (expt 2 (-1+ scheme-datum-width)))
-(define-integrable signed-fixnum/lower-limit (- signed-fixnum/upper-limit))
-(define-integrable unsigned-fixnum/upper-limit (* 2 signed-fixnum/upper-limit))
-
-(define-integrable (stack->memory-offset offset) offset)
-(define-integrable ic-block-first-parameter-offset 2)
-(define-integrable execute-cache-size 2) ; Long words per UUO link slot
-(define-integrable closure-entry-size
- ;; Long words in a single closure entry:
- ;; Format + GC offset word
- ;; JALR/JAL
- ;; ADDI
- 3)
-
-;; Given: the number of entry points in a closure, and a particular
-;; entry point number. Return: the distance from that entry point to
-;; the first variable slot in the closure (in words).
-
-(define (closure-first-offset nentries entry)
- (if (zero? nentries)
- 1 ; Strange boundary case
- (- (* closure-entry-size (- nentries entry)) 1)))
-
-;; Like the above, but from the start of the complete closure object,
-;; viewed as a vector, and including the header word.
-
-(define (closure-object-first-offset nentries)
- (case nentries
- ((0)
- ;; Vector header only
- 1)
- ((1)
- ;; Manifest closure header followed by single entry point
- (+ 1 closure-entry-size))
- (else
- ;; Manifest closure header, number of entries, then entries.
- (+ 1 1 (* closure-entry-size nentries)))))
-
-;; Bump from one entry point to another -- distance in BYTES
-
-(define (closure-entry-distance nentries entry entry*)
- nentries ; ignored
- (* (* closure-entry-size 4) (- entry* entry)))
-
-;; Bump to the canonical entry point. On a RISC (which forces
-;; longword alignment for entry points anyway) there is no need to
-;; canonicalize.
-
-(define (closure-environment-adjustment nentries entry)
- nentries entry ; ignored
- 0)
-\f
-;;;; Machine Registers
-
-(define-integrable g0 0)
-(define-integrable g1 1)
-(define-integrable g2 2)
-(define-integrable g3 3)
-(define-integrable g4 4)
-(define-integrable g5 5)
-(define-integrable g6 6)
-(define-integrable g7 7)
-(define-integrable g8 8)
-(define-integrable g9 9)
-(define-integrable g10 10)
-(define-integrable g11 11)
-(define-integrable g12 12)
-(define-integrable g13 13)
-(define-integrable g14 14)
-(define-integrable g15 15)
-(define-integrable g16 16)
-(define-integrable g17 17)
-(define-integrable g18 18)
-(define-integrable g19 19)
-(define-integrable g20 20)
-(define-integrable g21 21)
-(define-integrable g22 22)
-(define-integrable g23 23)
-(define-integrable g24 24)
-(define-integrable g25 25)
-(define-integrable g26 26)
-(define-integrable g27 27)
-(define-integrable g28 28)
-(define-integrable g29 29)
-(define-integrable g30 30)
-(define-integrable g31 31)
-
-;; Floating point general registers -- the odd numbered ones are
-;; only used when transferring to/from the CPU
-(define-integrable fp0 32)
-(define-integrable fp1 33)
-(define-integrable fp2 34)
-(define-integrable fp3 35)
-(define-integrable fp4 36)
-(define-integrable fp5 37)
-(define-integrable fp6 38)
-(define-integrable fp7 39)
-(define-integrable fp8 40)
-(define-integrable fp9 41)
-(define-integrable fp10 42)
-(define-integrable fp11 43)
-(define-integrable fp12 44)
-(define-integrable fp13 45)
-(define-integrable fp14 46)
-(define-integrable fp15 47)
-(define-integrable fp16 48)
-(define-integrable fp17 49)
-(define-integrable fp18 50)
-(define-integrable fp19 51)
-(define-integrable fp20 52)
-(define-integrable fp21 53)
-(define-integrable fp22 54)
-(define-integrable fp23 55)
-(define-integrable fp24 56)
-(define-integrable fp25 57)
-(define-integrable fp26 58)
-(define-integrable fp27 59)
-(define-integrable fp28 60)
-(define-integrable fp29 61)
-(define-integrable fp30 62)
-(define-integrable fp31 63)
-
-(define-integrable number-of-machine-registers 63)
-(define-integrable number-of-temporary-registers 256)
-\f
-;;; Fixed-use registers for Scheme compiled code.
-(define-integrable regnum:return-value g2)
-(define-integrable regnum:stack-pointer g3)
-(define-integrable regnum:memtop g8)
-(define-integrable regnum:free g9)
-(define-integrable regnum:scheme-to-interface g10)
-(define-integrable regnum:dynamic-link g11)
-(define-integrable regnum:closure-free g19)
-(define-integrable regnum:address-mask g20)
-(define-integrable regnum:regs-pointer g21)
-(define-integrable regnum:quad-bits g22)
-(define-integrable regnum:closure-hook g23)
-(define-integrable regnum:interface-index g25)
-
-;;; Fixed-use registers due to architecture or OS calling conventions.
-(define-integrable regnum:zero g0)
-(define-integrable regnum:assembler-temp g1)
-(define-integrable regnum:C-return-value g2)
-(define-integrable regnum:first-arg g4)
-(define-integrable regnum:second-arg g5)
-(define-integrable regnum:third-arg g6)
-(define-integrable regnum:fourth-arg g7)
-(define-integrable regnum:kernel-reserved-1 g26)
-(define-integrable regnum:kernel-reserved-2 g27)
-(define-integrable regnum:C-global-pointer g28)
-(define-integrable regnum:C-stack-pointer g29)
-(define-integrable regnum:linkage g31)
-
-(define machine-register-value-class
- (let ((special-registers
- `((,regnum:return-value . ,value-class=object)
- (,regnum:stack-pointer . ,value-class=address)
- (,regnum:memtop . ,value-class=address)
- (,regnum:free . ,value-class=address)
- (,regnum:scheme-to-interface . ,value-class=unboxed)
- (,regnum:closure-hook . ,value-class=unboxed)
- (,regnum:closure-free . ,value-class=unboxed)
- (,regnum:dynamic-link . ,value-class=address)
- (,regnum:address-mask . ,value-class=immediate)
- (,regnum:regs-pointer . ,value-class=unboxed)
- (,regnum:quad-bits . ,value-class=immediate)
- (,regnum:assembler-temp . ,value-class=unboxed)
- (,regnum:kernel-reserved-1 . ,value-class=unboxed)
- (,regnum:kernel-reserved-2 . ,value-class=unboxed)
- (,regnum:C-global-pointer . ,value-class=unboxed)
- (,regnum:C-stack-pointer . ,value-class=unboxed)
- (,regnum:linkage . ,value-class=address))))
- (lambda (register)
- (let ((lookup (assv register special-registers)))
- (cond
- ((not (null? lookup)) (cdr lookup))
- ((<= g0 register g31) value-class=word)
- ((<= fp0 register fp31) value-class=float)
- (else (error "illegal machine register" register)))))))
-
-(define-integrable (machine-register-known-value register)
- register ;ignore
- false)
-\f
-;;;; Interpreter Registers
-
-(define-integrable (interpreter-free-pointer)
- (rtl:make-machine-register regnum:free))
-
-(define (interpreter-free-pointer? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:free)))
-
-(define-integrable (interpreter-regs-pointer)
- (rtl:make-machine-register regnum:regs-pointer))
-
-(define (interpreter-regs-pointer? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:regs-pointer)))
-
-(define-integrable (interpreter-value-register)
- (rtl:make-machine-register regnum:return-value))
-
-(define (interpreter-value-register? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:return-value)))
-
-(define-integrable (interpreter-stack-pointer)
- (rtl:make-machine-register regnum:stack-pointer))
-
-(define (interpreter-stack-pointer? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:stack-pointer)))
-
-(define-integrable (interpreter-dynamic-link)
- (rtl:make-machine-register regnum:dynamic-link))
-
-(define (interpreter-dynamic-link? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:dynamic-link)))
-
-(define-integrable (interpreter-environment-register)
- (rtl:make-offset (interpreter-regs-pointer)
- (rtl:make-machine-constant 3)))
-
-(define (interpreter-environment-register? expression)
- (and (rtl:offset? expression)
- (interpreter-regs-pointer? (rtl:offset-base expression))
- (let ((offset (rtl:offset-offset expression)))
- (and (rtl:machine-constant? offset)
- (= 3 (rtl:machine-constant-value offset))))))
-
-(define-integrable (interpreter-register:access)
- (rtl:make-machine-register regnum:C-return-value))
-
-(define-integrable (interpreter-register:cache-reference)
- (rtl:make-machine-register regnum:C-return-value))
-
-(define-integrable (interpreter-register:cache-unassigned?)
- (rtl:make-machine-register regnum:C-return-value))
-
-(define-integrable (interpreter-register:lookup)
- (rtl:make-machine-register regnum:C-return-value))
-
-(define-integrable (interpreter-register:unassigned?)
- (rtl:make-machine-register regnum:C-return-value))
-
-(define-integrable (interpreter-register:unbound?)
- (rtl:make-machine-register regnum:C-return-value))
-\f
-;;;; RTL Registers, Constants, and Primitives
-
-(define (rtl:machine-register? rtl-register)
- (case rtl-register
- ((STACK-POINTER)
- (interpreter-stack-pointer))
- ((DYNAMIC-LINK)
- (interpreter-dynamic-link))
- ((VALUE)
- (interpreter-value-register))
- ((MEMORY-TOP)
- (rtl:make-machine-register regnum:memtop))
- ((FREE)
- (interpreter-free-pointer))
- ((INTERPRETER-CALL-RESULT:ACCESS)
- (interpreter-register:access))
- ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
- (interpreter-register:cache-reference))
- ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
- (interpreter-register:cache-unassigned?))
- ((INTERPRETER-CALL-RESULT:LOOKUP)
- (interpreter-register:lookup))
- ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
- (interpreter-register:unassigned?))
- ((INTERPRETER-CALL-RESULT:UNBOUND?)
- (interpreter-register:unbound?))
- (else false)))
-
-(define (rtl:interpreter-register? rtl-register)
- (case rtl-register
- ((INT-MASK) 1)
- ((ENVIRONMENT) 3)
- ((TEMPORARY) 4)
- (else false)))
-
-(define (rtl:interpreter-register->offset locative)
- (or (rtl:interpreter-register? locative)
- (error "Unknown register type" locative)))
-\f
-(define (rtl:constant-cost expression)
- ;; Magic numbers.
- (let ((if-integer
- (lambda (value)
- (cond ((zero? value) 1)
- ((or (fits-in-16-bits-signed? value)
- (fits-in-16-bits-unsigned? value)
- (top-16-bits-only? value))
- 2)
- (else 3)))))
- (let ((if-synthesized-constant
- (lambda (type datum)
- (if-integer (make-non-pointer-literal type datum)))))
- (case (rtl:expression-type expression)
- ((CONSTANT)
- (let ((value (rtl:constant-value expression)))
- (if (non-pointer-object? value)
- (if-synthesized-constant (object-type value)
- (object-datum value))
- 3)))
- ((MACHINE-CONSTANT)
- (if-integer (rtl:machine-constant-value expression)))
- ((ENTRY:PROCEDURE ENTRY:CONTINUATION
- ASSIGNMENT-CACHE VARIABLE-CACHE
- OFFSET-ADDRESS BYTE-OFFSET-ADDRESS FLOAT-OFFSET-ADDRESS)
- 3)
- ((CONS-NON-POINTER)
- (and (rtl:machine-constant? (rtl:cons-non-pointer-type expression))
- (rtl:machine-constant? (rtl:cons-non-pointer-datum expression))
- (if-synthesized-constant
- (rtl:machine-constant-value
- (rtl:cons-non-pointer-type expression))
- (rtl:machine-constant-value
- (rtl:cons-non-pointer-datum expression)))))
- (else false)))))
-
-(define compiler:open-code-floating-point-arithmetic?
- true)
-
-(define compiler:primitives-with-no-open-coding
- '(DIVIDE-FIXNUM GCD-FIXNUM FIXNUM-QUOTIENT FIXNUM-REMAINDER
- INTEGER-QUOTIENT INTEGER-REMAINDER &/ QUOTIENT REMAINDER
- FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN FLONUM-ACOS FLONUM-ATAN2
- FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-REMAINDER FLONUM-SQRT
- FLONUM-TRUNCATE FLONUM-ROUND FLONUM-CEILING FLONUM-FLOOR
- VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS
- FLONUM-EXPM1 FLONUM-LOG1P))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Compiler: System Construction
-
-(declare (usual-integrations))
-
-((load "base/make") "MIPS")
-(environment-assign! (->environment '(COMPILER)) 'ENDIANNESS 'BIG)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Compiler: System Construction
-
-(declare (usual-integrations))
-
-((load "base/make") "MIPS")
-(environment-assign! (->environment '(COMPILER)) 'ENDIANNESS 'LITTLE)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; MIPS instruction set
-
-(declare (usual-integrations))
-\f
-(let-syntax
- ((opcodes
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(BEGIN
- ,@(let loop ((names (caddr form)) (value 0))
- (if (pair? names)
- (if (symbol? (car names))
- (cons `(DEFINE-INTEGRABLE
- ,(symbol-append (car names) (cadr form))
- ,value)
- (loop (cdr names) (+ value 1)))
- (loop (cdr names) (+ value 1)))
- '())))))))
- ; OP CODES
- (opcodes '-OP
- (special bcond j jal beq bne blez bgtz ; 0 - 7
- addi addiu slti sltiu andi ori xori lui ; 8 - 15
- cop0 cop1 cop2 cop3 () () () () ; 16 - 23
- () () () () () () () () ; 24 - 31
- lb lh lwl lw lbu lhu lwr () ; 32 - 39
- sb sh swl sw () () swr () ; 40 - 47
- lwc0 lwc1 lwc2 lwc3 () () () () ; 48 - 55
- swc0 swc1 swc2 swc3 () () () ())) ; 56 - 63
-
- ; Special Function Codes
- (opcodes '-FUNCT
- (sll () srl sra sllv () srlv srav ; 0 - 7
- jr jalr () () syscall break () () ; 8 - 15
- mfhi mthi mflo mtlo () () () () ; 16 - 23
- mult multu div divu () () () () ; 24 - 31
- add addu sub subu and or xor nor ; 32 - 39
- () () slt sltu () () () () ; 40 - 47
- () () () () () () () () ; 48 - 55
- () () () () () () () ())) ; 56 - 63
-
- ; Condition codes for BCOND
- (opcodes '-COND
- (bltz bgez () () () () () () ; 0 - 7
- () () () () () () () () ; 8 - 15
- bltzal bgezal () () () () () () ; 16 - 23
- () () () () () () () ())) ; 24 - 31
-
- ; Floating point function codes for use with COP1 instruction
- (opcodes 'F-OP
- (add sub mul div () abs mov neg ; 0 - 7
- () () () () () () () () ; 8 - 15
- () () () () () () () () ; 16 - 23
- () () () () () () () () ; 24 - 31
- cvt.s cvt.d () () cvt.w () () () ; 32 - 39
- () () () () () () () () ; 40 - 47
- c.f c.un c.eq c.ueq c.olt c.ult c.ole c.ule ; 48 - 55
- c.sf c.ngle c.seq c.ngl c.lt c.nge c.le c.ngt)) ; 56 - 63
-) ; let-syntax
-
-; Operations on co-processors (for BCzFD, BCzT, CFCz, COPz, CTCz,
-; MFCz, and MTCz instructions)
-; This is confusing ... according to the diagrams, these occupy bits
-; 16 through 25, inclusive (10 bits). But the tables indicate that
-; only bits 16, and 21 through 25 matter. In fact, bit 25 is always 0
-; since that denotes a COPz instruction; hence COPz has 32 encodings
-; and all the others have two encodings.
-
-(define-integrable mf-cp-op #x000)
-(define-integrable mt-cp-op #x080)
-(define-integrable bcf-cp-op #x100)
-(define-integrable bct-cp-op #x101)
-(define-integrable cf-cp-op #x040)
-(define-integrable ct-cp-op #x0C0)
-
-(define-integrable mf-cp-op-alternate #x001)
-(define-integrable mt-cp-op-alternate #x081)
-(define-integrable bcf-cp-op-alternate #x180)
-(define-integrable bct-cp-op-alternate #x181)
-(define-integrable cf-cp-op-alternate #x041)
-(define-integrable ct-cp-op-alternate #x0C1)
-
-; Operations on co-processor 0
-(define-integrable cop0-op:tlbr 1)
-(define-integrable cop0-op:tlbwi 2)
-(define-integrable cop0-op:tlbwr 6)
-(define-integrable cop0-op:tlbp 8)
-(define-integrable cop0-op:rfe 16)
-
-; Floating point formats
-(define-integrable single-precision-float 0)
-(define-integrable double-precision-float 1)
+++ /dev/null
-#| -*-Scheme-*-
-
-$MC68020-Header: rgspcm.scm,v 4.1 87/12/30 07:05:38 GMT cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RTL Generation: Special primitive combinations. MIPS version.
-
-(declare (usual-integrations))
-\f
-(define (define-special-primitive-handler name handler)
- (let ((primitive (make-primitive-procedure name true)))
- (let ((entry (assq primitive special-primitive-handlers)))
- (if entry
- (set-cdr! entry handler)
- (set! special-primitive-handlers
- (cons (cons primitive handler)
- special-primitive-handlers)))))
- name)
-
-(define (special-primitive-handler primitive)
- (let ((entry (assq primitive special-primitive-handlers)))
- (and entry
- (cdr entry))))
-
-(define special-primitive-handlers
- '())
-
-(define (define-special-primitive/standard primitive)
- (define-special-primitive-handler primitive
- rtl:make-invocation:special-primitive))
-
-(define-special-primitive/standard '&+)
-(define-special-primitive/standard '&-)
-;; (define-special-primitive/standard '&*)
-(define-special-primitive/standard '&/)
-(define-special-primitive/standard '&=)
-(define-special-primitive/standard '&<)
-(define-special-primitive/standard '&>)
-(define-special-primitive/standard '1+)
-(define-special-primitive/standard '-1+)
-(define-special-primitive/standard 'zero?)
-(define-special-primitive/standard 'positive?)
-(define-special-primitive/standard 'negative?)
-
-
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Data Transfers
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Simple Operations
-
-;;; All assignments to pseudo registers are required to delete the
-;;; dead registers BEFORE performing the assignment. However, it is
-;;; necessary to derive the effective address of the source
-;;; expression(s) before deleting the dead registers. Otherwise any
-;;; source expression containing dead registers might refer to aliases
-;;; which have been reused.
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
- (standard-move-to-target! source target)
- (LAP))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum))))
- (let* ((type (standard-move-to-temporary! type))
- (target (standard-move-to-target! datum target)))
- (LAP (SLL ,type ,type ,(- 32 scheme-type-width))
- (AND ,target ,target ,regnum:address-mask)
- (OR ,target ,type ,target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-NON-POINTER (REGISTER (? type)) (REGISTER (? datum))))
- (let* ((type (standard-move-to-temporary! type))
- (target (standard-move-to-target! datum target)))
- (LAP (SLL ,type ,type ,(- 32 scheme-type-width))
- (OR ,target ,type ,target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source))))
- (standard-unary-conversion source target
- (lambda (source target)
- (deposit-type-address type source target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source))))
- (standard-unary-conversion source target
- (lambda (source target)
- (deposit-type-datum type source target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
- (standard-unary-conversion source target object->type))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
- (standard-unary-conversion source target object->datum))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
- (standard-unary-conversion source target object->address))
-\f
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OFFSET-ADDRESS (REGISTER (? base))
- (REGISTER (? index))))
- (shifted-add target base index 2))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OFFSET-ADDRESS (REGISTER (? source))
- (MACHINE-CONSTANT (? offset))))
- (standard-unary-conversion source target
- (lambda (source target)
- (add-immediate (* 4 offset) source target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET-ADDRESS (REGISTER (? base))
- (REGISTER (? index))))
- (shifted-add target base index 0))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET-ADDRESS (REGISTER (? source))
- (MACHINE-CONSTANT (? offset))))
- (standard-unary-conversion source target
- (lambda (source target)
- (add-immediate offset source target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET-ADDRESS (REGISTER (? base))
- (REGISTER (? index))))
- (shifted-add target base index 3))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET-ADDRESS (REGISTER (? source))
- (MACHINE-CONSTANT (? offset))))
- (standard-unary-conversion source target
- (lambda (source target)
- (add-immediate (* 8 offset) source target))))
-
-(define (shifted-add target base index shift)
- (if (zero? shift)
- (standard-binary-conversion base index target
- (lambda (base index target)
- (LAP (ADDU ,target ,base ,index))))
- (let ((base (standard-source! base))
- (index (standard-source! index))
- (temp (standard-temporary!)))
- (let ((target (standard-target! target)))
- (LAP (SLL ,temp ,index ,shift)
- (ADDU ,target ,base ,temp))))))
-
-(define (with-indexed-address base index shift recvr)
- (let ((base (standard-source! base))
- (index (standard-source! index))
- (temp (standard-temporary!)))
- (if (zero? shift)
- (LAP (ADDU ,temp ,base ,index)
- ,@(recvr temp))
- (LAP (SLL ,temp ,index ,shift)
- (ADDU ,temp ,base ,temp)
- ,@(recvr temp)))))
-\f
-;;;; Loading of Constants
-
-(define-rule statement
- ;; load a machine constant
- (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? source)))
- (load-immediate (standard-target! target) source #T))
-
-(define-rule statement
- ;; load a Scheme constant
- (ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
- (load-constant (standard-target! target) source #T #T))
-
-(define-rule statement
- ;; load the type part of a Scheme constant
- (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (CONSTANT (? constant))))
- (load-immediate (standard-target! target)
- (make-non-pointer-literal 0 (object-type constant))
- #T))
-
-(define-rule statement
- ;; load the datum part of a Scheme constant
- (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant))))
- (QUALIFIER (non-pointer-object? constant))
- (load-immediate (standard-target! target)
- (make-non-pointer-literal 0 (careful-object-datum constant))
- #T))
-
-(define-rule statement
- ;; load a synthesized constant
- (ASSIGN (REGISTER (? target))
- (CONS-NON-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum))))
- (load-immediate (standard-target! target)
- (make-non-pointer-literal type datum)
- #T))
-\f
-(define-rule statement
- ;; load the address of a variable reference cache
- (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
- (load-pc-relative (standard-target! target)
- 'CONSTANT
- (free-reference-label name)
- true))
-
-(define-rule statement
- ;; load the address of an assignment cache
- (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name)))
- (load-pc-relative (standard-target! target)
- 'CONSTANT
- (free-assignment-label name)
- true))
-
-(define-rule statement
- ;; load the address of a procedure's entry point
- (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label)))
- (load-pc-relative-address (standard-target! target) 'CODE label))
-
-(define-rule statement
- ;; load the address of a continuation
- (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label)))
- (load-pc-relative-address (standard-target! target) 'CODE label))
-
-(define-rule statement
- ;; load a procedure object
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (ENTRY:PROCEDURE (? label))))
- (load-entry target type label))
-
-(define-rule statement
- ;; load a return address object
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (ENTRY:CONTINUATION (? label))))
- (load-entry target type label))
-
-(define (load-entry target type label)
- (let ((temporary (standard-temporary!))
- (target (standard-target! target)))
- ;; Loading the address into a temporary makes it more useful,
- ;; because it can be reused later.
- (LAP ,@(load-pc-relative-address temporary 'CODE label)
- ,@(deposit-type-address type temporary target))))
-\f
-;;;; Transfers from memory
-
-#|
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OFFSET (REGISTER (? base)) (REGISTER (? index))))
- (with-indexed-address base index 2
- (lambda (address)
- (let ((target (standard-target! target)))
- (LAP (LW ,target (OFFSET 0 ,address))
- (NOP))))))
-|#
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OFFSET (REGISTER (? address)) (MACHINE-CONSTANT (? offset))))
- (standard-unary-conversion address target
- (lambda (address target)
- (LAP (LW ,target (OFFSET ,(* 4 offset) ,address))
- (NOP)))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 3) 1))
- (LAP (LW ,(standard-target! target) (OFFSET 0 ,regnum:stack-pointer))
- (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4)))
-
-;;;; Transfers to memory
-
-#|
-(define-rule statement
- ;; store an object in memory
- (ASSIGN (OFFSET (REGISTER (? base)) (REGISTER (? index)))
- (? source register-expression))
- (QUALIFIER (word-register? source))
- (with-indexed-address base index 2
- (lambda (address)
- (LAP (SW ,(standard-source! source) (OFFSET 0 ,address))))))
-|#
-
-(define-rule statement
- ;; store an object in memory
- (ASSIGN (OFFSET (REGISTER (? address)) (MACHINE-CONSTANT (? offset)))
- (? source register-expression))
- (QUALIFIER (word-register? source))
- (LAP (SW ,(standard-source! source)
- (OFFSET ,(* 4 offset) ,(standard-source! address)))))
-
-(define-rule statement
- ;; Push an object register on the heap
- (ASSIGN (POST-INCREMENT (REGISTER 9) 1)
- (? source register-expression))
- (QUALIFIER (word-register? source))
- (LAP (SW ,(standard-source! source) (OFFSET 0 ,regnum:free))
- (ADDI ,regnum:free ,regnum:free 4)))
-
-(define-rule statement
- ;; Push an object register on the stack
- (ASSIGN (PRE-INCREMENT (REGISTER 3) -1)
- (? source register-expression))
- (QUALIFIER (word-register? source))
- (LAP (ADDI ,regnum:stack-pointer ,regnum:stack-pointer -4)
- (SW ,(standard-source! source)
- (OFFSET 0 ,regnum:stack-pointer))))
-\f
-;; Cheaper, common patterns.
-
-#|
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? base)) (REGISTER (? index)))
- (MACHINE-CONSTANT 0))
- (with-indexed-address base index 2
- (lambda (address)
- (LAP (SW 0 (OFFSET 0 ,address))))))
-|#
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? address)) (MACHINE-CONSTANT (? offset)))
- (MACHINE-CONSTANT 0))
- (LAP (SW 0 (OFFSET ,(* 4 offset) ,(standard-source! address)))))
-
-(define-rule statement
- ; Push NIL (or whatever is represented by a machine 0) on heap
- (ASSIGN (POST-INCREMENT (REGISTER 9) 1) (MACHINE-CONSTANT 0))
- (LAP (SW 0 (OFFSET 0 ,regnum:free))
- (ADDI ,regnum:free ,regnum:free 4)))
-
-(define-rule statement
- ; Ditto, but on stack
- (ASSIGN (PRE-INCREMENT (REGISTER 3) -1) (MACHINE-CONSTANT 0))
- (LAP (ADDI ,regnum:stack-pointer ,regnum:stack-pointer -4)
- (SW 0 (OFFSET 0 ,regnum:stack-pointer))))
-\f
-;;;; CHAR->ASCII/BYTE-OFFSET
-
-#|
-(define-rule statement
- ;; load char object from memory and convert to ASCII byte
- (ASSIGN (REGISTER (? target))
- (CHAR->ASCII (OFFSET (REGISTER (? base))
- (REGISTER (? index)))))
- (with-indexed-address base index 2
- (lambda (address)
- (let ((target (standard-target! target)))
- (LAP (LBU ,target
- (OFFSET ,(if (eq? endianness 'LITTLE)
- 0
- 3)
- ,address))
- (NOP))))))
-|#
-
-(define-rule statement
- ;; load char object from memory and convert to ASCII byte
- (ASSIGN (REGISTER (? target))
- (CHAR->ASCII (OFFSET (REGISTER (? address))
- (MACHINE-CONSTANT (? offset)))))
- (standard-unary-conversion address target
- (lambda (address target)
- (LAP (LBU ,target
- (OFFSET ,(let ((offset (* 4 offset)))
- (if (eq? endianness 'LITTLE)
- offset
- (+ offset 3)))
- ,address))
- (NOP)))))
-
-#|
-(define-rule statement
- ;; load ASCII byte from memory
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET (REGISTER (? base))
- (REGISTER (? index))))
- (with-indexed-address base index 0
- (lambda (address)
- (let ((target (standard-target! target)))
- (LAP (LBU ,target (OFFSET 0 ,address))
- (NOP))))))
-|#
-
-(define-rule statement
- ;; load ASCII byte from memory
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET (REGISTER (? address))
- (MACHINE-CONSTANT (? offset))))
- (standard-unary-conversion address target
- (lambda (address target)
- (LAP (LBU ,target (OFFSET ,offset ,address))
- (NOP)))))
-\f
-(define-rule statement
- ;; convert char object to ASCII byte
- ;; Missing optimization: If source is home and this is the last
- ;; reference (it is dead afterwards), an LB could be done instead of
- ;; an LW followed by an ANDI. This is unlikely since the value will
- ;; be home only if we've spilled it, which happens rarely.
- (ASSIGN (REGISTER (? target))
- (CHAR->ASCII (REGISTER (? source))))
- (standard-unary-conversion source target
- (lambda (source target)
- (LAP (ANDI ,target ,source #xFF)))))
-
-#|
-(define-rule statement
- ;; store null byte in memory
- (ASSIGN (BYTE-OFFSET (REGISTER (? base))
- (REGISTER (? index)))
- (CHAR->ASCII (CONSTANT #\NUL)))
- (with-indexed-address base index 0
- (lambda (address)
- (LAP (SB 0 (OFFSET 0 ,address))))))
-|#
-
-(define-rule statement
- ;; store null byte in memory
- (ASSIGN (BYTE-OFFSET (REGISTER (? source))
- (MACHINE-CONSTANT (? offset)))
- (CHAR->ASCII (CONSTANT #\NUL)))
- (LAP (SB 0 (OFFSET ,offset ,(standard-source! source)))))
-
-#|
-(define-rule statement
- ;; store ASCII byte in memory
- (ASSIGN (BYTE-OFFSET (REGISTER (? base))
- (REGISTER (? index)))
- (REGISTER (? source)))
- (with-indexed-address base index 0
- (lambda (address)
- (LAP (SB ,(standard-source! source) (OFFSET 0 ,address))))))
-|#
-
-(define-rule statement
- ;; store ASCII byte in memory
- (ASSIGN (BYTE-OFFSET (REGISTER (? address))
- (MACHINE-CONSTANT (? offset)))
- (REGISTER (? source)))
- (LAP (SB ,(standard-source! source)
- (OFFSET ,offset ,(standard-source! address)))))
-
-#|
-(define-rule statement
- ;; convert char object to ASCII byte and store it in memory
- ;; register + byte offset <- contents of register (clear top bits)
- (ASSIGN (BYTE-OFFSET (REGISTER (? base)) (REGISTER (? index)))
- (CHAR->ASCII (REGISTER (? source))))
- (with-indexed-address base index 0
- (lambda (address)
- (LAP (SB ,(standard-source! source) (OFFSET 0 ,address))))))
-|#
-
-(define-rule statement
- ;; convert char object to ASCII byte and store it in memory
- ;; register + byte offset <- contents of register (clear top bits)
- (ASSIGN (BYTE-OFFSET (REGISTER (? address))
- (MACHINE-CONSTANT (? offset)))
- (CHAR->ASCII (REGISTER (? source))))
- (LAP (SB ,(standard-source! source)
- (OFFSET ,offset ,(standard-source! address)))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Predicates
-
-(declare (usual-integrations))
-\f
-(define-rule predicate
- ;; test for two registers EQ?
- (EQ-TEST (REGISTER (? source1)) (REGISTER (? source2)))
- (compare '= (standard-source! source1) (standard-source! source2)))
-
-(define-rule predicate
- ;; test for register EQ? to constant
- (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register)))
- (eq-test/constant*register constant register))
-
-(define-rule predicate
- ;; test for register EQ? to constant
- (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant)))
- (eq-test/constant*register constant register))
-
-(define (eq-test/constant*register constant source)
- (let ((source (standard-source! source)))
- (if (non-pointer-object? constant)
- (compare-immediate '= (non-pointer->literal constant) source)
- (let ((temp (standard-temporary!)))
- (LAP ,@(load-pc-relative temp
- 'CONSTANT (constant->label constant)
- #T)
- ,@(compare '= temp source))))))
-
-(define-rule predicate
- ;; test for register EQ? to synthesized constant
- (EQ-TEST (CONS-NON-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum)))
- (REGISTER (? register)))
- (eq-test/synthesized-constant*register type datum register))
-
-(define-rule predicate
- ;; test for register EQ? to synthesized constant
- (EQ-TEST (REGISTER (? register))
- (CONS-NON-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum))))
- (eq-test/synthesized-constant*register type datum register))
-
-(define (eq-test/synthesized-constant*register type datum source)
- (compare-immediate '=
- (make-non-pointer-literal type datum)
- (standard-source! source)))
-
-(define-rule predicate
- ;; Branch if virtual register contains the specified type number
- (TYPE-TEST (REGISTER (? register)) (? type))
- (compare-immediate '= type (standard-source! register)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Invocations and Entries
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Invocations
-
-(define-rule statement
- (POP-RETURN)
- (pop-return))
-
-(define (pop-return)
- (let ((temp (standard-temporary!)))
- (LAP ,@(clear-map!)
- (LW ,temp (OFFSET 0 ,regnum:stack-pointer))
- (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4)
- ,@(object->address temp temp)
- (JR ,temp)
- (NOP)))) ; DELAY SLOT
-
-(define-rule statement
- (INVOCATION:APPLY (? frame-size) (? continuation))
- continuation ;ignore
- (LAP ,@(clear-map!)
- (ADDI ,regnum:second-arg ,regnum:scheme-to-interface -56)
- ,@(let ((regs (get-immediate-aliases frame-size)))
- (cond ((not (null? regs))
- (LAP (JR ,regnum:second-arg)
- ,@(if (memv regnum:third-arg regs)
- (LAP (NOP))
- (LAP (ADD ,regnum:third-arg 0 ,(car regs))))))
- ((fits-in-16-bits-signed? frame-size)
- (LAP (JR ,regnum:second-arg)
- (ADDIU ,regnum:third-arg 0 ,frame-size)))
- ((fits-in-16-bits-unsigned? frame-size)
- (LAP (JR ,regnum:second-arg)
- (ORI ,regnum:third-arg 0 ,frame-size)))
- ((top-16-bits-only? frame-size)
- (LAP (JR ,regnum:second-arg)
- (LUI ,regnum:third-arg ,(top-16-bits frame-size))))
- (else
- (LAP (LUI ,regnum:third-arg ,(top-16-bits frame-size))
- (JR ,regnum:second-arg)
- (ORI ,regnum:third-arg
- ,regnum:third-arg
- ,(bottom-16-bits frame-size))))))))
-
-(define-rule statement
- (INVOCATION:JUMP (? frame-size) (? continuation) (? label))
- frame-size continuation ;ignore
- (LAP ,@(clear-map!)
- (BGEZ 0 (@PCR ,label))
- (NOP))) ; DELAY SLOT
-
-(define-rule statement
- (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation))
- frame-size continuation ;ignore
- ;; It expects the procedure at the top of the stack
- (pop-return))
-
-(define-rule statement
- (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
- continuation ;ignore
- (let* ((clear-second-arg (clear-registers! regnum:second-arg))
- (load-second-arg
- (load-pc-relative-address regnum:second-arg 'CODE label)))
- (LAP ,@clear-second-arg
- ,@load-second-arg
- ,@(clear-map!)
- ,@(load-immediate regnum:third-arg number-pushed #F)
- ,@(invoke-interface code:compiler-lexpr-apply))))
-
-(define-rule statement
- (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation))
- continuation ;ignore
- ;; Destination address is at TOS; pop it into second-arg
- (LAP ,@(clear-map!)
- (LW ,regnum:second-arg (OFFSET 0 ,regnum:stack-pointer))
- (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4)
- ,@(object->address regnum:second-arg regnum:second-arg)
- ,@(load-immediate regnum:third-arg number-pushed #F)
- ,@(invoke-interface code:compiler-lexpr-apply)))
-\f
-(define-rule statement
- (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
- continuation ;ignore
- (LAP ,@(clear-map!)
- (BGEZ 0 (@PCR ,(free-uuo-link-label name frame-size)))
- (NOP)))
-
-(define-rule statement
- (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
- continuation ;ignore
- (LAP ,@(clear-map!)
- (BGEZ 0 (@PCR ,(global-uuo-link-label name frame-size)))
- (NOP))) ; DELAY SLOT
-
-(define-rule statement
- (INVOCATION:CACHE-REFERENCE (? frame-size)
- (? continuation)
- (? extension register-expression))
- continuation ;ignore
- (let* ((clear-third-arg (clear-registers! regnum:third-arg))
- (load-third-arg
- (load-pc-relative-address regnum:third-arg 'CODE *block-label*)))
- (LAP ,@clear-third-arg
- ,@load-third-arg
- ,@(load-interface-args! extension false false false)
- ,@(load-immediate regnum:fourth-arg frame-size #F)
- ,@(invoke-interface code:compiler-cache-reference-apply))))
-
-(define-rule statement
- (INVOCATION:LOOKUP (? frame-size)
- (? continuation)
- (? environment register-expression)
- (? name))
- continuation ;ignore
- (LAP ,@(load-interface-args! environment false false false)
- ,@(load-constant regnum:third-arg name #F #F)
- ,@(load-immediate regnum:fourth-arg frame-size #F)
- ,@(invoke-interface code:compiler-lookup-apply)))
-\f
-(define-rule statement
- (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
- continuation ;ignore
- (cond ((eq? primitive compiled-error-procedure)
- (LAP ,@(clear-map!)
- ,@(load-immediate regnum:second-arg frame-size #F)
- ,@(invoke-interface code:compiler-error)))
- ((eq? primitive (ucode-primitive set-interrupt-enables!))
- (LAP ,@(clear-map!)
- (ADDI ,regnum:assembler-temp ,regnum:scheme-to-interface -48)
- (JR ,regnum:assembler-temp)
- (NOP)))
- (else
- (let* ((clear-second-arg (clear-registers! regnum:second-arg))
- (load-second-arg
- (load-pc-relative regnum:second-arg
- 'CONSTANT
- (constant->label primitive)
- false)))
- (LAP ,@clear-second-arg
- ,@load-second-arg
- ,@(clear-map!)
- ,@(let ((arity (primitive-procedure-arity primitive)))
- (cond ((not (negative? arity))
- (invoke-interface code:compiler-primitive-apply))
- ((= arity -1)
- (LAP ,@(load-immediate regnum:assembler-temp
- (-1+ frame-size)
- #F)
- (SW ,regnum:assembler-temp
- ,reg:lexpr-primitive-arity)
- ,@(invoke-interface
- code:compiler-primitive-lexpr-apply)))
- (else
- ;; Unknown primitive arity. Go through apply.
- (LAP ,@(load-immediate regnum:third-arg
- frame-size
- #F)
- ,@(invoke-interface
- code:compiler-apply))))))))))
-
-(let-syntax
- ((define-special-primitive-invocation
- (sc-macro-transformer
- (lambda (form environment)
- `(DEFINE-RULE STATEMENT
- (INVOCATION:SPECIAL-PRIMITIVE
- (? FRAME-SIZE)
- (? CONTINUATION)
- ,(make-primitive-procedure (cadr form) #t))
- FRAME-SIZE CONTINUATION
- ,(list 'LAP
- (list 'UNQUOTE-SPLICING '(CLEAR-MAP!))
- (list 'UNQUOTE-SPLICING
- `(INVOKE-INTERFACE
- ,(close-syntax (symbol-append 'CODE:COMPILER-
- (cadr form))
- environment)))))))))
- (define-special-primitive-invocation &+)
- (define-special-primitive-invocation &-)
- (define-special-primitive-invocation &*)
- (define-special-primitive-invocation &/)
- (define-special-primitive-invocation &=)
- (define-special-primitive-invocation &<)
- (define-special-primitive-invocation &>)
- (define-special-primitive-invocation 1+)
- (define-special-primitive-invocation -1+)
- (define-special-primitive-invocation zero?)
- (define-special-primitive-invocation positive?)
- (define-special-primitive-invocation negative?))
-\f
-;;;; Invocation Prefixes
-
-;;; (INVOCATION-PREFIX:MOVE-FRAME-UP frame-size address)
-
-;;; Move the topmost <frame-size> words of the stack downward so that
-;;; the bottommost of these words is at location <address>, and set
-;;; the stack pointer to the topmost of the moved words. That is,
-;;; discard the words between <address> and SP+<frame-size>, close the
-;;; resulting gap by shifting down the words from above the gap, and
-;;; adjust SP to point to the new topmost word.
-
-(define-rule statement
- ;; Move up 0 words back to top of stack : a No-Op
- (INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER 3))
- (LAP))
-
-(define-rule statement
- ;; Move <frame-size> words back to dynamic link marker
- (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER 11))
- (generate/move-frame-up frame-size
- (lambda (reg) (LAP (ADD ,reg 0 ,regnum:dynamic-link)))))
-
-(define-rule statement
- ;; Move <frame-size> words back to SP+offset
- (INVOCATION-PREFIX:MOVE-FRAME-UP
- (? frame-size)
- (OFFSET-ADDRESS (REGISTER 3)
- (MACHINE-CONSTANT (? offset))))
- (let ((how-far (* 4 (- offset frame-size))))
- (cond ((zero? how-far)
- (LAP))
- ((negative? how-far)
- (error "invocation-prefix:move-frame-up: bad specs"
- frame-size offset))
- ((zero? frame-size)
- (add-immediate how-far regnum:stack-pointer regnum:stack-pointer))
- ((= frame-size 1)
- (let ((temp (standard-temporary!)))
- (LAP (LW ,temp (OFFSET 0 ,regnum:stack-pointer))
- (ADDI ,regnum:stack-pointer ,regnum:stack-pointer ,how-far)
- (STW ,temp (OFFSET 0 ,regnum:stack-pointer)))))
- ((= frame-size 2)
- (let ((temp1 (standard-temporary!))
- (temp2 (standard-temporary!)))
- (LAP (LW ,temp1 (OFFSET 0 ,regnum:stack-pointer))
- (LW ,temp2 (OFFSET 4 ,regnum:stack-pointer))
- (ADDI ,regnum:stack-pointer ,regnum:stack-pointer ,how-far)
- (SW ,temp1 (OFFSET 0 ,regnum:stack-pointer))
- (SW ,temp2 (OFFSET 4 ,regnum:stack-pointer)))))
- (else
- (generate/move-frame-up frame-size
- (lambda (reg)
- (add-immediate (* 4 offset) regnum:stack-pointer reg)))))))
-
-(define-rule statement
- ;; Move <frame-size> words back to base virtual register + offset
- (INVOCATION-PREFIX:MOVE-FRAME-UP
- (? frame-size)
- (OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? offset))))
- (QUALIFIER (not (= base 3)))
- (generate/move-frame-up frame-size
- (lambda (reg)
- (add-immediate (* 4 offset) (standard-source! base) reg))))
-
-(define (generate/move-frame-up frame-size destination-generator)
- (let ((temp (standard-temporary!)))
- (LAP ,@(destination-generator temp)
- ,@(generate/move-frame-up* frame-size temp))))
-\f
-;;; DYNAMIC-LINK instructions have a <frame-size>, <new frame end>,
-;;; and <current dynamic link> as arguments. They pop the stack by
-;;; removing the lesser of the amount needed to move the stack pointer
-;;; back to the <new frame end> or <current dynamic link>. The last
-;;; <frame-size> words on the stack (the stack frame for the procedure
-;;; about to be called) are then put back onto the newly adjusted
-;;; stack.
-
-(define-rule statement
- (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
- (REGISTER (? source))
- (REGISTER 11))
- (if (and (zero? frame-size)
- (= source regnum:stack-pointer))
- (LAP)
- (let ((env-reg (standard-move-to-temporary! source))
- (label (generate-label)))
- (LAP (SLTU ,regnum:assembler-temp ,env-reg ,regnum:dynamic-link)
- (BNE 0 ,regnum:assembler-temp (@PCR ,label))
- (NOP)
- (ADD ,env-reg 0 ,regnum:dynamic-link)
- (LABEL ,label)
- ,@(generate/move-frame-up* frame-size env-reg)))))
-
-(define (generate/move-frame-up* frame-size destination)
- ;; Destination is guaranteed to be a machine register number; that
- ;; register has the destination base address for the frame. The stack
- ;; pointer is reset to the top end of the copied area.
- (LAP ,@(case frame-size
- ((0)
- (LAP))
- ((1)
- (let ((temp (standard-temporary!)))
- (LAP (LW ,temp (OFFSET 0 ,regnum:stack-pointer))
- (ADDI ,destination ,destination -4)
- (SW ,temp (OFFSET 0 ,destination)))))
- (else
- (let ((from (standard-temporary!))
- (temp1 (standard-temporary!))
- (temp2 (standard-temporary!)))
- (LAP ,@(add-immediate (* 4 frame-size) regnum:stack-pointer from)
- ,@(if (<= frame-size 3)
- ;; This code can handle any number > 1
- ;; (handled above), but we restrict it to 3
- ;; for space reasons.
- (let loop ((n frame-size))
- (case n
- ((0)
- (LAP))
- ((3)
- (let ((temp3 (standard-temporary!)))
- (LAP (LW ,temp1 (OFFSET -4 ,from))
- (LW ,temp2 (OFFSET -8 ,from))
- (LW ,temp3 (OFFSET -12 ,from))
- (ADDI ,from ,from -12)
- (SW ,temp1 (OFFSET -4 ,destination))
- (SW ,temp2 (OFFSET -8 ,destination))
- (SW ,temp3 (OFFSET -12 ,destination))
- (ADDI ,destination ,destination -12))))
- (else
- (LAP (LW ,temp1 (OFFSET -4 ,from))
- (LW ,temp2 (OFFSET -8 ,from))
- (ADDI ,from ,from -8)
- (SW ,temp1 (OFFSET -4 ,destination))
- (SW ,temp2 (OFFSET -8 ,destination))
- (ADDI ,destination ,destination -8)
- ,@(loop (- n 2))))))
- (let ((label (generate-label)))
- (LAP ,@(load-immediate temp2 frame-size #F)
- (LABEL ,label)
- (LW ,temp1 (OFFSET -4 ,from))
- (ADDI ,from ,from -4)
- (ADDI ,temp2 ,temp2 -1)
- (ADDI ,destination ,destination -4)
- (BNE ,temp2 0 (@PCR ,label))
- (SW ,temp1 (OFFSET 0 ,destination)))))))))
- (ADD ,regnum:stack-pointer 0 ,destination)))
-\f
-;;;; External Labels
-
-(define (make-external-label code label)
- (set! *external-labels* (cons label *external-labels*))
- (LAP (EXTERNAL-LABEL ,code (@PCR ,label))
- (LABEL ,label)))
-
-;;; Entry point types
-
-(define-integrable (make-code-word min max)
- (+ (* #x100 min) max))
-
-(define (make-procedure-code-word min max)
- ;; The "min" byte must be less than #x80; the "max" byte may not
- ;; equal #x80 but can take on any other value.
- (if (or (negative? min) (>= min #x80))
- (error "MAKE-PROCEDURE-CODE-WORD: minimum out of range" min))
- (if (>= (abs max) #x80)
- (error "MAKE-PROCEDURE-CODE-WORD: maximum out of range" max))
- (make-code-word min (if (negative? max) (+ #x100 max) max)))
-
-(define expression-code-word
- (make-code-word #xff #xff))
-
-(define internal-entry-code-word
- (make-code-word #xff #xfe))
-
-(define internal-continuation-code-word
- (make-code-word #xff #xfc))
-
-(define (continuation-code-word label)
- (frame-size->code-word
- (if label
- (rtl-continuation/next-continuation-offset (label->object label))
- 0)
- internal-continuation-code-word))
-
-(define (internal-procedure-code-word rtl-proc)
- ;; represented as return addresses so the debugger will
- ;; not barf when it sees them (on the stack if interrupted).
- (frame-size->code-word
- (rtl-procedure/next-continuation-offset rtl-proc)
- internal-entry-code-word))
-
-(define (frame-size->code-word offset default)
- (cond ((not offset)
- default)
- ((< offset #x2000)
- ;; This uses up through (#xff #xdf).
- (let ((qr (integer-divide offset #x80)))
- (make-code-word (+ #x80 (integer-divide-remainder qr))
- (+ #x80 (integer-divide-quotient qr)))))
- (else
- (error "Unable to encode continuation offset" offset))))
-\f
-;;;; Procedure headers
-
-;;; The following calls MUST appear as the first thing at the entry
-;;; point of a procedure. They assume that the register map is clear
-;;; and that no register contains anything of value.
-;;;
-;;; The only reason that this is true is that no register is live
-;;; across calls. If that were not true, then we would have to save
-;;; any such registers on the stack so that they would be GC'ed
-;;; appropriately.
-;;;
-;;; The only exception is the dynamic link register, handled
-;;; specially. Procedures that require a dynamic link use a different
-;;; interrupt handler that saves and restores the dynamic link
-;;; register.
-
-(define (simple-procedure-header code-word label code)
- (let ((gc-label (generate-label)))
- (LAP (LABEL ,gc-label)
- ,@(link-to-interface code)
- ,@(make-external-label code-word label)
- ,@(interrupt-check label gc-label))))
-
-(define (dlink-procedure-header code-word label)
- (let ((gc-label (generate-label)))
- (LAP (LABEL ,gc-label)
- (ADD ,regnum:third-arg 0 ,regnum:dynamic-link)
- ,@(link-to-interface code:compiler-interrupt-dlink)
- ,@(make-external-label code-word label)
- ,@(interrupt-check label gc-label))))
-
-(define (interrupt-check label gc-label)
- (if (not (let ((object (label->object label)))
- (and (rtl-procedure? object)
- (not (rtl-procedure/stack-leaf? object))
- compiler:generate-stack-checks?)))
- (LAP (SLT ,regnum:assembler-temp ,regnum:memtop ,regnum:free)
- (BNE ,regnum:assembler-temp 0 (@PCR ,gc-label))
- (LW ,regnum:memtop ,reg:memtop))
- (LAP (LW ,regnum:first-arg ,reg:stack-guard)
- (SLT ,regnum:assembler-temp ,regnum:memtop ,regnum:free)
- (BNE ,regnum:assembler-temp 0 (@PCR ,gc-label))
- (SLT ,regnum:assembler-temp ,regnum:stack-pointer ,regnum:first-arg)
- (BNE ,regnum:assembler-temp 0 (@PCR ,gc-label))
- (LW ,regnum:memtop ,reg:memtop))))
-
-(define-rule statement
- (CONTINUATION-ENTRY (? internal-label))
- (make-external-label (continuation-code-word internal-label)
- internal-label))
-
-(define-rule statement
- (CONTINUATION-HEADER (? internal-label))
- (simple-procedure-header (continuation-code-word internal-label)
- internal-label
- code:compiler-interrupt-continuation))
-
-(define-rule statement
- (IC-PROCEDURE-HEADER (? internal-label))
- (let ((procedure (label->object internal-label)))
- (let ((external-label (rtl-procedure/external-label procedure)))
- (LAP (ENTRY-POINT ,external-label)
- (EQUATE ,external-label ,internal-label)
- ,@(simple-procedure-header expression-code-word
- internal-label
- code:compiler-interrupt-ic-procedure)))))
-
-(define-rule statement
- (OPEN-PROCEDURE-HEADER (? internal-label))
- (let ((rtl-proc (label->object internal-label)))
- (LAP (EQUATE ,(rtl-procedure/external-label rtl-proc) ,internal-label)
- ,@((if (rtl-procedure/dynamic-link? rtl-proc)
- dlink-procedure-header
- (lambda (code-word label)
- (simple-procedure-header code-word label
- code:compiler-interrupt-procedure)))
- (internal-procedure-code-word rtl-proc)
- internal-label))))
-
-(define-rule statement
- (PROCEDURE-HEADER (? internal-label) (? min) (? max))
- (LAP (EQUATE ,(rtl-procedure/external-label (label->object internal-label))
- ,internal-label)
- ,@(simple-procedure-header (make-procedure-code-word min max)
- internal-label
- code:compiler-interrupt-procedure)))
-\f
-;;;; Closures.
-
-;; Magic for compiled entries.
-
-(define-rule statement
- (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
- entry ; ignored -- non-RISCs only
- (if (zero? nentries)
- (error "Closure header for closure with no entries!"
- internal-label))
- (let ((rtl-proc (label->object internal-label)))
- (let ((gc-label (generate-label))
- (external-label (rtl-procedure/external-label rtl-proc)))
- (LAP (LABEL ,gc-label)
- ,@(invoke-interface code:compiler-interrupt-closure)
- ,@(make-external-label
- (internal-procedure-code-word rtl-proc)
- external-label)
- ;; Code below here corresponds to code and count in cmpint2.h
- ,@(fluid-let ((*register-map* *register-map*))
- ;; Don't cache type constant here, because it won't be
- ;; in the register if the closure is entered from the
- ;; internal label.
- (deposit-type-address (ucode-type compiled-entry)
- regnum:linkage
- regnum:linkage))
- (ADDI ,regnum:stack-pointer ,regnum:stack-pointer -4)
- (SW ,regnum:linkage (OFFSET 0 ,regnum:stack-pointer))
- (LABEL ,internal-label)
- ,@(interrupt-check internal-label gc-label)))))
-
-(define (build-gc-offset-word offset code-word)
- (let ((encoded-offset (quotient offset 2)))
- (if (eq? endianness 'LITTLE)
- (+ (* encoded-offset #x10000) code-word)
- (+ (* code-word #x10000) encoded-offset))))
-
-(define (closure-bump-size nentries nvars)
- (* (* 4 closure-entry-size)
- (1+ (quotient (+ (+ nvars (-1+ (* closure-entry-size nentries)))
- (-1+ closure-entry-size))
- closure-entry-size))))
-
-(define (closure-test-size nentries nvars)
- (* 4
- (+ nvars
- (-1+ (* nentries closure-entry-size)))))
-
-(define (cons-closure target label min max nvars)
- ;; Invoke an out-of-line handler to set up the closure's entry point.
- ;; Arguments:
- ;; - GR31: "Return address"
- ;; GR31 points to a manifest closure header word, followed by a
- ;; two-word closure descriptor, followed by the actual
- ;; instructions to return to.
- ;; The first word of the descriptor is the format+gc-offset word of
- ;; the generated closure.
- ;; The second word is the PC-relative JAL instruction.
- ;; It is transformed into an absolute instruction by adding the shifted
- ;; "return address".
- ;; - GR4: Value to compare to closure free.
- ;; - GR5: Increment for closure free.
- ;; Returns closure in regnum:first-arg (GR4)
- (rtl-target:=machine-register! target regnum:first-arg)
- (require-register! regnum:second-arg)
- (require-register! regnum:fourth-arg)
- (let ((label-arg (generate-label)))
- (LAP (ADDI ,regnum:second-arg ,regnum:scheme-to-interface -72)
- (ADDI ,regnum:first-arg ,regnum:closure-free
- ,(closure-test-size 1 nvars))
- (JALR 31 ,regnum:second-arg)
- (ADDI ,regnum:second-arg 0 ,(closure-bump-size 1 nvars))
- (LABEL ,label-arg)
- (LONG U ,(make-non-pointer-literal (ucode-type manifest-closure)
- (+ closure-entry-size nvars)))
- (LONG U ,(build-gc-offset-word 8 (make-procedure-code-word min max)))
- (LONG U
- (+ #x0c000000 ; JAL opcode
- (/ (- ,(rtl-procedure/external-label (label->object label))
- ,label-arg)
- 4))))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
- (? min) (? max) (? nvars)))
- (cons-closure target procedure-label min max nvars))
-\f
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-MULTICLOSURE (? nentries) (? nvars) (? entries)))
- ;; entries is a vector of all the entry points
- (case nentries
- ((0)
- (let ((dest (standard-target! target))
- (temp (standard-temporary!)))
- (LAP (ADD ,dest 0 ,regnum:free)
- ,@(load-immediate
- temp
- (make-non-pointer-literal (ucode-type manifest-vector) nvars)
- #T)
- (SW ,temp (OFFSET 0 ,regnum:free))
- (ADDI ,regnum:free ,regnum:free ,(* 4 (+ nvars 1))))))
- ((1)
- (let ((entry (vector-ref entries 0)))
- (cons-closure target (car entry) (cadr entry) (caddr entry) nvars)))
- (else
- (cons-multiclosure target nentries nvars (vector->list entries)))))
-
-(define (cons-multiclosure target nentries nvars entries)
- ;; Invoke an out-of-line handler to set up the closure's entry points.
- ;; Arguments:
- ;; - GR31: "Return address"
- ;; GR31 points to a manifest closure header word, followed by
- ;; nentries two-word structures, followed by the actual
- ;; instructions to return to.
- ;; The first word of each descriptor is the format+gc-offset word of
- ;; the corresponding entry point of the generated closure.
- ;; The second word is the PC-relative JAL instruction.
- ;; It is transformed into an absolute instruction by adding the shifted
- ;; "return address".
- ;; - GR4: Value to compare to closure free.
- ;; - GR5: Increment for closure free.
- ;; - GR6: number of entries.
- ;; Returns closure in regnum:first-arg (GR4).
- (rtl-target:=machine-register! target regnum:first-arg)
- (require-register! regnum:second-arg)
- (require-register! regnum:third-arg)
- (require-register! regnum:fourth-arg)
- (let ((label-arg (generate-label)))
- (LAP (ADDI ,regnum:third-arg ,regnum:scheme-to-interface -64)
- (ADDI ,regnum:first-arg ,regnum:closure-free
- ,(closure-test-size nentries nvars))
- (ADDI ,regnum:second-arg 0 ,(closure-bump-size nentries nvars))
- (JALR 31 ,regnum:third-arg)
- (ADDI ,regnum:third-arg 0 ,nentries)
- (LABEL ,label-arg)
- (LONG U ,(make-non-pointer-literal (ucode-type manifest-closure)
- (+ 1
- (* nentries closure-entry-size)
- nvars)))
- ,@(let expand ((offset 12) (entries entries))
- (if (null? entries)
- (LAP)
- (let ((entry (car entries)))
- (LAP
- (LONG U ,(build-gc-offset-word
- offset
- (make-procedure-code-word (cadr entry)
- (caddr entry))))
- (LONG U
- (+ #x0c000000 ; JAL opcode
- (/ (- ,(rtl-procedure/external-label
- (label->object (car entry)))
- ,label-arg)
- 4)))
- ,@(expand (+ offset (* 4 closure-entry-size))
- (cdr entries)))))))))
-\f
-;;;; Entry Header
-;;; This is invoked by the top level of the LAP generator.
-
-(define (generate/quotation-header environment-label free-ref-label n-sections)
- ;; Calls the linker
- ;; On MIPS, regnum:first-arg is used as a temporary here since
- ;; load-pc-relative-address uses the assembler temporary.
- (in-assembler-environment (empty-register-map)
- (list regnum:first-arg regnum:second-arg
- regnum:third-arg regnum:fourth-arg)
- (lambda ()
- (let* ((i1
- (load-pc-relative-address regnum:second-arg
- 'CONSTANT environment-label))
- (i2 (load-pc-relative-address regnum:third-arg
- 'CODE *block-label*))
- (i3 (load-pc-relative-address regnum:fourth-arg
- 'CONSTANT free-ref-label)))
- (LAP
- ;; Grab interp's env. and store in code block at environment-label
- (LW ,regnum:first-arg ,reg:environment)
- ,@i1
- (SW ,regnum:first-arg (OFFSET 0 ,regnum:second-arg))
- ;; Now invoke the linker
- ;; (arg1 is return address, supplied by interface)
- ,@i2
- ,@i3
- ,@(load-immediate regnum:first-arg n-sections #F)
- (SW ,regnum:first-arg (OFFSET 16 ,regnum:C-stack-pointer))
- ,@(link-to-interface code:compiler-link)
- ,@(make-external-label (continuation-code-word false)
- (generate-label)))))))
-
-(define (generate/remote-link code-block-label
- environment-offset
- free-ref-offset
- n-sections)
- ;; Link all of the top level procedures within the file
- (in-assembler-environment (empty-register-map)
- (list regnum:first-arg regnum:second-arg
- regnum:third-arg regnum:fourth-arg)
- (lambda ()
- (LAP ,@(load-pc-relative regnum:third-arg 'CODE code-block-label false)
- (LW ,regnum:fourth-arg ,reg:environment)
- ,@(object->address regnum:third-arg regnum:third-arg)
- ,@(add-immediate environment-offset
- regnum:third-arg
- regnum:second-arg)
- (SW ,regnum:fourth-arg (OFFSET 0 ,regnum:second-arg))
- ,@(add-immediate free-ref-offset regnum:third-arg regnum:fourth-arg)
- ,@(load-immediate regnum:first-arg n-sections #F)
- (SW ,regnum:first-arg (OFFSET 16 ,regnum:C-stack-pointer))
- ,@(link-to-interface code:compiler-link)
- ,@(make-external-label (continuation-code-word false)
- (generate-label))))))
-
-(define (in-assembler-environment map needed-registers thunk)
- (fluid-let ((*register-map* map)
- (*prefix-instructions* (LAP))
- (*suffix-instructions* (LAP))
- (*needed-registers* needed-registers))
- (let ((instructions (thunk)))
- (LAP ,@*prefix-instructions*
- ,@instructions
- ,@*suffix-instructions*))))
-\f
-(define (generate/constants-block constants references assignments uuo-links
- global-links static-vars)
- (let ((constant-info
- (declare-constants 0 (transmogrifly uuo-links)
- (declare-constants 1 references
- (declare-constants 2 assignments
- (declare-constants 3 (transmogrifly global-links)
- (declare-constants false
- (map (lambda (pair)
- (cons false (cdr pair)))
- static-vars)
- (declare-constants false constants
- (cons false (LAP))))))))))
- (let ((free-ref-label (car constant-info))
- (constants-code (cdr constant-info))
- (debugging-information-label (allocate-constant-label))
- (environment-label (allocate-constant-label))
- (n-sections
- (+ (if (null? uuo-links) 0 1)
- (if (null? references) 0 1)
- (if (null? assignments) 0 1)
- (if (null? global-links) 0 1))))
- (values
- (LAP ,@constants-code
- ;; Place holder for the debugging info filename
- (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO)
- ;; Place holder for the load time environment if needed
- (SCHEME-OBJECT ,environment-label
- ,(if (null? free-ref-label) 0 'ENVIRONMENT)))
- environment-label
- free-ref-label
- n-sections))))
-
-(define (declare-constants tag constants info)
- (define (inner constants)
- (if (null? constants)
- (cdr info)
- (let ((entry (car constants)))
- (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry))
- ,@(inner (cdr constants))))))
- (if (and tag (not (null? constants)))
- (let ((label (allocate-constant-label)))
- (cons label
- (inner
- `((,(let ((datum (length constants)))
- (if (> datum #xffff)
- (error "datum too large" datum))
- (+ (* tag #x10000) datum))
- . ,label)
- ,@constants))))
- (cons (car info) (inner constants))))
-
-(define (transmogrifly uuos)
- (define (inner name assoc)
- (if (null? assoc)
- (transmogrifly (cdr uuos))
- ; produces ((name . label) (0 . label) ... (frame-size . label) ...)
- ; where the (0 . label) is repeated to fill out the size required
- ; as specified in machin.scm
- `((,name . ,(cdar assoc)) ; uuo-label
- ,@(let loop ((count (max 0 (- execute-cache-size 2))))
- (if (= count 0)
- '()
- (cons `(0 . ,(allocate-constant-label))
- (loop (- count 1)))))
- (,(caar assoc) . ; frame-size
- ,(allocate-constant-label))
- ,@(inner name (cdr assoc)))))
- (if (null? uuos)
- '()
- ;; caar is name, cdar is alist of frame sizes
- (inner (caar uuos) (cdar uuos))))
-\f
-;;; Local Variables: ***
-;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
-;;; End: ***
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Interpreter Calls
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Variable cache trap handling.
-
-(define-rule statement
- (INTERPRETER-CALL:CACHE-REFERENCE (? cont)
- (REGISTER (? extension))
- (? safe?))
- cont ; ignored
- (LAP ,@(load-interface-args! false extension false false)
- ,@(link-to-interface
- (if safe?
- code:compiler-safe-reference-trap
- code:compiler-reference-trap))))
-
-(define-rule statement
- (INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont)
- (REGISTER (? extension))
- (? value register-expression))
- cont ; ignored
- (LAP ,@(load-interface-args! false extension value false)
- ,@(link-to-interface code:compiler-assignment-trap)))
-
-(define-rule statement
- (INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont)
- (REGISTER (? extension)))
- cont ; ignored
- (LAP ,@(load-interface-args! false extension false false)
- ,@(link-to-interface code:compiler-unassigned?-trap)))
-\f
-;;;; Interpreter Calls
-
-;;; All the code that follows is obsolete. It hasn't been used in a while.
-;;; It is provided in case the relevant switches are turned off, but there
-;;; is no real reason to do this. Perhaps the switches should be removed.
-
-(define-rule statement
- (INTERPRETER-CALL:ACCESS (? cont)
- (? environment register-expression)
- (? name))
- cont ; ignored
- (lookup-call code:compiler-access environment name))
-
-(define-rule statement
- (INTERPRETER-CALL:LOOKUP (? cont)
- (? environment register-expression)
- (? name)
- (? safe?))
- cont ; ignored
- (lookup-call (if safe? code:compiler-safe-lookup code:compiler-lookup)
- environment
- name))
-
-(define-rule statement
- (INTERPRETER-CALL:UNASSIGNED? (? cont)
- (? environment register-expression)
- (? name))
- cont ; ignored
- (lookup-call code:compiler-unassigned? environment name))
-
-(define-rule statement
- (INTERPRETER-CALL:UNBOUND? (? cont)
- (? environment register-expression)
- (? name))
- cont ; ignored
- (lookup-call code:compiler-unbound? environment name))
-
-(define (lookup-call code environment name)
- (LAP ,@(load-interface-args! false environment false false)
- ,@(load-constant regnum:third-arg name #F #F)
- ,@(link-to-interface code)))
-
-(define-rule statement
- (INTERPRETER-CALL:DEFINE (? cont)
- (? environment register-expression)
- (? name)
- (? value register-expression))
- cont ; ignored
- (assignment-call code:compiler-define environment name value))
-
-(define-rule statement
- (INTERPRETER-CALL:SET! (? cont)
- (? environment register-expression)
- (? name)
- (? value register-expression))
- cont ; ignored
- (assignment-call code:compiler-set! environment name value))
-
-(define (assignment-call code environment name value)
- (LAP ,@(load-interface-args! false environment false value)
- ,@(load-constant regnum:third-arg name #F #F)
- ,@(link-to-interface code)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Fixnum Rules
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Conversions
-
-(define-rule statement
- ;; convert a fixnum object to a "fixnum integer"
- (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source))))
- (standard-unary-conversion source target object->fixnum))
-
-(define-rule statement
- ;; load a fixnum constant as a "fixnum integer"
- (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant))))
- (load-immediate (standard-target! target) (* constant fixnum-1) #T))
-
-(define-rule statement
- ;; convert a memory address to a "fixnum integer"
- (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source))))
- (standard-unary-conversion source target address->fixnum))
-
-(define-rule statement
- ;; convert an object's address to a "fixnum integer"
- (ASSIGN (REGISTER (? target))
- (ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source)))))
- (standard-unary-conversion source target object->fixnum))
-
-(define-rule statement
- ;; convert a "fixnum integer" to a fixnum object
- (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source))))
- (standard-unary-conversion source target fixnum->object))
-
-(define-rule statement
- ;; convert a "fixnum integer" to a memory address
- (ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source))))
- (standard-unary-conversion source target fixnum->address))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (OBJECT->FIXNUM (CONSTANT 4))
- (OBJECT->FIXNUM (REGISTER (? source)))
- #F))
- (standard-unary-conversion source target object->index-fixnum))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (OBJECT->FIXNUM (REGISTER (? source)))
- (OBJECT->FIXNUM (CONSTANT 4))
- #F))
- (standard-unary-conversion source target object->index-fixnum))
-
-;; This is a patch for the time being. Probably only one of these pairs
-;; of rules is needed.
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (OBJECT->FIXNUM (CONSTANT 4))
- (REGISTER (? source))
- #F))
- (standard-unary-conversion source target fixnum->index-fixnum))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (REGISTER (? source))
- (OBJECT->FIXNUM (CONSTANT 4))
- #F))
- (standard-unary-conversion source target fixnum->index-fixnum))
-\f
-;; "Fixnum" in this context means an integer left shifted so that
-;; the sign bit is the leftmost bit of the word, i.e., the datum
-;; has been left shifted by scheme-type-width bits.
-
-(define-integrable (fixnum->index-fixnum src tgt)
- ; Shift left 2 bits
- (LAP (SLL ,tgt ,src 2)))
-
-(define-integrable (object->fixnum src tgt)
- ; Shift left by scheme-type-width
- (LAP (SLL ,tgt ,src ,scheme-type-width)))
-
-(define-integrable (object->index-fixnum src tgt)
- ; Shift left by scheme-type-width+2
- (LAP (SLL ,tgt ,src ,(+ scheme-type-width 2))))
-
-(define-integrable (address->fixnum src tgt)
- ; Strip off type bits, just like object->fixnum
- (LAP (SLL ,tgt ,src ,scheme-type-width)))
-
-(define-integrable (fixnum->object src tgt)
- ; Move right by type code width and put on fixnum type code
- (LAP (SRL ,tgt ,src ,scheme-type-width)
- ,@(deposit-type-datum (ucode-type fixnum) tgt tgt)))
-
-(define (fixnum->address src tgt)
- ; Move right by type code width and put in address bits
- (LAP (SRL ,tgt ,src ,scheme-type-width)
- (OR ,tgt ,tgt ,regnum:quad-bits)))
-
-(define-integrable fixnum-1
- (expt 2 scheme-type-width))
-
-(define-integrable -fixnum-1
- (- fixnum-1))
-
-(define (no-overflow-branches!)
- (set-current-branches!
- (lambda (if-overflow)
- if-overflow
- (LAP))
- (lambda (if-no-overflow)
- (LAP (BGEZ 0 (@PCR ,if-no-overflow))
- (NOP)))))
-
-(define (guarantee-signed-fixnum n)
- (if (not (signed-fixnum? n)) (error "Not a signed fixnum" n))
- n)
-
-(define (signed-fixnum? n)
- (and (exact-integer? n)
- (>= n signed-fixnum/lower-limit)
- (< n signed-fixnum/upper-limit)))
-\f
-;;;; Arithmetic Operations
-
-(define-rule statement
- ;; execute a unary fixnum operation
- (ASSIGN (REGISTER (? target))
- (FIXNUM-1-ARG (? operation)
- (REGISTER (? source))
- (? overflow?)))
- (standard-unary-conversion source target
- (lambda (source target)
- ((fixnum-1-arg/operator operation) target source overflow?))))
-
-(define (fixnum-1-arg/operator operation)
- (lookup-arithmetic-method operation fixnum-methods/1-arg))
-
-(define fixnum-methods/1-arg
- (list 'FIXNUM-METHODS/1-ARG))
-
-(define-rule statement
- ;; execute a binary fixnum operation
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS (? operation)
- (REGISTER (? source1))
- (REGISTER (? source2))
- (? overflow?)))
- (standard-binary-conversion source1 source2 target
- (lambda (source1 source2 target)
- ((fixnum-2-args/operator operation) target source1 source2 overflow?))))
-
-(define (fixnum-2-args/operator operation)
- (lookup-arithmetic-method operation fixnum-methods/2-args))
-
-(define fixnum-methods/2-args
- (list 'FIXNUM-METHODS/2-ARGS))
-\f
-(define-rule statement
- ;; execute binary fixnum operation with constant second arg
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS (? operation)
- (REGISTER (? source))
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (? overflow?)))
- (QUALIFIER (fixnum-2-args/operator/register*constant? operation))
- (standard-unary-conversion source target
- (lambda (source target)
- ((fixnum-2-args/operator/register*constant operation)
- target source constant overflow?))))
-
-(define-rule statement
- ;; execute binary fixnum operation with constant first arg
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS (? operation)
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (REGISTER (? source))
- (? overflow?)))
- (QUALIFIER
- (or (fixnum-2-args/operator/constant*register? operation)
- (and (fixnum-2-args/commutative? operation)
- (fixnum-2-args/operator/register*constant? operation))))
- (standard-unary-conversion source target
- (lambda (source target)
- (if (fixnum-2-args/commutative? operation)
- ((fixnum-2-args/operator/register*constant operation)
- target source constant overflow?)
- ((fixnum-2-args/operator/constant*register operation)
- target constant source overflow?)))))
-
-(define (fixnum-2-args/commutative? operator)
- (memq operator
- '(PLUS-FIXNUM MULTIPLY-FIXNUM FIXNUM-AND FIXNUM-OR FIXNUM-XOR)))
-
-(define (fixnum-2-args/operator/register*constant operation)
- (lookup-arithmetic-method operation fixnum-methods/2-args/register*constant))
-
-(define (fixnum-2-args/operator/register*constant? operation)
- (arithmetic-method? operation fixnum-methods/2-args/register*constant))
-
-(define fixnum-methods/2-args/register*constant
- (list 'FIXNUM-METHODS/2-ARGS/REGISTER*CONSTANT))
-
-(define (fixnum-2-args/operator/constant*register operation)
- (lookup-arithmetic-method operation fixnum-methods/2-args/constant*register))
-
-(define (fixnum-2-args/operator/constant*register? operation)
- (arithmetic-method? operation fixnum-methods/2-args/constant*register))
-
-(define fixnum-methods/2-args/constant*register
- (list 'FIXNUM-METHODS/2-ARGS/CONSTANT*REGISTER))
-\f
-(define-arithmetic-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
- (lambda (tgt src overflow?)
- (fixnum-add-constant tgt src 1 overflow?)))
-
-(define-arithmetic-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg
- (lambda (tgt src overflow?)
- (fixnum-add-constant tgt src -1 overflow?)))
-
-(define (fixnum-add-constant tgt src constant overflow?)
- (let ((constant (* fixnum-1 constant)))
- (cond ((not overflow?)
- (add-immediate constant src tgt))
- ((= constant 0)
- (no-overflow-branches!)
- (LAP (ADDIU ,tgt ,src 0)))
- (else
- (let ((bcc (if (> constant 0) 'BLEZ 'BGEZ)))
- (let ((prefix
- (if (fits-in-16-bits-signed? constant)
- (lambda (label)
- (LAP (,bcc ,src (@PCR ,label))
- (ADDIU ,tgt ,src ,constant)))
- (with-values (lambda () (immediate->register constant))
- (lambda (prefix alias)
- (lambda (label)
- (LAP ,@prefix
- (,bcc ,src (@PCR ,label))
- (ADDU ,tgt ,src ,alias))))))))
- (if (> constant 0)
- (set-current-branches!
- (lambda (if-overflow)
- (let ((if-no-overflow (generate-label)))
- (LAP ,@(prefix if-no-overflow)
- (BLTZ ,tgt (@PCR ,if-overflow))
- (NOP)
- (LABEL ,if-no-overflow))))
- (lambda (if-no-overflow)
- (LAP ,@(prefix if-no-overflow)
- (BGEZ ,tgt (@PCR ,if-no-overflow))
- (NOP))))
- (set-current-branches!
- (lambda (if-overflow)
- (let ((if-no-overflow (generate-label)))
- (LAP ,@(prefix if-no-overflow)
- (BGEZ ,tgt (@PCR ,if-overflow))
- (NOP)
- (LABEL ,if-no-overflow))))
- (lambda (if-no-overflow)
- (LAP ,@(prefix if-no-overflow)
- (BLTZ ,tgt (@PCR ,if-no-overflow))
- (NOP)))))))
- (LAP)))))
-\f
-(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args
- (lambda (tgt src1 src2 overflow?)
- (if overflow?
- (do-overflow-addition tgt src1 src2)
- (LAP (ADDU ,tgt ,src1 ,src2)))))
-
-(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args/register*constant
- (lambda (tgt src constant overflow?)
- (guarantee-signed-fixnum constant)
- (fixnum-add-constant tgt src constant overflow?)))
-
-;;; Use of REGNUM:ASSEMBLER-TEMP is OK here, but only because its
-;;; value is not used after the branch instruction that tests it.
-;;; The long form of the @PCR branch will test it correctly, but
-;;; clobbers it after testing.
-
-(define (do-overflow-addition tgt src1 src2)
- (cond ((not (= src1 src2))
- (set-current-branches!
- (lambda (if-overflow)
- (let ((if-no-overflow (generate-label)))
- (LAP (XOR ,regnum:assembler-temp ,src1 ,src2)
- (BLTZ ,regnum:assembler-temp (@PCR ,if-no-overflow))
- (ADDU ,tgt ,src1 ,src2)
- (XOR ,regnum:assembler-temp
- ,tgt
- ,(if (= tgt src1) src2 src1))
- (BLTZ ,regnum:assembler-temp (@PCR ,if-overflow))
- (NOP)
- (LABEL ,if-no-overflow))))
- (lambda (if-no-overflow)
- (LAP (XOR ,regnum:assembler-temp ,src1 ,src2)
- (BLTZ ,regnum:assembler-temp (@PCR ,if-no-overflow))
- (ADDU ,tgt ,src1 ,src2)
- (XOR ,regnum:assembler-temp
- ,tgt
- ,(if (= tgt src1) src2 src1))
- (BGEZ ,regnum:assembler-temp (@PCR ,if-no-overflow))
- (NOP)))))
- ((not (= tgt src1))
- (set-current-branches!
- (lambda (if-overflow)
- (LAP (ADDU ,tgt ,src1 ,src1)
- (XOR ,regnum:assembler-temp ,tgt ,src1)
- (BLTZ ,regnum:assembler-temp (@PCR ,if-overflow))
- (NOP)))
- (lambda (if-no-overflow)
- (LAP (ADDU ,tgt ,src1 ,src1)
- (XOR ,regnum:assembler-temp ,tgt ,src1)
- (BGEZ ,regnum:assembler-temp (@PCR ,if-no-overflow))
- (NOP)))))
- (else
- (let ((temp (standard-temporary!)))
- (set-current-branches!
- (lambda (if-overflow)
- (LAP (ADDU ,temp ,src1 ,src1)
- (XOR ,regnum:assembler-temp ,temp ,src1)
- (BLTZ ,regnum:assembler-temp (@PCR ,if-overflow))
- (ADD ,tgt 0 ,temp)))
- (lambda (if-no-overflow)
- (LAP (ADDU ,temp ,src1 ,src1)
- (XOR ,regnum:assembler-temp ,temp ,src1)
- (BGEZ ,regnum:assembler-temp (@PCR ,if-no-overflow))
- (ADD ,tgt 0 ,temp)))))))
- (LAP))
-\f
-(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args
- (lambda (tgt src1 src2 overflow?)
- (if overflow?
- (if (= src1 src2) ;probably won't ever happen.
- (begin
- (no-overflow-branches!)
- (LAP (SUBU ,tgt ,src1 ,src1)))
- (do-overflow-subtraction tgt src1 src2))
- (LAP (SUB ,tgt ,src1 ,src2)))))
-
-(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args/register*constant
- (lambda (tgt src constant overflow?)
- (guarantee-signed-fixnum constant)
- (fixnum-add-constant tgt src (- constant) overflow?)))
-
-(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args/constant*register
- (lambda (tgt constant src overflow?)
- (guarantee-signed-fixnum constant)
- (with-values (lambda () (immediate->register (* constant fixnum-1)))
- (lambda (prefix alias)
- (LAP ,@prefix
- ,@(if overflow?
- (do-overflow-subtraction tgt alias src)
- (LAP (SUB ,tgt ,alias ,src))))))))
-
-(define (do-overflow-subtraction tgt src1 src2)
- (set-current-branches!
- (lambda (if-overflow)
- (let ((if-no-overflow (generate-label)))
- (LAP (XOR ,regnum:assembler-temp ,src1 ,src2)
- (BGEZ ,regnum:assembler-temp (@PCR ,if-no-overflow))
- (SUBU ,tgt ,src1 ,src2)
- ,@(if (not (= tgt src1))
- (LAP (XOR ,regnum:assembler-temp ,tgt ,src1)
- (BLTZ ,regnum:assembler-temp (@PCR ,if-overflow)))
- (LAP (XOR ,regnum:assembler-temp ,tgt ,src2)
- (BGEZ ,regnum:assembler-temp (@PCR ,if-overflow))))
- (NOP)
- (LABEL ,if-no-overflow))))
- (lambda (if-no-overflow)
- (LAP (XOR ,regnum:assembler-temp ,src1 ,src2)
- (BGEZ ,regnum:assembler-temp (@PCR ,if-no-overflow))
- (SUBU ,tgt ,src1 ,src2)
- ,@(if (not (= tgt src1))
- (LAP (XOR ,regnum:assembler-temp ,tgt ,src1)
- (BGEZ ,regnum:assembler-temp (@PCR ,if-no-overflow)))
- (LAP (XOR ,regnum:assembler-temp ,tgt ,src2)
- (BLTZ ,regnum:assembler-temp (@PCR ,if-no-overflow))))
- (NOP))))
- (LAP))
-\f
-(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args
- (lambda (tgt src1 src2 overflow?)
- (do-multiply tgt src1 src2 overflow?)))
-
-(define-arithmetic-method 'MULTIPLY-FIXNUM
- fixnum-methods/2-args/register*constant
- (lambda (tgt src constant overflow?)
- (cond ((zero? constant)
- (if overflow? (no-overflow-branches!))
- (LAP (ADDI ,tgt 0 0)))
- ((= constant 1)
- (if overflow? (no-overflow-branches!))
- (LAP (ADD ,tgt 0 ,src)))
- ((let loop ((n constant))
- (and (> n 0)
- (if (= n 1)
- 0
- (and (even? n)
- (let ((m (loop (quotient n 2))))
- (and m
- (+ m 1)))))))
- =>
- (lambda (power-of-two)
- (if overflow?
- (do-left-shift-overflow tgt src power-of-two)
- (LAP (SLL ,tgt ,src ,power-of-two)))))
- (else
- (with-values (lambda () (immediate->register (* constant fixnum-1)))
- (lambda (prefix alias)
- (LAP ,@prefix
- ,@(do-multiply tgt src alias overflow?))))))))
-
-(define (do-multiply tgt src1 src2 overflow?)
- (if overflow?
- (let ((temp (standard-temporary!)))
- (set-current-branches!
- (lambda (if-overflow)
- (LAP (MFHI ,temp)
- (SRA ,regnum:assembler-temp ,tgt 31)
- (BNE ,temp ,regnum:assembler-temp
- (@PCR ,if-overflow))
- (NOP)))
- (lambda (if-no-overflow)
- (LAP (MFHI ,temp)
- (SRA ,regnum:assembler-temp ,tgt 31)
- (BEQ ,temp ,regnum:assembler-temp
- (@PCR ,if-no-overflow))
- (NOP))))))
- (LAP (SRA ,regnum:assembler-temp ,src1 ,scheme-type-width)
- (MULT ,regnum:assembler-temp ,src2)
- (MFLO ,tgt)))
-
-(define (do-left-shift-overflow tgt src power-of-two)
- (if (= tgt src)
- (let ((temp (standard-temporary!)))
- (set-current-branches!
- (lambda (if-overflow)
- (LAP (SLL ,temp ,src ,power-of-two)
- (SRA ,regnum:assembler-temp ,temp ,power-of-two)
- (BNE ,regnum:assembler-temp ,src (@PCR ,if-overflow))
- (ADD ,tgt 0 ,temp)))
- (lambda (if-no-overflow)
- (LAP (SLL ,temp ,src ,power-of-two)
- (SRA ,regnum:assembler-temp ,temp ,power-of-two)
- (BEQ ,regnum:assembler-temp ,src (@PCR ,if-no-overflow))
- (ADD ,tgt 0 ,temp)))))
- (set-current-branches!
- (lambda (if-overflow)
- (LAP (SLL ,tgt ,src ,power-of-two)
- (SRA ,regnum:assembler-temp ,tgt ,power-of-two)
- (BNE ,regnum:assembler-temp ,src (@PCR ,if-overflow))
- (NOP)))
- (lambda (if-no-overflow)
- (LAP (SLL ,tgt ,src ,power-of-two)
- (SRA ,regnum:assembler-temp ,tgt ,power-of-two)
- (BEQ ,regnum:assembler-temp ,src (@PCR ,if-no-overflow))
- (NOP)))))
- (LAP))
-\f
-(define-arithmetic-method 'FIXNUM-NOT fixnum-methods/1-arg
- (lambda (tgt src overflow?)
- overflow?
- (LAP (NOR ,tgt 0 ,src))))
-
-(define-arithmetic-method 'FIXNUM-AND fixnum-methods/2-args
- (lambda (tgt src1 src2 overflow?)
- overflow?
- (LAP (AND ,tgt ,src1 ,src2))))
-
-(define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args
- (lambda (tgt src1 src2 overflow?)
- overflow?
- (LAP (NOR ,regnum:assembler-temp 0 ,src2)
- (AND ,tgt ,src1 ,regnum:assembler-temp))))
-
-(define-arithmetic-method 'FIXNUM-OR fixnum-methods/2-args
- (lambda (tgt src1 src2 overflow?)
- overflow?
- (LAP (OR ,tgt ,src1 ,src2))))
-
-(define-arithmetic-method 'FIXNUM-XOR fixnum-methods/2-args
- (lambda (tgt src1 src2 overflow?)
- overflow?
- (LAP (XOR ,tgt ,src1 ,src2))))
-
-(define-arithmetic-method 'FIXNUM-LSH fixnum-methods/2-args
- (lambda (tgt src1 src2 overflow?)
- overflow?
- (let ((merge (generate-label 'LSH-MERGE))
- (neg (generate-label 'LSH-NEG)))
- (LAP (BLTZ ,src2 (@PCR ,neg))
- (SRA ,regnum:assembler-temp ,src2 ,scheme-type-width)
- (BGEZ 0 (@PCR ,merge))
- (SLLV ,tgt ,src1 ,regnum:assembler-temp)
- (LABEL ,neg)
- (SUB ,regnum:assembler-temp 0 ,regnum:assembler-temp)
- (SRLV ,tgt ,src1 ,regnum:assembler-temp)
- (SRL ,tgt ,tgt ,scheme-type-width)
- (SLL ,tgt ,tgt ,scheme-type-width)
- (LABEL ,merge)))))
-
-(define-arithmetic-method 'FIXNUM-LSH fixnum-methods/2-args/register*constant
- (lambda (tgt src constant overflow?)
- overflow?
- (guarantee-signed-fixnum constant)
- (cond ((= constant 0)
- (LAP (ADD ,tgt 0 ,src)))
- ((<= 1 constant (- scheme-datum-width 1))
- (LAP (SLL ,tgt ,src ,constant)))
- ((<= 1 (- constant) (- scheme-datum-width 1))
- (LAP (SRL ,tgt ,src ,(+ (- constant) scheme-type-width))
- (SLL ,tgt ,tgt ,scheme-type-width)))
- (else
- (LAP (ADDIU ,tgt 0 0))))))
-\f
-;;;; Predicates
-
-(define-rule predicate
- (OVERFLOW-TEST)
- ;; The RTL code generate guarantees that this instruction is always
- ;; immediately preceded by a fixnum operation with the OVERFLOW?
- ;; flag turned on. Furthermore, it also guarantees that there are
- ;; no other fixnum operations with the OVERFLOW? flag set. So all
- ;; the processing of overflow tests has been moved into the fixnum
- ;; operations.
- (LAP))
-
-(define-rule predicate
- (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
- (compare-immediate (fixnum-pred-1->cc predicate)
- 0
- (standard-source! source)))
-
-(define (fixnum-pred-1->cc predicate)
- (case predicate
- ((ZERO-FIXNUM?) '=)
- ((NEGATIVE-FIXNUM?) '>)
- ((POSITIVE-FIXNUM?) '<)
- (else (error "unknown fixnum predicate" predicate))))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (REGISTER (? source1))
- (REGISTER (? source2)))
- (compare (fixnum-pred-2->cc predicate)
- (standard-source! source1)
- (standard-source! source2)))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (REGISTER (? source))
- (OBJECT->FIXNUM (CONSTANT (? constant))))
- (compare-fixnum/constant*register (invert-condition-noncommutative
- (fixnum-pred-2->cc predicate))
- constant
- (standard-source! source)))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (REGISTER (? source)))
- (compare-fixnum/constant*register (fixnum-pred-2->cc predicate)
- constant
- (standard-source! source)))
-
-(define-integrable (compare-fixnum/constant*register cc n r)
- (guarantee-signed-fixnum n)
- (compare-immediate cc (* n fixnum-1) r))
-
-(define (fixnum-pred-2->cc predicate)
- (case predicate
- ((EQUAL-FIXNUM?) '=)
- ((LESS-THAN-FIXNUM?) '<)
- ((GREATER-THAN-FIXNUM?) '>)
- ((UNSIGNED-LESS-THAN-FIXNUM?) '<<)
- ((UNSIGNED-GREATER-THAN-FIXNUM?) '>>)
- (else (error "unknown fixnum predicate" predicate))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Flonum rules
-
-(declare (usual-integrations))
-\f
-(define (flonum-source! register)
- (float-register->fpr (load-alias-register! register 'FLOAT)))
-
-(define (flonum-target! pseudo-register)
- (delete-dead-registers!)
- (float-register->fpr (allocate-alias-register! pseudo-register 'FLOAT)))
-
-(define (flonum-temporary!)
- (float-register->fpr (allocate-temporary-register! 'FLOAT)))
-
-(define-rule statement
- ;; convert a floating-point number to a flonum object
- (ASSIGN (REGISTER (? target))
- (FLOAT->OBJECT (REGISTER (? source))))
- (let ((source (fpr->float-register (flonum-source! source))))
- (let ((target (standard-target! target)))
- (LAP
- ; (SW 0 (OFFSET 0 ,regnum:free)) ; make heap parsable forwards
- (ORI ,regnum:free ,regnum:free #b100) ; Align to odd quad byte
- ,@(deposit-type-address (ucode-type flonum) regnum:free target)
- ,@(with-values
- (lambda ()
- (immediate->register
- (make-non-pointer-literal (ucode-type manifest-nm-vector) 2)))
- (lambda (prefix alias)
- (LAP ,@prefix
- (SW ,alias (OFFSET 0 ,regnum:free)))))
- ,@(fp-store-doubleword 4 regnum:free source)
- (ADDI ,regnum:free ,regnum:free 12)))))
-
-(define-rule statement
- ;; convert a flonum object to a floating-point number
- (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source))))
- (let ((source (standard-move-to-temporary! source)))
- (let ((target (fpr->float-register (flonum-target! target))))
- (LAP ,@(object->address source source)
- ,@(fp-load-doubleword 4 source target #T)))))
-
-;; Floating-point vector support
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET (REGISTER (? base))
- (MACHINE-CONSTANT (? offset))))
- (let* ((base (standard-source! base))
- (target (fpr->float-register (flonum-target! target))))
- (fp-load-doubleword (* 8 offset) base target #T)))
-
-(define-rule statement
- (ASSIGN (FLOAT-OFFSET (REGISTER (? base))
- (MACHINE-CONSTANT (? offset)))
- (REGISTER (? source)))
- (let ((base (standard-source! base))
- (source (fpr->float-register (flonum-source! source))))
- (fp-store-doubleword (* 8 offset) base source)))
-\f
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET (REGISTER (? base)) (REGISTER (? index))))
- (with-indexed-address base index 3
- (lambda (address)
- (fp-load-doubleword 0 address
- (fpr->float-register (flonum-target! target)) #T))))
-
-(define-rule statement
- (ASSIGN (FLOAT-OFFSET (REGISTER (? base)) (REGISTER (? index)))
- (REGISTER (? source)))
- (with-indexed-address base index 3
- (lambda (address)
- (fp-store-doubleword 0 address
- (fpr->float-register (flonum-source! source))))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? w-offset)))
- (MACHINE-CONSTANT (? f-offset))))
- (let* ((base (standard-source! base))
- (target (fpr->float-register (flonum-target! target))))
- (fp-load-doubleword (+ (* 4 w-offset) (* 8 f-offset)) base target #T)))
-
-(define-rule statement
- (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? w-offset)))
- (MACHINE-CONSTANT (? f-offset)))
- (REGISTER (? source)))
- (let ((base (standard-source! base))
- (source (fpr->float-register (flonum-source! source))))
- (fp-store-doubleword (+ (* 4 w-offset) (* 8 f-offset)) base source)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? w-offset)))
- (REGISTER (? index))))
- (with-indexed-address base index 3
- (lambda (address)
- (fp-load-doubleword (* 4 w-offset) address
- (fpr->float-register (flonum-target! target))
- #T))))
-
-(define-rule statement
- (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? w-offset)))
- (REGISTER (? index)))
- (REGISTER (? source)))
- (with-indexed-address base index 3
- (lambda (address)
- (fp-store-doubleword (* 4 w-offset) address
- (fpr->float-register (flonum-source! source))))))
-\f
-;;;; Flonum Arithmetic
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?)))
- overflow? ;ignore
- (let ((source (flonum-source! source)))
- ((flonum-1-arg/operator operation) (flonum-target! target) source)))
-
-(define (flonum-1-arg/operator operation)
- (lookup-arithmetic-method operation flonum-methods/1-arg))
-
-(define flonum-methods/1-arg
- (list 'FLONUM-METHODS/1-ARG))
-
-;;; Notice the weird ,', syntax here.
-;;; If LAP changes, this may also have to change.
-
-(let-syntax
- ((define-flonum-operation
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-ARITHMETIC-METHOD ',(cadr form) FLONUM-METHODS/1-ARG
- (LAMBDA (TARGET SOURCE)
- (LAP (,(caddr form) ,',TARGET ,',SOURCE))))))))
- (define-flonum-operation flonum-abs ABS.D)
- (define-flonum-operation flonum-negate NEG.D))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLONUM-2-ARGS (? operation)
- (REGISTER (? source1))
- (REGISTER (? source2))
- (? overflow?)))
- overflow? ;ignore
- (let ((source1 (flonum-source! source1))
- (source2 (flonum-source! source2)))
- ((flonum-2-args/operator operation) (flonum-target! target)
- source1
- source2)))
-
-(define (flonum-2-args/operator operation)
- (lookup-arithmetic-method operation flonum-methods/2-args))
-
-(define flonum-methods/2-args
- (list 'FLONUM-METHODS/2-ARGS))
-
-(let-syntax
- ((define-flonum-operation
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-ARITHMETIC-METHOD ',(cadr form) FLONUM-METHODS/2-ARGS
- (LAMBDA (TARGET SOURCE1 SOURCE2)
- (LAP (,(caddr form) ,',TARGET ,',SOURCE1 ,',SOURCE2))))))))
- (define-flonum-operation flonum-add ADD.D)
- (define-flonum-operation flonum-subtract SUB.D)
- (define-flonum-operation flonum-multiply MUL.D)
- (define-flonum-operation flonum-divide DIV.D))
-\f
-;;;; Flonum Predicates
-
-(define-rule predicate
- (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
- ;; No immediate zeros, easy to generate by subtracting from itself
- (let ((temp (flonum-temporary!))
- (source (flonum-source! source)))
- (LAP (MTC1 0 ,temp)
- (MTC1 0 ,(+ temp 1))
- (NOP)
- ,@(flonum-compare
- (case predicate
- ((FLONUM-ZERO?) 'C.EQ.D)
- ((FLONUM-NEGATIVE?) 'C.LT.D)
- ((FLONUM-POSITIVE?) 'C.GT.D)
- (else (error "unknown flonum predicate" predicate)))
- source temp))))
-
-(define-rule predicate
- (FLONUM-PRED-2-ARGS (? predicate)
- (REGISTER (? source1))
- (REGISTER (? source2)))
- (flonum-compare (case predicate
- ((FLONUM-EQUAL?) 'C.EQ.D)
- ((FLONUM-LESS?) 'C.LT.D)
- ((FLONUM-GREATER?) 'C.GT.D)
- (else (error "unknown flonum predicate" predicate)))
- (flonum-source! source1)
- (flonum-source! source2)))
-
-(define (flonum-compare cc r1 r2)
- (set-current-branches!
- (lambda (label)
- (LAP (BC1T (@PCR ,label)) (NOP)))
- (lambda (label)
- (LAP (BC1F (@PCR ,label)) (NOP))))
- (if (eq? cc 'C.GT.D)
- (LAP (C.LT.D ,r2 ,r1) (NOP))
- (LAP (,cc ,r1 ,r2) (NOP))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RTL Rewrite Rules
-
-(declare (usual-integrations))
-\f
-;;;; Synthesized Data
-
-(define-rule rewriting
- (CONS-NON-POINTER (REGISTER (? type register-known-value))
- (REGISTER (? datum register-known-value)))
- (QUALIFIER (and (rtl:machine-constant? type)
- (rtl:machine-constant? datum)))
- (rtl:make-cons-non-pointer type datum))
-
-(define-rule rewriting
- (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
- (QUALIFIER
- (and (rtl:object->type? type)
- (rtl:constant? (rtl:object->type-expression type))))
- (rtl:make-cons-pointer
- (rtl:make-machine-constant
- (object-type (rtl:object->type-expression datum)))
- datum))
-
-(define-rule rewriting
- (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
- (QUALIFIER (rtl:machine-constant? type))
- (rtl:make-cons-pointer type datum))
-
-(define-rule rewriting
- (CONS-NON-POINTER (REGISTER (? type register-known-value)) (? datum))
- (QUALIFIER (rtl:machine-constant? type))
- (rtl:make-cons-non-pointer type datum))
-
-(define-rule rewriting
- (CONS-NON-POINTER (REGISTER (? type register-known-value)) (? datum))
- (QUALIFIER
- (and (rtl:object->type? type)
- (rtl:constant? (rtl:object->type-expression type))))
- (rtl:make-cons-non-pointer
- (rtl:make-machine-constant
- (object-type (rtl:object->type-expression datum)))
- datum))
-
-(define-rule rewriting
- (CONS-NON-POINTER (? type) (REGISTER (? datum register-known-value)))
- (QUALIFIER
- (and (rtl:object->datum? datum)
- (rtl:constant-non-pointer? (rtl:object->datum-expression datum))))
- (rtl:make-cons-non-pointer
- type
- (rtl:make-machine-constant
- (careful-object-datum
- (rtl:constant-value (rtl:object->datum-expression datum))))))
-
-(define-rule rewriting
- (OBJECT->TYPE (REGISTER (? source register-known-value)))
- (QUALIFIER (rtl:constant? source))
- (rtl:make-machine-constant (object-type (rtl:constant-value source))))
-
-(define-rule rewriting
- (OBJECT->DATUM (REGISTER (? source register-known-value)))
- (QUALIFIER (rtl:constant-non-pointer? source))
- (rtl:make-machine-constant
- (careful-object-datum (rtl:constant-value source))))
-
-(define (rtl:constant-non-pointer? expression)
- (and (rtl:constant? expression)
- (non-pointer-object? (rtl:constant-value expression))))
-\f
-;;; These rules are losers because there's no abstract way to cons a
-;;; statement or a predicate without also getting some CFG structure.
-
-(define-rule rewriting
- ;; Use register 0, always 0.
- (ASSIGN (? target) (REGISTER (? comparand register-known-value)))
- (QUALIFIER (rtl:immediate-zero-constant? comparand))
- (list 'ASSIGN target (rtl:make-machine-register 0)))
-
-(define-rule rewriting
- ;; Compare to register 0, always 0.
- (EQ-TEST (? source) (REGISTER (? comparand register-known-value)))
- (QUALIFIER (rtl:immediate-zero-constant? comparand))
- (list 'EQ-TEST source (rtl:make-machine-register 0)))
-
-(define-rule rewriting
- ;; Compare to register 0, always 0.
- (EQ-TEST (REGISTER (? comparand register-known-value)) (? source))
- (QUALIFIER (rtl:immediate-zero-constant? comparand))
- (list 'EQ-TEST source (rtl:make-machine-register 0)))
-
-(define (rtl:immediate-zero-constant? expression)
- (cond ((rtl:constant? expression)
- (let ((value (rtl:constant-value expression)))
- (and (non-pointer-object? value)
- (zero? (object-type value))
- (zero? (careful-object-datum value)))))
- ((rtl:cons-non-pointer? expression)
- (and (let ((expression (rtl:cons-non-pointer-type expression)))
- (and (rtl:machine-constant? expression)
- (zero? (rtl:machine-constant-value expression))))
- (let ((expression (rtl:cons-non-pointer-datum expression)))
- (and (rtl:machine-constant? expression)
- (zero? (rtl:machine-constant-value expression))))))
- (else false)))
-\f
-;;;; Fixnums
-
-;; I've copied this rule from the MC68020. -- Jinx
-;; It should probably be qualified to be in the immediate range.
-
-(define-rule rewriting
- (OBJECT->FIXNUM (REGISTER (? source register-known-value)))
- (QUALIFIER (rtl:constant-fixnum? source))
- (rtl:make-object->fixnum source))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS FIXNUM-LSH
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- #F)
- (QUALIFIER (and (rtl:register? operand-1)
- (rtl:constant-fixnum? operand-2)))
- (rtl:make-fixnum-2-args 'FIXNUM-LSH operand-1 operand-2 #F))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (REGISTER (? operand-1 register-known-value))
- (? operand-2)
- #F)
- (QUALIFIER (rtl:constant-fixnum-4? operand-1))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- #F)
- (QUALIFIER (rtl:constant-fixnum-4? operand-2))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (REGISTER (? operand-1 register-known-value))
- (? operand-2)
- #F)
- (QUALIFIER
- (and (rtl:object->fixnum-of-register? operand-1)
- (rtl:constant-fixnum-4? operand-2)))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- #F)
- (QUALIFIER
- (and (rtl:constant-fixnum-4? operand-1)
- (rtl:object->fixnum-of-register? operand-2)))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
-
-(define (rtl:constant-fixnum? expression)
- (and (rtl:constant? expression)
- (fix:fixnum? (rtl:constant-value expression))))
-
-(define (rtl:constant-fixnum-4? expression)
- (and (rtl:object->fixnum? expression)
- (let ((expression (rtl:object->fixnum-expression expression)))
- (and (rtl:constant? expression)
- (eqv? 4 (rtl:constant-value expression))))))
-
-(define (rtl:object->fixnum-of-register? expression)
- (and (rtl:object->fixnum? expression)
- (rtl:register? (rtl:object->fixnum-expression expression))))
-\f
-;;;; Closures and other optimizations.
-
-(define-rule rewriting
- (CONS-POINTER (REGISTER (? type register-known-value))
- (REGISTER (? datum register-known-value)))
- (QUALIFIER (and (rtl:machine-constant? type)
- (= (rtl:machine-constant-value type)
- (ucode-type compiled-entry))
- (or (rtl:entry:continuation? datum)
- (rtl:entry:procedure? datum)
- (rtl:cons-closure? datum))))
- (rtl:make-cons-pointer type datum))
-
-(define-rule rewriting
- (FLOAT-OFFSET (REGISTER (? base register-known-value))
- (MACHINE-CONSTANT 0))
- (QUALIFIER (and (rtl:float-offset-address? base)
- (rtl:simple-subexpressions? base)))
- (rtl:make-float-offset (rtl:float-offset-address-base base)
- (rtl:float-offset-address-offset base)))
-
-(define (rtl:simple-subexpressions? expr)
- (for-all? (cdr expr)
- (lambda (sub)
- (or (rtl:machine-constant? sub)
- (rtl:register? sub)))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Assembler Machine Dependencies
-
-(declare (usual-integrations))
-\f
-(let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form))))))
-
-(define-integrable maximum-padding-length
- ;; Instruction length is always a multiple of 32 bits
- ;; Would 0 work here?
- 32)
-
-(define padding-string
- ;; Pad with `UNIMP' instructions
- (unsigned-integer->bit-string maximum-padding-length
- #b00000000000000000000000000000000 ))
-
-(define-integrable block-offset-width
- ;; Block offsets are always 16 bit words
- 16)
-
-(define-integrable maximum-block-offset
- ;; PC always aligned on longword boundary. Use the extra bit.
- (- (expt 2 (1+ block-offset-width)) 4))
-
-(define (block-offset->bit-string offset start?)
- (unsigned-integer->bit-string block-offset-width
- (+ (quotient offset 2)
- (if start? 0 1))))
-
-(define (make-nmv-header n)
- (bit-string-append (unsigned-integer->bit-string scheme-datum-width n)
- nmv-type-string))
-
-(define nmv-type-string
- (unsigned-integer->bit-string scheme-type-width
- (ucode-type manifest-nm-vector)))
-
-(define (object->bit-string object)
- (bit-string-append
- (unsigned-integer->bit-string scheme-datum-width
- (careful-object-datum object))
- (unsigned-integer->bit-string scheme-type-width (object-type object))))
-
-;;; Machine dependent instruction order
-
-(define (instruction-insert! bits block position receiver)
- (let ((l (bit-string-length bits)))
- (if (eq? endianness 'LITTLE)
- (begin
- (bit-substring-move-right! bits 0 l block position)
- (receiver (+ position l)))
- (let ((new-position (- position l)))
- (bit-substring-move-right! bits 0 l block new-position)
- (receiver new-position)))))
-
-(define-integrable instruction-initial-position bit-string-length)
-(define-integrable instruction-append bit-string-append-reversed)
-
-;;; end let-syntax
-)
\ No newline at end of file
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#define PROC_TYPE_UNKNOWN 0
-#define PROC_TYPE_68000 1
-#define PROC_TYPE_68020 2
-#define PROC_TYPE_HPPA 3 /* HP Precision Architecture */
-#define PROC_TYPE_VAX 4
-#define PROC_TYPE_MIPS 5
-#define PROC_TYPE_NS32K 6
-#define PROC_TYPE_HCX 7 /* Harris HCX */
-#define PROC_TYPE_IBM032 8 /* IBM RT */
-#define PROC_TYPE_SPARC 9
-#define PROC_TYPE_I386 10
-#define PROC_TYPE_ALPHA 11
-#define PROC_TYPE_POWER 12 /* IBM RS6000 and PowerPC */
-
-/* Define this macro to use a non-standard compiler.
- It must be defined before including the m/ and s/ files because
- they may be conditionalized on it. */
-
-#define ALTERNATE_CC gcc-2.3.3
-
-/* Define this macro to use a non-standard assembler. */
-/* #define ALTERNATE_AS gashp */
-
-#include "s.h"
-#include "m.h"
-
-#ifndef PROC_TYPE
-#define PROC_TYPE PROC_TYPE_UNKNOWN
-#endif
-
-/* Define HAVE_X_WINDOWS if you want to use the X window system. */
-#define HAVE_X_WINDOWS
-
-/* Define HAVE_STARBASE_GRAPHICS if you want Starbase graphics support.
- This is specific to HP-UX. */
-/* #define HAVE_STARBASE_GRAPHICS */
-/* #define STARBASE_DEVICE_DRIVERS -ldd300h -ldd98700 -ldd98710 -ldd98556 */
-
-/* Some compilation options:
- -DDISABLE_HISTORY turns off history recording mechanism */
-#define C_SWITCH_FEATURES
-
-/* The following two switches are mutually exclusive for most C compilers.
- An exception is the GNU C compiler. */
-
-/* If defined, this prevents the C compiler from running its optimizer. */
-#define SUPPRESS_C_OPTIMIZER
-
-/* If defined, this prevents the C compiler from
- generating debugging information. */
-#define SUPPRESS_C_DEBUGGING
+++ /dev/null
-/* #define DEBUG_INTERFACE */ /* -*-Midas-*- */
- !###
- !### Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
- !### 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- !### 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
- !### 2014, 2015, 2016, 2017 Massachusetts Institute of Technology
- !###
- !### This file is part of MIT/GNU Scheme.
- !###
- !### MIT/GNU Scheme is free software; you can redistribute it and/or
- !### modify it under the terms of the GNU General Public License as
- !### published by the Free Software Foundation; either version 2 of
- !### the License, or (at your option) any later version.
- !###
- !### MIT/GNU Scheme is distributed in the hope that it will be
- !### useful, but WITHOUT ANY WARRANTY; without even the implied
- !### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- !### See the GNU General Public License for more details.
- !###
- !### You should have received a copy of the GNU General Public
- !### License along with MIT/GNU Scheme; if not, write to the Free
- !### Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
- !### MA 02110-1301, USA.
- !###
-
- !#### SPARC Architecture assembly language part of the compiled
- !#### code interface. See cmpint.txt, cmpint.c, cmpint-mips.h, and
- !#### cmpgc.h for more documentation.
- !####
- !#### NOTE:
- !#### Assumptions:
- !####
- !#### 1) All registers (except double floating point registers) and
- !#### stack locations hold a C long object.
- !####
- !#### 2) The C compiler divides registers into four categories:
- !#### in: (%i7-%i0 or %r31-%r24) incoming parameters
- !#### note: %fp is in this group
- !#### note: %i7 holds the C return address, don't bash this.
- !####
- !#### out: (%o7-%o0 or %r15-%r8) outgoing parameters
- !#### note: %sp is in this group
- !####
- !#### locals: (%l7-%l0 or %r23-%r16)
- !####
- !#### globals: (%g7-%g0 or %r7-%r0), reserved, essentially useless
- !####
- !#### The ins and locals are callee save through the standard SPARC save
- !#### and restore instructions. This has the added effect of cleaning
- !#### up the stack and frame pointers correctly. Globals are callee save.
- !#### Note that save and restore also pose as simulataneous add
- !#### instructions. This comes in handy for allocating the stack frame.
- !####
- !#### 3) On SPARC the floating point registers are totally ungoverned.
- !#### The de-facto standard is caller save.
-
-
- !#### Compiled Scheme code uses the following register convention.
- !#### - g0 is the 0 constant (hardwired)
- !#### - g1 is the designated temporary (scheme available)
- !#### - g2-g4 are available for globals (scheme available)
- !#### - g5-g7 are off limits super globals. (don't touch!)
- !#### < Start of C callee saves >
- !#### - l0 is the return value register. (scheme available)
- !#### - l1 contains the Scheme stack pointer. (scheme available)
- !#### - l2 contains a cached version of MemTop. (scheme available)
- !#### - l3 contains the Scheme free pointer. (scheme available)
- !#### - l4 contains the address of scheme_to_interface. (scheme available)
- !#### - l5 contains the dynamic link when needed. (scheme available)
- !#### - l6 contains the closure free pointer. (scheme available)
- !#### - l7 is leftover (used for tramp index) (scheme available)
- !#### - i0 is the C return value / first parameter (scheme available)
- !#### - i1 contains the address mask for machine pointers. (scheme available)
- !#### - i2 contains a pointer to the Scheme interpreter's (scheme available)
- !#### "register" block. This block contains the compiler's
- !#### copy of MemTop, the interpreter's registers (val, env,
- !#### exp, etc), temporary locations for compiled code.
- !#### - i3 contains the top 6 address bits for heap pointers. (scheme available)
- !#### - i4 contains the closure hook. (scheme available)
- !#### - i5 is leftover. (scheme available)
- !#### - i6 is the C frame pointer, alternatively the old C sp.(don't touch!)
- !#### - i7 is the C return address. (don't touch!)
- !#### < End of C callee saves >
- !#### - o7 is the target of call instructions, ie next pc. (scheme available)
- !#### - o6 is the current C stack pointer. (scheme available)
- !#### - o5-o1 are outgoing parameters to the C world. (scheme available)
- !#### - o0 is an outgoing parameter to the C world, and the return value
- !#### from there (scheme available)
- !####
-
- !# .verstamp 1 31
-
-define(value, l0)
-define(stack, l1)
-define(C_arg1, o0)
-define(C_arg2, o1)
-define(C_arg3, o2)
-define(C_arg4, o3)
-define(utility_index, o5)
-
-define(memtop, l2)
-define(free, l3)
-define(s_to_i, l4)
-define(dynlink, l5)
-
-define(closure_free, l6)
-define(addr_mask, i1)
-define(registers, i2)
-define(heap_bits, i3)
-define(closure_reg, i4)
-
- .global _Free
- .global _Registers
- .global _Ext_Stack_Pointer
-
- .text
- .align 4
-
-
- !# Argument (in $C_arg1) is a compiled Scheme entry point
- !# but save C registers first
- .align 4
- .global _C_to_interface
- .proc 020
-_C_to_interface:
- save %sp,-104,%sp
-
- !# Make space for interface return structs and stick a pointer to
- !# on the stack. SPARC C calling conventions require this.
-
- add %fp, -24, %o0
- st %o0,[%sp+64]
-
- !# Now stick the right interpreter registers into the right machine
- !# registers.
-
- sethi %hi(_Free), %g1
- ld [%g1+%lo(_Free)], %heap_bits
- sethi %hi(0xfc000000), %addr_mask
- sethi %hi(_Registers), %g1
- or %g1, %lo(_Registers), %registers
- and %heap_bits, %addr_mask, %heap_bits
- xnor %g0, %addr_mask, %addr_mask
-
- .align 4
- .global _interface_to_scheme
-_interface_to_scheme:
-
- sethi %hi(_Free), %g1
- ld [%g1+%lo(_Free)], %free
- sethi %hi(_Ext_Stack_Pointer), %g1
- ld [%g1+%lo(_Ext_Stack_Pointer)], %stack
-
- ld [%registers + 36],%closure_free
- ld [%registers + 8],%value
- ld [%registers],%memtop
-
- and %value,%addr_mask,%dynlink
- or %dynlink,%heap_bits,%dynlink
- jmpl %i0 + 0, %o7
- add %o7,264,%s_to_i
-
-!# Don't rearrange the following procedures. The compiler backend knows their offsets
-!# from scheme_to_interface and uses this knowledge to jump to them.
-
- .align 4
- .global _cons_multi_closure
- !# arg1 -> linkage data start address
- !# arg2 -> number of entries
- !# arg3 -> contains contents of %free
- !# %s_to_1 -256
- !# C_arg1 points to a manifest closure header word, followed by
- !# nentries two-word structures, followed by the actual
- !# instructions to return to.
- !# The first word of each descriptor is the format+gc-offset word of
- !# the corresponding entry point of the generated closure.
- !# The second word is the offset from the entry address to the real
- !# code of the closure.
-_cons_multi_closure:
- save %sp, -96, %sp
- add %i0, 0, %l0
-
- !# Stuff the tag word and length into the beginning of the multi-closure
- !# also write in the number of entries word.
- ld [%l0], %g1
- st %g1, [%i2]
- add %l0, 4, %l0
-
- sll %i1, 16, %g1
- st %g1, [%i2 + 4]
-
- !# Setup a template for the Addi part of each entry
- sethi %hi(0x82006008), %l1
- add %lo(0x82006008), %l1, %l1
-
- !# Calcualate the first offset to the closed var.
- add %i1, -1, %l2
- umul %l2, 16, %l2
-
- !# Copy free and bump it up two words
- add %i2, 8, %l3
-
-cmc_l2:
- !# Copy the format+gc-offset word into the start of the entry
- ld [%l0], %g1
- st %g1, [%l3]
-
- !# Construct the sethi(target) part of the entry
- ld [%l0+4], %g1
- add %i0, %g1, %g1
- srl %g1, 10, %l4
- sethi %hi(0x03000000), %l5
- or %l4, %l5, %l5
- st %l5, [%l3+4]
-
- !# Construct the jmpl(lo(target)) part of the entry
- and %g1, 0x3ff, %l4
- sethi %hi(0x83c06000), %l5
- or %l4, %l5, %l5
- st %l5, [%l3+8]
-
- !# Construct the addi offset-to-data part of the entry
- add %l2, %l1, %l5
- st %l5, [%l3+12]
-
- !# Flush the instruction cache
- iflush %l3 + 4
- iflush %l3 + 8
- iflush %l3 + 12
-
- !# Bump to the next entry, next set of data
-
- add %l3, 16, %l3
- add %l0, 8, %l0
- subcc %l2, 16, %l2
- bge cmc_l2
- nop
-
- add %l0, 0, %g1
- jmpl %g1, %g0
- restore
-
- .align 4
- .global _cons_closure
- !# arg1 -> return address
- !# arg2 -> delta from return address
- !# arg3 -> closure size (in bytes)
- !# arg4 -> using as an extra temp
- !# s_to_i -108
-_cons_closure:
- ld [%C_arg1], %g1
- st %g1, [%free]
- ld [%C_arg1 + 4], %g1
- st %g1, [%free + 4]
- add %g0, %g0, %C_arg4
- add %C_arg2, %C_arg1, %C_arg2
- sethi %hi(0x03000000), %C_arg4
- srl %C_arg2, 10, %g1
- add %g1, %C_arg4, %C_arg4
- st %C_arg4, [%free + 8]
- sethi %hi(0x83c06000), %C_arg4
- and 0x3ff, %C_arg2, %g1
- add %g1, %C_arg4, %C_arg4
- st %C_arg4, [%free + 12]
- sethi %hi(0x82006008), %C_arg4
- add %lo(0x82006008), %C_arg4, %C_arg4
- st %C_arg4, [%free + 16]
- iflush %free + 8
- iflush %free + 12
- iflush %free + 16
- add %free, 8, %C_arg2
- add %C_arg3, %free, %free
- add %C_arg1, 8, %C_arg1
- jmpl %C_arg1, %g0
- nop
-
- .align 4
- .global _trampoline_to_interface
- !# s_to_i - 8
-_trampoline_to_interface:
- add %C_arg1, -4, %C_arg1
-
- .align 4
- .global _link_to_interface
- !# s_to_i - 4
-_link_to_interface:
- add %C_arg1, 12, %C_arg1
-
- .align 4
- .global _scheme_to_interface
- .proc 020
-_scheme_to_interface:
- st %value,[%registers + 8]
- st %closure_free,[%registers + 36]
-
- sethi %hi(_utility_table), %g1
- or %g1, %lo(_utility_table), %g1 !# Find table
- add %g1,%utility_index,%g1 !# Address of entry
- ld [%g1],%l7 !# l7 <- Entry
- nop
- sethi %hi(_Ext_Stack_Pointer), %g1
- st %stack,[%g1+%lo(_Ext_Stack_Pointer)] !# Save Scheme stack pointer
- nop
- sethi %hi(_Free), %g1
- st %free,[%g1+%lo(_Free)] !# Save Free
- nop
- jmpl %l7 + 0, %o7 !# Off to interface code
- nop
- unimp 8
- ld [%o0 + 4],%i0 !# Get dispatch address
- ld [%o0],%C_arg1 !# Arg1 <- value component
- jmpl %C_arg1,%o7 !# Redispatch ...
- nop !# Branch delay
-
- .align 4
- .global _interface_to_C
- .proc 020
-_interface_to_C:
- add %i0,%g0,%C_arg1 !# Return value to C
- ret !# Return to the C universe
- restore !# Restore callee save regs
-
- .align 4
- .global _flushrange
- .proc 020
-_flushrange:
- save %sp,-96,%sp
- !# arg1: address base, arg2: byte count
- add %g0, %g0, %l0
-flush_l:
- iflush %i0 + %l0
- add 4, %l0, %l0
- subcc %l0,%i1,%g0
- bl flush_l !# Continue if address < address + count
- nop
- nop !# flush pipeline
- nop
- nop
- nop
- nop
- ret !# Return to caller
- restore !# Restore callee save regs
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/*
- *
- * Compiled code interface macros.
- *
- * See cmpint.txt for a description of these fields.
- *
- * Specialized for the MIPS R2000/R3000
- */
-
-#ifndef CMPINT2_H_INCLUDED
-#define CMPINT2_H_INCLUDED
-
-#define ICACHEFLUSH(addr, nbytes) flushrange ((addr), (nbytes))
-
-#define COMPILER_NONE_TYPE 0
-#define COMPILER_MC68020_TYPE 1
-#define COMPILER_VAX_TYPE 2
-#define COMPILER_SPECTRUM_TYPE 3
-#define COMPILER_OLD_MIPS_TYPE 4
-#define COMPILER_MC68040_TYPE 5
-#define COMPILER_SPARC_TYPE 6
-#define COMPILER_RS6000_TYPE 7
-#define COMPILER_MC88K_TYPE 8
-#define COMPILER_I386_TYPE 9
-#define COMPILER_ALPHA_TYPE 10
-#define COMPILER_MIPS_TYPE 11
-\f
-/* Machine parameters to be set by the user. */
-
-/* Processor type. Choose a number from the above list, or allocate your own. */
-
-#define COMPILER_PROCESSOR_TYPE COMPILER_SPARC_TYPE
-
-/* Size (in long words) of the contents of a floating point register if
- different from a double. For example, an MC68881 saves registers
- in 96 bit (3 longword) blocks.
- Default is fine for MIPS.
- define COMPILER_TEMP_SIZE 3
-*/
-
-/* Descriptor size.
- This is the size of the offset field, and of the format field.
- This definition probably does not need to be changed.
- */
-
-typedef unsigned short format_word;
-
-/* PC alignment constraint.
- Change PC_ZERO_BITS to be how many low order bits of the pc are
- guaranteed to be 0 always because of PC alignment constraints.
-*/
-
-#define PC_ZERO_BITS 2
-\f
-/* Utilities for manipulating absolute subroutine calls.
- On the SPARC this is done with:
- CALL destination
-
- The low 30 bits of the instruction form the address. This will
- automatically be shifted over 2 bits to adjust for alignment.
- */
-
-#define EXTRACT_FROM_JAL_INSTR(target, address) \
-{ \
- unsigned long * addr = ((unsigned long *) (address)); \
- unsigned long jal_instr = (*addr); \
- (target) = \
- ((SCHEME_OBJECT) \
- ((((long) (address)) & 0x3FFFFFFF))); \
-}
-
-#define CALL_OP (0x1 << 30)
-#define CALL_INSTR(dest) (CALL_OP | (dest >> 2))
-
-#define STORE_JAL_INSTR(entry_point, address) \
-{ \
- unsigned long ep = ((unsigned long) (entry_point)); \
- unsigned long * addr = ((unsigned long *) (address)); \
- if ((((long) addr) & 0x3) != 0) \
- { \
- fprintf (stderr, \
- "\nSTORE_JAL_INSTR: Bad addr in CALL 0x%x, 0x%x\n", \
- addr, ep); \
- } \
- (*addr) = CALL_INSTR (ep); \
-}
-\f
-/* Compiled Code Register Conventions */
-/* This must match the compiler and cmpaux-sparc.s */
-
-#define COMP_REG_TEMPORARY 1
-#define COMP_REG_RETURN 16
-#define COMP_REG_STACK 17
-#define COMP_REG_C_ARG_1 8
-#define COMP_REG_C_ARG_2 9
-#define COMP_REG_C_ARG_3 10
-#define COMP_REG_C_ARG_4 11
-#define COMP_REG_MEMTOP 18
-#define COMP_REG_FREE 19
-#define COMP_REG_SCHEME_TO_INTERFACE 20
-#define COMP_REG_DYNAMIC_LINK 21
-#define COMP_REG_TRAMP_INDEX 13
-
-#define COMP_REG_CLOSURE_FREE 22
-#define COMP_REG_ADDRESS_MASK 25
-#define COMP_REG_REGISTERS 26
-#define COMP_REG_QUAD_MASK 27
-#define COMP_REG_CLOSURE_HOOK 28
-
-#define COMP_REG_KERNEL_RESERVED_1 2
-#define COMP_REG_KERNEL_RESERVED_2 3
-#define COMP_REG_KERNEL_RESERVED_3 4
-#define COMP_REG_C_GLOBALS
-#define COMP_REG_C_STACK 30
-#define COMP_REG_LINKAGE 31
-
-/* Interrupt/GC polling. */
-
-/* Skip over this many BYTES to bypass the GC check code (ordinary
-procedures and continuations differ from closures) */
-
-#define ENTRY_SKIPPED_CHECK_OFFSET 12
-#define CLOSURE_SKIPPED_CHECK_OFFSET 40
-
-/* The length of the GC recovery code that precedes an entry.
- On the SPARC a "addi, jalr, addi" instruction sequence.
- */
-
-#define ENTRY_PREFIX_LENGTH 12
-
-/*
- The instructions for a normal entry should be something like
-
- ADDICC $at,$FREE,$MEMTOP
- BGE interrupt
- LD $MEMTOP,REG_BLOCK
-
- For a closure
-
- LUI $at,FROB(TC_CLOSURE) ; temp <- closure tag
- XOR $1,$1,$at ; 1 <- tagged value
- ADDI $SP,$SP,-4 ; push closure
- ST $1,0($SP)
- ADDICC $at,$FREE,$MEMTOP
- BGE interrupt
- LD $MEMTOP,REG_BLOCK
-*/
-
-/* A NOP on machines where instructions are longword-aligned. */
-
-#define ADJUST_CLOSURE_AT_CALL(entry_point, location) \
-do { \
-} while (0)
-
-/* Compiled closures */
-
-/* Manifest closure entry block size.
- Size in bytes of a compiled closure's header excluding the
- TC_MANIFEST_CLOSURE header.
-
- On the SPARC this is 2 format_words for the format word and gc offset
- words, and 12 more bytes for 3 instructions.
-
- The three instructions are:
-
- SETHI %HI(TARGET), GLOBAL_TEMP
- JMPL [GLOBAL_TEMP + %LO(TARGET)], GLOBAL_TEMP
- ADDI 8,GLOBAL_TEMP,GLOBAL_TEMP
- */
-
-#define SETHI_GLOBAL_TEMP_TEMPLATE 0x03000000
-#define NOP_INSTRUCTION 0x01000000
-#define JMPL_TEMPLATE 0x81c06000
-#define CLOSURE_JMPL_TEMPLATE 0x83c06000
-
-#define COMPILED_CLOSURE_ENTRY_SIZE 16
-
-/* Manifest closure entry destructuring.
-
- Given the entry point of a closure, extract the `real entry point'
- (the address of the real code of the procedure, ie. one indirection)
- from the closure.
-
- On the SPARC we have to extract from a SETHI/JMPL_OFFSET sequence.
-
-*/
-
-#define EXTRACT_CLOSURE_ENTRY_ADDRESS(extracted_ep, clos_addr) do \
-{ \
- unsigned long * addr = ((unsigned long*)(clos_addr)); \
- unsigned long sethi_instr = addr[0]; \
- unsigned long jmpl_instr = addr[1]; \
- (extracted_ep) = \
- ((SCHEME_OBJECT) \
- (((sethi_instr & 0x3fffff) << 10) | (jmpl_instr & 0x3ff))); \
-} while (0)
-
-/* This is the inverse of EXTRACT_CLOSURE_ENTRY_ADDRESS.
- Given a closure's entry point and a code entry point, store the
- code entry point in the closure.
- */
-
-/* The following is a SPARC ADDI 8,G1,G1 */
-#define CLOSURE_BUMP_LINKAGE_TO_DATA_INSTR 0x82006008
-
-#define STORE_CLOSURE_ENTRY_ADDRESS(ep_to_store, clos_addr) do \
-{ \
- unsigned long * addr = (unsigned long *)(clos_addr); \
- unsigned long target = (unsigned long)(ep_to_store); \
- addr[0] = (addr[0] & SETHI_GLOBAL_TEMP_TEMPLATE) | (target >> 10); \
- addr[1] = (addr[1] & CLOSURE_JMPL_TEMPLATE) | (target & 0x000003ff); \
- addr[2] = CLOSURE_BUMP_LINKAGE_TO_DATA_INSTR; \
-} while (0)
-\f
-/* Trampolines
-
- On the SPARC, here's a picture of a trampoline (offset in bytes from
- entry point)
-
- -12: MANIFEST vector header
- - 8: NON_MARKED header
- - 4: Format word
- - 2: 0x6 (GC Offset to start of block from .+2)
- Note the encoding -- divided by 2, low bit for
- extended distances (see OFFSET_WORD_TO_BYTE_OFFSET)
- 0: ADDI TEMP,SCHEME_TO_INTERFACE,MAGIC_CONSTANT
- 4: JALR LINKAGE,TEMP
- 8: ADDI TRAMP_INDEX,0,index
- 12: trampoline dependent storage (0 - 3 longwords)
-
- TRAMPOLINE_ENTRY_SIZE is the size in longwords of the machine
- dependent portion of a trampoline, including the GC and format
- headers. The code in the trampoline must store an index (used to
- determine which C SCHEME_UTILITY procedure to invoke) in a
- register, jump to "scheme_to_interface" and leave the address of
- the storage following the code in a standard location.
-
- TRAMPOLINE_ENTRY_POINT returns the address of the entry point of a
- trampoline when given the address of the word containing
- the manifest vector header. According to the above picture,
- it would add 12 bytes to its argument.
-
- TRAMPOLINE_STORAGE takes the address of the first instruction in a
- trampoline (not the start of the trampoline block) and returns the
- address of the first storage word in the trampoline.
-
- STORE_TRAMPOLINE_ENTRY gets the address of the first instruction in
- the trampoline and stores the instructions. It also receives the
- index of the C SCHEME_UTILITY to be invoked.
-*/
-
-#define TRAMPOLINE_ENTRY_SIZE 5
-#define TRAMPOLINE_BLOCK_TO_ENTRY 3
-
-#define TRAMPOLINE_ENTRY_POINT(tramp_block) \
- (((SCHEME_OBJECT *) (tramp_block)) + TRAMPOLINE_BLOCK_TO_ENTRY)
-
-#define TRAMPOLINE_STORAGE(tramp_entry) \
- ((((SCHEME_OBJECT *)(tramp_entry)) + 3))
-
-#define SPECIAL_OPCODE 000
-#define ADDI_OPCODE 010
-
-#define OP(OPCODE) (OPCODE << 18)
-#define SPECIAL_OP OP(SPECIAL_OPCODE)
-#define ADDI_OP OP(ADDI_OPCODE)
-
-#define JALR_TEMPLATE 0x81c02000
-#define JALR_SRC(n) ((n & 0x1F) << 14)
-#define JALR_DST(n) ((n & 0x1F) << 25)
-#define JALR(d,s) (JALR_TEMPLATE|JALR_SRC(s)|JALR_DST(d))
-
-#define ADDI_TEMPLATE 0x80002000
-#define ADDI_SRC(n) ((n & 0x1F) << 14)
-#define ADDI_DST(n) ((n & 0x1F) << 25)
-#define ADDI_IMMED(n) (n & 0x1FFF)
-#define ADDI(d,s,imm) (ADDI_TEMPLATE|ADDI_DST(d)|ADDI_SRC(s)|ADDI_IMMED(imm))
-
-#define STORE_TRAMPOLINE_ENTRY(entry_address, index) \
-{ unsigned long *PC; \
- PC = ((unsigned long *) (entry_address)); \
- *PC++ = ADDI(COMP_REG_TEMPORARY, COMP_REG_SCHEME_TO_INTERFACE, -8); \
- *PC++ = JALR(COMP_REG_C_ARG_1, COMP_REG_TEMPORARY); \
- *PC = ADDI(COMP_REG_TRAMP_INDEX, 0, (4*index)); \
- /* assumes index fits in 13 bits */ \
-}
-\f
-/* Execute cache entries.
-
- Execute cache entry size size in longwords. The cache itself
- contains both the number of arguments provided by the caller and
- code to jump to the destination address. Before linkage, the cache
- contains the callee's name instead of the jump code.
-
- On SPARC: 3 instructions, the last being a NO-OP (SETHI with
- constant 0, destination 0)
- */
-
-#define EXECUTE_CACHE_ENTRY_SIZE 3
-
-/* Execute cache destructuring. */
-
-/* Given a target location and the address of the first word of an
- execute cache entry, extract from the cache cell the number of
- arguments supplied by the caller and store it in target. */
-
-/* For the SPARC (big endian), addresses in bytes from the start of
- the cache:
-
- Before linking
- +0: TC_SYMBOL || symbol address
- +4: TC_FIXNUM || 0
- +6: number of supplied arguments, +1
- +8: ???
-
- After linking
- +0: SETHI global_temp (top 22 bits)
- +4: JMPL global_temp (low 10 bits)
- +8: NOP
-
-*/
-
-#define SPARC_CACHE_ARITY_OFFSET 5
-#define SPARC_CACHE_CODE_OFFSET 8
-
-
-#define EXTRACT_EXECUTE_CACHE_ARITY(target, address) \
-{ \
- (target) = \
- ((long) \
- (((unsigned short *) (address)) [SPARC_CACHE_ARITY_OFFSET]) & 0x0fff);\
-}
-
-#define EXTRACT_EXECUTE_CACHE_SYMBOL(target, address) \
-{ \
- (target) = (* (((SCHEME_OBJECT *) (address)))); \
-}
-
-/* Extract the target address (not the code to get there) from an
- execute cache cell.
- */
-
-#define EXTRACT_EXECUTE_CACHE_ADDRESS(target, address) \
-{ \
- unsigned long * addr = ((unsigned long*)(address)); \
- unsigned long sethi_instr = addr[0]; \
- unsigned long jmpl_instr = addr[1]; \
- (target) = \
- ((SCHEME_OBJECT) \
- (((sethi_instr & 0x3fffff) << 10) | (jmpl_instr & 0x3ff))); \
-}
-
-/* This is the inverse of EXTRACT_EXECUTE_CACHE_ADDRESS.
- On the SPARC it must flush the I-cache, but there is no
- need to flush the following ADDI instruction, which is a NOP.
- */
-
-#define STORE_EXECUTE_CACHE_ADDRESS(address, entry) \
-{ \
- unsigned long * addr = (unsigned long *)(address); \
- unsigned long target = (unsigned long)(entry); \
- addr[0] = (addr[0] & SETHI_GLOBAL_TEMP_TEMPLATE) | (target >> 10); \
- addr[1] = (addr[1] & JMPL_TEMPLATE) | (target & 0x000003ff); \
-}
-
-/* This stores the fixed part of the instructions leaving the
- destination address and the number of arguments intact. These are
- split apart so the GC can call EXTRACT/STORE...ADDRESS but it does
- NOT need to store the instructions back. On some architectures the
- instructions may change due to GC and then STORE_EXECUTE_CACHE_CODE
- should become a no-op and all of the work is done by
- STORE_EXECUTE_CACHE_ADDRESS instead.
- */
-
-
-#define STORE_EXECUTE_CACHE_CODE(address) \
-{ \
- unsigned long* nop_addr = (((unsigned long *)(address)) + 2); \
- unsigned long nop_val; \
- *((unsigned long *)address) = (SETHI_GLOBAL_TEMP_TEMPLATE); \
- *(((unsigned long *)(address))+1) = JMPL_TEMPLATE; \
- nop_val = (*nop_addr); \
- (*nop_addr) = ADDI(0,0,nop_val); \
-}
-
-/* This flushes the Scheme portion of the I-cache.
- It is used after a GC or disk-restore.
- It's needed because the GC has moved code around, and closures
- and execute cache cells have absolute addresses that the
- processor might have old copies of.
- */
-
-#define FLUSH_I_CACHE() do \
-{ \
- ICACHEFLUSH (Heap_Bottom, \
- ((sizeof(SCHEME_OBJECT)) * \
- (Heap_Top - Heap_Bottom))); \
- ICACHEFLUSH (Constant_Space, \
- ((sizeof(SCHEME_OBJECT)) * \
- (Constant_Top - Constant_Space))); \
- ICACHEFLUSH (Stack_Pointer, \
- ((sizeof(SCHEME_OBJECT)) * \
- (Stack_Top - Stack_Pointer))); \
-} while (0)
-
-
-/* This flushes a region of the I-cache.
- It is used after updating an execute cache while running.
- Not needed during GC because FLUSH_I_CACHE will be used.
- */
-
-#define FLUSH_I_CACHE_REGION(address, nwords) do \
-{ \
- ICACHEFLUSH ((address), ((sizeof (long)) * (nwords))); \
-} while (0)
-
-#define PUSH_D_CACHE_REGION FLUSH_I_CACHE_REGION
-
-/* The following is misnamed.
- It should really be called STORE_BACK_D_CACHE.
- Neither the R2000 nor the R3000 systems have them.
- I don't know about the R4000 or R6000.
- */
-
-/* #define SPLIT_CACHES */
-
-#ifdef IN_CMPINT_C
-
-
-#define CLOSURE_ENTRY_WORDS \
- (COMPILED_CLOSURE_ENTRY_SIZE / (sizeof (SCHEME_OBJECT)))
-
-static long closure_chunk = (1024 * CLOSURE_ENTRY_WORDS);
-
-#define REGBLOCK_CLOSURE_LIMIT REGBLOCK_CLOSURE_SPACE
-
-/* The apparently random instances of the number 3 below arise from
- the convention that free_closure always points to a JAL instruction
- with (at least) 3 unused words preceding it.
- In this way, if there is enough space, we can use free_closure
- as the address of a new uni- or multi-closure.
-
- The code below (in the initialization loop) depends on knowing that
- CLOSURE_ENTRY_WORDS is 3.
-
- Random hack: ADDI instructions look like TC_TRUE objects, thus of the
- pre-initialized words, only the JALR looks like a pointer object
- (an SCODE-QUOTE). Since there is exactly one JALR of waste between
- closures, and it is always 3 words before free_closure,
- the code for uni-closure allocation (in mips.m4) bashes that word
- with 0 (SHARP_F) to make the heap parseable.
- */
-
-/* size in Scheme objects of the block we need to allocate. */
-
-void
-DEFUN (allocate_closure, (size), long size)
-{
- long space;
- SCHEME_OBJECT * free_closure, * limit;
-
- free_closure = ((SCHEME_OBJECT *) Registers[REGBLOCK_CLOSURE_FREE]);
- limit = ((SCHEME_OBJECT *) Registers[REGBLOCK_CLOSURE_LIMIT]);
- space = ((limit - free_closure) + 3);
-
- /* Bump up to a multiple of CLOSURE_ENTRY_WORDS.
- Otherwise clearing by the allocation code may clobber
- a different word.
- */
- size = (CLOSURE_ENTRY_WORDS
- * ((size + (CLOSURE_ENTRY_WORDS - 1))
- / CLOSURE_ENTRY_WORDS));
- if (size > space)
- {
- long chunk_size;
- SCHEME_OBJECT *ptr;
-
- /* Make the heap be parseable forward by protecting the waste
- in the last chunk.
- */
-
- if ((space > 0) && (free_closure != ((SCHEME_OBJECT) NULL)))
- free_closure[-3] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (space - 1)));
-
- free_closure = Free;
- if ((size <= closure_chunk) && (!(GC_Check (closure_chunk))))
- limit = (free_closure + closure_chunk);
- else
- {
- if (GC_Check (size))
- {
- if ((Heap_Top - Free) < size)
- {
- /* No way to back out -- die. */
- fprintf (stderr, "\nC_allocate_closure (%d): No space.\n", size);
- Microcode_Termination (TERM_NO_SPACE);
- /* NOTREACHED */
- }
- Request_GC (0);
- }
- else if (size <= closure_chunk)
- Request_GC (0);
- limit = (free_closure + size);
- }
- Free = limit;
- chunk_size = (limit - free_closure);
-
- ptr = free_closure;
- while (ptr < limit)
- {
- *ptr++ = (JALR (COMP_REG_LINKAGE, COMP_REG_CLOSURE_HOOK));
- *ptr++ = (ADDI (COMP_REG_LINKAGE, COMP_REG_LINKAGE, -8));
- *ptr++ = SHARP_F;
- }
- PUSH_D_CACHE_REGION (free_closure, chunk_size);
- Registers[REGBLOCK_CLOSURE_LIMIT] = ((SCHEME_OBJECT) limit);
- Registers[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) (free_closure + 3));
- }
- return;
-}
-
-#endif /* IN_CMPINT_C */
-\f
-/* Derived parameters and macros.
-
- These macros expect the above definitions to be meaningful.
- If they are not, the macros below may have to be changed as well.
- */
-
-#define COMPILED_ENTRY_OFFSET_WORD(entry) (((format_word *) (entry)) [-1])
-#define COMPILED_ENTRY_FORMAT_WORD(entry) (((format_word *) (entry)) [-2])
-
-/* The next one assumes 2's complement integers....*/
-#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2))
-#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0)
-
-#if (PC_ZERO_BITS == 0)
-/* Instructions aligned on byte boundaries */
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1)
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- ((CLEAR_LOW_BIT(offset_word)) >> 1)
-#endif
-
-#if (PC_ZERO_BITS == 1)
-/* Instructions aligned on word (16 bit) boundaries */
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset)
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- (CLEAR_LOW_BIT(offset_word))
-#endif
-
-#if (PC_ZERO_BITS >= 2)
-/* Should be OK for =2, but bets are off for >2 because of problems
- mentioned earlier!
-*/
-#define SHIFT_AMOUNT (PC_ZERO_BITS - 1)
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> (SHIFT_AMOUNT))
-#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \
- ((CLEAR_LOW_BIT(offset_word)) << (SHIFT_AMOUNT))
-#endif
-
-#define MAKE_OFFSET_WORD(entry, block, continue) \
- ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \
- ((char *) (block)))) | \
- ((continue) ? 1 : 0))
-
-#if (EXECUTE_CACHE_ENTRY_SIZE == 2)
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) >> 1)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) << 1)
-#endif
-
-#if (EXECUTE_CACHE_ENTRY_SIZE == 4)
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) >> 2)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) << 2)
-#endif
-
-#if (!defined(EXECUTE_CACHE_COUNT_TO_ENTRIES))
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) / EXECUTE_CACHE_ENTRY_SIZE)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) * EXECUTE_CACHE_ENTRY_SIZE)
-#endif
-\f
-/* The first entry in a cc block is preceeded by 2 headers (block and nmv),
- a format word and a gc offset word. See the early part of the
- TRAMPOLINE picture, above.
- */
-
-#define CC_BLOCK_FIRST_ENTRY_OFFSET \
- (2 * ((sizeof(SCHEME_OBJECT)) + (sizeof(format_word))))
-
-/* Format words */
-
-#define FORMAT_BYTE_EXPR 0xFF
-#define FORMAT_BYTE_COMPLR 0xFE
-#define FORMAT_BYTE_CMPINT 0xFD
-#define FORMAT_BYTE_DLINK 0xFC
-#define FORMAT_BYTE_RETURN 0xFB
-
-#define FORMAT_WORD_EXPR (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_EXPR))
-#define FORMAT_WORD_CMPINT (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_CMPINT))
-#define FORMAT_WORD_RETURN (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_RETURN))
-
-/* This assumes that a format word is at least 16 bits,
- and the low order field is always 8 bits.
- */
-
-#define MAKE_FORMAT_WORD(field1, field2) \
- (((field1) << 8) | ((field2) & 0xff))
-
-#define SIGN_EXTEND_FIELD(field, size) \
- (((field) & ((1 << (size)) - 1)) | \
- ((((field) & (1 << ((size) - 1))) == 0) ? 0 : \
- ((-1) << (size))))
-
-#define FORMAT_WORD_LOW_BYTE(word) \
- (SIGN_EXTEND_FIELD ((((unsigned long) (word)) & 0xff), 8))
-
-#define FORMAT_WORD_HIGH_BYTE(word) \
- (SIGN_EXTEND_FIELD \
- ((((unsigned long) (word)) >> 8), \
- (((sizeof (format_word)) * CHAR_BIT) - 8)))
-
-#define COMPILED_ENTRY_FORMAT_HIGH(addr) \
- (FORMAT_WORD_HIGH_BYTE (COMPILED_ENTRY_FORMAT_WORD (addr)))
-
-#define COMPILED_ENTRY_FORMAT_LOW(addr) \
- (FORMAT_WORD_LOW_BYTE (COMPILED_ENTRY_FORMAT_WORD (addr)))
-
-#define FORMAT_BYTE_FRAMEMAX 0x7f
-
-#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW
-#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH
-
-#endif /* CMPINT2_H_INCLUDED */
+++ /dev/null
-#| -*-Scheme-*-
-
-$MC68020-Header: coerce.scm,v 1.10 88/08/31 05:56:37 GMT cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-(declare (usual-integrations))
-\f
-;;;; SPARC coercions
-
-;;; Coercion top level
-
-(define make-coercion
- (coercion-maker
- `((UNSIGNED . ,coerce-unsigned-integer)
- (SIGNED . ,coerce-signed-integer))))
-
-(define coerce-1-bit-unsigned (make-coercion 'UNSIGNED 1))
-(define coerce-2-bit-unsigned (make-coercion 'UNSIGNED 2))
-(define coerce-3-bit-unsigned (make-coercion 'UNSIGNED 3))
-(define coerce-4-bit-unsigned (make-coercion 'UNSIGNED 4))
-(define coerce-5-bit-unsigned (make-coercion 'UNSIGNED 5))
-(define coerce-6-bit-unsigned (make-coercion 'UNSIGNED 6))
-(define coerce-8-bit-unsigned (make-coercion 'UNSIGNED 8))
-(define coerce-9-bit-unsigned (make-coercion 'UNSIGNED 9))
-(define coerce-10-bit-unsigned (make-coercion 'UNSIGNED 10))
-(define coerce-11-bit-unsigned (make-coercion 'UNSIGNED 11))
-(define coerce-13-bit-unsigned (make-coercion 'UNSIGNED 13))
-(define coerce-15-bit-unsigned (make-coercion 'UNSIGNED 15))
-(define coerce-16-bit-unsigned (make-coercion 'UNSIGNED 16))
-(define coerce-20-bit-unsigned (make-coercion 'UNSIGNED 20))
-(define coerce-22-bit-unsigned (make-coercion 'UNSIGNED 22))
-(define coerce-25-bit-unsigned (make-coercion 'UNSIGNED 25))
-(define coerce-26-bit-unsigned (make-coercion 'UNSIGNED 26))
-(define coerce-30-bit-unsigned (make-coercion 'UNSIGNED 30))
-(define coerce-32-bit-unsigned (make-coercion 'UNSIGNED 32))
-
-(define coerce-16-bit-signed (make-coercion 'SIGNED 16))
-(define coerce-13-bit-signed (make-coercion 'SIGNED 13))
-(define coerce-22-bit-signed (make-coercion 'SIGNED 22))
-(define coerce-26-bit-signed (make-coercion 'SIGNED 26))
-(define coerce-30-bit-signed (make-coercion 'SIGNED 30))
-(define coerce-32-bit-signed (make-coercion 'SIGNED 32))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Compiler File Dependencies
-
-(declare (usual-integrations))
-\f
-(define (initialize-package!)
- (add-event-receiver! event:after-restore reset-source-nodes!)
- (reset-source-nodes!))
-
-(define (reset-source-nodes!)
- (set! source-filenames '())
- (set! source-hash)
- (set! source-nodes)
- (set! source-nodes/by-rank))
-
-(define (maybe-setup-source-nodes!)
- (if (null? source-filenames)
- (setup-source-nodes!)))
-
-(define (setup-source-nodes!)
- (let ((filenames
- (mapcan (lambda (subdirectory)
- (map (lambda (pathname)
- (string-append subdirectory
- "/"
- (pathname-name pathname)))
- (directory-read
- (string-append subdirectory
- "/"
- source-file-expression))))
- '("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt"
- "machines/sparc"))))
- (if (null? filenames)
- (error "Can't find source files of compiler"))
- (set! source-filenames filenames))
- (set! source-hash (make-string-hash-table))
- (set! source-nodes
- (map (lambda (filename)
- (let ((node (make/source-node filename)))
- (hash-table/put! source-hash filename node)
- node))
- source-filenames))
- (initialize/syntax-dependencies!)
- (initialize/integration-dependencies!)
- (source-nodes/rank!))
-
-(define source-file-expression "*.scm")
-(define source-filenames)
-(define source-hash)
-(define source-nodes)
-(define source-nodes/by-rank)
-
-(define (filename/append directory . names)
- (map (lambda (name) (string-append directory "/" name)) names))
-\f
-(define-structure (source-node
- (conc-name source-node/)
- (constructor %make/source-node (filename pathname)))
- (filename #f read-only #t)
- (pathname #f read-only #t)
- (forward-links '())
- (backward-links '())
- (forward-closure '())
- (backward-closure '())
- (dependencies '())
- (dependents '())
- (rank #f)
- (syntax-table #f)
- (declarations '())
- (modification-time #f))
-
-(define (make/source-node filename)
- (%make/source-node filename (->pathname filename)))
-
-(define (filename->source-node filename)
- (let ((node (hash-table/get source-hash filename #f)))
- (if (not node)
- (error "Unknown source file:" filename))
- node))
-
-(define (source-node/circular? node)
- (memq node (source-node/backward-closure node)))
-
-(define (source-node/link! node dependency)
- (if (not (memq dependency (source-node/backward-links node)))
- (begin
- (set-source-node/backward-links!
- node
- (cons dependency (source-node/backward-links node)))
- (set-source-node/forward-links!
- dependency
- (cons node (source-node/forward-links dependency)))
- (source-node/close! node dependency))))
-
-(define (source-node/close! node dependency)
- (if (not (memq dependency (source-node/backward-closure node)))
- (begin
- (set-source-node/backward-closure!
- node
- (cons dependency (source-node/backward-closure node)))
- (set-source-node/forward-closure!
- dependency
- (cons node (source-node/forward-closure dependency)))
- (for-each (lambda (dependency)
- (source-node/close! node dependency))
- (source-node/backward-closure dependency))
- (for-each (lambda (node)
- (source-node/close! node dependency))
- (source-node/forward-closure node)))))
-\f
-;;;; Rank
-
-(define (source-nodes/rank!)
- (compute-dependencies! source-nodes)
- (compute-ranks! source-nodes)
- (set! source-nodes/by-rank (source-nodes/sort-by-rank source-nodes)))
-
-(define (compute-dependencies! nodes)
- (for-each (lambda (node)
- (set-source-node/dependencies!
- node
- (list-transform-negative (source-node/backward-closure node)
- (lambda (node*)
- (memq node (source-node/backward-closure node*)))))
- (set-source-node/dependents!
- node
- (list-transform-negative (source-node/forward-closure node)
- (lambda (node*)
- (memq node (source-node/forward-closure node*))))))
- nodes))
-
-(define (compute-ranks! nodes)
- (let loop ((nodes nodes) (unranked-nodes '()))
- (if (null? nodes)
- (if (not (null? unranked-nodes))
- (loop unranked-nodes '()))
- (loop (cdr nodes)
- (let ((node (car nodes)))
- (let ((rank (source-node/rank* node)))
- (if rank
- (begin
- (set-source-node/rank! node rank)
- unranked-nodes)
- (cons node unranked-nodes))))))))
-
-(define (source-node/rank* node)
- (let loop ((nodes (source-node/dependencies node)) (rank -1))
- (if (null? nodes)
- (1+ rank)
- (let ((rank* (source-node/rank (car nodes))))
- (and rank*
- (loop (cdr nodes) (max rank rank*)))))))
-
-(define (source-nodes/sort-by-rank nodes)
- (sort nodes (lambda (x y) (< (source-node/rank x) (source-node/rank y)))))
-\f
-;;;; File Syntaxer
-
-(define (syntax-files!)
- (maybe-setup-source-nodes!)
- (for-each
- (lambda (node)
- (let ((modification-time
- (let ((source (modification-time node "scm"))
- (binary (modification-time node "bin")))
- (if (not source)
- (error "Missing source file" (source-node/filename node)))
- (and binary (< source binary) binary))))
- (set-source-node/modification-time! node modification-time)
- (if (not modification-time)
- (begin (write-string "\nSource file newer than binary: ")
- (write (source-node/filename node))))))
- source-nodes)
- (if compiler:enable-integration-declarations?
- (begin
- (for-each
- (lambda (node)
- (let ((time (source-node/modification-time node)))
- (if (and time
- (there-exists? (source-node/dependencies node)
- (lambda (node*)
- (let ((newer?
- (let ((time*
- (source-node/modification-time node*)))
- (or (not time*)
- (> time* time)))))
- (if newer?
- (begin
- (write-string "\nBinary file ")
- (write (source-node/filename node))
- (write-string " newer than dependency ")
- (write (source-node/filename node*))))
- newer?))))
- (set-source-node/modification-time! node #f))))
- source-nodes)
- (for-each
- (lambda (node)
- (if (not (source-node/modification-time node))
- (for-each (lambda (node*)
- (if (source-node/modification-time node*)
- (begin
- (write-string "\nBinary file ")
- (write (source-node/filename node*))
- (write-string " depends on ")
- (write (source-node/filename node))))
- (set-source-node/modification-time! node* #f))
- (source-node/forward-closure node))))
- source-nodes)))
- (for-each (lambda (node)
- (if (not (source-node/modification-time node))
- (pathname-delete!
- (pathname-new-type (source-node/pathname node) "ext"))))
- source-nodes/by-rank)
- (write-string "\n\nBegin pass 1:")
- (for-each (lambda (node)
- (if (not (source-node/modification-time node))
- (source-node/syntax! node)))
- source-nodes/by-rank)
- (if (there-exists? source-nodes/by-rank
- (lambda (node)
- (and (not (source-node/modification-time node))
- (source-node/circular? node))))
- (begin
- (write-string "\n\nBegin pass 2:")
- (for-each (lambda (node)
- (if (not (source-node/modification-time node))
- (if (source-node/circular? node)
- (source-node/syntax! node)
- (source-node/touch! node))))
- source-nodes/by-rank))))
-\f
-(define (source-node/touch! node)
- (with-values
- (lambda ()
- (sf/pathname-defaulting (source-node/pathname node) "" #f))
- (lambda (input-pathname bin-pathname spec-pathname)
- input-pathname
- (pathname-touch! bin-pathname)
- (pathname-touch! (pathname-new-type bin-pathname "ext"))
- (if spec-pathname (pathname-touch! spec-pathname)))))
-
-(define (pathname-touch! pathname)
- (if (file-exists? pathname)
- (begin
- (write-string "\nTouch file: ")
- (write (pathname->string pathname))
- (file-touch pathname))))
-
-(define (pathname-delete! pathname)
- (if (file-exists? pathname)
- (begin
- (write-string "\nDelete file: ")
- (write (pathname->string pathname))
- (delete-file pathname))))
-
-(define (sc filename)
- (maybe-setup-source-nodes!)
- (source-node/syntax! (filename->source-node filename)))
-
-(define (source-node/syntax! node)
- (with-values
- (lambda ()
- (sf/pathname-defaulting (source-node/pathname node) "" #f))
- (lambda (input-pathname bin-pathname spec-pathname)
- (sf/internal
- input-pathname bin-pathname spec-pathname
- (source-node/syntax-table node)
- ((if compiler:enable-integration-declarations?
- identity-procedure
- (lambda (declarations)
- (list-transform-negative declarations
- integration-declaration?)))
- (source-node/declarations node))))))
-
-(define-integrable (modification-time node type)
- (file-modification-time
- (pathname-new-type (source-node/pathname node) type)))
-\f
-;;;; Syntax dependencies
-
-(define (initialize/syntax-dependencies!)
- (let ((file-dependency/syntax/join
- (lambda (filenames syntax-table)
- (for-each (lambda (filename)
- (set-source-node/syntax-table!
- (filename->source-node filename)
- syntax-table))
- filenames))))
- (file-dependency/syntax/join
- (append (filename/append "base"
- "blocks" "cfg1" "cfg2" "cfg3" "constr"
- "contin" "crstop" "ctypes" "debug" "enumer"
- "infnew" "lvalue" "object" "pmerly" "proced"
- "refctx" "rvalue" "scode" "sets" "subprb"
- "switch" "toplev" "utils")
- (filename/append "back"
- "asmmac" "bittop" "bitutl" "insseq" "lapgn1"
- "lapgn2" "lapgn3" "linear" "regmap" "symtab"
- "syntax")
- (filename/append "machines/sparc"
- "insmac" "lapopt" "machin" "rulrew" "rgspcm")
- (filename/append "fggen"
- "declar" "fggen" "canon")
- (filename/append "fgopt"
- "blktyp" "closan" "conect" "contan" "delint"
- "desenv" "envopt" "folcon" "offset" "operan"
- "order" "outer" "param" "reord" "reteqv" "reuse"
- "sideff" "simapp" "simple" "subfre" "varind")
- (filename/append "rtlbase"
- "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp"
- "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2"
- "valclass")
- (filename/append "rtlgen"
- "fndblk" "fndvar" "opncod" "rgcomb" "rgproc"
- "rgretn" "rgrval" "rgstmt" "rtlgen")
- (filename/append "rtlopt"
- "ralloc" "rcompr" "rcse1" "rcse2" "rcseep"
- "rcseht" "rcserq" "rcsesr" "rdebug" "rdflow"
- "rerite" "rinvex" "rlife" "rtlcsm"))
- (->environment '(COMPILER)))
- (file-dependency/syntax/join
- (filename/append "machines/sparc"
- "lapgen"
- "rules1" "rules2" "rules3" "rules4" "rulfix" "rulflo"
- "instr1" "instr2a" "instr2b" "instr3")
- (->environment '(COMPILER LAP-SYNTAXER)))))
-\f
-;;;; Integration Dependencies
-
-(define (initialize/integration-dependencies!)
-
- (define (add-declaration! declaration filenames)
- (for-each (lambda (filenames)
- (let ((node (filename->source-node filenames)))
- (set-source-node/declarations!
- node
- (cons declaration
- (source-node/declarations node)))))
- filenames))
-
- (let* ((front-end-base
- (filename/append "base"
- "blocks" "cfg1" "cfg2" "cfg3"
- "contin" "ctypes" "enumer" "lvalue"
- "object" "proced" "rvalue"
- "scode" "subprb" "utils"))
- (sparc-base
- (filename/append "machines/sparc" "machin"))
- (rtl-base
- (filename/append "rtlbase"
- "rgraph" "rtlcfg" "rtlobj" "rtlreg" "rtlty1"
- "rtlty2"))
- (cse-base
- (filename/append "rtlopt"
- "rcse1" "rcseht" "rcserq" "rcsesr"))
- (cse-all
- (append (filename/append "rtlopt"
- "rcse2" "rcseep")
- cse-base))
- (instruction-base
- (filename/append "machines/sparc" "assmd" "machin"))
- (lapgen-base
- (append (filename/append "back" "lapgn3" "regmap")
- (filename/append "machines/sparc" "lapgen")))
- (assembler-base
- (append (filename/append "back" "symtab")
- (filename/append "machines/sparc" "instr1")))
- (lapgen-body
- (append
- (filename/append "back" "lapgn1" "lapgn2" "syntax")
- (filename/append "machines/sparc"
- "rules1" "rules2" "rules3" "rules4"
- "rulfix" "rulflo")))
- (assembler-body
- (append
- (filename/append "back" "bittop")
- (filename/append "machines/sparc"
- "instr1" "instr2a" "instr2b" "instr3"))))
-
- (define (file-dependency/integration/join filenames dependencies)
- (for-each (lambda (filename)
- (file-dependency/integration/make filename dependencies))
- filenames))
-
- (define (file-dependency/integration/make filename dependencies)
- (let ((node (filename->source-node filename)))
- (for-each (lambda (dependency)
- (let ((node* (filename->source-node dependency)))
- (if (not (eq? node node*))
- (source-node/link! node node*))))
- dependencies)))
-
- (define (define-integration-dependencies directory name directory* . names)
- (file-dependency/integration/make
- (string-append directory "/" name)
- (apply filename/append directory* names)))
-
- (define-integration-dependencies "base" "object" "base" "enumer")
- (define-integration-dependencies "base" "enumer" "base" "object")
- (define-integration-dependencies "base" "utils" "base" "scode")
- (define-integration-dependencies "base" "cfg1" "base" "object")
- (define-integration-dependencies "base" "cfg2" "base"
- "cfg1" "cfg3" "object")
- (define-integration-dependencies "base" "cfg3" "base" "cfg1" "cfg2")
- (define-integration-dependencies "base" "ctypes" "base"
- "blocks" "cfg1" "cfg2" "cfg3" "contin" "lvalue" "object" "subprb")
- (define-integration-dependencies "base" "rvalue" "base"
- "blocks" "cfg1" "cfg2" "cfg3" "enumer" "lvalue" "object" "utils")
- (define-integration-dependencies "base" "lvalue" "base"
- "blocks" "object" "proced" "rvalue" "utils")
- (define-integration-dependencies "base" "blocks" "base"
- "enumer" "lvalue" "object" "proced" "rvalue" "scode")
- (define-integration-dependencies "base" "proced" "base"
- "blocks" "cfg1" "cfg2" "cfg3" "contin" "enumer" "lvalue" "object"
- "rvalue" "utils")
- (define-integration-dependencies "base" "contin" "base"
- "blocks" "cfg3" "ctypes")
- (define-integration-dependencies "base" "subprb" "base"
- "cfg3" "contin" "enumer" "object" "proced")
-
- (define-integration-dependencies "machines/sparc" "machin" "rtlbase"
- "rtlreg" "rtlty1" "rtlty2")
-
- (define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2")
- (define-integration-dependencies "rtlbase" "rgraph" "machines/sparc"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlcfg" "base"
- "cfg1" "cfg2" "cfg3")
- (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils")
- (define-integration-dependencies "rtlbase" "rtlcon" "machines/sparc"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlexp" "rtlbase"
- "rtlreg" "rtlty1")
- (define-integration-dependencies "rtlbase" "rtline" "base" "cfg1" "cfg2")
- (define-integration-dependencies "rtlbase" "rtline" "rtlbase"
- "rtlcfg" "rtlty2")
- (define-integration-dependencies "rtlbase" "rtlobj" "base"
- "cfg1" "object" "utils")
- (define-integration-dependencies "rtlbase" "rtlreg" "machines/sparc"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlreg" "rtlbase"
- "rgraph" "rtlty1")
- (define-integration-dependencies "rtlbase" "rtlty1" "rtlbase" "rtlcfg")
- (define-integration-dependencies "rtlbase" "rtlty2" "base" "scode")
- (define-integration-dependencies "rtlbase" "rtlty2" "machines/sparc"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlty2" "rtlbase" "rtlty1")
-
- (file-dependency/integration/join
- (append
- (filename/append "base" "refctx")
- (filename/append "fggen"
- "declar" "fggen") ; "canon" needs no integrations
- (filename/append "fgopt"
- "blktyp" "closan" "conect" "contan" "delint" "desenv"
- "envopt" "folcon" "offset" "operan" "order" "param"
- "outer" "reuse" "reteqv" "sideff" "simapp" "simple"
- "subfre" "varind"))
- (append sparc-base front-end-base))
-
- (define-integration-dependencies "fgopt" "reuse" "fgopt" "reord")
-
- (file-dependency/integration/join
- (filename/append "rtlgen"
- "fndblk" "fndvar" "opncod" "rgcomb" "rgproc" "rgretn"
- "rgrval" "rgstmt" "rtlgen")
- (append sparc-base front-end-base rtl-base))
-
- (file-dependency/integration/join
- (append cse-all
- (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow"
- "rerite" "rinvex" "rlife" "rtlcsm")
- (filename/append "machines/sparc" "rulrew"))
- (append sparc-base rtl-base))
-
- (file-dependency/integration/join cse-all cse-base)
-
- (file-dependency/integration/join
- (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife")
- (filename/append "rtlbase" "regset"))
-
- (file-dependency/integration/join
- (filename/append "rtlopt" "rcseht" "rcserq")
- (filename/append "base" "object"))
-
- (define-integration-dependencies "rtlopt" "rlife" "base" "cfg2")
-
- (let ((dependents
- (append instruction-base
- lapgen-base
- lapgen-body
- assembler-base
- assembler-body
- (filename/append "back" "linear" "syerly"))))
- (add-declaration! '(USUAL-DEFINITION (SET EXPT)) dependents)
- (file-dependency/integration/join dependents instruction-base))
-
- (file-dependency/integration/join (append lapgen-base lapgen-body)
- lapgen-base)
-
- (file-dependency/integration/join (append assembler-base assembler-body)
- assembler-base)
-
- (define-integration-dependencies "back" "lapgn1" "base"
- "cfg1" "cfg2" "utils")
- (define-integration-dependencies "back" "lapgn1" "rtlbase"
- "rgraph" "rtlcfg")
- (define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg")
- (define-integration-dependencies "back" "lapgn3" "rtlbase" "rtlcfg")
- (define-integration-dependencies "back" "linear" "base" "cfg1" "cfg2")
- (define-integration-dependencies "back" "linear" "rtlbase" "rtlcfg")
- (define-integration-dependencies "back" "mermap" "back" "regmap")
- (define-integration-dependencies "back" "regmap" "base" "utils")
- (define-integration-dependencies "back" "symtab" "base" "utils"))
-
- (for-each (lambda (node)
- (let ((links (source-node/backward-links node)))
- (if (not (null? links))
- (set-source-node/declarations!
- node
- (cons (make-integration-declaration
- (source-node/pathname node)
- (map source-node/pathname links))
- (source-node/declarations node))))))
- source-nodes))
-
-(define (make-integration-declaration pathname integration-dependencies)
- `(INTEGRATE-EXTERNAL
- ,@(map (let ((default
- (make-pathname
- #f
- #f
- (make-list (length (pathname-directory pathname)) 'UP)
- #f
- #f
- #f)))
- (lambda (pathname)
- (merge-pathnames pathname default)))
- integration-dependencies)))
-
-(define-integrable (integration-declaration? declaration)
- (eq? (car declaration) 'INTEGRATE-EXTERNAL))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;; SPARC Instruction Set Macros. Early version
-;;; NOPs for now.
-
-(declare (usual-integrations))
-
-(define-syntax define-instruction
- (non-hygienic-macro-transformer
- (lambda (opcode . patterns)
- `(SET! EARLY-INSTRUCTIONS
- (CONS
- (LIST ',opcode
- ,@(map (lambda (pattern)
- `(early-parse-rule
- ',(car pattern)
- (lambda (pat vars)
- (early-make-rule
- pat
- vars
- (scode-quote
- (instruction->instruction-sequence
- ,(parse-instruction (cadr pattern)
- (cddr pattern)
- #t)))))))
- patterns))
- EARLY-INSTRUCTIONS)))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; SPARC Instruction Set Macros
-
-(declare (usual-integrations))
-\f
-;;;; Definition macros
-
-(define-syntax define-symbol-transformer
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (if (syntax-match? '(IDENTIFIER * SYMBOL) (cdr form))
- `(DEFINE-INTEGRABLE (,(cadr form) SYMBOL)
- (LET ((PLACE (ASSQ SYMBOL ',(cddr form))))
- (IF (PAIR? PLACE)
- (CDR PLACE)
- #F)))
- (ill-formed-syntax form)))))
-
-(define-syntax define-transformer
- (rsc-macro-transformer
- (lambda (form environment)
- `(,(close-syntax 'DEFINE environment) ,@(cdr form)))))
-
-;;;; Fixed width instruction parsing
-
-(define (parse-instruction first-word tail early? environment)
- (if (not (null? tail))
- (error "Unknown format:" (cons first-word tail)))
- (let loop ((first-word first-word))
- (case (car first-word)
- ((LONG)
- (process-fields (cdr first-word) early? environment))
- ((VARIABLE-WIDTH)
- (process-variable-width first-word early? environment))
- ((IF)
- `(,(close-syntax 'IF environment)
- ,(cadr first-word)
- ,(loop (caddr first-word))
- ,(loop (cadddr first-word))))
- (else
- (error "Unknown format:" first-word)))))
-
-(define (process-variable-width descriptor early? environment)
- (let ((binding (cadr descriptor))
- (clauses (cddr descriptor)))
- `(,(close-syntax 'LIST environment)
- ,(variable-width-expression-syntaxer
- (car binding) ; name
- (cadr binding) ; expression
- environment
- (map (lambda (clause)
- (call-with-values
- (lambda ()
- (expand-fields (cdadr clause) early? environment))
- (lambda (code size)
- (if (not (zero? (remainder size 32)))
- (error "Bad clause size:" size))
- `((,(close-syntax 'LIST environment)
- ,(optimize-group-syntax code early? environment))
- ,size
- ,@(car clause)))))
- clauses)))))
-\f
-(define (process-fields fields early? environment)
- (call-with-values (lambda () (expand-fields fields early? environment))
- (lambda (code size)
- (if (not (zero? (remainder size 32)))
- (error "Bad syllable size:" size))
- `(,(close-syntax 'LIST environment)
- ,(optimize-group-syntax code early? environment)))))
-
-(define (expand-fields fields early? environment)
- (let expand ((first-word '()) (word-size 0) (fields fields))
- (if (pair? fields)
- (call-with-values
- (lambda () (expand-field (car fields) early? environment))
- (lambda (car-field car-size)
- (if (and (eq? endianness 'LITTLE)
- (= 32 (+ word-size car-size)))
- (call-with-values (lambda () (expand '() 0 (cdr fields)))
- (lambda (tail tail-size)
- (values (append (cons car-field first-word) tail)
- (+ car-size tail-size))))
- (call-with-values
- (lambda ()
- (expand (cons car-field first-word)
- (+ car-size word-size)
- (cdr fields)))
- (lambda (tail tail-size)
- (values (if (or (zero? car-size)
- (not (eq? endianness 'LITTLE)))
- (cons car-field tail)
- tail)
- (+ car-size tail-size)))))))
- (values '() 0))))
-
-(define (expand-field field early? environment)
- early? ; ignored for now
- (let ((size (car field))
- (expression (cadr field)))
-
- (define (default type)
- (values (integer-syntaxer expression environment type size)
- size))
-
- (if (pair? (cddr field))
- (case (caddr field)
- ((PC-REL)
- (values (integer-syntaxer ``(,',(close-syntax '- environment)
- ,,expression
- (,',(close-syntax '+ environment)
- ,',(close-syntax '*PC* environment)
- 4))
- environment
- (cadddr field)
- size)
- size))
- ((BLOCK-OFFSET)
- (values `(,(close-syntax 'LIST environment)
- 'BLOCK-OFFSET
- ,expression)
- size))
- (else
- (default (caddr field))))
- (default 'UNSIGNED))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; MIPS instruction set
-
-;; Branch-tensioned instructions are in instr2.scm
-;; Floating point instructions are in instr3.scm
-
-(declare (usual-integrations))
-\f
-(let-syntax
- ((arithmetic-immediate-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? destination) (? source) (? immediate))
- (VARIABLE-WIDTH (evaluated-immediate immediate)
- ((#x-2000 #x1fff)
- (LONG (2 2)
- (5 destination)
- (6 ,(caddr form))
- (5 source)
- (1 1)
- (13 evaluated-immediate SIGNED)))
- ((() ())
- ;; SETHI $1, top(immediate)
- ;; OR $1, bottom(immediate)
- ;; reg-op $destination, $source, $1
- (LONG (2 0)
- (5 1)
- (3 4)
- (22 evaluated-immediate) ; SETHI
- (2 2)
- (5 1)
- (6 2)
- (5 1)
- (1 1)
- (13 evaluated-immediate SIGNED) ; OR
- (2 0)
- (5 destination)
- (6 ,(caddr form))
- (5 source)
- (1 0)
- (8 0)
- (5 1)))))))))) ; reg-op
- (arithmetic-immediate-instruction addi 0)
- (arithmetic-immediate-instruction addcci 16)
- (arithmetic-immediate-instruction addxi 8)
- (arithmetic-immediate-instruction addxcci 24)
- (arithmetic-immediate-instruction andi 1)
- (arithmetic-immediate-instruction andcci 17)
- (arithmetic-immediate-instruction andni 5)
- (arithmetic-immediate-instruction andncci 21)
- (arithmetic-immediate-instruction ori 2)
- (arithmetic-immediate-instruction orcci 18)
- (arithmetic-immediate-instruction orni 6)
- (arithmetic-immediate-instruction orncci 22)
- (arithmetic-immediate-instruction xori 3)
- (arithmetic-immediate-instruction xorcci 19)
- (arithmetic-immediate-instruction xnori 7)
- (arithmetic-immediate-instruction xnorcc 23)
- (arithmetic-immediate-instruction subi 4)
- (arithmetic-immediate-instruction subcci 20)
- (arithmetic-immediate-instruction subxi 12)
- (arithmetic-immediate-instruction subxcci 28)
- (arithmetic-immediate-instruction umuli 10)
- (arithmetic-immediate-instruction smuli 11)
- (arithmetic-immediate-instruction umulcci 26)
- (arithmetic-immediate-instruction smulcci 27)
- (arithmetic-immediate-instruction udivi 14)
- (arithmetic-immediate-instruction sdivi 15)
- (arithmetic-immediate-instruction udivcci 30)
- (arithmetic-immediate-instruction sdivcci 31)
- )
-
-\f
-(define-instruction lui
- (((? destination) (? immediate))
- (LONG (6 15)
- (5 0)
- (5 destination)
- (16 immediate))))
-
-(define-instruction li
- (((? destination) (? immediate))
- (VARIABLE-WIDTH (evaluated-immediate immediate)
- ((#x-2000 #x1fff)
- (LONG (2 2)
- (5 destination)
- (6 2)
- (5 0)
- (1 1)
- (13 evaluated-immediate SIGNED)))
- ((() ())
- ;; SETHI $1, top(immediate)
- ;; OR $1, bottom(immediate)
- (LONG (2 0)
- (5 1)
- (3 4)
- (22 (high-bits evaluated-immediate)) ; SETHI
- (2 2)
- (5 1)
- (6 2)
- (5 1)
- (1 1)
- (13 (low-bits evaluated-immediate) SIGNED) ; OR
- )))))
-
-\f
-(let-syntax
- ((3-operand-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? destination) (? source-1) (? source-2))
- (LONG (2 2)
- (5 destination)
- (6 ,(caddr form))
- (5 source-1)
- (1 0)
- (8 0)
- (5 source-2)
- )))))))
- (3-operand-instruction add 0)
- (3-operand-instruction addcc 16)
- (3-operand-instruction addx 8)
- (3-operand-instruction addxcc 24)
- (3-operand-instruction andr 1)
- (3-operand-instruction andcc 17)
- (3-operand-instruction andn 5)
- (3-operand-instruction andncc 21)
- (3-operand-instruction orr 2)
- (3-operand-instruction orcc 18)
- (3-operand-instruction orn 6)
- (3-operand-instruction orncc 22)
- (3-operand-instruction xorr 3)
- (3-operand-instruction xorcc 19)
- (3-operand-instruction xnor 7)
- (3-operand-instruction xnorcc 23)
- (3-operand-instruction sllv 37)
- (3-operand-instruction srlv 38)
- (3-operand-instruction srav 39)
- (3-operand-instruction subr 4)
- (3-operand-instruction subcc 20)
- (3-operand-instruction subx 12)
- (3-operand-instruction umul 10)
- (3-operand-instruction smul 11)
- (3-operand-instruction umulcc 26)
- (3-operand-instruction smulcc 27)
- (3-operand-instruction udiv 14)
- (3-operand-instruction sdiv 15)
- (3-operand-instruction udivcc 30)
- (3-operand-instruction sdivcc 31)
- )
-
-
-(let-syntax
- ((shift-instruction-immediate
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? destination) (? source) (? amount))
- (LONG (2 2)
- (5 destination)
- (6 ,(caddr form))
- (5 source)
- (1 1)
- (8 0)
- (5 amount)
- )))))))
- (shift-instruction-immediate sll 37)
- (shift-instruction-immediate srl 38)
- (shift-instruction-immediate sra 39))
-
-\f
-
-(define-instruction jalr
- (((? destination) (? source))
- (LONG (2 2)
- (5 destination)
- (6 56)
- (5 source)
- (1 0)
- (8 0)
- (5 0))))
-
-(define-instruction jr
- (((? source))
- (LONG (2 2)
- (5 0)
- (6 56)
- (5 source)
- (1 0)
- (8 0)
- (5 0))))
-
-(define-instruction jmpl
- (((? destination) (? source1) (? source2))
- (LONG (2 2)
- (5 destination)
- (6 56)
- (5 source1)
- (1 0)
- (8 0)
- (5 source2))))
-
-(define-instruction call
- (((? offset))
- (LONG (2 1)
- (30 (quotient offset 4) SIGNED))))
-
-(define-instruction sethi
- (((? destination) (? bits))
- (LONG (2 0)
- (5 destination)
- (3 4)
- (22 (top-22-bits bits) UNSIGNED))))
-
-\f
-;;;; Assembler pseudo-ops
-
-(define-instruction EXTERNAL-LABEL
- ;; External labels provide the garbage collector with header
- ;; information and the runtime system with type, arity, and
- ;; debugging information.
- (((? format-word) (@PCR (? label)))
- (if (eq? endianness 'LITTLE)
- (LONG (16 label BLOCK-OFFSET)
- (16 format-word UNSIGNED))
- (LONG (16 format-word UNSIGNED)
- (16 label BLOCK-OFFSET)))))
-
-(define-instruction NOP
- ;; SETHI $0, 0
- (()
- (LONG (2 0)
- (5 0)
- (3 4)
- (22 0))))
-
-(define-instruction LONG
- ((S (? value))
- (LONG (32 value SIGNED)))
- ((U (? value))
- (LONG (32 value UNSIGNED))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; SPARC instruction set, part 2a
-
-(declare (usual-integrations))
-\f
-;;;; Instructions that require branch tensioning: branch
-
-(let-syntax
- ((branch
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((@PCO (? offset)))
- (LONG (2 0)
- ,(caddr form)
- ,(cadddr form)
- (3 2)
- (22 (quotient offset 4) SIGNED)))
- (((@PCR (? label)))
- (VARIABLE-WIDTH (offset `(/ (- ,label (+ *PC* 0)) 4))
- ((#x-400000 #x3fffff)
- (LONG (2 0)
- ,(caddr form)
- ,(cadddr form)
- (3 2)
- (22 offset SIGNED)))
- ((() ())
- ;; B??a condition, yyy
- ;; JMPL xxx, $0
- ;; yyy: SETHI $1, high(offset)
- ;; OR $1, $1, low(offset)
- ;; JMPL $1,$0
- ;; xxx: fall through
- (LONG (2 0)
- (1 1) ; set anull bit, the JMPL is cancelled
- ; on a taken branch
- ,(cadddr form)
- (3 2)
- (22 2 SIGNED) ; B??condition, yyy
- (2 2)
- (5 0)
- (6 #x38)
- (5 0)
- (1 1)
- (13 16 SIGNED) ; JMPL xxx, $0
- (2 0)
- (5 1)
- (3 4)
- (22 (high-bits (* offset 4)) SIGNED)
- ; SETHI $1, high22(offset)
- (2 2)
- (5 1)
- (6 2)
- (5 1)
- (1 1)
- (13 (low-bits (* offset 4)) SIGNED)
- ; OR $1, $1, low10(offset)
- (2 2)
- (5 0)
- (6 #x38)
- (5 1)
- (1 0)
- (8 0)
- (5 0) ; JMPL $1,$0
- )))))))))
- (branch ba (1 0) (4 8))
- (branch bn (1 0) (4 0))
- (branch bne (1 0) (4 9))
- (branch be (1 0) (4 1))
- (branch bg (1 0) (4 10))
- (branch ble (1 0) (4 2))
- (branch bge (1 0) (4 11))
- (branch bl (1 0) (4 3))
- (branch bgu (1 0) (4 12))
- (branch bleu (1 0) (4 4))
- (branch bcc (1 0) (4 13))
- (branch bcs (1 0) (4 5))
- (branch bpos (1 0) (4 14))
- (branch bneg (1 0) (4 6))
- (branch bvc (1 0) (4 15))
- (branch bvs (1 0) (4 7))
- )
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; SPARC instruction set, part 2b
-
-(declare (usual-integrations))
-\f
-;;;; Instructions that require branch tensioning: load/store
-
-(let-syntax
- ((load/store-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? source/dest-reg) (OFFSET (? offset-ls) (? base-reg)))
- (VARIABLE-WIDTH (delta offset-ls)
- ((#x-fff #xfff)
- (LONG (2 3)
- (5 source/dest-reg)
- (6 ,(caddr form))
- (5 base-reg)
- (1 1)
- (13 delta SIGNED)))
- ((() ())
- ;; SETHI 1, %hi(offset)
- ;; OR 1, 1, %lo(offset)
- ;; LD source/dest-reg,1,base-reg
- (LONG (2 0) ; SETHI
- (5 1)
- (3 4)
- (22 (high-bits delta))
-
- (2 2) ; OR
- (5 1)
- (6 2)
- (5 1)
- (1 1)
- (13 (low-bits delta))
-
- (2 3) ; LD
- (5 source/dest-reg)
- (6 ,(caddr form))
- (5 1)
- (1 0)
- (8 0)
- (5 base-reg))))))))))
- (load/store-instruction ldsb 9)
- (load/store-instruction ldsh 10)
- (load/store-instruction ldub 1)
- (load/store-instruction lduh 2)
- (load/store-instruction ld 0)
- (load/store-instruction ldd 3)
- (load/store-instruction stb 5)
- (load/store-instruction sth 6)
- (load/store-instruction st 4)
- (load/store-instruction std 7)
- (load/store-instruction ldf 32)
- (load/store-instruction lddf 35)
- (load/store-instruction ldfsr 33)
- (load/store-instruction stf 36)
- (load/store-instruction ltdf 39)
- (load/store-instruction stfsr 37)
- )
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; SPARC instruction set, part 3
-
-(declare (usual-integrations))
-\f
-(let-syntax
- ((float-instruction-3
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? destination) (? source1) (? source2))
- (LONG (2 2)
- (5 destination)
- (6 ,(caddr form))
- (5 source1)
- (9 ,(cadddr form))
- (5 source2))))))))
- (float-instruction-3 fadds 52 65)
- (float-instruction-3 faddd 52 66)
- (float-instruction-3 faddq 52 67)
- (float-instruction-3 fsubs 52 69)
- (float-instruction-3 fsubd 52 70)
- (float-instruction-3 fsubq 52 71)
- (float-instruction-3 fmuls 52 73)
- (float-instruction-3 fmuld 52 74)
- (float-instruction-3 fmulq 52 75)
- (float-instruction-3 fsmuld 52 #x69)
- (float-instruction-3 fdmulq 52 #x6e)
- (float-instruction-3 fdivs 52 #x4d)
- (float-instruction-3 fdivd 52 #x4e)
- (float-instruction-3 fdivq 52 #x4f))
-
-(let-syntax
- ((float-instruction-cmp
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? source1) (? source2))
- (LONG (2 2)
- (5 0)
- (6 ,(caddr form))
- (5 source1)
- (9 ,(cadddr form))
- (5 source2))))))))
- (float-instruction-cmp fcmps 53 #x51)
- (float-instruction-cmp fcmpd 53 #x52)
- (float-instruction-cmp fcmpq 53 #x53)
- (float-instruction-cmp fcmpes 53 #x55)
- (float-instruction-cmp fcmped 53 #x56)
- (float-instruction-cmp fcmpeq 53 #x57))
-
-(let-syntax
- ((float-instruction-2
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? destination) (? source))
- (LONG (2 2)
- (5 destination)
- (6 ,(caddr form))
- (5 0)
- (9 ,(cadddr form))
- (5 source))))))))
- (float-instruction-2 fsqrts #x34 #x29)
- (float-instruction-2 fsqrtd #x34 #x2a)
- (float-instruction-2 fsqrtq #x34 #x2b)
-
- (float-instruction-2 fmovs #x34 #x01)
- (float-instruction-2 fnegs #x34 #x05)
- (float-instruction-2 fabss #x34 #x09)
-
- (float-instruction-2 fstoi #x34 #xd1)
- (float-instruction-2 fdtoi #x34 #xd2)
- (float-instruction-2 fqtoi #x34 #xd3)
-
- (float-instruction-2 fitos #x34 #xc4)
- (float-instruction-2 fitod #x34 #xc8)
- (float-instruction-2 fitoq #x34 #xcc)
-
- (float-instruction-2 fstod #x34 #xc9)
- (float-instruction-2 fstoq #x34 #xcd)
-
- (float-instruction-2 fdtos #x34 #xc6)
- (float-instruction-2 fstod #x34 #xce)
-
- (float-instruction-2 fstod #x34 #xc7)
- (float-instruction-2 fstod #x34 #xcb))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RTL Rules for SPARC. Shared utilities.
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Register-Allocator Interface
-
-(define (register->register-transfer source target)
- (guarantee-registers-compatible source target)
- (case (register-type source)
- ((GENERAL) (copy source target))
- ((FLOAT) (fp-copy source target))
- (else (error "unknown register type" source))))
-
-(define (home->register-transfer source target)
- (memory->register-transfer (pseudo-register-displacement source)
- regnum:regs-pointer
- target))
-
-(define (register->home-transfer source target)
- (register->memory-transfer source
- (pseudo-register-displacement target)
- regnum:regs-pointer))
-
-(define (reference->register-transfer source target)
- (case (ea/mode source)
- ((GR)
- (copy (register-ea/register source) target))
- ((FPR)
- (fp-copy (fpr->float-register (register-ea/register source)) target))
- ((OFFSET)
- (memory->register-transfer (offset-ea/offset source)
- (offset-ea/register source)
- target))
- (else
- (error "unknown effective-address mode" source))))
-
-(define (pseudo-register-home register)
- ;; Register block consists of 16 4-byte registers followed by 256
- ;; 8-byte temporaries.
- (INST-EA (OFFSET ,(pseudo-register-displacement register)
- ,regnum:regs-pointer)))
-\f
-(define-integrable (sort-machine-registers registers)
- registers)
-
-(define available-machine-registers
- (list
- ;; g0 g1
- g2 g3 g4
- ;; g5 g6 g7
-
- g22 g23 ;; g24
- g28 g29 g30
-
- g8 g9 g10 g11 g12 g13
-
- ;; g14 g15
- ;; g16 g17 g18 g19 g20 g21 g22
- ;; g25 g26 g27 g28
- ;; g31 ; could be available if handled right
-
- fp0 fp2 fp4 fp6 fp8 fp10 fp12 fp14
- fp16 fp18 fp20 fp22 fp24 fp26 fp28 fp30
- ;; fp1 fp3 fp5 fp7 fp9 fp11 fp13 fp15
- ;; fp17 fp19 fp21 fp23 fp25 fp27 fp29 fp31
- ))
-
-(define-integrable (float-register? register)
- (eq? (register-type register) 'FLOAT))
-
-(define-integrable (general-register? register)
- (eq? (register-type register) 'GENERAL))
-
-(define-integrable (word-register? register)
- (eq? (register-type register) 'GENERAL))
-
-(define (register-type register)
- (cond ((machine-register? register)
- (vector-ref
- '#(GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
- GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
- GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
- GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
- FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
- FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
- FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
- FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT)
- register))
- ((register-value-class=word? register) 'GENERAL)
- ((register-value-class=float? register) 'FLOAT)
- (else (error "unable to determine register type" register))))
-
-(define register-reference
- (let ((references (make-vector number-of-machine-registers)))
- (let loop ((register 0))
- (if (< register 32)
- (begin
- (vector-set! references register (INST-EA (GR ,register)))
- (loop (1+ register)))))
- (let loop ((register 32) (fpr 0))
- (if (< register 48)
- (begin
- (vector-set! references register (INST-EA (FPR ,fpr)))
- (loop (1+ register) (1+ fpr)))))
- (lambda (register)
- (vector-ref references register))))
-\f
-;;;; Useful Cliches
-
-(define (memory->register-transfer offset base target)
- (case (register-type target)
- ((GENERAL) (LAP (LD ,target (OFFSET ,offset ,base)) (NOP)))
- ((FLOAT) (fp-load-doubleword offset base target #T))
- (else (error "unknown register type" target))))
-
-(define (register->memory-transfer source offset base)
- (case (register-type source)
- ((GENERAL) (LAP (ST ,source (OFFSET ,offset ,base))))
- ((FLOAT) (fp-store-doubleword offset base source))
- (else (error "unknown register type" source))))
-
-(define (load-constant target constant delay-slot? record?)
- ;; Load a Scheme constant into a machine register.
- (if (non-pointer-object? constant)
- (load-immediate target (non-pointer->literal constant) record?)
- (load-pc-relative target
- 'CONSTANT
- (constant->label constant)
- delay-slot?)))
-
-(define (deposit-type-address type source target)
- (deposit-type-datum (fix:xor (quotient #x10 type-scale-factor) type)
- source
- target))
-
-(define (deposit-type-datum type source target)
- (with-values
- (lambda ()
- (immediate->register (make-non-pointer-literal type 0)))
- (lambda (prefix alias)
- (LAP ,@prefix
- (XORR ,target ,alias ,source)))))
-
-(define (non-pointer->literal constant)
- (make-non-pointer-literal (object-type constant)
- (careful-object-datum constant)))
-
-(define-integrable (make-non-pointer-literal type datum)
- (+ (* type (expt 2 scheme-datum-width)) datum))
-
-(define-integrable (deposit-type type-num target-reg)
- (if (= target-reg regnum:assembler-temp)
- (error "deposit-type: into register 1"))
- (LAP (ANDR ,target-reg ,target-reg ,regnum:address-mask)
- ,@(put-type type-num target-reg)))
-
-(define-integrable (put-type type-num target-reg)
- ; Assumes that target-reg has 0 in type bits
- (LAP (SETHI ,regnum:assembler-temp ,(* type-num #x4000000))
- (ORR ,target-reg ,regnum:assembler-temp ,target-reg)))
-
-\f
-;;;; Regularized Machine Instructions
-
-(define (adjusted:high n)
- (let ((n (->unsigned n)))
- (if (< (remainder n #x10000) #x8000)
- (quotient n #x10000)
- (+ (quotient n #x10000) 1))))
-
-(define (adjusted:low n)
- (let ((remainder (remainder (->unsigned n) #x10000)))
- (if (< remainder #x8000)
- remainder
- (- remainder #x10000))))
-
-(define (low-bits offset)
- (let ((bits (signed-integer->bit-string 32 offset)))
- (bit-substring bits 0 10)))
-
-(define (high-bits offset)
- (let ((bits (signed-integer->bit-string 32 offset)))
- (bit-substring bits 10 32)))
-
-(define-integrable (top-16-bits n)
- (quotient (->unsigned n) #x10000))
-
-(define-integrable (bottom-16-bits n)
- (remainder (->unsigned n) #x10000))
-
-(define-integrable (bottom-10-bits n)
- (remainder (->unsigned n) #x400))
-
-(define-integrable (bottom-13-bits n)
- (remainder (->unsigned n) #x2000))
-
-(define-integrable (top-22-bits n)
- (quotient (->unsigned n) #x400))
-
-(define (->unsigned n)
- (if (negative? n) (+ #x100000000 n) n))
-
-(define-integrable (fits-in-16-bits-signed? value)
- (<= #x-8000 value #x7fff))
-
-(define-integrable (fits-in-16-bits-unsigned? value)
- (<= #x0 value #xffff))
-
-(define-integrable (fits-in-13-bits-signed? value)
- (<= #x-2000 value #x1fff))
-
-(define-integrable (fits-in-13-bits-unsigned? value)
- (<= #x0 value #x1fff))
-
-(define-integrable (top-16-bits-only? value)
- (zero? (bottom-16-bits value)))
-
-(define-integrable (top-22-bits-only? value)
- (zero? (bottom-10-bits value)))
-
-(define (copy r t)
- (if (= r t)
- (LAP)
- (LAP (ADD ,t 0 ,r))))
-
-(define (fp-copy from to)
- (if (= to from)
- (LAP)
- (let ((to-reg (float-register->fpr to))
- (from-reg (float-register->fpr from)))
- (LAP (FMOVS ,to-reg ,from-reg)
- (FMOVS ,(+ to-reg 1) ,(+ from-reg 1))))))
-
-;; Handled by VARIABLE-WIDTH in instr1.scm
-
-(define (fp-load-doubleword offset base target NOP?)
- (let* ((least (float-register->fpr target))
- (most (+ least 1)))
- (LAP (LDDF ,least (OFFSET ,offset ,base))
- ,@(if NOP? (LAP (NOP)) (LAP)))))
-
-(define (fp-store-doubleword offset base source)
- (let* ((least (float-register->fpr source))
- (most (+ least 1)))
- (LAP (SDDF ,least (OFFSET ,offset ,base))
- ,@(if NOP? (LAP (NOP)) (LAP)))))
-\f
-;;;; PC-relative addresses
-
-(define (load-pc-relative target type label delay-slot?)
- ;; Load a pc-relative location's contents into a machine register.
- ;; Optimization: if there is a register that contains the value of
- ;; another label, use that register as the base register.
- ;; Otherwise, allocate a temporary and load it with the value of the
- ;; label, then use the temporary as the base register. This
- ;; strategy of loading a temporary wins if the temporary is used
- ;; again, but loses if it isn't, since loading the temporary takes
- ;; two instructions in addition to the LW instruction, while doing a
- ;; pc-relative LW instruction takes only two instructions total.
- ;; But pc-relative loads of various kinds are quite common, so this
- ;; should almost always be advantageous.
- (with-values (lambda () (get-typed-label type))
- (lambda (label* alias)
- (if label*
- (LAP (LD ,target (OFFSET (- ,label ,label*) ,alias))
- ,@(if delay-slot? (LAP (NOP)) (LAP)))
- (let ((temporary (standard-temporary!)))
- (set-typed-label! type label temporary)
- (LAP ,@(%load-pc-relative-address temporary label)
- (LD ,target (OFFSET 0 ,temporary))
- ,@(if delay-slot? (LAP (NOP)) (LAP))))))))
-
-(define (load-pc-relative-address target type label)
- ;; Load address of a pc-relative location into a machine register.
- ;; Optimization: if there is another register that contains the
- ;; value of another label, add the difference between the labels to
- ;; that register's contents instead. The ADDI takes one
- ;; instruction, while the %LOAD-PC-RELATIVE-ADDRESS takes two, so
- ;; this is always advantageous.
- (let ((instructions
- (with-values (lambda () (get-typed-label type))
- (lambda (label* alias)
- (if label*
- (LAP (ADDI ,target ,alias (- ,label ,label*)))
- (%load-pc-relative-address target label))))))
- (set-typed-label! type label target)
- instructions))
-
-(define (%load-pc-relative-address target label)
- (let ((label* (generate-label)))
- (LAP (CALL 4)
- (LABEL ,label*)
- (ADDI ,target ,regnum:call-result (- ,label (- ,label* 4))))))
-
-;;; Typed labels provide further optimization. There are two types,
-;;; CODE and CONSTANT, that say whether the label is located in the
-;;; code block or the constants block of the output. Statistically,
-;;; a label is likely to be closer to another label of the same type
-;;; than to a label of the other type.
-
-(define (get-typed-label type)
- (let ((entries (register-map-labels *register-map* 'GENERAL)))
- (let loop ((entries* entries))
- (cond ((null? entries*)
- ;; If no entries of the given type, use any entry that is
- ;; available.
- (let loop ((entries entries))
- (cond ((null? entries)
- (values false false))
- ((pair? (caar entries))
- (values (cdaar entries) (cadar entries)))
- (else
- (loop (cdr entries))))))
- ((and (pair? (caar entries*))
- (eq? type (caaar entries*)))
- (values (cdaar entries*) (cadar entries*)))
- (else
- (loop (cdr entries*)))))))
-
-(define (set-typed-label! type label alias)
- (set! *register-map*
- (set-machine-register-label *register-map* alias (cons type label)))
- unspecific)
-\f
-(define (immediate->register immediate)
- (let ((register (get-immediate-alias immediate)))
- (if register
- (values (LAP) register)
- (let ((temporary (standard-temporary!)))
- (set! *register-map*
- (set-machine-register-label *register-map*
- temporary
- immediate))
- (values (%load-immediate temporary immediate) temporary)))))
-
-(define (get-immediate-alias immediate)
- (let loop ((entries (register-map-labels *register-map* 'GENERAL)))
- (cond ((null? entries)
- false)
- ((eqv? (caar entries) immediate)
- (cadar entries))
- (else
- (loop (cdr entries))))))
-
-(define (load-immediate target immediate record?)
- (let ((registers (get-immediate-aliases immediate)))
- (if (memv target registers)
- (LAP)
- (begin
- (if record?
- (set! *register-map*
- (set-machine-register-label *register-map*
- target
- immediate)))
- (if (not (null? registers))
- (LAP (ADD ,target 0 ,(car registers)))
- (%load-immediate target immediate))))))
-
-(define (get-immediate-aliases immediate)
- (let loop ((entries (register-map-labels *register-map* 'GENERAL)))
- (cond ((null? entries)
- '())
- ((eqv? (caar entries) immediate)
- (append (cdar entries) (loop (cdr entries))))
- (else
- (loop (cdr entries))))))
-
-(define (%load-immediate target immediate)
- (cond ((top-22-bits-only? immediate)
- (LAP (SETHI ,target ,immediate)))
- ((fits-in-13-bits-signed? immediate)
- (LAP (ORI ,target ,regnum:zero ,(bottom-13-bits immediate))))
- (else
- (LAP (SETHI ,target ,immediate)
- (ORI ,target ,target ,(bottom-10-bits immediate))))))
-
-(define (add-immediate immediate source target)
- (if (fits-in-13-bits-signed? immediate)
- (LAP (ADDI ,target ,source ,immediate))
- (with-values (lambda () (immediate->register immediate))
- (lambda (prefix alias)
- (LAP ,@prefix
- (ADDU ,target ,source ,alias))))))
-\f
-;;;; Comparisons
-
-(define (compare-immediate comp immediate source)
- ; Branch if immediate <comp> source
- (let ((cc (invert-condition-noncommutative comp)))
- ;; This machine does register <op> immediate; you can
- ;; now think of cc in this way
- (if (zero? immediate)
- (begin
- (branch-generator! cc
- `(BE) `(BL) `(BG)
- `(BNE) `(BGE) `(BLE))
- (LAP (SUBCCI 0 ,source 0)))
- (with-values (lambda () (immediate->register immediate))
- (lambda (prefix alias)
- (LAP ,@prefix
- ,@(compare comp alias source)))))))
-
-(define (compare condition r1 r2)
- ; Branch if r1 <cc> r2
- (if (= r1 r2)
- (let ((branch
- (lambda (label) (LAP (BA (@PCR ,label)) (NOP))))
- (dont-branch
- (lambda (label) label (LAP))))
- (if (memq condition '(< > <>))
- (set-current-branches! dont-branch branch)
- (set-current-branches! branch dont-branch))
- (LAP (SUBCC 0 ,r1 ,r2)))
- (begin
- (branch-generator! condition
- `(BE) `(BL) `(BG) `(BNE) `(BGE) `(BLE))
- (LAP (SUBCC 0 ,r1 ,r2)))))
-
-(define (branch-generator! cc = < > <> >= <=)
- (let ((forward
- (case cc
- ((=) =) ((<) <) ((>) >)
- ((<>) <>) ((>=) >=) ((<=) <=)))
- (inverse
- (case cc
- ((=) <>) ((<) >=) ((>) <=)
- ((<>) =) ((>=) <) ((<=) >))))
- (set-current-branches!
- (lambda (label)
- (LAP (,@forward (@PCR ,label)) (NOP)))
- (lambda (label)
- (LAP (,@inverse (@PCR ,label)) (NOP))))))
-
-(define (invert-condition condition)
- (let ((place (assq condition condition-inversion-table)))
- (if (not place)
- (error "unknown condition" condition))
- (cadr place)))
-
-(define (invert-condition-noncommutative condition)
- (let ((place (assq condition condition-inversion-table)))
- (if (not place)
- (error "unknown condition" condition))
- (caddr place)))
-
-(define condition-inversion-table
- ; A OP B NOT (A OP B) B OP A
- ; invert invert non-comm.
- '((= <> =)
- (< >= >)
- (> <= <)
- (<> = <>)
- (<= > >=)
- (>= < <=)))
-\f
-;;;; Miscellaneous
-
-(define-integrable (object->type source target)
- ; Type extraction
- (LAP (SRL ,target ,source ,(- 32 scheme-type-width))))
-
-(define-integrable (object->datum source target)
- ; Zero out the type field; don't put in the quad bits
- (LAP (ANDR ,target ,source ,regnum:address-mask)))
-
-(define (object->address source target)
- ; Drop in the segment bits
- (LAP (ANDR ,target ,source ,regnum:address-mask)
- (ADD ,target ,regnum:quad-bits ,target)))
-
-(define (standard-unary-conversion source target conversion)
- ;; `source' is any register, `target' a pseudo register.
- (let ((source (standard-source! source)))
- (conversion source (standard-target! target))))
-
-(define (standard-binary-conversion source1 source2 target conversion)
- (let ((source1 (standard-source! source1))
- (source2 (standard-source! source2)))
- (conversion source1 source2 (standard-target! target))))
-
-(define (standard-source! register)
- (load-alias-register! register (register-type register)))
-
-(define (standard-target! register)
- (delete-dead-registers!)
- (allocate-alias-register! register (register-type register)))
-
-(define-integrable (standard-temporary!)
- (allocate-temporary-register! 'GENERAL))
-
-(define (standard-move-to-target! source target)
- (move-to-alias-register! source (register-type source) target))
-
-(define (standard-move-to-temporary! source)
- (move-to-temporary-register! source (register-type source)))
-
-(define (register-expression expression)
- (case (rtl:expression-type expression)
- ((REGISTER)
- (rtl:register-number expression))
- ((CONSTANT)
- (let ((object (rtl:constant-value expression)))
- (and (zero? (object-type object))
- (zero? (object-datum object))
- 0)))
- ((CONS-NON-POINTER)
- (and (let ((type (rtl:cons-non-pointer-type expression)))
- (and (rtl:machine-constant? type)
- (zero? (rtl:machine-constant-value type))))
- (let ((datum (rtl:cons-non-pointer-datum expression)))
- (and (rtl:machine-constant? datum)
- (zero? (rtl:machine-constant-value datum))))
- 0))
- (else false)))
-\f
-(define (define-arithmetic-method operator methods method)
- (let ((entry (assq operator (cdr methods))))
- (if entry
- (set-cdr! entry method)
- (set-cdr! methods (cons (cons operator method) (cdr methods)))))
- operator)
-
-(define (lookup-arithmetic-method operator methods)
- (cdr (or (assq operator (cdr methods))
- (error "Unknown operator" operator))))
-
-(define-integrable (ea/mode ea) (car ea))
-(define-integrable (register-ea/register ea) (cadr ea))
-(define-integrable (offset-ea/offset ea) (cadr ea))
-(define-integrable (offset-ea/register ea) (caddr ea))
-
-(define (pseudo-register-displacement register)
- ;; Register block consists of 16 4-byte registers followed by 256
- ;; 8-byte temporaries.
- (+ (* 4 16) (* 8 (register-renumber register))))
-
-(define-integrable (float-register->fpr register)
- ;; Float registers are represented by 32 through 47 in the RTL,
- ;; corresponding to even registers 0 through 30 in the machine.
- (- register 32))
-
-(define-integrable (fpr->float-register register)
- (+ register 32))
-
-(define-integrable reg:memtop
- (INST-EA (OFFSET #x0000 ,regnum:regs-pointer)))
-
-(define-integrable reg:environment
- (INST-EA (OFFSET #x000C ,regnum:regs-pointer)))
-
-(define-integrable reg:lexpr-primitive-arity
- (INST-EA (OFFSET #x001C ,regnum:regs-pointer)))
-
-(define-integrable reg:closure-limit
- (INST-EA (OFFSET #x0024 ,regnum:regs-pointer)))
-
-(define-integrable reg:stack-guard
- (INST-EA (OFFSET #x002C ,regnum:regs-pointer)))
-
-(define (lap:make-label-statement label)
- (INST (LABEL ,label)))
-
-(define (lap:make-unconditional-branch label)
- (LAP (BA (@PCR ,label))
- (NOP)))
-
-(define (lap:make-entry-point label block-start-label)
- block-start-label
- (LAP (ENTRY-POINT ,label)
- ,@(make-external-label expression-code-word label)))
-\f
-;;;; Codes and Hooks
-
-(let-syntax ((define-codes
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(BEGIN
- ,@(let loop ((names (cddr form)) (index (cadr form)))
- (if (pair? names)
- (cons `(DEFINE-INTEGRABLE
- ,(symbol-append 'CODE:COMPILER-
- (car names))
- ,index)
- (loop (cdr names) (+ index 1)))
- '())))))))
- (define-codes #x012
- primitive-apply primitive-lexpr-apply
- apply error lexpr-apply link
- interrupt-closure interrupt-dlink interrupt-procedure
- interrupt-continuation interrupt-ic-procedure
- assignment-trap cache-reference-apply
- reference-trap safe-reference-trap unassigned?-trap
- -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero?
- access lookup safe-lookup unassigned? unbound?
- set! define lookup-apply))
-
-(define-integrable (link-to-interface code)
- ;; Jump to link-to-interface with link in C_arg1
- (LAP (ADDI ,regnum:assembler-temp ,regnum:scheme-to-interface -4)
- (JALR ,regnum:first-arg ,regnum:assembler-temp)
- (ADDI ,regnum:interface-index 0 ,(* 4 code))))
-
-(define-integrable (link-to-trampoline code)
- ;; Jump, with link in 31, to trampoline_to_interface
- ;; Jump, with link in C_arg1 to scheme-to-interface
- (LAP (JALR ,regnum:first-arg ,regnum:scheme-to-interface)
- (ADDI ,regnum:interface-index 0 ,(* 4 code))))
-
-(define-integrable (invoke-interface code)
- ;; Jump to scheme-to-interface
- (LAP (JALR ,regnum:assembler-temp ,regnum:scheme-to-interface)
- (ADDI ,regnum:interface-index 0 ,(* 4 code))))
-
-(define (load-interface-args! first second third fourth)
- (let ((clear-regs
- (apply clear-registers!
- (append (if first (list regnum:first-arg) '())
- (if second (list regnum:second-arg) '())
- (if third (list regnum:third-arg) '())
- (if fourth (list regnum:fourth-arg) '()))))
- (load-reg
- (lambda (reg arg)
- (if reg (load-machine-register! reg arg) (LAP)))))
- (let ((load-regs
- (LAP ,@(load-reg first regnum:first-arg)
- ,@(load-reg second regnum:second-arg)
- ,@(load-reg third regnum:third-arg)
- ,@(load-reg fourth regnum:fourth-arg))))
- (LAP ,@clear-regs
- ,@load-regs
- ,@(clear-map!)))))
-
-(define (require-register! machine-reg)
- (flush-register! machine-reg)
- (need-register! machine-reg))
-
-(define-integrable (flush-register! machine-reg)
- (prefix-instructions! (clear-registers! machine-reg)))
-
-(define (rtl-target:=machine-register! rtl-reg machine-reg)
- (if (machine-register? rtl-reg)
- (begin
- (require-register! machine-reg)
- (if (not (= rtl-reg machine-reg))
- (suffix-instructions!
- (register->register-transfer machine-reg rtl-reg))))
- (begin
- (delete-register! rtl-reg)
- (flush-register! machine-reg)
- (add-pseudo-register-alias! rtl-reg machine-reg))))
-
-
-(define (pre-lapgen-analysis rgraphs)
- rgraphs
- unspecific)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Optimizer for MIPS.
-
-(declare (usual-integrations))
-\f
-(define (optimize-linear-lap instructions)
- instructions)
-
-#|
-(define (optimize-linear-lap instructions)
- ;; Find occurrences of LW/LBU/LWC1 followed by NOP, and delete the
- ;; NOP if the instruction following it has no reference to the
- ;; target register of the load.
-
- ;; **** This is pretty fragile. ****
- (letrec
- ((find-load
- (lambda (instructions)
- (cond ((null? instructions) '())
- ((and (pair? (car instructions))
- (or (eq? 'LW (caar instructions))
- (eq? 'LBU (caar instructions))
- (eq? 'LWC1 (caar instructions))))
- instructions)
- (else (find-load (cdr instructions))))))
- (get-next
- (lambda (instructions)
- (let ((instructions (cdr instructions)))
- (cond ((null? instructions) '())
- ((or (not (pair? (car instructions)))
- (eq? 'LABEL (caar instructions))
- (eq? 'COMMENT (caar instructions)))
- (get-next instructions))
- (else instructions)))))
- (refers-to-register?
- (lambda (instruction register)
- (let loop ((x instruction))
- (if (pair? x)
- (or (loop (car x))
- (loop (cdr x)))
- (eqv? register x))))))
- (let loop ((instructions instructions))
- (let ((first (find-load instructions)))
- (if (not (null? first))
- (let ((second (get-next first)))
- (if (not (null? second))
- (let ((third (get-next second)))
- (if (not (null? third))
- (if (and (equal? '(NOP) (car second))
- ;; This is a crude way to test for a
- ;; reference to the target register
- ;; -- it will sometimes incorrectly
- ;; say that there is a reference, but
- ;; it will never incorrectly say that
- ;; there is no reference.
- (not (refers-to-register? (car third)
- (cadar first)))
- (or (not (and (eq? 'LWC1 (caar first))
- (odd? (cadar first))))
- (not (refers-to-register?
- (car third)
- (- (cadar first) 1)))))
- (begin
- (let loop ((this (cdr first)) (prev first))
- (if (eq? second this)
- (set-cdr! prev (cdr this))
- (loop (cdr this) this)))
- (loop (if (equal? '(NOP) (car third))
- first
- third)))
- (loop second))))))))))
- instructions)
-|#
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Machine Model for SPARC
-;;; package: (compiler)
-
-(declare (usual-integrations))
-\f
-;;;; Architecture Parameters
-
-(define use-pre/post-increment? false)
-(define endianness 'BIG)
-(define-integrable addressing-granularity 8)
-(define-integrable scheme-object-width 32)
-(define-integrable scheme-type-width 6) ;or 8
-(define-integrable type-scale-factor (expt 2 (- 8 scheme-type-width)))
-
-(define-integrable scheme-datum-width
- (- scheme-object-width scheme-type-width))
-
-(define-integrable float-width 64)
-(define-integrable float-alignment 64)
-
-(define-integrable address-units-per-float
- (quotient float-width addressing-granularity))
-
-;;; It is currently required that both packed characters and objects
-;;; be integrable numbers of address units. Furthermore, the number
-;;; of address units per object must be an integral multiple of the
-;;; number of address units per character. This will cause problems
-;;; on a machine that is word addressed, in which case we will have to
-;;; rethink the character addressing strategy.
-
-(define-integrable address-units-per-object
- (quotient scheme-object-width addressing-granularity))
-
-(define-integrable address-units-per-packed-char 1)
-
-(define-integrable signed-fixnum/upper-limit (expt 2 (-1+ scheme-datum-width)))
-(define-integrable signed-fixnum/lower-limit (- signed-fixnum/upper-limit))
-(define-integrable unsigned-fixnum/upper-limit (* 2 signed-fixnum/upper-limit))
-
-(define-integrable (stack->memory-offset offset) offset)
-(define-integrable ic-block-first-parameter-offset 2)
-(define-integrable execute-cache-size 3) ; Long words per UUO link slot
-(define-integrable closure-entry-size
- ;; Long words in a single closure entry:
- ;; Format + GC offset word
- ;; SETHI
- ;; JALR/JAL
- ;; ADDI
- 4)
-
-;; Given: the number of entry points in a closure, and a particular
-;; entry point number. Return: the distance from that entry point to
-;; the first variable slot in the closure (in words).
-
-(define (closure-first-offset nentries entry)
- (if (zero? nentries)
- 1 ; Strange boundary case
- (- (* closure-entry-size (- nentries entry)) 1)))
-
-;; Like the above, but from the start of the complete closure object,
-;; viewed as a vector, and including the header word.
-
-(define (closure-object-first-offset nentries)
- (case nentries
- ((0)
- ;; Vector header only
- 1)
- ((1)
- ;; Manifest closure header followed by single entry point
- (+ 1 closure-entry-size))
- (else
- ;; Manifest closure header, number of entries, then entries.
- (+ 1 1 (* closure-entry-size nentries)))))
-
-;; Bump from one entry point to another -- distance in BYTES
-
-(define (closure-entry-distance nentries entry entry*)
- nentries ; ignored
- (* (* closure-entry-size 4) (- entry* entry)))
-
-;; Bump to the canonical entry point. On a RISC (which forces
-;; longword alignment for entry points anyway) there is no need to
-;; canonicalize.
-
-(define (closure-environment-adjustment nentries entry)
- nentries entry ; ignored
- 0)
-\f
-;;;; Machine Registers
-
-(define-integrable g0 0)
-(define-integrable g1 1)
-(define-integrable g2 2)
-(define-integrable g3 3)
-(define-integrable g4 4)
-(define-integrable g5 5)
-(define-integrable g6 6)
-(define-integrable g7 7)
-(define-integrable g8 8)
-(define-integrable g9 9)
-(define-integrable g10 10)
-(define-integrable g11 11)
-(define-integrable g12 12)
-(define-integrable g13 13)
-(define-integrable g14 14)
-(define-integrable g15 15)
-(define-integrable g16 16)
-(define-integrable g17 17)
-(define-integrable g18 18)
-(define-integrable g19 19)
-(define-integrable g20 20)
-(define-integrable g21 21)
-(define-integrable g22 22)
-(define-integrable g23 23)
-(define-integrable g24 24)
-(define-integrable g25 25)
-(define-integrable g26 26)
-(define-integrable g27 27)
-(define-integrable g28 28)
-(define-integrable g29 29)
-(define-integrable g30 30)
-(define-integrable g31 31)
-
-;; Floating point general registers -- the odd numbered ones are
-;; only used when transferring to/from the CPU
-(define-integrable fp0 32)
-(define-integrable fp1 33)
-(define-integrable fp2 34)
-(define-integrable fp3 35)
-(define-integrable fp4 36)
-(define-integrable fp5 37)
-(define-integrable fp6 38)
-(define-integrable fp7 39)
-(define-integrable fp8 40)
-(define-integrable fp9 41)
-(define-integrable fp10 42)
-(define-integrable fp11 43)
-(define-integrable fp12 44)
-(define-integrable fp13 45)
-(define-integrable fp14 46)
-(define-integrable fp15 47)
-(define-integrable fp16 48)
-(define-integrable fp17 49)
-(define-integrable fp18 50)
-(define-integrable fp19 51)
-(define-integrable fp20 52)
-(define-integrable fp21 53)
-(define-integrable fp22 54)
-(define-integrable fp23 55)
-(define-integrable fp24 56)
-(define-integrable fp25 57)
-(define-integrable fp26 58)
-(define-integrable fp27 59)
-(define-integrable fp28 60)
-(define-integrable fp29 61)
-(define-integrable fp30 62)
-(define-integrable fp31 63)
-
-(define-integrable number-of-machine-registers 64)
-(define-integrable number-of-temporary-registers 256)
-\f
-;;; Fixed-use registers for Scheme compiled code.
-(define-integrable regnum:return-value g16)
-(define-integrable regnum:stack-pointer g17)
-(define-integrable regnum:memtop g18)
-(define-integrable regnum:free g19)
-(define-integrable regnum:scheme-to-interface g20)
-(define-integrable regnum:dynamic-link g21)
-(define-integrable regnum:closure-free g22)
-(define-integrable regnum:address-mask g25)
-(define-integrable regnum:regs-pointer g26)
-(define-integrable regnum:quad-bits g27)
-(define-integrable regnum:closure-hook g28)
-(define-integrable regnum:interface-index g13)
-
-;;; Fixed-use registers due to architecture or OS calling conventions.
-(define-integrable regnum:zero g0)
-(define-integrable regnum:assembler-temp g1)
-(define-integrable regnum:C-return-receive-value g8)
-(define-integrable regnum:C-return-send-value g24)
-(define-integrable regnum:C-stack-pointer g14)
-(define-integrable regnum:first-arg g8)
-(define-integrable regnum:second-arg g9)
-(define-integrable regnum:third-arg g10)
-(define-integrable regnum:fourth-arg g11)
-(define-integrable regnum:fifth-arg g12)
-(define-integrable regnum:sixth-arg g13)
-(define-integrable regnum:reserved-global-1 g2)
-(define-integrable regnum:reserved-global-2 g3)
-(define-integrable regnum:reserved-global-3 g4)
-(define-integrable regnum:reserved-global-4 g5)
-(define-integrable regnum:reserved-global-5 g6)
-(define-integrable regnum:reserved-global-6 g7)
-(define-integrable regnum:linkage g31)
-(define-integrable regnum:call-result g15)
-
-(define address-regs
- (list regnum:stack-pointer regnum:memtop regnum:free regnum:dynamic-link
- regnum:linkage))
-
-(define object-regs
- (list regnum:return-value regnum:C-return-send-value))
-
-(define immediate-regs
- (list regnum:address-mask regnum:quad-bits))
-
-(define unboxed-regs
- (list regnum:scheme-to-interface
- regnum:regs-pointer regnum:assembler-temp
- regnum:reserved-global-4
- regnum:reserved-global-5
- regnum:reserved-global-6
- regnum:C-stack-pointer
- ))
-
-(define machine-register-value-class
- (lambda (register)
- (cond ((member register address-regs) value-class=address)
- ((member register object-regs) value-class=object)
- ((member register immediate-regs) value-class=immediate)
- ((member register unboxed-regs) value-class=unboxed)
- ((<= g0 register g31) value-class=word)
- ((<= fp0 register fp31) value-class=float)
- (else (error "illegal machine register" register)))))
-
-(define-integrable (machine-register-known-value register)
- register ;ignore
- false)
-\f
-;;;; Interpreter Registers
-
-(define-integrable (interpreter-free-pointer)
- (rtl:make-machine-register regnum:free))
-
-(define (interpreter-free-pointer? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:free)))
-
-(define-integrable (interpreter-regs-pointer)
- (rtl:make-machine-register regnum:regs-pointer))
-
-(define (interpreter-regs-pointer? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:regs-pointer)))
-
-(define-integrable (interpreter-value-register)
- (rtl:make-machine-register regnum:return-value))
-
-(define (interpreter-value-register? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:return-value)))
-
-(define-integrable (interpreter-stack-pointer)
- (rtl:make-machine-register regnum:stack-pointer))
-
-(define (interpreter-stack-pointer? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:stack-pointer)))
-
-(define-integrable (interpreter-dynamic-link)
- (rtl:make-machine-register regnum:dynamic-link))
-
-(define (interpreter-dynamic-link? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:dynamic-link)))
-
-(define-integrable (interpreter-environment-register)
- (rtl:make-offset (interpreter-regs-pointer) 3))
-
-(define (interpreter-environment-register? expression)
- (and (rtl:offset? expression)
- (interpreter-regs-pointer? (rtl:offset-base expression))
- (= 3 (rtl:offset-number expression))))
-
-(define-integrable (interpreter-register:access)
- (rtl:make-machine-register regnum:C-return-send-value))
-
-(define-integrable (interpreter-register:cache-reference)
- (rtl:make-machine-register regnum:C-return-send-value))
-
-(define-integrable (interpreter-register:cache-unassigned?)
- (rtl:make-machine-register regnum:C-return-send-value))
-
-(define-integrable (interpreter-register:lookup)
- (rtl:make-machine-register regnum:C-return-send-value))
-
-(define-integrable (interpreter-register:unassigned?)
- (rtl:make-machine-register regnum:C-return-send-value))
-
-(define-integrable (interpreter-register:unbound?)
- (rtl:make-machine-register regnum:C-return-send-value))
-\f
-;;;; RTL Registers, Constants, and Primitives
-
-(define (rtl:machine-register? rtl-register)
- (case rtl-register
- ((STACK-POINTER)
- (interpreter-stack-pointer))
- ((DYNAMIC-LINK)
- (interpreter-dynamic-link))
- ((VALUE)
- (interpreter-value-register))
- ((INTERPRETER-CALL-RESULT:ACCESS)
- (interpreter-register:access))
- ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
- (interpreter-register:cache-reference))
- ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
- (interpreter-register:cache-unassigned?))
- ((INTERPRETER-CALL-RESULT:LOOKUP)
- (interpreter-register:lookup))
- ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
- (interpreter-register:unassigned?))
- ((INTERPRETER-CALL-RESULT:UNBOUND?)
- (interpreter-register:unbound?))
- (else false)))
-
-(define (rtl:interpreter-register? rtl-register)
- (case rtl-register
- ((MEMORY-TOP) 0)
- ((STACK-GUARD) 1)
- ((ENVIRONMENT) 3)
- ((TEMPORARY) 4)
- (else false)))
-
-(define (rtl:interpreter-register->offset locative)
- (or (rtl:interpreter-register? locative)
- (error "Unknown register type" locative)))
-
-(define (rtl:constant-cost expression)
- ;; Magic numbers.
- (let ((if-integer
- (lambda (value)
- (cond ((zero? value) 1)
- ((or (fits-in-16-bits-signed? value)
- (fits-in-16-bits-unsigned? value)
- (top-16-bits-only? value))
- 2)
- (else 3)))))
- (let ((if-synthesized-constant
- (lambda (type datum)
- (if-integer (make-non-pointer-literal type datum)))))
- (case (rtl:expression-type expression)
- ((CONSTANT)
- (let ((value (rtl:constant-value expression)))
- (if (non-pointer-object? value)
- (if-synthesized-constant (object-type value)
- (object-datum value))
- 3)))
- ((MACHINE-CONSTANT)
- (if-integer (rtl:machine-constant-value expression)))
- ((ENTRY:PROCEDURE
- ENTRY:CONTINUATION
- ASSIGNMENT-CACHE
- VARIABLE-CACHE
- OFFSET-ADDRESS)
- 3)
- ((CONS-NON-POINTER)
- (and (rtl:machine-constant? (rtl:cons-non-pointer-type expression))
- (rtl:machine-constant? (rtl:cons-non-pointer-datum expression))
- (if-synthesized-constant
- (rtl:machine-constant-value
- (rtl:cons-non-pointer-type expression))
- (rtl:machine-constant-value
- (rtl:cons-non-pointer-datum expression)))))
- (else false)))))
-
-(define compiler:open-code-floating-point-arithmetic?
- true)
-
-(set! compiler:open-code-primitives? #f)
-
-(define compiler:primitives-with-no-open-coding
- '(DIVIDE-FIXNUM GCD-FIXNUM FIXNUM-QUOTIENT FIXNUM-REMAINDER
- FIXNUM-NOT FIXNUM-AND FIXNUM-ANDC FIXNUM-OR FIXNUM-XOR FIXNUM-LSH
- INTEGER-QUOTIENT INTEGER-REMAINDER &/ QUOTIENT REMAINDER
- FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN FLONUM-ACOS
- FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-TRUNCATE FLONUM-ROUND
- FLONUM-REMAINDER FLONUM-SQRT FLONUM-EXPM1 FLONUM-LOG1P
- VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS
- FLOATING-VECTOR-REF FLOATING-VECTOR-SET!))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Compiler: System Construction
-
-(declare (usual-integrations))
-
-(let* ((val ((load "base/make") "SPARC"))
- (env (->environment '(COMPILER))))
- (set! (access endianness env) 'BIG)
- val)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$MC68020-Header: /scheme/compiler/bobcat/RCS/rgspcm.scm,v 4.2 1991/05/06 23:17:03 jinx Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RTL Generation: Special primitive combinations. Spectrum version.
-
-(declare (usual-integrations))
-\f
-(define (define-special-primitive-handler name handler)
- (let ((primitive (make-primitive-procedure name true)))
- (let ((entry (assq primitive special-primitive-handlers)))
- (if entry
- (set-cdr! entry handler)
- (set! special-primitive-handlers
- (cons (cons primitive handler)
- special-primitive-handlers)))))
- name)
-
-(define (special-primitive-handler primitive)
- (let ((entry (assq primitive special-primitive-handlers)))
- (and entry
- (cdr entry))))
-
-(define special-primitive-handlers
- '())
-
-(define (define-special-primitive/standard primitive)
- (define-special-primitive-handler primitive
- rtl:make-invocation:special-primitive))
-
-(define-special-primitive/standard '&+)
-(define-special-primitive/standard '&-)
-(define-special-primitive/standard '&*)
-(define-special-primitive/standard '&/)
-(define-special-primitive/standard '&=)
-(define-special-primitive/standard '&<)
-(define-special-primitive/standard '&>)
-(define-special-primitive/standard '1+)
-(define-special-primitive/standard '-1+)
-(define-special-primitive/standard 'zero?)
-(define-special-primitive/standard 'positive?)
-(define-special-primitive/standard 'negative?)
-(define-special-primitive/standard 'quotient)
-(define-special-primitive/standard 'remainder)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Data Transfers
-
-(declare (usual-integrations))
-\f
-;;;; Simple Operations
-
-;;; All assignments to pseudo registers are required to delete the
-;;; dead registers BEFORE performing the assignment. However, it is
-;;; necessary to derive the effective address of the source
-;;; expression(s) before deleting the dead registers. Otherwise any
-;;; source expression containing dead registers might refer to aliases
-;;; which have been reused.
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
- (standard-move-to-target! source target)
- (LAP))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum))))
- (let* ((type (standard-move-to-temporary! type))
- (target (standard-move-to-target! datum target)))
- (LAP (SLL ,type ,type ,(- 32 scheme-type-width))
- (ANDR ,target ,target ,regnum:address-mask)
- (ORR ,target ,type ,target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-NON-POINTER (REGISTER (? type)) (REGISTER (? datum))))
- (let* ((type (standard-move-to-temporary! type))
- (target (standard-move-to-target! datum target)))
- (LAP (SLL ,type ,type ,(- 32 scheme-type-width))
- (ORR ,target ,type ,target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source))))
- (let ((target (standard-move-to-target! source target)))
- (deposit-type type target)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source))))
- (standard-unary-conversion source target
- (lambda (source target)
- (deposit-type type source))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
- (standard-unary-conversion source target object->type))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
- (standard-unary-conversion source target object->datum))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
- (standard-unary-conversion source target object->address))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OFFSET-ADDRESS (REGISTER (? source)) (? offset)))
- (standard-unary-conversion source target
- (lambda (source target)
- (add-immediate (* 4 offset) source target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? offset)))
- (standard-unary-conversion source target
- (lambda (source target)
- (add-immediate offset source target))))
-\f
-;;;; Loading of Constants
-
-(define-rule statement
- ;; load a machine constant
- (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? source)))
- (load-immediate (standard-target! target) source #T))
-
-(define-rule statement
- ;; load a Scheme constant
- (ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
- (load-constant (standard-target! target) source #T #T))
-
-(define-rule statement
- ;; load the type part of a Scheme constant
- (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (CONSTANT (? constant))))
- (load-immediate (standard-target! target)
- (make-non-pointer-literal 0 (object-type constant))
- #T))
-
-(define-rule statement
- ;; load the datum part of a Scheme constant
- (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant))))
- (QUALIFIER (non-pointer-object? constant))
- (load-immediate (standard-target! target)
- (make-non-pointer-literal 0 (careful-object-datum constant))
- #T))
-
-(define-rule statement
- ;; load a synthesized constant
- (ASSIGN (REGISTER (? target))
- (CONS-NON-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum))))
- (load-immediate (standard-target! target)
- (make-non-pointer-literal type datum)
- #T))
-\f
-(define-rule statement
- ;; load the address of a variable reference cache
- (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
- (load-pc-relative (standard-target! target)
- 'CONSTANT
- (free-reference-label name)
- true))
-
-(define-rule statement
- ;; load the address of an assignment cache
- (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name)))
- (load-pc-relative (standard-target! target)
- 'CONSTANT
- (free-assignment-label name)
- true))
-
-(define-rule statement
- ;; load the address of a procedure's entry point
- (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label)))
- (load-pc-relative-address (standard-target! target) 'CODE label))
-
-(define-rule statement
- ;; load the address of a continuation
- (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label)))
- (load-pc-relative-address (standard-target! target) 'CODE label))
-
-(define-rule statement
- ;; load a procedure object
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (ENTRY:PROCEDURE (? label))))
- (load-entry target type label))
-
-(define-rule statement
- ;; load a return address object
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (ENTRY:CONTINUATION (? label))))
- (load-entry target type label))
-
-(define (load-entry target type label)
- (let ((temporary (standard-temporary!))
- (target (standard-target! target)))
- ;; Loading the address into a temporary makes it more useful,
- ;; because it can be reused later.
- (LAP ,@(load-pc-relative-address temporary 'CODE label)
- (ADDI ,target ,temporary 0)
- ,@(deposit-type type target))))
-\f
-;;;; Transfers from memory
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
- (standard-unary-conversion address target
- (lambda (address target)
- (LAP (LD ,target (OFFSET ,(* 4 offset) ,address))
- (NOP)))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 17) 1))
- (LAP (LD ,(standard-target! target) (OFFSET 0 ,regnum:stack-pointer))
- (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4)))
-
-;;;; Transfers to memory
-
-(define-rule statement
- ;; store an object in memory
- (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
- (? source register-expression))
- (QUALIFIER (word-register? source))
- (LAP (ST ,(standard-source! source)
- (OFFSET ,(* 4 offset) ,(standard-source! address)))))
-
-(define-rule statement
- ;; Push an object register on the heap
- (ASSIGN (POST-INCREMENT (REGISTER 19) 1)
- (? source register-expression))
- (QUALIFIER (word-register? source))
- (LAP (ST ,(standard-source! source) (OFFSET 0 ,regnum:free))
- (ADDI ,regnum:free ,regnum:free 4)))
-
-(define-rule statement
- ;; Push an object register on the stack
- (ASSIGN (PRE-INCREMENT (REGISTER 17) -1)
- (? source register-expression))
- (QUALIFIER (word-register? source))
- (LAP (ADDI ,regnum:stack-pointer ,regnum:stack-pointer -4)
- (ST ,(standard-source! source)
- (OFFSET 0 ,regnum:stack-pointer))))
-
-;; Cheaper, common patterns.
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
- (MACHINE-CONSTANT 0))
- (LAP (ST 0 (OFFSET ,(* 4 offset) ,(standard-source! address)))))
-
-(define-rule statement
- ; Push NIL (or whatever is represented by a machine 0) on heap
- (ASSIGN (POST-INCREMENT (REGISTER 19) 1) (MACHINE-CONSTANT 0))
- (LAP (ST 0 (OFFSET 0 ,regnum:free))
- (ADDI ,regnum:free ,regnum:free 4)))
-
-(define-rule statement
- ; Ditto, but on stack
- (ASSIGN (PRE-INCREMENT (REGISTER 17) -1) (MACHINE-CONSTANT 0))
- (LAP (ADDI ,regnum:stack-pointer ,regnum:stack-pointer -4)
- (ST 0 (OFFSET 0 ,regnum:stack-pointer))))
-\f
-;;;; CHAR->ASCII/BYTE-OFFSET
-
-(define-rule statement
- ;; load char object from memory and convert to ASCII byte
- (ASSIGN (REGISTER (? target))
- (CHAR->ASCII (OFFSET (REGISTER (? address)) (? offset))))
- (standard-unary-conversion address target
- (lambda (address target)
- (LAP (LDUB ,target
- (OFFSET ,(let ((offset (* 4 offset)))
- (if (eq? endianness 'LITTLE)
- offset
- (+ offset 3)))
- ,address))
- (NOP)))))
-
-(define-rule statement
- ;; load ASCII byte from memory
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET (REGISTER (? address)) (? offset)))
- (standard-unary-conversion address target
- (lambda (address target)
- (LAP (LDUB ,target (OFFSET ,offset ,address))
- (NOP)))))
-
-(define-rule statement
- ;; convert char object to ASCII byte
- ;; Missing optimization: If source is home and this is the last
- ;; reference (it is dead afterwards), an LB could be done instead of
- ;; an LW followed by an ANDI. This is unlikely since the value will
- ;; be home only if we've spilled it, which happens rarely.
- (ASSIGN (REGISTER (? target))
- (CHAR->ASCII (REGISTER (? source))))
- (standard-unary-conversion source target
- (lambda (source target)
- (LAP (ANDI ,target ,source #xFF)))))
-
-(define-rule statement
- ;; store null byte in memory
- (ASSIGN (BYTE-OFFSET (REGISTER (? source)) (? offset))
- (CHAR->ASCII (CONSTANT #\NUL)))
- (LAP (STB 0 (OFFSET ,offset ,(standard-source! source)))))
-
-(define-rule statement
- ;; store ASCII byte in memory
- (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
- (REGISTER (? source)))
- (LAP (STB ,(standard-source! source)
- (OFFSET ,offset ,(standard-source! address)))))
-
-(define-rule statement
- ;; convert char object to ASCII byte and store it in memory
- ;; register + byte offset <- contents of register (clear top bits)
- (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
- (CHAR->ASCII (REGISTER (? source))))
- (LAP (STB ,(standard-source! source)
- (OFFSET ,offset ,(standard-source! address)))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Predicates
-
-(declare (usual-integrations))
-\f
-(define-rule predicate
- ;; test for two registers EQ?
- (EQ-TEST (REGISTER (? source1)) (REGISTER (? source2)))
- (compare '= (standard-source! source1) (standard-source! source2)))
-
-(define-rule predicate
- ;; test for register EQ? to constant
- (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register)))
- (eq-test/constant*register constant register))
-
-(define-rule predicate
- ;; test for register EQ? to constant
- (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant)))
- (eq-test/constant*register constant register))
-
-(define (eq-test/constant*register constant source)
- (let ((source (standard-source! source)))
- (if (non-pointer-object? constant)
- (compare-immediate '= (non-pointer->literal constant) source)
- (let ((temp (standard-temporary!)))
- (LAP ,@(load-pc-relative temp
- 'CONSTANT (constant->label constant)
- #T)
- ,@(compare '= temp source))))))
-
-(define-rule predicate
- ;; test for register EQ? to synthesized constant
- (EQ-TEST (CONS-NON-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum)))
- (REGISTER (? register)))
- (eq-test/synthesized-constant*register type datum register))
-
-(define-rule predicate
- ;; test for register EQ? to synthesized constant
- (EQ-TEST (REGISTER (? register))
- (CONS-NON-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum))))
- (eq-test/synthesized-constant*register type datum register))
-
-(define (eq-test/synthesized-constant*register type datum source)
- (compare-immediate '=
- (make-non-pointer-literal type datum)
- (standard-source! source)))
-
-(define-rule predicate
- ;; Branch if virtual register contains the specified type number
- (TYPE-TEST (REGISTER (? register)) (? type))
- (compare-immediate '= type (standard-source! register)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Invocations and Entries
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Invocations
-
-(define-rule statement
- (POP-RETURN)
- (pop-return))
-
-(define (pop-return)
- (let ((temp (standard-temporary!)))
- (LAP ,@(clear-map!)
- (LD ,temp (OFFSET 0 ,regnum:stack-pointer))
- (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4)
- ,@(object->address temp temp)
- (JR ,temp)
- (NOP)))) ; DELAY SLOT
-
-(define-rule statement
- (INVOCATION:APPLY (? frame-size) (? continuation))
- continuation ;ignore
- (LAP ,@(clear-map!)
- ,@(load-immediate regnum:second-arg frame-size #F)
- (LD ,regnum:first-arg (OFFSET 0 ,regnum:stack-pointer))
- (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4)
- ,@(invoke-interface code:compiler-apply)))
-
-(define-rule statement
- (INVOCATION:JUMP (? frame-size) (? continuation) (? label))
- frame-size continuation ;ignore
- (LAP ,@(clear-map!)
- (BA (@PCR ,label))
- (NOP))) ; DELAY SLOT
-
-(define-rule statement
- (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation))
- frame-size continuation ;ignore
- ;; It expects the procedure at the top of the stack
- (pop-return))
-
-(define-rule statement
- (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
- continuation ;ignore
- (let* ((clear-second-arg (clear-registers! regnum:first-arg))
- (load-second-arg
- (load-pc-relative-address regnum:first-arg 'CODE label)))
- (LAP ,@clear-second-arg
- ,@load-second-arg
- ,@(clear-map!)
- ,@(load-immediate regnum:second-arg number-pushed #F)
- ,@(invoke-interface code:compiler-lexpr-apply))))
-
-(define-rule statement
- (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation))
- continuation ;ignore
- ;; Destination address is at TOS; pop it into second-arg
- (LAP ,@(clear-map!)
- (LD ,regnum:first-arg (OFFSET 0 ,regnum:stack-pointer))
- (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4)
- ,@(object->address regnum:first-arg regnum:first-arg)
- ,@(load-immediate regnum:second-arg number-pushed #F)
- ,@(invoke-interface code:compiler-lexpr-apply)))
-\f
-(define-rule statement
- (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
- continuation ;ignore
- (LAP ,@(clear-map!)
- (BA (@PCR ,(free-uuo-link-label name frame-size)))
- (NOP)))
-
-(define-rule statement
- (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
- continuation ;ignore
- (LAP ,@(clear-map!)
- (BA (@PCR ,(global-uuo-link-label name frame-size)))
- (NOP))) ; DELAY SLOT
-
-(define-rule statement
- (INVOCATION:CACHE-REFERENCE (? frame-size)
- (? continuation)
- (? extension register-expression))
- continuation ;ignore
- (let* ((clear-third-arg (clear-registers! regnum:second-arg))
- (load-third-arg
- (load-pc-relative-address regnum:second-arg 'CODE *block-label*)))
- (LAP ,@clear-third-arg
- ,@load-third-arg
- ,@(load-interface-args! extension false false false)
- ,@(load-immediate regnum:third-arg frame-size #F)
- ,@(invoke-interface code:compiler-cache-reference-apply))))
-
-(define-rule statement
- (INVOCATION:LOOKUP (? frame-size)
- (? continuation)
- (? environment register-expression)
- (? name))
- continuation ;ignore
- (LAP ,@(load-interface-args! environment false false false)
- ,@(load-constant regnum:second-arg name #F #F)
- ,@(load-immediate regnum:third-arg frame-size #F)
- ,@(invoke-interface code:compiler-lookup-apply)))
-\f
-(define-rule statement
- (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
- continuation ;ignore
- (if (eq? primitive compiled-error-procedure)
- (LAP ,@(clear-map!)
- ,@(load-immediate regnum:first-arg frame-size #F)
- ,@(invoke-interface code:compiler-error))
- (let* ((clear-second-arg (clear-registers! regnum:second-arg))
- (load-second-arg
- (load-pc-relative regnum:first-arg
- 'CONSTANT
- (constant->label primitive)
- false)))
- (LAP ,@clear-second-arg
- ,@load-second-arg
- ,@(clear-map!)
- ,@(let ((arity (primitive-procedure-arity primitive)))
- (cond ((not (negative? arity))
- (invoke-interface code:compiler-primitive-apply))
- ((= arity -1)
- (LAP ,@(load-immediate regnum:assembler-temp
- (-1+ frame-size)
- #F)
- (ST ,regnum:assembler-temp
- ,reg:lexpr-primitive-arity)
- ,@(invoke-interface
- code:compiler-primitive-lexpr-apply)))
- (else
- ;; Unknown primitive arity. Go through apply.
- (LAP ,@(load-immediate regnum:second-arg frame-size #F)
- ,@(invoke-interface code:compiler-apply)))))))))
-
-(let-syntax
- ((define-special-primitive-invocation
- (sc-macro-transformer
- (lambda (form environment)
- `(DEFINE-RULE STATEMENT
- (INVOCATION:SPECIAL-PRIMITIVE
- (? FRAME-SIZE)
- (? CONTINUATION)
- ,(make-primitive-procedure (cadr form) #t))
- FRAME-SIZE CONTINUATION
- ,(list 'LAP
- (list 'UNQUOTE-SPLICING '(CLEAR-MAP!))
- (list 'UNQUOTE-SPLICING
- `(INVOKE-INTERFACE
- ,(close-syntax (symbol-append 'CODE:COMPILER-
- (cadr form))
- environment)))))))))
- (define-special-primitive-invocation &+)
- (define-special-primitive-invocation &-)
- (define-special-primitive-invocation &*)
- (define-special-primitive-invocation &/)
- (define-special-primitive-invocation &=)
- (define-special-primitive-invocation &<)
- (define-special-primitive-invocation &>)
- (define-special-primitive-invocation 1+)
- (define-special-primitive-invocation -1+)
- (define-special-primitive-invocation zero?)
- (define-special-primitive-invocation positive?)
- (define-special-primitive-invocation negative?))
-\f
-;;;; Invocation Prefixes
-
-;;; (INVOCATION-PREFIX:MOVE-FRAME-UP frame-size address)
-
-;;; Move the topmost <frame-size> words of the stack downward so that
-;;; the bottommost of these words is at location <address>, and set
-;;; the stack pointer to the topmost of the moved words. That is,
-;;; discard the words between <address> and SP+<frame-size>, close the
-;;; resulting gap by shifting down the words from above the gap, and
-;;; adjust SP to point to the new topmost word.
-
-(define-rule statement
- ;; Move up 0 words back to top of stack : a No-Op
- (INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER 3))
- (LAP))
-
-(define-rule statement
- ;; Move <frame-size> words back to dynamic link marker
- (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER 11))
- (generate/move-frame-up frame-size
- (lambda (reg) (LAP (ADD ,reg 0 ,regnum:dynamic-link)))))
-
-(define-rule statement
- ;; Move <frame-size> words back to dynamic link marker
- (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER (? dest)))
- (generate/move-frame-up frame-size
- (lambda (reg) (LAP (ADD ,reg 0 ,dest)))))
-
-(define-rule statement
- ;; Move <frame-size> words back to SP+offset
- (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size)
- (OFFSET-ADDRESS (REGISTER 3) (? offset)))
- (let ((how-far (* 4 (- offset frame-size))))
- (cond ((zero? how-far)
- (LAP))
- ((negative? how-far)
- (error "invocation-prefix:move-frame-up: bad specs"
- frame-size offset))
- ((zero? frame-size)
- (add-immediate how-far regnum:stack-pointer regnum:stack-pointer))
- ((= frame-size 1)
- (let ((temp (standard-temporary!)))
- (LAP (LD ,temp (OFFSET 0 ,regnum:stack-pointer))
- (ADDI ,regnum:stack-pointer ,regnum:stack-pointer ,how-far)
- (STW ,temp (OFFSET 0 ,regnum:stack-pointer)))))
- ((= frame-size 2)
- (let ((temp1 (standard-temporary!))
- (temp2 (standard-temporary!)))
- (LAP (LD ,temp1 (OFFSET 0 ,regnum:stack-pointer))
- (LD ,temp2 (OFFSET 4 ,regnum:stack-pointer))
- (ADDI ,regnum:stack-pointer ,regnum:stack-pointer ,how-far)
- (ST ,temp1 (OFFSET 0 ,regnum:stack-pointer))
- (ST ,temp2 (OFFSET 4 ,regnum:stack-pointer)))))
- (else
- (generate/move-frame-up frame-size
- (lambda (reg)
- (add-immediate (* 4 offset) regnum:stack-pointer reg)))))))
-
-(define-rule statement
- ;; Move <frame-size> words back to base virtual register + offset
- (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size)
- (OFFSET-ADDRESS (REGISTER (? base))
- (? offset)))
- (QUALIFIER (not (= base 3)))
- (generate/move-frame-up frame-size
- (lambda (reg)
- (add-immediate (* 4 offset) (standard-source! base) reg))))
-
-(define (generate/move-frame-up frame-size destination-generator)
- (let ((temp (standard-temporary!)))
- (LAP ,@(destination-generator temp)
- ,@(generate/move-frame-up* frame-size temp))))
-\f
-;;; DYNAMIC-LINK instructions have a <frame-size>, <new frame end>,
-;;; and <current dynamic link> as arguments. They pop the stack by
-;;; removing the lesser of the amount needed to move the stack pointer
-;;; back to the <new frame end> or <current dynamic link>. The last
-;;; <frame-size> words on the stack (the stack frame for the procedure
-;;; about to be called) are then put back onto the newly adjusted
-;;; stack.
-
-(define-rule statement
- (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
- (REGISTER (? source))
- (REGISTER 11))
- (if (and (zero? frame-size)
- (= source regnum:stack-pointer))
- (LAP)
- (let ((env-reg (standard-move-to-temporary! source))
- (label (generate-label)))
- (LAP (SLTU ,regnum:assembler-temp ,env-reg ,regnum:dynamic-link)
- (BNE 0 ,regnum:assembler-temp (@PCR ,label))
- (NOP)
- (ADD ,env-reg 0 ,regnum:dynamic-link)
- (LABEL ,label)
- ,@(generate/move-frame-up* frame-size env-reg)))))
-
-(define (generate/move-frame-up* frame-size destination)
- ;; Destination is guaranteed to be a machine register number; that
- ;; register has the destination base address for the frame. The stack
- ;; pointer is reset to the top end of the copied area.
- (LAP ,@(case frame-size
- ((0)
- (LAP))
- ((1)
- (let ((temp (standard-temporary!)))
- (LAP (LD ,temp (OFFSET 0 ,regnum:stack-pointer))
- (ADDI ,destination ,destination -4)
- (ST ,temp (OFFSET 0 ,destination)))))
- (else
- (let ((from (standard-temporary!))
- (temp1 (standard-temporary!))
- (temp2 (standard-temporary!)))
- (LAP ,@(add-immediate (* 4 frame-size) regnum:stack-pointer from)
- ,@(if (<= frame-size 3)
- ;; This code can handle any number > 1
- ;; (handled above), but we restrict it to 3
- ;; for space reasons.
- (let loop ((n frame-size))
- (case n
- ((0)
- (LAP))
- ((3)
- (let ((temp3 (standard-temporary!)))
- (LAP (LD ,temp1 (OFFSET -4 ,from))
- (LD ,temp2 (OFFSET -8 ,from))
- (LD ,temp3 (OFFSET -12 ,from))
- (ADDI ,from ,from -12)
- (ST ,temp1 (OFFSET -4 ,destination))
- (ST ,temp2 (OFFSET -8 ,destination))
- (ST ,temp3 (OFFSET -12 ,destination))
- (ADDI ,destination ,destination -12))))
- (else
- (LAP (LD ,temp1 (OFFSET -4 ,from))
- (LD ,temp2 (OFFSET -8 ,from))
- (ADDI ,from ,from -8)
- (ST ,temp1 (OFFSET -4 ,destination))
- (ST ,temp2 (OFFSET -8 ,destination))
- (ADDI ,destination ,destination -8)
- ,@(loop (- n 2))))))
- (let ((label (generate-label)))
- (LAP ,@(load-immediate temp2 frame-size #F)
- (LABEL ,label)
- (LD ,temp1 (OFFSET -4 ,from))
- (ADDI ,from ,from -4)
- (ADDI ,temp2 ,temp2 -1)
- (ADDI ,destination ,destination -4)
- (BNE ,temp2 0 (@PCR ,label))
- (ST ,temp1 (OFFSET 0 ,destination)))))))))
- (ADD ,regnum:stack-pointer 0 ,destination)))
-\f
-;;;; External Labels
-
-(define (make-external-label code label)
- (set! *external-labels* (cons label *external-labels*))
- (LAP (EXTERNAL-LABEL ,code (@PCR ,label))
- (LABEL ,label)))
-
-;;; Entry point types
-
-(define-integrable (make-code-word min max)
- (+ (* #x100 min) max))
-
-(define (make-procedure-code-word min max)
- ;; The "min" byte must be less than #x80; the "max" byte may not
- ;; equal #x80 but can take on any other value.
- (if (or (negative? min) (>= min #x80))
- (error "MAKE-PROCEDURE-CODE-WORD: minimum out of range" min))
- (if (>= (abs max) #x80)
- (error "MAKE-PROCEDURE-CODE-WORD: maximum out of range" max))
- (make-code-word min (if (negative? max) (+ #x100 max) max)))
-
-(define expression-code-word
- (make-code-word #xff #xff))
-
-(define internal-entry-code-word
- (make-code-word #xff #xfe))
-
-(define internal-continuation-code-word
- (make-code-word #xff #xfc))
-
-(define (continuation-code-word label)
- (frame-size->code-word
- (if label
- (rtl-continuation/next-continuation-offset (label->object label))
- 0)
- internal-continuation-code-word))
-
-(define (internal-procedure-code-word rtl-proc)
- ;; represented as return addresses so the debugger will
- ;; not barf when it sees them (on the stack if interrupted).
- (frame-size->code-word
- (rtl-procedure/next-continuation-offset rtl-proc)
- internal-entry-code-word))
-
-(define (frame-size->code-word offset default)
- (cond ((not offset)
- default)
- ((< offset #x2000)
- ;; This uses up through (#xff #xdf).
- (let ((qr (integer-divide offset #x80)))
- (make-code-word (+ #x80 (integer-divide-remainder qr))
- (+ #x80 (integer-divide-quotient qr)))))
- (else
- (error "Unable to encode continuation offset" offset))))
-\f
-;;;; Procedure headers
-
-;;; The following calls MUST appear as the first thing at the entry
-;;; point of a procedure. They assume that the register map is clear
-;;; and that no register contains anything of value.
-;;;
-;;; The only reason that this is true is that no register is live
-;;; across calls. If that were not true, then we would have to save
-;;; any such registers on the stack so that they would be GC'ed
-;;; appropriately.
-;;;
-;;; The only exception is the dynamic link register, handled
-;;; specially. Procedures that require a dynamic link use a different
-;;; interrupt handler that saves and restores the dynamic link
-;;; register.
-
-(define (simple-procedure-header code-word label code)
- (let ((gc-label (generate-label)))
- (LAP (LABEL ,gc-label)
- ,@(link-to-interface code)
- ,@(make-external-label code-word label)
- ,@(interrupt-check gc-label))))
-
-(define (dlink-procedure-header code-word label)
- (let ((gc-label (generate-label)))
- (LAP (LABEL ,gc-label)
- (ADD ,regnum:third-arg 0 ,regnum:dynamic-link)
- ,@(link-to-interface code:compiler-interrupt-dlink)
- ,@(make-external-label code-word label)
- ,@(interrupt-check gc-label))))
-
-(define (interrupt-check gc-label)
- (LAP (SUBCC ,regnum:assembler-temp ,regnum:memtop ,regnum:free)
- (BGE (@PCR ,gc-label))
- (LD ,regnum:memtop ,reg:memtop)
- ))
-
-(define-rule statement
- (CONTINUATION-ENTRY (? internal-label))
- (make-external-label (continuation-code-word internal-label)
- internal-label))
-
-(define-rule statement
- (CONTINUATION-HEADER (? internal-label))
- (simple-procedure-header (continuation-code-word internal-label)
- internal-label
- code:compiler-interrupt-continuation))
-
-(define-rule statement
- (IC-PROCEDURE-HEADER (? internal-label))
- (let ((procedure (label->object internal-label)))
- (let ((external-label (rtl-procedure/external-label procedure)))
- (LAP (ENTRY-POINT ,external-label)
- (EQUATE ,external-label ,internal-label)
- ,@(simple-procedure-header expression-code-word
- internal-label
- code:compiler-interrupt-ic-procedure)))))
-
-(define-rule statement
- (OPEN-PROCEDURE-HEADER (? internal-label))
- (let ((rtl-proc (label->object internal-label)))
- (LAP (EQUATE ,(rtl-procedure/external-label rtl-proc) ,internal-label)
- ,@((if (rtl-procedure/dynamic-link? rtl-proc)
- dlink-procedure-header
- (lambda (code-word label)
- (simple-procedure-header code-word label
- code:compiler-interrupt-procedure)))
- (internal-procedure-code-word rtl-proc)
- internal-label))))
-
-(define-rule statement
- (PROCEDURE-HEADER (? internal-label) (? min) (? max))
- (LAP (EQUATE ,(rtl-procedure/external-label (label->object internal-label))
- ,internal-label)
- ,@(simple-procedure-header (make-procedure-code-word min max)
- internal-label
- code:compiler-interrupt-procedure)))
-\f
-;;;; Closures.
-
-;; Magic for compiled entries.
-
-(define-rule statement
- (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
- entry ; ignored -- non-RISCs only
- (if (zero? nentries)
- (error "Closure header for closure with no entries!"
- internal-label))
- (let ((rtl-proc (label->object internal-label)))
- (let ((gc-label (generate-label))
- (external-label (rtl-procedure/external-label rtl-proc)))
- (LAP (LABEL ,gc-label)
- ,@(invoke-interface code:compiler-interrupt-closure)
- ,@(make-external-label
- (internal-procedure-code-word rtl-proc)
- external-label)
- (ADDI ,regnum:assembler-temp ,regnum:assembler-temp -12)
- ;; Code below here corresponds to code and count in cmpint2.h
- ,@(fluid-let ((*register-map* *register-map*))
- (let ((temporary (standard-temporary!)))
- ;; Don't cache type constant here, because it won't be
- ;; in the register if the closure is entered from the
- ;; internal label.
- (LAP
- (ADDI ,temporary ,regnum:assembler-temp 0)
- ,@(put-type (ucode-type compiled-entry) temporary)
- (ADDI ,regnum:stack-pointer ,regnum:stack-pointer -4)
- (ST ,temporary (OFFSET 0 ,regnum:stack-pointer))
- (NOP))))
- (LABEL ,internal-label)
- ,@(interrupt-check gc-label)))))
-
-(define (build-gc-offset-word offset code-word)
- (let ((encoded-offset (quotient offset 2)))
- (if (eq? endianness 'LITTLE)
- (+ (* encoded-offset #x10000) code-word)
- (+ (* code-word #x10000) encoded-offset))))
-
-(define (closure-bump-size nentries nvars)
- (* (* 4 closure-entry-size)
- (1+ (quotient (+ (+ nvars (-1+ (* closure-entry-size nentries)))
- (-1+ closure-entry-size))
- closure-entry-size))))
-
-(define (closure-test-size nentries nvars)
- (* 4
- (+ nvars
- (-1+ (* nentries closure-entry-size)))))
-
-(define (cons-closure target label min max nvars)
-
- ;; Invoke an out-of-line handler to set up the closure's entry point.
- ;; Arguments:
- ;; - C_arg1: "Return address"
- ;; - C_arg2: Delta from header data to real closure code
- ;; - C_arg3: Closure size in bytes
- ;; After jumping to the out of line handler, the return address should
- ;; point to the header data.
- ;; Returns closure in regnum:second-arg
-
- (need-register! regnum:first-arg)
- (need-register! regnum:second-arg)
- (need-register! regnum:third-arg)
- (need-register! regnum:fourth-arg)
- (let* ((label-arg (generate-label))
- (dest (standard-target! target)))
- (LAP (ADDI ,regnum:assembler-temp ,regnum:scheme-to-interface -108)
- (ADDI ,regnum:second-arg 0 (- ,(rtl-procedure/external-label (label->object label))
- ,label-arg))
- (ADDI ,regnum:third-arg 0 ,(+ 20 (* nvars 4)))
- (JMPL ,regnum:first-arg ,regnum:assembler-temp 0)
- (ADDI ,regnum:first-arg ,regnum:first-arg 8)
- (LABEL ,label-arg)
- (LONG U ,(make-non-pointer-literal (ucode-type manifest-closure)
- (+ closure-entry-size nvars)))
- (LONG U ,(build-gc-offset-word 8 (make-procedure-code-word min max)))
- (ADDI ,dest ,regnum:second-arg 0)
- ))
- )
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
- (? min) (? max) (? nvars)))
- (cons-closure target procedure-label min max nvars))
-\f
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-MULTICLOSURE (? nentries) (? nvars) (? entries)))
- ;; entries is a vector of all the entry points
- (case nentries
- ((0)
- (let ((dest (standard-target! target))
- (temp (standard-temporary!)))
- (LAP (ADD ,dest 0 ,regnum:free)
- ,@(load-immediate
- temp
- (make-non-pointer-literal (ucode-type manifest-vector) nvars)
- #T)
- (ST ,temp (OFFSET 0 ,regnum:free))
- (ADDI ,regnum:free ,regnum:free ,(* 4 (+ nvars 1))))))
- ((1)
- (let ((entry (vector-ref entries 0)))
- (cons-closure target (car entry) (cadr entry) (caddr entry) nvars)))
- (else
- (cons-multiclosure target nentries nvars (vector->list entries)))))
-
-(define (cons-multiclosure target nentries nvars entries)
- ;; Invoke an out-of-line handler to set up the closure's entry points.
- ;; Arguments:
- ;; - C_arg1: Linkage address
- ;; - C_arg2: Number of entries
- ;; - C_arg3: Number of bytes taken up by closures
-
- ;; C_arg1 points to a manifest closure header word, followed by
- ;; nentries two-word structures, followed by the actual
- ;; instructions to return to.
- ;; The first word of each descriptor is the format+gc-offset word of
- ;; the corresponding entry point of the generated closure.
- ;; The second word is the PC-relative JAL instruction.
- ;; It is transformed into an absolute instruction by adding the shifted
- ;; "return address".
- ;; Returns closure in regnum:second-arg.
- (rtl-target:=machine-register! target regnum:second-arg)
- (require-register! regnum:first-arg)
- (require-register! regnum:second-arg)
- (require-register! regnum:third-arg)
- (require-register! regnum:fourth-arg)
- (let ((label-arg (generate-label))
- (dest (standard-target! target)))
- (LAP (ADDI ,regnum:assembler-temp ,regnum:scheme-to-interface -256)
- (ADDI ,regnum:second-arg 0 ,nentries)
- (ADDI ,regnum:third-arg ,regnum:free 0)
- (JMPL ,regnum:first-arg ,regnum:assembler-temp 0)
- (ADDI ,regnum:first-arg ,regnum:first-arg 8)
- (LABEL ,label-arg)
- (LONG U ,(make-non-pointer-literal (ucode-type manifest-closure)
- (+ 1
- (* nentries closure-entry-size)
- nvars)))
- ,@(let expand ((offset 12) (entries entries))
- (if (null? entries)
- (LAP)
- (let ((entry (car entries)))
- (LAP
- (LONG U ,(build-gc-offset-word
- offset
- (make-procedure-code-word (cadr entry)
- (caddr entry))))
- (LONG U (- ,(rtl-procedure/external-label (label->object (car entry)))
- ,label-arg))
- ,@(expand (+ offset (* 4 closure-entry-size))
- (cdr entries))))))
- (ADDI ,dest ,regnum:free 12)
- (ADDI ,regnum:free ,regnum:free ,(* (+ (* nentries closure-entry-size) 2 nvars) 4))
- )))
-\f
-;;;; Entry Header
-;;; This is invoked by the top level of the LAP generator.
-
-(define (generate/quotation-header environment-label free-ref-label n-sections)
- ;; Calls the linker
- ;; On SPARC, regnum:first-arg is used as a temporary here since
- ;; load-pc-relative-address uses the assembler temporary.
- (in-assembler-environment (empty-register-map)
- (list regnum:first-arg regnum:second-arg
- regnum:third-arg regnum:fourth-arg)
- (lambda ()
- (let* ((i1
- (load-pc-relative-address regnum:second-arg
- 'CONSTANT environment-label))
- (i2 (load-pc-relative-address regnum:second-arg
- 'CODE *block-label*))
- (i3 (load-pc-relative-address regnum:third-arg
- 'CONSTANT free-ref-label)))
- (LAP (LD ,regnum:first-arg ,reg:environment)
- ,@i1
- (ST ,regnum:first-arg (OFFSET 0 ,regnum:second-arg))
- ,@i2
- ,@i3
- ,@(load-immediate regnum:fourth-arg n-sections #F)
- ,@(link-to-interface code:compiler-link)
- ,@(make-external-label (continuation-code-word false)
- (generate-label)))))))
-
-(define (generate/remote-link code-block-label
- environment-offset
- free-ref-offset
- n-sections)
- ;; Link all of the top level procedures within the file
- (in-assembler-environment (empty-register-map)
- (list regnum:first-arg regnum:second-arg
- regnum:third-arg regnum:fourth-arg)
- (lambda ()
- (let ((i1 (load-pc-relative regnum:second-arg 'CODE code-block-label false)))
- (LAP ,@i1
- (LD ,regnum:fourth-arg ,reg:environment)
- ,@(object->address regnum:second-arg regnum:second-arg)
- ,@(add-immediate environment-offset regnum:second-arg regnum:first-arg)
- (ST ,regnum:fourth-arg (OFFSET 0 ,regnum:first-arg))
- ,@(add-immediate free-ref-offset regnum:second-arg regnum:third-arg)
- ,@(load-immediate regnum:fourth-arg n-sections #F)
- ,@(link-to-interface code:compiler-link)
- ,@(make-external-label (continuation-code-word false)
- (generate-label)))))))
-
-(define (in-assembler-environment map needed-registers thunk)
- (fluid-let ((*register-map* map)
- (*prefix-instructions* (LAP))
- (*suffix-instructions* (LAP))
- (*needed-registers* needed-registers))
- (let ((instructions (thunk)))
- (LAP ,@*prefix-instructions*
- ,@instructions
- ,@*suffix-instructions*))))
-\f
-(define (generate/constants-block constants references assignments uuo-links
- global-links static-vars)
- (let ((constant-info
- (declare-constants 0 (transmogrifly uuo-links)
- (declare-constants 1 references
- (declare-constants 2 assignments
- (declare-constants 3 (transmogrifly global-links)
- (declare-constants false
- (map (lambda (pair)
- (cons false (cdr pair)))
- static-vars)
- (declare-constants false constants
- (cons false (LAP))))))))))
- (let ((free-ref-label (car constant-info))
- (constants-code (cdr constant-info))
- (debugging-information-label (allocate-constant-label))
- (environment-label (allocate-constant-label))
- (n-sections
- (+ (if (null? uuo-links) 0 1)
- (if (null? references) 0 1)
- (if (null? assignments) 0 1)
- (if (null? global-links) 0 1))))
- (values
- (LAP ,@constants-code
- ;; Place holder for the debugging info filename
- (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO)
- ;; Place holder for the load time environment if needed
- (SCHEME-OBJECT ,environment-label
- ,(if (null? free-ref-label) 0 'ENVIRONMENT)))
- environment-label
- free-ref-label
- n-sections))))
-
-(define (declare-constants tag constants info)
- (define (inner constants)
- (if (null? constants)
- (cdr info)
- (let ((entry (car constants)))
- (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry))
- ,@(inner (cdr constants))))))
- (if (and tag (not (null? constants)))
- (let ((label (allocate-constant-label)))
- (cons label
- (inner
- `((,(let ((datum (length constants)))
- (if (> datum #xffff)
- (error "datum too large" datum))
- (+ (* tag #x10000) datum))
- . ,label)
- ,@constants))))
- (cons (car info) (inner constants))))
-
-(define (transmogrifly uuos)
- (define (inner name assoc)
- (if (null? assoc)
- (transmogrifly (cdr uuos))
- ; produces ((name . label) (0 . label) ... (frame-size . label) ...)
- ; where the (0 . label) is repeated to fill out the size required
- ; as specified in machin.scm
- `((,name . ,(cdar assoc)) ; uuo-label
- ,@(let loop ((count (max 0 (- execute-cache-size 2))))
- (if (= count 0)
- '()
- (cons `(0 . ,(allocate-constant-label))
- (loop (- count 1)))))
- (,(caar assoc) . ; frame-size
- ,(allocate-constant-label))
- ,@(inner name (cdr assoc)))))
- (if (null? uuos)
- '()
- ;; caar is name, cdar is alist of frame sizes
- (inner (caar uuos) (cdar uuos))))
-#|
-(define (cons-closure target label min max nvars)
- ;; Invoke an out-of-line handler to set up the closure's entry point.
- ;; Arguments:
- ;; - GR31: "Return address"
- ;; GR31 points to a manifest closure header word, followed by a
- ;; two-word closure descriptor, followed by the actual
- ;; instructions to return to.
- ;; The first word of the descriptor is the format+gc-offset word of
- ;; the generated closure.
- ;; The second word is the PC-relative JAL instruction.
- ;; It is transformed into an absolute instruction by adding the shifted
- ;; "return address".
- ;; - GR4: Value to compare to closure free.
- ;; - GR5: Increment for closure free.
- ;; Returns closure in regnum:first-arg (GR4)
- (rtl-target:=machine-register! target regnum:first-arg)
- (require-register! regnum:first-arg)
- (require-register! regnum:second-arg)
- (require-register! regnum:third-arg)
- (require-register! regnum:fourth-arg)
- (let ((label-arg (generate-label)))
- (LAP (ADDI ,regnum:second-arg ,regnum:scheme-to-interface -72)
- (ADDI ,regnum:first-arg ,regnum:closure-free
- ,(closure-test-size 1 nvars))
- (JALR 31 ,regnum:second-arg)
- (ADDI ,regnum:second-arg 0 ,(closure-bump-size 1 nvars))
- (LABEL ,label-arg)
- (LONG U ,(make-non-pointer-literal (ucode-type manifest-closure)
- (+ closure-entry-size nvars)))
- (LONG U ,(build-gc-offset-word 8 (make-procedure-code-word min max)))
- (LONG U
- (+ #x0c000000 ; JAL opcode
- (/ (- ,(rtl-procedure/external-label (label->object label))
- ,label-arg)
- 4))))))
-|#
-
-
-\f
-;;; Local Variables: ***
-;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
-;;; End: ***
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Interpreter Calls
-
-(declare (usual-integrations))
-\f
-;;;; Interpreter Calls
-
-(define-rule statement
- (INTERPRETER-CALL:ACCESS (? environment register-expression) (? name))
- (lookup-call code:compiler-access environment name))
-
-(define-rule statement
- (INTERPRETER-CALL:LOOKUP (? environment register-expression)
- (? name)
- (? safe?))
- (lookup-call (if safe? code:compiler-safe-lookup code:compiler-lookup)
- environment
- name))
-
-(define-rule statement
- (INTERPRETER-CALL:UNASSIGNED? (? environment register-expression) (? name))
- (lookup-call code:compiler-unassigned? environment name))
-
-(define-rule statement
- (INTERPRETER-CALL:UNBOUND? (? environment register-expression) (? name))
- (lookup-call code:compiler-unbound? environment name))
-
-(define (lookup-call code environment name)
- (LAP ,@(load-interface-args! false environment false false)
- ,@(load-constant regnum:third-arg name #F #F)
- ,@(link-to-interface code)))
-
-(define-rule statement
- (INTERPRETER-CALL:DEFINE (? environment register-expression)
- (? name)
- (? value register-expression))
- (assignment-call code:compiler-define environment name value))
-
-(define-rule statement
- (INTERPRETER-CALL:SET! (? environment register-expression)
- (? name)
- (? value register-expression))
- (assignment-call code:compiler-set! environment name value))
-
-(define (assignment-call code environment name value)
- (LAP ,@(load-interface-args! false environment false value)
- ,@(load-constant regnum:third-arg name #F #F)
- ,@(link-to-interface code)))
-
-(define-rule statement
- (INTERPRETER-CALL:CACHE-REFERENCE (REGISTER (? extension)) (? safe?))
- (LAP ,@(load-interface-args! false extension false false)
- ,@(link-to-interface
- (if safe?
- code:compiler-safe-reference-trap
- code:compiler-reference-trap))))
-
-(define-rule statement
- (INTERPRETER-CALL:CACHE-ASSIGNMENT (REGISTER (? extension))
- (? value register-expression))
- (LAP ,@(load-interface-args! false extension value false)
- ,@(link-to-interface code:compiler-assignment-trap)))
-
-(define-rule statement
- (INTERPRETER-CALL:CACHE-UNASSIGNED? (REGISTER (? extension)))
- (LAP ,@(load-interface-args! false extension false false)
- ,@(link-to-interface code:compiler-unassigned?-trap)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Fixnum Rules
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Conversions
-
-(define-rule statement
- ;; convert a fixnum object to a "fixnum integer"
- (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source))))
- (standard-unary-conversion source target object->fixnum))
-
-(define-rule statement
- ;; load a fixnum constant as a "fixnum integer"
- (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant))))
- (load-immediate (standard-target! target) (* constant fixnum-1) #T))
-
-(define-rule statement
- ;; convert a memory address to a "fixnum integer"
- (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source))))
- (standard-unary-conversion source target address->fixnum))
-
-(define-rule statement
- ;; convert an object's address to a "fixnum integer"
- (ASSIGN (REGISTER (? target))
- (ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source)))))
- (standard-unary-conversion source target object->fixnum))
-
-(define-rule statement
- ;; convert a "fixnum integer" to a fixnum object
- (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source))))
- (standard-unary-conversion source target fixnum->object))
-
-(define-rule statement
- ;; convert a "fixnum integer" to a memory address
- (ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source))))
- (standard-unary-conversion source target fixnum->address))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (OBJECT->FIXNUM (CONSTANT 4))
- (OBJECT->FIXNUM (REGISTER (? source)))
- #F))
- (standard-unary-conversion source target object->index-fixnum))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (OBJECT->FIXNUM (REGISTER (? source)))
- (OBJECT->FIXNUM (CONSTANT 4))
- #F))
- (standard-unary-conversion source target object->index-fixnum))
-
-;; This is a patch for the time being. Probably only one of these pairs
-;; of rules is needed.
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (OBJECT->FIXNUM (CONSTANT 4))
- (REGISTER (? source))
- #F))
- (standard-unary-conversion source target fixnum->index-fixnum))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (REGISTER (? source))
- (OBJECT->FIXNUM (CONSTANT 4))
- #F))
- (standard-unary-conversion source target fixnum->index-fixnum))
-\f
-;; "Fixnum" in this context means an integer left shifted so that
-;; the sign bit is the leftmost bit of the word, i.e., the datum
-;; has been left shifted by scheme-type-width bits.
-
-(define-integrable (fixnum->index-fixnum src tgt)
- ; Shift left 2 bits
- (LAP (SLL ,tgt ,src 2)))
-
-(define-integrable (object->fixnum src tgt)
- ; Shift left by scheme-type-width
- (LAP (SLL ,tgt ,src ,scheme-type-width)))
-
-(define-integrable (object->index-fixnum src tgt)
- ; Shift left by scheme-type-width+2
- (LAP (SLL ,tgt ,src ,(+ scheme-type-width 2))))
-
-(define-integrable (address->fixnum src tgt)
- ; Strip off type bits, just like object->fixnum
- (LAP (SLL ,tgt ,src ,scheme-type-width)))
-
-(define-integrable (fixnum->object src tgt)
- ; Move right by type code width and put on fixnum type code
- (LAP (SRL ,tgt ,src ,scheme-type-width)
- ,@(deposit-type-datum (ucode-type fixnum) tgt tgt)))
-
-(define (fixnum->address src tgt)
- ; Move right by type code width and put in address bits
- (LAP (SRL ,tgt ,src ,scheme-type-width)
- (OR ,tgt ,tgt ,regnum:quad-bits)))
-
-(define-integrable fixnum-1
- (expt 2 scheme-type-width))
-
-(define-integrable -fixnum-1
- (- fixnum-1))
-
-(define (no-overflow-branches!)
- (set-current-branches!
- (lambda (if-overflow)
- if-overflow
- (LAP))
- (lambda (if-no-overflow)
- (LAP (BA (@PCR ,if-no-overflow))
- (NOP)))))
-
-(define (guarantee-signed-fixnum n)
- (if (not (signed-fixnum? n)) (error "Not a signed fixnum" n))
- n)
-
-(define (signed-fixnum? n)
- (and (exact-integer? n)
- (>= n signed-fixnum/lower-limit)
- (< n signed-fixnum/upper-limit)))
-\f
-;;;; Arithmetic Operations
-
-(define-rule statement
- ;; execute a unary fixnum operation
- (ASSIGN (REGISTER (? target))
- (FIXNUM-1-ARG (? operation)
- (REGISTER (? source))
- (? overflow?)))
- (standard-unary-conversion source target
- (lambda (source target)
- ((fixnum-1-arg/operator operation) target source overflow?))))
-
-(define (fixnum-1-arg/operator operation)
- (lookup-arithmetic-method operation fixnum-methods/1-arg))
-
-(define fixnum-methods/1-arg
- (list 'FIXNUM-METHODS/1-ARG))
-
-(define-arithmetic-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
- (lambda (tgt src overflow?)
- (fixnum-add-constant tgt src 1 overflow?)))
-
-(define-arithmetic-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg
- (lambda (tgt src overflow?)
- (fixnum-add-constant tgt src -1 overflow?)))
-
-(define (fixnum-add-constant tgt src constant overflow?)
- (let ((constant (* fixnum-1 constant)))
- (cond ((not overflow?)
- (add-immediate constant src tgt))
- ((= constant 0)
- (no-overflow-branches!)
- (LAP (ADDIU ,tgt ,src 0)))
- (else
- (let ((bcc (if (> constant 0) 'BLE 'BGE)))
- (let ((prefix
- (if (fits-in-16-bits-signed? constant)
- (lambda (label)
- (LAP (SUBCCI ,regnum:assembler-temp 0 ,src)
- (,bcc ,regnum:assembler-temp (@PCR ,label))
- (ADDIU ,tgt ,src ,constant)))
- (with-values (lambda () (immediate->register constant))
- (lambda (prefix alias)
- (lambda (label)
- (LAP ,@prefix
- (,bcc ,src (@PCR ,label))
- (ADDU ,tgt ,src ,alias))))))))
- (if (> constant 0)
- (set-current-branches!
- (lambda (if-overflow)
- (let ((if-no-overflow (generate-label)))
- (LAP ,@(prefix if-no-overflow)
- (SUBCCI ,regnum:assembler-temp 0 ,tgt)
- (BLT ,tgt (@PCR ,if-overflow))
- (NOP)
- (LABEL ,if-no-overflow))))
- (lambda (if-no-overflow)
- (LAP ,@(prefix if-no-overflow)
- (SUBCCI ,regnum:assembler-temp 0 ,tgt)
- (BGE ,tgt (@PCR ,if-no-overflow))
- (NOP))))
- (set-current-branches!
- (lambda (if-overflow)
- (let ((if-no-overflow (generate-label)))
- (LAP ,@(prefix if-no-overflow)
- (SUBCCI ,regnum:assembler-temp 0 ,tgt)
- (BGE ,tgt (@PCR ,if-overflow))
- (NOP)
- (LABEL ,if-no-overflow))))
- (lambda (if-no-overflow)
- (LAP ,@(prefix if-no-overflow)
- (BLTZ ,tgt (@PCR ,if-no-overflow))
- (NOP)))))))
- (LAP)))))
-\f
-(define-rule statement
- ;; execute a binary fixnum operation
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS (? operation)
- (REGISTER (? source1))
- (REGISTER (? source2))
- (? overflow?)))
- (standard-binary-conversion source1 source2 target
- (lambda (source1 source2 target)
- ((fixnum-2-args/operator operation) target source1 source2 overflow?))))
-
-(define (fixnum-2-args/operator operation)
- (lookup-arithmetic-method operation fixnum-methods/2-args))
-
-(define fixnum-methods/2-args
- (list 'FIXNUM-METHODS/2-ARGS))
-
-(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args
- (lambda (tgt src1 src2 overflow?)
- (if overflow?
- (do-overflow-addition tgt src1 src2)
- (LAP (ADDU ,tgt ,src1 ,src2)))))
-
-;;; Use of REGNUM:ASSEMBLER-TEMP is OK here, but only because its
-;;; value is not used after the branch instruction that tests it.
-;;; The long form of the @PCR branch will test it correctly, but
-;;; clobbers it after testing.
-
-(define (do-overflow-addition tgt src1 src2)
- (cond ((not (= src1 src2))
- (set-current-branches!
- (lambda (if-overflow)
- (let ((if-no-overflow (generate-label)))
- (LAP (XOR ,regnum:assembler-temp ,src1 ,src2)
- (BLTZ ,regnum:assembler-temp (@PCR ,if-no-overflow))
- (ADDU ,tgt ,src1 ,src2)
- (XOR ,regnum:assembler-temp
- ,tgt
- ,(if (= tgt src1) src2 src1))
- (BLTZ ,regnum:assembler-temp (@PCR ,if-overflow))
- (NOP)
- (LABEL ,if-no-overflow))))
- (lambda (if-no-overflow)
- (LAP (XOR ,regnum:assembler-temp ,src1 ,src2)
- (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
- (BLT ,regnum:assembler-temp (@PCR ,if-no-overflow))
- (ADDU ,tgt ,src1 ,src2)
- (XOR ,regnum:assembler-temp
- ,tgt
- ,(if (= tgt src1) src2 src1))
- (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
- (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow))
- (NOP)))))
- ((not (= tgt src1))
- (set-current-branches!
- (lambda (if-overflow)
- (LAP (ADDU ,tgt ,src1 ,src1)
- (XOR ,regnum:assembler-temp ,tgt ,src1)
- (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
- (BLT ,regnum:assembler-temp (@PCR ,if-overflow))
- (NOP)))
- (lambda (if-no-overflow)
- (LAP (ADDU ,tgt ,src1 ,src1)
- (XOR ,regnum:assembler-temp ,tgt ,src1)
- (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
- (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow))
- (NOP)))))
- (else
- (let ((temp (standard-temporary!)))
- (set-current-branches!
- (lambda (if-overflow)
- (LAP (ADDU ,temp ,src1 ,src1)
- (XOR ,regnum:assembler-temp ,temp ,src1)
- (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
- (BLT ,regnum:assembler-temp (@PCR ,if-overflow))
- (ADD ,tgt 0 ,temp)))
- (lambda (if-no-overflow)
- (LAP (ADDU ,temp ,src1 ,src1)
- (XOR ,regnum:assembler-temp ,temp ,src1)
- (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
- (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow))
- (ADD ,tgt 0 ,temp)))))))
- (LAP))
-\f
-(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args
- (lambda (tgt src1 src2 overflow?)
- (if overflow?
- (if (= src1 src2) ;probably won't ever happen.
- (begin
- (no-overflow-branches!)
- (LAP (SUBU ,tgt ,src1 ,src1)))
- (do-overflow-subtraction tgt src1 src2))
- (LAP (SUB ,tgt ,src1 ,src2)))))
-
-(define (do-overflow-subtraction tgt src1 src2)
- (set-current-branches!
- (lambda (if-overflow)
- (let ((if-no-overflow (generate-label)))
- (LAP (XOR ,regnum:assembler-temp ,src1 ,src2)
- (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
- (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow))
- (SUBU ,tgt ,src1 ,src2)
- ,@(if (not (= tgt src1))
- (LAP (XOR ,regnum:assembler-temp ,tgt ,src1)
- (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
- (BLT ,regnum:assembler-temp (@PCR ,if-overflow)))
- (LAP (XOR ,regnum:assembler-temp ,tgt ,src2)
- (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
- (BGE ,regnum:assembler-temp (@PCR ,if-overflow))))
- (NOP)
- (LABEL ,if-no-overflow))))
- (lambda (if-no-overflow)
- (LAP (XOR ,regnum:assembler-temp ,src1 ,src2)
- (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
- (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow))
- (SUBU ,tgt ,src1 ,src2)
- ,@(if (not (= tgt src1))
- (LAP (XOR ,regnum:assembler-temp ,tgt ,src1)
- (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)
- (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow)))
- (LAP (XOR ,regnum:assembler-temp ,tgt ,src2)
- (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0g)
- (BLT ,regnum:assembler-temp (@PCR ,if-no-overflow))))
- (NOP))))
- (LAP))
-
-(define (do-multiply tgt src1 src2 overflow?)
- (if overflow?
- (let ((temp (standard-temporary!)))
- (set-current-branches!
- (lambda (if-overflow)
- (LAP (MFHI ,temp)
- (SRA ,regnum:assembler-temp ,tgt 31)
- (BNE ,temp ,regnum:assembler-temp
- (@PCR ,if-overflow))
- (NOP)))
- (lambda (if-no-overflow)
- (LAP (MFHI ,temp)
- (SRA ,regnum:assembler-temp ,tgt 31)
- (BEQ ,temp ,regnum:assembler-temp
- (@PCR ,if-no-overflow))
- (NOP))))))
- (LAP (SRA ,regnum:assembler-temp ,src1 ,scheme-type-width)
- (MULT ,regnum:assembler-temp ,src2)
- (MFLO ,tgt)))
-
-(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args do-multiply)
-\f
-(define-rule statement
- ;; execute binary fixnum operation with constant second arg
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS (? operation)
- (REGISTER (? source))
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (? overflow?)))
- (standard-unary-conversion source target
- (lambda (source target)
- ((fixnum-2-args/operator/register*constant operation)
- target source constant overflow?))))
-
-(define-rule statement
- ;; execute binary fixnum operation with constant first arg
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS (? operation)
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (REGISTER (? source))
- (? overflow?)))
- (standard-unary-conversion source target
- (lambda (source target)
- (if (fixnum-2-args/commutative? operation)
- ((fixnum-2-args/operator/register*constant operation)
- target source constant overflow?)
- ((fixnum-2-args/operator/constant*register operation)
- target constant source overflow?)))))
-
-(define (fixnum-2-args/commutative? operator)
- (memq operator '(PLUS-FIXNUM MULTIPLY-FIXNUM)))
-
-(define (fixnum-2-args/operator/register*constant operation)
- (lookup-arithmetic-method operation fixnum-methods/2-args/register*constant))
-
-(define fixnum-methods/2-args/register*constant
- (list 'FIXNUM-METHODS/2-ARGS/REGISTER*CONSTANT))
-
-(define (fixnum-2-args/operator/constant*register operation)
- (lookup-arithmetic-method operation
- fixnum-methods/2-args/constant*register))
-
-(define fixnum-methods/2-args/constant*register
- (list 'FIXNUM-METHODS/2-ARGS/CONSTANT*REGISTER))
-\f
-(define-arithmetic-method 'PLUS-FIXNUM
- fixnum-methods/2-args/register*constant
- (lambda (tgt src constant overflow?)
- (guarantee-signed-fixnum constant)
- (fixnum-add-constant tgt src constant overflow?)))
-
-(define-arithmetic-method 'MINUS-FIXNUM
- fixnum-methods/2-args/register*constant
- (lambda (tgt src constant overflow?)
- (guarantee-signed-fixnum constant)
- (fixnum-add-constant tgt src (- constant) overflow?)))
-
-(define-arithmetic-method 'MULTIPLY-FIXNUM
- fixnum-methods/2-args/register*constant
- (lambda (tgt src constant overflow?)
- (cond ((zero? constant)
- (if overflow? (no-overflow-branches!))
- (LAP (ADDI ,tgt 0 0)))
- ((= constant 1)
- (if overflow? (no-overflow-branches!))
- (LAP (ADD ,tgt 0 ,src)))
- ((let loop ((n constant))
- (and (> n 0)
- (if (= n 1)
- 0
- (and (even? n)
- (let ((m (loop (quotient n 2))))
- (and m
- (+ m 1)))))))
- =>
- (lambda (power-of-two)
- (if overflow?
- (do-left-shift-overflow tgt src power-of-two)
- (LAP (SLL ,tgt ,src ,power-of-two)))))
- (else
- (with-values (lambda () (immediate->register (* constant fixnum-1)))
- (lambda (prefix alias)
- (LAP ,@prefix
- ,@(do-multiply tgt src alias overflow?))))))))
-
-(define (do-left-shift-overflow tgt src power-of-two)
- (if (= tgt src)
- (let ((temp (standard-temporary!)))
- (set-current-branches!
- (lambda (if-overflow)
- (LAP (SLL ,temp ,src ,power-of-two)
- (SRA ,regnum:assembler-temp ,temp ,power-of-two)
- (BNE ,regnum:assembler-temp ,src (@PCR ,if-overflow))
- (ADD ,tgt 0 ,temp)))
- (lambda (if-no-overflow)
- (LAP (SLL ,temp ,src ,power-of-two)
- (SRA ,regnum:assembler-temp ,temp ,power-of-two)
- (BEQ ,regnum:assembler-temp ,src (@PCR ,if-no-overflow))
- (ADD ,tgt 0 ,temp)))))
- (set-current-branches!
- (lambda (if-overflow)
- (LAP (SLL ,tgt ,src ,power-of-two)
- (SRA ,regnum:assembler-temp ,tgt ,power-of-two)
- (BNE ,regnum:assembler-temp ,src (@PCR ,if-overflow))
- (NOP)))
- (lambda (if-no-overflow)
- (LAP (SLL ,tgt ,src ,power-of-two)
- (SRA ,regnum:assembler-temp ,tgt ,power-of-two)
- (BEQ ,regnum:assembler-temp ,src (@PCR ,if-no-overflow))
- (NOP)))))
- (LAP))
-
-(define-arithmetic-method 'MINUS-FIXNUM
- fixnum-methods/2-args/constant*register
- (lambda (tgt constant src overflow?)
- (guarantee-signed-fixnum constant)
- (with-values (lambda () (immediate->register (* constant fixnum-1)))
- (lambda (prefix alias)
- (LAP ,@prefix
- ,@(if overflow?
- (do-overflow-subtraction tgt alias src)
- (LAP (SUB ,tgt ,alias ,src))))))))
-\f
-;;;; Predicates
-
-(define-rule predicate
- (OVERFLOW-TEST)
- ;; The RTL code generate guarantees that this instruction is always
- ;; immediately preceded by a fixnum operation with the OVERFLOW?
- ;; flag turned on. Furthermore, it also guarantees that there are
- ;; no other fixnum operations with the OVERFLOW? flag set. So all
- ;; the processing of overflow tests has been moved into the fixnum
- ;; operations.
- (LAP))
-
-(define-rule predicate
- (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
- (compare-immediate (fixnum-pred-1->cc predicate)
- 0
- (standard-source! source)))
-
-(define (fixnum-pred-1->cc predicate)
- (case predicate
- ((ZERO-FIXNUM?) '=)
- ((NEGATIVE-FIXNUM?) '>)
- ((POSITIVE-FIXNUM?) '<)
- (else (error "unknown fixnum predicate" predicate))))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (REGISTER (? source1))
- (REGISTER (? source2)))
- (compare (fixnum-pred-2->cc predicate)
- (standard-source! source1)
- (standard-source! source2)))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (REGISTER (? source))
- (OBJECT->FIXNUM (CONSTANT (? constant))))
- (compare-fixnum/constant*register (invert-condition-noncommutative
- (fixnum-pred-2->cc predicate))
- constant
- (standard-source! source)))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (REGISTER (? source)))
- (compare-fixnum/constant*register (fixnum-pred-2->cc predicate)
- constant
- (standard-source! source)))
-
-(define-integrable (compare-fixnum/constant*register cc n r)
- (guarantee-signed-fixnum n)
- (compare-immediate cc (* n fixnum-1) r))
-
-(define (fixnum-pred-2->cc predicate)
- (case predicate
- ((EQUAL-FIXNUM?) '=)
- ((LESS-THAN-FIXNUM?) '<)
- ((GREATER-THAN-FIXNUM?) '>)
- (else (error "unknown fixnum predicate" predicate))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Flonum rules
-
-(declare (usual-integrations))
-\f
-(define (flonum-source! register)
- (float-register->fpr (load-alias-register! register 'FLOAT)))
-
-(define (flonum-target! pseudo-register)
- (delete-dead-registers!)
- (float-register->fpr (allocate-alias-register! pseudo-register 'FLOAT)))
-
-(define (flonum-temporary!)
- (float-register->fpr (allocate-temporary-register! 'FLOAT)))
-
-(define-rule statement
- ;; convert a floating-point number to a flonum object
- (ASSIGN (REGISTER (? target))
- (FLOAT->OBJECT (REGISTER (? source))))
- (let ((source (fpr->float-register (flonum-source! source))))
- (let ((target (standard-target! target)))
- (LAP
- ; (SW 0 (OFFSET 0 ,regnum:free)) ; make heap parsable forwards
- (ORI ,regnum:free ,regnum:free #b100) ; Align to odd quad byte
- ,@(deposit-type-address (ucode-type flonum) regnum:free target)
- ,@(with-values
- (lambda ()
- (immediate->register
- (make-non-pointer-literal (ucode-type manifest-nm-vector) 2)))
- (lambda (prefix alias)
- (LAP ,@prefix
- (SW ,alias (OFFSET 0 ,regnum:free)))))
- ,@(fp-store-doubleword 4 regnum:free source)
- (ADDI ,regnum:free ,regnum:free 12)))))
-
-(define-rule statement
- ;; convert a flonum object to a floating-point number
- (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source))))
- (let ((source (standard-move-to-temporary! source)))
- (let ((target (fpr->float-register (flonum-target! target))))
- (LAP ,@(object->address source source)
- ,@(fp-load-doubleword 4 source target #T)))))
-\f
-;;;; Flonum Arithmetic
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?)))
- overflow? ;ignore
- (let ((source (flonum-source! source)))
- ((flonum-1-arg/operator operation) (flonum-target! target) source)))
-
-(define (flonum-1-arg/operator operation)
- (lookup-arithmetic-method operation flonum-methods/1-arg))
-
-(define flonum-methods/1-arg
- (list 'FLONUM-METHODS/1-ARG))
-
-;;; Notice the weird ,', syntax here.
-;;; If LAP changes, this may also have to change.
-
-(let-syntax
- ((define-flonum-operation
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-ARITHMETIC-METHOD ',(cadr form) FLONUM-METHODS/1-ARG
- (LAMBDA (TARGET SOURCE)
- (LAP (,(caddr form) ,',TARGET ,',SOURCE))))))))
- (define-flonum-operation flonum-abs ABS.D)
- (define-flonum-operation flonum-negate NEG.D))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLONUM-2-ARGS (? operation)
- (REGISTER (? source1))
- (REGISTER (? source2))
- (? overflow?)))
- overflow? ;ignore
- (let ((source1 (flonum-source! source1))
- (source2 (flonum-source! source2)))
- ((flonum-2-args/operator operation) (flonum-target! target)
- source1
- source2)))
-
-(define (flonum-2-args/operator operation)
- (lookup-arithmetic-method operation flonum-methods/2-args))
-
-(define flonum-methods/2-args
- (list 'FLONUM-METHODS/2-ARGS))
-
-(let-syntax
- ((define-flonum-operation
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-ARITHMETIC-METHOD ',(cadr form) FLONUM-METHODS/2-ARGS
- (LAMBDA (TARGET SOURCE1 SOURCE2)
- (LAP (,(caddr form) ,',TARGET ,',SOURCE1 ,',SOURCE2))))))))
- (define-flonum-operation flonum-add ADD.D)
- (define-flonum-operation flonum-subtract SUB.D)
- (define-flonum-operation flonum-multiply MUL.D)
- (define-flonum-operation flonum-divide DIV.D))
-\f
-;;;; Flonum Predicates
-
-(define-rule predicate
- (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
- ;; No immediate zeros, easy to generate by subtracting from itself
- (let ((temp (flonum-temporary!))
- (source (flonum-source! source)))
- (LAP (MTC1 0 ,temp)
- (MTC1 0 ,(+ temp 1))
- (NOP)
- ,@(flonum-compare
- (case predicate
- ((FLONUM-ZERO?) 'C.EQ.D)
- ((FLONUM-NEGATIVE?) 'C.LT.D)
- ((FLONUM-POSITIVE?) 'C.GT.D)
- (else (error "unknown flonum predicate" predicate)))
- source temp))))
-
-(define-rule predicate
- (FLONUM-PRED-2-ARGS (? predicate)
- (REGISTER (? source1))
- (REGISTER (? source2)))
- (flonum-compare (case predicate
- ((FLONUM-EQUAL?) 'C.EQ.D)
- ((FLONUM-LESS?) 'C.LT.D)
- ((FLONUM-GREATER?) 'C.GT.D)
- (else (error "unknown flonum predicate" predicate)))
- (flonum-source! source1)
- (flonum-source! source2)))
-
-(define (flonum-compare cc r1 r2)
- (set-current-branches!
- (lambda (label)
- (LAP (BC1T (@PCR ,label)) (NOP)))
- (lambda (label)
- (LAP (BC1F (@PCR ,label)) (NOP))))
- (if (eq? cc 'C.GT.D)
- (LAP (C.LT.D ,r2 ,r1) (NOP))
- (LAP (,cc ,r1 ,r2) (NOP))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$MC68020-Header: rulrew.scm,v 1.1 90/01/18 22:48:52 GMT cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RTL Rewrite Rules
-
-(declare (usual-integrations))
-\f
-;;;; Synthesized Data
-#|
-(define-rule rewriting
- (CONS-POINTER (REGISTER (? type register-known-value))
- (REGISTER (? datum register-known-value)))
- (QUALIFIER (and (rtl:machine-constant? type)
- (rtl:machine-constant? datum)))
- (rtl:make-cons-pointer type datum))
-
-;; I've copied these rules from the MC68020. -- Jinx.
-
-(define-rule rewriting
- (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
- (QUALIFIER
- (and (rtl:object->type? type)
- (rtl:constant? (rtl:object->type-expression type))))
- (rtl:make-cons-pointer
- (rtl:make-machine-constant
- (object-type (rtl:object->type-expression datum)))
- datum))
-
-(define-rule rewriting
- (CONS-POINTER (? type) (REGISTER (? datum register-known-value)))
- (QUALIFIER
- (and (rtl:object->datum? datum)
- (rtl:constant-non-pointer? (rtl:object->datum-expression datum))))
- (rtl:make-cons-pointer
- type
- (rtl:make-machine-constant
- (careful-object-datum (rtl:object->datum-expression datum)))))
-
-(define-rule rewriting
- (OBJECT->TYPE (REGISTER (? source register-known-value)))
- (QUALIFIER (rtl:constant? source))
- (rtl:make-machine-constant (object-type (rtl:constant-value source))))
-
-(define-rule rewriting
- (OBJECT->DATUM (REGISTER (? source register-known-value)))
- (QUALIFIER (rtl:constant-non-pointer? source))
- (rtl:make-machine-constant (careful-object-datum source)))
-
-(define (rtl:constant-non-pointer? expression)
- (and (rtl:constant? expression)
- (non-pointer-object? (rtl:constant-value expression))))
-\f
-;; I've modified these rules from the MC68020. -- Jinx
-
-;;; These rules are losers because there's no abstract way to cons a
-;;; statement or a predicate without also getting some CFG structure.
-
-(define-rule rewriting
- ;; Use register 0, always 0.
- (ASSIGN (? target) (REGISTER (? comparand register-known-value)))
- (QUALIFIER (rtl:immediate-zero-constant? comparand))
- (list 'ASSIGN target (rtl:make-machine-constant 0)))
-
-(define-rule rewriting
- ;; Compare to register 0, always 0.
- (EQ-TEST (? source) (REGISTER (? comparand register-known-value)))
- (QUALIFIER (rtl:immediate-zero-constant? comparand))
- (list 'EQ-TEST source (rtl:make-machine-constant 0)))
-
-(define-rule rewriting
- ;; Compare to register 0, always 0.
- (EQ-TEST (REGISTER (? comparand register-known-value)) (? source))
- (QUALIFIER (rtl:immediate-zero-constant? comparand))
- (list 'EQ-TEST source (rtl:make-machine-constant 0)))
-
-(define (rtl:immediate-zero-constant? expression)
- (cond ((rtl:constant? expression)
- (let ((value (rtl:constant-value expression)))
- (and (non-pointer-object? value)
- (zero? (object-type value))
- (zero? (careful-object-datum value)))))
- ((rtl:cons-pointer? expression)
- (and (let ((expression (rtl:cons-pointer-type expression)))
- (and (rtl:machine-constant? expression)
- (zero? (rtl:machine-constant-value expression))))
- (let ((expression (rtl:cons-pointer-datum expression)))
- (and (rtl:machine-constant? expression)
- (zero? (rtl:machine-constant-value expression))))))
- (else false)))
-\f
-;;;; Fixnums
-
-;; I've copied this rule from the MC68020. -- Jinx
-;; It should probably be qualified to be in the immediate range.
-
-(define-rule rewriting
- (OBJECT->FIXNUM (REGISTER (? source register-known-value)))
- (QUALIFIER (rtl:constant-fixnum? source))
- (rtl:make-object->fixnum source))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (REGISTER (? operand-1 register-known-value))
- (? operand-2)
- #F)
- (QUALIFIER (rtl:constant-fixnum-4? operand-1))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- #F)
- (QUALIFIER (rtl:constant-fixnum-4? operand-2))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (REGISTER (? operand-1 register-known-value))
- (? operand-2)
- #F)
- (QUALIFIER
- (and (rtl:object->fixnum-of-register? operand-1)
- (rtl:constant-fixnum-4? operand-2)))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- #F)
- (QUALIFIER
- (and (rtl:constant-fixnum-4? operand-1)
- (rtl:object->fixnum-of-register? operand-2)))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
-
-(define (rtl:constant-fixnum? expression)
- (and (rtl:constant? expression)
- (fix:fixnum? (rtl:constant-value expression))))
-
-(define (rtl:constant-fixnum-4? expression)
- (and (rtl:object->fixnum? expression)
- (let ((expression (rtl:object->fixnum-expression expression)))
- (and (rtl:constant? expression)
- (eqv? 4 (rtl:constant-value expression))))))
-
-(define (rtl:object->fixnum-of-register? expression)
- (and (rtl:object->fixnum? expression)
- (rtl:register? (rtl:object->fixnum-expression expression))))
-\f
-;;;; Closures and othe optimizations.
-
-;; These rules are Spectrum specific
-
-(define-rule rewriting
- (CONS-POINTER (REGISTER (? type register-known-value))
- (REGISTER (? datum register-known-value)))
- (QUALIFIER (and (rtl:machine-constant? type)
- (= (rtl:machine-constant-value type)
- (ucode-type compiled-entry))
- (or (rtl:entry:continuation? datum)
- (rtl:entry:procedure? datum)
- (rtl:cons-closure? datum))))
- (rtl:make-cons-pointer type datum))
-|#
-
-#|
-;; Not yet written.
-
-;; A type is compatible when a depi instruction can put it in assuming that
-;; the datum has the quad bits set.
-;; A register is a machine-address-register if it is a machine register and
-;; always contains an address (ie. free pointer, stack pointer, or dlink register)
-
-(define-rule rewriting
- (CONS-POINTER (REGISTER (? type register-known-value))
- (REGISTER (? datum machine-address-register)))
- (QUALIFIER (and (rtl:machine-constant? type)
- (spectrum-type-optimizable? (rtl:machine-constant-value type))))
- (rtl:make-cons-pointer type datum))
-|#
-
-
-
\ No newline at end of file
+++ /dev/null
-Optimizations:
-
-A: - Done
-
-5510 (ldi () #x32 8)
-5514 (ldi () 0 9)
-5518 (dep () 8 5 6 9)
-
-Could be done with a single ldil instruction.
-
-It comes from the sequence
-
-(assign (register #x30) (machine-constant #x32))
-(assign (register #x31) (machine-constant 0))
-(assign (register #x32) (cons-pointer (register #x30) (register #x31)))
-
-B: - Done
-
- (ldi () #x28 7)
- (bl () 1 (@pco 0))
- (dep () 0 #x1F 2 1)
- (ldo () (offset (- continuation-695 *pc*) 0 1) 6)
- (dep () 7 5 6 6)
-
-No need for ldi/dep, can be done with depi.
-
-It comes from sequence
-
-(assign (register #x33) (machine-constant #x28))
-(assign (register #x34) (entry:continuation #[uninterned-symbol 482 continuation-695]))
-(assign (register #x35) (cons-pointer (register #x33) (register #x34)))
-
-C:
-
- (bl () 1 (@pco 0))
- (dep () 0 #x1F 2 1)
- (ldo () (offset (- continuation-695 *pc*) 0 1) 6)
-
-can become
-
- (bl () 1 (@pco 0))
- (ldo () (offset (- (- continuation-695 (+ *pc* 4)) privilege-bits) 0 1) 6)
-
-assuming that privilege bits are constant.
-
-D: - Done
-
- (ldi () #x28 #xA)
- (stw () #x1F (offset #xC8 0 4))
- (ldil () #x68000 8)
- (ldo () (offset #x18 0 8) 8)
- (stwm () 8 (offset 4 0 #x15))
- (ldil () #x2020 8)
- (ldo () (offset 4 0 8) 8)
- (stwm () 8 (offset 4 0 #x15))
- (bl () 1 (@pco 0))
- (dep () 0 #x1F 2 1)
- (ldo () (offset (- lambda-1814 *pc*) 0 1) 1)
- (ble () (offset #x64 4 3))
-
-[Closure consing code]
-
-This can be shortened, and the ldi/dep can become a depi.
-
-E:
-
-4DC4 (ldi () #x36 8)
-4DC8 (copy () #x15 9)
-4DCC (dep () 8 5 6 9)
-
-No need for ldi/dep. Can be done with depi. (as long as free).
-
-F:
-
-(flo:- 0.0 x)
-uses a scheme object for 0.0
-fpr0 (the status register) reads as 0.0 (except for stores), a rule
-should use this.
-
-G: - Done
-
-Introduce new macro instructions
-COMIBTN
-COMIBFN
-COMBN
-
-which work like the versions without N except that they always nullify
-the following instruction. The branch tensioner knows the sign of the
-displacement and can therfore insert the NOP when necessary.
-
-H:
-
-Hooks are invoked by the following sequence:
-
- BLE n(4,scheme_to_interface_ble_reg)
- NOP
-
-Why? The NOP should go away, and the hooks should use -4(4,31)
-
-No. The sequence must be uniform, and the NOP allows for further
-optimization. If the sequence were BLE,n, there would be no way
-to improve it.
-
-Note that hooks that don't return (e.g. +) can use BE,n .
-
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Assembler Machine Dependencies
-
-(declare (usual-integrations))
-\f
-(let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form))))))
-
-(define-integrable maximum-padding-length
- ;; Instruction length is always a multiple of 32 bits
- ;; Would 0 work here?
- 32)
-
-(define padding-string
- ;; Pad with `DIAG SCM' instructions
- (unsigned-integer->bit-string maximum-padding-length
- #b00010100010100110100001101001101))
-
-(define-integrable block-offset-width
- ;; Block offsets are always 16 bit words
- 16)
-
-(define-integrable maximum-block-offset
- ;; PC always aligned on longword boundary. Use the extra bit.
- (- (expt 2 (1+ block-offset-width)) 4))
-
-(define (block-offset->bit-string offset start?)
- (unsigned-integer->bit-string block-offset-width
- (+ (quotient offset 2)
- (if start? 0 1))))
-
-(define (make-nmv-header n)
- (bit-string-append (unsigned-integer->bit-string scheme-datum-width n)
- nmv-type-string))
-
-(define nmv-type-string
- (unsigned-integer->bit-string scheme-type-width
- (ucode-type manifest-nm-vector)))
-
-(define (object->bit-string object)
- (bit-string-append
- (unsigned-integer->bit-string scheme-datum-width
- (careful-object-datum object))
- (unsigned-integer->bit-string scheme-type-width (object-type object))))
-
-;;; Machine dependent instruction order
-
-(define (instruction-insert! bits block position receiver)
- (let* ((l (bit-string-length bits))
- (new-position (- position l)))
- (bit-substring-move-right! bits 0 l block new-position)
- (receiver new-position)))
-
-(define instruction-initial-position bit-string-length)
-(define-integrable instruction-append bit-string-append-reversed)
-
-;;; end let-syntax
-)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$MC68020-Header: coerce.scm,v 1.10 88/08/31 05:56:37 GMT cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-(declare (usual-integrations))
-\f
-;;;; Strange hppa coercions
-
-(define (coerce-right-signed nbits)
- (let ((offset (1+ (expt 2 nbits))))
- (lambda (n)
- (unsigned-integer->bit-string nbits
- (if (negative? n)
- (+ (* n 2) offset)
- (* n 2))))))
-
-(define (coerce-assemble12:x nbits)
- (let ((range (expt 2 11)))
- (lambda (n)
- (let ((n (machine-word-offset n range))
- (r (unsigned-integer->bit-string nbits 0)))
- (bit-substring-move-right! n 0 10 r 1)
- (bit-substring-move-right! n 10 11 r 0)
- r))))
-
-(define (coerce-assemble12:y nbits)
- (let ((range (expt 2 11)))
- (lambda (n)
- (let ((r (unsigned-integer->bit-string nbits 0)))
- (bit-substring-move-right! (machine-word-offset n range) 11 12 r 0)
- r))))
-
-(define (coerce-assemble17:x nbits)
- (let ((range (expt 2 16)))
- (lambda (n)
- (let ((r (unsigned-integer->bit-string nbits 0)))
- (bit-substring-move-right! (machine-word-offset n range) 11 16 r 0)
- r))))
-
-(define (coerce-assemble17:y nbits)
- (let ((range (expt 2 16)))
- (lambda (n)
- (let ((n (machine-word-offset n range))
- (r (unsigned-integer->bit-string nbits 0)))
- (bit-substring-move-right! n 0 10 r 1)
- (bit-substring-move-right! n 10 11 r 0)
- r))))
-
-(define (coerce-assemble17:z nbits)
- (let ((range (expt 2 16)))
- (lambda (n)
- (let ((r (unsigned-integer->bit-string nbits 0)))
- (bit-substring-move-right! (machine-word-offset n range) 16 17 r 0)
- r))))
-
-(define (coerce-assemble21:x nbits)
- ;; This one does not check for range. Should it?
- (lambda (n)
- (let ((n (integer->word n))
- (r (unsigned-integer->bit-string nbits 0)))
- (bit-substring-move-right! n 0 2 r 12)
- (bit-substring-move-right! n 2 7 r 16)
- (bit-substring-move-right! n 7 9 r 14)
- (bit-substring-move-right! n 9 20 r 1)
- (bit-substring-move-right! n 20 21 r 0)
- r)))
-
-(define (machine-word-offset n range)
- (let ((value (integer-divide n 4)))
- (if (not (zero? (integer-divide-remainder value)))
- (error "machine-word-offset: Invalid offset" n))
- (let ((result (integer-divide-quotient value)))
- (if (and (< result range)
- (>= result (- range)))
- (integer->word result)
- (error "machine-word-offset: Doesn't fit" n range)))))
-
-(define (integer->word x)
- (unsigned-integer->bit-string
- 32
- (let ((x (if (negative? x) (+ x #x100000000) x)))
- (if (not (and (not (negative? x)) (< x #x100000000)))
- (error "Integer too large to be encoded" x))
- x)))
-\f
-;;; Coercion top level
-
-(define make-coercion
- (coercion-maker
- `((ASSEMBLE12:X . ,coerce-assemble12:x)
- (ASSEMBLE12:Y . ,coerce-assemble12:y)
- (ASSEMBLE17:X . ,coerce-assemble17:x)
- (ASSEMBLE17:Y . ,coerce-assemble17:y)
- (ASSEMBLE17:Z . ,coerce-assemble17:z)
- (ASSEMBLE21:X . ,coerce-assemble21:x)
- (RIGHT-SIGNED . ,coerce-right-signed)
- (UNSIGNED . ,coerce-unsigned-integer)
- (SIGNED . ,coerce-signed-integer))))
-
-(define coerce-1-bit-unsigned (make-coercion 'UNSIGNED 1))
-(define coerce-2-bit-unsigned (make-coercion 'UNSIGNED 2))
-(define coerce-3-bit-unsigned (make-coercion 'UNSIGNED 3))
-(define coerce-4-bit-unsigned (make-coercion 'UNSIGNED 4))
-(define coerce-5-bit-unsigned (make-coercion 'UNSIGNED 5))
-(define coerce-6-bit-unsigned (make-coercion 'UNSIGNED 6))
-(define coerce-7-bit-unsigned (make-coercion 'UNSIGNED 7))
-(define coerce-8-bit-unsigned (make-coercion 'UNSIGNED 8))
-(define coerce-9-bit-unsigned (make-coercion 'UNSIGNED 9))
-(define coerce-10-bit-unsigned (make-coercion 'UNSIGNED 10))
-(define coerce-11-bit-unsigned (make-coercion 'UNSIGNED 11))
-(define coerce-12-bit-unsigned (make-coercion 'UNSIGNED 12))
-(define coerce-13-bit-unsigned (make-coercion 'UNSIGNED 13))
-(define coerce-14-bit-unsigned (make-coercion 'UNSIGNED 14))
-(define coerce-15-bit-unsigned (make-coercion 'UNSIGNED 15))
-(define coerce-16-bit-unsigned (make-coercion 'UNSIGNED 16))
-(define coerce-32-bit-unsigned (make-coercion 'UNSIGNED 32))
-
-(define coerce-8-bit-signed (make-coercion 'SIGNED 8))
-(define coerce-16-bit-signed (make-coercion 'SIGNED 16))
-(define coerce-32-bit-signed (make-coercion 'SIGNED 32))
-
-(define coerce-5-bit-right-signed (make-coercion 'RIGHT-SIGNED 5))
-(define coerce-11-bit-right-signed (make-coercion 'RIGHT-SIGNED 11))
-(define coerce-14-bit-right-signed (make-coercion 'RIGHT-SIGNED 14))
-(define coerce-11-bit-assemble12:x (make-coercion 'ASSEMBLE12:X 11))
-(define coerce-1-bit-assemble12:y (make-coercion 'ASSEMBLE12:Y 1))
-(define coerce-5-bit-assemble17:x (make-coercion 'ASSEMBLE17:X 5))
-(define coerce-11-bit-assemble17:y (make-coercion 'ASSEMBLE17:Y 11))
-(define coerce-1-bit-assemble17:z (make-coercion 'ASSEMBLE17:Z 1))
-(define coerce-21-bit-assemble21:x (make-coercion 'ASSEMBLE21:X 21))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Script to incrementally compile the compiler (from .bins)
-
-(fluid-let ((compiler:coalescing-constant-warnings? #f))
- (for-each compile-directory
- '("back"
- "base"
- "fggen"
- "fgopt"
- "machines/spectrum"
- "rtlbase"
- "rtlgen"
- "rtlopt")))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Compiler Packaging
-\f
-(global-definitions "../runtime/runtime")
-(global-definitions "../sf/sf")
-
-(define-package (compiler)
- (files "base/switch"
- "base/object" ;tagged object support
- "base/enumer" ;enumerations
- "base/sets" ;set abstraction
- "base/mvalue" ;multiple-value support
- "base/scode" ;SCode abstraction
- "machines/spectrum/machin" ;machine dependent stuff
- "back/asutl" ;back-end odds and ends
- "base/utils" ;odds and ends
-
- "base/cfg1" ;control flow graph
- "base/cfg2"
- "base/cfg3"
-
- "base/ctypes" ;CFG datatypes
-
- "base/rvalue" ;Right hand values
- "base/lvalue" ;Left hand values
- "base/blocks" ;rvalue: blocks
- "base/proced" ;rvalue: procedures
- "base/contin" ;rvalue: continuations
-
- "base/subprb" ;subproblem datatype
-
- "rtlbase/rgraph" ;program graph abstraction
- "rtlbase/rtlty1" ;RTL: type definitions
- "rtlbase/rtlty2" ;RTL: type definitions
- "rtlbase/rtlexp" ;RTL: expression operations
- "rtlbase/rtlcon" ;RTL: complex constructors
- "rtlbase/rtlreg" ;RTL: registers
- "rtlbase/rtlcfg" ;RTL: CFG types
- "rtlbase/rtlobj" ;RTL: CFG objects
- "rtlbase/regset" ;RTL: register sets
- "rtlbase/valclass" ;RTL: value classes
-
- "back/insseq" ;LAP instruction sequences
- )
- (parent ())
- (export ()
- compiler:analyze-side-effects?
- compiler:cache-free-variables?
- compiler:coalescing-constant-warnings?
- compiler:code-compression?
- compiler:compile-by-procedures?
- compiler:cse?
- compiler:default-top-level-declarations
- compiler:enable-integration-declarations?
- compiler:generate-lap-files?
- compiler:generate-range-checks?
- compiler:generate-rtl-files?
- compiler:generate-stack-checks?
- compiler:generate-type-checks?
- compiler:implicit-self-static?
- compiler:intersperse-rtl-in-lap?
- compiler:noisy?
- compiler:open-code-flonum-checks?
- compiler:open-code-primitives?
- compiler:optimize-environments?
- compiler:package-optimization-level
- compiler:preserve-data-structures?
- compiler:show-phases?
- compiler:show-procedures?
- compiler:show-subphases?
- compiler:show-time-reports?
- compiler:use-multiclosures?)
- (import (runtime system-macros)
- ucode-primitive
- ucode-type)
- (import ()
- (scode/access-components access-components)
- (scode/access-environment access-environment)
- (scode/access-name access-name)
- (scode/access? access?)
- (scode/assignment-components assignment-components)
- (scode/assignment-name assignment-name)
- (scode/assignment-value assignment-value)
- (scode/assignment? assignment?)
- (scode/combination-components combination-components)
- (scode/combination-operands combination-operands)
- (scode/combination-operator combination-operator)
- (scode/combination? combination?)
- (scode/comment-components comment-components)
- (scode/comment-expression comment-expression)
- (scode/comment-text comment-text)
- (scode/comment? comment?)
- (scode/conditional-alternative conditional-alternative)
- (scode/conditional-components conditional-components)
- (scode/conditional-consequent conditional-consequent)
- (scode/conditional-predicate conditional-predicate)
- (scode/conditional? conditional?)
- (scode/constant? scode-constant?)
- (scode/declaration-components declaration-components)
- (scode/declaration-expression declaration-expression)
- (scode/declaration-text declaration-text)
- (scode/declaration? declaration?)
- (scode/definition-components definition-components)
- (scode/definition-name definition-name)
- (scode/definition-value definition-value)
- (scode/definition? definition?)
- (scode/delay-components delay-components)
- (scode/delay-expression delay-expression)
- (scode/delay? delay?)
- (scode/disjunction-alternative disjunction-alternative)
- (scode/disjunction-components disjunction-components)
- (scode/disjunction-predicate disjunction-predicate)
- (scode/disjunction? disjunction?)
- (scode/lambda-components lambda-components)
- (scode/lambda? lambda?)
- (scode/make-access make-access)
- (scode/make-assignment make-assignment)
- (scode/make-combination make-combination)
- (scode/make-comment make-comment)
- (scode/make-conditional make-conditional)
- (scode/make-declaration make-declaration)
- (scode/make-definition make-definition)
- (scode/make-delay make-delay)
- (scode/make-disjunction make-disjunction)
- (scode/make-lambda make-lambda)
- (scode/make-open-block make-open-block)
- (scode/make-quotation make-quotation)
- (scode/make-sequence make-sequence)
- (scode/make-the-environment make-the-environment)
- (scode/make-unassigned? make-unassigned?)
- (scode/make-variable make-variable)
- (scode/open-block-components open-block-components)
- (scode/open-block? open-block?)
- (scode/primitive-procedure? primitive-procedure?)
- (scode/procedure? procedure?)
- (scode/quotation-expression quotation-expression)
- (scode/quotation? quotation?)
- (scode/sequence-actions sequence-actions)
- (scode/sequence-components sequence-components)
- (scode/sequence-immediate-first sequence-immediate-first)
- (scode/sequence-immediate-second sequence-immediate-second)
- (scode/sequence-first sequence-first)
- (scode/sequence-second sequence-second)
- (scode/sequence? sequence?)
- (scode/symbol? symbol?)
- (scode/the-environment? the-environment?)
- (scode/unassigned?-name unassigned?-name)
- (scode/unassigned?? unassigned??)
- (scode/variable-components variable-components)
- (scode/variable-name variable-name)
- (scode/variable? variable?)))
-\f
-(define-package (compiler reference-contexts)
- (files "base/refctx")
- (parent (compiler))
- (export (compiler)
- add-reference-context/adjacent-parents!
- initialize-reference-contexts!
- make-reference-context
- modify-reference-contexts!
- reference-context/adjacent-parent?
- reference-context/block
- reference-context/offset
- reference-context/procedure
- reference-context?
- set-reference-context/offset!))
-
-(define-package (compiler macros)
- (files "base/macros")
- (parent ())
- (import (runtime macros)
- parse-define-syntax)
- (initialization (initialize-package!)))
-
-(define-package (compiler declarations)
- (files "machines/spectrum/decls")
- (parent (compiler))
- (export (compiler)
- sc
- syntax-files!)
- (import (scode-optimizer top-level)
- sf/internal)
- (initialization (initialize-package!)))
-
-(define-package (compiler top-level)
- (files "base/toplev"
- "base/crstop"
- "base/asstop")
- (parent (compiler))
- (export ()
- cbf
- cf
- compile-directory
- compile-bin-file
- compile-file
- compile-file:force?
- compile-file:override-usual-integrations
- compile-file:sf-only?
- compile-procedure
- compile-scode
- compiler:dump-bci-file
- compiler:dump-bci/bcs-files
- compiler:dump-bif/bsm-files
- compiler:dump-inf-file
- compiler:dump-info-file
- compiler:reset!
- cross-compile-bin-file
- cross-compile-bin-file-end)
- (export (compiler)
- canonicalize-label-name)
- (export (compiler fg-generator)
- compile-recursively)
- (export (compiler rtl-generator)
- *ic-procedure-headers*
- *rtl-continuations*
- *rtl-expression*
- *rtl-graphs*
- *rtl-procedures*)
- (export (compiler lap-syntaxer)
- *block-label*
- *external-labels*
- label->object)
- (export (compiler debug)
- *root-expression*
- *rtl-procedures*
- *rtl-graphs*)
- (import (runtime compiler-info)
- make-dbg-info-vector
- split-inf-structure!)
- (import (runtime unparser)
- param:unparse-uninterned-symbols-by-name?)
- (import (scode-optimizer build-utilities)
- directory-processor))
-\f
-(define-package (compiler debug)
- (files "base/debug")
- (parent (compiler))
- (export ()
- debug/find-continuation
- debug/find-entry-node
- debug/find-procedure
- debug/where
- dump-rtl
- po
- show-bblock-rtl
- show-fg
- show-fg-node
- show-rtl
- write-rtl-instructions)
- (import (runtime unparser)
- param:unparse-uninterned-symbols-by-name?))
-
-(define-package (compiler pattern-matcher/lookup)
- (files "base/pmlook")
- (parent (compiler))
- (export (compiler)
- make-pattern-variable
- pattern-lookup
- pattern-variable-name
- pattern-variable?
- pattern-variables))
-
-(define-package (compiler pattern-matcher/parser)
- (files "base/pmpars")
- (parent (compiler))
- (export (compiler)
- parse-rule
- rule-result-expression)
- (export (compiler macros)
- parse-rule
- rule-result-expression))
-
-(define-package (compiler pattern-matcher/early)
- (files "base/pmerly")
- (parent (compiler))
- (export (compiler)
- early-parse-rule
- early-pattern-lookup
- early-make-rule
- make-database-transformer
- make-symbol-transformer
- make-bit-mask-transformer))
-\f
-(define-package (compiler debugging-information)
- (files "base/infnew")
- (parent (compiler))
- (export (compiler top-level)
- info-generation-phase-1
- info-generation-phase-2
- info-generation-phase-3)
- (export (compiler rtl-generator)
- generated-dbg-continuation)
- (import (runtime compiler-info)
- make-dbg-info
-
- make-dbg-expression
- dbg-expression/block
- dbg-expression/label
- set-dbg-expression/label!
-
- make-dbg-procedure
- dbg-procedure/block
- dbg-procedure/label
- set-dbg-procedure/label!
- dbg-procedure/name
- dbg-procedure/required
- dbg-procedure/optional
- dbg-procedure/rest
- dbg-procedure/auxiliary
- dbg-procedure/external-label
- set-dbg-procedure/external-label!
- dbg-procedure<?
-
- make-dbg-continuation
- dbg-continuation/block
- dbg-continuation/label
- set-dbg-continuation/label!
- dbg-continuation<?
-
- make-dbg-block
- dbg-block/parent
- dbg-block/layout
- dbg-block/stack-link
- set-dbg-block/procedure!
-
- make-dbg-variable
- dbg-variable/value
- set-dbg-variable/value!
-
- dbg-block-name/dynamic-link
- dbg-block-name/ic-parent
- dbg-block-name/normal-closure
- dbg-block-name/return-address
- dbg-block-name/static-link
-
- make-dbg-label-2
- dbg-label/offset
- set-dbg-label/external?!))
-
-(define-package (compiler constraints)
- (files "base/constr")
- (parent (compiler))
- (export (compiler)
- make-constraint
- constraint/element
- constraint/graph-head
- constraint/afters
- constraint/closed?
- constraint-add!
- add-constraint-element!
- add-constraint-set!
- make-constraint-graph
- constraint-graph/entry-nodes
- constraint-graph/closed?
- close-constraint-graph!
- close-constraint-node!
- order-per-constraints
- order-per-constraints/extracted
- legal-ordering-per-constraints?
- with-new-constraint-marks
- constraint-marked?
- constraint-mark!
- transitively-close-dag!
- reverse-postorder))
-\f
-(define-package (compiler fg-generator)
- (files "fggen/canon" ;SCode canonicalizer
- "fggen/fggen" ;SCode->flow-graph converter
- "fggen/declar" ;Declaration handling
- )
- (parent (compiler))
- (export (compiler top-level)
- canonicalize/top-level
- construct-graph)
- (import (runtime scode-data)
- &pair-car
- &pair-cdr
- &triple-first
- &triple-second
- &triple-third))
-
-(define-package (compiler fg-optimizer)
- (files "fgopt/outer" ;outer analysis
- "fgopt/sideff" ;side effect analysis
- )
- (parent (compiler))
- (export (compiler top-level)
- clear-call-graph!
- compute-call-graph!
- outer-analysis
- side-effect-analysis))
-
-(define-package (compiler fg-optimizer fold-constants)
- (files "fgopt/folcon")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) fold-constants))
-
-(define-package (compiler fg-optimizer operator-analysis)
- (files "fgopt/operan")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) operator-analysis))
-
-(define-package (compiler fg-optimizer variable-indirection)
- (files "fgopt/varind")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) initialize-variable-indirections!))
-
-(define-package (compiler fg-optimizer environment-optimization)
- (files "fgopt/envopt")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) optimize-environments!))
-
-(define-package (compiler fg-optimizer closure-analysis)
- (files "fgopt/closan")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) identify-closure-limits!))
-
-(define-package (compiler fg-optimizer continuation-analysis)
- (files "fgopt/contan")
- (parent (compiler fg-optimizer))
- (export (compiler top-level)
- continuation-analysis
- setup-block-static-links!))
-
-(define-package (compiler fg-optimizer compute-node-offsets)
- (files "fgopt/offset")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) compute-node-offsets))
-\f
-(define-package (compiler fg-optimizer connectivity-analysis)
- (files "fgopt/conect")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) connectivity-analysis))
-
-(define-package (compiler fg-optimizer delete-integrated-parameters)
- (files "fgopt/delint")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) delete-integrated-parameters))
-
-(define-package (compiler fg-optimizer design-environment-frames)
- (files "fgopt/desenv")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) design-environment-frames!))
-
-(define-package (compiler fg-optimizer setup-block-types)
- (files "fgopt/blktyp")
- (parent (compiler fg-optimizer))
- (export (compiler top-level)
- setup-block-types!
- setup-closure-contexts!)
- (export (compiler)
- indirection-block-procedure))
-
-(define-package (compiler fg-optimizer simplicity-analysis)
- (files "fgopt/simple")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) simplicity-analysis)
- (export (compiler fg-optimizer subproblem-ordering)
- new-subproblem/compute-simplicity!))
-
-(define-package (compiler fg-optimizer simulate-application)
- (files "fgopt/simapp")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) simulate-application))
-
-(define-package (compiler fg-optimizer subproblem-free-variables)
- (files "fgopt/subfre")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) compute-subproblem-free-variables)
- (export (compiler fg-optimizer) map-union)
- (export (compiler fg-optimizer subproblem-ordering)
- new-subproblem/compute-free-variables!))
-
-(define-package (compiler fg-optimizer subproblem-ordering)
- (files "fgopt/order")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) subproblem-ordering))
-
-(define-package (compiler fg-optimizer subproblem-ordering reuse-frames)
- (files "fgopt/reord" "fgopt/reuse")
- (parent (compiler fg-optimizer subproblem-ordering))
- (export (compiler top-level) setup-frame-adjustments)
- (export (compiler fg-optimizer subproblem-ordering)
- order-subproblems/maybe-overwrite-block))
-
-(define-package (compiler fg-optimizer subproblem-ordering parameter-analysis)
- (files "fgopt/param")
- (parent (compiler fg-optimizer subproblem-ordering))
- (export (compiler fg-optimizer subproblem-ordering)
- parameter-analysis))
-
-(define-package (compiler fg-optimizer return-equivalencing)
- (files "fgopt/reteqv")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) find-equivalent-returns!))
-\f
-(define-package (compiler rtl-generator)
- (files "rtlgen/rtlgen" ;RTL generator
- "rtlgen/rgstmt" ;statements
- "rtlgen/fndvar" ;find variables
- "machines/spectrum/rgspcm" ;special close-coded primitives
- "rtlbase/rtline" ;linearizer
- )
- (parent (compiler))
- (export (compiler)
- make-linearizer)
- (export (compiler top-level)
- generate/top-level
- linearize-rtl
- setup-bblock-continuations!)
- (export (compiler debug)
- linearize-rtl)
- (import (compiler top-level)
- label->object))
-
-(define-package (compiler rtl-generator generate/procedure-header)
- (files "rtlgen/rgproc")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator) generate/procedure-header))
-
-(define-package (compiler rtl-generator combination/inline)
- (files "rtlgen/opncod")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator) combination/inline)
- (export (compiler top-level) open-coding-analysis))
-
-(define-package (compiler rtl-generator find-block)
- (files "rtlgen/fndblk")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator) find-block))
-
-(define-package (compiler rtl-generator generate/rvalue)
- (files "rtlgen/rgrval")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator)
- generate/rvalue
- load-closure-environment
- make-cons-closure-indirection
- make-cons-closure-redirection
- make-closure-redirection
- make-ic-cons
- make-non-trivial-closure-cons
- make-trivial-closure-cons
- redirect-closure))
-
-(define-package (compiler rtl-generator generate/combination)
- (files "rtlgen/rgcomb")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator)
- generate/combination
- rtl:bump-closure)
- (export (compiler rtl-generator combination/inline)
- generate/invocation-prefix))
-
-(define-package (compiler rtl-generator generate/return)
- (files "rtlgen/rgretn")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator)
- make-return-operand
- generate/return
- generate/return*
- generate/trivial-return))
-\f
-(define-package (compiler rtl-cse)
- (files "rtlopt/rcse1" ;RTL common subexpression eliminator
- "rtlopt/rcse2"
- "rtlopt/rcseep" ;CSE expression predicates
- "rtlopt/rcseht" ;CSE hash table
- "rtlopt/rcserq" ;CSE register/quantity abstractions
- "rtlopt/rcsesr" ;CSE stack references
- )
- (parent (compiler))
- (export (compiler top-level) common-subexpression-elimination))
-
-(define-package (compiler rtl-optimizer)
- (files "rtlopt/rdebug")
- (parent (compiler)))
-
-(define-package (compiler rtl-optimizer invertible-expression-elimination)
- (files "rtlopt/rinvex")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) invertible-expression-elimination))
-
-(define-package (compiler rtl-optimizer common-suffix-merging)
- (files "rtlopt/rtlcsm")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) merge-common-suffixes!))
-
-(define-package (compiler rtl-optimizer rtl-dataflow-analysis)
- (files "rtlopt/rdflow")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) rtl-dataflow-analysis))
-
-(define-package (compiler rtl-optimizer rtl-rewriting)
- (files "rtlopt/rerite")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level)
- rtl-rewriting:post-cse
- rtl-rewriting:pre-cse)
- (export (compiler lap-syntaxer) add-rewriting-rule!))
-
-(define-package (compiler rtl-optimizer lifetime-analysis)
- (files "rtlopt/rlife")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) lifetime-analysis)
- (export (compiler rtl-optimizer code-compression) mark-set-registers!))
-
-(define-package (compiler rtl-optimizer code-compression)
- (files "rtlopt/rcompr")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) code-compression))
-
-(define-package (compiler rtl-optimizer register-allocation)
- (files "rtlopt/ralloc")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) register-allocation))
-\f
-(define-package (compiler lap-syntaxer)
- (files "back/lapgn1" ;LAP generator
- "back/lapgn2" ; " "
- "back/lapgn3" ; " "
- "back/regmap" ;Hardware register allocator
- "machines/spectrum/lapgen" ;code generation rules
- "machines/spectrum/rules1" ; " " "
- "machines/spectrum/rules2" ; " " "
- "machines/spectrum/rules3" ; " " "
- "machines/spectrum/rules4" ; " " "
- "machines/spectrum/rulfix" ; " " "
- "machines/spectrum/rulflo" ; " " "
- "machines/spectrum/rulrew" ;code rewriting rules
- "back/syntax" ;Generic syntax phase
- "back/syerly" ;Early binding version
- "machines/spectrum/coerce" ;Coercions: integer -> bit string
- "back/asmmac" ;Macros for hairy syntax
- "machines/spectrum/insmac" ;Macros for hairy syntax
- "machines/spectrum/instr1" ;Spectrum instruction utilities
- "machines/spectrum/instr2" ;Spectrum instructions
- "machines/spectrum/instr3" ; " "
- )
- (parent (compiler))
- (export (compiler)
- available-machine-registers
- fits-in-5-bits-signed?
- lap-generator/match-rtl-instruction
- lap:make-entry-point
- lap:make-label-statement
- lap:make-unconditional-branch
- lap:syntax-instruction)
- (export (compiler top-level)
- *block-associations*
- *interned-assignments*
- *interned-constants*
- *interned-global-links*
- *interned-uuo-links*
- *interned-static-variables*
- *interned-variables*
- *next-constant*
- generate-lap)
- (import (scode-optimizer expansion)
- scode->scode-expander))
-
-(define-package (compiler lap-syntaxer map-merger)
- (files "back/mermap")
- (parent (compiler lap-syntaxer))
- (export (compiler lap-syntaxer)
- merge-register-maps))
-
-(define-package (compiler lap-syntaxer linearizer)
- (files "back/linear")
- (parent (compiler lap-syntaxer))
- (export (compiler lap-syntaxer)
- add-end-of-block-code!
- add-extra-code!
- bblock-linearize-lap
- extra-code-block/xtra
- declare-extra-code-block!
- find-extra-code-block
- linearize-lap
- set-current-branches!
- set-extra-code-block/xtra!)
- (export (compiler top-level)
- *end-of-block-code*
- linearize-lap))
-
-(define-package (compiler lap-optimizer)
- (files "machines/spectrum/lapopt")
- (parent (compiler))
- (export (compiler top-level)
- optimize-linear-lap))
-
-(define-package (compiler assembler)
- (files "machines/spectrum/assmd" ;Machine dependent
- "back/symtab" ;Symbol tables
- "back/bitutl" ;Assembly blocks
- "back/bittop" ;Assembler top level
- )
- (parent (compiler))
- (export (compiler)
- instruction-append)
- (export (compiler top-level)
- assemble))
-
-(define-package (compiler disassembler)
- (files "machines/spectrum/dassm1"
- "machines/spectrum/dassm2"
- "machines/spectrum/dassm3")
- (parent (compiler))
- (export ()
- compiler:write-lap-file
- compiler:disassemble)
- (import (runtime compiler-info)
- compiled-code-block/dbg-info
- dbg-info-vector/blocks-vector
- dbg-info-vector?
- dbg-info/labels
- dbg-label/external?
- dbg-label/name
- dbg-labels/find-offset))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Script to incrementally syntax the compiler
-\f
-(load-option 'CREF)
-
-;; Guarantee that the compiler's package structure exists.
-(if (not (name->package '(COMPILER)))
- (let ((package-set (package-set-pathname "compiler")))
- (if (not (file-exists? package-set))
- (cref/generate-trivial-constructor "compiler"))
- (construct-packages-from-file (fasload package-set))))
-
-;; Guarantee that the necessary syntactic transforms and optimizers
-;; are loaded.
-(if (lexical-unreferenceable? (->environment '(COMPILER)) 'SYNTAX-FILES!)
- (let ((sf-and-load
- (lambda (files package)
- (sf-conditionally files)
- (for-each (lambda (file)
- (load (string-append file ".bin") package))
- files))))
- (load-option 'HASH-TABLE)
- (fresh-line)
- (newline)
- (write-string "---- Loading compile-time files ----")
- (newline)
- (sf-and-load '("base/switch") '(COMPILER))
- (sf-and-load '("base/macros") '(COMPILER MACROS))
- ((access initialize-package! (->environment '(COMPILER MACROS))))
- (sf-and-load '("machines/spectrum/decls") '(COMPILER DECLARATIONS))
- (let ((environment (->environment '(COMPILER DECLARATIONS))))
- (set! (access source-file-expression environment) "*.scm")
- ((access initialize-package! environment)))
- (sf-and-load '("base/pmlook") '(COMPILER PATTERN-MATCHER/LOOKUP))
- (sf-and-load '("base/pmpars") '(COMPILER PATTERN-MATCHER/PARSER))
- (fluid-let ((sf/default-syntax-table (->environment '(COMPILER))))
- (sf-and-load '("machines/spectrum/machin") '(COMPILER)))
- (fluid-let ((sf/default-declarations
- '((integrate-external "insseq")
- (integrate-external "machin")
- (usual-definition (set expt)))))
- (sf-and-load '("machines/spectrum/assmd") '(COMPILER ASSEMBLER)))
- (sf-and-load '("back/syntax") '(COMPILER LAP-SYNTAXER))
- (sf-and-load '("machines/spectrum/coerce"
- "back/asmmac"
- "machines/spectrum/insmac")
- '(COMPILER LAP-SYNTAXER))
- (sf-and-load '("base/scode") '(COMPILER))
- (sf-and-load '("base/pmerly") '(COMPILER PATTERN-MATCHER/EARLY))
- (sf-and-load '("back/syerly") '(COMPILER LAP-SYNTAXER))))
-
-;; Resyntax any files that need it.
-((access syntax-files! (->environment '(COMPILER))))
-
-;; Rebuild the package constructors and cref.
-(cref/generate-constructors "compiler")
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Disassembler: User Level
-;;; package: (compiler disassembler)
-
-(declare (usual-integrations))
-\f
-;;; Flags that control disassembler behavior
-
-(define disassembler/symbolize-output? true)
-(define disassembler/compiled-code-heuristics? true)
-(define disassembler/write-offsets? true)
-(define disassembler/write-addresses? false)
-
-;;;; Top level entries
-
-(define (compiler:write-lap-file filename #!optional symbol-table?)
- (let ((pathname (->pathname filename))
- (symbol-table?
- (if (default-object? symbol-table?) true symbol-table?)))
- (with-output-to-file (pathname-new-type pathname "lap")
- (lambda ()
- (let ((com-file (pathname-new-type pathname "com")))
- (let ((object (fasload com-file)))
- (if (compiled-code-address? object)
- (let ((block (compiled-code-address->block object)))
- (disassembler/write-compiled-code-block
- block
- (compiled-code-block/dbg-info block symbol-table?)))
- (begin
- (if (not
- (and (scode/comment? object)
- (dbg-info-vector? (scode/comment-text object))))
- (error "Not a compiled file" com-file))
- (let ((blocks
- (vector->list
- (dbg-info-vector/blocks-vector
- (scode/comment-text object)))))
- (if (not (null? blocks))
- (do ((blocks blocks (cdr blocks)))
- ((null? blocks) unspecific)
- (disassembler/write-compiled-code-block
- (car blocks)
- (compiled-code-block/dbg-info (car blocks)
- symbol-table?))
- (if (not (null? (cdr blocks)))
- (begin
- (write-char #\page)
- (newline))))))))))))))
-
-(define disassembler/base-address)
-
-(define (compiler:disassemble entry)
- (let ((block (compiled-entry/block entry)))
- (let ((info (compiled-code-block/dbg-info block true)))
- (fluid-let ((disassembler/write-offsets? true)
- (disassembler/write-addresses? true)
- (disassembler/base-address (object-datum block)))
- (newline)
- (newline)
- (disassembler/write-compiled-code-block block info)))))
-\f
-(define (disassembler/write-compiled-code-block block info)
- (let ((symbol-table (and info (dbg-info/labels info))))
- (write-string "Disassembly of ")
- (write block)
- (call-with-values
- (lambda () (compiled-code-block/filename-and-index block))
- (lambda (filename index)
- (if filename
- (begin
- (write-string " (Block ")
- (write index)
- (write-string " in ")
- (write-string filename)
- (write-string ")")))))
- (write-string ":\n")
- (write-string "Code:\n\n")
- (disassembler/write-instruction-stream
- symbol-table
- (disassembler/instructions/compiled-code-block block symbol-table))
- (write-string "\nConstants:\n\n")
- (disassembler/write-constants-block block symbol-table)
- (newline)))
-
-(define (disassembler/instructions/compiled-code-block block symbol-table)
- (disassembler/instructions block
- (compiled-code-block/code-start block)
- (compiled-code-block/code-end block)
- symbol-table))
-
-(define (disassembler/instructions/address start-address end-address)
- (disassembler/instructions false start-address end-address false))
-
-(define (disassembler/write-instruction-stream symbol-table instruction-stream)
- (parameterize* (list (cons param:unparser-radix 16))
- (lambda ()
- (disassembler/for-each-instruction instruction-stream
- (lambda (offset instruction)
- (disassembler/write-instruction symbol-table
- offset
- (lambda () (display instruction))))))))
-
-(define (disassembler/for-each-instruction instruction-stream procedure)
- (let loop ((instruction-stream instruction-stream))
- (if (not (disassembler/instructions/null? instruction-stream))
- (disassembler/instructions/read instruction-stream
- (lambda (offset instruction instruction-stream)
- (procedure offset instruction)
- (loop (instruction-stream)))))))
-\f
-(define (disassembler/write-constants-block block symbol-table)
- (parameterize* (list (cons param:unparser-radix 16))
- (lambda ()
- (let ((end (system-vector-length block)))
- (let loop ((index (compiled-code-block/constants-start block)))
- (cond ((not (< index end)) 'DONE)
- ((object-type?
- (let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form))))))
- (ucode-type linkage-section))
- (system-vector-ref block index))
- (loop (disassembler/write-linkage-section block
- symbol-table
- index)))
- (else
- (disassembler/write-instruction
- symbol-table
- (compiled-code-block/index->offset index)
- (lambda ()
- (write-constant block
- symbol-table
- (system-vector-ref block index))))
- (loop (1+ index)))))))))
-
-(define (write-constant block symbol-table constant)
- (write-string (cdr (write-to-string constant 60)))
- (cond ((lambda? constant)
- (let ((expression (lambda-body constant)))
- (if (and (compiled-code-address? expression)
- (eq? (compiled-code-address->block expression) block))
- (begin
- (write-string " (")
- (let ((offset (compiled-code-address->offset expression)))
- (let ((label
- (disassembler/lookup-symbol symbol-table offset)))
- (if label
- (write-string label)
- (write offset))))
- (write-string ")")))))
- ((compiled-code-address? constant)
- (write-string " (offset ")
- (write (compiled-code-address->offset constant))
- (write-string " in ")
- (write (compiled-code-address->block constant))
- (write-string ")"))
- (else false)))
-\f
-(define (disassembler/write-linkage-section block symbol-table index)
- (let* ((field (object-datum (system-vector-ref block index)))
- (descriptor (integer-divide field #x10000)))
- (let ((kind (integer-divide-quotient descriptor))
- (length (integer-divide-remainder descriptor)))
-
- (define (write-caches offset size writer)
- (let loop ((index (1+ (+ offset index)))
- (how-many (quotient (- length offset) size)))
- (if (zero? how-many)
- 'DONE
- (begin
- (disassembler/write-instruction
- symbol-table
- (compiled-code-block/index->offset index)
- (lambda ()
- (writer block index)))
- (loop (+ size index) (-1+ how-many))))))
-
- (disassembler/write-instruction
- symbol-table
- (compiled-code-block/index->offset index)
- (lambda ()
- (write-string "#[LINKAGE-SECTION ")
- (write field)
- (write-string "]")))
- (case kind
- ((0 3)
- (write-caches
- compiled-code-block/procedure-cache-offset
- compiled-code-block/objects-per-procedure-cache
- disassembler/write-procedure-cache))
- ((1)
- (write-caches
- 0
- compiled-code-block/objects-per-variable-cache
- (lambda (block index)
- (disassembler/write-variable-cache "Reference" block index))))
- ((2)
- (write-caches
- 0
- compiled-code-block/objects-per-variable-cache
- (lambda (block index)
- (disassembler/write-variable-cache "Assignment" block index))))
- (else
- (error "disassembler/write-linkage-section: Unknown section kind"
- kind)))
- (1+ (+ index length)))))
-\f
-(define-integrable (variable-cache-name cache)
- ((ucode-primitive primitive-object-ref 2) cache 1))
-
-(define (disassembler/write-variable-cache kind block index)
- (write-string kind)
- (write-string " cache to ")
- (write (variable-cache-name (disassembler/read-variable-cache block index))))
-
-(define (disassembler/write-procedure-cache block index)
- (let ((result (disassembler/read-procedure-cache block index)))
- (write (vector-ref result 2))
- (write-string " argument procedure cache to ")
- (case (vector-ref result 0)
- ((COMPILED INTERPRETED)
- (write (vector-ref result 1)))
- ((VARIABLE)
- (write-string "variable ")
- (write (vector-ref result 1)))
- (else
- (error "disassembler/write-procedure-cache: Unknown cache kind"
- (vector-ref result 0))))))
-
-(define (disassembler/write-instruction symbol-table offset write-instruction)
- (if symbol-table
- (let ((label (dbg-labels/find-offset symbol-table offset)))
- (if label
- (begin
- (write-char #\Tab)
- (write-string (dbg-label/name label))
- (write-char #\:)
- (newline)))))
-
- (if disassembler/write-addresses?
- (begin
- (write-string
- (number->string (+ offset disassembler/base-address) 16))
- (write-char #\Tab)))
-
- (if disassembler/write-offsets?
- (begin
- (write-string (number->string offset 16))
- (write-char #\Tab)))
-
- (if symbol-table
- (write-string " "))
- (write-instruction)
- (newline))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Spectrum Disassembler: Top Level
-;;; package: (compiler disassembler)
-
-(declare (usual-integrations))
-\f
-(define (disassembler/read-variable-cache block index)
- (let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form)))))
- (ucode-primitive
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply make-primitive-procedure (cdr form))))))
- ((ucode-primitive primitive-object-set-type 2)
- (ucode-type quad)
- (system-vector-ref block index))))
-
-(define (disassembler/read-procedure-cache block index)
- (fluid-let ((*block block))
- (let* ((offset (compiled-code-block/index->offset index))
- (opcode (fix:lsh (read-unsigned-integer offset 8) -2)))
- (case opcode
- ((#x08) ; LDIL
- ;; This should learn how to decode trampolines.
- (vector 'COMPILED
- (read-procedure offset)
- (read-unsigned-integer (+ offset 10) 16)))
- (else
- (error "disassembler/read-procedure-cache: Unknown opcode"
- opcode block index))))))
-
-(define (disassembler/instructions block start-offset end-offset symbol-table)
- (let loop ((offset start-offset) (state (disassembler/initial-state)))
- (if (and end-offset (< offset end-offset))
- (disassemble-one-instruction
- block offset symbol-table state
- (lambda (offset* instruction state)
- (make-instruction offset
- instruction
- (lambda () (loop offset* state)))))
- '())))
-
-(define (disassembler/instructions/null? obj)
- (null? obj))
-
-(define (disassembler/instructions/read instruction-stream receiver)
- (receiver (instruction-offset instruction-stream)
- (instruction-instruction instruction-stream)
- (instruction-next instruction-stream)))
-
-(define-structure (instruction (type vector))
- (offset false read-only true)
- (instruction false read-only true)
- (next false read-only true))
-
-(define *block)
-(define *current-offset)
-(define *symbol-table)
-(define *ir)
-(define *valid?)
-
-(define (disassemble-one-instruction block offset symbol-table state receiver)
- (fluid-let ((*block block)
- (*current-offset offset)
- (*symbol-table symbol-table)
- (*ir)
- (*valid? true))
- (set! *ir (get-longword))
- (let ((start-offset *current-offset))
- (if (external-label-marker? symbol-table offset state)
- (receiver start-offset
- (make-external-label *ir start-offset)
- 'INSTRUCTION)
- (let ((instruction (disassemble-word *ir)))
- (if (not *valid?)
- (let ((inst (make-word *ir)))
- (receiver start-offset
- inst
- (disassembler/next-state inst state)))
- (let ((next-state (disassembler/next-state instruction state)))
- (receiver
- *current-offset
- (if (and (pair? state)
- (eq? (car state) 'PC-REL-OFFSET))
- (pc-relative-inst offset instruction (cdr state))
- instruction)
- next-state))))))))
-\f
-(define-integrable *privilege-level* 3)
-
-(define (pc-relative-inst start-address instruction base-reg)
- (let ((opcode (car instruction)))
- (if (not (memq opcode '(LDO LDW)))
- instruction
- (let ((offset-exp (caddr instruction))
- (target (cadddr instruction)))
- (let ((offset (cadr offset-exp))
- (space-reg (caddr offset-exp))
- (base-reg* (cadddr offset-exp)))
- (if (not (= base-reg* base-reg))
- instruction
- (let* ((real-address
- (+ start-address
- (- offset *privilege-level*)
- #|
- (if (not left-side)
- 0
- (- (let ((val (* left-side #x800)))
- (if (>= val #x80000000)
- (- val #x100000000)
- val))
- 4))
- |#
- ))
- (label
- (disassembler/lookup-symbol *symbol-table real-address)))
- (if (not label)
- instruction
- `(,opcode () (OFFSET `(- ,label *PC*)
- #|
- ,(if left-side
- `(RIGHT (- ,label (- *PC* 4)))
- `(- ,label *PC*))
- |#
- ,space-reg
- ,base-reg)
- ,target)))))))))
-
-(define (disassembler/initial-state)
- 'INSTRUCTION-NEXT)
-
-(define (disassembler/next-state instruction state)
- (cond ((not disassembler/compiled-code-heuristics?)
- 'INSTRUCTION)
- ((and (eq? state 'INSTRUCTION)
- (eq? (list-ref instruction 0) 'BL)
- (equal? (list-ref instruction 3) '(@PCO 0)))
- (cons 'PC-REL-OFFSET (list-ref instruction 2)))
- ((memq (car instruction) '(B BV BLE))
- (if (memq 'N (cadr instruction))
- 'EXTERNAL-LABEL
- 'DELAY-SLOT))
- ((eq? state 'DELAY-SLOT)
- 'EXTERNAL-LABEL)
- (else
- 'INSTRUCTION)))
-\f
-(define (disassembler/lookup-symbol symbol-table offset)
- (and symbol-table
- (let ((label (dbg-labels/find-offset symbol-table offset)))
- (and label
- (dbg-label/name label)))))
-
-(define (external-label-marker? symbol-table offset state)
- (if symbol-table
- (let ((label (dbg-labels/find-offset symbol-table (+ offset 4))))
- (and label
- (dbg-label/external? label)))
- (and *block
- (eq? state 'EXTERNAL-LABEL)
- (let loop ((offset (+ offset 4)))
- (let* ((contents (read-bits (- offset 2) 16))
- (odd? (bit-string-clear! contents 0))
- (delta (* 2 (bit-string->unsigned-integer contents))))
- (if odd?
- (let ((offset (- offset delta)))
- (and (positive? offset)
- (loop offset)))
- (= offset delta)))))))
-
-(define (make-word bit-string)
- `(UWORD () ,(bit-string->unsigned-integer bit-string)))
-
-(define (make-external-label bit-string offset)
- `(EXTERNAL-LABEL ()
- ,(extract bit-string 16 32)
- ,(offset->pc-relative (* 4 (extract bit-string 1 16))
- offset)))
-
-(define (read-procedure offset)
- (define (bit-string-andc-bang x y)
- (bit-string-andc! x y)
- x)
-
- (define-integrable (low-21-bits offset)
- #|
- (bit-string->unsigned-integer
- (bit-string-andc-bang (read-bits offset 32)
- #*11111111111000000000000000000000))
- |#
- (fix:and (read-unsigned-integer (1+ offset) 24) #x1FFFFF))
-
- (define (assemble-21 val)
- (fix:or (fix:or (fix:lsh (fix:and val 1) 20)
- (fix:lsh (fix:and val #xffe) 8))
- (fix:or (fix:or (fix:lsh (fix:and val #xc000) -7)
- (fix:lsh (fix:and val #x1f0000) -14))
- (fix:lsh (fix:and val #x3000) -12))))
-
-
- (define (assemble-17 val)
- (fix:or (fix:or (fix:lsh (fix:and val 1) 16)
- (fix:lsh (fix:and val #x1f0000) -5))
- (fix:or (fix:lsh (fix:and val #x4) 8)
- (fix:lsh (fix:and val #x1ff8) -3))))
-
- (with-absolutely-no-interrupts
- (lambda ()
- (let* ((address
- (+ (* (assemble-21 (low-21-bits offset)) #x800)
- (fix:lsh (assemble-17 (low-21-bits (+ offset 4))) 2)))
- (bitstr (bit-string-andc-bang
- (unsigned-integer->bit-string 32 address)
- #*11111100000000000000000000000000)))
- (let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form)))))
- (ucode-primitive
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply make-primitive-procedure (cdr form))))))
- ((ucode-primitive primitive-object-set-type 2)
- (ucode-type compiled-entry)
- ((ucode-primitive make-non-pointer-object 1)
- (bit-string->unsigned-integer bitstr))))))))
-
-(define (read-unsigned-integer offset size)
- (bit-string->unsigned-integer (read-bits offset size)))
-
-(define (read-bits offset size-in-bits)
- (let ((word (bit-string-allocate size-in-bits))
- (bit-offset (* offset addressing-granularity)))
- (with-absolutely-no-interrupts
- (lambda ()
- (if *block
- (read-bits! *block bit-offset word)
- (read-bits! offset 0 word))))
- word))
-
-(define (invalid-instruction)
- (set! *valid? false)
- false)
-
-(define (offset->pc-relative pco reference-offset)
- (if (not disassembler/symbolize-output?)
- `(@PCO ,pco)
- ;; Only add 4 because it has already been bumped to the
- ;; next instruction.
- (let* ((absolute (+ pco (+ 4 reference-offset)))
- (label (disassembler/lookup-symbol *symbol-table absolute)))
- (if label
- `(@PCR ,label)
- `(@PCO ,pco)))))
-
-(define compiled-code-block/procedure-cache-offset 0)
-(define compiled-code-block/objects-per-procedure-cache 3)
-(define compiled-code-block/objects-per-variable-cache 1)
-
-;; global variable used by runtime/udata.scm -- Moby yuck!
-
-(set! compiled-code-block/bytes-per-object 4)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;; Spectrum Disassembler: Internals
-;;; package: (compiler disassembler)
-
-(declare (usual-integrations))
-\f
-;;;; Utilities
-
-(define (get-longword)
- (let ((word (read-bits *current-offset 32)))
- (set! *current-offset (+ *current-offset 4))
- word))
-
-(declare (integrate-operator extract))
-
-(define (extract bit-string start end)
- (declare (integrate bit-string start end))
- (bit-string->unsigned-integer (bit-substring bit-string start end)))
-
-#|
-(define disassembly '())
-
-(define (verify-instruction instruction)
- (let ((bits (car (syntax-instruction instruction))))
- (if (and (bit-string? bits)
- (= (bit-string-length bits) 32))
- (begin (set! disassembly (disassemble-word bits))
- (newline)
- (newline)
- (if (equal? instruction disassembly)
- (write "EQUAL")
- (write "************************* NOT EQUAL"))
- (newline)
- (newline)
- (write instruction)
- (newline)
- (newline)
- (write "Disassembly: ")
- (write disassembly)))))
-
-(define v verify-instruction)
-|#
-
-(define-integrable Mask-2-9 #b0011111111000000)
-(define-integrable Mask-2-16 #b0011111111111111)
-(define-integrable Mask-3-14 #b0001111111111100)
-(define-integrable Mask-3-10 #b0001111111100000)
-(define-integrable Mask-3-5 #b0001110000000000)
-(define-integrable Mask-4-10 #b0000111111100000)
-(define-integrable Mask-4-5 #b0000110000000000)
-(define-integrable Mask-6-9 #b0000001111000000)
-(define-integrable Mask-6-10 #b0000001111100000)
-(define-integrable Mask-11-15 #b0000000000011111)
-(define-integrable mask-copr #b0000000111000000)
-\f
-;;;; The disassembler proper
-
-(define (disassemble-word word)
- (let ((hi-halfword (extract word 16 32))
- (lo-halfword (extract word 0 16)))
- (let ((opcode (fix:quotient hi-halfword #x400)))
- ((case opcode
- ((#x00) sysctl-1)
- ((#x01) sysctl-2)
- ((#x02) arith&log)
- ((#x03) indexed-mem)
- ((#x04) #| SFUop |# unknown-major-opcode)
- ((#x05)
- (lambda (opcode hi lo)
- opcode hi lo ;ignore
- `(DIAG () ,(extract word 0 26))))
- ((#x08 #x0a) ldil&addil)
- ((#x09 #x0b) #| COPR-w and COPR-dw |# float-mem)
- ((#x0c) #| COPRop |# float-op)
- ((#x0d #x10 #x11 #x12 #x13) scalar-load)
- ((#x18 #x19 #x1a #x1b) scalar-store)
- ((#x20 #x21 #x22 #x23 #x28 #x29 #x2a #x2b #x30 #x31 #x32 #x33)
- cond-branch)
- ((#x24 #x25 #x2c #x2d) addi&subi)
- ((#x34 #x35) extr&dep)
- ((#x38 #x39) be&ble)
- ((#x3a) branch)
- (else unknown-major-opcode))
- opcode hi-halfword lo-halfword))))
-
-(define (unknown-major-opcode opcode hi lo)
- opcode hi lo ;ignore
- (invalid-instruction))
-\f
-(define (sysctl-1 opcode hi-halfword lo-halfword)
- ;; BREAK SYNC MFSP MFCTL MTSP MTCTL LDSID
- ;; Missing other system control:
- ;; MTSM, RSM, SSM, RFI.
- opcode ;ignore
- (let ((opcode-extn (fix:quotient (fix:and lo-halfword Mask-3-10) #x20)))
- (case opcode-extn
- ((#x00)
- (let ((immed-13-hi (fix:and hi-halfword 1023))
- (immed-13-lo (fix:quotient lo-halfword #x2000))
- (immed-5 (fix:and lo-halfword #x1f)))
- `(BREAK () ,immed-5 ,(+ (* immed-13-hi #x100) immed-13-lo))))
- ((#x20)
- `(SYNC ()))
- ((#x25)
- (let ((target-reg (fix:and hi-halfword #x1f))
- (space-reg (fix:quotient lo-halfword #x2000)))
- `(MFSP () ,space-reg ,target-reg)))
- ((#x45)
- (let ((ctl-reg (fix:quotient (fix:and Mask-6-10 hi-halfword)
- #x20))
- (target-reg (fix:and lo-halfword #x1f)))
- `(MFCTL () ,ctl-reg ,target-reg)))
- ((#xc1)
- (let ((source-reg hi-halfword)
- (space-reg (fix:quotient lo-halfword #x2000)))
- `(MTSP () ,source-reg ,space-reg)))
- ((#xc2)
- (let ((ctl-reg (fix:quotient (fix:and Mask-6-10 hi-halfword)
- #x20))
- (source-reg (fix:and hi-halfword #x1f)))
- `(MTCTL () ,source-reg ,ctl-reg)))
- ((#x85)
- (let ((base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword)
- #x20))
- (space-spec (fix:quotient lo-halfword #x4000))
- (target-reg (fix:and lo-halfword #x1f)))
- `(LDSID () (OFFSET ,space-spec ,base-reg)
- ,target-reg)))
- (else
- (invalid-instruction)))))
-\f
-(define (sysctl-2 opcode hi-halfword lo-halfword)
- ;; PROBER PROBERI PROBEW PROBEWI
- ;; Missing other system control:
- ;; LPA, LHA, PDTLB, PITLB, PDTLBE, PITLBE, IDTLBA, IITLBA,
- ;; IDTLBP, IITLBP, PDC, FDC, FIC, FDCE, FICE.
- opcode ;ignore
- (let ((opcode-extn (fix:quotient (fix:and lo-halfword Mask-2-9) #x40)))
- (let ((mnemonic (case opcode-extn
- ((#x46) 'PROBER)
- ((#xc6) 'PROBERI)
- ((#x47) 'PROBEW)
- ((#xc7) 'PROBEWI)
- (else (invalid-instruction))))
- (base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword)
- #x20))
- (priv-reg (fix:and hi-halfword #x1f))
- (space-spec (fix:quotient lo-halfword #x4000))
- (target-reg (fix:and lo-halfword #x1f)))
- `(,mnemonic () (OFFSET ,space-spec ,base-reg)
- ,priv-reg ,target-reg))))
-\f
-(define (arith&log opcode hi-halfword lo-halfword)
- opcode ;ignore
- (let ((opcode-extn (fix:quotient (fix:and Mask-4-10 lo-halfword) #x20)))
- (let ((source-reg-2 (fix:quotient (fix:and Mask-6-10 hi-halfword)
- #x20))
- (source-reg-1 (fix:and hi-halfword #x1f))
- (target-reg (fix:and lo-halfword #x1f))
- (completer (x-arith-log-completer lo-halfword opcode-extn))
- (mnemonic
- (case opcode-extn
- ((#x00) 'ANDCM)
- ((#x10) 'AND)
- ((#x12) 'OR)
- ((#x14) 'XOR)
- ((#x1c) 'UXOR)
- ((#x20) 'SUB)
- ((#x22) 'DS)
- ((#x26) 'SUBT)
- ((#x28) 'SUBB)
- ((#x30) 'ADD)
- ((#x32) 'SH1ADD)
- ((#x34) 'SH2ADD)
- ((#x36) 'SH3ADD)
- ((#x38) 'ADDC)
- ((#x44) 'COMCLR)
- ((#x4c) 'UADDCM)
- ((#x4e) 'UADDCMT)
- ((#x50) 'ADDL)
- ((#x52) 'SH1ADDL)
- ((#x54) 'SH2ADDL)
- ((#x56) 'SH3ADDL)
- ((#x5c) 'DCOR)
- ((#x5e) 'IDCOR)
- ((#x60) 'SUBO)
- ((#x66) 'SUBTO)
- ((#x68) 'SUBBO)
- ((#x70) 'ADDO)
- ((#x72) 'SH1ADDO)
- ((#x74) 'SH2ADDO)
- ((#x76) 'SH3ADDO)
- ((#x78) 'ADDCO)
- (else (invalid-instruction)))))
- (cond ((or (eq? mnemonic 'DCOR) (eq? mnemonic 'IDCOR))
- `(,mnemonic ,completer ,source-reg-2 ,target-reg))
- ((and (eq? mnemonic 'OR) (zero? source-reg-2))
- (if (and (zero? source-reg-1) (zero? target-reg))
- `(NOP ,completer)
- `(COPY ,completer ,source-reg-1 ,target-reg)))
- (else
- `(,mnemonic ,completer ,source-reg-1 ,source-reg-2
- ,target-reg))))))
-\f
-(define (indexed-mem opcode hi-halfword lo-halfword)
- ;; LDBX/S LDHX/S LDWX/S LDCWX/S STWS STHS STBS STBYS
- opcode ;ignore
- (let ((short-flag (fix:and lo-halfword #x1000)))
- (let ((base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword)
- #x20))
- (index-or-source (fix:and hi-halfword #x1f))
- (space-spec (fix:quotient lo-halfword #x4000))
- (opcode-extn (fix:quotient (fix:and lo-halfword Mask-6-9) #x40))
- (target-or-index (fix:and lo-halfword #x1f))
- (cc-print-completer (cc-completer lo-halfword))
- (um-print-completer (um-completer short-flag lo-halfword)))
- (let ((mnemonic
- (if (zero? short-flag)
- (case opcode-extn
- ((#x0) 'LDBX)
- ((#x1) 'LDHX)
- ((#x2) 'LDWX)
- ((#x7) 'LDCWX)
- (else (invalid-instruction)))
- (case opcode-extn
- ((#x0) 'LDBS)
- ((#x1) 'LDHS)
- ((#x2) 'LDWS)
- ((#x7) 'LDCWS)
- ((#x8) 'STBS)
- ((#x9) 'STHS)
- ((#xa) 'STWS)
- ((#xc) 'STBYS)
- (else (invalid-instruction))))))
- (if (< opcode-extn 8)
- `(,mnemonic (,@um-print-completer ,@cc-print-completer)
- (,(if (zero? short-flag) 'INDEX 'OFFSET)
- ,(if (zero? short-flag)
- index-or-source
- (X-Signed-5-Bit index-or-source))
- ,space-spec ,base-reg)
- ,target-or-index)
- `(,mnemonic (,@um-print-completer ,@cc-print-completer)
- ,index-or-source
- (,(if (zero? short-flag) 'INDEX 'OFFSET)
- ,(if (zero? short-flag)
- target-or-index
- (X-Signed-5-Bit target-or-index))
- ,space-spec ,base-reg)))))))
-\f
-(define (ldil&addil opcode hi-halfword lo-halfword)
- ;; LDIL ADDIL
- (let* ((reg (fix:quotient (fix:and Mask-6-10 hi-halfword) #x20))
- (hi-immed (fix:and hi-halfword #x1f))
- (immed (assemble-21 (+ (* hi-immed #x10000) lo-halfword))))
- `(,(if (= opcode #x08) 'LDIL 'ADDIL) () ,immed ,reg)))
-
-(define (float-mem opcode hi-halfword lo-halfword)
- ;; FLDWX/S FLDDX/S FSTWX/S FSTDX/S
- (let ((short-flag (fix:and lo-halfword #x1000))
- (index (fix:and hi-halfword #x1f)))
- (let ((base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword) #x20))
- (index (if (zero? short-flag)
- index
- (X-Signed-5-Bit index)))
- (space-spec (fix:quotient lo-halfword #x4000))
- (opcode-extn (fix:quotient (fix:and lo-halfword Mask-6-9) #x40))
- (source-or-target (fix:and lo-halfword #x1f))
- (cc-print-completer (cc-completer lo-halfword))
- (um-print-completer (um-completer short-flag lo-halfword)))
- (let ((mnemonic
- (if (zero? short-flag)
- (if (= opcode #x09)
- (if (= opcode-extn 0) 'FLDWX 'FSTWX)
- (if (= opcode-extn 0) 'FLDDX 'FSTDX))
- (if (= opcode #x09)
- (if (= opcode-extn 0) 'FLDWS 'FSTWS)
- (if (= opcode-extn 0) 'FLDDS 'FSTDS)))))
- (if (< opcode-extn 8)
- `(,mnemonic (,@um-print-completer ,@cc-print-completer)
- (,(if (zero? short-flag) 'INDEX 'OFFSET)
- ,index ,space-spec ,base-reg)
- ,source-or-target)
- `(,mnemonic (,@um-print-completer ,@cc-print-completer)
- ,source-or-target
- (,(if (zero? short-flag) 'INDEX 'OFFSET)
- ,index ,space-spec ,base-reg)))))))
-
-(define (scalar-load opcode hi-halfword lo-halfword)
- ;; LDO LDB LDH LDW LDWM
- (let ((base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword) #x20))
- (space-spec (fix:quotient lo-halfword #x4000))
- (target-reg (fix:and hi-halfword #x1f))
- (displacement (XRight2s (fix:and lo-halfword Mask-2-16)))
- (mnemonic
- (case opcode
- ((#x0d) 'LDO)
- ((#x10) 'LDB)
- ((#x11) 'LDH)
- ((#x12) 'LDW)
- ((#x13) 'LDWM)
- (else (invalid-instruction)))))
- (cond ((not (eq? mnemonic 'LDO))
- `(,mnemonic ()
- (OFFSET ,displacement ,space-spec ,base-reg)
- ,target-reg))
- ((zero? base-reg)
- `(LDI () ,displacement ,target-reg))
- (else
- `(,mnemonic ()
- (OFFSET ,displacement 0 ,base-reg)
- ,target-reg)))))
-\f
-(define (scalar-store opcode hi-halfword lo-halfword)
- ;; STB STH STW STWM
- (let ((base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword)
- #x20))
- (space-spec (fix:quotient lo-halfword #x4000))
- (source-reg (fix:and hi-halfword #x1f))
- (displacement (XRight2s (fix:and lo-halfword Mask-2-16)))
- (mnemonic
- (case opcode
- ((#x18) 'STB)
- ((#x19) 'STH)
- ((#x1a) 'STW)
- ((#x1b) 'STWM)
- (else (invalid-instruction)))))
- `(,mnemonic () ,source-reg
- (OFFSET ,displacement ,space-spec ,base-reg))))
-
-(define (cond-branch opcode hi-halfword lo-halfword)
- ;; MOVB MOVIB COMB COMIB ADDB ADDIB BVB BB
- (let* ((reg-2 (fix:quotient (fix:and Mask-6-10 hi-halfword) #x20))
- (reg-1 (if (and (not (= opcode #x31))
- (odd? opcode))
- ;; For odd opcodes, this is immed-5 data, not reg-1
- (X-Signed-5-Bit (fix:and hi-halfword #x1f))
- (fix:and hi-halfword #x1f)))
- (c (fix:quotient lo-halfword #x2000))
- (word-displacement (collect-14 lo-halfword))
- (null-completer (nullify-bit lo-halfword))
- (mnemonic (case opcode
- ((#x20) 'COMBT)
- ((#x21) 'COMIBT)
- ((#x22) 'COMBF)
- ((#x23) 'COMIBF)
- ((#x28) 'ADDBT)
- ((#x29) 'ADDIBT)
- ((#x2a) 'ADDBF)
- ((#x2b) 'ADDIBF)
- ((#x30) 'BVB)
- ((#x31) 'BB)
- ((#x32) 'MOVB)
- ((#x33) 'MOVIB)
- (else (invalid-instruction))))
- (completer-symbol
- (X-Extract-Deposit-Completers c)))
- (if (eq? mnemonic 'BVB)
- `(,mnemonic (,@completer-symbol ,@null-completer) ,reg-1
- ,word-displacement)
- `(,mnemonic (,@completer-symbol ,@null-completer) ,reg-1 ,reg-2
- ,word-displacement))))
-\f
-(define (addi&subi opcode hi-halfword lo-halfword)
- ;; ADDI-T-O SUBI-O COMICLR
- (let ((opcode-extn (fix:quotient (fix:and 2048 lo-halfword) #x800)))
- (let ((source-reg (fix:quotient (fix:and Mask-6-10 hi-halfword)
- #x20))
- (target-reg (fix:and hi-halfword #x1f))
- (immed-value (X-Signed-11-Bit (fix:and lo-halfword 2047)))
- (completer-symbol (x-arith-log-completer lo-halfword opcode))
- (mnemonic
- (if (= opcode-extn 0)
- (case opcode
- ((#x24) 'COMICLR)
- ((#x25) 'SUBI)
- ((#x2c) 'ADDIT)
- ((#x2d) 'ADDI)
- (else (invalid-instruction)))
- (case opcode
- ((#x25) 'SUBIO)
- ((#x2c) 'ADDITO)
- ((#x2d) 'ADDIO)
- (else (invalid-instruction))))))
- `(,mnemonic ,completer-symbol ,immed-value
- ,source-reg ,target-reg))))
-
-(define (extr&dep opcode hi-halfword lo-halfword)
- ;; VEXTRU VEXTRS VDEP ZVDEP
- (let* ((reg-2 (fix:quotient (fix:and Mask-6-10 hi-halfword) #x20))
- (reg-1 (fix:and hi-halfword #x1f))
- (c (fix:quotient lo-halfword #x2000))
- (opcode-extn (fix:quotient (fix:and lo-halfword Mask-3-5) #x400))
- (cp (fix:quotient (fix:and lo-halfword Mask-6-10) #x20))
- (clen (fix:and lo-halfword #x1f))
- (completer-symbol (X-Extract-Deposit-Completers c))
- (mnemonic
- (vector-ref (if (= opcode #x34)
- '#(VSHD *INVALID* SHD *INVALID*
- VEXTRU VEXTRS EXTRU EXTRS)
- '#(ZVDEP VDEP ZDEP DEP
- ZVDEPI VDEPI ZDEPI DEPI))
- opcode-extn)))
-
- (define (process reg-1 reg-2)
- (cond ((or (<= 4 opcode-extn 5)
- (and (= opcode #x35)
- (< opcode-extn 2)))
- ;; Variable dep/ext
- `(,mnemonic ,completer-symbol ,reg-1 ,(- 32 clen) ,reg-2))
- ((eq? mnemonic 'VSHD)
- `(,mnemonic ,completer-symbol ,reg-1 ,reg-2 ,clen))
- ((eq? mnemonic 'SHD)
- `(,mnemonic ,completer-symbol ,reg-1 ,reg-2 ,(- 31 cp) ,clen))
- (else
- `(,mnemonic ,completer-symbol
- ,reg-1
- ,(if (= opcode #x34) cp (- 31 cp))
- ,(- 32 clen) ,
- reg-2))))
-
- (cond ((eq? mnemonic '*INVALID*)
- (invalid-instruction))
- ((<= opcode-extn 3)
- (process reg-1 reg-2))
- ((= opcode #x34)
- (process reg-2 reg-1))
- (else
- (process (X-Signed-5-Bit reg-1) reg-2)))))
-\f
-(define (be&ble opcode hi-halfword lo-halfword)
- ;; BE BLE
- (let ((base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword) #x20))
- (space-reg (Assemble-3 (fix:quotient lo-halfword #x2000)))
- (null-completer (nullify-bit lo-halfword))
- (word-displacement (collect-19 lo-halfword hi-halfword false))
- (mnemonic (if (= opcode #x38) 'BE 'BLE)))
- `(,mnemonic ,null-completer
- (OFFSET ,word-displacement ,space-reg ,base-reg))))
-
-(define (branch opcode hi-halfword lo-halfword)
- ;; B, BL, BLR, BV, GATE
- opcode ;ignore
- (let ((opcode-extension (fix:quotient lo-halfword #x2000)))
- (case opcode-extension
- ((0 1)
- ;; B BL GATE
- (let ((return-reg (fix:quotient (fix:and Mask-6-10 hi-halfword)
- #x20))
- (word-displacement (collect-19 lo-halfword hi-halfword true))
- (null-completer (nullify-bit lo-halfword)))
- (let ((mnemonic (cond ((= opcode-extension 1) 'GATE)
- ((= return-reg 0) 'B)
- (else 'BL))))
- (if (eq? mnemonic 'B)
- `(,mnemonic ,null-completer ,word-displacement)
- `(,mnemonic ,null-completer ,return-reg ,word-displacement)))))
- ((2 6)
- ;; BLR BV
- (let ((return-reg (fix:quotient (fix:and Mask-6-10 hi-halfword)
- #x20))
- (offset-reg (fix:and hi-halfword #x1f))
- (null-completer (nullify-bit lo-halfword))
- (mnemonic (if (= opcode-extension 2)
- 'BLR
- 'BV)))
- `(,mnemonic ,null-completer ,offset-reg ,return-reg)))
- (else (invalid-instruction)))))
-\f
-;;;; FLoating point operations
-
-(define (float-op opcode hi-halfword lo-halfword)
- ;; Copr 0 is the floating point copr.
- opcode ;ignore
- (if (not (zero? (fix:and (fix:quotient lo-halfword #x40) 7)))
- (invalid-instruction)
- ((case (fix:and (fix:quotient lo-halfword #x200) 3)
- ((0) float-op0)
- ((1) float-op1)
- ((2) float-op2)
- (else float-op3))
- hi-halfword lo-halfword)))
-
-(define (float-op0 hi-halfword lo-halfword)
- (let ((mnemonic
- (vector-ref '#(COPR *INVALID* FCPY FABS FSQRT FRND
- *INVALID* *INVALID*)
- (fix:quotient lo-halfword #x2000)))
- (fmt (floating-format (fix:and (fix:quotient lo-halfword #x800) 3)))
- (r (fix:and (fix:quotient hi-halfword #x20) #x1f))
- (t (fix:and lo-halfword #x1f)))
- (if (eq? mnemonic '*INVALID*)
- (invalid-instruction)
- `(,mnemonic (,fmt) ,r ,t))))
-
-(define (float-op1 hi-halfword lo-halfword)
- (let ((mnemonic
- (vector-ref '#(FCNVFF FCNVXF FCNVFX FCNVFXT)
- (+ (* 2 (fix:and hi-halfword 1))
- (fix:quotient lo-halfword #x8000))))
- (sf (floating-format (fix:and (fix:quotient lo-halfword #x800) 3)))
- (df (floating-format (fix:and (fix:quotient lo-halfword #x2000) 3)))
- (r (fix:and (fix:quotient hi-halfword #x20) #x1f))
- (t (fix:and lo-halfword #x1f)))
- `(,mnemonic (,sf ,df) ,r ,t)))
-
-(define (float-op2 hi-halfword lo-halfword)
- (case (fix:quotient lo-halfword #x2000)
- ((0)
- (let ((fmt (floating-format (fix:and (fix:quotient lo-halfword #x800) 3)))
- (r1 (fix:and (fix:quotient hi-halfword #x20) #x1f))
- (r2 (fix:and hi-halfword #x1f))
- (c (float-completer (fix:and lo-halfword #x1f))))
- `(FCMP (,c ,fmt) ,r1 ,r2)))
- ((1)
- `(FTEST))
- (else
- (invalid-instruction))))
-
-(define (float-op3 hi-halfword lo-halfword)
- (let ((mnemonic
- (vector-ref '#(FADD FSUB FMPY FDIV FREM *INVALID* *INVALID* *INVALID*)
- (fix:quotient lo-halfword #x2000)))
- (fmt (floating-format (fix:and (fix:quotient lo-halfword #x800) 3)))
- (r1 (fix:and (fix:quotient hi-halfword #x20) #x1f))
- (r2 (fix:and hi-halfword #x1f))
- (t (fix:and lo-halfword #x1f)))
- (if (eq? mnemonic '*INVALID*)
- (invalid-instruction)
- `(,mnemonic (,fmt) ,r1 ,r2 ,t))))
-\f
-;;;; Field extraction
-
-(define (assemble-3 x)
- (let ((split (integer-divide x 2)))
- (+ (* (integer-divide-remainder split) 4)
- (integer-divide-quotient split))))
-
-(define (assemble-12 x y)
- (let ((split (integer-divide x 2)))
- (+ (* y #x800)
- (* (integer-divide-remainder split) #x400)
- (integer-divide-quotient split))))
-
-(define (assemble-17 x y z)
- (let ((split (integer-divide y 2)))
- (+ (* z #x10000)
- (* x #x800)
- (* (integer-divide-remainder split) #x400)
- (integer-divide-quotient split))))
-
-#|
-(define (assemble-21 x) ; Source Dest
- (+ (* (* (fix:and x 1) #x10000) #x10) ; bit 20 bit 0
- (* (fix:and x #xffe) #x100) ; bits 9-19 bits 1-11
- (fix:quotient (fix:and x #xc000) #x80) ; bits 5-6 bits 12-13
- (fix:quotient (fix:and x #x1f0000) #x4000) ; bits 0-4 bits 14-18
- (fix:quotient (fix:and x #x3000) #x1000))) ; bits 7-8 bits 19-20
-|#
-
-(define (assemble-21 x)
- (let ((b (unsigned-integer->bit-string 21 x)))
- (+ (* (extract b 0 1) #x100000)
- (* (extract b 1 12) #x200)
- (* (extract b 14 16) #x80)
- (* (extract b 16 21) #x4)
- (extract b 12 14))))
-
-(define (x-signed-5-bit x) ; Sign bit is lo.
- (let ((sign-bit (fix:and x 1))
- (hi-bits (fix:quotient x 2)))
- (if (= sign-bit 0)
- hi-bits
- (- hi-bits 16))))
-
-(define (x-signed-11-bit x) ; Sign bit is lo.
- (let ((sign-bit (fix:and x 1))
- (hi-bits (fix:quotient x 2)))
- (if (= sign-bit 0)
- hi-bits
- (- hi-bits #x400))))
-
-(define (xright2s d)
- (let ((sign-bit (fix:and d 1)))
- (- (fix:quotient d 2)
- (if (= sign-bit 0)
- 0
- #x2000))))
-
-(define-integrable (make-pc-relative value)
- (offset->pc-relative value *current-offset))
-
-(define (collect-14 lo-halfword)
- (let* ((sign (fix:and lo-halfword 1))
- (w (* 4 (assemble-12 (fix:quotient (fix:and lo-halfword #x1ffc) 4)
- sign))))
- (make-pc-relative (if (= sign 1)
- (- w #x4000) ; (expt 2 14)
- w))))
-
-(define (collect-19 lo-halfword hi-halfword pc-rel?)
- (let* ((sign (fix:and 1 lo-halfword))
- (w (* 4 (assemble-17 (fix:and Mask-11-15 hi-halfword)
- (fix:quotient (fix:and Mask-3-14 lo-halfword)
- 4)
- sign)))
- (disp (if (= sign 1)
- (- w #x80000) ; (expt 2 19)
- w)))
- (if pc-rel?
- (make-pc-relative disp)
- disp)))
-\f
-;;;; Completers (modifier suffixes)
-
-(define (x-arith-log-completer lo-halfword xtra)
- ;; c is 3-bit, f 1-bit
- (let ((c (fix:quotient lo-halfword #x2000))
- (f (fix:quotient (fix:and lo-halfword 4096) #x1000)))
- (let ((index (+ (* f 8) c)))
- (case xtra
- ((#x2c #x2d #x30 #x32 #x34 #x36 #x38 #x4c #x4e
- #x50 #x52 #x54 #x56 #x70 #x72 #x74 #x76 #x78)
- ;; adds: #x2c #x2d are ADDI
- (vector-ref
- '#(() (=) (<) (<=) (NUV) (ZNV) (SV) (OD)
- (TR) (<>) (>=) (>) (UV) (VNZ) (NSV) (EV))
- #|
- '#(() (Eq) (Lt) (LtEq) (NUV) (ZNV) (SV) (OD)
- (TR) (LtGt) (GtEq) (Gt) (UV) (VNZ) (NSV) (EV))
- |#
- index))
- ((#x20 #x22 #x24 #x25 #x26 #x28 #x44 #x60 #x66 #x68)
- ;; subtract/compare: #x24 #x25 are SUBI
- (vector-ref
- '#(() (=) (<) (<=) (<<) (<<=) (SV) (OD)
- (TR) (<>) (>=) (>) (>>=) (>>) (NSV) (EV))
- #|
- '#(() (Eq) (Lt) (LtEq) (LtLt) (LtLtEq) (SV) (OD)
- (TR) (LtGt) (GtEq) (Gt) (GtGtEq) (GtGt) (NSV) (EV))
- |#
- index))
- ((0 #x10 #x12 #x14 #x1c)
- ;; logical
- (vector-ref
- '#(() (=) (<) (<=) () () () (OD)
- (TR) (<>) (>=) (>) () () () (EV))
- #|
- '#(() (Eq) (Lt) (LtEq) () () () (OD)
- (TR) (LtGt) (GtEq) (Gt) () () () (EV))
- |#
- index))
- ((#x5c #x5e)
- ;; unit
- (vector-ref '#(() () (SBZ) (SHZ) (SDC) () (SBC) (SHC)
- (TR) () (NBZ) (NHZ) (NDC) () (NBC) (NHC))
- index))))))
-\f
-(define (X-Extract-Deposit-Completers c)
- (vector-ref '#(() (=) (<) (OD) (TR) (<>) (>=) (EV))
- #| '#(() (Eq) (Lt) (OD) (TR) (LtGt) (GtEq) (EV)) |#
- c))
-
-(define (cc-completer lo-halfword)
- (vector-ref '#(() (C) (Q) (P))
- (fix:quotient (fix:and lo-halfword Mask-4-5) #x400)))
-
-(define (um-completer short-flag lo-halfword)
- (let ((u-completer (fix:and lo-halfword #x2000))
- (m-completer (fix:and lo-halfword #x20)))
- (if (zero? short-flag)
- (if (zero? u-completer)
- (if (zero? m-completer) '() '(M))
- (if (zero? m-completer) '(S) '(SM)))
- (if (zero? m-completer)
- '()
- (if (zero? u-completer) '(MA) '(MB))))))
-
-(define-integrable (nullify-bit lo-halfword)
- (if (= (fix:and lo-halfword 2) 2) '(N) '()))
-
-(define-integrable (floating-format value)
- (vector-ref '#(SGL DBL FMT=2 QUAD) value))
-
-(define-integrable (float-completer value)
- (vector-ref '#(false? false ? !<=> = =T ?= !<> !?>= < ?< !>= !?> <= ?<= !>
- !?<= > ?> !<= !?< >= ?>= !< !?= <> != !=T !? <=> true? true)
- value))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Compiler File Dependencies
-;;; package: (compiler declarations)
-
-(declare (usual-integrations))
-\f
-(define (initialize-package!)
- (add-event-receiver! event:after-restore reset-source-nodes!)
- (reset-source-nodes!))
-
-(define (reset-source-nodes!)
- (set! source-filenames '())
- (set! source-hash)
- (set! source-nodes)
- (set! source-nodes/by-rank)
- unspecific)
-
-(define (maybe-setup-source-nodes!)
- (if (null? source-filenames)
- (setup-source-nodes!)))
-
-(define (setup-source-nodes!)
- (let ((filenames
- (append-map!
- (lambda (subdirectory)
- (map (lambda (pathname)
- (string-append subdirectory
- "/"
- (pathname-name pathname)))
- (directory-read
- (string-append subdirectory
- "/"
- source-file-expression))))
- '("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt"
- "machines/spectrum"))))
- (if (null? filenames)
- (error "Can't find source files of compiler"))
- (set! source-filenames filenames))
- (set! source-hash (make-string-hash-table))
- (set! source-nodes
- (map (lambda (filename)
- (let ((node (make/source-node filename)))
- (hash-table/put! source-hash filename node)
- node))
- source-filenames))
- (initialize/syntax-dependencies!)
- (initialize/integration-dependencies!)
- (source-nodes/rank!))
-
-(define source-file-expression "*.scm")
-(define source-filenames)
-(define source-hash)
-(define source-nodes)
-(define source-nodes/by-rank)
-
-(define (filename/append directory . names)
- (map (lambda (name) (string-append directory "/" name)) names))
-\f
-(define-structure (source-node
- (conc-name source-node/)
- (constructor %make/source-node (filename pathname)))
- (filename #f read-only #t)
- (pathname #f read-only #t)
- (forward-links '())
- (backward-links '())
- (forward-closure '())
- (backward-closure '())
- (dependencies '())
- (dependents '())
- (rank #f)
- (syntax-table #f)
- (declarations '())
- (modification-time #f))
-
-(define (make/source-node filename)
- (%make/source-node filename (->pathname filename)))
-
-(define (filename->source-node filename)
- (let ((node (hash-table/get source-hash filename #f)))
- (if (not node)
- (error "Unknown source file:" filename))
- node))
-
-(define (source-node/circular? node)
- (memq node (source-node/backward-closure node)))
-
-(define (source-node/link! node dependency)
- (if (not (memq dependency (source-node/backward-links node)))
- (begin
- (set-source-node/backward-links!
- node
- (cons dependency (source-node/backward-links node)))
- (set-source-node/forward-links!
- dependency
- (cons node (source-node/forward-links dependency)))
- (source-node/close! node dependency))))
-
-(define (source-node/close! node dependency)
- (if (not (memq dependency (source-node/backward-closure node)))
- (begin
- (set-source-node/backward-closure!
- node
- (cons dependency (source-node/backward-closure node)))
- (set-source-node/forward-closure!
- dependency
- (cons node (source-node/forward-closure dependency)))
- (for-each (lambda (dependency)
- (source-node/close! node dependency))
- (source-node/backward-closure dependency))
- (for-each (lambda (node)
- (source-node/close! node dependency))
- (source-node/forward-closure node)))))
-\f
-;;;; Rank
-
-(define (source-nodes/rank!)
- (compute-dependencies! source-nodes)
- (compute-ranks! source-nodes)
- (set! source-nodes/by-rank (source-nodes/sort-by-rank source-nodes))
- unspecific)
-
-(define (compute-dependencies! nodes)
- (for-each (lambda (node)
- (set-source-node/dependencies!
- node
- (list-transform-negative (source-node/backward-closure node)
- (lambda (node*)
- (memq node (source-node/backward-closure node*)))))
- (set-source-node/dependents!
- node
- (list-transform-negative (source-node/forward-closure node)
- (lambda (node*)
- (memq node (source-node/forward-closure node*))))))
- nodes))
-
-(define (compute-ranks! nodes)
- (let loop ((nodes nodes) (unranked-nodes '()))
- (if (null? nodes)
- (if (not (null? unranked-nodes))
- (loop unranked-nodes '()))
- (loop (cdr nodes)
- (let ((node (car nodes)))
- (let ((rank (source-node/rank* node)))
- (if rank
- (begin
- (set-source-node/rank! node rank)
- unranked-nodes)
- (cons node unranked-nodes))))))))
-
-(define (source-node/rank* node)
- (let loop ((nodes (source-node/dependencies node)) (rank -1))
- (if (null? nodes)
- (1+ rank)
- (let ((rank* (source-node/rank (car nodes))))
- (and rank*
- (loop (cdr nodes) (max rank rank*)))))))
-
-(define (source-nodes/sort-by-rank nodes)
- (sort nodes (lambda (x y) (< (source-node/rank x) (source-node/rank y)))))
-\f
-;;;; File Syntaxer
-
-(define (syntax-files!)
- (maybe-setup-source-nodes!)
- (for-each
- (lambda (node)
- (let ((modification-time
- (let ((source (modification-time node "scm"))
- (binary (modification-time node "bin")))
- (if (not source)
- (error "Missing source file" (source-node/filename node)))
- (and binary (< source binary) binary))))
- (set-source-node/modification-time! node modification-time)
- (if (not modification-time)
- (begin (write-string "\nSource file newer than binary: ")
- (write (source-node/filename node))))))
- source-nodes)
- (if compiler:enable-integration-declarations?
- (begin
- (for-each
- (lambda (node)
- (let ((time (source-node/modification-time node)))
- (if (and time
- (there-exists? (source-node/dependencies node)
- (lambda (node*)
- (let ((newer?
- (let ((time*
- (source-node/modification-time node*)))
- (or (not time*)
- (> time* time)))))
- (if newer?
- (begin
- (write-string "\nBinary file ")
- (write (source-node/filename node))
- (write-string " newer than dependency ")
- (write (source-node/filename node*))))
- newer?))))
- (set-source-node/modification-time! node #f))))
- source-nodes)
- (for-each
- (lambda (node)
- (if (not (source-node/modification-time node))
- (for-each (lambda (node*)
- (if (source-node/modification-time node*)
- (begin
- (write-string "\nBinary file ")
- (write (source-node/filename node*))
- (write-string " depends on ")
- (write (source-node/filename node))))
- (set-source-node/modification-time! node* #f))
- (source-node/forward-closure node))))
- source-nodes)))
- (for-each (lambda (node)
- (if (not (source-node/modification-time node))
- (pathname-delete!
- (pathname-new-type (source-node/pathname node) "ext"))))
- source-nodes/by-rank)
- (write-string "\n\nBegin pass 1:")
- (for-each (lambda (node)
- (if (not (source-node/modification-time node))
- (source-node/syntax! node)))
- source-nodes/by-rank)
- (if (there-exists? source-nodes/by-rank
- (lambda (node)
- (and (not (source-node/modification-time node))
- (source-node/circular? node))))
- (begin
- (write-string "\n\nBegin pass 2:")
- (for-each (lambda (node)
- (if (not (source-node/modification-time node))
- (if (source-node/circular? node)
- (source-node/syntax! node)
- (source-node/touch! node))))
- source-nodes/by-rank))))
-\f
-(define (source-node/touch! node)
- (with-values
- (lambda ()
- (sf/pathname-defaulting (source-node/pathname node) "" #f))
- (lambda (input-pathname bin-pathname spec-pathname)
- input-pathname
- (pathname-touch! bin-pathname)
- (pathname-touch! (pathname-new-type bin-pathname "ext"))
- (if spec-pathname (pathname-touch! spec-pathname)))))
-
-(define (pathname-touch! pathname)
- (if (file-exists? pathname)
- (begin
- (write-string "\nTouch file: ")
- (write (enough-namestring pathname))
- (file-touch pathname))))
-
-(define (pathname-delete! pathname)
- (if (file-exists? pathname)
- (begin
- (write-string "\nDelete file: ")
- (write (enough-namestring pathname))
- (delete-file pathname))))
-
-(define (sc filename)
- (maybe-setup-source-nodes!)
- (source-node/syntax! (filename->source-node filename)))
-
-(define (source-node/syntax! node)
- (with-values
- (lambda ()
- (sf/pathname-defaulting (source-node/pathname node) "" #f))
- (lambda (input-pathname bin-pathname spec-pathname)
- (sf/internal
- input-pathname bin-pathname spec-pathname
- (source-node/syntax-table node)
- ((if compiler:enable-integration-declarations?
- identity-procedure
- (lambda (declarations)
- (list-transform-negative declarations
- integration-declaration?)))
- (source-node/declarations node))))))
-
-(define-integrable (modification-time node type)
- (file-modification-time
- (pathname-new-type (source-node/pathname node) type)))
-\f
-;;;; Syntax dependencies
-
-(define (initialize/syntax-dependencies!)
- (let ((file-dependency/syntax/join
- (lambda (filenames syntax-table)
- (for-each (lambda (filename)
- (set-source-node/syntax-table!
- (filename->source-node filename)
- syntax-table))
- filenames))))
- (file-dependency/syntax/join
- (append (filename/append "base"
- "toplev" "asstop" "crstop"
- "blocks" "cfg1" "cfg2" "cfg3" "constr"
- "contin" "ctypes" "debug" "enumer"
- "infnew" "lvalue" "object" "pmerly" "proced"
- "refctx" "rvalue" "scode" "sets" "subprb"
- "switch" "utils")
- (filename/append "back"
- "asmmac" "bittop" "bitutl" "insseq" "lapgn1"
- "lapgn2" "lapgn3" "linear" "regmap" "symtab"
- "syntax")
- (filename/append "machines/spectrum"
- "dassm1" "insmac" "lapopt" "machin" "rgspcm"
- "rulrew")
- (filename/append "fggen"
- "declar" "fggen" "canon")
- (filename/append "fgopt"
- "blktyp" "closan" "conect" "contan" "delint"
- "desenv" "envopt" "folcon" "offset" "operan"
- "order" "outer" "param" "reord" "reteqv" "reuse"
- "sideff" "simapp" "simple" "subfre" "varind")
- (filename/append "rtlbase"
- "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp"
- "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2"
- "valclass")
- (filename/append "rtlgen"
- "fndblk" "fndvar" "opncod" "rgcomb" "rgproc"
- "rgretn" "rgrval" "rgstmt" "rtlgen")
- (filename/append "rtlopt"
- "ralloc" "rcompr" "rcse1" "rcse2" "rcseep"
- "rcseht" "rcserq" "rcsesr" "rdebug" "rdflow"
- "rerite" "rinvex" "rlife" "rtlcsm"))
- (->environment '(COMPILER)))
- (file-dependency/syntax/join
- (filename/append "machines/spectrum"
- "lapgen"
- "rules1" "rules2" "rules3" "rules4" "rulfix" "rulflo"
- "instr1" "instr2" "instr3")
- (->environment '(COMPILER LAP-SYNTAXER)))))
-\f
-;;;; Integration Dependencies
-
-(define (initialize/integration-dependencies!)
- (define (add-declaration! declaration filenames)
- (for-each (lambda (filenames)
- (let ((node (filename->source-node filenames)))
- (set-source-node/declarations!
- node
- (cons declaration
- (source-node/declarations node)))))
- filenames))
-
- (let* ((front-end-base
- (filename/append "base"
- "blocks" "cfg1" "cfg2" "cfg3"
- "contin" "ctypes" "enumer" "lvalue"
- "object" "proced" "rvalue"
- "scode" "subprb" "utils"))
- (spectrum-base
- (append (filename/append "machines/spectrum" "machin")
- (filename/append "back" "asutl")))
- (rtl-base
- (filename/append "rtlbase"
- "rgraph" "rtlcfg" "rtlobj" "rtlreg" "rtlty1"
- "rtlty2"))
- (cse-base
- (filename/append "rtlopt"
- "rcse1" "rcseht" "rcserq" "rcsesr"))
- (cse-all
- (append (filename/append "rtlopt"
- "rcse2" "rcseep")
- cse-base))
- (instruction-base
- (filename/append "machines/spectrum" "assmd" "machin"))
- (lapgen-base
- (append (filename/append "back" "linear" "regmap")
- (filename/append "machines/spectrum" "lapgen")))
- (assembler-base
- (append (filename/append "back" "symtab")
- (filename/append "machines/spectrum" "instr1")))
- (lapgen-body
- (append
- (filename/append "back" "lapgn1" "lapgn2" "syntax")
- (filename/append "machines/spectrum"
- "rules1" "rules2" "rules3" "rules4"
- "rulfix" "rulflo")))
- (assembler-body
- (append
- (filename/append "back" "bittop")
- (filename/append "machines/spectrum"
- "instr1" "instr2" "instr3"))))
-
- (define (file-dependency/integration/join filenames dependencies)
- (for-each (lambda (filename)
- (file-dependency/integration/make filename dependencies))
- filenames))
-
- (define (file-dependency/integration/make filename dependencies)
- (let ((node (filename->source-node filename)))
- (for-each (lambda (dependency)
- (let ((node* (filename->source-node dependency)))
- (if (not (eq? node node*))
- (source-node/link! node node*))))
- dependencies)))
-
- (define (define-integration-dependencies directory name directory* . names)
- (file-dependency/integration/make
- (string-append directory "/" name)
- (apply filename/append directory* names)))
-
- (define-integration-dependencies "machines/spectrum" "machin" "back" "asutl")
- (define-integration-dependencies "base" "object" "base" "enumer")
- (define-integration-dependencies "base" "enumer" "base" "object")
- (define-integration-dependencies "base" "utils" "base" "scode")
- (define-integration-dependencies "base" "cfg1" "base" "object")
- (define-integration-dependencies "base" "cfg2" "base"
- "cfg1" "cfg3" "object")
- (define-integration-dependencies "base" "cfg3" "base" "cfg1" "cfg2")
- (define-integration-dependencies "base" "ctypes" "base"
- "blocks" "cfg1" "cfg2" "cfg3" "contin" "lvalue" "object" "subprb")
- (define-integration-dependencies "base" "rvalue" "base"
- "blocks" "cfg1" "cfg2" "cfg3" "enumer" "lvalue" "object" "utils")
- (define-integration-dependencies "base" "lvalue" "base"
- "blocks" "object" "proced" "rvalue" "utils")
- (define-integration-dependencies "base" "blocks" "base"
- "enumer" "lvalue" "object" "proced" "rvalue" "scode")
- (define-integration-dependencies "base" "proced" "base"
- "blocks" "cfg1" "cfg2" "cfg3" "contin" "enumer" "lvalue" "object"
- "rvalue" "utils")
- (define-integration-dependencies "base" "contin" "base"
- "blocks" "cfg3" "ctypes")
- (define-integration-dependencies "base" "subprb" "base"
- "cfg3" "contin" "enumer" "object" "proced")
-
- (define-integration-dependencies "machines/spectrum" "machin" "rtlbase"
- "rtlreg" "rtlty1" "rtlty2")
-
- (define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2")
- (define-integration-dependencies "rtlbase" "rgraph" "machines/spectrum"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlcfg" "base"
- "cfg1" "cfg2" "cfg3")
- (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils")
- (define-integration-dependencies "rtlbase" "rtlcon" "machines/spectrum"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlexp" "rtlbase"
- "rtlreg" "rtlty1")
- (define-integration-dependencies "rtlbase" "rtline" "base" "cfg1" "cfg2")
- (define-integration-dependencies "rtlbase" "rtline" "rtlbase"
- "rtlcfg" "rtlty2")
- (define-integration-dependencies "rtlbase" "rtlobj" "base"
- "cfg1" "object" "utils")
- (define-integration-dependencies "rtlbase" "rtlreg" "machines/spectrum"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlreg" "rtlbase"
- "rgraph" "rtlty1")
- (define-integration-dependencies "rtlbase" "rtlty1" "rtlbase" "rtlcfg")
- (define-integration-dependencies "rtlbase" "rtlty2" "base" "scode")
- (define-integration-dependencies "rtlbase" "rtlty2" "machines/spectrum"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlty2" "rtlbase" "rtlty1")
-
- (file-dependency/integration/join
- (append
- (filename/append "base" "refctx")
- (filename/append "fggen"
- "declar" "fggen") ; "canon" needs no integrations
- (filename/append "fgopt"
- "blktyp" "closan" "conect" "contan" "delint" "desenv"
- "envopt" "folcon" "offset" "operan" "order" "param"
- "outer" "reuse" "reteqv" "sideff" "simapp" "simple"
- "subfre" "varind"))
- (append spectrum-base front-end-base))
-
- (define-integration-dependencies "fgopt" "reuse" "fgopt" "reord")
-
- (file-dependency/integration/join
- (filename/append "rtlgen"
- "fndblk" "fndvar" "opncod" "rgcomb" "rgproc" "rgretn"
- "rgrval" "rgstmt" "rtlgen")
- (append spectrum-base front-end-base rtl-base))
-
- (file-dependency/integration/join
- (append cse-all
- (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow"
- "rerite" "rinvex" "rlife" "rtlcsm")
- (filename/append "machines/spectrum" "rulrew"))
- (append spectrum-base rtl-base))
-
- (file-dependency/integration/join cse-all cse-base)
-
- (file-dependency/integration/join
- (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife")
- (filename/append "rtlbase" "regset"))
-
- (file-dependency/integration/join
- (filename/append "rtlopt" "rcseht" "rcserq")
- (filename/append "base" "object"))
-
- (define-integration-dependencies "rtlopt" "rlife" "base" "cfg2")
-
- (let ((dependents
- (append instruction-base
- lapgen-base
- lapgen-body
- assembler-base
- assembler-body
- (filename/append "back" "linear" "syerly"))))
- (add-declaration! '(USUAL-DEFINITION (SET EXPT)) dependents)
- (file-dependency/integration/join dependents instruction-base))
-
- (file-dependency/integration/join (append lapgen-base lapgen-body)
- lapgen-base)
-
- (file-dependency/integration/join (append assembler-base assembler-body)
- assembler-base)
-
- (define-integration-dependencies "back" "lapgn1" "base"
- "cfg1" "cfg2" "utils")
- (define-integration-dependencies "back" "lapgn1" "rtlbase"
- "rgraph" "rtlcfg")
- (define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg")
- (define-integration-dependencies "back" "linear" "base" "cfg1" "cfg2")
- (define-integration-dependencies "back" "linear" "rtlbase" "rtlcfg")
- (define-integration-dependencies "back" "mermap" "back" "regmap")
- (define-integration-dependencies "back" "regmap" "base" "utils")
- (define-integration-dependencies "back" "symtab" "base" "utils"))
-
- (for-each (lambda (node)
- (let ((links (source-node/backward-links node)))
- (if (not (null? links))
- (set-source-node/declarations!
- node
- (cons (make-integration-declaration
- (source-node/pathname node)
- (map source-node/pathname links))
- (source-node/declarations node))))))
- source-nodes))
-
-(define (make-integration-declaration pathname integration-dependencies)
- `(INTEGRATE-EXTERNAL
- ,@(map (let ((default
- (make-pathname
- #f
- #f
- (cons 'RELATIVE
- (make-list
- (length (cdr (pathname-directory pathname)))
- 'UP))
- #f
- #f
- #f)))
- (lambda (pathname)
- (merge-pathnames pathname default)))
- integration-dependencies)))
-
-(define-integrable (integration-declaration? declaration)
- (eq? (car declaration) 'INTEGRATE-EXTERNAL))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;; Spectrum Instruction Set Macros. Early version
-;;; NOPs for now.
-
-(declare (usual-integrations))
-
-(define-syntax define-instruction
- (non-hygienic-macro-transformer
- (lambda (opcode . patterns)
- `(SET! EARLY-INSTRUCTIONS
- (CONS
- (LIST ',opcode
- ,@(map (lambda (pattern)
- `(early-parse-rule
- ',(car pattern)
- (lambda (pat vars)
- (early-make-rule
- pat
- vars
- (scode-quote
- (instruction->instruction-sequence
- ,(parse-instruction (cadr pattern)
- (cddr pattern)
- #t)))))))
- patterns))
- EARLY-INSTRUCTIONS)))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Spectrum Instruction Set Macros
-
-(declare (usual-integrations))
-\f
-;;;; Definition macros
-
-(define-syntax define-symbol-transformer
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (if (syntax-match? '(IDENTIFIER * SYMBOL) (cdr form))
- `(DEFINE-INTEGRABLE (,(cadr form) SYMBOL)
- (LET ((PLACE (ASSQ SYMBOL ',(cddr form))))
- (IF (PAIR? PLACE)
- (CDR PLACE)
- #F)))
- (ill-formed-syntax form)))))
-
-(define-syntax define-transformer
- (rsc-macro-transformer
- (lambda (form environment)
- `(,(close-syntax 'DEFINE environment) ,@(cdr form)))))
-\f
-;;;; Fixed width instruction parsing
-
-(define (parse-instruction first-word tail early? environment)
- (if (not (null? tail))
- (error "Unknown format:" (cons first-word tail)))
- (case (car first-word)
- ((LONG) (process-fields (cdr first-word) early? environment))
- ((VARIABLE-WIDTH) (process-variable-width first-word early? environment))
- (else (error "Unknown format:" first-word))))
-
-(define (process-variable-width descriptor early? environment)
- (let ((binding (cadr descriptor))
- (clauses (cddr descriptor)))
- `(,(close-syntax 'LIST environment)
- ,(variable-width-expression-syntaxer
- (car binding) ; name
- (cadr binding) ; expression
- environment
- (map (lambda (clause)
- (call-with-values
- (lambda ()
- (expand-fields (cdadr clause) early? environment))
- (lambda (code size)
- (if (not (zero? (remainder size 32)))
- (error "Bad clause size:" size))
- `((,(close-syntax 'LIST environment)
- ,(optimize-group-syntax code early? environment))
- ,size
- ,@(car clause)))))
- clauses)))))
-
-(define (process-fields fields early? environment)
- (call-with-values (lambda () (expand-fields fields early? environment))
- (lambda (code size)
- (if (not (zero? (remainder size 32)))
- (error "Bad syllable size:" size))
- `(,(close-syntax 'LIST environment)
- ,(optimize-group-syntax code early? environment)))))
-
-(define (expand-fields fields early? environment)
- (let expand ((first-word '()) (word-size 0) (fields fields))
- (if (pair? fields)
- (call-with-values
- (lambda () (expand-field (car fields) early? environment))
- (lambda (car-field car-size)
- (if (and (eq? endianness 'LITTLE)
- (= 32 (+ word-size car-size)))
- (call-with-values (lambda () (expand '() 0 (cdr fields)))
- (lambda (tail tail-size)
- (values (append (cons car-field first-word) tail)
- (+ car-size tail-size))))
- (call-with-values
- (lambda ()
- (expand (cons car-field first-word)
- (+ car-size word-size)
- (cdr fields)))
- (lambda (tail tail-size)
- (values (if (or (zero? car-size)
- (not (eq? endianness 'LITTLE)))
- (cons car-field tail)
- tail)
- (+ car-size tail-size)))))))
- (values '() 0))))
-
-(define (expand-field field early? environment)
- early? ; ignored for now
- (let ((size (car field))
- (expression (cadr field)))
-
- (define (default type)
- (values (integer-syntaxer expression environment type size)
- size))
-
- (if (pair? (cddr field))
- (case (caddr field)
- ((PC-REL)
- (values (integer-syntaxer ``(,',(close-syntax '- environment)
- ,,expression
- (,',(close-syntax '+ environment)
- ,',(close-syntax '*PC* environment)
- 8))
- environment
- (cadddr field)
- size)
- size))
- ((BLOCK-OFFSET)
- (values `(,(close-syntax 'LIST environment)
- 'BLOCK-OFFSET
- ,expression)
- size))
- (else
- (default (caddr field))))
- (default 'UNSIGNED))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; HP Spectrum instruction utilities
-;;; Originally from Walt Hill, who did the hard part.
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-(define-transformer complx
- (lambda (completer)
- (vector (encode-S/SM completer)
- (cc-val completer)
- (m-val completer))))
-
-(define-transformer compls
- (lambda (completer)
- (vector (encode-MB completer)
- (cc-val completer)
- (m-val completer))))
-
-(define-transformer compledb
- (lambda (completer)
- (cons (encode-n completer)
- (extract-deposit-condition completer))))
-
-(define-transformer compled
- (lambda (completer)
- (extract-deposit-condition completer)))
-
-(define-transformer complalb
- (lambda (completer)
- (cons (encode-n completer)
- (arith-log-condition completer))))
-
-(define-transformer complaltfb
- (lambda (completer)
- (list (encode-n completer)
- (let ((val (arith-log-condition completer)))
- (if (not (zero? (cadr val)))
- (error "complaltfb: Bad completer" completer)
- (car val))))))
-
-(define-transformer complal
- (lambda (completer)
- (arith-log-condition completer)))
-
-(define-transformer complaltf
- (lambda (completer)
- (let ((val (arith-log-condition completer)))
- (if (not (zero? (cadr val)))
- (error "complaltf: Bad completer" completer)
- val))))
-
-(define-transformer fpformat
- (lambda (completer)
- (encode-fpformat completer)))
-
-(define-transformer fpcond
- (lambda (completer)
- (encode-fpcond completer)))
-
-(define-transformer sr3
- (lambda (value)
- (let ((place (assq value '((0 . 0) (1 . 2) (2 . 4) (3 . 6)
- (4 . 1) (5 . 3) (6 . 5) (7 . 7)))))
- (if place
- (cdr place)
- (error "sr3: Invalid space register descriptor" value)))))
-\f
-;;;; Utilities
-
-(define-integrable (branch-extend-pco disp nullify?)
- (if (and (= nullify? 1)
- (negative? disp))
- 4
- 0))
-
-(define-integrable (branch-extend-nullify disp nullify?)
- (if (and (= nullify? 1)
- (not (negative? disp)))
- 1
- 0))
-
-(define-integrable (branch-extend-disp disp)
- (- disp 4))
-
-(define-integrable (branch-extend-edcc cc)
- (remainder (+ cc 4) 8))
-
-(define-integrable (encode-N completers)
- (if (memq 'N completers)
- 1
- 0))
-
-(define-integrable (encode-S/SM completers)
- (if (or (memq 'S completers) (memq 'SM completers))
- 1
- 0))
-
-(define-integrable (encode-MB completers)
- (if (memq 'MB completers)
- 1
- 0))
-
-(define-integrable (m-val compl-list)
- (if (or (memq 'M compl-list)
- (memq 'SM compl-list)
- (memq 'MA compl-list)
- (memq 'MB compl-list))
- 1
- 0))
-
-(define-integrable (cc-val compl-list)
- (cond ((memq 'P compl-list) 3)
- ((memq 'Q compl-list) 2)
- ((memq 'C compl-list) 1)
- (else 0)))
-
-(define (extract-deposit-condition compl)
- (cond ((or (null? compl) (memq 'NV compl)) 0)
- ((or (memq 'EQ compl) (memq '= compl)) 1)
- ((or (memq 'LT compl) (memq '< compl)) 2)
- ((memq 'OD compl) 3)
- ((memq 'TR compl) 4)
- ((or (memq 'LTGT compl) (memq '<> compl)) 5)
- ((or (memq 'GTEQ compl) (memq '>= compl)) 6)
- ((memq 'EV compl) 7)
- (else
- ;; This should really error out, but it's hard to
- ;; arrange given that the compl includes other
- ;; fields.
- 0)))
-
-(define-integrable (encode-fpformat compl)
- (case compl
- ((DBL) 1)
- ((SGL) 0)
- ((QUAD) 3)
- (else
- (error "Missing Floating Point Format" compl))))
-\f
-(define-integrable (encode-fpcond fpcond)
- (let ((place (assq fpcond float-condition-table)))
- (if place
- (cadr place)
- (error "encode-fpcond: Unknown condition" fpcond))))
-
-(define float-condition-table
- '((false? 0)
- (false 1)
- (? 2)
- (!<=> 3)
- (= 4)
- (=T 5)
- (?= 6)
- (!<> 7)
- (!?>= 8)
- (< 9)
- (?< 10)
- (!>= 11)
- (!?> 12)
- (<= 13)
- (?<= 14)
- (!> 15)
- (!?<= 16)
- (> 17)
- (?> 18)
- (!<= 19)
- (!?< 20)
- (>= 21)
- (?>= 22)
- (!< 23)
- (!?= 24)
- (<> 25)
- (!= 26)
- (!=T 27)
- (!? 28)
- (<=> 29)
- (true? 30)
- (true 31)))
-\f
-(define (arith-log-condition compl-list)
- ;; Returns (c f)
- (let loop ((compl-list compl-list))
- (if (null? compl-list)
- '(0 0)
- (let ((val (assq (car compl-list) arith-log-condition-table)))
- (if val
- (cadr val)
- (loop (cdr compl-list)))))))
-
-(define arith-log-condition-table
- '((NV (0 0))
- (EQ (1 0))
- (= (1 0))
- (LT (2 0))
- (< (2 0))
- (SBZ (2 0))
- (LTEQ (3 0))
- (<= (3 0))
- (SHZ (3 0))
- (LTLT (4 0))
- (<< (4 0))
- (NUV (4 0))
- (SDC (4 0))
- (LTLTEQ (5 0))
- (<<= (5 0))
- (ZNV (5 0))
- (SV (6 0))
- (SBC (6 0))
- (OD (7 0))
- (SHC (7 0))
- (TR (0 1))
- (LTGT (1 1))
- (<> (1 1))
- (GTEQ (2 1))
- (>= (2 1))
- (NBZ (2 1))
- (GT (3 1))
- (> (3 1))
- (NHZ (3 1))
- (GTGTEQ (4 1))
- (>>= (4 1))
- (UV (4 1))
- (NDC (4 1))
- (GTGT (5 1))
- (>> (5 1))
- (VNZ (5 1))
- (NSV (6 1))
- (NBC (6 1))
- (EV (7 1))
- (NHC (7 1))))
-
-(define-integrable (tf-adjust opcode condition)
- (+ opcode (* 2 (cadr condition))))
-
-(define (tf-adjust-inverted opcode condition)
- (+ opcode (* 2 (- 1 (cadr condition)))))
-\f
-(define (make-operator name handler)
- (lambda (value)
- (if (exact-integer? value)
- (handler value)
- `(,name ,value))))
-
-(let-syntax ((define-operator
- (sc-macro-transformer
- (lambda (form environment)
- `(DEFINE ,(cadr form)
- (MAKE-operator ',(cadr form)
- ,(close-syntax (caddr form)
- environment)))))))
-
- (define-operator LEFT
- (lambda (number)
- (bit-string->signed-integer
- (bit-substring (signed-integer->bit-string 32 number) 11 32))))
-
- (define-operator RIGHT
- (lambda (number)
- (bit-string->unsigned-integer
- (bit-substring (signed-integer->bit-string 32 number) 0 11)))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; HP Spectrum Instruction Set Description
-;;; Originally from Walt Hill, who did the hard part.
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Memory and offset operations
-
-;;; The long forms of many of the following instructions use register
-;;; 1 -- this may be inappropriate for assembly-language programs, but
-;;; is OK for the output of the compiler.
-
-(let-syntax ((long-load
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- ((() (OFFSET (? offset) (? space) (? base)) (? reg))
- (VARIABLE-WIDTH (disp offset)
- ((#x-2000 #x1FFF)
- (LONG (6 ,(caddr form))
- (5 base)
- (5 reg)
- (2 space)
- (14 disp RIGHT-SIGNED)))
- ((() ())
- (LONG
- ;; (ADDIL () L$,offset ,base)
- (6 #x0A)
- (5 base)
- (21 (quotient disp #x800) ASSEMBLE21:X)
- ;; (LDW () (OFFSET R$,offset ,space 1) ,reg)
- (6 ,(caddr form))
- (5 1)
- (5 reg)
- (2 space)
- (14 (remainder disp #x800) RIGHT-SIGNED))))))))))
- (long-load LDW #x12)
- (long-load LDWM #x13)
- (long-load LDH #x11)
- (long-load LDB #x10))
-
-(let-syntax ((long-store
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- ((() (? reg) (OFFSET (? offset) (? space) (? base)))
- (VARIABLE-WIDTH (disp offset)
- ((#x-2000 #x1FFF)
- (LONG (6 ,(caddr form))
- (5 base)
- (5 reg)
- (2 space)
- (14 disp RIGHT-SIGNED)))
- ((() ())
- (LONG
- ;; (ADDIL () L$,offset ,base)
- (6 #x0A)
- (5 base)
- (21 (quotient disp #x800) ASSEMBLE21:X)
- ;; (STW () ,reg (OFFSET R$,offset ,space 1))
- (6 ,(caddr form))
- (5 1)
- (5 reg)
- (2 space)
- (14 (remainder disp #x800) RIGHT-SIGNED))))))))))
- (long-store STW #x1a)
- (long-store STWM #x1b)
- (long-store STH #x19)
- (long-store STB #x18))
-\f
-(let-syntax ((load-offset
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- ((() (OFFSET (? offset) 0 (? base)) (? reg))
- (VARIABLE-WIDTH (disp offset)
- ((#x-2000 #x1FFF)
- (LONG (6 ,(caddr form))
- (5 base)
- (5 reg)
- (2 #b00)
- (14 disp RIGHT-SIGNED)))
- ((() ())
- (LONG
- ;; (ADDIL () L$,offset ,base)
- (6 #x0A)
- (5 base)
- (21 (quotient disp #x800) ASSEMBLE21:X)
- ;; (LDO () (OFFSET R$,offset 0 1) ,reg)
- (6 ,(caddr form))
- (5 1)
- (5 reg)
- (2 #b00)
- (14 (remainder disp #x800) RIGHT-SIGNED))))))))))
- (load-offset LDO #x0d))
-
-(let-syntax ((load-immediate
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- ((() (? offset) (? reg))
- (VARIABLE-WIDTH (disp offset)
- ((#x-2000 #x1FFF)
- (LONG (6 ,(caddr form))
- (5 0)
- (5 reg)
- (2 #b00)
- (14 disp RIGHT-SIGNED)))
- ((() ())
- (LONG
- ;; (LDIL () L$,offset ,base)
- (6 #x08)
- (5 reg)
- (21 (quotient disp #x800) ASSEMBLE21:X)
- ;; (LDO () (OFFSET R$,offset 0 ,reg) ,reg)
- (6 ,(caddr form))
- (5 reg)
- (5 reg)
- (2 #b00)
- (14 (remainder disp #x800) RIGHT-SIGNED))))))))))
- ;; pseudo-op (LDO complt (OFFSET displ 0) reg)
- (load-immediate LDI #x0d))
-
-(let-syntax ((left-immediate
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- ((() (? immed-21) (? reg))
- (LONG (6 ,(caddr form))
- (5 reg)
- (21 immed-21 ASSEMBLE21:X))))))))
- (left-immediate LDIL #x08)
- (left-immediate ADDIL #x0a))
-\f
-;; In the following, the middle completer field (2 bits) appears to be zero,
-;; according to the hardware. Also, the u-bit seems not to exist in the
-;; cache instructions.
-
-(let-syntax ((indexed-load
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? compl complx) (INDEX (? index-reg) (? space) (? base))
- (? reg))
- (LONG (6 ,(caddr form))
- (5 base)
- (5 index-reg)
- (2 space)
- (1 (vector-ref compl 0))
- (1 #b0)
- (2 (vector-ref compl 1))
- (4 ,(cadddr form))
- (1 (vector-ref compl 2))
- (5 reg))))))))
- (indexed-load LDWX #x03 #x2)
- (indexed-load LDHX #x03 #x1)
- (indexed-load LDBX #x03 #x0)
- (indexed-load LDCWX #x03 #x7)
- (indexed-load FLDWX #x09 #x0)
- (indexed-load FLDDX #x0B #x0))
-
-(let-syntax ((indexed-store
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? compl complx) (? reg)
- (INDEX (? index-reg) (? space)
- (? base)))
- (LONG (6 ,(caddr form))
- (5 base)
- (5 index-reg)
- (2 space)
- (1 (vector-ref compl 0))
- (1 #b0)
- (2 (vector-ref compl 1))
- (4 ,(cadddr form))
- (1 (vector-ref compl 2))
- (5 reg))))))))
- (indexed-store FSTWX #x09 #x8)
- (indexed-store FSTDX #x0b #x8))
-\f
-(let-syntax ((indexed-d-cache
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? compl m-val) (INDEX (? index-reg) (? space) (? base)))
- (LONG (6 #x01)
- (5 base)
- (5 index-reg)
- (2 space)
- (8 ,(caddr form))
- (1 compl)
- (5 #x0))))))))
- (indexed-d-cache PDC #x4e)
- (indexed-d-cache FDC #x4a)
- (indexed-d-cache FDCE #x4b))
-
-(let-syntax ((indexed-i-cache
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? compl m-val)
- (INDEX (? index-reg) (? space sr3) (? base)))
- (LONG (6 #x01)
- (5 base)
- (5 index-reg)
- (3 space)
- (7 ,(caddr form))
- (1 compl)
- (5 #x0))))))))
- (indexed-i-cache FIC #x0a)
- (indexed-i-cache FICE #x0b))
-
-(let-syntax ((scalr-short-load
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? compl compls) (OFFSET (? offset) (? space) (? base))
- (? reg))
- (LONG (6 #x03)
- (5 base)
- (5 offset RIGHT-SIGNED)
- (2 space)
- (1 (vector-ref compl 0))
- (1 #b1)
- (2 (vector-ref compl 1))
- (4 ,(caddr form))
- (1 (vector-ref compl 2))
- (5 reg))))))))
- (scalr-short-load LDWS #x02)
- (scalr-short-load LDHS #x01)
- (scalr-short-load LDBS #x00)
- (scalr-short-load LDCWS #x07))
-
-(let-syntax ((scalr-short-store
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? compl compls) (? reg)
- (OFFSET (? offset) (? space) (? base)))
- (LONG (6 #x03)
- (5 base)
- (5 reg)
- (2 space)
- (1 (vector-ref compl 0))
- (1 #b1)
- (2 (vector-ref compl 1))
- (4 ,(caddr form))
- (1 (vector-ref compl 2))
- (5 offset RIGHT-SIGNED))))))))
- (scalr-short-store STWS #x0a)
- (scalr-short-store STHS #x09)
- (scalr-short-store STBS #x08)
- (scalr-short-store STBYS #x0c))
-\f
-(let-syntax ((float-short-load
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? compl compls) (OFFSET (? offset) (? space) (? base))
- (? reg))
- (LONG (6 ,(caddr form))
- (5 base)
- (5 offset RIGHT-SIGNED)
- (2 space)
- (1 (vector-ref compl 0))
- (1 #b1)
- (2 (vector-ref compl 1))
- (4 ,(cadddr form))
- (1 (vector-ref compl 2))
- (5 reg))))))))
- (float-short-load FLDWS #x09 #x00)
- (float-short-load FLDDS #x0b #x00))
-
-(let-syntax ((float-short-store
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? compl compls) (? reg)
- (OFFSET (? offset) (? space) (? base)))
- (LONG (6 ,(caddr form))
- (5 base)
- (5 offset RIGHT-SIGNED)
- (2 space)
- (1 (vector-ref compl 0))
- (1 #b1)
- (2 (vector-ref compl 1))
- (4 ,(cadddr form))
- (1 (vector-ref compl 2))
- (5 reg))))))))
- (float-short-store FSTWS #x09 #x08)
- (float-short-store FSTDS #x0b #x08))
-\f
-;;;; Control transfer instructions
-
-;;; Note: For the time being the unconditionaly branch instructions are not
-;;; branch tensioned since their range is pretty large (1/2 Mbyte).
-;;; They should be eventually (by using an LDIL,LDI,BLR sequence, for example).
-
-(let-syntax ((branch&link
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- ((() (? reg) (@PCR (? label)))
- (LONG (6 #x3a)
- (5 reg)
- (5 label PC-REL ASSEMBLE17:X)
- (3 ,(caddr form))
- (11 label PC-REL ASSEMBLE17:Y)
- (1 0)
- (1 label PC-REL ASSEMBLE17:Z)))
-
- (((N) (? reg) (@PCR (? label)))
- (LONG (6 #x3a)
- (5 reg)
- (5 label PC-REL ASSEMBLE17:X)
- (3 ,(caddr form))
- (11 label PC-REL ASSEMBLE17:Y)
- (1 1)
- (1 label PC-REL ASSEMBLE17:Z)))
-
- ((() (? reg) (@PCO (? offset)))
- (LONG (6 #x3a)
- (5 reg)
- (5 offset ASSEMBLE17:X)
- (3 ,(caddr form))
- (11 offset ASSEMBLE17:Y)
- (1 0)
- (1 offset ASSEMBLE17:Z)))
-
- (((N) (? reg) (@PCO (? offset)))
- (LONG (6 #x3a)
- (5 reg)
- (5 offset ASSEMBLE17:X)
- (3 ,(caddr form))
- (11 offset ASSEMBLE17:Y)
- (1 1)
- (1 offset ASSEMBLE17:Z))))))))
- (branch&link BL 0)
- (branch&link GATE 1))
-\f
-(let-syntax ((branch
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- ((() (@PCR (? l)))
- (LONG (6 #x3a)
- (5 #b00000)
- (5 l PC-REL ASSEMBLE17:X)
- (3 #b000)
- (11 l PC-REL ASSEMBLE17:Y)
- (1 0)
- (1 l PC-REL ASSEMBLE17:Z)))
-
- (((N) (@PCR (? l)))
- (LONG (6 #x3a)
- (5 #b00000)
- (5 l PC-REL ASSEMBLE17:X)
- (3 #b000)
- (11 l PC-REL ASSEMBLE17:Y)
- (1 1)
- (1 l PC-REL ASSEMBLE17:Z)))
-
- ((() (@PCO (? offset)))
- (LONG (6 #x3a)
- (5 #b00000)
- (5 offset ASSEMBLE17:X)
- (3 #b000)
- (11 offset ASSEMBLE17:Y)
- (1 0)
- (1 offset ASSEMBLE17:Z)))
-
- (((N) (@PCO (? offset)))
- (LONG (6 #x3a)
- (5 #b00000)
- (5 offset ASSEMBLE17:X)
- (3 #b000)
- (11 offset ASSEMBLE17:Y)
- (1 1)
- (1 offset ASSEMBLE17:Z))))))))
- ;; pseudo-op (BL complt 0 displ)
- (branch B 0))
-\f
-(let-syntax ((BV&BLR
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- ((() (? offset-reg) (? reg))
- (LONG (6 #x3a)
- (5 reg)
- (5 offset-reg)
- (3 ,(caddr form))
- (11 #b00000000000)
- (1 0)
- (1 #b0)))
-
- (((N) (? offset-reg) (? reg))
- (LONG (6 #x3a)
- (5 reg)
- (5 offset-reg)
- (3 ,(caddr form))
- (11 #b00000000000)
- (1 1)
- (1 #b0))))))))
- (BV&BLR BLR 2)
- (BV&BLR BV 6))
-
-(let-syntax ((BE&BLE
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- ((() (OFFSET (? offset) (? space sr3) (? base)))
- (LONG (6 ,(caddr form))
- (5 base)
- (5 offset ASSEMBLE17:X)
- (3 space)
- (11 offset ASSEMBLE17:Y)
- (1 0)
- (1 offset ASSEMBLE17:Z)))
-
- (((N) (OFFSET (? offset) (? space sr3) (? base)))
- (LONG (6 ,(caddr form))
- (5 base)
- (5 offset ASSEMBLE17:X)
- (3 space)
- (11 offset ASSEMBLE17:Y)
- (1 1)
- (1 offset ASSEMBLE17:Z))))))))
- (BE&BLE BE #x38)
- (BE&BLE BLE #x39))
-\f
-;;;; Conditional branch instructions
-
-#|
-
-Branch tensioning notes for the conditional branch instructions:
-
-The sequence
-
- combt,cc r1,r2,label
- instr1
- instr2
-
-becomes
-
- combf,cc,n r1,r2,tlabel ; pco = 0
- b label ; no nullification
-tlabel instr1
- instr2
-
-The sequence
-
- combt,cc,n r1,r2,label
- instr1
- instr2
-
-becomes either
-
- combf,cc,n r1,r2,tlabel ; pco = 0
- b,n label ; nullification
-tlabel instr1
- instr2
-
-when label is downstream (a forwards branch)
-
-or
-
- combf,cc,n r1,r2,tlabel ; pco = 4
- b label ; no nullification
- instr1
-tlabel instr2
-
-when label is upstream (a backwards branch).
-
-This adjusting of the nullify bits, the pc offset, etc. for tlabel are
-performed by the utilities branch-extend-pco, branch-extend-disp, and
-branch-extend-nullify in instr1.
-|#
-\f
-;;;; Compare/compute and branch.
-
-(let-syntax
- ((defccbranch
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (let ((completer (list-ref form 2))
- (opcode1 (list-ref form 3))
- (opcode2 (list-ref form 4))
- (opr1 (list-ref form 5)))
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? compl ,completer) (? ,(car opr1)) (? reg-2)
- (@PCO (? offset)))
- (LONG (6 ,opcode1)
- (5 reg-2)
- (5 ,@opr1)
- (3 (cadr compl))
- (11 offset ASSEMBLE12:X)
- (1 (car compl))
- (1 offset ASSEMBLE12:Y)))
- (((? compl ,completer) (? ,(car opr1)) (? reg-2) (@PCR (? l)))
- (VARIABLE-WIDTH
- (disp `(- ,l (+ *PC* 8)))
- ((#x-2000 #x1FFF)
- (LONG (6 ,opcode1)
- (5 reg-2)
- (5 ,@opr1)
- (3 (cadr compl))
- (11 disp ASSEMBLE12:X)
- (1 (car compl))
- (1 disp ASSEMBLE12:Y)))
- ((() ())
- ;; See page comment above.
- (LONG (6 ,opcode2) ; COMBF
- (5 reg-2)
- (5 ,@opr1)
- (3 (cadr compl))
- (11 (branch-extend-pco disp (car compl)) ASSEMBLE12:X)
- (1 1)
- (1 (branch-extend-pco disp (car compl)) ASSEMBLE12:Y)
- (6 #x3a) ; B
- (5 0)
- (5 (branch-extend-disp disp) ASSEMBLE17:X)
- (3 0)
- (11 (branch-extend-disp disp) ASSEMBLE17:Y)
- (1 (branch-extend-nullify disp (car compl)))
- (1 (branch-extend-disp disp) ASSEMBLE17:Z)))))))))))
- (let-syntax
- ((defcond
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFCCBRANCH ,(cadr form) COMPLALTFB ,@(cddr form))))))
- (defcond COMBT #x20 #x22 (reg-1))
- (defcond COMBF #x22 #x20 (reg-1))
- (defcond ADDBT #x28 #x2a (reg-1))
- (defcond ADDBF #x2a #x28 (reg-1))
- (defcond COMIBT #x21 #x23 (immed-5 right-signed))
- (defcond COMIBF #x23 #x21 (immed-5 right-signed))
- (defcond ADDIBT #x29 #x2b (immed-5 right-signed))
- (defcond ADDIBF #x2b #x29 (immed-5 right-signed)))
- (let-syntax
- ((defpseudo
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFCCBRANCH ,(cadr form) COMPLALB
- (TF-ADJUST ,(caddr form) (CDR COMPL))
- (TF-ADJUST-INVERTED ,(caddr form) (CDR COMPL))
- ,(cadddr form))))))
- (defpseudo COMB #x20 (reg-1))
- (defpseudo ADDB #x28 (reg-1))
- (defpseudo COMIB #x21 (immed-5 right-signed))
- (defpseudo ADDIB #x29 (immed-5 right-signed))))
-\f
-;;;; Pseudo branch instructions.
-
-#|
-
-These nullify the following instruction when the branch is taken.
-irrelevant of the sign of the displacement (unlike the real instructions).
-If the displacement is positive, they use the nullify bit.
-If the displacement is negative, they use a NOP.
-
- combn,cc r1,r2,label
-
-becomes either
-
- comb,cc,n r1,r2,label
-
-if label is downstream (forward branch)
-
-or
-
- comb,cc r1,r2,label
- nop
-
-if label is upstream (backward branch)
-
-If the displacement is too large, it becomes
-
- comb,!cc,n r1,r2,tlabel ; pco = 0
- b,n label
-tlabel
-
-Note: Only those currently used by the code generator are implemented.
-|#
-\f
-(let-syntax
- ((defccbranch
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (let ((completer (list-ref form 2))
- (opcode1 (list-ref form 3))
- (opcode2 (list-ref form 4))
- (opr1 (list-ref form 5)))
- `(DEFINE-INSTRUCTION ,(cadr form)
- ;; No @PCO form.
- ;; This is a pseudo-instruction used by the code-generator
- (((? compl ,completer) (? ,(car opr1)) (? reg-2) (@PCR (? l)))
- (VARIABLE-WIDTH
- (disp `(- ,l (+ *PC* 8)))
- ((0 #x1FFF)
- ;; Forward branch. Nullify.
- (LONG (6 ,opcode1) ; COMB,cc,n
- (5 reg-2)
- (5 ,@opr1)
- (3 (car compl))
- (11 disp ASSEMBLE12:X)
- (1 1)
- (1 disp ASSEMBLE12:Y)))
- ((#x-2000 -1)
- ;; Backward branch. No nullification, insert NOP.
- (LONG (6 ,opcode1) ; COMB,cc
- (5 reg-2)
- (5 ,@opr1)
- (3 (car compl))
- (11 disp ASSEMBLE12:X)
- (1 0)
- (1 disp ASSEMBLE12:Y)
- (6 #x02) ; NOP (OR 0 0 0)
- (10 #b0000000000)
- (3 0)
- (1 0)
- (7 #x12)
- (5 #b00000)))
- ((() ())
- (LONG (6 ,opcode2) ; COMB!,n
- (5 reg-2)
- (5 ,@opr1)
- (3 (car compl))
- (11 0 ASSEMBLE12:X)
- (1 1)
- (1 0 ASSEMBLE12:Y)
- (6 #x3a) ; B,n
- (5 0)
- (5 (branch-extend-disp disp) ASSEMBLE17:X)
- (3 0)
- (11 (branch-extend-disp disp) ASSEMBLE17:Y)
- (1 1)
- (1 (branch-extend-disp disp) ASSEMBLE17:Z)))))))))))
- (let-syntax ((defcond
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFCCBRANCH ,(cadr form) COMPLALTF ,@(cddr form))))))
- (defcond COMIBTN #x21 #x23 (immed-5 right-signed))
- (defcond COMIBFN #x23 #x21 (immed-5 right-signed)))
- (let-syntax ((defpseudo
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFCCBRANCH ,(cadr form) COMPLAL
- (TF-adjust ,(caddr form) COMPL)
- (TF-ADJUST-INVERTED ,(caddr form) COMPL)
- ,(cadddr form))))))
- (defpseudo COMBN #x20 (reg-1))))
-\f
-;;;; Miscellaneous control
-
-(let-syntax
- ((defmovb&bb
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (let ((opcode (list-ref form 2))
- (opr1 (list-ref form 3))
- (opr2 (list-ref form 4))
- (field2 (list-ref form 5)))
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? compl compledb) (? ,(car opr1)) ,@opr2 (@PCO (? offset)))
- (LONG (6 ,opcode)
- (5 ,field2)
- (5 ,@opr1)
- (3 (cdr compl))
- (11 offset ASSEMBLE12:X)
- (1 (car compl))
- (1 offset ASSEMBLE12:Y)))
- (((? compl compledb) (? ,(car opr1)) ,@opr2 (@PCR (? l)))
- (VARIABLE-WIDTH
- (disp `(- ,l (+ *PC* 8)))
- ((#x-2000 #x1FFF)
- (LONG (6 ,opcode)
- (5 ,field2)
- (5 ,@opr1)
- (3 (cdr compl))
- (11 l PC-REL ASSEMBLE12:X)
- (1 (car compl))
- (1 l PC-REL ASSEMBLE12:Y)))
- ((() ())
- ;; See page comment above.
- (LONG (6 ,opcode) ; MOVB
- (5 ,field2)
- (5 ,@opr1)
- (3 (branch-extend-edcc (cdr compl)))
- (11 (branch-extend-pco disp (car compl)) ASSEMBLE12:X)
- (1 1)
- (1 (branch-extend-pco disp (car compl)) ASSEMBLE12:Y)
- (6 #x3a) ; B
- (5 0)
- (5 (branch-extend-disp disp) ASSEMBLE17:X)
- (3 0)
- (11 (branch-extend-disp disp) ASSEMBLE17:Y)
- (1 (branch-extend-nullify disp (car compl)))
- (1 (branch-extend-disp disp) ASSEMBLE17:Z)))))))))))
- (defmovb&bb BVB #x30 (reg) () #b00000)
- (defmovb&bb BB #x31 (reg) ((? pos)) pos)
- (defmovb&bb MOVB #x32 (reg-1) ((? reg-2)) reg-2)
- (defmovb&bb MOVIB #x33 (immed-5 right-signed) ((? reg-2)) reg-2))
-\f
-;;;; Assembler pseudo-ops
-
-(define-instruction USHORT
- ((() (? high) (? low))
- (LONG (16 high UNSIGNED)
- (16 low UNSIGNED))))
-
-(define-instruction WORD
- ((() (? expression))
- (LONG (32 expression SIGNED))))
-
-(define-instruction UWORD
- ((() (? expression))
- (LONG (32 expression UNSIGNED))))
-
-(define-instruction EXTERNAL-LABEL
- ((() (? format-word) (@PCR (? label)))
- (LONG (16 format-word UNSIGNED)
- (16 label BLOCK-OFFSET)))
-
- ((() (? format-word) (@PCO (? offset)))
- (LONG (16 format-word UNSIGNED)
- (16 offset UNSIGNED))))
-
-(define-instruction PCR-HOOK
- ((() (? target)
- (OFFSET (? offset) (? space sr3) (? base))
- (@PCR (? label)))
- (VARIABLE-WIDTH
- (disp `(- ,label (+ *PC* 8)))
- ((#x-2000 #x1FFF)
- (LONG
- ;; (BLE () (OFFSET ,offset ,space ,base))
- (6 #x39)
- (5 base)
- (5 offset ASSEMBLE17:X)
- (3 space)
- (11 offset ASSEMBLE17:Y)
- (1 0)
- (1 offset ASSEMBLE17:Z)
- ;; (LDO () (OFFSET ,disp 0 31) ,target)
- (6 #x0D)
- (5 31)
- (5 target)
- (2 #b00)
- (14 disp RIGHT-SIGNED)))
- ((() ())
- (LONG
- ;; (LDIL () L$disp-8 target)
- (6 #x08)
- (5 1)
- (21 (quotient (- disp 8) #x800) ASSEMBLE21:X)
- ;; (LDO () (OFFSET R$disp-4 0 1) target)
- (6 #x0D)
- (5 1)
- (5 1)
- (2 #b00)
- (14 (remainder (- disp 8) #x800) RIGHT-SIGNED)
- ;; (BLE () (OFFSET ,offset ,space ,base))
- (6 #x39)
- (5 base)
- (5 offset ASSEMBLE17:X)
- (3 space)
- (11 offset ASSEMBLE17:Y)
- (1 0)
- (1 offset ASSEMBLE17:Z)
- ;; (ADD () 31 1 target)
- (6 #x02)
- (5 31)
- (5 1)
- (3 0)
- (1 0)
- (7 #x30)
- (5 target))))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; HP Spectrum Instruction Set Description
-;;; Originally from Walt Hill, who did the hard part.
-
-(declare (usual-integrations))
-\f
-;;;; Computation instructions
-
-(let-syntax ((arith-logical
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? compl complal) (? source-reg1) (? source-reg2)
- (? target-reg))
- (LONG (6 #x02)
- (5 source-reg2)
- (5 source-reg1)
- (3 (car compl))
- (1 (cadr compl))
- (7 ,(caddr form))
- (5 target-reg))))))))
-
- (arith-logical ANDCM #x00)
- (arith-logical AND #x10)
- (arith-logical OR #x12)
- (arith-logical XOR #x14)
- (arith-logical UXOR #x1c)
- (arith-logical SUB #x20)
- (arith-logical DS #x22)
- (arith-logical SUBT #x26)
- (arith-logical SUBB #x28)
- (arith-logical ADD #x30)
- (arith-logical SH1ADD #x32)
- (arith-logical SH2ADD #x34)
- (arith-logical SH3ADD #x36)
- (arith-logical ADDC #x38)
- (arith-logical COMCLR #x44)
- (arith-logical UADDCM #x4c)
- (arith-logical UADDCMT #x4e)
- (arith-logical ADDL #x50)
- (arith-logical SH1ADDL #x52)
- (arith-logical SH2ADDL #x54)
- (arith-logical SH3ADDL #x56)
- (arith-logical SUBO #x60)
- (arith-logical SUBTO #x66)
- (arith-logical SUBBO #x68)
- (arith-logical ADDO #x70)
- (arith-logical SH1ADDO #x72)
- (arith-logical SH2ADDO #x74)
- (arith-logical SH3ADDO #x76)
- (arith-logical ADDCO #x78))
-
-;; WH Maybe someday. (Spec-DefOpcode DCOR 2048 DecimalCorrect) % 02
-;; (Spec-DefOpcode IDCOR 2048 DecimalCorrect) % 02
-\f
-;;;; Assembler pseudo-ops
-
-(define-instruction NOP ; pseudo-op: (OR complt 0 0 0)
- (((? compl complal))
- (LONG (6 #x02)
- (10 #b0000000000)
- (3 (car compl))
- (1 (cadr compl))
- (7 #x12)
- (5 #b00000))))
-
-(define-instruction COPY ; pseudo-op (OR complt 0 s t)
- (((? compl complal) (? source-reg) (? target-reg))
- (LONG (6 #x02)
- (5 #b00000)
- (5 source-reg)
- (3 (car compl))
- (1 (cadr compl))
- (7 #x12)
- (5 target-reg))))
-
-(define-instruction SKIP ; pseudo-op (ADD complt 0 0 0)
- (((? compl complal))
- (LONG (6 #x02)
- (10 #b0000000000)
- (3 (car compl))
- (1 (cadr compl))
- (7 #x30)
- (5 #b00000))))
-\f
-(let-syntax ((immed-arith
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? compl complal) (? immed-11) (? source-reg)
- (? target-reg))
- (LONG (6 ,(caddr form))
- (5 source-reg)
- (5 target-reg)
- (3 (car compl))
- (1 (cadr compl))
- (1 ,(cadddr form))
- (11 immed-11 RIGHT-SIGNED))))))))
- (immed-arith ADDI #x2d 0)
- (immed-arith ADDIO #x2d 1)
- (immed-arith ADDIT #x2c 0)
- (immed-arith ADDITO #x2c 1)
- (immed-arith SUBI #x25 0)
- (immed-arith SUBIO #x25 1)
- (immed-arith COMICLR #x24 0))
-
-(define-instruction VSHD
- (((? compl compled) (? source-reg1) (? source-reg2)
- (? target-reg))
- (LONG (6 #x34)
- (5 source-reg2)
- (5 source-reg1)
- (3 compl)
- (3 0)
- (5 #b00000)
- (5 target-reg))))
-
-(define-instruction SHD
- (((? compl compled) (? source-reg1) (? source-reg2) (? pos)
- (? target-reg))
- (LONG (6 #x34)
- (5 source-reg2)
- (5 source-reg1)
- (3 compl)
- (3 2)
- (5 (- 31 pos))
- (5 target-reg))))
-
-(let-syntax ((extr
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? compl compled) (? source-reg) (? pos) (? len)
- (? target-reg))
- (LONG (6 #x34)
- (5 source-reg)
- (5 target-reg)
- (3 compl)
- (3 ,(caddr form))
- (5 pos)
- (5 (- 32 len))))))))
- (vextr
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? compl compled) (? source-reg) (? len)
- (? target-reg))
- (LONG (6 #x34)
- (5 source-reg)
- (5 target-reg)
- (3 compl)
- (3 ,(caddr form))
- (5 #b00000)
- (5 (- 32 len)))))))))
- (extr EXTRU 6)
- (extr EXTRS 7)
- (vextr VEXTRU 4)
- (vextr VEXTRS 5))
-\f
-(let-syntax ((depos
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? compl compled) (? source-reg) (? pos) (? len)
- (? target-reg))
- (LONG (6 #x35)
- (5 target-reg)
- (5 source-reg)
- (3 compl)
- (3 ,(caddr form))
- (5 (- 31 pos))
- (5 (- 32 len))))))))
- (vdepos
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? compl compled) (? source-reg) (? len)
- (? target-reg))
- (LONG (6 #x35)
- (5 target-reg)
- (5 source-reg)
- (3 compl)
- (3 ,(caddr form))
- (5 #b00000)
- (5 (- 32 len))))))))
- (idepos
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? compl compled) (? immed) (? pos) (? len)
- (? target-reg))
- (LONG (6 #x35)
- (5 target-reg)
- (5 immed RIGHT-SIGNED)
- (3 compl)
- (3 ,(caddr form))
- (5 (- 31 pos))
- (5 (- 32 len))))))))
- (videpos
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? compl compled) (? immed) (? len)
- (? target-reg))
- (LONG (6 #x35)
- (5 target-reg)
- (5 immed RIGHT-SIGNED)
- (3 compl)
- (3 ,(caddr form))
- (5 #b00000)
- (5 (- 32 len)))))))))
-
- (idepos DEPI 7)
- (idepos ZDEPI 6)
- (videpos VDEPI 5)
- (videpos ZVDEPI 4)
- (depos DEP 3)
- (depos ZDEP 2)
- (vdepos VDEP 1)
- (vdepos ZVDEP 0))
-\f
-(let-syntax ((Probe-Read-Write
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- ((() (OFFSET 0 (? space) (? base)) (? priv-reg)
- (? target-reg))
- (LONG (6 1)
- (5 base)
- (5 priv-reg)
- (2 space)
- (8 ,(caddr form))
- (1 #b0)
- (5 target-reg))))))))
- (Probe-Read-Write PROBER #x46)
- (Probe-Read-Write PROBEW #x47)
- (Probe-Read-Write PROBERI #xc6)
- (Probe-Read-Write PROBEWI #xc7))
-
-(define-instruction BREAK
- ((() (? immed-5) (? immed-13))
- (LONG (6 #b000000)
- (13 immed-13)
- (8 #b00000000)
- (5 immed-5))))
-
-(define-instruction LDSID
- ((() (OFFSET 0 (? space) (? base)) (? target-reg))
- (LONG (6 #b000000)
- (5 base)
- (5 #b00000)
- (2 space)
- (1 #b0)
- (8 #x85)
- (5 target-reg))))
-
-(define-instruction MTSP
- ((() (? source-reg) (? space-reg sr3))
- (LONG (6 #b000000)
- (5 #b00000)
- (5 source-reg)
- (3 space-reg)
- (8 #xc1)
- (5 #b00000))))
-
-(define-instruction MTCTL
- ((() (? source-reg) (? control-reg))
- (LONG (6 #b000000)
- (5 control-reg)
- (5 source-reg)
- (3 #b000)
- (8 #xc2)
- (5 #b00000))))
-
-(define-instruction MTSAR ; pseudo-oop (MTCLT () source 11)
- ((() (? source-reg))
- (LONG (6 #b000000)
- (5 #x0b)
- (5 source-reg)
- (3 #b000)
- (8 #xc2)
- (5 #b00000))))
-\f
-(define-instruction MFSP
- ((() (? space-reg sr3) (? target-reg))
- (LONG (16 #b0000000000000000)
- (3 space-reg)
- (8 #x25)
- (5 target-reg))))
-
-(define-instruction MFCTL
- ((() (? control-reg) (? target-reg))
- (LONG (6 #b000000)
- (5 control-reg)
- (5 #b00000)
- (3 #b000)
- (8 #x45)
- (5 target-reg))))
-
-(define-instruction SYNC
- ((())
- (LONG (16 #b0000000000000000)
- (3 #b000)
- (8 #x20)
- (5 #b00000))))
-
-#|
-Missing:
-
-LPA
-LHA
-PDTLB
-PITLB
-PDTLBE
-PITLBE
-IDTLBA
-IITLBA
-IDTLBP
-IITLBP
-DIAG
-
-|#
-\f
-(let-syntax ((floatarith-1
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- ((((? fmt fpformat)) (? source-reg) (? target-reg))
- (LONG (6 #x0c)
- (5 source-reg)
- (5 #b00000)
- (3 ,(caddr form))
- (2 fmt)
- (2 ,(cadddr form))
- (4 #b0000)
- (5 target-reg)))))))
- (floatarith-2
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- ((((? fmt fpformat)) (? source-reg1) (? source-reg2)
- (? target-reg))
- (LONG (6 #x0c)
- (5 source-reg1)
- (5 source-reg2)
- (3 ,(caddr form))
- (2 fmt)
- (2 ,(cadddr form))
- (4 #b0000)
- (5 target-reg))))))))
-
- (floatarith-2 FADD 0 3)
- (floatarith-2 FSUB 1 3)
- (floatarith-2 FMPY 2 3)
- (floatarith-2 FDIV 3 3)
- (floatarith-1 FSQRT 4 0)
- (floatarith-1 FABS 3 0)
- (floatarith-2 FREM 4 3)
- (floatarith-1 FRND 5 0)
- (floatarith-1 FCPY 2 0))
-
-(define-instruction FCMP
- ((((? condition fpcond) (? fmt fpformat)) (? reg1) (? reg2))
- (LONG (6 #x0c)
- (5 reg1)
- (5 reg2)
- (3 #b000)
- (2 fmt)
- (6 #b100000)
- (5 condition))))
-
-(let-syntax ((fpconvert
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- ((((? sf fpformat) (? df fpformat))
- (? source-reg1)
- (? reg-t))
- (LONG (6 #x0c)
- (5 source-reg1)
- (4 #b0000)
- (2 ,(caddr form))
- (2 df)
- (2 sf)
- (6 #b010000)
- (5 reg-t))))))))
- (fpconvert FCNVFF 0)
- (fpconvert FCNVFX 1)
- (fpconvert FCNVXF 2)
- (fpconvert FCNVFXT 3))
-
-(define-instruction FTEST
- ((())
- (LONG (6 #x0c)
- (10 #b0000000000)
- (16 #b0010010000100000))))
-\f
-#|
-;; What SFU is this? -- Jinx
-
-;; WARNING The SFU instruction code below should be
-;; tested before use. WLH 11/18/86
-
-(let-syntax ((multdiv
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- ((() (? reg-1) (? reg-2))
- (LONG (6 #x04)
- (5 reg-2)
- (5 reg-1)
- (5 ,(caddr form))
- (11 #b11000000000))))))))
- (multdiv MPYS #x08)
- (multdiv MPYU #x0a)
- (multdiv MPYSCV #x0c)
- (multdiv MPYUCV #x0e)
- (multdiv MPYACCS #x0d)
- (multdiv MPYACCU #x0f)
- (multdiv DIVSIR #x00)
- (multdiv DIVSFR #x04)
- (multdiv DIVUIR #x03)
- (multdiv DIVUFR #x07)
- (multdiv DIVSIM #x01)
- (multdiv DIVSFM #x05)
- (multdiv MDRR #x06))
-
-(define-instruction MDRO
- ((() (? reg))
- (LONG (6 #x04)
- (5 reg)
- (5 #b00000)
- (16 #b1000000000000000))))
-
-(let-syntax ((multdivresult
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- ((() (? reg-t))
- (LONG (6 #x04)
- (10 #b0000000000)
- (5 ,(caddr form))
- (5 #b01000)
- (1 ,(cadddr form))
- (5 reg-t))))))))
- (multdivresult MDLO 4 0)
- (multdivresult MDLNV 4 1)
- (multdivresult MDLV 5 1)
- (multdivresult MDL 5 0)
- (multdivresult MDHO 6 0)
- (multdivresult MDHNV 6 1)
- (multdivresult MDHV 7 1)
- (multdivresult MDH 7 0)
- (multdivresult MDSFUID 0 0))
-|#
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RTL Rules for HPPA. Shared utilities.
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Register-Allocator Interface
-
-(define (register->register-transfer source target)
- (guarantee-registers-compatible source target)
- (case (register-type source)
- ((GENERAL) (copy source target))
- ((FLOAT) (fp-copy source target))
- (else (error "unknown register type" source))))
-
-(define (home->register-transfer source target)
- (memory->register-transfer (pseudo-register-displacement source)
- regnum:regs-pointer
- target))
-
-(define (register->home-transfer source target)
- (register->memory-transfer source
- (pseudo-register-displacement target)
- regnum:regs-pointer))
-
-(define (reference->register-transfer source target)
- (case (ea/mode source)
- ((GR)
- (copy (register-ea/register source) target))
- ((FPR)
- (fp-copy (fpr->float-register (register-ea/register source)) target))
- ((OFFSET)
- (memory->register-transfer (offset-ea/offset source)
- (offset-ea/register source)
- target))
- (else
- (error "unknown effective-address mode" source))))
-
-(define (pseudo-register-home register)
- ;; Register block consists of 16 4-byte registers followed by 256
- ;; 8-byte temporaries.
- (INST-EA (OFFSET ,(pseudo-register-displacement register)
- 0
- ,regnum:regs-pointer)))
-\f
-(define-integrable (sort-machine-registers registers)
- registers)
-
-;; ***
-;; Note: fp16-fp31 only exist on PA-RISC 1.1 or later.
-;; If compiling for PA-RISC 1.0, truncate this
-;; list after fp15.
-;; ***
-
-(define available-machine-registers
- ;; g1 removed from this list since it is the target of ADDIL,
- ;; needed to expand some rules. g31 may want to be removed
- ;; too.
- (list
- ;; g0 g1 g2 g3 g4 g5
- g6 g7 g8 g9 g10 g11 g12 g13 g14 g15 g16 g17 g18
- ;; g19 g20 g21 g22
- g23 g24 g25 g26
- ;; g27
- g28 g29
- ;; g30
- g31
- ;; fp0 fp1 fp2 fp3
- fp12 fp13 fp14 fp15
- fp4 fp5 fp6 fp7 fp8 fp9 fp10 fp11
- ;; The following are only available on newer processors
- fp16 fp17 fp18 fp19 fp20 fp21 fp22 fp23
- fp24 fp25 fp26 fp27 fp28 fp29 fp30 fp31
- ))
-
-(define-integrable (float-register? register)
- (eq? (register-type register) 'FLOAT))
-
-(define-integrable (general-register? register)
- (eq? (register-type register) 'GENERAL))
-
-(define-integrable (word-register? register)
- (eq? (register-type register) 'GENERAL))
-
-(define (register-type register)
- (cond ((machine-register? register)
- (vector-ref
- '#(GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
- GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
- GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
- GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
- FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
- FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
- FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
- FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT)
- register))
- ((register-value-class=word? register) 'GENERAL)
- ((register-value-class=float? register) 'FLOAT)
- (else (error "unable to determine register type" register))))
-
-(define register-reference
- (let ((references (make-vector number-of-machine-registers)))
- (let loop ((register 0))
- (if (< register 32)
- (begin
- (vector-set! references register (INST-EA (GR ,register)))
- (loop (1+ register)))))
- (let loop ((register 32) (fpr 0))
- (if (< register 64)
- (begin
- (vector-set! references register (INST-EA (FPR ,fpr)))
- (loop (1+ register) (1+ fpr)))))
- (lambda (register)
- (vector-ref references register))))
-\f
-;;;; Useful Cliches
-
-(define (memory->register-transfer offset base target)
- (case (register-type target)
- ((GENERAL) (load-word offset base target))
- ((FLOAT) (fp-load-doubleword offset base target))
- (else (error "unknown register type" target))))
-
-(define (register->memory-transfer source offset base)
- (case (register-type source)
- ((GENERAL) (store-word source offset base))
- ((FLOAT) (fp-store-doubleword source offset base))
- (else (error "unknown register type" source))))
-
-(define (load-constant constant target)
- ;; Load a Scheme constant into a machine register.
- (if (non-pointer-object? constant)
- (load-immediate (non-pointer->literal constant) target)
- (load-pc-relative (constant->label constant) target 'CONSTANT)))
-
-(define (load-non-pointer type datum target)
- ;; Load a Scheme non-pointer constant, defined by type and datum,
- ;; into a machine register.
- (load-immediate (make-non-pointer-literal type datum) target))
-
-(define (non-pointer->literal constant)
- (make-non-pointer-literal (object-type constant)
- (careful-object-datum constant)))
-
-(define-integrable (make-non-pointer-literal type datum)
- (+ (* type type-scale-factor) datum))
-
-(define-integrable type-scale-factor
- ;; (expt 2 scheme-datum-width) ***
- #x4000000)
-
-(define-integrable (deposit-type type target)
- (deposit-immediate type (-1+ scheme-type-width) scheme-type-width target))
-\f
-;;;; Regularized Machine Instructions
-
-(define (copy r t)
- (if (= r t)
- (LAP)
- (LAP (COPY () ,r ,t))))
-
-(define-integrable ldil-scale
- ;; (expt 2 11) ***
- 2048)
-
-(define (load-immediate i t)
- (if (fits-in-14-bits-signed? i)
- (LAP (LDI () ,i ,t))
- (let ((split (integer-divide i ldil-scale)))
- (LAP (LDIL () ,(integer-divide-quotient split) ,t)
- ,@(let ((r%i (integer-divide-remainder split)))
- (if (zero? r%i)
- (LAP)
- (LAP (LDO () (OFFSET ,r%i 0 ,t) ,t))))))))
-
-(define (deposit-immediate i p len t)
- (if (fits-in-5-bits-signed? i)
- (LAP (DEPI () ,i ,p ,len ,t))
- (LAP ,@(load-immediate i regnum:addil-result)
- (DEP () ,regnum:addil-result ,p ,len ,t))))
-
-(define (load-offset d b t)
- (cond ((and (zero? d) (= b t))
- (LAP))
- ((fits-in-14-bits-signed? d)
- (LAP (LDO () (OFFSET ,d 0 ,b) ,t)))
- (else
- (let ((split (integer-divide d ldil-scale)))
- (LAP (ADDIL () ,(integer-divide-quotient split) ,b)
- (LDO () (OFFSET ,(integer-divide-remainder split) 0 1) ,t))))))
-
-(define (load-word d b t)
- (if (fits-in-14-bits-signed? d)
- (LAP (LDW () (OFFSET ,d 0 ,b) ,t))
- (let ((split (integer-divide d ldil-scale)))
- (LAP (ADDIL () ,(integer-divide-quotient split) ,b)
- (LDW () (OFFSET ,(integer-divide-remainder split) 0 1) ,t)))))
-
-(define (load-byte d b t)
- (if (fits-in-14-bits-signed? d)
- (LAP (LDB () (OFFSET ,d 0 ,b) ,t))
- (let ((split (integer-divide d ldil-scale)))
- (LAP (ADDIL () ,(integer-divide-quotient split) ,b)
- (LDB () (OFFSET ,(integer-divide-remainder split) 0 1) ,t)))))
-
-(define (store-word b d t)
- (if (fits-in-14-bits-signed? d)
- (LAP (STW () ,b (OFFSET ,d 0 ,t)))
- (let ((split (integer-divide d ldil-scale)))
- (LAP (ADDIL () ,(integer-divide-quotient split) ,t)
- (STW () ,b (OFFSET ,(integer-divide-remainder split) 0 1))))))
-
-(define (store-byte b d t)
- (if (fits-in-14-bits-signed? d)
- (LAP (STB () ,b (OFFSET ,d 0 ,t)))
- (let ((split (integer-divide d ldil-scale)))
- (LAP (ADDIL () ,(integer-divide-quotient split) ,t)
- (STB () ,b (OFFSET ,(integer-divide-remainder split) 0 1))))))
-\f
-(define (fp-copy r t)
- (if (= r t)
- (LAP)
- (LAP (FCPY (DBL) ,(float-register->fpr r) ,(float-register->fpr t)))))
-
-(define (fp-load-doubleword d b t)
- (let ((t (float-register->fpr t)))
- (if (fits-in-5-bits-signed? d)
- (LAP (FLDDS () (OFFSET ,d 0 ,b) ,t))
- (LAP ,@(load-offset d b regnum:addil-result)
- (FLDDS () (OFFSET 0 0 ,regnum:addil-result) ,t)))))
-
-(define (fp-store-doubleword r d b)
- (let ((r (float-register->fpr r)))
- (if (fits-in-5-bits-signed? d)
- (LAP (FSTDS () ,r (OFFSET ,d 0 ,b)))
- (LAP ,@(load-offset d b regnum:addil-result)
- (FSTDS () ,r (OFFSET 0 0 ,regnum:addil-result))))))
-
-#|
-(define (load-pc-relative label target type)
- type ; ignored
- ;; Load a pc-relative location's contents into a machine register.
- ;; This assumes that the offset fits in 14 bits!
- ;; We should have a pseudo-op for LDW that does some "branch" tensioning.
- (LAP (BL () ,regnum:addil-result (@PCO 0))
- ;; Clear the privilege level, making this a memory address.
- (DEP () 0 31 2 ,regnum:addil-result)
- (LDW () (OFFSET (- ,label *PC*) 0 ,regnum:addil-result) ,target)))
-
-(define (load-pc-relative-address label target type)
- type ; ignored
- ;; Load a pc-relative address into a machine register.
- ;; This assumes that the offset fits in 14 bits!
- ;; We should have a pseudo-op for LDO that does some "branch" tensioning.
- (LAP (BL () ,regnum:addil-result (@PCO 0))
- ;; Clear the privilege level, making this a memory address.
- (DEP () 0 31 2 ,regnum:addil-result)
- (LDO () (OFFSET (- ,label *PC*) 0 ,regnum:addil-result) ,target)))
-|#
-\f
-;; These versions of load-pc-... remember what they obtain, to avoid
-;; doing the sequence multiple times.
-;; In addition, they assume that the code is running in the least
-;; privilege, and avoid the DEP in the sequences above.
-
-(define-integrable *privilege-level* 3)
-
-(define-integrable (close? label label*)
- ;; Heuristic
- label label* ; ignored
- compiler:compile-by-procedures?)
-
-(define (load-pc-relative label target type)
- (load-pc-relative-internal label target type
- (lambda (offset base target)
- (LAP (LDW () (OFFSET ,offset 0 ,base)
- ,target)))))
-
-(define (load-pc-relative-address label target type)
- (load-pc-relative-internal label target type
- (lambda (offset base target)
- (LAP (LDO () (OFFSET ,offset 0 ,base)
- ,target)))))
-
-(define (load-pc-relative-internal label target type gen)
- (with-values (lambda () (get-typed-label type))
- (lambda (label* alias type*)
- (define (closer label* alias)
- (let ((temp (standard-temporary!)))
- (set-typed-label! type label temp)
- (LAP (LDO () (OFFSET (- ,label ,label*) 0 ,alias) ,temp)
- ,@(gen 0 temp target))))
-
- (cond ((not label*)
- (let ((temp (standard-temporary!))
- (here (generate-label)))
- (let ((value `(+ ,here ,(+ 8 *privilege-level*))))
- (set-typed-label! 'CODE value temp)
- (LAP (LABEL ,here)
- (BL () ,temp (@PCO 0))
- ,@(if (or (eq? type 'CODE) (close? label label*))
- (gen (INST-EA (- ,label ,value)) temp target)
- (closer value temp))))))
- ((or (eq? type* type) (close? label label*))
- (gen (INST-EA (- ,label ,label*)) alias target))
- (else
- (closer label* alias))))))
-\f
-;;; Typed labels provide further optimization. There are two types,
-;;; CODE and CONSTANT, that say whether the label is located in the
-;;; code block or the constants block of the output. Statistically,
-;;; a label is likely to be closer to another label of the same type
-;;; than to a label of the other type.
-
-(define (get-typed-label type)
- (let ((entries (register-map-labels *register-map* 'GENERAL)))
- (let loop ((entries* entries))
- (cond ((null? entries*)
- ;; If no entries of the given type, use any entry that is
- ;; available.
- (let loop ((entries entries))
- (cond ((null? entries)
- (values false false false))
- ((pair? (caar entries))
- (values (cdaar entries) (cadar entries) (caaar entries)))
- (else
- (loop (cdr entries))))))
- ((and (pair? (caar entries*))
- (eq? type (caaar entries*)))
- (values (cdaar entries*) (cadar entries*) type))
- (else
- (loop (cdr entries*)))))))
-
-(define (set-typed-label! type label alias)
- (set! *register-map*
- (set-machine-register-label *register-map* alias (cons type label)))
- unspecific)
-\f
-;; COMIBTN, COMIBFN, and COMBN are pseudo-instructions that nullify
-;; the following instruction when the branch is taken. Since COMIBT,
-;; etc. nullify according to the sign of the displacement, the branch
-;; tensioner inserts NOPs as necessary (backward branches).
-
-(define (compare-immediate cc i r2)
- (cond ((zero? i)
- (compare cc 0 r2))
- ((fits-in-5-bits-signed? i)
- (let* ((inverted? (memq cc '(TR <> >= > >>= >> NSV EV
- LTGT GTEQ GT GTGTEQ GTGT)))
- (cc (if inverted? (invert-condition cc) cc))
- (set-branches!
- (lambda (if-true if-false)
- (if inverted?
- (set-current-branches! if-false if-true)
- (set-current-branches! if-true if-false)))))
-
- (set-branches!
- (lambda (label)
- (LAP (COMIBTN (,cc) ,i ,r2 (@PCR ,label))))
- (lambda (label)
- (LAP (COMIBFN (,cc) ,i ,r2 (@PCR ,label)))))
- (LAP)))
- ((fits-in-11-bits-signed? i)
- (set-current-branches!
- (lambda (label)
- (LAP (COMICLR (,(invert-condition cc)) ,i ,r2 0)
- (B (N) (@PCR ,label))))
- (lambda (label)
- (LAP (COMICLR (,cc) ,i ,r2 0)
- (B (N) (@PCR ,label)))))
- (LAP))
- (else
- (let ((temp (standard-temporary!)))
- (LAP ,@(load-immediate i temp)
- ,@(compare cc temp r2))))))
-
-(define (compare condition r1 r2)
- (set-current-branches!
- (lambda (label)
- (LAP (COMBN (,condition) ,r1 ,r2 (@PCR ,label))))
- (lambda (label)
- (LAP (COMBN (,(invert-condition condition)) ,r1 ,r2 (@PCR ,label)))))
- (LAP))
-\f
-;;;; Conditions
-
-(define (invert-condition condition)
- (let ((place (assq condition condition-inversion-table)))
- (if (not place)
- (error "unknown condition" condition))
- (cadr place)))
-
-(define (invert-condition-noncommutative condition)
- (let ((place (assq condition condition-inversion-table)))
- (if (not place)
- (error "unknown condition" condition))
- (caddr place)))
-
-(define condition-inversion-table
- '((= <> =)
- (< >= >)
- (> <= <)
- (NUV UV NUV)
- (TR NV TR)
- (<< >>= >>)
- (>> <<= <<)
- (<> = <>)
- (<= > >=)
- (>= < <=)
- (<<= >> >>=)
- (>>= << <<=)
- (NV TR NV)
- (EQ LTGT EQ)
- (LT GTEQ GT)
- (SBZ NBZ SBZ)
- (LTEQ GT GTEQ)
- (SHZ NHZ SHZ)
- (LTLT GTGTEQ GTGT)
- (SDC NDC SDC)
- (LTLTEQ GTGT GTGTEQ)
- (ZNV VNZ ZNV)
- (SV NSV SV)
- (SBC NBC SBC)
- (OD EV OD)
- (SHC NHC SHC)
- (LTGT EQ LTGT)
- (GTEQ LT LTEQ)
- (NBZ SBZ NBZ)
- (GT LTEQ LT)
- (NHZ SHZ NHZ)
- (GTGTEQ LTLT LTLTEQ)
- (UV NUV UV)
- (NDC SDC NDC)
- (GTGT LTLTEQ LTLT)
- (VNZ ZNV NVZ)
- (NSV SV NSV)
- (NBC SBC NBC)
- (EV OD EV)
- (NHC SHC NHC)))
-\f
-;;;; Miscellaneous
-
-(define-integrable (object->datum src tgt)
- (LAP (ZDEP () ,src 31 ,scheme-datum-width ,tgt)))
-
-(define-integrable (object->address reg)
- (LAP (DEP ()
- ,regnum:quad-bitmask
- ,(-1+ scheme-type-width)
- ,scheme-type-width
- ,reg)))
-
-(define-integrable (object->type src tgt)
- (LAP (EXTRU () ,src ,(-1+ scheme-type-width) ,scheme-type-width ,tgt)))
-
-(define (standard-unary-conversion source target conversion)
- ;; `source' is any register, `target' a pseudo register.
- (let ((source (standard-source! source)))
- (conversion source (standard-target! target))))
-
-(define (standard-binary-conversion source1 source2 target conversion)
- ;; The sources are any register, `target' a pseudo register.
- (let ((source1 (standard-source! source1))
- (source2 (standard-source! source2)))
- (conversion source1 source2 (standard-target! target))))
-
-(define (standard-source! register)
- (load-alias-register! register (register-type register)))
-
-(define (standard-target! register)
- (delete-dead-registers!)
- (allocate-alias-register! register (register-type register)))
-
-(define-integrable (standard-temporary!)
- (allocate-temporary-register! 'GENERAL))
-
-(define (standard-move-to-target! source target)
- (move-to-alias-register! source (register-type source) target))
-
-(define (standard-move-to-temporary! source)
- (move-to-temporary-register! source (register-type source)))
-
-(define (register-expression expression)
- (case (rtl:expression-type expression)
- ((REGISTER)
- (rtl:register-number expression))
- ((CONSTANT)
- (let ((object (rtl:constant-value expression)))
- (and (zero? (object-type object))
- (zero? (object-datum object))
- 0)))
- ((CONS-POINTER)
- (and (let ((type (rtl:cons-pointer-type expression)))
- (and (rtl:machine-constant? type)
- (zero? (rtl:machine-constant-value type))))
- (let ((datum (rtl:cons-pointer-datum expression)))
- (and (rtl:machine-constant? datum)
- (zero? (rtl:machine-constant-value datum))))
- 0))
- (else false)))
-\f
-(define (define-arithmetic-method operator methods method)
- (let ((entry (assq operator (cdr methods))))
- (if entry
- (set-cdr! entry method)
- (set-cdr! methods (cons (cons operator method) (cdr methods)))))
- operator)
-
-(define (lookup-arithmetic-method operator methods)
- (cdr (or (assq operator (cdr methods))
- (error "Unknown operator" operator))))
-
-(define-integrable (arithmetic-method? operator methods)
- (assq operator (cdr methods)))
-
-(define (fits-in-5-bits-signed? value)
- (<= #x-10 value #xF))
-
-(define (fits-in-11-bits-signed? value)
- (<= #x-400 value #x3FF))
-
-(define (fits-in-14-bits-signed? value)
- (<= #x-2000 value #x1FFF))
-
-(define-integrable (ea/mode ea) (car ea))
-(define-integrable (register-ea/register ea) (cadr ea))
-(define-integrable (offset-ea/offset ea) (cadr ea))
-(define-integrable (offset-ea/space ea) (caddr ea))
-(define-integrable (offset-ea/register ea) (cadddr ea))
-
-(define (pseudo-register-displacement register)
- ;; Register block consists of 16 4-byte registers followed by 256
- ;; 8-byte temporaries.
- (+ (* 4 16) (* 8 (register-renumber register))))
-
-(define-integrable (float-register->fpr register)
- ;; Float registers are represented by 32 through 47/63 in the RTL,
- ;; corresponding to registers 0 through 15/31 in the machine.
- (- register 32))
-
-(define-integrable (fpr->float-register register)
- (+ register 32))
-
-(define-integrable reg:memtop
- (INST-EA (OFFSET #x0000 0 ,regnum:regs-pointer)))
-
-(define-integrable reg:environment
- (INST-EA (OFFSET #x000C 0 ,regnum:regs-pointer)))
-
-(define-integrable reg:lexpr-primitive-arity
- (INST-EA (OFFSET #x001C 0 ,regnum:regs-pointer)))
-
-(define-integrable reg:stack-guard
- (INST-EA (OFFSET #x002C 0 ,regnum:regs-pointer)))
-
-(define (lap:make-label-statement label)
- (LAP (LABEL ,label)))
-
-(define (lap:make-unconditional-branch label)
- (LAP (B (N) (@PCR ,label))))
-
-(define (lap:make-entry-point label block-start-label)
- block-start-label
- (LAP (ENTRY-POINT ,label)
- ,@(make-external-label expression-code-word label)))
-\f
-;;;; Codes and Hooks
-
-(let-syntax ((define-codes
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(BEGIN
- ,@(let loop ((names (cddr form)) (index (cadr form)))
- (if (pair? names)
- (cons `(DEFINE-INTEGRABLE
- ,(symbol-append 'CODE:COMPILER-
- (car names))
- ,index)
- (loop (cdr names) (+ index 1)))
- '())))))))
- (define-codes #x012
- primitive-apply primitive-lexpr-apply
- apply error lexpr-apply link
- interrupt-closure interrupt-dlink interrupt-procedure
- interrupt-continuation interrupt-ic-procedure
- assignment-trap cache-reference-apply
- reference-trap safe-reference-trap unassigned?-trap
- -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero?
- access lookup safe-lookup unassigned? unbound?
- set! define lookup-apply primitive-error
- quotient remainder modulo
- reflect-to-interface interrupt-continuation-2
- compiled-code-bkpt compiled-closure-bkpt))
-
-(define-integrable (invoke-interface-ble code)
- ;; Jump to scheme-to-interface-ble
- (LAP (BLE () (OFFSET 0 4 ,regnum:scheme-to-interface-ble))
- (LDI () ,code 28)))
-
-;;; trampoline-to-interface uses (OFFSET 4 4 ,regnum:scheme-to-interface-ble)
-
-(define-integrable (invoke-interface code)
- ;; Jump to scheme-to-interface
- (LAP (BLE () (OFFSET 12 4 ,regnum:scheme-to-interface-ble))
- (LDI () ,code 28)))
-\f
-(let-syntax ((define-hooks
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(BEGIN
- ,@(let loop ((names (cddr form)) (index (cadr form)))
- (if (pair? names)
- (cons `(DEFINE-INTEGRABLE
- ,(symbol-append 'HOOK:COMPILER-
- (car names))
- ,index)
- (loop (cdr names) (+ index 8)))
- '())))))))
- (define-hooks 100
- store-closure-code
- store-closure-entry ; newer version of store-closure-code.
- multiply-fixnum
- fixnum-quotient
- fixnum-remainder
- fixnum-lsh
- &+
- &-
- &*
- &/
- &=
- &<
- &>
- 1+
- -1+
- zero?
- positive?
- negative?
- shortcircuit-apply
- shortcircuit-apply-1
- shortcircuit-apply-2
- shortcircuit-apply-3
- shortcircuit-apply-4
- shortcircuit-apply-5
- shortcircuit-apply-6
- shortcircuit-apply-7
- shortcircuit-apply-8
- stack-and-interrupt-check
- invoke-primitive
- vector-cons
- string-allocate
- floating-vector-cons
- flonum-sin
- flonum-cos
- flonum-tan
- flonum-asin
- flonum-acos
- flonum-atan
- flonum-exp
- flonum-log
- flonum-truncate
- flonum-ceiling
- flonum-floor
- flonum-atan2
- compiled-code-bkpt
- compiled-closure-bkpt
- copy-closure-pattern
- copy-multiclosure-pattern))
-\f
-;; There is a NOP here because otherwise the return address would have
-;; to be adjusted by the hook code. This gives more flexibility to the
-;; compiler since it may be able to eliminate the NOP by moving an
-;; instruction preceding the BLE to the delay slot.
-
-(define (invoke-hook hook)
- (LAP (BLE () (OFFSET ,hook 4 ,regnum:scheme-to-interface-ble))
- (NOP ())))
-
-;; This is used when not returning. It uses BLE instead of BE as a debugging
-;; aid. The hook gets a return address pointing to the caller, even
-;; though the code will not return.
-
-(define (invoke-hook/no-return hook)
- (LAP (BLE (N) (OFFSET ,hook 4 ,regnum:scheme-to-interface-ble))))
-
-(define (require-registers! . regs)
- (let ((code (apply clear-registers! regs)))
- (need-registers! regs)
- code))
-
-(define (load-interface-args! first second third fourth)
- (let ((clear-regs
- (apply clear-registers!
- (append (if first (list regnum:first-arg) '())
- (if second (list regnum:second-arg) '())
- (if third (list regnum:third-arg) '())
- (if fourth (list regnum:fourth-arg) '()))))
- (load-reg
- (lambda (reg arg)
- (if reg (load-machine-register! reg arg) (LAP)))))
- (let ((load-regs
- (LAP ,@(load-reg first regnum:first-arg)
- ,@(load-reg second regnum:second-arg)
- ,@(load-reg third regnum:third-arg)
- ,@(load-reg fourth regnum:fourth-arg))))
- (LAP ,@clear-regs
- ,@load-regs
- ,@(clear-map!)))))
-
-
-(define (pre-lapgen-analysis rgraphs)
- rgraphs
- unspecific)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Optimizer for HP Precision Archtecture.
-;; package: (compiler lap-optimizer)
-
-(declare (usual-integrations))
-\f
-;;;; An instruction classifier and decomposer
-
-(define-integrable (float-reg reg)
- (+ 32 reg))
-
-(define (classify-instruction instr)
- ;; (values type target source-1 source-2 offset)
- ;; This needs the following:
- ;; - Loads with base modification (LDWM)
- ;; - Third source (indexed loads)
- (let ((opcode (car instr)))
- (cond ((memq opcode '(ANDCM AND OR XOR UXOR SUB DS SUBT
- SUBB ADD SH1ADD SH2ADD SH3ADD ADDC
- COMCLR UADDCM UADDCMT ADDL SH1ADDL
- SH2ADDL SH3ADDL SUBO SUBTO SUBBO
- ADDO SH1ADDO SH2ADDO SH3ADDO ADDCO
- VSHD SHD))
- ;; source source ... target
- (values 'ALU
- ;; not (list-ref instr 4)
- (car (last-pair instr))
- (list-ref instr 2)
- (list-ref instr 3)
- false))
- ((memq opcode '(ADDI ADDIO ADDIT ADDITO SUBI SUBIO COMICLR))
- ;; immed source target
- (values 'ALU
- (list-ref instr 4)
- (list-ref instr 3)
- false
- false))
- ((memq opcode '(COPY))
- ;; source target
- (values 'ALU
- (list-ref instr 3)
- (list-ref instr 2)
- false
- false))
- ((memq opcode '(LDW LDB LDO LDH))
- ;; (offset n m source) target
- (let ((offset (list-ref instr 2)))
- (values 'MEMORY
- (list-ref instr 3)
- (cadddr offset)
- false
- (cadr offset))))
- ((memq opcode '(STW STB STH))
- ;; source1 (offset n m source2)
- (let ((offset (list-ref instr 3)))
- (values 'MEMORY
- false
- (list-ref instr 2)
- (cadddr offset)
- (cadr offset))))
- ((memq opcode '(STWM STWS))
- ;; source1 (offset n m target/source)
- (let* ((offset (list-ref instr 3))
- (base (cadddr offset)))
- (values 'MEMORY
- base
- (list-ref instr 2)
- base
- (cadr offset))))
-\f
- ((memq opcode '(LDI LDIL))
- ;; immed target
- (values 'ALU
- (list-ref instr 3)
- false
- false
- false))
- ((memq opcode '(ADDIL))
- ;; immed source
- (values 'ALU
- regnum:addil-result
- (list-ref instr 3)
- false
- false))
- ((memq opcode '(NOP))
- (values 'ALU false false false false))
- ((memq opcode '(VDEPI DEPI ZVDEPI ZDEPI))
- (values 'ALU
- (car (last-pair instr))
- false
- false
- false))
- ((memq opcode '(EXTRU EXTRS DEP ZDEP))
- (values 'ALU
- (list-ref instr 5)
- (list-ref instr 2)
- false
- false))
- ((memq opcode '(VEXTRU VEXTRS VDEP ZVDEP))
- (values 'ALU
- (list-ref instr 4)
- (list-ref instr 2)
- false
- false))
- ((memq opcode '(FCPY FABS FSQRT FRND))
- ;; source target
- (values 'FALU
- (float-reg (list-ref instr 3))
- (float-reg (list-ref instr 2))
- false
- false))
- ((memq opcode '(FADD FSUB FMPY FDIV FREM))
- ;; source1 source2 target
- (values 'FALU
- (float-reg (list-ref instr 4))
- (float-reg (list-ref instr 2))
- (float-reg (list-ref instr 3))
- false))
- ((eq? opcode 'FSTDS)
- ;; source (offset n m base)
- (let* ((offset (list-ref instr 3))
- (base (cadddr offset)))
- (values 'MEMORY
- (and (or (memq 'MA (cadr instr))
- (memq 'MB (cadr instr)))
- base)
- base
- (float-reg (list-ref instr 2))
- (cadr offset))))
-\f
- #|
- ((memq opcode '(B BL GATE))
- <>)
- ((memq opcode '(BV BLR))
- ;; source-1 source-2
- (values 'CONTROL
- false
- (list-ref instr 2)
- (list-ref instr 3)
- false))
- ((memq opcode '(BLR))
- ;; source target
- (values 'CONTROL
- (list-ref instr 3)
- (list-ref instr 2)
- false
- false))
- ((memq opcode '(BV))
- ;; source-1 source-2
- (values 'CONTROL
- false
- (list-ref instr 2)
- (list-ref instr 3)
- false))
- ((memq opcode '(BE))
- <>)
- ((memq opcode '(BLE))
- <>)
- ((memq opcode '(COMB ...))
- <>)
- ((memq opcode '(PCR-HOOK))
- <>)
- ((memq opcode '(LABEL EQUATE ENTRY-POINT
- EXTERNAL-LABEL BLOCK-OFFSET
- SCHEME-OBJECT SCHEME-EVALUATION PADDING))
- (values 'DIRECTIVE false false false false))
- |#
- (else
- (values 'UNKNOWN false false false false)))))
-
-(define (offset-fits? offset opcode)
- (and (number? offset)
- (memq opcode '(LDW LDB LDO LDH STW STB STH STWM LDWM
- STWS LDWS FLDWS FLDDS FSTWS FSTDS))
- (<= -8192 offset 8191)))
-\f
-;;;; Utilities
-
-;; A trivial pattern matcher
-
-(define (match pattern instance)
- (let ((dict '(("empty" . empty))))
-
- (define (match-internal pattern instance)
- (cond ((not (pair? pattern))
- (eqv? pattern instance))
- ((eq? (car pattern) '?)
- (let ((var (cadr pattern))
- (val instance))
- (cond ((eq? var '?) ; quoting ?
- (eq? val '?))
- ((assq var dict)
- => (lambda (place)
- (equal? (cdr place) val)))
- (else
- (set! dict (cons (cons var val) dict))
- true))))
- (else
- (and (pair? instance)
- (match-internal (car pattern) (car instance))
- (match-internal (cdr pattern) (cdr instance))))))
-
- (and (match-internal pattern instance)
- dict)))
-
-(define (pc-sensitive? instr)
- (or (eq? instr '*PC*)
- (and (pair? instr)
- (or (pc-sensitive? (car instr))
- (pc-sensitive? (cdr instr))))))
-
-(define (skips? instr)
- ;; Not really true, for example
- ;; (COMBT (<) ...)
- (and (pair? (cadr instr))
- (not (memq (car instr)
- '(B BL BV BLR BLE BE
- LDWS LDHS LDBS LDCWS
- STWS STHS STBS STBYS
- FLDWS FLDDS FSTWS FSTDS)))
- ;; or SGL, or QUAD, but not used now.
- (not (memq 'DBL (cadr instr)))))
-
-(define (find-or-label instrs)
- (and (not (null? instrs))
- (if (memq (caar instrs)
- '(COMMENT SCHEME-OBJECT SCHEME-EVALUATION EQUATE))
- (find-or-label (cdr instrs))
- instrs)))
-
-(define (find-non-label instrs)
- (and (not (null? instrs))
- (if (memq (caar instrs)
- '(LABEL COMMENT SCHEME-OBJECT SCHEME-EVALUATION EQUATE))
- (find-non-label (cdr instrs))
- instrs)))
-
-(define (list-difference whole suffix)
- (if (eq? whole suffix)
- '()
- (cons (car whole)
- (list-difference (cdr whole) suffix))))
-\f
-(define (fix-complex-return ret frame junk instr avoid)
- (let ((syll `(OFFSET ,frame 0 ,regnum:stack-pointer)))
- (if (and (eq? (car instr) 'STW)
- (equal? (cadddr instr) syll))
- ;; About to store return address. Forego store completely
- (let ((ret (caddr instr)))
- `(,@(reverse junk)
- (DEP () ,regnum:quad-bitmask
- ,(-1+ scheme-type-width)
- ,scheme-type-width
- ,ret)
- (BV () 0 ,ret)
- (LDO () (OFFSET ,(+ frame 4) 0 ,regnum:stack-pointer)
- ,regnum:stack-pointer)))
- (let ((ret (list-search-positive
- (list ret regnum:first-arg regnum:second-arg
- regnum:third-arg regnum:fourth-arg)
- (lambda (reg)
- (not (memq reg avoid))))))
- `(,@(reverse junk)
- (LDW () ,syll ,ret)
- ,instr
- (DEP () ,regnum:quad-bitmask
- ,(-1+ scheme-type-width)
- ,scheme-type-width
- ,ret)
- (BV () 0 ,ret)
- (LDO () (OFFSET ,(+ frame 4) 0 ,regnum:stack-pointer)
- ,regnum:stack-pointer))))))
-
-(define (fix-simple-return ret frame junk)
- `(,@(reverse junk)
- (LDW () (OFFSET ,frame 0 ,regnum:stack-pointer) ,ret)
- (LDO () (OFFSET ,(+ frame 4) 0 ,regnum:stack-pointer)
- ,regnum:stack-pointer)
- (DEP () ,regnum:quad-bitmask
- ,(-1+ scheme-type-width)
- ,scheme-type-width
- ,ret)
- (BV (N) 0 ,ret)))
-
-(define (fix-a-return dict1 junk dict2 rest)
- (let* ((next (find-or-label rest))
- (next* (and next (find-non-label next)))
- (frame (cdr (assq 'frame dict2)))
- (ret (cdr (assq 'ret dict1))))
- (cond ((or (not next)
- (pc-sensitive? (car next))
- (memq (caar next)
- '(ENTRY-POINT EXTERNAL-LABEL BLOCK-OFFSET PCR-HOOK))
- (and (eq? (caar next) 'LABEL)
- (or (not next*)
- (not (skips? (car next*))))))
- (values (fix-simple-return ret frame junk)
- rest))
- ((or (eq? (caar next) 'LABEL)
- (skips? (car next)))
- (values '() false))
- (else
- (with-values
- (lambda () (classify-instruction (car next)))
- (lambda (type target src1 src2 offset)
- offset ; ignored
- (if (or (not (memq type '(MEMORY ALU FALU)))
- (eq? target regnum:stack-pointer))
- (values (fix-simple-return ret frame junk)
- rest)
- (values
- (fix-complex-return ret frame
- (append junk
- (list-difference rest next))
- (car next)
- (list target src1 src2))
- (cdr next)))))))))
-\f
-(define (fix-sequences instrs tail)
- (define-integrable (fail)
- (fix-sequences (cdr instrs)
- (cons (car instrs) tail)))
-
- (if (null? instrs)
- tail
- (let* ((instr (car instrs))
- (opcode (car instr)))
- (case opcode
- ((BV)
- (let ((dict1 (match (cdr return-pattern) instrs)))
- (if (not dict1)
- (fail)
- (let* ((tail* (cdddr instrs))
- (next (find-or-label tail*))
- (fail*
- (lambda ()
- (fix-sequences
- tail*
- (append (reverse (list-head instrs 3))
- tail))))
- (dict2
- (and next
- (match (car return-pattern) (car next)))))
-
- (if (not dict2)
- (fail*)
- (with-values
- (lambda ()
- (fix-a-return dict1
- (list-difference tail* next)
- dict2
- (cdr next)))
- (lambda (frobbed untouched)
- (if (null? frobbed)
- (fail*)
- (fix-sequences untouched
- (append frobbed tail))))))))))
- ((B BE BLE)
- (let ((completer (cadr instr)))
- (if (or (not (pair? completer))
- (not (eq? 'N (car completer)))
- (not (null? (cdr completer))))
- (fail)
- (with-values (lambda () (find-movable-instr (cdr instrs)))
- (lambda (movable junk rest)
- (if (not movable)
- (fail)
- (fix-sequences
- rest
- `(,@(reverse junk)
- (,opcode () ,@(cddr instr))
- ,movable
- ,@tail))))))))
-\f
- ((NOP)
- (let ((dict (match hook-pattern instrs)))
- (if (not dict)
- (fail)
- (with-values (lambda () (find-movable-instr (cddr instrs)))
- (lambda (movable junk rest)
- (if (not movable)
- (fail)
- (fix-sequences
- rest
- `(,@(reverse junk)
- ,(cadr instrs)
- ,movable
- ,@tail))))))))
- (else
- (fail))))))
-
-(define (find-movable-instr instrs)
- (let* ((next (find-or-label instrs))
- (instr (and next (car next)))
- (next* (and next (find-non-label (cdr next)))))
- (if (and instr
- (with-values (lambda () (classify-instruction instr))
- (lambda (type tgt src1 src2 offset)
- tgt src1 src2 ; ignored
- (or (memq type '(ALU FALU))
- (and (eq? type 'MEMORY)
- (offset-fits? offset (car instr))))))
- (not (skips? instr))
- (not (pc-sensitive? instr))
- (or (not next*)
- (not (skips? (car next*)))))
- (values instr
- (list-difference instrs next)
- (cdr next))
- (values false false false))))
-
-(define return-pattern ; reversed
- (cons
- `(LDO () (OFFSET (? frame) 0 ,regnum:stack-pointer) ,regnum:stack-pointer)
- `((BV (N) 0 (? ret))
- (DEP () ,regnum:quad-bitmask
- ,(-1+ scheme-type-width)
- ,scheme-type-width
- (? ret))
- (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) (? ret))
- . (? more-insts))))
-
-(define hook-pattern
- `((NOP ())
- (BLE () (OFFSET (? hook) 4 ,regnum:scheme-to-interface-ble))
- . (? more-insts)))
-
-(define (optimize-linear-lap instructions)
- (fix-sequences (reverse! instructions) '()))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;; Machine Model for Spectrum
-;;; package: (compiler)
-
-(declare (usual-integrations))
-\f
-;;;; Architecture Parameters
-
-(define use-pre/post-increment? true)
-(define-integrable endianness 'BIG)
-(define-integrable addressing-granularity 8)
-(define-integrable scheme-object-width 32)
-(define-integrable scheme-type-width 6) ;or 8
-
-;; NOTE: expt is not being constant-folded now.
-;; For the time being, some of the parameters below are
-;; pre-computed and marked with ***
-;; There are similar parameters in lapgen.scm
-;; Change them if any of the parameters above do.
-
-(define-integrable scheme-datum-width
- (- scheme-object-width scheme-type-width))
-
-(define-integrable type-scale-factor
- ;; (expt 2 (- 8 scheme-type-width)) ***
- 4)
-
-(define-integrable float-width 64)
-(define-integrable float-alignment 64)
-
-(define-integrable address-units-per-float
- (quotient float-width addressing-granularity))
-
-;;; It is currently required that both packed characters and objects
-;;; be integrable numbers of address units. Furthermore, the number
-;;; of address units per object must be an integral multiple of the
-;;; number of address units per character. This will cause problems
-;;; on a machine that is word addressed: we will have to rethink the
-;;; character addressing strategy.
-
-(define-integrable address-units-per-object
- (quotient scheme-object-width addressing-granularity))
-
-(define-integrable address-units-per-packed-char 1)
-
-(define-integrable signed-fixnum/upper-limit
- ;; (expt 2 (-1+ scheme-datum-width)) ***
- 33554432)
-
-(define-integrable signed-fixnum/lower-limit
- (- signed-fixnum/upper-limit))
-
-(define-integrable unsigned-fixnum/upper-limit
- (* 2 signed-fixnum/upper-limit))
-
-(define-integrable (stack->memory-offset offset) offset)
-(define-integrable ic-block-first-parameter-offset 2)
-(define-integrable execute-cache-size 3) ; Long words per UUO link slot
-\f
-;;;; Closures and multi-closures
-
-;; On the 68k, to save space, entries can be at 2 mod 4 addresses,
-;; which makes it impossible to use an arbitrary closure entry-point
-;; to reference closed-over variables since the compiler only uses
-;; long-word offsets. Instead, all closure entry points are bumped
-;; back to the first entry point, which is always long-word aligned.
-
-;; On the HP-PA, and all other RISCs, all the entry points are
-;; long-word aligned, so there is no need to bump back to the first
-;; entry point.
-
-(define-integrable closure-entry-size
- #|
- Long words in a single closure entry:
- GC offset word
- LDIL L'target,26
- BLE R'target(5,26)
- ADDI -12,31,31
- |#
- 4)
-
-;; Given: the number of entry points in a closure, and a particular
-;; entry point number, compute the distance from that entry point to
-;; the first variable slot in the closure object (in long words).
-
-(define (closure-first-offset nentries entry)
- (if (zero? nentries)
- 1 ; Strange boundary case
- (- (* closure-entry-size (- nentries entry)) 1)))
-
-;; Like the above, but from the start of the complete closure object,
-;; viewed as a vector, and including the header word.
-
-(define (closure-object-first-offset nentries)
- (case nentries
- ((0)
- ;; Vector header only
- 1)
- ((1)
- ;; Manifest closure header followed by single entry point
- (+ 1 closure-entry-size))
- (else
- ;; Manifest closure header, number of entries, then entries.
- (+ 1 1 (* closure-entry-size nentries)))))
-
-;; Bump distance in bytes from one entry point to another.
-;; Used for invocation purposes.
-
-(define (closure-entry-distance nentries entry entry*)
- nentries ; ignored
- (* (* closure-entry-size 4) (- entry* entry)))
-
-;; Bump distance in bytes from one entry point to the entry point used
-;; for variable-reference purposes.
-;; On a RISC, this is the entry point itself.
-
-(define (closure-environment-adjustment nentries entry)
- nentries entry ; ignored
- 0)
-\f
-;;;; Machine Registers
-
-(define-integrable g0 0)
-(define-integrable g1 1)
-(define-integrable g2 2)
-(define-integrable g3 3)
-(define-integrable g4 4)
-(define-integrable g5 5)
-(define-integrable g6 6)
-(define-integrable g7 7)
-(define-integrable g8 8)
-(define-integrable g9 9)
-(define-integrable g10 10)
-(define-integrable g11 11)
-(define-integrable g12 12)
-(define-integrable g13 13)
-(define-integrable g14 14)
-(define-integrable g15 15)
-(define-integrable g16 16)
-(define-integrable g17 17)
-(define-integrable g18 18)
-(define-integrable g19 19)
-(define-integrable g20 20)
-(define-integrable g21 21)
-(define-integrable g22 22)
-(define-integrable g23 23)
-(define-integrable g24 24)
-(define-integrable g25 25)
-(define-integrable g26 26)
-(define-integrable g27 27)
-(define-integrable g28 28)
-(define-integrable g29 29)
-(define-integrable g30 30)
-(define-integrable g31 31)
-
-;; fp0 - fp3 are status registers. The rest are real registers
-(define-integrable fp0 32)
-(define-integrable fp1 33)
-(define-integrable fp2 34)
-(define-integrable fp3 35)
-(define-integrable fp4 36)
-(define-integrable fp5 37)
-(define-integrable fp6 38)
-(define-integrable fp7 39)
-(define-integrable fp8 40)
-(define-integrable fp9 41)
-(define-integrable fp10 42)
-(define-integrable fp11 43)
-(define-integrable fp12 44)
-(define-integrable fp13 45)
-(define-integrable fp14 46)
-(define-integrable fp15 47)
-
-;; The following registers are available only on the newer processors
-(define-integrable fp16 48)
-(define-integrable fp17 49)
-(define-integrable fp18 50)
-(define-integrable fp19 51)
-(define-integrable fp20 52)
-(define-integrable fp21 53)
-(define-integrable fp22 54)
-(define-integrable fp23 55)
-(define-integrable fp24 56)
-(define-integrable fp25 57)
-(define-integrable fp26 58)
-(define-integrable fp27 59)
-(define-integrable fp28 60)
-(define-integrable fp29 61)
-(define-integrable fp30 62)
-(define-integrable fp31 63)
-
-(define-integrable number-of-machine-registers 64)
-(define-integrable number-of-temporary-registers 256)
-\f
-;;; Fixed-use registers for Scheme compiled code.
-(define-integrable regnum:return-value g2)
-(define-integrable regnum:scheme-to-interface-ble g3)
-(define-integrable regnum:regs-pointer g4)
-(define-integrable regnum:quad-bitmask g5)
-(define-integrable regnum:dynamic-link g19)
-(define-integrable regnum:memtop-pointer g20)
-(define-integrable regnum:free-pointer g21)
-(define-integrable regnum:stack-pointer g22)
-
-;;; Fixed-use registers due to architecture or OS calling conventions.
-(define-integrable regnum:zero g0)
-(define-integrable regnum:addil-result g1)
-(define-integrable regnum:C-global-pointer g27)
-(define-integrable regnum:C-return-value g28)
-(define-integrable regnum:C-stack-pointer g30)
-(define-integrable regnum:ble-return g31)
-(define-integrable regnum:fourth-arg g23)
-(define-integrable regnum:third-arg g24)
-(define-integrable regnum:second-arg g25)
-(define-integrable regnum:first-arg g26)
-
-(define (machine-register-value-class register)
- (cond ((or (= register 0)
- (<= 6 register 18)
- (<= 23 register 26)
- (= register 29)
- (= register 31))
- value-class=word)
- ((or (= register 2) (= register 28))
- value-class=object)
- ((or (= register 1) (= register 3))
- value-class=unboxed)
- ((or (= register 4)
- (<= 19 register 22)
- (= register 27)
- (= register 30))
- value-class=address)
- ((= register 5)
- value-class=immediate)
- ((<= 32 register 63)
- value-class=float)
- (else
- (error "illegal machine register" register))))
-
-(define-integrable (machine-register-known-value register)
- register ;ignore
- false)
-\f
-;;;; Interpreter Registers
-
-(define-integrable (interpreter-free-pointer)
- (rtl:make-machine-register regnum:free-pointer))
-
-(define (interpreter-free-pointer? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:free-pointer)))
-
-(define-integrable (interpreter-regs-pointer)
- (rtl:make-machine-register regnum:regs-pointer))
-
-(define (interpreter-regs-pointer? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:regs-pointer)))
-
-(define-integrable (interpreter-value-register)
- (rtl:make-machine-register regnum:return-value))
-
-(define (interpreter-value-register? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:return-value)))
-
-(define-integrable (interpreter-stack-pointer)
- (rtl:make-machine-register regnum:stack-pointer))
-
-(define (interpreter-stack-pointer? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:stack-pointer)))
-
-(define-integrable (interpreter-dynamic-link)
- (rtl:make-machine-register regnum:dynamic-link))
-
-(define (interpreter-dynamic-link? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:dynamic-link)))
-
-(define-integrable (interpreter-environment-register)
- (rtl:make-offset (interpreter-regs-pointer)
- (rtl:make-machine-constant 3)))
-
-(define (interpreter-environment-register? expression)
- (and (rtl:offset? expression)
- (interpreter-regs-pointer? (rtl:offset-base expression))
- (let ((offset (rtl:offset-offset expression)))
- (and (rtl:machine-constant? offset)
- (= 3 (rtl:machine-constant-value offset))))))
-
-(define-integrable (interpreter-register:access)
- (rtl:make-machine-register g28))
-
-(define-integrable (interpreter-register:cache-reference)
- (rtl:make-machine-register g28))
-
-(define-integrable (interpreter-register:cache-unassigned?)
- (rtl:make-machine-register g28))
-
-(define-integrable (interpreter-register:lookup)
- (rtl:make-machine-register g28))
-
-(define-integrable (interpreter-register:unassigned?)
- (rtl:make-machine-register g28))
-
-(define-integrable (interpreter-register:unbound?)
- (rtl:make-machine-register g28))
-\f
-;;;; RTL Registers, Constants, and Primitives
-
-(define (rtl:machine-register? rtl-register)
- (case rtl-register
- ((STACK-POINTER)
- (interpreter-stack-pointer))
- ((DYNAMIC-LINK)
- (interpreter-dynamic-link))
- ((VALUE)
- (interpreter-value-register))
- ((FREE)
- (interpreter-free-pointer))
- ((MEMORY-TOP)
- (rtl:make-machine-register regnum:memtop-pointer))
- ((INTERPRETER-CALL-RESULT:ACCESS)
- (interpreter-register:access))
- ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
- (interpreter-register:cache-reference))
- ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
- (interpreter-register:cache-unassigned?))
- ((INTERPRETER-CALL-RESULT:LOOKUP)
- (interpreter-register:lookup))
- ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
- (interpreter-register:unassigned?))
- ((INTERPRETER-CALL-RESULT:UNBOUND?)
- (interpreter-register:unbound?))
- (else false)))
-
-(define (rtl:interpreter-register? rtl-register)
- (case rtl-register
- ((INT-MASK) 1)
- ((ENVIRONMENT) 3)
- ((TEMPORARY) 4)
- (else false)))
-
-(define (rtl:interpreter-register->offset locative)
- (or (rtl:interpreter-register? locative)
- (error "Unknown register type" locative)))
-
-(define (rtl:constant-cost expression)
- ;; Magic numbers.
- (let ((if-integer
- (lambda (value)
- (cond ((zero? value) 1)
- ((fits-in-5-bits-signed? value) 2)
- (else 3)))))
- (let ((if-synthesized-constant
- (lambda (type datum)
- (if-integer (make-non-pointer-literal type datum)))))
- (case (rtl:expression-type expression)
- ((CONSTANT)
- (let ((value (rtl:constant-value expression)))
- (if (non-pointer-object? value)
- (if-synthesized-constant (object-type value)
- (object-datum value))
- 3)))
- ((MACHINE-CONSTANT)
- (if-integer (rtl:machine-constant-value expression)))
- ((ENTRY:PROCEDURE
- ENTRY:CONTINUATION
- ASSIGNMENT-CACHE
- VARIABLE-CACHE
- OFFSET-ADDRESS
- BYTE-OFFSET-ADDRESS
- FLOAT-OFFSET-ADDRESS)
- 3)
- ((CONS-POINTER)
- (and (rtl:machine-constant? (rtl:cons-pointer-type expression))
- (rtl:machine-constant? (rtl:cons-pointer-datum expression))
- (if-synthesized-constant
- (rtl:machine-constant-value (rtl:cons-pointer-type expression))
- (rtl:machine-constant-value
- (rtl:cons-pointer-datum expression)))))
- (else false)))))
-
-(define compiler:open-code-floating-point-arithmetic?
- true)
-
-(define compiler:primitives-with-no-open-coding
- '(DIVIDE-FIXNUM GCD-FIXNUM &/ FLONUM-EXPM1 FLONUM-LOG1P))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Compiler: System Construction
-
-(declare (usual-integrations))
-
-(let ((value ((load "base/make") "HPPA")))
- (set! (access compiler:compress-top-level? (->environment '(compiler)))
- #t)
- value)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RTL Generation: Special primitive combinations. Spectrum version.
-
-(declare (usual-integrations))
-\f
-(define (define-special-primitive-handler name handler)
- (let ((primitive (make-primitive-procedure name true)))
- (let ((entry (assq primitive special-primitive-handlers)))
- (if entry
- (set-cdr! entry handler)
- (set! special-primitive-handlers
- (cons (cons primitive handler)
- special-primitive-handlers)))))
- name)
-
-(define (special-primitive-handler primitive)
- (let ((entry (assq primitive special-primitive-handlers)))
- (and entry
- ((cdr entry)))))
-
-(define special-primitive-handlers
- '())
-
-(define (define-special-primitive/standard primitive)
- (define-special-primitive-handler primitive
- (lambda ()
- rtl:make-invocation:special-primitive)))
-
-(define (define-special-primitive/if-open-coding primitive)
- (define-special-primitive-handler primitive
- (lambda ()
- (and compiler:open-code-primitives?
- rtl:make-invocation:special-primitive))))
-
-(define-special-primitive/standard '&+)
-(define-special-primitive/standard '&-)
-(define-special-primitive/standard '&*)
-(define-special-primitive/standard '&/)
-(define-special-primitive/standard '&=)
-(define-special-primitive/standard '&<)
-(define-special-primitive/standard '&>)
-(define-special-primitive/standard '1+)
-(define-special-primitive/standard '-1+)
-(define-special-primitive/standard 'zero?)
-(define-special-primitive/standard 'positive?)
-(define-special-primitive/standard 'negative?)
-(define-special-primitive/standard 'quotient)
-(define-special-primitive/standard 'remainder)
-(define-special-primitive/if-open-coding 'vector-cons)
-(define-special-primitive/if-open-coding 'string-allocate)
-(define-special-primitive/if-open-coding 'floating-vector-cons)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Data Transfers
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Simple Operations
-
-;;; All assignments to pseudo registers are required to delete the
-;;; dead registers BEFORE performing the assignment. However, it is
-;;; necessary to derive the effective address of the source
-;;; expression(s) before deleting the dead registers. Otherwise any
-;;; source expression containing dead registers might refer to aliases
-;;; which have been reused.
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
- (standard-move-to-target! source target)
- (LAP))
-
-(define-rule statement
- ;; tag the contents of a register
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum))))
- (let* ((type (standard-source! type))
- (target (standard-move-to-target! datum target)))
- (LAP (DEP () ,type ,(-1+ scheme-type-width) ,scheme-type-width ,target))))
-
-(define-rule statement
- ;; tag the contents of a register
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source))))
- ;; (QUALIFIER (fits-in-5-bits-signed? type))
- ;; This qualifier does not work because the qualifiers are not
- ;; tested in the rtl compressor. The qualifier is combined with
- ;; the rule body into a single procedure, and the rtl compressor
- ;; cannot invoke it since it is not in the context of the lap
- ;; generator. Thus the qualifier is not checked, the RTL instruction
- ;; is compressed, and then the lap generator fails when the qualifier
- ;; fails.
- (deposit-type type (standard-move-to-target! source target)))
-
-(define-rule statement
- ;; extract the type part of a register's contents
- (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
- (standard-unary-conversion source target object->type))
-
-(define-rule statement
- ;; extract the datum part of a register's contents
- (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
- (standard-unary-conversion source target object->datum))
-
-(define-rule statement
- ;; convert the contents of a register to an address
- (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
- (object->address (standard-move-to-target! source target)))
-
-(define-rule statement
- ;; pop an object off the stack
- (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER (? reg)) 1))
- (QUALIFIER (= reg regnum:stack-pointer))
- (LAP
- (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,(standard-target! target))))
-\f
-;;;; Indexed modes
-
-(define-rule statement
- ;; read an object from memory
- (ASSIGN (REGISTER (? target))
- (OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset))))
- (standard-unary-conversion base target
- (lambda (base target)
- (load-word (* 4 offset) base target))))
-
-(define-rule statement
- ;; read an object from memory
- (ASSIGN (REGISTER (? target))
- (OFFSET (REGISTER (? base)) (REGISTER (? offset))))
- (let ((base (standard-source! base))
- (offset (standard-source! offset)))
- (let ((target (standard-target! target)))
- (LAP (LDWX (S) (INDEX ,offset 0 ,base) ,target)))))
-\f
-;;;; Address manipulation
-
-(define-rule statement
- ;; add a constant offset (in long words) to a register's contents
- (ASSIGN (REGISTER (? target))
- (OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? offset))))
- (standard-unary-conversion base target
- (lambda (base target)
- (load-offset (* 4 offset) base target))))
-
-(define-rule statement
- ;; add a constant offset (in bytes) to a register's contents
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? offset))))
- (standard-unary-conversion base target
- (lambda (base target)
- (load-offset offset base target))))
-
-(define-rule statement
- ;; add a constant offset (in bytes) to a register's contents
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? offset))))
- (standard-unary-conversion base target
- (lambda (base target)
- (load-offset (* 8 offset) base target))))
-
-(define-rule statement
- ;; add a computed offset (in long words) to a register's contents
- (ASSIGN (REGISTER (? target))
- (OFFSET-ADDRESS (REGISTER (? base))
- (REGISTER (? offset))))
- (indexed-load-address target base offset 4))
-
-(define-rule statement
- ;; add a computed offset (in long words) to a register's contents
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET-ADDRESS (REGISTER (? base))
- (REGISTER (? offset))))
- (indexed-load-address target base offset 1))
-
-(define-rule statement
- ;; add a computed offset (in long words) to a register's contents
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET-ADDRESS (REGISTER (? base))
- (REGISTER (? offset))))
- (indexed-load-address target base offset 8))
-
-;;; Optimized address operations
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
- (OBJECT->DATUM (REGISTER (? index)))))
- (indexed-object->address target base index 4))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
- (OBJECT->DATUM (REGISTER (? index)))))
- (indexed-object->address target base index 1))
-\f
-;; These have to be here because the instruction combiner
-;; operates by combining one piece at a time, and the intermediate
-;; pieces can be generated.
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
- (REGISTER (? index))))
- (indexed-object->address target base index 4))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
- (REGISTER (? index))))
- (indexed-object->address target base index 1))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OFFSET-ADDRESS (REGISTER (? base))
- (OBJECT->DATUM (REGISTER (? index)))))
- (indexed-object->datum target base index 4))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET-ADDRESS (REGISTER (? base))
- (OBJECT->DATUM (REGISTER (? index)))))
- (indexed-object->datum target base index 1))
-
-(define (indexed-load-address target base index scale)
- (let ((base (standard-source! base))
- (index (standard-source! index)))
- (%indexed-load-address (standard-target! target) base index scale)))
-
-(define (indexed-object->datum target base index scale)
- (let ((base (standard-source! base))
- (index (standard-source! index))
- (temp (standard-temporary!)))
- (let ((target (standard-target! target)))
- (LAP ,@(object->datum index temp)
- ,@(%indexed-load-address target base temp scale)))))
-
-(define (indexed-object->address target base index scale)
- (let ((base (standard-source! base))
- (index (standard-source! index)))
- (let ((target (standard-target! target)))
- (LAP ,@(%indexed-load-address target base index scale)
- ,@(object->address target)))))
-
-(define (%indexed-load-address target base index scale)
- (case scale
- ((4)
- (LAP (SH2ADDL () ,index ,base ,target)))
- ((8)
- (LAP (SH3ADDL () ,index ,base ,target)))
- ((1)
- (LAP (ADDL () ,index ,base ,target)))
- ((2)
- (LAP (SH1ADDL () ,index ,base ,target)))
- (else
- (error "%indexed-load-address: Unknown scale"))))
-\f
-;;;; Loading of Constants
-
-(define-rule statement
- ;; load a machine constant
- (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? source)))
- (load-immediate source (standard-target! target)))
-
-(define-rule statement
- ;; load a Scheme constant
- (ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
- (load-constant source (standard-target! target)))
-
-(define-rule statement
- ;; load the type part of a Scheme constant
- (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (CONSTANT (? constant))))
- (load-non-pointer 0 (object-type constant) (standard-target! target)))
-
-(define-rule statement
- ;; load the datum part of a Scheme constant
- (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant))))
- (QUALIFIER (non-pointer-object? constant))
- (load-non-pointer 0
- (careful-object-datum constant)
- (standard-target! target)))
-
-(define-rule statement
- ;; load a synthesized constant
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum))))
- (load-non-pointer type datum (standard-target! target)))
-
-(define-rule statement
- ;; load the address of a variable reference cache
- (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
- (load-pc-relative (free-reference-label name)
- (standard-target! target)
- 'CONSTANT))
-
-(define-rule statement
- ;; load the address of an assignment cache
- (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name)))
- (load-pc-relative (free-assignment-label name)
- (standard-target! target)
- 'CONSTANT))
-
-(define-rule statement
- ;; load the address of a procedure's entry point
- (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label)))
- (load-pc-relative-address label (standard-target! target) 'CODE))
-
-(define-rule statement
- ;; load the address of a continuation
- (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label)))
- (load-pc-relative-address label (standard-target! target) 'CODE))
-
-;;; Spectrum optimizations
-
-(define (load-entry label target)
- (let ((target (standard-target! target)))
- (LAP ,@(load-pc-relative-address label target 'CODE)
- ,@(address->entry target))))
-
-(define-rule statement
- ;; load a procedure object
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (ENTRY:PROCEDURE (? label))))
- (QUALIFIER (= type (ucode-type compiled-entry)))
- (load-entry label target))
-
-(define-rule statement
- ;; load a return address object
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (ENTRY:CONTINUATION (? label))))
- (QUALIFIER (= type (ucode-type compiled-entry)))
- (load-entry label target))
-\f
-;;;; Transfers to Memory
-
-(define-rule statement
- ;; store an object in memory
- (ASSIGN (OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
- (? source register-expression))
- (QUALIFIER (word-register? source))
- (store-word (standard-source! source)
- (* 4 offset)
- (standard-source! base)))
-
-(define-rule statement
- ;; Push an object register on the heap
- ;; *** IMPORTANT: This uses a STWS instruction with the cache hint set.
- ;; The cache hint prevents newer HP PA processors from loading a cache
- ;; line from memory when it is about to be overwritten.
- ;; In theory this could cause a problem at the very end (64 bytes) of the
- ;; heap, since the last cache line may overlap the next area (the stack).
- ;; ***
- (ASSIGN (POST-INCREMENT (REGISTER (? reg)) 1) (? source register-expression))
- (QUALIFIER (and (= reg regnum:free-pointer)
- (word-register? source)))
- (LAP
- (STWS (MA C) ,(standard-source! source) (OFFSET 4 0 ,regnum:free-pointer))))
-
-(define-rule statement
- ;; Push an object register on the stack
- (ASSIGN (PRE-INCREMENT (REGISTER (? reg)) -1) (? source register-expression))
- (QUALIFIER (and (word-register? source)
- (= reg regnum:stack-pointer)))
- (LAP
- (STWM () ,(standard-source! source) (OFFSET -4 0 ,regnum:stack-pointer))))
-
-;; Cheaper, common patterns.
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
- (MACHINE-CONSTANT 0))
- (store-word 0
- (* 4 offset)
- (standard-source! base)))
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER (? reg)) 1) (MACHINE-CONSTANT 0))
- (QUALIFIER (= reg regnum:free-pointer))
- (LAP (STWS (MA C) 0 (OFFSET 4 0 ,regnum:free-pointer))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER (? reg)) -1) (MACHINE-CONSTANT 0))
- (QUALIFIER (= reg regnum:stack-pointer))
- (LAP (STWM () 0 (OFFSET -4 0 ,regnum:stack-pointer))))
-\f
-;;;; CHAR->ASCII/BYTE-OFFSET
-
-(define-rule statement
- ;; load char object from memory and convert to ASCII byte
- (ASSIGN (REGISTER (? target))
- (CHAR->ASCII (OFFSET (REGISTER (? base))
- (MACHINE-CONSTANT (? offset)))))
- (standard-unary-conversion base target
- (lambda (base target)
- (load-byte (+ 3 (* 4 offset)) base target))))
-
-(define-rule statement
- ;; load ASCII byte from memory
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET (REGISTER (? base))
- (MACHINE-CONSTANT (? offset))))
- (standard-unary-conversion base target
- (lambda (base target)
- (load-byte offset base target))))
-
-(define-rule statement
- ;; load ASCII byte from memory
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET (REGISTER (? base))
- (REGISTER (? offset))))
- (let ((base (standard-source! base))
- (offset (standard-source! offset)))
- (let ((target (standard-target! target)))
- (LAP (LDBX () (INDEX ,offset 0 ,base) ,target)))))
-
-(define-rule statement
- ;; convert char object to ASCII byte
- ;; Missing optimization: If source is home and this is the last
- ;; reference (it is dead afterwards), an LDB could be done instead
- ;; of an LDW followed by an object->datum. This is unlikely since
- ;; the value will be home only if we've spilled it, which happens
- ;; rarely.
- (ASSIGN (REGISTER (? target))
- (CHAR->ASCII (REGISTER (? source))))
- (standard-unary-conversion source target
- (lambda (source target)
- (LAP (EXTRU () ,source 31 8 ,target)))))
-
-(define-rule statement
- ;; store null byte in memory
- (ASSIGN (BYTE-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
- (CHAR->ASCII (CONSTANT #\NUL)))
- (store-byte 0 offset (standard-source! base)))
-
-(define-rule statement
- ;; store ASCII byte in memory
- (ASSIGN (BYTE-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
- (REGISTER (? source)))
- (store-byte (standard-source! source) offset (standard-source! base)))
-
-(define-rule statement
- ;; convert char object to ASCII byte and store it in memory
- ;; register + byte offset <- contents of register (clear top bits)
- (ASSIGN (BYTE-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
- (CHAR->ASCII (REGISTER (? source))))
- (store-byte (standard-source! source) offset (standard-source! base)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$MC68020-Header: rules2.scm,v 4.12 90/01/18 22:44:04 GMT cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Predicates
-
-(declare (usual-integrations))
-\f
-(define-rule predicate
- ;; test for two registers EQ?
- (EQ-TEST (REGISTER (? source1)) (REGISTER (? source2)))
- (compare '= (standard-source! source1) (standard-source! source2)))
-
-(define-rule predicate
- (EQ-TEST (MACHINE-CONSTANT 0) (REGISTER (? register)))
- (compare-immediate '= 0 (standard-source! register)))
-
-(define-rule predicate
- (EQ-TEST (REGISTER (? register)) (MACHINE-CONSTANT 0))
- (compare-immediate '= 0 (standard-source! register)))
-
-(define-rule predicate
- ;; test for register EQ? to constant
- (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register)))
- (eq-test/constant*register constant register))
-
-(define-rule predicate
- ;; test for register EQ? to constant
- (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant)))
- (eq-test/constant*register constant register))
-
-(define (eq-test/constant*register constant source)
- (let ((source (standard-source! source)))
- (if (non-pointer-object? constant)
- (compare-immediate '= (non-pointer->literal constant) source)
- (let ((temp (standard-temporary!)))
- (LAP ,@(load-constant constant temp)
- ,@(compare '= temp source))))))
-
-(define-rule predicate
- ;; test for register EQ? to synthesized constant
- (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum)))
- (REGISTER (? register)))
- (eq-test/synthesized-constant*register type datum register))
-
-(define-rule predicate
- ;; test for register EQ? to synthesized constant
- (EQ-TEST (REGISTER (? register))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum))))
- (eq-test/synthesized-constant*register type datum register))
-
-(define (eq-test/synthesized-constant*register type datum source)
- (compare-immediate '=
- (make-non-pointer-literal type datum)
- (standard-source! source)))
-
-(define-rule predicate
- ;; Branch if virtual register contains the specified type number
- (TYPE-TEST (REGISTER (? register)) (? type))
- (compare-immediate '= type (standard-source! register)))
-
-
-;; Combine tests for fixnum and non-negative by extracting the type
-;; bits and the sign bit.
-
-(define-rule predicate
- (PRED-1-ARG INDEX-FIXNUM?
- (REGISTER (? source)))
- (let ((src (standard-source! source)))
- (let ((temp (standard-temporary!)))
- (LAP (EXTRU () ,src ,(- scheme-type-width 0) ,(+ scheme-type-width 1)
- ,temp)
- ,@(compare-immediate '= (* 2 (ucode-type fixnum)) temp)))))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Invocations and Entries
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Invocations
-
-(define-rule statement
- (POP-RETURN)
- (pop-return))
-
-(define (pop-return)
- (let ((temp (standard-temporary!)))
- (LAP ,@(clear-map!)
- ;; This assumes that the return address is always longword aligned
- ;; (it better be, since instructions should be longword aligned).
- ;; Thus the bottom two bits of temp are 0, representing the
- ;; highest privilege level, and the privilege level will
- ;; not be changed by the BV instruction.
- (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,temp)
- ,@(object->address temp)
- (BV (N) 0 ,temp))))
-
-(define-rule statement
- (INVOCATION:APPLY (? frame-size) (? continuation))
- continuation ;ignore
- (LAP ,@(clear-map!)
- ,@(case frame-size
- ((1) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-1 4
- ,regnum:scheme-to-interface-ble))))
- ((2) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-2 4
- ,regnum:scheme-to-interface-ble))))
- ((3) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-3 4
- ,regnum:scheme-to-interface-ble))))
- ((4) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-4 4
- ,regnum:scheme-to-interface-ble))))
- ((5) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-5 4
- ,regnum:scheme-to-interface-ble))))
- ((6) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-6 4
- ,regnum:scheme-to-interface-ble))))
- ((7) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-7 4
- ,regnum:scheme-to-interface-ble))))
- ((8) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-8 4
- ,regnum:scheme-to-interface-ble))))
- (else
- (LAP ,@(load-immediate frame-size regnum:second-arg)
- (BLE () (OFFSET ,hook:compiler-shortcircuit-apply 4
- ,regnum:scheme-to-interface-ble)))))
- (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,regnum:first-arg)))
-
-(define-rule statement
- (INVOCATION:JUMP (? frame-size) (? continuation) (? label))
- frame-size continuation ;ignore
- (LAP ,@(clear-map!)
- (B (N) (@PCR ,label))))
-
-(define-rule statement
- (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation))
- frame-size continuation ;ignore
- ;; It expects the procedure at the top of the stack
- (pop-return))
-
-(define-rule statement
- (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
- continuation ;ignore
- (LAP ,@(clear-map!)
- ,@(load-immediate number-pushed regnum:second-arg)
- ,@(load-pc-relative-address label regnum:first-arg 'CODE)
- ,@(invoke-interface code:compiler-lexpr-apply)))
-
-(define-rule statement
- (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation))
- continuation ;ignore
- ;; Destination address is at TOS; pop it into first-arg
- (LAP ,@(clear-map!)
- (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,regnum:first-arg)
- ,@(load-immediate number-pushed regnum:second-arg)
- ,@(object->address regnum:first-arg)
- ,@(invoke-interface code:compiler-lexpr-apply)))
-\f
-(define-rule statement
- (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
- continuation ;ignore
- (LAP ,@(clear-map!)
- (B (N) (@PCR ,(free-uuo-link-label name frame-size)))))
-
-(define-rule statement
- (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
- continuation ;ignore
- (LAP ,@(clear-map!)
- (B (N) (@PCR ,(global-uuo-link-label name frame-size)))))
-
-(define-rule statement
- (INVOCATION:CACHE-REFERENCE (? frame-size)
- (? continuation)
- (? extension register-expression))
- continuation ;ignore
- (LAP ,@(load-interface-args! extension false false false)
- ,@(load-immediate frame-size regnum:third-arg)
- ,@(load-pc-relative-address *block-label* regnum:second-arg 'CODE)
- ,@(invoke-interface code:compiler-cache-reference-apply)))
-
-(define-rule statement
- (INVOCATION:LOOKUP (? frame-size)
- (? continuation)
- (? environment register-expression)
- (? name))
- continuation ;ignore
- (LAP ,@(load-interface-args! environment false false false)
- ,(load-constant name regnum:second-arg)
- ,(load-immediate frame-size regnum:third-arg)
- ,@(invoke-interface code:compiler-lookup-apply)))
-
-(define-rule statement
- (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
- continuation ;ignore
- (if (eq? primitive compiled-error-procedure)
- (LAP ,@(clear-map!)
- ,@(load-immediate frame-size regnum:first-arg)
- ,@(invoke-interface code:compiler-error))
- (let ((arity (primitive-procedure-arity primitive)))
- (if (not (negative? arity))
- (invoke-primitive primitive
- hook:compiler-invoke-primitive)
- (LAP ,@(clear-map!)
- ,@(load-pc-relative (constant->label primitive)
- regnum:first-arg
- 'CONSTANT)
- ,@(cond ((= arity -1)
- (LAP ,@(load-immediate (-1+ frame-size) 1)
- (STW () 1 ,reg:lexpr-primitive-arity)
- ,@(invoke-interface
- code:compiler-primitive-lexpr-apply)))
- #|
- ((not (negative? arity))
- (invoke-interface code:compiler-primitive-apply))
- |#
- (else
- ;; Unknown primitive arity. Go through apply.
- (LAP ,@(load-immediate frame-size regnum:second-arg)
- ,@(invoke-interface code:compiler-apply)))))))))
-
-(define (invoke-primitive primitive hook)
- ;; Only for known, fixed-arity primitives
- (LAP ,@(clear-map!)
- ,@(invoke-hook hook)
- (WORD () (- ,(constant->label primitive) *PC*))))
-\f
-(let-syntax
- ((define-special-primitive-invocation
- (sc-macro-transformer
- (lambda (form environment)
- `(DEFINE-RULE STATEMENT
- (INVOCATION:SPECIAL-PRIMITIVE
- (? frame-size)
- (? continuation)
- ,(make-primitive-procedure (cadr form) #t))
- FRAME-SIZE CONTINUATION
- (SPECIAL-PRIMITIVE-INVOCATION
- ,(close-syntax (symbol-append 'CODE:COMPILER- (cadr form))
- environment))))))
-
- (define-optimized-primitive-invocation
- (sc-macro-transformer
- (lambda (form environment)
- `(DEFINE-RULE STATEMENT
- (INVOCATION:SPECIAL-PRIMITIVE
- (? frame-size)
- (? continuation)
- ,(make-primitive-procedure (cadr form) #t))
- FRAME-SIZE CONTINUATION
- (OPTIMIZED-PRIMITIVE-INVOCATION
- ,(close-syntax (symbol-append 'HOOK:COMPILER- (cadr form))
- environment))))))
-
- (define-allocation-primitive
- (sc-macro-transformer
- (lambda (form environment)
- (let ((prim (make-primitive-procedure (cadr form) #t)))
- `(DEFINE-RULE STATEMENT
- (INVOCATION:SPECIAL-PRIMITIVE
- (? frame-size)
- (? continuation)
- ,prim)
- (OPEN-CODE-BLOCK-ALLOCATION
- ',(cadr form)
- ',prim
- ,(close-syntax (symbol-append 'HOOK:COMPILER- (cadr form))
- environment)
- FRAME-SIZE
- CONTINUATION)))))))
-
- (define-optimized-primitive-invocation &+)
- (define-optimized-primitive-invocation &-)
- (define-optimized-primitive-invocation &*)
- (define-optimized-primitive-invocation &/)
- (define-optimized-primitive-invocation &=)
- (define-optimized-primitive-invocation &<)
- (define-optimized-primitive-invocation &>)
- (define-optimized-primitive-invocation 1+)
- (define-optimized-primitive-invocation -1+)
- (define-optimized-primitive-invocation zero?)
- (define-optimized-primitive-invocation positive?)
- (define-optimized-primitive-invocation negative?)
- (define-special-primitive-invocation quotient)
- (define-special-primitive-invocation remainder)
- (define-allocation-primitive vector-cons)
- (define-allocation-primitive string-allocate)
- (define-allocation-primitive floating-vector-cons))
-
-(define (special-primitive-invocation code)
- (LAP ,@(clear-map!)
- ,@(invoke-interface code)))
-
-(define (optimized-primitive-invocation hook)
- (LAP ,@(clear-map!)
- ,@(invoke-hook/no-return hook)))
-
-(define (open-code-block-allocation name prim hook frame-size cont-label)
- name frame-size cont-label ; ignored
- (invoke-primitive prim hook))
-\f
-#|
-(define (open-code-block-allocation name prim hook frame-size cont-label)
- ;; One argument (length in units) on top of the stack.
- ;; Note: The length checked is not necessarily the complete length
- ;; of the object, but is off by a constant number of words, which
- ;; is OK, since we can cons a finite number of words without
- ;; checking.
- (define (default)
- (LAP ,@(clear-map!)
- ,@(load-pc-relative (constant->label prim)
- regnum:first-arg
- 'CONSTANT)
- ,@(invoke-interface code:compiler-primitive-apply)))
-
- hook ; ignored
- (cond ((not (= frame-size 2))
- (error "open-code-allocate-block: Wrong number of arguments"
- prim frame-size))
- ((not compiler:open-code-primitives?)
- (default))
- (else
- (let ((label (generate-label))
- (rsp regnum:stack-pointer)
- (rfp regnum:free-pointer)
- (rmp regnum:memtop-pointer)
- (ra1 regnum:first-arg)
- (ra2 regnum:second-arg)
- (ra3 regnum:third-arg)
- (rrv regnum:return-value))
-
- (define (end tag rl)
- (LAP ,@(deposit-type (ucode-type manifest-nm-vector) rl)
- (STW () ,rl (OFFSET 0 0 ,rrv))
- ,@(deposit-type tag rrv)
- (LDO () (OFFSET ,(* 4 frame-size) 0 ,rsp) ,rsp)
- (B (N) (@PCR ,cont-label))
- (LABEL ,label)
- ,@(default)))
-
- (case name
- ((STRING-ALLOCATE)
- (LAP (LDW () (OFFSET 0 0 ,rsp) ,ra1)
- (COPY () ,rfp ,rrv)
- ,@(object->datum ra1 ra1)
- (ADD () ,ra1 ,rfp ,ra2)
- (COMB (>= N) ,ra2 ,rmp (@PCR ,label))
- (STB () 0 (OFFSET 8 0 ,ra2))
- (SHD () 0 ,ra1 2 ,ra3)
- (LDO () (OFFSET 2 0 ,ra3) ,ra3)
- (STWS (MB) ,ra1 (OFFSET 4 0 ,rfp))
- (SH2ADD () ,ra3 ,rfp ,rfp)
- ,@(end (ucode-type string) ra3)))
- ((FLOATING-VECTOR-CONS)
- (LAP (LDW () (OFFSET 0 0 ,rsp) ,ra1)
- ;; (STW () 0 (OFFSET 0 0 ,rfp))
- (DEPI () #b100 31 3 ,rfp)
- (COPY () ,rfp ,rrv)
- ,@(object->datum ra1 ra1)
- (SH3ADD () ,ra1 ,rfp ,ra2)
- (COMB (>= N) ,ra2 ,rmp (@PCR ,label))
- (SHD () ,ra1 0 31 ,ra1)
- (LDO () (OFFSET 4 0 ,ra2) ,rfp)
- ,@(end (ucode-type flonum) ra1)))
- (else
- (error "open-code-block-allocation: Unknown primitive"
- name)))))))
-|#
-\f
-;;;; Invocation Prefixes
-
-;;; MOVE-FRAME-UP size address
-;;;
-;;; Moves up the last <size> words of the stack so that the first of
-;;; these words is at location <address>, and resets the stack pointer
-;;; to the last of these words. That is, it pops off all the words
-;;; between <address> and TOS+/-<size>.
-
-(define-rule statement
- ;; Move up 0 words back to top of stack : a No-Op
- (INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER (? reg)))
- (QUALIFIER (= reg regnum:stack-pointer))
- (LAP))
-
-(define-rule statement
- ;; Move <frame-size> words back to dynamic link marker
- (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER (? reg)))
- (QUALIFIER (= reg regnum:dynamic-link))
- (generate/move-frame-up frame-size
- (lambda (reg)
- (LAP (COPY () ,regnum:dynamic-link ,reg)))))
-
-(define-rule statement
- ;; Move <frame-size> words back to SP+offset
- (INVOCATION-PREFIX:MOVE-FRAME-UP
- (? frame-size)
- (OFFSET-ADDRESS (REGISTER (? reg))
- (MACHINE-CONSTANT (? offset))))
- (QUALIFIER (= reg regnum:stack-pointer))
- (let ((how-far (* 4 (- offset frame-size))))
- (cond ((zero? how-far)
- (LAP))
- ((negative? how-far)
- (error "invocation-prefix:move-frame-up: bad specs"
- frame-size offset))
- ((zero? frame-size)
- (load-offset how-far regnum:stack-pointer regnum:stack-pointer))
- ((= frame-size 1)
- (let ((temp (standard-temporary!)))
- (LAP (LDWM () (OFFSET ,how-far 0 ,regnum:stack-pointer) ,temp)
- (STW () ,temp (OFFSET 0 0 ,regnum:stack-pointer)))))
- ((= frame-size 2)
- (let ((temp1 (standard-temporary!))
- (temp2 (standard-temporary!)))
- (LAP (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,temp1)
- (LDWM () (OFFSET ,(- how-far 4) 0 ,regnum:stack-pointer)
- ,temp2)
- (STW () ,temp1 (OFFSET 0 0 ,regnum:stack-pointer))
- (STW () ,temp2 (OFFSET 4 0 ,regnum:stack-pointer)))))
- (else
- (generate/move-frame-up frame-size
- (lambda (reg)
- (load-offset (* 4 offset) regnum:stack-pointer reg)))))))
-
-(define-rule statement
- ;; Move <frame-size> words back to base virtual register + offset
- (INVOCATION-PREFIX:MOVE-FRAME-UP
- (? frame-size)
- (OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? offset))))
- (generate/move-frame-up frame-size
- (lambda (reg)
- (load-offset (* 4 offset) (standard-source! base) reg))))
-\f
-;;; DYNAMIC-LINK instructions have a <frame-size>, <new frame end>,
-;;; and <current dynamic link> as arguments. They pop the stack by
-;;; removing the lesser of the amount needed to move the stack pointer
-;;; back to the <new frame end> or <current dynamic link>. The last
-;;; <frame-size> words on the stack (the stack frame for the procedure
-;;; about to be called) are then put back onto the newly adjusted
-;;; stack.
-
-(define-rule statement
- (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
- (REGISTER (? source))
- (REGISTER (? reg)))
- (QUALIFIER (= reg regnum:dynamic-link))
- (if (and (zero? frame-size)
- (= source regnum:stack-pointer))
- (LAP)
- (let ((env-reg (standard-move-to-temporary! source)))
- (LAP
- ;; skip if env LS dyn link
- (SUB (<<=) ,env-reg ,regnum:dynamic-link 0)
- ;; env <- dyn link
- (COPY () ,regnum:dynamic-link ,env-reg)
- ,@(generate/move-frame-up* frame-size env-reg)))))
-
-(define (generate/move-frame-up frame-size destination-generator)
- (let ((temp (standard-temporary!)))
- (LAP ,@(destination-generator temp)
- ,@(generate/move-frame-up* frame-size temp))))
-
-(define (generate/move-frame-up* frame-size destination)
- ;; Destination is guaranteed to be a machine register number; that
- ;; register has the destination base address for the frame. The stack
- ;; pointer is reset to the top end of the copied area.
- (LAP ,@(case frame-size
- ((0)
- (LAP))
- ((1)
- (let ((temp (standard-temporary!)))
- (LAP (LDW () (OFFSET 0 0 ,regnum:stack-pointer) ,temp)
- (STWM () ,temp (OFFSET -4 0 ,destination)))))
- (else
- (generate/move-frame-up** frame-size destination)))
- (COPY () ,destination ,regnum:stack-pointer)))
-
-(define (generate/move-frame-up** frame-size dest)
- (let ((from (standard-temporary!))
- (temp1 (standard-temporary!))
- (temp2 (standard-temporary!)))
- (LAP ,@(load-offset (* 4 frame-size) regnum:stack-pointer from)
- ,@(if (<= frame-size 3)
- ;; This code can handle any number > 1 (handled above),
- ;; but we restrict it to 3 for space reasons.
- (let loop ((n frame-size))
- (case n
- ((0)
- (LAP))
- ((3)
- (let ((temp3 (standard-temporary!)))
- (LAP (LDWM () (OFFSET -4 0 ,from) ,temp1)
- (LDWM () (OFFSET -4 0 ,from) ,temp2)
- (LDWM () (OFFSET -4 0 ,from) ,temp3)
- (STWM () ,temp1 (OFFSET -4 0 ,dest))
- (STWM () ,temp2 (OFFSET -4 0 ,dest))
- (STWM () ,temp3 (OFFSET -4 0 ,dest)))))
- (else
- (LAP (LDWM () (OFFSET -4 0 ,from) ,temp1)
- (LDWM () (OFFSET -4 0 ,from) ,temp2)
- (STWM () ,temp1 (OFFSET -4 0 ,dest))
- (STWM () ,temp2 (OFFSET -4 0 ,dest))
- ,@(loop (- n 2))))))
- (LAP ,@(load-immediate frame-size temp2)
- (LDWM () (OFFSET -4 0 ,from) ,temp1)
- (ADDIBF (=) -1 ,temp2 (@PCO -12))
- (STWM () ,temp1 (OFFSET -4 0 ,dest)))))))
-\f
-;;;; External Labels
-
-(define (make-external-label code label)
- (set! *external-labels* (cons label *external-labels*))
- (LAP (EXTERNAL-LABEL () ,code (@PCR ,label))
- (LABEL ,label)))
-
-;;; Entry point types
-
-(define-integrable (make-code-word min max)
- (+ (* #x100 min) max))
-
-(define (make-procedure-code-word min max)
- ;; The "min" byte must be less than #x80; the "max" byte may not
- ;; equal #x80 but can take on any other value.
- (if (or (negative? min) (>= min #x80))
- (error "MAKE-PROCEDURE-CODE-WORD: minimum out of range" min))
- (if (>= (abs max) #x80)
- (error "MAKE-PROCEDURE-CODE-WORD: maximum out of range" max))
- (make-code-word min (if (negative? max) (+ #x100 max) max)))
-
-(define expression-code-word
- (make-code-word #xff #xff))
-
-(define internal-entry-code-word
- (make-code-word #xff #xfe))
-
-(define internal-continuation-code-word
- (make-code-word #xff #xfc))
-
-;; #xff #xfb taken up by return-to-interpreter and reflect-to-interface
-
-(define internal-closure-code-word
- (make-code-word #xff #xfa))
-
-(define (continuation-code-word label)
- (frame-size->code-word
- (if label
- (rtl-continuation/next-continuation-offset (label->object label))
- 0)
- internal-continuation-code-word))
-
-(define (internal-procedure-code-word rtl-proc)
- ;; represented as return addresses so the debugger will
- ;; not barf when it sees them (on the stack if interrupted).
- (frame-size->code-word
- (rtl-procedure/next-continuation-offset rtl-proc)
- internal-entry-code-word))
-
-(define (frame-size->code-word offset default)
- (cond ((not offset)
- default)
- ((< offset #x2000)
- ;; This uses up through (#xff #xdf).
- (let ((qr (integer-divide offset #x80)))
- (make-code-word (+ #x80 (integer-divide-remainder qr))
- (+ #x80 (integer-divide-quotient qr)))))
- (else
- (error "Unable to encode continuation offset" offset))))
-\f
-;;;; Procedure headers
-
-;;; The following calls MUST appear as the first thing at the entry
-;;; point of a procedure. They assume that the register map is clear
-;;; and that no register contains anything of value.
-;;;
-;;; The only reason that this is true is that no register is live
-;;; across calls. If that were not true, then we would have to save
-;;; any such registers on the stack so that they would be GC'ed
-;;; appropriately.
-;;;
-;;; The only exception is the dynamic link register, handled
-;;; specially. Procedures that require a dynamic link use a different
-;;; interrupt handler that saves and restores the dynamic link
-;;; register.
-
-(define (simple-procedure-header code-word label code)
- (let ((gc-label (generate-label)))
- (LAP (LABEL ,gc-label)
- ,@(invoke-interface-ble code)
- ,@(make-external-label code-word label)
- ,@(interrupt-check label gc-label))))
-
-(define (dlink-procedure-header code-word label)
- (let ((gc-label (generate-label)))
- (LAP (LABEL ,gc-label)
- (COPY () ,regnum:dynamic-link ,regnum:second-arg)
- ,@(invoke-interface-ble code:compiler-interrupt-dlink)
- ,@(make-external-label code-word label)
- ,@(interrupt-check label gc-label))))
-
-(define (interrupt-check label gc-label)
- (case (let ((object (label->object label)))
- (and (rtl-procedure? object)
- (not (rtl-procedure/stack-leaf? object))
- compiler:generate-stack-checks?))
- ((#F)
- (LAP (COMB (>=) ,regnum:free-pointer ,regnum:memtop-pointer
- (@PCR ,gc-label))
- (LDW () ,reg:memtop ,regnum:memtop-pointer)))
- ((OUT-OF-LINE)
- (let ((label (generate-label)))
- (LAP (BLE ()
- (OFFSET ,hook:compiler-stack-and-interrupt-check
- 4
- ,regnum:scheme-to-interface-ble))
- ;; Assumes that (<= #x-2000 (- ,gc-label ,label) #x1fff)
- ;; otherwise this assembles to two instructions, and it
- ;; won't fit in the branch-delay slot.
- (LDI () (- ,gc-label ,label) ,regnum:first-arg)
- (LABEL ,label))))
- (else
- (LAP (LDW () ,reg:stack-guard ,regnum:first-arg)
- (COMB (>=) ,regnum:free-pointer ,regnum:memtop-pointer
- (@PCR ,gc-label))
- (COMB (<=) ,regnum:stack-pointer ,regnum:first-arg (@PCR ,gc-label))
- (LDW () ,reg:memtop ,regnum:memtop-pointer)))))
-\f
-(define-rule statement
- (CONTINUATION-ENTRY (? internal-label))
- (make-external-label (continuation-code-word internal-label)
- internal-label))
-
-(define-rule statement
- (CONTINUATION-HEADER (? internal-label))
- (simple-procedure-header (continuation-code-word internal-label)
- internal-label
- code:compiler-interrupt-continuation))
-
-(define-rule statement
- (IC-PROCEDURE-HEADER (? internal-label))
- (let ((procedure (label->object internal-label)))
- (let ((external-label (rtl-procedure/external-label procedure)))
- (LAP (ENTRY-POINT ,external-label)
- (EQUATE ,external-label ,internal-label)
- ,@(simple-procedure-header expression-code-word
- internal-label
- code:compiler-interrupt-ic-procedure)))))
-
-(define-rule statement
- (OPEN-PROCEDURE-HEADER (? internal-label))
- (let ((rtl-proc (label->object internal-label)))
- (LAP (EQUATE ,(rtl-procedure/external-label rtl-proc) ,internal-label)
- ,@((if (rtl-procedure/dynamic-link? rtl-proc)
- dlink-procedure-header
- (lambda (code-word label)
- (simple-procedure-header code-word label
- code:compiler-interrupt-procedure)))
- (internal-procedure-code-word rtl-proc)
- internal-label))))
-
-(define-rule statement
- (PROCEDURE-HEADER (? internal-label) (? min) (? max))
- (LAP (EQUATE ,(rtl-procedure/external-label (label->object internal-label))
- ,internal-label)
- ,@(simple-procedure-header (make-procedure-code-word min max)
- internal-label
- code:compiler-interrupt-procedure)))
-\f
-;;;; Closures. These two statements are intertwined:
-
-(define-rule statement
- ;; This depends on the following facts:
- ;; 1- TC_COMPILED_ENTRY is a multiple of two.
- ;; 2- all the top 6 bits in a data address are 0 except the quad bit
- ;; 3- type codes are 6 bits long.
- (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
- entry ; Used only if entries may not be word-aligned.
- (if (zero? nentries)
- (error "Closure header for closure with no entries!"
- internal-label))
-
- ;; Closures used to use (internal-procedure-code-word rtl-proc)
- ;; instead of internal-closure-code-word.
- ;; This confused the bkpt utilties and was unnecessary because
- ;; these entry points cannot properly be used as return addresses.
-
- (let* ((rtl-proc (label->object internal-label))
- (external-label (rtl-procedure/external-label rtl-proc)))
- (let ((suffix
- (lambda (gc-label)
- (LAP ,@(make-external-label internal-closure-code-word
- external-label)
- ,@(address->entry g25)
- (STWM () ,g25 (OFFSET -4 0 ,regnum:stack-pointer))
- (LABEL ,internal-label)
- ,@(interrupt-check internal-label gc-label)))))
- (share-instruction-sequence!
- 'CLOSURE-GC-STUB
- suffix
- (lambda (gc-label)
- (LAP (LABEL ,gc-label)
- ,@(invoke-interface code:compiler-interrupt-closure)
- ,@(suffix gc-label)))))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
- (? min) (? max) (? size)))
- (cons-closure target procedure-label min max size))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-MULTICLOSURE (? nentries) (? size) (? entries)))
- ;; entries is a vector of all the entry points
- (case nentries
- ((0)
- (let ((dest (standard-target! target)))
- (LAP ,@(load-non-pointer (ucode-type manifest-vector)
- size
- dest)
- (STW () ,dest (OFFSET 0 0 ,regnum:free-pointer))
- (COPY () ,regnum:free-pointer ,dest)
- ,@(load-offset (* 4 (1+ size))
- regnum:free-pointer
- regnum:free-pointer))))
- ((1)
- (let ((entry (vector-ref entries 0)))
- (cons-closure
- target (car entry) (cadr entry) (caddr entry) size)))
- (else
- (cons-multiclosure target nentries size (vector->list entries)))))
-\f
-#|
-;;; Old style closure consing -- Out of line.
-
-(define (%cons-closure target total-size size core)
- (let* ((flush-reg (require-registers! regnum:first-arg
- #| regnum:addil-result |#
- regnum:ble-return))
- (target (standard-target! target)))
- (LAP ,@flush-reg
- ;; Vector header
- ,@(load-non-pointer (ucode-type manifest-closure)
- total-size
- regnum:first-arg)
- (STWS (MA C) ,regnum:first-arg (OFFSET 4 0 ,regnum:free-pointer))
- ;; Make entries and store result
- ,@(core target)
- ;; Allocate space for closed-over variables
- ,@(load-offset (* 4 size)
- regnum:free-pointer
- regnum:free-pointer))))
-
-(define (cons-closure target entry min max size)
- (%cons-closure
- target
- (+ size closure-entry-size)
- size
- (lambda (target)
- (LAP ;; Entry point is result.
- ,@(load-offset 4 regnum:free-pointer target)
- ,@(cons-closure-entry entry min max 8)))))
-
-(define (cons-multiclosure target nentries size entries)
- (define (generate-entries offset entries)
- (if (null? entries)
- (LAP)
- (let ((entry (car entries)))
- (LAP ,@(cons-closure-entry (car entry) (cadr entry) (caddr entry)
- offset)
- ,@(generate-entries (+ offset (* 4 closure-entry-size))
- (cdr entries))))))
-
- (%cons-closure
- target
- (+ 1 (* closure-entry-size nentries) size)
- size
- (lambda (target)
- (LAP ;; Number of closure entries
- ,@(load-entry-format nentries 0 target)
- (STWS (MA C) ,target (OFFSET 4 0 ,regnum:free-pointer))
- ;; First entry point is result.
- ,@(load-offset 4 regnum:free-pointer target)
- ,@(generate-entries 12 entries)))))
-\f
-;; Utilities for old-style closure consing.
-
-(define (load-entry-format code-word gc-offset dest)
- (load-immediate (+ (* code-word #x10000)
- (quotient gc-offset 2))
- dest))
-
-(define (cons-closure-entry entry min max offset)
- ;; Call an out-of-line hook to do this.
- ;; Making the instructions is a lot of work!
- ;; Perhaps there should be a closure hook invoked and the real
- ;; entry point could follow. It would also be easier on the GC.
- (let ((entry-label (rtl-procedure/external-label (label->object entry))))
- (LAP ,@(load-entry-format (make-procedure-code-word min max)
- offset
- regnum:first-arg)
- #|
- ;; This does not work!!! The LDO may overflow.
- ;; A new pseudo-op has been introduced for this purpose.
- (BLE ()
- (OFFSET ,hook:compiler-store-closure-entry
- 4
- ,regnum:scheme-to-interface-ble))
- (LDO ()
- (OFFSET (- ,entry-label (+ *PC* 4))
- 0
- ,regnum:ble-return)
- ,regnum:addil-result)
- |#
- (PCR-HOOK ()
- ,regnum:addil-result
- (OFFSET ,hook:compiler-store-closure-entry
- 4
- ,regnum:scheme-to-interface-ble)
- (@PCR ,entry-label)))))
-|#
-
-;; Magic for compiled entries.
-
-(define compiled-entry-type-im5
- (let* ((qr (integer-divide (ucode-type compiled-entry) 2))
- (immed (integer-divide-quotient qr)))
- (if (or (not (= scheme-type-width 6))
- (not (zero? (integer-divide-remainder qr)))
- (not (<= 0 immed #x1F)))
- (error "HPPA RTL rules3: closure header rule assumptions violated!"))
- (if (<= immed #x0F)
- immed
- (- immed #x20))))
-
-(define-integrable (address->entry register)
- (LAP (DEPI () ,compiled-entry-type-im5 4 5 ,register)))
-\f
-;;; New style closure consing using compiler-prepared and
-;;; linker-maintained patterns
-
-;; Compiled code blocks are aligned like floating-point numbers and vectors.
-;; That is, the address of their header word is congruent 4 mod 8
-
-(define *initial-dword-offset* 4)
-(define *closure-padding-bitstring* (make-bit-string 32 false))
-
-;; This agrees with hppa_extract_absolute_address in microcode/cmpintmd/hppa.h
-
-(define *ldil/ble-split*
- ;; (expt 2 13) ***
- 8192)
-
-(define *ldil-factor*
- ;; (/ *ldil/ble-split* ldil-scale)
- 4)
-
-(define (declare-closure-pattern! pattern)
- (add-extra-code!
- (or (find-extra-code-block 'CLOSURE-PATTERNS)
- (let ((section-label (generate-label))
- (ev-label (generate-label)))
- (let ((block (declare-extra-code-block!
- 'CLOSURE-PATTERNS
- 'LAST
- `(((/ (- ,ev-label ,section-label) 4)
- . ,ev-label)))))
- (add-extra-code! block
- (LAP (LABEL ,section-label)))
- block)))
- (LAP (PADDING ,(- 4 *initial-dword-offset*) 8 ,*closure-padding-bitstring*)
- ,@pattern)))
-
-(define (generate-closure-entry offset pattern label min max)
- (let ((entry-label (rtl-procedure/external-label (label->object label))))
- (LAP (USHORT ()
- ,(make-procedure-code-word min max)
- ,(quotient offset 2))
- ;; This contains an offset -- the linker turns it to an abs. addr.
- (LDIL () (* (QUOTIENT (- (+ ,pattern ,offset) ,entry-label)
- ,*ldil/ble-split*)
- ,*ldil-factor*)
- 26)
- (BLE () (OFFSET (REMAINDER (- (+ ,pattern ,offset) ,entry-label)
- ,*ldil/ble-split*)
- 5 26))
- (ADDI () -15 31 25))))
-
-(define (cons-closure target entry-label min max size)
- (let ((offset 8)
- (total-size (+ size closure-entry-size))
- (pattern (generate-label)))
-
- (declare-closure-pattern!
- (LAP ,@(lap:comment `(CLOSURE-PATTERN ,entry-label))
- (LABEL ,pattern)
- (UWORD () ,(make-non-pointer-literal (ucode-type manifest-closure)
- total-size))
- ,@(generate-closure-entry offset pattern entry-label min max)))
- #|
- ;; This version uses ordinary integer instructions
-
- (let* ((offset* (* 4 (1+ closure-entry-size)))
- (target (standard-target! target))
- (temp1 (standard-temporary!))
- (temp2 (standard-temporary!))
- (temp3 (standard-temporary!)))
-
- (LAP ,@(load-pc-relative-address pattern target 'CODE)
- (LDWS (MA) (OFFSET 4 0 ,target) ,temp1)
- (LDWS (MA) (OFFSET 4 0 ,target) ,temp2)
- (LDWS (MA) (OFFSET 4 0 ,target) ,temp3)
- (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer))
- (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer))
- (STWS (MA C) ,temp3 (OFFSET 4 0 ,regnum:free-pointer))
-\f
- (LDWS (MA) (OFFSET 4 0 ,target) ,temp1)
- (LDWS (MA) (OFFSET 4 0 ,target) ,temp2)
- (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer))
- (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer))
- (LDO () (OFFSET ,(- offset offset*) 0 ,regnum:free-pointer) ,target)
- (FDC () (INDEX 0 0 ,target))
- (FDC () (INDEX 0 0 ,regnum:free-pointer))
- (SYNC ())
- (FIC () (INDEX 0 5 ,target))
- (SYNC ())
- (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer)
- ,regnum:free-pointer)))
- |#
-
- #|
- ;; This version is faster by using floating-point (doubleword) moves
-
- (let* ((offset* (* 4 (1+ closure-entry-size)))
- (target (standard-target! target))
- (dwtemp1 (flonum-temporary!))
- (dwtemp2 (flonum-temporary!))
- (swtemp (standard-temporary!)))
-
- (LAP ,@(load-pc-relative-address pattern target 'CODE)
- (DEPI () #b100 31 3 ,regnum:free-pointer) ; quad align
- (LDWS (MA) (OFFSET 4 0 ,target) ,swtemp)
- (FLDDS (MA) (OFFSET 8 0 ,target) ,dwtemp1)
- (STWS (MA) ,swtemp (OFFSET 4 0 ,regnum:free-pointer))
- (FLDDS (MA) (OFFSET 8 0 ,target) ,dwtemp2)
- (FSTDS (MA) ,dwtemp1 (OFFSET 8 0 ,regnum:free-pointer))
- (LDO () (OFFSET ,(- offset (- offset* 8)) 0 ,regnum:free-pointer)
- ,target)
- (FSTDS (MA) ,dwtemp2 (OFFSET 8 0 ,regnum:free-pointer))
- (FDC () (INDEX 0 0 ,target))
- (FDC () (INDEX 0 0 ,regnum:free-pointer))
- (SYNC ())
- (FIC () (INDEX 0 5 ,target))
- (SYNC ())
- (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer)
- ,regnum:free-pointer)))
- |#
-
- ;; This version does the copy out of line, using fp instructions.
-
- (let* ((hook-label (generate-label))
- (flush-reg (require-registers! g29 g28 g26 g25 fp11 fp10
- #| regnum:addil-result |#
- regnum:ble-return)))
- (delete-register! target)
- (delete-dead-registers!)
- (add-pseudo-register-alias! target g25)
- (LAP ,@flush-reg
- ,@(invoke-hook hook:compiler-copy-closure-pattern)
- (LABEL ,hook-label)
- (UWORD () (- (- ,pattern ,hook-label) ,*privilege-level*))
- (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer)
- ,regnum:free-pointer)))))
-\f
-(define (cons-multiclosure target nentries size entries)
- ;; nentries > 1
- (let ((offset 12)
- (total-size (+ (+ 1 (* closure-entry-size nentries)) size))
- (pattern (generate-label)))
-
- (declare-closure-pattern!
- (LAP ,@(lap:comment `(CLOSURE-PATTERN ,(caar entries)))
- (LABEL ,pattern)
- (UWORD () ,(make-non-pointer-literal (ucode-type manifest-closure)
- total-size))
- (USHORT () ,nentries 0)
- ,@(let make-entries ((entries entries)
- (offset offset))
- (if (null? entries)
- (LAP)
- (let ((entry (car entries)))
- (LAP ,@(generate-closure-entry offset
- pattern
- (car entry)
- (cadr entry)
- (caddr entry))
- ,@(make-entries (cdr entries)
- (+ offset
- (* 4 closure-entry-size)))))))))
- #|
- ;; This version uses ordinary integer instructions
-
- (let ((target (standard-target! target)))
- (let ((temp1 (standard-temporary!))
- (temp2 (standard-temporary!))
- (ctr (standard-temporary!))
- (srcptr (standard-temporary!))
- (index (standard-temporary!))
- (loop-label (generate-label)))
-
- (LAP ,@(load-pc-relative-address pattern srcptr 'CODE)
- (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp1)
- (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp2)
- (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer))
- (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer))
- (LDO () (OFFSET 4 0 ,regnum:free-pointer) ,target)
- (LDI () -16 ,index)
- (LDI () ,nentries ,ctr)
- ;; The loop copies 16 bytes, and the architecture specifies
- ;; that a cache line must be a multiple of this value.
- ;; Therefore we only need to flush once per loop,
- ;; and once more (D only) to take care of phase.
- (LABEL ,loop-label)
- (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp1)
- (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp2)
- (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer))
- (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer))
- (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp1)
- (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp2)
- (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer))
- (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer))
- (FDC () (INDEX ,index 0 ,regnum:free-pointer))
- (SYNC ())
- (ADDIB (>) -1 ,ctr ,ctr (@PCR ,loop-label))
- (FIC () (INDEX ,index 5 ,regnum:free-pointer))
- (FDC () (INDEX 0 0 ,regnum:free-pointer))
- (SYNC ())
- (FIC () (INDEX 0 5 ,regnum:free-pointer))
- (SYNC ())
- (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer)
- ,regnum:free-pointer))))
- |#
-\f
- #|
- ;; This version is faster by using floating-point (doubleword) moves
-
- (let ((target (standard-target! target)))
- (let ((dwtemp1 (flonum-temporary!))
- (dwtemp2 (flonum-temporary!))
- (temp (standard-temporary!))
- (ctr (standard-temporary!))
- (srcptr (standard-temporary!))
- (index (standard-temporary!))
- (loop-label (generate-label)))
-
- (LAP ,@(load-pc-relative-address pattern srcptr 'CODE)
- (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp)
- (DEPI () #b100 31 3 ,regnum:free-pointer) ; quad align
- (STWS (MA C) ,temp (OFFSET 4 0 ,regnum:free-pointer))
- (LDO () (OFFSET 8 0 ,regnum:free-pointer) ,target)
- (LDI () -16 ,index)
- (LDI () ,nentries ,ctr)
-
- ;; The loop copies 16 bytes, and the architecture specifies
- ;; that a cache line must be a multiple of this value.
- ;; Therefore we only need to flush (D) once per loop,
- ;; and once more to take care of phase.
- ;; We only need to flush the I cache once because it is
- ;; newly allocated memory.
-
- (LABEL ,loop-label)
- (FLDDS (MA) (OFFSET 8 0 ,srcptr) ,dwtemp1)
- (FLDDS (MA) (OFFSET 8 0 ,srcptr) ,dwtemp2)
- (FSTDS (MA) ,dwtemp1 (OFFSET 8 0 ,regnum:free-pointer))
- (FSTDS (MA) ,dwtemp2 (OFFSET 8 0 ,regnum:free-pointer))
- (ADDIB (>) -1 ,ctr (@PCR ,loop-label))
- (FDC () (INDEX ,index 0 ,regnum:free-pointer))
-
- (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp)
- (LDI () ,(* -4 (1+ size)) ,index)
- (STWM () ,temp (OFFSET ,(* 4 (1+ size)) 0 ,regnum:free-pointer))
- (FDC () (INDEX ,index 0 ,regnum:free-pointer))
- (SYNC ())
- (FIC () (INDEX 0 5 ,target))
- (SYNC ()))))
- |#
-
- ;; This version does the copy out of line, using fp instructions.
-
- (let* ((hook-label (generate-label))
- (flush-reg (require-registers! g29 g28 g26 g25 fp11 fp10
- #| regnum:addil-result |#
- regnum:ble-return)))
- (delete-register! target)
- (delete-dead-registers!)
- (add-pseudo-register-alias! target g25)
- (LAP ,@flush-reg
- (LDI () ,nentries 1)
- ,@(invoke-hook hook:compiler-copy-multiclosure-pattern)
- (LABEL ,hook-label)
- (UWORD () (- (- ,pattern ,hook-label) ,*privilege-level*))
- (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer)
- ,regnum:free-pointer)))))
-\f
-;;;; Entry Header
-;;; This is invoked by the top level of the LAP generator.
-
-(define (generate/quotation-header environment-label free-ref-label n-sections)
- ;; Calls the linker
- (in-assembler-environment
- (empty-register-map)
- (list regnum:first-arg regnum:second-arg
- regnum:third-arg regnum:fourth-arg)
- (lambda ()
- (let ((segment (load-pc-relative-address environment-label 1 'CONSTANT)))
- (LAP (LDW () ,reg:environment 2)
- ,@segment
- (STW () 2 (OFFSET 0 0 1))
- ,@(load-pc-relative-address *block-label* regnum:second-arg 'CODE)
- ,@(load-pc-relative-address free-ref-label regnum:third-arg
- 'CONSTANT)
- ,@(load-immediate n-sections regnum:fourth-arg)
- ,@(invoke-interface-ble code:compiler-link)
- ,@(make-external-label (continuation-code-word false)
- (generate-label)))))))
-
-(define (generate/remote-link code-block-label
- environment-offset
- free-ref-offset
- n-sections)
- ;; Link all of the top level procedures within the file
- (in-assembler-environment
- (empty-register-map)
- (list regnum:first-arg regnum:second-arg
- regnum:third-arg regnum:fourth-arg)
- (lambda ()
- (let ((segment (load-pc-relative code-block-label regnum:second-arg
- 'CONSTANT)))
- (LAP ,@segment
- ,@(object->address regnum:second-arg)
- (LDW () ,reg:environment 2)
- ,@(load-offset environment-offset regnum:second-arg 1)
- (STW () 2 (OFFSET 0 0 1))
- ,@(load-offset free-ref-offset regnum:second-arg regnum:third-arg)
- ,@(load-immediate n-sections regnum:fourth-arg)
- ,@(invoke-interface-ble code:compiler-link)
- ,@(make-external-label (continuation-code-word false)
- (generate-label)))))))
-
-(define (in-assembler-environment map needed-registers thunk)
- (fluid-let ((*register-map* map)
- (*prefix-instructions* (LAP))
- (*suffix-instructions* (LAP))
- (*needed-registers* needed-registers))
- (let ((instructions (thunk)))
- (LAP ,@*prefix-instructions*
- ,@instructions
- ,@*suffix-instructions*))))
-\f
-(define (generate/remote-links n-code-blocks code-blocks-label n-sections)
- (if (= n-code-blocks 0)
- (LAP)
- (let ((loop (generate-label))
- (bytes (generate-label))
- (after-bytes (generate-label)))
- (LAP (STWM () 0 (OFFSET -4 0 ,regnum:stack-pointer))
- (COPY () 0 ,regnum:first-arg)
- (LABEL ,loop)
- (LDO () (OFFSET 1 0 ,regnum:first-arg) ,regnum:second-arg)
- (STW () ,regnum:second-arg (OFFSET 0 0 ,regnum:stack-pointer))
- (BL () ,regnum:third-arg (@PCR ,after-bytes))
- (DEP () 0 31 2 ,regnum:third-arg)
- (LABEL ,bytes)
- ,@(sections->bytes n-code-blocks n-sections)
- (LABEL ,after-bytes)
- (LDBX () (INDEX ,regnum:first-arg 0 ,regnum:third-arg)
- ,regnum:fourth-arg)
- (LDW () (OFFSET (- ,code-blocks-label ,bytes) 0 ,regnum:third-arg)
- ,regnum:third-arg)
- ,@(object->address regnum:third-arg)
- (LDWX (S) (INDEX ,regnum:second-arg 0 ,regnum:third-arg)
- ,regnum:second-arg)
- ,@(object->address regnum:second-arg)
- (LDW () (OFFSET 4 0 ,regnum:second-arg) ,regnum:third-arg)
- (LDW () (OFFSET 0 0 ,regnum:second-arg) ,regnum:first-arg)
- (LDW () ,reg:environment 2)
- ,@(object->datum regnum:third-arg regnum:third-arg)
- ,@(object->datum regnum:first-arg regnum:first-arg)
- (SH2ADD () ,regnum:third-arg ,regnum:second-arg ,regnum:third-arg)
- (SH2ADD () ,regnum:first-arg ,regnum:second-arg
- ,regnum:first-arg)
- (LDO () (OFFSET 8 0 ,regnum:third-arg) ,regnum:third-arg)
- (STW () 2 (OFFSET 0 0 ,regnum:first-arg))
- ,@(invoke-interface-ble code:compiler-link)
- ,@(make-external-label (continuation-code-word false)
- (generate-label))
- (LDW () (OFFSET 0 0 ,regnum:stack-pointer) ,regnum:first-arg)
- ,@(cond ((fits-in-5-bits-signed? n-code-blocks)
- (LAP (COMIBF (<=) ,n-code-blocks ,regnum:first-arg
- (@PCR ,loop))
- (NOP ())))
- ((fits-in-11-bits-signed? n-code-blocks)
- (LAP (COMICLR (<=) ,n-code-blocks ,regnum:first-arg 0)
- (B (N) (@PCR ,loop))))
- (else
- (LAP (LDI () ,n-code-blocks ,regnum:second-arg)
- (COMBF (<=) ,regnum:second-arg ,regnum:first-arg
- (@PCR ,loop))
- (NOP ()))))
- (LDO () (OFFSET 4 0 ,regnum:stack-pointer)
- ,regnum:stack-pointer)))))
-
-(define (sections->bytes n-code-blocks n-sections)
- (let walk ((bytes
- (append (vector->list n-sections)
- (let ((left (remainder n-code-blocks 4)))
- (if (zero? left)
- '()
- (make-list (- 4 left) 0))))))
- (if (null? bytes)
- (LAP)
- (let ((hi (car bytes))
- (midhi (cadr bytes))
- (midlo (caddr bytes))
- (lo (cadddr bytes)))
- (LAP (UWORD () ,(+ lo (* 256
- (+ midlo (* 256 (+ midhi (* 256 hi)))))))
- ,@(walk (cddddr bytes)))))))
-\f
-(define (generate/constants-block constants references assignments
- uuo-links global-links static-vars)
- (let ((constant-info
- ;; Note: generate/remote-links depends on all the linkage sections
- ;; (references & uuos) being first!
- (declare-constants 0 (transmogrifly uuo-links)
- (declare-constants 1 references
- (declare-constants 2 assignments
- (declare-constants 3 (transmogrifly global-links)
- (declare-closure-patterns
- (declare-constants false (map (lambda (pair)
- (cons false (cdr pair)))
- static-vars)
- (declare-constants false constants
- (cons false (LAP)))))))))))
- (let ((free-ref-label (car constant-info))
- (constants-code (cdr constant-info))
- (debugging-information-label (allocate-constant-label))
- (environment-label (allocate-constant-label))
- (n-sections
- (+ (if (null? uuo-links) 0 1)
- (if (null? references) 0 1)
- (if (null? assignments) 0 1)
- (if (null? global-links) 0 1)
- (if (not (find-extra-code-block 'CLOSURE-PATTERNS)) 0 1))))
- (values
- (LAP ,@constants-code
- ;; Place holder for the debugging info filename
- (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO)
- ;; Place holder for the load time environment if needed
- (SCHEME-OBJECT ,environment-label
- ,(if (null? free-ref-label) 0 'ENVIRONMENT)))
- environment-label
- free-ref-label
- n-sections))))
-\f
-(define (declare-constants/tagged tag header constants info)
- (define-integrable (wrap tag label value)
- (LAP (,tag ,label ,value)))
-
- (define (inner constants)
- (if (null? constants)
- (cdr info)
- (let ((entry (car constants)))
- (LAP ,@(wrap tag (cdr entry) (car entry))
- ,@(inner (cdr constants))))))
-
- (if (and header (not (null? constants)))
- (let ((label (allocate-constant-label)))
- (cons label
- (LAP (SCHEME-OBJECT
- ,label
- ,(let ((datum (length constants)))
- (if (> datum #xffff)
- (error "datum too large" datum))
- (+ (* header #x10000) datum)))
- ,@(inner constants))))
- (cons (car info) (inner constants))))
-
-(define (declare-constants header constants info)
- (declare-constants/tagged 'SCHEME-OBJECT header constants info))
-
-(define (declare-closure-patterns info)
- (let ((block (find-extra-code-block 'CLOSURE-PATTERNS)))
- (if (not block)
- info
- (declare-constants/tagged 'SCHEME-EVALUATION
- 4
- (extra-code-block/xtra block)
- info))))
-
-(define (declare-evaluations header evals info)
- (declare-constants/tagged 'SCHEME-EVALUATION header evals info))
-
-(define (transmogrifly uuos)
- (define (inner name assoc)
- (if (null? assoc)
- (transmogrifly (cdr uuos))
- `((,name . ,(cdar assoc)) ; uuo-label LDIL
- (0 . ,(allocate-constant-label)) ; spare BLE
- (,(caar assoc) . ; frame-size
- ,(allocate-constant-label))
- ,@(inner name (cdr assoc)))))
- (if (null? uuos)
- '()
- (inner (caar uuos) (cdar uuos))))
-\f
-;;; Local Variables: ***
-;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
-;;; End: ***
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Interpreter Calls
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Variable cache trap handling.
-
-(define-rule statement
- (INTERPRETER-CALL:CACHE-REFERENCE (? cont)
- (REGISTER (? extension))
- (? safe?))
- cont ; ignored
- (LAP ,@(load-interface-args! false extension false false)
- ,@(invoke-interface-ble
- (if safe?
- code:compiler-safe-reference-trap
- code:compiler-reference-trap))))
-
-(define-rule statement
- (INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont)
- (REGISTER (? extension))
- (? value register-expression))
- cont ; ignored
- (LAP ,@(load-interface-args! false extension value false)
- ,@(invoke-interface-ble code:compiler-assignment-trap)))
-
-(define-rule statement
- (INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont)
- (REGISTER (? extension)))
- cont ; ignored
- (LAP ,@(load-interface-args! false extension false false)
- ,@(invoke-interface-ble code:compiler-unassigned?-trap)))
-\f
-;;;; Interpreter Calls
-
-;;; All the code that follows is obsolete. It hasn't been used in a while.
-;;; It is provided in case the relevant switches are turned off, but there
-;;; is no real reason to do this. Perhaps the switches should be removed.
-
-(define-rule statement
- (INTERPRETER-CALL:ACCESS (? cont)
- (? environment register-expression)
- (? name))
- cont ; ignored
- (lookup-call code:compiler-access environment name))
-
-(define-rule statement
- (INTERPRETER-CALL:LOOKUP (? cont)
- (? environment register-expression)
- (? name)
- (? safe?))
- cont ; ignored
- (lookup-call (if safe? code:compiler-safe-lookup code:compiler-lookup)
- environment
- name))
-
-(define-rule statement
- (INTERPRETER-CALL:UNASSIGNED? (? cont)
- (? environment register-expression)
- (? name))
- cont ; ignored
- (lookup-call code:compiler-unassigned? environment name))
-
-(define-rule statement
- (INTERPRETER-CALL:UNBOUND? (? cont)
- (? environment register-expression)
- (? name))
- cont ; ignored
- (lookup-call code:compiler-unbound? environment name))
-
-(define (lookup-call code environment name)
- (LAP ,@(load-interface-args! false environment false false)
- ,@(load-constant name regnum:third-arg)
- ,@(invoke-interface-ble code)))
-
-(define-rule statement
- (INTERPRETER-CALL:DEFINE (? cont)
- (? environment register-expression)
- (? name)
- (? value register-expression))
- cont ; ignored
- (assignment-call code:compiler-define environment name value))
-
-(define-rule statement
- (INTERPRETER-CALL:SET! (? cont)
- (? environment register-expression)
- (? name)
- (? value register-expression))
- cont ; ignored
- (assignment-call code:compiler-set! environment name value))
-
-(define (assignment-call code environment name value)
- (LAP ,@(load-interface-args! false environment false value)
- ,@(load-constant name regnum:third-arg)
- ,@(invoke-interface-ble code)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Fixnum Rules
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Conversions
-
-(define-rule statement
- ;; convert a fixnum object to a "fixnum integer"
- (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source))))
- (standard-unary-conversion source target object->fixnum))
-
-(define-rule statement
- ;; load a fixnum constant as a "fixnum integer"
- (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant))))
- (load-fixnum-constant constant (standard-target! target)))
-
-(define-rule statement
- ;; convert a memory address to a "fixnum integer"
- (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source))))
- (standard-unary-conversion source target address->fixnum))
-
-(define-rule statement
- ;; convert an object's address to a "fixnum integer"
- (ASSIGN (REGISTER (? target))
- (ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source)))))
- (standard-unary-conversion source target object->fixnum))
-
-(define-rule statement
- ;; convert a "fixnum integer" to a fixnum object
- (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source))))
- (standard-unary-conversion source target fixnum->object))
-
-(define-rule statement
- ;; convert a "fixnum integer" to a memory address
- (ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source))))
- (standard-unary-conversion source target fixnum->address))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (OBJECT->FIXNUM (CONSTANT (? value)))
- (OBJECT->FIXNUM (REGISTER (? source)))
- #F))
- (QUALIFIER (integer-log-base-2? value))
- (standard-unary-conversion source target
- (make-scaled-object->fixnum value)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (OBJECT->FIXNUM (REGISTER (? source)))
- (OBJECT->FIXNUM (CONSTANT (? value)))
- #F))
- (QUALIFIER (integer-log-base-2? value))
- (standard-unary-conversion source target
- (make-scaled-object->fixnum value)))
-\f
-(define-integrable (fixnum->index-fixnum src tgt)
- (LAP (SHD () ,src 0 30 ,tgt)))
-
-(define-integrable (object->fixnum src tgt)
- (LAP (SHD () ,src 0 ,scheme-datum-width ,tgt)))
-
-(define (make-scaled-object->fixnum factor)
- (let ((shift (integer-log-base-2? factor)))
- (cond ((not shift)
- (error "make-scaled-object->fixnum: Not a power of 2" factor))
- ((> shift scheme-datum-width)
- (error "make-scaled-object->fixnum: shift too large" shift))
- (else
- (lambda (src tgt)
- (LAP (SHD () ,src 0 ,(- scheme-datum-width shift) ,tgt)))))))
-
-(define-integrable (address->fixnum src tgt)
- (LAP (SHD () ,src 0 ,scheme-datum-width ,tgt)))
-
-(define-integrable (fixnum->object src tgt)
- (LAP ,@(load-immediate (ucode-type fixnum) regnum:addil-result)
- (SHD () ,regnum:addil-result ,src ,scheme-type-width ,tgt)))
-
-(define (fixnum->address src tgt)
- (LAP (SHD () ,regnum:quad-bitmask ,src ,scheme-type-width ,tgt)))
-
-(define (fixnum->datum src tgt)
- (LAP (SHD () 0 ,src ,scheme-type-width ,tgt)))
-
-(define (load-fixnum-constant constant target)
- (load-immediate (* constant fixnum-1) target))
-
-(define-integrable fixnum-1
- ;; (expt 2 scheme-type-width) ***
- 64)
-\f
-;;;; Arithmetic Operations
-
-(define-rule statement
- ;; execute a unary fixnum operation
- (ASSIGN (REGISTER (? target))
- (FIXNUM-1-ARG (? operation)
- (REGISTER (? source))
- (? overflow?)))
- (QUALIFIER (fixnum-1-arg/operator? operation))
- (standard-unary-conversion source target
- (lambda (source target)
- ((fixnum-1-arg/operator operation) target source overflow?))))
-
-(define-integrable (fixnum-1-arg/operator operation)
- (lookup-arithmetic-method operation fixnum-methods/1-arg))
-
-(define-integrable (fixnum-1-arg/operator? operation)
- (arithmetic-method? operation fixnum-methods/1-arg))
-
-(define fixnum-methods/1-arg
- (list 'FIXNUM-METHODS/1-ARG))
-
-(define-rule statement
- ;; execute a binary fixnum operation
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS (? operation)
- (REGISTER (? source1))
- (REGISTER (? source2))
- (? overflow?)))
- (QUALIFIER (fixnum-2-args/operator? operation))
- (standard-binary-conversion source1 source2 target
- (lambda (source1 source2 target)
- ((fixnum-2-args/operator operation) target source1 source2 overflow?))))
-
-(define-integrable (fixnum-2-args/operator operation)
- (lookup-arithmetic-method operation fixnum-methods/2-args))
-
-(define-integrable (fixnum-2-args/operator? operation)
- (arithmetic-method? operation fixnum-methods/2-args))
-
-(define fixnum-methods/2-args
- (list 'FIXNUM-METHODS/2-ARGS))
-
-;; Some operations are too long to do in-line.
-;; Use out-of-line utilities.
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS (? operation)
- (REGISTER (? source1))
- (REGISTER (? source2))
- (? overflow?)))
- (QUALIFIER (fixnum-2-args/special-operator? operation))
- (special-binary-operation
- operation
- (fixnum-2-args/special-operator operation)
- target source1 source2 overflow?))
-
-(define-integrable (fixnum-2-args/special-operator operation)
- (lookup-arithmetic-method operation fixnum-methods/2-args/special))
-
-(define-integrable (fixnum-2-args/special-operator? operation)
- (arithmetic-method? operation fixnum-methods/2-args/special))
-
-(define fixnum-methods/2-args/special
- (list 'FIXNUM-METHODS/2-ARGS/SPECIAL))
-\f
-;; Note: Bit-wise operations never overflow, therefore they always
-;; skip the branch (cond = TR). Perhaps they should error?
-
-;; Note: The commas in the macros do not follow normal QUASIQUOTE patterns.
-;; This is due to a bad interaction between QUASIQUOTE and LAP!
-
-(let-syntax
- ((unary-fixnum
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-ARITHMETIC-METHOD ',(cadr form) FIXNUM-METHODS/1-ARG
- (LAMBDA (TGT SRC OVERFLOW?)
- (IF OVERFLOW?
- (LAP (,(caddr form) (,(cadddr form))
- ,(list-ref form 4) ,',SRC ,',TGT))
- (LAP (,(caddr form) () ,fixed-operand ,',SRC ,',TGT))))))))
-
- (binary-fixnum
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-ARITHMETIC-METHOD ',(cadr form) FIXNUM-METHODS/2-ARGS
- (LAMBDA (TGT SRC1 SRC2 OVERFLOW?)
- (IF OVERFLOW?
- (LAP (,(caddr form) (,(cadddr form)) ,',SRC1 ,',SRC2 ,',TGT))
- (LAP (,(caddr form) () ,',SRC1 ,',SRC2 ,',TGT))))))))
-
- (binary-out-of-line
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-ARITHMETIC-METHOD ',(cadr form) FIXNUM-METHODS/2-ARGS/SPECIAL
- (CONS ,(symbol-append 'HOOK:COMPILER- (cadr form))
- (LAMBDA ()
- ,(if (null? (cddr form))
- `(LAP)
- `(REQUIRE-REGISTERS! ,@(cddr form))))))))))
-
- (unary-fixnum ONE-PLUS-FIXNUM ADDI NSV ,fixnum-1)
- (unary-fixnum MINUS-ONE-PLUS-FIXNUM ADDI NSV ,(- fixnum-1))
- (unary-fixnum FIXNUM-NOT SUBI TR ,(- fixnum-1))
-
- (binary-fixnum PLUS-FIXNUM ADD NSV)
- (binary-fixnum MINUS-FIXNUM SUB NSV)
- (binary-fixnum FIXNUM-AND AND TR)
- (binary-fixnum FIXNUM-ANDC ANDCM TR)
- (binary-fixnum FIXNUM-OR OR TR)
- (binary-fixnum FIXNUM-XOR XOR TR)
-
- (binary-out-of-line MULTIPLY-FIXNUM fp4 fp5)
- (binary-out-of-line FIXNUM-QUOTIENT fp4 fp5)
- (binary-out-of-line FIXNUM-REMAINDER fp4 fp5 regnum:addil-result)
- (binary-out-of-line FIXNUM-LSH))
-\f
-;;; Out of line calls.
-
-;; Arguments are passed in regnum:first-arg and regnum:second-arg.
-;; Result is returned in regnum:first-arg, and a boolean is returned
-;; in regnum:second-arg indicating wheter there was overflow.
-
-(define (special-binary-operation operation hook target source1 source2 ovflw?)
- (if (not (pair? hook))
- (error "special-binary-operation: Unknown operation" operation))
-
- (let* ((extra ((cdr hook)))
- (load-1 (->machine-register source1 regnum:first-arg))
- (load-2 (->machine-register source2 regnum:second-arg)))
- ;; Make regnum:first-arg the only alias for target
- (delete-register! target)
- (delete-dead-registers!)
- (add-pseudo-register-alias! target regnum:first-arg)
- (LAP ,@extra
- ,@load-1
- ,@load-2
- ,@(invoke-hook (car hook))
- ,@(if (not ovflw?)
- (LAP)
- (LAP (COMICLR (=) 0 ,regnum:second-arg 0))))))
-
-(define (->machine-register source machine-reg)
- (let ((code (load-machine-register! source machine-reg)))
- ;; Prevent it from being allocated again.
- (need-register! machine-reg)
- code))
-
-;;; Binary operations with one argument constant.
-
-(define-rule statement
- ;; execute binary fixnum operation with constant second arg
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS (? operation)
- (REGISTER (? source))
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (? overflow?)))
- (QUALIFIER
- (fixnum-2-args/operator/register*constant? operation constant overflow?))
- (standard-unary-conversion source target
- (lambda (source target)
- ((fixnum-2-args/operator/register*constant operation)
- target source constant overflow?))))
-
-(define-rule statement
- ;; execute binary fixnum operation with constant first arg
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS (? operation)
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (REGISTER (? source))
- (? overflow?)))
- (QUALIFIER
- (fixnum-2-args/operator/constant*register? operation constant overflow?))
- (standard-unary-conversion source target
- (lambda (source target)
- (if (fixnum-2-args/commutative? operation)
- ((fixnum-2-args/operator/register*constant operation)
- target source constant overflow?)
- ((fixnum-2-args/operator/constant*register operation)
- target constant source overflow?)))))
-\f
-(define (define-arithconst-method name table qualifier code-gen)
- (define-arithmetic-method name table
- (cons code-gen qualifier)))
-
-(define (fixnum-2-args/commutative? operator)
- (memq operator '(PLUS-FIXNUM
- MULTIPLY-FIXNUM
- FIXNUM-AND
- FIXNUM-OR
- FIXNUM-XOR)))
-
-(define-integrable (fixnum-2-args/operator/register*constant operation)
- (car (lookup-arithmetic-method operation
- fixnum-methods/2-args/register*constant)))
-
-(define (fixnum-2-args/operator/register*constant? operation constant ovflw?)
- (let ((handler (arithmetic-method? operation
- fixnum-methods/2-args/register*constant)))
- (and handler
- ((cddr handler) constant ovflw?))))
-
-(define fixnum-methods/2-args/register*constant
- (list 'FIXNUM-METHODS/2-ARGS/REGISTER*CONSTANT))
-
-(define-integrable (fixnum-2-args/operator/constant*register operation)
- (car (lookup-arithmetic-method operation
- fixnum-methods/2-args/constant*register)))
-
-(define (fixnum-2-args/operator/constant*register? operation constant ovflw?)
- (let ((handler (arithmetic-method? operation
- fixnum-methods/2-args/constant*register)))
- (or (and handler
- ((cddr handler) constant ovflw?))
- (and (fixnum-2-args/commutative? operation)
- (fixnum-2-args/operator/register*constant? operation
- constant ovflw?)))))
-
-(define fixnum-methods/2-args/constant*register
- (list 'FIXNUM-METHODS/2-ARGS/CONSTANT*REGISTER))
-
-(define (guarantee-signed-fixnum n)
- (if (not (signed-fixnum? n)) (error "Not a signed fixnum" n))
- n)
-
-(define (signed-fixnum? n)
- (and (exact-integer? n)
- (>= n signed-fixnum/lower-limit)
- (< n signed-fixnum/upper-limit)))
-\f
-(define-arithconst-method 'PLUS-FIXNUM fixnum-methods/2-args/register*constant
- (lambda (constant ovflw?)
- ovflw? ; ignored
- (fits-in-11-bits-signed? (* constant fixnum-1)))
- (lambda (tgt src constant overflow?)
- (guarantee-signed-fixnum constant)
- (let ((value (* constant fixnum-1)))
- (if overflow?
- (cond ((zero? constant)
- (LAP (ADD (TR) ,src 0 ,tgt)))
- ((fits-in-11-bits-signed? value)
- (LAP (ADDI (NSV) ,value ,src ,tgt)))
- (else
- (let ((temp (standard-temporary!)))
- (LAP ,@(load-fixnum-constant constant temp)
- (ADD (NSV) ,src ,temp ,tgt)))))
- (load-offset value src tgt)))))
-
-(define-arithconst-method 'MINUS-FIXNUM fixnum-methods/2-args/register*constant
- (lambda (constant ovflw?)
- ovflw? ; ignored
- (fits-in-11-bits-signed? (* constant fixnum-1)))
- (lambda (tgt src constant overflow?)
- (guarantee-signed-fixnum constant)
- (let ((value (- (* constant fixnum-1))))
- (if overflow?
- (cond ((zero? constant)
- (LAP (SUB (TR) ,src 0 ,tgt)))
- ((fits-in-11-bits-signed? value)
- (LAP (ADDI (NSV) ,value ,src ,tgt)))
- (else
- (let ((temp (standard-temporary!)))
- (LAP ,@(load-fixnum-constant constant temp)
- (SUB (NSV) ,src ,temp ,tgt)))))
- (load-offset value src tgt)))))
-
-(define-arithconst-method 'MINUS-FIXNUM fixnum-methods/2-args/constant*register
- (lambda (constant ovflw?)
- ovflw? ; ignored
- (fits-in-11-bits-signed? (* constant fixnum-1)))
- (lambda (tgt constant src overflow?)
- (guarantee-signed-fixnum constant)
- (let ((value (* constant fixnum-1)))
- (if (fits-in-11-bits-signed? value)
- (if overflow?
- (LAP (SUBI (NSV) ,value ,src ,tgt))
- (LAP (SUBI () ,value ,src ,tgt)))
- (let ((temp (standard-temporary!)))
- (LAP ,@(load-fixnum-constant constant temp)
- ,@(if overflow?
- (LAP (SUB (NSV) ,temp ,src ,tgt))
- (LAP (SUB () ,temp ,src ,tgt)))))))))
-\f
-(define-arithconst-method 'FIXNUM-LSH fixnum-methods/2-args/register*constant
- (lambda (constant ovflw?)
- constant ovflw? ; ignored
- true)
- (lambda (tgt src shift overflow?)
- ;; What does overflow mean for a logical shift?
- ;; The code commented out below corresponds to arithmetic shift
- ;; overflow conditions.
- (guarantee-signed-fixnum shift)
- (cond ((zero? shift)
- (cond ((not overflow?)
- (copy src tgt))
- ((= src tgt)
- (LAP (SKIP (TR))))
- (else
- (LAP (COPY (TR) ,src ,tgt)))))
- ((negative? shift)
- ;; Right shift
- (let ((shift (- shift)))
- (cond ((< shift scheme-datum-width)
- (LAP (SHD () 0 ,src ,shift ,tgt)
- ;; clear shifted bits
- (DEP (,(if overflow? 'TR 'NV))
- 0 31 ,scheme-type-width ,tgt)))
- ((not overflow?)
- (copy 0 tgt))
- (else
- (LAP (COPY (TR) 0 ,tgt))))))
- (else
- ;; Left shift
- (if (>= shift scheme-datum-width)
- (if (not overflow?)
- (copy 0 tgt)
- #| (LAP (COMICLR (=) 0 ,src ,tgt)) |#
- (LAP (COMICLR (TR) 0 ,src ,tgt)))
- (let ((nbits (- 32 shift)))
- (if overflow?
- #|
- ;; Arithmetic overflow condition accomplished
- ;; by skipping all over the place.
- ;; Another possibility is to use the shift-and-add
- ;; instructions, which compute correct signed overflow
- ;; conditions.
- (let ((nkept (- 32 shift))
- (temp (standard-temporary!)))
- (LAP (ZDEP () ,src ,(- nkept 1) ,nkept ,tgt)
- (EXTRS (=) ,src ,(- shift 1) ,shift ,temp)
- (COMICLR (<>) -1 ,temp 0)
- (SKIP (TR))))
- |#
- (LAP (ZDEP (TR) ,src ,(- nbits 1) ,nbits ,tgt))
- (LAP (ZDEP () ,src ,(- nbits 1) ,nbits ,tgt)))))))))
-
-(define-integrable (divisible? m n)
- (zero? (remainder m n)))
-
-(define (integer-log-base-2? n)
- (let loop ((power 1) (exponent 0))
- (cond ((< n power) false)
- ((= n power) exponent)
- (else
- (loop (* 2 power) (1+ exponent))))))
-\f
-(define-arithconst-method 'MULTIPLY-FIXNUM
- fixnum-methods/2-args/register*constant
- (lambda (constant ovflw?)
- (let ((factor (abs constant)))
- #|
- (or (integer-log-base-2? factor)
- (and (<= factor 64)
- (or (not ovflw?)
- (<= factor (expt 2 scheme-type-width)))))
- |#
- (or (not ovflw?)
- (<= factor 64)
- (integer-log-base-2? factor))))
-
- (lambda (tgt src constant overflow?)
- (guarantee-signed-fixnum constant)
- (let ((skip (if overflow? 'NSV 'NV)))
- (case constant
- ((0)
- (if overflow?
- (LAP (COPY (TR) 0 ,tgt))
- (LAP (COPY () 0 ,tgt))))
- ((1)
- (if overflow?
- (LAP (COPY (TR) ,src ,tgt))
- (copy src tgt)))
- ((-1)
- (LAP (SUB (,skip) 0 ,src ,tgt)))
- (else
- (let* ((factor (abs constant))
- (src+ (if (negative? constant) tgt src))
- (xpt (integer-log-base-2? factor)))
- (cond ((not overflow?)
- (LAP ,@(if (negative? constant)
- (LAP (SUB () 0 ,src ,tgt))
- (LAP))
- ,@(if xpt
- (LAP (SHD () ,src+ 0 ,(- 32 xpt) ,tgt))
- (expand-factor tgt src+ factor false 'NV
- (lambda ()
- (LAP))))))
- ((and xpt (> xpt 6))
- (let* ((high (standard-temporary!))
- (low (if (or (= src tgt) (negative? constant))
- (standard-temporary!)
- src))
- (nbits (- 32 xpt))
- (core
- (LAP (SHD () ,low 0 ,nbits ,tgt)
- (SHD (=) ,high ,low ,(-1+ nbits) ,high)
- (COMICLR (<>) -1 ,high 0)
- (SKIP (TR)))))
- (if (negative? constant)
- (LAP (EXTRS () ,src 0 1 ,high)
- (SUB () 0 ,src ,low)
- (SUBB () 0 ,high ,high)
- ,@core)
- (LAP ,@(if (not (= src low))
- (LAP (COPY () ,src ,low))
- (LAP))
- (EXTRS () ,low 0 1 ,high)
- ,@core))))
- (else
- (LAP ,@(if (negative? constant)
- (LAP (SUB (SV) 0 ,src ,tgt))
- (LAP))
- ,@(expand-factor tgt src+ factor (negative? constant)
- 'NSV
- (lambda ()
- (LAP (SKIP (TR))))))))))))))
-\f
-(define (expand-factor tgt src factor skipping? condition skip)
- (define (sh3add condition src1 src2 tgt)
- (LAP (SH3ADD (,condition) ,src1 ,src2 ,tgt)))
-
- (define (sh2add condition src1 src2 tgt)
- (LAP (SH2ADD (,condition) ,src1 ,src2 ,tgt)))
-
- (define (sh1add condition src1 src2 tgt)
- (LAP (SH1ADD (,condition) ,src1 ,src2 ,tgt)))
-
- (define (handle factor fixed)
- (define (wrap instr next value)
- (let ((code? (car next))
- (result-reg (cadr next))
- (temp-reg (caddr next))
- (code (cadddr next)))
- (list true
- tgt
- temp-reg
- (LAP ,@code
- ,@(if code?
- (skip)
- (LAP))
- ,@(instr condition result-reg value tgt)))))
-
- (cond ((zero? factor) (list false 0 fixed (LAP)))
- ((= factor 1) (list false fixed fixed (LAP)))
- ((divisible? factor 8)
- (wrap sh3add (handle (/ factor 8) fixed) 0))
- ((divisible? factor 4)
- (wrap sh2add (handle (/ factor 4) fixed) 0))
- ((divisible? factor 2)
- (wrap sh1add (handle (/ factor 2) fixed) 0))
- (else
- (let* ((f1 (-1+ factor))
- (fixed (if (or (not (= fixed src))
- (not (= src tgt))
- (and (integer-log-base-2? f1)
- (< f1 16)))
- fixed
- (standard-temporary!))))
- (cond ((divisible? f1 8)
- (wrap sh3add (handle (/ f1 8) fixed) fixed))
- ((divisible? f1 4)
- (wrap sh2add (handle (/ f1 4) fixed) fixed))
- (else
- (wrap sh1add (handle (/ f1 2) fixed) fixed)))))))
-
- (let ((result (handle factor src)))
- (let ((result-reg (cadr result))
- (temp-reg (caddr result))
- (code (cadddr result)))
-
- (LAP ,@(cond ((= temp-reg src)
- (LAP))
- ((not skipping?)
- (LAP (COPY () ,src ,temp-reg)))
- (else
- (LAP (COPY (TR) ,src ,temp-reg)
- ,@(skip))))
- ,@code
- ,@(cond ((= result-reg tgt)
- (LAP))
- ((eq? condition 'NV)
- (LAP (COPY () ,result-reg ,tgt)))
- (else
- (LAP (COPY (TR) ,result-reg ,tgt)
- ,@(skip))))))))
-\f
-;;;; Division
-
-(define-arithconst-method 'FIXNUM-QUOTIENT
- fixnum-methods/2-args/register*constant
- (lambda (constant ovflw?)
- ovflw? ; ignored
- (integer-log-base-2? (abs constant)))
- (lambda (tgt src constant ovflw?)
- (guarantee-signed-fixnum constant)
- (case constant
- ((1)
- (if ovflw?
- (LAP (COPY (TR) ,src ,tgt))
- (copy src tgt)))
- ((-1)
- (let ((skip (if ovflw? 'NSV 'NV)))
- (LAP (SUB (,skip) 0 ,src ,tgt))))
- (else
- (let* ((factor (abs constant))
- (xpt (integer-log-base-2? factor)))
- (cond ((not xpt)
- (error "fixnum-quotient: Inconsistency" constant))
- ((>= xpt scheme-datum-width)
- (if ovflw?
- (LAP (COPY (TR) 0 ,tgt))
- (copy 0 tgt)))
- (else
- ;; Note: The following cannot overflow because we are
- ;; dividing by a constant whose absolute value is
- ;; strictly greater than 1. However, we need to
- ;; negate after shifting, not before, because negating
- ;; the input can overflow (if it is -0).
- ;; This unfortunately implies an extra instruction in the
- ;; case of negative constants because if this weren't the
- ;; case, we could substitute the first ADD instruction for
- ;; a SUB for negative constants, and eliminate the SUB later.
- (let* ((posn (- 32 xpt))
- (delta (* (-1+ factor) fixnum-1))
- (fits? (fits-in-11-bits-signed? delta))
- (temp (and (not fits?) (standard-temporary!))))
- (LAP ,@(if fits? (LAP) (load-immediate delta temp))
- (ADD (>=) 0 ,src ,tgt)
- ,@(if fits?
- (LAP (ADDI () ,delta ,tgt ,tgt))
- (LAP (ADD () ,temp ,tgt ,tgt)))
- (EXTRS () ,tgt ,(-1+ posn) ,posn ,tgt)
- ,@(let ((skip (if ovflw? 'TR 'NV)))
- (if (negative? constant)
- (LAP (DEP () 0 31 ,scheme-type-width ,tgt)
- (SUB (,skip) 0 ,tgt ,tgt))
- (LAP
- (DEP (,skip) 0 31 ,scheme-type-width
- ,tgt)))))))))))))
-
-(define-arithconst-method 'FIXNUM-REMAINDER
- fixnum-methods/2-args/register*constant
- (lambda (constant ovflw?)
- ovflw? ; ignored
- (integer-log-base-2? (abs constant)))
- (lambda (tgt src constant ovflw?)
- (guarantee-signed-fixnum constant)
- (case constant
- ((1 -1)
- (if ovflw?
- (LAP (COPY (TR) 0 ,tgt))
- (LAP (COPY () 0 ,tgt))))
- (else
- (let ((sign (standard-temporary!))
- (len (let ((xpt (integer-log-base-2? (abs constant))))
- (and xpt (+ xpt scheme-type-width)))))
- (let ((sgn-len (- 32 len)))
- (if (not len)
- (error "fixnum-remainder: Inconsistency" constant ovflw?))
- (LAP (EXTRS () ,src 0 1 ,sign)
- (EXTRU (=) ,src 31 ,len ,tgt)
- (DEP () ,sign ,(- sgn-len 1) ,sgn-len ,tgt)
- ,@(if ovflw?
- (LAP (SKIP (TR)))
- (LAP)))))))))
-\f
-;;;; Predicates
-
-;; This is a kludge. It assumes that the last instruction of the
-;; arithmetic operation that may cause an overflow condition will skip
-;; the following instruction if there was no overflow, ie., the last
-;; instruction will nullify using NSV (or TR if overflow is
-;; impossible). The code for the alternative is a real kludge because
-;; we can't force the arithmetic instruction that precedes this code
-;; to use the inverted condition. Hopefully a peep-hole optimizer
-;; will fix this. The linearizer attempts to use the "good" branch.
-
-(define-rule predicate
- (OVERFLOW-TEST)
- (set-current-branches!
- (lambda (label)
- (LAP (B (N) (@PCR ,label))))
- (lambda (label)
- (LAP (SKIP (TR))
- (B (N) (@PCR ,label)))))
- (LAP))
-
-(define-rule predicate
- (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
- (compare (fixnum-pred->cc predicate)
- (standard-source! source)
- 0))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (REGISTER (? source1))
- (REGISTER (? source2)))
- (compare (fixnum-pred->cc predicate)
- (standard-source! source1)
- (standard-source! source2)))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (REGISTER (? source))
- (OBJECT->FIXNUM (CONSTANT (? constant))))
- (compare-fixnum/constant*register (invert-condition-noncommutative
- (fixnum-pred->cc predicate))
- constant
- (standard-source! source)))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (REGISTER (? source)))
- (compare-fixnum/constant*register (fixnum-pred->cc predicate)
- constant
- (standard-source! source)))
-
-(define-integrable (compare-fixnum/constant*register cc n r)
- (guarantee-signed-fixnum n)
- (compare-immediate cc (* n fixnum-1) r))
-
-(define (fixnum-pred->cc predicate)
- (case predicate
- ((ZERO-FIXNUM? EQUAL-FIXNUM?) '=)
- ((NEGATIVE-FIXNUM? LESS-THAN-FIXNUM?) '<)
- ((POSITIVE-FIXNUM? GREATER-THAN-FIXNUM?) '>)
- ((UNSIGNED-LESS-THAN-FIXNUM?) '<<)
- ((UNSIGNED-GREATER-THAN-FIXNUM?) '>>)
- (else
- (error "fixnum-pred->cc: unknown predicate" predicate))))
-\f
-;;;; New "optimizations"
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OBJECT->DATUM (FIXNUM->OBJECT (REGISTER (? source)))))
- (standard-unary-conversion source target fixnum->datum))
-
-(define (constant->additive-operand operation constant)
- (case operation
- ((PLUS-FIXNUM ONE-PLUS-FIXNUM) constant)
- ((MINUS-FIXNUM MINUS-ONE-PLUS-FIXNUM) (- constant))
- (else
- (error "constant->additive-operand: Unknown operation"
- operation))))
-
-(define (guarantee-fixnum-result target)
- (let ((default
- (lambda ()
- (deposit-immediate (ucode-type fixnum)
- (-1+ scheme-type-width)
- scheme-type-width
- target))))
- #|
- ;; Unsafe at sign crossings until the tags are changed.
- (if compiler:assume-safe-fixnums?
- (LAP)
- (default))
- |#
- (default)))
-
-(define (obj->fix-of-reg*obj->fix-of-const operation target source constant)
- (let* ((source (standard-source! source))
- (temp (standard-temporary!))
- (target (standard-target! target)))
- (LAP ,@(load-offset (constant->additive-operand operation constant)
- source temp)
- ,@(object->fixnum temp target))))
-
-(define (fix->obj-of-obj->fix-of-reg*obj->fix-of-const operation target
- source constant)
- (let* ((source (standard-source! source))
- (target (standard-target! target)))
- (LAP ,@(load-offset (constant->additive-operand operation constant)
- source target)
- ,@(guarantee-fixnum-result target))))
-
-(define (obj->dat-of-fix->obj-of-obj->fix-of-reg*obj->fix-of-const
- operation target source constant)
- (let* ((source (standard-source! source))
- (temp (standard-temporary!))
- (target (standard-target! target)))
- (LAP ,@(load-offset (constant->additive-operand operation constant)
- source temp)
- ,@(object->datum temp target))))
-
-(define (fix->obj-of-reg*obj->fix-of-const operation target source constant)
- (let* ((source (standard-source! source))
- (temp (standard-temporary!))
- (target (standard-target! target)))
- (LAP ,@(load-offset
- (constant->additive-operand operation (* constant fixnum-1))
- source temp)
- ,@(fixnum->object temp target))))
-
-(define (obj->dat-of-fix->obj-of-reg*obj->fix-of-const
- operation target source constant)
- (let* ((source (standard-source! source))
- (temp (standard-temporary!))
- (target (standard-target! target)))
- (LAP ,@(load-offset
- (constant->additive-operand operation (* constant fixnum-1))
- source temp)
- ,@(fixnum->datum temp target))))
-\f
-(define (incr-or-decr? operation)
- (and (memq operation '(ONE-PLUS-FIXNUM MINUS-ONE-PLUS-FIXNUM))
- operation))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM-1-ARG (? operation incr-or-decr?)
- (OBJECT->FIXNUM (REGISTER (? source)))
- #F))
- (obj->fix-of-reg*obj->fix-of-const operation target source 1))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM->OBJECT
- (FIXNUM-1-ARG (? operation incr-or-decr?)
- (OBJECT->FIXNUM (REGISTER (? source)))
- #F)))
- (fix->obj-of-obj->fix-of-reg*obj->fix-of-const operation target source 1))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OBJECT->DATUM
- (FIXNUM->OBJECT
- (FIXNUM-1-ARG (? operation incr-or-decr?)
- (OBJECT->FIXNUM (REGISTER (? source)))
- #F))))
- (obj->dat-of-fix->obj-of-obj->fix-of-reg*obj->fix-of-const
- operation target source 1))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM->OBJECT
- (FIXNUM-1-ARG (? operation incr-or-decr?)
- (REGISTER (? source))
- #F)))
- (fix->obj-of-reg*obj->fix-of-const operation target source 1))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OBJECT->DATUM
- (FIXNUM->OBJECT
- (FIXNUM-1-ARG (? operation incr-or-decr?)
- (REGISTER (? source))
- #F))))
- (obj->dat-of-fix->obj-of-reg*obj->fix-of-const
- operation target source 1))
-\f
-(define (plus-or-minus? operation)
- (and (memq operation '(PLUS-FIXNUM MINUS-FIXNUM))
- operation))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS (? operation plus-or-minus?)
- (OBJECT->FIXNUM (REGISTER (? source)))
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- #F))
- (obj->fix-of-reg*obj->fix-of-const operation target source constant))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM->OBJECT
- (FIXNUM-2-ARGS (? operation plus-or-minus?)
- (OBJECT->FIXNUM (REGISTER (? source)))
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- #F)))
- (QUALIFIER (memq operation '(PLUS-FIXNUM MINUS-FIXNUM)))
- (fix->obj-of-obj->fix-of-reg*obj->fix-of-const operation target
- source constant))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OBJECT->DATUM
- (FIXNUM->OBJECT
- (FIXNUM-2-ARGS (? operation plus-or-minus?)
- (OBJECT->FIXNUM (REGISTER (? source)))
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- #F))))
- (QUALIFIER (memq operation '(PLUS-FIXNUM MINUS-FIXNUM)))
- (obj->dat-of-fix->obj-of-obj->fix-of-reg*obj->fix-of-const
- operation target source constant))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM->OBJECT
- (FIXNUM-2-ARGS (? operation plus-or-minus?)
- (REGISTER (? source))
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- #F)))
- (QUALIFIER (memq operation '(PLUS-FIXNUM MINUS-FIXNUM)))
- (fix->obj-of-reg*obj->fix-of-const operation target source constant))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OBJECT->DATUM
- (FIXNUM->OBJECT
- (FIXNUM-2-ARGS (? operation plus-or-minus?)
- (REGISTER (? source))
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- #F))))
- (QUALIFIER (memq operation '(PLUS-FIXNUM MINUS-FIXNUM)))
- (obj->dat-of-fix->obj-of-reg*obj->fix-of-const
- operation target source constant))
-\f
-(define (additive-operate operation target source-1 source-2)
- (case operation
- ((PLUS-FIXNUM)
- (LAP (ADD () ,source-1 ,source-2 ,target)))
- ((MINUS-FIXNUM)
- (LAP (SUB () ,source-1 ,source-2 ,target)))
- (else
- (error "constant->additive-operand: Unknown operation"
- operation))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS (? operation plus-or-minus?)
- (REGISTER (? source-1))
- (OBJECT->FIXNUM (REGISTER (? source-2)))
- #F))
- (let* ((source-1 (standard-source! source-1))
- (source-2 (standard-source! source-2))
- (temp (standard-temporary!))
- (target (standard-target! target)))
- (LAP ,@(object->fixnum source-2 temp)
- ,@(additive-operate operation target source-1 temp))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS (? operation plus-or-minus?)
- (OBJECT->FIXNUM (REGISTER (? source-1)))
- (REGISTER (? source-2))
- #F))
- (let* ((source-1 (standard-source! source-1))
- (source-2 (standard-source! source-2))
- (temp (standard-temporary!))
- (target (standard-target! target)))
- (LAP ,@(object->fixnum source-1 temp)
- ,@(additive-operate operation target temp source-2))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS (? operation plus-or-minus?)
- (OBJECT->FIXNUM (REGISTER (? source-1)))
- (OBJECT->FIXNUM (REGISTER (? source-2)))
- #F))
- (let* ((source-1 (standard-source! source-1))
- (source-2 (standard-source! source-2))
- (temp (standard-temporary!))
- (target (standard-target! target)))
- (LAP ,@(additive-operate operation temp source-1 source-2)
- ,@(object->fixnum temp target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM->OBJECT
- (FIXNUM-2-ARGS (? operation plus-or-minus?)
- (OBJECT->FIXNUM (REGISTER (? source-1)))
- (OBJECT->FIXNUM (REGISTER (? source-2)))
- #F)))
- (let* ((source-1 (standard-source! source-1))
- (source-2 (standard-source! source-2))
- (target (standard-target! target)))
- (LAP ,@(additive-operate operation target source-1 source-2)
- ,@(guarantee-fixnum-result target))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Flonum rules
-;; Package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-(define (flonum-source! register)
- (float-register->fpr (load-alias-register! register 'FLOAT)))
-
-(define (flonum-target! pseudo-register)
- (delete-dead-registers!)
- (float-register->fpr (allocate-alias-register! pseudo-register 'FLOAT)))
-
-(define (flonum-temporary!)
- (float-register->fpr (allocate-temporary-register! 'FLOAT)))
-
-(define-rule statement
- ;; convert a floating-point number to a flonum object
- (ASSIGN (REGISTER (? target))
- (FLOAT->OBJECT (REGISTER (? source))))
- (let ((source (flonum-source! source))
- (temp (standard-temporary!)))
- (let ((target (standard-target! target)))
- (LAP
- ;; make heap parsable forwards
- ;; (STW () 0 (OFFSET 0 0 ,regnum:free-pointer))
- (DEPI () #b100 31 3 ,regnum:free-pointer) ; quad align
- (COPY () ,regnum:free-pointer ,target)
- ,@(deposit-type (ucode-type flonum) target)
- ,@(load-non-pointer (ucode-type manifest-nm-vector) 2 temp)
- (STWS (MA C) ,temp (OFFSET 4 0 ,regnum:free-pointer))
- (FSTDS (MA) ,source (OFFSET 8 0 ,regnum:free-pointer))))))
-
-(define-rule statement
- ;; convert a flonum object to a floating-point number
- (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source))))
- (let ((source (standard-move-to-temporary! source)))
- (LAP ,@(object->address source)
- (FLDDS () (OFFSET 4 0 ,source) ,(flonum-target! target)))))
-
-;; This is endianness dependent!
-
-(define (flonum-value->data-decl value)
- (let ((high (make-bit-string 32 false))
- (low (make-bit-string 32 false)))
- (read-bits! value 32 high)
- (read-bits! value 64 low)
- (LAP ,@(lap:comment `(FLOAT ,value))
- (UWORD () ,(bit-string->unsigned-integer high))
- (UWORD () ,(bit-string->unsigned-integer low)))))
-
-(define (flonum->label value)
- (let* ((block
- (or (find-extra-code-block 'FLOATING-CONSTANTS)
- (let ((block (declare-extra-code-block! 'FLOATING-CONSTANTS
- 'ANYWHERE
- '())))
- (add-extra-code!
- block
- (LAP (PADDING ,(- 0 *initial-dword-offset*) 8)))
- block)))
- (pairs (extra-code-block/xtra block))
- (place (assoc value pairs)))
- (if place
- (cdr place)
- (let ((label (generate-label)))
- (set-extra-code-block/xtra!
- block
- (cons (cons value label) pairs))
- (add-extra-code! block
- (LAP (LABEL ,label)
- ,@(flonum-value->data-decl value)))
- label))))
-\f
-#|
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (CONSTANT 0.)))
- (LAP (FCPY (DBL) 0 ,(flonum-target! target))))
-|#
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (CONSTANT (? fp-value))))
- (cond ((not (flo:flonum? fp-value))
- (error "OBJECT->FLOAT: Not a floating-point value" fp-value))
- (compiler:cross-compiling?
- (let ((temp (standard-temporary!)))
- (LAP ,@(load-constant fp-value temp)
- ,@(object->address temp)
- (FLDDS () (OFFSET 4 0 ,temp) ,(flonum-target! target)))))
- ((flo:= fp-value 0.0)
- (LAP (FCPY (DBL) 0 ,(flonum-target! target))))
- (else
- (let* ((temp (standard-temporary!))
- (target (flonum-target! target)))
- (LAP ,@(load-pc-relative-address (flonum->label fp-value)
- temp
- 'CONSTANT)
- (FLDDS () (OFFSET 0 0 ,temp) ,target))))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset))))
- (float-load/offset target base (* 8 offset)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? w-offset)))
- (MACHINE-CONSTANT (? f-offset))))
- (float-load/offset target base (+ (* 4 w-offset) (* 8 f-offset))))
-
-(define-rule statement
- (ASSIGN (FLOAT-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
- (REGISTER (? source)))
- (float-store/offset base (* 8 offset) source))
-
-(define-rule statement
- (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? w-offset)))
- (MACHINE-CONSTANT (? f-offset)))
- (REGISTER (? source)))
- (float-store/offset base (+ (* 4 w-offset) (* 8 f-offset)) source))
-\f
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET (REGISTER (? base)) (REGISTER (? index))))
- (let* ((base (standard-source! base))
- (index (standard-source! index))
- (target (flonum-target! target)))
- (LAP (FLDDX (S) (INDEX ,index 0 ,base) ,target))))
-
-(define-rule statement
- (ASSIGN (FLOAT-OFFSET (REGISTER (? base)) (REGISTER (? index)))
- (REGISTER (? source)))
- (let ((source (flonum-source! source))
- (base (standard-source! base))
- (index (standard-source! index)))
- (LAP (FSTDX (S) ,source (INDEX ,index 0 ,base)))))
-
-(define (float-load/offset target base offset)
- (let ((base (standard-source! base)))
- (%float-load/offset (flonum-target! target)
- base
- offset)))
-
-(define (float-store/offset base offset source)
- (%float-store/offset (standard-source! base)
- offset
- (flonum-source! source)))
-
-(define (%float-load/offset target base offset)
- (if (<= -16 offset 15)
- (LAP (FLDDS () (OFFSET ,offset 0 ,base) ,target))
- (let ((base* (standard-temporary!)))
- (LAP (LDO () (OFFSET ,offset 0 ,base) ,base*)
- (FLDDS () (OFFSET 0 0 ,base*) ,target)))))
-
-(define (%float-store/offset base offset source)
- (if (<= -16 offset 15)
- (LAP (FSTDS () ,source (OFFSET ,offset 0 ,base)))
- (let ((base* (standard-temporary!)))
- (LAP (LDO () (OFFSET ,offset 0 ,base) ,base*)
- (FSTDS () ,source (OFFSET 0 0 ,base*))))))
-\f
-;;;; Optimized floating-point references
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
- (MACHINE-CONSTANT (? w-offset)))
- (MACHINE-CONSTANT (? f-offset))))
- (let ((b-offset (+ (* 4 w-offset) (* 8 f-offset))))
- (reuse-pseudo-register-alias!
- base 'GENERAL
- (lambda (base)
- (let ((target (flonum-target! target)))
- (LAP ,@(object->address base)
- ,@(%float-load/offset target base b-offset))))
- (lambda ()
- (let* ((base (standard-source! base))
- (base* (standard-temporary!))
- (target (flonum-target! target)))
- (LAP (LDO () (OFFSET ,b-offset 0 ,base) ,base*)
- ,@(object->address base*)
- (FLDDS () (OFFSET 0 0 ,base*) ,target)))))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
- (MACHINE-CONSTANT (? offset)))
- (OBJECT->DATUM (REGISTER (? index)))))
- (let ((base (standard-source! base))
- (index (standard-source! index))
- (temp (standard-temporary!)))
- (let ((target (flonum-target! target)))
- (LAP (SH3ADDL () ,index ,base ,temp)
- ,@(object->address temp)
- ,@(%float-load/offset target temp (* 4 offset))))))
-
-(define-rule statement
- (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
- (MACHINE-CONSTANT (? offset)))
- (OBJECT->DATUM (REGISTER (? index))))
- (REGISTER (? source)))
- (let ((source (flonum-source! source))
- (base (standard-source! base))
- (index (standard-source! index))
- (temp (standard-temporary!)))
- (LAP (SH3ADDL () ,index ,base ,temp)
- ,@(object->address temp)
- ,@(%float-store/offset temp (* 4 offset) source))))
-\f
-;;;; Intermediate rules needed to generate the above.
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
- (MACHINE-CONSTANT (? offset))))
- (let* ((base (standard-source! base))
- (target (standard-target! target)))
- (LAP (LDO () (OFFSET ,(* 4 offset) 0 ,base) ,target)
- ,@(object->address target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? offset)))
- (OBJECT->DATUM (REGISTER (? index)))))
- (let ((base (standard-source! base))
- (index (standard-source! index))
- (temp (standard-temporary!)))
- (let ((target (flonum-target! target)))
- (LAP ,@(object->datum index temp)
- (SH3ADDL () ,temp ,base ,temp)
- ,@(%float-load/offset target temp (* 4 offset))))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET (REGISTER (? base))
- (OBJECT->DATUM (REGISTER (? index)))))
- (let ((base (standard-source! base))
- (index (standard-source! index))
- (temp (standard-temporary!)))
- (let ((target (flonum-target! target)))
- (LAP ,@(object->datum index temp)
- (FLDDX (S) (INDEX ,temp 0 ,base) ,target)))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? offset)))
- (REGISTER (? index))))
- (let ((base (standard-source! base))
- (index (standard-source! index))
- (temp (standard-temporary!)))
- (let ((target (flonum-target! target)))
- (LAP (SH3ADDL () ,index ,base ,temp)
- ,@(%float-load/offset target temp (* 4 offset))))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLOAT-OFFSET (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
- (MACHINE-CONSTANT (? offset)))
- (REGISTER (? index))))
- (let ((base (standard-source! base))
- (index (standard-source! index))
- (temp (standard-temporary!)))
- (let ((target (flonum-target! target)))
- (LAP (SH3ADDL () ,index ,base ,temp)
- ,@(object->address temp)
- ,@(%float-load/offset target temp (* 4 offset))))))
-\f
-(define-rule statement
- (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? offset)))
- (OBJECT->DATUM (REGISTER (? index))))
- (REGISTER (? source)))
- (let ((base (standard-source! base))
- (index (standard-source! index))
- (temp (standard-temporary!))
- (source (flonum-source! source)))
- (LAP ,@(object->datum index temp)
- (SH3ADDL () ,temp ,base ,temp)
- ,@(%float-store/offset temp (* 4 offset) source))))
-
-(define-rule statement
- (ASSIGN (FLOAT-OFFSET (REGISTER (? base))
- (OBJECT->DATUM (REGISTER (? index))))
- (REGISTER (? source)))
- (let ((base (standard-source! base))
- (index (standard-source! index))
- (temp (standard-temporary!))
- (source (flonum-source! source)))
- (LAP ,@(object->datum index temp)
- (FSTDX (S) ,source (INDEX ,temp 0 ,base)))))
-
-(define-rule statement
- (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
- (MACHINE-CONSTANT (? offset)))
- (REGISTER (? index)))
- (REGISTER (? source)))
- (let ((base (standard-source! base))
- (index (standard-source! index))
- (temp (standard-temporary!))
- (source (flonum-source! source)))
- (LAP (SH3ADDL () ,index ,base ,temp)
- ,@(%float-store/offset temp (* 4 offset) source))))
-
-(define-rule statement
- (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
- (MACHINE-CONSTANT (? offset)))
- (REGISTER (? index)))
- (REGISTER (? source)))
- (let ((base (standard-source! base))
- (index (standard-source! index))
- (temp (standard-temporary!))
- (source (flonum-source! source)))
- (LAP (SH3ADDL () ,index ,base ,temp)
- ,@(object->address temp)
- ,@(%float-store/offset temp (* 4 offset) source))))
-\f
-;;;; Flonum Arithmetic
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?)))
- (QUALIFIER (arithmetic-method? operation flonum-methods/1-arg))
- overflow? ;ignore
- (let ((source (flonum-source! source)))
- ((flonum-1-arg/operator operation) (flonum-target! target) source)))
-
-(define (flonum-1-arg/operator operation)
- (lookup-arithmetic-method operation flonum-methods/1-arg))
-
-(define flonum-methods/1-arg
- (list 'FLONUM-METHODS/1-ARG))
-
-;;; Notice the weird ,', syntax here.
-;;; If LAP changes, this may also have to change.
-
-(let-syntax
- ((define-flonum-operation
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-ARITHMETIC-METHOD ',(cadr form) FLONUM-METHODS/1-ARG
- (LAMBDA (TARGET SOURCE)
- (LAP (,(caddr form) (DBL) ,',SOURCE ,',TARGET))))))))
- (define-flonum-operation FLONUM-ABS FABS)
- (define-flonum-operation FLONUM-SQRT FSQRT)
- (define-flonum-operation FLONUM-ROUND FRND))
-
-(define-arithmetic-method 'FLONUM-NEGATE flonum-methods/1-arg
- (lambda (target source)
- ;; The status register (fr0) reads as 0 for non-store instructions.
- (LAP (FSUB (DBL) 0 ,source ,target))))
-\f
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?)))
- (QUALIFIER (arithmetic-method? operation flonum-methods/1-arg/special))
- overflow? ;ignore
- (flonum/1-arg/special
- (lookup-arithmetic-method operation flonum-methods/1-arg/special)
- target source))
-
-(define flonum-methods/1-arg/special
- (list 'FLONUM-METHODS/1-ARG/SPECIAL))
-
-(let-syntax ((define-out-of-line
- (sc-macro-transformer
- (lambda (form environment)
- `(DEFINE-ARITHMETIC-METHOD ',(cadr form)
- FLONUM-METHODS/1-ARG/SPECIAL
- ,(close-syntax (symbol-append 'HOOK:COMPILER- (cadr form))
- environment))))))
- (define-out-of-line FLONUM-SIN)
- (define-out-of-line FLONUM-COS)
- (define-out-of-line FLONUM-TAN)
- (define-out-of-line FLONUM-ASIN)
- (define-out-of-line FLONUM-ACOS)
- (define-out-of-line FLONUM-ATAN)
- (define-out-of-line FLONUM-EXP)
- (define-out-of-line FLONUM-LOG)
- (define-out-of-line FLONUM-TRUNCATE)
- (define-out-of-line FLONUM-CEILING)
- (define-out-of-line FLONUM-FLOOR))
-
-(define caller-saves-registers
- (list
- ;; g1 g19 g20 g21 g22 ; Not available for allocation
- g23 g24 g25 g26 g28 g29 g31
- ;; fp0 fp1 fp2 fp3 ; Not real registers
- fp4 fp5 fp6 fp7 fp8 fp9 fp10 fp11))
-
-(define registers-to-preserve-around-special-calls
- (append (list g15 g16 g17 g18)
- caller-saves-registers))
-
-(define (flonum/1-arg/special hook target source)
- (let ((load-arg (->machine-register source fp5)))
- (delete-register! target)
- (delete-dead-registers!)
- (let ((clear-regs
- (apply clear-registers!
- registers-to-preserve-around-special-calls)))
- (add-pseudo-register-alias! target fp4)
- (LAP ,@load-arg
- ,@clear-regs
- ,@(invoke-hook hook)))))
-
-;; Missing operations
-
-#|
-;; Return integers
-(define-out-of-line FLONUM-ROUND->EXACT)
-(define-out-of-line FLONUM-TRUNCATE->EXACT)
-(define-out-of-line FLONUM-FLOOR->EXACT)
-(define-out-of-line FLONUM-CEILING->EXACT)
-
-;; Returns a pair
-(define-out-of-line FLONUM-NORMALIZE)
-
-;; Two arguments
-(define-out-of-line FLONUM-DENORMALIZE) ; flo*int
-|#
-\f
-;;;; Two arg operations
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLONUM-2-ARGS FLONUM-SUBTRACT
- (OBJECT->FLOAT (CONSTANT 0.))
- (REGISTER (? source))
- (? overflow?)))
- overflow? ; ignore
- (let ((source (flonum-source! source)))
- (LAP (FSUB (DBL) 0 ,source ,(flonum-target! target)))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLONUM-2-ARGS (? operation)
- (REGISTER (? source1))
- (REGISTER (? source2))
- (? overflow?)))
- (QUALIFIER (arithmetic-method? operation flonum-methods/2-args))
- overflow? ;ignore
- (let ((source1 (flonum-source! source1))
- (source2 (flonum-source! source2)))
- ((flonum-2-args/operator operation) (flonum-target! target)
- source1
- source2)))
-
-(define (flonum-2-args/operator operation)
- (lookup-arithmetic-method operation flonum-methods/2-args))
-
-(define flonum-methods/2-args
- (list 'FLONUM-METHODS/2-ARGS))
-
-(let-syntax
- ((define-flonum-operation
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-ARITHMETIC-METHOD ',(cadr form) FLONUM-METHODS/2-ARGS
- (LAMBDA (TARGET SOURCE1 SOURCE2)
- (LAP (,(caddr form) (DBL)
- ,',SOURCE1 ,',SOURCE2 ,',TARGET))))))))
- (define-flonum-operation flonum-add fadd)
- (define-flonum-operation flonum-subtract fsub)
- (define-flonum-operation flonum-multiply fmpy)
- (define-flonum-operation flonum-divide fdiv)
- (define-flonum-operation flonum-remainder frem))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FLONUM-2-ARGS FLONUM-ATAN2
- (REGISTER (? source1))
- (REGISTER (? source2))
- (? overflow?)))
- overflow? ;ignore
- (let* ((load-arg-1 (->machine-register source1 fp5))
- (load-arg-2 (->machine-register source2 fp7)))
- (delete-register! target)
- (delete-dead-registers!)
- (let ((clear-regs
- (apply clear-registers!
- registers-to-preserve-around-special-calls)))
- (add-pseudo-register-alias! target fp4)
- (LAP ,@load-arg-1
- ,@load-arg-2
- ,@clear-regs
- ,@(invoke-hook hook:compiler-flonum-atan2)))))
-\f
-;;;; Flonum Predicates
-
-(define-rule predicate
- (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
- #|
- ;; No immediate zeros, easy to generate by subtracting from itself
- (let ((temp (flonum-temporary!)))
- (LAP (FSUB (DBL) ,temp ,temp ,temp)
- ,@(flonum-compare
- (case predicate
- ((FLONUM-ZERO?) '=)
- ((FLONUM-NEGATIVE?) '<)
- ((FLONUM-POSITIVE?) '>)
- (else (error "unknown flonum predicate" predicate)))
- (flonum-source! source)
- temp)))
- |#
- ;; The status register (fr0) reads as 0 for non-store instructions.
- (flonum-compare (case predicate
- ((FLONUM-ZERO?) '=)
- ((FLONUM-NEGATIVE?) '<)
- ((FLONUM-POSITIVE?) '>)
- (else (error "unknown flonum predicate" predicate)))
- (flonum-source! source)
- 0))
-
-(define-rule predicate
- (FLONUM-PRED-2-ARGS (? predicate)
- (REGISTER (? source1))
- (REGISTER (? source2)))
- (flonum-compare (case predicate
- ((FLONUM-EQUAL?) '=)
- ((FLONUM-LESS?) '<)
- ((FLONUM-GREATER?) '>)
- (else (error "unknown flonum predicate" predicate)))
- (flonum-source! source1)
- (flonum-source! source2)))
-
-(define (flonum-compare cc r1 r2)
- (set-current-branches!
- (lambda (true-label)
- (LAP (FCMP (,(invert-float-condition cc) DBL) ,r1 ,r2)
- (FTEST ())
- (B (N) (@PCR ,true-label))))
- (lambda (false-label)
- (LAP (FCMP (,cc DBL) ,r1 ,r2)
- (FTEST ())
- (B (N) (@PCR ,false-label)))))
- (LAP))
-
-;; invert-float-condition makes sure that NaNs are taken care of
-;; correctly.
-
-(define (invert-float-condition cc)
- (let ((place (assq cc float-inversion-table)))
- (if (not place)
- (error "invert-float-condition: Unknown condition"
- cc)
- (cadr place))))
-
-(define float-inversion-table
- ;; There are many others, but only these are used here.
- '((> !>)
- (< !<)
- (= !=)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RTL Rewrite Rules
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Synthesized Data
-
-(define-rule rewriting
- (CONS-NON-POINTER (? type) (? datum))
- ;; Since we use DEP instructions to insert type codes, there's no
- ;; difference between the way that pointers and non-pointers are
- ;; constructed.
- (rtl:make-cons-pointer type datum))
-
-(define-rule rewriting
- (CONS-POINTER (REGISTER (? type register-known-value))
- (REGISTER (? datum register-known-value)))
- (QUALIFIER (and (rtl:machine-constant? type)
- (rtl:machine-constant? datum)))
- (rtl:make-cons-pointer type datum))
-
-(define-rule rewriting
- (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
- (QUALIFIER
- (and (rtl:object->type? type)
- (rtl:constant? (rtl:object->type-expression type))))
- (rtl:make-cons-pointer
- (rtl:make-machine-constant
- (object-type (rtl:constant-value (rtl:object->type-expression datum))))
- datum))
-
-(define-rule rewriting
- (CONS-POINTER (? type) (REGISTER (? datum register-known-value)))
- (QUALIFIER (and (rtl:object->datum? datum)
- (not (rtl:constant-non-pointer?
- (rtl:object->datum-expression datum)))))
- ;; Since we use DEP/DEPI, there is no need to clear the old bits
- (rtl:make-cons-pointer type (rtl:object->datum-expression datum)))
-
-(define-rule rewriting
- (OBJECT->TYPE (REGISTER (? source register-known-value)))
- (QUALIFIER (rtl:constant? source))
- (rtl:make-machine-constant (object-type (rtl:constant-value source))))
-
-(define-rule rewriting
- (OBJECT->DATUM (REGISTER (? source register-known-value)))
- (QUALIFIER (rtl:constant-non-pointer? source))
- (rtl:make-machine-constant (careful-object-datum (rtl:constant-value source))))
-
-(define (rtl:constant-non-pointer? expression)
- (and (rtl:constant? expression)
- (non-pointer-object? (rtl:constant-value expression))))
-\f
-;;; These rules are losers because there's no abstract way to cons a
-;;; statement or a predicate without also getting some CFG structure.
-
-(define-rule rewriting
- ;; Use register 0, always 0.
- (ASSIGN (? target) (REGISTER (? comparand register-known-value)))
- (QUALIFIER (rtl:immediate-zero-constant? comparand))
- (list 'ASSIGN target (rtl:make-machine-constant 0)))
-
-(define-rule rewriting
- ;; Compare to register 0, always 0.
- (EQ-TEST (? source) (REGISTER (? comparand register-known-value)))
- (QUALIFIER (rtl:immediate-zero-constant? comparand))
- (list 'EQ-TEST source (rtl:make-machine-constant 0)))
-
-(define-rule rewriting
- ;; Compare to register 0, always 0.
- (EQ-TEST (REGISTER (? comparand register-known-value)) (? source))
- (QUALIFIER (rtl:immediate-zero-constant? comparand))
- (list 'EQ-TEST source (rtl:make-machine-constant 0)))
-
-(define (rtl:immediate-zero-constant? expression)
- (cond ((rtl:constant? expression)
- (let ((value (rtl:constant-value expression)))
- (and (non-pointer-object? value)
- (zero? (object-type value))
- (zero? (careful-object-datum value)))))
- ((rtl:cons-pointer? expression)
- (and (let ((expression (rtl:cons-pointer-type expression)))
- (and (rtl:machine-constant? expression)
- (zero? (rtl:machine-constant-value expression))))
- (let ((expression (rtl:cons-pointer-datum expression)))
- (and (rtl:machine-constant? expression)
- (zero? (rtl:machine-constant-value expression))))))
- (else false)))
-\f
-;;;; Fixnums
-
-(define-rule rewriting
- (OBJECT->FIXNUM (REGISTER (? source register-known-value)))
- (QUALIFIER (rtl:constant-fixnum? source))
- (rtl:make-object->fixnum source))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS FIXNUM-LSH
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- #F)
- (QUALIFIER (and (rtl:register? operand-1)
- (rtl:constant-fixnum-test operand-2 (lambda (n) n true))))
- (rtl:make-fixnum-2-args 'FIXNUM-LSH operand-1 operand-2 #F))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (REGISTER (? operand-1 register-known-value))
- (? operand-2)
- #F)
- (QUALIFIER (and (rtl:register? operand-2)
- (rtl:constant-fixnum-test operand-1 spectrum-inline-multiply?)))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- #F)
- (QUALIFIER (and (rtl:register? operand-1)
- (rtl:constant-fixnum-test operand-2 spectrum-inline-multiply?)))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
-
-(define (spectrum-inline-multiply? n)
- #|
- (let ((absn (abs n)))
- (and (integer-log-base-2? absn)
- (<= absn 64)))
- |#
- n ; fnord
- true)
-
-(define-rule rewriting
- (FIXNUM-2-ARGS FIXNUM-QUOTIENT
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- #F)
- (QUALIFIER (and (rtl:register? operand-1)
- (rtl:constant-fixnum-test
- operand-2
- (lambda (n)
- (integer-log-base-2? (abs n))))))
- (rtl:make-fixnum-2-args 'FIXNUM-QUOTIENT operand-1 operand-2 #F))
-\f
-(define-rule rewriting
- (FIXNUM-2-ARGS FIXNUM-REMAINDER
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- #F)
- (QUALIFIER (and (rtl:register? operand-1)
- (rtl:constant-fixnum-test
- operand-2
- (lambda (n)
- (integer-log-base-2? (abs n))))))
- (rtl:make-fixnum-2-args 'FIXNUM-REMAINDER operand-1 operand-2 #F))
-
-;; These are used by vector-ref and friends with computed indices.
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (REGISTER (? operand-1 register-known-value))
- (REGISTER (? operand-2 register-known-value))
- #F)
- (QUALIFIER
- (and (rtl:object->fixnum-of-register? operand-1)
- (rtl:constant-fixnum-test
- operand-2
- (lambda (n)
- (integer-log-base-2? n)))))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (REGISTER (? operand-1 register-known-value))
- (REGISTER (? operand-2 register-known-value))
- #F)
- (QUALIFIER
- (and (rtl:constant-fixnum-test
- operand-1
- (lambda (n)
- (integer-log-base-2? n)))
- (rtl:object->fixnum-of-register? operand-2)))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
-
-(define (rtl:constant-fixnum? expression)
- (and (rtl:constant? expression)
- (fix:fixnum? (rtl:constant-value expression))))
-
-(define (rtl:constant-fixnum-test expression predicate)
- (and (rtl:object->fixnum? expression)
- (let ((expression (rtl:object->fixnum-expression expression)))
- (and (rtl:constant? expression)
- (let ((n (rtl:constant-value expression)))
- (and (fix:fixnum? n)
- (predicate n)))))))
-
-(define (rtl:object->fixnum-of-register? expression)
- (and (rtl:object->fixnum? expression)
- (rtl:register? (rtl:object->fixnum-expression expression))))
-\f
-;;;; Closures and othe optimizations.
-
-;; These rules are Spectrum specific
-
-(define-rule rewriting
- (CONS-POINTER (REGISTER (? type register-known-value))
- (REGISTER (? datum register-known-value)))
- (QUALIFIER (and (rtl:machine-constant? type)
- (= (rtl:machine-constant-value type)
- (ucode-type compiled-entry))
- (or (rtl:entry:continuation? datum)
- (rtl:entry:procedure? datum)
- (rtl:cons-closure? datum))))
- (rtl:make-cons-pointer type datum))
-
-#|
-;; Not yet written.
-
-;; A type is compatible when a depi instruction can put it in assuming that
-;; the datum has the quad bits set.
-;; A register is a machine-address-register if it is a machine register and
-;; always contains an address (ie. free pointer, stack pointer,
-;; or dlink register)
-
-(define-rule rewriting
- (CONS-POINTER (REGISTER (? type register-known-value))
- (REGISTER (? datum machine-address-register)))
- (QUALIFIER
- (and (rtl:machine-constant? type)
- (spectrum-type-optimizable? (rtl:machine-constant-value type))))
- (rtl:make-cons-pointer type datum))
-|#
-
-(define-rule rewriting
- (FLOAT-OFFSET (REGISTER (? base register-known-value))
- (MACHINE-CONSTANT 0))
- (QUALIFIER (rtl:simple-float-offset-address? base))
- (rtl:make-float-offset (rtl:float-offset-address-base base)
- (rtl:float-offset-address-offset base)))
-
-;; This is here to avoid generating things like
-;;
-;; (float-offset (offset-address (object->address (constant #(foo bar baz gack)))
-;; (machine-constant 1))
-;; (register 84))
-;;
-;; since the offset-address subexpression is constant, and therefore
-;; known!
-
-(define (rtl:simple-float-offset-address? expr)
- (and (rtl:float-offset-address? expr)
- (let ((offset (rtl:float-offset-address-offset expr)))
- (or (rtl:machine-constant? offset)
- (rtl:register? offset)
- (and (rtl:object->datum? offset)
- (rtl:register? (rtl:object->datum-expression offset)))))
- (let ((base (rtl:float-offset-address-base expr)))
- (or (rtl:register? base)
- (and (rtl:offset-address? base)
- (let ((base* (rtl:offset-address-base base))
- (offset* (rtl:offset-address-offset base)))
- (and (rtl:machine-constant? offset*)
- (or (rtl:register? base*)
- (and (rtl:object->address? base*)
- (rtl:register?
- (rtl:object->address-expression
- base*)))))))))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Assembler Machine Dependencies. DEC Vax version
-
-(declare (usual-integrations))
-\f
-(let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form))))))
-
-(define-integrable maximum-padding-length
- ;; Instructions can be any number of bytes long.
- ;; Thus the maximum padding is 3 bytes.
- 24)
-
-(define-integrable padding-string
- ;; Pad with HALT instructions
- (unsigned-integer->bit-string 8 #x00))
-
-(define-integrable block-offset-width
- ;; Block offsets are encoded words
- 16)
-
-(define maximum-block-offset
- (- (expt 2 (-1+ block-offset-width)) 1))
-
-(define-integrable (block-offset->bit-string offset start?)
- (unsigned-integer->bit-string block-offset-width
- (+ (* 2 offset)
- (if start? 0 1))))
-
-
-(define-integrable nmv-type-string
- (unsigned-integer->bit-string scheme-type-width
- (ucode-type manifest-nm-vector)))
-
-(define (make-nmv-header n)
- (bit-string-append (unsigned-integer->bit-string scheme-datum-width n)
- nmv-type-string))
-
-;;; Machine dependent instruction order
-
-(define (instruction-insert! bits block position receiver)
- (let ((l (bit-string-length bits)))
- (bit-substring-move-right! bits 0 l block position)
- (receiver (+ position l))))
-
-(define-integrable (instruction-initial-position block)
- block ; ignored
- 0)
-
-(define-integrable instruction-append bit-string-append)
-
-;;; end let-syntax
-)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$MC68020-Header: coerce.scm,v 1.10 88/08/31 05:56:37 GMT cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Vax Specific Coercions
-
-(declare (usual-integrations))
-\f
-(define coerce-literal
- (standard-coercion
- (lambda (n)
- (if (<= 0 n 63)
- n
- (error "Bad short literal" n)))))
-
-(define coerce-short-label
- (standard-coercion
- (lambda (offset)
- (or (if (negative? offset)
- (and (>= offset -128) (+ offset 256))
- (and (< offset 128) offset))
- (error "Short label out of range" offset)))))
-\f
-;; *** NOTE ***
-;; If you add coercions here, remember to also add them in "insmac.scm".
-
-(define make-coercion
- (coercion-maker
- `((UNSIGNED . ,coerce-unsigned-integer)
- (SIGNED . ,coerce-signed-integer))))
-
-(define coerce-2-bit-unsigned (make-coercion 'UNSIGNED 2))
-(define coerce-4-bit-unsigned (make-coercion 'UNSIGNED 4))
-(define coerce-6-bit-unsigned (make-coercion 'UNSIGNED 6))
-(define coerce-8-bit-unsigned (make-coercion 'UNSIGNED 8))
-(define coerce-16-bit-unsigned (make-coercion 'UNSIGNED 16))
-(define coerce-32-bit-unsigned (make-coercion 'UNSIGNED 32))
-
-(define coerce-8-bit-signed (make-coercion 'SIGNED 8))
-(define coerce-16-bit-signed (make-coercion 'SIGNED 16))
-(define coerce-32-bit-signed (make-coercion 'SIGNED 32))
-
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Script to incrementally compile the compiler (from .bins)
-
-(fluid-let ((compiler:coalescing-constant-warnings? #f))
- (for-each compile-directory
- '("back"
- "base"
- "fggen"
- "fgopt"
- "machines/vax"
- "rtlbase"
- "rtlgen"
- "rtlopt")))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Compiler Packaging
-\f
-(global-definitions "../runtime/runtime")
-(global-definitions "../sf/sf")
-
-(define-package (compiler)
- (files "base/switch"
- "base/object" ;tagged object support
- "base/enumer" ;enumerations
- "base/sets" ;set abstraction
- "base/mvalue" ;multiple-value support
- "base/scode" ;SCode abstraction
- "machines/vax/machin" ;machine dependent stuff
- "back/asutl" ;back-end odds and ends
- "base/utils" ;odds and ends
-
- "base/cfg1" ;control flow graph
- "base/cfg2"
- "base/cfg3"
-
- "base/ctypes" ;CFG datatypes
-
- "base/rvalue" ;Right hand values
- "base/lvalue" ;Left hand values
- "base/blocks" ;rvalue: blocks
- "base/proced" ;rvalue: procedures
- "base/contin" ;rvalue: continuations
-
- "base/subprb" ;subproblem datatype
-
- "rtlbase/rgraph" ;program graph abstraction
- "rtlbase/rtlty1" ;RTL: type definitions
- "rtlbase/rtlty2" ;RTL: type definitions
- "rtlbase/rtlexp" ;RTL: expression operations
- "rtlbase/rtlcon" ;RTL: complex constructors
- "rtlbase/rtlreg" ;RTL: registers
- "rtlbase/rtlcfg" ;RTL: CFG types
- "rtlbase/rtlobj" ;RTL: CFG objects
- "rtlbase/regset" ;RTL: register sets
- "rtlbase/valclass" ;RTL: value classes
-
- "back/insseq" ;LAP instruction sequences
- )
- (parent ())
- (export ()
- compiler:analyze-side-effects?
- compiler:cache-free-variables?
- compiler:coalescing-constant-warnings?
- compiler:code-compression?
- compiler:compile-by-procedures?
- compiler:cse?
- compiler:default-top-level-declarations
- compiler:enable-integration-declarations?
- compiler:generate-lap-files?
- compiler:generate-range-checks?
- compiler:generate-rtl-files?
- compiler:generate-stack-checks?
- compiler:generate-type-checks?
- compiler:implicit-self-static?
- compiler:intersperse-rtl-in-lap?
- compiler:noisy?
- compiler:open-code-flonum-checks?
- compiler:open-code-primitives?
- compiler:optimize-environments?
- compiler:package-optimization-level
- compiler:preserve-data-structures?
- compiler:show-phases?
- compiler:show-procedures?
- compiler:show-subphases?
- compiler:show-time-reports?
- compiler:use-multiclosures?)
- (import (runtime system-macros)
- ucode-primitive
- ucode-type)
- (import ()
- (scode/access-components access-components)
- (scode/access-environment access-environment)
- (scode/access-name access-name)
- (scode/access? access?)
- (scode/assignment-components assignment-components)
- (scode/assignment-name assignment-name)
- (scode/assignment-value assignment-value)
- (scode/assignment? assignment?)
- (scode/combination-components combination-components)
- (scode/combination-operands combination-operands)
- (scode/combination-operator combination-operator)
- (scode/combination? combination?)
- (scode/comment-components comment-components)
- (scode/comment-expression comment-expression)
- (scode/comment-text comment-text)
- (scode/comment? comment?)
- (scode/conditional-alternative conditional-alternative)
- (scode/conditional-components conditional-components)
- (scode/conditional-consequent conditional-consequent)
- (scode/conditional-predicate conditional-predicate)
- (scode/conditional? conditional?)
- (scode/constant? scode-constant?)
- (scode/declaration-components declaration-components)
- (scode/declaration-expression declaration-expression)
- (scode/declaration-text declaration-text)
- (scode/declaration? declaration?)
- (scode/definition-components definition-components)
- (scode/definition-name definition-name)
- (scode/definition-value definition-value)
- (scode/definition? definition?)
- (scode/delay-components delay-components)
- (scode/delay-expression delay-expression)
- (scode/delay? delay?)
- (scode/disjunction-alternative disjunction-alternative)
- (scode/disjunction-components disjunction-components)
- (scode/disjunction-predicate disjunction-predicate)
- (scode/disjunction? disjunction?)
- (scode/lambda-components lambda-components)
- (scode/lambda? lambda?)
- (scode/make-access make-access)
- (scode/make-assignment make-assignment)
- (scode/make-combination make-combination)
- (scode/make-comment make-comment)
- (scode/make-conditional make-conditional)
- (scode/make-declaration make-declaration)
- (scode/make-definition make-definition)
- (scode/make-delay make-delay)
- (scode/make-disjunction make-disjunction)
- (scode/make-lambda make-lambda)
- (scode/make-open-block make-open-block)
- (scode/make-quotation make-quotation)
- (scode/make-sequence make-sequence)
- (scode/make-the-environment make-the-environment)
- (scode/make-unassigned? make-unassigned?)
- (scode/make-variable make-variable)
- (scode/open-block-components open-block-components)
- (scode/open-block? open-block?)
- (scode/primitive-procedure? primitive-procedure?)
- (scode/procedure? procedure?)
- (scode/quotation-expression quotation-expression)
- (scode/quotation? quotation?)
- (scode/sequence-actions sequence-actions)
- (scode/sequence-components sequence-components)
- (scode/sequence-immediate-first sequence-immediate-first)
- (scode/sequence-immediate-second sequence-immediate-second)
- (scode/sequence-first sequence-first)
- (scode/sequence-second sequence-second)
- (scode/sequence? sequence?)
- (scode/symbol? symbol?)
- (scode/the-environment? the-environment?)
- (scode/unassigned?-name unassigned?-name)
- (scode/unassigned?? unassigned??)
- (scode/variable-components variable-components)
- (scode/variable-name variable-name)
- (scode/variable? variable?)))
-\f
-(define-package (compiler reference-contexts)
- (files "base/refctx")
- (parent (compiler))
- (export (compiler)
- add-reference-context/adjacent-parents!
- initialize-reference-contexts!
- make-reference-context
- modify-reference-contexts!
- reference-context/adjacent-parent?
- reference-context/block
- reference-context/offset
- reference-context/procedure
- reference-context?
- set-reference-context/offset!))
-
-(define-package (compiler macros)
- (files "base/macros")
- (parent ())
- (import (runtime macros)
- parse-define-syntax)
- (initialization (initialize-package!)))
-
-(define-package (compiler declarations)
- (files "machines/vax/decls")
- (parent (compiler))
- (export (compiler)
- sc
- syntax-files!)
- (import (scode-optimizer top-level)
- sf/internal)
- (initialization (initialize-package!)))
-
-(define-package (compiler top-level)
- (files "base/toplev"
- "base/crstop"
- "base/asstop")
- (parent (compiler))
- (export ()
- cbf
- cf
- compile-directory
- compile-bin-file
- compile-procedure
- compile-scode
- compiler:reset!
- cross-compile-bin-file
- cross-compile-bin-file-end)
- (export (compiler)
- canonicalize-label-name)
- (export (compiler fg-generator)
- compile-recursively)
- (export (compiler rtl-generator)
- *ic-procedure-headers*
- *rtl-continuations*
- *rtl-expression*
- *rtl-graphs*
- *rtl-procedures*)
- (export (compiler lap-syntaxer)
- *block-label*
- *external-labels*
- label->object)
- (export (compiler debug)
- *root-expression*
- *rtl-procedures*
- *rtl-graphs*)
- (import (runtime compiler-info)
- make-dbg-info-vector
- split-inf-structure!)
- (import (runtime unparser)
- param:unparse-uninterned-symbols-by-name?)
- (import (scode-optimizer build-utilities)
- directory-processor))
-\f
-(define-package (compiler debug)
- (files "base/debug")
- (parent (compiler))
- (export ()
- debug/find-continuation
- debug/find-entry-node
- debug/find-procedure
- debug/where
- dump-rtl
- po
- show-bblock-rtl
- show-fg
- show-fg-node
- show-rtl
- write-rtl-instructions)
- (import (runtime unparser)
- param:unparse-uninterned-symbols-by-name?))
-
-(define-package (compiler pattern-matcher/lookup)
- (files "base/pmlook")
- (parent (compiler))
- (export (compiler)
- make-pattern-variable
- pattern-lookup
- pattern-variable-name
- pattern-variable?
- pattern-variables))
-
-(define-package (compiler pattern-matcher/parser)
- (files "base/pmpars")
- (parent (compiler))
- (export (compiler)
- parse-rule
- rule-result-expression)
- (export (compiler macros)
- parse-rule
- rule-result-expression))
-
-(define-package (compiler pattern-matcher/early)
- (files "base/pmerly")
- (parent (compiler))
- (export (compiler)
- early-parse-rule
- early-pattern-lookup
- early-make-rule
- make-database-transformer
- make-symbol-transformer
- make-bit-mask-transformer))
-\f
-(define-package (compiler debugging-information)
- (files "base/infnew")
- (parent (compiler))
- (export (compiler top-level)
- info-generation-phase-1
- info-generation-phase-2
- info-generation-phase-3)
- (export (compiler rtl-generator)
- generated-dbg-continuation)
- (import (runtime compiler-info)
- make-dbg-info
-
- make-dbg-expression
- dbg-expression/block
- dbg-expression/label
- set-dbg-expression/label!
-
- make-dbg-procedure
- dbg-procedure/block
- dbg-procedure/label
- set-dbg-procedure/label!
- dbg-procedure/name
- dbg-procedure/required
- dbg-procedure/optional
- dbg-procedure/rest
- dbg-procedure/auxiliary
- dbg-procedure/external-label
- set-dbg-procedure/external-label!
- dbg-procedure<?
-
- make-dbg-continuation
- dbg-continuation/block
- dbg-continuation/label
- set-dbg-continuation/label!
- dbg-continuation<?
-
- make-dbg-block
- dbg-block/parent
- dbg-block/layout
- dbg-block/stack-link
- set-dbg-block/procedure!
-
- make-dbg-variable
- dbg-variable/value
- set-dbg-variable/value!
-
- dbg-block-name/dynamic-link
- dbg-block-name/ic-parent
- dbg-block-name/normal-closure
- dbg-block-name/return-address
- dbg-block-name/static-link
-
- make-dbg-label-2
- dbg-label/offset
- set-dbg-label/external?!))
-
-(define-package (compiler constraints)
- (files "base/constr")
- (parent (compiler))
- (export (compiler)
- make-constraint
- constraint/element
- constraint/graph-head
- constraint/afters
- constraint/closed?
- constraint-add!
- add-constraint-element!
- add-constraint-set!
- make-constraint-graph
- constraint-graph/entry-nodes
- constraint-graph/closed?
- close-constraint-graph!
- close-constraint-node!
- order-per-constraints
- order-per-constraints/extracted
- legal-ordering-per-constraints?
- with-new-constraint-marks
- constraint-marked?
- constraint-mark!
- transitively-close-dag!
- reverse-postorder))
-\f
-(define-package (compiler fg-generator)
- (files "fggen/canon" ;SCode canonicalizer
- "fggen/fggen" ;SCode->flow-graph converter
- "fggen/declar" ;Declaration handling
- )
- (parent (compiler))
- (export (compiler top-level)
- canonicalize/top-level
- construct-graph)
- (import (runtime scode-data)
- &pair-car
- &pair-cdr
- &triple-first
- &triple-second
- &triple-third))
-
-(define-package (compiler fg-optimizer)
- (files "fgopt/outer" ;outer analysis
- "fgopt/sideff" ;side effect analysis
- )
- (parent (compiler))
- (export (compiler top-level)
- clear-call-graph!
- compute-call-graph!
- outer-analysis
- side-effect-analysis))
-
-(define-package (compiler fg-optimizer fold-constants)
- (files "fgopt/folcon")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) fold-constants))
-
-(define-package (compiler fg-optimizer operator-analysis)
- (files "fgopt/operan")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) operator-analysis))
-
-(define-package (compiler fg-optimizer variable-indirection)
- (files "fgopt/varind")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) initialize-variable-indirections!))
-
-(define-package (compiler fg-optimizer environment-optimization)
- (files "fgopt/envopt")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) optimize-environments!))
-
-(define-package (compiler fg-optimizer closure-analysis)
- (files "fgopt/closan")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) identify-closure-limits!))
-
-(define-package (compiler fg-optimizer continuation-analysis)
- (files "fgopt/contan")
- (parent (compiler fg-optimizer))
- (export (compiler top-level)
- continuation-analysis
- setup-block-static-links!))
-
-(define-package (compiler fg-optimizer compute-node-offsets)
- (files "fgopt/offset")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) compute-node-offsets))
-\f
-(define-package (compiler fg-optimizer connectivity-analysis)
- (files "fgopt/conect")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) connectivity-analysis))
-
-(define-package (compiler fg-optimizer delete-integrated-parameters)
- (files "fgopt/delint")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) delete-integrated-parameters))
-
-(define-package (compiler fg-optimizer design-environment-frames)
- (files "fgopt/desenv")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) design-environment-frames!))
-
-(define-package (compiler fg-optimizer setup-block-types)
- (files "fgopt/blktyp")
- (parent (compiler fg-optimizer))
- (export (compiler top-level)
- setup-block-types!
- setup-closure-contexts!)
- (export (compiler)
- indirection-block-procedure))
-
-(define-package (compiler fg-optimizer simplicity-analysis)
- (files "fgopt/simple")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) simplicity-analysis)
- (export (compiler fg-optimizer subproblem-ordering)
- new-subproblem/compute-simplicity!))
-
-(define-package (compiler fg-optimizer simulate-application)
- (files "fgopt/simapp")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) simulate-application))
-
-(define-package (compiler fg-optimizer subproblem-free-variables)
- (files "fgopt/subfre")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) compute-subproblem-free-variables)
- (export (compiler fg-optimizer) map-union)
- (export (compiler fg-optimizer subproblem-ordering)
- new-subproblem/compute-free-variables!))
-
-(define-package (compiler fg-optimizer subproblem-ordering)
- (files "fgopt/order")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) subproblem-ordering))
-
-(define-package (compiler fg-optimizer subproblem-ordering reuse-frames)
- (files "fgopt/reord" "fgopt/reuse")
- (parent (compiler fg-optimizer subproblem-ordering))
- (export (compiler top-level) setup-frame-adjustments)
- (export (compiler fg-optimizer subproblem-ordering)
- order-subproblems/maybe-overwrite-block))
-
-(define-package (compiler fg-optimizer subproblem-ordering parameter-analysis)
- (files "fgopt/param")
- (parent (compiler fg-optimizer subproblem-ordering))
- (export (compiler fg-optimizer subproblem-ordering)
- parameter-analysis))
-
-(define-package (compiler fg-optimizer return-equivalencing)
- (files "fgopt/reteqv")
- (parent (compiler fg-optimizer))
- (export (compiler top-level) find-equivalent-returns!))
-\f
-(define-package (compiler rtl-generator)
- (files "rtlgen/rtlgen" ;RTL generator
- "rtlgen/rgstmt" ;statements
- "rtlgen/fndvar" ;find variables
- "machines/vax/rgspcm" ;special close-coded primitives
- "rtlbase/rtline" ;linearizer
- )
- (parent (compiler))
- (export (compiler)
- make-linearizer)
- (export (compiler top-level)
- generate/top-level
- linearize-rtl
- setup-bblock-continuations!)
- (export (compiler debug)
- linearize-rtl)
- (import (compiler top-level)
- label->object))
-
-(define-package (compiler rtl-generator generate/procedure-header)
- (files "rtlgen/rgproc")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator) generate/procedure-header))
-
-(define-package (compiler rtl-generator combination/inline)
- (files "rtlgen/opncod")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator) combination/inline)
- (export (compiler top-level) open-coding-analysis))
-
-(define-package (compiler rtl-generator find-block)
- (files "rtlgen/fndblk")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator) find-block))
-
-(define-package (compiler rtl-generator generate/rvalue)
- (files "rtlgen/rgrval")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator)
- generate/rvalue
- load-closure-environment
- make-cons-closure-indirection
- make-cons-closure-redirection
- make-closure-redirection
- make-ic-cons
- make-non-trivial-closure-cons
- make-trivial-closure-cons
- redirect-closure))
-
-(define-package (compiler rtl-generator generate/combination)
- (files "rtlgen/rgcomb")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator)
- generate/combination)
- (export (compiler rtl-generator combination/inline)
- generate/invocation-prefix))
-
-(define-package (compiler rtl-generator generate/return)
- (files "rtlgen/rgretn")
- (parent (compiler rtl-generator))
- (export (compiler rtl-generator)
- make-return-operand
- generate/return
- generate/return*
- generate/trivial-return))
-\f
-(define-package (compiler rtl-cse)
- (files "rtlopt/rcse1" ;RTL common subexpression eliminator
- "rtlopt/rcse2"
- "rtlopt/rcseep" ;CSE expression predicates
- "rtlopt/rcseht" ;CSE hash table
- "rtlopt/rcserq" ;CSE register/quantity abstractions
- "rtlopt/rcsesr" ;CSE stack references
- )
- (parent (compiler))
- (export (compiler top-level) common-subexpression-elimination))
-
-(define-package (compiler rtl-optimizer)
- (files "rtlopt/rdebug")
- (parent (compiler)))
-
-(define-package (compiler rtl-optimizer invertible-expression-elimination)
- (files "rtlopt/rinvex")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) invertible-expression-elimination))
-
-(define-package (compiler rtl-optimizer common-suffix-merging)
- (files "rtlopt/rtlcsm")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) merge-common-suffixes!))
-
-(define-package (compiler rtl-optimizer rtl-dataflow-analysis)
- (files "rtlopt/rdflow")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) rtl-dataflow-analysis))
-
-(define-package (compiler rtl-optimizer rtl-rewriting)
- (files "rtlopt/rerite")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level)
- rtl-rewriting:post-cse
- rtl-rewriting:pre-cse)
- (export (compiler lap-syntaxer) add-rewriting-rule!))
-
-(define-package (compiler rtl-optimizer lifetime-analysis)
- (files "rtlopt/rlife")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) lifetime-analysis)
- (export (compiler rtl-optimizer code-compression) mark-set-registers!))
-
-(define-package (compiler rtl-optimizer code-compression)
- (files "rtlopt/rcompr")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) code-compression))
-
-(define-package (compiler rtl-optimizer register-allocation)
- (files "rtlopt/ralloc")
- (parent (compiler rtl-optimizer))
- (export (compiler top-level) register-allocation))
-\f
-(define-package (compiler lap-syntaxer)
- (files "back/lapgn1" ;LAP generator
- "back/lapgn2" ; " "
- "back/lapgn3" ; " "
- "back/regmap" ;Hardware register allocator
- "machines/vax/lapgen" ;code generation rules
- "machines/vax/rules1" ; " " "
- "machines/vax/rules2" ; " " "
- "machines/vax/rules3" ; " " "
- "machines/vax/rules4" ; " " "
- "machines/vax/rulfix" ;code generation rules: fixnums
- "machines/vax/rulrew" ;code rewriting rules
- "back/syntax" ;Generic syntax phase
- "back/syerly" ;Early binding version
- "machines/vax/coerce" ;Coercions: integer -> bit string
- "back/asmmac" ;Macros for hairy syntax
- "machines/vax/insmac" ;Macros for hairy syntax
- "machines/vax/insutl" ;Utilities for instructions
- "machines/vax/instr1" ;Vax Instructions
- "machines/vax/instr2" ; " "
- "machines/vax/instr3" ; " "
- )
- (parent (compiler))
- (export (compiler)
- available-machine-registers
- lap-generator/match-rtl-instruction
- lap:make-entry-point
- lap:make-label-statement
- lap:make-unconditional-branch
- lap:syntax-instruction)
- (export (compiler top-level)
- *block-associations*
- *interned-assignments*
- *interned-constants*
- *interned-global-links*
- *interned-static-variables*
- *interned-uuo-links*
- *interned-variables*
- *next-constant*
- generate-lap)
- (import (scode-optimizer expansion)
- scode->scode-expander))
-
-(define-package (compiler lap-syntaxer map-merger)
- (files "back/mermap")
- (parent (compiler lap-syntaxer))
- (export (compiler lap-syntaxer)
- merge-register-maps))
-
-(define-package (compiler lap-syntaxer linearizer)
- (files "back/linear")
- (parent (compiler lap-syntaxer))
- (export (compiler lap-syntaxer)
- add-end-of-block-code!
- add-extra-code!
- bblock-linearize-lap
- extra-code-block/xtra
- declare-extra-code-block!
- find-extra-code-block
- linearize-lap
- set-current-branches!
- set-extra-code-block/xtra!)
- (export (compiler top-level)
- *end-of-block-code*
- linearize-lap))
-\f
-(define-package (compiler lap-optimizer)
- (files "machines/vax/lapopt")
- (parent (compiler))
- (export (compiler top-level)
- optimize-linear-lap))
-
-(define-package (compiler assembler)
- (files "machines/vax/assmd" ;Machine dependent
- "back/symtab" ;Symbol tables
- "back/bitutl" ;Assembly blocks
- "back/bittop" ;Assembler top level
- )
- (parent (compiler))
- (export (compiler)
- instruction-append)
- (export (compiler top-level)
- assemble))
-
-(define-package (compiler disassembler)
- (files "machines/vax/dassm1"
- "machines/vax/dassm2"
- "machines/vax/dassm3"
- "machines/vax/dinstr1"
- "machines/vax/dinstr2"
- "machines/vax/dinstr3"
- )
- (parent (compiler))
- (export ()
- compiler:write-lap-file
- compiler:disassemble)
- (import (runtime compiler-info)
- compiled-code-block/dbg-info
- dbg-info-vector/blocks-vector
- dbg-info-vector?
- dbg-info/labels
- dbg-label/external?
- dbg-label/name
- dbg-labels/find-offset))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Script to incrementally syntax the compiler
-\f
-(load-option 'CREF)
-
-;; Guarantee that the compiler's package structure exists.
-(if (not (name->package '(COMPILER)))
- (let ((package-set (package-set-pathname "compiler")))
- (if (not (file-exists? package-set))
- (cref/generate-trivial-constructor "compiler"))
- (construct-packages-from-file (fasload package-set))))
-
-;; Guarantee that the necessary syntactic transforms and optimizers
-;; are loaded.
-(if (lexical-unreferenceable? (->environment '(COMPILER)) 'SYNTAX-FILES!)
- (let ((sf-and-load
- (lambda (files package)
- (sf-conditionally files)
- (for-each (lambda (file)
- (load (string-append file ".bin") package))
- files))))
- (load-option 'HASH-TABLE)
- (fresh-line)
- (newline)
- (write-string "---- Loading compile-time files ----")
- (newline)
- (sf-and-load '("base/switch") '(COMPILER))
- (sf-and-load '("base/macros") '(COMPILER MACROS))
- ((access initialize-package! (->environment '(COMPILER MACROS))))
- (sf-and-load '("machines/vax/decls") '(COMPILER DECLARATIONS))
- (let ((environment (->environment '(COMPILER DECLARATIONS))))
- (set! (access source-file-expression environment) "*.scm")
- ((access initialize-package! environment)))
- (sf-and-load '("base/pmlook") '(COMPILER PATTERN-MATCHER/LOOKUP))
- (sf-and-load '("base/pmpars") '(COMPILER PATTERN-MATCHER/PARSER))
- (fluid-let ((sf/default-syntax-table (->environment '(COMPILER))))
- (sf-and-load '("machines/vax/machin") '(COMPILER)))
- (fluid-let ((sf/default-declarations
- '((integrate-external "insseq")
- (integrate-external "machin")
- (usual-definition (set expt)))))
- (sf-and-load '("machines/vax/assmd") '(COMPILER ASSEMBLER)))
- (sf-and-load '("back/syntax") '(COMPILER LAP-SYNTAXER))
- (sf-and-load '("machines/vax/coerce"
- "back/asmmac"
- "machines/vax/insmac")
- '(COMPILER LAP-SYNTAXER))
- (sf-and-load '("base/scode") '(COMPILER))
- (sf-and-load '("base/pmerly") '(COMPILER PATTERN-MATCHER/EARLY))
- (sf-and-load '("back/syerly") '(COMPILER LAP-SYNTAXER))
- (sf-and-load '("machines/vax/dsyn") '(COMPILER DISASSEMBLER MACROS))
- ((access initialize-package!
- (->environment '(COMPILER DISASSEMBLER MACROS))))))
-
-;; Resyntax any files that need it.
-((access syntax-files! (->environment '(COMPILER))))
-
-;; Rebuild the package constructors and cref.
-(cref/generate-constructors "compiler")
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; VAX Disassembler: User level
-;;; package: (compiler disassembler)
-
-(declare (usual-integrations))
-\f
-;;; Flags that control disassembler behavior
-
-(define disassembler/symbolize-output? true)
-(define disassembler/compiled-code-heuristics? true)
-(define disassembler/write-offsets? true)
-(define disassembler/write-addresses? false)
-
-;;;; Top level entries
-
-(define (compiler:write-lap-file filename #!optional symbol-table?)
- (let ((pathname (->pathname filename))
- (symbol-table?
- (if (default-object? symbol-table?) true symbol-table?)))
- (with-output-to-file (pathname-new-type pathname "lap")
- (lambda ()
- (let ((com-file (pathname-new-type pathname "com")))
- (let ((object (fasload com-file)))
- (if (compiled-code-address? object)
- (let ((block (compiled-code-address->block object)))
- (disassembler/write-compiled-code-block
- block
- (compiled-code-block/dbg-info block symbol-table?)))
- (begin
- (if (not
- (and (scode/comment? object)
- (dbg-info-vector? (scode/comment-text object))))
- (error "Not a compiled file" com-file))
- (let ((blocks
- (vector->list
- (dbg-info-vector/blocks-vector
- (scode/comment-text object)))))
- (if (not (null? blocks))
- (do ((blocks blocks (cdr blocks)))
- ((null? blocks) unspecific)
- (disassembler/write-compiled-code-block
- (car blocks)
- (compiled-code-block/dbg-info (car blocks)
- symbol-table?))
- (if (not (null? (cdr blocks)))
- (write-char #\page)))))))))))))
-
-(define disassembler/base-address)
-
-(define (compiler:disassemble entry)
- (let ((block (compiled-entry/block entry)))
- (let ((info (compiled-code-block/dbg-info block true)))
- (fluid-let ((disassembler/write-offsets? true)
- (disassembler/write-addresses? true)
- (disassembler/base-address (object-datum block)))
- (newline)
- (newline)
- (disassembler/write-compiled-code-block block info)))))
-\f
-(define (disassembler/write-compiled-code-block block info)
- (let ((symbol-table (and info (dbg-info/labels info))))
- (write-string "Disassembly of ")
- (write block)
- (write-string ":\n")
- (write-string "Code:\n\n")
- (disassembler/write-instruction-stream
- symbol-table
- (disassembler/instructions/compiled-code-block block symbol-table))
- (write-string "\nConstants:\n\n")
- (disassembler/write-constants-block block symbol-table)
- (newline)))
-
-(define (disassembler/instructions/compiled-code-block block symbol-table)
- (disassembler/instructions block
- (compiled-code-block/code-start block)
- (compiled-code-block/code-end block)
- symbol-table))
-
-(define (disassembler/instructions/address start-address end-address)
- (disassembler/instructions false start-address end-address false))
-
-(define (disassembler/write-instruction-stream symbol-table instruction-stream)
- (parameterize* (list (cons param:unparser-radix 16))
- (lambda ()
- (disassembler/for-each-instruction instruction-stream
- (lambda (offset instruction)
- (disassembler/write-instruction symbol-table
- offset
- (lambda () (display instruction))))))))
-
-(define (disassembler/for-each-instruction instruction-stream procedure)
- (let loop ((instruction-stream instruction-stream))
- (if (not (disassembler/instructions/null? instruction-stream))
- (disassembler/instructions/read instruction-stream
- (lambda (offset instruction instruction-stream)
- (procedure offset instruction)
- (loop (instruction-stream)))))))
-\f
-(define (disassembler/write-constants-block block symbol-table)
- (parameterize* (list (cons param:unparser-radix 16))
- (lambda ()
- (let ((end (system-vector-length block)))
- (let loop ((index (compiled-code-block/constants-start block)))
- (cond ((not (< index end)) 'DONE)
- ((object-type?
- (let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form))))))
- (ucode-type linkage-section))
- (system-vector-ref block index))
- (loop (disassembler/write-linkage-section block
- symbol-table
- index)))
- (else
- (disassembler/write-instruction
- symbol-table
- (compiled-code-block/index->offset index)
- (lambda ()
- (write-constant block
- symbol-table
- (system-vector-ref block index))))
- (loop (1+ index)))))))))
-
-(define (write-constant block symbol-table constant)
- (write-string (cdr (write-to-string constant 60)))
- (cond ((lambda? constant)
- (let ((expression (lambda-body constant)))
- (if (and (compiled-code-address? expression)
- (eq? (compiled-code-address->block expression) block))
- (begin
- (write-string " (")
- (let ((offset (compiled-code-address->offset expression)))
- (let ((label
- (disassembler/lookup-symbol symbol-table offset)))
- (if label
- (write-string label)
- (write offset))))
- (write-string ")")))))
- ((compiled-code-address? constant)
- (write-string " (offset ")
- (write (compiled-code-address->offset constant))
- (write-string " in ")
- (write (compiled-code-address->block constant))
- (write-string ")"))
- (else false)))
-\f
-(define (disassembler/write-linkage-section block symbol-table index)
- (let* ((field (object-datum (system-vector-ref block index)))
- (descriptor (integer-divide field #x10000)))
- (let ((kind (integer-divide-quotient descriptor))
- (length (integer-divide-remainder descriptor)))
-
- (define (write-caches offset size writer)
- (let loop ((index (1+ (+ offset index)))
- (how-many (quotient (- length offset) size)))
- (if (zero? how-many)
- 'DONE
- (begin
- (disassembler/write-instruction
- symbol-table
- (compiled-code-block/index->offset index)
- (lambda ()
- (writer block index)))
- (loop (+ size index) (-1+ how-many))))))
-
- (disassembler/write-instruction
- symbol-table
- (compiled-code-block/index->offset index)
- (lambda ()
- (write-string "#[LINKAGE-SECTION ")
- (write field)
- (write-string "]")))
- (case kind
- ((0 3)
- (write-caches
- compiled-code-block/procedure-cache-offset
- compiled-code-block/objects-per-procedure-cache
- disassembler/write-procedure-cache))
- ((1)
- (write-caches
- 0
- compiled-code-block/objects-per-variable-cache
- (lambda (block index)
- (disassembler/write-variable-cache "Reference" block index))))
- ((2)
- (write-caches
- 0
- compiled-code-block/objects-per-variable-cache
- (lambda (block index)
- (disassembler/write-variable-cache "Assignment" block index))))
- (else
- (error "disassembler/write-linkage-section: Unknown section kind"
- kind)))
- (1+ (+ index length)))))
-\f
-(define-integrable (variable-cache-name cache)
- ((ucode-primitive primitive-object-ref 2) cache 1))
-
-(define (disassembler/write-variable-cache kind block index)
- (write-string kind)
- (write-string " cache to ")
- (write (variable-cache-name (disassembler/read-variable-cache block index))))
-
-(define (disassembler/write-procedure-cache block index)
- (let ((result (disassembler/read-procedure-cache block index)))
- (write (vector-ref result 2))
- (write-string " argument procedure cache to ")
- (case (vector-ref result 0)
- ((COMPILED INTERPRETED)
- (write (vector-ref result 1)))
- ((VARIABLE)
- (write-string "variable ")
- (write (vector-ref result 1)))
- (else
- (error "disassembler/write-procedure-cache: Unknown cache kind"
- (vector-ref result 0))))))
-
-(define (disassembler/write-instruction symbol-table offset write-instruction)
- (if symbol-table
- (let ((label (dbg-labels/find-offset symbol-table offset)))
- (if label
- (begin
- (write-char #\Tab)
- (write-string (dbg-label/name label))
- (write-char #\:)
- (newline)))))
-
- (if disassembler/write-addresses?
- (begin
- (write-string
- (number->string (+ offset disassembler/base-address) 16))
- (write-char #\Tab)))
-
- (if disassembler/write-offsets?
- (begin
- (write-string (number->string offset 16))
- (write-char #\Tab)))
-
- (if symbol-table
- (write-string " "))
- (write-instruction)
- (newline))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; VAX Disassembler: Top Level
-;;; package: (compiler disassembler)
-
-(declare (usual-integrations))
-\f
-(define (disassembler/read-variable-cache block index)
- (let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form)))))
- (ucode-primitive
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply make-primitive-procedure (cdr form))))))
- ((ucode-primitive primitive-object-set-type 2)
- (ucode-type quad)
- (system-vector-ref block index))))
-
-(define (disassembler/read-procedure-cache block index)
- (fluid-let ((*block block))
- (let* ((offset (compiled-code-block/index->offset index))
- (opcode (read-unsigned-integer (+ offset 2) 16)))
- (case opcode
- ((#x9f17) ; JMP @&<value>
- ;; This should learn to decode trampolines.
- (vector 'COMPILED
- (read-procedure (+ offset 4))
- (read-unsigned-integer offset 16)))
- (else
- (error "disassembler/read-procedure-cache: Unknown opcode"
- opcode block index))))))
-\f
-(define (disassembler/instructions block start-offset end-offset symbol-table)
- (let loop ((offset start-offset) (state (disassembler/initial-state)))
- (if (and end-offset (< offset end-offset))
- (disassemble-one-instruction
- block offset symbol-table state
- (lambda (offset* instruction state)
- (make-instruction offset
- instruction
- (lambda () (loop offset* state)))))
- '())))
-
-(define (disassembler/instructions/null? obj)
- (null? obj))
-
-(define (disassembler/instructions/read instruction-stream receiver)
- (receiver (instruction-offset instruction-stream)
- (instruction-instruction instruction-stream)
- (instruction-next instruction-stream)))
-
-(define-structure (instruction (type vector))
- (offset false read-only true)
- (instruction false read-only true)
- (next false read-only true))
-
-(define *block)
-(define *current-offset)
-(define *symbol-table)
-(define *valid?)
-
-(define (disassemble-one-instruction block offset symbol-table state receiver)
- (define (instruction-end instruction state)
- (let ((next-state (disassembler/next-state instruction state)))
- (receiver *current-offset instruction next-state)))
-
- (fluid-let ((*block block)
- (*current-offset offset)
- (*symbol-table symbol-table)
- (*valid? true))
- (let* ((byte (get-byte))
- (start-offset *current-offset))
- ;; External label markers come in two parts:
- ;; An entry type descriptor, and a gc offset.
- (if (or (eq? state 'EXTERNAL-LABEL)
- (eq? state 'EXTERNAL-LABEL-OFFSET)
- (external-label-marker? symbol-table offset state))
- (instruction-end (make-data-deposit byte 'W)
- (if (eq? state 'EXTERNAL-LABEL-OFFSET)
- state
- 'EXTERNAL-LABEL))
- (let ((instruction
- ((vector-ref
- opcode-dispatch
- (bit-string->unsigned-integer byte)))))
- (if *valid?
- (instruction-end instruction state)
- (begin
- (set! *current-offset start-offset)
- (instruction-end
- (make-data-deposit
- byte
- (if disassembler/compiled-code-heuristics?
- 'W
- 'B))
- 'UNKNOWN))))))))
-\f
-(define (disassembler/initial-state)
- 'INSTRUCTION)
-
-(define (disassembler/next-state instruction state)
- (define (check delta state get-word)
- (let ((offset *current-offset))
- (let* ((next (bit-string->unsigned-integer (get-word)))
- (result
- (if (= (+ offset delta) (/ next 2))
- state
- 'INSTRUCTION)))
- (set! *current-offset offset)
- result)))
-
- (cond ((or (not disassembler/compiled-code-heuristics?)
- (eq? state 'EXTERNAL-LABEL-OFFSET))
- 'INSTRUCTION)
- ((and (eq? state 'INSTRUCTION)
- (or (memq (car instruction) '(BR JMP RSB))
- (and (eq? (car instruction) 'JSB)
- (let ((entry
- (interpreter-register?
- (cadr instruction))))
- (and entry
- (eq? (car entry) 'ENTRY))))))
- (check 4 'EXTERNAL-LABEL (lambda () (get-word) (get-word))))
- ((eq? state 'EXTERNAL-LABEL)
- 'EXTERNAL-LABEL-OFFSET)
- ((eq? state 'UNKNOWN)
- (check 2 'EXTERNAL-LABEL-OFFSET get-word))
- (else
- 'INSTRUCTION)))
-
-(define (disassembler/lookup-symbol symbol-table offset)
- (and symbol-table
- (let ((label (dbg-labels/find-offset symbol-table offset)))
- (and label
- (dbg-label/name label)))))
-
-(define (external-label-marker? symbol-table offset state)
- (if symbol-table
- (let ((label (dbg-labels/find-offset symbol-table (+ offset 4))))
- (and label
- (dbg-label/external? label)))
- (and *block
- (not (eq? state 'INSTRUCTION))
- (let loop ((offset (+ offset 4)))
- (let ((contents (read-bits (- offset 2) 16)))
- (if (bit-string-clear! contents 0)
- (let ((offset
- (- offset
- (/ (bit-string->unsigned-integer contents) 2))))
- (and (positive? offset)
- (loop offset)))
- (= offset
- (/ (bit-string->unsigned-integer contents) 2))))))))
-\f
-(define (make-data-deposit *ir size)
- (case size
- ((B)
- `(BYTE U ,(bit-string->unsigned-integer *ir)))
- ((W)
- `(WORD U ,(bit-string->unsigned-integer
- (bit-string-append *ir (get-byte)))))
- ((L)
- `(LONG U ,(bit-string->unsigned-integer
- (bit-string-append (bit-string-append *ir (get-byte))
- (get-word)))))))
-
-(define (read-procedure offset)
- (with-absolutely-no-interrupts
- (lambda ()
- (let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form)))))
- (ucode-primitive
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply make-primitive-procedure (cdr form))))))
- ((ucode-primitive primitive-object-set-type 2)
- (ucode-type compiled-entry)
- ((ucode-primitive make-non-pointer-object 1)
- (read-unsigned-integer offset 32)))))))
-
-(define (read-unsigned-integer offset size)
- (bit-string->unsigned-integer (read-bits offset size)))
-
-(define (read-bits offset size-in-bits)
- (let ((word (bit-string-allocate size-in-bits))
- (bit-offset (* offset addressing-granularity)))
- (with-absolutely-no-interrupts
- (lambda ()
- (if *block
- (read-bits! *block bit-offset word)
- (read-bits! offset 0 word))))
- word))
-\f
-;;;; Compiler specific information
-
-(define-integrable (lookup-special-register reg table)
- (assq reg table))
-
-(define-integrable (special-register reg-pair)
- (cdr reg-pair))
-
-(define (make-register register)
- (let ((special (and disassembler/symbolize-output?
- (assq register register-assignments))))
- (if special
- (cdr special)
- register)))
-
-(define register-assignments
- '((0 . 0) ;serves multiple functions, not handled now
- (1 . 1)
- (2 . 2)
- (3 . 3)
- (4 . 4)
- (5 . 5)
- (6 . 6)
- (7 . 7)
- (8 . 8)
- (9 . 9)
- (10 . DYNAMIC-LINK)
- (11 . REFERENCE-MASK)
- (12 . FREE-POINTER)
- (13 . REGS-POINTER)
- (14 . STACK-POINTER)
- (15 . PROGRAM-COUNTER)))
-\f
-(define (make-offset deferred? register size offset)
- (let ((key (if deferred? '@@RO '@RO)))
- (if (not disassembler/symbolize-output?)
- `(,key ,size ,register ,offset)
- (let ((special
- (lookup-special-register register register-assignments)))
- (if special
- (if (eq? (special-register special) 'REGS-POINTER)
- (let ((interpreter-register
- (lookup-special-register offset
- interpreter-register-assignments)))
- (cond ((not interpreter-register)
- `(,key ,size REGS-POINTER ,offset))
- ((not deferred?)
- (special-register interpreter-register))
- (else
- `(@ ,(special-register interpreter-register)))))
- `(,key ,size ,(special-register special) ,offset))
- `(,key ,size ,register ,offset))))))
-
-(define interpreter-register?
- (lambda (effective-address)
- (case (car effective-address)
- ((@RO)
- (and (eq? (caddr effective-address) 'REGS-POINTER)
- (let ((entry
- (assq (cadddr effective-address)
- interpreter-register-assignments)))
- (and entry
- (cdr entry)))))
- ((REGISTER TEMPORARY ENTRY) effective-address)
- (else false))))
-\f
-(define interpreter-register-assignments
- (let ()
- (define (make-entries index names)
- (if (null? names)
- '()
- (cons `(,index . (ENTRY ,(car names)))
- (make-entries (+ index 6) (cdr names)))))
- `(;; Interpreter registers
- (0 . (REGISTER MEMORY-TOP))
- (4 . (REGISTER INT-MASK))
- (8 . (REGISTER VALUE))
- (12 . (REGISTER ENVIRONMENT))
- (16 . (REGISTER TEMPORARY))
- (20 . (REGISTER INTERPRETER-CALL-RESULT:ENCLOSE))
- (24 . (REGISTER RETURN-CODE))
- (28 . (REGISTER LEXPR-PRIMITIVE-ACTUALS))
- (32 . (REGISTER MINIMUM-LENGTH))
- (36 . (REGISTER PRIMITIVE))
- (44 . (REGISTER STACK-GUARD))
- ;; Interface entry points
- ,@(make-entries
- #x0280
- '(link error apply
- lexpr-apply primitive-apply primitive-lexpr-apply
- cache-reference-apply lookup-apply
- interrupt-continuation interrupt-ic-procedure
- interrupt-procedure interrupt-closure
- lookup safe-lookup set! access unassigned? unbound? define
- reference-trap safe-reference-trap assignment-trap
- unassigned?-trap
- &+ &- &* &/ &= &< &> 1+ -1+ zero? positive? negative?))
- ;; Compiler temporaries
- ,@(let loop ((index -4) (i 0))
- (if (>= i 512)
- '()
- (cons `(,index . (TEMPORARY ,i))
- (loop (- index 4) (1+ i))))))))
-
-\f
-(define (make-pc-relative deferred? size pco)
- ;; This assumes that pco was just extracted.
- ;; VAX PC relative modes are defined with respect to the pc
- ;; immediately after the PC relative field.
-
- (define (default)
- `(,(if deferred? '@@PCO '@PCO) ,size ,pco))
-
- (define (test address)
- (disassembler/lookup-symbol *symbol-table address))
-
- (define (object-offset? relative)
- (let* ((unsigned (if (negative? relative)
- (+ (expt 2 32) relative)
- relative))
- (tc (quotient unsigned (expt 2 scheme-datum-width))))
-
- (define (try tc)
- (let* ((object-base (* tc (expt 2 scheme-datum-width)))
- (offset (- unsigned object-base)))
- (cond ((test (+ *current-offset offset))
- =>
- (lambda (label)
- (list label object-base)))
- (else
- false))))
-
- (or (try tc)
- (try (1+ tc)))))
-
- (let ((absolute (+ pco *current-offset)))
- (cond ((not disassembler/symbolize-output?)
- (default))
- ((test absolute)
- =>
- (lambda (answ)
- `(,(if deferred? '@@PCR '@PCR) ,answ)))
- ((test (- absolute 2))
- ;; Kludge to get branches to execute caches correctly.
- =>
- (lambda (answ)
- `(,(if deferred? '@@PCRO '@PCRO) ,answ 2)))
- ((object-offset? pco)
- =>
- (lambda (answ)
- `(,(if deferred? '@@PCRO '@PCRO) ,@answ)))
- (else
- (default)))))
-
-(define (undefined-instruction)
- ;; This losing assignment removes a 'cwcc'. Too bad.
- (set! *valid? false)
- '())
-
-(define (undefined)
- undefined-instruction)
-
-(define compiled-code-block/procedure-cache-offset 0)
-(define compiled-code-block/objects-per-procedure-cache 2)
-(define compiled-code-block/objects-per-variable-cache 1)
-
-;; global variable used by runtime/udata.scm -- Moby yuck!
-
-(set! compiled-code-block/bytes-per-object 4)
+++ /dev/null
-#| -*-Scheme-*-
-
-$MC68020-Header: dassm3.scm,v 4.6 88/08/29 22:40:41 GMT cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; VAX Disassembler: Internals
-
-(declare (usual-integrations))
-\f
-;;;; Bit String Manipulation
-
-(define (make-fetcher size-in-bits)
- (let ((size-in-bytes (quotient size-in-bits 8)))
- (lambda ()
- (let ((word (read-bits *current-offset size-in-bits)))
- (set! *current-offset (+ *current-offset size-in-bytes))
- word))))
-
-(define get-byte (make-fetcher 8))
-(define get-word (make-fetcher 16))
-(define get-longword (make-fetcher 32))
-
-(define-integrable (get-immediate-byte)
- (extract+ (get-byte) 0 8))
-
-(define-integrable (get-immediate-word)
- (extract+ (get-word) 0 16))
-
-(define-integrable (get-immediate-longword)
- (extract+ (get-longword) 0 32))
-
-(define-integrable (extract bit-string start end)
- (bit-string->unsigned-integer (bit-substring bit-string start end)))
-
-(define-integrable (extract+ bit-string start end)
- (bit-string->signed-integer (bit-substring bit-string start end)))
-\f
-;;;; Operand decoding
-
-(define operand-dispatch
- (let ((short-literal
- (lambda (*or* *os*)
- *os* ; ignored
- `(S ,(extract *or* 0 6))))
- (index-operand
- (lambda (*or* *os*)
- (let ((index-reg (extract *or* 0 4)))
- `(X ,index-reg ,(decode-operand *os*)))))
- (standard-operand
- (lambda (if-reg if-pc)
- (lambda (*or* *os*)
- (let ((reg (extract *or* 0 4)))
- (if (= #xF reg)
- (if-pc *os*)
- (if-reg reg))))))
- (simple-operand
- (lambda (keyword)
- (lambda (*or* *os*)
- *os* ; ignored
- `(,keyword ,(make-register (extract *or* 0 4)))))))
- (let ((offset-operand
- (lambda (deferred? size get)
- (standard-operand
- (lambda (reg)
- (make-offset deferred? reg size (get)))
- (lambda (*os*)
- *os* ; ignored
- (make-pc-relative deferred? size (get)))))))
- (vector
- short-literal ;0 short immediate
- short-literal ;1 " "
- short-literal ;2 " "
- short-literal ;3 " "
- index-operand ;4 indexed
- (simple-operand 'R) ;5 register
- (simple-operand '@R) ;6 register deferred
- (simple-operand '@-R) ;7 autodecrement
- (standard-operand ;8 autoincrement/immediate
- (lambda (reg)
- `(@R+ ,(make-register reg)))
- (lambda (*os*)
- `(&
- ,(case *os*
- ((B) (get-immediate-byte))
- ((W) (get-immediate-word))
- ((L) (get-immediate-longword))))))
- (standard-operand ;9 autoincrement deferred/absolute
- (lambda (reg)
- `(@@R+ ,(make-register reg)))
- (lambda (*os*)
- *os* ; ignored
- `(@& , (extract+ (get-longword) 0 32))))
- (offset-operand false 'B ;a byte offset
- get-immediate-byte)
- (offset-operand true 'B ;b byte offset deferred
- get-immediate-byte)
- (offset-operand false 'W ;c word offset
- get-immediate-word)
- (offset-operand true 'W ;d word offset deferred
- get-immediate-word)
- (offset-operand false 'L ;e long offset
- get-immediate-longword)
- (offset-operand true 'L ;f long offset deferred
- get-immediate-longword)))))
-\f
-;;;; Instruction decoding
-
-(define (decode-operand size)
- (let ((*or* (get-byte)))
- ((vector-ref operand-dispatch (extract *or* 4 8))
- *or* size)))
-
-(define (decode-displacement size)
- (case size
- ((8) (make-pc-relative false 'B (get-immediate-byte)))
- ((16) (make-pc-relative false 'W (get-immediate-word)))
- ((32) (make-pc-relative false 'L (get-immediate-longword)))
- (else (error "decode-displacement: bad size" size))))
-
-(define opcode-dispatch
- (make-vector 256 undefined-instruction))
-
-(define secondary-opcode-dispatch
- (make-vector 256 undefined-instruction))
-
-(define (define-standard-instruction opcode handler)
- (vector-set! opcode-dispatch opcode handler))
-
-(define (define-extended-instruction opcode handler)
- (vector-set! secondary-opcode-dispatch opcode handler))
-
-(define-standard-instruction #xFD
- (lambda ()
- ((vector-ref secondary-opcode-dispatch (get-immediate-byte)))))
-\f
-;; Most of the instructions decoders are generated from from the
-;; assembler tables, but branch instructions are treated separately.
-
-(define (displacement-decoder size)
- (define (make-decoder keyword getter)
- (lambda ()
- (make-pc-relative false keyword (getter))))
-
- (case size
- ((8) (make-decoder 'B get-immediate-byte))
- ((16) (make-decoder 'W get-immediate-word))
- ((32) (make-decoder 'L get-immediate-longword))
- (else (error "displacement-decoder: bad size" size))))
-
-(define (define-branch-instruction opcode prefix size)
- (let ((decoder (displacement-decoder size)))
- (define-standard-instruction opcode
- (lambda ()
- `(,@prefix ,(decoder))))))
-
-;; Conditional branches
-
-(define-branch-instruction #x12 '(B B NEQ) 8)
-(define-branch-instruction #x13 '(B B EQL) 8)
-(define-branch-instruction #x14 '(B B GTR) 8)
-(define-branch-instruction #x15 '(B B LEQ) 8)
-(define-branch-instruction #x18 '(B B GEQ) 8)
-(define-branch-instruction #x19 '(B B LSS) 8)
-(define-branch-instruction #x1A '(B B GTRU) 8)
-(define-branch-instruction #x1B '(B B LEQU) 8)
-(define-branch-instruction #x1C '(B B VC) 8)
-(define-branch-instruction #x1D '(B B VS) 8)
-(define-branch-instruction #x1E '(B B CC) 8)
-(define-branch-instruction #x1F '(B B CS) 8)
-
-;; Unconditional branches
-
-(define-branch-instruction #x11 '(BR B) 8)
-(define-branch-instruction #x31 '(BR W) 16)
-(define-branch-instruction #x10 '(BSB B) 8)
-(define-branch-instruction #x30 '(BSB W) 16)
-
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Compiler File Dependencies. VAX version.
-;;; package: (compiler declarations)
-
-(declare (usual-integrations))
-\f
-(define (initialize-package!)
- (add-event-receiver! event:after-restore reset-source-nodes!)
- (reset-source-nodes!))
-
-(define (reset-source-nodes!)
- (set! source-filenames '())
- (set! source-hash)
- (set! source-nodes)
- (set! source-nodes/by-rank)
- unspecific)
-
-(define (maybe-setup-source-nodes!)
- (if (null? source-filenames)
- (setup-source-nodes!)))
-
-(define (setup-source-nodes!)
- (let ((filenames
- (append-map!
- (lambda (subdirectory)
- (map (lambda (pathname)
- (string-append subdirectory
- "/"
- (pathname-name pathname)))
- (directory-read
- (string-append subdirectory
- "/"
- source-file-expression))))
- '("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt"
- "machines/vax"))))
- (if (null? filenames)
- (error "Can't find source files of compiler"))
- (set! source-filenames filenames))
- (set! source-hash (make-string-hash-table))
- (set! source-nodes
- (map (lambda (filename)
- (let ((node (make/source-node filename)))
- (hash-table/put! source-hash filename node)
- node))
- source-filenames))
- (initialize/syntax-dependencies!)
- (initialize/integration-dependencies!)
- (source-nodes/rank!))
-
-(define source-file-expression "*.scm")
-(define source-filenames)
-(define source-hash)
-(define source-nodes)
-(define source-nodes/by-rank)
-
-(define (filename/append directory . names)
- (map (lambda (name) (string-append directory "/" name)) names))
-\f
-(define-structure (source-node
- (conc-name source-node/)
- (constructor %make/source-node (filename pathname)))
- (filename #f read-only #t)
- (pathname #f read-only #t)
- (forward-links '())
- (backward-links '())
- (forward-closure '())
- (backward-closure '())
- (dependencies '())
- (dependents '())
- (rank #f)
- (syntax-table #f)
- (declarations '())
- (modification-time #f))
-
-(define (make/source-node filename)
- (%make/source-node filename (->pathname filename)))
-
-(define (filename->source-node filename)
- (let ((node (hash-table/get source-hash filename #f)))
- (if (not node)
- (error "Unknown source file:" filename))
- node))
-
-(define (source-node/circular? node)
- (memq node (source-node/backward-closure node)))
-
-(define (source-node/link! node dependency)
- (if (not (memq dependency (source-node/backward-links node)))
- (begin
- (set-source-node/backward-links!
- node
- (cons dependency (source-node/backward-links node)))
- (set-source-node/forward-links!
- dependency
- (cons node (source-node/forward-links dependency)))
- (source-node/close! node dependency))))
-
-(define (source-node/close! node dependency)
- (if (not (memq dependency (source-node/backward-closure node)))
- (begin
- (set-source-node/backward-closure!
- node
- (cons dependency (source-node/backward-closure node)))
- (set-source-node/forward-closure!
- dependency
- (cons node (source-node/forward-closure dependency)))
- (for-each (lambda (dependency)
- (source-node/close! node dependency))
- (source-node/backward-closure dependency))
- (for-each (lambda (node)
- (source-node/close! node dependency))
- (source-node/forward-closure node)))))
-\f
-;;;; Rank
-
-(define (source-nodes/rank!)
- (compute-dependencies! source-nodes)
- (compute-ranks! source-nodes)
- (set! source-nodes/by-rank (source-nodes/sort-by-rank source-nodes))
- unspecific)
-
-(define (compute-dependencies! nodes)
- (for-each (lambda (node)
- (set-source-node/dependencies!
- node
- (list-transform-negative (source-node/backward-closure node)
- (lambda (node*)
- (memq node (source-node/backward-closure node*)))))
- (set-source-node/dependents!
- node
- (list-transform-negative (source-node/forward-closure node)
- (lambda (node*)
- (memq node (source-node/forward-closure node*))))))
- nodes))
-
-(define (compute-ranks! nodes)
- (let loop ((nodes nodes) (unranked-nodes '()))
- (if (null? nodes)
- (if (not (null? unranked-nodes))
- (loop unranked-nodes '()))
- (loop (cdr nodes)
- (let ((node (car nodes)))
- (let ((rank (source-node/rank* node)))
- (if rank
- (begin
- (set-source-node/rank! node rank)
- unranked-nodes)
- (cons node unranked-nodes))))))))
-
-(define (source-node/rank* node)
- (let loop ((nodes (source-node/dependencies node)) (rank -1))
- (if (null? nodes)
- (1+ rank)
- (let ((rank* (source-node/rank (car nodes))))
- (and rank*
- (loop (cdr nodes) (max rank rank*)))))))
-
-(define (source-nodes/sort-by-rank nodes)
- (sort nodes (lambda (x y) (< (source-node/rank x) (source-node/rank y)))))
-\f
-;;;; File Syntaxer
-
-(define (syntax-files!)
- (maybe-setup-source-nodes!)
- (for-each
- (lambda (node)
- (let ((modification-time
- (let ((source (modification-time node "scm"))
- (binary (modification-time node "bin")))
- (if (not source)
- (error "Missing source file" (source-node/filename node)))
- (and binary (< source binary) binary))))
- (set-source-node/modification-time! node modification-time)
- (if (not modification-time)
- (begin (write-string "\nSource file newer than binary: ")
- (write (source-node/filename node))))))
- source-nodes)
- (if compiler:enable-integration-declarations?
- (begin
- (for-each
- (lambda (node)
- (let ((time (source-node/modification-time node)))
- (if (and time
- (there-exists? (source-node/dependencies node)
- (lambda (node*)
- (let ((newer?
- (let ((time*
- (source-node/modification-time node*)))
- (or (not time*)
- (> time* time)))))
- (if newer?
- (begin
- (write-string "\nBinary file ")
- (write (source-node/filename node))
- (write-string " newer than dependency ")
- (write (source-node/filename node*))))
- newer?))))
- (set-source-node/modification-time! node #f))))
- source-nodes)
- (for-each
- (lambda (node)
- (if (not (source-node/modification-time node))
- (for-each (lambda (node*)
- (if (source-node/modification-time node*)
- (begin
- (write-string "\nBinary file ")
- (write (source-node/filename node*))
- (write-string " depends on ")
- (write (source-node/filename node))))
- (set-source-node/modification-time! node* #f))
- (source-node/forward-closure node))))
- source-nodes)))
- (for-each (lambda (node)
- (if (not (source-node/modification-time node))
- (pathname-delete!
- (pathname-new-type (source-node/pathname node) "ext"))))
- source-nodes/by-rank)
- (write-string "\n\nBegin pass 1:")
- (for-each (lambda (node)
- (if (not (source-node/modification-time node))
- (source-node/syntax! node)))
- source-nodes/by-rank)
- (if (there-exists? source-nodes/by-rank
- (lambda (node)
- (and (not (source-node/modification-time node))
- (source-node/circular? node))))
- (begin
- (write-string "\n\nBegin pass 2:")
- (for-each (lambda (node)
- (if (not (source-node/modification-time node))
- (if (source-node/circular? node)
- (source-node/syntax! node)
- (source-node/touch! node))))
- source-nodes/by-rank))))
-\f
-(define (source-node/touch! node)
- (with-values
- (lambda ()
- (sf/pathname-defaulting (source-node/pathname node) "" #f))
- (lambda (input-pathname bin-pathname spec-pathname)
- input-pathname
- (pathname-touch! bin-pathname)
- (pathname-touch! (pathname-new-type bin-pathname "ext"))
- (if spec-pathname (pathname-touch! spec-pathname)))))
-
-(define (pathname-touch! pathname)
- (if (file-exists? pathname)
- (begin
- (write-string "\nTouch file: ")
- (write (enough-namestring pathname))
- (file-touch pathname))))
-
-(define (pathname-delete! pathname)
- (if (file-exists? pathname)
- (begin
- (write-string "\nDelete file: ")
- (write (enough-namestring pathname))
- (delete-file pathname))))
-
-(define (sc filename)
- (maybe-setup-source-nodes!)
- (source-node/syntax! (filename->source-node filename)))
-
-(define (source-node/syntax! node)
- (with-values
- (lambda ()
- (sf/pathname-defaulting (source-node/pathname node) "" #f))
- (lambda (input-pathname bin-pathname spec-pathname)
- (sf/internal
- input-pathname bin-pathname spec-pathname
- (source-node/syntax-table node)
- ((if compiler:enable-integration-declarations?
- identity-procedure
- (lambda (declarations)
- (list-transform-negative declarations
- integration-declaration?)))
- (source-node/declarations node))))))
-
-(define-integrable (modification-time node type)
- (file-modification-time
- (pathname-new-type (source-node/pathname node) type)))
-\f
-;;;; Syntax dependencies
-
-(define (initialize/syntax-dependencies!)
- (let ((file-dependency/syntax/join
- (lambda (filenames syntax-table)
- (for-each (lambda (filename)
- (set-source-node/syntax-table!
- (filename->source-node filename)
- syntax-table))
- filenames))))
- (file-dependency/syntax/join
- (append (filename/append "base"
- "toplev" "asstop" "crstop"
- "blocks" "cfg1" "cfg2" "cfg3" "constr"
- "contin" "ctypes" "debug" "enumer"
- "infnew" "lvalue" "object" "pmerly" "proced"
- "refctx" "rvalue" "scode" "sets" "subprb"
- "switch" "utils")
- (filename/append "back"
- "asmmac" "bittop" "bitutl" "insseq" "lapgn1"
- "lapgn2" "lapgn3" "linear" "regmap" "symtab"
- "syntax")
- (filename/append "machines/vax"
- "dassm1" "dsyn" "insmac" "lapopt" "machin"
- "rgspcm" "rulrew")
- (filename/append "fggen"
- "declar" "fggen" "canon")
- (filename/append "fgopt"
- "blktyp" "closan" "conect" "contan" "delint"
- "desenv" "envopt" "folcon" "offset" "operan"
- "order" "outer" "param" "reord" "reteqv" "reuse"
- "sideff" "simapp" "simple" "subfre" "varind")
- (filename/append "rtlbase"
- "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp"
- "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2"
- "valclass")
- (filename/append "rtlgen"
- "fndblk" "fndvar" "opncod" "rgcomb" "rgproc"
- "rgretn" "rgrval" "rgstmt" "rtlgen")
- (filename/append "rtlopt"
- "ralloc" "rcompr" "rcse1" "rcse2" "rcseep"
- "rcseht" "rcserq" "rcsesr" "rdebug" "rdflow"
- "rerite" "rinvex" "rlife" "rtlcsm"))
- (->environment '(COMPILER)))
- (file-dependency/syntax/join
- (filename/append "machines/vax"
- "lapgen" "rules1" "rules2" "rules3" "rules4" "rulfix"
- "insutl" "instr1" "instr2" "instr3")
- (->environment '(COMPILER LAP-SYNTAXER)))
- (file-dependency/syntax/join
- (filename/append "machines/vax"
- "dinstr1" "dinstr2" "dinstr3")
- (->environment '(COMPILER DISASSEMBLER)))))
-\f
-;;;; Integration Dependencies
-
-(define (initialize/integration-dependencies!)
-
- (define (add-declaration! declaration filenames)
- (for-each (lambda (filenames)
- (let ((node (filename->source-node filenames)))
- (set-source-node/declarations!
- node
- (cons declaration
- (source-node/declarations node)))))
- filenames))
-
- (let* ((front-end-base
- (filename/append "base"
- "blocks" "cfg1" "cfg2" "cfg3"
- "contin" "ctypes" "enumer" "lvalue"
- "object" "proced" "rvalue"
- "scode" "subprb" "utils"))
- (vax-base
- (append (filename/append "machines/vax" "machin")
- (filename/append "back" "asutl")))
- (rtl-base
- (filename/append "rtlbase"
- "rgraph" "rtlcfg" "rtlobj" "rtlreg" "rtlty1"
- "rtlty2"))
- (cse-base
- (filename/append "rtlopt"
- "rcse1" "rcseht" "rcserq" "rcsesr"))
- (cse-all
- (append (filename/append "rtlopt"
- "rcse2" "rcseep")
- cse-base))
- (instruction-base
- (filename/append "machines/vax" "assmd" "machin"))
- (lapgen-base
- (append (filename/append "back" "linear" "regmap")
- (filename/append "machines/vax" "lapgen")))
- (assembler-base
- (append (filename/append "back" "symtab")
- (filename/append "machines/vax" "insutl")))
- (lapgen-body
- (append
- (filename/append "back" "lapgn1" "lapgn2" "syntax")
- (filename/append "machines/vax"
- "rules1" "rules2" "rules3" "rules4" "rulfix")))
- (assembler-body
- (append
- (filename/append "back" "bittop")
- (filename/append "machines/vax"
- "instr1" "instr2" "instr3"))))
-
- (define (file-dependency/integration/join filenames dependencies)
- (for-each (lambda (filename)
- (file-dependency/integration/make filename dependencies))
- filenames))
-
- (define (file-dependency/integration/make filename dependencies)
- (let ((node (filename->source-node filename)))
- (for-each (lambda (dependency)
- (let ((node* (filename->source-node dependency)))
- (if (not (eq? node node*))
- (source-node/link! node node*))))
- dependencies)))
-
- (define (define-integration-dependencies directory name directory* . names)
- (file-dependency/integration/make
- (string-append directory "/" name)
- (apply filename/append directory* names)))
-
- (define-integration-dependencies "machines/vax" "machin" "back" "asutl")
- (define-integration-dependencies "base" "object" "base" "enumer")
- (define-integration-dependencies "base" "enumer" "base" "object")
- (define-integration-dependencies "base" "utils" "base" "scode")
- (define-integration-dependencies "base" "cfg1" "base" "object")
- (define-integration-dependencies "base" "cfg2" "base"
- "cfg1" "cfg3" "object")
- (define-integration-dependencies "base" "cfg3" "base" "cfg1" "cfg2")
- (define-integration-dependencies "base" "ctypes" "base"
- "blocks" "cfg1" "cfg2" "cfg3" "contin" "lvalue" "object" "subprb")
- (define-integration-dependencies "base" "rvalue" "base"
- "blocks" "cfg1" "cfg2" "cfg3" "enumer" "lvalue" "object" "utils")
- (define-integration-dependencies "base" "lvalue" "base"
- "blocks" "object" "proced" "rvalue" "utils")
- (define-integration-dependencies "base" "blocks" "base"
- "enumer" "lvalue" "object" "proced" "rvalue" "scode")
- (define-integration-dependencies "base" "proced" "base"
- "blocks" "cfg1" "cfg2" "cfg3" "contin" "enumer" "lvalue" "object"
- "rvalue" "utils")
- (define-integration-dependencies "base" "contin" "base"
- "blocks" "cfg3" "ctypes")
- (define-integration-dependencies "base" "subprb" "base"
- "cfg3" "contin" "enumer" "object" "proced")
-
- (define-integration-dependencies "machines/vax" "machin" "rtlbase"
- "rtlreg" "rtlty1" "rtlty2")
-
- (define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2")
- (define-integration-dependencies "rtlbase" "rgraph" "machines/vax"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlcfg" "base"
- "cfg1" "cfg2" "cfg3")
- (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils")
- (define-integration-dependencies "rtlbase" "rtlcon" "machines/vax"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlexp" "rtlbase"
- "rtlreg" "rtlty1")
- (define-integration-dependencies "rtlbase" "rtline" "base" "cfg1" "cfg2")
- (define-integration-dependencies "rtlbase" "rtline" "rtlbase"
- "rtlcfg" "rtlty2")
- (define-integration-dependencies "rtlbase" "rtlobj" "base"
- "cfg1" "object" "utils")
- (define-integration-dependencies "rtlbase" "rtlreg" "machines/vax"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlreg" "rtlbase"
- "rgraph" "rtlty1")
- (define-integration-dependencies "rtlbase" "rtlty1" "rtlbase" "rtlcfg")
- (define-integration-dependencies "rtlbase" "rtlty2" "base" "scode")
- (define-integration-dependencies "rtlbase" "rtlty2" "machines/vax"
- "machin")
- (define-integration-dependencies "rtlbase" "rtlty2" "rtlbase" "rtlty1")
-
- (file-dependency/integration/join
- (append
- (filename/append "base" "refctx")
- (filename/append "fggen"
- "declar" "fggen") ; "canon" needs no integrations
- (filename/append "fgopt"
- "blktyp" "closan" "conect" "contan" "delint" "desenv"
- "envopt" "folcon" "offset" "operan" "order" "param"
- "outer" "reuse" "reteqv" "sideff" "simapp" "simple"
- "subfre" "varind"))
- (append vax-base front-end-base))
-
- (define-integration-dependencies "fgopt" "reuse" "fgopt" "reord")
-
- (file-dependency/integration/join
- (filename/append "rtlgen"
- "fndblk" "fndvar" "opncod" "rgcomb" "rgproc" "rgretn"
- "rgrval" "rgstmt" "rtlgen")
- (append vax-base front-end-base rtl-base))
-
- (file-dependency/integration/join
- (append cse-all
- (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow"
- "rerite" "rinvex" "rlife" "rtlcsm")
- (filename/append "machines/vax" "rulrew"))
- (append vax-base rtl-base))
-
- (file-dependency/integration/join cse-all cse-base)
-
- (file-dependency/integration/join
- (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife")
- (filename/append "rtlbase" "regset"))
-
- (file-dependency/integration/join
- (filename/append "rtlopt" "rcseht" "rcserq")
- (filename/append "base" "object"))
-
- (define-integration-dependencies "rtlopt" "rlife" "base" "cfg2")
-
- (let ((dependents
- (append instruction-base
- lapgen-base
- lapgen-body
- assembler-base
- assembler-body
- (filename/append "back" "linear" "syerly"))))
- (add-declaration! '(USUAL-DEFINITION (SET EXPT)) dependents)
- (file-dependency/integration/join dependents instruction-base))
-
- (file-dependency/integration/join (append lapgen-base lapgen-body)
- lapgen-base)
-
- (file-dependency/integration/join (append assembler-base assembler-body)
- assembler-base)
-
- (define-integration-dependencies "back" "lapgn1" "base"
- "cfg1" "cfg2" "utils")
- (define-integration-dependencies "back" "lapgn1" "rtlbase"
- "rgraph" "rtlcfg")
- (define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg")
- (define-integration-dependencies "back" "linear" "base" "cfg1" "cfg2")
- (define-integration-dependencies "back" "linear" "rtlbase" "rtlcfg")
- (define-integration-dependencies "back" "mermap" "back" "regmap")
- (define-integration-dependencies "back" "regmap" "base" "utils")
- (define-integration-dependencies "back" "symtab" "base" "utils"))
-
- (for-each (lambda (node)
- (let ((links (source-node/backward-links node)))
- (if (not (null? links))
- (set-source-node/declarations!
- node
- (cons (make-integration-declaration
- (source-node/pathname node)
- (map source-node/pathname links))
- (source-node/declarations node))))))
- source-nodes))
-
-(define (make-integration-declaration pathname integration-dependencies)
- `(INTEGRATE-EXTERNAL
- ,@(map (let ((default
- (make-pathname
- #f
- #f
- (cons 'RELATIVE
- (make-list
- (length (cdr (pathname-directory pathname)))
- 'UP))
- #f
- #f
- #f)))
- (lambda (pathname)
- (merge-pathnames pathname default)))
- integration-dependencies)))
-
-(define-integrable (integration-declaration? declaration)
- (eq? (car declaration) 'INTEGRATE-EXTERNAL))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; VAX Disassembler instruction definition syntax
-
-(declare (usual-integrations))
-\f
-;;;; Instruction decoding
-#|
-(define (initialize-package!)
- (environment-define-macro (->environment '(COMPILER DISASSEMBLER))
- 'DEFINE-INSTRUCTION
- transform/define-instruction))
-|#
-
-(define instructions-disassembled-specially
- '(BYTE WORD LONG BUG B BR BSB))
-
-(define-syntax define-instruction
- (rsc-macro-transformer
- (lambda (form environment)
- (if (syntax-match? '(SYMBOL * DATUM) (cdr form))
- (if (memq (cadr form) instructions-disassembled-specially)
- `'()
- `(,(close-syntax 'BEGIN environment)
- ,@(map (lambda (pattern)
- (process-instruction-definition (cadr form)
- pattern
- environment))
- (cddr form))))
- (ill-formed-syntax form)))))
-
-(define (process-instruction-definition name pattern environment)
- (let ((prefix (cons name (find-pattern-prefix (car pattern))))
- (opcode-field (cadr pattern))
- (operands (cddr pattern)))
- (if (not (eq? (car opcode-field) 'BYTE))
- (error "Unhandled opcode kind:" opcode-field))
- (let ((opcode (cadadr opcode-field)))
- (case (caadr opcode-field) ;size in bits
- ((8)
- `(,(close-syntax 'DEFINE-STANDARD-INSTRUCTION environment)
- ,opcode
- ,(make-instruction-parser prefix operands environment)))
- ((16)
- (let ((low (remainder opcode 256))
- (high (quotient opcode 256)))
- (if (not (= low #xFD))
- (error "Unhandled extension:" opcode))
- `(,(close-syntax 'DEFINE-EXTENDED-INSTRUCTION environment)
- ,high
- ,(make-instruction-parser prefix operands environment))))
- (else
- (error "Bad opcode size:" (caadr opcode-field)))))))
-
-(define (find-pattern-prefix pattern) ; KLUDGE
- (if (and (pair? pattern)
- (not (and (pair? (car pattern))
- (eq? (caar pattern) '?))))
- (cons (car pattern) (find-pattern-prefix (cdr pattern)))
- '()))
-
-(define (make-instruction-parser prefix operands environment)
- `(,(close-syntax 'LAMBDA environment)
- ()
- (,(close-syntax 'APPEND environment)
- ',prefix
- ,(process-operands operands environment))))
-
-;; A let is used below to force the order of evaluation.
-
-(define (process-operands operands environment)
- (if (pair? operands)
- (let ((temp (make-synthetic-identifier 'TEMP)))
- `(,(close-syntax 'LET environment)
- ((,temp
- ,(let ((operand (car operands)))
- (case (car operand)
- ((OPERAND)
- `(,(close-syntax 'DECODE-OPERAND environment)
- ',(cadr operand)))
- ((DISPLACEMENT)
- `(,(close-syntax 'DECODE-DISPLACEMENT environment)
- ,(caadr operand)))
- (else
- (error "Unknown operand kind:" operand))))))
- (,(close-syntax 'CONS environment)
- ,temp
- ,(process-operands (cdr operands) environment))))
- `'()))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; VAX Instruction Set Macros. Early version
-
-(declare (usual-integrations))
-\f
-;;;; Instruction macros
-
-(define early-ea-database '())
-
-(define-syntax define-instruction
- (non-hygienic-macro-transformer
- (lambda (opcode . patterns)
- `(SET! EARLY-INSTRUCTIONS
- (CONS
- (LIST ',opcode
- ,@(map (lambda (pattern)
- `(EARLY-PARSE-RULE
- ',(car pattern)
- (LAMBDA (PAT VARS)
- (EARLY-MAKE-RULE
- PAT
- VARS
- (SCODE-QUOTE
- (instruction->instruction-sequence
- ,(parse-instruction (cadr pattern)
- (cddr pattern)
- #t)))))))
- patterns))
- EARLY-INSTRUCTIONS)))))
-\f
-;;;; Transformers and utilities
-
-(define (define-early-transformer name transformer)
- (set! early-transformers
- (cons (cons name transformer)
- early-transformers)))
-
-(define-syntax define-symbol-transformer
- (non-hygienic-macro-transformer
- (lambda (name . assoc)
- `(DEFINE-EARLY-TRANSFORMER ',name (MAKE-SYMBOL-TRANSFORMER ',assoc)))))
-
-;; *** Is this right? ***
-
-(define-syntax define-transformer
- (non-hygienic-macro-transformer
- (lambda (name value)
- `(DEFINE-EARLY-TRANSFORMER ',name ,value))))
-
-(define-syntax define-ea-transformer
- (non-hygienic-macro-transformer
- (lambda (name category type)
- `(DEFINE-EARLY-TRANSFORMER ',name
- (MAKE-EA-TRANSFORMER ',category ',type)))))
-
-(define (make-ea-transformer category type)
- type ; ignored
- (make-database-transformer
- (append-map! (lambda (rule)
- (apply
- (lambda (pattern variables categories expression)
- (if (memq category categories)
- (list (early-make-rule pattern variables expression))
- '()))
- rule))
- early-ea-database)))
-\f
-;;;; Early effective address assembly.
-
-;;; *** NOTE: If this format changes, insutl.scm must also be changed! ***
-
-(define-syntax define-ea-database
- (non-hygienic-macro-transformer
- (lambda rules
- `(SET! EARLY-EA-DATABASE
- (LIST
- ,@(map (lambda (rule)
- (apply
- (lambda (pattern categories . fields)
- (let ((keyword (car pattern)))
- `(EARLY-PARSE-RULE
- ',pattern
- (LAMBDA (PAT VARS)
- (LIST PAT
- VARS
- ',categories
- (SCODE-QUOTE
- (MAKE-EFFECTIVE-ADDRESS
- ',keyword
- ',categories
- ,(process-fields fields true))))))))
- rule))
- rules))))))
-\f
-;; This is super hairy because of immediate operands!
-;; The index 2 here is the argument number to MAKE-EFFECTIVE-ADDRESS.
-
-(define ea-value-expander
- (scode->scode-expander
- (lambda (operands if-expanded if-not-expanded)
- if-not-expanded ; ignored
- (define (default)
- (if-expanded (scode/make-combination (scode/make-variable 'EA-VALUE)
- (cdr operands))))
-
- (let ((operand (cadr operands))
- (type (car operands)))
- (if (not (scode/combination? operand))
- (default)
- (scode/combination-components
- operand
- (lambda (operator operands)
- (if (or (not (scode/variable? operator))
- (not (eq? (scode/variable-name operator)
- 'MAKE-EFFECTIVE-ADDRESS)))
- (default)
- (if-expanded
- (scode/make-combination
- (scode/make-lambda lambda-tag:let
- '(*IMMEDIATE-TYPE*)
- '()
- false
- '()
- '((INTEGRATE *IMMEDIATE-TYPE*))
- (scode/make-sequence
- (list (scode/make-variable '*IMMEDIATE-TYPE*)
- (list-ref operands 2))))
- (list type)))))))))))
-
-#|
-;; Not used currently
-
-(define coerce-to-type-expander
- (scode->scode-expander
- (lambda (operands if-expanded if-not-expanded)
- (define (handle coercion name)
- (if-expanded
- (if (scode/constant? (car operands))
- (scode/make-constant
- (coercion (scode/constant-value (car operands))))
- (scode/make-combination (scode/make-variable name)
- (list (car operands))))))
-
- (if (not (scode/constant? (cadr operands)))
- (if-not-expanded)
- (case (scode/constant-value (cadr operands))
- ((b) (handle coerce-8-bit-signed 'coerce-8-bit-signed))
- ((w) (handle coerce-16-bit-signed 'coerce-16-bit-signed))
- ((l) (handle coerce-32-bit-signed 'coerce-32-bit-signed))
- (else (if-not-expanded)))))))
-|#
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; VAX Instruction Set Macros
-
-(declare (usual-integrations))
-\f
-;;;; Effective addressing
-
-(define ea-database-name
- 'EA-DATABASE)
-
-(define-syntax define-ea-database
- (rsc-macro-transformer
- (lambda (form environment)
- `(,(close-syntax 'DEFINE environment)
- ,ea-database-name
- ,(compile-database (cdr form) environment
- (lambda (pattern actions)
- (let ((keyword (car pattern))
- (categories (car actions))
- (value (cdr actions)))
- `(,(close-syntax 'MAKE-EFFECTIVE-ADDRESS environment)
- ',keyword
- ',categories
- ,(process-fields value #f environment)))))))))
-
-(define-syntax define-ea-transformer
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (if (syntax-match? '(IDENTIFIER DATUM DATUM) (cdr form))
- `(DEFINE (,(cadr form) EXPRESSION)
- (LET ((EA (PROCESS-EA EXPRESSION ',(cadddr form))))
- (AND EA
- (MEMQ ',(caddr form) (EA-CATEGORIES EA))
- EA)))
- (ill-formed-syntax form)))))
-
-(define-syntax define-symbol-transformer
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (if (syntax-match? '(IDENTIFIER * SYMBOL) (cdr form))
- `(DEFINE-INTEGRABLE (,(cadr form) SYMBOL)
- (LET ((PLACE (ASSQ SYMBOL ',(cddr form))))
- (IF (PAIR? PLACE)
- (CDR PLACE)
- #F)))
- (ill-formed-syntax form)))))
-
-(define-syntax define-transformer
- (rsc-macro-transformer
- (lambda (form environment)
- `(,(close-syntax 'DEFINE environment) ,@(cdr form)))))
-
-(define-syntax define-trivial-instruction
- (sc-macro-transformer
- (lambda (form environment)
- (if (syntax-match? '(SYMBOL EXPRESSION) (cdr form))
- `(DEFINE-INSTRUCTION ,(cadr form)
- (()
- (BYTE (8 ,(close-syntax (caddr form) environment)))))
- (ill-formed-syntax form)))))
-\f
-(define (parse-instruction opcode tail early? environment)
- (process-fields (cons opcode tail) early? environment))
-
-(define (process-fields fields early? environment)
- (if (and (null? (cdr fields))
- (eq? (caar fields) 'VARIABLE-WIDTH))
- (expand-variable-width (car fields) early? environment)
- (call-with-values (lambda () (expand-fields fields early? environment))
- (lambda (code size)
- (if (not (zero? (remainder size 8)))
- (error "Bad syllable size:" size))
- code))))
-
-(define (expand-variable-width field early? environment)
- (let ((binding (cadr field))
- (clauses (cddr field)))
- `(,(close-syntax 'LIST environment)
- ,(variable-width-expression-syntaxer
- (car binding) ; name
- (cadr binding) ; expression
- environment
- (map (lambda (clause)
- (call-with-values
- (lambda () (expand-fields (cdr clause) early? environment))
- (lambda (code size)
- (if (not (zero? (remainder size 8)))
- (error "Bad clause size:" size))
- `(,code ,size ,@(car clause)))))
- clauses)))))
-\f
-(define (expand-fields fields early? environment)
- (if (pair? fields)
- (call-with-values
- (lambda () (expand-fields (cdr fields) early? environment))
- (lambda (tail tail-size)
- (case (caar fields)
- ((BYTE)
- (call-with-values
- (lambda () (collect-byte (cdar fields) tail environment))
- (lambda (code size)
- (values code (+ size tail-size)))))
- ((OPERAND)
- (values `(,(close-syntax 'APPEND-SYNTAX! environment)
- ,(if early?
- `(,(close-syntax 'EA-VALUE-EARLY environment)
- ',(cadar fields)
- ,(caddar fields))
- `(,(close-syntax 'EA-VALUE environment)
- ,(caddar fields)))
- ,tail)
- tail-size))
- ;; Displacements are like signed bytes. They are a
- ;; different keyword to allow the disassembler to do its
- ;; thing correctly.
- ((DISPLACEMENT)
- (let* ((desc (cadar fields))
- (size (car desc)))
- (values `(,(close-syntax 'CONS-SYNTAX environment)
- ,(integer-syntaxer (cadr desc)
- environment
- 'SIGNED
- size)
- ,tail)
- (+ size tail-size))))
- ((IMMEDIATE)
- (values `(,(close-syntax 'CONS-SYNTAX environment)
- (,(close-syntax 'COERCE-TO-TYPE environment)
- ,(cadar fields)
- ,(close-syntax '*IMMEDIATE-TYPE* environment)
- ,(and (cddar fields)
- (eq? (caddar fields) 'UNSIGNED)))
- ,tail)
- tail-size))
- (else
- (error "Unknown field kind:" (caar fields))))))
- (values `'() 0)))
-
-(define (collect-byte components tail environment)
- (let inner ((components components))
- (if (pair? components)
- (call-with-values (lambda () (inner (cdr components)))
- (lambda (byte-tail byte-size)
- (let ((size (caar components))
- (expression (cadar components))
- (type (if (pair? (cddar components))
- (caddar components)
- 'UNSIGNED)))
- (values `(,(close-syntax 'CONS-SYNTAX environment)
- ,(integer-syntaxer expression environment type size)
- ,byte-tail)
- (+ size byte-size)))))
- (values tail 0))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; VAX Instruction Set Description, Part 1
-
-;;; The ordering is essentially that in "Vax Architecture Handbook" 1981.
-
-(declare (usual-integrations))
-\f
-;;;; REMARKS
-
-#|
-
-A) There are two types of operand specifiers:
-
- - General addressing mode operand specifier, with matching pattern syntax
-
- (? foo ea-<access-type>-<operand-type>)
-
- Access types and operand types are described on the "Vax Architecture
- Handbook", on Appendix E.
- They are implemented in insutl.scm
-
- - Immediate operands. The matching syntax is (? value). The operand
- is processed appropriately by the body of the instruction definition.
- It is used for instruction displacements (ie. the SOB instruction), or
- immediate operands (ie. the BUG instruction).
-
-B) The instruction set is currently incomplete. In particular, none
-of the instructions in chapters 14 or 16 are below. The missing
-opcodes are
-
-- Chap. 14: MOVC, MOVTC, MOVTUC, CMPC, SCANC, SPANC, LOCC, SKPC,
- MATCHC, CRC.
-
-- Chap. 16: EDITPC.
-
-|#
-\f
-;; Pseudo ops
-
-(define-instruction BYTE
- ((S (? value))
- (BYTE (8 value SIGNED)))
- ((U (? value))
- (BYTE (8 value UNSIGNED))))
-
-(define-instruction WORD
- ((S (? value))
- (BYTE (16 value SIGNED)))
- ((U (? value))
- (BYTE (16 value UNSIGNED))))
-
-(define-instruction LONG
- ((S (? value))
- (BYTE (32 value SIGNED)))
- ((U (? value))
- (BYTE (32 value UNSIGNED))))
-
-;;; Privilleged and miscellaneous (Chap. 10)
-
-(define-instruction CHM
- ((K (? code ea-r-w)) ; kernel
- (BYTE (8 #xBC))
- (OPERAND W code))
-
- ((E (? code ea-r-w)) ; executive
- (BYTE (8 #xBD))
- (OPERAND W code))
-
- ((S (? code ea-r-w)) ; supervisor
- (BYTE (8 #xBE))
- (OPERAND W code))
-
- ((U (? code ea-r-w)) ; user
- (BYTE (8 #xBF))
- (OPERAND W code)))
-
-(define-instruction PROBE
- ((R (? mode ea-r-b) (? len ea-r-w) (? base ea-a-b))
- (BYTE (8 #x0C))
- (OPERAND B mode)
- (OPERAND W len)
- (OPERAND B base))
-
- ((W (? mode ea-r-b) (? len ea-r-w) (? base ea-a-b))
- (BYTE (8 #x0D))
- (OPERAND B mode)
- (OPERAND W len)
- (OPERAND B base)))
-
-(define-trivial-instruction REI #x02)
-(define-trivial-instruction LDPCTX #x06)
-(define-trivial-instruction SVPCTX #x07)
-\f
-(define-instruction MTPR
- (((? src ea-r-l) (? procreg ea-r-l))
- (BYTE (8 #xDA))
- (OPERAND L src)
- (OPERAND L procreg)))
-
-(define-instruction MFPR
- (((? procreg ea-r-l) (? dst ea-w-l))
- (BYTE (8 #xDB))
- (OPERAND L procreg)
- (OPERAND L dst)))
-
-(define-trivial-instruction XFC #xFC)
-
-(define-trivial-instruction BPT #x03)
-
-(define-instruction BUG
- ((W (? message))
- (BYTE (16 #xFEFF))
- (BYTE (16 message)))
-
- ((L (? message))
- (BYTE (16 #xFDFF))
- (BYTE (32 message))))
-
-(define-trivial-instruction HALT #x00)
-\f
-;;;; Integer and floating point instructions (Chap. 11)
-
-(define-instruction MOV
- ((B (? src ea-r-b) (? dst ea-w-b))
- (BYTE (8 #x90))
- (OPERAND B src)
- (OPERAND B dst))
-
- ((W (? src ea-r-w) (? dst ea-w-w))
- (BYTE (8 #xB0))
- (OPERAND W src)
- (OPERAND W dst))
-
- ((L (? src ea-r-l) (? dst ea-w-l))
- (BYTE (8 #xD0))
- (OPERAND L src)
- (OPERAND L dst))
-
- ((Q (? src ea-r-q) (? dst ea-w-q))
- (BYTE (8 #x7D))
- (OPERAND Q src)
- (OPERAND Q dst))
-
- ((O (? src ea-r-o) (? dst ea-w-o))
- (BYTE (16 #x7DFD))
- (OPERAND O src)
- (OPERAND O dst))
-
- ((F (? src ea-r-f) (? dst ea-w-f))
- (BYTE (8 #x50))
- (OPERAND F src)
- (OPERAND F dst))
-
- ((D (? src ea-r-d) (? dst ea-w-d))
- (BYTE (8 #x70))
- (OPERAND D src)
- (OPERAND D dst))
-
- ((G (? src ea-r-g) (? dst ea-w-g))
- (BYTE (16 #x50FD))
- (OPERAND G src)
- (OPERAND G dst))
-
- ((H (? src ea-r-h) (? dst ea-w-h))
- (BYTE (16 #x70FD))
- (OPERAND H src)
- (OPERAND H dst)))
-
-(define-instruction PUSHL
- (((? src ea-r-l))
- (BYTE (8 #xDD))
- (OPERAND L src)))
-\f
-(define-instruction CLR
- ((B (? dst ea-w-b))
- (BYTE (8 #x94))
- (OPERAND B dst))
-
- ((W (? dst ea-w-w))
- (BYTE (8 #xB4))
- (OPERAND W dst))
-
- ((L (? dst ea-w-l))
- (BYTE (8 #xD4))
- (OPERAND L dst))
-
- ((F (? dst ea-w-f))
- (BYTE (8 #xD4))
- (OPERAND F dst))
-
- ((Q (? dst ea-w-q))
- (BYTE (8 #x7C))
- (OPERAND Q dst))
-
- ((D (? dst ea-w-d))
- (BYTE (8 #x7C))
- (OPERAND D dst))
-
- ((G (? dst ea-w-g))
- (BYTE (8 #x7C))
- (OPERAND G dst))
-
- ((O (? dst ea-w-o))
- (BYTE (16 #x7CFD))
- (OPERAND O dst))
-
- ((H (? dst ea-w-h))
- (BYTE (16 #x7CFD))
- (OPERAND H dst)))
-\f
-(define-instruction MNEG
- ((B (? src ea-r-b) (? dst ea-w-b))
- (BYTE (8 #x8E))
- (OPERAND B src)
- (OPERAND B dst))
-
- ((W (? src ea-r-w) (? dst ea-w-w))
- (BYTE (8 #xAE))
- (OPERAND W src)
- (OPERAND W dst))
-
- ((L (? src ea-r-l) (? dst ea-w-l))
- (BYTE (8 #xCE))
- (OPERAND L src)
- (OPERAND L dst))
-
- ((F (? src ea-r-f) (? dst ea-w-f))
- (BYTE (8 #x52))
- (OPERAND F src)
- (OPERAND F dst))
-
- ((D (? src ea-r-d) (? dst ea-w-d))
- (BYTE (8 #x72))
- (OPERAND F src)
- (OPERAND F dst))
-
- ((G (? src ea-r-g) (? dst ea-w-g))
- (BYTE (16 #x52FD))
- (OPERAND G src)
- (OPERAND G dst))
-
- ((H (? src ea-r-h) (? dst ea-w-h))
- (BYTE (16 #x72FD))
- (OPERAND H src)
- (OPERAND H dst)))
-
-(define-instruction MCOM
- ((B (? src ea-r-b) (? dst ea-w-b))
- (BYTE (8 #x92))
- (OPERAND B src)
- (OPERAND B dst))
-
- ((W (? src ea-r-w) (? dst ea-w-w))
- (BYTE (8 #xB2))
- (OPERAND W src)
- (OPERAND W dst))
-
- ((L (? src ea-r-l) (? dst ea-w-l))
- (BYTE (8 #xD2))
- (OPERAND L src)
- (OPERAND L dst)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; VAX Instruction Set Description, Part 2
-
-;;; The ordering is essentially that in "Vax Architecture Handbook" 1981.
-
-(declare (usual-integrations))
-\f
-(define-instruction CVT
- ((B W (? src ea-r-b) (? dst ea-w-w))
- (BYTE (8 #x99))
- (OPERAND B src)
- (OPERAND W dst))
-
- ((B L (? src ea-r-b) (? dst ea-w-l))
- (BYTE (8 #x98))
- (OPERAND B src)
- (OPERAND L dst))
-
- ((W B (? src ea-r-w) (? dst ea-w-b))
- (BYTE (8 #x33))
- (OPERAND W src)
- (OPERAND B dst))
-
- ((W L (? src ea-r-w) (? dst ea-w-l))
- (BYTE (8 #x32))
- (OPERAND W src)
- (OPERAND L dst))
-
- ((L B (? src ea-r-l) (? dst ea-w-b))
- (BYTE (8 #xF6))
- (OPERAND L src)
- (OPERAND B dst))
-
- ((L W (? src ea-r-l) (? dst ea-w-w))
- (BYTE (8 #xF7))
- (OPERAND L src)
- (OPERAND W dst))
-
- ((B F (? src ea-r-b) (? dst ea-w-f))
- (BYTE (8 #x4C))
- (OPERAND B src)
- (OPERAND F dst))
-
- ((B D (? src ea-r-b) (? dst ea-w-d))
- (BYTE (8 #x6C))
- (OPERAND B src)
- (OPERAND D dst))
-
- ((B G (? src ea-r-b) (? dst ea-w-g))
- (BYTE (16 #x4CFD))
- (OPERAND B src)
- (OPERAND G dst))
-
- ((B H (? src ea-r-b) (? dst ea-w-h))
- (BYTE (16 #x6CFD))
- (OPERAND B src)
- (OPERAND H dst))
-\f
- ((W F (? src ea-r-w) (? dst ea-w-f))
- (BYTE (8 #x4D))
- (OPERAND W src)
- (OPERAND F dst))
-
- ((W D (? src ea-r-w) (? dst ea-w-d))
- (BYTE (8 #x6D))
- (OPERAND W src)
- (OPERAND D dst))
-
- ((W G (? src ea-r-w) (? dst ea-w-g))
- (BYTE (16 #x4DFD))
- (OPERAND W src)
- (OPERAND G dst))
-
- ((W H (? src ea-r-w) (? dst ea-w-h))
- (BYTE (16 #x6DFD))
- (OPERAND W src)
- (OPERAND H dst))
-
- ((L F (? src ea-r-l) (? dst ea-w-f))
- (BYTE (8 #x4E))
- (OPERAND L src)
- (OPERAND F dst))
-
- ((L D (? src ea-r-l) (? dst ea-w-d))
- (BYTE (8 #x6E))
- (OPERAND L src)
- (OPERAND D dst))
-
- ((L G (? src ea-r-l) (? dst ea-w-g))
- (BYTE (16 #x4EFD))
- (OPERAND L src)
- (OPERAND G dst))
-
- ((L H (? src ea-r-l) (? dst ea-w-h))
- (BYTE (16 #x6EFD))
- (OPERAND L src)
- (OPERAND H dst))
-
- ((F B (? src ea-r-f) (? dst ea-w-b))
- (BYTE (8 #x48))
- (OPERAND F src)
- (OPERAND B dst))
-
- ((D B (? src ea-r-d) (? dst ea-w-b))
- (BYTE (8 #x68))
- (OPERAND D src)
- (OPERAND B dst))
-\f
- ((G B (? src ea-r-g) (? dst ea-w-b))
- (BYTE (16 #x48FD))
- (OPERAND G src)
- (OPERAND B dst))
-
- ((H B (? src ea-r-h) (? dst ea-w-b))
- (BYTE (16 #x68FD))
- (OPERAND H src)
- (OPERAND B dst))
-
- ((F W (? src ea-r-f) (? dst ea-w-w))
- (BYTE (8 #x49))
- (OPERAND F src)
- (OPERAND W dst))
-
- ((D W (? src ea-r-d) (? dst ea-w-w))
- (BYTE (8 #x69))
- (OPERAND D src)
- (OPERAND W dst))
-
- ((G W (? src ea-r-g) (? dst ea-w-w))
- (BYTE (16 #x49FD))
- (OPERAND G src)
- (OPERAND W dst))
-
- ((H W (? src ea-r-h) (? dst ea-w-w))
- (BYTE (16 #x69FD))
- (OPERAND H src)
- (OPERAND W dst))
-
- ((F L T (? src ea-r-f) (? dst ea-w-l))
- (BYTE (8 #x4A))
- (OPERAND F src)
- (OPERAND L dst))
-
- ((F L R (? src ea-r-f) (? dst ea-w-l))
- (BYTE (8 #x4B))
- (OPERAND F src)
- (OPERAND L dst))
-
- ((D L T (? src ea-r-d) (? dst ea-w-l))
- (BYTE (8 #x6A))
- (OPERAND D src)
- (OPERAND L dst))
-
- ((D L R (? src ea-r-d) (? dst ea-w-l))
- (BYTE (8 #x6B))
- (OPERAND D src)
- (OPERAND L dst))
-\f
- ((G L T (? src ea-r-g) (? dst ea-w-l))
- (BYTE (16 #x4AFD))
- (OPERAND G src)
- (OPERAND L dst))
-
- ((G L R (? src ea-r-g) (? dst ea-w-l))
- (BYTE (16 #x48FD))
- (OPERAND G src)
- (OPERAND L dst))
-
- ((H L T (? src ea-r-h) (? dst ea-w-l))
- (BYTE (16 #x6AFD))
- (OPERAND H src)
- (OPERAND L dst))
-
- ((H L R (? src ea-r-h) (? dst ea-w-l))
- (BYTE (16 #x6BFD))
- (OPERAND H src)
- (OPERAND L dst))
-
- ((F D (? src ea-r-f) (? dst ea-w-d))
- (BYTE (8 #x56))
- (OPERAND F src)
- (OPERAND D dst))
-
- ((F G (? src ea-r-f) (? dst ea-w-g))
- (BYTE (16 #x99FD))
- (OPERAND F src)
- (OPERAND G dst))
-
- ((F H (? src ea-r-f) (? dst ea-w-h))
- (BYTE (16 #x98FD))
- (OPERAND F src)
- (OPERAND H dst))
-
- ((D F (? src ea-r-d) (? dst ea-w-f))
- (BYTE (8 #x76))
- (OPERAND D src)
- (OPERAND F dst))
-
- ((D H (? src ea-r-d) (? dst ea-w-h))
- (BYTE (16 #x32FD))
- (OPERAND D src)
- (OPERAND H dst))
-
- ((G F (? src ea-r-g) (? dst ea-w-f))
- (BYTE (16 #x33FD))
- (OPERAND G src)
- (OPERAND F dst))
-
- ((G H (? src ea-r-g) (? dst ea-w-h))
- (BYTE (16 #x56FD))
- (OPERAND G src)
- (OPERAND H dst))
-\f
- ((H F (? src ea-r-h) (? dst ea-w-f))
- (BYTE (16 #xF6FD))
- (OPERAND H src)
- (OPERAND F dst))
-
- ((H D (? src ea-r-h) (? dst ea-w-d))
- (BYTE (16 #xF7FD))
- (OPERAND H src)
- (OPERAND D dst))
-
- ((H G (? src ea-r-h) (? dst ea-w-g))
- (BYTE (16 #x76FD))
- (OPERAND H src)
- (OPERAND G dst)))
-
-(define-instruction CMP
- ((B (? src1 ea-r-b) (? src2 ea-r-b))
- (BYTE (8 #x91))
- (OPERAND B src1)
- (OPERAND B src2))
-
- ((W (? src1 ea-r-w) (? src2 ea-r-w))
- (BYTE (8 #xB1))
- (OPERAND W src1)
- (OPERAND W src2))
-
- ((L (? src1 ea-r-l) (? src2 ea-r-l))
- (BYTE (8 #xD1))
- (OPERAND L src1)
- (OPERAND L src2))
-
- ((F (? src1 ea-r-f) (? src2 ea-r-f))
- (BYTE (8 #x51))
- (OPERAND F src1)
- (OPERAND F src2))
-
- ((D (? src1 ea-r-d) (? src2 ea-r-d))
- (BYTE (8 #x71))
- (OPERAND D src1)
- (OPERAND D src2))
-
- ((G (? src1 ea-r-g) (? src2 ea-r-g))
- (BYTE (16 #x51FD))
- (OPERAND G src1)
- (OPERAND G src2))
-
- ((H (? src1 ea-r-h) (? src2 ea-r-h))
- (BYTE (16 #x71FD))
- (OPERAND H src1)
- (OPERAND H src2)))
-\f
-(define-instruction MOVZ
- ((B W (? src ea-r-b) (? dst ea-w-w))
- (BYTE (8 #x9B))
- (OPERAND B src)
- (OPERAND W dst))
-
- ((B L (? src ea-r-b) (? dst ea-w-l))
- (BYTE (8 #x9A))
- (OPERAND B src)
- (OPERAND L dst))
-
- ((W L (? src ea-r-w) (? dst ea-w-l))
- (BYTE (8 #x3C))
- (OPERAND W src)
- (OPERAND L dst)))
-
-(define-instruction TST
- ((B (? src ea-r-b))
- (BYTE (8 #x95))
- (OPERAND B src))
-
- ((W (? src ea-r-w))
- (BYTE (8 #xB5))
- (OPERAND W src))
-
- ((L (? src ea-r-l))
- (BYTE (8 #xD5))
- (OPERAND L src))
-
- ((F (? src ea-r-f))
- (BYTE (8 #x53))
- (OPERAND F src))
-
- ((D (? src ea-r-d))
- (BYTE (8 #x73))
- (OPERAND D src))
-
- ((G (? src ea-r-g))
- (BYTE (16 #x53FD))
- (OPERAND G src))
-
- ((H (? src ea-r-h))
- (BYTE (16 #x73FD))
- (OPERAND H src)))
-\f
-(let-syntax
- ((define-arithmetic
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- ((B (? op ea-r-b) (? res ea-m-b))
- (BYTE (8 ,(+ #x80 (caddr form))))
- (OPERAND B op)
- (OPERAND B res))
-
- ((B (? op1 ea-r-b) (? op2 ea-r-b) (? res ea-w-b))
- (BYTE (8 ,(+ #x81 (caddr form))))
- (OPERAND B op1)
- (OPERAND B op2)
- (OPERAND B res))
-
- ((W (? op ea-r-w) (? res ea-m-w))
- (BYTE (8 ,(+ #xA0 (caddr form))))
- (OPERAND W op)
- (OPERAND W res))
-
- ((W (? op1 ea-r-w) (? op2 ea-r-w) (? res ea-w-w))
- (BYTE (8 ,(+ #xA1 (caddr form))))
- (OPERAND W op1)
- (OPERAND W op2)
- (OPERAND W res))
-
- ((L (? op ea-r-l) (? res ea-m-l))
- (BYTE (8 ,(+ #xC0 (caddr form))))
- (OPERAND L op)
- (OPERAND L res))
-
- ((L (? op1 ea-r-l) (? op2 ea-r-l) (? res ea-w-l))
- (BYTE (8 ,(+ #xC1 (caddr form))))
- (OPERAND L op1)
- (OPERAND L op2)
- (OPERAND L res))
-
- ((F (? op ea-r-f) (? res ea-m-f))
- (BYTE (8 ,(+ #x40 (caddr form))))
- (OPERAND F op)
- (OPERAND F res))
-
- ((F (? op1 ea-r-f) (? op2 ea-r-f) (? res ea-w-f))
- (BYTE (8 ,(+ #x41 (caddr form))))
- (OPERAND F op1)
- (OPERAND F op2)
- (OPERAND F res))
-
- ((D (? op ea-r-d) (? res ea-m-d))
- (BYTE (8 ,(+ #x60 (caddr form))))
- (OPERAND D op)
- (OPERAND D res))
-
- ((D (? op1 ea-r-d) (? op2 ea-r-d) (? res ea-w-d))
- (BYTE (8 ,(+ #x61 (caddr form))))
- (OPERAND D op1)
- (OPERAND D op2)
- (OPERAND D res))
-
- ((G (? op ea-r-g) (? res ea-m-g))
- (BYTE (16 ,(+ #x40FD (* (caddr form) #x100))))
- (OPERAND G op)
- (OPERAND G res))
-
- ((G (? op1 ea-r-g) (? op2 ea-r-g) (? res ea-w-g))
- (BYTE (16 ,(+ #x41FD (* (caddr form) #x100))))
- (OPERAND G op1)
- (OPERAND G op2)
- (OPERAND G res))
-
- ((H (? op ea-r-h) (? res ea-m-h))
- (BYTE (16 ,(+ #x60FD (* (caddr form) #x100))))
- (OPERAND H op)
- (OPERAND H res))
-
- ((H (? op1 ea-r-h) (? op2 ea-r-h) (? res ea-w-h))
- (BYTE (16 ,(+ #x61FD (* (caddr form) #x100))))
- (OPERAND H op1)
- (OPERAND H op2)
- (OPERAND H res)))))))
-
- (define-arithmetic ADD #x0)
- (define-arithmetic SUB #x2)
- (define-arithmetic MUL #x4)
- (define-arithmetic DIV #x6))
-
-(define-instruction ADAWI
- (((? add ea-r-w) (? sum ea-m-w))
- (BYTE (8 #x58))
- (OPERAND W add)
- (OPERAND W sum)))
-\f
-(define-instruction INC
- ((B (? sum ea-m-b))
- (BYTE (8 #x96))
- (OPERAND B sum))
-
- ((W (? sum ea-m-w))
- (BYTE (8 #xB6))
- (OPERAND W sum))
-
- ((L (? sum ea-m-l))
- (BYTE (8 #xD6))
- (OPERAND L sum)))
-
-(define-instruction DEC
- ((B (? dif ea-m-b))
- (BYTE (8 #x97))
- (OPERAND B dif))
-
- ((W (? dif ea-m-w))
- (BYTE (8 #xB7))
- (OPERAND W dif))
-
- ((L (? dif ea-m-l))
- (BYTE (8 #xD7))
- (OPERAND L dif)))
-
-(define-instruction ADWC
- (((? add ea-r-l) (? sum ea-m-l))
- (BYTE (8 #xD8))
- (OPERAND L add)
- (OPERAND L sum)))
-
-(define-instruction SBWC
- (((? sub ea-r-l) (? dif ea-m-l))
- (BYTE (8 #xD9))
- (OPERAND L sub)
- (OPERAND L dif)))
-
-(define-instruction EMUL
- (((? mul1 ea-r-l) (? mul2 ea-r-l) (? add ea-r-l) (? prod ea-w-q))
- (BYTE (8 #x7A))
- (OPERAND L mul1)
- (OPERAND L mul2)
- (OPERAND L add)
- (OPERAND Q prod)))
-
-(define-instruction EDIV
- (((? divr ea-r-l) (? divd ea-r-q) (? quo ea-w-l) (? rem ea-w-l))
- (BYTE (8 #x7B))
- (OPERAND L divr)
- (OPERAND Q divd)
- (OPERAND L quo)
- (OPERAND L rem)))
-\f
-(define-instruction EMOD
- ((F (? mulr ea-r-f) (? mulrx ea-r-b) (? muld ea-r-f)
- (? int ea-w-l) (? fract ea-w-f))
- (BYTE (8 #x54))
- (OPERAND F mulr)
- (OPERAND B mulrx)
- (OPERAND F muld)
- (OPERAND L int)
- (OPERAND F fract))
-
- ((D (? mulr ea-r-d) (? mulrx ea-r-b) (? muld ea-r-d)
- (? int ea-w-l) (? fract ea-w-d))
- (BYTE (8 #x74))
- (OPERAND D mulr)
- (OPERAND B mulrx)
- (OPERAND D muld)
- (OPERAND L int)
- (OPERAND D fract))
-
- ((G (? mulr ea-r-g) (? mulrx ea-r-w) (? muld ea-r-g)
- (? int ea-w-l) (? fract ea-w-g))
- (BYTE (16 #x54FD))
- (OPERAND G mulr)
- (OPERAND W mulrx)
- (OPERAND G muld)
- (OPERAND L int)
- (OPERAND G fract))
-
- ((H (? mulr ea-r-h) (? mulrx ea-r-w) (? muld ea-r-h)
- (? int ea-w-l) (? fract ea-w-h))
- (BYTE (16 #x74FD))
- (OPERAND H mulr)
- (OPERAND W mulrx)
- (OPERAND H muld)
- (OPERAND L int)
- (OPERAND H fract)))
-
-(define-instruction BIT
- ((B (? mask ea-r-b) (? src ea-r-b))
- (BYTE (8 #x93))
- (OPERAND B mask)
- (OPERAND B src))
-
- ((W (? mask ea-r-w) (? src ea-r-w))
- (BYTE (8 #xB3))
- (OPERAND W mask)
- (OPERAND W src))
-
- ((L (? mask ea-r-l) (? src ea-r-l))
- (BYTE (8 #xD3))
- (OPERAND L mask)
- (OPERAND L src)))
-\f
-(let-syntax
- ((define-bitwise
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- ((B (? mask ea-r-b) (? dst ea-m-b))
- (BYTE (8 ,(+ #x80 (caddr form))))
- (OPERAND B mask)
- (OPERAND B dst))
-
- ((B (? mask ea-r-b) (? src ea-r-b) (? dst ea-w-b))
- (BYTE (8 ,(+ #x81 (caddr form))))
- (OPERAND B mask)
- (OPERAND B src)
- (OPERAND B dst))
-
- ((W (? mask ea-r-w) (? dst ea-m-w))
- (BYTE (8 ,(+ #xA0 (caddr form))))
- (OPERAND W mask)
- (OPERAND W dst))
-
- ((W (? mask ea-r-w) (? src ea-r-w) (? dst ea-w-w))
- (BYTE (8 ,(+ #xA1 (caddr form))))
- (OPERAND W mask)
- (OPERAND W src)
- (OPERAND W dst))
-
- ((L (? mask ea-r-l) (? dst ea-m-l))
- (BYTE (8 ,(+ #xC0 (caddr form))))
- (OPERAND L mask)
- (OPERAND L dst))
-
- ((L (? mask ea-r-l) (? src ea-r-l) (? dst ea-w-l))
- (BYTE (8 ,(+ #xC1 (caddr form))))
- (OPERAND L mask)
- (OPERAND L src)
- (OPERAND L dst)))))))
-
- (define-bitwise BIS #x8)
- (define-bitwise BIC #xA)
- (define-bitwise XOR #xC))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; VAX Instruction Set Description, Part 3
-
-;;; The ordering is essentially that in "Vax Architecture Handbook" 1981.
-
-(declare (usual-integrations))
-\f
-(define-instruction ASH
- ((L (? cnt ea-r-b) (? src ea-r-l) (? dst ea-w-l))
- (BYTE (8 #x78))
- (OPERAND B cnt)
- (OPERAND L src)
- (OPERAND L dst))
-
- ((Q (? cnt ea-r-b) (? src ea-r-q) (? dst ea-w-q))
- (BYTE (8 #x79))
- (OPERAND B cnt)
- (OPERAND Q src)
- (OPERAND Q dst)))
-
-(define-instruction ROTL
- (((? cnt ea-r-b) (? src ea-r-l) (? dst ea-w-l))
- (BYTE (8 #x9C))
- (OPERAND B cnt)
- (OPERAND L src)
- (OPERAND L dst)))
-
-(define-instruction POLY
- ((F (? arg ea-r-f) (? degree ea-r-w) (? tbladdr ea-a-b))
- (BYTE (8 #x55))
- (OPERAND F arg)
- (OPERAND W degree)
- (OPERAND B tbladdr))
-
- ((D (? arg ea-r-d) (? degree ea-r-w) (? tbladdr ea-a-b))
- (BYTE (8 #x75))
- (OPERAND D arg)
- (OPERAND W degree)
- (OPERAND B tbladdr))
-
- ((G (? arg ea-r-g) (? degree ea-r-w) (? tbladdr ea-a-b))
- (BYTE (16 #x55FD))
- (OPERAND G arg)
- (OPERAND W degree)
- (OPERAND B tbladdr))
-
- ((H (? arg ea-r-h) (? degree ea-r-w) (? tbladdr ea-a-b))
- (BYTE (16 #x75FD))
- (OPERAND H arg)
- (OPERAND W degree)
- (OPERAND B tbladdr)))
-\f
-;;;; Special instructions (Chap. 12)
-
-(define-instruction PUSHR
- (((? mask ea-r-w))
- (BYTE (8 #xBB))
- (OPERAND W mask)))
-
-(define-instruction POPR
- (((? mask ea-r-w))
- (BYTE (8 #xBA))
- (OPERAND W mask)))
-
-(define-instruction MOVPSL
- (((? dst ea-w-l))
- (BYTE (8 #xDC))
- (OPERAND L dst)))
-
-(define-instruction BISPSW
- (((? mask ea-r-w))
- (BYTE (8 #xB8))
- (OPERAND W mask)))
-
-(define-instruction BICPSW
- (((? mask ea-r-w))
- (BYTE (8 #xB9))
- (OPERAND W mask)))
-\f
-(define-instruction MOVA
- ((B (? src ea-a-b) (? dst ea-w-l))
- (BYTE (8 #x9E))
- (OPERAND B src)
- (OPERAND L dst))
-
- ((W (? src ea-a-w) (? dst ea-w-l))
- (BYTE (8 #x3E))
- (OPERAND W src)
- (OPERAND L dst))
-
- ((L (? src ea-a-l) (? dst ea-w-l))
- (BYTE (8 #xDE))
- (OPERAND L src)
- (OPERAND L dst))
-
- ((F (? src ea-a-f) (? dst ea-w-l))
- (BYTE (8 #xDE))
- (OPERAND F src)
- (OPERAND L dst))
-
- ((Q (? src ea-a-q) (? dst ea-w-l))
- (BYTE (8 #x7E))
- (OPERAND Q src)
- (OPERAND L dst))
-
- ((D (? src ea-a-d) (? dst ea-w-l))
- (BYTE (8 #x7E))
- (OPERAND D src)
- (OPERAND L dst))
-
- ((G (? src ea-a-g) (? dst ea-w-l))
- (BYTE (8 #x7E))
- (OPERAND G src)
- (OPERAND L dst))
-
- ((H (? src ea-a-h) (? dst ea-w-l))
- (BYTE (16 #x7EFD))
- (OPERAND H src)
- (OPERAND L dst))
-
- ((O (? src ea-a-o) (? dst ea-w-l))
- (BYTE (16 #x7EFD))
- (OPERAND O src)
- (OPERAND L dst)))
-\f
-(define-instruction PUSHA
- ((B (? src ea-a-b))
- (BYTE (8 #x9F))
- (OPERAND B src))
-
- ((W (? src ea-a-w))
- (BYTE (8 #x3F))
- (OPERAND W src))
-
- ((L (? src ea-a-l))
- (BYTE (8 #xDF))
- (OPERAND L src))
-
- ((F (? src ea-a-f))
- (BYTE (8 #xDF))
- (OPERAND F src))
-
- ((Q (? src ea-a-q))
- (BYTE (8 #x7F))
- (OPERAND Q src))
-
- ((D (? src ea-a-d))
- (BYTE (8 #x7F))
- (OPERAND D src))
-
- ((G (? src ea-a-g))
- (BYTE (8 #x7F))
- (OPERAND G src))
-
- ((H (? src ea-a-h))
- (BYTE (16 #x7FFD))
- (OPERAND H src))
-
- ((O (? src ea-a-o))
- (BYTE (16 #x7FFD))
- (OPERAND O src)))
-\f
-;;; Array indeces and queues
-
-(define-instruction INDEX
- (((? subscript ea-r-l) (? low ea-r-l) (? high ea-r-l)
- (? size ea-r-l) (? indexin ea-r-l) (? indexout ea-w-l))
- (BYTE (8 #x0A))
- (OPERAND L subscript)
- (OPERAND L low)
- (OPERAND L high)
- (OPERAND L size)
- (OPERAND L indexin)
- (OPERAND L indexout)))
-
-(define-instruction INSQUE
- (((? entry ea-a-b) (? pred ea-a-b))
- (BYTE (8 #x0E))
- (OPERAND B entry)
- (OPERAND B pred)))
-
-(define-instruction REMQUE
- (((? entry ea-a-b) (? addr ea-w-l))
- (BYTE (8 #x0F))
- (OPERAND B entry)
- (OPERAND L addr)))
-
-(define-instruction INSQHI
- (((? entry ea-a-b) (? header ea-a-q))
- (BYTE (8 #x5C))
- (OPERAND B entry)
- (OPERAND Q header)))
-
-(define-instruction INSQTI
- (((? entry ea-a-b) (? header ea-a-q))
- (BYTE (8 #x5D))
- (OPERAND B entry)
- (OPERAND Q header)))
-
-(define-instruction REMQHI
- (((? header ea-a-q) (? addr ea-w-l))
- (BYTE (8 #x5E))
- (OPERAND Q header)
- (OPERAND L addr)))
-
-(define-instruction REMQTI
- (((? header ea-a-q) (? addr ea-w-l))
- (BYTE (8 #x5F))
- (OPERAND Q header)
- (OPERAND L addr)))
-\f
-;;; Bit field instructions
-
-(let-syntax
- ((define-field-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (let ((name (list-ref form 1))
- (suffix1 (list-ref form 2))
- (suffix2 (list-ref form 3))
- (opcode (list-ref form 4))
- (mode (list-ref form 5)))
- `(DEFINE-INSTRUCTION ,name
- ((,suffix1 (? pos ea-r-l) (? size ea-r-b) (? base ea-v-b)
- (? dst ,mode))
- (BYTE (8 ,opcode))
- (OPERAND L pos)
- (OPERAND B size)
- (OPERAND B base)
- (OPERAND L dst))
-
- ((,suffix2 (? pos ea-r-l) (? size ea-r-b) (? base ea-v-b)
- (? dst ,mode))
- (BYTE (8 ,(1+ opcode)))
- (OPERAND L pos)
- (OPERAND B size)
- (OPERAND B base)
- (OPERAND L dst))))))))
-
- (define-field-instruction FF S C #xEA ea-w-l)
- (define-field-instruction EXTV S Z #xEE ea-w-l)
- (define-field-instruction CMPV S Z #xEC ea-r-l))
-
-(define-instruction INSV
- (((? src ea-r-l) (? pos ea-r-l) (? size ea-r-b) (? base ea-v-b))
- (BYTE (8 #xF0))
- (OPERAND L src)
- (OPERAND L pos)
- (OPERAND B size)
- (OPERAND B base)))
-\f
-;;;; Control instructions (Chap. 13)
-
-;; The VAX only has byte offset conditional branch instructions.
-;; Longer displacements are obtained by negating the condition and
-;; branching over an unconditional instruction.
-
-(define-instruction B
- ((B (? c cc) (@PCO (? dest)))
- (BYTE (4 c) (4 #x1))
- (DISPLACEMENT (8 dest)))
-
- ((B (? c cc) (@PCR (? dest)))
- (BYTE (4 c) (4 #x1))
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1)))))
-
- ((W (? c inverse-cc) (@PCO (? dest)))
- (BYTE (4 c) (4 #x1)) ; (B B (~ cc) (+ *PC* 3))
- (BYTE (8 #x03 SIGNED))
- (BYTE (8 #x31)) ; (BR W dest)
- (DISPLACEMENT (16 dest)))
-
- ((W (? c inverse-cc) (@PCR (? dest)))
- (BYTE (4 c) (4 #x1)) ; (B B (~ cc) (+ *PC* 3))
- (BYTE (8 #x03 SIGNED))
- (BYTE (8 #x31)) ; (BR W dest)
- (DISPLACEMENT (16 `(- ,dest (+ *PC* 2)))))
-
- ;; Self adjusting version. It does not handle @PCO
- (((? c cc cs) (@PCR (? label)))
- (VARIABLE-WIDTH
- (disp `(- ,label (+ *PC* 2)))
- ((-128 127)
- (BYTE (4 c) (4 #x1))
- (BYTE (8 disp SIGNED)))
- ((-32765 32770)
- (BYTE (4 (inverse-cc cs)) (4 #x1)) ; (B B (~ cc) (+ *PC* 3))
- (BYTE (8 #x03))
- (BYTE (8 #x31)) ; (BR W label)
- (BYTE (16 (- disp 3) SIGNED)))
- ((() ())
- (BYTE (4 (inverse-cc cs)) (4 #x1)) ; (B B (~ cc) (+ *PC* 6))
- (BYTE (8 #x06))
- (BYTE (8 #x17)) ; (JMP (@PCO L label))
- (BYTE (4 15) (4 14))
- (BYTE (32 (- disp 6) SIGNED)))))
-
- (((? c cc cs) (@PCRO (? label) (? offset))) ; Kludge!
- (VARIABLE-WIDTH
- (disp `(+ ,offset (- ,label (+ *PC* 2))))
- ((-128 127)
- (BYTE (4 c) (4 #x1))
- (BYTE (8 disp SIGNED)))
- ((-32765 32770)
- (BYTE (4 (inverse-cc cs)) (4 #x1)) ; (B B (~ cc) (+ *PC* 3))
- (BYTE (8 #x03))
- (BYTE (8 #x31)) ; (BR W label)
- (BYTE (16 (- disp 3) SIGNED)))
- ((() ())
- (BYTE (4 (inverse-cc cs)) (4 #x1)) ; (B B (~ cc) (+ *PC* 6))
- (BYTE (8 #x06))
- (BYTE (8 #x17)) ; (JMP (@PCO L label))
- (BYTE (4 15) (4 14))
- (BYTE (32 (- disp 6) SIGNED))))))
-\f
-(let-syntax
- ((define-unconditional-transfer
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (let ((nameb (cadr form))
- (namej (caddr form))
- (bit (cadddr form)))
- `(BEGIN
- (DEFINE-INSTRUCTION ,nameb
- ((B (@PCO (? dest)))
- (BYTE (8 ,(+ #x10 bit)))
- (DISPLACEMENT (8 dest)))
-
- ((B (@PCR (? dest)))
- (BYTE (8 ,(+ #x10 bit)))
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1)))))
-
- ((W (@PCO (? dest)))
- (BYTE (8 ,(+ #x30 bit)))
- (DISPLACEMENT (16 dest)))
-
- ((W (@PCR (? dest)))
- (BYTE (8 ,(+ #x30 bit)))
- (DISPLACEMENT (16 `(- ,dest (+ *PC* 2)))))
-
- ;; Self tensioned version. @PCO not handled.
- (((@PCR (? label)))
- (VARIABLE-WIDTH
- (disp `(- ,label (+ *PC* 2)))
- ((-128 127) ; (BR/BSB B label)
- (BYTE (8 ,(+ #x10 bit)))
- (BYTE (8 disp SIGNED)))
- ((-32767 32768) ; (BR/BSB W label)
- (BYTE (8 ,(+ #x30 bit)))
- (BYTE (16 (- disp 1) SIGNED)))
- ((() ()) ; (JMP/JSB (@PCO L label))
- (BYTE (8 ,(+ #x16 bit)))
- (BYTE (4 15)
- (4 14))
- (BYTE (32 (- disp 4) SIGNED)))))
-
- (((@PCRO (? label) (? offset))) ; Kludge!
- (VARIABLE-WIDTH
- (disp `(+ ,offset (- ,label (+ *PC* 2))))
- ((-128 127) ; (BR/BSB B label)
- (BYTE (8 ,(+ #x10 bit)))
- (BYTE (8 disp SIGNED)))
- ((-32767 32768) ; (BR/BSB W label)
- (BYTE (8 ,(+ #x30 bit)))
- (BYTE (16 (- disp 1) SIGNED)))
- ((() ()) ; (JMP/JSB (@PCO L label))
- (BYTE (8 ,(+ #x16 bit)))
- (BYTE (4 15)
- (4 14))
- (BYTE (32 (- disp 4) SIGNED))))))
-
- (DEFINE-INSTRUCTION ,namej
- (((? dst ea-a-b))
- (BYTE (8 ,(+ #x16 bit)))
- (OPERAND B dst)))))))))
-
- (define-unconditional-transfer BR JMP #x1)
- (define-unconditional-transfer BSB JSB #x0))
-\f
-(define-trivial-instruction RSB #x05)
-
-(define-instruction CALLG
- (((? arglist ea-a-b) (? dst ea-a-b))
- (BYTE (8 #xFA))
- (OPERAND B arglist)
- (OPERAND B dst)))
-
-(define-instruction CALLS
- (((? narg ea-r-l) (? dst ea-a-b))
- (BYTE (8 #xFB))
- (OPERAND L narg)
- (OPERAND B dst)))
-
-(define-trivial-instruction RET #x04)
-
-(define-instruction BLB
- ((S (? src ea-r-l) (@PCO (? dest)))
- (BYTE (8 #xE8))
- (OPERAND L src)
- (DISPLACEMENT (8 dest)))
-
- ((S (? src ea-r-l) (@PCR (? dest)))
- (BYTE (8 #xE8))
- (OPERAND L src)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1)))))
-
- ((C (? src ea-r-l) (@PCO (? dest)))
- (BYTE (8 #xE9))
- (OPERAND L src)
- (DISPLACEMENT (8 dest)))
-
- ((C (? src ea-r-l) (@PCR (? dest)))
- (BYTE (8 #xE9))
- (OPERAND L src)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1))))))
-\f
-(define-instruction BB
- ((S (? pos ea-r-l) (? base ea-v-b) (@PCO (? dest)))
- (BYTE (8 #xE0))
- (OPERAND L pos)
- (OPERAND B base)
- (DISPLACEMENT (8 dest)))
-
- ((S (? pos ea-r-l) (? base ea-v-b) (@PCR (? dest)))
- (BYTE (8 #xE0))
- (OPERAND L pos)
- (OPERAND B base)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1)))))
-
- ((C (? pos ea-r-l) (? base ea-v-b) (@PCO (? dest)))
- (BYTE (8 #xE1))
- (OPERAND L pos)
- (OPERAND B base)
- (DISPLACEMENT (8 dest)))
-
- ((C (? pos ea-r-l) (? base ea-v-b) (@PCR (? dest)))
- (BYTE (8 #xE1))
- (OPERAND L pos)
- (OPERAND B base)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1)))))
-
- ((S S (? pos ea-r-l) (? base ea-v-b) (@PCO (? dest)))
- (BYTE (8 #xE2))
- (OPERAND L pos)
- (OPERAND B base)
- (DISPLACEMENT (8 dest)))
-
- ((S S (? pos ea-r-l) (? base ea-v-b) (@PCR (? dest)))
- (BYTE (8 #xE2))
- (OPERAND L pos)
- (OPERAND B base)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1)))))
-
- ((C S (? pos ea-r-l) (? base ea-v-b) (@PCO (? dest)))
- (BYTE (8 #xE3))
- (OPERAND L pos)
- (OPERAND B base)
- (DISPLACEMENT (8 dest)))
-
- ((C S (? pos ea-r-l) (? base ea-v-b) (@PCR (? dest)))
- (BYTE (8 #xE3))
- (OPERAND L pos)
- (OPERAND B base)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1)))))
-
- ((S C (? pos ea-r-l) (? base ea-v-b) (@PCO (? dest)))
- (BYTE (8 #xE4))
- (OPERAND L pos)
- (OPERAND B base)
- (DISPLACEMENT (8 dest)))
-
- ((S C (? pos ea-r-l) (? base ea-v-b) (@PCR (? dest)))
- (BYTE (8 #xE4))
- (OPERAND L pos)
- (OPERAND B base)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1)))))
-
- ((C C (? pos ea-r-l) (? base ea-v-b) (@PCO (? dest)))
- (BYTE (8 #xE5))
- (OPERAND L pos)
- (OPERAND B base)
- (DISPLACEMENT (8 dest)))
-
- ((C C (? pos ea-r-l) (? base ea-v-b) (@PCR (? dest)))
- (BYTE (8 #xE5))
- (OPERAND L pos)
- (OPERAND B base)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1)))))
-
- ((S S I (? pos ea-r-l) (? base ea-v-b) (@PCO (? dest)))
- (BYTE (8 #xE6))
- (OPERAND L pos)
- (OPERAND B base)
- (DISPLACEMENT (8 dest)))
-
- ((S S I (? pos ea-r-l) (? base ea-v-b) (@PCR (? dest)))
- (BYTE (8 #xE6))
- (OPERAND L pos)
- (OPERAND B base)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1)))))
-
- ((C C I (? pos ea-r-l) (? base ea-v-b) (@PCO (? dest)))
- (BYTE (8 #xE7))
- (OPERAND L pos)
- (OPERAND B base)
- (DISPLACEMENT (8 dest)))
-
- ((C C I (? pos ea-r-l) (? base ea-v-b) (@PCR (? dest)))
- (BYTE (8 #xE7))
- (OPERAND L pos)
- (OPERAND B base)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1))))))
-\f
-(define-instruction ACB
- ((B (? limit ea-r-b) (? add ea-r-b) (? index ea-m-b) (@PCO (? dest)))
- (BYTE (8 #x9D))
- (OPERAND B limit)
- (OPERAND B add)
- (OPERAND B index)
- (DISPLACEMENT (8 dest)))
-
- ((B (? limit ea-r-b) (? add ea-r-b) (? index ea-m-b) (@PCR (? dest)))
- (BYTE (8 #x9D))
- (OPERAND B limit)
- (OPERAND B add)
- (OPERAND B index)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1)))))
-
- ((W (? limit ea-r-w) (? add ea-r-w) (? index ea-m-w) (@PCO (? dest)))
- (BYTE (8 #x3D))
- (OPERAND W limit)
- (OPERAND W add)
- (OPERAND W index)
- (DISPLACEMENT (8 dest)))
-
- ((W (? limit ea-r-w) (? add ea-r-w) (? index ea-m-w) (@PCR (? dest)))
- (BYTE (8 #x3D))
- (OPERAND W limit)
- (OPERAND W add)
- (OPERAND W index)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1)))))
-
- ((L (? limit ea-r-l) (? add ea-r-l) (? index ea-m-l) (@PCO (? dest)))
- (BYTE (8 #xF1))
- (OPERAND L limit)
- (OPERAND L add)
- (OPERAND L index)
- (DISPLACEMENT (8 dest)))
-
- ((L (? limit ea-r-l) (? add ea-r-l) (? index ea-m-l) (@PCR (? dest)))
- (BYTE (8 #xF1))
- (OPERAND L limit)
- (OPERAND L add)
- (OPERAND L index)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1)))))
-
- ((F (? limit ea-r-f) (? add ea-r-f) (? index ea-m-f) (@PCO (? dest)))
- (BYTE (8 #x4F))
- (OPERAND F limit)
- (OPERAND F add)
- (OPERAND F index)
- (DISPLACEMENT (8 dest)))
-
- ((F (? limit ea-r-f) (? add ea-r-f) (? index ea-m-f) (@PCR (? dest)))
- (BYTE (8 #x4F))
- (OPERAND F limit)
- (OPERAND F add)
- (OPERAND F index)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1)))))
-
- ((D (? limit ea-r-d) (? add ea-r-d) (? index ea-m-d) (@PCO (? dest)))
- (BYTE (8 #x6F))
- (OPERAND D limit)
- (OPERAND D add)
- (OPERAND D index)
- (DISPLACEMENT (8 dest)))
-
- ((D (? limit ea-r-d) (? add ea-r-d) (? index ea-m-d) (@PCR (? dest)))
- (BYTE (8 #x6F))
- (OPERAND D limit)
- (OPERAND D add)
- (OPERAND D index)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1)))))
-
- ((G (? limit ea-r-g) (? add ea-r-g) (? index ea-m-g) (@PCO (? dest)))
- (BYTE (16 #x4FFD))
- (OPERAND G limit)
- (OPERAND G add)
- (OPERAND G index)
- (DISPLACEMENT (8 dest)))
-
- ((G (? limit ea-r-g) (? add ea-r-g) (? index ea-m-g) (@PCR (? dest)))
- (BYTE (16 #x4FFD))
- (OPERAND G limit)
- (OPERAND G add)
- (OPERAND G index)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1)))))
-
- ((H (? limit ea-r-h) (? add ea-r-h) (? index ea-m-h) (@PCO (? dest)))
- (BYTE (16 #x6FFD))
- (OPERAND H limit)
- (OPERAND H add)
- (OPERAND H index)
- (DISPLACEMENT (8 dest)))
-
- ((H (? limit ea-r-h) (? add ea-r-h) (? index ea-m-h) (@PCR (? dest)))
- (BYTE (16 #x6FFD))
- (OPERAND H limit)
- (OPERAND H add)
- (OPERAND H index)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1))))))
-\f
-(define-instruction AOB
- ((LSS (? limit ea-r-l) (? index ea-m-l) (@PCO (? dest)))
- (BYTE (8 #xF2))
- (OPERAND L limit)
- (OPERAND L index)
- (DISPLACEMENT (8 dest)))
-
- ((LSS (? limit ea-r-l) (? index ea-m-l) (@PCR (? dest)))
- (BYTE (8 #xF2))
- (OPERAND L limit)
- (OPERAND L index)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1)))))
-
- ((LEQ (? limit ea-r-l) (? index ea-m-l) (@PCO (? dest)))
- (BYTE (8 #xF3))
- (OPERAND L limit)
- (OPERAND L index)
- (DISPLACEMENT (8 dest)))
-
- ((LEQ (? limit ea-r-l) (? index ea-m-l) (@PCR (? dest)))
- (BYTE (8 #xF3))
- (OPERAND L limit)
- (OPERAND L index)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1))))))
-
-(define-instruction SOB
- ((GEQ (? index ea-m-l) (@PCO (? dest)))
- (BYTE (8 #xF4))
- (OPERAND L index)
- (DISPLACEMENT (8 dest)))
-
- ((GEQ (? index ea-m-l) (@PCR (? dest)))
- (BYTE (8 #xF4))
- (OPERAND L index)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1)))))
-
- ((GTR (? index ea-m-l) (@PCO (? dest)))
- (BYTE (8 #xF5))
- (OPERAND L index)
- (DISPLACEMENT (8 dest)))
-
- ((GTR (? index ea-m-l) (@PCR (? dest)))
- (BYTE (8 #xF5))
- (OPERAND L index)
- (DISPLACEMENT (8 `(- ,dest (+ *PC* 1))))))
-\f
-;; NOTE: The displacements must be placed separately on the
-;; instruction stream after the instruction.
-;;
-;; For example:
-;;
-;; (CASE B (R 0) (& 5) (& 2))
-;; (LABEL case-begin)
-;; (WORD `(- case-5 case-begin))
-;; (WORD `(- case-6 case-begin))
-;; (WORD `(- case-7 case-begin))
-;; <fall through if out of range>
-
-(define-instruction CASE
- ((B (? selector ea-r-b) (? base ea-r-b) (? limit ea-r-b))
- (BYTE (8 #x8F))
- (OPERAND B selector)
- (OPERAND B base)
- (OPERAND B limit))
-
- ((W (? selector ea-r-w) (? base ea-r-w) (? limit ea-r-w))
- (BYTE (8 #xAF))
- (OPERAND W selector)
- (OPERAND W base)
- (OPERAND W limit))
-
- ((L (? selector ea-r-l) (? base ea-r-l) (? limit ea-r-l))
- (BYTE (8 #xCF))
- (OPERAND L selector)
- (OPERAND L base)
- (OPERAND L limit)))
-\f
-;;;; BCD instructions (Chap 15.)
-
-(let-syntax
- ((define-add/sub-bcd-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (let ((opcode4 (caddr form)))
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? oplen ea-r-w) (? op ea-a-b)
- (? reslen ea-r-w) (? res ea-a-b))
- (BYTE (8 ,opcode4))
- (OPERAND W oplen)
- (OPERAND B op)
- (OPERAND W reslen)
- (OPERAND B res))
-
- (((? op1len ea-r-w) (? op1 ea-a-b)
- (? op2len ea-r-w) (? op2 ea-a-b)
- (? reslen ea-r-w) (? res ea-a-b))
- (BYTE (8 ,(1+ opcode4)))
- (OPERAND W op1len)
- (OPERAND B op1)
- (OPERAND W op2len)
- (OPERAND B op2)
- (OPERAND W reslen)
- (OPERAND B res))))))))
-
- (define-add/sub-bcd-instruction ADDP #x20)
- (define-add/sub-bcd-instruction SUBP #x22))
-
-(let-syntax
- ((define-add/sub-bcd-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? op1len ea-r-w) (? op1 ea-a-b)
- (? op2len ea-r-w) (? op2 ea-a-b)
- (? reslen ea-r-w) (? res ea-a-b))
- (BYTE (8 ,(caddr form)))
- (OPERAND W op1len)
- (OPERAND B op1)
- (OPERAND W op2len)
- (OPERAND B op2)
- (OPERAND W reslen)
- (OPERAND B res)))))))
-
- (define-add/sub-bcd-instruction MULP #x25)
- (define-add/sub-bcd-instruction DIVP #x27))
-\f
-(define-instruction CMPP
- (((? len ea-r-w) (? src1 ea-a-b) (? src2 ea-a-b))
- (BYTE (8 #x35))
- (OPERAND W len)
- (OPERAND B src1)
- (OPERAND B src2))
-
- (((? len1 ea-r-w) (? src1 ea-a-b) (? len2 ea-r-w) (? src2 ea-a-b))
- (BYTE (8 #x37))
- (OPERAND W len1)
- (OPERAND B src1)
- (OPERAND W len2)
- (OPERAND B src2)))
-
-(define-instruction ASHP
- (((? srclen ea-r-w) (? src ea-a-b)
- (? round ea-r-b)
- (? dstlen ea-r-w) (? dst ea-a-b))
- (BYTE (8 #xF8))
- (OPERAND W srclen)
- (OPERAND B src)
- (OPERAND B round)
- (OPERAND W dstlen)
- (OPERAND B dst)))
-
-(define-instruction MOVP
- (((? len ea-r-w) (? src ea-a-b) (? dst ea-a-b))
- (BYTE (8 #x34))
- (OPERAND W len)
- (OPERAND B src)
- (OPERAND B dst)))
-\f
-(define-instruction CVTLP
- (((? src ea-r-l) (? len ea-r-w) (? dst ea-a-b))
- (BYTE (8 #xF9))
- (OPERAND L src)
- (OPERAND W len)
- (OPERAND B dst)))
-
-(define-instruction CVTPL
- (((? len ea-r-w) (? src ea-a-b) (? dst ea-w-l))
- (BYTE (8 #x36))
- (OPERAND W len)
- (OPERAND B src)
- (OPERAND L dst)))
-
-(let-syntax
- ((define-cvt-trailing-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? srclen ea-r-w) (? src ea-a-b)
- (? tbl ea-a-b)
- (? dstlen ea-r-w) (? dst ea-a-b))
- (BYTE (8 ,(caddr form)))
- (OPERAND W srclen)
- (OPERAND B src)
- (OPERAND B tbl)
- (OPERAND W dstlen)
- (OPERAND B dst)))))))
-
- (define-cvt-trailing-instruction CVTPT #x24)
- (define-cvt-trailing-instruction CVTTT #x26))
-
-(let-syntax
- ((define-cvt-separate-instruction
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INSTRUCTION ,(cadr form)
- (((? srclen ea-r-w) (? src ea-a-b)
- (? dstlen ea-r-w) (? dst ea-a-b))
- (BYTE (8 ,(caddr form)))
- (OPERAND W srclen)
- (OPERAND B src)
- (OPERAND W dstlen)
- (OPERAND B dst)))))))
-
- (define-cvt-separate-instruction CVTPS #x08)
- (define-cvt-separate-instruction CVTSP #x09))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; VAX utility procedures
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Effective Addressing
-
-;;; *** NOTE: If this format changes, inerly.scm must also be changed! ***
-
-(define ea-tag
- "Effective-Address")
-
-(define (make-effective-address keyword categories value)
- (vector ea-tag keyword categories value))
-
-(define (effective-address? object)
- (and (vector? object)
- (not (zero? (vector-length object)))
- (eq? (vector-ref object 0) ea-tag)))
-
-(define-integrable (ea-keyword ea)
- (vector-ref ea 1))
-
-(define-integrable (ea-categories ea)
- (vector-ref ea 2))
-
-(define-integrable (ea-value ea)
- (vector-ref ea 3))
-
-;; For completeness
-
-(define (ea-keyword-early ea)
- (vector-ref ea 1))
-
-(define (ea-categories-early ea)
- (vector-ref ea 2))
-
-(define (ea-value-early ea)
- (vector-ref ea 3))
-\f
-;;;; Addressing modes
-
-(define-ea-database
- ((S (? value))
- (R)
- (BYTE (6 value)
- (2 0)))
-
- ((X (? n) (? base ea-i-?))
- (R M W V)
- (BYTE (4 n)
- (4 4))
- (OPERAND ? base))
-
- ((R (? n))
- (R M W V)
- (BYTE (4 n)
- (4 5)))
-
- ((@R (? n))
- (R M W A V I)
- (BYTE (4 n)
- (4 6)))
-
- ((@-R (? n))
- (R M W A V I)
- (BYTE (4 n)
- (4 7)))
-
- ((@R+ (? n))
- (R M W A V I)
- (BYTE (4 n)
- (4 8)))
-
- ((@@R+ (? n))
- (R M W A V I)
- (BYTE (4 n)
- (4 9)))
-\f
- ((@RO B (? n) (? off))
- (R M W A V I)
- (BYTE (4 n)
- (4 10))
- (BYTE (8 off SIGNED)))
-
- ((@@RO B (? n) (? off))
- (R M W A V I)
- (BYTE (4 n)
- (4 11))
- (BYTE (8 off SIGNED)))
-
- ((@RO W (? n) (? off))
- (R M W A V I)
- (BYTE (4 n)
- (4 12))
- (BYTE (16 off SIGNED)))
-
- ((@@RO W (? n) (? off))
- (R M W A V I)
- (BYTE (4 n)
- (4 13))
- (BYTE (16 off SIGNED)))
-
- ((@RO L (? n) (? off))
- (R M W A V I)
- (BYTE (4 n)
- (4 14))
- (BYTE (32 off SIGNED)))
-
- ((@RO UL (? n) (? off)) ; Kludge
- (R M W A V I)
- (BYTE (4 n)
- (4 14))
- (BYTE (32 off UNSIGNED)))
-
- ((@@RO L (? n) (? off))
- (R M W A V I)
- (BYTE (4 n)
- (4 15))
- (BYTE (32 off SIGNED)))
-\f
- ((& (? value))
- (R M W A V I)
- (BYTE (4 15)
- (4 8))
- (IMMEDIATE value SIGNED))
-
- ((&U (? value)) ; Kludge
- (R M W A V I)
- (BYTE (4 15)
- (4 8))
- (IMMEDIATE value UNSIGNED))
-
- ((@& (? value)) ; Absolute
- (R M W A V I)
- (BYTE (4 15)
- (4 9))
- (BYTE (32 value)))
-
- ((@PCO B (? off))
- (R M W A V I)
- (BYTE (4 15)
- (4 10))
- (BYTE (8 off SIGNED)))
-
- ((@@PCO B (? off))
- (R M W A V I)
- (BYTE (4 15)
- (4 11))
- (BYTE (8 off SIGNED)))
-
- ((@PCO W (? off))
- (R M W A V I)
- (BYTE (4 15)
- (4 12))
- (BYTE (16 off SIGNED)))
-
- ((@@PCO W (? off))
- (R M W A V I)
- (BYTE (4 15)
- (4 13))
- (BYTE (16 off SIGNED)))
-
- ((@PCO L (? off))
- (R M W A V I)
- (BYTE (4 15)
- (4 14))
- (BYTE (32 off SIGNED)))
-
- ((@@PCO L (? off))
- (R M W A V I)
- (BYTE (4 15)
- (4 15))
- (BYTE (32 off SIGNED)))
-\f
- ;; Self adjusting modes
- ;; The ranges seem wrong, but are correct given that disp
- ;; must be adjusted for the longer modes.
-
- ((@PCR (? label))
- (R M W A V I)
- (VARIABLE-WIDTH
- (disp `(- ,label (+ *PC* 2)))
- ((-128 127) ; (@PCO B label)
- (BYTE (4 15)
- (4 10))
- (BYTE (8 disp SIGNED)))
- ((-32767 32768) ; (@PCO W label)
- (BYTE (4 15)
- (4 12))
- (BYTE (16 (- disp 1) SIGNED)))
- ((() ()) ; (@PCO L label)
- (BYTE (4 15)
- (4 14))
- (BYTE (32 (- disp 3) SIGNED)))))
-
- ((@@PCR (? label))
- (R M W A V I)
- (VARIABLE-WIDTH
- (disp `(- ,label (+ *PC* 2)))
- ((-128 127) ; (@@PCO B label)
- (BYTE (4 15)
- (4 11))
- (BYTE (8 disp SIGNED)))
- ((-32767 32768) ; (@@PCO W label)
- (BYTE (4 15)
- (4 13))
- (BYTE (16 (- disp 1) SIGNED)))
- ((() ()) ; (@@PCO L label)
- (BYTE (4 15)
- (4 15))
- (BYTE (32 (- disp 3) SIGNED)))))
-
- ((@PCRO (? label) (? offset)) ; Kludge
- (R M W A V I)
- (VARIABLE-WIDTH
- (disp `(+ ,offset (- ,label (+ *PC* 2))))
- ((-128 127) ; (@PCO B label)
- (BYTE (4 15)
- (4 10))
- (BYTE (8 disp UNSIGNED)))
- ((-32767 32768) ; (@PCO W label)
- (BYTE (4 15)
- (4 12))
- (BYTE (16 (- disp 1) UNSIGNED)))
- ((() ()) ; (@PCO L label)
- (BYTE (4 15)
- (4 14))
- (BYTE (32 (- disp 3) UNSIGNED))))))
-\f
-;;;; Effective address processing
-
-(define *immediate-type*)
-
-(define (process-ea expression type)
- (fluid-let ((*immediate-type*
- (if (eq? '? type) *immediate-type* type)))
- (let ((match (pattern-lookup ea-database expression)))
- (cond (match (match))
- ;; Guarantee idempotency for early instruction processing.
- ((effective-address? expression) expression)
- (else #F)))))
-
-(define (coerce-to-type expression type #!optional unsigned?)
- (let ((unsigned? (and (not (default-object? unsigned?))
- unsigned?)))
- (syntax-evaluation
- expression
- (case type
- ((B) (if unsigned? coerce-8-bit-unsigned coerce-8-bit-signed))
- ((W) (if unsigned? coerce-16-bit-unsigned coerce-16-bit-signed))
- ((L) (if unsigned? coerce-32-bit-unsigned coerce-32-bit-signed))
- ((D F G H L O Q)
- (error "coerce-to-type: Unimplemented type" type))
- (else (error "coerce-to-type: Unknown type" type))))))
-
-;;; Transformers
-
-(define-symbol-transformer cc
- (NEQ . #x2) (NEQU . #x2) (EQL . #x3) (EQLU . #x3)
- (GTR . #x4) (LEQ . #x5) (GEQ . #x8) (LSS . #x9) (GTRU . #xA) (LEQU . #xB)
- (VC . #xC) (VS . #xD) (GEQU . #xE) (CC . #xE) (LSSU . #xF) (CS . #xF))
-
-(define-symbol-transformer inverse-cc
- (NEQ . #x3) (NEQU . #x3) (EQL . #x2) (EQLU . #x2)
- (GTR . #x5) (LEQ . #x4) (GEQ . #x9) (LSS . #x8) (GTRU . #xB) (LEQU . #xA)
- (VC . #xD) (VS . #xC) (GEQU . #xF) (CC . #xF) (LSSU . #xE) (CS . #xE))
-
-(define-transformer displacement
- (lambda (expression)
- (and (pair? expression)
- (or (eq? (car expression) '@PCR)
- (eq? (car expression) '@PCO))
- expression)))
-\f
-;;;; Effective address transformers
-
-(define-ea-transformer ea-a-b a b)
-(define-ea-transformer ea-a-d a d)
-(define-ea-transformer ea-a-f a f)
-(define-ea-transformer ea-a-g a g)
-(define-ea-transformer ea-a-h a h)
-(define-ea-transformer ea-a-l a l)
-(define-ea-transformer ea-a-o a o)
-(define-ea-transformer ea-a-q a q)
-(define-ea-transformer ea-a-w a w)
-(define-ea-transformer ea-m-b m b)
-(define-ea-transformer ea-m-d m d)
-(define-ea-transformer ea-m-f m f)
-(define-ea-transformer ea-m-g m g)
-(define-ea-transformer ea-m-h m h)
-(define-ea-transformer ea-m-l m l)
-(define-ea-transformer ea-m-w m w)
-(define-ea-transformer ea-r-b r b)
-(define-ea-transformer ea-r-d r d)
-(define-ea-transformer ea-r-f r f)
-(define-ea-transformer ea-r-g r g)
-(define-ea-transformer ea-r-h r h)
-(define-ea-transformer ea-r-l r l)
-(define-ea-transformer ea-r-o r o)
-(define-ea-transformer ea-r-q r q)
-(define-ea-transformer ea-r-w r w)
-(define-ea-transformer ea-v-b v b)
-(define-ea-transformer ea-w-b w b)
-(define-ea-transformer ea-w-d w d)
-(define-ea-transformer ea-w-f w f)
-(define-ea-transformer ea-w-g w g)
-(define-ea-transformer ea-w-h w h)
-(define-ea-transformer ea-w-l w l)
-(define-ea-transformer ea-w-o w o)
-(define-ea-transformer ea-w-q w q)
-(define-ea-transformer ea-w-w w w)
-(define-ea-transformer ea-i-? i ?)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RTL Rules for DEC VAX.
-;;; Shared utilities and exports to the rest of the compiler.
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Register-Allocator Interface
-
-(define (reference->register-transfer source target)
- (if (and (effective-address/register? source)
- (= (lap:ea-R-register source) target))
- (LAP)
- (LAP (MOV L ,source ,(register-reference target)))))
-
-(define (register->register-transfer source target)
- (LAP ,@(machine->machine-register source target)))
-
-(define (home->register-transfer source target)
- (LAP ,@(pseudo->machine-register source target)))
-
-(define (register->home-transfer source target)
- (LAP ,@(machine->pseudo-register source target)))
-
-(define-integrable (pseudo-register-home register)
- (offset-reference regnum:regs-pointer
- (pseudo-register-offset register)))
-
-(define-integrable (sort-machine-registers registers)
- registers)
-
-(define available-machine-registers
- ;; r9 is value register.
- ;; r10 - r13 are taken up by Scheme.
- ;; r14 is sp and r15 is pc.
- (list r0 r1 r2 r3 r4 r5 r6 r7 r8))
-
-(define (register-type register)
- ;; This will have to be changed when floating point support is added.
- (if (or (machine-register? register)
- (register-value-class=word? register))
- 'GENERAL
- (error "unable to determine register type" register)))
-
-(define register-reference
- (let ((references (make-vector number-of-machine-registers)))
- (let loop ((i 0))
- (if (< i number-of-machine-registers)
- (begin
- (vector-set! references i (INST-EA (R ,i)))
- (loop (1+ i)))))
- (lambda (register)
- (vector-ref references register))))
-
-(define mask-reference
- (register-reference regnum:pointer-mask))
-
-(define (lap:make-label-statement label)
- (LAP (LABEL ,label)))
-
-(define (lap:make-unconditional-branch label)
- (LAP (BR (@PCR ,label)))) ; Unsized
-
-(define (lap:make-entry-point label block-start-label)
- block-start-label
- (LAP (ENTRY-POINT ,label)
- ,@(make-external-label expression-code-word label)))
-\f
-;;;; Basic Machine Instructions
-
-(define-integrable (pseudo->machine-register source target)
- (memory->machine-register (pseudo-register-home source) target))
-
-(define-integrable (machine->pseudo-register source target)
- (machine-register->memory source (pseudo-register-home target)))
-
-(define (pseudo-float? register)
- (and (pseudo-register? register)
- (value-class=float? (pseudo-register-value-class register))))
-
-(define (pseudo-word? register)
- (and (pseudo-register? register)
- (value-class=word? (pseudo-register-value-class register))))
-
-(define-integrable (machine->machine-register source target)
- (LAP (MOV L
- ,(register-reference source)
- ,(register-reference target))))
-
-(define-integrable (machine-register->memory source target)
- (LAP (MOV L
- ,(register-reference source)
- ,target)))
-
-(define-integrable (memory->machine-register source target)
- (LAP (MOV L
- ,source
- ,(register-reference target))))
-
-(define (byte-offset-reference register offset)
- (if (zero? offset)
- (INST-EA (@R ,register))
- (INST-EA (@RO ,(datum-size offset) ,register ,offset))))
-
-(define-integrable (offset-reference register offset)
- (byte-offset-reference register (* 4 offset)))
-
-(define-integrable (pseudo-register-offset register)
- ;; Offset into register block for temporary registers
- (+ (+ (* 16 4) (* 40 8))
- (* 2 (register-renumber register))))
-
-(define (datum-size datum)
- (cond ((<= -128 datum 127) 'B)
- ((<= -32768 datum 32767) 'W)
- (else 'L)))
-\f
-;;;; Utilities needed by the rules files.
-
-(define-integrable (standard-target-reference target)
- (delete-dead-registers!)
- (reference-target-alias! target 'GENERAL))
-
-(define-integrable (any-register-reference register)
- (standard-register-reference register false true))
-
-(define-integrable (standard-temporary-reference)
- (reference-temporary-register! 'GENERAL))
-
-;;; Assignments
-
-(define-integrable (convert-object/constant->register target constant
- rtconversion
- ctconversion)
- (let ((target (standard-target-reference target)))
- (if (non-pointer-object? constant)
- (ctconversion constant target)
- (rtconversion (constant->ea constant) target))))
-
-(define-integrable (convert-object/register->register target source conversion)
- ;; `conversion' often expands into multiple references to `target'.
- (with-register-copy-alias! source 'GENERAL target
- (lambda (target)
- (conversion target target))
- conversion))
-
-(define-integrable (convert-object/offset->register target address
- offset conversion)
- (let ((source (indirect-reference! address offset)))
- (conversion source
- (standard-target-reference target))))
-
-;;; Predicates
-
-(define (predicate/memory-operand? expression)
- (or (rtl:offset? expression)
- (and (rtl:post-increment? expression)
- (interpreter-stack-pointer?
- (rtl:post-increment-register expression)))))
-
-(define (predicate/memory-operand-reference expression)
- (case (rtl:expression-type expression)
- ((OFFSET) (offset->indirect-reference! expression))
- ((POST-INCREMENT) (INST-EA (@R+ 14)))
- (else (error "Illegal memory operand" expression))))
-
-(define (compare/register*register register-1 register-2 cc)
- (set-standard-branches! cc)
- (LAP (CMP L ,(any-register-reference register-1)
- ,(any-register-reference register-2))))
-
-(define (compare/register*memory register memory cc)
- (set-standard-branches! cc)
- (LAP (CMP L ,(any-register-reference register) ,memory)))
-
-(define (compare/memory*memory memory-1 memory-2 cc)
- (set-standard-branches! cc)
- (LAP (CMP L ,memory-1 ,memory-2)))
-\f
-;;;; Utilities needed by the rules files (contd.)
-
-;;; Interpreter and interface calls
-
-(define (interpreter-call-argument? expression)
- (or (rtl:register? expression)
- (rtl:constant? expression)
- (and (rtl:cons-pointer? expression)
- (rtl:machine-constant? (rtl:cons-pointer-type expression))
- (rtl:machine-constant? (rtl:cons-pointer-datum expression)))
- (and (rtl:offset? expression)
- (rtl:register? (rtl:offset-base expression)))))
-
-(define (interpreter-call-argument->machine-register! expression register)
- (let ((target (register-reference register)))
- (case (car expression)
- ((REGISTER)
- (load-machine-register! (rtl:register-number expression) register))
- ((CONSTANT)
- (LAP ,@(clear-registers! register)
- ,@(load-constant (rtl:constant-value expression) target)))
- ((CONS-POINTER)
- (LAP ,@(clear-registers! register)
- ,@(load-non-pointer (rtl:machine-constant-value
- (rtl:cons-pointer-type expression))
- (rtl:machine-constant-value
- (rtl:cons-pointer-datum expression))
- target)))
- ((OFFSET)
- (let ((source-reference (offset->indirect-reference! expression)))
- (LAP ,@(clear-registers! register)
- (MOV L ,source-reference ,target))))
- (else
- (error "Unknown expression type" (car expression))))))
-\f
-;;;; Utilities needed by the rules files (contd.)
-
-;;; Object structure.
-
-(define (cons-pointer/ea type-ea datum target)
- (LAP (ROTL (S ,scheme-datum-width) ,type-ea ,target)
- (BIS L ,datum ,target)))
-
-(define (cons-pointer/constant type datum target)
- (if (ea/same? datum target)
- (LAP (BIS L (&U ,(make-non-pointer-literal type 0)) ,target))
- (cons-pointer/ea (INST-EA (S ,type)) datum target)))
-
-(define (set-type/ea type-ea target)
- (LAP (INSV ,type-ea (S ,scheme-datum-width) (S ,scheme-type-width)
- ,target)))
-
-(define-integrable (set-type/constant type target)
- (set-type/ea (INST-EA (S ,type)) target))
-
-(define-integrable (extract-type source target)
- (LAP (EXTV Z (S ,scheme-datum-width) (S ,scheme-type-width)
- ,source ,target)))
-
-(define (object->type source target)
- (extract-type source target))
-
-(define-integrable (ct/object->type object target)
- (load-immediate (object-type object) target))
-
-(define (object->datum source target)
- (if (eq? source target)
- (LAP (BIC L ,mask-reference ,target))
- (LAP (BIC L ,mask-reference ,source ,target))))
-
-(define-integrable (ct/object->datum object target)
- (load-immediate (object-datum object) target))
-
-(define (object->address source target)
- (declare (integrate-operator object->datum))
- (object->datum source target))
-
-(define-integrable (ct/object->address object target)
- (declare (integrate-operator ct/object->datum))
- (ct/object->datum object target))
-
-(define (compare-type type ea)
- (set-standard-branches! 'EQL)
- (LAP (CMPV Z (S ,scheme-datum-width) (S ,scheme-type-width)
- ,ea ,(make-immediate type))))
-\f
-;;;; Utilities needed by the rules files (contd.)
-
-(define-integrable (ea/same? ea1 ea2)
- (equal? ea1 ea2))
-
-(define (ea/copy source target)
- (if (ea/same? source target)
- (LAP)
- (LAP (MOV L ,source ,target))))
-
-(define (increment/ea ea offset)
- (cond ((zero? offset)
- (LAP))
- ((= offset 1)
- (LAP (INC L ,ea)))
- ((= offset -1)
- (LAP (DEC L ,ea)))
- ((<= 0 offset 63)
- (LAP (ADD L (S ,offset) ,ea)))
- ((<= -63 offset 0)
- (LAP (SUB L (S ,(- 0 offset)) ,ea)))
- ((effective-address/register? ea)
- (let ((size (datum-size offset)))
- (if (not (eq? size 'L))
- (LAP (MOVA L (@RO ,size ,(lap:ea-R-register ea) ,offset)
- ,ea))
- (LAP (ADD L (& ,offset) ,ea)))))
- (else
- (LAP (ADD L (& ,offset) ,ea)))))
-
-(define (add-constant/ea source offset target)
- (if (ea/same? source target)
- (increment/ea target offset)
- (cond ((zero? offset)
- (LAP (MOV L ,source ,target)))
- ((<= 0 offset 63)
- (LAP (ADD L (S ,offset) ,source ,target)))
- ((<= -63 offset 0)
- (LAP (SUB L (S ,(- 0 offset)) ,source ,target)))
- ((effective-address/register? source)
- (let ((size (datum-size offset)))
- (if (not (eq? size 'L))
- (LAP (MOVA L (@RO ,size ,(lap:ea-R-register source) ,offset)
- ,target))
- (LAP (ADD L (& ,offset) ,source ,target)))))
- (else
- (LAP (ADD L (& ,offset) ,source ,target))))))
-
-(define-integrable (increment-rn rn value)
- (increment/ea (INST-EA (R ,rn)) value))
-\f
-;;;; Utilities needed by the rules files (contd.)
-
-;;; Constants
-
-(define (make-immediate value)
- (if (<= 0 value 63)
- (INST-EA (S ,value))
- (INST-EA (& ,value))))
-
-(define (constant->ea constant)
- (if (non-pointer-object? constant)
- (non-pointer->ea (object-type constant)
- (careful-object-datum constant))
- (INST-EA (@PCR ,(constant->label constant)))))
-
-(define (non-pointer->ea type datum)
- (if (and (zero? type)
- (<= 0 datum 63))
- (INST-EA (S ,datum))
- (INST-EA (&U ,(make-non-pointer-literal type datum)))))
-
-(define (load-constant constant target)
- (if (non-pointer-object? constant)
- (load-non-pointer (object-type constant)
- (object-datum constant)
- target)
- (LAP (MOV L (@PCR ,(constant->label constant)) ,target))))
-
-(define (load-non-pointer type datum target)
- (if (not (zero? type))
- (LAP (MOV L (&U ,(make-non-pointer-literal type datum)) ,target))
- (load-immediate datum target)))
-
-(define (load-immediate value target)
- (cond ((zero? value)
- (LAP (CLR L ,target)))
- ((<= 0 value 63)
- (LAP (MOV L (S ,value) ,target)))
- (else
- (let ((size (datum-size value)))
- (if (not (eq? size 'L))
- (LAP (CVT ,size L (& ,value) ,target))
- (LAP (MOV L (& ,value) ,target)))))))
-
-(define-integrable (load-rn value rn)
- (load-immediate value (INST-EA (R ,rn))))
-\f
-;;;; Utilities needed by the rules files (contd.)
-
-;;; Predicate utilities
-
-(define (set-standard-branches! condition-code)
- (set-current-branches!
- (lambda (label)
- (LAP (B ,condition-code (@PCR ,label))))
- (lambda (label)
- (LAP (B ,(invert-cc condition-code) (@PCR ,label))))))
-
-(define (test-byte n effective-address)
- (cond ((zero? n)
- (LAP (TST B ,effective-address)))
- ((<= 0 n 63)
- (LAP (CMP B ,effective-address (S ,n))))
- (else
- (LAP (CMP B ,effective-address (& ,n))))))
-
-(define (test-non-pointer type datum effective-address)
- (cond ((not (zero? type))
- (LAP (CMP L
- ,effective-address
- (&U ,(make-non-pointer-literal type datum)))))
- ((zero? datum)
- (LAP (TST L ,effective-address)))
- ((<= 0 datum 63)
- (LAP (CMP L ,effective-address (S ,datum))))
- (else
- (LAP (CMP L
- ,effective-address
- (&U ,(make-non-pointer-literal type datum)))))))
-
-(define (invert-cc condition-code)
- (cdr (or (assq condition-code
- '((NEQU . EQLU) (EQLU . NEQU)
- (NEQ . EQL) (EQL . NEQ)
- (GTR . LEQ) (LEQ . GTR)
- (GEQ . LSS) (LSS . GEQ)
- (VC . VS) (VS . VC)
- (CC . CS) (CS . CC)
- (GTRU . LEQU) (LEQU . GTRU)
- (GEQU . LSSU) (LSSU . GEQU)))
- (error "INVERT-CC: Not a known CC" condition-code))))
-
-(define (invert-cc-noncommutative condition-code)
- ;; Despite the fact that the name of this procedure is similar to
- ;; that of `invert-cc', it is quite different. `invert-cc' is used
- ;; when the branches of a conditional are being exchanged, while
- ;; this is used when the arguments are being exchanged.
- (cdr (or (assq condition-code
- '((NEQU . NEQU) (EQLU . EQLU)
- (NEQ . NEQ) (EQL . EQL)
- (GTR . LSS) (LSS . GTR)
- (GEQ . LEQ) (LEQ . GEQ)
- ;; *** Are these two really correct? ***
- (VC . VC) (VS . VS)
- (CC . CC) (CS . CS)
- (GTRU . LSSU) (LSSU . GTRU)
- (GEQU . LEQU) (LEQU . GEQU)))
- (error "INVERT-CC-NONCOMMUTATIVE: Not a known CC" condition-code))))
-\f
-;;;; Utilities needed by the rules files (contd.)
-
-(define-integrable (effective-address/register? ea)
- (eq? (lap:ea-keyword ea) 'R))
-
-(define-integrable (effective-address/register-indirect? ea)
- (eq? (lap:ea-keyword ea) '@R))
-
-(define-integrable (effective-address/register-offset? ea)
- (eq? (lap:ea-keyword ea) '@RO))
-
-(define (offset->indirect-reference! offset)
- (indirect-reference! (rtl:register-number (rtl:offset-base offset))
- (rtl:offset-number offset)))
-
-(define-integrable (indirect-reference! register offset)
- (offset-reference (allocate-indirection-register! register) offset))
-
-(define-integrable (indirect-byte-reference! register offset)
- (byte-offset-reference (allocate-indirection-register! register) offset))
-
-(define (allocate-indirection-register! register)
- (load-alias-register! register 'GENERAL))
-
-(define (generate-n-times n limit instruction-gen with-counter)
- (if (> n limit)
- (let ((loop (generate-label 'LOOP)))
- (with-counter
- (lambda (counter)
- (LAP ,@(load-rn (-1+ n) counter)
- (LABEL ,loop)
- ,@(instruction-gen)
- (SOB GEQ (R ,counter) (@PCR ,loop))))))
- (let loop ((n n))
- (if (zero? n)
- (LAP)
- (LAP ,@(instruction-gen)
- ,@(loop (-1+ n)))))))
-\f
-;;;; Utilities needed by the rules files (contd.)
-
-;;; CHAR->ASCII utilities
-
-(define (coerce->any/byte-reference register)
- (if (machine-register? register)
- (register-reference register)
- (let ((alias (register-alias register false)))
- (if alias
- (register-reference alias)
- (indirect-char/ascii-reference!
- regnum:regs-pointer
- (pseudo-register-offset register))))))
-
-(define-integrable (indirect-char/ascii-reference! register offset)
- (indirect-byte-reference! register (* offset 4)))
-
-(define (char->signed-8-bit-immediate character)
- (let ((ascii (char->ascii character)))
- (if (< ascii 128)
- ascii
- (- ascii 256))))
-
-(define-integrable (lap:ea-keyword expression)
- (car expression))
-
-(define-integrable (lap:ea-R-register expression)
- (cadr expression))
-
-(define-integrable (lap:ea-@R-register expression)
- (cadr expression))
-
-(define-integrable (lap:ea-@RO-register expression)
- (caddr expression))
-
-(define-integrable (lap:ea-@RO-offset expression)
- (cadddr expression))
-\f
-;;;; Utilities needed by the rules files (contd.)
-
-;;; Layout of the Scheme register array.
-
-(define-integrable reg:compiled-memtop (INST-EA (@R 10)))
-(define-integrable reg:environment (INST-EA (@RO B 10 #x000C)))
-(define-integrable reg:temp (INST-EA (@RO B 10 #x0010)))
-(define-integrable reg:lexpr-primitive-arity (INST-EA (@RO B 10 #x001C)))
-(define-integrable reg:stack-guard (INST-EA (@RO B 10 #x002C)))
-
-(let-syntax ((define-codes
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(BEGIN
- ,@(let loop ((names (cddr form)) (index (cadr form)))
- (if (pair? names)
- (cons `(DEFINE-INTEGRABLE
- ,(symbol-append 'CODE:COMPILER-
- (car names))
- ,index)
- (loop (cdr names) (+ index 1)))
- '())))))))
- (define-codes #x012
- primitive-apply primitive-lexpr-apply
- apply error lexpr-apply link
- interrupt-closure interrupt-dlink interrupt-procedure
- interrupt-continuation interrupt-ic-procedure
- assignment-trap cache-reference-apply
- reference-trap safe-reference-trap unassigned?-trap
- -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero?
- access lookup safe-lookup unassigned? unbound?
- set! define lookup-apply))
-
-(let-syntax ((define-entries
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(BEGIN
- ,@(let loop ((names (cddr form)) (index (cadr form)))
- (if (pair? names)
- (cons `(DEFINE-INTEGRABLE
- ,(symbol-append 'ENTRY:COMPILER-
- (car names))
- (INST-EA (@RO B 10 ,index)))
- (loop (cdr names) (+ index 8)))
- '())))))))
- (define-entries #x40
- scheme-to-interface ; Main entry point (only one necessary)
- scheme-to-interface-jsb ; Used by rules3&4, for convenience.
- trampoline-to-interface ; Used by trampolines, for convenience.
- ;; If more are added, the size of the addressing mode must be changed.
- ))
-
-(define-integrable (invoke-interface code)
- (LAP ,@(load-rn code 0)
- (JMP ,entry:compiler-scheme-to-interface)))
-
-#|
-;; If the entry point scheme-to-interface-jsb were not available,
-;; this code should replace the definition below.
-;; The others can be handled similarly.
-
-(define-integrable (invoke-interface-jsb code)
- (LAP ,@(load-rn code 0)
- (MOVA B (@PCO B 10) (R 1))
- (JMP ,entry:compiler-scheme-to-interface)))
-|#
-
-(define-integrable (invoke-interface-jsb code)
- (LAP ,@(load-rn code 0)
- (JSB ,entry:compiler-scheme-to-interface-jsb)))
-
-
-(define (pre-lapgen-analysis rgraphs)
- rgraphs
- unspecific)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Optimizer for VAX.
-
-(declare (usual-integrations))
-
-(define (optimize-linear-lap instructions)
- instructions)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Machine Model for DEC Vax
-;;; package: (compiler)
-
-(declare (usual-integrations))
-\f
-;;;; Architecture Parameters
-
-(define use-pre/post-increment? true)
-(define-integrable endianness 'LITTLE)
-(define-integrable addressing-granularity 8)
-(define-integrable scheme-object-width 32)
-(define-integrable scheme-type-width 6) ;or 8
-
-;; NOTE: expt is not being constant-folded now.
-;; For the time being, some of the parameters below are
-;; pre-computed and marked with ***
-;; There are similar parameters in lapgen.scm
-;; Change them if any of the parameters above change.
-
-(define-integrable scheme-datum-width
- (- scheme-object-width scheme-type-width))
-
-(define-integrable float-width 64)
-(define-integrable float-alignment 32)
-
-(define-integrable address-units-per-float
- (quotient float-width addressing-granularity))
-
-;;; It is currently required that both packed characters and objects
-;;; be integrable numbers of address units. Furthermore, the number
-;;; of address units per object must be an integral multiple of the
-;;; number of address units per character. This will cause problems
-;;; on a machine that is word addressed: we will have to rethink the
-;;; character addressing strategy.
-
-(define-integrable address-units-per-object
- (quotient scheme-object-width addressing-granularity))
-
-(define-integrable address-units-per-packed-char 1)
-
-(define-integrable signed-fixnum/upper-limit
- ;; (expt 2 (-1+ scheme-datum-width)) ***
- 33554432)
-
-(define-integrable signed-fixnum/lower-limit
- (- signed-fixnum/upper-limit))
-
-(define-integrable unsigned-fixnum/upper-limit
- (* 2 signed-fixnum/upper-limit))
-
-(define-integrable (stack->memory-offset offset) offset)
-(define-integrable ic-block-first-parameter-offset 2)
-\f
-;; This must return a word based offset.
-;; On the VAX, to save space, entries can be at 2 mod 4 addresses,
-;; which makes it impossible if the closure object used for
-;; referencing points to arbitrary entries. Instead, all closure
-;; entry points bump to the canonical entry point, which is always
-;; longword aligned.
-;; On other machines (word aligned), it may be easier to bump back
-;; to each entry point, and the entry number `entry' would be part
-;; of the computation.
-
-(define (closure-first-offset nentries entry)
- entry ; ignored
- (if (zero? nentries)
- 1
- (quotient (+ (+ 3 1) (* 5 (- nentries 1))) 2)))
-
-;; This is from the start of the complete closure object,
-;; viewed as a vector, and including the header word.
-
-(define (closure-object-first-offset nentries)
- (case nentries
- ((0) 1)
- ((1) 4)
- (else
- (quotient (+ 5 (* 5 nentries)) 2))))
-
-;; Bump from one entry point to another.
-
-(define (closure-entry-distance nentries entry entry*)
- nentries ; ignored
- (* 10 (- entry* entry)))
-
-;; Bump to the canonical entry point.
-
-(define (closure-environment-adjustment nentries entry)
- (declare (integrate-operator closure-entry-distance))
- (closure-entry-distance nentries entry 0))
-\f
-(define-integrable r0 0) ; return value
-(define-integrable r1 1)
-(define-integrable r2 2)
-(define-integrable r3 3)
-(define-integrable r4 4)
-(define-integrable r5 5)
-(define-integrable r6 6)
-(define-integrable r7 7)
-(define-integrable r8 8)
-(define-integrable r9 9)
-(define-integrable r10 10)
-(define-integrable r11 11)
-(define-integrable r12 12) ; AP
-(define-integrable r13 13) ; FP
-(define-integrable r14 14) ; SP
-(define-integrable r15 15) ; PC, not really useable.
-
-(define number-of-machine-registers 16)
-(define number-of-temporary-registers 256)
-
-(define-integrable regnum:return-value r9)
-(define-integrable regnum:regs-pointer r10)
-(define-integrable regnum:pointer-mask r11)
-(define-integrable regnum:free-pointer r12)
-(define-integrable regnum:dynamic-link r13)
-(define-integrable regnum:stack-pointer r14)
-(define-integrable (machine-register-known-value register) register false)
-
-(define (machine-register-value-class register)
- (cond ((<= 0 register 9) value-class=object)
- ((= 11 register) value-class=immediate)
- ((<= 10 register 15) value-class=address)
- (else (error "illegal machine register" register))))
-\f
-;;;; RTL Generator Interface
-
-(define (interpreter-register:access)
- (rtl:make-machine-register r0))
-
-(define (interpreter-register:cache-reference)
- (rtl:make-machine-register r0))
-
-(define (interpreter-register:cache-unassigned?)
- (rtl:make-machine-register r0))
-
-(define (interpreter-register:lookup)
- (rtl:make-machine-register r0))
-
-(define (interpreter-register:unassigned?)
- (rtl:make-machine-register r0))
-
-(define (interpreter-register:unbound?)
- (rtl:make-machine-register r0))
-
-(define-integrable (interpreter-value-register)
- (rtl:make-machine-register regnum:return-value))
-
-(define (interpreter-value-register? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:return-value)))
-
-(define (interpreter-environment-register)
- (rtl:make-offset (interpreter-regs-pointer) 3))
-
-(define (interpreter-environment-register? expression)
- (and (rtl:offset? expression)
- (interpreter-regs-pointer? (rtl:offset-base expression))
- (= 3 (rtl:offset-number expression))))
-
-(define (interpreter-free-pointer)
- (rtl:make-machine-register regnum:free-pointer))
-
-(define (interpreter-free-pointer? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:free-pointer)))
-
-(define (interpreter-regs-pointer)
- (rtl:make-machine-register regnum:regs-pointer))
-
-(define (interpreter-regs-pointer? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:regs-pointer)))
-
-(define (interpreter-stack-pointer)
- (rtl:make-machine-register regnum:stack-pointer))
-
-(define (interpreter-stack-pointer? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:stack-pointer)))
-
-(define (interpreter-dynamic-link)
- (rtl:make-machine-register regnum:dynamic-link))
-
-(define (interpreter-dynamic-link? expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression) regnum:dynamic-link)))
-\f
-(define (rtl:machine-register? rtl-register)
- (case rtl-register
- ((STACK-POINTER)
- (interpreter-stack-pointer))
- ((DYNAMIC-LINK)
- (interpreter-dynamic-link))
- ((VALUE)
- (interpreter-value-register))
- ((FREE)
- (interpreter-free-pointer))
- ((INTERPRETER-CALL-RESULT:ACCESS)
- (interpreter-register:access))
- ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
- (interpreter-register:cache-reference))
- ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
- (interpreter-register:cache-unassigned?))
- ((INTERPRETER-CALL-RESULT:LOOKUP)
- (interpreter-register:lookup))
- ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
- (interpreter-register:unassigned?))
- ((INTERPRETER-CALL-RESULT:UNBOUND?)
- (interpreter-register:unbound?))
- (else
- false)))
-
-(define (rtl:interpreter-register? rtl-register)
- (case rtl-register
- ((MEMORY-TOP) 0)
- ((INT-MASK) 1)
- #| ((VALUE) 2) |#
- ((ENVIRONMENT) 3)
- ((TEMPORARY) 4)
- (else false)))
-
-(define (rtl:interpreter-register->offset locative)
- (or (rtl:interpreter-register? locative)
- (error "Unknown register type" locative)))
-
-(define (rtl:constant-cost expression)
- ;; Magic numbers
- ;; number of bytes for the instruction to construct/fetch into register.
- (let ((if-integer
- (lambda (value)
- (cond ((zero? value) 2)
- ((<= -63 value 63)
- 3)
- (else
- 7)))))
- (let ((if-synthesized-constant
- (lambda (type datum)
- (if-integer (make-non-pointer-literal type datum)))))
- (case (rtl:expression-type expression)
- ((CONSTANT)
- (let ((value (rtl:constant-value expression)))
- (if (non-pointer-object? value)
- (if-synthesized-constant (object-type value)
- (careful-object-datum value))
- 3)))
- ((MACHINE-CONSTANT)
- (if-integer (rtl:machine-constant-value expression)))
- ((ENTRY:PROCEDURE
- ENTRY:CONTINUATION
- ASSIGNMENT-CACHE
- VARIABLE-CACHE
- OFFSET-ADDRESS
- BYTE-OFFSET-ADDRESS)
- 4) ; assuming word offset
- ((CONS-POINTER)
- (and (rtl:machine-constant? (rtl:cons-pointer-type expression))
- (rtl:machine-constant? (rtl:cons-pointer-datum expression))
- (if-synthesized-constant
- (rtl:machine-constant-value (rtl:cons-pointer-type expression))
- (rtl:machine-constant-value
- (rtl:cons-pointer-datum expression)))))
- (else false)))))
-
-;;; Floating-point open-coding not implemented for VAXen.
-
-(define compiler:open-code-floating-point-arithmetic?
- false)
-
-(define compiler:primitives-with-no-open-coding
- '(DIVIDE-FIXNUM GCD-FIXNUM &/
- VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS
- FLOATING-VECTOR-REF FLOATING-VECTOR-SET! FLONUM-EXPM1 FLONUM-LOG1P))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Compiler: System Construction
-
-(declare (usual-integrations))
-
-((load "base/make") "VAX")
-((environment-lookup (->environment '(COMPILER DISASSEMBLER MACROS))
- 'INITIALIZE-PACKAGE!))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$MC68020-Header: rgspcm.scm,v 4.1 87/12/30 07:05:38 GMT cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RTL Generation: Special primitive combinations. VAX version.
-
-(declare (usual-integrations))
-\f
-(define (define-special-primitive-handler name handler)
- (let ((primitive (make-primitive-procedure name true)))
- (let ((entry (assq primitive special-primitive-handlers)))
- (if entry
- (set-cdr! entry handler)
- (set! special-primitive-handlers
- (cons (cons primitive handler)
- special-primitive-handlers)))))
- name)
-
-(define (special-primitive-handler primitive)
- (let ((entry (assq primitive special-primitive-handlers)))
- (and entry
- (cdr entry))))
-
-(define special-primitive-handlers
- '())
-
-(define (define-special-primitive/standard primitive)
- (define-special-primitive-handler primitive
- rtl:make-invocation:special-primitive))
-
-(define-special-primitive/standard '&+)
-(define-special-primitive/standard '&-)
-(define-special-primitive/standard '&*)
-(define-special-primitive/standard '&/)
-(define-special-primitive/standard '&=)
-(define-special-primitive/standard '&<)
-(define-special-primitive/standard '&>)
-(define-special-primitive/standard '1+)
-(define-special-primitive/standard '-1+)
-(define-special-primitive/standard 'zero?)
-(define-special-primitive/standard 'positive?)
-(define-special-primitive/standard 'negative?)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$MC68020-Header: rules1.scm,v 4.34 1991/01/23 21:34:30 jinx Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Data Transfers.
-;;; Note: All fixnum code is in rulfix.scm
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Register Assignments
-
-;;; All assignments to pseudo registers are required to delete the
-;;; dead registers BEFORE performing the assignment. However, it is
-;;; necessary to derive the effective address of the source
-;;; expression(s) before deleting the dead registers. Otherwise any
-;;; source expression containing dead registers might refer to aliases
-;;; which have been reused.
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
- (assign-register->register target source))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OFFSET-ADDRESS (REGISTER (? source)) (? n)))
- (load-displaced-register target source (* 4 n)))
-
-(define-rule statement
- ;; This is an intermediate rule -- not intended to produce code.
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (OFFSET-ADDRESS (REGISTER (? source)) (? n))))
- (load-displaced-register/typed target source type (* 4 n)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n)))
- (load-displaced-register target source n))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n))))
- (load-displaced-register/typed target source type n))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
- (convert-object/register->register target source object->type))
-\f
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum))))
- (cond ((register-copy-if-available datum 'GENERAL target)
- =>
- (lambda (get-datum-alias)
- (let* ((type (any-register-reference type))
- (datum&target (get-datum-alias)))
- (set-type/ea type datum&target))))
- ((register-copy-if-available type 'GENERAL target)
- =>
- (lambda (get-type-alias)
- (let* ((datum (any-register-reference datum))
- (type&target (get-type-alias)))
- (cons-pointer/ea type&target datum type&target))))
- (else
- (let* ((type (any-register-reference type))
- (datum (any-register-reference datum))
- (target (standard-target-reference target)))
- (cons-pointer/ea type datum target)))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum))))
- (if (zero? type)
- (assign-register->register target datum)
- (with-register-copy-alias! datum 'GENERAL target
- (lambda (alias)
- (set-type/constant type alias))
- (lambda (datum target)
- (cons-pointer/constant type datum target)))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
- (convert-object/register->register target source object->datum))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
- (convert-object/register->register target source object->address))
-\f
-;;;; Loading Constants
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
- (load-constant source (standard-target-reference target)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? n)))
- (load-immediate n (standard-target-reference target)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum))))
- (load-non-pointer type datum (standard-target-reference target)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label)))
- (load-pc-relative-address
- target
- (rtl-procedure/external-label (label->object label))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label)))
- (load-pc-relative-address target label))
-
-(define-rule statement
- ;; This is an intermediate rule -- not intended to produce code.
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (ENTRY:PROCEDURE (? label))))
- (load-pc-relative-address/typed target
- type
- (rtl-procedure/external-label
- (label->object label))))
-
-(define-rule statement
- ;; This is an intermediate rule -- not intended to produce code.
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (ENTRY:CONTINUATION (? label))))
- (load-pc-relative-address/typed target type label))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
- (load-pc-relative target (free-reference-label name)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name)))
- (load-pc-relative target (free-assignment-label name)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant))))
- (convert-object/constant->register target constant
- object->datum ct/object->datum))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (CONSTANT (? constant))))
- (convert-object/constant->register target constant
- object->address ct/object->address))
-\f
-;;;; Transfers from Memory
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OBJECT->TYPE (OFFSET (REGISTER (? address)) (? offset))))
- (convert-object/offset->register target address offset object->type))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OBJECT->DATUM (OFFSET (REGISTER (? address)) (? offset))))
- (convert-object/offset->register target address offset object->datum))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OBJECT->ADDRESS (OFFSET (REGISTER (? address)) (? offset))))
- (convert-object/offset->register target address offset object->address))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
- (let ((source (indirect-reference! address offset)))
- (LAP (MOV L ,source ,(standard-target-reference target)))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 14) 1))
- (LAP (MOV L (@R+ 14) ,(standard-target-reference target))))
-
-;;;; Transfers to Memory
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n))
- (CONSTANT (? object)))
- (load-constant object (indirect-reference! a n)))
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum))))
- (load-non-pointer type datum (indirect-reference! a n)))
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (REGISTER (? r)))
- (QUALIFIER (register-value-class=word? r))
- (LAP (MOV L
- ,(any-register-reference r)
- ,(indirect-reference! a n))))
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n))
- (POST-INCREMENT (REGISTER 14) 1))
- (LAP (MOV L (@R+ 14) ,(indirect-reference! a n))))
-\f
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
- (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum))))
- (let ((target (indirect-reference! address offset)))
- (cons-pointer/constant type
- (any-register-reference datum)
- target)))
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (OFFSET-ADDRESS (REGISTER (? source)) (? n))))
- (store-displaced-register/typed address offset type source (* 4 n)))
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n))))
- (store-displaced-register/typed address offset type source n))
-
-;; Common case that can be done cheaply:
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
- (BYTE-OFFSET-ADDRESS (OFFSET (REGISTER (? address)) (? offset))
- (? n)))
- (if (zero? n)
- (LAP)
- (increment/ea (indirect-reference! address offset) n)))
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (ENTRY:PROCEDURE (? label))))
- (let ((target (indirect-reference! address offset))
- (label (rtl-procedure/external-label (label->object label))))
- #|
- (LAP (MOVA B (@PCR ,label) ,target)
- ,@(set-type/constant type target))
- |#
- (LAP (MOVA B (@PCRO ,label ,(make-non-pointer-literal type 0)) ,target))))
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a0)) (? n0))
- (OFFSET (REGISTER (? a1)) (? n1)))
- (if (and (= a0 a1) (= n0 n1))
- (LAP)
- (let ((source (indirect-reference! a1 n1)))
- (LAP (MOV L ,source ,(indirect-reference! a0 n0))))))
-\f
-;;;; Consing
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 12) 1) (CONSTANT (? object)))
- (load-constant object (INST-EA (@R+ 12))))
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 12) 1)
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum))))
- (load-non-pointer type datum (INST-EA (@R+ 12))))
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 12) 1) (REGISTER (? r)))
- (QUALIFIER (register-value-class=word? r))
- (LAP (MOV L ,(any-register-reference r) (@R+ 12))))
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 12) 1) (OFFSET (REGISTER (? r)) (? n)))
- (LAP (MOV L ,(indirect-reference! r n) (@R+ 12))))
-
-(define-rule statement
- ;; This pops the top of stack into the heap
- (ASSIGN (POST-INCREMENT (REGISTER 12) 1) (POST-INCREMENT (REGISTER 14) 1))
- (LAP (MOV L (@R+ 14) (@R+ 12))))
-
-;;;; Pushes
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (REGISTER (? r)))
- (QUALIFIER (register-value-class=word? r))
- (LAP (PUSHL ,(any-register-reference r))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (CONSTANT (? object)))
- (LAP (PUSHL ,(constant->ea object))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
- (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum))))
- (LAP (PUSHL ,(any-register-reference datum))
- ,@(set-type/constant type (INST-EA (@R 14)))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum))))
- (LAP (PUSHL ,(non-pointer->ea type datum))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (ENTRY:PROCEDURE (? label))))
- (push-pc-relative-address/typed type
- (rtl-procedure/external-label
- (label->object label))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (ENTRY:CONTINUATION (? label))))
- (push-pc-relative-address/typed type label))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (OFFSET-ADDRESS (REGISTER (? r)) (? n))))
- (push-displaced-register/typed type r (* 4 n)))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (BYTE-OFFSET-ADDRESS (REGISTER (? r)) (? n))))
- (push-displaced-register/typed type r n))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (OFFSET (REGISTER (? r)) (? n)))
- (LAP (PUSHL ,(indirect-reference! r n))))
-\f
-;;;; CHAR->ASCII/BYTE-OFFSET
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CHAR->ASCII (OFFSET (REGISTER (? address)) (? offset))))
- (load-char-into-register 0
- (indirect-char/ascii-reference! address offset)
- target))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CHAR->ASCII (REGISTER (? source))))
- (load-char-into-register 0
- (reference-alias-register! source 'GENERAL)
- target))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (BYTE-OFFSET (REGISTER (? address)) (? offset)))
- (load-char-into-register 0
- (indirect-byte-reference! address offset)
- target))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (BYTE-OFFSET (REGISTER (? address)) (? offset))))
- (load-char-into-register type
- (indirect-byte-reference! address offset)
- target))
-
-(define-rule statement
- (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
- (CHAR->ASCII (CONSTANT (? character))))
- (LAP (MOV B
- (& ,(char->signed-8-bit-immediate character))
- ,(indirect-byte-reference! address offset))))
-
-(define-rule statement
- (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
- (REGISTER (? source)))
- (let ((source (coerce->any/byte-reference source)))
- (let ((target (indirect-byte-reference! address offset)))
- (LAP (MOV B ,source ,target)))))
-
-(define-rule statement
- (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
- (CHAR->ASCII (REGISTER (? source))))
- (let ((source (coerce->any/byte-reference source)))
- (let ((target (indirect-byte-reference! address offset)))
- (LAP (MOV B ,source ,target)))))
-
-(define-rule statement
- (ASSIGN (BYTE-OFFSET (REGISTER (? target)) (? target-offset))
- (CHAR->ASCII (OFFSET (REGISTER (? source)) (? source-offset))))
- (let ((source (indirect-char/ascii-reference! source source-offset)))
- (LAP (MOV B ,source ,(indirect-byte-reference! target target-offset)))))
-\f
-;;;; Utilities specific to rules1 (others in lapgen)
-
-(define (load-displaced-register target source n)
- (if (zero? n)
- (assign-register->register target source)
- (with-register-copy-alias! source 'GENERAL target
- (lambda (reusable-alias)
- (increment/ea reusable-alias n))
- (lambda (source target)
- (add-constant/ea source n target)))))
-
-(define (load-displaced-register/typed target source type n)
- (if (zero? type)
- (load-displaced-register target source n)
- (let ((unsigned-offset (+ (make-non-pointer-literal type 0) n)))
- (with-register-copy-alias! source 'GENERAL target
- (lambda (reusable-alias)
- (LAP (ADD L (&U ,unsigned-offset) ,reusable-alias)))
- (lambda (source target)
- (LAP (ADD L (&U ,unsigned-offset) ,source ,target)))))))
-
-(define (store-displaced-register/typed address offset type source n)
- (let* ((source (any-register-reference source))
- (target (indirect-reference! address offset)))
- (if (zero? type)
- (add-constant/ea source n target)
- (LAP (ADD L (&U ,(+ (make-non-pointer-literal type 0) n))
- ,source ,target)))))
-
-(define (push-displaced-register/typed type r n)
- (if (zero? type)
- (LAP (PUSHA B ,(indirect-byte-reference! r n)))
- #|
- (LAP (PUSHA B ,(indirect-byte-reference! r n))
- (set-type/constant type (INST-EA (@R 14))))
- |#
- (let ((reg (allocate-indirection-register! r)))
- (LAP (PUSHA B (@RO UL ,reg ,(+ (make-non-pointer-literal type 0)
- n)))))))
-
-(define (assign-register->register target source)
- (move-to-alias-register! source (register-type target) target)
- (LAP))
-
-(define (load-pc-relative target label)
- (LAP (MOV L (@PCR ,label) ,(standard-target-reference target))))
-
-(define (load-pc-relative-address target label)
- (LAP (MOVA B (@PCR ,label) ,(standard-target-reference target))))
-
-(define (load-pc-relative-address/typed target type label)
- (let ((target (standard-target-reference target)))
- #|
- (LAP (MOVA B (@PCR ,label) ,target)
- ,@(set-type/constant type target))
- |#
- (LAP (MOVA B (@PCRO ,label ,(make-non-pointer-literal type 0)) ,target))))
-
-(define (push-pc-relative-address/typed type label)
- #|
- (LAP (PUSHA B (@PCR ,label))
- ,@(set-type/constant type (INST-EA (@R 14))))
- |#
- (LAP (PUSHA B (@PCRO ,label ,(make-non-pointer-literal type 0)))))
-
-(define (load-char-into-register type source target)
- (let ((target (standard-target-reference target)))
- (LAP ,@(load-non-pointer type 0 target)
- (MOV B ,source ,target))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$MC68020-Header: rules2.scm,v 4.12 90/01/18 22:44:04 GMT cph Exp $
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Predicates.
-;;; Note: All fixnum code is in rulfix.scm.
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-(define-rule predicate
- (TYPE-TEST (REGISTER (? register)) (? type))
- (set-standard-branches! 'EQL)
- (test-byte type (reference-alias-register! register 'GENERAL)))
-
-(define-rule predicate
- (TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) (? type))
- (compare-type type (any-register-reference register)))
-
-(define-rule predicate
- (TYPE-TEST (OBJECT->TYPE (OFFSET (REGISTER (? address)) (? offset)))
- (? type))
- (compare-type type (indirect-reference! address offset)))
-
-(define-rule predicate
- (EQ-TEST (REGISTER (? register-1)) (REGISTER (? register-2)))
- (compare/register*register register-1 register-2 'EQL))
-
-(define-rule predicate
- (EQ-TEST (REGISTER (? register)) (? memory))
- (QUALIFIER (predicate/memory-operand? memory))
- (compare/register*memory register
- (predicate/memory-operand-reference memory)
- 'EQL))
-
-(define-rule predicate
- (EQ-TEST (? memory) (REGISTER (? register)))
- (QUALIFIER (predicate/memory-operand? memory))
- (compare/register*memory register
- (predicate/memory-operand-reference memory)
- 'EQL))
-
-(define-rule predicate
- (EQ-TEST (? memory-1) (? memory-2))
- (QUALIFIER (and (predicate/memory-operand? memory-1)
- (predicate/memory-operand? memory-2)))
- (compare/memory*memory (predicate/memory-operand-reference memory-1)
- (predicate/memory-operand-reference memory-2)
- 'EQL))
-
-(define-rule predicate
- (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register)))
- (eq-test/constant*register constant register))
-
-(define-rule predicate
- (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant)))
- (eq-test/constant*register constant register))
-
-(define-rule predicate
- (EQ-TEST (CONSTANT (? constant)) (? memory))
- (QUALIFIER (predicate/memory-operand? memory))
- (eq-test/constant*memory constant memory))
-
-(define-rule predicate
- (EQ-TEST (? memory) (CONSTANT (? constant)))
- (QUALIFIER (predicate/memory-operand? memory))
- (eq-test/constant*memory constant memory))
-
-(define-rule predicate
- (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum)))
- (REGISTER (? register)))
- (eq-test/synthesized-constant*register type datum register))
-
-(define-rule predicate
- (EQ-TEST (REGISTER (? register))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum))))
- (eq-test/synthesized-constant*register type datum register))
-
-(define-rule predicate
- (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum)))
- (? memory))
- (QUALIFIER (predicate/memory-operand? memory))
- (eq-test/synthesized-constant*memory type datum memory))
-
-(define-rule predicate
- (EQ-TEST (? memory)
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (MACHINE-CONSTANT (? datum))))
- (QUALIFIER (predicate/memory-operand? memory))
- (eq-test/synthesized-constant*memory type datum memory))
-\f
-;;;; Utilities
-
-(define (eq-test/synthesized-constant type datum ea)
- (set-standard-branches! 'EQL)
- (test-non-pointer type datum ea))
-
-(define-integrable (eq-test/synthesized-constant*register type datum reg)
- (eq-test/synthesized-constant type datum
- (any-register-reference reg)))
-
-(define-integrable (eq-test/synthesized-constant*memory type datum memory)
- (eq-test/synthesized-constant type datum
- (predicate/memory-operand-reference memory)))
-
-(define (eq-test/constant*register constant register)
- (if (non-pointer-object? constant)
- (eq-test/synthesized-constant (object-type constant)
- (careful-object-datum constant)
- (any-register-reference register))
- (compare/register*memory register
- (INST-EA (@PCR ,(constant->label constant)))
- 'EQL)))
-
-(define (eq-test/constant*memory constant memory)
- (let ((memory (predicate/memory-operand-reference memory)))
- (if (non-pointer-object? constant)
- (eq-test/synthesized-constant (object-type constant)
- (careful-object-datum constant)
- memory)
- (compare/memory*memory memory
- (INST-EA (@PCR ,(constant->label constant)))
- 'EQL))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Invocations and Entries.
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Invocations
-
-(define-integrable (clear-continuation-type-code)
- (LAP (BIC L ,mask-reference (@R 14))))
-
-(define-rule statement
- (POP-RETURN)
- (LAP ,@(clear-map!)
- ,@(clear-continuation-type-code)
- (RSB)))
-
-(define-rule statement
- (INVOCATION:APPLY (? frame-size) (? continuation))
- continuation ; ignored
- (LAP ,@(clear-map!)
- ,@(load-rn frame-size 2)
- #|
- (JMP ,entry:compiler-shortcircuit-apply)
- |#
- (MOV L (@R+ 14) (R 1))
- ,@(invoke-interface code:compiler-apply)
- ;; 'Til here
- ))
-
-(define-rule statement
- (INVOCATION:JUMP (? frame-size) (? continuation) (? label))
- frame-size continuation ; ignored
- (LAP ,@(clear-map!)
- (BR (@PCR ,label))))
-
-(define-rule statement
- (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation))
- frame-size continuation ; ignored
- ;; It expects the procedure at the top of the stack
- (LAP ,@(clear-map!)
- ,@(clear-continuation-type-code)
- (RSB)))
-
-(define-rule statement
- (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
- continuation ; ignored
- (LAP ,@(clear-map!)
- ,@(load-rn number-pushed 2)
- (MOVA B (@PCR ,label) (R 1))
- ,@(invoke-interface code:compiler-lexpr-apply)))
-
-(define-rule statement
- (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation))
- continuation ; ignored
- ;; It expects the procedure at the top of the stack
- (LAP ,@(clear-map!)
- ,@(load-rn number-pushed 2)
- (BIC L ,mask-reference (@R+ 14) (R 1))
- ,@(invoke-interface code:compiler-lexpr-apply)))
-
-(define-rule statement
- (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
- continuation ; ignored
- (LAP ,@(clear-map!)
- ;; The following assumes that at label there is
- ;; (JMP (L <entry>))
- ;; The other possibility would be
- ;; (JMP (@@PCR ,(free-uuo-link-label name frame-size)))
- ;; and to have <entry> at label, but it is longer and slower.
- ;; The 2 below accomodates the arrangement between the arity
- ;; and the instructions in an execute cache.
- (BR (@PCRO ,(free-uuo-link-label name frame-size) 2))))
-
-(define-rule statement
- (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
- continuation ; ignored
- (LAP ,@(clear-map!)
- (BR (@PCRO ,(global-uuo-link-label name frame-size) 2))))
-\f
-;;; The following two rules are obsolete. They haven't been used in a while.
-;;; They are provided in case the relevant switches are turned off, but there
-;;; is no reason to do this. Perhaps the switches should be removed.
-
-(define-rule statement
- (INVOCATION:CACHE-REFERENCE (? frame-size) (? continuation) (? extension))
- continuation ; ignored
- (let* ((set-extension
- (interpreter-call-argument->machine-register! extension r1))
- (clear-map (clear-map!)))
- (LAP ,@set-extension
- ,@clear-map
- ,@(load-rn frame-size 3)
- (MOVA B (@PCR ,*block-label*) (R 2))
- ,@(invoke-interface code:compiler-cache-reference-apply))))
-
-(define-rule statement
- (INVOCATION:LOOKUP (? frame-size) (? continuation) (? environment) (? name))
- continuation ; ignored
- (let* ((set-environment
- (interpreter-call-argument->machine-register! environment r1))
- (clear-map (clear-map!)))
- (LAP ,@set-environment
- ,@clear-map
- ,@(load-constant name (INST-EA (R 2)))
- ,@(load-rn frame-size 3)
- ,@(invoke-interface code:compiler-lookup-apply))))
-\f
-(define-rule statement
- (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
- continuation ; ignored
- (LAP ,@(clear-map!)
- ,@(if (eq? primitive compiled-error-procedure)
- (LAP ,@(load-rn frame-size 1)
- #|
- (JMP ,entry:compiler-error)
- |#
- ,@(invoke-interface code:compiler-error))
- (let ((arity (primitive-procedure-arity primitive)))
- (cond ((not (negative? arity))
- (LAP (MOV L (@PCR ,(constant->label primitive)) (R 1))
- #|
- (JMP ,entry:compiler-primitive-apply)
- |#
- ,@(invoke-interface code:compiler-primitive-apply)))
- ((= arity -1)
- (LAP (MOV L ,(make-immediate (-1+ frame-size))
- ,reg:lexpr-primitive-arity)
- (MOV L (@PCR ,(constant->label primitive)) (R 1))
- #|
- (JMP ,entry:compiler-primitive-lexpr-apply)
- |#
- ,@(invoke-interface
- code:compiler-primitive-lexpr-apply)))
- (else
- ;; Unknown primitive arity. Go through apply.
- (LAP ,@(load-rn frame-size 2)
- (MOV L (constant->ea primitive) (R 1))
- #|
- (JMP ,entry:compiler-apply)
- |#
- ,@(invoke-interface code:compiler-apply))))))))
-
-(let-syntax
- ((define-special-primitive-invocation
- (sc-macro-transformer
- (lambda (form environment)
- `(DEFINE-RULE STATEMENT
- (INVOCATION:SPECIAL-PRIMITIVE
- (? frame-size)
- (? continuation)
- ,(make-primitive-procedure (cadr form) #t))
- FRAME-SIZE CONTINUATION ; ignored
- ,(list 'LAP
- (list 'UNQUOTE-SPLICING '(CLEAR-MAP!))
- #|
- (list 'JMP
- (list 'UNQUOTE
- (close-syntax (symbol-append 'ENTRY:COMPILER-
- (cadr form))
- environment)))
- |#
- (list 'UNQUOTE-SPLICING
- `(INVOKE-INTERFACE
- ,(close-syntax (symbol-append 'CODE:COMPILER-
- (cadr form))
- environment)))))))))
- (define-special-primitive-invocation &+)
- (define-special-primitive-invocation &-)
- (define-special-primitive-invocation &*)
- (define-special-primitive-invocation &/)
- (define-special-primitive-invocation &=)
- (define-special-primitive-invocation &<)
- (define-special-primitive-invocation &>)
- (define-special-primitive-invocation 1+)
- (define-special-primitive-invocation -1+)
- (define-special-primitive-invocation zero?)
- (define-special-primitive-invocation positive?)
- (define-special-primitive-invocation negative?))
-\f
-;;;; Invocation Prefixes
-
-(define-rule statement
- (INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER 14))
- (LAP))
-
-(define-rule statement
- (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER 13))
- (generate/move-frame-up frame-size (offset-reference 13 0)))
-
-(define-rule statement
- (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size)
- (OFFSET-ADDRESS (REGISTER 14) (? offset)))
- (let ((how-far (- offset frame-size)))
- (cond ((zero? how-far)
- (LAP))
- ((zero? frame-size)
- (increment-rn 14 (* 4 how-far)))
- ((= frame-size 1)
- (LAP (MOV L (@R+ 14) ,(offset-reference r14 (-1+ how-far)))
- ,@(increment-rn 14 (* 4 (-1+ how-far)))))
- ((= frame-size 2)
- (if (= how-far 1)
- (LAP (MOV L (@RO B 14 4) (@RO B 14 8))
- (MOV L (@R+ 14) (@R 14)))
- (let ((i (lambda ()
- (LAP (MOV L (@R+ 14)
- ,(offset-reference r14 (-1+ how-far)))))))
- (LAP ,@(i)
- ,@(i)
- ,@(increment-rn 14 (* 4 (- how-far 2)))))))
- (else
- (generate/move-frame-up frame-size
- (offset-reference r14 offset))))))
-
-(define-rule statement
- (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size)
- (OFFSET-ADDRESS (REGISTER (? base))
- (? offset)))
- (QUALIFIER (pseudo-register? base))
- (generate/move-frame-up frame-size (indirect-reference! base offset)))
-\f
-(define-rule statement
- (INVOCATION-PREFIX:DYNAMIC-LINK 0 (REGISTER 14) (REGISTER 13))
- (LAP))
-
-(define-rule statement
- (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
- (OFFSET-ADDRESS (REGISTER (? base))
- (? offset))
- (REGISTER 13))
- (let ((label (generate-label))
- (temp (allocate-temporary-register! 'GENERAL)))
- (let ((temp-ref (register-reference temp)))
- (LAP (MOVA L ,(indirect-reference! base offset) ,temp-ref)
- (CMP L ,temp-ref (R 13))
- (B B LEQU (@PCR ,label))
- (MOV L (R 13) ,temp-ref)
- (LABEL ,label)
- ,@(generate/move-frame-up* frame-size temp)))))
-
-(define-rule statement
- (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
- (OBJECT->ADDRESS (REGISTER (? source)))
- (REGISTER 13))
- (QUALIFIER (pseudo-register? source))
- (let ((do-it
- (lambda (reg-ref)
- (let ((label (generate-label)))
- (LAP (CMP L ,reg-ref (R 13))
- (B B LEQU (@PCR ,label))
- (MOV L (R 13) ,reg-ref)
- (LABEL ,label)
- ,@(generate/move-frame-up* frame-size
- (lap:ea-R-register reg-ref)))))))
- (with-temporary-register-copy! source 'GENERAL
- (lambda (temp)
- (LAP (BIC L ,mask-reference ,temp)
- ,@(do-it temp)))
- (lambda (source temp)
- (LAP (BIC L ,mask-reference ,source ,temp)
- ,@(do-it temp))))))
-
-(define-rule statement
- (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
- (REGISTER (? source))
- (REGISTER 13))
- (QUALIFIER (pseudo-register? source))
- (let ((reg-ref (move-to-temporary-register! source 'GENERAL))
- (label (generate-label)))
- (LAP (CMP L ,reg-ref (R 13))
- (B B LEQU (@PCR ,label))
- (MOV L (R 13) ,reg-ref)
- (LABEL ,label)
- ,@(generate/move-frame-up* frame-size
- (lap:ea-R-register reg-ref)))))
-
-(define (generate/move-frame-up frame-size destination)
- (let ((temp (allocate-temporary-register! 'GENERAL)))
- (LAP (MOVA L ,destination ,(register-reference temp))
- ,@(generate/move-frame-up* frame-size temp))))
-
-(define (generate/move-frame-up* frame-size destination)
- (let ((temp (allocate-temporary-register! 'GENERAL)))
- (LAP (MOVA L ,(offset-reference r14 frame-size) ,(register-reference temp))
- ,@(generate-n-times
- frame-size 5
- (lambda ()
- (LAP (MOV L (@-R ,temp) (@-R ,destination))))
- (lambda (generator)
- (generator (allocate-temporary-register! 'GENERAL))))
- (MOV L ,(register-reference destination) (R 14)))))
-\f
-;;;; External Labels
-
-(define (make-external-label code label)
- (set! *external-labels* (cons label *external-labels*))
- (LAP (WORD U ,code)
- (BLOCK-OFFSET ,label)
- (LABEL ,label)))
-
-;;; Entry point types
-
-(define-integrable (make-format-longword format-word gc-offset)
- (+ (* #x20000 gc-offset) format-word))
-
-(define-integrable (make-code-word min max)
- (+ (* #x100 min) max))
-
-(define (make-procedure-code-word min max)
- ;; The "min" byte must be less than #x80; the "max" byte may not
- ;; equal #x80 but can take on any other value.
- (if (or (negative? min) (>= min #x80))
- (error "MAKE-PROCEDURE-CODE-WORD: minimum out of range" min))
- (if (>= (abs max) #x80)
- (error "MAKE-PROCEDURE-CODE-WORD: maximum out of range" max))
- (make-code-word min (if (negative? max) (+ #x100 max) max)))
-
-(define expression-code-word
- (make-code-word #xff #xff))
-
-(define internal-entry-code-word
- (make-code-word #xff #xfe))
-
-(define internal-continuation-code-word
- (make-code-word #xff #xfc))
-
-(define (frame-size->code-word offset default)
- (cond ((not offset)
- default)
- ((< offset #x2000)
- ;; This uses up through (#xff #xdf).
- (let ((qr (integer-divide offset #x80)))
- (make-code-word (+ #x80 (integer-divide-remainder qr))
- (+ #x80 (integer-divide-quotient qr)))))
- (else
- (error "Unable to encode continuation offset" offset))))
-
-(define (continuation-code-word label)
- (frame-size->code-word
- (if label
- (rtl-continuation/next-continuation-offset (label->object label))
- 0)
- internal-continuation-code-word))
-
-(define (internal-procedure-code-word rtl-proc)
- (frame-size->code-word
- (rtl-procedure/next-continuation-offset rtl-proc)
- internal-entry-code-word))
-\f
-;;;; Procedure headers
-
-;;; The following calls MUST appear as the first thing at the entry
-;;; point of a procedure. They assume that the register map is clear
-;;; and that no register contains anything of value.
-;;;
-;;; The only reason that this is true is that no register is live
-;;; across calls. If that were not true, then we would have to save
-;;; any such registers on the stack so that they would be GC'ed
-;;; appropriately.
-;;;
-;;; The only exception is the dynamic link register, handled
-;;; specially. Procedures that require a dynamic link use a different
-;;; interrupt handler that saves and restores the dynamic link
-;;; register.
-
-(define (interrupt-check procedure-label interrupt-label)
- ;; This always does interrupt/stack checks in line.
- (LAP (CMP L (R ,regnum:free-pointer) ,reg:compiled-memtop)
- (B B GEQ (@PCR ,interrupt-label))
- ,@(if (let ((object (label->object procedure-label)))
- (and (rtl-procedure? object)
- (not (rtl-procedure/stack-leaf? object))
- compiler:generate-stack-checks?))
- (LAP (CMP L (R ,regnum:stack-pointer) ,reg:stack-guard)
- (B B LSS (@PCR ,interrupt-label)))
- (LAP))))
-
-(define (simple-procedure-header code-word label
- ;; entry:compiler-interrupt
- code:compiler-interrupt)
- (let ((gc-label (generate-label)))
- (LAP (LABEL ,gc-label)
- #|
- (JSB ,entry:compiler-interrupt)
- |#
- ,@(invoke-interface-jsb code:compiler-interrupt)
- ,@(make-external-label code-word label)
- ,@(interrupt-check label gc-label))))
-
-(define (dlink-procedure-header code-word label)
- (let ((gc-label (generate-label)))
- (LAP (LABEL ,gc-label)
- #|
- (JSB ,entry:compiler-interrupt-dlink)
- |#
- (MOV L (R 13) (R 2)) ; move dlink to arg register.
- ,@(invoke-interface-jsb code:compiler-interrupt-dlink)
- ;; 'Til here
- ,@(make-external-label code-word label)
- ,@(interrupt-check label gc-label))))
-
-(define-rule statement
- (CONTINUATION-ENTRY (? internal-label))
- (make-external-label (continuation-code-word internal-label)
- internal-label))
-
-(define-rule statement
- (CONTINUATION-HEADER (? internal-label))
- (simple-procedure-header (continuation-code-word internal-label)
- internal-label
- ;; entry:compiler-interrupt-continuation
- code:compiler-interrupt-continuation))
-
-(define-rule statement
- (IC-PROCEDURE-HEADER (? internal-label))
- (let* ((procedure (label->object internal-label))
- (external-label (rtl-procedure/external-label procedure)))
- (LAP (ENTRY-POINT ,external-label)
- (EQUATE ,external-label ,internal-label)
- ,@(simple-procedure-header expression-code-word
- internal-label
- ;; entry:compiler-interrupt-ic-procedure
- code:compiler-interrupt-ic-procedure))))
-
-(define-rule statement
- (OPEN-PROCEDURE-HEADER (? internal-label))
- (let ((rtl-proc (label->object internal-label)))
- (LAP
- (EQUATE ,(rtl-procedure/external-label rtl-proc) ,internal-label)
- ,@((if (rtl-procedure/dynamic-link? rtl-proc)
- dlink-procedure-header
- (lambda (code-word label)
- (simple-procedure-header code-word label
- ;; entry:compiler-interrupt-procedure
- code:compiler-interrupt-procedure)))
- (internal-procedure-code-word rtl-proc)
- internal-label))))
-
-(define-rule statement
- (PROCEDURE-HEADER (? internal-label) (? min) (? max))
- (LAP (EQUATE ,(rtl-procedure/external-label
- (label->object internal-label))
- ,internal-label)
- ,@(simple-procedure-header (make-procedure-code-word min max)
- internal-label
- ;; entry:compiler-interrupt-procedure
- code:compiler-interrupt-procedure)))
-\f
-;;;; Closures. These two statements are intertwined:
-;;; Note: If the closure is a multiclosure, the closure object on the
-;;; stack corresponds to the first (official) entry point.
-;;; Thus on entry and interrupt it must be bumped around.
-
-(define (make-magic-closure-constant entry)
- (- (make-non-pointer-literal (ucode-type compiled-entry) 0)
- (+ (* entry 10) 6)))
-
-(define-rule statement
- (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
- nentries ; ignored
- (let ((rtl-proc (label->object internal-label)))
- (let ((gc-label (generate-label))
- (external-label (rtl-procedure/external-label rtl-proc)))
- (if (zero? nentries)
- (LAP (EQUATE ,external-label ,internal-label)
- ,@(simple-procedure-header
- (internal-procedure-code-word rtl-proc)
- internal-label
- ;; entry:compiler-interrupt-procedure
- code:compiler-interrupt-procedure))
- (LAP (LABEL ,gc-label)
- ,@(increment/ea (INST-EA (@R 14)) (* 10 entry))
- #|
- (JMP ,entry:compiler-interrupt-closure)
- |#
- ,@(invoke-interface code:compiler-interrupt-closure)
- ,@(make-external-label internal-entry-code-word
- external-label)
- (ADD L (&U ,(make-magic-closure-constant entry)) (@R 14))
- (LABEL ,internal-label)
- ,@(interrupt-check internal-label gc-label))))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
- (? min) (? max) (? size)))
- (let ((target (standard-target-reference target)))
- (generate/cons-closure target
- false procedure-label min max size)))
-
-(define (generate/cons-closure target type procedure-label min max size)
- (LAP ,@(load-non-pointer (ucode-type manifest-closure)
- (+ 3 size)
- (INST-EA (@R+ 12)))
- (MOV L (&U ,(make-format-longword (make-procedure-code-word min max) 8))
- (@R+ 12))
- ,@(if type
- (LAP (BIS L (&U ,(make-non-pointer-literal type 0)) (R 12)
- ,target))
- (LAP (MOV L (R 12) ,target)))
- (MOV W (&U #x9f16) (@R+ 12)) ; (JSB (@& <entry>))
- (MOVA B (@PCR ,(rtl-procedure/external-label
- (label->object procedure-label)))
- (@R+ 12))
- (CLR W (@R+ 12))
- ,@(increment-rn 12 (* 4 size))))
-\f
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-MULTICLOSURE (? nentries) (? size) (? entries)))
- (let ((target (standard-target-reference target)))
- (case nentries
- ((0)
- (LAP (MOV L (R 12) ,target)
- ,@(load-non-pointer (ucode-type manifest-vector)
- size
- (INST-EA (@R+ 12)))
- ,@(increment-rn 12 (* 4 size))))
- ((1)
- (let ((entry (vector-ref entries 0)))
- (generate/cons-closure target false
- (car entry) (cadr entry) (caddr entry)
- size)))
- (else
- (generate/cons-multiclosure target nentries size
- (vector->list entries))))))
-
-(define (generate/cons-multiclosure target nentries size entries)
- (let ((total-size (+ size
- (quotient (+ 3 (* 5 nentries))
- 2)))
- (temp (standard-temporary-reference)))
-
- (define (generate-entries entries offset first?)
- (if (null? entries)
- (LAP)
- (let ((entry (car entries)))
- (LAP (MOV L (&U ,(make-format-longword
- (make-procedure-code-word (cadr entry)
- (caddr entry))
- offset))
- (@R+ 12))
- ,@(if first?
- (LAP (MOV L (R 12) ,target))
- (LAP))
- (MOV W ,temp (@R+ 12)) ; (JSB (@& <entry>))
- (MOVA B (@PCR ,(rtl-procedure/external-label
- (label->object (car entry))))
- (@R+ 12))
- ,@(generate-entries (cdr entries)
- (+ 10 offset)
- false)))))
-
- (LAP ,@(load-non-pointer (ucode-type manifest-closure)
- total-size
- (INST-EA (@R+ 12)))
- (MOV L (&U ,(make-format-longword nentries 0)) (@R+ 12))
- (MOV W (&U #x9f16) ,temp)
- ,@(generate-entries entries 12 true)
- ,@(if (odd? nentries)
- (LAP (CLR W (@R+ 12)))
- (LAP))
- ,@(increment-rn 12 (* 4 size)))))
-\f
-;;;; Entry Header
-;;; This is invoked by the top level of the LAP GENERATOR.
-
-(define (generate/quotation-header environment-label free-ref-label n-sections)
- (LAP (MOV L ,reg:environment (@PCR ,environment-label))
- (MOVA B (@PCR ,*block-label*) (R 2))
- (MOVA B (@PCR ,free-ref-label) (R 3))
- ,@(load-rn n-sections 4)
- #|
- (JSB ,entry:compiler-link)
- |#
- ,@(invoke-interface-jsb code:compiler-link)
- ,@(make-external-label (continuation-code-word false)
- (generate-label))))
-
-(define (generate/remote-link code-block-label
- environment-offset
- free-ref-offset
- n-sections)
- (LAP (BIC L ,mask-reference (@PCR ,code-block-label) (R 2))
- (MOV L ,reg:environment
- (@RO ,(datum-size environment-offset) 2 ,environment-offset))
- ,@(add-constant/ea (INST-EA (R 2)) free-ref-offset (INST-EA (R 3)))
- ,@(load-rn n-sections 4)
- #|
- (JSB ,entry:compiler-link)
- |#
- ,@(invoke-interface-jsb code:compiler-link)
- ,@(make-external-label (continuation-code-word false)
- (generate-label))))
-\f
-(define (generate/constants-block constants references assignments
- uuo-links global-links static-vars)
- (let ((constant-info
- (declare-constants 0 (transmogrifly uuo-links)
- (declare-constants 1 references
- (declare-constants 2 assignments
- (declare-constants 3 (transmogrifly global-links)
- (declare-constants false
- (map (lambda (pair)
- (cons false (cdr pair)))
- static-vars)
- (declare-constants false constants
- (cons false (LAP))))))))))
- (let ((free-ref-label (car constant-info))
- (constants-code (cdr constant-info))
- (debugging-information-label (allocate-constant-label))
- (environment-label (allocate-constant-label))
- (n-sections
- (+ (if (null? uuo-links) 0 1)
- (if (null? references) 0 1)
- (if (null? assignments) 0 1)
- (if (null? global-links) 0 1))))
- (values
- (LAP ,@constants-code
- ;; Place holder for the debugging info filename
- (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO)
- ;; Place holder for the load time environment if needed
- (SCHEME-OBJECT ,environment-label
- ,(if (null? free-ref-label) 0 'ENVIRONMENT)))
- environment-label
- free-ref-label
- n-sections))))
-
-(define (declare-constants tag constants info)
- (define (inner constants)
- (if (null? constants)
- (cdr info)
- (let ((entry (car constants)))
- (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry))
- ,@(inner (cdr constants))))))
- (if (and tag (not (null? constants)))
- (let ((label (allocate-constant-label)))
- (cons label
- (inner
- `((,(let ((datum (length constants)))
- (if (> datum #xffff)
- (error "datum too large" datum))
- (+ (* tag #x10000) datum))
- . ,label)
- ,@constants))))
- (cons (car info) (inner constants))))
-
-;; IMPORTANT:
-;; frame-size and uuo-label are switched (with respect to the 68k
-;; version) in order to preserve the arity in a constant position (the
-;; Vax is little-endian). The invocation rule for uuo-links has been
-;; changed to take the extra 2 bytes into account.
-;; Alternatively we could
-;; make execute caches 3 words long, with the third containing the
-;; frame size and the middle the second part of the instruction.
-
-(define (transmogrifly uuos)
- (define (inner name assoc)
- (if (null? assoc)
- (transmogrifly (cdr uuos))
- (cons (cons (caar assoc) ; frame-size
- (cdar assoc)) ; uuo-label
- (cons (cons name ; variable name
- (allocate-constant-label)) ; dummy label
- (inner name (cdr assoc))))))
- (if (null? uuos)
- '()
- (inner (caar uuos) (cdar uuos))))
-\f
-;;; Local Variables: ***
-;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
-;;; End: ***
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Interpreter Calls.
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Variable cache trap handling.
-
-(define-rule statement
- (INTERPRETER-CALL:CACHE-REFERENCE (? cont) (? extension) (? safe?))
- (QUALIFIER (interpreter-call-argument? extension))
- cont ; ignored
- (let* ((set-extension
- (interpreter-call-argument->machine-register! extension r2))
- (clear-map (clear-map!)))
- (LAP ,@set-extension
- ,@clear-map
- #|
- ;; This should be enabled if the short-circuit code is written.
- (JSB ,(if safe?
- entry:compiler-safe-reference-trap
- entry:compiler-reference-trap))
- |#
- ,@(invoke-interface-jsb (if safe?
- code:compiler-safe-reference-trap
- code:compiler-reference-trap)))))
-
-(define-rule statement
- (INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont) (? extension) (? value))
- (QUALIFIER (and (interpreter-call-argument? extension)
- (interpreter-call-argument? value)))
- cont ; ignored
- (let* ((set-extension
- (interpreter-call-argument->machine-register! extension r2))
- (set-value (interpreter-call-argument->machine-register! value r3))
- (clear-map (clear-map!)))
- (LAP ,@set-extension
- ,@set-value
- ,@clear-map
- #|
- ;; This should be enabled if the short-circuit code is written.
- (JSB ,entry:compiler-assignment-trap)
- |#
- ,@(invoke-interface-jsb code:compiler-assignment-trap))))
-
-(define-rule statement
- (INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont) (? extension))
- (QUALIFIER (interpreter-call-argument? extension))
- cont ; ignored
- (let* ((set-extension
- (interpreter-call-argument->machine-register! extension r2))
- (clear-map (clear-map!)))
- (LAP ,@set-extension
- ,@clear-map
- ,@(invoke-interface-jsb code:compiler-unassigned?-trap))))
-\f
-;;;; Interpreter Calls
-
-;;; All the code that follows is obsolete. It hasn't been used in a while.
-;;; It is provided in case the relevant switches are turned off, but there
-;;; is no real reason to do this. Perhaps the switches should be removed.
-
-(define-rule statement
- (INTERPRETER-CALL:ACCESS (? cont) (? environment) (? name))
- (QUALIFIER (interpreter-call-argument? environment))
- cont ; ignored
- (lookup-call code:compiler-access environment name))
-
-(define-rule statement
- (INTERPRETER-CALL:LOOKUP (? cont) (? environment) (? name) (? safe?))
- (QUALIFIER (interpreter-call-argument? environment))
- cont ; ignored
- (lookup-call (if safe? code:compiler-safe-lookup code:compiler-lookup)
- environment name))
-
-(define-rule statement
- (INTERPRETER-CALL:UNASSIGNED? (? cont) (? environment) (? name))
- (QUALIFIER (interpreter-call-argument? environment))
- cont ; ignored
- (lookup-call code:compiler-unassigned? environment name))
-
-(define-rule statement
- (INTERPRETER-CALL:UNBOUND? (? cont) (? environment) (? name))
- (QUALIFIER (interpreter-call-argument? environment))
- cont ; ignored
- (lookup-call code:compiler-unbound? environment name))
-
-(define (lookup-call code environment name)
- (let* ((set-environment
- (interpreter-call-argument->machine-register! environment r2))
- (clear-map (clear-map!)))
- (LAP ,@set-environment
- ,@clear-map
- ,@(load-constant name (INST-EA (R 3)))
- ,@(invoke-interface-jsb code))))
-
-(define-rule statement
- (INTERPRETER-CALL:DEFINE (? environment) (? cont) (? name) (? value))
- (QUALIFIER (and (interpreter-call-argument? environment)
- (interpreter-call-argument? value)))
- cont ; ignored
- (assignment-call code:compiler-define environment name value))
-
-(define-rule statement
- (INTERPRETER-CALL:SET! (? environment) (? cont) (? name) (? value))
- (QUALIFIER (and (interpreter-call-argument? environment)
- (interpreter-call-argument? value)))
- cont ; ignored
- (assignment-call code:compiler-set! environment name value))
-
-(define (assignment-call code environment name value)
- (let* ((set-environment
- (interpreter-call-argument->machine-register! environment r2))
- (set-value (interpreter-call-argument->machine-register! value r4))
- (clear-map (clear-map!)))
- (LAP ,@set-environment
- ,@set-value
- ,@clear-map
- ,@(load-constant name (INST-EA (R 3)))
- ,@(invoke-interface-jsb code))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; LAP Generation Rules: Fixnum operations.
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Making and examining fixnums
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source)))))
- (convert-object/register->register target source address->fixnum))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source))))
- (convert-object/register->register target source object->fixnum))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source))))
- (convert-object/register->register target source address->fixnum))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source))))
- (convert-object/register->register target source fixnum->object))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source))))
- (convert-object/register->register target source fixnum->address))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (ADDRESS->FIXNUM (OBJECT->ADDRESS (CONSTANT (? constant)))))
- (convert-object/constant->register target constant
- address->fixnum ct/address->fixnum))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant))))
- (load-fixnum-constant constant (standard-target-reference target)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (ADDRESS->FIXNUM
- (OBJECT->ADDRESS (OFFSET (REGISTER (? address)) (? offset)))))
- (convert-object/offset->register target address offset address->fixnum))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OBJECT->FIXNUM (OFFSET (REGISTER (? address)) (? offset))))
- (convert-object/offset->register target address offset object->fixnum))
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n))
- (FIXNUM->OBJECT (REGISTER (? source))))
- (let* ((source (any-register-reference source))
- (target (indirect-reference! a n)))
- (fixnum->object source target)))
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 12) 1)
- (FIXNUM->OBJECT (REGISTER (? r))))
- (fixnum->object (any-register-reference r) (INST-EA (@R+ 12))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
- (FIXNUM->OBJECT (REGISTER (? r))))
- (fixnum->object (any-register-reference r) (INST-EA (@-R 14))))
-\f
-;;;; Fixnum Operations
-
-(define-rule statement
- (ASSIGN (? target)
- (FIXNUM-1-ARG (? operator) (REGISTER (? source)) (? overflow?)))
- (QUALIFIER (machine-operation-target? target))
- overflow? ; ignored
- (fixnum-1-arg target source (fixnum-1-arg/operate operator)))
-
-(define-rule statement
- (ASSIGN (? target)
- (FIXNUM-2-ARGS (? operator)
- (REGISTER (? source1))
- (REGISTER (? source2))
- (? overflow?)))
- (QUALIFIER (machine-operation-target? target))
- overflow? ; ignored
- (fixnum-2-args target source1 source2 (fixnum-2-args/operate operator)))
-
-(define-rule statement
- (ASSIGN (? target)
- (FIXNUM-2-ARGS (? operator)
- (REGISTER (? source))
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (? overflow?)))
- (QUALIFIER (machine-operation-target? target))
- overflow? ; ignored
- (fixnum-2-args/register*constant operator target source constant))
-
-(define-rule statement
- (ASSIGN (? target)
- (FIXNUM-2-ARGS (? operator)
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (REGISTER (? source))
- (? overflow?)))
- (QUALIFIER (machine-operation-target? target))
- overflow? ; ignored
- (if (fixnum-2-args/commutative? operator)
- (fixnum-2-args/register*constant operator target source constant)
- (fixnum-2-args/constant*register operator target constant source)))
-
-(define-rule statement
- (ASSIGN (? target)
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (OBJECT->FIXNUM (CONSTANT 4))
- (OBJECT->FIXNUM (REGISTER (? source)))
- (? overflow?)))
- (QUALIFIER (machine-operation-target? target))
- overflow? ; ignored
- (convert-index->fixnum/register target source))
-
-(define-rule statement
- (ASSIGN (? target)
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (OBJECT->FIXNUM (REGISTER (? source)))
- (OBJECT->FIXNUM (CONSTANT 4))
- (? overflow?)))
- (QUALIFIER (machine-operation-target? target))
- overflow? ; ignored
- (convert-index->fixnum/register target source))
-\f
-(define-rule statement
- (ASSIGN (? target)
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (OBJECT->FIXNUM (CONSTANT 4))
- (OBJECT->FIXNUM (OFFSET (REGISTER (? r)) (? n)))
- (? overflow?)))
- (QUALIFIER (machine-operation-target? target))
- overflow? ; ignored
- (convert-index->fixnum/offset target r n))
-
-(define-rule statement
- (ASSIGN (? target)
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (OBJECT->FIXNUM (OFFSET (REGISTER (? r)) (? n)))
- (OBJECT->FIXNUM (CONSTANT 4))
- (? overflow?)))
- (QUALIFIER (machine-operation-target? target))
- overflow? ; ignored
- (convert-index->fixnum/offset target r n))
-
-#|
-;; These could be used for multiply instead of the generic rule used above.
-;; They are better when the target is in memory, but they are not worth it.
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (REGISTER (? source1))
- (REGISTER (? source2))))
- (fixnum-2-args `(REGISTER ,target)
- source1 source2
- (fixnum-2-args/operate 'MULTIPLY-FIXNUM)))
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? base)) (? offset))
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (REGISTER (? source1))
- (REGISTER (? source2))))
- (let* ((shift (- 0 scheme-type-width))
- (target (indirect-reference! base offset))
- (get-temp (temporary-copy-if-available source1 'GENERAL)))
- (if get-temp
- (let ((source2 (any-register-reference source2))
- (temp (get-temp)))
- (LAP (ASH L ,(make-immediate shift) ,temp ,temp)
- (MUL L ,temp ,source2 ,target)))
- (let ((get-temp (temporary-copy-if-available source2 'GENERAL)))
- (if get-temp
- (let ((source1 (any-register-reference source1))
- (temp (get-temp)))
- (LAP (ASH L ,(make-immediate shift) ,temp ,temp)
- (MUL L ,source1 ,temp ,target)))
- (let ((source1 (any-register-reference source1))
- (source2 (any-register-reference source2))
- (temp (reference-temporary-register! 'GENERAL)))
- (LAP (ASH L ,(make-immediate shift) ,source1 ,temp)
- (MUL L ,temp ,source2 ,target))))))))
-|#
-\f
-;;;; Fixnum Predicates
-
-(define-rule predicate
- (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? register)))
- (set-standard-branches! (fixnum-predicate->cc predicate))
- (test-fixnum/ea (any-register-reference register)))
-
-(define-rule predicate
- (FIXNUM-PRED-1-ARG (? predicate) (OBJECT->FIXNUM (REGISTER (? register))))
- (set-standard-branches! (fixnum-predicate->cc predicate))
- (let ((temporary (standard-temporary-reference)))
- (object->fixnum (any-register-reference register) temporary)))
-
-(define-rule predicate
- (FIXNUM-PRED-1-ARG (? predicate) (? memory))
- (QUALIFIER (predicate/memory-operand? memory))
- (set-standard-branches! (fixnum-predicate->cc predicate))
- (test-fixnum/ea (predicate/memory-operand-reference memory)))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (REGISTER (? register-1))
- (REGISTER (? register-2)))
- (compare/register*register register-1
- register-2
- (fixnum-predicate->cc predicate)))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate) (REGISTER (? register)) (? memory))
- (QUALIFIER (predicate/memory-operand? memory))
- (compare/register*memory register
- (predicate/memory-operand-reference memory)
- (fixnum-predicate->cc predicate)))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate) (? memory) (REGISTER (? register)))
- (QUALIFIER (predicate/memory-operand? memory))
- (compare/register*memory
- register
- (predicate/memory-operand-reference memory)
- (invert-cc-noncommutative (fixnum-predicate->cc predicate))))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate) (? memory-1) (? memory-2))
- (QUALIFIER (and (predicate/memory-operand? memory-1)
- (predicate/memory-operand? memory-2)))
- (compare/memory*memory (predicate/memory-operand-reference memory-1)
- (predicate/memory-operand-reference memory-2)
- (fixnum-predicate->cc predicate)))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (REGISTER (? register))
- (OBJECT->FIXNUM (CONSTANT (? constant))))
- (fixnum-predicate/register*constant register
- constant
- (fixnum-predicate->cc predicate)))
-\f
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (REGISTER (? register)))
- (fixnum-predicate/register*constant
- register
- constant
- (invert-cc-noncommutative (fixnum-predicate->cc predicate))))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (? memory)
- (OBJECT->FIXNUM (CONSTANT (? constant))))
- (QUALIFIER (predicate/memory-operand? memory))
- (fixnum-predicate/memory*constant (predicate/memory-operand-reference memory)
- constant
- (fixnum-predicate->cc predicate)))
-
-(define-rule predicate
- (FIXNUM-PRED-2-ARGS (? predicate)
- (OBJECT->FIXNUM (CONSTANT (? constant)))
- (? memory))
- (QUALIFIER (predicate/memory-operand? memory))
- (fixnum-predicate/memory*constant
- (predicate/memory-operand-reference memory)
- constant
- (invert-cc-noncommutative (fixnum-predicate->cc predicate))))
-
-;; This assumes that the last instruction sets the condition code bits
-;; correctly.
-
-(define-rule predicate
- (OVERFLOW-TEST)
- (set-standard-branches! 'VS)
- (LAP))
-
-;;;; Utilities
-
-(define-integrable (datum->fixnum source target)
- ;; This drops the type code
- (LAP (ASH L (S ,scheme-type-width) ,source ,target)))
-
-(define-integrable (fixnum->datum source target)
- ;; This maintains the type code, if any.
- (LAP (ROTL (S ,scheme-datum-width) ,source ,target)))
-
-(define (object->fixnum source target)
- (datum->fixnum source target))
-
-(define-integrable (ct/object->fixnum object target)
- (load-fixnum-constant object target))
-
-(define (address->fixnum source target)
- (datum->fixnum source target))
-
-(define-integrable (ct/address->fixnum address target)
- (load-fixnum-constant (careful-object-datum address) target))
-
-(define (fixnum->address source target)
- (fixnum->datum source target))
-
-(define (ct/fixnum->address fixnum target)
- (load-immediate fixnum target))
-\f
-(define-integrable (target-or-register target)
- (if (effective-address/register? target)
- target
- (standard-temporary-reference)))
-
-(define (fixnum->object source target)
- (let ((rtarget (target-or-register target)))
- (LAP ,@(if (eq? rtarget source)
- (LAP (BIS L (S ,(ucode-type fixnum)) ,rtarget))
- (LAP (BIS L (S ,(ucode-type fixnum)) ,source ,rtarget)))
- ,@(fixnum->datum rtarget target))))
-
-(define-integrable (ct/fixnum->object fixnum target)
- (load-constant fixnum target))
-
-(define-integrable fixnum-1 64) ; (expt 2 scheme-type-width) ***
-
-(define-integrable fixnum-bits-mask
- (-1+ fixnum-1))
-
-(define (load-fixnum-constant constant target)
- (cond ((zero? constant)
- (LAP (CLR L ,target)))
- ((<= 1 constant 63)
- (LAP (ASH L (S ,scheme-type-width) (S ,constant) ,target)))
- (else
- (let* ((constant (* constant fixnum-1))
- (size (datum-size constant)))
- (cond ((not (eq? size 'L))
- (LAP (CVT ,size L ,(make-immediate constant) ,target)))
- ((and (positive? constant) (< constant #x10000))
- (LAP (MOVZ W L ,(make-immediate constant) ,target)))
- (else
- (LAP (MOV L ,(make-immediate constant) ,target))))))))
-
-(define (machine-operation-target? target)
- (or (rtl:register? target)
- (and (rtl:offset? target)
- (rtl:register? (rtl:offset-base target)))))
-
-(define (fixnum-choose-target target operate-on-pseudo operate-on-target)
- (cond ((rtl:register? target)
- (let ((register (rtl:register-number target)))
- (if (pseudo-register? register)
- (operate-on-pseudo register)
- (operate-on-target (register-reference register)))))
- ((rtl:offset? target)
- (operate-on-target (offset->indirect-reference! target)))
- (else
- (error "fixnum-choose-target: Not a machine-operation-target"
- target))))
-
-(define (convert-index->fixnum/register target source)
- (fixnum-1-arg
- target source
- (lambda (target source)
- (LAP (ASH L (S ,(+ scheme-type-width 2)) ,source ,target)))))
-
-(define (convert-index->fixnum/offset target address offset)
- (let ((source (indirect-reference! address offset)))
- (fixnum-choose-target
- target
- (lambda (pseudo)
- (let ((target (standard-target-reference pseudo)))
- (LAP (ASH L (S ,(+ scheme-type-width 2)) ,source ,target))))
- (lambda (target)
- (LAP (ASH L (S ,(+ scheme-type-width 2)) ,source ,target))))))
-\f
-;;;; Fixnum operation dispatch
-
-(define (define-fixnum-method operator methods method)
- (let ((entry (assq operator (cdr methods))))
- (if entry
- (set-cdr! entry method)
- (set-cdr! methods (cons (cons operator method) (cdr methods)))))
- operator)
-
-(define (lookup-fixnum-method operator methods)
- (cdr (or (assq operator (cdr methods))
- (error "Unknown operator" operator))))
-
-(define fixnum-methods/1-arg
- (list 'FIXNUM-METHODS/1-ARG))
-
-(define-integrable (fixnum-1-arg/operate operator)
- (lookup-fixnum-method operator fixnum-methods/1-arg))
-
-(define fixnum-methods/2-args
- (list 'FIXNUM-METHODS/2-ARGS))
-
-(define-integrable (fixnum-2-args/operate operator)
- (lookup-fixnum-method operator fixnum-methods/2-args))
-
-(define fixnum-methods/2-args-constant
- (list 'FIXNUM-METHODS/2-ARGS-CONSTANT))
-
-(define-integrable (fixnum-2-args/operate-constant operator)
- (lookup-fixnum-method operator fixnum-methods/2-args-constant))
-
-(define fixnum-methods/2-args-tnatsnoc
- (list 'FIXNUM-METHODS/2-ARGS-TNATSNOC))
-
-(define-integrable (fixnum-2-args/operate-tnatsnoc operator)
- (lookup-fixnum-method operator fixnum-methods/2-args-tnatsnoc))
-
-(define (fixnum-2-args/commutative? operator)
- (memq operator '(PLUS-FIXNUM
- MULTIPLY-FIXNUM
- FIXNUM-AND
- FIXNUM-OR
- FIXNUM-XOR)))
-
-(define (fixnum-1-arg target source operation)
- (fixnum-choose-target
- target
- (lambda (target)
- (cond ((register-copy-if-available source 'GENERAL target)
- =>
- (lambda (get-target)
- (let ((target (get-target)))
- (operation target target))))
- (else
- (let* ((source (any-register-reference source))
- (target (standard-target-reference target)))
- (operation target source)))))
- (lambda (target)
- (let ((source (any-register-reference source)))
- (operation target source)))))
-
-(define-integrable (commute target source1 source2 recvr1 recvr2)
- (cond ((ea/same? target source1)
- (recvr1 source2))
- ((ea/same? target source2)
- (recvr1 source1))
- (else
- (recvr2))))
-\f
-(define (fixnum-2-args target source1 source2 operation)
- (fixnum-choose-target
- target
- (lambda (target)
- (cond ((register-copy-if-available source1 'GENERAL target)
- =>
- (lambda (get-target)
- (let* ((source2 (any-register-reference source2))
- (target (get-target)))
- (operation target target source2))))
- ((register-copy-if-available source2 'GENERAL target)
- =>
- (lambda (get-target)
- (let* ((source1 (any-register-reference source1))
- (target (get-target)))
- (operation target source1 target))))
- (else
- (let* ((source1 (any-register-reference source1))
- (source2 (any-register-reference source2))
- (target (standard-target-reference target)))
- (operation target source1 source2)))))
- (lambda (target)
- (let* ((source1 (any-register-reference source1))
- (source2 (any-register-reference source2)))
- (operation target source1 source2)))))
-
-(define (fixnum-2-args/register*constant operator target source constant)
- (fixnum-1-arg
- target source
- (lambda (target source)
- ((fixnum-2-args/operate-constant operator) target source constant))))
-
-(define (fixnum-2-args/constant*register operator target constant source)
- (fixnum-1-arg
- target source
- (lambda (target source)
- ((fixnum-2-args/operate-tnatsnoc operator) target constant source))))
-
-(define (integer-power-of-2? n)
- (let loop ((power 1) (exponent 0))
- (cond ((< n power) false)
- ((= n power) exponent)
- (else
- (loop (* 2 power) (1+ exponent))))))
-
-(define (word->fixnum/ea source target)
- (if (eq? target source)
- (LAP (BIC B ,(make-immediate fixnum-bits-mask) ,target))
- (LAP (BIC B ,(make-immediate fixnum-bits-mask) ,source ,target))))
-
-;; This is used instead of add-constant/ea because add-constant/ea is not
-;; guaranteed to set the overflow flag correctly.
-
-(define (add-fixnum-constant source constant target)
- ;; This ignores instructions like INC and DEC because
- ;; word is always too big.
- (let ((word (* constant fixnum-1)))
- (cond ((zero? word)
- (ea/copy source target))
- ((ea/same? source target)
- (LAP (ADD L ,(make-immediate word) ,target)))
- (else
- (LAP (ADD L ,(make-immediate word) ,source ,target))))))
-\f
-;;;; Arithmetic operations
-
-(define-fixnum-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
- (lambda (target source)
- (add-fixnum-constant source 1 target)))
-
-(define-fixnum-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg
- (lambda (target source)
- (add-fixnum-constant source -1 target)))
-
-(define-fixnum-method 'FIXNUM-NOT fixnum-methods/1-arg
- (lambda (target source)
- (let ((rtarget (target-or-register target)))
- (LAP (MCOM L ,source ,rtarget)
- ,@(word->fixnum/ea rtarget target)))))
-
-(let-syntax
- ((binary/commutative
- (sc-macro-transformer
- (lambda (form environment)
- `(DEFINE-FIXNUM-METHOD ',(cadr form) FIXNUM-METHODS/2-ARGS
- (LAMBDA (TARGET SOURCE1 SOURCE2)
- (IF (EA/SAME? SOURCE1 SOURCE2)
- (,(close-syntax (cadddr form) environment)
- TARGET
- (IF (OR (EQ? TARGET SOURCE1)
- (EQ? TARGET SOURCE2))
- TARGET
- SOURCE1))
- (COMMUTE TARGET SOURCE1 SOURCE2
- (LAMBDA (SOURCE*)
- (LAP (,(caddr form) L ,',SOURCE* ,',TARGET)))
- (LAMBDA ()
- (LAP (,(caddr form) L ,',SOURCE1 ,',SOURCE2
- ,',TARGET)))))))))))
- (binary/commutative PLUS-FIXNUM ADD
- (lambda (target source)
- (if (eq? target source)
- (LAP (ADD L ,source ,target))
- (LAP (ADD L ,source ,source ,target)))))
- (binary/commutative FIXNUM-OR BIS
- (lambda (target source)
- (if (eq? target source)
- (LAP)
- (LAP (MOV L ,source ,target)))))
- (binary/commutative FIXNUM-XOR XOR
- (lambda (target source)
- source ; ignored
- (load-fixnum-constant target))))
-
-(let-syntax
- ((binary/noncommutative
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-FIXNUM-METHOD ',(cadr form) FIXNUM-METHODS/2-ARGS
- (LAMBDA (TARGET SOURCE1 SOURCE2)
- (COND ((EA/SAME? SOURCE1 SOURCE2)
- (LOAD-FIXNUM-CONSTANT 0 TARGET))
- ((EQ? TARGET SOURCE1)
- (LAP (,(caddr form) L ,',SOURCE2 ,',TARGET)))
- (ELSE
- (LAP (,(caddr form) L ,',SOURCE2 ,',SOURCE1
- ,',TARGET))))))))))
- (binary/noncommutative MINUS-FIXNUM SUB)
- (binary/noncommutative FIXNUM-ANDC BIC))
-\f
-(define-fixnum-method 'FIXNUM-AND fixnum-methods/2-args
- (lambda (target source1 source2)
- (if (ea/same? source1 source2)
- (ea/copy source1 target)
- (let ((temp (standard-temporary-reference)))
- (commute target source1 source2
- (lambda (source*)
- (LAP (MCOM L ,source* ,temp)
- (BIC L ,temp ,target)))
- (lambda ()
- (LAP (MCOM L ,source1 ,temp)
- (BIC L ,temp ,source2 ,target))))))))
-
-(define-fixnum-method 'MULTIPLY-FIXNUM fixnum-methods/2-args
- (let ((shift (- 0 scheme-type-width)))
- (lambda (target source1 source2)
- (if (not (effective-address/register? target))
- (let ((temp (standard-temporary-reference)))
- (commute target source1 source2
- (lambda (source*)
- (LAP (ASH L ,(make-immediate shift) ,source* ,temp)
- (MUL L ,temp ,target)))
- (lambda ()
- (LAP (ASH L ,(make-immediate shift) ,source1 ,temp)
- (MUL L ,temp ,source2 ,target)))))
- (commute
- target source1 source2
- (lambda (source*)
- (cond ((not (ea/same? target source*))
- (LAP (ASH L ,(make-immediate shift) ,target ,target)
- (MUL L ,source* ,target)))
- ((even? scheme-type-width)
- (let ((shift (quotient shift 2)))
- (LAP (ASH L ,(make-immediate shift) ,target ,target)
- (MUL L ,target ,target))))
- (else
- (let ((temp (standard-temporary-reference)))
- (LAP (ASH L ,(make-immediate shift) ,target ,temp)
- (MUL L ,temp ,target))))))
- (lambda ()
- (LAP (ASH L ,(make-immediate shift) ,source1 ,target)
- (MUL L ,source2 ,target))))))))
-
-(define (code-fixnum-shift target source1 source2)
- #|
- ;; This does arithmetic shifting, rather than logical!
- (let* ((rtarget (target-or-register target))
- (temp (if (eq? rtarget target)
- (standard-temporary-reference)
- rtarget)))
- (LAP (ASH L ,(make-immediate (- 0 scheme-type-width))
- ,source2 ,temp)
- (ASH L ,temp ,source1 ,rtarget)
- ,@(word->fixnum/ea rtarget target)))
- |#
- ;; This is a kludge that depends on the fact that there are
- ;; always scheme-type-width 0 bits at the bottom.
- (let* ((rtarget (target-or-register target))
- (temp (standard-temporary-reference)))
- (LAP (ASH L ,(make-immediate (- 0 scheme-type-width))
- ,source2 ,temp)
- (ROTL (S 31) ,source1 ,rtarget) ; guarantee sign bit of 0.
- (ASH L ,temp ,rtarget ,rtarget)
- (ROTL (S 1) ,rtarget ,rtarget) ; undo effect of previous ROTL.
- ,@(word->fixnum/ea rtarget target))))
-
-(define-fixnum-method 'FIXNUM-LSH fixnum-methods/2-args
- code-fixnum-shift)
-\f
-(define-fixnum-method 'FIXNUM-QUOTIENT fixnum-methods/2-args
- (lambda (target source1 source2)
- (if (ea/same? source1 source2)
- (load-fixnum-constant 1 target)
- (code-fixnum-quotient target source1 source2))))
-
-(define-fixnum-method 'FIXNUM-REMAINDER fixnum-methods/2-args
- (lambda (target source1 source2)
- (if (ea/same? source1 source2)
- (load-fixnum-constant 0 target)
- (code-fixnum-remainder target source1 source2))))
-
-(define-fixnum-method 'PLUS-FIXNUM fixnum-methods/2-args-constant
- (lambda (target source n)
- (add-fixnum-constant source n target)))
-
-(define-fixnum-method 'MINUS-FIXNUM fixnum-methods/2-args-constant
- (lambda (target source n)
- (add-fixnum-constant source (- 0 n) target)))
-
-(define-fixnum-method 'MINUS-FIXNUM fixnum-methods/2-args-tnatsnoc
- (lambda (target n source)
- (if (zero? n)
- (LAP (MNEG L ,source ,target))
- (LAP (SUB L ,source ,(make-immediate (* n fixnum-1)) ,target)))))
-
-(let-syntax
- ((binary-fixnum/constant
- (sc-macro-transformer
- (lambda (form environment)
- (let ((->constant (close-syntax (list-ref form 4) environment))
- (identity? (close-syntax (list-ref form 5) environment)))
- `(DEFINE-FIXNUM-METHOD ',(cadr form) FIXNUM-METHODS/2-ARGS-CONSTANT
- (LAMBDA (TARGET SOURCE N)
- (COND ((EQV? N ,(cadddr form))
- (LOAD-FIXNUM-CONSTANT ,(cadddr form) TARGET))
- ((,identity? N)
- (EA/COPY SOURCE TARGET))
- (ELSE
- (LET ((CONSTANT (* FIXNUM-1 (,->constant N))))
- (IF (EA/SAME? SOURCE TARGET)
- (LAP (,(caddr form) L ,',(make-immediate constant)
- ,',target))
- (LAP (,(caddr form) L
- ,',(make-immediate constant)
- ,',source
- ,',target)))))))))))))
-
- (binary-fixnum/constant FIXNUM-OR BIS -1 identity-procedure zero?)
- (binary-fixnum/constant FIXNUM-XOR XOR 'SELF identity-procedure zero?)
- (binary-fixnum/constant FIXNUM-AND BIC 0 fix:not (lambda (n) (= n -1))))
-
-(define-fixnum-method 'FIXNUM-ANDC fixnum-methods/2-args-constant
- (lambda (target source n)
- (cond ((zero? n)
- (ea/copy source target))
- ((= n -1)
- (load-fixnum-constant 0 target))
- ((eq? target source)
- (LAP (BIC L ,(make-immediate (* n fixnum-1)) ,target)))
- (else
- (LAP (BIC L ,(make-immediate (* n fixnum-1)) ,source ,target))))))
-
-(define-fixnum-method 'FIXNUM-ANDC fixnum-methods/2-args-tnatsnoc
- (lambda (target n source)
- (if (zero? n)
- (load-fixnum-constant 0 target)
- (LAP (BIC L ,source ,(make-immediate (* n fixnum-1)) ,target)))))
-\f
-(define-fixnum-method 'FIXNUM-LSH fixnum-methods/2-args-constant
- (lambda (target source n)
- (cond ((zero? n)
- (ea/copy source target))
- ((not (<= (- 0 scheme-datum-width) n scheme-datum-width))
- (load-fixnum-constant 0 target))
- ((not (negative? n))
- (LAP (ASH L ,(make-immediate n) ,source ,target)))
- ;; The following two cases depend on having scheme-type-width
- ;; 0 bits at the bottom.
- ((>= n (- 0 scheme-type-width))
- (let ((rtarget (target-or-register target)))
- (LAP (ROTL (S ,(+ 32 n)) ,source ,rtarget)
- ,@(word->fixnum/ea rtarget target))))
- (else
- (let ((rtarget (target-or-register target)))
- (LAP (ROTL (S 31) ,source ,rtarget)
- (ASH L ,(make-immediate (1+ n)) ,rtarget ,rtarget)
- ,@(word->fixnum/ea rtarget target)))))))
-
-(define-fixnum-method 'FIXNUM-LSH fixnum-methods/2-args-tnatsnoc
- (lambda (target n source)
- (if (zero? n)
- (load-fixnum-constant 0 target)
- (code-fixnum-shift target (make-immediate (* n fixnum-1)) source))))
-
-(define-fixnum-method 'MULTIPLY-FIXNUM fixnum-methods/2-args-constant
- (lambda (target source n)
- (cond ((zero? n)
- (load-fixnum-constant 0 target))
- ((= n 1)
- (ea/copy source target))
- ((= n -1)
- (LAP (MNEG L ,source ,target)))
- ((integer-power-of-2? (if (negative? n) (- 0 n) n))
- =>
- (lambda (expt-of-2)
- (if (negative? n)
- (let ((rtarget (target-or-register target)))
- (LAP (ASH L ,(make-immediate expt-of-2) ,source ,rtarget)
- (MNEG L ,rtarget ,target)))
- (LAP (ASH L ,(make-immediate expt-of-2) ,source ,target)))))
- ((eq? target source)
- (LAP (MUL L ,(make-immediate n) ,target)))
- (else
- (LAP (MUL L ,(make-immediate n) ,source ,target))))))
-
-(define-fixnum-method 'FIXNUM-QUOTIENT fixnum-methods/2-args-constant
- (lambda (target source n)
- (cond ((= n 1)
- (ea/copy source target))
- ((= n -1)
- (LAP (MNEG L ,source ,target)))
- ((integer-power-of-2? (if (negative? n) (- 0 n) n))
- =>
- (lambda (expt-of-2)
- (let ((label (generate-label 'QUO-SHIFT))
- (absn (if (negative? n) (- 0 n) n))
- (rtarget (target-or-register target)))
- (LAP ,@(if (eq? rtarget source)
- (LAP (TST L ,rtarget))
- (LAP (MOV L ,source ,rtarget)))
- (B GEQ (@PCR ,label))
- (ADD L ,(make-immediate (* (-1+ absn) fixnum-1)) ,rtarget)
- (LABEL ,label)
- (ASH L ,(make-immediate (- 0 expt-of-2)) ,rtarget ,rtarget)
- ,@(if (negative? n)
- (LAP ,@(word->fixnum/ea rtarget rtarget)
- (MNEG L ,rtarget ,target))
- (word->fixnum/ea rtarget target))))))
- (else
- ;; This includes negative n.
- (code-fixnum-quotient target source
- (make-immediate (* n fixnum-1)))))))
-\f
-(define-fixnum-method 'FIXNUM-QUOTIENT fixnum-methods/2-args-tnatsnoc
- (lambda (target n source)
- (if (zero? n)
- (load-fixnum-constant 0 target)
- (code-fixnum-quotient target (make-immediate (* n fixnum-1))
- source))))
-
-(define-fixnum-method 'FIXNUM-REMAINDER fixnum-methods/2-args-constant
- (lambda (target source n)
- ;; (remainder x y) is 0 or has the sign of x.
- ;; Thus we can always "divide" by (abs y) to make things simpler.
- (let ((n (if (negative? n) (- 0 n) n)))
- (cond ((= n 1)
- (load-fixnum-constant 0 target))
- ((integer-power-of-2? n)
- =>
- (lambda (expt-of-2)
- (let ((sign (standard-temporary-reference))
- (label (generate-label 'REM-MERGE))
- (nbits (+ scheme-type-width expt-of-2)))
- ;; This may produce a branch to a branch, but a
- ;; peephole optimizer should be able to fix this.
- (LAP (EXTV S (S 31) (S 1) ,source ,sign)
- (EXTV Z (S 0) (S ,nbits) ,source ,target)
- (B EQL (@PCR ,label))
- (INSV ,sign (S ,nbits) (S ,(- 32 nbits)) ,target)
- (LABEL ,label)))))
- (else
- (code-fixnum-remainder target source
- (make-immediate (* n fixnum-1))))))))
-
-(define-fixnum-method 'FIXNUM-REMAINDER fixnum-methods/2-args-tnatsnoc
- (lambda (target n source)
- (if (zero? n)
- (load-fixnum-constant 0 target)
- (code-fixnum-remainder target (make-immediate (* n fixnum-1))
- source))))
-
-(define (code-fixnum-quotient target source1 source2)
- (let ((rtarget (target-or-register target)))
- (LAP ,@(if (eq? rtarget source1)
- (LAP (DIV L ,source2 ,rtarget))
- (LAP (DIV L ,source2 ,source1 ,rtarget)))
- (ASH L (S ,scheme-type-width) ,rtarget ,target))))
-
-(define (code-fixnum-remainder target source1 source2)
- #|
- ;; This does not work because the second arg to EDIV
- ;; is a quad and we have a long. It must be sign extended.
- ;; In addition, the compiler does not currently support
- ;; consecutive register allocation so the work must be done
- ;; in memory.
- (LAP (EDIV ,source2 ,source1 ,(standard-temporary-reference)
- ,target))
- |#
- (define (perform source-reg temp)
- ;; sign extend to quad on the stack
- (LAP (EXTV S (S 31) (S 1) ,source-reg (@-R 14))
- (PUSHL ,source-reg)
- (EDIV ,source2 (@R+ 14) ,temp ,target)))
-
- (let ((temp (standard-temporary-reference)))
- (if (effective-address/register? source1)
- (perform source1 temp)
- (LAP (MOV L ,source1 ,temp)
- ,@(perform temp temp)))))
-\f
-;;;; Predicate utilities
-
-(define (signed-fixnum? n)
- (and (integer? n)
- (>= n signed-fixnum/lower-limit)
- (< n signed-fixnum/upper-limit)))
-
-(define (unsigned-fixnum? n)
- (and (integer? n)
- (not (negative? n))
- (< n unsigned-fixnum/upper-limit)))
-
-(define (guarantee-signed-fixnum n)
- (if (not (signed-fixnum? n)) (error "Not a signed fixnum" n))
- n)
-
-(define (guarantee-unsigned-fixnum n)
- (if (not (unsigned-fixnum? n)) (error "Not a unsigned fixnum" n))
- n)
-
-(define (fixnum-predicate->cc predicate)
- (case predicate
- ((EQUAL-FIXNUM? ZERO-FIXNUM?) 'EQL)
- ((LESS-THAN-FIXNUM? NEGATIVE-FIXNUM?) 'LSS)
- ((GREATER-THAN-FIXNUM? POSITIVE-FIXNUM?) 'GTR)
- (else
- (error "FIXNUM-PREDICATE->CC: Unknown predicate" predicate))))
-
-(define-integrable (test-fixnum/ea ea)
- (LAP (TST L ,ea)))
-
-(define (fixnum-predicate/register*constant register constant cc)
- (set-standard-branches! cc)
- (guarantee-signed-fixnum constant)
- (if (zero? constant)
- (test-fixnum/ea (any-register-reference register))
- (LAP (CMP L ,(any-register-reference register)
- ,(make-immediate (* constant fixnum-1))))))
-
-(define (fixnum-predicate/memory*constant memory constant cc)
- (set-standard-branches! cc)
- (guarantee-signed-fixnum constant)
- (if (zero? constant)
- (test-fixnum/ea memory)
- (LAP (CMP L ,memory ,(make-immediate (* constant fixnum-1))))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RTL Rewrite Rules
-;;; package: (compiler lap-syntaxer)
-
-(declare (usual-integrations))
-\f
-;;;; Synthesized Data
-
-(define-rule rewriting
- (CONS-NON-POINTER (? type) (? datum))
- ;; On the VAX, there's no difference between an address and a datum,
- ;; so the rules for constructing non-pointer objects are the same as
- ;; those for pointer objects.
- (rtl:make-cons-pointer type datum))
-
-(define-rule rewriting
- (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
- (QUALIFIER (rtl:machine-constant? type))
- (rtl:make-cons-pointer type datum))
-
-(define-rule rewriting
- (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
- (QUALIFIER
- (and (rtl:object->type? type)
- (rtl:constant? (rtl:object->type-expression type))))
- (rtl:make-cons-pointer
- (rtl:make-machine-constant
- (object-type (rtl:constant-value (rtl:object->type-expression datum))))
- datum))
-
-(define-rule rewriting
- (CONS-POINTER (? type) (REGISTER (? datum register-known-value)))
- (QUALIFIER (rtl:machine-constant? datum))
- (rtl:make-cons-pointer type datum))
-
-(define-rule rewriting
- (CONS-POINTER (? type) (REGISTER (? datum register-known-value)))
- (QUALIFIER
- (and (rtl:object->datum? datum)
- (rtl:constant-non-pointer? (rtl:object->datum-expression datum))))
- (rtl:make-cons-pointer
- type
- (rtl:make-machine-constant
- (careful-object-datum
- (rtl:constant-value (rtl:object->datum-expression datum))))))
-
-(define-rule rewriting
- (OBJECT->TYPE (REGISTER (? source register-known-value)))
- (QUALIFIER (rtl:constant? source))
- (rtl:make-machine-constant (object-type (rtl:constant-value source))))
-
-(define-rule rewriting
- (OBJECT->DATUM (REGISTER (? source register-known-value)))
- (QUALIFIER (rtl:constant-non-pointer? source))
- (rtl:make-machine-constant
- (careful-object-datum (rtl:constant-value source))))
-
-(define (rtl:constant-non-pointer? expression)
- (and (rtl:constant? expression)
- (non-pointer-object? (rtl:constant-value expression))))
-\f
-;;; These rules are losers because there's no abstract way to cons a
-;;; statement or a predicate without also getting some CFG structure.
-
-;;; Shouldn't these rules use (rtl:make-machine-constant 0)
-;;; rather than comparand? Of course, there would have to
-;;; be more translation rules, but... -- Jinx
-
-(define-rule rewriting
- ;; CLR instruction
- (ASSIGN (? target) (REGISTER (? comparand register-known-value)))
- (QUALIFIER (rtl:immediate-zero-constant? comparand))
- (list 'ASSIGN target comparand))
-
-(define-rule rewriting
- ;; TST instruction
- (EQ-TEST (? source) (REGISTER (? comparand register-known-value)))
- (QUALIFIER (rtl:immediate-zero-constant? comparand))
- (list 'EQ-TEST source comparand))
-
-(define-rule rewriting
- ;; TSTL instruction
- (EQ-TEST (REGISTER (? comparand register-known-value)) (? source))
- (QUALIFIER (rtl:immediate-zero-constant? comparand))
- (list 'EQ-TEST source comparand))
-
-(define (rtl:immediate-zero-constant? expression)
- (cond ((rtl:constant? expression)
- (let ((value (rtl:constant-value expression)))
- (and (non-pointer-object? value)
- (zero? (object-type value))
- (zero? (careful-object-datum value)))))
- ((rtl:cons-pointer? expression)
- (and (let ((expression (rtl:cons-pointer-type expression)))
- (and (rtl:machine-constant? expression)
- (zero? (rtl:machine-constant-value expression))))
- (let ((expression (rtl:cons-pointer-datum expression)))
- (and (rtl:machine-constant? expression)
- (zero? (rtl:machine-constant-value expression))))))
- (else false)))
-\f
-;;;; Fixnums
-
-(define-rule rewriting
- (OBJECT->FIXNUM (REGISTER (? source register-known-value)))
- (QUALIFIER (rtl:constant-fixnum? source))
- (rtl:make-object->fixnum source))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (REGISTER (? operand-1 register-known-value))
- (? operand-2)
- (? overflow?))
- (QUALIFIER
- (rtl:constant-fixnum-test operand-1
- (lambda (n)
- (or (zero? n)
- (integer-power-of-2? n)))))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 overflow?))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- (? overflow?))
- (QUALIFIER
- (rtl:constant-fixnum-test operand-2
- (lambda (n)
- (or (zero? n)
- (= -1 n)
- (integer-power-of-2? n)))))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 overflow?))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS (? operator)
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- (? overflow?))
- (QUALIFIER
- (and (memq operator '(PLUS-FIXNUM MINUS-FIXNUM))
- (rtl:constant-fixnum-test operand-2 zero?)))
- (rtl:make-fixnum-2-args operator operand-1 operand-2 overflow?))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS (? operator)
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- (? overflow?))
- (QUALIFIER
- (and (memq operator '(FIXNUM-QUOTIENT FIXNUM-REMAINDER))
- (rtl:constant-fixnum-test operand-2
- (lambda (n)
- (or (= -1 n)
- (integer-power-of-2? n))))))
- (rtl:make-fixnum-2-args operator operand-1 operand-2 overflow?))
-
-(define (rtl:constant-fixnum? expression)
- (and (rtl:constant? expression)
- (fix:fixnum? (rtl:constant-value expression))))
-
-(define (rtl:constant-fixnum-test expression predicate)
- (and (rtl:object->fixnum? expression)
- (let ((expression (rtl:object->fixnum-expression expression)))
- (and (rtl:constant? expression)
- (let ((n (rtl:constant-value expression)))
- (and (fix:fixnum? n)
- (predicate n)))))))
\ No newline at end of file
#| -*-Scheme-*-
-$MC68020-Header: coerce.scm,v 1.10 88/08/31 05:56:37 GMT cph Exp $
-
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
#| -*-Scheme-*-
-$MC68020-Header: /scheme/compiler/bobcat/RCS/rgspcm.scm,v 4.2 1991/05/06 23:17:03 jinx Exp $
-
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
(define-load-option '*PARSER
(guarded-system-loader '(runtime *parser) "star-parser"))
-(define-load-option 'PC-SAMPLE
- (guarded-system-loader '(pc-sample) "pcsample"))
-
-(define-load-option 'RCS
- (guarded-system-loader '(rcs) "rcs"))
-
(define-load-option 'SF
(guarded-system-loader '(scode-optimizer) "sf"))
(define-load-option 'STUDENT
(guarded-system-loader '(student) "6001"))
-(define-load-option 'SWAT
- (guarded-system-loader '(swat) "swat"))
-
(define-load-option 'WIN32
(guarded-system-loader '(win32) "win32"))
case ${_mit_scheme_native_code_spec} in
yes|YES|y|Y)
case ${_mit_scheme_native_code_host_cpu} in
- alpha*)
- mit_scheme_native_code=alpha
- ;;
- hppa*)
- mit_scheme_native_code=hppa
- ;;
i386)
mit_scheme_native_code=i386
;;
- m68k|m680?0)
- mit_scheme_native_code=mc68k
- ;;
- mips*)
- mit_scheme_native_code=mips
- ;;
- vax)
- mit_scheme_native_code=vax
- ;;
x86_64)
mit_scheme_native_code=x86-64
;;
+++ /dev/null
- ### -*- Midas -*-
- ###
- ### Copyright (C) 1992 Digital Equipment Corporation (D.E.C.)
- ### Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
- ### 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- ### 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
- ### 2014, 2015, 2016, 2017 Massachusetts Institute of Technology
- ###
- ### This software was developed at the Digital Equipment Corporation
- ### Cambridge Research Laboratory. Permission to copy this software, to
- ### redistribute it, and to use it for any purpose is granted, subject to
- ### the following restrictions and understandings.
- ###
- ### 1. Any copy made of this software must include this copyright notice
- ### in full.
- ###
- ### 2. Users of this software agree to make their best efforts (a) to
- ### return to both the Digital Equipment Corporation Cambridge Research
- ### Lab (CRL) and the MIT Scheme project any improvements or extensions
- ### that they make, so that these may be included in future releases; and
- ### (b) to inform CRL and MIT of noteworthy uses of this software.
- ###
- ### 3. All materials developed as a consequence of the use of this
- ### software shall duly acknowledge such use, in accordance with the usual
- ### standards of acknowledging credit in academic research.
- ###
- ### 4. D.E.C. has made no warrantee or representation that the operation
- ### of this software will be error-free, and D.E.C. is under no obligation
- ### to provide any services, by way of maintenance, update, or otherwise.
- ###
- ### 5. In conjunction with products arising from the use of this material,
- ### there shall be no use of the name of the Digital Equipment Corporation
- ### nor of any adaptation thereof in any advertising, promotional, or
- ### sales literature without prior written consent from D.E.C. in each
- ### case.
-\f
- ### Alpha Architecture assembly language part of the compiled
- ### code interface. See cmpint.txt, cmpint.c, cmpint-alpha.h, and
- ### cmpgc.h for more documentation.
- ###
- ### NOTE:
- ### Assumptions:
- ###
- ### 1) The C compiler divides registers into three groups:
- ### - Linkage registers, used for procedure calls and global
- ### references. On Alpha: 26 (return address), 27 (procedure
- ### descriptor), 28 (assembler temp), 29 (global pointer),
- ### 30 (stack pointer), and 31 (always 0).
- ### - super temporaries, not preserved accross procedure calls and
- ### always usable. On Alpha: 0-8, 16-21 (argument registers), and
- ### 22-25. Values are returned in 0.
- ### - preserved registers saved by the callee if they are written.
- ### On Alpha: 9-14, 15 (frame base)
- ###
- ### 2) Arguments, if passed on a stack, are popped by the caller.
- ### Thus most "leaf" procedures need not worry about them. On
- ### Alpha: The first six arguments are passed in registers and
- ### have no space allocated on the stack. Integer scalars are
- ### returned in register 0; floating point scalars are returned
- ### in fp0; floating point complex numbers are returned in fp0 and
- ### fp1; structured values are returned through a pointer passed
- ### in the first argument register and the remaining arguments are
- ### shifted over by one register.
- ###
- ### 3) There is a hardware or software maintained stack for
- ### control. The procedure calling sequence may leave return
- ### addresses in registers, but they must be saved somewhere for
- ### nested calls and recursive procedures. On Alpha: Passed in a
- ### register, and no slot stack exists. The return link is in 26.
- ### The (C) stack pointer is in 30.
- ###
- ### 4) C procedures return long values in a super temporary
- ### register. Alpha: two or more word structures are returned in
- ### a location specified by the contents of the first argument
- ### register, and all other arguments are shifted over one
- ### location (i.e. apparent argument 1 is passed in the register
- ### usually used for argument 2, etc.)
- ###
- ### 5) On Alpha we don't know the floating point register save
- ### convention yet.
- ###
- ### Compiled Scheme code uses the following register convention.
- ### Note that scheme_to_interface, the register block, the closure
- ### hook, link_to_interface, compiled_entry_type_bits, and
- ### closure_free are preserved by C calls, but the others are not,
- ### since they change dynamically. trampoline_to_interface can be
- ### reached at a fixed offset from scheme_to_interface.
- ###
- ### Register Usage Information
- ### Number .dis C Scheme
- ### ====== ==== ======= ======
- ### 0 v0 Return Value Return Value
- ### 1 t0 caller saves <free, but utility index (not shifted)>
- ### 2 t1 caller saves Stack-Pointer
- ### 3 t2 caller saves MemTop
- ### 4 t3 caller saves Free
- ### 5 t4 caller saves Dynamic Link
- ### 6 t5 caller saves <free>
- ### 7 t6 caller saves <free>
- ### 8 t7 caller saves <free>
- ### 9 s0 callee saves Regs-Pointer
- ### 10 s1 callee saves Scheme-To-Interface
- ### 11 s2 callee saves Closure Hook (jump ind. for full addr.)
- ### 12 s3 callee saves Link-To-Interface
- ### 13 s4 callee saves Compiled-Entry-Type-Bits
- ### 14 s5 callee saves Closure-Free
- ### 15 fp? frame base <free>
- ### 16 a0 argument 1 <free, but for utilities>
- ### 17 a1 argument 2 <free, but for utilities>
- ### 18 a2 argument 3 <free, but for utilities>
- ### 19 a3 argument 4 <free, but for utilities>
- ### 20 a4 argument 5 <free, but for utilities>
- ### 21 a5 argument 6 <free>
- ### 22 t8 caller saves <free>
- ### 23 t9 caller saves <free>
- ### 24 t10 caller saves <free>
- ### 25 t11 caller saves <free>
- ### 26 ra return address <free, but used for closure linkage>
- ### 27 t12 proc. descript. <free>
- ### 28 at? volatile scratch Assembler Temporary (tensioning)
- ### 29 gp global pointer <free>
- ### 30 sp stack pointer C Stack Pointer (do not use!)
- ### 31 zero Z E R O Z E R O
-
- # The following are derived from cmpint-alpha.h, scaled by 8
-#define REGBLOCK_FIRST_EXTRA 128
-#define REGBLOCK_ADDRESS_OF_STACK_POINTER REGBLOCK_FIRST_EXTRA
-#define REGBLOCK_ADDRESS_OF_FREE REGBLOCK_FIRST_EXTRA+8
-#define REGBLOCK_ADDRESS_OF_UTILITY_TABLE REGBLOCK_FIRST_EXTRA+16
-#define REGBLOCK_ALLOCATE_CLOSURE REGBLOCK_FIRST_EXTRA+24
-
- # The following are derived from const.h, scaled by 8
-#define REGBLOCK_MEMTOP 0
-#define REGBLOCK_STACKGUARD 8
-#define REGBLOCK_VAL 16
-#define REGBLOCK_ENV 24
-#define REGBLOCK_COMPILER_TEMP 32
-#define REGBLOCK_EXPR 40
-#define REGBLOCK_RETURN 48
-#define REGBLOCK_LEXPR_ACTUALS 56
-#define REGBLOCK_PRIMITIVE 64
-#define REGBLOCK_CLOSURE_FREE 72
-#define REGBLOCK_CLOSURE_SPACE 80
-
-#include "types.h"
-#include <machine/pal.h>
- .text
- .set noat
- .set noreorder
- .set nomacro
-
- ### A bunch of .aent pseudo-ops were removed because they generate
- ### a NOP, and we are counting instructions
-
- # .align 16
- # ^ Apparently the assembler does not like that, but will take the following.
- # Even though the manual says 1-4 is the valid range.
-
- .align 12
- .ent hook_jump_table 0
- .globl hook_jump_table
-hook_jump_table:
- # All entries in this table must be exactly four
- # instructions long (see lapgen.scm)
-
- ### .aent scheme_closure_hook
- .globl scheme_closure_hook
-scheme_closure_hook: # Entry 0, Offset 0
- # Compiled code in a closure can be of the form
- # JMP $26,($11),0
- # <desired address>
- # when <desired address> is too far away, and $11
- # points here.
- ldq $22,0($26)
- jmp $28,($22),0
- nop
- nop
-
- ### .aent asm_allocate_closure
-asm_allocate_closure: # Entry 1, Offset 16
- # This must preserve ALL Scheme allocatable registers
- # $16 has the total number of Scheme objects to allocate
- # $17 has pointer to the first entry point, 16 bytes into the
- # block we failed to allocate.
- # $28 has the return address
- # Returns an offset 16 bytes into the allocated space in $17
- # It fills the allocated region with
- # SUBQ SP,#8,SP//JMP $26,($11),hint
- # and then synchronizes the I- and D-caches for this region of
- # memory. It also needs to update regnum:closure-free and
- # free (i.e. registers $14 and $4)
-
- stq $0,80($sp)
- stq $1,88($sp)
- ldq $1,REGBLOCK_ADDRESS_OF_FREE($9)
- br $31,asm_allocate_continue
-
-asm_allocate_continue:
- stq $2,96($sp)
- # Register 3 is MemTop
- stq $4,0($1) # Store into Free itself
- stq $5,104($sp)
- stq $6,112($sp)
- stq $7,120($sp)
- stq $8,128($sp)
- # 9 - 15 are callee saves anyway
- # 16 and 17 are the argument registers we are passing through
- stq $18,136($sp)
- stq $19,144($sp)
- stq $20,152($sp)
- stq $21,160($sp)
- stq $22,168($sp)
- stq $23,176($sp)
- stq $24,184($sp)
- stq $25,192($sp)
- stq $26,200($sp)
- stq $27,208($sp)
- stq $28,216($sp)
- stq $29,224($sp)
- # 30 is the stack pointer itself, 31 is ZERO
- ldq $27,REGBLOCK_ALLOCATE_CLOSURE($9)
- jsr $26,($27),allocate_closure
- ldq $29,REGBLOCK_ADDRESS_OF_FREE($9)
- bis $0,$0,$17 # Return the value in $17
- ldq $0,80($sp)
- ldq $1,88($sp)
- ldq $2,96($sp)
- ldq $3,REGBLOCK_MEMTOP($9)
- ldq $4,0($29) # Retrieve from Free itself
- ldq $5,104($sp)
- ldq $6,112($sp)
- ldq $7,120($sp)
- ldq $8,128($sp)
- ldq $14,REGBLOCK_CLOSURE_FREE($9)
- ldq $18,136($sp)
- ldq $19,144($sp)
- ldq $20,152($sp)
- ldq $21,160($sp)
- ldq $22,168($sp)
- ldq $23,176($sp)
- ldq $24,184($sp)
- ldq $25,192($sp)
- ldq $26,200($sp)
- ldq $27,208($sp)
- ldq $28,216($sp)
- ldq $29,224($sp)
- ret $28,($28),1
- .end hook_jump_table
-
- .align 4
- .globl Flush_I_Cache
- .ent Flush_I_Cache 0
-Flush_I_Cache:
- call_pal PAL_imb
- ret $28,($26),1
- .end Flush_I_Cache
-\f
- # Argument (in $a0) is a compiled Scheme entry point
- # but save C registers first
- #
- # Frame layout:
-#define FRAME_SIZE 232
- # ....................
- # FS . . <-- Old SP (not our property)
- # ....................
- #FS-8 . Register save .
- # . area used by .
- # 80 . Allocate_Closure .
- # ....................
- # 72 . Return str. high .
- # ....................
- # 64 . Return str. low .
- # ....................
- # 56 . Caller's $9 (S0) .
- # ....................
- # 48 . Caller's $10 (S1).
- # ....................
- # 40 . Caller's $11 (S2).
- # ....................
- # 32 . Caller's $12 (S3).
- # ....................
- # 24 . Caller's $13 (S4).
- # ....................
- # 16 . Caller's $14 (S5).
- # ....................
- # 8 . Caller's $15 (FP).
- # ....................
- # 0 . Our return addr. . <-- New SP
- # ....................
-
- # IMPORTANT: If the following sequence is changed,
- # link_to_interface must remain aligned!
-
- .align 4
- .globl C_to_interface
- .ent C_to_interface 1
-C_to_interface:
- .set macro
- ldgp $gp,0($27) # Offset 0, 4
- # which expands into (low and high from linker):
- # ldah $gp,high($t12)
- # lda $gp,low($gp)
- .set nomacro
- lda $sp,-FRAME_SIZE($sp)
- # Offset 8: Allocate frame
- stq $9,56($sp) # Offset 12
- stq $10,48($sp) # Offset 16
- stq $11,40($sp) # Offset 20
- stq $12,32($sp) # Offset 24
- stq $13,24($sp) # Offset 28
- stq $14,16($sp) # Offset 32
- stq $15,8($sp) # Offset 36
- stq $26,0($sp) # Offset 40
- .mask 0x0400fe00, -FRAME_SIZE
- .frame $sp,FRAME_SIZE,$26
- br $12,setup_registers_continue
- # Offset 44
-
-#define LINK_TO_SCHEME 16
-
- # IMPORTANT: The distance between link_to_interface
- # and scheme_to_interface is fixed at LINK_TO_SCHEME bytes!
-
- ### .aent link_to_interface
-link_to_interface: # Offset 48, SHOULD BE octabyte aligned
- # $1 has utility index
- # $17 (arg 1) has return address from JMP that got you here
- # $18 etc. have other utility arguments if needed
- lda $17,4($17) # Skip over format word ...
- br $28,scheme_to_interface
- nop
- nop
-
- .align 4
- ### .aent scheme_to_interface
- .globl scheme_to_interface
-scheme_to_interface:
- # $1 has utility index (not shifted)
- # $17 (etc.) have utility arguments as needed
- ldq $24,REGBLOCK_ADDRESS_OF_UTILITY_TABLE($9) # 0
- stq $0,REGBLOCK_VAL($9) # 4
- ldq $22,REGBLOCK_ADDRESS_OF_STACK_POINTER($9) # 8
- ldq $23,REGBLOCK_ADDRESS_OF_FREE($9) # 12
- stq $14,REGBLOCK_CLOSURE_FREE($9)
- s8addq $1,$24,$24 # Address of entry in table # 16
- stq $2,0($22) # Save sp_register # 20
- ldq $27,0($24) # Destination address # 24
- lda $16,64($sp) # Return structure value here # 28
- stq $4,0($23) # Save Free # 32
- jsr $26,($27),comutil_operator_arity_trap
- ldq $22,64($sp) # Get next procedure address # 40
- ldq $16,72($sp) # Value to pass to next procedure # 44
- jmp $28,($22),interface_to_scheme # 48
-
- # Argument (in $a0) is a compiled Scheme entry point. Reload
- # the Scheme registers and go to work...any registers not reloaded
- # here must be callee saves by C.
-
- .align 4
- ### .aent interface_to_scheme
- .globl interface_to_scheme
-interface_to_scheme:
- ldq $0,REGBLOCK_VAL($9) # 64
- # Register 1 isn't used
- ldq $2,REGBLOCK_ADDRESS_OF_STACK_POINTER($9)
- ldq $3,REGBLOCK_MEMTOP($9)
- ldq $4,REGBLOCK_ADDRESS_OF_FREE($9)
- ldq $2,0($2)
- ldq $4,0($4)
- zap $0,0x80,$5 # Initialize dynamic link register
- .aent off_to_scheme_code
- .globl off_to_scheme_code
-off_to_scheme_code:
- jmp $28,($16),0 # Off to compiled code ...
-
- .align 4
-setup_registers_continue:
- .set at
- .set macro
- lda $9,Registers
- # lda $10,scheme_to_interface-link_to_interface($12)
- # ^ The assembler cannot handle the instruction above.
- # The offset is computed by counting the distance between
- # both labels.
- lda $10,LINK_TO_SCHEME($12)
- # lda $11,scheme_closure_hook-link_to_interface($12)
- # ^ The assembler cannot handle the instruction above.
- # use a more expensive 2-instruction sequence.
- lda $11,scheme_closure_hook
- .set nomacro
- .set noat
- # Register 12 already initialized
- bis $31,TC_COMPILED_ENTRY,$13
- sll $13,56,$13 # Shift to most significant byte
- ldq $14,REGBLOCK_CLOSURE_FREE($9)
- br $28,interface_to_scheme
-
- .align 4
- .aent interface_to_C
- .globl interface_to_C
-interface_to_C:
- # Argument 1 (in $16) is the returned value
- bis $16,$16,$0 # Real return value register
- ldq $26,0($sp) # Return address
- ldq $9,56($sp)
- ldq $10,48($sp)
- ldq $11,40($sp)
- ldq $12,32($sp)
- ldq $13,24($sp)
- ldq $14,16($sp)
- ldq $15,8($sp)
- lda $sp,FRAME_SIZE($sp)
- ret $28,($26), 1
- .end C_to_interface
+++ /dev/null
-changecom(`;');;; -*-Midas-*-
-;;;
-;;; Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
-;;; 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
-;;; 2014, 2015, 2016, 2017 Massachusetts Institute of Technology
-;;;
-;;; This file is part of MIT/GNU Scheme.
-;;;
-;;; MIT/GNU Scheme is free software; you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation; either version 2 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; MIT/GNU Scheme is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with MIT/GNU Scheme; if not, write to the Free Software
-;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
-;;; 02110-1301, USA.
-\f
-;;;; HP Precision Architecture assembly language part of the compiled
-;;;; code interface. See cmpint.txt, cmpint.c, cmpint-hppa.h, and
-;;;; cmpgc.h for more documentation.
-;;;;
-;;;; NOTE:
-;;;; Assumptions:
-;;;;
-;;;; 1) All registers (except double floating point registers) and
-;;;; stack locations hold a C long object.
-;;;;
-;;;; 2) The C compiler divides registers into three groups:
-;;;; - Linkage registers, used for procedure calls and global
-;;;; references. On HPPA: gr0 (always 0), gr2 (return address),
-;;;; gr27 (global data pointer), and gr30 (stack pointer).
-;;;; - super temporaries, not preserved accross procedure calls and
-;;;; always usable. On HPPA: gr1, gr19-gr26, gr28-29, gr31.
-;;;; gr26-23 are argument registers, gr28-29 are return registers.
-;;;; - preserved registers saved by the callee if they are written.
-;;;; On HPPA: gr3-gr18
-;;;;
-;;;; 3) Arguments, if passed on a stack, are popped by the caller
-;;;; or by the procedure return instruction (as on the VAX). Thus
-;;;; most "leaf" procedures need not worry about them. On HPPA: All
-;;;; arguments have slots in the stack, allocated and popped by the
-;;;; caller, but the first four words are actually passed in gr26,
-;;;; gr25, gr24, gr23, unless they are floating point arguments, in
-;;;; which case they are passed in floating point registers.
-;;;;
-;;;; 4) There is a hardware or software maintained stack for
-;;;; control. The procedure calling sequence may leave return
-;;;; addresses in registers, but they must be saved somewhere for
-;;;; nested calls and recursive procedures. On HPPA: Passed in a
-;;;; register, but a slot on the stack exists, allocated by the
-;;;; caller. The return link is in gr2 and immediately saved in
-;;;; -20(0,30) if the procedure makes further calls. The stack
-;;;; pointer is in gr30.
-;;;;
-;;;; 5) C procedures return long values in a super temporary
-;;;; register. Two word structures are returned in super temporary
-;;;; registers as well. On HPPA: gr28 is used for long returns,
-;;;; gr28/gr29 are used for two word structure returns.
-;;;; GCC returns two word structures differently: It passes
-;;;; the address of the structure in gr28!
-;;;;
-;;;; 6) Floating point registers are not preserved by this
-;;;; interface. The interface is only called from the Scheme
-;;;; interpreter, which does not use floating point data. Thus
-;;;; although the calling convention would require us to preserve
-;;;; them, they contain garbage. On HPPA: fr12-fr15 are
-;;;; callee-saves registers, fr4-fr7 are parameter registers, and
-;;;; fr8-fr11 are caller-saves registers. fr0-fr3 are status
-;;;; registers.
-;;;;
-;;;; Compiled Scheme code uses the following register convention.
-;;;; Note that scheme_to_interface_ble and the register block are
-;;;; preserved by C calls, but the others are not, since they change
-;;;; dynamically. scheme_to_interface and trampoline_to_interface can
-;;;; be reached at fixed offsets from scheme_to_interface_ble.
-;;;; - gr22 contains the Scheme stack pointer.
-;;;; - gr21 contains the Scheme free pointer.
-;;;; - gr20 contains a cached version of MemTop.
-;;;; - gr19 contains the dynamic link when needed.
-;;;; - gr5 contains the quad mask for machine pointers.
-;;;; - gr4 contains a pointer to the Scheme interpreter's
-;;;; "register" block. This block contains the compiler's copy of
-;;;; MemTop, the interpreter's registers (val, env, exp, etc),
-;;;; temporary locations for compiled code.
-;;;; - gr3 contains the address of scheme_to_interface_ble.
-;;;;
-;;;; All other registers are available to the compiler. A
-;;;; caller-saves convention is used, so the registers need not be
-;;;; preserved by subprocedures.
-;;;;
-;;;; ADB mnemonics:
-;;;; arg3 = gr23; arg2 = gr24; arg1 = gr25; arg0 = gr26
-;;;; dp = gr27; ret0 = gr28; ret1 = gr29; sp = gr30; rp = gr02
-\f
-changequote(",")
-define(HEX, "0x$1")
-define(ASM_DEBUG, 0)
-define(TC_LENGTH, ifdef("TYPE_CODE_LENGTH", TYPE_CODE_LENGTH, 6))
-define(QUAD_MASK, eval(2 ** (TC_LENGTH - 2)))
-define(LOW_TC_BIT, eval(TC_LENGTH - 1))
-define(DATUM_LENGTH, eval(32 - TC_LENGTH))
-define(FIXNUM_LENGTH, DATUM_LENGTH)
-define(FIXNUM_POS, eval(FIXNUM_LENGTH - 1))
-define(FIXNUM_BIT, eval(TC_LENGTH + 1))
-define(TC_START, eval(TC_LENGTH - 1))
-define(TC_FLONUM, 0x6)
-define(TC_VECTOR, 0xa)
-define(TC_FIXNUM, 0x1a)
-define(TC_STRING, 0x1e)
-define(TC_NMV, 0x27)
-define(TC_CCENTRY, 0x28)
-define(FLONUM_VECTOR_HEADER, eval((TC_NMV * (2 ** DATUM_LENGTH)) + 2))
-define(TC_FALSE, 0)
-define(TC_TRUE, 0x8)
-define(SHARP_F, eval(TC_FALSE * (2 ** DATUM_LENGTH)))
-define(SHARP_T, eval(TC_TRUE * (2 ** DATUM_LENGTH)))
-define(C_FRAME_SIZE,
- ifdef("HPC", 112,
- ifdef("GCC", 120,
- `Unknown C compiler: bad frame size')))
-define(INT_BIT_STACK_OVERFLOW, 31)
-
- .SPACE $TEXT$
- .SUBSPA $CODE$,QUAD=0,ALIGN=8,ACCESS=44,CODE_ONLY
-C_to_interface
- .PROC
- .CALLINFO CALLER,FRAME=28,SAVE_RP
- .ENTRY
- STW 2,-20(0,30) ; Save return address
- STWM 3,eval(C_FRAME_SIZE)(30) ; Save first reg,
- STW 4,-108(30) ; and allocate frame
- STW 5,-104(30) ; Save the other regs
- STW 6,-100(30)
- STW 7,-96(30)
- STW 8,-92(30)
- STW 9,-88(30)
- STW 10,-84(30)
- STW 11,-80(30)
- STW 12,-76(30)
- STW 13,-72(30)
- STW 14,-68(30)
- STW 15,-64(30)
- STW 16,-60(30)
- STW 17,-56(30)
- STW 18,-52(30)
- ADDIL L'Registers-$global$,27
- LDO R'Registers-$global$(1),4 ; Setup Regs
- LDI QUAD_MASK,5
-
-ep_interface_to_scheme
- LDW 8(0,4),2 ; Move interpreter reg to val
- COPY 2,19 ; Restore dynamic link if any
- DEP 5,LOW_TC_BIT,TC_LENGTH,19
- ADDIL L'sp_register-$global$,27
- LDW R'sp_register-$global$(1),22 ; Setup stack pointer
-\f
-ep_interface_to_scheme_2
- LDW 0(0,4),20 ; Setup memtop
- ADDIL L'Free-$global$,27
- LDW R'Free-$global$(1),21 ; Setup free
- .CALL RTNVAL=GR ; out=28
- BLE 0(5,26) ; Invoke entry point
- COPY 31,3 ; Setup scheme_to_interface_ble
-
-scheme_to_interface_ble
- ADDI 4,31,31 ; Skip over format word ...
-trampoline_to_interface
- COPY 31,26
- DEP 0,31,2,26
-scheme_to_interface
- STW 2,8(0,4) ; Move val to interpreter reg
- ADDIL L'hppa_utility_table-$global$,27
- LDW R'hppa_utility_table-$global$(1),29
- ADDIL L'sp_register-$global$,27
- LDWX,S 28(0,29),29 ; Find handler
- STW 22,R'sp_register-$global$(1) ; Update stack pointer
- ADDIL L'Free-$global$,27
- STW 21,R'Free-$global$(1) ; Update free
- ifelse(ASM_DEBUG,1,"ADDIL L'interface_counter-$global$,27
- LDW R'interface_counter-$global$(1),21
- LDO 1(21),21
- STW 21,R'interface_counter-$global$(1)
- ADDIL L'interface_limit-$global$,27
- LDW R'interface_limit-$global$(1),22
- COMB,=,N 21,22,interface_break
-interface_proceed")
- ifdef("GCC", "LDO -116(30),28")
- .CALL ARGW0=GR,ARGW1=GR,ARGW2=GR,ARGW3=GR,RTNVAL=GR
- BLE 0(4,29) ; Call handler
- COPY 31,2 ; Setup return address
- ifdef("GCC", "LDW -116(30),28
- LDW -112(30),29")
- BV 0(28) ; Call receiver
- COPY 29,26 ; Setup entry point
-
-;; This sequence of NOPs is provided to allow for modification of
-;; the sequence that appears above without having to recompile the
-;; world. The compiler "knows" the distance between
-;; scheme_to_interface_ble and hook_jump_table (100 bytes)
-
- ifelse(ASM_DEBUG,1,"","NOP
- NOP
- NOP
- NOP
- NOP
- NOP
- NOP")
- ifdef("GCC","","NOP
- NOP
- NOP")
-
-;; This label is used by the trap handler
-
-ep_scheme_hooks_low
-hook_jump_table ; scheme_to_interface + 100
-store_closure_code_hook
- B store_closure_code+4
- LDIL L'0x23400000,20 ; LDIL opcode and register
-
-store_closure_entry_hook
- B store_closure_entry+4
- DEP 0,31,2,1 ; clear PC protection bits
-\f
-multiply_fixnum_hook
- B multiply_fixnum+4
- EXTRS 26,FIXNUM_POS,FIXNUM_LENGTH,26 ; arg1
-
-fixnum_quotient_hook
- B fixnum_quotient+4
- EXTRS 26,FIXNUM_POS,FIXNUM_LENGTH,26 ; arg1
-
-fixnum_remainder_hook
- B fixnum_remainder+4
- EXTRS 26,FIXNUM_POS,FIXNUM_LENGTH,26 ; arg1
-
-fixnum_lsh_hook
- B fixnum_lsh+4
- EXTRS 25,FIXNUM_POS,FIXNUM_LENGTH,25 ; arg2
-
-generic_plus_hook
- B generic_plus+4
- LDW 0(0,22),6 ; arg1
-
-generic_subtract_hook
- B generic_subtract+4
- LDW 0(0,22),6 ; arg1
-
-generic_times_hook
- B generic_times+4
- LDW 0(0,22),6 ; arg1
-
-generic_divide_hook
- B generic_divide+4
- LDW 0(0,22),6 ; arg1
-
-generic_equal_hook
- B generic_equal+4
- LDW 0(0,22),6 ; arg1
-
-generic_less_hook
- B generic_less+4
- LDW 0(0,22),6 ; arg1
-
-generic_greater_hook
- B generic_greater+4
- LDW 0(0,22),6 ; arg1
-
-generic_increment_hook
- B generic_increment+4
- LDW 0(0,22),6 ; arg1
-
-generic_decrement_hook
- B generic_decrement+4
- LDW 0(0,22),6 ; arg1
-
-generic_zero_hook
- B generic_zero+4
- LDW 0(0,22),6 ; arg1
-
-generic_positive_hook
- B generic_positive+4
- LDW 0(0,22),6 ; arg1
-
-generic_negative_hook
- B generic_negative+4
- LDW 0(0,22),6 ; arg1
-\f
-shortcircuit_apply_hook
- B shortcircuit_apply+4
- EXTRU 26,5,6,24 ; procedure type -> 24
-
-shortcircuit_apply_1_hook
- B shortcircuit_apply_1+4
- EXTRU 26,5,6,24 ; procedure type -> 24
-
-shortcircuit_apply_2_hook
- B shortcircuit_apply_2+4
- EXTRU 26,5,6,24 ; procedure type -> 24
-
-shortcircuit_apply_3_hook
- B shortcircuit_apply_3+4
- EXTRU 26,5,6,24 ; procedure type -> 24
-
-shortcircuit_apply_4_hook
- B shortcircuit_apply_4+4
- EXTRU 26,5,6,24 ; procedure type -> 24
-
-shortcircuit_apply_5_hook
- B shortcircuit_apply_5+4
- EXTRU 26,5,6,24 ; procedure type -> 24
-
-shortcircuit_apply_6_hook
- B shortcircuit_apply_6+4
- EXTRU 26,5,6,24 ; procedure type -> 24
-
-shortcircuit_apply_7_hook
- B shortcircuit_apply_7+4
- EXTRU 26,5,6,24 ; procedure type -> 24
-
-shortcircuit_apply_8_hook
- B shortcircuit_apply_8+4
- EXTRU 26,5,6,24 ; procedure type -> 24
-
-stack_and_interrupt_check_hook
- B stack_and_interrupt_check+4
- LDW 44(0,4),25 ; Stack_Guard -> r25
-
-invoke_primitive_hook
- B invoke_primitive+4
- DEPI 0,31,2,31 ; clear privilege bits
-
-vector_cons_hook
- B vector_cons+4
- LDW 0(0,22),26 ; length as fixnum
-
-string_allocate_hook
- B string_allocate+4
- LDW 0(0,22),26 ; length as fixnum
-
-floating_vector_cons_hook
- B floating_vector_cons+4
- LDW 0(0,22),26 ; length as fixnum
-\f
-flonum_sin_hook
- B flonum_sin+4
- COPY 22,18
-
-flonum_cos_hook
- B flonum_cos+4
- COPY 22,18
-
-flonum_tan_hook
- B flonum_tan+4
- COPY 22,18
-
-flonum_asin_hook
- B flonum_asin+4
- COPY 22,18
-
-flonum_acos_hook
- B flonum_acos+4
- COPY 22,18
-
-flonum_atan_hook
- B flonum_atan+4
- COPY 22,18
-
-flonum_exp_hook
- B flonum_exp+4
- COPY 22,18
-
-flonum_log_hook
- B flonum_log+4
- COPY 22,18
-
-flonum_truncate_hook
- B flonum_truncate+4
- COPY 22,18
-
-flonum_ceiling_hook
- B flonum_ceiling+4
- COPY 22,18
-
-flonum_floor_hook
- B flonum_floor+4
- COPY 22,18
-
-flonum_atan2_hook
- B flonum_atan2+4
- COPY 22,18
-
-compiled_code_bkpt_hook ; hook 44 (offset 451 + 1)
- B compiled_code_bkpt+4
- LDO -8(31),31
-
-compiled_closure_bkpt_hook ; hook 45 (offset 451 + 9)
- B compiled_closure_bkpt+4
- LDO -12(31),31
-
-copy_closure_pattern_hook
- B copy_closure_pattern+4
- LDW -3(0,31),29 ; offset
-
-copy_multiclosure_pattern_hook
- B copy_multiclosure_pattern+4
- LDW -3(0,31),29 ; offset
-
-closure_entry_bkpt_hook ; hook 48 (offset 451 + 33)
- B closure_entry_bkpt+4
- LDO -8(31),31 ; bump back to entry point
-\f
-;;
-;; Provide dummy trapping hooks in case a newer version of compiled
-;; code that expects more hooks is run.
-;;
-
-no_hook
- BREAK 0,49
- NOP
- BREAK 0,50
- NOP
- BREAK 0,51
- NOP
- BREAK 0,52
- NOP
- BREAK 0,53
- NOP
- BREAK 0,54
- NOP
- BREAK 0,55
- NOP
- BREAK 0,56
- NOP
- BREAK 0,57
- NOP
- BREAK 0,58
- NOP
- BREAK 0,59
- NOP
- BREAK 0,60
- NOP
- BREAK 0,61
- NOP
- BREAK 0,62
- NOP
- BREAK 0,63
- NOP
-
-ifelse(ASM_DEBUG,1,"interface_break
- COMB,= 21,22,interface_break
- NOP
- B,N interface_proceed")
-\f
-store_closure_entry
-;;
-;; On arrival, 31 has a return address and 1 contains the address to
-;; which the closure should jump with pc protection bits.
-;; 26 contains the format/gc-offset word for this entry.
-;;
- DEP 0,31,2,1 ; clear PC protection bits
- STWM 26,4(0,21) ; move format long to heap
-;; fall through to store_closure_code
-
-store_closure_code
-;;
-;; On arrival, 31 has a return address and 1 contains the address to
-;; which the closure should jump. The appropriate instructions (LDIL
-;; and BLE and SUBI) are pushed on the heap.
-;; Important:
-;; 3 words in memory are modified, but only 2 FDC instructions and one FIC
-;; instruction are issued. The PDC_CACHE description in the I/O Architecture
-;; manual specifies that each flush will flush a multiple of 16 bytes, thus
-;; a flush of the first data word and a flush of the last data word suffice to
-;; flush all three. A single FIC of the first instruction word suffices since
-;; the space is newly allocated and the whole I-cache was flushed at
-;; exec and relocation(GC) time.
-;; The SYNC is assumed to be separated by at least 7 instructions from
-;; the first execution of the new instructions.
-;;
- LDIL L'0x23400000,20 ; LDIL opcode and register
- EXTRU 1,0,1,5
- DEP 5,31,1,20
- EXTRU 1,11,11,5
- DEP 5,30,11,20
- EXTRU 1,13,2,5
- DEP 5,17,2,20
- EXTRU 1,18,5,5
- DEP 5,15,5,20
- STW 20,0(0,21) ; Store LDIL instruction
- LDIL L'0xe7406000,20 ; BLE opcode, register
- LDO R'0xe7406000(20),20 ; and nullify
- EXTRU 1,19,1,5
- DEP 5,29,1,20
- EXTRU 1,29,10,5
- DEP 5,28,10,20
- STW 20,4(0,21) ; Store BLE instruction
- LDIL L'0xb7ff07e9,20
- LDO R'0xb7ff07e9(20),20
- STW 20,8(0,21) ; Store ADDI instruction
- LDI 12,20
- FDC 0(0,21) ; flush 1st inst. from D-cache
- FDC 20(0,21) ; flush last inst. from D-cache
- SYNC
- FIC,M 20(5,21) ; flush 1st inst. from I-cache
- SYNC
- LDW 0(0,4),20 ; Reload memtop
- BE 0(5,31) ; Return
- LDI QUAD_MASK,5 ; Restore register 5
-\f
-multiply_fixnum
-;;
-;; On arrival, 31 has a return address and 26 and 25 have the fixnum arguments.
-;;
- EXTRS 26,FIXNUM_POS,FIXNUM_LENGTH,26 ; arg1
- STW 26,0(0,21)
- EXTRS 25,FIXNUM_POS,FIXNUM_LENGTH,25 ; arg2
- STW 25,4(0,21)
- ZDEPI 1,TC_LENGTH,1,26 ; FIXNUM_LIMIT
- FLDWS 0(0,21),4
- FLDWS 4(0,21),5
- STW 26,8(0,21) ; FIXNUM_LIMIT
- FCNVXF,SGL,DBL 4,4 ; arg1
- FCNVXF,SGL,DBL 5,5 ; arg2
- FMPY,DBL 4,5,4
- FLDWS 8(0,21),5 ; FIXNUM_LIMIT
- FCNVXF,SGL,DBL 5,5 ; FIXNUM_LIMIT
- COPY 0,25 ; signal no overflow
- FCMP,DBL,!>= 4,5 ; result too large?
- FTEST
- B,N multiply_fixnum_ovflw
- FSUB,DBL 0,5,5
- FCMP,DBL,!< 4,5 ; result too small?
- FTEST
- B,N multiply_fixnum_ovflw
- FCNVFXT,DBL,SGL 4,5
- FSTWS 5,0(0,21) ; result
- LDW 0(0,21),26
- BE 0(5,31) ; return
- ZDEP 26,FIXNUM_POS,FIXNUM_LENGTH,26 ; make into fixnum
-;;
-multiply_fixnum_ovflw
- COPY 0,26
- LDO 1(0),25 ; signal overflow
- BE 0(5,31) ; return
- ZDEP 26,FIXNUM_POS,FIXNUM_LENGTH,26 ; make into fixnum
-
-fixnum_quotient
-;;
-;; On arrival, 31 has a return address and 26 and 25 have the fixnum arguments.
-;; Note that quotient only overflows when dividing by 0 and when the
-;; divisor is -1 and the dividend is the most negative fixnum,
-;; producing the most positive fixnum plus 1.
-;;
- EXTRS 26,FIXNUM_POS,FIXNUM_LENGTH,26 ; arg1
- COMB,= 0,25,fixnum_quotient_ovflw
- STW 26,0(0,21)
- EXTRS 25,FIXNUM_POS,FIXNUM_LENGTH,25 ; arg2
- STW 25,4(0,21)
- ZDEPI 1,TC_LENGTH,1,26 ; FIXNUM_LIMIT
- FLDWS 0(0,21),4
- FLDWS 4(0,21),5
- FCNVXF,SGL,DBL 4,4 ; arg1
- FCNVXF,SGL,DBL 5,5 ; arg2
- FDIV,DBL 4,5,4
- STW 26,0(0,21) ; FIXNUM_LIMIT
- FCNVFXT,DBL,SGL 4,5
- FSTWS 5,4(0,21) ; result
- FLDWS 0(0,21),5 ; FIXNUM_LIMIT
- FCNVXF,SGL,DBL 5,5
- FCMP,DBL,!>= 4,5 ; result too large?
- LDW 4(0,21),26
- COPY 0,25 ; signal no overflow
- FTEST
-;;
-fixnum_quotient_ovflw
- LDO 1(0),25 ; signal overflow
- BE 0(5,31) ; return
- ZDEP 26,FIXNUM_POS,FIXNUM_LENGTH,26 ; make into fixnum
-\f
-;; fixnum_remainder
-;;
-;; NOTE: The following code is disabled because the FREM instruction
-;; has been dropped from the architecture and has never been
-;; implemented in hardware.
-;;
-;; On arrival, 31 has a return address and 26 and 25 have the fixnum arguments.
-;; Note that remainder only overflows when dividing by 0.
-;; Note also that the FREM instruction does not compute the same as
-;; the Scheme remainder operation. The sign of the result must
-;; sometimes be adjusted.
-;;
-;; EXTRS 26,FIXNUM_POS,FIXNUM_LENGTH,26 ; arg1
-;; COMB,=,N 0,25,fixnum_remainder_ovflw
-;; STW 26,0(0,21)
-;; EXTRS 25,FIXNUM_POS,FIXNUM_LENGTH,25 ; arg2
-;; STW 25,4(0,21)
-;; FLDWS 0(0,21),4
-;; FLDWS 4(0,21),5
-;; FCNVXF,SGL,DBL 4,4 ; arg1
-;; FCNVXF,SGL,DBL 5,5 ; arg2
-;; FREM,DBL 4,5,4
-;; FCNVFXT,DBL,SGL 4,5
-;; FSTWS 5,4(0,21) ; result
-;; LDW 4(0,21),1
-;; XOR,< 26,1,0 ; skip if signs !=
-;; B,N fixnum_remainder_done
-;; COMB,=,N 0,1,fixnum_remainder_done
-;; XOR,< 26,25,0 ; skip if signs !=
-;; ADD,TR 1,25,1 ; result += arg2
-;; SUB 1,25,1 ; result -= arg2
-;;;;
-;;fixnum_remainder_done
-;; ZDEP 1,FIXNUM_POS,FIXNUM_LENGTH,26 ; make into fixnum
-;; BE 0(5,31) ; return
-;; COPY 0,25 ; signal no overflow
-;;;;
-;;fixnum_remainder_ovflw
-;; BE 0(5,31) ; return
-;; LDO 1(0),25 ; signal overflow
-\f
-fixnum_remainder
-;;
-;; On arrival, 31 has a return address and 26 and 25 have the fixnum
-;; arguments.
-;; Remainder can overflow only if arg2 = 0.
-;;
- EXTRS 26,FIXNUM_POS,FIXNUM_LENGTH,26 ; arg1
- STWM 29,-4(0,22) ; Preserve gr29
- COMB,=,N 0,25,fixnum_remainder_ovflw
- STWM 31,-4(0,22) ; Preserve ret. add.
- EXTRS 25,FIXNUM_POS,FIXNUM_LENGTH,25 ; arg2
- STWM 26,-4(0,22) ; Preserve arg1
- .CALL ;in=25,26;out=29; (MILLICALL)
- BL $$remI,31
- STWM 25,-4(0,22) ; Preserve arg2
-;;
- LDWM 4(0,22),25 ; Restore arg2
- LDWM 4(0,22),26 ; Restore arg1
- XOR,< 26,29,0 ; Skip if signs !=
- B,N fixnum_remainder_done
- COMB,=,N 0,29,fixnum_remainder_done
- XOR,< 26,25,0
- ADD,TR 29,25,29 ; setup result
- SUB 29,25,29
-;;
-fixnum_remainder_done
- ZDEP 29,FIXNUM_POS,FIXNUM_LENGTH,26 ; make into fixnum
- LDWM 4(0,22),31 ; Restore ret. add.
- COPY 0,25 ; signal no overflow
- BE 0(5,31) ; return
- LDWM 4(0,22),29 ; Restore gr29
-;;
-fixnum_remainder_ovflw
- LDO 1(0),25 ; signal overflow
- COPY 0,26 ; bogus return value
- BE 0(5,31) ; return
- LDWM 4(0,22),29 ; Restore gr29
-
-fixnum_lsh
-;;
-;; On arrival, 31 has a return address and 26 and 25 have the fixnum arguments.
-;; If arg2 is negative, it is a right shift, otherwise a left shift.
-;;
- EXTRS 25,FIXNUM_POS,FIXNUM_LENGTH,25 ; arg2
- COMB,<,N 0,25,fixnum_lsh_positive
- SUB 0,25,25 ; negate, for right shift
- COMICLR,> FIXNUM_LENGTH,25,0
- LDI 31,25 ; shift right completely
- MTSAR 25
- VSHD 0,26,26 ; shift right
- DEP 0,31,TC_LENGTH,26 ; normalize fixnum
- BE 0(5,31) ; return
- COPY 0,25 ; signal no overflow
-;;
-fixnum_lsh_positive
- SUBI,> 32,25,25 ; shift amount for right shift
- COPY 0,25 ; shift left completely
- MTSAR 25
- VSHD 26,0,26 ; shift right (32 - arg2)
- BE 0(5,31) ; return
- COPY 0,25 ; signal no overflow
-\f
-;;;; Generic arithmetic utilities.
-;;; On entry the arguments are on the Scheme stack, and the return
-;;; address immediately above them.
-
-define(define_generic_binary,
-"generic_$1
- LDW 0(0,22),6 ; arg1
- LDW 4(0,22),8 ; arg2
- EXTRU 6,TC_START,TC_LENGTH,7 ; type of arg1
- EXTRU 8,TC_START,TC_LENGTH,9 ; type of arg2
- COMIB,<>,N TC_FLONUM,7,generic_$1_fail
- COMIB,<>,N TC_FLONUM,9,generic_$1_fail
- DEP 5,TC_START,TC_LENGTH,6 ; data segment quadrant bits
- FLDDS 4(0,6),4 ; arg1 -> fr4
- DEP 5,TC_START,TC_LENGTH,8 ; data segment quadrant bits
- FLDDS 4(0,8),5 ; arg2 -> fr5
- B binary_flonum_result ; cons flonum and return
- $3,DBL 4,5,4 ; operate
-
-generic_$1_fail ; ?? * ??, out of line
- B scheme_to_interface
- LDI HEX($2),28 ; operation code")
-
-flonum_result
-unary_flonum_result
- ADDI,TR 4,22,6 ; ret. add. location
-
-binary_flonum_result ; expects data in fr4.
- LDO 8(22),6 ; ret. add. location
- DEPI 4,31,3,21 ; align free
- COPY 21,2 ; result (untagged)
- LDW 0(0,6),8 ; return address
- LDIL L'FLONUM_VECTOR_HEADER,7
- ; LDO R'FLONUM_VECTOR_HEADER(7),7 ; Assembler bug!
- ADDI R'FLONUM_VECTOR_HEADER,7,7
- STWM 7,4(0,21) ; vector header
- DEPI TC_FLONUM,TC_START,TC_LENGTH,2 ; tag flonum
- DEP 5,TC_START,TC_LENGTH,8 ; data segment quadrant bits
- FSTDS,MA 4,8(0,21) ; store floating data
- BLE 0(5,8) ; return!
- LDO 4(6),22 ; pop frame
-\f
-define(define_generic_binary_predicate,
-"generic_$1
- LDW 0(0,22),6 ; arg1
- LDW 4(0,22),8 ; arg2
- EXTRU 6,TC_START,TC_LENGTH,7 ; type of arg1
- EXTRU 8,TC_START,TC_LENGTH,9 ; type of arg2
- COMIB,<>,N TC_FLONUM,7,generic_$1_one_unk
- COMIB,<>,N TC_FLONUM,9,generic_$1_two_unk
- DEP 5,TC_START,TC_LENGTH,6 ; data segment quadrant bits
- FLDDS 4(0,6),4 ; arg1 -> fr4
- DEP 5,TC_START,TC_LENGTH,8 ; data segment quadrant bits
- FLDDS 4(0,8),5 ; arg2 -> fr5
- LDO 8(22),22 ; pop args from stack
- B generic_boolean_result ; cons answer and return
- FCMP,DBL,$3 4,5 ; compare
-
-generic_$1_one_unk ; ~FLO * ??
- COMIB,<>,N TC_FLONUM,9,generic_$1_fail
- COMICLR,= TC_FIXNUM,7,0
- B,N generic_$1_fail
- EXTRS 6,31,FIXNUM_LENGTH,6 ; sign extend arg1
- STW 6,0(0,21) ; through memory into fpcp
- LDO 8(22),22 ; pop args from stack
- DEP 5,TC_START,TC_LENGTH,8 ; data segment quadrant bits
- FLDWS 0(0,21),4 ; single int arg1 -> fr4
- FLDDS 4(0,8),5 ; arg2 -> fr5
- FCNVXF,SGL,DBL 4,4 ; convert to double float
- B generic_boolean_result ; cons answer and return
- FCMP,DBL,$3 4,5 ; compare
-
-generic_$1_two_unk ; FLO * ~FLO
- COMICLR,= TC_FIXNUM,9,0
- B,N generic_$1_fail
- EXTRS 8,31,FIXNUM_LENGTH,8 ; sign extend arg2
- STW 8,0(0,21) ; through memory into fpcp
- LDO 8(22),22 ; pop args from stack
- DEP 5,TC_START,TC_LENGTH,6 ; data segment quadrant bits
- FLDWS 0(0,21),5 ; single int arg2 -> fr5
- FLDDS 4(0,6),4 ; arg1 -> fr4
- FCNVXF,SGL,DBL 5,5 ; convert to double float
- B generic_boolean_result ; cons answer and return
- FCMP,DBL,$3 4,5 ; compare
-
-generic_$1_fail ; ?? * ??, out of line
- B scheme_to_interface
- LDI HEX($2),28 ; operation code")
-
-generic_boolean_result
- LDWM 4(0,22),8 ; return address
- LDIL L'SHARP_T,2
- FTEST
- LDIL L'SHARP_F,2
- DEP 5,TC_START,TC_LENGTH,8 ; data segment quadrant bits
- BLE,N 0(5,8) ; return!
-\f
-define(define_generic_unary,
-"generic_$1
- LDW 0(0,22),6 ; arg
- EXTRU 6,TC_START,TC_LENGTH,7 ; type of arg
- COMIB,<>,N TC_FLONUM,7,generic_$1_fail
- LDI 1,7 ; constant 1
- STW 7,0(0,21) ; into memory
- DEP 5,TC_START,TC_LENGTH,6 ; data segment quadrant bits
- FLDWS 0(0,21),5 ; 1 -> fr5
- FLDDS 4(0,6),4 ; arg -> fr4
- FCNVXF,SGL,DBL 5,5 ; convert to double float
- B unary_flonum_result ; cons flonum and return
- $3,DBL 4,5,4 ; operate
-
-generic_$1_fail
- B scheme_to_interface
- LDI HEX($2),28 ; operation code")
-
-define(define_generic_unary_predicate,
-"generic_$1
- LDW 0(0,22),6 ; arg
- EXTRU 6,TC_START,TC_LENGTH,7 ; type of arg
- COMIB,<>,N TC_FLONUM,7,generic_$1_fail
- DEP 5,TC_START,TC_LENGTH,6 ; data segment quadrant bits
- FLDDS 4(0,6),4 ; arg -> fr4
- LDO 4(22),22 ; pop arg from stack
- B generic_boolean_result ; cons answer and return
- FCMP,DBL,$3 4,0 ; compare
-
-generic_$1_fail
- B scheme_to_interface
- LDI HEX($2),28 ; operation code")
-
-define_generic_unary(decrement,22,FSUB)
-define_generic_binary(divide,23,FDIV)
-define_generic_binary_predicate(equal,24,=)
-define_generic_binary_predicate(greater,25,>)
-define_generic_unary(increment,26,FADD)
-define_generic_binary_predicate(less,27,<)
-define_generic_binary(subtract,28,FSUB)
-define_generic_binary(times,29,FMPY)
-define_generic_unary_predicate(negative,2a,<)
-define_generic_binary(plus,2b,FADD)
-define_generic_unary_predicate(positive,2c,>)
-define_generic_unary_predicate(zero,2d,=)
-\f
-;;;; Optimized procedure application for unknown procedures.
-;;; Procedure in r26, arity (for shortcircuit-apply) in r25.
-
-shortcircuit_apply
- EXTRU 26,5,6,24 ; procedure type -> 24
- COMICLR,= TC_CCENTRY,24,0
- B,N shortcircuit_apply_lose
- DEP 5,5,6,26 ; procedure -> address
- LDB -3(0,26),23 ; procedure's frame-size
- COMB,<>,N 25,23,shortcircuit_apply_lose
- BLE,N 0(5,26) ; invoke procedure
-
-define(define_shortcircuit_fixed,
-"shortcircuit_apply_$1
- EXTRU 26,5,6,24 ; procedure type -> 24
- COMICLR,= TC_CCENTRY,24,0
- B shortcircuit_apply_lose
- LDI $1,25
- DEP 5,5,6,26 ; procedure -> address
- LDB -3(0,26),23 ; procedure's frame-size
- COMB,<>,N 25,23,shortcircuit_apply_lose
- BLE,N 0(5,26) ; invoke procedure")
-
-define_shortcircuit_fixed(1)
-define_shortcircuit_fixed(2)
-define_shortcircuit_fixed(3)
-define_shortcircuit_fixed(4)
-define_shortcircuit_fixed(5)
-define_shortcircuit_fixed(6)
-define_shortcircuit_fixed(7)
-define_shortcircuit_fixed(8)
-
-shortcircuit_apply_lose
- DEP 24,5,6,26 ; insert type back
- B scheme_to_interface
- LDI 0x14,28
-\f
-;;; Return address in r31. r26 contains the offset from the return
-;;; address to the interrupt invocation label.
-
-stack_and_interrupt_check
- LDW 44(0,4),25 ; Stack_Guard -> r25
- LDW 0(0,4),20 ; MemTop -> r20
-;;;
-;;; If the Scheme stack pointer is <= Stack_Guard, then the stack has
-;;; overflowed -- in which case we must signal a stack-overflow interrupt.
- COMB,<=,N 22,25,stack_and_interrupt_check_stack_overflow
-;;;
-;;; If (Free >= MemTop), signal an interrupt.
- COMB,>=,N 21,20,stack_and_interrupt_check_signal_interrupt
-;;;
-;;; Otherwise, return normally -- there's nothing to do.
- BE 0(5,31)
- NOP
-
-stack_and_interrupt_check_stack_overflow
- LDW 48(0,4),25 ; IntCode -> r25
- LDW 4(0,4),24 ; IntEnb -> r24
-;;;
-;;; Set the stack-overflow interrupt bit and write the interrupt word
-;;; back out to memory. If the stack-overflow interrupt is disabled,
-;;; skip forward to gc test. Otherwise, set MemTop to -1 and signal
-;;; the interrupt.
- DEPI 1,INT_BIT_STACK_OVERFLOW,1,25
- BB,>= 24,INT_BIT_STACK_OVERFLOW,stack_and_interrupt_check_no_overflow
- STW 25,48(0,4) ; r25 -> IntCode
- ADDI -1,0,20 ; -1 -> r20
- STW 20,0(0,4) ; r20 -> MemTop
-;;;
-;;; If (Free >= MemTop), signal an interrupt.
-stack_and_interrupt_check_no_overflow
- SUB,< 21,20,0 ; skip next inst.
- ; if (Free < MemTop)
-;;;
-;;; To signal the interrupt, add the interrupt invocation offset to
-;;; the return address, then return normally.
-stack_and_interrupt_check_signal_interrupt
- ADD 26,31,31
- BE 0(5,31) ; return
- NOP
-\f
-;;; invoke_primitive and *cons all have the same interface:
-;;; The "return address" in r31 points to a word containing
-;;; the distance between itself and the word in memory containing
-;;; the primitive object.
-;;; All arguments are passed on the stack, ready for the primitive.
-
-invoke_primitive
- DEPI 0,31,2,31 ; clear privilege bits
- LDW 0(0,31),26 ; get offset
- ADDIL L'hppa_primitive_table-$global$,27
- LDWX 26(0,31),26 ; get primitive
- LDW R'hppa_primitive_table-$global$(1),25
- EXTRU 26,31,DATUM_LENGTH,24 ; get primitive index
- STW 26,32(0,4) ; store primitive
- ADDIL L'Primitive_Arity_Table-$global$,27
- LDW R'Primitive_Arity_Table-$global$(1),18
- LDWX,S 24(0,25),25 ; find primitive entry point
- ADDIL L'sp_register-$global$,27
- STW 22,R'sp_register-$global$(1) ; Update stack pointer
- ADDIL L'Free-$global$,27
- LDWX,S 24(0,18),18 ; primitive arity
- STW 21,R'Free-$global$(1) ; Update free
- .CALL RTNVAL=GR ; out=28
- BLE 0(4,25) ; Call primitive
- COPY 31,2 ; Setup return address
-
- ADDIL L'sp_register-$global$,27
- LDW R'sp_register-$global$(1),22 ; Setup stack pointer
- COPY 28,2 ; Move result to val
- SH2ADD 18,22,22 ; pop frame
- LDWM 4(0,22),26 ; return address as object
- STW 0,32(0,4) ; clear primitive
- B ep_interface_to_scheme_2
- DEP 5,TC_START,TC_LENGTH,26 ; return address as address
-
-;;; The BLE in invoke_primitive can jump here.
-;;; The primitive index is in gr24
-
-cross_segment_call
- ADDIL L'Primitive_Procedure_Table-$global$,27
- LDW R'Primitive_Procedure_Table-$global$(1),22
- LDWX,S 24(0,22),22
- B,N $$dyncall ; ignore the return address
-
-vector_cons
- LDW 0(0,22),26 ; length as fixnum
- COPY 21,2
- ZDEP 26,31,DATUM_LENGTH,26 ; length as machine word
- SH2ADD 26,21,25 ; end of data (-1)
- COMBF,< 25,20,invoke_primitive ; no space, use primitive
- LDW 4(0,22),24 ; fill value
- LDO 4(25),21 ; allocate!
- STW 26,0(0,2) ; vector length (0-tagged)
- LDO 4(2),23 ; start location
-
-vector_cons_loop
- COMBT,<,N 23,21,vector_cons_loop
- STWM 24,4(0,23) ; initialize
-
- LDW 8(0,22),25 ; return address as object
- DEPI TC_VECTOR,TC_START,TC_LENGTH,2 ; tag result
- DEP 5,TC_START,TC_LENGTH,25 ; return address as address
- BLE 0(5,25) ; return!
- LDO 12(22),22 ; pop stack frame
-\f
-string_allocate
- LDW 0(0,22),26 ; length as fixnum
- COPY 21,2 ; return value
- ZDEP 26,31,DATUM_LENGTH,26 ; length as machine word
- ADD 26,21,25 ; end of data (-(9+round))
- COMBF,< 25,20,invoke_primitive ; no space, use primitive
- SHD 0,26,2,24 ; scale down to word
- STB 0,8(0,25) ; end-of-string #\NUL
- LDO 2(24),24 ; total word size (-1)
- STWS,MB 26,4(0,21) ; store string length
- LDI TC_NMV,1
- SH2ADD 24,21,21 ; allocate!
- DEP 1,TC_START,TC_LENGTH,24 ; tag header
- LDW 4(0,22),25 ; return address as object
- STW 24,0(0,2) ; store nmv header
- LDI TC_STRING,1
- DEP 5,TC_START,TC_LENGTH,25 ; return address as address
- DEP 1,TC_START,TC_LENGTH,2 ; tag result
- BLE 0(5,25) ; return!
- LDO 8(22),22 ; pop stack frame
-
-floating_vector_cons
- LDW 0(0,22),26 ; length as fixnum
- ; STW 0,0(0,21) ; make heap parseable
- DEPI 4,31,3,21 ; bump free past header
- COPY 21,2 ; return value
- ZDEP 26,31,DATUM_LENGTH,26 ; length as machine word
- SH3ADD 26,21,25 ; end of data (-1)
- COMBF,< 25,20,invoke_primitive ; no space, use primitive
- SHD 26,0,31,26 ; scale, harmless in delay slot
- LDO 4(25),21 ; allocate!
- LDI TC_NMV,1
- DEP 1,TC_START,TC_LENGTH,26 ; tag header
- LDW 4(0,22),25 ; return address as object
- STW 26,0(0,2) ; store nmv header
- DEPI TC_FLONUM,TC_START,TC_LENGTH,2 ; tag result
- DEP 5,TC_START,TC_LENGTH,25 ; return address as address
- BLE 0(5,25) ; return!
- LDO 8(22),22 ; pop stack frame
-\f
-define(define_floating_point_util,
-"flonum_$1
- STW 2,8(0,4) ; preserve val
- COPY 22,18 ; preserve regs
- COPY 21,17
- COPY 19,16
- .CALL ARGW0=FR,ARGW1=FU,RTNVAL=FU ;fpin=105;fpout=104;
- BL $2,2
- COPY 31,15
- COPY 16,19
- COPY 17,21
- COPY 18,22
- LDW 8(0,4),2 ; restore val
- BE 0(5,15)
- LDW 0(0,4),20")
-
-define_floating_point_util(sin,sin)
-define_floating_point_util(cos,cos)
-define_floating_point_util(tan,tan)
-define_floating_point_util(asin,asin)
-define_floating_point_util(acos,acos)
-define_floating_point_util(atan,atan)
-define_floating_point_util(exp,exp)
-define_floating_point_util(log,log)
-define_floating_point_util(truncate,double_truncate)
-define_floating_point_util(ceiling,ceil)
-define_floating_point_util(floor,floor)
-
-flonum_atan2
- STW 2,8(0,4) ; preserve val
- COPY 22,18 ; preserve regs
- COPY 21,17
- COPY 19,16
- .CALL ARGW0=FR,ARGW1=FU,ARGW2=FR,ARGW3=FU,RTNVAL=FU ;fpin=105,107;fpout=104;
- BL atan2,2
- COPY 31,15
- COPY 16,19
- COPY 17,21
- COPY 18,22
- LDW 8(0,4),2 ; restore val
- BE 0(5,15)
- LDW 0(0,4),20
-
-compiled_code_bkpt
- LDO -4(31),31 ; bump back to entry point
- COPY 19,25 ; Preserve Dynamic link
- B trampoline_to_interface
- LDI 0x3c,28
-
-compiled_closure_bkpt
- LDO -12(31),31 ; bump back to entry point
- B trampoline_to_interface
- LDI 0x3d,28
-
-closure_entry_bkpt
- LDO -4(31),31 ; bump back to entry point
- B trampoline_to_interface
- LDI 0x3c,28
-\f
-;; On arrival, 31 has a return address. The word at the return
-;; address has the offset between the return address and the
-;; closure pattern.
-;; Returns the address of the entry point in 25
-;; Used: 29, 28, 26, 25, fp11, fp10 [31]
-
-copy_closure_pattern
- LDW -3(0,31),29 ; offset
- DEPI 4,31,3,21 ; quad align
- ADD 29,31,29 ; addr of pattern
- LDWS,MA 4(0,29),28 ; load pattern header
- LDO 8(21),25 ; preserve for FDC & FIC
- STWS,MA 28,4(0,21) ; store pattern header
- FLDDS,MA 8(0,29),10 ; load entry
- FLDDS,MA 8(0,29),11
- FSTDS,MA 10,8(0,21) ; store entry
- FSTDS,MA 11,8(0,21)
- FDC 0(0,25)
- FDC 0(0,21)
- SYNC
- FIC 0(5,25)
- BE 4(5,31)
- SYNC
-
-;; On arrival, 31 has a return address and 1 contains the number of
-;; entries in the closure. The word at the return address has the
-;; offset between the return address and the closure pattern.
-;; Returns the address of the entry point in 25
-;; Used: 29, 28, 26, 25, fp11, fp10 [31, 1]
-
-copy_multiclosure_pattern
- LDW -3(0,31),29 ; offset
- DEPI 4,31,3,21 ; quad align
- ADD 29,31,29 ; addr of pattern
- LDWS,MA 4(0,29),28 ; load pattern header
- LDO 12(21),25 ; preserve for FIC
- STWS,MA 28,4(0,21) ; store pattern header
- LDI -16,26 ; FDC index
-
-copy_multiclosure_pattern_loop
- FLDDS,MA 8(0,29),10 ; load entry
- FLDDS,MA 8(0,29),11
- FSTDS,MA 10,8(0,21) ; store entry
- FSTDS,MA 11,8(0,21)
- ADDIB,> -1,1,copy_multiclosure_pattern_loop
- FDC 26(0,21)
-
- LDWS,MA 4(0,29),28 ; load pattern tail
- COPY 21,26
- STWS,MA 28,4(0,21) ; store pattern tail
- FDC 0(0,26)
- SYNC
- FIC 0(5,25)
- BE 4(5,31) ; return
- SYNC
-
-;; This label is used by the trap handler
-
-ep_scheme_hooks_high
-\f
-;;;; Assembly language entry point used by utilities in cmpint.c
-;;; to return to the interpreter.
-;;; It returns from C_to_interface.
-
-ep_interface_to_C
- COPY 29,28 ; Setup C value
- LDW -eval(C_FRAME_SIZE+20)(0,30),2 ; Restore return address
- LDW -52(0,30),18 ; Restore saved registers
- LDW -56(0,30),17
- LDW -60(0,30),16
- LDW -64(0,30),15
- LDW -68(0,30),14
- LDW -72(0,30),13
- LDW -76(0,30),12
- LDW -80(0,30),11
- LDW -84(0,30),10
- LDW -88(0,30),9
- LDW -92(0,30),8
- LDW -96(0,30),7
- LDW -100(0,30),6
- LDW -104(0,30),5
- LDW -108(0,30),4
- BV 0(2) ; Return
- .EXIT
- LDWM -eval(C_FRAME_SIZE)(0,30),3 ; Restore last reg, pop frame
- .PROCEND ;in=26;out=28;
-
-;;;; Procedure to initialize this interface.
-;;;
-;;; C signature:
-;;;
-;;; void initialize_interface (void);
-
-interface_initialize
- .PROC
- .CALLINFO CALLER,FRAME=4,SAVE_RP
- .ENTRY
- STW 2,-20(0,30) ; Preserve return address
- LDO 64(30),30 ; Allocate stack frame
- STW 3,-64(30) ; Preserve gr3
- FSTWS 0,-4(30)
- LDW -4(30),22
- LDI 30,21 ; enable V, Z, O, U traps
- OR 21,22,22
- STW 22,-4(30)
- FLDWS -4(30),0
- ; Prepare entry points
- BL known_pc,3 ; get pc
- NOP
-known_pc
-
-define(store_entry_point,"ADDIL L'ep_$1-known_pc,3
- LDO R'ep_$1-known_pc(1),29
- ADDIL L'$1-$global$,27
- STW 29,R'$1-$global$(1)")
-
- store_entry_point(interface_to_scheme)
- store_entry_point(interface_to_C)
-\f
-changequote([,])
-define(builtin,[ADDIL L'$1-known_pc,3
- LDO R'$1-known_pc(1),26
- ADDIL L'$1_string-$global$,27
- .CALL ARGW0=GR
- BL declare_builtin,2
- LDO R'$1_string-$global$(1),25 divert(1)
-$1_string
- .ALIGN 8
- .STRINGZ "$1" divert(0)])
-
- builtin(scheme_to_interface_ble)
- builtin(ep_scheme_hooks_low)
- builtin(store_closure_entry)
- builtin(store_closure_code)
- builtin(multiply_fixnum)
- builtin(fixnum_quotient)
- builtin(fixnum_remainder)
- builtin(fixnum_lsh)
- builtin(flonum_result)
- builtin(generic_boolean_result)
- builtin(generic_decrement)
- builtin(generic_divide)
- builtin(generic_equal)
- builtin(generic_greater)
- builtin(generic_increment)
- builtin(generic_less)
- builtin(generic_subtract)
- builtin(generic_times)
- builtin(generic_negative)
- builtin(generic_plus)
- builtin(generic_positive)
- builtin(generic_zero)
- builtin(shortcircuit_apply)
- builtin(shortcircuit_apply_1)
- builtin(shortcircuit_apply_2)
- builtin(shortcircuit_apply_3)
- builtin(shortcircuit_apply_4)
- builtin(shortcircuit_apply_5)
- builtin(shortcircuit_apply_6)
- builtin(shortcircuit_apply_7)
- builtin(shortcircuit_apply_8)
- builtin(stack_and_interrupt_check)
- builtin(invoke_primitive)
- builtin(cross_segment_call)
- builtin(vector_cons)
- builtin(string_allocate)
- builtin(floating_vector_cons)
- builtin(flonum_sin)
- builtin(flonum_cos)
- builtin(flonum_tan)
- builtin(flonum_asin)
- builtin(flonum_acos)
- builtin(flonum_atan)
- builtin(flonum_exp)
- builtin(flonum_log)
- builtin(flonum_truncate)
- builtin(flonum_ceiling)
- builtin(flonum_floor)
- builtin(flonum_atan2)
- builtin(compiled_code_bkpt)
- builtin(compiled_closure_bkpt)
- builtin(copy_closure_pattern)
- builtin(copy_multiclosure_pattern)
- builtin(ep_scheme_hooks_high)
-changequote(",")
- ; Return
- LDW -84(30),2 ; Restore return address
- LDW -64(30),3 ; Restore gr3
- BV 0(2)
- .EXIT
- LDO -64(30),30 ; De-allocate stack frame
- .PROCEND
-\f
-;;;; Routine to flush some locations from the processor cache.
-;;;
-;;; Its C signature is
-;;;
-;;; void
-;;; cache_flush_region (address, count, cache_set)
-;;; void *address;
-;;; long count; /* in long words */
-;;; unsigned int cache_set;
-;;;
-;;; cache_set is a bit mask of the flags I_CACHE (1) and D_CACHE (2).
-;;; the requested cache (or both) is flushed.
-;;;
-;;; We only need to flush every 16 bytes, since cache lines are
-;;; architecturally required to have cache line sizes that are
-;;; multiples of 16 bytes. This is wasteful on processors with cache
-;;; line sizes greater than 16 bytes, but this routine is typically
-;;; called to flush very small ranges.
-;;; We flush an additional time after flushing every 16 bytes since
-;;; the start address may not be aligned with a cache line, and thus
-;;; the end address may fall in a different cache line from the
-;;; expected one. The extra flush is harmless when not necessary.
-
-cache_flush_region
- .PROC
- .CALLINFO CALLER,FRAME=0
- .ENTRY
- LDO 3(25),25 ; add 3 to round up
- SHD 0,25,2,25 ; divide count (in longs) by 4
- COPY 25,28 ; save for FIC loop
- COPY 26,29 ; save for FIC loop
- LDI 16,1 ; increment
- BB,>=,N 24,30,process_i_cache ; if D_CACHE is not set,
- ; skip d-cache
-;;;
-flush_cache_fdc_loop
- ADDIB,>= -1,25,flush_cache_fdc_loop
- FDC,M 1(0,26)
- SYNC
-;;;
-process_i_cache
- BB,>=,N 24,31,L$exit2 ; if I_CACHE is not set, return
-;;;
-flush_cache_fic_loop
- ADDIB,>= -1,28,flush_cache_fic_loop
- FIC,M 1(5,29)
-;;;
-L$exit2
- BV 0(2)
- .EXIT
- SYNC
- .PROCEND ;in=25,26;
-\f
-;;;; Routine to flush the processor cache.
-;;;
-;;; Its C signature is
-;;;
-;;; void
-;;; cache_flush_all (cache_set, cache_info)
-;;; unsigned int cache_set;
-;;; struct pdc_cache_rtn_block *cache_info;
-;;;
-;;; cache_set is a bit mask of the flags I_CACHE (1) and D_CACHE (2).
-;;; the requested cache (or both) is flushed.
-;;;
-;;; struct pdc_cache_rtn_block is defined in <machine/pdc_rqsts.h> and
-;;; is the structure returned by the PDC_CACHE
-;;; processor-dependent-code call, and stored in the kernel variable
-;;; (HP-UX) "cache_tlb_parms". Only the cache parameters (and not the
-;;; TLB parameters) are used.
-
-cache_flush_all
- .PROC
- .CALLINFO CALLER,FRAME=24
- .ENTRY
-
-do_d_cache
- BB,>=,N 26,30,do_i_cache ; if D_CACHE is not set,
- ; skip d-cache
-
- LDW 32(0,25),31 ; 31 <- address (init. base)
- LDW 44(0,25),29 ; 29 <- loop
- LDW 36(0,25),23 ; 23 <- stride
- LDW 40(0,25),19 ; 19 <- count
-
- LDO -1(19),19 ; decrement count
- COMIB,>,N 0,19,d_sync ; if (count < 0), no flush
- COMIB,=,N 1,29,d_direct_l
- COMIB,=,N 2,29,d_assoc2_l
- COMIB,=,N 4,29,d_assoc4_l
-
-d_assoc_l ; set-associative flush-loop
- COPY 29,20 ; 20 (lcount) <- loop
-
-d_set_l ; set flush-loop
- LDO -1(20),20 ; decrement lcount
- COMIB,<=,N 0,20,d_set_l ; if (lcount >= 0), set loop
- FDCE 0(0,31) ; flush entry at (address)
-
- LDO -1(19),19 ; decrement count
- COMIB,<= 0,19,d_assoc_l ; if (count >= 0), loop
- ADD 31,23,31 ; address++
-
- B do_i_cache ; next
- SYNC ; synchronize after flush
-
-d_assoc4_l ; 4-way set-associative loop
- FDCE 0(0,31) ; flush entry at (*address)
- FDCE 0(0,31) ; flush entry at (*address)
- FDCE 0(0,31) ; flush entry at (*address)
- FDCE,M 23(0,31) ; flush entry at (*address++)
- COMIB,< 0,19,d_assoc4_l ; if (count > 0), loop
- LDO -1(19),19 ; decrement count
-
- B do_i_cache ; next
- SYNC ; synchronize after flush
-
-d_assoc2_l ; 2-way set-associative loop
- FDCE 0(0,31) ; flush entry at (*address)
- FDCE,M 23(0,31) ; flush entry at (*address++)
- COMIB,< 0,19,d_assoc2_l ; if (count > 0), loop
- LDO -1(19),19 ; decrement count
-
- B do_i_cache ; next
- SYNC ; synchronize after flush
-
-d_direct_l ; direct-mapped flush loop
- FDCE,M 23(0,31) ; flush entry at (*address++)
- COMIB,< 0,19,d_direct_l ; if (count > 0), loop
- LDO -1(19),19 ; decrement count
-
-d_sync
- SYNC ; synchronize after flush
-
-do_i_cache
- BB,>=,N 26,31,L$exit1 ; if I_CACHE is not set, return
-
- LDW 8(0,25),31 ; 31 <- address (init. base)
- LDW 20(0,25),29 ; 29 <- loop
- LDW 12(0,25),23 ; 23 <- stride
- LDW 16(0,25),19 ; 19 <- count
-
- LDO -1(19),19 ; decrement count
- COMIB,>,N 0,19,i_sync ; if (count < 0), no flush
- COMIB,=,N 1,29,i_direct_l
- COMIB,=,N 2,29,i_assoc2_l
- COMIB,=,N 4,29,i_assoc4_l
-
-i_assoc_l ; set-associative flush-loop
- COPY 29,20 ; 20 (lcount) <- loop
-
-i_set_l ; set flush-loop
- LDO -1(20),20 ; decrement lcount
- COMIB,<=,N 0,20,i_set_l ; if (lcount >= 0), set loop
- FICE 0(5,31) ; flush entry at (address)
-
- LDO -1(19),19 ; decrement count
- COMIB,<= 0,19,i_assoc_l ; if (count >= 0), loop
- ADD 31,23,31 ; address++
-
- B i_skips ; next
- SYNC ; synchronize after flush
-
-i_assoc4_l ; 4-way set-associative loop
- FICE 0(5,31) ; flush entry at (*address)
- FICE 0(5,31) ; flush entry at (*address)
- FICE 0(5,31) ; flush entry at (*address)
- FICE,M 23(5,31) ; flush entry at (*address++)
- COMIB,< 0,19,i_assoc4_l ; if (count > 0), loop
- LDO -1(19),19 ; decrement count
-
- B i_skips ; next
- SYNC ; synchronize after flush
-
-i_assoc2_l ; 2-way set-associative loop
- FICE 0(5,31) ; flush entry at (*address)
- FICE,M 23(5,31) ; flush entry at (*address++)
- COMIB,< 0,19,i_assoc2_l ; if (count > 0), loop
- LDO -1(19),19 ; decrement count
-
- B i_skips ; next
- SYNC ; synchronize after flush
-
-i_direct_l ; direct-mapped flush loop
- FICE,M 23(5,31) ; flush entry at (*address++)
- COMIB,< 0,19,i_direct_l ; if (count > 0), loop
- LDO -1(19),19 ; decrement count
-
-i_sync
- SYNC ; synchronize after flush
-
-i_skips
- NOP ; 7 instructionss as prescribed
- NOP ; by the programming note in
- NOP ; the description for SYNC.
- NOP
- NOP
-
-L$exit1
- BV 0(2)
- .EXIT
- NOP
- .PROCEND ;in=25,26;
-\f
-bkpt_normal_proceed
- BL bkpt_normal_cont,1 ; Get PC
- DEP 0,31,2,1
-bkpt_normal_cont
- LDW bkpt_normal_ep-bkpt_normal_cont(0,1),1 ; entry point
- BV 0(1) ; Invoke
- NOP ; Slot for first instruction
-bkpt_normal_ep
- NOP ; Slot for fall through
-
-bkpt_plus_proceed
- COMB,= 1,1,bkpt_plus_t ; Slot for first instruction
- NOP ; Slot for second instruction
- STWM 1,-4(0,22) ; Preserve 1
- BL bkpt_plus_cont_f,1 ; Get PC
- DEP 0,31,2,1
-bkpt_plus_cont_f
- LDW bkpt_plus_ep-bkpt_plus_cont_f(0,1),1 ; entry point
- BV 0(1) ; Invoke
- LDWM 4(0,22),1
-bkpt_plus_t
- STWM 1,-4(0,22) ; Preserve 1
- BL bkpt_plus_cont_t,1 ; Get PC
- DEP 0,31,2,1
-bkpt_plus_cont_t
- LDW bkpt_plus_bt-bkpt_plus_cont_t(0,1),1 ; entry point
- BV 0(1) ; Invoke
- LDWM 4(0,22),1
-bkpt_plus_ep
- NOP ; Slot for fall through
-bkpt_plus_bt
- NOP ; Slot for branch target
-
-bkpt_minus_proceed_start
-bkpt_minus_t
- STWM 1,-4(0,22) ; Preserve 1
- BL bkpt_minus_cont_t,1 ; Get PC
- DEP 0,31,2,1
-bkpt_minus_cont_t
- LDW bkpt_minus_bt-bkpt_minus_cont_t(0,1),1 ; entry point
- BV 0(1) ; Invoke
- LDWM 4(0,22),1
-bkpt_minus_proceed
- COMB,= 1,1,bkpt_minus_t ; Slot for first instruction
- NOP ; Slot for second instruction
- STWM 1,-4(0,22) ; Preserve 1
- BL bkpt_minus_cont_f,1 ; Get PC
- DEP 0,31,2,1
-bkpt_minus_cont_f
- LDW bkpt_minus_ep-bkpt_minus_cont_f(0,1),1 ; entry point
- BV 0(1) ; Invoke
- LDWM 4(0,22),1
-bkpt_minus_ep
- NOP ; Slot for fall through
-bkpt_minus_bt
- NOP ; Slot for branch target
-
-bkpt_closure_proceed
- BL bkpt_closure_cont,1
- DEP 0,31,2,1
-bkpt_closure_cont
- LDW bkpt_closure_entry-bkpt_closure_cont(0,1),25
- LDW bkpt_closure_closure-bkpt_closure_cont(0,1),31
- BV 0(25)
- COPY 31,25
-bkpt_closure_closure
- NOP ; Closure object pointer
-bkpt_closure_entry
- NOP ; Eventual entry point
-bkpt_closure_proceed_end
- NOP
-\f
- .SPACE $TEXT$
- .SUBSPA $LIT$,QUAD=0,ALIGN=8,ACCESS=44
-; .SUBSPA $CODE$,QUAD=0,ALIGN=8,ACCESS=44,CODE_ONLY
- .SUBSPA $UNWIND$,QUAD=0,ALIGN=8,ACCESS=44
- .SUBSPA $CODE$
- .SPACE $PRIVATE$
- .SUBSPA $SHORTBSS$
-interface_to_scheme .COMM 4
-interface_to_C .COMM 4
-scheme_hooks_low .COMM 4
-scheme_hooks_high .COMM 4
- .SUBSPA $DATA$,QUAD=1,ALIGN=8,ACCESS=31
-$THISMODULE$
-ifelse(ASM_DEBUG,1,"interface_counter
- .ALIGN 8
- .WORD 0
-interface_limit
- .WORD 0")
-undivert(1)
- .SUBSPA $BSS$,QUAD=1,ALIGN=8,ACCESS=31,ZERO
- .IMPORT $global$,DATA
- .IMPORT Registers,DATA
- .IMPORT sp_register,DATA
- .IMPORT Free,DATA
- .IMPORT hppa_utility_table,DATA
- .IMPORT hppa_primitive_table,DATA
- .IMPORT Primitive_Arity_Table,DATA
- .IMPORT Primitive_Procedure_Table,DATA
- .SPACE $TEXT$
- .SUBSPA $CODE$
- .IMPORT $$dyncall,MILLICODE
- .IMPORT $$remI,MILLICODE
- .IMPORT declare_builtin,CODE
- .IMPORT sin,CODE
- .IMPORT cos,CODE
- .IMPORT tan,CODE
- .IMPORT asin,CODE
- .IMPORT acos,CODE
- .IMPORT atan,CODE
- .IMPORT exp,CODE
- .IMPORT log,CODE
- .IMPORT double_truncate,CODE
- .IMPORT ceil,CODE
- .IMPORT floor,CODE
- .IMPORT atan2,CODE
- .EXPORT C_to_interface,PRIV_LEV=3,ARGW0=GR,RTNVAL=GR
- .EXPORT ep_interface_to_scheme,PRIV_LEV=3
- .EXPORT scheme_to_interface_ble,PRIV_LEV=3
- .EXPORT trampoline_to_interface,PRIV_LEV=3
- .EXPORT scheme_to_interface,PRIV_LEV=3
- .EXPORT hook_jump_table,PRIV_LEV=3
- .EXPORT cross_segment_call,PRIV_LEV=3
- .EXPORT flonum_atan2,PRIV_LEV=3
- .EXPORT ep_interface_to_C,PRIV_LEV=3
- .EXPORT interface_initialize,PRIV_LEV=3
- .EXPORT cache_flush_region,PRIV_LEV=3
- .EXPORT cache_flush_all,PRIV_LEV=3
- .EXPORT bkpt_normal_proceed,PRIV_LEV=3
- .EXPORT bkpt_plus_proceed,PRIV_LEV=3
- .EXPORT bkpt_minus_proceed_start,PRIV_LEV=3
- .EXPORT bkpt_minus_proceed,PRIV_LEV=3
- .EXPORT bkpt_closure_proceed,PRIV_LEV=3
- .EXPORT bkpt_closure_proceed_end,PRIV_LEV=3
- .END
### 02110-1301, USA.
\f
### Intel IA-32 assembly language part of the compiled code interface.
-### See cmpint.txt, cmpint.c, cmpint-mc68k.h, and cmpgc.h for more
+### See cmpint.txt, cmpint.c, cmpintmd/i386*, and cmpgc.h for more
### documentation.
###
### This m4 source expands into either Unix (gas) source or PC
+++ /dev/null
-### -*-Midas-*-
-###
-### Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
-### 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-### 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
-### 2014, 2015, 2016, 2017 Massachusetts Institute of Technology
-###
-### This file is part of MIT/GNU Scheme.
-###
-### MIT/GNU Scheme is free software; you can redistribute it and/or
-### modify it under the terms of the GNU General Public License as
-### published by the Free Software Foundation; either version 2 of the
-### License, or (at your option) any later version.
-###
-### MIT/GNU Scheme is distributed in the hope that it will be useful,
-### but WITHOUT ANY WARRANTY; without even the implied warranty of
-### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-### General Public License for more details.
-###
-### You should have received a copy of the GNU General Public License
-### along with MIT/GNU Scheme; if not, write to the Free Software
-### Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
-### 02110-1301, USA.
-\f
-#### 68K assembly language (HP/Motorola Syntax) part of the compiled
-#### code interface. See cmpint.txt, cmpint.c, cmpint-mc68k.h, and
-#### cmpgc.h for more documentation.
-####
-#### NOTE:
-#### Assumptions:
-####
-#### 1) All registers (except double floating point registers) and
-#### stack locations hold a C long object.
-####
-#### 2) The C compiler divides registers into three groups:
-#### - Linkage registers, used for procedure calls and global
-#### references. On MC68K: a6, sp.
-#### - super temporaries, not preserved accross procedure calls and
-#### always usable. On MC68K: a0, a1, d0, d1
-#### - preserved registers saved by the callee if they are written.
-#### On MC68K: all others.
-####
-#### 3) Arguments, if passed on a stack, are popped by the caller
-#### or by the procedure return instruction (as on the VAX). Thus
-#### most "leaf" procedures need not worry about them.
-####
-#### 4) There is a hardware or software maintained stack for
-#### control. The procedure calling sequence may leave return
-#### addresses in registers, but they must be saved somewhere for
-#### nested calls and recursive procedures. On MC68K: saved on
-#### the stack.
-####
-#### 5) C procedures return long values in a super temporary
-#### register. Two word structures are returned in super temporary
-#### registers as well. On MC68K: d0 is used for long returns.
-#### Since there are two methods for returning structures on MC68K,
-#### there is a flag to choose a mechanism:
-#### o GCC returns two word structures in d0/d1 (set flag GCC in
-#### M4_MACHINE_SWITCHES in m.h)
-#### o Other compilers return the address of the structure in d0
-#### o The HP compiler requires that the address of this structure
-#### be in a1 before the procedure is called (set flag HP in
-#### M4_MACHINE_SWITCHES in m.h)
-####
-#### 6) Floating point registers are not preserved by this
-#### interface. The interface is only called from the Scheme
-#### interpreter, which does not use floating point data. Thus
-#### although the calling convention would require us to preserve
-#### them, they contain garbage.
-####
-#### Compiled Scheme code uses the following register convention:
-#### - a7 (sp) contains the Scheme stack pointer, not the C stack
-#### pointer.
-#### - a6 (fp) contains a pointer to the Scheme interpreter's
-#### "register" block. This block contains the compiler's copy of
-#### MemTop, the interpreter's registers (val, env, exp, etc),
-#### temporary locations for compiled code, and the mechanism used
-#### to invoke the hooks in this file.
-#### - a5 contains the Scheme free pointer.
-#### - a4 contains the dynamic link when needed.
-#### - d7 contains the Scheme datum mask.
-#### - d6 is where Scheme compiled code returns values.
-####
-#### All other registers are available to the compiler. A
-#### caller-saves convention is used, so the registers need not be
-#### preserved by subprocedures.
-\f
-#### Utility macros and definitions
-
-define(KEEP_HISTORY,0) # Debugging switch
-
-define(reference_external,`') # Declare desire to use an external
-define(extern_c_label,`_$1') # The actual reference
-
-define(define_c_label,
-` global extern_c_label($1)
-extern_c_label($1):')
-
-define(define_debugging_label,
-` global $1
-$1:')
-
-# Call a SCHEME_UTILITY (see cmpint.c) and then dispatch to the
-# interface procedure requested with the data to be passed to the
-# procedure in d1.
-#
-# NOTE: Read introductory note about GCC and HP switches
-
-define(allocate_utility_result,
- `ifdef(`HP',
- `subq.l &8,%sp
- mov.l %sp,%a1',
- `')')
-
-
-define(utility_call,
- `jsr (%a0) # call C procedure
- ifdef(`HP',
- `lea eval(($1+2)*4)(%sp),%sp',
- `lea eval($1*4)(%sp),%sp')
- mov.l %d0,%a0
- ifdef(`GCC',
- `',
- `mov.l 4(%a0),%d1
- mov.l 0(%a0),%a0')
- jmp (%a0)')
-
-# Scheme object representation. Must match object.h
-
-define(HEX, `0x$1')
-define(TC_LENGTH, ifdef(`TYPE_CODE_LENGTH', TYPE_CODE_LENGTH, 6))
-define(ADDRESS_MASK, eval(((2 ** (32 - TC_LENGTH)) - 1), 16))
-define(TYPE_CODE_FACTOR, eval(2 ** (8 - TC_LENGTH)))
-define(TYPE_CODE_MASK, eval((256 - TYPE_CODE_FACTOR), 16))
-define(CLEAR_TYPE_MASK, eval((TYPE_CODE_FACTOR - 1), 16))
-
-define(TYPE_CODE_TO_BYTE, `$1*TYPE_CODE_FACTOR')
-define(TYPE_CODE_TO_OBJECT, `TYPE_CODE_TO_BYTE($1)*0x1000000')
-
-define(EXTRACT_TYPE_CODE,
- `ifelse(TC_LENGTH, 8,
- `mov.b $1,$2',
- `mov.b $1,$2
- and.b &HEX(TYPE_CODE_MASK), $2')')
-
-define(COMPARE_TYPE_CODE,
- `cmp.b $1,&TYPE_CODE_TO_BYTE($2)')
-\f
-### External conventions
-
- set regblock_memtop,0 # from const.h (* 4)
- set regblock_int_mask,4
- set regblock_val,8
- set regblock_stack_guard,44
- set regblock_int_code,48
- set address_mask,HEX(ADDRESS_MASK)
-
-# This must match the compiler (machin.scm)
-
-define(dlink, %a4) # Dynamic link register (contains a
- # pointer to a return address)
-define(rfree, %a5) # Free pointer
-define(regs, %a6) # Pointer to Registers[0]
-define(rmask, %d7) # Mask to clear type code
-define(rval,%d6) # Procedure value
-
-reference_external(sp_register)
-reference_external(Free)
-reference_external(Registers)
-
-# These must match the C compiler
-
-define(switch_to_scheme_registers,
- `mov.l %a6,(%sp)
- mov.l %sp,c_save_stack
- mov.l extern_c_label(sp_register),%sp
- mov.l extern_c_label(Free),rfree
- lea extern_c_label(Registers),regs
- mov.l &address_mask,rmask')
-
-define(switch_to_C_registers,
- `mov.l rfree,extern_c_label(Free)
- mov.l %sp,extern_c_label(sp_register)
- mov.l c_save_stack,%sp
- mov.l (%sp),%a6')
-
-###
-### Global data
-###
-
- data
-
-define_debugging_label(c_save_stack)
- space 4
-ifelse(KEEP_HISTORY, 1,
-`define_debugging_label(ring_pointer)
- long ring_block_1
-define_debugging_label(ring_block_1)
- long ring_block_2
- space 28
-define_debugging_label(ring_block_2)
- long ring_block_3
- space 28
-define_debugging_label(ring_block_3)
- long ring_block_4
- space 28
-define_debugging_label(ring_block_4)
- long ring_block_5
- space 28
-define_debugging_label(ring_block_5)
- long ring_block_1
- space 28')
- text
-\f
-### Initialize the 68881 if present.
-
-define_c_label(interface_initialize)
- link %a6,&0
- ifdef(`MC68881', `fmov.l &0x3480,%fpcr')
- unlk %a6
- rts
-
-### Callable by C conventions. Swaps to Scheme register set and jumps
-### to the entry point specified by its only argument.
-
-define_c_label(C_to_interface)
- link %a6,&-44
- movm.l %d2-%d7/%a2-%a5,4(%sp)
- mov.l 8(%a6),%a0 # Argument: entry point
- bra.b interface_to_scheme_internal
-
-### Called by Scheme through a jump instruction in the register block.
-### It expects an index in %d0, and 4 longword arguments in %d1-%d4
-
-reference_external(utility_table)
-
-define_c_label(asm_scheme_to_interface)
-define_debugging_label(scheme_to_interface)
- ifelse(KEEP_HISTORY, 1,
- `lea ring_pointer,%a1
- mov.l (%a1),%a0
- mov.l (%a0),(%a1)
- mov.l %sp,4(%a0)
- mov.l %a5,8(%a0)
- mov.l %d0,12(%a0)
- mov.l %d1,16(%a0)
- mov.l %d2,20(%a0)
- mov.l %d3,24(%a0)
- mov.l %d4,28(%a0)
- cmp.l %sp,%a5
- bgt.b scheme_to_interface_proceed
- nop
-define_debugging_label(scheme_to_interface_proceed)')
- mov.l rval,regblock_val(regs)
- switch_to_C_registers()
- allocate_utility_result()
- mov.l %d4,-(%sp) # Push arguments to scheme utility
- mov.l %d3,-(%sp)
- mov.l %d2,-(%sp)
- mov.l %d1,-(%sp)
- lea extern_c_label(utility_table),%a0
- mov.l (0,%a0,%d0.w*4),%a0 # C-written Scheme utility
- utility_call(4) # 4 arguments
-
-### The data in %d1 is the address of an entry point to invoke.
-
-define_c_label(interface_to_scheme)
- mov.l %d1,%a0
-###
-### Enter the scheme compiled world.
-### The value register is copied to %d0 because some utilities are
-### expected to return their value there (this should be fixed),
-### and it is stripped and placed in the dlink register since
-### we may be returning after interrupting a procedure which
-### needs this register. This should also be separated or handled
-### inline.
-###
-define_debugging_label(interface_to_scheme_internal)
- switch_to_scheme_registers()
- mov.l regblock_val(regs),rval
- mov.l rval,%d0
- mov.l %d0,%d1
- and.l rmask,%d1
- mov.l %d1,dlink
- jmp (%a0)
-
-### The data in %d1 is a return code (integer) to the interpreter.
-
-define_c_label(interface_to_C)
- mov.l %d1,%d0 # C return value location
- movm.l 4(%sp),%d2-%d7/%a2-%a5
- unlk %a6
- rts
-\f
-#### Optimized entry points
-
-### Additional entry points that take care of common cases and are used to
-### shorten code sequences.
-### These are not strictly necessary, since the code sequences emitted by
-### the compiler could use scheme_to_interface instead, but a few instructions
-### are saved this way.
-
-### Called by linker-generated trampolines to invoke the appropriate
-### C-written handler. The return address on the stack is the address
-### of the trampoline storage area, passed to the C handler as the
-### first argument.
-
-### IMPORTANT:
-### All the asm_* routines are declared in cmpint-mc68k.h.
-### New ones need to be declared there as well!
-
-define_c_label(asm_trampoline_to_interface)
-define_debugging_label(trampoline_to_interface)
- mov.l (%sp)+,%d1
- bra scheme_to_interface
-
-### Called by Scheme through a jump instruction in the register block.
-### It is a special version of scheme_to_interface below, used when
-### a return address is stored in the Scheme stack.
-
-define_c_label(asm_scheme_to_interface_jsr)
-define_debugging_label(scheme_to_interface_jsr)
- mov.l (%sp)+,%d1 # Return addr -> d1
- addq.l &4,%d1 # Skip format info.
- bra scheme_to_interface
-
-define(define_interface_indirection,
-`define_c_label(asm_$1)
- movq &HEX($2),%d0
- bra scheme_to_interface')
-
-define(define_interface_jsr_indirection,
-`define_c_label(asm_$1)
- movq &HEX($2),%d0
- bra scheme_to_interface_jsr')
-
-define_interface_indirection(primitive_lexpr_apply,13)
-define_interface_indirection(error,15)
-define_interface_jsr_indirection(link,17)
-define_interface_indirection(interrupt_closure,18)
-define_interface_jsr_indirection(interrupt_procedure,1a)
-define_interface_jsr_indirection(interrupt_continuation,1b)
-define_interface_jsr_indirection(assignment_trap,1d)
-define_interface_jsr_indirection(reference_trap,1f)
-define_interface_jsr_indirection(safe_reference_trap,20)
-###
-### These are handled directly below.
-###
-### define_interface_indirection(generic_decrement,22)
-### define_interface_indirection(generic_divide,23)
-### define_interface_indirection(generic_equal,24)
-### define_interface_indirection(generic_greater,25)
-### define_interface_indirection(generic_increment,26)
-### define_interface_indirection(generic_less,27)
-### define_interface_indirection(generic_subtract,28)
-### define_interface_indirection(generic_multiply,29)
-### define_interface_indirection(generic_negative,2a)
-### define_interface_indirection(generic_add,2b)
-### define_interface_indirection(generic_positive,2c)
-### define_interface_indirection(generic_zero,2d)
-###
-define_interface_jsr_indirection(primitive_error,36)
-define_interface_indirection(generic_quotient,37)
-define_interface_indirection(generic_remainder,38)
-define_interface_indirection(generic_modulo,39)
-
-# Save an additional instruction here to load the dynamic link.
-define_c_label(asm_interrupt_dlink)
- mov.l dlink,%d2 # Dynamic link -> d2
- movq &HEX(19),%d0
- bra scheme_to_interface_jsr
-
-# Bum this one for speed.
-define_c_label(asm_primitive_apply)
- switch_to_C_registers()
- allocate_utility_result()
- mov.l %d1,-(%sp) # only one argument
- ifdef(`SUNASM',
- `lea extern_c_label(utility_table),%a0
- mov.l HEX(12)*4(%a0),%a0',
- `mov.l extern_c_label(utility_table)+HEX(12)*4,%a0')
- utility_call(1) # one argument
-\f
- set tc_compiled_entry,HEX(28)
- set tc_flonum,HEX(06)
- set tc_fixnum,HEX(1A)
- set tc_manifest_nmv,HEX(27)
- set tc_false,HEX(0)
- set tc_true,HEX(8)
- set offset_apply,HEX(14)
-
-define(call_utility,
- `movq &offset_$1,%d0
- bra scheme_to_interface')
-
-### Called by Scheme when invoking an unknown procedure.
-### Having this short sequence in assembly language avoids the C call
-### in the common case where the procedure is compiled and the number
-### of arguments is correct.
-### The number of actual arguments is in d2, the procedure on top
-### of the stack.
-
-define_c_label(asm_shortcircuit_apply)
-define_debugging_label(shortcircuit_apply)
- EXTRACT_TYPE_CODE((%sp),%d0) # Get procedure type
- mov.l (%sp)+,%d1 # Get procedure
- COMPARE_TYPE_CODE(%d0,tc_compiled_entry)
- bne.b shortcircuit_apply_1
- mov.l %d1,%d3 # Extract entry point
- and.l rmask,%d3
- mov.l %d3,%a0
- mov.b -3(%a0),%d3 # Extract the frame size
- ext.w %d3
- cmp.w %d2,%d3 # Is the frame size right?
- bne.b shortcircuit_apply_1
- jmp (%a0) # Invoke
-
-define_debugging_label(shortcircuit_apply_1)
- call_utility(apply)
-
-### Optimized versions of shortcircuit_apply for 0-7 arguments.
-
-define(define_apply_size_n,
-`define_c_label(asm_shortcircuit_apply_size_$1)
-define_debugging_label(shortcircuit_apply_size_$1)
- EXTRACT_TYPE_CODE((%sp),%d0) # Get procedure type
- mov.l (%sp)+,%d1 # Get procedure
- COMPARE_TYPE_CODE(%d0,tc_compiled_entry)
- bne.b shortcircuit_apply_size_$1_1
- mov.l %d1,%d3 # Extract entry point
- and.l rmask,%d3
- mov.l %d3,%a0
- cmp.b -3(%a0),&$1 # Is the frame size right?
- bne.b shortcircuit_apply_size_$1_1
- jmp (%a0) # Invoke
-
-define_debugging_label(shortcircuit_apply_size_$1_1)
- movq &$1,%d2 # initialize frame size
- call_utility(apply)')
-
-define_apply_size_n(1)
-define_apply_size_n(2)
-define_apply_size_n(3)
-define_apply_size_n(4)
-define_apply_size_n(5)
-define_apply_size_n(6)
-define_apply_size_n(7)
-define_apply_size_n(8)
-\f
-### This utility depends on the C compiler preserving d2-d7 and a2-a7.
-### It takes its parameters in d0 and d1, and returns its value in a0.
-
-define_c_label(asm_allocate_closure)
- switch_to_C_registers()
- mov.l %a1,-(%sp) # Preserve reg.
- mov.l %d1,-(%sp) # Preserve reg.
- mov.l %d0,-(%sp) # Push arg.
- jsr extern_c_label(allocate_closure)
- addq.l &4,%sp # Pop arg.
- mov.l %d0,%a0 # Return value
- mov.l (%sp)+,%d1 # Restore reg.
- mov.l (%sp)+,%a1 # Restore reg.
- switch_to_scheme_registers()
- rts
-
-### These utilities improve the performance of floating point code
-### significantly.
-### Arguments on top of the stack followed by the return address.
-
-define_debugging_label(asm_generic_flonum_result)
- mov.l rfree,rval
- mov.l &TYPE_CODE_TO_OBJECT(tc_manifest_nmv)+2,(rfree)+
- fmove.d %fp0,(rfree)+
- or.l &TYPE_CODE_TO_OBJECT(tc_flonum),rval
- and.b &TYPE_CODE_TO_BYTE(1)-1,(%sp)
- rts
-
-define_debugging_label(asm_true_result)
- mov.l &TYPE_CODE_TO_OBJECT(tc_true),rval
- and.b &TYPE_CODE_TO_BYTE(1)-1,(%sp)
- rts
-
-define_debugging_label(asm_false_result)
- mov.l &TYPE_CODE_TO_OBJECT(tc_false),rval
- and.b &TYPE_CODE_TO_BYTE(1)-1,(%sp)
- rts
-
-define(define_generic_unary,
-`define_c_label(asm_generic_$1)
- EXTRACT_TYPE_CODE((%sp),%d0) # Get arg1s type
- COMPARE_TYPE_CODE(%d0,tc_flonum)
- bne.b asm_generic_$1_hook
- mov.l (%sp)+,%d0 # arg1
- and.l rmask,%d0
- mov.l %d0,%a0
- fmove.d 4(%a0),%fp0
- $3.b &1,%fp0
- bra asm_generic_flonum_result
-
-asm_generic_$1_hook:
- movq &HEX($2),%d0
- bra scheme_to_interface')
-
-define(define_generic_unary_predicate,
-`define_c_label(asm_generic_$1)
- EXTRACT_TYPE_CODE((%sp),%d0) # Get arg1s type
- COMPARE_TYPE_CODE(%d0,tc_flonum)
- bne.b asm_generic_$1_hook
- mov.l (%sp)+,%d0 # arg1
- and.l rmask,%d0
- mov.l %d0,%a0
- fmove.d 4(%a0),%fp0
- fb$3 asm_true_result
- bra asm_false_result
-
-asm_generic_$1_hook:
- movq &HEX($2),%d0
- bra scheme_to_interface')
-\f
-define(define_generic_binary,
-`define_c_label(asm_generic_$1)
- EXTRACT_TYPE_CODE((%sp),%d0) # Get arg1s type
- EXTRACT_TYPE_CODE(4(%sp),%d1) # Get arg2s type
- mov.l (%sp),%d2 # arg1
- mov.l 4(%sp),%d3 # arg2
- and.l rmask,%d2
- and.l rmask,%d3
- mov.l %d2,%a0
- mov.l %d3,%a1
- COMPARE_TYPE_CODE(%d0,tc_flonum)
- bne.b asm_generic_$1_fix_flo
- COMPARE_TYPE_CODE(%d1,tc_flonum)
- bne.b asm_generic_$1_flo_fix
- fmove.d 4(%a0),%fp0
- $3.d 4(%a1),%fp0
- addq.l &8,%sp
- bra asm_generic_flonum_result
-
-asm_generic_$1_fix_flo:
- COMPARE_TYPE_CODE(%d0,tc_fixnum)
- bne.b asm_generic_$1_hook
- COMPARE_TYPE_CODE(%d1,tc_flonum)
- bne.b asm_generic_$1_hook
- lsl.l &TC_LENGTH,%d2
- asr.l &TC_LENGTH,%d2
- fmove.l %d2,%fp0
- $3.d 4(%a1),%fp0
- addq.l &8,%sp
- bra asm_generic_flonum_result
-
-asm_generic_$1_flo_fix:
- COMPARE_TYPE_CODE(%d1,tc_fixnum)
- bne.b asm_generic_$1_hook
- lsl.l &TC_LENGTH,%d3
- asr.l &TC_LENGTH,%d3
- fmove.d 4(%a0),%fp0
- $3.l %d3,%fp0
- addq.l &8,%sp
- bra asm_generic_flonum_result
-
-asm_generic_$1_hook:
- movq &HEX($2),%d0
- bra scheme_to_interface')
-\f
-define(define_generic_binary_predicate,
-`define_c_label(asm_generic_$1)
- EXTRACT_TYPE_CODE((%sp),%d0) # Get arg1s type
- EXTRACT_TYPE_CODE(4(%sp),%d1) # Get arg2s type
- mov.l (%sp),%d2 # arg1
- mov.l 4(%sp),%d3 # arg2
- and.l rmask,%d2
- and.l rmask,%d3
- mov.l %d2,%a0
- mov.l %d3,%a1
- COMPARE_TYPE_CODE(%d0,tc_flonum)
- bne.b asm_generic_$1_fix_flo
- COMPARE_TYPE_CODE(%d1,tc_flonum)
- bne.b asm_generic_$1_flo_fix
- addq.l &8,%sp
- fmove.d 4(%a0),%fp0
- fcmp.d %fp0,4(%a1)
- fb$3 asm_true_result
- bra asm_false_result
-
-asm_generic_$1_fix_flo:
- COMPARE_TYPE_CODE(%d0,tc_fixnum)
- bne.b asm_generic_$1_hook
- COMPARE_TYPE_CODE(%d1,tc_flonum)
- bne.b asm_generic_$1_hook
- addq.l &8,%sp
- lsl.l &TC_LENGTH,%d2
- asr.l &TC_LENGTH,%d2
- fmove.l %d2,%fp0
- fcmp.d %fp0,4(%a1)
- fb$3 asm_true_result
- bra asm_false_result
-
-asm_generic_$1_flo_fix:
- COMPARE_TYPE_CODE(%d1,tc_fixnum)
- bne.b asm_generic_$1_hook
- addq.l &8,%sp
- lsl.l &TC_LENGTH,%d3
- asr.l &TC_LENGTH,%d3
- fmove.d 4(%a0),%fp0
- fcmp.l %fp0,%d3
- fb$3 asm_true_result
- bra asm_false_result
-
-asm_generic_$1_hook:
- movq &HEX($2),%d0
- bra scheme_to_interface')
-
-define_generic_unary(decrement,22,fsub)
-define_generic_binary(divide,23,fdiv)
-define_generic_binary_predicate(equal,24,eq)
-define_generic_binary_predicate(greater,25,gt)
-define_generic_unary(increment,26,fadd)
-define_generic_binary_predicate(less,27,lt)
-define_generic_binary(subtract,28,fsub)
-define_generic_binary(multiply,29,fmul)
-define_generic_unary_predicate(negative,2a,lt)
-define_generic_binary(add,2b,fadd)
-define_generic_unary_predicate(positive,2c,gt)
-define_generic_unary_predicate(zero,2d,eq)
-\f
-### Close-coded stack and interrupt check for use when stack checking
-### is enabled.
-
-define_c_label(asm_stack_and_interrupt_check_12)
- mov.l &-12,-(%sp)
- bra.b stack_and_interrupt_check
-
-define_c_label(asm_stack_and_interrupt_check_14)
- mov.l &-14,-(%sp)
- bra.b stack_and_interrupt_check
-
-define_c_label(asm_stack_and_interrupt_check_18)
- mov.l &-18,-(%sp)
- bra.b stack_and_interrupt_check
-
-define_c_label(asm_stack_and_interrupt_check_22)
- mov.l &-22,-(%sp)
- bra.b stack_and_interrupt_check
-
-define_c_label(asm_stack_and_interrupt_check_24)
- mov.l &-24,-(%sp)
-# bra.b stack_and_interrupt_check
-
-### On entry, 4(%sp) contains the resumption address, and 0(%sp) is
-### the offset between the resumption address and the GC label
-### address.
-define_debugging_label(stack_and_interrupt_check)
-
-### If the Scheme stack pointer is <= Stack_Guard, then the stack has
-### overflowed -- in which case we must signal a stack-overflow interrupt.
- cmp.l %sp,regblock_stack_guard(regs)
- bgt.b stack_and_interrupt_check_1
-
-### Set the stack-overflow interrupt bit. If the stack-overflow
-### interrupt is disabled, skip forward to gc test. Otherwise, set
-### MemTop to -1 and signal the interrupt.
- bset &0,regblock_int_code+3(regs)
- btst &0,regblock_int_mask+3(regs)
- beq.b stack_and_interrupt_check_1
- mov.l &-1,regblock_memtop(regs)
- bra.b stack_and_interrupt_check_2
-
-### If (Free >= MemTop), signal an interrupt.
-stack_and_interrupt_check_1:
- cmp.l rfree,regblock_memtop(regs)
- bge.b stack_and_interrupt_check_2
-
-### No action necessary -- return to resumption address.
- addq.l &4,%sp
- rts
-
-### Must signal the interrupt -- return to GC label instead.
-stack_and_interrupt_check_2:
- mov.l %d0,-(%sp)
- mov.l 4(%sp),%d0
- add.l %d0,8(%sp)
- mov.l (%sp),%d0
- addq.l &8,%sp
- rts
-\f
-### Assembly-language implementation of SET-INTERRUPT-ENABLES!
-### primitive. Argument appears at top of stack, return address below
-### that.
-
-define_c_label(asm_set_interrupt_enables)
-define_debugging_label(set_interrupt_enables)
- # Return value is previous contents of mask register.
- mov.l regblock_int_mask(regs),rval
- or.l &TYPE_CODE_TO_OBJECT(tc_fixnum),rval
- mov.l (%sp)+,%d0 # get new interrupt mask
- and.l rmask,%d0 # strip fixnum type
- mov.l %d0,regblock_int_mask(regs) # store it in mask register
- # Setup compiled memtop register: -1 if pending interrupt,
- # Memtop if GC enabled, else Heap_Top.
- movq &-1,%d1
- mov.l regblock_int_code(regs),%d2
- and.l %d0,%d2
- bne.b set_interrupt_enables_1
- mov.l extern_c_label(MemTop),%d1
- btst &2,%d0
- bne.b set_interrupt_enables_1
- mov.l extern_c_label(Heap_Top),%d1
-set_interrupt_enables_1:
- mov.l %d1,regblock_memtop(regs)
- # Setup compiled stack_guard register: Stack_Guard if
- # stack-overflow enabled, else Stack_Bottom
- mov.l extern_c_label(Stack_Guard),%d1
- btst &0,%d0
- bne.b set_interrupt_enables_2
- mov.l extern_c_label(Stack_Bottom),%d1
-set_interrupt_enables_2:
- mov.l %d1,regblock_stack_guard(regs)
- mov.l (%sp)+,%d0
- and.l rmask,%d0
- mov.l %d0,%a0
- jmp (%a0)
+++ /dev/null
-/* #define DEBUG_INTERFACE */ /* -*-Midas-*- */
- ###
- ### Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
- ### 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- ### 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
- ### 2014, 2015, 2016, 2017 Massachusetts Institute of Technology
- ###
- ### This file is part of MIT/GNU Scheme.
- ###
- ### MIT/GNU Scheme is free software; you can redistribute it and/or
- ### modify it under the terms of the GNU General Public License as
- ### published by the Free Software Foundation; either version 2 of
- ### the License, or (at your option) any later version.
- ###
- ### MIT/GNU Scheme is distributed in the hope that it will be useful,
- ### but WITHOUT ANY WARRANTY; without even the implied warranty of
- ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- ### General Public License for more details.
- ###
- ### You should have received a copy of the GNU General Public License
- ### along with MIT/GNU Scheme; if not, write to the Free Software
- ### Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
- ### 02110-1301, USA.
-\f
- #### MIPS Architecture assembly language part of the compiled
- #### code interface. See cmpint.txt, cmpint.c, cmpint-mips.h, and
- #### cmpgc.h for more documentation.
- ####
- #### NOTE:
- #### Assumptions:
- ####
- #### 1) All registers (except double floating point registers) and
- #### stack locations hold a C long object.
- ####
- #### 2) The C compiler divides registers into three groups:
- #### - Linkage registers, used for procedure calls and global
- #### references. On MIPS: 0 (always 0), 31 (return address),
- #### 28 (global data pointer), and 29 (C stack pointer).
- #### - super temporaries, not preserved accross procedure calls and
- #### always usable. On MIPS: 1-15, and 24-25.
- #### 4-7 are argument registers,
- #### 2 and 3 are return registers.
- #### - preserved registers saved by the callee if they are written.
- #### On MIPS: 16-23, and 30.
- ####
- #### 3) Arguments, if passed on a stack, are popped by the caller
- #### or by the procedure return instruction (as on the VAX). Thus
- #### most "leaf" procedures need not worry about them. On MIPS: All
- #### arguments have slots in the stack, allocated and popped by the
- #### caller, but the first four words are actually passed in
- #### registers 4 through 7, unless they are floating point
- #### arguments, in which case they are passed in floating point
- #### registers.
- ####
- #### 4) There is a hardware or software maintained stack for
- #### control. The procedure calling sequence may leave return
- #### addresses in registers, but they must be saved somewhere for
- #### nested calls and recursive procedures. On MIPS: Passed in a
- #### register, but a slot on the stack exists, allocated by the
- #### caller. The return link is in 31. The stack pointer is in
- #### 29.
- ####
- #### 5) C procedures return long values in a super temporary
- #### register. MIPS only: two word structures are returned in a
- #### location specified by the contents of the first argument
- #### register, and all other arguments are shifted over one
- #### location (i.e. apparent argument 1 is passed in the register
- #### usually used for argument 2, etc.)
- ####
- #### 6) On MIPS the floating point registers fr20-fr31 are
- #### callee-saves registers, fr12-fr15 are parameter registers, and
- #### fr4-fr11 and fr16-fr19 are caller-saves registers. fr0-3 are
- #### return result registers. Only the even numbered registers are
- #### used (odd registers contain second 32 bits of 64 bit values).
-\f
- #### Compiled Scheme code uses the following register convention.
- #### Note that scheme_to_interface and the register block are
- #### preserved by C calls, but the others are not, since they change
- #### dynamically. scheme_to_interface_linked and
- #### trampoline_to_interface can be reached at fixed offsets from
- #### scheme_to_interface.
- #### - gr1 is the assembler temporary.
- #### - gr2 is the returned value register.
- #### - gr3 contains the Scheme stack pointer.
- #### - gr4 - gr7 are used by C for passing arguments.
- #### - gr8 contains a cached version of MemTop.
- #### - gr9 contains the Scheme free pointer.
- #### - gr10 contains the address of scheme_to_interface.
- #### - gr11 contains the dynamic link when needed.
- #### - gr12 - gr15 have no special uses.
- #### <CALLEE SAVES REGISTERS BELOW HERE>
- #### - gr16 - gr18 have no special uses.
- #### - gr19 contains the closure free pointer.
- #### - gr20 contains the address mask for machine pointers.
- #### - gr21 contains a pointer to the Scheme interpreter's
- #### "register" block. This block contains the compiler's
- #### copy of MemTop, the interpreter's registers (val, env,
- #### exp, etc), temporary locations for compiled code.
- #### - gr22 contains the top 6 address bits for heap pointers.
- #### - gr23 contains the closure hook.
- #### <CALLEE SAVES REGISTERS ABOVE HERE>
- #### - gr24 has no special use.
- #### - gr25 is used a an index for dispatch into C.
- #### - gr26 and 27 are reserved for the OS.
- #### - gr28 contains the pointer to C static variables.
- #### - gr29 contains the C stack pointer.
- #### <CALLEE SAVES REGISTERS BELOW HERE>
- #### - gr30 has no special use.
- #### <CALLEE SAVES REGISTERS ABOVE HERE>
- #### - gr31 is used for linkage (JALR, JAL, BGEZAL, and BLTZAL write it).
- ####
- #### All other registers are available to the compiler. A
- #### caller-saves convention is used, so the registers need not be
- #### preserved by subprocedures.
- ####
- #### Notice that register gr25 is used for the index used to
- #### dispatch into the trampolines and interface routines.
-\f
- # .verstamp 1 31
- .text
- .align 2
- .set noat
- .set noreorder
-
- # This is required to work around a bug in the IRIX 6.3 assembler.
- # The bug caused an incorrect reference to be generated in the
- # "la $closure_reg,closure_hook" instruction.
- .globl closure_hook
-
-define(value, 2)
-define(stack, 3)
-define(C_arg1, 4)
-define(C_arg2, 5)
-define(C_arg3, 6)
-define(C_arg4, 7)
-define(memtop, 8)
-define(free, 9)
-define(s_to_i, 10)
-define(dynlink, 11)
-
-define(closure_free, 19)
-define(addr_mask, 20)
-define(registers, 21)
-define(heap_bits, 22)
-define(closure_reg, 23)
-
-define(tramp_index, 25)
-
-define(TC_ENTITY, 0x10)
-define(TC_FIXNUM, 0x1A)
-define(TC_CCENTRY, 0x28)
-
- # Argument (in $C_arg1) is a compiled Scheme entry point
- # but save C registers first
- .globl C_to_interface
- .ent C_to_interface
-C_to_interface:
- addi $sp,$sp,-120
- .frame $sp,120,$0
- .mask 0x80ff0000,0
- sw $31,116($sp) # Save return address
- sw $30,112($sp)
- sw $23,108($sp)
- sw $22,104($sp)
- sw $21,100($sp)
- sw $20,96($sp)
- sw $19,92($sp)
- sw $18,88($sp)
- sw $17,84($sp)
- sw $16,80($sp)
- .fmask 0x00000fff,0
- s.d $f30,72($sp)
- s.d $f28,64($sp)
- s.d $f26,56($sp)
- s.d $f24,48($sp)
- s.d $f22,40($sp)
- s.d $f20,32($sp)
- # 20 and 24($sp) hold return data structure from C hooks
- # 16 is reserved for 4th argument to hooks, if used.
- # 4, 8, and 12($sp) are space for 1st - 3rd argument.
- # 0($sp) is space for holding return pointer
-#ifdef DEBUG_INTERFACE
- la $registers,Debug_Buffer
- .set at
- sw $registers,Debug_Buffer_Pointer
- .set noat
-#endif
- la $registers,Registers
- lw $heap_bits,Free
- lui $addr_mask,0xfc00
- and $heap_bits,$heap_bits,$addr_mask
- nor $addr_mask,$0,$addr_mask
- la $closure_reg,closure_hook
- lw $closure_free,36($registers)
- # ... fall through ...
- # Argument (in $C_arg1) is a compiled Scheme entry point. Reload
- # the Scheme registers and go to work...any registers not reloaded
- # here must be callee saves by C.
- .globl interface_to_scheme
-interface_to_scheme:
- lw $value,8($registers)
- lw $memtop,0($registers)
- lw $stack,sp_register
- lw $free,Free
- and $dynlink,$addr_mask,$value
- or $dynlink,$heap_bits,$dynlink
-#ifdef DEBUG_INTERFACE
- andi $at,$free,3
- bne $at,0,Bad_Free_Pointer
- nop
-Continue_Past_Free_Problem:
-#endif
- jal $31,$C_arg1 # Off to compiled code ...
- addi $s_to_i,$31,100 # Set up scheme_to_interface
-
- .globl hook_jump_table
-hook_jump_table:
- # This sequence of NOPs is provided to allow for modification of
- # the sequence that appears above without having to recompile the
- # world. The compiler "knows" the distance between
- # scheme_to_interface_ble and hook_jump_table (100 bytes)
- #
- # $tramp_index has the offset into the table that is desired.
- .globl link_to_interface
-link_to_interface: # ...scheme_to_interface-100
- addi $31,$31,4 # Skip over format word ...
-
- .globl trampoline_to_interface
-trampoline_to_interface: # ...scheme_to_interface-96
- j scheme_to_interface
- add $C_arg2,$0,$31 # Arg2 <- trampoline data area
-
- break 1 # ...-88 Used to be generate_closure
- nop # ...-84
-
- break 2 # ...-80 Used to be push_closure_entry
- nop # ...-76
-
- j cons_closure # -72
- lw $7,40($registers) # closure limit -68
-
- j cons_multi # -64
- lw $7,40($registers) # closure limit -60
-
- j shortcircuit_apply # ...-56
- lw $C_arg2,0($stack) # procedure -52
-
- j set_interrupt_enables # ...-48
- lw $value,4($registers) # ...-44
-
- nop # ...-40
- nop # ...-36
- nop # ...-32
- nop # ...-28
- nop # ...-24
- nop # ...-20
- nop # ...-16
- nop # ...-12
- nop # ...-8
- nop # ...-4
-
- # DO NOT MOVE the following label, it is used above ...
- # Argument (in $tramp_index) is index into utility_table for the
- # interface procedure to be called. The Scheme compiler has saved
- # any registers that it may need. Registers 5 through 7 are loaded
- # with arguments for the C procedure that is being invoked. The
- # fourth argument (if used) is stored at 16($sp).
-
- .globl scheme_to_interface
-scheme_to_interface:
- sw $value,8($registers)
- sw $closure_free,36($registers)
-#ifdef DEBUG_INTERFACE
- lw $value,Stack_Bottom
- addi $0,$0,0 # Load delay
- sltu $at,$stack,$value
- bne $at,$0,Stack_Overflow_Detected
- addi $0,$0,0
- lw $value,Debug_Buffer_Pointer
- addi $0,$0,0
- sw $stack,0($value) # Stack pointer
- sw $25,4($value) # Index
- sw $C_arg2,8($value) # 1st arg.
- sw $C_arg3,12($value) # 2nd arg.
- sw $C_arg4,16($value) # 3rd arg.
- addi $value,$value,20
- la $12,Debug_Buffer_End
- bne $12,$value,Store_Pointer_Back
- nop
- la $12,Debug_Buffer
- add $value,$0,$12
-Store_Pointer_Back:
- .set at
- sw $value,Debug_Buffer_Pointer
- lw $value,Debug_Call_Count
- lw $12,Debug_Call_Max
- addi $value,$value,1
- sw $value,Debug_Call_Count
- beq $value,$12,Debug_Tight_Loop
- nop
- .set noat
-#endif
-after_overflow:
- la $24,utility_table # Find table
- add $25,$24,$25 # Address of entry
- lw $25,0($25) # gr25 <- Entry
- la $24,sp_register
- sw $stack,0($24) # Save Scheme stack pointer
- la $24,Free
- sw $free,0($24) # Save Free
- jal $31,$25 # Off to interface code
- addi $C_arg1,$sp,20 # Return value on C stack
- lw $25,20($sp) # Get dispatch address
- lw $C_arg1,24($sp) # Arg1 <- value component
- jal $31,$25 # Redispatch ...
- addi $0,$0,0 # Branch delay...
-
- .globl closure_hook
-closure_hook:
- # On arrival:
- # GR31 has address of JAL instruction we were supposed to have
- # executed. This code emulates the JAL.
- # (except that R31 is already set).
- lw $at,0($31) # Load JAL instruction
- nop # Load delay slot
- and $at,$at,$addr_mask # clear JAL opcode
- sll $at,$at,2 # obtain destination address
- or $at,$at,$heap_bits # insert top bits into destination
- j $at # invoke
- nop # jump delay slot
-
- .globl cons_closure
-cons_closure:
- # On arriveal:
- # - GR31 has the address of the manifest closure header,
- # followed by the closure descriptor (2 words),
- # followed by the instructions we need to continue with.
- # The closure descriptor consists of the format+gc-offset word
- # followed by a PC-relative JAL instruction.
- # - GR4 has the address past the first word on this closure
- # (assuming the entry point is at closure-free).
- # - GR5 has the increment for closure-free.
- # On return:
- # - GR4 has the address of the closure
- # This code assumes that it can clobber registers 7 and at freely.
- # lw $7,40($registers) # closure limit
- lw $at,0($31) # closure header word
- subu $7,$7,$4 # check if it fits
- bgez $7,cons_closure_continue
- or $4,$closure_free,$0 # setup result
- or $7,$31,$0 # Preserve original return address
- bgezal $0,invoke_allocate_closure
- addi $at,$at,2 # Total size = datum(header) + 2
-
-cons_closure_continue:
- add $closure_free,$closure_free,$5 # allocate
- lw $5,4($31) # format+gc-offset word
- lw $7,8($31) # JAL instruction
- sw $0,-12($4) # Make heap parseable
- sw $5,-4($4) # Store format+gc-offset
- srl $5,$31,2 # return address -> JAL destination
- sw $at,-8($4) # Store closure header
- and $5,$5,$addr_mask # clear top bits
- addi $31,$31,12 # Bump past structure
- addu $5,$5,$7 # JAL instruction
- j $31 # Return.
- sw $5,0($4) # Store the JAL instruction
-
- .globl cons_multi
-cons_multi:
- # On arriveal:
- # - GR31 has the address of the manifest closure header,
- # followed by n closure descriptors (2 words each),
- # followed by the instructions we need to continue with.
- # Each closure descriptor consists of the format+gc-offset
- # word followed by a PC-relative JAL instruction.
- # - GR4 has the address past the first word on this closure
- # (assuming the entry point is at closure-free).
- # - GR5 has the increment for closure-free.
- # - GR6 has the number of entries (>= 1)
- # On return:
- # - GR4 has the address of the closure
- # This code assumes that it can clobber registers 7 and at freely.
- # lw $7,40($registers) # closure limit
- lw $at,0($31) # closure header word
- subu $7,$7,$4 # check if it fits
- bgez $7,cons_multi_continue
- or $4,$closure_free,$0 # setup result
- or $7,$31,$0 # Preserve original return address
- bgezal $0,invoke_allocate_closure
- addi $at,$at,1 # Total size = datum(header) + 1
-
-cons_multi_continue:
- add $closure_free,$closure_free,$5 # allocate
- sw $at,-12($4) # Store closure header
- sh $6,-8($4) # Store number of entries
- sh $0,-6($4) # Tag as multi-closure
- addi $7,$4,-4 # Pointer to closure entries
- srl $5,$31,2 # return-address -> JAL destination
- and $5,$5,$addr_mask # clear top bits
- addi $31,$31,4 # bump to first descriptor
-
-store_loop:
- lw $at,0($31) # format+gc-offset word
- addi $6,$6,-1 # decrement count
- addi $31,$31,8 # bump pointer to block
- sw $at,0($7) # store into closure
- lw $at,-4($31) # PC-relative JAL
- addi $7,$7,12 # bump pointer to closure
- add $at,$at,$5 # absolute JAL instruction
- bgtz $6,store_loop
- sw $at,-8($7) # store JAL instruction
-
- j $31 # return
- nop # delay slot
-
-invoke_allocate_closure:
- # $at contains in its datum the minimum size to allocate.
- # $7 contains the "return address" for cons_closure or cons_multi.
- # $31 contains the return address for invoke_allocate_closure.
- addi $sp,$sp,-80
- # 1 is at, a temp
- sw $2,80-4($sp)
- sw $3,80-8($sp)
- and $4,$at,$addr_mask # total size (- 1)
- sw $5,80-12($sp)
- sw $6,80-16($sp)
- sw $7,80-20($sp) # Original value of r31
- # sw $8,0($registers) # memtop is read-only
- la $7,Free
- sw $9,0($7)
- sw $10,80-24($sp)
- sw $11,80-28($sp)
- sw $12,80-32($sp)
- sw $13,80-36($sp)
- sw $14,80-40($sp)
- sw $15,80-44($sp)
- # 16-23 are callee-saves registers.
- sw $24,80-48($sp)
- sw $25,80-52($sp)
- # 26-29 are taken up by the OS and the C calling convention.
- # 30 is a callee-saves register.
- sw $31,80-60($sp) # return address
- jal allocate_closure
- sw $closure_free,36($registers) # uncache
-
- lw $closure_free,36($registers)
- lw $31,80-20($sp) # original value of r31
- lw $25,80-52($sp)
- lw $24,80-48($sp)
- lw $15,80-44($sp)
- lw $14,80-40($sp)
- lw $13,80-36($sp)
- lw $12,80-32($sp)
- lw $11,80-28($sp)
- lw $10,80-24($sp)
- lw $9,Free
- lw $8,0($registers)
- lw $7,80-60($sp) # return address for invoke...
- lw $6,80-16($sp)
- lw $5,80-12($sp)
- lw $3,80-8($sp)
- lw $2,80-4($sp)
- lw $at,0($31) # manifest closure header
- or $4,$closure_free,$0 # setup result
-
- j $7
- addi $sp,$sp,80
-
- .globl shortcircuit_apply
-shortcircuit_apply:
- # $C_arg2 contains the procedure one cycle after this point.
- # $C_arg3 contains the frame size
- addi $at,$0,TC_CCENTRY # test for compiled entry
- srl $C_arg4,$C_arg2,26
- bne $C_arg4,$at,shortcircuit_apply_1
- and $C_arg2,$addr_mask,$C_arg2 # procedure -> address
- or $C_arg2,$heap_bits,$C_arg2
- lhu $C_arg4,-4($C_arg2) # lose if wrong arity
- addi $at,$0,0xff
- and $C_arg4,$at,$C_arg4
- bne $C_arg4,$C_arg3,shortcircuit_apply_lose
- nop
- j $C_arg2 # invoke procedure
- addi $stack,$stack,4 # pop it too
-
- .globl shortcircuit_apply_1
-shortcircuit_apply_1:
- addi $at,$0,TC_ENTITY # Test for entity
- bne $C_arg4,$at,shortcircuit_apply_lose
- or $C_arg2,$heap_bits,$C_arg2 # get entity's procedure
- lw $C_arg2,0($C_arg2)
- addi $at,$0,TC_CCENTRY # test for compiled entry
- srl $C_arg4,$C_arg2,26
- bne $C_arg4,$at,shortcircuit_apply_lose
- and $C_arg2,$addr_mask,$C_arg2 # procedure -> address
- or $C_arg2,$heap_bits,$C_arg2
- lhu $C_arg4,-4($C_arg2) # lose if wrong arity
- addi $at,$0,0xff
- and $C_arg4,$at,$C_arg4
- addi $at,$C_arg3,1 # adjust for entity arg
- bne $C_arg4,$C_arg3,shortcircuit_apply_lose
- nop
- j $C_arg2 # invoke procedure
- nop # don't pop entity arg
-
- .globl shortcircuit_apply_lose
-shortcircuit_apply_lose:
- lw $C_arg2,0($stack) # pop procedure into arg register
- addi $stack,$stack,4
- la $at,scheme_to_interface # invoke the standard apply
- j $at
- addi $tramp_index,$0,80
-
- .globl set_interrupt_enables
-set_interrupt_enables:
- # 0($stack) has the new interrupt mask (a fixnum)
- # 4($stack) has the return address (a compiled entry)
- # $value has been set above to old interrupt mask
- lui $at,(TC_FIXNUM*0x400) # slap fixnum type code on value
- or $value,$value,$at
- lw $C_arg1,0($stack) # get new interrupt mask
- lw $C_arg2,48($registers) # get interrupt code
- and $C_arg1,$C_arg1,$addr_mask
- sw $C_arg1,4($registers) # store new mask in mask register
- # Now, set up the memtop and stack_guard registers.
- # Memtop is -1 if there are any pending interrupts, else
- # "MemTop" if GC interrupt is enabled, else "Heap_Top".
- and $C_arg2,$C_arg2,$C_arg1 # get masked interrupts
- bne $C_arg2,$0,set_interrupt_enables_1
- addi $memtop,$0,-1
- andi $C_arg2,$C_arg1,4 # test for GC interrupt
- lw $memtop,MemTop
- bne $C_arg2,$0,set_interrupt_enables_1
- nop
- lw $memtop,Heap_Top
- .globl set_interrupt_enables_1
-set_interrupt_enables_1:
- andi $C_arg2,$C_arg1,1 # test for stack-overflow interrupt
- sw $memtop,0($registers)
- # Stack_guard's value depends on whether the stack-overflow
- # interrupt is enabled.
- lw $C_arg3,Stack_Guard
- bne $C_arg2,$0,set_interrupt_enables_2
- nop
- lw $C_arg3,Stack_Bottom
- .globl set_interrupt_enables_2
-set_interrupt_enables_2:
- lw $C_arg2,4($stack) # get return address
- sw $C_arg3,44($registers) # store stack_guard
- and $C_arg2,$C_arg2,$addr_mask # return to caller
- or $C_arg2,$C_arg2,$heap_bits
- j $C_arg2
- addi $stack,$stack,8
-
- # Argument 1 (in $C_arg1) is the returned value
- .globl interface_to_C
-interface_to_C:
- l.d $f20,32($sp)
- l.d $f22,40($sp)
- l.d $f24,48($sp)
- l.d $f26,56($sp)
- l.d $f28,64($sp)
- l.d $f30,72($sp)
- lw $16,80($sp)
- lw $17,84($sp)
- lw $18,88($sp)
- lw $19,92($sp)
- lw $20,96($sp)
- lw $21,100($sp)
- lw $22,104($sp)
- lw $23,108($sp)
- lw $30,112($sp)
- lw $31,116($sp)
- addi $sp,$sp,120 # Pop stack back
- j $31 # Return
- add $2,$0,$C_arg1 # Return value to C
- .end C_to_interface
-
-#ifdef DEBUG_INTERFACE
- .globl Stack_Overflow_Detected
-Stack_Overflow_Detected:
- j after_overflow
- nop
-
- .globl Bad_Free_Pointer
-Bad_Free_Pointer:
- j Continue_Past_Free_Problem
- nop
-#endif
-
- .globl interface_initialize
- .ent interface_initialize
-interface_initialize:
- .frame $sp,0,$31
- cfc1 $25,$31 # read FPU control register
- nop
- ori $25,$25,0xf00 # enable V, Z, O, U traps
- ctc1 $25,$31 # write FPU control register
- nop
- j $31 # return
- nop
- .end interface_initialize
-
- .globl Debug_Tight_Loop
- .ent Debug_Tight_Loop
-Debug_Tight_Loop:
- beq $12,$value,Debug_Tight_Loop
- nop
- j after_overflow
- .end Debug_Tight_Loop
-
-#ifdef DEBUG_INTERFACE
- .data
- .globl Debug_Buffer_Pointer
-Debug_Buffer_Pointer:
- .word 0
- .globl Debug_Buffer
-Debug_Buffer:
- .word 0:30
-Debug_Buffer_End:
- .word 0
- .globl Debug_Call_Count
-Debug_Call_Count:
- .word 0
- .globl Debug_Call_Max
-Debug_Call_Max:
- .word 0
-#endif
+++ /dev/null
-regblock_memtop = 0
-regblock_int_mask = 4
-regblock_val = 8
-regblock_stack_guard = 44
-regblock_int_code = 48
-address_mask = 0x3FFFFFF
- .data
- .globl c_save_stack
-c_save_stack:
- .skip 4
- .text
- .globl _interface_initialize
-_interface_initialize:
- link a6,#0
- fmovel #0x3480,fpcr
- unlk a6
- rts
- .globl _C_to_interface
-_C_to_interface:
- link a6,#-44
- moveml d2-d7/a2-a5,a7@(4)
- movl a6@(8),a0
- bras interface_to_scheme_internal
- .globl _asm_scheme_to_interface
-_asm_scheme_to_interface:
- .globl scheme_to_interface
-scheme_to_interface:
- movl d6,a6@(regblock_val)
- movl a5,_Free
- movl sp,_sp_register
- movl c_save_stack,sp
- movl a7@,a6
- movl d4,a7@-
- movl d3,a7@-
- movl d2,a7@-
- movl d1,a7@-
- lea _utility_table,a0
- movl a0@(0,d0:w:4),a0
- jsr a0@
- lea a7@(16),sp
- movl d0,a0
- jmp a0@
- .globl _interface_to_scheme
-_interface_to_scheme:
- movl d1,a0
- .globl interface_to_scheme_internal
-interface_to_scheme_internal:
- movl a6,a7@
- movl sp,c_save_stack
- movl _sp_register,sp
- movl _Free,a5
- lea _Registers,a6
- movl #address_mask,d7
- movl a6@(regblock_val),d6
- movl d6,d0
- movl d0,d1
- andl d7,d1
- movl d1,a4
- jmp a0@
- .globl _interface_to_C
-_interface_to_C:
- movl d1,d0
- moveml a7@(4),d2-d7/a2-a5
- unlk a6
- rts
- .globl _asm_trampoline_to_interface
-_asm_trampoline_to_interface:
- .globl trampoline_to_interface
-trampoline_to_interface:
- movl a7@+,d1
- bra scheme_to_interface
- .globl _asm_scheme_to_interface_jsr
-_asm_scheme_to_interface_jsr:
- .globl scheme_to_interface_jsr
-scheme_to_interface_jsr:
- movl a7@+,d1
- addql #4,d1
- bra scheme_to_interface
- .globl _asm_primitive_lexpr_apply
-_asm_primitive_lexpr_apply:
- moveq #0x13,d0
- bra scheme_to_interface
- .globl _asm_error
-_asm_error:
- moveq #0x15,d0
- bra scheme_to_interface
- .globl _asm_link
-_asm_link:
- moveq #0x17,d0
- bra scheme_to_interface_jsr
- .globl _asm_interrupt_closure
-_asm_interrupt_closure:
- moveq #0x18,d0
- bra scheme_to_interface
- .globl _asm_interrupt_procedure
-_asm_interrupt_procedure:
- moveq #0x1a,d0
- bra scheme_to_interface_jsr
- .globl _asm_interrupt_continuation
-_asm_interrupt_continuation:
- moveq #0x1b,d0
- bra scheme_to_interface_jsr
- .globl _asm_assignment_trap
-_asm_assignment_trap:
- moveq #0x1d,d0
- bra scheme_to_interface_jsr
- .globl _asm_reference_trap
-_asm_reference_trap:
- moveq #0x1f,d0
- bra scheme_to_interface_jsr
- .globl _asm_safe_reference_trap
-_asm_safe_reference_trap:
- moveq #0x20,d0
- bra scheme_to_interface_jsr
- .globl _asm_primitive_error
-_asm_primitive_error:
- moveq #0x36,d0
- bra scheme_to_interface_jsr
- .globl _asm_generic_quotient
-_asm_generic_quotient:
- moveq #0x37,d0
- bra scheme_to_interface
- .globl _asm_generic_remainder
-_asm_generic_remainder:
- moveq #0x38,d0
- bra scheme_to_interface
- .globl _asm_generic_modulo
-_asm_generic_modulo:
- moveq #0x39,d0
- bra scheme_to_interface
- .globl _asm_interrupt_dlink
-_asm_interrupt_dlink:
- movl a4,d2
- moveq #0x19,d0
- bra scheme_to_interface_jsr
- .globl _asm_primitive_apply
-_asm_primitive_apply:
- movl a5,_Free
- movl sp,_sp_register
- movl c_save_stack,sp
- movl a7@,a6
- movl d1,a7@-
- movl _utility_table+0x12*4,a0
- jsr a0@
- lea a7@(4),sp
- movl d0,a0
- jmp a0@
-tc_compiled_entry = 0x28
-tc_flonum = 0x06
-tc_fixnum = 0x1A
-tc_manifest_nmv = 0x27
-tc_false = 0x0
-tc_true = 0x8
-offset_apply = 0x14
- .globl _asm_shortcircuit_apply
-_asm_shortcircuit_apply:
- .globl shortcircuit_apply
-shortcircuit_apply:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- movb a0@(-3),d3
- extw d3
- cmpw d3,d2
- bnes shortcircuit_apply_1
- jmp a0@
- .globl shortcircuit_apply_1
-shortcircuit_apply_1:
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_1
-_asm_shortcircuit_apply_size_1:
- .globl shortcircuit_apply_size_1
-shortcircuit_apply_size_1:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_1_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #1,a0@(-3)
- bnes shortcircuit_apply_size_1_1
- jmp a0@
- .globl shortcircuit_apply_size_1_1
-shortcircuit_apply_size_1_1:
- moveq #1,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_2
-_asm_shortcircuit_apply_size_2:
- .globl shortcircuit_apply_size_2
-shortcircuit_apply_size_2:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_2_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #2,a0@(-3)
- bnes shortcircuit_apply_size_2_1
- jmp a0@
- .globl shortcircuit_apply_size_2_1
-shortcircuit_apply_size_2_1:
- moveq #2,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_3
-_asm_shortcircuit_apply_size_3:
- .globl shortcircuit_apply_size_3
-shortcircuit_apply_size_3:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_3_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #3,a0@(-3)
- bnes shortcircuit_apply_size_3_1
- jmp a0@
- .globl shortcircuit_apply_size_3_1
-shortcircuit_apply_size_3_1:
- moveq #3,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_4
-_asm_shortcircuit_apply_size_4:
- .globl shortcircuit_apply_size_4
-shortcircuit_apply_size_4:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_4_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #4,a0@(-3)
- bnes shortcircuit_apply_size_4_1
- jmp a0@
- .globl shortcircuit_apply_size_4_1
-shortcircuit_apply_size_4_1:
- moveq #4,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_5
-_asm_shortcircuit_apply_size_5:
- .globl shortcircuit_apply_size_5
-shortcircuit_apply_size_5:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_5_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #5,a0@(-3)
- bnes shortcircuit_apply_size_5_1
- jmp a0@
- .globl shortcircuit_apply_size_5_1
-shortcircuit_apply_size_5_1:
- moveq #5,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_6
-_asm_shortcircuit_apply_size_6:
- .globl shortcircuit_apply_size_6
-shortcircuit_apply_size_6:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_6_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #6,a0@(-3)
- bnes shortcircuit_apply_size_6_1
- jmp a0@
- .globl shortcircuit_apply_size_6_1
-shortcircuit_apply_size_6_1:
- moveq #6,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_7
-_asm_shortcircuit_apply_size_7:
- .globl shortcircuit_apply_size_7
-shortcircuit_apply_size_7:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_7_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #7,a0@(-3)
- bnes shortcircuit_apply_size_7_1
- jmp a0@
- .globl shortcircuit_apply_size_7_1
-shortcircuit_apply_size_7_1:
- moveq #7,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_8
-_asm_shortcircuit_apply_size_8:
- .globl shortcircuit_apply_size_8
-shortcircuit_apply_size_8:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_8_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #8,a0@(-3)
- bnes shortcircuit_apply_size_8_1
- jmp a0@
- .globl shortcircuit_apply_size_8_1
-shortcircuit_apply_size_8_1:
- moveq #8,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_allocate_closure
-_asm_allocate_closure:
- movl a5,_Free
- movl sp,_sp_register
- movl c_save_stack,sp
- movl a7@,a6
- movl a1,a7@-
- movl d1,a7@-
- movl d0,a7@-
- jsr _allocate_closure
- addql #4,sp
- movl d0,a0
- movl a7@+,d1
- movl a7@+,a1
- movl a6,a7@
- movl sp,c_save_stack
- movl _sp_register,sp
- movl _Free,a5
- lea _Registers,a6
- movl #address_mask,d7
- rts
- .globl asm_generic_flonum_result
-asm_generic_flonum_result:
- movl a5,d6
- movl #tc_manifest_nmv*4*0x1000000+2,a5@+
- fmoved fp0,a5@+
- orl #tc_flonum*4*0x1000000,d6
- andb #1*4-1,a7@
- rts
- .globl asm_true_result
-asm_true_result:
- movl #tc_true*4*0x1000000,d6
- andb #1*4-1,a7@
- rts
- .globl asm_false_result
-asm_false_result:
- movl #tc_false*4*0x1000000,d6
- andb #1*4-1,a7@
- rts
- .globl _asm_generic_decrement
-_asm_generic_decrement:
- movb a7@,d0
- andb #0xFC,d0
- cmpb #tc_flonum*4,d0
- bnes asm_generic_decrement_hook
- movl a7@+,d0
- andl d7,d0
- movl d0,a0
- fmoved a0@(4),fp0
- fsubb #1,fp0
- bra asm_generic_flonum_result
-asm_generic_decrement_hook:
- moveq #0x22,d0
- bra scheme_to_interface
- .globl _asm_generic_divide
-_asm_generic_divide:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_divide_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_divide_flo_fix
- fmoved a0@(4),fp0
- fdivd a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_divide_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_divide_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_divide_hook
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- fdivd a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_divide_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_divide_hook
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- fdivl d3,fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_divide_hook:
- moveq #0x23,d0
- bra scheme_to_interface
- .globl _asm_generic_equal
-_asm_generic_equal:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_equal_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_equal_flo_fix
- addql #8,sp
- fmoved a0@(4),fp0
- fcmpd a1@(4),fp0
- fbeq asm_true_result
- bra asm_false_result
-asm_generic_equal_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_equal_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_equal_hook
- addql #8,sp
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- fcmpd a1@(4),fp0
- fbeq asm_true_result
- bra asm_false_result
-asm_generic_equal_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_equal_hook
- addql #8,sp
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- fcmpl d3,fp0
- fbeq asm_true_result
- bra asm_false_result
-asm_generic_equal_hook:
- moveq #0x24,d0
- bra scheme_to_interface
- .globl _asm_generic_greater
-_asm_generic_greater:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_greater_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_greater_flo_fix
- addql #8,sp
- fmoved a0@(4),fp0
- fcmpd a1@(4),fp0
- fbgt asm_true_result
- bra asm_false_result
-asm_generic_greater_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_greater_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_greater_hook
- addql #8,sp
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- fcmpd a1@(4),fp0
- fbgt asm_true_result
- bra asm_false_result
-asm_generic_greater_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_greater_hook
- addql #8,sp
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- fcmpl d3,fp0
- fbgt asm_true_result
- bra asm_false_result
-asm_generic_greater_hook:
- moveq #0x25,d0
- bra scheme_to_interface
- .globl _asm_generic_increment
-_asm_generic_increment:
- movb a7@,d0
- andb #0xFC,d0
- cmpb #tc_flonum*4,d0
- bnes asm_generic_increment_hook
- movl a7@+,d0
- andl d7,d0
- movl d0,a0
- fmoved a0@(4),fp0
- faddb #1,fp0
- bra asm_generic_flonum_result
-asm_generic_increment_hook:
- moveq #0x26,d0
- bra scheme_to_interface
- .globl _asm_generic_less
-_asm_generic_less:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_less_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_less_flo_fix
- addql #8,sp
- fmoved a0@(4),fp0
- fcmpd a1@(4),fp0
- fblt asm_true_result
- bra asm_false_result
-asm_generic_less_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_less_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_less_hook
- addql #8,sp
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- fcmpd a1@(4),fp0
- fblt asm_true_result
- bra asm_false_result
-asm_generic_less_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_less_hook
- addql #8,sp
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- fcmpl d3,fp0
- fblt asm_true_result
- bra asm_false_result
-asm_generic_less_hook:
- moveq #0x27,d0
- bra scheme_to_interface
- .globl _asm_generic_subtract
-_asm_generic_subtract:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_subtract_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_subtract_flo_fix
- fmoved a0@(4),fp0
- fsubd a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_subtract_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_subtract_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_subtract_hook
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- fsubd a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_subtract_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_subtract_hook
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- fsubl d3,fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_subtract_hook:
- moveq #0x28,d0
- bra scheme_to_interface
- .globl _asm_generic_multiply
-_asm_generic_multiply:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_multiply_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_multiply_flo_fix
- fmoved a0@(4),fp0
- fmuld a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_multiply_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_multiply_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_multiply_hook
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- fmuld a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_multiply_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_multiply_hook
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- fmull d3,fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_multiply_hook:
- moveq #0x29,d0
- bra scheme_to_interface
- .globl _asm_generic_negative
-_asm_generic_negative:
- movb a7@,d0
- andb #0xFC,d0
- cmpb #tc_flonum*4,d0
- bnes asm_generic_negative_hook
- movl a7@+,d0
- andl d7,d0
- movl d0,a0
- fmoved a0@(4),fp0
- fblt asm_true_result
- bra asm_false_result
-asm_generic_negative_hook:
- moveq #0x2a,d0
- bra scheme_to_interface
- .globl _asm_generic_add
-_asm_generic_add:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_add_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_add_flo_fix
- fmoved a0@(4),fp0
- faddd a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_add_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_add_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_add_hook
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- faddd a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_add_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_add_hook
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- faddl d3,fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_add_hook:
- moveq #0x2b,d0
- bra scheme_to_interface
- .globl _asm_generic_positive
-_asm_generic_positive:
- movb a7@,d0
- andb #0xFC,d0
- cmpb #tc_flonum*4,d0
- bnes asm_generic_positive_hook
- movl a7@+,d0
- andl d7,d0
- movl d0,a0
- fmoved a0@(4),fp0
- fbgt asm_true_result
- bra asm_false_result
-asm_generic_positive_hook:
- moveq #0x2c,d0
- bra scheme_to_interface
- .globl _asm_generic_zero
-_asm_generic_zero:
- movb a7@,d0
- andb #0xFC,d0
- cmpb #tc_flonum*4,d0
- bnes asm_generic_zero_hook
- movl a7@+,d0
- andl d7,d0
- movl d0,a0
- fmoved a0@(4),fp0
- fbeq asm_true_result
- bra asm_false_result
-asm_generic_zero_hook:
- moveq #0x2d,d0
- bra scheme_to_interface
- .globl _asm_stack_and_interrupt_check_12
-_asm_stack_and_interrupt_check_12:
- movl #-12,a7@-
- bras stack_and_interrupt_check
- .globl _asm_stack_and_interrupt_check_14
-_asm_stack_and_interrupt_check_14:
- movl #-14,a7@-
- bras stack_and_interrupt_check
- .globl _asm_stack_and_interrupt_check_18
-_asm_stack_and_interrupt_check_18:
- movl #-18,a7@-
- bras stack_and_interrupt_check
- .globl _asm_stack_and_interrupt_check_22
-_asm_stack_and_interrupt_check_22:
- movl #-22,a7@-
- bras stack_and_interrupt_check
- .globl _asm_stack_and_interrupt_check_24
-_asm_stack_and_interrupt_check_24:
- movl #-24,a7@-
- .globl stack_and_interrupt_check
-stack_and_interrupt_check:
- cmpl a6@(regblock_stack_guard),sp
- bgts stack_and_interrupt_check_1
- bset #0,a6@(regblock_int_code+3)
- btst #0,a6@(regblock_int_mask+3)
- beqs stack_and_interrupt_check_1
- movl #-1,a6@(regblock_memtop)
- bras stack_and_interrupt_check_2
-stack_and_interrupt_check_1:
- cmpl a6@(regblock_memtop),a5
- bges stack_and_interrupt_check_2
- addql #4,sp
- rts
-stack_and_interrupt_check_2:
- movl d0,a7@-
- movl a7@(4),d0
- addl d0,a7@(8)
- movl a7@,d0
- addql #8,sp
- rts
- .globl _asm_set_interrupt_enables
-_asm_set_interrupt_enables:
- .globl set_interrupt_enables
-set_interrupt_enables:
- movl a6@(regblock_int_mask),d6
- orl #tc_fixnum*4*0x1000000,d6
- movl a7@+,d0
- andl d7,d0
- movl d0,a6@(regblock_int_mask)
- moveq #-1,d1
- movl a6@(regblock_int_code),d2
- andl d0,d2
- bnes set_interrupt_enables_1
- movl _MemTop,d1
- btst #2,d0
- bnes set_interrupt_enables_1
- movl _Heap_Top,d1
-set_interrupt_enables_1:
- movl d1,a6@(regblock_memtop)
- movl _Stack_Guard,d1
- btst #0,d0
- bnes set_interrupt_enables_2
- movl _Stack_Bottom,d1
-set_interrupt_enables_2:
- movl d1,a6@(regblock_stack_guard)
- movl a7@+,d0
- andl d7,d0
- movl d0,a0
- jmp a0@
+++ /dev/null
-regblock_memtop = 0
-regblock_int_mask = 4
-regblock_val = 8
-regblock_stack_guard = 44
-regblock_int_code = 48
-address_mask = 0x3FFFFFF
- .data
- .globl c_save_stack
-c_save_stack:
- .skip 4
- .text
- .globl _interface_initialize
-_interface_initialize:
- link a6,#0
- unlk a6
- rts
- .globl _C_to_interface
-_C_to_interface:
- link a6,#-44
- moveml d2-d7/a2-a5,a7@(4)
- movl a6@(8),a0
- bras interface_to_scheme_internal
- .globl _asm_scheme_to_interface
-_asm_scheme_to_interface:
- .globl scheme_to_interface
-scheme_to_interface:
- movl d6,a6@(regblock_val)
- movl a5,_Free
- movl sp,_sp_register
- movl c_save_stack,sp
- movl a7@,a6
- movl d4,a7@-
- movl d3,a7@-
- movl d2,a7@-
- movl d1,a7@-
- lea _utility_table,a0
- movl a0@(0,d0:w:4),a0
- jsr a0@
- lea a7@(16),sp
- movl d0,a0
- movl a0@(4),d1
- movl a0@(0),a0
- jmp a0@
- .globl _interface_to_scheme
-_interface_to_scheme:
- movl d1,a0
- .globl interface_to_scheme_internal
-interface_to_scheme_internal:
- movl a6,a7@
- movl sp,c_save_stack
- movl _sp_register,sp
- movl _Free,a5
- lea _Registers,a6
- movl #address_mask,d7
- movl a6@(regblock_val),d6
- movl d6,d0
- movl d0,d1
- andl d7,d1
- movl d1,a4
- jmp a0@
- .globl _interface_to_C
-_interface_to_C:
- movl d1,d0
- moveml a7@(4),d2-d7/a2-a5
- unlk a6
- rts
- .globl _asm_trampoline_to_interface
-_asm_trampoline_to_interface:
- .globl trampoline_to_interface
-trampoline_to_interface:
- movl a7@+,d1
- bra scheme_to_interface
- .globl _asm_scheme_to_interface_jsr
-_asm_scheme_to_interface_jsr:
- .globl scheme_to_interface_jsr
-scheme_to_interface_jsr:
- movl a7@+,d1
- addql #4,d1
- bra scheme_to_interface
- .globl _asm_primitive_lexpr_apply
-_asm_primitive_lexpr_apply:
- moveq #0x13,d0
- bra scheme_to_interface
- .globl _asm_error
-_asm_error:
- moveq #0x15,d0
- bra scheme_to_interface
- .globl _asm_link
-_asm_link:
- moveq #0x17,d0
- bra scheme_to_interface_jsr
- .globl _asm_interrupt_closure
-_asm_interrupt_closure:
- moveq #0x18,d0
- bra scheme_to_interface
- .globl _asm_interrupt_procedure
-_asm_interrupt_procedure:
- moveq #0x1a,d0
- bra scheme_to_interface_jsr
- .globl _asm_interrupt_continuation
-_asm_interrupt_continuation:
- moveq #0x1b,d0
- bra scheme_to_interface_jsr
- .globl _asm_assignment_trap
-_asm_assignment_trap:
- moveq #0x1d,d0
- bra scheme_to_interface_jsr
- .globl _asm_reference_trap
-_asm_reference_trap:
- moveq #0x1f,d0
- bra scheme_to_interface_jsr
- .globl _asm_safe_reference_trap
-_asm_safe_reference_trap:
- moveq #0x20,d0
- bra scheme_to_interface_jsr
- .globl _asm_primitive_error
-_asm_primitive_error:
- moveq #0x36,d0
- bra scheme_to_interface_jsr
- .globl _asm_generic_quotient
-_asm_generic_quotient:
- moveq #0x37,d0
- bra scheme_to_interface
- .globl _asm_generic_remainder
-_asm_generic_remainder:
- moveq #0x38,d0
- bra scheme_to_interface
- .globl _asm_generic_modulo
-_asm_generic_modulo:
- moveq #0x39,d0
- bra scheme_to_interface
- .globl _asm_interrupt_dlink
-_asm_interrupt_dlink:
- movl a4,d2
- moveq #0x19,d0
- bra scheme_to_interface_jsr
- .globl _asm_primitive_apply
-_asm_primitive_apply:
- movl a5,_Free
- movl sp,_sp_register
- movl c_save_stack,sp
- movl a7@,a6
- movl d1,a7@-
- lea _utility_table,a0
- movl a0@(0x12*4),a0
- jsr a0@
- lea a7@(4),sp
- movl d0,a0
- movl a0@(4),d1
- movl a0@(0),a0
- jmp a0@
-tc_compiled_entry = 0x28
-tc_flonum = 0x06
-tc_fixnum = 0x1A
-tc_manifest_nmv = 0x27
-tc_false = 0x0
-tc_true = 0x8
-offset_apply = 0x14
- .globl _asm_shortcircuit_apply
-_asm_shortcircuit_apply:
- .globl shortcircuit_apply
-shortcircuit_apply:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- movb a0@(-3),d3
- extw d3
- cmpw d3,d2
- bnes shortcircuit_apply_1
- jmp a0@
- .globl shortcircuit_apply_1
-shortcircuit_apply_1:
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_1
-_asm_shortcircuit_apply_size_1:
- .globl shortcircuit_apply_size_1
-shortcircuit_apply_size_1:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_1_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #1,a0@(-3)
- bnes shortcircuit_apply_size_1_1
- jmp a0@
- .globl shortcircuit_apply_size_1_1
-shortcircuit_apply_size_1_1:
- moveq #1,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_2
-_asm_shortcircuit_apply_size_2:
- .globl shortcircuit_apply_size_2
-shortcircuit_apply_size_2:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_2_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #2,a0@(-3)
- bnes shortcircuit_apply_size_2_1
- jmp a0@
- .globl shortcircuit_apply_size_2_1
-shortcircuit_apply_size_2_1:
- moveq #2,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_3
-_asm_shortcircuit_apply_size_3:
- .globl shortcircuit_apply_size_3
-shortcircuit_apply_size_3:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_3_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #3,a0@(-3)
- bnes shortcircuit_apply_size_3_1
- jmp a0@
- .globl shortcircuit_apply_size_3_1
-shortcircuit_apply_size_3_1:
- moveq #3,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_4
-_asm_shortcircuit_apply_size_4:
- .globl shortcircuit_apply_size_4
-shortcircuit_apply_size_4:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_4_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #4,a0@(-3)
- bnes shortcircuit_apply_size_4_1
- jmp a0@
- .globl shortcircuit_apply_size_4_1
-shortcircuit_apply_size_4_1:
- moveq #4,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_5
-_asm_shortcircuit_apply_size_5:
- .globl shortcircuit_apply_size_5
-shortcircuit_apply_size_5:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_5_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #5,a0@(-3)
- bnes shortcircuit_apply_size_5_1
- jmp a0@
- .globl shortcircuit_apply_size_5_1
-shortcircuit_apply_size_5_1:
- moveq #5,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_6
-_asm_shortcircuit_apply_size_6:
- .globl shortcircuit_apply_size_6
-shortcircuit_apply_size_6:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_6_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #6,a0@(-3)
- bnes shortcircuit_apply_size_6_1
- jmp a0@
- .globl shortcircuit_apply_size_6_1
-shortcircuit_apply_size_6_1:
- moveq #6,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_7
-_asm_shortcircuit_apply_size_7:
- .globl shortcircuit_apply_size_7
-shortcircuit_apply_size_7:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_7_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #7,a0@(-3)
- bnes shortcircuit_apply_size_7_1
- jmp a0@
- .globl shortcircuit_apply_size_7_1
-shortcircuit_apply_size_7_1:
- moveq #7,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_8
-_asm_shortcircuit_apply_size_8:
- .globl shortcircuit_apply_size_8
-shortcircuit_apply_size_8:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_8_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #8,a0@(-3)
- bnes shortcircuit_apply_size_8_1
- jmp a0@
- .globl shortcircuit_apply_size_8_1
-shortcircuit_apply_size_8_1:
- moveq #8,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_allocate_closure
-_asm_allocate_closure:
- movl a5,_Free
- movl sp,_sp_register
- movl c_save_stack,sp
- movl a7@,a6
- movl a1,a7@-
- movl d1,a7@-
- movl d0,a7@-
- jsr _allocate_closure
- addql #4,sp
- movl d0,a0
- movl a7@+,d1
- movl a7@+,a1
- movl a6,a7@
- movl sp,c_save_stack
- movl _sp_register,sp
- movl _Free,a5
- lea _Registers,a6
- movl #address_mask,d7
- rts
- .globl asm_generic_flonum_result
-asm_generic_flonum_result:
- movl a5,d6
- movl #tc_manifest_nmv*4*0x1000000+2,a5@+
- fmoved fp0,a5@+
- orl #tc_flonum*4*0x1000000,d6
- andb #1*4-1,a7@
- rts
- .globl asm_true_result
-asm_true_result:
- movl #tc_true*4*0x1000000,d6
- andb #1*4-1,a7@
- rts
- .globl asm_false_result
-asm_false_result:
- movl #tc_false*4*0x1000000,d6
- andb #1*4-1,a7@
- rts
- .globl _asm_generic_decrement
-_asm_generic_decrement:
- movb a7@,d0
- andb #0xFC,d0
- cmpb #tc_flonum*4,d0
- bnes asm_generic_decrement_hook
- movl a7@+,d0
- andl d7,d0
- movl d0,a0
- fmoved a0@(4),fp0
- fsubb #1,fp0
- bra asm_generic_flonum_result
-asm_generic_decrement_hook:
- moveq #0x22,d0
- bra scheme_to_interface
- .globl _asm_generic_divide
-_asm_generic_divide:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_divide_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_divide_flo_fix
- fmoved a0@(4),fp0
- fdivd a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_divide_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_divide_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_divide_hook
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- fdivd a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_divide_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_divide_hook
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- fdivl d3,fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_divide_hook:
- moveq #0x23,d0
- bra scheme_to_interface
- .globl _asm_generic_equal
-_asm_generic_equal:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_equal_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_equal_flo_fix
- addql #8,sp
- fmoved a0@(4),fp0
- fcmpd a1@(4),fp0
- fbeq asm_true_result
- bra asm_false_result
-asm_generic_equal_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_equal_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_equal_hook
- addql #8,sp
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- fcmpd a1@(4),fp0
- fbeq asm_true_result
- bra asm_false_result
-asm_generic_equal_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_equal_hook
- addql #8,sp
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- fcmpl d3,fp0
- fbeq asm_true_result
- bra asm_false_result
-asm_generic_equal_hook:
- moveq #0x24,d0
- bra scheme_to_interface
- .globl _asm_generic_greater
-_asm_generic_greater:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_greater_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_greater_flo_fix
- addql #8,sp
- fmoved a0@(4),fp0
- fcmpd a1@(4),fp0
- fbgt asm_true_result
- bra asm_false_result
-asm_generic_greater_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_greater_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_greater_hook
- addql #8,sp
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- fcmpd a1@(4),fp0
- fbgt asm_true_result
- bra asm_false_result
-asm_generic_greater_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_greater_hook
- addql #8,sp
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- fcmpl d3,fp0
- fbgt asm_true_result
- bra asm_false_result
-asm_generic_greater_hook:
- moveq #0x25,d0
- bra scheme_to_interface
- .globl _asm_generic_increment
-_asm_generic_increment:
- movb a7@,d0
- andb #0xFC,d0
- cmpb #tc_flonum*4,d0
- bnes asm_generic_increment_hook
- movl a7@+,d0
- andl d7,d0
- movl d0,a0
- fmoved a0@(4),fp0
- faddb #1,fp0
- bra asm_generic_flonum_result
-asm_generic_increment_hook:
- moveq #0x26,d0
- bra scheme_to_interface
- .globl _asm_generic_less
-_asm_generic_less:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_less_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_less_flo_fix
- addql #8,sp
- fmoved a0@(4),fp0
- fcmpd a1@(4),fp0
- fblt asm_true_result
- bra asm_false_result
-asm_generic_less_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_less_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_less_hook
- addql #8,sp
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- fcmpd a1@(4),fp0
- fblt asm_true_result
- bra asm_false_result
-asm_generic_less_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_less_hook
- addql #8,sp
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- fcmpl d3,fp0
- fblt asm_true_result
- bra asm_false_result
-asm_generic_less_hook:
- moveq #0x27,d0
- bra scheme_to_interface
- .globl _asm_generic_subtract
-_asm_generic_subtract:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_subtract_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_subtract_flo_fix
- fmoved a0@(4),fp0
- fsubd a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_subtract_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_subtract_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_subtract_hook
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- fsubd a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_subtract_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_subtract_hook
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- fsubl d3,fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_subtract_hook:
- moveq #0x28,d0
- bra scheme_to_interface
- .globl _asm_generic_multiply
-_asm_generic_multiply:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_multiply_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_multiply_flo_fix
- fmoved a0@(4),fp0
- fmuld a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_multiply_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_multiply_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_multiply_hook
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- fmuld a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_multiply_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_multiply_hook
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- fmull d3,fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_multiply_hook:
- moveq #0x29,d0
- bra scheme_to_interface
- .globl _asm_generic_negative
-_asm_generic_negative:
- movb a7@,d0
- andb #0xFC,d0
- cmpb #tc_flonum*4,d0
- bnes asm_generic_negative_hook
- movl a7@+,d0
- andl d7,d0
- movl d0,a0
- fmoved a0@(4),fp0
- fblt asm_true_result
- bra asm_false_result
-asm_generic_negative_hook:
- moveq #0x2a,d0
- bra scheme_to_interface
- .globl _asm_generic_add
-_asm_generic_add:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_add_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_add_flo_fix
- fmoved a0@(4),fp0
- faddd a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_add_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_add_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_add_hook
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- faddd a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_add_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_add_hook
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- faddl d3,fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_add_hook:
- moveq #0x2b,d0
- bra scheme_to_interface
- .globl _asm_generic_positive
-_asm_generic_positive:
- movb a7@,d0
- andb #0xFC,d0
- cmpb #tc_flonum*4,d0
- bnes asm_generic_positive_hook
- movl a7@+,d0
- andl d7,d0
- movl d0,a0
- fmoved a0@(4),fp0
- fbgt asm_true_result
- bra asm_false_result
-asm_generic_positive_hook:
- moveq #0x2c,d0
- bra scheme_to_interface
- .globl _asm_generic_zero
-_asm_generic_zero:
- movb a7@,d0
- andb #0xFC,d0
- cmpb #tc_flonum*4,d0
- bnes asm_generic_zero_hook
- movl a7@+,d0
- andl d7,d0
- movl d0,a0
- fmoved a0@(4),fp0
- fbeq asm_true_result
- bra asm_false_result
-asm_generic_zero_hook:
- moveq #0x2d,d0
- bra scheme_to_interface
- .globl _asm_stack_and_interrupt_check_12
-_asm_stack_and_interrupt_check_12:
- movl #-12,a7@-
- bras stack_and_interrupt_check
- .globl _asm_stack_and_interrupt_check_14
-_asm_stack_and_interrupt_check_14:
- movl #-14,a7@-
- bras stack_and_interrupt_check
- .globl _asm_stack_and_interrupt_check_18
-_asm_stack_and_interrupt_check_18:
- movl #-18,a7@-
- bras stack_and_interrupt_check
- .globl _asm_stack_and_interrupt_check_22
-_asm_stack_and_interrupt_check_22:
- movl #-22,a7@-
- bras stack_and_interrupt_check
- .globl _asm_stack_and_interrupt_check_24
-_asm_stack_and_interrupt_check_24:
- movl #-24,a7@-
- .globl stack_and_interrupt_check
-stack_and_interrupt_check:
- cmpl a6@(regblock_stack_guard),sp
- bgts stack_and_interrupt_check_1
- bset #0,a6@(regblock_int_code+3)
- btst #0,a6@(regblock_int_mask+3)
- beqs stack_and_interrupt_check_1
- movl #-1,a6@(regblock_memtop)
- bras stack_and_interrupt_check_2
-stack_and_interrupt_check_1:
- cmpl a6@(regblock_memtop),a5
- bges stack_and_interrupt_check_2
- addql #4,sp
- rts
-stack_and_interrupt_check_2:
- movl d0,a7@-
- movl a7@(4),d0
- addl d0,a7@(8)
- movl a7@,d0
- addql #8,sp
- rts
- .globl _asm_set_interrupt_enables
-_asm_set_interrupt_enables:
- .globl set_interrupt_enables
-set_interrupt_enables:
- movl a6@(regblock_int_mask),d6
- orl #tc_fixnum*4*0x1000000,d6
- movl a7@+,d0
- andl d7,d0
- movl d0,a6@(regblock_int_mask)
- moveq #-1,d1
- movl a6@(regblock_int_code),d2
- andl d0,d2
- bnes set_interrupt_enables_1
- movl _MemTop,d1
- btst #2,d0
- bnes set_interrupt_enables_1
- movl _Heap_Top,d1
-set_interrupt_enables_1:
- movl d1,a6@(regblock_memtop)
- movl _Stack_Guard,d1
- btst #0,d0
- bnes set_interrupt_enables_2
- movl _Stack_Bottom,d1
-set_interrupt_enables_2:
- movl d1,a6@(regblock_stack_guard)
- movl a7@+,d0
- andl d7,d0
- movl d0,a0
- jmp a0@
+++ /dev/null
-regblock_memtop = 0
-regblock_int_mask = 4
-regblock_val = 8
-regblock_stack_guard = 44
-regblock_int_code = 48
-address_mask = 0x3FFFFFF
- .data
- .globl c_save_stack
-c_save_stack:
- .skip 4
- .text
- .globl _interface_initialize
-_interface_initialize:
- link a6,#0
- fmovel #0x3480,fpcr
- unlk a6
- rts
- .globl _C_to_interface
-_C_to_interface:
- link a6,#-44
- moveml d2-d7/a2-a5,a7@(4)
- movl a6@(8),a0
- bras interface_to_scheme_internal
- .globl _asm_scheme_to_interface
-_asm_scheme_to_interface:
- .globl scheme_to_interface
-scheme_to_interface:
- movl d6,a6@(regblock_val)
- movl a5,_Free
- movl sp,_sp_register
- movl c_save_stack,sp
- movl a7@,a6
- movl d4,a7@-
- movl d3,a7@-
- movl d2,a7@-
- movl d1,a7@-
- lea _utility_table,a0
- movl a0@(0,d0:w:4),a0
- jsr a0@
- lea a7@(16),sp
- movl d0,a0
- movl a0@(4),d1
- movl a0@(0),a0
- jmp a0@
- .globl _interface_to_scheme
-_interface_to_scheme:
- movl d1,a0
- .globl interface_to_scheme_internal
-interface_to_scheme_internal:
- movl a6,a7@
- movl sp,c_save_stack
- movl _sp_register,sp
- movl _Free,a5
- lea _Registers,a6
- movl #address_mask,d7
- movl a6@(regblock_val),d6
- movl d6,d0
- movl d0,d1
- andl d7,d1
- movl d1,a4
- jmp a0@
- .globl _interface_to_C
-_interface_to_C:
- movl d1,d0
- moveml a7@(4),d2-d7/a2-a5
- unlk a6
- rts
- .globl _asm_trampoline_to_interface
-_asm_trampoline_to_interface:
- .globl trampoline_to_interface
-trampoline_to_interface:
- movl a7@+,d1
- bra scheme_to_interface
- .globl _asm_scheme_to_interface_jsr
-_asm_scheme_to_interface_jsr:
- .globl scheme_to_interface_jsr
-scheme_to_interface_jsr:
- movl a7@+,d1
- addql #4,d1
- bra scheme_to_interface
- .globl _asm_primitive_lexpr_apply
-_asm_primitive_lexpr_apply:
- moveq #0x13,d0
- bra scheme_to_interface
- .globl _asm_error
-_asm_error:
- moveq #0x15,d0
- bra scheme_to_interface
- .globl _asm_link
-_asm_link:
- moveq #0x17,d0
- bra scheme_to_interface_jsr
- .globl _asm_interrupt_closure
-_asm_interrupt_closure:
- moveq #0x18,d0
- bra scheme_to_interface
- .globl _asm_interrupt_procedure
-_asm_interrupt_procedure:
- moveq #0x1a,d0
- bra scheme_to_interface_jsr
- .globl _asm_interrupt_continuation
-_asm_interrupt_continuation:
- moveq #0x1b,d0
- bra scheme_to_interface_jsr
- .globl _asm_assignment_trap
-_asm_assignment_trap:
- moveq #0x1d,d0
- bra scheme_to_interface_jsr
- .globl _asm_reference_trap
-_asm_reference_trap:
- moveq #0x1f,d0
- bra scheme_to_interface_jsr
- .globl _asm_safe_reference_trap
-_asm_safe_reference_trap:
- moveq #0x20,d0
- bra scheme_to_interface_jsr
- .globl _asm_primitive_error
-_asm_primitive_error:
- moveq #0x36,d0
- bra scheme_to_interface_jsr
- .globl _asm_generic_quotient
-_asm_generic_quotient:
- moveq #0x37,d0
- bra scheme_to_interface
- .globl _asm_generic_remainder
-_asm_generic_remainder:
- moveq #0x38,d0
- bra scheme_to_interface
- .globl _asm_generic_modulo
-_asm_generic_modulo:
- moveq #0x39,d0
- bra scheme_to_interface
- .globl _asm_interrupt_dlink
-_asm_interrupt_dlink:
- movl a4,d2
- moveq #0x19,d0
- bra scheme_to_interface_jsr
- .globl _asm_primitive_apply
-_asm_primitive_apply:
- movl a5,_Free
- movl sp,_sp_register
- movl c_save_stack,sp
- movl a7@,a6
- movl d1,a7@-
- lea _utility_table,a0
- movl a0@(0x12*4),a0
- jsr a0@
- lea a7@(4),sp
- movl d0,a0
- movl a0@(4),d1
- movl a0@(0),a0
- jmp a0@
-tc_compiled_entry = 0x28
-tc_flonum = 0x06
-tc_fixnum = 0x1A
-tc_manifest_nmv = 0x27
-tc_false = 0x0
-tc_true = 0x8
-offset_apply = 0x14
- .globl _asm_shortcircuit_apply
-_asm_shortcircuit_apply:
- .globl shortcircuit_apply
-shortcircuit_apply:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- movb a0@(-3),d3
- extw d3
- cmpw d3,d2
- bnes shortcircuit_apply_1
- jmp a0@
- .globl shortcircuit_apply_1
-shortcircuit_apply_1:
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_1
-_asm_shortcircuit_apply_size_1:
- .globl shortcircuit_apply_size_1
-shortcircuit_apply_size_1:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_1_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #1,a0@(-3)
- bnes shortcircuit_apply_size_1_1
- jmp a0@
- .globl shortcircuit_apply_size_1_1
-shortcircuit_apply_size_1_1:
- moveq #1,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_2
-_asm_shortcircuit_apply_size_2:
- .globl shortcircuit_apply_size_2
-shortcircuit_apply_size_2:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_2_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #2,a0@(-3)
- bnes shortcircuit_apply_size_2_1
- jmp a0@
- .globl shortcircuit_apply_size_2_1
-shortcircuit_apply_size_2_1:
- moveq #2,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_3
-_asm_shortcircuit_apply_size_3:
- .globl shortcircuit_apply_size_3
-shortcircuit_apply_size_3:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_3_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #3,a0@(-3)
- bnes shortcircuit_apply_size_3_1
- jmp a0@
- .globl shortcircuit_apply_size_3_1
-shortcircuit_apply_size_3_1:
- moveq #3,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_4
-_asm_shortcircuit_apply_size_4:
- .globl shortcircuit_apply_size_4
-shortcircuit_apply_size_4:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_4_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #4,a0@(-3)
- bnes shortcircuit_apply_size_4_1
- jmp a0@
- .globl shortcircuit_apply_size_4_1
-shortcircuit_apply_size_4_1:
- moveq #4,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_5
-_asm_shortcircuit_apply_size_5:
- .globl shortcircuit_apply_size_5
-shortcircuit_apply_size_5:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_5_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #5,a0@(-3)
- bnes shortcircuit_apply_size_5_1
- jmp a0@
- .globl shortcircuit_apply_size_5_1
-shortcircuit_apply_size_5_1:
- moveq #5,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_6
-_asm_shortcircuit_apply_size_6:
- .globl shortcircuit_apply_size_6
-shortcircuit_apply_size_6:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_6_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #6,a0@(-3)
- bnes shortcircuit_apply_size_6_1
- jmp a0@
- .globl shortcircuit_apply_size_6_1
-shortcircuit_apply_size_6_1:
- moveq #6,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_7
-_asm_shortcircuit_apply_size_7:
- .globl shortcircuit_apply_size_7
-shortcircuit_apply_size_7:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_7_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #7,a0@(-3)
- bnes shortcircuit_apply_size_7_1
- jmp a0@
- .globl shortcircuit_apply_size_7_1
-shortcircuit_apply_size_7_1:
- moveq #7,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_shortcircuit_apply_size_8
-_asm_shortcircuit_apply_size_8:
- .globl shortcircuit_apply_size_8
-shortcircuit_apply_size_8:
- movb a7@,d0
- andb #0xFC,d0
- movl a7@+,d1
- cmpb #tc_compiled_entry*4,d0
- bnes shortcircuit_apply_size_8_1
- movl d1,d3
- andl d7,d3
- movl d3,a0
- cmpb #8,a0@(-3)
- bnes shortcircuit_apply_size_8_1
- jmp a0@
- .globl shortcircuit_apply_size_8_1
-shortcircuit_apply_size_8_1:
- moveq #8,d2
- moveq #offset_apply,d0
- bra scheme_to_interface
- .globl _asm_allocate_closure
-_asm_allocate_closure:
- movl a5,_Free
- movl sp,_sp_register
- movl c_save_stack,sp
- movl a7@,a6
- movl a1,a7@-
- movl d1,a7@-
- movl d0,a7@-
- jsr _allocate_closure
- addql #4,sp
- movl d0,a0
- movl a7@+,d1
- movl a7@+,a1
- movl a6,a7@
- movl sp,c_save_stack
- movl _sp_register,sp
- movl _Free,a5
- lea _Registers,a6
- movl #address_mask,d7
- rts
- .globl asm_generic_flonum_result
-asm_generic_flonum_result:
- movl a5,d6
- movl #tc_manifest_nmv*4*0x1000000+2,a5@+
- fmoved fp0,a5@+
- orl #tc_flonum*4*0x1000000,d6
- andb #1*4-1,a7@
- rts
- .globl asm_true_result
-asm_true_result:
- movl #tc_true*4*0x1000000,d6
- andb #1*4-1,a7@
- rts
- .globl asm_false_result
-asm_false_result:
- movl #tc_false*4*0x1000000,d6
- andb #1*4-1,a7@
- rts
- .globl _asm_generic_decrement
-_asm_generic_decrement:
- movb a7@,d0
- andb #0xFC,d0
- cmpb #tc_flonum*4,d0
- bnes asm_generic_decrement_hook
- movl a7@+,d0
- andl d7,d0
- movl d0,a0
- fmoved a0@(4),fp0
- fsubb #1,fp0
- bra asm_generic_flonum_result
-asm_generic_decrement_hook:
- moveq #0x22,d0
- bra scheme_to_interface
- .globl _asm_generic_divide
-_asm_generic_divide:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_divide_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_divide_flo_fix
- fmoved a0@(4),fp0
- fdivd a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_divide_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_divide_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_divide_hook
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- fdivd a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_divide_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_divide_hook
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- fdivl d3,fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_divide_hook:
- moveq #0x23,d0
- bra scheme_to_interface
- .globl _asm_generic_equal
-_asm_generic_equal:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_equal_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_equal_flo_fix
- addql #8,sp
- fmoved a0@(4),fp0
- fcmpd a1@(4),fp0
- fbeq asm_true_result
- bra asm_false_result
-asm_generic_equal_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_equal_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_equal_hook
- addql #8,sp
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- fcmpd a1@(4),fp0
- fbeq asm_true_result
- bra asm_false_result
-asm_generic_equal_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_equal_hook
- addql #8,sp
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- fcmpl d3,fp0
- fbeq asm_true_result
- bra asm_false_result
-asm_generic_equal_hook:
- moveq #0x24,d0
- bra scheme_to_interface
- .globl _asm_generic_greater
-_asm_generic_greater:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_greater_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_greater_flo_fix
- addql #8,sp
- fmoved a0@(4),fp0
- fcmpd a1@(4),fp0
- fbgt asm_true_result
- bra asm_false_result
-asm_generic_greater_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_greater_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_greater_hook
- addql #8,sp
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- fcmpd a1@(4),fp0
- fbgt asm_true_result
- bra asm_false_result
-asm_generic_greater_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_greater_hook
- addql #8,sp
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- fcmpl d3,fp0
- fbgt asm_true_result
- bra asm_false_result
-asm_generic_greater_hook:
- moveq #0x25,d0
- bra scheme_to_interface
- .globl _asm_generic_increment
-_asm_generic_increment:
- movb a7@,d0
- andb #0xFC,d0
- cmpb #tc_flonum*4,d0
- bnes asm_generic_increment_hook
- movl a7@+,d0
- andl d7,d0
- movl d0,a0
- fmoved a0@(4),fp0
- faddb #1,fp0
- bra asm_generic_flonum_result
-asm_generic_increment_hook:
- moveq #0x26,d0
- bra scheme_to_interface
- .globl _asm_generic_less
-_asm_generic_less:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_less_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_less_flo_fix
- addql #8,sp
- fmoved a0@(4),fp0
- fcmpd a1@(4),fp0
- fblt asm_true_result
- bra asm_false_result
-asm_generic_less_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_less_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_less_hook
- addql #8,sp
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- fcmpd a1@(4),fp0
- fblt asm_true_result
- bra asm_false_result
-asm_generic_less_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_less_hook
- addql #8,sp
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- fcmpl d3,fp0
- fblt asm_true_result
- bra asm_false_result
-asm_generic_less_hook:
- moveq #0x27,d0
- bra scheme_to_interface
- .globl _asm_generic_subtract
-_asm_generic_subtract:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_subtract_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_subtract_flo_fix
- fmoved a0@(4),fp0
- fsubd a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_subtract_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_subtract_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_subtract_hook
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- fsubd a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_subtract_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_subtract_hook
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- fsubl d3,fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_subtract_hook:
- moveq #0x28,d0
- bra scheme_to_interface
- .globl _asm_generic_multiply
-_asm_generic_multiply:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_multiply_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_multiply_flo_fix
- fmoved a0@(4),fp0
- fmuld a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_multiply_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_multiply_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_multiply_hook
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- fmuld a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_multiply_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_multiply_hook
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- fmull d3,fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_multiply_hook:
- moveq #0x29,d0
- bra scheme_to_interface
- .globl _asm_generic_negative
-_asm_generic_negative:
- movb a7@,d0
- andb #0xFC,d0
- cmpb #tc_flonum*4,d0
- bnes asm_generic_negative_hook
- movl a7@+,d0
- andl d7,d0
- movl d0,a0
- fmoved a0@(4),fp0
- fblt asm_true_result
- bra asm_false_result
-asm_generic_negative_hook:
- moveq #0x2a,d0
- bra scheme_to_interface
- .globl _asm_generic_add
-_asm_generic_add:
- movb a7@,d0
- andb #0xFC,d0
- movb a7@(4),d1
- andb #0xFC,d1
- movl a7@,d2
- movl a7@(4),d3
- andl d7,d2
- andl d7,d3
- movl d2,a0
- movl d3,a1
- cmpb #tc_flonum*4,d0
- bnes asm_generic_add_fix_flo
- cmpb #tc_flonum*4,d1
- bnes asm_generic_add_flo_fix
- fmoved a0@(4),fp0
- faddd a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_add_fix_flo:
- cmpb #tc_fixnum*4,d0
- bnes asm_generic_add_hook
- cmpb #tc_flonum*4,d1
- bnes asm_generic_add_hook
- lsll #6,d2
- asrl #6,d2
- fmovel d2,fp0
- faddd a1@(4),fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_add_flo_fix:
- cmpb #tc_fixnum*4,d1
- bnes asm_generic_add_hook
- lsll #6,d3
- asrl #6,d3
- fmoved a0@(4),fp0
- faddl d3,fp0
- addql #8,sp
- bra asm_generic_flonum_result
-asm_generic_add_hook:
- moveq #0x2b,d0
- bra scheme_to_interface
- .globl _asm_generic_positive
-_asm_generic_positive:
- movb a7@,d0
- andb #0xFC,d0
- cmpb #tc_flonum*4,d0
- bnes asm_generic_positive_hook
- movl a7@+,d0
- andl d7,d0
- movl d0,a0
- fmoved a0@(4),fp0
- fbgt asm_true_result
- bra asm_false_result
-asm_generic_positive_hook:
- moveq #0x2c,d0
- bra scheme_to_interface
- .globl _asm_generic_zero
-_asm_generic_zero:
- movb a7@,d0
- andb #0xFC,d0
- cmpb #tc_flonum*4,d0
- bnes asm_generic_zero_hook
- movl a7@+,d0
- andl d7,d0
- movl d0,a0
- fmoved a0@(4),fp0
- fbeq asm_true_result
- bra asm_false_result
-asm_generic_zero_hook:
- moveq #0x2d,d0
- bra scheme_to_interface
- .globl _asm_stack_and_interrupt_check_12
-_asm_stack_and_interrupt_check_12:
- movl #-12,a7@-
- bras stack_and_interrupt_check
- .globl _asm_stack_and_interrupt_check_14
-_asm_stack_and_interrupt_check_14:
- movl #-14,a7@-
- bras stack_and_interrupt_check
- .globl _asm_stack_and_interrupt_check_18
-_asm_stack_and_interrupt_check_18:
- movl #-18,a7@-
- bras stack_and_interrupt_check
- .globl _asm_stack_and_interrupt_check_22
-_asm_stack_and_interrupt_check_22:
- movl #-22,a7@-
- bras stack_and_interrupt_check
- .globl _asm_stack_and_interrupt_check_24
-_asm_stack_and_interrupt_check_24:
- movl #-24,a7@-
- .globl stack_and_interrupt_check
-stack_and_interrupt_check:
- cmpl a6@(regblock_stack_guard),sp
- bgts stack_and_interrupt_check_1
- bset #0,a6@(regblock_int_code+3)
- btst #0,a6@(regblock_int_mask+3)
- beqs stack_and_interrupt_check_1
- movl #-1,a6@(regblock_memtop)
- bras stack_and_interrupt_check_2
-stack_and_interrupt_check_1:
- cmpl a6@(regblock_memtop),a5
- bges stack_and_interrupt_check_2
- addql #4,sp
- rts
-stack_and_interrupt_check_2:
- movl d0,a7@-
- movl a7@(4),d0
- addl d0,a7@(8)
- movl a7@,d0
- addql #8,sp
- rts
- .globl _asm_set_interrupt_enables
-_asm_set_interrupt_enables:
- .globl set_interrupt_enables
-set_interrupt_enables:
- movl a6@(regblock_int_mask),d6
- orl #tc_fixnum*4*0x1000000,d6
- movl a7@+,d0
- andl d7,d0
- movl d0,a6@(regblock_int_mask)
- moveq #-1,d1
- movl a6@(regblock_int_code),d2
- andl d0,d2
- bnes set_interrupt_enables_1
- movl _MemTop,d1
- btst #2,d0
- bnes set_interrupt_enables_1
- movl _Heap_Top,d1
-set_interrupt_enables_1:
- movl d1,a6@(regblock_memtop)
- movl _Stack_Guard,d1
- btst #0,d0
- bnes set_interrupt_enables_2
- movl _Stack_Bottom,d1
-set_interrupt_enables_2:
- movl d1,a6@(regblock_stack_guard)
- movl a7@+,d0
- andl d7,d0
- movl d0,a0
- jmp a0@
+++ /dev/null
-### -*-Midas-*-
-###
-### Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
-### 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-### 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
-### 2014, 2015, 2016, 2017 Massachusetts Institute of Technology
-###
-### This file is part of MIT/GNU Scheme.
-###
-### MIT/GNU Scheme is free software; you can redistribute it and/or
-### modify it under the terms of the GNU General Public License as
-### published by the Free Software Foundation; either version 2 of the
-### License, or (at your option) any later version.
-###
-### MIT/GNU Scheme is distributed in the hope that it will be useful,
-### but WITHOUT ANY WARRANTY; without even the implied warranty of
-### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-### General Public License for more details.
-###
-### You should have received a copy of the GNU General Public License
-### along with MIT/GNU Scheme; if not, write to the Free Software
-### Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
-### 02110-1301, USA.
-\f
-#### Vax assembly language (BSD as Syntax) part of the compiled code
-#### interface. See cmpint.txt, cmpaux.txt, cmpint.c, cmpint-vax.h,
-#### and cmpgc.h for more documentation.
-####
-#### NOTE:
-#### Assumptions:
-####
-#### 1) C uses CALLS and RET for linkage.
-####
-#### 2) The C compiler divides registers into three groups:
-#### - Linkage registers, used for procedure calls and global
-#### references. On Vax: ap, fp, sp, pc.
-#### - Super temporaries, not preserved accross procedure calls and
-#### always usable. On the Vax this depends on the compiler:
-#### GCC and BSD PCC use r0-r5 as super temporaries.
-#### The (VMS) Vax C compiler uses r0-r1 as super temporaries.
-#### - Preserved registers saved by the callee if they are written.
-#### On the Vax: all others.
-####
-#### 3) C procedures return long values in r0.
-#### Two word structures are returned in different ways:
-#### o GCC returns them in r0/r1. Define flag GCC.
-#### o PCC returns the address of the structure (in static storage)
-#### in r0. This is the default.
-#### o (VMS) Vax C passes the address of the destination structure
-#### as the first argument. The other arguments are shifted right.
-####
-#### Compiled Scheme code uses the following register convention:
-#### - sp (r14) contains the Scheme stack pointer, not the C stack
-#### pointer.
-#### - fp (r13) contains the dynamic link when needed.
-#### - ap (r12) contains the Scheme free pointer.
-#### - r11 contains the Scheme datum mask.
-#### - r10 contains a pointer to the Scheme interpreter's
-#### "register" block. This block contains the compiler's copy of
-#### MemTop, the interpreter's registers (val, env, exp, etc),
-#### temporary locations for compiled code, and the mechanism used
-#### to invoke the hooks in this file.
-#### - r9 is where Scheme compiled code returns values.
-####
-#### All other registers are available to the compiler. A
-#### caller-saves convention is used, so the registers need not be
-#### preserved by subprocedures.
-####
-#### MAJOR NOTE: $ signifies immediate values to AS on the Vax.
-#### However, M4 also uses $ to signify macro constants,
-#### thus we use @ here to signify immediate values and a sed script
-#### is run on the output of M4 to change them to $.
-\f
-#### Utility macros and definitions
-
-ifdef(`VMS', `', `ifdef(`GCC',`',`define(PCC,1)')')
-
-ifdef(`VMS',
- `define(HEX,`^X$1')',
- `define(HEX,`0x$1')')
-
-
-ifdef(`VMS',
- `define(ASMSET,
- `
- $1=$2')',
-
- `define(ASMSET,
- `
- .set $1,$2')')
-
-
-ifdef(`VMS',
- `define(extern_c_variable,
- `$1')',
- `define(extern_c_variable,
- `_$1')')
-
-define(extern_c_label,
- `extern_c_variable($1)')
-
-
-ifdef(`VMS',
- `define(reference_c_variable,
- `
- .save_psect
- .psect $1,pic,usr,ovr,rel,gbl,shr,noexe,rd,wrt,novec
-$1:
- .restore_psect')',
-
- `define(reference_c_variable,
- `')')
-
-
-ifdef(`VMS',
- `define(define_c_label,
- `
-$1::')',
-
- `define(define_c_label,
- `
- .globl extern_c_label($1)
-extern_c_label($1):')')
-
-
-ifdef(`VMS',
- `define(define_c_procedure,
- `
- .align word
-define_c_label($1)
- .word ^M<r2,r3,r4,r5,r6,r7,r8,r9,r10,r11>')', # save r2-r11
-
- `define(define_c_procedure,
- `
- .align 1
-define_c_label($1)
- .word 0x0fc0')') # save r6-r11
-\f
-# This must match the compiler (machines/vax/machin.scm)
-
-define(TC_LENGTH, ifdef(`TYPE_CODE_LENGTH', TYPE_CODE_LENGTH, 6))
-define(ADDRESS_MASK, eval((0 - (2 ** (32 - TC_LENGTH))), 10))
-
-define(rval,r9)
-define(regs,r10)
-define(rmask,r11)
-define(rfree,ap)
-define(dlink,fp)
-
-ASMSET(regblock_val,8)
-ASMSET(address_mask,ADDRESS_MASK)
-
-reference_c_variable(sp_register)
-reference_c_variable(Free)
-reference_c_variable(Registers)
-reference_c_variable(utility_table)
-
-###
-### Global data
-###
-
-ifdef(`VMS',
- `
- .psect code,nowrt,exe,long
- .psect data,wrt,noexe,quad
-
- .psect data
- .align long
-c_save_stack:
- .long 0
-
- .psect code',
- `
- .data
- .align 2
- .comm c_save_stack,4
-
- .text')
-
-### Callable by C conventions. Swaps to Scheme register set and jumps
-### to the entry point specified by its only argument.
-
-define_c_procedure(C_to_interface)
- movl 4(ap),r1 # Argument: entry point
- subl2 @8,sp # Allocate space for return struct.
- pushl ap # Save while in Scheme
- pushl fp
- movl @address_mask,rmask
- moval extern_c_variable(Registers),regs
-
-### The data in r1 is the address of an entry point to invoke.
-
-define_c_label(interface_to_scheme)
- # Swap to C registers
- movl sp,c_save_stack
- movl extern_c_variable(sp_register),sp
- movl extern_c_variable(Free),rfree
- # Scheme return value
- movl regblock_val(regs),rval
- bicl3 rmask,rval,dlink
- jmp (r1) # invoke entry point
-
-### The data in r1 is a return code to the interpreter
-
-define_c_label(interface_to_C)
- movl r1,r0 # C return location
- ret
-\f
-### Called by Scheme through a jump instruction in the register block.
-### It expects an index in r0, a return address on the stack, and 3
-### longword arguments in r2-r4.
-### The return address needs to be bumped over the format longword.
-
-define_c_label(asm_scheme_to_interface_jsb)
- addl3 @4,(sp)+,r1
-# brb asm_scheme_to_interface
-
-### Transfer procedure from Scheme to C.
-### Called by Scheme through a jump instruction in the register block.
-### It expects an index in r0, and 4 longword arguments in r1-r4
-
-define_c_label(asm_scheme_to_interface)
- # Swap to C registers
- movl rval,regblock_val(regs)
- movl rfree,extern_c_variable(Free)
- movl sp,extern_c_variable(sp_register)
- movl c_save_stack,sp
- movl (sp),fp
- movl 4(sp),ap
- # extract the C utility
- moval extern_c_variable(utility_table),r6
- movl (r6)[r0],r6
- # push arguments to utility
- pushl r4
- pushl r3
- pushl r2
- pushl r1
- # call C procedure
- ifdef(`VMS',
- `pushab 24(sp)
- calls @5,(r6)',
- `calls @4,(r6)')
- # return struct -> r0/r1
- ifdef(`VMS',
- `movl 28(sp),r1
- movl 24(sp),r0')
- ifdef(`PCC',
- `movl 4(r0),r1
- movl (r0),r0')
-
- jmp (r0) # invoke return handler
-
-### Called by Scheme trampolines through a jump instruction in the
-### register block.
-### It expects an index in r0, and a return address on the stack.
-### The return address needs to be bumped over the padding in the
-### trampoline.
-
-define_c_label(asm_trampoline_to_interface)
- addl3 @2,(sp)+,r1
- brb extern_c_label(asm_scheme_to_interface)
-
-ifdef(`VMS',
- `.end',
- `')
### 02110-1301, USA.
\f
### AMD x86-64 assembly language part of the compiled code interface.
-### See cmpint.txt, cmpint.c, cmpint-mc68k.h, and cmpgc.h for more
+### See cmpint.txt, cmpint.c, cmpintmd/x86-64*, and cmpgc.h for more
### documentation.
###
### This m4 source expands into either Unix (gas) source or PC
+++ /dev/null
-/* -*- C -*-
-
-Copyright (C) 1992, 1993 Digital Equipment Corporation (D.E.C.)
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This software was developed at the Digital Equipment Corporation
-Cambridge Research Laboratory. Permission to copy this software, to
-redistribute it, and to use it for any purpose is granted, subject to
-the following restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to both the Digital Equipment Corporation Cambridge Research
-Lab (CRL) and the MIT Scheme project any improvements or extensions
-that they make, so that these may be included in future releases; and
-(b) to inform CRL and MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. D.E.C. has made no warrantee or representation that the operation
-of this software will be error-free, and D.E.C. is under no obligation
-to provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Digital Equipment Corporation
-nor of any adaptation thereof in any advertising, promotional, or
-sales literature without prior written consent from D.E.C. in each
-case. */
-
-/*
- *
- * Compiled code interface macros.
- *
- * See cmpint.txt for a description of these fields.
- *
- * Specialized for the Alpha
- */
-
-#ifndef SCM_CMPINTMD_H_INCLUDED
-#define SCM_CMPINTMD_H_INCLUDED
-
-\f
-/* Machine parameters to be set by the user. */
-
-/* Until cmpaux-alpha.m4 is updated. */
-#define CMPINT_USE_STRUCS
-
-#define PAGE_SIZE (8 * 1024)
-
-/* Processor type. Choose a number from the above list, or allocate your own.
- */
-
-#define COMPILER_PROCESSOR_TYPE COMPILER_ALPHA_TYPE
-
-/* Size (in long words) of the contents of a floating point register if
- different from a double. For example, an MC68881 saves registers
- in 96 bit (3 longword) blocks.
- #define COMPILER_TEMP_SIZE 1
-*/
-
-/* Descriptor size.
- This is the size of the offset field, and of the format field.
- This definition probably does not need to be changed.
- */
-
-typedef unsigned short format_word; /* 16 bits */
-\f
-/* Utilities for manipulating absolute subroutine calls.
- On the ALPHA this is done with either
- BR rtarget, displacement
- <absolute address of destination>
- or
- JMP rtarget, closure_hook
- <absolute address of destination>
- The latter form is installed by the out-of-line code that allocates
- and initializes closures and execute caches. The former is
- generated by the GC when the closure is close enough to the
- destination address to fit in a branch displacement (4 megabytes).
-
- Why does EXTRACT_ABSOLUTE_ADDRESS store into the execute cache or
- closure? Because the GC (which calls it) assumes that if the
- destination is in constant space there will be no need to modify the
- cell, since the destination won't move. Since the Alpha uses
- PC-relative addressing, though, the cell needs to be updated if the
- cell has moved even if the destination hasn't.
- */
-
-#define EXTRACT_ABSOLUTE_ADDRESS(target, address) \
- (target) = (* ((SCHEME_OBJECT *) (((int *) address) + 1))); \
- /* The +1 skips over the instruction to the absolute address */ \
- alpha_store_absolute_address(((void *) target), ((void *) address))
-
-
-#define STORE_ABSOLUTE_ADDRESS(entry_point, address) \
- alpha_store_absolute_address (((void *) entry_point), ((void *) address))
-
-extern void alpha_store_absolute_address(void *, void *);
-
-#define opJMP 0x1A
-#define fnJMP 0x00
-#define JMP(linkage, dest, displacement) \
- ((opJMP << 26) | ((linkage) << 21) | \
- ((dest) << 16) | (fnJMP << 14) | \
- (((displacement)>>2) & ((1<<14)-1)))
-
-/* Compiled Code Register Conventions */
-/* This must match the compiler and cmpaux-alpha.m4 */
-
-#define COMP_REG_UTILITY_CODE 1
-#define COMP_REG_TRAMP_INDEX COMP_REG_UTILITY_CODE
-#define COMP_REG_STACK_POINTER 2
-#define COMP_REG_MEMTOP 3
-#define COMP_REG_FREE 4
-#define COMP_REG_REGISTERS 9
-#define COMP_REG_SCHEME_INTERFACE 10
-#define COMP_REG_CLOSURE_HOOK 11
-#define COMP_REG_LONGJUMP COMP_REG_CLOSURE_HOOK
-#define COMP_REG_FIRST_ARGUMENT 17
-#define COMP_REG_LINKAGE 26
-#define COMP_REG_TEMPORARY 28
-#define COMP_REG_ZERO 31
-
-#ifdef IN_CMPINT_C
-#define PC_FIELD_SIZE 21
-#define MAX_PC_DISPLACEMENT (1<<22)
-#define MIN_PC_DISPLACEMENT (-MAX_PC_DISPLACEMENT)
-#define opBR 0x30
-
-void
-alpha_store_absolute_address (void *entry_point, void *address)
-{
- extern void scheme_closure_hook (void);
- int *Instruction_Address = (int *) address;
- SCHEME_OBJECT *Addr = (SCHEME_OBJECT *) (Instruction_Address + 1);
- SCHEME_OBJECT *Entry_Point = (SCHEME_OBJECT *) entry_point;
- long offset = ((char *) Entry_Point) - ((char *) Addr);
- *Addr = (SCHEME_OBJECT) Entry_Point;
- if ((offset < MAX_PC_DISPLACEMENT) &&
- (offset >= MIN_PC_DISPLACEMENT))
- *Instruction_Address =
- (opBR << 26) | (COMP_REG_LINKAGE << 21) |
- ((offset>>2) & ((1L<<PC_FIELD_SIZE)-1));
- else
- *Instruction_Address =
- JMP(COMP_REG_LINKAGE, COMP_REG_LONGJUMP,
- (((char *) scheme_closure_hook) - ((char *) Addr)));
- return;
-}
-#endif
-\f
-/* Interrupt/GC polling. */
-
-/* Procedure entry points look like:
-
- CONTINUATIONS AND ORDINARY PROCEDURES
-
- GC_Handler: <code sequence 1> -- call interrupt handler
- <entry descriptor> (32 bits)
- label: <code sequence 2> -- test for interrupts
- <code for procedure>
- Interrupt: BR GC_Handler -- to help branch predictor in
- code sequences 2
-
- It is a good idea to align the GC_Handler (hence the label) so that
- we dual issue nicely.
-
-Code sequence 1 (call interrupt handler):
- LDA UTILITY_CODE,#code(ZERO)
- JMP LINKAGE,(SCHEME-TO-INTERFACE-JSR)
-
-Code sequence 2 (test for interrupts):
- CMPLT FREE,MEMTOP,temp
- LDQ MEMTOP, 0(BLOCK)
- BEQ temp,Interrupt
-
- CLOSURES
-
- <entry descriptor> (32 bits)
- label: <code sequence 3> -- test for interrupts
- merge: <code for procedure>
- Internal-Label:
- <code sequence 4> -- test for interrupts, and
- branch to merge: if none
- Interrupt: <code sequence 5> -- call interrupt handler
- to help branch predictor in
- code sequence 3
-
-Code sequence 3 (test for interrupts):
- ...SUBQ SP,#8,SP -- in closure object before entry
- SUBQ LINKAGE,#8,temp -- bump ret. addr. back to entry point
- CMPLT FREE,MEMTOP,temp2 -- interrupt/gc check
- LDQ MEMTOP,0(BLOCK) -- Fill MemTop register
- BIS CC_ENTRY_TYPE,temp,temp -- put tag on closure object
- STQ temp,0(SP) -- save closure on top of stack
- BEQ temp2,Interrupt -- possible interrupt ...
-
-Code sequence 4 (test for interrupts):
- *Note*: In most machines code sequence 3 and 4 are the same and are
- shared. We've carefully optimized sequence 3 for dual issue, so it
- differs from sequence 4. Time over space ...
- CMPLT FREE,MEMTOP,temp -- interrupt/gc check
- LDQ MEMTOP,0(BLOCK) -- Fill MemTop register
- BNE temp,Merge -- branch back if no interrupt
-
-Code sequence 5 (call interrupt handler):
- LDA UTILITY_CODE,#code(ZERO)
- JMP LINKAGE,(SCHEME-TO-INTERFACE)
-
-*/
-
-#define INSTRUCTIONS *4 /* bytes/instruction */
-
-/* The length of code sequence 1, above */
-#define ENTRY_PREFIX_LENGTH (2 INSTRUCTIONS)
-
-/* Compiled closures */
-
-/* On the Alpha (byte offsets from start of closure):
-
- -16: TC_MANIFEST_CLOSURE || length of object
- -8 : count of entry points
- -4 : Format word and GC offset
- 0 : SUBQ SP,#8,SP
- +4 : BR or JMP instruction
- +8 : absolute target address
- +16: more entry points (i.e. repetitions from -8 through +8)
- and/or closed variables
- ...
-
- Note: On other machines, there is a different format used for one
- entry point closures and closures with more than one entry point.
- This is not needed on the Alpha, because we have a "wasted" 32 bit
- pad area in all closures.
-*/
-
-#define CLOSURE_OFFSET_OF_FIRST_ENTRY_POINT 16
-/* Bytes from manifest header to SUBQ in first entry point code */
-
-/* A NOP on machines where closure entry points are aligned at object */
-/* boundaries, as on the Alpha. */
-
-#define ADJUST_CLOSURE_AT_CALL(entry_point, location) \
-do { \
- } while (0)
-
-/* Manifest closure entry block size.
- Size in bytes of a compiled closure's header excluding the
- TC_MANIFEST_CLOSURE header.
-
- On the Alpha this is 32 bits (one instruction) of padding, 16 bits
- of format_word, 16 bits of GC offset word, 2 32-bit instructions
- (SUBQ and JMP or BR), and a 64-bit absolute address.
- */
-
-#define COMPILED_CLOSURE_ENTRY_SIZE \
- ((1 INSTRUCTIONS) + (2*(sizeof(format_word)) + \
- (2 INSTRUCTIONS) + (sizeof(SCHEME_OBJECT *))))
-
-/* Override the default definition of MANIFEST_CLOSURE_END in cmpgc.h */
-
-#define MANIFEST_CLOSURE_END(start, count) \
-(((SCHEME_OBJECT *) (start)) \
- + (CHAR_TO_SCHEME_OBJECT (((count) * COMPILED_CLOSURE_ENTRY_SIZE))))
-
-/* Manifest closure entry destructuring.
-
- Given the entry point of a closure, extract the `real entry point'
- (the address of the real code of the procedure, ie. one indirection)
- from the closure.
-*/
-
-#define EXTRACT_CLOSURE_ENTRY_ADDRESS(returned_address, entry_point) \
-{ EXTRACT_ABSOLUTE_ADDRESS (returned_address, \
- (((unsigned int *) entry_point) + 1)); \
-}
-
-/* This is the inverse of EXTRACT_CLOSURE_ENTRY_ADDRESS.
- Given a closure's entry point and a code entry point, store the
- code entry point in the closure.
- */
-
-#define STORE_CLOSURE_ENTRY_ADDRESS(address_to_store, entry_point) \
-{ STORE_ABSOLUTE_ADDRESS (address_to_store, \
- (((unsigned int *) entry_point) + 1)); \
-}
-\f
-/* Trampolines
-
- On the Alpha, here's a picture of a trampoline (offset in bytes
- from entry point)
-
- -24: MANIFEST vector header
- -16: NON_MARKED header
- - 8: 0
- - 4: Format word
- - 2: 0xC (GC Offset to start of block from .+2)
- Note the encoding -- divided by 2, low bit for
- extended distances (see OFFSET_WORD_TO_BYTE_OFFSET)
- 0: BIS ZERO, #index, TRAMP_INDEX
- 4: JMP Utility_Argument_1, (SCHEME_TO_INTERFACE)
- 8: trampoline dependent storage (0 - 3 objects)
-
- TRAMPOLINE_ENTRY_SIZE is the size in longwords of the machine
- dependent portion of a trampoline, including the GC and format
- headers. The code in the trampoline must store an index (used to
- determine which C SCHEME_UTILITY procedure to invoke) in a
- register, jump to "scheme_to_interface" and leave the address of
- the storage following the code in a standard location.
-
- TRAMPOLINE_ENTRY_POINT takes the address of the manifest vector
- header of a trampoline and returns the address of its first
- instruction.
-
- TRAMPOLINE_STORAGE takes the address of the first instruction in a
- trampoline (not the start of the trampoline block) and returns the
- address of the first storage word in the trampoline.
-
- STORE_TRAMPOLINE_ENTRY gets the address of the first instruction in
- the trampoline and stores the instructions. It also receives the
- index of the C SCHEME_UTILITY to be invoked.
-*/
-
-#define TRAMPOLINE_ENTRY_SIZE 2
-#define TRAMPOLINE_ENTRY_POINT(tramp) \
- ((void *) (((SCHEME_OBJECT *) (tramp)) + 3))
-#define TRAMPOLINE_STORAGE(tramp_entry) \
- ((SCHEME_OBJECT *) (((char *) (tramp_entry)) + (2 INSTRUCTIONS)))
-
-#define opBIS 0x11
-#define opSUBQ 0x10
-#define funcBIS 0x20
-#define funcSUBQ 0x29
-
-#define constantBIS(source, constant, target) \
- ((opBIS << 26) | ((source) << 21) | \
- ((constant) << 13) | (1 << 12) | (funcBIS << 5) | (target))
-
-#define constantSUBQ(source, constant, target) \
- ((opSUBQ << 26) | ((source) << 21) | \
- ((constant) << 13) | (1 << 12) | (funcSUBQ << 5) | (target))
-
-#define STORE_TRAMPOLINE_ENTRY(entry_address, index) \
-{ unsigned int *PC; \
- extern void scheme_to_interface(void); \
- PC = ((unsigned int *) (entry_address)); \
- *PC++ = constantBIS(COMP_REG_ZERO, index, COMP_REG_TRAMP_INDEX);\
- *PC = JMP(COMP_REG_FIRST_ARGUMENT, \
- COMP_REG_SCHEME_INTERFACE, \
- (((char *) scheme_to_interface) - \
- ((char *) (PC+1)))); \
- PC += 1; \
-}
-\f
-/* Execute cache entries.
-
- Execute cache entry size in longwords. The cache itself
- contains both the number of arguments provided by the caller and
- code to jump to the destination address. Before linkage, the cache
- contains the callee's name instead of the jump code.
-
- On Alpha: 2 machine words (64 bits each).
- */
-
-#define EXECUTE_CACHE_ENTRY_SIZE 2
-
-/* Execute cache destructuring. */
-
-/* Given a target location and the address of the first word of an
- execute cache entry, extract from the cache cell the number of
- arguments supplied by the caller and store it in target. */
-
-/* For the Alpha, addresses in bytes from the start of the cache:
-
- Before linking
- +0: number of supplied arguments, +1
- +4: TC_FIXNUM | 0
- +8: TC_SYMBOL || symbol address
-
- After linking
- +0: number of supplied arguments, +1
- +4: BR or JMP instruction
- +8: absolute target address
-*/
-
-#define EXTRACT_EXECUTE_CACHE_ARITY(target, address) \
- (target) = ((long) (((unsigned int *) (address)) [0]))
-
-#define EXTRACT_EXECUTE_CACHE_SYMBOL(target, address) \
- (target) = ((SCHEME_OBJECT *) (address))[1]
-
-/* Extract the target address (not the code to get there) from an
- execute cache cell.
- */
-
-#define EXTRACT_EXECUTE_CACHE_ADDRESS(target, address) \
-{ \
- EXTRACT_ABSOLUTE_ADDRESS (target, (((unsigned int *)address)+1)); \
-}
-
-/* This is the inverse of EXTRACT_EXECUTE_CACHE_ADDRESS.
- */
-
-#define STORE_EXECUTE_CACHE_ADDRESS(address, entry) \
-{ \
- STORE_ABSOLUTE_ADDRESS (entry, (((unsigned int *)address)+1)); \
-}
-
-/* This stores the fixed part of the instructions leaving the
- destination address and the number of arguments intact. These are
- split apart so the GC can call EXTRACT/STORE...ADDRESS but it does
- NOT need to store the instructions back. On this architecture the
- instructions may change due to GC and thus STORE_EXECUTE_CACHE_CODE
- is a no-op; all of the work is done by STORE_EXECUTE_CACHE_ADDRESS
- instead.
- */
-
-#define STORE_EXECUTE_CACHE_CODE(address) { }
-
-/* This flushes the Scheme portion of the I-cache.
- It is used after a GC or disk-restore.
- It's needed because the GC has moved code around, and closures
- and execute cache cells have absolute addresses that the
- processor might have old copies of.
- */
-
-extern long Synchronize_Caches(void);
-extern void Flush_I_Cache(void);
-
-#if 1
-#define FLUSH_I_CACHE() ((void) Synchronize_Caches())
-#else
-#define FLUSH_I_CACHE() (Flush_I_Cache())
-#endif
-
-/* This flushes a region of the I-cache.
- It is used after updating an execute cache while running.
- Not needed during GC because FLUSH_I_CACHE will be used.
- */
-
-#define FLUSH_I_CACHE_REGION(address, nwords) FLUSH_I_CACHE()
-#define PUSH_D_CACHE_REGION(address, nwords) FLUSH_I_CACHE()
-#define SPLIT_CACHES
-
-#ifdef IN_CMPINT_C
-#include <sys/mman.h>
-#include <sys/types.h>
-
-#define VM_PROT_SCHEME (PROT_READ | PROT_WRITE | PROT_EXEC)
-
-#define ASM_RESET_HOOK() interface_initialize((void *) &utility_table[0])
-
-#define REGBLOCK_EXTRA_SIZE 8 /* See lapgen.scm */
-#define COMPILER_REGBLOCK_N_FIXED 16
-#define REGBLOCK_FIRST_EXTRA COMPILER_REGBLOCK_N_FIXED
-#define REGBLOCK_ADDRESS_OF_STACK_POINTER REGBLOCK_FIRST_EXTRA
-#define REGBLOCK_ADDRESS_OF_FREE REGBLOCK_FIRST_EXTRA+1
-#define REGBLOCK_ADDRESS_OF_UTILITY_TABLE REGBLOCK_FIRST_EXTRA+2
-#define REGBLOCK_ALLOCATE_CLOSURE REGBLOCK_FIRST_EXTRA+3
-#define REGBLOCK_DIVQ REGBLOCK_FIRST_EXTRA+4
-#define REGBLOCK_REMQ REGBLOCK_FIRST_EXTRA+5
-#define COMPILER_REGBLOCK_N_TEMPS 256
-
-void *
-alpha_heap_malloc (long Size)
-{ int pagesize;
- caddr_t Heap_Start_Page;
- void *Area;
-
- pagesize = getpagesize();
- Area = (void *) malloc(Size+pagesize);
- if (Area==NULL) return Area;
- Heap_Start_Page =
- ((caddr_t) (((((long) Area)+(pagesize-1)) /
- pagesize) *
- pagesize));
- if (mprotect (Heap_Start_Page, Size, VM_PROT_SCHEME) == -1)
- { perror("compiler_reset: unable to change protection for Heap");
- fprintf(stderr, "mprotect(0x%lx, %d (0x%lx), 0x%lx)\n",
- Heap_Start_Page, Size, Size, VM_PROT_SCHEME);
- Microcode_Termination (TERM_EXIT);
- /*NOTREACHED*/
- }
- return (void *) Heap_Start_Page;
-}
-
-/* ASSUMPTION: Direct mapped first level cache, with
- shared secondary caches. Sizes in bytes.
-*/
-#define DCACHE_SIZE (8*1024)
-#define DCACHE_LINE_SIZE 32
-#define WRITE_BUFFER_SIZE (4*DCACHE_LINE_SIZE)
-
-long
-Synchronize_Caches (void)
-{ long Foo=0;
-
- Flush_I_Cache();
- { static volatile long Fake_Out[WRITE_BUFFER_SIZE/(sizeof (long))];
- volatile long *Ptr, *End, i=0;
-
- for (End = &(Fake_Out[WRITE_BUFFER_SIZE/(sizeof (long))]),
- Ptr = &(Fake_Out[0]);
- Ptr < End;
- Ptr += DCACHE_LINE_SIZE/(sizeof (long)))
- { Foo += *Ptr;
- *Ptr = Foo;
- i += 1;
- }
- }
-#if 0
- { static volatile long Fake_Out[DCACHE_SIZE/(sizeof (long))];
- volatile long *Ptr, *End;
-
- for (End = &(Fake_Out[DCACHE_SIZE/(sizeof (long))]),
- Ptr = &(Fake_Out[0]);
- Ptr < End;
- Ptr += DCACHE_LINE_SIZE/(sizeof (long)))
- Foo += *Ptr;
- }
-#endif
- return Foo;
-}
-
-extern char *allocate_closure(long, char *);
-
-static void
-interface_initialize (void * table)
-{ extern void __divq();
- extern void __remq();
-
- Registers[REGBLOCK_ADDRESS_OF_STACK_POINTER] =
- ((SCHEME_OBJECT) &stack_pointer);
- Registers[REGBLOCK_ADDRESS_OF_FREE] =
- ((SCHEME_OBJECT) &Free);
- Registers[REGBLOCK_ADDRESS_OF_UTILITY_TABLE] =
- ((SCHEME_OBJECT) table);
- Registers[REGBLOCK_ALLOCATE_CLOSURE] =
- ((SCHEME_OBJECT) allocate_closure);
- Registers[REGBLOCK_DIVQ] = ((SCHEME_OBJECT) __divq);
- Registers[REGBLOCK_REMQ] = ((SCHEME_OBJECT) __remq);
- return;
-}
-
-#define CLOSURE_ENTRY_WORDS \
- (COMPILED_CLOSURE_ENTRY_SIZE / (sizeof (SCHEME_OBJECT)))
-
-static long closure_chunk = (1024 * CLOSURE_ENTRY_WORDS);
-static long last_chunk_size;
-
-char *
-allocate_closure (long size, char *this_block)
-/* size in Scheme objects of the block we need to allocate.
- this_block is a pointer to the first entry point in the block we
- didn't manage to allocate.
-*/
-{ long space;
- SCHEME_OBJECT *free_closure, *limit;
-
- free_closure = (SCHEME_OBJECT *)
- (this_block-CLOSURE_OFFSET_OF_FIRST_ENTRY_POINT);
- limit = GET_CLOSURE_SPACE;
- space = limit - free_closure;
- if (size > space)
- { SCHEME_OBJECT *ptr;
- unsigned int *wptr;
- /* Clear remaining words from last chunk so that the heap can be scanned
- forward.
- */
- if (space > 0)
- { for (ptr = free_closure; ptr < limit; ptr++) *ptr = SHARP_F;
- /* We can reformat the closures (from JMPs to BRs) using
- last_chunk_size. The start of the area is
- (limit - last_chunk_size), and all closures are contiguous
- and have appropriate headers.
- */
- }
- free_closure = Free;
- if ((size <= closure_chunk) && (!GC_NEEDED_P (closure_chunk)))
- { limit = (free_closure + closure_chunk);
- }
- else
- { if (GC_NEEDED_P (size))
- { if ((heap_end - Free) < size)
- { /* No way to back out -- die. */
- fprintf (stderr, "\nC_allocate_closure (%d): No space.\n", size);
- Microcode_Termination (TERM_NO_SPACE);
- /* NOTREACHED */
- }
- REQUEST_GC (0);
- }
- else if (size <= closure_chunk)
- { REQUEST_GC (0);
- }
- limit = (free_closure + size);
- }
- Free = limit;
- last_chunk_size = limit-free_closure; /* For next time, maybe. */
- for (wptr = (unsigned int *) free_closure;
- wptr < (unsigned int *) limit;)
- { extern void scheme_closure_hook (void);
- *wptr++ = constantSUBQ (COMP_REG_STACK_POINTER,
- 8,
- COMP_REG_STACK_POINTER);
- *wptr = JMP(COMP_REG_LINKAGE, COMP_REG_LONGJUMP,
- (((char *) scheme_closure_hook) -
- ((char *) (wptr + 1))));
- wptr += 1;
- }
- PUSH_D_CACHE_REGION (free_closure, last_chunk_size);
- SET_CLOSURE_SPACE (limit);
- }
- SET_CLOSURE_FREE (free_closure + size);
- return (((char *) free_closure)+CLOSURE_OFFSET_OF_FIRST_ENTRY_POINT);
-}
-#endif /* IN_CMPINT_C */
-\f
-/* Derived parameters and macros.
-
- These macros expect the above definitions to be meaningful.
- If they are not, the macros below may have to be changed as well.
- */
-
-#define COMPILED_ENTRY_OFFSET_WORD(entry) (((format_word *) (entry)) [-1])
-#define COMPILED_ENTRY_FORMAT_WORD(entry) (((format_word *) (entry)) [-2])
-
-/* The next one assumes 2's complement integers....*/
-#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2))
-#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0)
-
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> 1)
-#define OFFSET_WORD_TO_BYTE_OFFSET(word) ((CLEAR_LOW_BIT (word)) << 1)
-
-#define MAKE_OFFSET_WORD(entry, block, continue) \
- ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \
- ((char *) (block)))) | \
- ((continue) ? 1 : 0))
-
-#if (EXECUTE_CACHE_ENTRY_SIZE == 2)
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) >> 1)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) << 1)
-#endif
-
-#if (EXECUTE_CACHE_ENTRY_SIZE == 4)
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) >> 2)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) << 2)
-#endif
-
-#if (!defined(EXECUTE_CACHE_COUNT_TO_ENTRIES))
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) / EXECUTE_CACHE_ENTRY_SIZE)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) * EXECUTE_CACHE_ENTRY_SIZE)
-#endif
-\f
-/* The first entry in a cc block is preceeded by 2 headers (block and nmv),
- a format word and a gc offset word. See the early part of the
- TRAMPOLINE picture, above.
- */
-
-#define CC_BLOCK_FIRST_ENTRY_OFFSET \
- (2 * ((sizeof(SCHEME_OBJECT)) + (sizeof(format_word))))
-
-/* Format words */
-
-#define FORMAT_BYTE_EXPR 0xFF
-#define FORMAT_BYTE_COMPLR 0xFE
-#define FORMAT_BYTE_CMPINT 0xFD
-#define FORMAT_BYTE_DLINK 0xFC
-#define FORMAT_BYTE_RETURN 0xFB
-
-#define FORMAT_WORD_EXPR (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_EXPR))
-#define FORMAT_WORD_CMPINT (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_CMPINT))
-#define FORMAT_WORD_RETURN (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_RETURN))
-
-/* This assumes that a format word is at least 16 bits,
- and the low order field is always 8 bits.
- */
-
-#define MAKE_FORMAT_WORD(field1, field2) \
- (((field1) << 8) | ((field2) & 0xff))
-
-#define SIGN_EXTEND_FIELD(field, size) \
- (((field) & ((1 << (size)) - 1)) | \
- ((((field) & (1 << ((size) - 1))) == 0) ? 0 : \
- ((-1) << (size))))
-
-#define FORMAT_WORD_LOW_BYTE(word) \
- (SIGN_EXTEND_FIELD ((((unsigned long) (word)) & 0xff), 8))
-
-#define FORMAT_WORD_HIGH_BYTE(word) \
- (SIGN_EXTEND_FIELD \
- ((((unsigned long) (word)) >> 8), \
- (((sizeof (format_word)) * CHAR_BIT) - 8)))
-
-#define COMPILED_ENTRY_FORMAT_HIGH(addr) \
- (FORMAT_WORD_HIGH_BYTE (COMPILED_ENTRY_FORMAT_WORD (addr)))
-
-#define COMPILED_ENTRY_FORMAT_LOW(addr) \
- (FORMAT_WORD_LOW_BYTE (COMPILED_ENTRY_FORMAT_WORD (addr)))
-
-#define FORMAT_BYTE_FRAMEMAX 0x7f
-
-#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW
-#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH
-
-#endif /* !SCM_CMPINTMD_H_INCLUDED */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Compiled code interface macros, specialized for the HP Precision
- Architecture. */
-
-#ifndef SCM_CMPINTMD_H_INCLUDED
-#define SCM_CMPINTMD_H_INCLUDED 1
-
-#include "hppacach.h"
-
-/* Machine parameters to be set by the user. */
-
-/* Until cmpaux-hppa.m4 is updated. */
-#define CMPINT_USE_STRUCS
-
-/* Processor type. Choose a number from the above list, or allocate
- your own. */
-
-#define COMPILER_PROCESSOR_TYPE COMPILER_SPECTRUM_TYPE
-
-/* Size (in long words) of the contents of a floating point register if
- different from a double. For example, an MC68881 saves registers
- in 96 bit (3 longword) blocks.
- Default is fine for PA.
- define COMPILER_TEMP_SIZE 3
- */
-
-#define COMPILER_REGBLOCK_N_TEMPS 256
-
-/* Descriptor size.
- This is the size of the offset field, and of the format field.
- This definition probably does not need to be changed. */
-
-typedef unsigned short format_word;
-
-typedef unsigned long insn_t;
-
-/* C function pointers are pairs of instruction addreses and data segment
- pointers. We don't want that for the assembly language entry points. */
-
-#define C_FUNC_PTR_IS_CLOSURE 1
-
-#ifndef C_FUNC_PTR_IS_CLOSURE
-# define interface_to_C ep_interface_to_C
-# define interface_to_scheme ep_interface_to_scheme
-#endif
-\f
-/* Utilities for manipulating absolute subroutine calls.
- On the PA the absolute address is "smeared out" over two
- instructions, an LDIL and a BLE instruction. */
-
-extern unsigned long hppa_extract_absolute_address (unsigned long *);
-
-extern void hppa_store_absolute_address
- (unsigned long *, unsigned long, unsigned long);
-
-#define EXTRACT_ABSOLUTE_ADDRESS(target, address) \
-{ \
- (target) = \
- ((SCHEME_OBJECT) \
- (hppa_extract_absolute_address ((unsigned long *) (address)))); \
-}
-
-#define STORE_ABSOLUTE_ADDRESS(entry_point, address, nullify_p) \
-{ \
- hppa_store_absolute_address (((unsigned long *) (address)), \
- ((unsigned long) (entry_point)), \
- ((unsigned long) (nullify_p))); \
-}
-\f
-/* Interrupt/GC polling. */
-
-/* The length of the GC recovery code that precedes an entry.
- On the HP-PA a "ble, ldi" instruction sequence.
- */
-
-#define ENTRY_PREFIX_LENGTH 8
-
-/*
- The instructions for a normal entry should be something like
-
- COMBT,>=,N Rfree,Rmemtop,interrupt
- LDW 0(0,Regs),Rmemtop
-
- For a closure
-
- DEPI tc_closure>>1,4,5,25 ; set type code
- STWM 25,-4(0,Rstack) ; push on stack
- COMB,>= Rfree,Rmemtop,interrupt ; GC/interrupt check
- LDW 0(0,Regs),Rmemtop ; Recache memtop
-
- Notes:
-
- The LDW can be eliminated once the C interrupt handler is changed to
- update Rmemtop directly. At that point, the instruction following the
- COMB instruction will have to be nullified whenever the interrupt
- branch is processed.
-
- */
-
-/* Compiled closures */
-
-/* Manifest closure entry block size.
- Size in bytes of a compiled closure's header excluding the
- TC_MANIFEST_CLOSURE header.
-
- On the PA this is 2 format_words for the format word and gc
- offset words, and 12 more bytes for 3 instructions:
-
- LDIL L'target,26
- BLE R'target(5,26)
- ADDI -15,31,25 ; handle privilege bits
- */
-
-#define COMPILED_CLOSURE_ENTRY_SIZE 16
-
-/* Manifest closure entry destructuring.
-
- Given the entry point of a closure, extract the `real entry point'
- (the address of the real code of the procedure, ie. one indirection)
- from the closure.
- On the PA, the real entry point is "smeared out" over the LDIL and
- the BLE instructions.
-*/
-
-#define EXTRACT_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point) \
-{ \
- EXTRACT_ABSOLUTE_ADDRESS (real_entry_point, entry_point); \
-}
-
-/* This is the inverse of EXTRACT_CLOSURE_ENTRY_ADDRESS.
- Given a closure's entry point and a code entry point, store the
- code entry point in the closure.
- */
-
-#define STORE_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point) \
-{ \
- STORE_ABSOLUTE_ADDRESS (real_entry_point, entry_point, false); \
-}
-\f
-/* Trampolines
-
- Here's a picture of a trampoline on the PA (offset in bytes from
- entry point)
-
- -12: MANIFEST vector header
- - 8: NON_MARKED header
- - 4: Format word
- - 2: 0xC (GC Offset to start of block from .+2)
- 0: BLE 4(4,3) ; call trampoline_to_interface
- 4: LDI index,28
- 8: trampoline dependent storage (0 - 3 longwords)
-
- TRAMPOLINE_ENTRY_SIZE is the size in longwords of the machine
- dependent portion of a trampoline, including the GC and format
- headers. The code in the trampoline must store an index (used to
- determine which C SCHEME_UTILITY procedure to invoke) in a
- register, jump to "scheme_to_interface" and leave the address of
- the storage following the code in a standard location.
-
- TRAMPOLINE_ENTRY_POINT returns the address of the entry point of a
- trampoline when given the address of the word containing
- the manifest vector header. According to the above picture,
- it would add 12 bytes to its argument.
-
- TRAMPOLINE_STORAGE takes the address of the first instruction in a
- trampoline (not the start of the trampoline block) and returns the
- address of the first storage word in the trampoline.
-
- STORE_TRAMPOLINE_ENTRY gets the address of the first instruction in
- the trampoline and stores the instructions. It also receives the
- index of the C SCHEME_UTILITY to be invoked.
-
- Note: this flushes both caches because the words may fall in a cache
- line that already has an association in the i-cache because a different
- trampoline or a closure are in it.
-*/
-
-#define TRAMPOLINE_ENTRY_SIZE 3
-#define TRAMPOLINE_BLOCK_TO_ENTRY 3 /* longwords from MNV to BLE */
-
-#define TRAMPOLINE_ENTRY_POINT(tramp_block) \
- (((SCHEME_OBJECT *) (tramp_block)) + TRAMPOLINE_BLOCK_TO_ENTRY)
-
-#define TRAMPOLINE_STORAGE(tramp_entry) \
- ((((SCHEME_OBJECT *) (tramp_entry)) - TRAMPOLINE_BLOCK_TO_ENTRY) + \
- (2 + TRAMPOLINE_ENTRY_SIZE))
-
-#define STORE_TRAMPOLINE_ENTRY(entry_address, index) do \
-{ \
- extern void \
- cache_flush_region (void *, long, unsigned int); \
- \
- unsigned long *PC; \
- \
- PC = ((unsigned long *) (entry_address)); \
- \
- /* BLE 4(4,3) */ \
- \
- *PC = ((unsigned long) 0xe4602008); \
- \
- /* LDO index(0),28 */ \
- /* This assumes that index is >= 0. */ \
- \
- *(PC + 1) = (((unsigned long) 0x341c0000) + \
- (((unsigned long) (index)) << 1)); \
- cache_flush_region (PC, (TRAMPOLINE_ENTRY_SIZE - 1), \
- (I_CACHE | D_CACHE)); \
-} while (0)
-\f
-/* Execute cache entries.
-
- Execute cache entry size size in longwords. The cache itself
- contains both the number of arguments provided by the caller and
- code to jump to the destination address. Before linkage, the cache
- contains the callee's name instead of the jump code.
-
- On PA: 2 instructions, and a fixnum representing the number of arguments.
- */
-
-#define EXECUTE_CACHE_ENTRY_SIZE 3
-
-/* For the HPPA, addresses in bytes from the start of the cache:
-
- Before linking
-
- +0: TC_SYMBOL || symbol address
- +4: #F
- +8: TC_FIXNUM || 0
- +10: number of supplied arguments, +1
-
- After linking
-
- +0: LDIL L'target,26
- +4: BLE,n R'target(5,26)
- +8: (unchanged)
- +10: (unchanged)
-
- Important:
-
- Currently the code below unconditionally nullifies the delay-slot
- instruction for the BLE instruction. This is wasteful and
- unnecessary. An EXECUTE_CACHE_ENTRY could be one word longer to
- accomodate a delay-slot instruction, and the linker could do the
- following:
-
- - If the target instruction is not a branch instruction, use 4 +
- the address of the target instruction, and copy the target
- instruction to the delay slot. Note that branch instructions are
- those with opcodes (6 bits) in the range #b1xy0zw, for any bit
- value for x, y, z, w.
-
- - If the target instruction is the COMBT instruction of an
- interrupt/gc check, use 4 + the address of the target
- instruction, and insert a similar COMBT instruction in the delay
- slot. This COMBT instruction would then branch to an instruction
- shared by all the cache cells in the same block. This shared
- instruction would be a BE instruction used to jump to an assembly
- language handler. This handler would recover the target address
- from the link address left in register 31 by the BLE instruction
- in the execute cache cell, and use it to compute the address of
- and branch to the interrupt code for the entry.
-
- - Otherwise use the address of the target instruction and insert
- a NOP in the delay slot.
-*/
-\f
-/* Execute cache destructuring. */
-
-/* Given a target location and the address of the first word of an
- execute cache entry, extract from the cache cell the number of
- arguments supplied by the caller and store it in target.
- */
-
-#define EXTRACT_EXECUTE_CACHE_ARITY(target, address) \
-{ \
- (target) = ((long) (* (((unsigned short *) (address)) + 5))); \
-}
-
-/* Given a target location and the address of the first word of an
- execute cache entry, extract from the cache cell the name
- of the variable whose value is being invoked.
- This is valid only before linking.
- */
-
-#define EXTRACT_EXECUTE_CACHE_SYMBOL(target, address) \
-{ \
- (target) = (* (((SCHEME_OBJECT *) (address)))); \
-}
-
-/* Extract the target address (not the code to get there) from an
- execute cache cell.
- */
-
-#define EXTRACT_EXECUTE_CACHE_ADDRESS(target, address) \
-{ \
- EXTRACT_ABSOLUTE_ADDRESS(target, address); \
-}
-
-/* This is the inverse of EXTRACT_EXECUTE_CACHE_ADDRESS. */
-
-#define STORE_EXECUTE_CACHE_ADDRESS(address, entry) \
-{ \
- STORE_ABSOLUTE_ADDRESS(entry, address, true); \
-}
-\f
-/* This stores the fixed part of the instructions leaving the
- destination address and the number of arguments intact. These are
- split apart so the GC can call EXTRACT/STORE...ADDRESS but it does
- NOT need to store the instructions back. On some architectures the
- instructions may change due to GC and then STORE_EXECUTE_CACHE_CODE
- should become a no-op and all of the work is done by
- STORE_EXECUTE_CACHE_ADDRESS instead.
- On PA this is a NOP.
- */
-
-#define STORE_EXECUTE_CACHE_CODE(address) do \
-{ \
-} while (0)
-
-/* This is supposed to flush the Scheme portion of the I-cache.
- It flushes the entire I-cache instead, since it is easier.
- It is used after a GC or disk-restore.
- It's needed because the GC has moved code around, and closures
- and execute cache cells have absolute addresses that the
- processor might have old copies of.
- */
-
-#define FLUSH_I_CACHE() do \
-{ \
- extern void flush_i_cache (void); \
- flush_i_cache (); \
-} while (0)
-
-/* This flushes a region of the I-cache.
- It is used after updating an execute cache while running.
- Not needed during GC because FLUSH_I_CACHE will be used.
- */
-
-#define FLUSH_I_CACHE_REGION(address, nwords) do \
-{ \
- extern void cache_flush_region, (void *, long, unsigned int); \
- cache_flush_region (((void *) (address)), ((long) (nwords)), \
- (D_CACHE | I_CACHE)); \
-} while (0)
-
-/* This pushes a region of the D-cache back to memory.
- It is (typically) used after loading (and relocating) a piece of code
- into memory.
- */
-
-#define PUSH_D_CACHE_REGION(address, nwords) do \
-{ \
- extern void push_d_cache_region (void *, unsigned long); \
- push_d_cache_region (((void *) (address)), \
- ((unsigned long) (nwords))); \
-} while (0)
-
-extern void hppa_update_primitive_table (int, int);
-extern bool hppa_grow_primitive_table (int);
-
-#define UPDATE_PRIMITIVE_TABLE_HOOK hppa_update_primitive_table
-#define GROW_PRIMITIVE_TABLE_HOOK hppa_grow_primitive_table
-
-/* This is not completely true. Some models (eg. 850) have combined caches,
- but we have to assume the worst.
- */
-
-#define SPLIT_CACHES
-\f
-/* Derived parameters and macros.
-
- These macros expect the above definitions to be meaningful.
- If they are not, the macros below may have to be changed as well.
- */
-
-#define COMPILED_ENTRY_OFFSET_WORD(entry) \
- (((format_word *) (entry))[-1])
-#define COMPILED_ENTRY_FORMAT_WORD(entry) \
- (((format_word *) (entry))[-2])
-
-/* The next one assumes 2's complement integers....*/
-#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2))
-#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0)
-
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> 1)
-#define OFFSET_WORD_TO_BYTE_OFFSET(word) ((CLEAR_LOW_BIT (word)) << 1)
-
-#define MAKE_OFFSET_WORD(entry, block, continue) \
- ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \
- ((char *) (block)))) | \
- ((continue) ? 1 : 0))
-
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) / EXECUTE_CACHE_ENTRY_SIZE)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) * EXECUTE_CACHE_ENTRY_SIZE)
-\f
-/* The first entry in a cc block is preceeded by 2 headers (block and nmv),
- a format word and a gc offset word. See the early part of the
- TRAMPOLINE picture, above.
- */
-
-#define CC_BLOCK_FIRST_ENTRY_OFFSET \
- (2 * ((sizeof(SCHEME_OBJECT)) + (sizeof(format_word))))
-
-#ifndef FORMAT_BYTE_CLOSURE
-#define FORMAT_BYTE_CLOSURE 0xFA
-#endif
-
-#ifndef FORMAT_WORD_CLOSURE
-#define FORMAT_WORD_CLOSURE (MAKE_FORMAT_WORD (0xFF, FORMAT_BYTE_CLOSURE))
-#endif
-
-/* This assumes that a format word is at least 16 bits,
- and the low order field is always 8 bits.
- */
-
-#define MAKE_FORMAT_WORD(field1, field2) \
- (((field1) << 8) | ((field2) & 0xff))
-
-#define SIGN_EXTEND_FIELD(field, size) \
- (((field) & ((1 << (size)) - 1)) | \
- ((((field) & (1 << ((size) - 1))) == 0) ? 0 : \
- ((-1) << (size))))
-
-#define FORMAT_WORD_LOW_BYTE(word) \
- (SIGN_EXTEND_FIELD((((unsigned long) (word)) & 0xff), 8))
-
-#define FORMAT_WORD_HIGH_BYTE(word) \
- (SIGN_EXTEND_FIELD((((unsigned long) (word)) >> 8), \
- (((sizeof (format_word)) * CHAR_BIT) - 8)))
-
-#define COMPILED_ENTRY_FORMAT_HIGH(addr) \
- (FORMAT_WORD_HIGH_BYTE(COMPILED_ENTRY_FORMAT_WORD(addr)))
-
-#define COMPILED_ENTRY_FORMAT_LOW(addr) \
- (FORMAT_WORD_LOW_BYTE(COMPILED_ENTRY_FORMAT_WORD(addr)))
-
-#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW
-#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH
-\f
-#ifdef IN_CMPINT_C
-
-/* Definitions of the utility procedures.
- Procedure calls of leaf procedures on the HPPA are pretty fast,
- so there is no reason not to do this out of line.
- In this way compiled code can use them too.
- */
-
-union ldil_inst
-{
- unsigned long inst;
- struct
- {
- unsigned opcode : 6;
- unsigned base : 5;
- unsigned D : 5;
- unsigned C : 2;
- unsigned E : 2;
- unsigned B : 11;
- unsigned A : 1;
- } fields;
-};
-
-union branch_inst
-{
- unsigned long inst;
- struct
- {
- unsigned opcode : 6;
- unsigned t_or_b : 5;
- unsigned x_or_w1 : 5;
- unsigned s : 3;
- unsigned w2b : 10;
- unsigned w2a : 1;
- unsigned n : 1;
- unsigned w0 : 1;
- } fields;
-};
-
-union short_pointer
-{
- unsigned long address;
- struct
- {
- unsigned A : 1;
- unsigned B : 11;
- unsigned C : 2;
- unsigned D : 5;
- unsigned w2a : 1;
- unsigned w2b : 10;
- unsigned pad : 2;
- } fields;
-};
-\f
-union assemble_17_u
-{
- long value;
- struct
- {
- int sign_pad : 13;
- unsigned w0 : 1;
- unsigned w1 : 5;
- unsigned w2a : 1;
- unsigned w2b : 10;
- unsigned pad : 2;
- } fields;
-};
-
-union assemble_12_u
-{
- long value;
- struct
- {
- int sign_pad : 18;
- unsigned w0 : 1;
- unsigned w2a : 1;
- unsigned w2b : 10;
- unsigned pad : 2;
- } fields;
-};
-
-long
-assemble_17 (union branch_inst inst)
-{
- union assemble_17_u off;
-
- off.fields.pad = 0;
- off.fields.w2b = inst.fields.w2b;
- off.fields.w2a = inst.fields.w2a;
- off.fields.w1 = inst.fields.x_or_w1;
- off.fields.w0 = inst.fields.w0;
- off.fields.sign_pad = ((inst.fields.w0 == 0) ? 0 : -1);
- return (off.value);
-}
-
-long
-assemble_12 (union branch_inst inst)
-{
- union assemble_12_u off;
-
- off.fields.pad = 0;
- off.fields.w2b = inst.fields.w2b;
- off.fields.w2a = inst.fields.w2a;
- off.fields.w0 = inst.fields.w0;
- off.fields.sign_pad = ((inst.fields.w0 == 0) ? 0 : -1);
- return (off.value);
-}
-\f
-static unsigned long hppa_closure_hook = 0;
-
-static unsigned long
-C_closure_entry_point (unsigned long C_closure)
-{
- if ((C_closure & 0x3) != 0x2)
- return (C_closure);
- else
- {
- long offset;
- extern int etext;
- unsigned long entry_point;
- char * blp = (* ((char **) (C_closure - 2)));
-
- blp = ((char *) (((unsigned long) blp) & ~3));
- offset = (assemble_17 (* ((union branch_inst *) blp)));
- entry_point = ((unsigned long) ((blp + 8) + offset));
- return ((entry_point < ((unsigned long) &etext))
- ? entry_point
- : hppa_closure_hook);
- }
-}
-\f
-#define HAVE_BKPT_SUPPORT
-
-static unsigned short branch_opcodes[] =
-{
- 0x20, 0x21, 0x22, 0x23, 0x28, 0x29, 0x2a, 0x2b,
- 0x30, 0x31, 0x32, 0x33, 0x38, 0x39, 0x3a
-};
-
-static bool
- branch_opcode_table[64];
-
-static unsigned long
- bkpt_instruction,
- closure_bkpt_instruction,
- closure_entry_bkpt_instruction,
- * bkpt_normal_proceed_thunk,
- * bkpt_plus_proceed_thunk,
- * bkpt_minus_proceed_thunk_start,
- * bkpt_minus_proceed_thunk,
- * bkpt_closure_proceed_thunk,
- * bkpt_closure_proceed_thunk_end,
- * bkpt_proceed_buffer = ((unsigned long *) NULL);
-
-#define FAHRENHEIT 451
-
-static void
-bkpt_init (void)
-{
- int i, this_size, max_size;
- union branch_inst instr;
- extern void bkpt_normal_proceed (void);
- extern void bkpt_plus_proceed (void);
- extern void bkpt_minus_proceed_start (void);
- extern void bkpt_minus_proceed (void);
- extern void bkpt_closure_proceed (void);
- extern void bkpt_closure_proceed_end (void);
-
- for (i = 0;
- i < ((sizeof (branch_opcode_table)) / (sizeof (bool)));
- i++)
- branch_opcode_table[i] = FALSE;
-
- for (i = 0;
- i < ((sizeof (branch_opcodes)) / (sizeof (short)));
- i++)
- branch_opcode_table[branch_opcodes[i]] = TRUE;
-
- instr.fields.opcode = 0x39; /* BLE opcode */
- instr.fields.t_or_b = 03; /* scheme_to_interface_ble */
- instr.fields.n = 01; /* nullify */
- instr.fields.s = 01; /* C code space, rotated illegibly */
- instr.fields.w0 = 00;
- instr.fields.x_or_w1 = 00;
- instr.fields.w2a = 00;
- instr.fields.w2b = ((FAHRENHEIT + 1) >> 2);
-
- bkpt_instruction = instr.inst;
-
- instr.fields.w2b = ((FAHRENHEIT + 33) >> 2);
- closure_entry_bkpt_instruction = instr.inst;
-
- instr.fields.opcode = 0x38; /* BE opcode */
- instr.fields.w2b = ((FAHRENHEIT + 9) >> 2);
- closure_bkpt_instruction = instr.inst;
-
- bkpt_normal_proceed_thunk
- = ((unsigned long *)
- (C_closure_entry_point ((unsigned long) bkpt_normal_proceed)));
- bkpt_plus_proceed_thunk
- = ((unsigned long *)
- (C_closure_entry_point ((unsigned long) bkpt_plus_proceed)));
- bkpt_minus_proceed_thunk_start
- = ((unsigned long *)
- (C_closure_entry_point ((unsigned long) bkpt_minus_proceed_start)));
- bkpt_minus_proceed_thunk
- = ((unsigned long *)
- (C_closure_entry_point ((unsigned long) bkpt_minus_proceed)));
- bkpt_closure_proceed_thunk
- = ((unsigned long *)
- (C_closure_entry_point ((unsigned long) bkpt_closure_proceed)));
- bkpt_closure_proceed_thunk_end
- = ((unsigned long *)
- (C_closure_entry_point ((unsigned long) bkpt_closure_proceed_end)));
-
- max_size = (bkpt_closure_proceed_thunk_end - bkpt_closure_proceed_thunk);
- this_size = (bkpt_plus_proceed_thunk - bkpt_normal_proceed_thunk);
- if (this_size > max_size)
- max_size = this_size;
- this_size = (bkpt_closure_proceed_thunk - bkpt_minus_proceed_thunk_start);
- if (this_size > max_size)
- max_size = this_size;
- this_size = (bkpt_minus_proceed_thunk_start - bkpt_plus_proceed_thunk);
- if (this_size > max_size)
- max_size = this_size;
-
- bkpt_proceed_buffer = ((unsigned long *)
- (malloc (max_size * (sizeof (unsigned long)))));
- if (bkpt_proceed_buffer == ((unsigned long *) NULL))
- {
- outf_fatal ("Unable to allocate the breakpoint buffer.\n");
- termination_init_error ();
- }
- return;
-}
-\f
-#define BKPT_KIND_CLOSURE 0
-#define BKPT_KIND_NORMAL 1
-#define BKPT_KIND_PC_REL_BRANCH 2
-#define BKPT_KIND_BL_INST 3
-#define BKPT_KIND_BLE_INST 4
-#define BKPT_KIND_CLOSURE_ENTRY 5
-
-extern void cache_flush_region (void *, long, unsigned int);
-
-static SCHEME_OBJECT
-alloc_bkpt_handle (int kind, unsigned long first_instr, void * entry_point)
-{
- SCHEME_OBJECT * handle;
- Primitive_GC_If_Needed (5);
- handle = Free;
- Free += 5;
-
- handle[0] = (MAKE_OBJECT (TC_MANIFEST_VECTOR, 4));
- handle[1] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 2));
- handle[2] = ((SCHEME_OBJECT) (FIXNUM_ZERO + kind));
- handle[3] = ((SCHEME_OBJECT) first_instr);
- handle[4] = (ENTRY_TO_OBJECT (entry_point));
-
- return (MAKE_POINTER_OBJECT (TC_NON_MARKED_VECTOR, handle));
-}
-
-SCHEME_OBJECT
-bkpt_install (void * entry_point)
-{
- unsigned long kind;
- SCHEME_OBJECT handle;
- unsigned long first_instr = (* ((unsigned long *) entry_point));
- unsigned short opcode = ((first_instr >> 26) & 0x3f);
- unsigned long new_instr = bkpt_instruction;
-
- if ((COMPILED_ENTRY_FORMAT_WORD (entry_point)) == FORMAT_WORD_CLOSURE)
- {
- /* This assumes that the first instruction is normal */
- kind = BKPT_KIND_CLOSURE_ENTRY;
- new_instr = closure_entry_bkpt_instruction;
- }
- else if ((! (branch_opcode_table[opcode])) || (opcode == 0x38))
- kind = BKPT_KIND_NORMAL; /* BE instr included */
- else if (opcode == 0x39)
-#if 0
- kind = BKPT_KIND_BLE_INST;
-#else /* for now */
- return (SHARP_F);
-#endif
- else if (opcode != 0x3a)
- {
- unsigned long second_instr = (* (((unsigned long *) entry_point) + 1));
- unsigned long second_opcode = ((second_instr >> 26) & 0x3f);
-
- /* We can't handle breakpoints to a branch instruction
- with another branch instruction in its delay slot.
- This could be nullification sensitive, but not
- currently worthwhile.
- */
-
- if (branch_opcode_table[second_opcode])
- return (SHARP_F);
-
- kind = BKPT_KIND_PC_REL_BRANCH;
- }
-\f
- else
- {
- union branch_inst finstr;
-
- finstr.inst = first_instr;
- switch (finstr.fields.s) /* minor opcode */
- {
- case 0: /* BL instruction */
-#if 0
- kind = BKPT_KIND_BL_INST;
- break;
-#endif /* for now, fall through */
-
- case 1: /* GATE instruction */
- case 2: /* BLR instruction */
- default: /* ?? */
- return (SHARP_F);
-
- case 6:
- kind = BKPT_KIND_NORMAL;
- break;
- }
- }
-
- handle = (alloc_bkpt_handle (kind, first_instr, entry_point));
-
- (* ((unsigned long *) entry_point)) = new_instr;
- cache_flush_region (((void *) entry_point), 1, (D_CACHE | I_CACHE));
-
- return (handle);
-}
-
-SCHEME_OBJECT
-bkpt_closure_install (void * entry_point)
-{
- unsigned long * instrs = ((unsigned long *) entry_point);
- SCHEME_OBJECT handle;
-
- handle = (alloc_bkpt_handle (BKPT_KIND_CLOSURE, instrs[2], entry_point));
- instrs[2] = closure_bkpt_instruction;
- cache_flush_region (((void *) &instrs[2]), 1, (D_CACHE | I_CACHE));
- return (handle);
-}
-
-void
-bkpt_remove (void * entry_point, SCHEME_OBJECT handle)
-{
- int offset;
- unsigned long * instrs = ((unsigned long *) entry_point);
-
- if ((instrs[0] == bkpt_instruction)
- || (instrs[0] == closure_entry_bkpt_instruction))
- offset = 0;
- else if (instrs[2] == closure_bkpt_instruction)
- offset = 2;
- else
- error_external_return ();
-
- instrs[offset] = ((unsigned long) (MEMORY_REF (handle, 3)));
- cache_flush_region (((void *) &instrs[offset]), 1, (D_CACHE | I_CACHE));
- return;
-}
-
-bool
-bkpt_p (void * entry_point)
-{
- unsigned long * instrs = ((unsigned long *) entry_point);
-
- return ((instrs[0] == bkpt_instruction)
- || (instrs[0] == closure_entry_bkpt_instruction)
- || (instrs[2] == closure_bkpt_instruction));
-}
-\f
-long
-do_bkpt_proceed (insn_t ** addr_r)
-{
- insn_t * buffer = bkpt_proceed_buffer;
- SCHEME_OBJECT ep = (STACK_POP ());
- SCHEME_OBJECT handle = (STACK_POP ());
- SCHEME_OBJECT state = (STACK_POP ());
-
- STACK_POP (); /* Pop duplicate entry point. */
-
- switch (OBJECT_DATUM (MEMORY_REF (handle, 2)))
- {
- case BKPT_KIND_CLOSURE:
- {
- int i, len;
- unsigned long * clos_entry
- = (OBJECT_ADDRESS (MEMORY_REF (handle, 4)));
- SCHEME_OBJECT real_entry_point;
-
- EXTRACT_CLOSURE_ENTRY_ADDRESS (real_entry_point, clos_entry);
- len = (bkpt_closure_proceed_thunk_end - bkpt_closure_proceed_thunk);
- for (i = 0; i < (len - 2); i++)
- buffer[i] = bkpt_closure_proceed_thunk[i];
- cache_flush_region (((void *) buffer), (len - 2), (D_CACHE | I_CACHE));
-
- buffer[len - 2] = ((unsigned long) clos_entry);
- buffer[len - 1] = real_entry_point;
-
- SET_VAL (SHARP_F);
- (*addr_r) = buffer;
- return (PRIM_DONE);
- }
-
- case BKPT_KIND_NORMAL:
- {
- int i, len;
-
- len = (bkpt_plus_proceed_thunk - bkpt_normal_proceed_thunk);
- for (i = 0; i < (len - 2); i++)
- buffer[i] = bkpt_normal_proceed_thunk[i];
- buffer[len - 2] = ((unsigned long) (MEMORY_REF (handle, 3)));
-
- cache_flush_region (((void *) buffer), (len - 1), (D_CACHE | I_CACHE));
- buffer[len - 1] = (((unsigned long) (OBJECT_ADDRESS (ep))) + 4);
-
- SET_VAL (state);
- (*addr_r) = buffer;
- return (PRIM_DONE);
- }
-
- case BKPT_KIND_CLOSURE_ENTRY:
- {
- STACK_PUSH (state); /* closure object */
- (*addr_r) = ((CC_ENTRY_ADDRESS (ep)) + 2);
- return (PRIM_DONE);
- }
-
- case BKPT_KIND_BL_INST:
- case BKPT_KIND_BLE_INST:
- default:
- STACK_PUSH (ep);
- return (ERR_EXTERNAL_RETURN);
-
- case BKPT_KIND_PC_REL_BRANCH:
- {
- long offset;
- int i, len, clobber;
- union branch_inst new, old;
- insn_t * instrs = (CC_ENTRY_ADDRESS (ep));
- unsigned long * block;
-
- old.inst = ((unsigned long) (MEMORY_REF (handle, 3)));
- offset = (assemble_12 (old));
- if (offset >= 0)
- {
- block = bkpt_plus_proceed_thunk;
- len = (bkpt_minus_proceed_thunk_start - block);
- clobber = 0;
- }
- else
- {
- block = bkpt_minus_proceed_thunk_start;
- len = (bkpt_closure_proceed_thunk - block);
- clobber = (bkpt_minus_proceed_thunk - block);
- }
-
- for (i = 0; i < (len - 2); i++)
- buffer[i] = block[i];
-
- new.inst = buffer[clobber];
- old.inst = ((unsigned long) (MEMORY_REF (handle, 3)));
- old.fields.w2b = new.fields.w2b;
- old.fields.w2a = new.fields.w2a;
- old.fields.w0 = new.fields.w0;
- buffer[clobber] = old.inst;
- buffer[clobber + 1] = instrs[1];
- cache_flush_region (((void *) buffer), (len - 2), (D_CACHE | I_CACHE));
-
- buffer[len - 2] = (((unsigned long) instrs) + 8);
- buffer[len - 1] = ((((unsigned long) instrs) + 8)
- + offset);
-
- SET_VAL (state);
- (*addr_r) = (buffer + clobber);
- return (PRIM_DONE);
- }
- }
-}
-\f
-static void
-transform_procedure_entries (long len, void ** otable, void ** ntable)
-{
- long counter;
-
- for (counter = 0; counter < len; counter++)
- ntable[counter] =
- ((void *) (C_closure_entry_point ((unsigned long) (otable [counter]))));
- return;
-}
-
-static void **
-transform_procedure_table (long table_length, void ** old_table)
-{
- void ** new_table;
-
- new_table = ((void **) (malloc (table_length * (sizeof (void *)))));
- if (new_table == ((void **) NULL))
- {
- outf_fatal ("transform_procedure_table: malloc (%d) failed.\n",
- (table_length * (sizeof (void *))));
- exit (1);
- }
- transform_procedure_entries (table_length, old_table, new_table);
- return (new_table);
-}
-
-#define UTIL_TABLE_PC_REF(index) \
- (C_closure_entry_point (UTIL_TABLE_PC_REF_REAL (index)))
-
-#ifdef _BSD4_3
-# include <sys/mman.h>
-# define VM_PROT_SCHEME (PROT_READ | PROT_WRITE | PROT_EXEC)
-#endif
-
-void
-change_vm_protection (void)
-{
-#if 0
- /* Thought I needed this under _BSD4_3 */
-
- unsigned long pagesize = (getpagesize ());
- unsigned long heap_start_page;
- unsigned long size;
-
- heap_start_page = (((unsigned long) Heap) & (pagesize - 1));
- size = (((memory_block_end + (pagesize - 1)) & (pagesize - 1))
- - heap_start_page);
- if ((mprotect (((caddr_t) heap_start_page), size, VM_PROT_SCHEME))
- == -1)
- {
- perror ("\nchange_vm_protection");
- outf_fatal ("mprotect (0x%lx, 0x%lx, 0x%lx)\n",
- heap_start_page, size, VM_PROT_SCHEME);
- outf_fatal ("ASM_RESET_HOOK: Unable to change VM protection of Heap.\n");
- termination_init_error ();
- }
-#endif
-}
-\f
-#include "option.h"
-
-#ifndef MODELS_FILENAME
-#define MODELS_FILENAME "hppacach.mod"
-#endif
-
-static struct pdc_cache_dump cache_info;
-
-static void
-flush_i_cache_initialize (void)
-{
- const char * models_filename =
- (search_path_for_file (0, MODELS_FILENAME, true, true));
- char * model;
-
- model = (getenv ("MITSCHEME_HPPA_MODEL"));
-
-#ifdef _HPUX
- if (model == ((char *) NULL))
- {
- struct utsname sysinfo;
- if ((uname (&sysinfo)) < 0)
- {
- outf_fatal ("\nflush_i_cache: uname failed.\n");
- goto loser;
- }
- model = &sysinfo.machine[0];
- }
-#endif /* _HPUX */
- if (model == ((char *) NULL))
- {
- outf_fatal
- ("\nflush_i_cache: MITSCHEME_HPPA_MODEL not set in environment.\n");
- goto loser;
- }
- {
- int fd = (open (models_filename, O_RDONLY));
- if (fd < 0)
- {
- outf_fatal ("\nflush_i_cache: open (%s) failed.\n",
- models_filename);
- goto loser;
- }
- while (1)
- {
- int read_result =
- (read (fd,
- ((char *) (&cache_info)),
- (sizeof (struct pdc_cache_dump))));
- if (read_result == 0)
- {
- close (fd);
- break;
- }
- if (read_result != (sizeof (struct pdc_cache_dump)))
- {
- close (fd);
- outf_fatal ("\nflush_i_cache: read (%s) failed.\n",
- models_filename);
- goto loser;
- }
- if ((strcmp (model, (cache_info . hardware))) == 0)
- {
- close (fd);
- return;
- }
- }
- }
- outf_fatal (
- "The cache parameters database has no entry for the %s model.\n",
- model);
- outf_fatal ("Please make an entry in the database;\n");
- outf_fatal ("the installation notes contain instructions for doing so.\n");
- loser:
- outf_fatal ("\nASM_RESET_HOOK: Unable to read cache parameters.\n");
- termination_init_error ();
-}
-\f
-/* This loads the cache information structure for use by flush_i_cache,
- sets the floating point flags correctly, and accommodates the c
- function pointer closure format problems for utilities for HP-UX >= 8.0 .
- It also changes the VM protection of the heap, if necessary.
- */
-
-extern void ** hppa_utility_table;
-extern void ** hppa_primitive_table;
-
-void ** hppa_utility_table = ((void **) NULL);
-
-static void
-hppa_reset_hook (long utility_length, void ** utility_table)
-{
- extern void interface_initialize (void);
- extern void cross_segment_call (void);
-
- flush_i_cache_initialize ();
- interface_initialize ();
- change_vm_protection ();
- hppa_closure_hook
- = (C_closure_entry_point ((unsigned long) cross_segment_call));
- hppa_utility_table
- = (transform_procedure_table (utility_length, utility_table));
- return;
-}
-
-#define ASM_RESET_HOOK() do \
-{ \
- bkpt_init (); \
- hppa_reset_hook (((sizeof (utility_table)) / (sizeof (void *))), \
- ((void **) (&utility_table[0]))); \
-} while (0)
-
-void ** hppa_primitive_table = ((void **) NULL);
-
-void
-hppa_update_primitive_table (int low, int high)
-{
- transform_procedure_entries ((high - low),
- ((void **) (Primitive_Procedure_Table + low)),
- (hppa_primitive_table + low));
- return;
-}
-
-bool
-hppa_grow_primitive_table (int new_size)
-{
- void ** new_table
- = ((void **)
- (realloc (hppa_primitive_table, (new_size * (sizeof (void *))))));
- if (new_table != ((void **) NULL))
- hppa_primitive_table = new_table;
- return (new_table != ((void **) NULL));
-}
-\f
-/*
- Note: The following does not do a full decoding of the BLE instruction.
- It assumes that the bits have been set by STORE_ABSOLUTE_ADDRESS below,
- which decomposes an absolute address according to the `short_pointer'
- structure above, and thus certain fields are 0.
-
- The sequence inserted by STORE_ABSOLUTE_ADDRESS is approximately
- (the actual address decomposition is given above).
- LDIL L'ep,26
- BLE R'ep(5,26)
- */
-
-unsigned long
-hppa_extract_absolute_address (unsigned long * addr)
-{
- union short_pointer result;
- union branch_inst ble;
- union ldil_inst ldil;
-
- ldil.inst = *addr++;
- ble.inst = *addr;
-
- /* Fill the padding */
- result.address = 0;
-
- result.fields.A = ldil.fields.A;
- result.fields.B = ldil.fields.B;
- result.fields.C = ldil.fields.C;
- result.fields.D = ldil.fields.D;
- result.fields.w2a = ble.fields.w2a;
- result.fields.w2b = ble.fields.w2b;
-
- return (result.address);
-}
-
-void
-hppa_store_absolute_address (unsigned long * addr, unsigned long sourcev,
- unsigned long nullify_p)
-{
- union short_pointer source;
- union ldil_inst ldil;
- union branch_inst ble;
-
- source.address = sourcev;
-
-#if 0
- ldil.fields.opcode = 0x08;
- ldil.fields.base = 26;
- ldil.fields.E = 0;
-#else
- ldil.inst = ((0x08 << 26) | (26 << 21));
-#endif
-
- ldil.fields.A = source.fields.A;
- ldil.fields.B = source.fields.B;
- ldil.fields.C = source.fields.C;
- ldil.fields.D = source.fields.D;
-
-#if 0
- ble.fields.opcode = 0x39;
- ble.fields.t_or_b = 26;
- ble.fields.x_or_w1 = 0;
- ble.fields.s = 3;
- ble.fields.w0 = 0;
-#else
- ble.inst = ((0x39 << 26) | (26 << 21) | (3 << 13));
-#endif
-
- ble.fields.w2a = source.fields.w2a;
- ble.fields.w2b = source.fields.w2b;
- ble.fields.n = (nullify_p & 1);
-
- *addr++ = ldil.inst;
- *addr = ble.inst;
- return;
-}
-\f
-/* Cache flushing/pushing code.
- Uses routines from cmpaux-hppa.m4.
- */
-
-extern void
- flush_i_cache (void),
- push_d_cache_region (void *, unsigned long);
-
-void
-flush_i_cache (void)
-{
- extern void
- cache_flush_all (unsigned int, struct pdc_cache_result *);
-
- struct pdc_cache_result * cache_desc;
-
- cache_desc = ((struct pdc_cache_result *) &(cache_info.cache_format));
-
- /* The call can be interrupted in the middle of a set, so do it twice.
- Probability of two interrupts in the same cache line is
- exceedingly small, so this is likely to win.
- On the other hand, if the caches are directly mapped, a single
- call can't lose.
- In addition, if the cache is shared, there is no need to flush at all.
- */
-
- if (((cache_desc->I_info.conf.bits.fsel & 1) == 0)
- || ((cache_desc->D_info.conf.bits.fsel & 1) == 0))
- {
- unsigned int flag = 0;
-
- if (cache_desc->I_info.loop != 1)
- flag |= I_CACHE;
- if (cache_desc->D_info.loop != 1)
- flag |= D_CACHE;
-
- if (flag != 0)
- cache_flush_all (flag, cache_desc);
- cache_flush_all ((D_CACHE | I_CACHE), cache_desc);
- }
-}
-
-void
-push_d_cache_region (void * start_address, unsigned long block_size)
-{
- extern void
- cache_flush_region (void *, long, unsigned int);
-
- struct pdc_cache_result * cache_desc;
-
- cache_desc = ((struct pdc_cache_result *) &(cache_info.cache_format));
-
- /* Note that the first and last words are also flushed from the I-cache
- in case this object is adjacent to another that has already caused
- the cache line to be copied into the I-cache.
- */
-
- if (((cache_desc->I_info.conf.bits.fsel & 1) == 0)
- || ((cache_desc->D_info.conf.bits.fsel & 1) == 0))
- {
- cache_flush_region (start_address, block_size, D_CACHE);
- cache_flush_region (start_address, 1, I_CACHE);
- cache_flush_region (((void *)
- (((unsigned long *) start_address)
- + (block_size - 1))),
- 1,
- I_CACHE);
- }
- return;
-}
-\f
-#define DECLARE_CMPINTMD_UTILITIES() \
- UTLD (assemble_17), \
- UTLD (assemble_12), \
- UTLD (C_closure_entry_point), \
- UTLD (bkpt_init), \
- UTLD (alloc_bkpt_handle), \
- UTLD (bkpt_install), \
- UTLD (bkpt_closure_install), \
- UTLD (bkpt_remove), \
- UTLD (bkpt_p), \
- UTLD (do_bkpt_proceed), \
- UTLD (transform_procedure_entries), \
- UTLD (transform_procedure_table), \
- UTLD (change_vm_protection), \
- UTLD (hppa_reset_hook), \
- UTLD (hppa_update_primitive_table), \
- UTLD (hppa_grow_primitive_table), \
- UTLD (hppa_extract_absolute_address), \
- UTLD (hppa_store_absolute_address), \
- UTLD (flush_i_cache), \
- UTLD (push_d_cache_region), \
- UTLD (flush_i_cache_initialize)
-
-#endif /* IN_CMPINT_C */
-
-#endif /* !SCM_CMPINTMD_H_INCLUDED */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/*
- *
- * Compiled code interface macros.
- *
- * See cmpint.txt for a description of these fields.
- *
- * Specialized for the Motorola 68K family.
- */
-
-#ifndef SCM_CMPINTMD_H_INCLUDED
-#define SCM_CMPINTMD_H_INCLUDED 1
-\f
-/* Machine parameters to be set by the user. */
-
-/* Until cmpaux-mc68k.m4 is updated. */
-#define CMPINT_USE_STRUCS
-
-/* Processor type.
- Choose a number from the above list, or allocate your own. */
-
-#ifndef COMPILER_PROCESSOR_TYPE
-#define COMPILER_PROCESSOR_TYPE COMPILER_MC68040_TYPE
-#endif
-
-/* Size (in long words) of the contents of a floating point register if
- different from a double. For example, an MC68881 saves registers
- in 96 bit (3 longword) blocks.
-*/
-#define COMPILER_TEMP_SIZE 3
-
-/* Descriptor size.
- This is the size of the offset field, and of the format field.
- This definition probably does not need to be changed.
- */
-
-typedef unsigned short format_word;
-
-/* The length of the GC recovery code that precedes an entry.
- On the 68K a "jsr n(a6)" instruction.
- */
-
-#define ENTRY_PREFIX_LENGTH 4
-\f
-/* Cache flushing. */
-
-#ifdef _NEXTOS
-
-extern void NeXT_cacheflush (void);
-
-# ifdef IN_CMPINT_C
-
-/* This is not inlined because trap #2 clobbers %d0.
- Since %d0 is a compiler supertemporary, doing the trap
- out of line wins.
- Perhaps this should be more paranoid and preserve all, but...
- */
-
-void
-NeXT_cacheflush (void)
-{
- asm ("trap #2");
- return;
-}
-
-# endif /* IN_CMPINT_C */
-
-# define SPLIT_CACHES
-# define FLUSH_I_CACHE() NeXT_cacheflush ()
-# define FLUSH_I_CACHE_REGION(addr,nwords) FLUSH_I_CACHE()
-
-#endif /* _NEXTOS */
-
-#ifdef __hpux
-
-/* The following is a test for HP-UX >= 7.05 */
-
-# include <sys/time.h>
-# include <sys/resource.h>
-# include <sys/proc.h>
-
-# if defined(S2DATA_WT) || defined(SWITZERLAND)
-
-/* This only works in HP-UX >= 7.05 */
-
-# include <sys/cache.h>
-
-# ifdef SWITZERLAND
-
-extern void swiss_cachectl (int, void *, unsigned long);
-
-# define FLUSH_CACHE_INITIALIZE() swiss_cachectl_init_p = 0
-
-# ifdef IN_CMPINT_C
-
-static int
- swiss_cachectl_init_p = 0,
- swiss_cachectl_flush_p = 0;
-
-void
-swiss_cachectl (int mode, void * base, unsigned long count)
-{
- if (swiss_cachectl_init_p == 0)
- {
- int length;
- char *string, *posn;
- extern char * strstr (char *, char *);
- extern int getcontext (char *, int);
-
- string = ((char *) Free);
- length = (getcontext (string,
- ((heap_alloc_limit - Free)
- * (sizeof (SCHEME_OBJECT)))));
- swiss_cachectl_flush_p =
- (((strstr (string, "HP-MC68040")) == ((char *) NULL)) ? 0 : 1);
- swiss_cachectl_init_p = 1;
- }
- if (swiss_cachectl_flush_p == 1)
- {
- (void) (cachectl (mode, base, count));
- }
- return;
-}
-
-# endif /* IN_CMPINT_C */
-
-# define cachectl(m,b,l) swiss_cachectl(m,b,l)
-# endif /* SWITZERLAND */
-
-extern void
- operate_on_cache_region (int, char *, unsigned long);
-
-# define SPLIT_CACHES
-
-# define FLUSH_I_CACHE() \
- (void) (cachectl (CC_IPURGE, 0, 0))
-
-# define FLUSH_I_CACHE_REGION(addr, nwords) \
- (operate_on_cache_region (CC_IPURGE, ((char *) (addr)), (nwords)))
-
-# define PUSH_D_CACHE_REGION(addr, nwords) \
-do \
-{ \
- char *base = ((char *) (addr)); \
- unsigned long len = (nwords); \
- \
- operate_on_cache_region (CC_FLUSH, base, len); \
- operate_on_cache_region (CC_IPURGE, base, 1); \
- operate_on_cache_region (CC_IPURGE, \
- ((char *) \
- (((unsigned long *) base) + (len - 1))), \
- 1); \
-} while (0)
-
-# ifdef IN_CMPINT_C
-
-void
-operate_on_cache_region (int cachecmd, char * bptr, unsigned long nwords)
-{
- char * eptr;
- unsigned long nbytes, quantum;
-
- if (nwords == 0)
- return;
-
- nbytes = (nwords * (sizeof (long)));
- eptr = (bptr + (nbytes - 1));
- quantum = ((nbytes <= 0x40) ? 0x10 : 0x1000);
-
- for (bptr = ((char *) (((unsigned long) bptr) & (~(quantum - 1)))),
- eptr = ((char *) (((unsigned long) eptr) & (~(quantum - 1))));
- (bptr <= eptr);
- bptr += quantum)
- (void) (cachectl (cachecmd, bptr, quantum));
- return;
-}
-
-# endif /* IN_CMPINT_C */
-# else /* S2DATA_WT */
-# define FLUSH_I_CACHE() do {} while (0)
-# endif /* S2DATA_WT */
-#endif /* __hpux */
-
-#ifndef FLUSH_CACHE_INITIALIZE
-# define FLUSH_CACHE_INITIALIZE() do {} while (0)
-#endif /* FLUSH_CACHE_INITIALIZE */
-
-#ifndef FLUSH_I_CACHE_REGION
-# define FLUSH_I_CACHE_REGION(addr, nwords) do {} while (0)
-#endif /* not FLUSH_I_CACHE_REGION */
-
-#ifndef PUSH_D_CACHE_REGION
-# define PUSH_D_CACHE_REGION(addr, nwords) FLUSH_I_CACHE_REGION(addr, nwords)
-#endif /* not PUSH_D_CACHE_REGION */
-\f
-#if (COMPILER_PROCESSOR_TYPE == COMPILER_MC68020_TYPE)
-
-/* 68k magic.
- On the 68k, when closures are invoked, the closure corresponding
- to the first entry point is what's needed on the top of the stack.
- Note that it is needed for environment only, not for code.
- The closure code does an
- ADDI.L &magic-constant,(SP)
- on entry, to bump the current entry point (after the JSR instruction)
- to the correct place.
- This code emulates that operation by extracting the magic constant
- from the closure code, and adjusting the address by 6 as if the
- JSR instruction had just been executed.
- It is used when interrupts are disabled, in order not to get into a loop.
- Note that if closure entry points were always longword-aligned, there
- would be no need for this nonsense.
- */
-
-# define ADJUST_CLOSURE_AT_CALL(entry_point, location) \
-do { \
- long magic_constant; \
- \
- magic_constant = (* ((long *) (((char *) (entry_point)) + 2))); \
- (location) = ((SCHEME_OBJECT) \
- ((((long) (OBJECT_ADDRESS (location))) + 6) + \
- magic_constant)); \
-} while (0)
-
-/* Manifest closure entry block size.
- Size in bytes of a compiled closure's header excluding the
- TC_MANIFEST_CLOSURE header.
-
- On the 68k, this is the format word and gc offset word and 6 bytes
- more for the jsr instruction.
-*/
-
-# define COMPILED_CLOSURE_ENTRY_SIZE \
- ((2 * (sizeof (format_word))) + 6)
-
-/* Manifest closure entry destructuring.
-
- Given the entry point of a closure, extract the `real entry point'
- (the address of the real code of the procedure, ie. one indirection)
- from the closure.
- Note that on some machines this address may be "smeared out" over
- multiple instructions.
-*/
-
-# define EXTRACT_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point) \
-{ \
- (real_entry_point) = \
- (* ((SCHEME_OBJECT *) (((char *) (entry_point)) + 2))); \
-}
-
-/* This is the inverse of EXTRACT_CLOSURE_ENTRY_ADDRESS.
- Given a closure's entry point and a code entry point, store the
- code entry point in the closure.
- */
-
-# define STORE_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point) \
-{ \
- (* ((SCHEME_OBJECT *) (((char *) (entry_point)) + 2))) = \
- ((SCHEME_OBJECT) (real_entry_point)); \
-}
-
-#endif /* (COMPILER_PROCESSOR_TYPE == COMPILER_MC68020_TYPE) */
-\f
-#if (COMPILER_PROCESSOR_TYPE == COMPILER_MC68040_TYPE)
-
-/* On the MC68040, closure entry points are aligned, so this is a NOP. */
-
-# define ADJUST_CLOSURE_AT_CALL(entry_point, location) do {} while (0)
-
-/* Manifest closure entry block size.
- Size in bytes of a compiled closure's header excluding the
- TC_MANIFEST_CLOSURE header.
-
- On the 68040, this is the format word and gc offset word a 4-byte-long
- jsr instruction, and 4 bytes for the target address.
-*/
-
-# define COMPILED_CLOSURE_ENTRY_SIZE \
- ((2 * (sizeof (format_word))) + 4 + 4)
-
-/* Manifest closure entry destructuring.
-
- EXTRACT_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point)
- Given the entry point of a closure, extract the `real entry point'
- (the address of the real code of the procedure, ie. one indirection)
- from the closure.
- Note that on some machines this address may be "smeared out" over
- multiple instructions.
-
- STORE_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point)
- is the inverse of EXTRACT_CLOSURE_ENTRY_ADDRESS.
- Given a closure's entry point and a code entry point, store the
- code entry point in the closure.
-*/
-
-# ifndef GC_ELIMINATES_CLOSURE_HOOK
-
-# define EXTRACT_CLOSURE_ENTRY_ADDRESS(real_ep, entry_point) do \
-{ \
- (real_ep) = \
- (* ((SCHEME_OBJECT *) (((char *) (entry_point)) + 4))); \
-} while (0)
-
-# define STORE_CLOSURE_ENTRY_ADDRESS(real_ep, entry_point) do \
-{ \
- (* ((SCHEME_OBJECT *) (((char *) (entry_point)) + 4))) = \
- ((SCHEME_OBJECT) (real_ep)); \
-} while (0)
-
-
-# else /* GC_ELIMINATES_CLOSURE_HOOK */
-
-
-# define EXTRACT_CLOSURE_ENTRY_ADDRESS(real_ep, entry_point) do \
-{ \
- unsigned short *pc = ((unsigned short *) (entry_point)); \
- \
- (real_ep) = \
- (((*pc) == 0x4eae) \
- ? (* ((SCHEME_OBJECT *) (((char *) pc) + 4))) \
- : (* ((SCHEME_OBJECT *) (((char *) pc) + 2)))); \
-} while (0)
-
-/* This version changes the instructions to a more efficient version.
- It is assumed that this is done only by the GC or other processes
- that flush the I-cache at the end.
- */
-
-# define STORE_CLOSURE_ENTRY_ADDRESS(real_ep, entry_point) do \
-{ \
- unsigned short *pc = ((unsigned short *) (entry_point)); \
- \
- *pc++ = 0x4eb9; /* JSR absolute */ \
- (* ((SCHEME_OBJECT *) pc)) = ((SCHEME_OBJECT) (real_ep)); \
-} while (0)
-
-# endif /* GC_ELIMINATES_CLOSURE_HOOK */
-
-
-#endif /* (COMPILER_PROCESSOR_TYPE == COMPILER_MC68040_TYPE) */
-
-
-#ifndef ADJUST_CLOSURE_AT_CALL
-
-# include "ERROR: COMPILER_PROCESSOR_TYPE unknown"
-
-#endif /* ADJUST_CLOSURE_AT_CALL */
-\f
-/* Execute cache entry size size in longwords. The cache itself
- contains both the number of arguments provided by the caller and
- code to jump to the destination address. Before linkage, the cache
- contains the callee's name instead of the jump code.
- */
-
-#define EXECUTE_CACHE_ENTRY_SIZE 2
-
-/* Execute cache destructuring. */
-
-/* Given a target location and the address of the first word of an
- execute cache entry, extract from the cache cell the number of
- arguments supplied by the caller and store it in target. */
-
-/* For the 68K, addresses in bytes from start of cache:
- Before linking
- +0: TC_SYMBOL || symbol address
- +4: TC_FIXNUM || 0
- +6: number of supplied arguments, + 1
- After linking
- +0: jmp $xxx
- +2: xxx
- +6: (unchanged)
-*/
-
-#define EXTRACT_EXECUTE_CACHE_ARITY(target, address) do \
-{ \
- (target) = \
- ((long) (* ((unsigned short *) (((char *) (address)) + 6)))); \
-} while (0)
-
-#define EXTRACT_EXECUTE_CACHE_SYMBOL(target, address) do \
-{ \
- (target) = (* ((SCHEME_OBJECT *) (address))); \
-} while (0)
-
-/* Extract the target address (not the code to get there) from an
- execute cache cell.
- */
-
-#define EXTRACT_EXECUTE_CACHE_ADDRESS(target, address) do \
-{ \
- (target) = (* ((SCHEME_OBJECT *) (((char *) (address)) + 2))); \
-} while (0)
-
-/* This is the inverse of EXTRACT_EXECUTE_CACHE_ADDRESS. */
-
-#define STORE_EXECUTE_CACHE_ADDRESS(address, entry_address) do \
-{ \
- (* ((SCHEME_OBJECT *) (((char *) (address)) + 2))) = \
- ((SCHEME_OBJECT) (entry_address)); \
-} while (0)
-
-/* This stores the fixed part of the instructions leaving the
- destination address and the number of arguments intact. These are
- split apart so the GC can call EXTRACT/STORE...ADDRESS but it does
- NOT need to store the instructions back. On some architectures the
- instructions may change due to GC and then STORE_EXECUTE_CACHE_CODE
- should become a no-op and all of the work is done by
- STORE_EXECUTE_CACHE_ADDRESS instead.
- */
-
-#define STORE_EXECUTE_CACHE_CODE(address) do \
-{ \
- (* ((unsigned short *) (address))) = ((unsigned short) 0x4ef9); \
-} while (0)
-\f
-/* This overrides the definition in cmpint.c because the code below
- depends on knowing it, and is inserted before the definition in
- "cmpint.c". */
-
-#define COMPILER_REGBLOCK_N_FIXED 16
-#define COMPILER_REGBLOCK_N_TEMPS 256
-
-#define COMPILER_REGBLOCK_START_HOOKS COMPILER_REGBLOCK_N_FIXED
-#define COMPILER_REGBLOCK_N_HOOKS 80
-#define COMPILER_HOOK_SIZE 2 /* absolute jsr instruction */
-
-#define COMPILER_REGBLOCK_EXTRA_SIZE \
- (COMPILER_REGBLOCK_N_HOOKS * COMPILER_HOOK_SIZE)
-
-#define A6_TRAMPOLINE_TO_INTERFACE_OFFSET \
- ((COMPILER_REGBLOCK_START_HOOKS + (2 * COMPILER_HOOK_SIZE)) * \
- (sizeof (SCHEME_OBJECT)))
-
-#define A6_CLOSURE_HOOK_OFFSET \
- ((COMPILER_REGBLOCK_START_HOOKS + (37 * COMPILER_HOOK_SIZE)) * \
- (sizeof (SCHEME_OBJECT)))
-
-#ifdef IN_CMPINT_C
-
-#define ASM_RESET_HOOK mc68k_reset_hook
-
-#ifdef CAST_FUNCTION_TO_INT_BUG
-
-#define SETUP_REGISTER(hook) do \
-{ \
- extern unsigned long hook; \
- (* ((unsigned short *) (a6_value + offset))) = 0x4ef9; \
- (* ((unsigned long *) \
- (((unsigned short *) (a6_value + offset)) + 1))) = \
- ((unsigned long) (&hook)); \
- offset += (COMPILER_HOOK_SIZE * (sizeof (SCHEME_OBJECT))); \
-} while (0)
-
-#else /* not CAST_FUNCTION_TO_INT_BUG */
-
-#define SETUP_REGISTER(hook) do \
-{ \
- extern void hook, (void); \
- (* ((unsigned short *) (a6_value + offset))) = 0x4ef9; \
- (* ((unsigned long *) \
- (((unsigned short *) (a6_value + offset)) + 1))) = \
- ((unsigned long) hook); \
- offset += (COMPILER_HOOK_SIZE * (sizeof (SCHEME_OBJECT))); \
-} while (0)
-
-#endif
-\f
-void
-mc68k_reset_hook (void)
-{
- extern void interface_initialize (void);
-
- unsigned char * a6_value = ((unsigned char *) (&Registers[0]));
- int offset = (COMPILER_REGBLOCK_START_HOOKS * (sizeof (SCHEME_OBJECT)));
-
- /* These must match machines/bobcat/lapgen.scm */
-
- SETUP_REGISTER (asm_scheme_to_interface); /* 0 */
- SETUP_REGISTER (asm_scheme_to_interface_jsr); /* 1 */
-
- if (offset != A6_TRAMPOLINE_TO_INTERFACE_OFFSET)
- {
- fprintf (stderr,
- "\nmc68k_reset_hook: A6_TRAMPOLINE_TO_INTERFACE_OFFSET\n");
- Microcode_Termination (TERM_EXIT);
- }
-
- SETUP_REGISTER (asm_trampoline_to_interface); /* 2 */
- SETUP_REGISTER (asm_shortcircuit_apply); /* 3 */
- SETUP_REGISTER (asm_shortcircuit_apply_size_1); /* 4 */
- SETUP_REGISTER (asm_shortcircuit_apply_size_2); /* 5 */
- SETUP_REGISTER (asm_shortcircuit_apply_size_3); /* 6 */
- SETUP_REGISTER (asm_shortcircuit_apply_size_4); /* 7 */
- SETUP_REGISTER (asm_shortcircuit_apply_size_5); /* 8 */
- SETUP_REGISTER (asm_shortcircuit_apply_size_6); /* 9 */
- SETUP_REGISTER (asm_shortcircuit_apply_size_7); /* 10 */
- SETUP_REGISTER (asm_shortcircuit_apply_size_8); /* 11 */
- SETUP_REGISTER (asm_primitive_apply); /* 12 */
- SETUP_REGISTER (asm_primitive_lexpr_apply); /* 13 */
- SETUP_REGISTER (asm_error); /* 14 */
- SETUP_REGISTER (asm_link); /* 15 */
- SETUP_REGISTER (asm_interrupt_closure); /* 16 */
- SETUP_REGISTER (asm_interrupt_dlink); /* 17 */
- SETUP_REGISTER (asm_interrupt_procedure); /* 18 */
- SETUP_REGISTER (asm_interrupt_continuation); /* 19 */
- SETUP_REGISTER (asm_assignment_trap); /* 20 */
- SETUP_REGISTER (asm_reference_trap); /* 21 */
- SETUP_REGISTER (asm_safe_reference_trap); /* 22 */
- SETUP_REGISTER (asm_generic_add); /* 23 */
- SETUP_REGISTER (asm_generic_subtract); /* 24 */
- SETUP_REGISTER (asm_generic_multiply); /* 25 */
- SETUP_REGISTER (asm_generic_divide); /* 26 */
- SETUP_REGISTER (asm_generic_equal); /* 27 */
- SETUP_REGISTER (asm_generic_less); /* 28 */
- SETUP_REGISTER (asm_generic_greater); /* 29 */
- SETUP_REGISTER (asm_generic_increment); /* 30 */
- SETUP_REGISTER (asm_generic_decrement); /* 31 */
- SETUP_REGISTER (asm_generic_zero); /* 32 */
- SETUP_REGISTER (asm_generic_positive); /* 33 */
- SETUP_REGISTER (asm_generic_negative); /* 34 */
- SETUP_REGISTER (asm_primitive_error); /* 35 */
- SETUP_REGISTER (asm_allocate_closure); /* 36 */
-
- if (offset != A6_CLOSURE_HOOK_OFFSET)
- {
- fprintf (stderr, "\nmc68k_reset_hook: A6_CLOSURE_HOOK_OFFSET\n");
- Microcode_Termination (TERM_EXIT);
- }
- else
- { /* 37 */
- unsigned short *pc;
-
- pc = ((unsigned short *) (a6_value + offset));
- *pc++ = 0x2057; /* MOVEA.L (%sp),%a0 */
- *pc++ = 0x2050; /* MOVEA.L (%a0),%a0 */
- *pc++ = 0x5497; /* ADDQ.L &2,(%sp) */
- *pc++ = 0x4ed0; /* JMP (%a0) */
-
- offset += (COMPILER_HOOK_SIZE * (sizeof (SCHEME_OBJECT)));
- }
-
- SETUP_REGISTER (asm_generic_quotient); /* 38 */
- SETUP_REGISTER (asm_generic_remainder); /* 39 */
- SETUP_REGISTER (asm_generic_modulo); /* 40 */
- SETUP_REGISTER (asm_stack_and_interrupt_check_12); /* 41 */
- SETUP_REGISTER (asm_stack_and_interrupt_check_14); /* 42 */
- SETUP_REGISTER (asm_stack_and_interrupt_check_18); /* 43 */
- SETUP_REGISTER (asm_stack_and_interrupt_check_22); /* 44 */
- SETUP_REGISTER (asm_stack_and_interrupt_check_24); /* 45 */
- SETUP_REGISTER (asm_set_interrupt_enables); /* 46 */
-
- FLUSH_CACHE_INITIALIZE ();
- FLUSH_I_CACHE_REGION (&Registers[COMPILER_REGBLOCK_START_HOOKS],
- (COMPILER_REGBLOCK_N_HOOKS * COMPILER_HOOK_SIZE));
-
- interface_initialize ();
- return;
-}
-\f
-#define CLOSURE_ENTRY_WORDS \
- (COMPILED_CLOSURE_ENTRY_SIZE / (sizeof (SCHEME_OBJECT)))
-
-static long closure_chunk = (1024 * CLOSURE_ENTRY_WORDS);
-static long last_chunk_size;
-
-SCHEME_OBJECT *
-allocate_closure (long size)
-{
- long space;
- SCHEME_OBJECT *result;
-
-#if (COMPILER_PROCESSOR_TYPE != COMPILER_MC68040_TYPE)
-
- fprintf (stderr, "\nallocate_closure should not be invoked!\n");
- Microcode_Termination (TERM_COMPILER_DEATH);
-
-#else /* (COMPILER_PROCESSOR_TYPE == COMPILER_MC68040_TYPE) */
-
- space = ((long) GET_CLOSURE_SPACE);
- result = GET_CLOSURE_FREE;
-
- if (size > space)
- {
- SCHEME_OBJECT *start, *ptr, *eptr;
-
- /* Clear remaining words from last chunk so that the heap can be scanned
- forward.
- Do not clear if there was no last chunk (ie. CLOSURE_FREE was NULL).
- */
-
- if (result != (((SCHEME_OBJECT *) NULL) + space))
- {
- start = result;
- if (space < 0)
- start -= size;
- eptr = (result + space);
- for (ptr = start; ptr < eptr; ptr++)
- *ptr = SHARP_F;
-
- /* We can reformat the closures here using last_chunk_size.
- The start of the area is (eptr - last_chunk_size), and all
- closures are contiguous and have appropriate headers.
- */
- }
-
- if ((size <= closure_chunk) && (!GC_NEEDED_P (closure_chunk)))
- {
- start = Free;
- eptr = (start + closure_chunk);
- }
- else
- {
- if (GC_NEEDED_P (size))
- {
- if ((heap_end - Free) < size)
- {
- /* No way to back out -- die. */
-
- fprintf (stderr, "\nC_allocate_closure (%d): No space.\n", size);
- Microcode_Termination (TERM_NO_SPACE);
- /* NOTREACHED */
- }
- REQUEST_GC (0);
- }
- else if (size <= closure_chunk)
- {
- REQUEST_GC (0);
- }
- start = Free;
- eptr = (start + size);
- }
-
- Free = eptr;
- result = start;
- space = (eptr - start);
- last_chunk_size = space; /* To be used next time, maybe. */
-
- for (ptr = start; ptr < eptr; ptr++)
- {
- unsigned short *wptr;
-
- wptr = ((unsigned short *) ptr);
- *wptr++ = 0x4eae; /* JSR n(a6) */
- *wptr = A6_CLOSURE_HOOK_OFFSET; /* n */
- }
-
- PUSH_D_CACHE_REGION (start, space);
- }
-
- SET_CLOSURE_FREE (result + size);
- SET_CLOSURE_SPACE (space - size);
- return (result);
-
-#endif /* (COMPILER_PROCESSOR_TYPE == COMPILER_MC68040_TYPE) */
-}
-
-#endif /* IN_CMPINT_C */
-\f
-/* On the 68K, here's a picture of a trampoline (offset in bytes from
- entry point)
- -12: MANIFEST vector header
- - 8: NON_MARKED header
- - 4: Format word
- - 2: 0xFFF4 (GC Offset to start of block from .+2)
- 0: mov.w #index,%d0
- 4: jsr A6_TRAMPOLINE_TO_INTERFACE_OFFSET(a6)
- 8: trampoline dependent storage (0 - 3 longwords)
-
- TRAMPOLINE_ENTRY_SIZE is the size in longwords of the machine
- dependent portion of a trampoline, including the GC and format
- headers. The code in the trampoline must store an index (used to
- determine which C SCHEME_UTILITY procedure to invoke) in a
- register, jump to "scheme_to_interface" and leave the address of
- the storage following the code in a standard location.
-
- TRAMPOLINE_ENTRY_POINT returns the address of the entry point of a
- trampoline when given the address of the word containing
- the manifest vector header. According to the above picture,
- it would add 12 bytes to its argument.
-
- TRAMPOLINE_STORAGE takes the address of the first instruction in a
- trampoline (not the start of the trampoline block) and returns the
- address of the first storage word in the trampoline.
-
- STORE_TRAMPOLINE_ENTRY gets the address of the first instruction in
- the trampoline and stores the instructions. It also receives the
- index of the C SCHEME_UTILITY to be invoked.
-*/
-
-#define TRAMPOLINE_ENTRY_SIZE 3
-#define TRAMPOLINE_BLOCK_TO_ENTRY 3 /* longwords from MNV to MOV */
-
-#define TRAMPOLINE_ENTRY_POINT(tramp_block) \
- (((SCHEME_OBJECT *) (tramp_block)) + TRAMPOLINE_BLOCK_TO_ENTRY)
-
-#define TRAMPOLINE_STORAGE(tramp_entry) \
- ((((SCHEME_OBJECT *) (tramp_entry)) - TRAMPOLINE_BLOCK_TO_ENTRY) + \
- (2 + TRAMPOLINE_ENTRY_SIZE))
-
-#define STORE_TRAMPOLINE_ENTRY(entry_address, index) do \
-{ \
- unsigned short *start_address, *PC; \
- /* D0 will get the index. JSR will be used to call the assembly \
- language to C SCHEME_UTILITY handler: \
- mov.w #index,%d0 \
- jsr n(a6) \
- */ \
- start_address = ((unsigned short *) (entry_address)); \
- PC = start_address; \
- *PC++ = ((unsigned short) 0x303C); /* mov.w #???,%d0 */ \
- *PC++ = ((unsigned short) index); /* ??? */ \
- *PC++ = ((unsigned short) 0x4EAE); /* jsr n(a6) */ \
- *PC++ = ((unsigned short) A6_TRAMPOLINE_TO_INTERFACE_OFFSET); \
- PUSH_D_CACHE_REGION (start_address, 2); \
-} while (0)
-\f
-/* Derived parameters and macros.
- These macros expect the above definitions to be meaningful.
- If they are not, the macros below may have to be changed as well.
- */
-
-#define COMPILED_ENTRY_OFFSET_WORD(entry) \
- (((format_word *) (entry))[-1])
-#define COMPILED_ENTRY_FORMAT_WORD(entry) \
- (((format_word *) (entry))[-2])
-
-/* The next one assumes 2's complement integers....*/
-#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2))
-#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0)
-
-/* Instructions aligned on word (16 bit) boundaries */
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset)
-#define OFFSET_WORD_TO_BYTE_OFFSET(word) (CLEAR_LOW_BIT (word))
-
-#define MAKE_OFFSET_WORD(entry, block, continue) \
- ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \
- ((char *) (block)))) | \
- ((continue) ? 1 : 0))
-
-#if (EXECUTE_CACHE_ENTRY_SIZE == 2)
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) >> 1)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) << 1)
-#endif
-
-#if (EXECUTE_CACHE_ENTRY_SIZE == 4)
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) >> 2)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) << 2)
-#endif
-
-#if (!defined(EXECUTE_CACHE_COUNT_TO_ENTRIES))
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) / EXECUTE_CACHE_ENTRY_SIZE)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) * EXECUTE_CACHE_ENTRY_SIZE)
-#endif
-\f
-/* The first entry in a cc block is preceeded by 2 headers (block and nmv),
- a format word and a gc offset word. See the early part of the
- TRAMPOLINE picture, above.
- */
-
-#define CC_BLOCK_FIRST_ENTRY_OFFSET \
- (2 * ((sizeof(SCHEME_OBJECT)) + (sizeof(format_word))))
-
-/* Format words */
-
-#define FORMAT_BYTE_EXPR 0xFF
-#define FORMAT_BYTE_COMPLR 0xFE
-#define FORMAT_BYTE_CMPINT 0xFD
-#define FORMAT_BYTE_DLINK 0xFC
-#define FORMAT_BYTE_RETURN 0xFB
-
-#define FORMAT_WORD_EXPR (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_EXPR))
-#define FORMAT_WORD_CMPINT (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_CMPINT))
-#define FORMAT_WORD_RETURN (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_RETURN))
-
-/* This assumes that a format word is at least 16 bits,
- and the low order field is always 8 bits.
- */
-
-#define MAKE_FORMAT_WORD(field1, field2) \
- (((field1) << 8) | ((field2) & 0xff))
-
-#define SIGN_EXTEND_FIELD(field, size) \
- (((field) & ((1 << (size)) - 1)) | \
- ((((field) & (1 << ((size) - 1))) == 0) ? 0 : \
- ((-1) << (size))))
-
-#define FORMAT_WORD_LOW_BYTE(word) \
- (SIGN_EXTEND_FIELD((((unsigned long) (word)) & 0xff), 8))
-
-#define FORMAT_WORD_HIGH_BYTE(word) \
- (SIGN_EXTEND_FIELD((((unsigned long) (word)) >> 8), \
- (((sizeof (format_word)) * CHAR_BIT) - 8)))
-
-#define COMPILED_ENTRY_FORMAT_HIGH(addr) \
- (FORMAT_WORD_HIGH_BYTE(COMPILED_ENTRY_FORMAT_WORD(addr)))
-
-#define COMPILED_ENTRY_FORMAT_LOW(addr) \
- (FORMAT_WORD_LOW_BYTE(COMPILED_ENTRY_FORMAT_WORD(addr)))
-
-#define FORMAT_BYTE_FRAMEMAX 0x7f
-
-#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW
-#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH
-
-#endif /* !SCM_CMPINTMD_H_INCLUDED */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/*
- *
- * Compiled code interface macros.
- *
- * See cmpint.txt for a description of these fields.
- *
- * Specialized for the MIPS R2000/R3000
- */
-
-#ifndef SCM_CMPINTMD_H_INCLUDED
-#define SCM_CMPINTMD_H_INCLUDED 1
-\f
-#ifdef _IRIX
-
-#include <sys/cachectl.h>
-#include <unistd.h>
-
-/* Define this to use the official method of flushing the cache: the
- `mprotect' system call. When not defined, we use `cacheflush',
- which is more efficient. The mprotect method is known to work on
- IRIX 6.3. */
-/* #define USE_MPROTECT_CACHE_FLUSH */
-
-#else /* not _IRIX */
-#ifdef sonyrisc
-
-#include <sys/syscall.h>
-#include <sys/sysmips.h>
-#include <sys/cachectl.h>
-
-extern void syscall ();
-
-#define cacheflush(addr, nbytes, cache) \
- syscall (SYS_sysmips, FLUSH_CACHE, (addr), (nbytes), cache)
-
-#else /* not sonyrisc */
-
-#if 0
-
-/* advertised, but not provided */
-extern void cacheflush();
-
-#else /* not 0 */
-
-#include <sys/syscall.h>
-#include <sys/sysmips.h>
-#include <mips/cachectl.h>
-
-extern void syscall();
-
-#define cacheflush(addr,nbytes,cache) \
- syscall (SYS_sysmips, MIPS_CACHEFLUSH, (addr), (nbytes), (cache))
-
-#endif /* not 0 */
-
-#endif /* not sonyrisc */
-#endif /* not _IRIX */
-
-#ifdef USE_MPROTECT_CACHE_FLUSH
-#define FLUSH_BOTH call_mprotect
-#else
-#define FLUSH_BOTH(addr, size) cacheflush ((addr), (size), BCACHE)
-#endif
-\f
-/* Machine parameters to be set by the user. */
-
-/* Until cmpaux-mips.m4 is updated. */
-#define CMPINT_USE_STRUCS
-
-/* Processor type. Choose a number from the above list, or allocate your own. */
-
-#define COMPILER_PROCESSOR_TYPE COMPILER_MIPS_TYPE
-
-/* Size (in long words) of the contents of a floating point register if
- different from a double. For example, an MC68881 saves registers
- in 96 bit (3 longword) blocks.
- Default is fine for MIPS.
- define COMPILER_TEMP_SIZE 3
-*/
-
-#define COMPILER_REGBLOCK_N_TEMPS 256
-
-/* Descriptor size.
- This is the size of the offset field, and of the format field.
- This definition probably does not need to be changed.
- */
-
-typedef unsigned short format_word;
-\f
-/* Utilities for manipulating absolute subroutine calls.
- On the MIPS this is done with:
- JAL destination
- The low 26 bits of the instruction form the low 28 bits of address,
- and the top 4 bits of the address of the JAL instruction form the
- top 4 bits of the address.
- */
-
-#define EXTRACT_FROM_JAL_INSTR(target, address) \
-{ \
- unsigned long * addr = ((unsigned long *) (address)); \
- unsigned long jal_instr = (*addr); \
- (target) = \
- ((SCHEME_OBJECT) \
- ((((long) (address)) & 0xF0000000) | \
- ((jal_instr & 0x03FFFFFF) << 2))); \
-}
-
-#define JAL_OP (003 << 26)
-#define JAL_INSTR(dest) (JAL_OP | ((dest) >> 2))
-
-#define STORE_JAL_INSTR(entry_point, address) \
-{ \
- unsigned long ep = ((unsigned long) (entry_point)); \
- unsigned long * addr = ((unsigned long *) (address)); \
- if (((((long) addr) & 0xF0000000) \
- != (((long) entry_point) & 0xF0000000)) \
- || ((((long) addr) & 0x3) != 0)) \
- { \
- fprintf (stderr, \
- "\nSTORE_JAL_INSTR: Bad addr in JAL 0x%x, 0x%x\n", \
- addr, ep); \
- } \
- (*addr) = JAL_INSTR (ep & 0x0FFFFFFF); \
-}
-\f
-/* Compiled Code Register Conventions */
-/* This must match the compiler and cmpaux-mips.s */
-
-#define COMP_REG_TEMPORARY 1
-#define COMP_REG_RETURN 2
-#define COMP_REG_STACK 3
-#define COMP_REG_C_ARG_1 4
-#define COMP_REG_C_ARG_2 5
-#define COMP_REG_C_ARG_3 6
-#define COMP_REG_C_ARG_4 7
-#define COMP_REG_MEMTOP 8
-#define COMP_REG_FREE 9
-#define COMP_REG_SCHEME_TO_INTERFACE 10
-#define COMP_REG_DYNAMIC_LINK 11
-
-#define COMP_REG_CLOSURE_FREE 19
-#define COMP_REG_ADDRESS_MASK 20
-#define COMP_REG_REGISTERS 21
-#define COMP_REG_QUAD_MASK 22
-#define COMP_REG_CLOSURE_HOOK 23
-
-#define COMP_REG_TRAMP_INDEX 25
-#define COMP_REG_KERNEL_RESERVED_1 26
-#define COMP_REG_KERNEL_RESERVED_2 27
-#define COMP_REG_C_GLOBALS 28
-#define COMP_REG_C_STACK 29
-#define COMP_REG_LINKAGE 31
-
-/* Interrupt/GC polling. */
-
-/* The length of the GC recovery code that precedes an entry.
- On the MIPS a "addi, jalr, addi" instruction sequence.
- */
-
-#define ENTRY_PREFIX_LENGTH 12
-
-/*
- The instructions for a normal entry should be something like
-
- SLT $at,$FREE,$MEMTOP
- BEQ $at,$0,interrupt
- LW $MEMTOP,REG_BLOCK
-
- For a closure
-
- LUI $at,FROB(TC_CLOSURE) ; temp <- closure tag
- XOR $31,$31,$at ; 31 <- tagged value
- ADDI $SP,$SP,-4 ; push closure
- SW $31,0($SP)
- SLT $at,$FREE,$MEMTOP
- BEQ $at,$0,interrupt
- LW $MEMTOP,REG_BLOCK
-*/
-
-/* A NOP on machines where instructions are longword-aligned. */
-
-#define ADJUST_CLOSURE_AT_CALL(entry_point, location) \
-do { \
-} while (0)
-
-/* Compiled closures */
-
-/* Manifest closure entry block size.
- Size in bytes of a compiled closure's header excluding the
- TC_MANIFEST_CLOSURE header.
-
- On the MIPS this is 2 format_words for the format word and gc
- offset words, and 8 more bytes for 2 instructions.
-
- The two instructions are
-
- JAL destination
- ADDI LINKAGE,LINKAGE,-8
-
- However, there is some trickery involved. Because of cache-line
- sizes and prefetch buffers, the straight-forward allocation does
- not always work, thus closures are allocated from a pre-initialized
- pool where the entries have been initialized to contain
- the following instructions.
-
- JALR LINKAGE,CLOSURE_HOOK
- ADDI LINKAGE,LINKAGE,-8
-
- Note that the JALR instruction is overwritten with the JAL
- instruction, thus although the I-cache may have a stale instruction,
- execution will be correct, since the stale instruction will jump
- to an out-of-line handler which will fetch the correct destination
- from the return-address (through the D cache) and jump there.
- */
-
-#define COMPILED_CLOSURE_ENTRY_SIZE 12
-
-/* Manifest closure entry destructuring.
-
- Given the entry point of a closure, extract the `real entry point'
- (the address of the real code of the procedure, ie. one indirection)
- from the closure.
- On the MIPS, the real entry point is stored directly 8 bytes from
- the closure's address (address of JAL or JALR instruction).
- When using the JAL format, it is also the target address encoded
- in the instruction.
-*/
-
-#define EXTRACT_CLOSURE_ENTRY_ADDRESS(extracted_ep, clos_addr) do \
-{ \
- EXTRACT_FROM_JAL_INSTR (extracted_ep, clos_addr); \
-} while (0)
-
-/* This is the inverse of EXTRACT_CLOSURE_ENTRY_ADDRESS.
- Given a closure's entry point and a code entry point, store the
- code entry point in the closure.
- */
-
-#define STORE_CLOSURE_ENTRY_ADDRESS(ep_to_store, clos_addr) do \
-{ \
- STORE_JAL_INSTR (ep_to_store, clos_addr); \
-} while (0)
-\f
-/* Trampolines
-
- On the MIPS, here's a picture of a trampoline (offset in bytes from
- entry point)
-
- -12: MANIFEST vector header
- - 8: NON_MARKED header
- - 4: Format word
- - 2: 0x6 (GC Offset to start of block from .+2)
- Note the encoding -- divided by 2, low bit for
- extended distances (see OFFSET_WORD_TO_BYTE_OFFSET)
- 0: ADDI TEMP,SCHEME_TO_INTERFACE,-96
- 4: JALR LINKAGE,TEMP
- 8: ADDI TRAMP_INDEX,0,index
- 12: trampoline dependent storage (0 - 3 longwords)
-
- TRAMPOLINE_ENTRY_SIZE is the size in longwords of the machine
- dependent portion of a trampoline, including the GC and format
- headers. The code in the trampoline must store an index (used to
- determine which C SCHEME_UTILITY procedure to invoke) in a
- register, jump to "scheme_to_interface" and leave the address of
- the storage following the code in a standard location.
-
- TRAMPOLINE_ENTRY_POINT returns the address of the entry point of a
- trampoline when given the address of the word containing
- the manifest vector header. According to the above picture,
- it would add 12 bytes to its argument.
-
- TRAMPOLINE_STORAGE takes the address of the first instruction in a
- trampoline (not the start of the trampoline block) and returns the
- address of the first storage word in the trampoline.
-
- STORE_TRAMPOLINE_ENTRY gets the address of the first instruction in
- the trampoline and stores the instructions. It also receives the
- index of the C SCHEME_UTILITY to be invoked.
-*/
-
-#define TRAMPOLINE_ENTRY_SIZE 4
-#define TRAMPOLINE_BLOCK_TO_ENTRY 3
-
-#define TRAMPOLINE_ENTRY_POINT(tramp_block) \
- (((SCHEME_OBJECT *) (tramp_block)) + TRAMPOLINE_BLOCK_TO_ENTRY)
-
-#define TRAMPOLINE_STORAGE(tramp_entry) \
- ((((SCHEME_OBJECT *) (tramp_entry)) - TRAMPOLINE_BLOCK_TO_ENTRY) + \
- (2 + TRAMPOLINE_ENTRY_SIZE))
-
-#define SPECIAL_OPCODE 000
-#define ADDI_OPCODE 010
-
-#define OP(OPCODE) (OPCODE << 26)
-#define SPECIAL_OP OP(SPECIAL_OPCODE)
-#define ADDI_OP OP(ADDI_OPCODE)
-
-#define JALR_OP (SPECIAL_OP | (011))
-#define JALR_SRC(n) ((n & 0x1F) << 21)
-#define JALR_DST(n) ((n & 0x1F) << 11)
-#define JALR(d,s) (JALR_OP|JALR_SRC(s)|JALR_DST(d))
-
-#define ADDI_SRC(n) ((n & 0x1F) << 21)
-#define ADDI_DST(n) ((n & 0x1F) << 16)
-#define ADDI_IMMED(n) (n & 0xFFFF)
-#define ADDI(d,s,imm) (ADDI_OP|ADDI_SRC(s)|ADDI_DST(d)|ADDI_IMMED(imm))
-
-#define STORE_TRAMPOLINE_ENTRY(entry_address, index) \
-{ unsigned long *PC; \
- PC = ((unsigned long *) (entry_address)); \
- PC[0] = ADDI(COMP_REG_TEMPORARY, COMP_REG_SCHEME_TO_INTERFACE, -96); \
- PC[1] = JALR(COMP_REG_LINKAGE, COMP_REG_TEMPORARY); \
- PC[2] = ADDI(COMP_REG_TRAMP_INDEX, 0, (4*index)); \
- /* assumes index fits in 16 bits */ \
- FLUSH_BOTH (PC, (3 * sizeof (unsigned long))); \
-}
-\f
-/* Execute cache entries.
-
- Execute cache entry size size in longwords. The cache itself
- contains both the number of arguments provided by the caller and
- code to jump to the destination address. Before linkage, the cache
- contains the callee's name instead of the jump code.
-
- On MIPS: 2 instructions, the last being a NO-OP (ADDI with
- destination 0) containing a fixnum representing the number of
- arguments in the lower 16 bits.
- */
-
-#define EXECUTE_CACHE_ENTRY_SIZE 2
-
-/* Execute cache destructuring. */
-
-/* Given a target location and the address of the first word of an
- execute cache entry, extract from the cache cell the number of
- arguments supplied by the caller and store it in target. */
-
-/* For the MIPS (little endian), addresses in bytes from the start of
- the cache:
-
- Before linking
- +0: TC_SYMBOL || symbol address
- +4: number of supplied arguments, +1
- +6: TC_FIXNUM || 0
-
- After linking
- +0: JAL destination
- +4: (unchanged)
- +6: ADDI 0, arg count
-
- (big endian):
-
- Before linking
- +0: TC_SYMBOL || symbol address
- +4: TC_FIXNUM || 0
- +6: number of supplied arguments, +1
-
- After linking
- +0: JAL destination
- +4: ADDI 0, arg count
- +6: (unchanged)
-
-*/
-
-#ifdef MIPSEL
-
-/* Little-endian MIPS, i.e. DecStations. */
-
-#define MIPS_CACHE_ARITY_OFFSET 2
-#define MIPS_CACHE_CODE_OFFSET 7
-
-#else /* not MIPSEL */
-
-/* Big-endian MIPS, e.g. SGI and Sony. */
-
-#define MIPS_CACHE_ARITY_OFFSET 3
-#define MIPS_CACHE_CODE_OFFSET 4
-
-#endif /* not MIPSEL */
-
-#define EXTRACT_EXECUTE_CACHE_ARITY(target, address) \
-{ \
- (target) = \
- ((long) \
- (((unsigned short *) (address)) [MIPS_CACHE_ARITY_OFFSET])); \
-}
-
-#define EXTRACT_EXECUTE_CACHE_SYMBOL(target, address) \
-{ \
- (target) = (* (((SCHEME_OBJECT *) (address)))); \
-}
-
-/* Extract the target address (not the code to get there) from an
- execute cache cell.
- */
-
-#define EXTRACT_EXECUTE_CACHE_ADDRESS(target, address) \
-{ \
- EXTRACT_FROM_JAL_INSTR (target, address); \
-}
-
-/* This is the inverse of EXTRACT_EXECUTE_CACHE_ADDRESS.
- On the MIPS it must flush the I-cache, but there is no
- need to flush the ADDI instruction, which is a NOP.
- */
-
-#define STORE_EXECUTE_CACHE_ADDRESS(address, entry) \
-{ \
- STORE_JAL_INSTR (entry, address); \
-}
-
-/* This stores the fixed part of the instructions leaving the
- destination address and the number of arguments intact. These are
- split apart so the GC can call EXTRACT/STORE...ADDRESS but it does
- NOT need to store the instructions back. On some architectures the
- instructions may change due to GC and then STORE_EXECUTE_CACHE_CODE
- should become a no-op and all of the work is done by
- STORE_EXECUTE_CACHE_ADDRESS instead.
- */
-
-#define STORE_EXECUTE_CACHE_CODE(address) \
-{ \
- char * opcode_addr = (((char *) (address)) + MIPS_CACHE_CODE_OFFSET); \
- (*opcode_addr) = (ADDI_OPCODE << 2); \
-}
-
-/* This flushes the Scheme portion of the I-cache.
- It is used after a GC or disk-restore.
- It's needed because the GC has moved code around, and closures
- and execute cache cells have absolute addresses that the
- processor might have old copies of.
- */
-
-#define FLUSH_I_CACHE() do \
-{ \
- FLUSH_BOTH (constant_start, \
- (((unsigned long) heap_end) \
- - ((unsigned long) constant_start))); \
-} while (0)
-
-/* This flushes a region of the I-cache.
- It is used after updating an execute cache while running.
- Not needed during GC because FLUSH_I_CACHE will be used.
- */
-
-#define FLUSH_I_CACHE_REGION(address, nwords) do \
-{ \
- FLUSH_BOTH ((address), ((sizeof (long)) * (nwords))); \
-} while (0)
-
-/* This guarantees that a newly-written section of address space
- has its values propagated to main memory so that i-stream fetches
- will see the new values.
- The first and last byte are flushed from the i-cache in case
- the written region overlaps with already-executed areas.
- */
-
-#ifdef USE_MPROTECT_CACHE_FLUSH
-
-#define PUSH_D_CACHE_REGION(address, nwords) do \
-{ \
- FLUSH_BOTH ((address), ((sizeof (long)) * (nwords))); \
-} while (0)
-
-#else /* not USE_MPROTECT_CACHE_FLUSH */
-
-#define PUSH_D_CACHE_REGION(address, nwords) do \
-{ \
- unsigned long _addr = ((unsigned long) (address)); \
- unsigned long _nbytes = ((sizeof (long)) * (nwords)); \
- cacheflush (((void *) _addr), _nbytes, DCACHE); \
- cacheflush (((void *) _addr), 1, ICACHE); \
- cacheflush (((void *) (_addr + (_nbytes - 1))), 1, ICACHE); \
-} while (0)
-
-#endif /* not USE_MPROTECT_CACHE_FLUSH */
-
-#ifdef IN_CMPINT_C
-
-static void
-interface_initialize_C (void)
-{
- extern void interface_initialize (void);
-
- /* Prevent the OS from "fixing" unaligned accesses.
- Within Scheme, they are a BUG, and should fault.
-
- Is this defined for all the OSs?
- */
-#ifdef MIPSEL
- syscall (SYS_sysmips, MIPS_FIXADE, 0);
-#endif
- interface_initialize ();
- return;
-}
-
-#ifdef _IRIX6
-
-#include <sys/mman.h>
-#include <sys/types.h>
-
-#define VM_PROT_SCHEME (PROT_READ | PROT_WRITE | PROT_EXEC)
-
-static void * mprotect_start;
-static unsigned long mprotect_size;
-
-static void
-call_mprotect_1 (void * start, unsigned long size)
-{
- if ((mprotect (start, size, VM_PROT_SCHEME)) != 0)
- {
- perror ("unable to change memory protection");
- fprintf (stderr, "mprotect(0x%lx, %d (0x%lx), 0x%lx)\n",
- start, size, size, VM_PROT_SCHEME);
- Microcode_Termination (TERM_EXIT);
- /*NOTREACHED*/
- }
-}
-
-#ifdef USE_MPROTECT_CACHE_FLUSH
-void
-call_mprotect (void * start, unsigned long size)
-{
- unsigned long pagesize = (getpagesize ());
- unsigned long istart = ((unsigned long) start);
- unsigned long pstart = ((istart / pagesize) * pagesize);
- call_mprotect_1 (((void *) pstart), (istart - pstart));
-}
-#endif /* USE_MPROTECT_CACHE_FLUSH */
-
-void *
-irix_heap_malloc (long size)
-{
- int pagesize = (getpagesize ());
- void * area = (malloc (size + pagesize));
- if (area == 0)
- return (0);
- mprotect_start
- = ((void *)
- (((((unsigned long) area) + (pagesize - 1)) / pagesize) * pagesize));
- mprotect_size = size;
- call_mprotect_1 (mprotect_start, mprotect_size);
- return (mprotect_start);
-}
-
-#endif /* _IRIX6 */
-
-#define ASM_RESET_HOOK interface_initialize_C
-
-#define CLOSURE_ENTRY_WORDS \
- (COMPILED_CLOSURE_ENTRY_SIZE / (sizeof (SCHEME_OBJECT)))
-
-static long closure_chunk = (1024 * CLOSURE_ENTRY_WORDS);
-
-/* The apparently random instances of the number 3 below arise from
- the convention that free_closure always points to a JAL instruction
- with (at least) 3 unused words preceding it.
- In this way, if there is enough space, we can use free_closure
- as the address of a new uni- or multi-closure.
-
- The code below (in the initialization loop) depends on knowing that
- CLOSURE_ENTRY_WORDS is 3.
-
- Random hack: ADDI instructions look like TC_TRUE objects, thus of the
- pre-initialized words, only the JALR looks like a pointer object
- (an SCODE-QUOTE). Since there is exactly one JALR of waste between
- closures, and it is always 3 words before free_closure,
- the code for uni-closure allocation (in mips.m4) bashes that word
- with 0 (SHARP_F) to make the heap parseable.
- */
-
-/* size in Scheme objects of the block we need to allocate. */
-
-void
-allocate_closure (long size)
-{
- long space;
- SCHEME_OBJECT * free_closure, * limit;
-
- free_closure = GET_CLOSURE_FREE;
- limit = GET_CLOSURE_SPACE;
- space = ((limit - free_closure) + 3);
-
- /* Bump up to a multiple of CLOSURE_ENTRY_WORDS.
- Otherwise clearing by the allocation code may clobber
- a different word.
- */
- size = (CLOSURE_ENTRY_WORDS
- * ((size + (CLOSURE_ENTRY_WORDS - 1))
- / CLOSURE_ENTRY_WORDS));
- if (size > space)
- {
- long chunk_size;
- SCHEME_OBJECT *ptr;
-
- /* Make the heap be parseable forward by protecting the waste
- in the last chunk.
- */
-
- if ((space > 0) && (free_closure != ((SCHEME_OBJECT *) NULL)))
- free_closure[-3] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (space - 1)));
-
- free_closure = Free;
- if ((size <= closure_chunk) && (!GC_NEEDED_P (closure_chunk)))
- limit = (free_closure + closure_chunk);
- else
- {
- if (GC_NEEDED_P (size))
- {
- if ((heap_end - Free) < size)
- {
- /* No way to back out -- die. */
- fprintf (stderr, "\nC_allocate_closure (%d): No space.\n", size);
- Microcode_Termination (TERM_NO_SPACE);
- /* NOTREACHED */
- }
- REQUEST_GC (0);
- }
- else if (size <= closure_chunk)
- REQUEST_GC (0);
- limit = (free_closure + size);
- }
- Free = limit;
- chunk_size = (limit - free_closure);
-
- ptr = free_closure;
- while (ptr < limit)
- {
- *ptr++ = (JALR (COMP_REG_LINKAGE, COMP_REG_CLOSURE_HOOK));
- *ptr++ = (ADDI (COMP_REG_LINKAGE, COMP_REG_LINKAGE, -8));
- *ptr++ = SHARP_F;
- }
- PUSH_D_CACHE_REGION (free_closure, chunk_size);
- SET_CLOSURE_SPACE (limit);
- SET_CLOSURE_FREE (free_closure + 3);
- }
-}
-
-#endif /* IN_CMPINT_C */
-\f
-/* Derived parameters and macros.
-
- These macros expect the above definitions to be meaningful.
- If they are not, the macros below may have to be changed as well.
- */
-
-#define COMPILED_ENTRY_OFFSET_WORD(entry) (((format_word *) (entry)) [-1])
-#define COMPILED_ENTRY_FORMAT_WORD(entry) (((format_word *) (entry)) [-2])
-
-/* The next one assumes 2's complement integers....*/
-#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2))
-#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0)
-
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> 1)
-#define OFFSET_WORD_TO_BYTE_OFFSET(word) ((CLEAR_LOW_BIT (word)) << 1)
-
-#define MAKE_OFFSET_WORD(entry, block, continue) \
- ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \
- ((char *) (block)))) | \
- ((continue) ? 1 : 0))
-
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \
- ((count) >> 1)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \
- ((entries) << 1)
-\f
-/* The first entry in a cc block is preceeded by 2 headers (block and nmv),
- a format word and a gc offset word. See the early part of the
- TRAMPOLINE picture, above.
- */
-
-#define CC_BLOCK_FIRST_ENTRY_OFFSET \
- (2 * ((sizeof(SCHEME_OBJECT)) + (sizeof(format_word))))
-
-/* Format words */
-
-#define FORMAT_BYTE_EXPR 0xFF
-#define FORMAT_BYTE_COMPLR 0xFE
-#define FORMAT_BYTE_CMPINT 0xFD
-#define FORMAT_BYTE_DLINK 0xFC
-#define FORMAT_BYTE_RETURN 0xFB
-
-#define FORMAT_WORD_EXPR (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_EXPR))
-#define FORMAT_WORD_CMPINT (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_CMPINT))
-#define FORMAT_WORD_RETURN (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_RETURN))
-
-/* This assumes that a format word is at least 16 bits,
- and the low order field is always 8 bits.
- */
-
-#define MAKE_FORMAT_WORD(field1, field2) \
- (((field1) << 8) | ((field2) & 0xff))
-
-#define SIGN_EXTEND_FIELD(field, size) \
- (((field) & ((1 << (size)) - 1)) | \
- ((((field) & (1 << ((size) - 1))) == 0) ? 0 : \
- ((-1) << (size))))
-
-#define FORMAT_WORD_LOW_BYTE(word) \
- (SIGN_EXTEND_FIELD ((((unsigned long) (word)) & 0xff), 8))
-
-#define FORMAT_WORD_HIGH_BYTE(word) \
- (SIGN_EXTEND_FIELD \
- ((((unsigned long) (word)) >> 8), \
- (((sizeof (format_word)) * CHAR_BIT) - 8)))
-
-#define COMPILED_ENTRY_FORMAT_HIGH(addr) \
- (FORMAT_WORD_HIGH_BYTE (COMPILED_ENTRY_FORMAT_WORD (addr)))
-
-#define COMPILED_ENTRY_FORMAT_LOW(addr) \
- (FORMAT_WORD_LOW_BYTE (COMPILED_ENTRY_FORMAT_WORD (addr)))
-
-#define FORMAT_BYTE_FRAMEMAX 0x7f
-
-#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW
-#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH
-
-#endif /* !SCM_CMPINTMD_H_INCLUDED */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/*
- *
- * Compiled code interface macros.
- *
- * See cmpint.txt for a description of these fields.
- *
- * Specialized for the Vax architecture.
- */
-
-#ifndef SCM_CMPINTMD_H_INCLUDED
-#define SCM_CMPINTMD_H_INCLUDED 1
-\f
-/* Machine parameters to be set by the user. */
-
-/* Until cmpaux-vax.m4 is updated. */
-#define CMPINT_USE_STRUCS
-
-/* Processor type. Choose a number from the above list, or allocate your own. */
-
-#define COMPILER_PROCESSOR_TYPE COMPILER_VAX_TYPE
-
-/* Size (in long words) of the contents of a floating point register if
- different from a double. Default is fine.
-
- #define COMPILER_TEMP_SIZE 2
-
-*/
-
-/* Descriptor size.
- This is the size of the offset field, and of the format field.
- This definition probably does not need to be changed.
- */
-
-typedef unsigned short format_word;
-\f
-/* The length of the GC recovery code that precedes an entry.
- On the Vax a "movl s^code,r0; jsb b^n(r10)" sequence.
- */
-
-#define ENTRY_PREFIX_LENGTH 6
-
-/* Multi-closure magic
- On the Vax, when closures are invoked, the closure corresponding
- to the first entry point is what's needed on the top of the stack.
- Note that it is needed for environment only, not for code.
- The closure code does an
- ADDL2 &magic-constant,(SP)
- on entry, to bump the current entry point (after the JSB instruction)
- to the correct place.
- This code emulates that operation by extracting the magic constant
- from the closure code, and adjusting the address by 6 as if the
- JSB instruction had just been executed.
- It is used when interrupts are disabled, in order not to get into a loop.
- Note that if closure entry points were always longword-aligned, there
- would be no need for this nonsense.
- */
-
-#define ADJUST_CLOSURE_AT_CALL(entry_point, location) \
-do { \
- long magic_constant; \
- \
- magic_constant = (* ((long *) (((char *) (entry_point)) + 2))); \
- (location) = ((SCHEME_OBJECT) \
- ((((long) (OBJECT_ADDRESS (location))) + 6) + \
- magic_constant)); \
-} while (0)
-
-/* Manifest closure entry block size.
- Size in bytes of a compiled closure's header excluding the
- TC_MANIFEST_CLOSURE header.
-
- On the Vax, this is the format word and gc offset word and 6 bytes
- more for the jsb instruction.
-*/
-
-#define COMPILED_CLOSURE_ENTRY_SIZE \
-((2 * (sizeof (format_word))) + 6)
-
-/* Manifest closure entry destructuring.
-
- Given the entry point of a closure, extract the `real entry point'
- (the address of the real code of the procedure, ie. one indirection)
- from the closure.
- Note that on some machines this address may be "smeared out" over
- multiple instructions.
-*/
-
-#define EXTRACT_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point) \
-{ \
- (real_entry_point) = \
- (* ((SCHEME_OBJECT *) (((char *) (entry_point)) + 2))); \
-}
-
-/* This is the inverse of EXTRACT_CLOSURE_ENTRY_ADDRESS.
- Given a closure's entry point and a code entry point, store the
- code entry point in the closure.
- */
-
-#define STORE_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point) \
-{ \
- (* ((SCHEME_OBJECT *) (((char *) (entry_point)) + 2))) = \
- ((SCHEME_OBJECT) (real_entry_point)); \
-}
-\f
-/* Execute cache entry size size in longwords. The cache itself
- contains both the number of arguments provided by the caller and
- code to jump to the destination address. Before linkage, the cache
- contains the callee's name instead of the jump code.
- */
-
-#define EXECUTE_CACHE_ENTRY_SIZE 2
-
-/* Execute cache destructuring. */
-
-/* Given a target location and the address of the first word of an
- execute cache entry, extract from the cache cell the number of
- arguments supplied by the caller and store it in target. */
-
-/* For the Vax, addresses in bytes from start of cache:
- Before linking
- +0: TC_FIXNUM || arity
- +4: TC_SYMBOL || symbol address
- After linking
- +0: arity
- +2: jmp @&
- +4: xxx
- Note that arity stays in the same place since Vaxen are little-endian.
-*/
-
-#define EXTRACT_EXECUTE_CACHE_ARITY(target, address) \
-{ \
- (target) = ((long) (* ((unsigned short *) (address)))); \
-}
-
-#define EXTRACT_EXECUTE_CACHE_SYMBOL(target, address) \
-{ \
- (target) = (* (((SCHEME_OBJECT *) (address)) + 1)); \
-}
-
-/* Extract the target address (not the code to get there) from an
- execute cache cell.
- */
-
-#define EXTRACT_EXECUTE_CACHE_ADDRESS(target, address) \
-{ \
- (target) = (* (((SCHEME_OBJECT *) (address)) + 1)); \
-}
-
-/* This is the inverse of EXTRACT_EXECUTE_CACHE_ADDRESS. */
-
-#define STORE_EXECUTE_CACHE_ADDRESS(address, entry_address) \
-{ \
- (* (((SCHEME_OBJECT *) (address)) + 1)) = \
- ((SCHEME_OBJECT) (entry_address)); \
-}
-
-/* This stores the fixed part of the instructions leaving the
- destination address and the number of arguments intact. These are
- split apart so the GC can call EXTRACT/STORE...ADDRESS but it does
- NOT need to store the instructions back. On some architectures the
- instructions may change due to GC and then STORE_EXECUTE_CACHE_CODE
- should become a no-op and all of the work is done by
- STORE_EXECUTE_CACHE_ADDRESS instead.
- */
-
-#define STORE_EXECUTE_CACHE_CODE(address) \
-{ \
- (* (((unsigned short *) (address)) + 1)) = \
- ((unsigned short) 0x9f17); \
-}
-\f
-/* This overrides the definition in cmpint.c because the code below
- depends on knowing it, and is inserted before the definition in
- cmpint.c
- */
-
-#define COMPILER_REGBLOCK_N_FIXED 16
-#define COMPILER_REGBLOCK_N_TEMPS 256
-
-#define COMPILER_REGBLOCK_N_HOOKS 40
-#define COMPILER_HOOK_SIZE 2 /* jsb @& + pad */
-
-#define COMPILER_REGBLOCK_EXTRA_SIZE \
-(COMPILER_REGBLOCK_N_HOOKS * COMPILER_HOOK_SIZE)
-
-#define R10_TRAMPOLINE_TO_INTERFACE_OFFSET \
-((COMPILER_REGBLOCK_N_FIXED + (2 * COMPILER_HOOK_SIZE)) * \
- (sizeof (SCHEME_OBJECT)))
-
-#ifdef IN_CMPINT_C
-
-#define ASM_RESET_HOOK vax_reset_hook
-
-#ifdef CAST_FUNCTION_TO_INT_BUG
-
-#define SETUP_REGISTER(hook) \
-{ \
- extern unsigned long hook; \
- (* ((unsigned short *) (r10_value + offset))) = \
- ((unsigned short) 0x9f17); \
- (* ((unsigned long *) \
- (((unsigned short *) (r10_value + offset)) + 1))) = \
- ((unsigned long) (&hook)); \
- offset += (COMPILER_HOOK_SIZE * (sizeof (SCHEME_OBJECT))); \
-}
-
-#else /* not CAST_FUNCTION_TO_INT_BUG */
-
-#define SETUP_REGISTER(hook) \
-{ \
- extern void hook (void); \
- (* ((unsigned short *) (r10_value + offset))) = \
- ((unsigned short) 0x9f17); \
- (* ((unsigned long *) \
- (((unsigned short *) (r10_value + offset)) + 1))) = \
- ((unsigned long) hook); \
- offset += (COMPILER_HOOK_SIZE * (sizeof (SCHEME_OBJECT))); \
-}
-
-#endif
-
-void
-vax_reset_hook (void)
-{
- unsigned char * r10_value = ((unsigned char *) (&Registers[0]));
- int offset = (COMPILER_REGBLOCK_N_FIXED * (sizeof (SCHEME_OBJECT)));
-
- /* These must match machines/vax/lapgen.scm */
- SETUP_REGISTER (asm_scheme_to_interface); /* 0 */
- SETUP_REGISTER (asm_scheme_to_interface_jsb); /* 1 */
- SETUP_REGISTER (asm_trampoline_to_interface); /* 2 */
-#if 0
- /* Not yet written for the Vax */
- SETUP_REGISTER (asm_shortcircuit_apply); /* 3 */
- SETUP_REGISTER (asm_shortcircuit_apply_size_1); /* 4 */
- SETUP_REGISTER (asm_shortcircuit_apply_size_2); /* 5 */
- SETUP_REGISTER (asm_shortcircuit_apply_size_3); /* 6 */
- SETUP_REGISTER (asm_shortcircuit_apply_size_4); /* 7 */
- SETUP_REGISTER (asm_shortcircuit_apply_size_5); /* 8 */
- SETUP_REGISTER (asm_shortcircuit_apply_size_6); /* 9 */
- SETUP_REGISTER (asm_shortcircuit_apply_size_7); /* 10 */
- SETUP_REGISTER (asm_shortcircuit_apply_size_8); /* 11 */
- SETUP_REGISTER (asm_primitive_apply); /* 12 */
- SETUP_REGISTER (asm_primitive_lexpr_apply); /* 13 */
- SETUP_REGISTER (asm_error); /* 14 */
- SETUP_REGISTER (asm_link); /* 15 */
- SETUP_REGISTER (asm_interrupt_closure); /* 16 */
- SETUP_REGISTER (asm_interrupt_dlink); /* 17 */
- SETUP_REGISTER (asm_interrupt_procedure); /* 18 */
- SETUP_REGISTER (asm_interrupt_continuation); /* 19 */
- SETUP_REGISTER (asm_assignment_trap); /* 20 */
- SETUP_REGISTER (asm_reference_trap); /* 21 */
- SETUP_REGISTER (asm_safe_reference_trap); /* 22 */
- SETUP_REGISTER (asm_generic_add); /* 23 */
- SETUP_REGISTER (asm_generic_subtract); /* 24 */
- SETUP_REGISTER (asm_generic_multiply); /* 25 */
- SETUP_REGISTER (asm_generic_divide); /* 26 */
- SETUP_REGISTER (asm_generic_equal); /* 27 */
- SETUP_REGISTER (asm_generic_less); /* 28 */
- SETUP_REGISTER (asm_generic_greater); /* 29 */
- SETUP_REGISTER (asm_generic_increment); /* 30 */
- SETUP_REGISTER (asm_generic_decrement); /* 31 */
- SETUP_REGISTER (asm_generic_zero); /* 32 */
- SETUP_REGISTER (asm_generic_positive); /* 33 */
- SETUP_REGISTER (asm_generic_negative); /* 34 */
- SETUP_REGISTER (asm_primitive_error); /* 35 */
-#endif /* 0 */
- return;
-}
-
-#endif /* IN_CMPINT_C */
-\f
-/* On the Vax, here's a picture of a trampoline (offset in bytes from
- entry point)
- -12: MANIFEST vector header
- - 8: NON_MARKED header
- - 4: Format word
- - 2: 0x12 (GC Offset to start of block from .+2)
- 0: movl S^code,r0
- 3: jsb B^R10_TRAMPOLINE_TO_INTERFACE_OFFSET(r10)
- 6: 0
- 8: trampoline dependent storage (0 - 3 longwords)
-
- TRAMPOLINE_ENTRY_SIZE is the size in longwords of the machine
- dependent portion of a trampoline, including the GC and format
- headers. The code in the trampoline must store an index (used to
- determine which C SCHEME_UTILITY procedure to invoke) in a
- register, jump to "scheme_to_interface" and leave the address of
- the storage following the code in a standard location.
-
- TRAMPOLINE_ENTRY_POINT returns the address of the entry point of a
- trampoline when given the address of the word containing
- the manifest vector header. According to the above picture,
- it would add 12 bytes to its argument.
-
- TRAMPOLINE_STORAGE takes the address of the first instruction in a
- trampoline (not the start of the trampoline block) and returns the
- address of the first storage word in the trampoline.
-
- STORE_TRAMPOLINE_ENTRY gets the address of the first instruction in
- the trampoline and stores the instructions. It also receives the
- index of the C SCHEME_UTILITY to be invoked.
-*/
-
-#define TRAMPOLINE_ENTRY_SIZE 3
-#define TRAMPOLINE_BLOCK_TO_ENTRY 3 /* longwords from MNV to MOVL */
-
-#define TRAMPOLINE_ENTRY_POINT(tramp_block) \
- (((SCHEME_OBJECT *) (tramp_block)) + TRAMPOLINE_BLOCK_TO_ENTRY)
-
-#define TRAMPOLINE_STORAGE(tramp_entry) \
- ((((SCHEME_OBJECT *) tramp_entry) - TRAMPOLINE_BLOCK_TO_ENTRY) + \
- (2 + TRAMPOLINE_ENTRY_SIZE))
-
-#define STORE_TRAMPOLINE_ENTRY(entry_address, code) \
-{ \
- unsigned long *PC; \
- /* r0 will get the code. JSB will be used to call the assembly \
- language to C SCHEME_UTILITY handler: \
- movl S^code,r0 \
- jsb B^R10_TRAMPOLINE_TO_INTERFACE_OFFSET(R10) \
- */ \
- PC = ((unsigned long *) entry_address); \
- *PC++ = (((unsigned long) 0x165000d0) + \
- (((unsigned long) (code)) << 8)); \
- *PC++ = (((unsigned long) 0x000000aa) + \
- (((unsigned long) R10_TRAMPOLINE_TO_INTERFACE_OFFSET) \
- << 8)); \
-}
-\f
-/* Derived parameters and macros.
- These macros expect the above definitions to be meaningful.
- If they are not, the macros below may have to be changed as well.
- */
-
-#define COMPILED_ENTRY_OFFSET_WORD(entry) \
- (((format_word *) (entry))[-1])
-#define COMPILED_ENTRY_FORMAT_WORD(entry) \
- (((format_word *) (entry))[-2])
-
-/* The next one assumes 2's complement integers....*/
-#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2))
-#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0)
-
-/* Instructions aligned on byte boundaries */
-#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1)
-#define OFFSET_WORD_TO_BYTE_OFFSET(word) ((CLEAR_LOW_BIT (word)) >> 1)
-
-#define MAKE_OFFSET_WORD(entry, block, continue) \
- ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \
- ((char *) (block)))) | \
- ((continue) ? 1 : 0))
-
-#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) ((count) >> 1)
-#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) ((entries) << 1)
-\f
-/* The first entry in a cc block is preceeded by 2 headers (block and nmv),
- a format word and a gc offset word. See the early part of the
- TRAMPOLINE picture, above.
- */
-
-#define CC_BLOCK_FIRST_ENTRY_OFFSET \
- (2 * ((sizeof(SCHEME_OBJECT)) + (sizeof(format_word))))
-
-/* Format words */
-
-#define FORMAT_BYTE_EXPR 0xFF
-#define FORMAT_BYTE_COMPLR 0xFE
-#define FORMAT_BYTE_CMPINT 0xFD
-#define FORMAT_BYTE_DLINK 0xFC
-#define FORMAT_BYTE_RETURN 0xFB
-
-#define FORMAT_WORD_EXPR (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_EXPR))
-#define FORMAT_WORD_CMPINT (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_CMPINT))
-#define FORMAT_WORD_RETURN (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_RETURN))
-
-/* This assumes that a format word is at least 16 bits,
- and the low order field is always 8 bits.
- */
-
-#define MAKE_FORMAT_WORD(field1, field2) \
- (((field1) << 8) | ((field2) & 0xff))
-
-#define SIGN_EXTEND_FIELD(field, size) \
- (((field) & ((1 << (size)) - 1)) | \
- ((((field) & (1 << ((size) - 1))) == 0) ? 0 : \
- ((-1) << (size))))
-
-#define FORMAT_WORD_LOW_BYTE(word) \
- (SIGN_EXTEND_FIELD((((unsigned long) (word)) & 0xff), 8))
-
-#define FORMAT_WORD_HIGH_BYTE(word) \
- (SIGN_EXTEND_FIELD((((unsigned long) (word)) >> 8), \
- (((sizeof (format_word)) * CHAR_BIT) - 8)))
-
-#define COMPILED_ENTRY_FORMAT_HIGH(addr) \
- (FORMAT_WORD_HIGH_BYTE(COMPILED_ENTRY_FORMAT_WORD(addr)))
-
-#define COMPILED_ENTRY_FORMAT_LOW(addr) \
- (FORMAT_WORD_LOW_BYTE(COMPILED_ENTRY_FORMAT_WORD(addr)))
-
-#define FORMAT_BYTE_FRAMEMAX 0x7f
-
-#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW
-#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH
-
-#endif /* !SCM_CMPINTMD_H_INCLUDED */
MIT_SCHEME_NATIVE_CODE([${enable_native_code}],[${host_cpu}])
-if test x${mit_scheme_native_code} = xhppa; then
- GC_HEAD_FILES="${GC_HEAD_FILES} hppacach.h"
-fi
-
AUXDIR_NAME=mit-scheme-${mit_scheme_native_code}
EXE_NAME=mit-scheme-${mit_scheme_native_code}
typedef enum
{
- COMPILER_NONE_TYPE,
- COMPILER_MC68020_TYPE,
- COMPILER_VAX_TYPE,
- COMPILER_SPECTRUM_TYPE,
- COMPILER_OLD_MIPS_TYPE,
- COMPILER_MC68040_TYPE,
- COMPILER_SPARC_TYPE,
- COMPILER_RS6000_TYPE,
- COMPILER_MC88K_TYPE,
- COMPILER_IA32_TYPE,
- COMPILER_ALPHA_TYPE,
- COMPILER_MIPS_TYPE,
- COMPILER_C_TYPE,
- COMPILER_SVM_TYPE,
- COMPILER_X86_64_TYPE,
+ COMPILER_NONE_TYPE = 0,
+ COMPILER_IA32_TYPE = 9,
+ COMPILER_C_TYPE = 12,
+ COMPILER_SVM_TYPE = 13,
+ COMPILER_X86_64_TYPE = 14,
} cc_arch_t;
#include "cmpintmd-config.h"
/* SHARP_F is a magic value:
Typecode TC_CONSTANT, high datum bits #b100, low datum bits are the top
- TYPE_CODE_LENGTH bits of HPPA_QUAD_BIT
-
- SHARP_F is stored in gr5 for access by compiled code. This allows
- us to generate #F and test against #F quickly, and also to use gr5
- for compiled OBJECT->ADDRESS operations. If we ever go to 5bit
- typecodes we will be able to dispense with this overloading.
-
- See also cmpauxmd/hppa.m4. */
-
+ TYPE_CODE_LENGTH bits of HPPA_QUAD_BIT */
#define SHARP_F 0x22000010
#endif /* hp9000s800 */
#define CC_BKPT_PROCEDURE 0x3F /* Procedure to invoke when
compiled code hits a
breakpoint. */
-/* #F or a vector of 4 elements:
- - A boolean flag
- - A vector of objects to find
- - A vector to fill with references
- - A boolean flag = do you want a vector of all obj heads returned
- in this slot. If so, slot 0 will be a boolean flag indicating if
- there may be more. */
-#define GC_WABBIT_DESCRIPTOR 0x40
+/* #define GC_WABBIT_DESCRIPTOR 0x40 */
#define CALLBACK_HANDLER 0x41
/* 0x3D */ "pc-sample/prob-comp-table", \
/* 0x3E */ "pc-sample/ufo-table", \
/* 0x3F */ "compiled-code-bkpt-handler", \
- /* 0x40 */ "gc-wabbit-descwiptor", \
+ /* 0x40 */ 0 , \
/* 0x41 */ "callback-handler", \
/* 0x42 */ 0, \
/* 0x43 */ 0, \
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#include <stdio.h>
-#include <math.h>
-#include <sys/stat.h>
-#include <memory.h>
-#include <nlist.h>
-#include <unistd.h>
-#include <errno.h>
-
-#include "hppacach.h"
-
-#define true 1
-#define false 0
-#define boolean int
-
-#ifdef DEBUG
-
-#define DEBUGGING(stmt) stmt
-
-#else
-
-#define DEBUGGING(stmt) do \
-{ \
-} while (0)
-
-#endif
-\f
-/* File that contains the symbol table for the kernel */
-
-char * kernel_filenames [] =
-{
- "/hp-ux",
- "/stand/vmunix",
- 0
-};
-
-/* File where the kernel image lives */
-
-#define KERNEL_MEMORY_FILE "/dev/kmem"
-
-#define UTSNAME_SYMBOL "utsname"
-#define PDC_CACHE_SYMBOL "cache_tlb_parms"
-
-static struct utsname sysinfo;
-static char **the_argv;
-
-void
-io_error (pname, format, fname)
- char * pname;
- char * format;
- char * fname;
-{
- char errmsg[MAXPATHLEN + 257];
- char errstring[MAXPATHLEN + 257];
-
- sprintf (&errmsg[0], format, fname);
- sprintf (&errstring[0], "%s: %s: %s", (the_argv[0]), pname, (&errmsg[0]));
- perror (&errstring[0]);
-}
-
-void
-io_lose (pname, format, fname)
- char * pname;
- char * format;
- char * fname;
-{
- io_error (pname, format, fname);
- exit (1);
-}
-\f
-struct kernel_locations
-{
- long utsname_location;
- long pdc_cache_location;
-};
-
-struct nlist nl[] =
-{
- { UTSNAME_SYMBOL },
- { PDC_CACHE_SYMBOL },
- { 0 },
-};
-
-static char *
-choose_kernel_file ()
-{
- char ** p = kernel_filenames;
- while (1)
- {
- struct stat s;
- if ((stat ((*p), (&s))) == 0)
- return (*p);
- p += 1;
- }
- fprintf (stderr, "Unable to find kernel.\n");
- fflush (stderr);
- exit (1);
-}
-
-void
-read_nlist (kloc)
- struct kernel_locations *kloc;
-{
- char * kernel_filename = (choose_kernel_file ());
- DEBUGGING (printf ("reading nlist...\n"));
-
- if ((nlist (kernel_filename, nl)) != 0)
- io_lose ("read_nlist", "failed on both %s and %s", kernel_filename);
-
- DEBUGGING (printf ("reading nlist done.\n"));
-
- kloc->utsname_location = nl[0].n_value;
- kloc->pdc_cache_location = nl[1].n_value;
-
- DEBUGGING (printf ("utsname location = 0x%x\n", kloc->utsname_location));
- DEBUGGING (printf ("pdc_cache location = 0x%x\n", kloc->pdc_cache_location));
-}
-
-void
-read_parameters (pdc_cache)
- struct pdc_cache_dump *pdc_cache;
-{
- struct kernel_locations kloc;
- struct utsname kerninfo;
- int kmem = (open (KERNEL_MEMORY_FILE, O_RDONLY));
- if (kmem < 0)
- io_lose ("read_parameters", "open (%s) failed", KERNEL_MEMORY_FILE);
- read_nlist (&kloc);
- if ((lseek (kmem, kloc.utsname_location, SEEK_SET)) < 0)
- io_lose ("read_parameters", "lseek (%s) failed", KERNEL_MEMORY_FILE);
- if ((read (kmem, (&kerninfo), (sizeof (kerninfo)))) !=
- (sizeof (kerninfo)))
- io_lose ("read_parameters", "read (%s) failed", KERNEL_MEMORY_FILE);
- if ((memcmp ((&kerninfo), (&sysinfo), (sizeof (sysinfo)))) != 0)
- fprintf (stderr, "read_parameters: uname and %s in %s differ.\n",
- kloc.utsname_location, KERNEL_MEMORY_FILE);
- strncpy (pdc_cache->hardware, (kerninfo.machine),
- (sizeof (kerninfo.machine)));
- if ((lseek (kmem, (kloc.pdc_cache_location), SEEK_SET)) < 0)
- io_lose ("read_parameters", "lseek (%s) failed", KERNEL_MEMORY_FILE);
- if ((read (kmem, &pdc_cache->cache_format,
- (sizeof (pdc_cache->cache_format)))) !=
- (sizeof (pdc_cache->cache_format)))
- io_lose ("read_parameters", "read (%s) failed", KERNEL_MEMORY_FILE);
- if ((close (kmem)) < 0)
- io_lose ("read_parameters", "close (%s) failed", KERNEL_MEMORY_FILE);
- return;
-}
-\f
-void
-print_sel (sel, name, pattern, op)
- unsigned int sel;
- char *name;
- char *pattern;
- char *op;
-{
- switch (sel)
- {
- case 0:
- printf ("\n Both ");
- printf (pattern, "D");
- printf (" and ");
- printf (pattern, "I");
- printf (" must be used to %s.", op);
- break;
-
- case 1:
- printf ("\n Only ");
- printf (pattern, "D");
- printf (" needs to be used to %s.", op);
- break;
-
- case 2:
- printf ("\n Only ");
- printf (pattern, "I");
- printf (" needs to be used to %s.", op);
- break;
-
- case 3:
- printf ("\n Either ");
- printf (pattern, "D");
- printf (" or ");
- printf (pattern, "I");
- printf (" can be used to %s.", op);
- break;
-
- default:
- fprintf (stderr, "\n Bad %s value %d.", name, (sel));
- break;
- }
-
- return;
-}
-
-void
-print_cst (cst)
- unsigned int cst;
-{
- switch (cst)
- {
- case 0:
- printf ("\n It does not issue coherent operations.");
- break;
-
- case 1:
- printf ("\n It issues coherent operations.");
- break;
-
- default:
- printf ("\n It has a reserved cst value %d.", (cst));
- break;
- }
- return;
-}
-\f
-void
-print_cache (info, name, write_only_p)
- struct cache_info *info;
- char *name;
- boolean write_only_p;
-{
- printf ("\n");
-
- /* First print the user-readable information as a comment. */
-
- printf (" /*\n");
- printf (" %s-cache information:\n", name);
-
- printf ("\tsize\t\t%ld bytes (%ld K).\n", info->size, (info->size / 1024));
- printf ("\tconf\t\t0x%08lx\n", info->conf.word);
- printf ("\tbase\t\t0x%lx\n", info->base);
- printf ("\tstride\t\t%ld bytes.\n", info->stride);
- printf ("\tcount\t\t%ld entries.\n", info->count);
- printf ("\tloop\t\t%ld association%s per entry.\n",
- info->loop, ((info->loop == 1) ? "" : "s"));
-
- printf ("\tblock size\t%d line%s.\n",
- info->conf.bits.block,
- ((info->conf.bits.block == 1) ? "" : "s"));
- printf ("\tline size\t%d (16-byte units).\n", info->conf.bits.line);
-
- if (write_only_p)
- {
- printf (" It is a read-only cache.");
- }
- else if (info->conf.bits.wt == 0)
- {
- printf (" It is a write-to cache.");
- }
- else
- {
- printf (" It is a write-through cache.");
- }
-
- print_cst ((info->conf.bits.cst));
- print_sel ((info->conf.bits.fsel), "f-sel", "F%sC", "flush");
-
- /* Now print the C-readable information. */
-
- printf ("\n */\n");
- printf (" { %ld, 0x%08lx, 0x%lx, %ld, %ld, %ld }",
- info->size, info->conf.word, info->base,
- info->stride, info->count, info->loop);
-
- return;
-}
-\f
-void
-print_tlb (info, name)
- struct tlb_info *info;
- char *name;
-{
- printf ("\n");
-
- /* First print the user-readable information as a comment. */
-
- printf (" /*\n");
- printf (" %s-TLB information:\n", name);
-
- printf ("\tsize\t\t%ld entries (%ld K).\n",
- info->size, (info->size / 1024));
- printf ("\tconf\t\t0x%08lx\n", info->conf.word);
- printf ("\tsp_base\t\t0x%lx\n", info->sp_base);
- printf ("\tsp_stride\t%ld\n", info->sp_stride);
- printf ("\tsp_count\t%ld\n", info->sp_count);
- printf ("\toff_base\t0x%lx\n", info->off_base);
- printf ("\toff_stride\t%ld\n", info->off_stride);
- printf ("\toff_count\t%ld\n", info->off_count);
- printf ("\tloop\t\t%ld association%s per entry.",
- info->loop, ((info->loop == 1) ? "" : "s"));
-
- print_cst ((info->conf.bits.cst));
- print_sel ((info->conf.bits.psel), "p-sel", "P%sTLB", "purge");
-
- /* Now print the C-readable information. */
-
- printf ("\n */\n");
- printf (" { %ld, 0x%08lx, 0x%lx, %ld, %ld, 0x%lx, %ld, %ld, %ld }",
- info->size, info->conf.word,
- info->sp_base, info->sp_stride, info->sp_count,
- info->off_base, info->off_stride, info->off_count,
- info->loop);
-
- return;
-}
-\f
-void
-print_parameters (pdc_cache, node_p)
- struct pdc_cache_dump *pdc_cache;
- int node_p;
-{
- struct pdc_cache_result *io_arch_format;
-
- if (node_p)
- {
- printf ("/* Emacs: Use -*- C -*- mode when editting this file. */\n\n");
- printf ("{\n /* Cache description for %s, an HP PA %s processor. */\n\n",
- sysinfo.nodename,
- sysinfo.machine);
- }
- else
- {
- printf ("{\n");
- }
-
- io_arch_format = ((struct pdc_cache_result *) &(pdc_cache->cache_format));
-
- printf (" \"%s\",\n\n {", pdc_cache->hardware);
-
- print_cache (&(io_arch_format->I_info), "I", true);
- printf (",");
- print_cache (&(io_arch_format->D_info), "D", false);
- printf (",");
-
- print_tlb (&(io_arch_format->IT_info), "I");
- printf (",");
- print_tlb (&(io_arch_format->DT_info), "D");
- printf ("\n");
-
- printf (" }};\n");
- return;
-}
-
-int
-search_pdc_database (fd, pdc_cache, filename)
- int fd;
- struct pdc_cache_dump * pdc_cache;
- char * filename;
-{
- while (1)
- {
- int scr =
- (read (fd, ((char *) pdc_cache), (sizeof (struct pdc_cache_dump))));
- if (scr < 0)
- io_lose ("search_pdc_database", "read (%s) failed", filename);
- if (scr != (sizeof (struct pdc_cache_dump)))
- {
- if (scr == 0)
- return (0);
- fprintf (stderr, "%s: %s: incomplete read (%s)\n",
- (the_argv[0]), "search_pdc_database", filename);
- fflush (stderr);
- exit (1);
- }
- if ((strcmp ((sysinfo . machine), (pdc_cache -> hardware))) == 0)
- return (1);
- }
-}
-\f
-#define MODE_ADD 0
-#define MODE_REPLACE 1
-#define MODE_PRINT 2
-
-void
-update_pdc_database (mode, pdc_cache, filename)
- int mode;
- struct pdc_cache_dump * pdc_cache;
- char * filename;
-{
- int write_p = 1;
- int fd = (open (filename, (O_RDWR | O_CREAT), 0666));
- if (fd < 0)
- {
- if (errno != EACCES)
- io_lose ("update_pdc_database", "open (%s) failed", filename);
- fd = (open (filename, O_RDONLY));
- if (fd < 0)
- io_lose ("update_pdc_database", "open (%s) failed", filename);
- else
- {
- write_p = 0;
- if (mode != MODE_PRINT)
- fprintf (stderr, "Data base \"%s\" is write-protected.\n", filename);
- }
- }
- if (! (search_pdc_database (fd, pdc_cache, filename)))
- {
- read_parameters (pdc_cache);
- if (!write_p && (mode != MODE_PRINT))
- printf ("Could not write information to data base.\n");
- else
- {
- int scr =
- (write (fd, ((char *) pdc_cache), (sizeof (struct pdc_cache_dump))));
- if (scr < 0)
- io_lose ("update_pdc_database", "write (%s) failed", filename);
- if (scr != (sizeof (struct pdc_cache_dump)))
- {
- fprintf (stderr, "%s: %s: incomplete write (%s)\n",
- (the_argv[0]), "update_pdc_database", filename);
- fflush (stderr);
- exit (1);
- }
- }
- }
- else
- {
- struct pdc_cache_dump new_cache_s, * new_cache;
-
- new_cache = & new_cache_s;
- read_parameters (new_cache);
- if ((memcmp (new_cache, pdc_cache, (sizeof (struct pdc_cache_dump))))
- == 0)
- {
- if (mode != MODE_PRINT)
- printf ("Correct information for model %s is present in data base.\n",
- &new_cache->hardware[0]);
- }
- else
- {
- printf ("Data base contains different information for model %s.\n",
- &new_cache->hardware[0]);
- switch (mode)
- {
- case MODE_REPLACE:
- {
- if (write_p)
- {
- printf ("Keeping the new information.\n");
- if ((lseek (fd, (- (sizeof (struct pdc_cache_dump))), SEEK_CUR))
- == -1)
- io_lose ("update_pdc_database", "lseek (%s) failed", filename);
- if ((write (fd, new_cache, (sizeof (struct pdc_cache_dump))))
- != (sizeof (struct pdc_cache_dump)))
- io_lose ("update_pdc_database", "write (%s) failed", filename);
- break;
- }
- }
-
- case MODE_ADD:
- {
- printf ("Keeping the old information.\n");
- break;
- }
-
- case MODE_PRINT:
- {
- printf ("New information:\n");
- print_parameters (new_cache, 1);
- printf ("\n\nOld information:\n");
- }
- default:
- fprintf (stderr, "%s error. Unknown mode %d.\n", the_argv[0], mode);
- }
- }
- }
- if ((close (fd)) < 0)
- io_lose ("update_pdc_database", "close (%s) failed", filename);
- return;
-}
-\f
-void
-print_pdc_database (filename)
- char * filename;
-{
- struct pdc_cache_dump pdc_cache_s, *pdc_cache;
- int fd = (open (filename, (O_RDONLY), 0666));
- int first;
-
- if (fd < 0)
- io_lose ("print_pdc_database", "open (%s) failed", filename);
-
- pdc_cache = &pdc_cache_s;
- first = 1;
- while (1)
- {
- int scr =
- (read (fd, ((char *) pdc_cache), (sizeof (struct pdc_cache_dump))));
- if (scr < 0)
- io_lose ("print_pdc_database", "read (%s) failed", filename);
- if (scr != (sizeof (struct pdc_cache_dump)))
- {
- if (scr == 0)
- break;
- fprintf (stderr, "%s: %s: incomplete read (%s)\n",
- (the_argv[0]), "print_pdc_database", filename);
- fflush (stderr);
- exit (1);
- }
-
- if (first == 0)
- {
- putchar ('\f');
- putchar ('\n');
- }
- else
- {
- first = 0;
- }
- print_parameters (pdc_cache, 0);
- }
-
- if ((close (fd)) < 0)
- io_lose ("print_pdc_database", "close (%s) failed", filename);
-}
-
-void
-read_stored_parameters (pdc_cache, filename)
- struct pdc_cache_dump * pdc_cache;
- char * filename;
-{
- int fd = (open (filename, (O_RDONLY), 0));
- if (fd < 0)
- io_lose ("read_stored_parameters", "open (%s) failed", filename);
- if (! (search_pdc_database (fd, pdc_cache, filename)))
- {
- fprintf (stderr, "%s: %s: unable to find entry in models database\n",
- (the_argv[0]), "read_stored_parameters");
- fflush (stderr);
- exit (1);
- }
- if ((close (fd)) < 0)
- io_lose ("read_stored_parameters", "close (%s) failed", filename);
-}
-
-void
-verify_parameters (new_pdc_cache, old_pdc_cache)
- struct pdc_cache_dump *new_pdc_cache, *old_pdc_cache;
-{
- boolean lose;
-
- lose = false;
- if ((strcmp (new_pdc_cache->hardware, old_pdc_cache->hardware)) != 0)
- {
- lose = true;
- printf ("Model differs: old = %s; current = %s.\n",
- new_pdc_cache->hardware, old_pdc_cache->hardware);
- }
- if ((memcmp (&new_pdc_cache->cache_format,
- &old_pdc_cache->cache_format,
- (sizeof (struct pdc_cache_result)))) != 0)
- {
- lose = true;
- printf ("The stored cache information is incorrect.\n");
- }
- if (!lose)
- {
- printf ("The stored cache information is correct.\n");
- }
- return;
-}
-\f
-void
-usage ()
-{
- fprintf (stderr, "usage: one of:\n");
- fprintf (stderr, " %s -add FILENAME\n", (the_argv[0]));
- fprintf (stderr, " %s -replace FILENAME\n", (the_argv[0]));
- fprintf (stderr, " %s -verify FILENAME\n", (the_argv[0]));
- fprintf (stderr, " %s -print FILENAME\n", (the_argv[0]));
- fprintf (stderr, " %s -printall FILENAME\n", (the_argv[0]));
- fflush (stderr);
- exit (1);
-}
-
-void
-main (argc, argv)
- int argc;
- char **argv;
-{
- the_argv = argv;
- if ((uname (&sysinfo)) < 0)
- io_lose ("main", "uname failed", 0);
- if (argc != 3)
- usage ();
- {
- char * keyword = (argv[1]);
- char * filename = (argv[2]);
- if ((strcmp (keyword, "-add")) == 0)
- {
- struct pdc_cache_dump pdc_cache;
- update_pdc_database (MODE_ADD, (&pdc_cache), filename);
- }
- else if ((strcmp (keyword, "-replace")) == 0)
- {
- struct pdc_cache_dump pdc_cache;
- update_pdc_database (MODE_REPLACE, (&pdc_cache), filename);
- }
- else if ((strcmp (keyword, "-print")) == 0)
- {
- struct pdc_cache_dump pdc_cache;
- update_pdc_database (MODE_PRINT, (&pdc_cache), filename);
- print_parameters (&pdc_cache, 1);
- }
- else if ((strcmp (keyword, "-printall")) == 0)
- {
- print_pdc_database (filename);
- }
- else if ((strcmp (keyword, "-verify")) == 0)
- {
- struct pdc_cache_dump old_pdc_cache;
- struct pdc_cache_dump new_pdc_cache;
- read_stored_parameters ((&old_pdc_cache), filename);
- read_parameters (&new_pdc_cache);
- verify_parameters ((&new_pdc_cache), (&old_pdc_cache));
- }
- else
- usage ();
- }
- exit (0);
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#ifndef HPPACACHE_H /* Prevent multiple inclusion */
-#define HPPACACHE_H
-
-#define I_CACHE 1
-#define D_CACHE 2
-
-#include <fcntl.h>
-
-#ifdef __HPUX__
-#include <sys/utsname.h>
-#include <sys/types.h>
-#include <sys/param.h>
-#include <machine/cpu.h>
-#include <machine/pdc_rqsts.h>
-#endif /* __HPUX__ */
-\f
-/* PDC_CACHE (processor dependent code cache information call)
- return data destructuring.
-
- This is the same information as in machine/pdc_rqsts.h
- pdc_cache_rtn_block, but with fields as defined in the PDC_CACHE
- section of the I/O Architecture Manual.
-
- The main difference is the cache configuration field.
- Which is correct? */
-
-union cache_conf
-{
- unsigned long word;
- struct
- {
- unsigned block: 8;
- unsigned line: 3;
- unsigned res1: 2;
- unsigned wt: 1;
- unsigned fsel: 2;
- unsigned cst: 3;
- unsigned res2: 11;
- unsigned hv: 2;
- } bits;
-};
-
-struct cache_info
-{
- unsigned long size; /* in bytes */
- union cache_conf conf; /* format description */
- unsigned long base; /* start address */
- unsigned long stride; /* in bytes */
- unsigned long count; /* number of entries */
- unsigned long loop; /* set associativity */
-};
-
-union tlb_conf
-{
- unsigned long word;
- struct
- {
- unsigned res1: 12;
- unsigned psel: 2;
- unsigned hv1: 1;
- unsigned res2: 1;
- unsigned cst: 3;
- unsigned res3: 11;
- unsigned hv2: 2;
- } bits;
-};
-
-struct tlb_info
-{
- unsigned long size; /* number of entries */
- union tlb_conf conf; /* format description */
- unsigned long sp_base; /* space parameters */
- unsigned long sp_stride;
- unsigned long sp_count;
- unsigned long off_base; /* offset parameters */
- unsigned long off_stride;
- unsigned long off_count;
- unsigned long loop; /* set associativity */
-};
-
-struct pdc_cache_result
-{
- struct cache_info I_info;
- struct cache_info D_info;
- struct tlb_info IT_info;
- struct tlb_info DT_info;
-};
-
-#ifdef __HPUX__
-
-# define HARDWARE_SIZE sizeof (utsname.machine)
-
-#else /* not __HPUX__ */
-/* Presumably BSD */
-
-# define HARDWARE_SIZE 9
-
-struct pdc_cache_rtn_block
-{
- struct pdc_cache_result goodies;
- int filler[2];
-};
-
-#endif /* __HPUX__ */
-
-struct pdc_cache_dump
-{
- char hardware[HARDWARE_SIZE];
- struct pdc_cache_rtn_block cache_format;
-};
-
-#endif /* HPPACACHE_H */
+++ /dev/null
-{
- "9000/850",
-
- {
- /*
- I-cache information:
- size 131072 bytes (128 K).
- conf 0x01410002
- base 0x0
- stride 32 bytes.
- count 2048 entries.
- loop 2 associations per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a read-only cache.
- It does not issue coherent operations.
- Only FDC needs to be used to flush.
- */
- { 131072, 0x01410002, 0x0, 32, 2048, 2 },
- /*
- D-cache information:
- size 131072 bytes (128 K).
- conf 0x01410002
- base 0x0
- stride 32 bytes.
- count 2048 entries.
- loop 2 associations per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a write-to cache.
- It does not issue coherent operations.
- Only FDC needs to be used to flush.
- */
- { 131072, 0x01410002, 0x0, 32, 2048, 2 },
- /*
- I-TLB information:
- size 2048 entries (2 K).
- conf 0x00020001
- sp_base 0x0
- sp_stride 1
- sp_count 1
- off_base 0x0
- off_stride 2048
- off_count 2048
- loop 1 association per entry.
- It does not issue coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 2048, 0x00020001, 0x0, 1, 1, 0x0, 2048, 2048, 1 },
- /*
- D-TLB information:
- size 2048 entries (2 K).
- conf 0x00020001
- sp_base 0x0
- sp_stride 1
- sp_count 1
- off_base 0x0
- off_stride 2048
- off_count 2048
- loop 1 association per entry.
- It does not issue coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 2048, 0x00020001, 0x0, 1, 1, 0x0, 2048, 2048, 1 }
- }};
-\f
-{
- "9000/835",
-
- {
- /*
- I-cache information:
- size 131072 bytes (128 K).
- conf 0x01410002
- base 0x0
- stride 32 bytes.
- count 2048 entries.
- loop 2 associations per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a read-only cache.
- It does not issue coherent operations.
- Only FDC needs to be used to flush.
- */
- { 131072, 0x01410002, 0x0, 32, 2048, 2 },
- /*
- D-cache information:
- size 131072 bytes (128 K).
- conf 0x01410002
- base 0x0
- stride 32 bytes.
- count 2048 entries.
- loop 2 associations per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a write-to cache.
- It does not issue coherent operations.
- Only FDC needs to be used to flush.
- */
- { 131072, 0x01410002, 0x0, 32, 2048, 2 },
- /*
- I-TLB information:
- size 2048 entries (2 K).
- conf 0x00020001
- sp_base 0x0
- sp_stride 1
- sp_count 1
- off_base 0x0
- off_stride 2048
- off_count 2048
- loop 1 association per entry.
- It does not issue coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 2048, 0x00020001, 0x0, 1, 1, 0x0, 2048, 2048, 1 },
- /*
- D-TLB information:
- size 2048 entries (2 K).
- conf 0x00020001
- sp_base 0x0
- sp_stride 1
- sp_count 1
- off_base 0x0
- off_stride 2048
- off_count 2048
- loop 1 association per entry.
- It does not issue coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 2048, 0x00020001, 0x0, 1, 1, 0x0, 2048, 2048, 1 }
- }};
-\f
-{
- "9000/834",
-
- {
- /*
- I-cache information:
- size 131072 bytes (128 K).
- conf 0x01410002
- base 0x0
- stride 32 bytes.
- count 2048 entries.
- loop 2 associations per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a read-only cache.
- It does not issue coherent operations.
- Only FDC needs to be used to flush.
- */
- { 131072, 0x01410002, 0x0, 32, 2048, 2 },
- /*
- D-cache information:
- size 131072 bytes (128 K).
- conf 0x01410002
- base 0x0
- stride 32 bytes.
- count 2048 entries.
- loop 2 associations per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a write-to cache.
- It does not issue coherent operations.
- Only FDC needs to be used to flush.
- */
- { 131072, 0x01410002, 0x0, 32, 2048, 2 },
- /*
- I-TLB information:
- size 2048 entries (2 K).
- conf 0x00020001
- sp_base 0x0
- sp_stride 1
- sp_count 1
- off_base 0x0
- off_stride 2048
- off_count 2048
- loop 1 association per entry.
- It does not issue coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 2048, 0x00020001, 0x0, 1, 1, 0x0, 2048, 2048, 1 },
- /*
- D-TLB information:
- size 2048 entries (2 K).
- conf 0x00020001
- sp_base 0x0
- sp_stride 1
- sp_count 1
- off_base 0x0
- off_stride 2048
- off_count 2048
- loop 1 association per entry.
- It does not issue coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 2048, 0x00020001, 0x0, 1, 1, 0x0, 2048, 2048, 1 }
- }};
-\f
-{
- "9000/720",
-
- {
- /*
- I-cache information:
- size 131072 bytes (128 K).
- conf 0x01402000
- base 0x0
- stride 32 bytes.
- count 4096 entries.
- loop 1 association per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a read-only cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 131072, 0x01402000, 0x0, 32, 4096, 1 },
- /*
- D-cache information:
- size 262144 bytes (256 K).
- conf 0x01402000
- base 0x0
- stride 32 bytes.
- count 8192 entries.
- loop 1 association per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a write-to cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 262144, 0x01402000, 0x0, 32, 8192, 1 },
- /*
- I-TLB information:
- size 96 entries (0 K).
- conf 0x00012000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 96, 0x00012000, 0x0, 0, 1, 0x0, 0, 1, 1 },
- /*
- D-TLB information:
- size 96 entries (0 K).
- conf 0x00002000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 96, 0x00002000, 0x0, 0, 1, 0x0, 0, 1, 1 }
- }};
-\f
-{
- "9000/730",
-
- {
- /*
- I-cache information:
- size 131072 bytes (128 K).
- conf 0x01402000
- base 0x0
- stride 32 bytes.
- count 4096 entries.
- loop 1 association per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a read-only cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 131072, 0x01402000, 0x0, 32, 4096, 1 },
- /*
- D-cache information:
- size 262144 bytes (256 K).
- conf 0x01402000
- base 0x0
- stride 32 bytes.
- count 8192 entries.
- loop 1 association per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a write-to cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 262144, 0x01402000, 0x0, 32, 8192, 1 },
- /*
- I-TLB information:
- size 96 entries (0 K).
- conf 0x00012000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 96, 0x00012000, 0x0, 0, 1, 0x0, 0, 1, 1 },
- /*
- D-TLB information:
- size 96 entries (0 K).
- conf 0x00002000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 96, 0x00002000, 0x0, 0, 1, 0x0, 0, 1, 1 }
- }};
-\f
-{
- "9000/750",
-
- {
- /*
- I-cache information:
- size 262144 bytes (256 K).
- conf 0x01402000
- base 0x0
- stride 32 bytes.
- count 8192 entries.
- loop 1 association per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a read-only cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 262144, 0x01402000, 0x0, 32, 8192, 1 },
- /*
- D-cache information:
- size 262144 bytes (256 K).
- conf 0x01402000
- base 0x0
- stride 32 bytes.
- count 8192 entries.
- loop 1 association per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a write-to cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 262144, 0x01402000, 0x0, 32, 8192, 1 },
- /*
- I-TLB information:
- size 96 entries (0 K).
- conf 0x00012000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 96, 0x00012000, 0x0, 0, 1, 0x0, 0, 1, 1 },
- /*
- D-TLB information:
- size 96 entries (0 K).
- conf 0x00002000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 96, 0x00002000, 0x0, 0, 1, 0x0, 0, 1, 1 }
- }};
-\f
-{
- "9000/710",
-
- {
- /*
- I-cache information:
- size 32768 bytes (32 K).
- conf 0x01402000
- base 0x0
- stride 32 bytes.
- count 1024 entries.
- loop 1 association per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a read-only cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 32768, 0x01402000, 0x0, 32, 1024, 1 },
- /*
- D-cache information:
- size 65536 bytes (64 K).
- conf 0x01402000
- base 0x0
- stride 32 bytes.
- count 2048 entries.
- loop 1 association per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a write-to cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 65536, 0x01402000, 0x0, 32, 2048, 1 },
- /*
- I-TLB information:
- size 96 entries (0 K).
- conf 0x00012000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 96, 0x00012000, 0x0, 0, 1, 0x0, 0, 1, 1 },
- /*
- D-TLB information:
- size 96 entries (0 K).
- conf 0x00002000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 96, 0x00002000, 0x0, 0, 1, 0x0, 0, 1, 1 }
- }};
-\f
-{
- "9000/877",
-
- {
- /*
- I-cache information:
- size 262144 bytes (256 K).
- conf 0x01402000
- base 0x0
- stride 32 bytes.
- count 8192 entries.
- loop 1 association per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a read-only cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 262144, 0x01402000, 0x0, 32, 8192, 1 },
- /*
- D-cache information:
- size 262144 bytes (256 K).
- conf 0x01402000
- base 0x0
- stride 32 bytes.
- count 8192 entries.
- loop 1 association per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a write-to cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 262144, 0x01402000, 0x0, 32, 8192, 1 },
- /*
- I-TLB information:
- size 96 entries (0 K).
- conf 0x00012000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 96, 0x00012000, 0x0, 0, 1, 0x0, 0, 1, 1 },
- /*
- D-TLB information:
- size 96 entries (0 K).
- conf 0x00002000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 96, 0x00002000, 0x0, 0, 1, 0x0, 0, 1, 1 }
- }};
-\f
-{
- "9000/705",
-
- {
- /*
- I-cache information:
- size 32768 bytes (32 K).
- conf 0x01402000
- base 0x0
- stride 32 bytes.
- count 1024 entries.
- loop 1 association per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a read-only cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 32768, 0x01402000, 0x0, 32, 1024, 1 },
- /*
- D-cache information:
- size 65536 bytes (64 K).
- conf 0x01402000
- base 0x0
- stride 32 bytes.
- count 2048 entries.
- loop 1 association per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a write-to cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 65536, 0x01402000, 0x0, 32, 2048, 1 },
- /*
- I-TLB information:
- size 96 entries (0 K).
- conf 0x00012000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 96, 0x00012000, 0x0, 0, 1, 0x0, 0, 1, 1 },
- /*
- D-TLB information:
- size 96 entries (0 K).
- conf 0x00002000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 96, 0x00002000, 0x0, 0, 1, 0x0, 0, 1, 1 }
- }};
-\f
-{
- "9000/735",
-
- {
- /*
- I-cache information:
- size 262144 bytes (256 K).
- conf 0x71402000
- base 0x0
- stride 32 bytes.
- count 8192 entries.
- loop 1 association per entry.
- block size 113 lines.
- line size 2 (16-byte units).
- It is a read-only cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 262144, 0x71402000, 0x0, 32, 8192, 1 },
- /*
- D-cache information:
- size 262144 bytes (256 K).
- conf 0x71402000
- base 0x0
- stride 32 bytes.
- count 8192 entries.
- loop 1 association per entry.
- block size 113 lines.
- line size 2 (16-byte units).
- It is a write-to cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 262144, 0x71402000, 0x0, 32, 8192, 1 },
- /*
- I-TLB information:
- size 120 entries (0 K).
- conf 0x000d2000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Either PDTLB or PITLB can be used to purge.
- */
- { 120, 0x000d2000, 0x0, 0, 1, 0x0, 0, 1, 1 },
- /*
- D-TLB information:
- size 120 entries (0 K).
- conf 0x000c2000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Either PDTLB or PITLB can be used to purge.
- */
- { 120, 0x000c2000, 0x0, 0, 1, 0x0, 0, 1, 1 }
- }};
-\f
-{
- "9000/715",
-
- {
- /*
- I-cache information:
- size 65536 bytes (64 K).
- conf 0x51402000
- base 0x0
- stride 32 bytes.
- count 2048 entries.
- loop 1 association per entry.
- block size 81 lines.
- line size 2 (16-byte units).
- It is a read-only cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 65536, 0x51402000, 0x0, 32, 2048, 1 },
- /*
- D-cache information:
- size 65536 bytes (64 K).
- conf 0x51402000
- base 0x0
- stride 32 bytes.
- count 2048 entries.
- loop 1 association per entry.
- block size 81 lines.
- line size 2 (16-byte units).
- It is a write-to cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 65536, 0x51402000, 0x0, 32, 2048, 1 },
- /*
- I-TLB information:
- size 120 entries (0 K).
- conf 0x000d2000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Either PDTLB or PITLB can be used to purge.
- */
- { 120, 0x000d2000, 0x0, 0, 1, 0x0, 0, 1, 1 },
- /*
- D-TLB information:
- size 120 entries (0 K).
- conf 0x000c2000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Either PDTLB or PITLB can be used to purge.
- */
- { 120, 0x000c2000, 0x0, 0, 1, 0x0, 0, 1, 1 }
- }};
-\f
-{
- "9000/867",
-
- {
- /*
- I-cache information:
- size 262144 bytes (256 K).
- conf 0x01402000
- base 0x0
- stride 32 bytes.
- count 8192 entries.
- loop 1 association per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a read-only cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 262144, 0x01402000, 0x0, 32, 8192, 1 },
- /*
- D-cache information:
- size 262144 bytes (256 K).
- conf 0x01402000
- base 0x0
- stride 32 bytes.
- count 8192 entries.
- loop 1 association per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a write-to cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 262144, 0x01402000, 0x0, 32, 8192, 1 },
- /*
- I-TLB information:
- size 96 entries (0 K).
- conf 0x00012000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 96, 0x00012000, 0x0, 0, 1, 0x0, 0, 1, 1 },
- /*
- D-TLB information:
- size 96 entries (0 K).
- conf 0x00002000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 96, 0x00002000, 0x0, 0, 1, 0x0, 0, 1, 1 }
- }};
-\f
-{
- "9000/755",
-
- {
- /*
- I-cache information:
- size 262144 bytes (256 K).
- conf 0x71402000
- base 0x0
- stride 32 bytes.
- count 8192 entries.
- loop 1 association per entry.
- block size 113 lines.
- line size 2 (16-byte units).
- It is a read-only cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 262144, 0x71402000, 0x0, 32, 8192, 1 },
- /*
- D-cache information:
- size 262144 bytes (256 K).
- conf 0x71402000
- base 0x0
- stride 32 bytes.
- count 8192 entries.
- loop 1 association per entry.
- block size 113 lines.
- line size 2 (16-byte units).
- It is a write-to cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 262144, 0x71402000, 0x0, 32, 8192, 1 },
- /*
- I-TLB information:
- size 120 entries (0 K).
- conf 0x000d2000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Either PDTLB or PITLB can be used to purge.
- */
- { 120, 0x000d2000, 0x0, 0, 1, 0x0, 0, 1, 1 },
- /*
- D-TLB information:
- size 120 entries (0 K).
- conf 0x000c2000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Either PDTLB or PITLB can be used to purge.
- */
- { 120, 0x000c2000, 0x0, 0, 1, 0x0, 0, 1, 1 }
- }};
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Program to convert ascii-format cache descriptions into the binary
- form used by Scheme.
-
- To use, replace the structure labeled "written_data" below with the
- new one (if not present in the data base), then recompile this program:
- cc -Ae -O -o hppanewcache hppanewcache.c
- and then type
- ./hppanewcache >>HPPAmodels
- */
-
-#include <stdio.h>
-#define __HPUX__
-#include "hppacach.h"
-
-struct pdc_cache_written
-{
- char hardware[sizeof (utsname.machine)];
- struct pdc_cache_result cache_format;
-};
-\f
-static struct pdc_cache_written written_data =
-{
- /* Cache description for amertume, an HP PA 9000/750 processor. */
-
- "9000/750",
-
- {
- /*
- I-cache information:
- size 262144 bytes (256 K).
- conf 0x01402000
- base 0x0
- stride 32 bytes.
- count 8192 entries.
- loop 1 association per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a read-only cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 262144, 0x01402000, 0x0, 32, 8192, 1 },
- /*
- D-cache information:
- size 262144 bytes (256 K).
- conf 0x01402000
- base 0x0
- stride 32 bytes.
- count 8192 entries.
- loop 1 association per entry.
- block size 1 line.
- line size 2 (16-byte units).
- It is a write-to cache.
- It issues coherent operations.
- Both FDC and FIC must be used to flush.
- */
- { 262144, 0x01402000, 0x0, 32, 8192, 1 },
- /*
- I-TLB information:
- size 96 entries (0 K).
- conf 0x00012000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 96, 0x00012000, 0x0, 0, 1, 0x0, 0, 1, 1 },
- /*
- D-TLB information:
- size 96 entries (0 K).
- conf 0x00002000
- sp_base 0x0
- sp_stride 0
- sp_count 1
- off_base 0x0
- off_stride 0
- off_count 1
- loop 1 association per entry.
- It issues coherent operations.
- Both PDTLB and PITLB must be used to purge.
- */
- { 96, 0x00002000, 0x0, 0, 1, 0x0, 0, 1, 1 }
- }};
-\f
-#define INTMIN(x,y) (((y) > (x)) ? (y) : (x))
-
-main ()
-{
- struct pdc_cache_dump data_to_dump;
-
- memcpy (&data_to_dump.hardware, &written_data.hardware,
- (INTMIN ((sizeof (data_to_dump.hardware)),
- (sizeof (written_data.hardware)))));
- memcpy (&data_to_dump.cache_format, &written_data.cache_format,
- (INTMIN ((sizeof (data_to_dump.cache_format)),
- (sizeof (written_data.cache_format)))));
- fprintf (stderr, "Writing %d bytes...\n", (sizeof (data_to_dump)));
- fflush (stderr);
- write ((fileno (stdout)), &data_to_dump, (sizeof (data_to_dump)));
- exit (0);
-}
+++ /dev/null
-artutl.obj
-avltree.obj
-bignum.obj
-bigprm.obj
-bitstr.obj
-boot.obj
-char.obj
-cmpauxmd.obj
-cmpint.obj
-comutl.obj
-daemon.obj
-debug.obj
-dfloat.obj
-error.obj
-extern.obj
-fasload.obj
-fixnum.obj
-flonum.obj
-generic.obj
-hooks.obj
-hunk.obj
-intern.obj
-interp.obj
-intext.obj
-intprm.obj
-list.obj
-lookprm.obj
-lookup.obj
-missing.obj
-obstack.obj
-option.obj
-osscheme.obj
-ostty.obj
-outf.obj
-prim.obj
-primutl.obj
-prmcon.obj
-ptrvec.obj
-purutl.obj
-regex.obj
-rgxprim.obj
-step.obj
-storage.obj
-string.obj
-syntax.obj
-sysprim.obj
-term.obj
-tparam.obj
-transact.obj
-utils.obj
-vector.obj
-wind.obj
-
-prosenv.obj
-prosfile.obj
-prosfs.obj
-prosio.obj
-prosterm.obj
-prostty.obj
-
-prntenv.obj
-prntfs.obj
-prntio.obj
-
-ntasutl.obj
-ntenv.obj
-ntfile.obj
-ntfs.obj
-ntgui.obj
-ntgui.rbj
-ntio.obj
-ntsig.obj
-ntsys.obj
-nttop.obj
-nttrap.obj
-ntscreen.obj
-nttterm.obj
-nttty.obj
-
-bchdmp.obj
-bchgcl.obj
-bchmmg.obj
-bchpur.obj
-bchutl.obj
-bchdef.obj
-wabbit.obj
+++ /dev/null
-;;; -*-Fundamental-*-
-;;;
-;;; Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
-;;; 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
-;;; 2014, 2015, 2016, 2017 Massachusetts Institute of Technology
-;;;
-;;; This file is part of MIT/GNU Scheme.
-;;;
-;;; MIT/GNU Scheme is free software; you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation; either version 2 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; MIT/GNU Scheme is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with MIT/GNU Scheme; if not, write to the Free Software
-;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
-;;; 02110-1301, USA.
-;;;
-;;;; Shared files (Unix and DOS)
-artutl.c
-avltree.c
-bignum.c
-bigprm.c
-bitstr.c
-boot.c
-char.c
-comutl.c
-daemon.c
-debug.c
-dfloat.c
-error.c
-extern.c
-fasload.c
-fixnum.c
-flonum.c
-generic.c
-hooks.c
-hunk.c
-intern.c
-interp.c
-intprm.c
-list.c
-lookprm.c
-lookup.c
-missing.c
-obstack.c
-option.c
-osscheme.c
-ostty.c
-prim.c
-primutl.c
-prmcon.c
-ptrvec.c
-purutl.c
-regex.c
-rgxprim.c
-step.c
-storage.c
-string.c
-syntax.c
-sysprim.c
-term.c
-transact.c
-utils.c
-vector.c
-wind.c
-;;;; Generic OS primitive files
-prosenv.c
-prosfile.c
-prosfs.c
-prosio.c
-prosterm.c
-prostty.c
-;;;; NT OS primitive files
-prntenv.c
-prntfs.c
-prntio.c
-;;;; Bizarre NT primitive files
-ntgui.c
-nttterm.c
-;;;; GC files
-bchdmp.c
-bchgcl.c
-bchmmg.c
-bchpur.c
-bchutl.c
!ENDIF
cflags = $(cflags) $(cvarsmt) /DMIT_SCHEME /DGUI=1 /I.
-all: scheme.exe bchschem.exe bintopsb.exe psbtobin.exe
+all: scheme.exe bintopsb.exe psbtobin.exe
.c.obj:
$(cc) $(cflags) -c $*.c
fasdump.c \
gcloop.c \
memmag.c \
-purify.c \
-wabbit.c
-
-BCH_GC_SOURCES = \
-bchdmp.c \
-bchgcl.c \
-bchmmg.c \
-bchpur.c \
-bchutl.c
+purify.c
NT_SOURCES = \
intext.c \
fasdump.obj \
gcloop.obj \
memmag.obj \
-purify.obj \
-wabbit.obj
-
-BCH_GC_OBJECTS = \
-bchdmp.obj \
-bchgcl.obj \
-bchmmg.obj \
-bchpur.obj \
-bchutl.obj
+purify.obj
NT_OBJECTS = \
intext.obj \
OBJECTS = $(CORE_OBJECTS) $(STD_GC_OBJECTS) $(NT_OBJECTS) \
$(OS_PRIM_OBJECTS) usrdef.obj
-BCHSOURCES = $(CORE_SOURCES) $(BCH_GC_SOURCES)
-BCHOBJECTS = $(CORE_OBJECTS) $(BCH_GC_OBJECTS) $(NT_OBJECTS) \
- $(OS_PRIM_OBJECTS) bchdef.obj
-
SCHEME_SOURCES = $(USER_PRIM_SOURCES) missing.c
SCHEME_OBJECTS = $(USER_PRIM_OBJECTS) missing.obj
SCHEME_LIB = $(USER_LIBS)
-out:scheme.exe $(OBJECTS) $(SCHEME_OBJECTS) scheme32.obj \
$(guilibsmt) $(SCHEME_LIB) ntgui.res
-bchschem.exe : $(BCHOBJECTS) $(SCHEME_OBJECTS) scheme32.obj
- $(link) $(linkdebug) $(guiflags) /base:0x4000000 /fixed /map \
- -out:bchschem.exe $(BCHOBJECTS) $(SCHEME_OBJECTS) scheme32.obj \
- $(guilibsmt) $(SCHEME_LIB) ntgui.res
-
scheme32.obj : scheme32.c ntscmlib.h
bintopsb.exe : bintopsb.obj missing.obj
.\findprim $(SCHEME_SOURCES) $(SOURCES) $(OS_PRIM_SOURCES) ntgui.c \
> usrdef.c
-bchdef.c : $(SCHEME_SOURCES) $(BCHSOURCES) $(OS_PRIM_SOURCES) ntgui.c \
- findprim.exe
- .\findprim $(SCHEME_SOURCES) $(BCHSOURCES) $(OS_PRIM_SOURCES) ntgui.c \
- > bchdef.c
-
#
# Dependencies. (This was a lot of work!)
#
# This first section defines the dependencies of the include files.
#
AVLTREE_H = avltree.h $(CONFIG_H)
-BCHDRN_H = bchdrn.h $(CONFIG_H)
-BCHGCC_H = bchgcc.h $(CONFIG_H) $(GCCODE_H)
BIGNMINT_H = bignmint.h $(PRIMS_H)
BIGNUM_H = bignum.h ansidecl.h
BITSTR_H = bitstr.h
gcloop.obj: gcloop.c $(SCHEME_H) $(GCCODE_H)
memmag.obj: memmag.c $(SCHEME_H) $(PRIMS_H) $(MEMMAG_H) $(GCCODE_H)
purify.obj: purify.c $(SCHEME_H) $(PRIMS_H) $(GCCODE_H) $(ZONES_H)
-wabbit.obj: wabbit.c $(SCHEME_H) $(GCCODE_H)
-
-bchdmp.obj: bchdmp.c $(SCHEME_H) $(PRIMS_H) $(OSFILE_H) $(OSFS_H) $(TRAP_H) \
- $(LOOKUP_H) $(FASL_H) $(NT_H) $(NTIO_H) $(BCHGCC_H) $(DUMP_C)
-bchgcl.obj: bchgcl.c $(SCHEME_H) $(BCHGCC_H)
-bchmmg.obj: bchmmg.c $(SCHEME_H) $(PRIMS_H) $(MEMMAG_H) $(OPTION_H) \
- $(OSENV_H) $(OSENV_H) $(NT_H) $(BCHGCC_H) $(BCHDRN_H)
-bchpur.obj: bchpur.c $(SCHEME_H) $(PRIMS_H) $(BCHGCC_H) $(ZONES_H)
-bchutl.obj: bchutl.c $(CONFIG_H)
intext.obj: intext.c ansidecl.h $(DSTACK_H) $(INTEXT_H)
ntenv.obj: ntenv.c $(SCHEME_H) $(NT_H) $(OSENV_H) $(NTSCREEN_H)
gcloop.obj
memmag.obj
purify.obj
-wabbit.obj
usrdef.obj
switch (compiler_processor_type)
{
case COMPILER_NONE_TYPE: return ("none");
- case COMPILER_MC68020_TYPE: return ("mc68k");
- case COMPILER_VAX_TYPE: return ("vax");
- case COMPILER_SPECTRUM_TYPE: return ("hppa");
- case COMPILER_MC68040_TYPE: return ("mc68k");
- case COMPILER_SPARC_TYPE: return ("sparc");
case COMPILER_IA32_TYPE: return ("i386");
- case COMPILER_ALPHA_TYPE: return ("alpha");
- case COMPILER_MIPS_TYPE: return ("mips");
case COMPILER_C_TYPE: return ("c");
case COMPILER_SVM_TYPE: return ("svm1");
case COMPILER_X86_64_TYPE: return ("x86-64");
+++ /dev/null
-#
-# This makefile handles these tasks:
-# . production of pcsdld.sl
-# . installation in scheme library
-#
-# It does not handle the compilation of scheme files.
-
-#SCHEME_ROOT=..
-SCHEME_ROOT=/scheme/8.0/700
-INSTALL_DIRECTORY=$(SCHEME_ROOT)/lib/pcsample
-
-SCHEME_OBJECTS = load.com pcsboot.com pcsdisp.com pcsiproc.com \
- pcsample.com pcscobl.com pcsintrp.com pribinut.com
-
-pcsdld.sl: pcsdld.o
- ld -b -o pcsdld.sl pcsdld.o
-
-pcsdld.o: pcsdld.c pcsample.c pcscobl.c pcsiproc.c
- cc -c -O -Ae +z -I$(SCHEME_ROOT) -DMIT_SCHEME -D_HPUX pcsdld.c
-
-install: pcsdld.sl $(SCHEME_OBJECTS) pcs.bco pcs.bld
- -mkdir $(INSTALL_DIRECTORY)
- cp -p pcsdld.sl $(INSTALL_DIRECTORY)
- cp -p pcs.bco pcs.bld *.com *.bci $(INSTALL_DIRECTORY)
-
-tags: TAGS
-TAGS:
- etags *.scm *.c
-
-.PHONY: tags TAGS install
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; System Packaging
-
-(declare (usual-integrations))
-\f
-(load-package-set "pcs")
-(add-subsystem-identification! "PC Sampler" '(1 0))
-
-(let ()
- (define (package-initialize package-name
- #!optional procedure-name mandatory?)
- (let ((procedure-name
- (if (default-object? procedure-name)
- 'INITIALIZE-PACKAGE!
- procedure-name))
- (mandatory?
- (or (default-object? mandatory?) mandatory?)))
- (define (print-name string)
- (display "\n")
- (display string)
- (display " (")
- (let loop ((name package-name))
- (if (not (null? name))
- (begin
- (if (not (eq? name package-name))
- (display " "))
- (display (system-pair-car (car name)))
- (loop (cdr name)))))
- (display ")"))
-
- (define (package-reference name)
- (package/environment (find-package name)))
-
- (let ((env (package-reference package-name)))
- (cond ((not procedure-name))
- ((not (lexical-unreferenceable? env procedure-name))
- (print-name "initialize:")
- (if (not (eq? procedure-name 'INITIALIZE-PACKAGE!))
- (begin
- (display " [")
- (display (system-pair-car procedure-name))
- (display "]")))
- ((lexical-reference env procedure-name)))
- ((not mandatory?)
- (print-name "* skipping:"))
- (else
- ;; Missing mandatory package! Report it and die.
- (print-name "Package")
- (display " is missing initialization procedure ")
- (display (system-pair-car procedure-name))
- (error "Could not initialize a required package."))))))
-
- (for-each package-initialize
- '((pribinut)
- (pc-sample interrupt-handler)
- (pc-sample)
- (pc-sample interp-procs)
- (pc-sample code-blocks)
- (pc-sample display)
- (pc-sample zones))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-(fluid-let ((compiler:coalescing-constant-warnings? #f))
- (compile-directory "."))
-
-(display "
-
-Remember to use `make install' to copy compiled files to library directory.
-
-")
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; PC Sampler System Packaging
-
-(global-definitions "../runtime/runtime")
-
-
-(define-package (pribinut)
- (files "pribinut")
- (parent ())
- (export (pc-sample)
- get-primitive-name
- get-builtin-name
- get-utility-name
- get-primitive-count
- get-builtin-count
- get-utility-count)
- (initialization (initialize-package!)))
-
-
-(define-package (pc-sample interrupt-handler)
- (files "pcsboot" "pcsintrp")
- (parent ())
- (import (runtime interrupt-handler)
- index:interrupt-vector
- index:interrupt-mask-vector)
- (export () ; export only because boot.scm does too
- interrupt-bit/IPPB-flush
- interrupt-bit/IPPB-extend
- interrupt-bit/PCBPB-flush
- interrupt-bit/PCBPB-extend
- interrupt-bit/HCBPB-flush
- interrupt-bit/HCBPB-extend)
- (initialization (initialize-package!)))
-\f
-(define-package (pc-sample)
- (files "pcsample")
- (parent ())
- (export ()
- *pc-sample/sample-sampler?*
- *pc-sample/noisy?*
- pc-sample/init
- pc-sample/start
- pc-sample/stop
- pc-sample/state
- pc-sample/uninitialized?
- pc-sample/initialized?
- pc-sample/running?
- pc-sample/started?
- pc-sample/stopped?
- pc-sample/sample-interval
- pc-sample/set-sample-interval
- pc-sample/default-sample-interval
- pc-sample/fixed-objects
- pc-sample/builtin-table
- pc-sample/utility-table
- pc-sample/primitive-table
- pc-sample/prob-comp-table
- pc-sample/UFO-table
- pc-sample/purified-code-block-block-buffer
- pc-sample/purified-code-block-offset-buffer
- pc-sample/heathen-code-block-block-buffer
- pc-sample/heathen-code-block-offset-buffer
- pc-sample/interp-proc-buffer
- pc-sample/status
- pc-sample/status/previous
- pc-sample/builtin/status
- pc-sample/utility/status
- pc-sample/primitive/status
- pc-sample/code-block/status
- pc-sample/code-block-buffer/status
- pc-sample/interp-proc/status
- pc-sample/interp-proc-buffer/status
- pc-sample/prob-comp/status
- pc-sample/UFO/status
- pc-sample/reset
- pc-sample/builtin/reset
- pc-sample/utility/reset
- pc-sample/primitive/reset
- pc-sample/code-block/reset
- pc-sample/purified-code-block/reset
- pc-sample/heathen-code-block/reset
- pc-sample/interp-proc/reset
- pc-sample/prob-comp/reset
- pc-sample/UFO/reset
- pc-sample/enable
- pc-sample/builtin/enable
- pc-sample/utility/enable
- pc-sample/primitive/enable
- pc-sample/code-block/enable
- pc-sample/purified-code-block/enable
- pc-sample/heathen-code-block/enable
- pc-sample/interp-proc/enable
- pc-sample/prob-comp/enable
- pc-sample/UFO/enable
- pc-sample/disable
- pc-sample/builtin/disable
- pc-sample/utility/disable
- pc-sample/primitive/disable
- pc-sample/code-block/disable
- pc-sample/purified-code-block/disable
- pc-sample/heathen-code-block/disable
- pc-sample/interp-proc/disable
- pc-sample/prob-comp/disable
- pc-sample/UFO/disable
- call-with-pc-sampling
- call-with-builtin-pc-sampling
- call-with-utility-pc-sampling
- call-with-primitive-pc-sampling
- call-with-code-block-pc-sampling
- call-with-interp-proc-pc-sampling
- call-with-prob-comp-pc-sampling
- call-with-UFO-pc-sampling
- with-pc-sampling
- with-builtin-pc-sampling
- with-utility-pc-sampling
- with-primitive-pc-sampling
- with-code-block-pc-sampling
- with-interp-proc-pc-sampling
- with-prob-comp-pc-sampling
- with-UFO-pc-sampling
- call-without-pc-sampling
- call-without-builtin-pc-sampling
- call-without-utility-pc-sampling
- call-without-primitive-pc-sampling
- call-without-code-block-pc-sampling
- call-without-interp-proc-pc-sampling
- call-without-prob-comp-pc-sampling
- call-without-UFO-pc-sampling
- without-pc-sampling
- without-builtin-pc-sampling
- without-utility-pc-sampling
- without-primitive-pc-sampling
- without-code-block-pc-sampling
- without-interp-proc-pc-sampling
- without-prob-comp-pc-sampling
- without-UFO-pc-sampling
- call-with-absolutely-no-pc-sampling
- call-with-absolutely-no-builtin-pc-sampling
- call-with-absolutely-no-utility-pc-sampling
- call-with-absolutely-no-primitive-pc-sampling
- call-with-absolutely-no-code-block-pc-sampling
- call-with-absolutely-no-interp-proc-pc-sampling
- call-with-absolutely-no-prob-comp-pc-sampling
- call-with-absolutely-no-UFO-pc-sampling
- with-absolutely-no-pc-sampling
- with-absolutely-no-builtin-pc-sampling
- with-absolutely-no-utility-pc-sampling
- with-absolutely-no-primitive-pc-sampling
- with-absolutely-no-code-block-pc-sampling
- with-absolutely-no-interp-proc-pc-sampling
- with-absolutely-no-prob-comp-pc-sampling
- with-absolutely-no-UFO-pc-sampling
- )
- (export (pc-sample interp-procs)
- pc-sample/set-state!
- make-profile-hash-table
- profile-hash-table-car
- profile-hash-table-cdr
- pc-sample/interp-proc-buffer/make
- fixed-interp-proc-profile-buffer/disable
- fixed-interp-proc-profile-buffer/install
- )
- (export (pc-sample code-blocks)
- pc-sample/set-state!
- make-profile-hash-table
- profile-hash-table-car
- profile-hash-table-cdr
- pc-sample/code-block-buffer/make/purified-blocks
- pc-sample/code-block-buffer/make/purified-offsets
- pc-sample/code-block-buffer/make/heathen-blocks
- pc-sample/code-block-buffer/make/heathen-offsets
- fixed-purified-code-block-profile-buffers/install
- fixed-heathen-code-block-profile-buffers/install
- fixed-purified-code-block-profile-buffers/disable
- fixed-heathen-code-block-profile-buffers/disable
- )
-
- (export (pc-sample display)
- get-builtin-name
- get-utility-name
- pc-sample/interp-proc-table
- pc-sample/code-block-table
- profile-hash-table-car
- profile-hash-table-cdr
- pc-sample/status/builtin-table
- pc-sample/status/interp-proc-buffer/status
- pc-sample/status/interp-proc-table
- pc-sample/status/code-block-buffer/status
- pc-sample/status/code-block-table
- pc-sample/status/primitive-table
- pc-sample/status/prob-comp-table
- pc-sample/status/UFO-table
- pc-sample/status/utility-table
- )
- (initialization (initialize-package!)))
-
-
-
-
-(define-package (pc-sample interp-procs)
- (files "pcsiproc")
- (parent (pc-sample))
- (export () ; monitor buffer evolution... for now
- interp-proc-profiling-disabled?
- interp-proc-profile-buffer/status
- interp-proc-profile-buffer/status/previous
- interp-proc-profile-buffer/length
- interp-proc-profile-buffer/slack
- interp-proc-profile-buffer/slack-increment
- interp-proc-profile-buffer/set-slack
- interp-proc-profile-buffer/set-slack-increment
- interp-proc-profile-buffer/extend-noisy?
- interp-proc-profile-buffer/flush-noisy?
- interp-proc-profile-buffer/overflow-noisy?
- interp-proc-profile-buffer/extend-noisy?/toggle!
- interp-proc-profile-buffer/flush-noisy?/toggle!
- interp-proc-profile-buffer/overflow-noisy?/toggle!
- interp-proc-profile-buffer/with-extend-notification!
- interp-proc-profile-buffer/with-flush-notification!
- interp-proc-profile-buffer/with-overflow-notification!
- interp-proc-profile-buffer/extend-count?
- interp-proc-profile-buffer/flush-count?
- interp-proc-profile-buffer/overflow-count?
- interp-proc-profile-buffer/extend-count?/toggle!
- interp-proc-profile-buffer/flush-count?/toggle!
- interp-proc-profile-buffer/overflow-count?/toggle!
- interp-proc-profile-buffer/with-extend-count!
- interp-proc-profile-buffer/with-flush-count!
- interp-proc-profile-buffer/with-overflow-count!
- interp-proc-profile-buffer/extend-count
- interp-proc-profile-buffer/flush-count
- interp-proc-profile-buffer/overflow-count
- interp-proc-profile-buffer/extend-count/reset
- interp-proc-profile-buffer/flush-count/reset
- interp-proc-profile-buffer/overflow-count/reset
- )
- (export (pc-sample interrupt-handler)
- interp-proc-profile-buffer/flush
- interp-proc-profile-buffer/extend
- )
- (export (pc-sample)
- interp-proc-profile-table ; probably a kludge
- interp-proc-profile-table/old
- interp-proc-profile-table/reset
- interp-proc-profile-table/enable
- interp-proc-profile-table/disable
- interp-proc-profile-buffer/status
- interp-proc-profile-buffer/status/previous
- )
- (export (pc-sample display)
- interp-proc-profile-datum/count
- )
- (initialization (initialize-package!)))
-
-(define-package (pc-sample code-blocks)
- (files "pcscobl")
- (parent (pc-sample))
- (import (runtime compiler-info)
- compiled-code-block/dbg-info
- dbg-info?
- dbg-info/procedures
- dbg-procedure/label-offset)
- (export () ; monitor buffer evolution... for now
- compiled-code-block/trampoline?
- trampoline/return-to-interpreter?
- code-block-profiling-disabled?
- code-block-profile-buffer/status
- code-block-profile-buffer/status/previous
- purified-trampoline-profile-table
- heathen-trampoline-profile-table
- purified-code-block-profile-buffer/length
- heathen-code-block-profile-buffer/length
- purified-code-block-profile-buffer/slack
- heathen-code-block-profile-buffer/slack
- purified-code-block-profile-buffer/slack-increment
- heathen-code-block-profile-buffer/slack-increment
- purified-code-block-profile-buffer/set-slack
- heathen-code-block-profile-buffer/set-slack
- purified-code-block-profile-buffer/set-slack-increment
- heathen-code-block-profile-buffer/set-slack-increment
- purified-code-block-profile-buffer/extend-noisy?
- heathen-code-block-profile-buffer/extend-noisy?
- purified-code-block-profile-buffer/flush-noisy?
- heathen-code-block-profile-buffer/flush-noisy?
- purified-code-block-profile-buffer/overflow-noisy?
- heathen-code-block-profile-buffer/overflow-noisy?
- purified-code-block-profile-buffer/extend-noisy?/toggle!
- heathen-code-block-profile-buffer/extend-noisy?/toggle!
- purified-code-block-profile-buffer/flush-noisy?/toggle!
- heathen-code-block-profile-buffer/flush-noisy?/toggle!
- purified-code-block-profile-buffer/overflow-noisy?/toggle!
- heathen-code-block-profile-buffer/overflow-noisy?/toggle!
- purified-code-block-profile-buffer/with-extend-notification!
- heathen-code-block-profile-buffer/with-extend-notification!
- purified-code-block-profile-buffer/with-flush-notification!
- heathen-code-block-profile-buffer/with-flush-notification!
- purified-code-block-profile-buffer/with-overflow-notification!
- heathen-code-block-profile-buffer/with-overflow-notification!
- purified-code-block-profile-buffer/extend-count?
- heathen-code-block-profile-buffer/extend-count?
- purified-code-block-profile-buffer/flush-count?
- heathen-code-block-profile-buffer/flush-count?
- purified-code-block-profile-buffer/overflow-count?
- heathen-code-block-profile-buffer/overflow-count?
- purified-code-block-profile-buffer/extend-count?/toggle!
- heathen-code-block-profile-buffer/extend-count?/toggle!
- purified-code-block-profile-buffer/flush-count?/toggle!
- heathen-code-block-profile-buffer/flush-count?/toggle!
- purified-code-block-profile-buffer/overflow-count?/toggle!
- heathen-code-block-profile-buffer/overflow-count?/toggle!
- purified-code-block-profile-buffer/with-extend-count!
- heathen-code-block-profile-buffer/with-extend-count!
- purified-code-block-profile-buffer/with-flush-count!
- heathen-code-block-profile-buffer/with-flush-count!
- purified-code-block-profile-buffer/with-overflow-count!
- heathen-code-block-profile-buffer/with-overflow-count!
- purified-code-block-profile-buffer/extend-count
- heathen-code-block-profile-buffer/extend-count
- purified-code-block-profile-buffer/flush-count
- heathen-code-block-profile-buffer/flush-count
- purified-code-block-profile-buffer/overflow-count
- heathen-code-block-profile-buffer/overflow-count
- purified-code-block-profile-buffer/extend-count/reset
- heathen-code-block-profile-buffer/extend-count/reset
- purified-code-block-profile-buffer/flush-count/reset
- heathen-code-block-profile-buffer/flush-count/reset
- purified-code-block-profile-buffer/overflow-count/reset
- heathen-code-block-profile-buffer/overflow-count/reset)
- (export (pc-sample interrupt-handler)
- purified-code-block-profile-buffer/flush
- purified-code-block-profile-buffer/extend
- heathen-code-block-profile-buffer/flush
- heathen-code-block-profile-buffer/extend)
- (export (pc-sample)
- code-block-profile-table ; probably a kludge
- code-block-profile-table/old
- code-block-profile-tables/reset
- code-block-profile-tables/enable
- code-block-profile-tables/disable
- purified-code-block-profile-tables/reset
- purified-code-block-profile-tables/enable
- purified-code-block-profile-tables/disable
- heathen-code-block-profile-tables/reset
- heathen-code-block-profile-tables/enable
- heathen-code-block-profile-tables/disable
- code-block-profile-buffer/status
- code-block-profile-buffer/status/previous
- )
- (export (pc-sample display)
- code-block-profile-datum/count
- )
- (initialization (initialize-package!)))
-
-
-
-
-
-(define-package (pc-sample display)
- (files "pcsdisp")
- (parent (pc-sample))
- (import (runtime compiler-info)
- special-form-procedure-name?
- dbg-info?
- dbg-procedure?
- compiled-code-block/filename-and-index
- compiled-entry/filename-and-index
- )
- (export ()
- pc-sample/status/display
- pc-sample/builtin/status/display
- pc-sample/utility/status/display
- pc-sample/primitive/status/display
- pc-sample/code-block/status/display
- pc-sample/interp-proc/status/display
- pc-sample/prob-comp/status/display
- pc-sample/UFO/status/display
- pc-sample/builtin/display-acate
- pc-sample/utility/display-acate
- pc-sample/primitive/display-acate
- pc-sample/code-block/display-acate
- pc-sample/interp-proc/display-acate
- pc-sample/prob-comp/display-acate
- pc-sample/UFO/display-acate
- pc-sample/purified-trampoline/display-acate
- pc-sample/heathen-trampoline/display-acate
- pc-sample/status/table
- pc-sample/builtin/status/table
- pc-sample/utility/status/table
- pc-sample/primitive/status/table
- pc-sample/code-block/status/table
- pc-sample/interp-proc/status/table
- pc-sample/prob-comp/status/table
- pc-sample/UFO/status/table
- pc-sample/purified-trampoline/status/table
- pc-sample/heathen-trampoline/status/table
- with-pc-sample-displayacation-status
- *nonmeaningful-procedure-names*
- *pc-sample/default-status-displayer*
- with-pc-sample-default-status-displayer
- )
- (initialization (initialize-package!)))
-
-(define-package (pc-sample zones)
- (files "zones")
- (parent ())
- (export ()
- make-pc-sample-zone
- wrap-with-zone
- reset-zone-counts!
- display-zone-report))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-(fluid-let ((sf/default-syntax-table (->environment '(RUNTIME))))
- (sf-directory "."))
-
-(load-option 'CREF)
-(cref/generate-constructors "pcs")
\ No newline at end of file
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* PCSAMPLE.C -- defines the PC Sample subroutines for UNIX implementations */
-
-/*****************************************************************************/
-#ifdef REALLY_INCLUDE_PROFILE_CODE /* scan_defines concession */
-\f
-/*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*\
- * TODO:
- *
- * - The mumble_index func ptrs can be avoided via macro passing?!
- * - Maybe macro-ize/in-line code:
- * PC_SAMPLE
- * PC_SAMPLE_RECORD
- * PC_SAMPLE_UPDATE_BI_BUFFER (after merging out paranoia & verbosity)
- * PC_SAMPLE_RECORD_TABLE_ENTRY and some others?
- * PC_SAMPLE_SPILL_GC_SAMPLES_INTO_PRIMITIVE_TABLE
- *
-\*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*/
-\f
-
-#include <microcode/ux.h> /* UNIX bullocks */
-#include <microcode/osenv.h> /* For profile_timer_set/clear */
-#include <microcode/config.h> /* For TRUE/FALSE & true/false */
-#include <microcode/scheme.h>
-#include <microcode/uxtrap.h> /* UNIX trap handlers */
-#include <microcode/uxsig.h> /* For DEFUN_STD_HANDLER */
-#include <microcode/prims.h> /* For DEFINE_PRIMITIVE */
-#include <microcode/cmpintmd.h> /* Compiled code interface macros */
-
-#ifdef HAVE_ITIMER /* No interrupt timer ==> no PC sampling */
-
-/*****************************************************************************
- * Very crude, brute force enable/disable key switch ... KERCHUNK! Debuggery */
-
-static volatile Boolean pc_sample_halted = true ;
-static volatile clock_t profile_interval = 0 ; /* one-shot interval */
-
-/*---------------------------------------------------------------------------*/
-static void
-DEFUN (OS_pc_sample_timer_set, (first, interval),
- clock_t first AND
- clock_t interval)
-{
- /* The profile trap handler will issue another one-shot triggering
- * of the prof timer once it has handled the pending profile request.
- * This assures that the profile interval cannot be so small as
- * to cause PROF triggers to deluge the system.
- */
-
- Tsignal_handler_result sighnd_profile() ; /* See uxtrap.c section */
-
- {
- OS_profile_timer_clear (); /* ``Cease fire!'' while reset */
- pc_sample_halted = false; /* clear internal state flag */
- profile_interval = interval; /* trap handler re-arms @ interval */
- activate_handler (SIGPROF, ((Tsignal_handler) sighnd_profile));
- /* in case deactivated */
- OS_profile_timer_set (first, ((clock_t) 0)); /* Open fire! (one shot) */
- }
-
-#if ( defined(PCS_LOG_TIMER_DELTA) /* Profile gestalt debuggery */ \
- || defined(PCS_LOG_TIMER_SET) \
- )
- outf_console ("0x%x ", profile_interval) ;
- outf_flush_console () ;
-#endif
-}
-
-static void
-DEFUN_VOID (OS_pc_sample_timer_clear)
-{
- long old_mask = sigblock (sigmask (SIGPROF)); /* atomic wrt sigprof */
- {
- OS_profile_timer_clear () ; /* ``Cease fire!'' */
- deactivate_handler (SIGPROF) ; /* disable handler */
- pc_sample_halted = true ; /* set internal state flag */
- profile_interval = ((clock_t) 0); /* disable re-triggers too */
- }
- (void) sigblock (old_mask) ; /* end atomic wrt sigprof */
-
-#if ( defined(PCS_LOG_TIMER_DELTA) /* Profile gestalt debuggery */ \
- || defined(PCS_LOG_TIMER_CLEAR) \
- )
- outf_console ("-\n") ;
- outf_flush_console () ;
-#endif
-
-}
-\f
-
-/*****************************************************************************/
-#if !defined(HAVE_SIGCONTEXT) || !defined(HAS_COMPILER_SUPPORT) || defined(USE_STACKLETS)
-/*---------------------------------------------------------------------------*/
-
-static void
-DEFUN (profile_trap_handler, (scp), struct FULL_SIGCONTEXT * scp)
-{
- /* Cannot recover PC w/o sigcontext (?) so nothing to sample */
-
-#ifndef PCS_TACIT_NO_TRAP
- outf_error ("\nProfile trap handler called but is non-existent.\n") ;
- outf_flush_error () ;
-#endif
-
- return;
-}
-
-#else /* HAVE_SIGCONTEXT and HAS_COMPILER_SUPPORT and not USE_STACKLETS */
-\f
-/* Timezones
- * These timezones are different to the ones in the microcode. The basic support here allows them to be
- */
-
-#define INITIAL_ZONE_LIMIT 10
-static int current_zone = 0;
-static int max_zone = INITIAL_ZONE_LIMIT;
-
-static double initial_zone_buffer[INITIAL_ZONE_LIMIT] = {0.0};
-static double *zones = initial_zone_buffer;
-
-/* Invariant: 0 <= current_zone < max_zone */
-/* Invariant: zones -> allocation of max_zone doubles */
-\f
-
-#define essential_profile_trap_handler(scp) do \
-{ \
- extern void EXFUN (pc_sample, (struct FULL_SIGCONTEXT *)); \
- extern void EXFUN (zone_sample, ()); \
- \
- pc_sample (scp) ; /* For now, profiler just PC samples */ \
- zones[current_zone] += 1.0; /* and zone sampling */ \
- OS_pc_sample_timer_set(profile_interval, /* launch another 1-shot */ \
- profile_interval) ; /* at the same interval */ \
-} while (FALSE)
-
-
-#ifndef PCS_TRAP_LOG /* Sample debuggery */
-#define real_profile_trap_handler(scp) essential_profile_trap_handler(scp)
-#else
-#define real_profile_trap_handler(scp) do \
-{ \
- essential_profile_trap_handler(scp); \
- outf_console ("\n; Profile trap handler called while interval = %d.\n", \
- profile_interval) ; \
- outf_flush_console () ; \
-} while (FALSE)
-#endif
-\f
-static void
-DEFUN (profile_trap_handler, (scp), struct FULL_SIGCONTEXT * scp)
-{
-
-#ifndef PCS_TRAP_HANDLER_PARANOIA
-
- real_profile_trap_handler (scp) ;
- return;
-
-#else /* PCS_TRAP_HANDLER_PARANOIA */
-
- if ( (! (pc_sample_halted))
- && (profile_interval != ((clock_t) 0)))
- real_profile_trap_handler (scp) ;
-
-#ifndef PCS_TACIT_PUNT_BELATED /* Sample debuggery */
- else if (profile_interval == ((clock_t) 0))
- {
- /* This shouldn't arise since now de-activate trap handler @ timer clear */
- outf_console ("\n\
- \n;----------------------------------------------\
- \n; Profile trap handler punted a belated sample.\
- \n;----------------------------------------------\
- \n\
- \n") ;
- outf_flush_console () ;
- }
-#endif
-
-#ifndef PCS_TACIT_WIZARD_HALT /* Sample gestalt debuggery */
- else if (pc_sample_halted)
- {
- /* Only official wizards should ever witness this. FNORD! */
-
- outf_console ("!") ;
- outf_flush_console ();
- }
-#endif
-
-#ifndef PCS_TACIT_MUSIC_MAN /* Sample debuggery */
- else
- {
- outf_error ("\n ; There's trouble, right here in Sample City.\n") ;
- outf_flush_error () ;
- }
-#endif
-
-#endif /* PCS_TRAP_HANDLER_PARANOIA */
-}
-
-#endif /* HAVE_SIGCONTEXT and HAS_COMPILER_SUPPORT and not USE_STACKLETS */
-
-
-DEFUN_STD_HANDLER (sighnd_profile,
- {
- profile_trap_handler (scp);
- })
-\f
-DEFINE_PRIMITIVE ("PC-SAMPLE/TIMER-CLEAR", Prim_pc_sample_timer_clear, 0, 0,
- "()\n\
- Turn off the PC sample timer.\
- ")
-{
- PRIMITIVE_HEADER (0);
- OS_pc_sample_timer_clear ();
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("PC-SAMPLE/TIMER-SET", Prim_pc_sample_timer_set, 2, 2,
- "(first interval)\n\
- Set the PC sample timer.\n\
- First arg FIRST says how long to wait until the first interrupt;\n\
- second arg INTERVAL says how long to wait between interrupts after that.\n\
- Both arguments are in units of milliseconds.\
- ")
-{
- PRIMITIVE_HEADER (2);
- OS_pc_sample_timer_set ((arg_nonnegative_integer (1)),
- (arg_nonnegative_integer (2)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%PC-SAMPLE/HALTED?", Prim_pc_sample_halted_p, 0, 0,
- "()\n\
- Specifies whether PC sampling has been brute forcably disabled.\n\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (pc_sample_halted)) ;
-}
-
-DEFINE_PRIMITIVE ("%PC-SAMPLE/HALTED?/TOGGLE!",
- Prim_pc_sample_halted_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether PC sampling is brute forcably disabled.\n\
- \n\
- It returns the newly installed sense of the flag.\n\
- \n\
- -------\n\
- WARNING! If pc-sample/init has not been called (to initialize profiling\n\
- ------- tables) then you will lose big if you naively toggle halted-flag\n\
- to #F because that will start the profile timer.\n\
- \n\
- Only officially designated moby wizards should even think of thinking of\n\
- using this most ultra super duper secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(0);
- pc_sample_halted = (! (pc_sample_halted)) ;
- if ( (! (pc_sample_halted))
- && (profile_interval != ((clock_t) 0)))
- OS_pc_sample_timer_set(1, profile_interval) ; /* Throw the switch, Igor! */
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (pc_sample_halted)) ;
-}
-\f
-/*****************************************************************************
- * Mondo hack to keep track of where the primitive GARBAGE-COLLECT is so we
- * can still sample GC calls during GC despite the PC_Sample_Primitive_Table
- * can shift about
- *****************************************************************************/
-
-long Garbage_Collect_Primitive_Index = -1; /* installed later */
-
-static void
-DEFUN_VOID (pc_sample_cache_GC_primitive_index)
-{
- SCHEME_OBJECT primitive = make_primitive("GARBAGE-COLLECT");
- Garbage_Collect_Primitive_Index = ((primitive != SHARP_F)
- ? PRIMITIVE_NUMBER(primitive) : -1) ;
-#ifdef PCS_LOG_GCI_CACHE
- outf_console ("\n GC Index %d (0x%x)\n",
- Garbage_Collect_Primitive_Index,
- Garbage_Collect_Primitive_Index) ;
- outf_flush_console () ;
-#endif
-
-}
-
-DEFINE_PRIMITIVE ("%PC-SAMPLE/CACHE-GC-PRIMITIVE-INDEX",
- Prim_pc_sample_cache_GC_primitive_index, 0, 0,
- "()\n\
- Signals the microcode to go find the GARBAGE-COLLECT primitive and cache\n\
- away its index into the Primitive Table.\n\
- \n\
- This should be invoked each time the Primitive Table is altered in such a\n\
- way that existing primitives can shift about.\
- ")
-{
- PRIMITIVE_HEADER(0);
- pc_sample_cache_GC_primitive_index();
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-
-
-static volatile Boolean pc_sample_within_GC_flag = false;
-static volatile double GC_samples = 0 ;
-
-static void
-DEFUN_VOID (pc_sample_spill_GC_samples_into_primitive_table)
-{
- if ( ( GC_samples != 0) /* Something to tally */
- && (Garbage_Collect_Primitive_Index != -1) /* Safe to tally GC samples */
- )
- {
- /* flush GC_samples into GARBAGE-COLLECT entry w/in Primitive Table */
- double * fpp
- = ((double *)
- (MEMORY_LOC
- ((VECTOR_REF((Get_Fixed_Obj_Slot(PC_Sample_Primitive_Table)),
- Garbage_Collect_Primitive_Index)),
- 1))) ;
- (* fpp) = ((* fpp) + ((double) GC_samples)) ;
- }
- GC_samples = 0 ; /* reset counter */
-}
-
-DEFINE_PRIMITIVE ("PC-SAMPLE/SPILL-GC-SAMPLES-INTO-PRIMITIVE-TABLE",
- Prim_pc_sample_spill_GC_samples_into_primitive_table, 0, 0,
- "()\n\
- Make sure all samples taken during GC are present and accounted for in the\n\
- Primitive Sample Table.\
- ")
-{
- PRIMITIVE_HEADER(0);
- pc_sample_spill_GC_samples_into_primitive_table();
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-\f
-
-static void
-DEFUN_VOID (pc_sample__pre_gc_gc_synch_hook)
-{
- pc_sample_within_GC_flag = true; /* will count samples during GC */
-}
-
-static void
-DEFUN_VOID (pc_sample_post_gc_gc_synch_hook)
-{
- if ((Get_Fixed_Obj_Slot(PC_Sample_Primitive_Table)) != SHARP_F) /* enabled */
- pc_sample_spill_GC_samples_into_primitive_table() ;
- pc_sample_within_GC_flag = false;
- /***************************************************************************
- * Moby hack: may still get a few samples after this hook runs but they will
- * not be lost since we reset the counter *after* GC appears to be over, not
- * at the beginning of the next GC. Thus, eventually these GCs will be coun-
- * ted, just not necessarily right away. To be sure, however, that they get
- * appropriately charged to the current sample run, we will manually call
- * this hook whenever we try to access the primitive table in runtime code.
- ***************************************************************************/
-}
-
-/****************************************************************************
- * Following debuggery was used to isolate bug with unwarranted samples. *
- ****************************************************************************/
-static Boolean
-DEFUN (repugnant_sample_block_addr_p, (block_addr), SCHEME_OBJECT * block_addr)
-{
- /* If you uncomment the next lines, add 0x10+ to each constant below */
- /* outf_error ("Block addr = %lx\n", ((unsigned long) block_addr));
- outf_flush_error () ;
- */
- return ( (((unsigned long) block_addr) == 0x411F60FC) /* IPPB/flush */
- || (((unsigned long) block_addr) == 0x411EEBD0) /* IPPB/need2flush?*/
- || (((unsigned long) block_addr) == 0x410C6A94) /* name->package */
- || (((unsigned long) block_addr) == 0x410EB880) /* package/child */
- || (((unsigned long) block_addr) == 0x410AEB24) /* ->environment */
- ); /* block-off+0x40000000 */
-}
-
-static void /* debuggery hook */
-DEFUN (flame_block, (block_addr), SCHEME_OBJECT * block_addr)
-{
- if (pc_sample_halted)
- outf_console ("\n\nAAAHH!! 0x%x\n\n",((unsigned long) block_addr));
- else
- outf_console ("MADRE!! Bad ass = %lx ; P(h) = %d ; P(i) = %d\n",
- ((unsigned long) block_addr),
- pc_sample_halted,
- profile_interval) ;
-
- outf_flush_console () ;
-}
-\f
-static struct trap_recovery_info *
-DEFUN (find_sigcontext_ptr_pc, (scp, trinfo),
- struct FULL_SIGCONTEXT * scp AND
- struct trap_recovery_info * trinfo
- )
-{
- /* Recover the PC from the signal context ptr. */
- /* (Extracted from continue_from_trap in uxtrap.c) */
-
- long the_pc = ((FULL_SIGCONTEXT_PC (scp)) & PC_VALUE_MASK);
-
- int builtin_index;
- int utility_index;
-
- int pc_in_builtin;
- int pc_in_utility;
- int pc_in_C;
- int pc_in_heap;
- int pc_in_constant_space;
- int pc_in_scheme;
- int pc_in_hyper_space;
-
- if ((the_pc & PC_ALIGNMENT_MASK) != 0)
- {
- pc_in_builtin = false;
- pc_in_utility = false;
- pc_in_C = false;
- pc_in_heap = false;
- pc_in_constant_space = false;
- pc_in_scheme = false;
- pc_in_hyper_space = true;
- }
- else
- {
- extern int EXFUN (pc_to_builtin_index, (unsigned long));
- extern int EXFUN (pc_to_utility_index, (unsigned long));
-
- builtin_index = (pc_to_builtin_index (the_pc));
- utility_index = (pc_to_utility_index (the_pc));
-
- pc_in_builtin = (builtin_index != -1);
- pc_in_utility = (utility_index != -1);
- pc_in_heap = ( (the_pc < ((long) Heap_Top ))
- && (the_pc >= ((long) Heap_Bottom)));
- pc_in_constant_space = ( (the_pc < ((long) Free_Constant ))
- && (the_pc >= ((long) Constant_Space)));
- pc_in_scheme = ( pc_in_heap
- || pc_in_constant_space
- || pc_in_builtin);
- /* This doesnt work for dynamically loaded libraries, e.g. libc.sl:
- pc_in_C = ( (the_pc <= ((long) (get_etext ())))
- && (!pc_in_builtin));
- */
- pc_in_C = ( (!pc_in_scheme)
- && (!pc_in_builtin));
- pc_in_hyper_space = ( (! pc_in_C )
- && (! pc_in_scheme));
- }
-
- if ( pc_in_hyper_space
- || (pc_in_scheme && ALLOW_ONLY_C)) /* In hyper space. */
- {
- (trinfo -> state) = STATE_UNKNOWN;
- (trinfo -> pc_info_1) = 0; /* UFO[0]: Doesnt look like a primitive */
- (trinfo -> pc_info_2) = the_pc;
- (trinfo -> extra_trap_info) = pc_in_hyper_space;
- }
- else if (pc_in_scheme) /* In compiled code. */
- {
- SCHEME_OBJECT * block_addr = (pc_in_builtin
- ? ((SCHEME_OBJECT *) NULL)
- : (find_block_address (((PTR) the_pc),
- (pc_in_heap
- ? Heap_Bottom
- : Constant_Space))));
- if (block_addr != ((SCHEME_OBJECT *) NULL))
- {
- (trinfo -> state) = STATE_COMPILED_CODE;
- (trinfo -> pc_info_1) = /* code block */
- (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr));
- (trinfo -> pc_info_2) = /* offset w/in block */
- (LONG_TO_UNSIGNED_FIXNUM (the_pc - ((long) block_addr)));
- (trinfo -> extra_trap_info) = pc_in_constant_space;
-#ifdef PCS_LOG_REPUGNANCE
- if (repugnant_sample_block_addr_p (block_addr))
- flame_block (block_addr);
-#endif
- }
- else if (pc_in_builtin) /* In builtin */
- {
- (trinfo -> state) = STATE_BUILTIN;
- (trinfo -> pc_info_1) = builtin_index;
- (trinfo -> pc_info_2) = SHARP_T;
- (trinfo -> extra_trap_info) = true;
- }
- else /* In Probably Compiled frobby */
- {
- int prob_comp_index = (pc_in_constant_space ? 0 : 1) ;
-
- (trinfo -> state) = STATE_PROBABLY_COMPILED;
- (trinfo -> pc_info_1) = prob_comp_index;
- (trinfo -> pc_info_2) = the_pc;
- (trinfo -> extra_trap_info) = pc_in_constant_space;
- }
- }
- else /* pc_in_C */
- {
- /* In the interpreter, a primitive, or a compiled code utility. */
-
- SCHEME_OBJECT primitive = (Regs[REGBLOCK_PRIMITIVE]);
-
- if (pc_in_utility) /* In Utility */
- {
- (trinfo -> state) = STATE_UTILITY;
- (trinfo -> pc_info_1) = utility_index;
- (trinfo -> pc_info_2) = SHARP_F;
- (trinfo -> extra_trap_info) = false;
- }
- else if ((OBJECT_TYPE (primitive)) == TC_PRIMITIVE) /* In Primitive */
- {
- (trinfo -> state) = STATE_PRIMITIVE;
- (trinfo -> pc_info_1) = (PRIMITIVE_NUMBER (primitive));
- (trinfo -> pc_info_2) = primitive;
- (trinfo -> extra_trap_info) = true;
- }
- else /* In Interpreted or In UFO ?!?!?!?! */
- {
- (trinfo -> state) = STATE_UNKNOWN;
- (trinfo -> pc_info_1) = 1; /* UFO[1]: Looked like a primitive */
- (trinfo -> pc_info_2) = the_pc;
- (trinfo -> extra_trap_info) = primitive;
- }
- }
- return (trinfo) ;
-}
-\f
-/*****************************************************************************/
-static SCHEME_OBJECT
-DEFUN (pc_sample_flame_bad_table, (table_no, table), unsigned int table_no AND
- SCHEME_OBJECT table)
-{
- outf_error ("\nPC sample table (0x%x) find fault: ", table_no);
-
- if (table_no >= NFixed_Objects)
- outf_error ("bad ucode band--- table out of range.") ;
- else if (! (VECTOR_P(table)))
- outf_error ("table was not a Scheme VECTOR.") ;
- else
- outf_error("Bloody mess, that!") ;
-
- outf_error ("\n") ;
- outf_flush_error () ;
-
- return (UNSPECIFIC) ; /* Fault: signal UNSPECIFIC */
-}
-
-#ifndef PCS_TABLE_PARANOIA
-#define pc_sample_find_table(table_no) Get_Fixed_Obj_Slot (table_no)
-#else
-#define pc_sample_find_table(table_no) do \
-{ \
- SCHEME_OBJECT table; \
- \
- if ( (table_no < NFixed_Objects) /* in band? */\
- && ((table = (Get_Fixed_Obj_Slot (table_no))) != SHARP_F) /* enabled? */\
- && (VECTOR_P(table)) /* valid? */\
- ) /* Success: return vector */ \
- return (table) ; \
- else if (table == SHARP_F) /* Disabled: percolate #F */ \
- return (SHARP_F) ; \
- else /* fault: lay blame */ \
- pc_sample_flame_bad_table (table_no, table); \
-} while (FALSE)
-#endif /* PCS_TABLE_PARANOIA */
-
-
-static unsigned long
-DEFUN (pc_sample_cc_block_index, (trinfo), struct trap_recovery_info * trinfo)
-{
- /* SCHEME_OBJECT block = (trinfo -> pc_info_1);
- * unsigned int offset = (trinfo -> pc_info_2);
- */
- /* SOME DAY....
- * Compute unique ID for the entry in the code block as:
- * code_block_ID + index_of_current_cc_block_entry
- */
- /* MUCH LATER CC_BLOCK_ID (block_addr) +
- * INDEX_OF_CURRENT_CC_BLOCK_ENTRY (block_addr, offset)) ;
- *
- * .... BUT UNTIL THAT DAY ARRIVES, just store a count
- */
-
- return((unsigned long) 0) ;
-}
-
-/*****************************************************************************/
-static unsigned long
-DEFUN (pc_sample_counter_index, (trinfo), struct trap_recovery_info * trinfo)
-{
- /* For now, we just increment a single counter. Later a more exotic structure
- * may be maintained.. like discriminated counters and a real-time histogram.
- */
-
- return ((unsigned long) 0) ;
-}
-
-/*****************************************************************************/
-static unsigned long
-DEFUN (pc_sample_indexed_table_index, (trinfo), struct trap_recovery_info * trinfo)
-{
- /* pc_info_1 = index into Mumble_Procedure_Table */
-
- return ((unsigned long) (trinfo -> pc_info_1)) ;
-}
-\f
-/*****************************************************************************/
-static void
-DEFUN (pc_sample_record_table_entry, (table, index), unsigned int table AND
- unsigned long index)
-{
-
-#ifdef PCS_LOG_PUNTS /* Punt warnings */
- if (pc_sample_halted)
- {
- outf_console
- ("\n; PC sample punted in the nick of time from table 0x%x[%d].\n",
- table, index) ;
- outf_flush_console () ;
- }
- else
-#endif
-
- {
- /* For now, we just increment a counter. Later a more exotic structure
- * may be maintained here.. like a counter and a real-time histogram...
- */
- double * fpp = ((double *) (MEMORY_LOC ((VECTOR_REF (table, index)), 1)));
-
- (*fpp) += 1.0;
- }
-}
-
-
-
-
-
-
-
-
-
-/*****************************************************************************
- * Sample verbosity (console logging)...
- *****************************************************************************/
-
-/*---------------------------------------------------------------------------*/
-static void
-DEFUN (log_cobl_sample, (trinfo), struct trap_recovery_info * trinfo)
-{
- /* pc_info_1 = code block
- * pc_info_2 = offset into block
- * xtra_info = pc_in_constant_space
- */
- outf_console
- ("; PC Sampler encountered a Compiled FNORD! 0x%x (off = %d, P(c) = %d%%)\n",
- ((unsigned long)(trinfo -> pc_info_1) ),
- ( UNSIGNED_FIXNUM_TO_LONG((trinfo -> pc_info_2)) ),
- (( int)(trinfo -> extra_trap_info) )) ;
- outf_flush_console () ;
-}
-/*---------------------------------------------------------------------------*/
-static void
-DEFUN (log_prob_comp_sample, (trinfo), struct trap_recovery_info * trinfo)
-{
- /* pc_info_2 = the_pc (long)
- * xtra_info = pc_in_constant_space
- */
- outf_console
- ("; PC Sampler stumbled into a Prob Comp FNORD! at addr 0x%x (P(c) = %d%%)\n",
- (trinfo -> pc_info_2), ((Boolean)(trinfo -> extra_trap_info))) ;
- outf_flush_console () ;
-}
-\f
-/*****************************************************************************
- * More Sample verbosity (console logging)...
- *****************************************************************************/
-
-/*---------------------------------------------------------------------------*/
-static void
-DEFUN (log_UNKNOWN_STATE_sample, (trinfo), struct trap_recovery_info * trinfo)
-{
- /* ``UNKNOWN_STATE'' samples are either interpreted procs or UFOs.
- * Any way you look at it, you lose. What's that you say...?
- */
- outf_console
- ((((trinfo -> pc_info_1) == SHARP_T) /* pc_apparent_prim? */
- ? "; PC Sampler taught it taw a pwimitive...\
- \n; But it didn't. It didn't taw a pwimitive."
- : (((trinfo -> extra_trap_info) == SHARP_T) /* dreaded hyper space */
- /*------------------------------------------------------------------*/
- ? "; **** WARNING! WARNING! DANGER, WILL ROBINSON! DANGER! ****\
- \n; **** LOST IN HYPER SPACE! WE'RE DOOMED! DOOMED, I TELL YOU! ****\
- \n; **** ALL DOOMED!! OH, THE PAIN!! THE PAIN!!! ****"
- /*------------------------------------------------------------------*/
- : "; PC Sampler had a close encounter with an Unidentifiable Functional Object\
- \n; -- i.e., This is a UFO sighting! Run for your life!!\
- \n; ``You will be assimilated. Resistance is futile.''"))) ;
- /*------------------------------------------------------------------*/
- outf_console ("\n") ;
-}
-/*---------------------------------------------------------------------------*/
-static void
-DEFUN (log_interp_proc_sample, (trinfo), struct trap_recovery_info * trinfo)
-{
- /* pc_info_1 = pc_an_apparent_primitive
- * pc_info_2 = the_pc
- * extra_trap_info = /prim if pc_info_1 = #T
- * \pc_in_hyper_space otherwise
- */
- outf_console
- ("\n\
- \n;---------------------------------------------------------------------\
- \n; PC Sampler slogged down inside an interpreted bog\
- \n; in Loch 0x%x at Glen 0x%x.",
- (trinfo -> pc_info_2),
- (trinfo -> extra_trap_info)) ;
- outf_console ("\n; The context was as follows:\n") ;
- log_UNKNOWN_STATE_sample (trinfo) ;
- outf_flush_console () ;
-}
-/*---------------------------------------------------------------------------*/
-static void
-DEFUN (log_UFO_sample, (trinfo), struct trap_recovery_info * trinfo)
-{
- /* pc_info_1 = pc_an_apparent_primitive_flag
- * pc_info_2 = the_pc
- * xtra_info = /prim if pc_info_1 = #T
- * \pc_in_hyper_space otherwise
- */
- outf_console
- ("\n\
- \n;---------------------------------------------------------------------\
- \n; BEGIN TRANSMISSION \n; \
- \n; ^ \n; ` ` \
- \n; _ ` ` _ \n; \" ` ` \" \
- \n; \" ` ` \" \n; \" ` .` `. ` \" \
- \n; \" `` _ _ `` \" \n; ` ` \n;\
- \n; CAPTAINS'S LOG: ``UFO'' sighting at sector [0x%x] at warp [%d])\n",
- ((unsigned long)(trinfo -> pc_info_2)),
- (((trinfo -> pc_info_1) == SHARP_T)
- ? ((unsigned long) (trinfo -> extra_trap_info)) /* pwimitive */
- : ( (Boolean) (trinfo -> extra_trap_info))) /* hyperspace? */
- ) ;
- log_UNKNOWN_STATE_sample (trinfo) ;
- outf_console
- ("\n\
- \n; END TRANSMISSION\
- \n;---------------------------------------------------------------------\
- \n") ;
- outf_flush_console () ;
-}
-\f
-/*****************************************************************************/
-static void
-DEFUN (pc_sample_update_table, (PC_Sample_Table, trinfo, index_func_ptr),
- unsigned int PC_Sample_Table AND
- struct trap_recovery_info * trinfo AND
- unsigned long (* index_func_ptr)())
-{
- SCHEME_OBJECT table = UNSPECIFIC;
- unsigned long index;
-
-#if ( defined(PCS_LOG) /* Sample logging */ \
- || defined(PCS_LOG_PROB_COMP) \
- )
- if (PC_Sample_Table == PC_Sample_Prob_Comp_Table)
- log_prob_comp_sample (trinfo) ;
-#endif
-
-#if ( defined(PCS_LOG) /* Sample logging */ \
- || defined(PCS_LOG_UFO) \
- )
- if (PC_Sample_Table == PC_Sample_UFO_Table)
- log_UFO_sample (trinfo) ;
-#endif
-
- if ((table = pc_sample_find_table (PC_Sample_Table)) == SHARP_F)
- {
- /* Samples of this type are disabled, so drop the sample on the floor */
- /* for now... later count drops */
- return;
- }
- else
- {
- index = ((* index_func_ptr)(trinfo)) ;
-
-#ifdef PCS_TABLE_PARANOIA
- if ( (VECTOR_P (table) )
- && (VECTOR_LENGTH(table) > index)
- )
- {
-#endif /* ------------------------------ PARANOIA OVERDRIVE --------------. */
- /* | */
- if ( (PC_Sample_Table == PC_Sample_Primitive_Table) /* | */
- && ( index == Garbage_Collect_Primitive_Index) /* | */
- ) /* | */
- /* Yow! The primitives sample table will be moved by the GC *//* | */
- /* so storing into it can lose by storing into the old *//* | */
- /* (broken heart) address. *//* | */
- /* *//* | */
- /* To avoid this, we keep a count of GC samples until *//* | */
- /* the GC is over then add the GC_samples to the GC *//* | */
- /* primitive's sample entry. *//* | */
- /* *//* | */
- /* GJR installed gc_hooks for just this purpose. *//* | */
- /* Damned sporting of him, I must say. *//* | */
- /* *//* | */
- GC_samples += 1; /* | */
- else /* | */
- (pc_sample_record_table_entry (table, index)) ; /* | */
- /* | */
-#ifdef PCS_TABLE_PARANOIA /* <----------- PARANOIA OVERDRIVE --------------' */
- }
- else if (VECTOR_P(table)) /* index was out of range */
- {
- outf_error
- ("\nPC sample table (0x%x) update fault: index out of range-- %d >= %d.\n",
- PC_Sample_Table, index, (VECTOR_LENGTH(table))) ;
- outf_flush_error () ;
- }
- else if (table == UNSPECIFIC) /* fault */
- return; /* Let it slide: already flamed about it in finder. */
- else /* something's broken */
- {
- outf_error ("\nPC sample find table do a poo-poo, do a poo-poo.\n") ;
- outf_flush_error () ;
- }
-#endif /* PCS_TABLE_PARANOIA */
- }
-}
-\f
-/*****************************************************************************/
-struct profile_buffer_state
-{
- char * name; /* name string */
-
- unsigned int ID; /* indices into the Fixed Obj Vector */
- unsigned int ID_aux; /* ... for the buffer(s) */
-
- Boolean enabled_flag; /* the buffer qua buffer, as it were */
- SCHEME_OBJECT buffer;
- SCHEME_OBJECT buffer_aux;
- unsigned long length;
- unsigned long next_empty_slot_index;
-
- unsigned long slack; /* flush/extend nearness thresholds */
- long slack_increment;
-
- unsigned int flush_INT; /* Interrupt request bits */
- unsigned int extend_INT;
-
- Boolean flush_noisy_flag; /* verbosity flags for monitoring */
- Boolean extend_noisy_flag; /* ... buffer parameter performance */
- Boolean overflow_noisy_flag;
-
- Boolean flush_immed_flag; /* debuggery hook */
-
- Boolean debug_flag; /* random hook */
- Boolean monitor_flag; /* random hook */
-
- unsigned long flush_count; /* Counts for performance monitoring */
- unsigned long extend_count;
- unsigned long overflow_count;
-
- SCHEME_OBJECT extra_buffer_state_info; /* etc hook for future extensions */
-};
-\f
-/*****************************************************************************/
-static void
-DEFUN (init_profile_buffer_state, (pbs_ptr,
- name, ID, ID_aux, slack, slack_increment,
- flush_INT, extend_INT),
- struct profile_buffer_state * pbs_ptr AND
- char * name AND
- unsigned int ID AND
- unsigned int ID_aux AND
- unsigned long slack AND
- long slack_increment AND
- unsigned int flush_INT AND
- unsigned int extend_INT)
-{
- (pbs_ptr -> name) = name; /* arg */
- (pbs_ptr -> ID) = ID; /* arg */
- (pbs_ptr -> ID_aux) = ID_aux; /* arg */
- (pbs_ptr -> enabled_flag) = false;
- (pbs_ptr -> buffer) = UNSPECIFIC;
- (pbs_ptr -> buffer_aux) = UNSPECIFIC;
- (pbs_ptr -> length) = ((unsigned long) 0);
- (pbs_ptr -> next_empty_slot_index) = ((unsigned long) 0);
- (pbs_ptr -> slack) = slack; /* arg */
- (pbs_ptr -> slack_increment) = slack_increment; /* arg */
- (pbs_ptr -> flush_INT) = flush_INT; /* arg */
- (pbs_ptr -> extend_INT) = extend_INT; /* arg */
- (pbs_ptr -> flush_noisy_flag) = false;
- (pbs_ptr -> extend_noisy_flag) = false;
- (pbs_ptr -> overflow_noisy_flag) = true;
- (pbs_ptr -> flush_immed_flag) = false;
- (pbs_ptr -> debug_flag) = false; /* i.e. no count flush/xtnd */
- (pbs_ptr -> monitor_flag) = true; /* i.e. count buf overflows */
- (pbs_ptr -> flush_count) = ((unsigned long) 0);
- (pbs_ptr -> extend_count) = ((unsigned long) 0);
- (pbs_ptr -> overflow_count) = ((unsigned long) 0);
- (pbs_ptr -> extra_buffer_state_info) = SHARP_F;
-}
-/*---------------------------------------------------------------------------*/
-#define init_profile_bi_buffer_state(pbs_ptr, \
- name, ID, ID_aux, slack, slack_increment,\
- flush_INT, extend_INT) \
- init_profile_buffer_state(pbs_ptr, \
- name, ID, ID_aux, slack, slack_increment,\
- flush_INT, extend_INT)
-
-#define init_profile_uni_buffer_state(pbs_ptr, \
- name, ID, slack, slack_increment,\
- flush_INT, extend_INT) \
- init_profile_buffer_state(pbs_ptr, \
- name, ID, false, slack, slack_increment,\
- flush_INT, extend_INT)
-/*...........................................................................*\
-|*. For example... *|
-\*...........................................................................*/
-
-static struct profile_buffer_state dummy_profile_buffer_state;
-
-static void
-DEFUN_VOID (init_dummy_profile_buffer_state)
-{
- init_profile_buffer_state(&dummy_profile_buffer_state,
- "PBS Fnord!", /* name */
- false, /* ID */
- false, /* ID_aux */
- ((unsigned long) 0), /* slack */
- (( long) 0), /* slack_inc */
- ((unsigned int) 0), /* flush_INT */
- ((unsigned int) 0) /* extnd_INT */
- );
-}
-/*---------------------------------------------------------------------------*/
-\f
-/*****************************************************************************/
-static void
-DEFUN (pc_sample_record_bi_buffer_entry, (entry, entry_aux, PBS),
- SCHEME_OBJECT entry AND
- SCHEME_OBJECT entry_aux AND
- struct profile_buffer_state * PBS)
-{
- /* Cache some useful state values */
-
- unsigned long buffer_length = (PBS -> length ) ;
- unsigned long next_empty_slot_index = (PBS -> next_empty_slot_index) ;
-
- if (next_empty_slot_index >= buffer_length)
- {
- (PBS -> next_empty_slot_index) = buffer_length - 1 ;
- if (PBS -> overflow_noisy_flag)
- {
- outf_error ("\n\nBloody Hell! The bloody %s bloody overflowed.\n",
- (PBS -> name)) ;
- outf_flush_error () ;
- }
- if (PBS -> monitor_flag)
- (PBS -> overflow_count) += 1;
- }
-
-#ifdef PCS_LOG_PUNTS /* Punt warnings */
- else if (pc_sample_halted)
- {
- outf_console ("\n; PC sample %s entry punted in the nick of time.\n",
- (PBS -> name)) ;
- outf_flush_console () ;
-
- return;
- }
-#endif
-
- else
- {
- unsigned long next_index_plus_slack ;
-
- /* Cache some more useful state values */
-
- Boolean uni_buffer_flag = (! (PBS -> ID_aux)) ;
-
- SCHEME_OBJECT buffer = (PBS -> buffer ) ;
- SCHEME_OBJECT buffer_aux = (PBS -> buffer_aux) ;
- unsigned long slack = (PBS -> slack ) ;
- unsigned int flush_INT = (PBS -> flush_INT) ;
- unsigned int extend_INT = (PBS -> extend_INT) ;
-
- ( VECTOR_SET(buffer , next_empty_slot_index, entry )) ;
- if (! uni_buffer_flag)
- (VECTOR_SET(buffer_aux, next_empty_slot_index, entry_aux)) ;
-
- next_empty_slot_index += 1 ; /* incr cache */
- (PBS -> next_empty_slot_index) = next_empty_slot_index ; /* synch cache */
-
- next_index_plus_slack = next_empty_slot_index + slack ;
-
-#ifdef PCS_FLUSH_DEBUGGERY /* Flush debuggering */
- outf_console (";============================================\n") ;
- outf_console ("; name == %s\n", (PBS -> name) ) ;
- outf_console ("; ni+s == %d\n", next_index_plus_slack ) ;
- outf_console ("; blen == %d\n", buffer_length ) ;
- outf_console ("; nmti == %d\n", next_empty_slot_index ) ;
- outf_console ("; slak == %d\n", slack ) ;
- outf_console ("; BFQP == %d\n", INTERRUPT_QUEUED_P ( flush_INT)) ;
- outf_console ("; BFXP == %d\n", INTERRUPT_QUEUED_P (extend_INT)) ;
- outf_flush_console () ;
-#endif
-
-
- /* ... continued on next page ... */
-\f
- /* ... pc_sample_record_bi_buffer_entry: continued from previous page... */
-
- /* Buffer Nearly Full (or unsigned overflow) ? */
-
- if ( (next_index_plus_slack > buffer_length) /* nearfull */
- || (next_index_plus_slack < next_empty_slot_index) /* overflow */
- || (next_index_plus_slack < slack ) /* overflow */
- || (PBS -> flush_immed_flag) /* Flush debuggering */
- )
- {
- if (! (INTERRUPT_QUEUED_P(flush_INT)))
- {
- REQUEST_INTERRUPT(flush_INT) ;
- if (PBS -> flush_noisy_flag)
- { outf_console ("\n;>>>>>>>>> %s Flush Request issued.",
- (PBS -> name)) ; outf_flush_console () ;
- }
- if ((PBS -> debug_flag) && (PBS -> monitor_flag)) /* can monitor */
- (PBS -> flush_count) += 1; /* in runtime */
- }
- else if (PBS -> flush_noisy_flag)
- { outf_console ("\n;>> >> > %s Flush Request still queued.",
- (PBS -> name)) ; outf_flush_console () ;
- }
- }
-
- /* Buffer Full? */
-
- if ( (! (INTERRUPT_QUEUED_P (extend_INT)))
- && (next_empty_slot_index >= buffer_length) /* > is PARANOIA */
- )
- {
- int slack_inc_neg_p ; /* Gonna cut the slack a little slack */
- unsigned long new_slack ; /* to increase our margin of safety. */
-
- /* Cache one last useful state value */
-
- long slack_increment = (PBS -> slack_increment) ;
-
- /* Back up the next slot pointer so we don't go out of range */
-
- (PBS -> next_empty_slot_index) = buffer_length - 1 ;
-
- /* Increase slack to attempt to avoid additional overflows */
-
- slack_inc_neg_p = (slack_increment < 0) ;
- new_slack = (slack_inc_neg_p
- ? slack - ((unsigned long) (- slack_increment))
- : slack + ((unsigned long) slack_increment )) ;
-
- if ( slack_inc_neg_p && (new_slack > slack))
- new_slack = 1 ; /* unsigned underflow: min to 1 */
- else if ((! slack_inc_neg_p) && (new_slack < slack))
- new_slack = slack ; /* unsigned overflow: max to old value */
-
- (PBS -> slack) = new_slack ;
-
- /* Issue extend request */
-
- REQUEST_INTERRUPT (extend_INT) ;
- if (PBS -> extend_noisy_flag)
- { outf_console ("\n;>>>>>>>>> %s Extend Request issued.",
- (PBS -> name)) ; outf_flush_console () ;
- }
- if ((PBS -> debug_flag) && (PBS -> monitor_flag)) /* can monitor */
- (PBS -> extend_count) += 1; /* in runtime */
- }
- else if ((PBS -> extend_noisy_flag) && (INTERRUPT_QUEUED_P (extend_INT)))
- { outf_console ("\n;>> >> > %s Extend Request still queued.",
- (PBS -> name)) ; outf_flush_console () ;
- }
- }
-}
-/*...........................................................................*/
-#define FNORD UNSPECIFIC
-
-#define pc_sample_record_buffer_entry(entry, PBS) /* uni_buffer is a */\
- pc_sample_record_bi_buffer_entry(entry, FNORD, PBS) /* ...special case */
-\f
-/*****************************************************************************/
-static void
-DEFUN (pc_sample_update_bi_buffer, (buffer_state, trinfo, record_func_ptr),
- struct profile_buffer_state * buffer_state AND
- struct trap_recovery_info * trinfo AND
- void (* record_func_ptr)())
-{
- /* Like interp-procs, wanna maintain a hashtable of instances encountered,
- * so we maintain a buffer and defer to an interrupt handler to flush and
- * extend the buffer as needed. Both the code block and the offset into the
- * code block are informative (since code blocks can contain multiple
- * definitions) so both are stored in synchronized buffers [i.e., slot N of
- * each of two buffers stores the Nth sampled code block and its associated
- * code block offset].
- *
- * Moreover, purified (non-relocateable) code blocks are distinguished from
- * non-purified (``heathen''?) code blocks since the GC can move the latter
- * around but not the former...meaning that purified ones can be hashed off
- * their addr/offset alone whereas heathens must be obj hashed (christened?).
- *
- * FOR PURIFIED CODE BLOCKS...
- * Win. Location is fixed so needn't sweat GC re-location
- * For now, buffer addr/offset pairs for later hashing.
- *
- * FOR HEATHEN CODE BLOCKS...
- * Sigh. GC can re-locate, so buffer SCHEME_OBJ ptr for hashing.
- * For now, buffer away the re-locatable addr & offset for later hashing.
- *
- * Once we arrange for the linker/loader to embed a hash code, we can just
- * use that instead of buffered add/offset pairs.
- */
-
-#ifndef PCS_FOV_SNARK_HUNT
-
- if (buffer_state -> enabled_flag)
- ((* record_func_ptr)(trinfo)) ;
- else
- {
- /* Samples of this type are disabled, so drop the sample on the floor */
- /* for now... later count drops */
- return;
- }
-
- return;
-
-
- /* ... continued on next page ... */
-\f
- /* ... pc_sample_update_bi_buffer: continued from previous page ... */
-
-
-
-#else /* PCS_FOV_SNARK_HUNT */
-
- Boolean uni_buffer_flag = (! (buffer_state -> ID_aux)) ;
-
- SCHEME_OBJECT buffer_1 = (pc_sample_find_table (buffer_state -> ID )) ;
- SCHEME_OBJECT buffer_2 = (uni_buffer_flag
- ? SHARP_F /* treat as if disabled */
- : (pc_sample_find_table (buffer_state -> ID_aux)));
-
- if ( (VECTOR_P (buffer_1)) /* massive paranoia... */
- && (uni_buffer_flag || (VECTOR_P (buffer_2)))
- && (buffer_state -> enabled_flag) /* ... flag alone should suffice */
- )
- ((* record_func_ptr)(trinfo)) ;
-
- /* very paranoid debuggery... should just return now, no questions asked */
-
- else if ( (buffer_1 == SHARP_F ) /* buffer_1 disabled? */
- || (buffer_1 == UNSPECIFIC) /* buffer_1 un-initialized */
- || ( (! uni_buffer_flag) /* regardez buffer_2? */
- && ( (buffer_2 == SHARP_F ) /* buffer_2 disabled? */
- || (buffer_2 == UNSPECIFIC) /* buffer_2 un-initialized? */
- )
- )
- )
- {
-
-#ifdef PCS_PBS_ENABLE_PARANOIA /* Paranoia */
- if (buffer_state -> enabled_flag)
- {
- outf_error ("\nSigh. %s looked enabled but is disabled.\n",
- (buffer_state -> name)) ;
- outf_flush_error () ;
- }
-#endif
-
- return; /* Let it slide: find_table will have flamed if appropriate. */
- }
- else
- {
- outf_error ("\nThere's something rotten in the state of update_buffer\n") ;
- outf_flush_error () ;
- }
-
-#endif /* PCS_FOV_SNARK_HUNT */
-
-}
-/*...........................................................................*/
-
-#define pc_sample_update_buffer(buffer_state, trinfo, record_func_ptr) \
- pc_sample_update_bi_buffer(buffer_state, trinfo, record_func_ptr)/* aka */
-\f
-/*****************************************************************************/
-#include "pcsiproc.c" /* (Interpreted) Interp-Proc sampling */
-#include "pcscobl.c" /* (Compiled) Code Block sampling */
-
-#define VALID_PC_SAMPLE_ENV_P(env) ((OBJECT_TYPE (env) == TC_ENVIRONMENT))
-/*****************************************************************************/
-static void
-DEFUN (pc_sample_record, (trinfo), struct trap_recovery_info * trinfo)
-{
-
-#ifdef PCS_LOG_PUNTS /* Punt warnings */
- if (pc_sample_halted)
- {
- outf_console
- ("\n; PC sample punted at the last moment: HALTED flag set.\n");
- outf_flush_console ();
- }
- else
-#endif
-
- {
- switch (trinfo -> state)
- {
- case STATE_BUILTIN:
- pc_sample_update_table (PC_Sample_Builtin_Table, trinfo,
- pc_sample_indexed_table_index);
- break;
- case STATE_UTILITY:
- pc_sample_update_table (PC_Sample_Utility_Table, trinfo,
- pc_sample_indexed_table_index);
- break;
- case STATE_PRIMITIVE:
- pc_sample_update_table (PC_Sample_Primitive_Table, trinfo,
- pc_sample_indexed_table_index);
- break;
- case STATE_PROBABLY_COMPILED:
- pc_sample_update_table (PC_Sample_Prob_Comp_Table, trinfo,
- pc_sample_indexed_table_index);
- break;
- case STATE_COMPILED_CODE:
- pc_sample_update_table (PC_Sample_Code_Block_Table, trinfo,
- pc_sample_cc_block_index);
-
- /* Above line is a back door for future expansion...real code is: */
-
- (((Boolean)(trinfo -> extra_trap_info)) /* pc_in_constant_space */
- ? (pc_sample_update_bi_buffer (&purified_cobl_profile_buffer_state,
- trinfo,
- pc_sample_record_purified_cobl))
- : (pc_sample_update_bi_buffer (& heathen_cobl_profile_buffer_state,
- trinfo,
- pc_sample_record_heathen_cobl))) ;
- break;
- case STATE_UNKNOWN: /* i.e., in interpreted code or in hyper space */
- /* Hope we're in interpreted code and attempt to deduce the current
- * interp-proc from the current active environment frame anyway.
- * GJR suggested nabbing the current ENV to find the current PROC,
- * warning that the current ENV may be invalid, e.g. in the middle
- * of a LOAD. In that case we are S.O.L., so record a UFO. Sigh.
- */
- ((VALID_PC_SAMPLE_ENV_P (pc_sample_current_env_frame = Fetch_Env()))
- ? pc_sample_update_buffer (&interp_proc_profile_buffer_state,
- trinfo,
- pc_sample_record_interp_proc)
- : pc_sample_update_table (PC_Sample_UFO_Table,
- trinfo,
- pc_sample_indexed_table_index)) ;
- break;
- }
- }
-}
-\f
-/*****************************************************************************/
-void
-DEFUN (pc_sample, (scp), struct FULL_SIGCONTEXT * scp)
-{
-
-#ifdef PCS_LOG_PUNTS /* Punt warnings */
- if (pc_sample_halted)
- {
- outf_console ("\n; PC sample called but punted due to halt flag.\n") ;
- outf_flush_console () ;
- }
- else
-#endif
-
- if (pc_sample_within_GC_flag)
- GC_samples += 1;
- else
- {
- struct trap_recovery_info trinfo ;
-
- (pc_sample_record (find_sigcontext_ptr_pc (scp, &trinfo)));
-
-#ifdef PCS_LOG /* Sample logging */
- outf_console ("; PC sample called.\n") ;
- outf_flush_console () ;
-#endif
-
- }
-}
-
-/*****************************************************************************/
-static int
-DEFUN_VOID (pc_sample_install_gc_synch_gc_hooks)
-{
- static int stat = -1; /* some clown may call this more than once */
-
- if (stat != 0)
- {
- if ((stat = add_pre_gc_hook(pc_sample__pre_gc_gc_synch_hook)) != 0)
- outf_error (";Could not add pre_gc GC synch hook. You.lose\n");
-
- else if ((stat = add_post_gc_hook(pc_sample_post_gc_gc_synch_hook)) != 0)
- outf_error (";Could not add post_gc GC synch hook. You.lose\n");
-
- else if ((stat = add_post_gc_hook(resynch_IPPB_post_gc_hook)) != 0)
- outf_error (";Could not add post GC IPPB re-synch hook. You.lose\n");
-
- else if ((stat = add_post_gc_hook(resynch_CBPBs_post_gc_hook)) != 0)
- outf_error (";Could not add post GC CBPB re-synch hook. You.lose\n");
-
- outf_flush_error () ;
- }
- return (stat);
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/INSTALL-GC-SYNCH-GC-HOOKS",
- Prim_pc_sample_install_gc_synch_gc_hooks, 0, 0,
- "()\n\
- This must be called once when PC sampling is enabled.\n\
- \n\
- If it returns #F then PC sampling must be disabled. You.lose\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((pc_sample_install_gc_synch_gc_hooks() == 0)));
-}
-\f
-/*****************************************************************************/
-static void
-DEFUN_VOID (pc_sample_disable_microcode)
-{
- IPPB_disable (); /* From pcsiproc.c */
- CBPBs_disable (); /* From pcscobl.c */
-}
-/*---------------------------------------------------------------------------*/
-/*---------------------------------------------------------------------------*/
-static void
-DEFUN_VOID (pc_sample_init_profile_buffer_states)
-{
- init_dummy_profile_buffer_state ();
- init_IPPB_profile_buffer_state ();
- init_CBPB_profile_buffer_states();
-}
-/*---------------------------------------------------------------------------*/
-static int
-DEFUN_VOID (pc_sample_install_microcode)
-{
- static int stat = -1; /* Some clown may call this more than once */
-
- if (stat != 0)
- {
- if (! (Valid_Fixed_Obj_Vector ())) /* Profile tables are in the FOV */
- {
- outf_error
- ("\npc_sample_install_microcode encountered an invalid Fixed Obj Vector.\n") ;
- outf_flush_error () ;
- }
- else /* safe to init */
- {
- pc_sample_cache_GC_primitive_index();
-
- pc_sample_init_profile_buffer_states();
-
- if ((stat = pc_sample_install_gc_synch_gc_hooks()) != 0) /* Once only! */
- {
- outf_error
- ("; PC Sample GC synch GC hooks installation failed (0x%x)\n");
- outf_flush_error () ;
- }
- /* ... maybe more stuff here later ... */
-
- if (stat != 0)
- {
- outf_error ("; PC Sample installation failed. You.lose\n");
- outf_flush_error () ;
- }
- }
- }
- return (stat);
-}
-/*---------------------------------------------------------------------------*/
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/INSTALL-MICROCODE",
- Prim_pc_sample_install_microcode, 0, 0,
- "()\n\
- Installs the microcode support structures for PC sampling.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((pc_sample_install_microcode() == 0)));
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/DISABLE-MICROCODE",
- Prim_pc_sample_disable_microcode, 0, 0,
- "()\n\
- Disables the microcode support structures for PC sampling.\
- ")
-{
- PRIMITIVE_HEADER(0);
- pc_sample_disable_microcode ();
- PRIMITIVE_RETURN (UNSPECIFIC) ;
-}
-/*****************************************************************************/
-\f
-/* Zone operations
-
- These are not locked agains PC-Sampling activity but they are safe
- in the sense that they will at worst gain or lose a sample
-*/
-
-DEFINE_PRIMITIVE ("%PC-SAMPLE/SET-ZONE!",
- Prim_pc_sample_set_current_zone, 1, 1,
- "(index)\n\
-Set current pc-sampling zone to INDEX (a small exact integer), returning \
-the previous value if different, else #F if same.")
-{
- PRIMITIVE_HEADER(1);
- {
- int old_zone = current_zone;
- int new_zone = arg_index_integer (1, INITIAL_ZONE_LIMIT);
- if (old_zone == new_zone) {
- PRIMITIVE_RETURN (SHARP_F);
- } else {
- current_zone = new_zone;
- PRIMITIVE_RETURN (LONG_TO_FIXNUM(old_zone));
- }
- }
-}
-
-DEFINE_PRIMITIVE ("%PC-SAMPLE/MAX-ZONE",
- Prim_pc_sample_get_max_zone, 0, 0, 0)
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN(LONG_TO_FIXNUM(max_zone));
-}
-
-DEFINE_PRIMITIVE ("%PC-SAMPLE/CLEAR-ZONES!", Prim_pc_sample_clear_zones, 0, 0,
- "()\n\
-Zero zone counts.")
-{
- PRIMITIVE_HEADER (0);
- {
- int i;
- for (i = 0; i < max_zone; i++) zones[i] = 0.0;
- }
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%PC-SAMPLE/READ-ZONES!", Prim_pc_sample_read_zones, 1, 1,
- "(flonum-vector)\n\
-Copy zone counts into FLONUM-VECTOR. Returns the number copied, which \
-is limited by either the number of zones to the capacity of FLONUM-VECTOR.")
-{
- PRIMITIVE_HEADER (1);
- {
- SCHEME_OBJECT vector = (FLOATING_VECTOR_ARG (1));
- int length = FLOATING_VECTOR_LENGTH (vector);
- int limit = (length<max_zone) ? length : max_zone;
- int i;
- for (i = 0; i < limit; i++)
- FLOATING_VECTOR_SET (vector, i, zones[i]);
- PRIMITIVE_RETURN (LONG_TO_FIXNUM(limit));
- }
-}
-
-#endif /* HAVE_ITIMER */
-#endif /* REALLY_INCLUDE_PROFILE_CODE */
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-#|
-TODO:
- Flonum in counts should be coerced into exacts straight away.
- Make profile tables hold their elements weakly again (?)
- Reset should preserve enable/disable state.
- Separate timing from sampling.
-|#
-
-;;;; PC Sampling
-;;; package: (pc-sample)
-
-(declare (usual-integrations))
-\f
-(define (initialize-package!)
- (set! *pc-sample/state* 'UNINITIALIZED)
- (set! *pc-sample/sample-interval* pc-sample/default-sample-interval)
- (install))
-
-(define-primitives
- (pc-sample/timer-clear 0)
- (pc-sample/timer-set 2)
- (%pc-sample/halted? 0) ; super secret state hook
- (pc-sample/spill-GC-samples-into-primitive-table 0)
- ( interp-proc-profile-buffer/install 1)
- ( interp-proc-profile-buffer/disable 0)
- (purified-code-block-profile-buffers/install 2)
- ( heathen-code-block-profile-buffers/install 2)
- (purified-code-block-profile-buffers/disable 0)
- ( heathen-code-block-profile-buffers/disable 0)
- ;; Following for runtime/microcode installation only
- (%pc-sample/install-microcode 0)
- (%pc-sample/disable-microcode 0)
- )
-
-(define index:pc-sample/builtin-table)
-(define index:pc-sample/utility-table)
-(define index:pc-sample/primitive-table)
-(define index:pc-sample/code-block-table)
-(define index:pc-sample/purified-code-block-block-buffer)
-(define index:pc-sample/purified-code-block-offset-buffer)
-(define index:pc-sample/heathen-code-block-block-buffer)
-(define index:pc-sample/heathen-code-block-offset-buffer)
-(define index:pc-sample/interp-proc-buffer)
-(define index:pc-sample/prob-comp-table)
-(define index:pc-sample/UFO-table)
-
-(define (install-indices) ; see utabmd.scm
- (set! index:pc-sample/builtin-table
- (fixed-objects-vector-slot 'PC-Sample/Builtin-Table))
- (set! index:pc-sample/utility-table
- (fixed-objects-vector-slot 'PC-Sample/Utility-Table))
- (set! index:pc-sample/primitive-table
- (fixed-objects-vector-slot 'PC-Sample/Primitive-Table))
- (set! index:pc-sample/code-block-table
- (fixed-objects-vector-slot 'PC-Sample/Code-Block-Table))
- (set! index:pc-sample/purified-code-block-block-buffer
- (fixed-objects-vector-slot 'PC-Sample/Purified-Code-Block-Block-Buffer))
- (set! index:pc-sample/purified-code-block-offset-buffer
- (fixed-objects-vector-slot 'PC-Sample/Purified-Code-Block-Offset-Buffer))
- (set! index:pc-sample/heathen-code-block-block-buffer
- (fixed-objects-vector-slot 'PC-Sample/Heathen-Code-Block-Block-Buffer))
- (set! index:pc-sample/heathen-code-block-offset-buffer
- (fixed-objects-vector-slot 'PC-Sample/Heathen-Code-Block-Offset-Buffer))
- (set! index:pc-sample/interp-proc-buffer
- (fixed-objects-vector-slot 'PC-Sample/Interp-Proc-Buffer))
- (set! index:pc-sample/prob-comp-table
- (fixed-objects-vector-slot 'PC-Sample/Prob-Comp-Table))
- (set! index:pc-sample/UFO-table
- (fixed-objects-vector-slot 'PC-Sample/UFO-Table))
- )
-\f
-;; Sample while running pc-sample interrupt handling code?
-
-(define *pc-sample/sample-sampler?* #F) ; Ziggy wants to, but nobody else...
-
-;; Sample Interval
-
-(define *pc-sample/sample-interval*)
-(define pc-sample/default-sample-interval 20) ; milliseconds (i.e. 50Hz-ish)
-
-(define (pc-sample/sample-interval)
- "()\n\
- Returns the interval (in milliseconds) between the completion of one\n\
- PC sampling and the initiation of the next PC sampling.\n\
- This value may be changed by invoking:\n\
- (PC-SAMPLE/SET-SAMPLE-INTERVAL <interval>)\n\
- where <interval> is an exact positive integer expressing milliseconds.\n\
- The initial value for this implicit system state variable is determined\n\
- by the value returned by the expression: (PC-SAMPLE/DEFAULT-SAMPLE-INTERVAL)\
- "
- *pc-sample/sample-interval*) ; Fear not: package inits to default
-
-(define (pc-sample/set-sample-interval #!optional interval)
- "(#!OPTIONAL interval)\n\
- Sets the interval between the completion of one PC sampling and the\n\
- initiation of the next PC sampling to be roughly INTERVAL milliseconds.\n\
- If no INTERVAL argument is supplied, it defaults to the value returned by\n\
- the expression (PC-SAMPLE/DEFAULT-SAMPLE-INTERVAL).\
- "
- (set! *pc-sample/sample-interval*
- (cond ((default-object? interval)
- pc-sample/default-sample-interval)
- ((zero? interval)
- (cond (*pc-sample/noisy?*
- (display
- (string-append "\n;; PC Sampling has been disabled "
- "via a 0 msec sampling interval."))))
- 0)
- ((negative? interval) ; Smart ass.
- (display (string-append
- "\n"
- ";;-----------\n"
- ";; WARNING --\n"
- ";;-----------\n"
- ";;\n"
- ";; Your hardware configuration cannot "
- "support negative PC sampling intervals.\n"
- ";; Consult your local hardware distributor for an "
- "FTL co-processor upgrade kit.\n"
- ";;\n"
- ";; In the meantime, a sample interval of 1 msec "
- "will be used instead.\n"
- ";;\n"
- ";; Have a nice day, " (current-user-name) ".\n"))
- 1)
- ((not (integer? interval))
- (error "PC Sampling interval must be a non-negative integer."
- interval))
- (else
- interval)))
- unspecific)
-
-(define *current-user-name-promise*)
-(define (current-user-name) (force *current-user-name-promise*))
-
-(define (install-current-user-name-promise)
- (cond (*pc-sample/install-verbosity?*
- (newline)
- (display "Installing current user name promise...")
- (newline)))
- (set! *current-user-name-promise* (delay (unix/current-user-name)))
- unspecific)
-
-;; Sample State Regulation
-
-(define *pc-sample/state*)
-(define (pc-sample/state)
- *pc-sample/state*)
-(define (pc-sample/set-state! new-state)
- (set! *pc-sample/state* new-state))
-
-(define (pc-sample/uninitialized?)
- (eq? (pc-sample/state) 'UNINITIALIZED))
-
-(define (pc-sample/init #!optional start?)
- "(#!OPTIONAL start?)\n\
- Resets all PC sampling tables and sets the sampling interval to the\n\
- system default sampling interval.\n\
- This is the preferred way to initialize PC sampling in the system.\n\
- If the optional START? argument is supplied, PC sampling commences ASAP.\n\
- Otherwise, (PC-SAMPLE/START) may be invoked to commence sampling, whereupon\n\
- the evolving state of the PC sampling tables and counters may be monitored\n\
- by invoking: (PC-SAMPLE/STATUS).\
- "
- (pc-sample/reset)
- (pc-sample/set-state! 'INITIALIZED)
- (if (or (default-object? start?) (not start?))
- (pc-sample/set-sample-interval)
- (pc-sample/start))
- unspecific)
-
-(define (pc-sample/initialized?)
- (not (pc-sample/uninitialized?)))
-
-
-(define *pc-sample/noisy?* #F)
-
-(define (pc-sample/start #!optional interval)
- "(#!OPTIONAL interval)\n\
- Enables periodic sampling of the virtual Program Counter by starting the\n\
- PC sampling interrupt timer. Note that this does *not* initialize the PC\n\
- sampling tables into which the sampling profile information is gathered.\n\
- Unless/until these tables are initialized, no gathering of sampling info\n\
- will be recorded, although the PC sampling interrupts will be issued and\n\
- processed: the data will just not be recorded. To initiate sampling, refer\n\
- to (PC-SAMPLE/INIT) instead. By contrast, PC-SAMPLE/START serves two pur-\n\
- poses: 1) it is useful for unsuspending PC sampling after one has issued\n\
- a (PC-SAMPLE/STOP), and 2) it is useful for debuggering the interrupt/trap\n\
- mechanism for processing periodic PC sampling.\n\
- \n\
- The optional INTERVAL argument specifies how many milliseconds after a\n\
- PC sample completes should the next PC sample be attempted.\n\
- The evolving state of the PC sampling tables and counters may be monitored\n\
- by invoking: (PC-SAMPLE/STATUS).\
- "
- (cond ((not (default-object? interval))
- (pc-sample/set-sample-interval interval)))
- (let ((real-interval (pc-sample/sample-interval)))
- (cond ((zero? real-interval)
- (pc-sample/timer-clear)
- (pc-sample/disable)
- (cond (*pc-sample/noisy?*
- (display
- "\n;; PC Sampling DISABLED: by virtue of 0 msec interval")))
- )
- ((pc-sample/uninitialized?)
- (pc-sample/init 'START))
- (else
- (cond (*pc-sample/noisy?*
- (display (string-append "\n;; PC Sampling starting: "
- (number->string real-interval)
- " millisecond period."))))
- (pc-sample/set-state! 'RUNNING)
- (pc-sample/timer-set *ASAP* real-interval)))
- )
- unspecific)
-
-(define *ASAP* 1) ; cannot be 0... that would disable the timer.
-
-(define-integrable (pc-sample/running?)
- (not (%pc-sample/halted?)))
-
-(define-integrable (pc-sample/started?)
- (pc-sample/running?))
-
-
-(define (pc-sample/stop)
- "()\n\
- Halts PC sampling by disabling the sampling interrupt timer.\n\
- No profiling state is reset so invoking (PC-SAMPLE/START <interval>)\n\
- afterward will re-start profiling by accumulating into the existing state.\n\
- By contrast, see PC-SAMPLE/ENABLE and PC-SAMPLE/DISABLE.\n\
- The state of the PC sampling tables and counters existent at the time when\n\
- the sampling was stopped may be monitored by invoking: (PC-SAMPLE/STATUS).\
- "
- (pc-sample/timer-clear)
- (pc-sample/set-state! 'STOPPED)
- (cond (*pc-sample/noisy?*
- (display "\n;; PC Sampling stopped.")))
- unspecific)
-
-(define-integrable (pc-sample/stopped?)
- (%pc-sample/halted?))
-
-;; Status/Accessors
-
-;; Returns a structure of PC sampling profile information.
-;; This is useful for monitoring the evolving histogram of PC sampling data.
-
-(define-structure (pc-sample/status-record
- (conc-name pc-sample/status/)
- (constructor pc-sample/status
- (#!optional builtin-table
- utility-table
- primitive-table
- code-block-table
- code-block-buffer/status
- interp-proc-table
- interp-proc-buffer/status
- prob-comp-table
- UFO-table)))
- (builtin-table (pc-sample/builtin-table))
- (utility-table (pc-sample/utility-table))
- (primitive-table (pc-sample/primitive-table))
- (code-block-table (pc-sample/code-block-table))
- (code-block-buffer/status (pc-sample/code-block-buffer/status))
- (interp-proc-table (pc-sample/interp-proc-table))
- (interp-proc-buffer/status (pc-sample/interp-proc-buffer/status))
- (prob-comp-table (pc-sample/prob-comp-table))
- (UFO-table (pc-sample/UFO-table))
- )
-
-(define pc-sample/builtin-table)
-(define pc-sample/utility-table)
-(define pc-sample/primitive-table)
-(define pc-sample/purified-code-block-block-buffer)
-(define pc-sample/purified-code-block-offset-buffer)
-(define pc-sample/heathen-code-block-block-buffer)
-(define pc-sample/heathen-code-block-offset-buffer)
-(define pc-sample/interp-proc-buffer)
-(define pc-sample/prob-comp-table)
-(define pc-sample/UFO-table)
-
-(define (pc-sample/code-block-table) (code-block-profile-table))
-(define (pc-sample/code-block-buffer/status) (code-block-profile-buffer/status))
-(define (pc-sample/interp-proc-table) (interp-proc-profile-table))
-(define (pc-sample/interp-proc-buffer/status)(interp-proc-profile-buffer/status))
-
-;; Exportable naming scheme
-(define (pc-sample/builtin/status)
- (pc-sample/builtin-table))
-(define (pc-sample/utility/status)
- (pc-sample/utility-table))
-(define (pc-sample/primitive/status)
- (pc-sample/primitive-table))
-(define (pc-sample/code-block/status)
- (pc-sample/code-block-table))
-(define (pc-sample/interp-proc/status)
- (pc-sample/interp-proc-table))
-(define (pc-sample/prob-comp/status)
- (pc-sample/prob-comp-table))
-(define (pc-sample/UFO/status)
- (pc-sample/UFO-table))
-
-(define (generate:pc-sample/table-accessor index)
- (lambda ()
- (cond ((eq? index index:pc-sample/primitive-table)
- (pc-sample/spill-GC-samples-into-primitive-table)))
- (vector-ref (get-fixed-objects-vector) index)))
-
-(define (install-accessors)
- (set! pc-sample/builtin-table
- (generate:pc-sample/table-accessor index:pc-sample/builtin-table))
- (set! pc-sample/utility-table
- (generate:pc-sample/table-accessor index:pc-sample/utility-table))
- (set! pc-sample/primitive-table
- (generate:pc-sample/table-accessor index:pc-sample/primitive-table))
- (set! pc-sample/purified-code-block-block-buffer
- (generate:pc-sample/table-accessor index:pc-sample/purified-code-block-block-buffer))
- (set! pc-sample/purified-code-block-offset-buffer
- (generate:pc-sample/table-accessor index:pc-sample/purified-code-block-offset-buffer))
- (set! pc-sample/heathen-code-block-block-buffer
- (generate:pc-sample/table-accessor index:pc-sample/heathen-code-block-block-buffer))
- (set! pc-sample/heathen-code-block-offset-buffer
- (generate:pc-sample/table-accessor index:pc-sample/heathen-code-block-offset-buffer))
- (set! pc-sample/interp-proc-buffer
- (generate:pc-sample/table-accessor index:pc-sample/interp-proc-buffer))
- (set! pc-sample/prob-comp-table
- (generate:pc-sample/table-accessor index:pc-sample/prob-comp-table))
- (set! pc-sample/UFO-table
- (generate:pc-sample/table-accessor index:pc-sample/UFO-table))
- )
-
-(define-structure (pc-sample/fixed-objects-record
- (conc-name pc-sample/fixed-objects/)
- (constructor pc-sample/fixed-objects
- (#!optional builtin-table
- utility-table
- primitive-table
- purified-cobl-block-buffer
- purified-cobl-offset-buffer
- heathen-cobl-block-buffer
- heathen-cobl-offset-buffer
- interp-proc-buffer
- prob-comp-table
- UFO-table)))
- (builtin-table (pc-sample/builtin-table))
- (utility-table (pc-sample/utility-table))
- (primitive-table (pc-sample/primitive-table))
- (purified-cobl-block-buffer (pc-sample/purified-code-block-block-buffer))
- (purified-cobl-offset-buffer (pc-sample/purified-code-block-offset-buffer))
- (heathen-cobl-block-buffer (pc-sample/heathen-code-block-block-buffer))
- (heathen-cobl-offset-buffer (pc-sample/heathen-code-block-offset-buffer))
- (interp-proc-buffer (pc-sample/interp-proc-buffer))
- (prob-comp-table (pc-sample/prob-comp-table))
- (UFO-table (pc-sample/UFO-table))
- )
-
-;; Makers
-
-(define pc-sample/builtin-table/make)
-(define pc-sample/utility-table/make)
-(define pc-sample/primitive-table/make)
-(define pc-sample/code-block-buffer/make/purified-blocks)
-(define pc-sample/code-block-buffer/make/purified-offsets)
-(define pc-sample/code-block-buffer/make/heathen-blocks)
-(define pc-sample/code-block-buffer/make/heathen-offsets)
-(define pc-sample/interp-proc-buffer/make)
-(define pc-sample/prob-comp-table/make)
-(define pc-sample/UFO-table/make)
-
-(define (generate:pc-sample/table-maker length-thunk init-value-thunk)
- (lambda ()
- (make-initialized-vector (length-thunk)
- (lambda (i) i (init-value-thunk)))))
-
-(define (generate:pc-sample/buffer-maker length-thunk)
- (lambda ()
- (make-vector (length-thunk)
- ;; interp-proc-buffer is a buffer of interp-procs,
- ;; not a table of counters.
- #F)))
-
-(define (generate:pc-sample/counter-maker init-value-thunk)
- (lambda ()
- (vector (init-value-thunk) ; happy count
- (init-value-thunk) ; sad count
- )))
-
-(define (install-makers)
- (set! pc-sample/builtin-table/make
- (generate:pc-sample/table-maker get-builtin-count
- pc-sample/init-datum))
- (set! pc-sample/utility-table/make
- (generate:pc-sample/table-maker get-utility-count
- pc-sample/init-datum))
- (set! pc-sample/primitive-table/make
- (generate:pc-sample/table-maker get-primitive-count
- pc-sample/init-datum))
- (set! pc-sample/code-block-buffer/make/purified-blocks
- (generate:pc-sample/buffer-maker code-block-profile-buffer/purified/length))
- (set! pc-sample/code-block-buffer/make/purified-offsets
- (generate:pc-sample/buffer-maker code-block-profile-buffer/purified/length))
- (set! pc-sample/code-block-buffer/make/heathen-blocks
- (generate:pc-sample/buffer-maker code-block-profile-buffer/heathen/length))
- (set! pc-sample/code-block-buffer/make/heathen-offsets
- (generate:pc-sample/buffer-maker code-block-profile-buffer/heathen/length))
- (set! pc-sample/interp-proc-buffer/make
- (generate:pc-sample/buffer-maker interp-proc-profile-buffer/length))
- (set! pc-sample/prob-comp-table/make
- (generate:pc-sample/counter-maker pc-sample/init-datum))
- (set! pc-sample/UFO-table/make
- (generate:pc-sample/counter-maker pc-sample/init-datum))
- )
-
-(define (code-block-profile-buffer/purified/length) ; annoying alias
- (purified-code-block-profile-buffer/length))
-(define (code-block-profile-buffer/heathen/length) ; disturbing alias
- ( heathen-code-block-profile-buffer/length))
-
-(define (pc-sample/init-datum)
- "()\n\
- The initial PC sampling profile datum for each profiling table entry.\n\
- This is a convenient data abstraction for later extending profiling\n\
- data to be more than mere counts. More elaborate histograms are envisioned,\
- including gathering of timing and type statistics.\
- "
-;------------------------------------------------------------------------------
-; HORROR! When I used a constant 0.0, I found it shared throughout the
-; profile data structures... I think maybe my C manipulation is
-; updating in place rather than storing back into the vector(s).
-; Dr.Adams assisted me in defining this adorable little work around
-; as a means of confusing the compiler into CONS-ing up a bunch o'
-; floating point 0.0's.
-;------------------------------------------------------------------------------
- (massive-kludge *kludgey-constant*)) ; for now, just a count
-
-(define *kludgey-constant* (flo:+ 37. 42.))
-
-(define (massive-kludge x)
- (flo:- x *kludgey-constant*))
-;--------------------------------END-OF-HORROR---------------------------------
-
-;; Profile hashtables (for interp-procs [pcsiproc] & code blocks [pcscobl])
-
-(define make-profile-hash-table )
-(define profile-hash-table-car)
-(define profile-hash-table-cdr)
-
-(define (install-profile-hash-table)
-
-;;;(set! make-profile-hash-table make-weak-eq-hash-table); weakly held
-;;;(set! profile-hash-table-car weak-car)
-;;;(set! profile-hash-table-cdr weak-cdr)
-
- (set! make-profile-hash-table ; strongly held
- (strong-hash-table/constructor (lambda (obj modulus)
- (modulo (object-hash obj) modulus))
- eq?
- #T))
- (set! profile-hash-table-car car)
- (set! profile-hash-table-cdr cdr)
- )
-
-;; Old value caches
-
-;; Returns the profiling status in effect just before the last reset of any\n\
-;; PC sampling profile table.\
-
-(define-structure (pc-sample/status/previous-record
- (conc-name pc-sample/status/previous/)
- (constructor pc-sample/status/previous
- (#!optional builtin-table
- utility-table
- primitive-table
- code-block-table
- code-block-buffer/status
- interp-proc-table
- interp-proc-buffer/status
- prob-comp-table
- UFO-table)))
- (builtin-table (pc-sample/builtin-table/old))
- (utility-table (pc-sample/utility-table/old))
- (primitive-table (pc-sample/primitive-table/old))
- (code-block-table (pc-sample/code-block-table/old))
- (code-block-buffer/status (pc-sample/code-block-buffer/status/previous))
- (interp-proc-table (pc-sample/interp-proc-table/old))
- (interp-proc-buffer/status (pc-sample/interp-proc-buffer/status/previous))
- (prob-comp-table (pc-sample/prob-comp-table/old))
- (UFO-table (pc-sample/UFO-table/old))
- )
-
-(define *pc-sample/builtin-table/old* #F)
-(define (pc-sample/builtin-table/old)
- *pc-sample/builtin-table/old*)
-
-(define *pc-sample/utility-table/old* #F)
-(define (pc-sample/utility-table/old)
- *pc-sample/utility-table/old*)
-
-(define *pc-sample/primitive-table/old* #F)
-(define (pc-sample/primitive-table/old)
- *pc-sample/primitive-table/old*)
-
-(define (pc-sample/code-block-table/old)
- (code-block-profile-table/old))
-
-(define (pc-sample/code-block-buffer/status/previous)
- (code-block-profile-buffer/status/previous))
-
-(define (pc-sample/interp-proc-table/old)
- (interp-proc-profile-table/old))
-
-(define (pc-sample/interp-proc-buffer/status/previous)
- (interp-proc-profile-buffer/status/previous))
-
-(define *pc-sample/prob-comp-table/old* #F)
-(define (pc-sample/prob-comp-table/old)
- *pc-sample/prob-comp-table/old*)
-
-(define *pc-sample/UFO-table/old* #F)
-(define (pc-sample/UFO-table/old)
- *pc-sample/UFO-table/old*)
-
-;; quirk... synchronize C buffer state w/ Scheme buffer state
-
-(define-integrable (fixed-interp-proc-profile-buffer/disable)
- (interp-proc-profile-buffer/disable))
-(define-integrable (fixed-interp-proc-profile-buffer/install buffer)
- (interp-proc-profile-buffer/install buffer))
-
-;; quirks... for export to pcscobl.scm [temporary kludges]
-
-(define-integrable (fixed-purified-code-block-profile-buffers/disable)
- (purified-code-block-profile-buffers/disable))
-(define-integrable ( fixed-heathen-code-block-profile-buffers/disable)
- ( heathen-code-block-profile-buffers/disable))
-
-(define-integrable (fixed-purified-code-block-profile-buffers/install buff1
- buff2)
- (purified-code-block-profile-buffers/install buff1
- buff2))
-(define-integrable ( fixed-heathen-code-block-profile-buffers/install buff1
- buff2)
- ( heathen-code-block-profile-buffers/install buff1
- buff2))
-
-;; Resetters TODO: Worry about disabling while copying? Not for now.
-;; Maybe employ W/O-INTERRUPTS later. Maybe not.
-
-(define (pc-sample/reset #!optional disable?)
- "(#!OPTIONAL disable?)\n\
- Resets all the PC Sampling profile tables and counters, initializing them\n\
- if they have never yet been initialized.\n\
- If the optional DISABLE? argument is supplied, PC Sampling is then\n\
- disabled by virtue of disabling the PC sampling timer interrupt.\n\
- PC sampling can be re-enabled by typing: (PC-SAMPLE/ENABLE)\n\
- \n\
- For more fine grained enabling/disabling of various kinds of sampling data\n\
- consider:\n\
- \n\
- PC-SAMPLE/BUILTIN/ENABLE, PC-SAMPLE/BUILTIN/DISABLE,\n\
- PC-SAMPLE/UTILITY/ENABLE, PC-SAMPLE/UTILITY/DISABLE,\n\
- PC-SAMPLE/PRIMITIVE/ENABLE, PC-SAMPLE/PRIMITIVE/DISABLE,\n\
- PC-SAMPLE/CODE-BLOCK/ENABLE, PC-SAMPLE/CODE-BLOCK/DISABLE,\n\
- PC-SAMPLE/PURIFIED-CODE-BLOCK/ENABLE, PC-SAMPLE/PURIFIED-CODE-BLOCK/DISABLE,\n\
- PC-SAMPLE/HEATHEN-CODE-BLOCK/ENABLE, PC-SAMPLE/HEATHEN-CODE-BLOCK/DISABLE,\n\
- PC-SAMPLE/INTERP-PROC/ENABLE, PC-SAMPLE/INTERP-PROC/DISABLE,\n\
- PC-SAMPLE/PROB-COMP/ENABLE, PC-SAMPLE/PROB-COMP/DISABLE,\n\
- PC-SAMPLE/UFO/ENABLE, PC-SAMPLE/UFO/DISABLE\
- "
- (cond ((or (default-object? disable?) (not disable?))
- (pc-sample/builtin/reset)
- (pc-sample/utility/reset)
- (pc-sample/primitive/reset)
- (pc-sample/code-block/reset)
- (pc-sample/interp-proc/reset)
- (pc-sample/prob-comp/reset)
- (pc-sample/UFO/reset)
- ;; resetting in itself does not alter the state of the pc-sampling...
- 'RESET)
- (else
- (pc-sample/builtin/reset disable?)
- (pc-sample/utility/reset disable?)
- (pc-sample/primitive/reset disable?)
- (pc-sample/code-block/reset disable?)
- (pc-sample/interp-proc/reset disable?)
- (pc-sample/prob-comp/reset disable?)
- (pc-sample/UFO/reset disable?)
- (cond ((pc-sample/initialized?)
- (pc-sample/set-state! 'DISABLED)
- 'RESET-AND-DISABLED)
- (else
- 'STILL-UNINITIALIZED)))))
-
-(define pc-sample/builtin/reset)
-(define pc-sample/utility/reset)
-(define pc-sample/primitive/reset)
-(define (pc-sample/code-block/reset #!optional disable?) ; alias
- (if (or (default-object? disable?) (not disable?))
- (code-block-profile-tables/reset)
- (code-block-profile-tables/reset disable?)))
-(define (pc-sample/purified-code-block/reset #!optional disable?) ; alias
- (if (or (default-object? disable?) (not disable?))
- (purified-code-block-profile-tables/reset)
- (purified-code-block-profile-tables/reset disable?)))
-(define (pc-sample/heathen-code-block/reset #!optional disable?) ; alias
- (if (or (default-object? disable?) (not disable?))
- (heathen-code-block-profile-tables/reset)
- (heathen-code-block-profile-tables/reset disable?)))
-(define (pc-sample/interp-proc/reset #!optional disable?) ; alias
- (if (or (default-object? disable?) (not disable?))
- (interp-proc-profile-table/reset)
- (interp-proc-profile-table/reset disable?)))
-(define pc-sample/prob-comp/reset)
-(define pc-sample/UFO/reset)
-
-;; TODO: Would be very nice to maintain a bit-vector of the states of the
-;; sundry profiling tables: enabled/disabled
-
-(define (generate:pc-sample/table-resetter index save-oldy default-table-maker)
- (lambda (#!optional disable?)
- (save-oldy)
- (let ((enabling? (or (default-object? disable?) (not disable?))))
- (vector-set! (get-fixed-objects-vector)
- index
- (if enabling?
- (default-table-maker)
- #F))
- (cond (enabling?
- (cond ((pc-sample/uninitialized?)
- (pc-sample/set-state! 'RESET)))
- 'RESET-AND-ENABLED)
- ((pc-sample/uninitialized?)
- 'STILL-UNINITIALIZED)
- (else
- ;; TODO: should recognize when the last is disabled and mark
- ;; overall sampling state as disabled then.
- 'RESET-AND-DISABLED)))))
-
-;; TODO: To avoid gratuitous cons-ing, really should always maintain two
-;; of each table (current and old) then flip the two on reset, re-
-;; initializing the new current (former old). [double buffer]
-
-(define (install-resetters)
- (set! pc-sample/builtin/reset
- (generate:pc-sample/table-resetter
- index:pc-sample/builtin-table
- (lambda () (set! *pc-sample/builtin-table/old*
- (pc-sample/builtin-table)))
- pc-sample/builtin-table/make))
- (set! pc-sample/utility/reset
- (generate:pc-sample/table-resetter
- index:pc-sample/utility-table
- (lambda () (set! *pc-sample/utility-table/old*
- (pc-sample/utility-table)))
- pc-sample/utility-table/make))
- (set! pc-sample/primitive/reset
- (generate:pc-sample/table-resetter
- index:pc-sample/primitive-table
- (lambda () (set! *pc-sample/primitive-table/old*
- (pc-sample/primitive-table)))
- pc-sample/primitive-table/make))
- (set! pc-sample/prob-comp/reset
- (generate:pc-sample/table-resetter
- index:pc-sample/prob-comp-table
- (lambda () (set! *pc-sample/prob-comp-table/old*
- (pc-sample/prob-comp-table)))
- pc-sample/prob-comp-table/make))
- (set! pc-sample/UFO/reset
- (generate:pc-sample/table-resetter
- index:pc-sample/UFO-table
- (lambda () (set! *pc-sample/UFO-table/old*
- (pc-sample/UFO-table)))
- pc-sample/UFO-table/make))
- )
-
-;; Enablers/Disablers
-
-(define (pc-sample/enable)
- "()\n\
- Resets all PC sampling tables and counters and re-starts the PC\n\
- sampling periodic interrupt timer.\n\
- The old state/status of the PC sampling tables and counters can be\n\
- monitored by invoking: (PC-SAMPLE/STATUS/PREVIOUS).\n\
- The evolving state of the PC sampling tables and counters may be monitored\n\
- by invoking: (PC-SAMPLE/STATUS).\n\
- \n\
- For more fine grained enabling/disabling of various kinds of sampling data\n\
- consider:\n\
- \n\
- PC-SAMPLE/BUILTIN/ENABLE, PC-SAMPLE/BUILTIN/DISABLE,\n\
- PC-SAMPLE/UTILITY/ENABLE, PC-SAMPLE/UTILITY/DISABLE,\n\
- PC-SAMPLE/PRIMITIVE/ENABLE, PC-SAMPLE/PRIMITIVE/DISABLE,\n\
- PC-SAMPLE/CODE-BLOCK/ENABLE, PC-SAMPLE/CODE-BLOCK/DISABLE,\n\
- PC-SAMPLE/PURIFIED-CODE-BLOCK/ENABLE, PC-SAMPLE/PURIFIED-CODE-BLOCK/DISABLE,\n\
- PC-SAMPLE/HEATHEN-CODE-BLOCK/ENABLE, PC-SAMPLE/HEATHEN-CODE-BLOCK/DISABLE,\n\
- PC-SAMPLE/INTERP-PROC/ENABLE, PC-SAMPLE/INTERP-PROC/DISABLE,\n\
- PC-SAMPLE/PROB-COMP/ENABLE, PC-SAMPLE/PROB-COMP/DISABLE,\n\
- PC-SAMPLE/UFO/ENABLE, PC-SAMPLE/UFO/DISABLE\
- "
- (pc-sample/reset))
-
-(define (pc-sample/disable)
- "()\n\
- Resets all the PC sampling tables and counters then disables the PC\n\
- sampling periodic interrupt timer.\n\
- The old state/status of the PC sampling tables and counters can be\n\
- monitored by invoking: (PC-SAMPLE/STATUS/PREVIOUS).\n\
- \n\
- For more fine grained enabling/disabling of various kinds of sampling data\n\
- consider:\n\
- \n\
- PC-SAMPLE/BUILTIN/ENABLE, PC-SAMPLE/BUILTIN/DISABLE,\n\
- PC-SAMPLE/UTILITY/ENABLE, PC-SAMPLE/UTILITY/DISABLE,\n\
- PC-SAMPLE/PRIMITIVE/ENABLE, PC-SAMPLE/PRIMITIVE/DISABLE,\n\
- PC-SAMPLE/CODE-BLOCK/ENABLE, PC-SAMPLE/CODE-BLOCK/DISABLE,\n\
- PC-SAMPLE/PURIFIED-CODE-BLOCK/ENABLE, PC-SAMPLE/PURIFIED-CODE-BLOCK/DISABLE,\n\
- PC-SAMPLE/HEATHEN-CODE-BLOCK/ENABLE, PC-SAMPLE/HEATHEN-CODE-BLOCK/DISABLE,\n\
- PC-SAMPLE/INTERP-PROC/ENABLE, PC-SAMPLE/INTERP-PROC/DISABLE,\n\
- PC-SAMPLE/PROB-COMP/ENABLE, PC-SAMPLE/PROB-COMP/DISABLE,\n\
- PC-SAMPLE/UFO/ENABLE, PC-SAMPLE/UFO/DISABLE\
- "
- (pc-sample/reset 'DISABLE))
-
-
-(define (pc-sample/builtin/enable) (pc-sample/builtin/reset))
-(define (pc-sample/builtin/disable) (pc-sample/builtin/reset 'DISABLE))
-
-(define (pc-sample/utility/enable) (pc-sample/utility/reset))
-(define (pc-sample/utility/disable) (pc-sample/utility/reset 'DISABLE))
-
-(define (pc-sample/primitive/enable) (pc-sample/primitive/reset))
-(define (pc-sample/primitive/disable) (pc-sample/primitive/reset 'DISABLE))
-
-(define (pc-sample/code-block/enable) (code-block-profile-tables/enable)) ;cob
-(define (pc-sample/code-block/disable) (code-block-profile-tables/disable));cob
-
-(define (pc-sample/purified-code-block/enable) (purified-code-block-profile-tables/enable)) ;cob
-(define (pc-sample/purified-code-block/disable)(purified-code-block-profile-tables/disable));cob
-
-(define (pc-sample/heathen-code-block/enable) (heathen-code-block-profile-tables/enable)) ;cob
-(define (pc-sample/heathen-code-block/disable) (heathen-code-block-profile-tables/disable));cob
-
-(define (pc-sample/interp-proc/enable) (interp-proc-profile-table/enable)) ;clo
-(define (pc-sample/interp-proc/disable) (interp-proc-profile-table/disable)) ;clo
-
-(define (pc-sample/prob-comp/enable) (pc-sample/prob-comp/reset))
-(define (pc-sample/prob-comp/disable) (pc-sample/prob-comp/reset 'DISABLE))
-
-(define (pc-sample/UFO/enable) (pc-sample/UFO/reset))
-(define (pc-sample/UFO/disable) (pc-sample/UFO/reset 'DISABLE))
-\f
-#|
- |
- | --------------------------------------------------
- | --------------------------------------------------
- |
- | THIS PAGE INTENTIONALLY LEFT VERY NEARLY BLANK
- |
- | --------------------------------------------------
- | --------------------------------------------------
- |
- | Seriously, though, user interface hacks moved to a separate file 'cause
- | I could not decide on a stable set of basic display mechanisms... I leave
- | it to the SWAT Team to deal with all that rot. For now, see PCDISP.SCM.
- |
- |#
-\f
-;;; Call-with-pc-sampling
-
-(define *pc-sample/top-level?* #T)
-(define *pc-sample/wan-sampling?* #F) ; With-Absolutely-No-PC-Sampling
-(define *pc-sample/timing?* #F)
-(define *pc-sample/timing-deficit?* #F)
-
-(define *pc-sample/last-sampling-duration-deficit* 0 )
-(define *pc-sample/last-sampling-duration-deficit/no-gc* 0.)
-(define *pc-sample/last-sampling-duration-deficit/real* 0 )
-
-
-(define (call-with-pc-sampling thunk #!optional untimed? displayer)
- (let ((restart? (and (pc-sample/running?)
- (begin (pc-sample/stop) ; stop sampling until in d-wind
- #T))))
- (dynamic-wind
- (lambda () 'restart-sampling-even-when-thunk-craps-out)
- (lambda ()
- (let* ((tople? *pc-sample/top-level?*)
- (defle? *pc-sample/timing-deficit?*)
- (timing? *pc-sample/timing?*)
- (timing-up? (and timing? (not defle?)))
- (wanna-time? (or (default-object? untimed?) (not untimed?)))
- (time-it? (and wanna-time? (not timing?)))
- (deficit? (and (not wanna-time?) timing? ))
- (neficit? (and time-it? defle?)) ; nix enclosing deficit charge
- )
- (cond (tople? ; tolerate nesting of cwpcs
- (pc-sample/reset))) ; start afresh inside thunk
- (cond ((and tople? time-it?) ; erase deficit...
- ;;... by first killing all the liberals
- '(for-each (lambda (x) (kill x)) *liberals*)
- (set! *pc-sample/last-sampling-duration-deficit* 0 )
- (set! *pc-sample/last-sampling-duration-deficit/no-gc* 0.)
- (set! *pc-sample/last-sampling-duration-deficit/real* 0 )))
- (with-values
- (lambda ()
- ;; Uhm... would wrap fluid-let around d-wind body but then it
- ;; would be included in the sample/timing: not desirable.
- (fluid-let ((*pc-sample/top-level?* #F)
- (*pc-sample/timing?* (or time-it? timing?))
- (*pc-sample/timing-deficit?* (or deficit? defle?)))
- (dynamic-wind (lambda () (or *pc-sample/wan-sampling?*
- (pc-sample/start)))
- (if (eq? wanna-time? timing-up?)
- (lambda () (values (thunk)
- 'runtime-fnord!
- 'process-time-fnord!
- 'real-time-fnord!))
- (lambda ()
- (let* ((start-rt ( runtime ))
- (start-ptc (process-time-clock))
- (start-rtc ( real-time-clock))
- (result (thunk))
- ( end-rt ( runtime ))
- ( end-ptc (process-time-clock))
- ( end-rtc ( real-time-clock)))
- (pc-sample/stop) ; dun sample following
- (let ((p-s/no-gc (- end-rt start-rt ))
- (p-ticks (- end-ptc start-ptc))
- (r-ticks (- end-rtc start-rtc)))
- (values result
- p-s/no-gc
- p-ticks
- r-ticks)))))
- (lambda () (pc-sample/stop)))))
- (lambda (result process-secs/no-gc process-ticks real-ticks)
- ;; Probably not the best control paradigm in the world.
- ;; If you know of a more elegant solution, I'd sure like
- ;; to hear it. -ziggy@ai.mit.edu
- (cond
- ((or deficit? neficit?)
- (let ((t:mixin (if deficit? int:+ int:-))
- (s:mixin (if deficit? flo:+ flo:-)))
- (set! *pc-sample/last-sampling-duration-deficit*
- (t:mixin *pc-sample/last-sampling-duration-deficit*
- process-ticks))
- (set! *pc-sample/last-sampling-duration-deficit/no-gc*
- (s:mixin *pc-sample/last-sampling-duration-deficit/no-gc*
- process-secs/no-gc))
- (set! *pc-sample/last-sampling-duration-deficit/real*
- (t:mixin *pc-sample/last-sampling-duration-deficit/real*
- real-ticks)))))
- (cond ((and tople? time-it?)
- (time-display thunk
- process-ticks
- process-secs/no-gc
- real-ticks)))
- (cond (tople?
- (cond ((default-object? displayer)
- (*pc-sample/default-status-displayer*))
- (displayer
- (displayer)))))
- result))))
- (lambda ()
- (cond (restart?
- (pc-sample/start)))))))
-\f
-;;; Time Display
-
-(define *pc-sample/time-display?* #T)
-(define *pc-sample/time-display/running-time-too?* #T)
-(define *pc-sample/time-display/non-gc-time-too?* #T)
-
-(define *pc-sample/time-display/real-time-too?* #F)
-
-(define (time-display thunk p-ticks p-secs/no-gc r-ticks)
- ;; not integrable so customizable
- (cond
- (*pc-sample/time-display?*
- (let ((stealth-t *pc-sample/last-sampling-duration-deficit* )
- (stealth-s/no-gc *pc-sample/last-sampling-duration-deficit/no-gc*)
- (stealth-t/real *pc-sample/last-sampling-duration-deficit/real* ))
- (let (( delta-t (int:- p-ticks stealth-t ))
- ( delta-s/no-gc (flo:- p-secs/no-gc stealth-s/no-gc))
- ( delta-t/real (int:- r-ticks stealth-t/real )))
- (let ((delta-s
- (flo:round-to-magnification
- (internal-time/ticks->seconds delta-t )
- *flo:round-to-magnification/scale*))
- (delta-s/real
- (flo:round-to-magnification
- (internal-time/ticks->seconds delta-t/real)
- *flo:round-to-magnification/scale*)))
- (let ((delta-s/gc-only (flo:- delta-s delta-s/no-gc)))
- (for-each
- display
- `("\n;;;"
- "\n;;; Timed funcall of " ,thunk
- "\n;;; took (in secs) " ,delta-s
- ,@(if *pc-sample/time-display/running-time-too?*
- `("\n;;; running: " ,delta-s/no-gc)
- '())
- ,@(if *pc-sample/time-display/non-gc-time-too?*
- `("\n;;; GC time: " ,delta-s/gc-only)
- '())
- ,@(if *pc-sample/time-display/real-time-too?*
- `("\n;;; wall clock time: " ,delta-s/real)
- '())
- "\n;;;\n"
- ,@(if (fix:zero? stealth-t)
- '()
- (let ((stealth-s
- (flo:round-to-magnification
- (internal-time/ticks->seconds stealth-t )
- *flo:round-to-magnification/scale*))
- (stealth-s/real
- (flo:round-to-magnification
- (internal-time/ticks->seconds stealth-t/real)
- *flo:round-to-magnification/scale*)))
- (let ((stealth-s/gc-only
- (flo:- stealth-s stealth-s/no-gc)))
- `("\n;;; discounting " ,stealth-s
- ,@(if *pc-sample/time-display/running-time-too?*
- `("\n;;; running: " ,stealth-s/no-gc)
- '())
- ,@(if *pc-sample/time-display/non-gc-time-too?*
- `("\n;;; GC time: " ,stealth-s/gc-only)
- '())
- ,@(if *pc-sample/time-display/real-time-too?*
- `("\n;;; wall clock time: " ,stealth-s/real)
- '())
- "\n;;; seconds spent in clandestine activities."
- "\n;;;\n")))))
- ))))))))
-
-(define-integrable (flo:round-to-magnification num magnification)
- (flo:/ (flo:round (flo:* num magnification)) magnification))
-
-(define *flo:round-to-magnification/scale* 1000000.)
-\f
-
-(define (call-with-builtin-pc-sampling thunk)
- (call-with-pc-sampling thunk pc-sample/builtin/status/display))
-
-(define (call-with-utility-pc-sampling thunk)
- (call-with-pc-sampling thunk pc-sample/utility/status/display))
-
-(define (call-with-primitive-pc-sampling thunk)
- (call-with-pc-sampling thunk pc-sample/primitive/status/display))
-
-(define (call-with-code-block-pc-sampling thunk)
- (call-with-pc-sampling thunk pc-sample/code-block/status/display))
-
-(define (call-with-interp-proc-pc-sampling thunk)
- (call-with-pc-sampling thunk pc-sample/interp-proc/status/display))
-
-(define (call-with-prob-comp-pc-sampling thunk)
- (call-with-pc-sampling thunk pc-sample/prob-comp/status/display))
-
-(define (call-with-UFO-pc-sampling thunk)
- (call-with-pc-sampling thunk pc-sample/UFO/status/display))
-
-;;; With-pc-sampling
-
-(define (with-pc-sampling proc . args)
- (call-with-pc-sampling (lambda () (apply proc args))))
-(define (with-builtin-pc-sampling proc . args)
- (call-with-builtin-pc-sampling (lambda () (apply proc args))))
-(define (with-utility-pc-sampling proc . args)
- (call-with-utility-pc-sampling (lambda () (apply proc args))))
-(define (with-primitive-pc-sampling proc . args)
- (call-with-primitive-pc-sampling (lambda () (apply proc args))))
-(define (with-code-block-pc-sampling proc . args)
- (call-with-code-block-pc-sampling (lambda () (apply proc args))))
-(define (with-interp-proc-pc-sampling proc . args)
- (call-with-interp-proc-pc-sampling (lambda () (apply proc args))))
-(define (with-prob-comp-pc-sampling proc . args)
- (call-with-prob-comp-pc-sampling (lambda () (apply proc args))))
-(define (with-UFO-pc-sampling proc . args)
- (call-with-UFO-pc-sampling (lambda () (apply proc args))))
-\f
-;;; Call-without-pc-sampling
-
-(define (call-without-pc-sampling thunk #!optional untimed?)
- ;; If UNTIMED? then subtract time in thunk from total time.
- (let ((restart? (and (pc-sample/running?)
- (begin (pc-sample/stop) ; stop ASAP
- #T))))
- (dynamic-wind
- (lambda () 'restart-sampling-even-when-thunk-craps-out)
- (lambda ()
- (let* ((tople? *pc-sample/top-level?*)
- (defle? *pc-sample/timing-deficit?*)
- (timing? *pc-sample/timing?*)
- (timing-up? (and timing? (not defle?)))
- (wanna-time? (or (default-object? untimed?) (not untimed?)))
- (time-it? (and wanna-time? (not timing?)))
- (deficit? (and (not wanna-time?) timing? ))
- (neficit? (and time-it? defle?)) ; nix enclosing deficit charge
- )
- (cond ((and tople? time-it?) ; erase deficit...
- ;;... by first killing all the liberals
- '(for-each (lambda (x) (kill x)) *liberals*)
- (set! *pc-sample/last-sampling-duration-deficit* 0 )
- (set! *pc-sample/last-sampling-duration-deficit/no-gc* 0.)
- (set! *pc-sample/last-sampling-duration-deficit/real* 0 )))
- ;; Really just want fluid-let around THUNK calls, but what the hay.
- (fluid-let ((*pc-sample/top-level?* #F)
- (*pc-sample/timing?* (or time-it? timing?))
- (*pc-sample/timing-deficit?* (or deficit? defle?)))
- (if (eq? wanna-time? timing-up?)
- (thunk)
- (let* ((start-rt ( runtime ))
- (start-ptc (process-time-clock))
- (start-rtc ( real-time-clock))
- (result (thunk))
- ( end-rt ( runtime ))
- ( end-ptc (process-time-clock))
- ( end-rtc ( real-time-clock)))
- (let ((process-secs/no-gc (- end-rt start-rt ))
- (process-ticks (- end-ptc start-ptc))
- (real-ticks (- end-rtc start-rtc)))
- (cond
- ((or deficit? neficit?)
- (let ((t:mixin (if deficit? int:+ int:-))
- (s:mixin (if deficit? flo:+ flo:-)))
- (set! *pc-sample/last-sampling-duration-deficit*
- (t:mixin *pc-sample/last-sampling-duration-deficit*
- process-ticks))
- (set! *pc-sample/last-sampling-duration-deficit/no-gc*
- (s:mixin *pc-sample/last-sampling-duration-deficit/no-gc*
- process-secs/no-gc))
- (set! *pc-sample/last-sampling-duration-deficit/real*
- (t:mixin *pc-sample/last-sampling-duration-deficit/real*
- real-ticks)))))
- (cond ((and tople? time-it?)
- (time-display thunk
- process-ticks
- process-secs/no-gc
- real-ticks))))
- result)))))
- (lambda ()
- (cond (restart?
- (pc-sample/start)))))))
-
-(define (call-without-builtin-pc-sampling thunk)
- (call-without-pc-sampling thunk pc-sample/builtin/status/display))
-
-(define (call-without-utility-pc-sampling thunk)
- (call-without-pc-sampling thunk pc-sample/utility/status/display))
-
-(define (call-without-primitive-pc-sampling thunk)
- (call-without-pc-sampling thunk pc-sample/primitive/status/display))
-
-(define (call-without-code-block-pc-sampling thunk)
- (call-without-pc-sampling thunk pc-sample/code-block/status/display))
-
-(define (call-without-interp-proc-pc-sampling thunk)
- (call-without-pc-sampling thunk pc-sample/interp-proc/status/display))
-
-(define (call-without-prob-comp-pc-sampling thunk)
- (call-without-pc-sampling thunk pc-sample/prob-comp/status/display))
-
-(define (call-without-UFO-pc-sampling thunk)
- (call-without-pc-sampling thunk pc-sample/UFO/status/display))
-
-;;; Without-pc-sampling
-
-(define (without-pc-sampling proc . args)
- (call-without-pc-sampling (lambda () (apply proc args))))
-(define (without-builtin-pc-sampling proc . args)
- (call-without-builtin-pc-sampling (lambda () (apply proc args))))
-(define (without-utility-pc-sampling proc . args)
- (call-without-utility-pc-sampling (lambda () (apply proc args))))
-(define (without-primitive-pc-sampling proc . args)
- (call-without-primitive-pc-sampling (lambda () (apply proc args))))
-(define (without-code-block-pc-sampling proc . args)
- (call-without-code-block-pc-sampling (lambda () (apply proc args))))
-(define (without-interp-proc-pc-sampling proc . args)
- (call-without-interp-proc-pc-sampling (lambda () (apply proc args))))
-(define (without-prob-comp-pc-sampling proc . args)
- (call-without-prob-comp-pc-sampling (lambda () (apply proc args))))
-(define (without-UFO-pc-sampling proc . args)
- (call-without-UFO-pc-sampling (lambda () (apply proc args))))
-\f
-;;; Call-with-absolutely-no-pc-sampling
-
-(define (call-with-absolutely-no-pc-sampling thunk #!optional untimed?)
- (let ((restart? (and (pc-sample/running?)
- (begin (pc-sample/stop) ; stop ASAP
- #T))))
- (dynamic-wind
- (lambda () 'restart-sampling-even-when-thunk-craps-out)
- (lambda () (let ((untimed-arg (and (not (default-object? untimed?))
- untimed?)))
- (fluid-let ((*pc-sample/wan-sampling?* #T))
- (call-without-pc-sampling thunk untimed-arg))))
- (lambda () (cond (restart?
- (pc-sample/start)))))))
-
-(define (call-with-absolutely-no-builtin-pc-sampling thunk)
- (call-with-absolutely-no-pc-sampling thunk
- pc-sample/builtin/status/display))
-
-(define (call-with-absolutely-no-utility-pc-sampling thunk)
- (call-with-absolutely-no-pc-sampling thunk
- pc-sample/utility/status/display))
-
-(define (call-with-absolutely-no-primitive-pc-sampling thunk)
- (call-with-absolutely-no-pc-sampling thunk
- pc-sample/primitive/status/display))
-
-(define (call-with-absolutely-no-code-block-pc-sampling thunk)
- (call-with-absolutely-no-pc-sampling thunk
- pc-sample/code-block/status/display))
-
-(define (call-with-absolutely-no-interp-proc-pc-sampling thunk)
- (call-with-absolutely-no-pc-sampling thunk
- pc-sample/interp-proc/status/display))
-
-(define (call-with-absolutely-no-prob-comp-pc-sampling thunk)
- (call-with-absolutely-no-pc-sampling thunk
- pc-sample/prob-comp/status/display))
-
-(define (call-with-absolutely-no-UFO-pc-sampling thunk)
- (call-with-absolutely-no-pc-sampling thunk
- pc-sample/UFO/status/display))
-
-;;; With-absolutely-no-pc-sampling
-
-(define (with-absolutely-no-pc-sampling proc . args)
- (call-with-absolutely-no-pc-sampling (lambda () (apply proc args))))
-(define (with-absolutely-no-builtin-pc-sampling proc . args)
- (call-with-absolutely-no-builtin-pc-sampling (lambda () (apply proc args))))
-(define (with-absolutely-no-utility-pc-sampling proc . args)
- (call-with-absolutely-no-utility-pc-sampling (lambda () (apply proc args))))
-(define (with-absolutely-no-primitive-pc-sampling proc . args)
- (call-with-absolutely-no-primitive-pc-sampling (lambda () (apply proc args))))
-(define (with-absolutely-no-code-block-pc-sampling proc . args)
- (call-with-absolutely-no-code-block-pc-sampling (lambda () (apply proc args))))
-(define (with-absolutely-no-interp-proc-pc-sampling proc . args)
- (call-with-absolutely-no-interp-proc-pc-sampling (lambda () (apply proc args))))
-(define (with-absolutely-no-prob-comp-pc-sampling proc . args)
- (call-with-absolutely-no-prob-comp-pc-sampling (lambda () (apply proc args))))
-(define (with-absolutely-no-UFO-pc-sampling proc . args)
- (call-with-absolutely-no-UFO-pc-sampling (lambda () (apply proc args))))
-\f
-;;; Install
-
-(define *pc-sample/install-verbosity?* #F)
-
-(define (install-dynamic-microcode)
- (let ((pcs-directory (system-library-directory-pathname "pcsample")))
- (cond (*pc-sample/install-verbosity?*
- (newline)
- (display "Installing dynamic microcode...")
- (newline)))
- (cond ((not (implemented-primitive-procedure? ; avoid ucode re-loads
- (make-primitive-procedure '%pc-sample/install-microcode 0)))
- (let ((filename
- (->namestring (merge-pathnames "pcsdld.sl" pcs-directory))))
- (newline)
- (write-string ";Loading ")
- (write-string filename)
- (let* ((handle ((make-primitive-procedure 'load-object-file)
- filename))
- (cth ((make-primitive-procedure 'object-lookup-symbol)
- handle "initialize_pcsample_primitives" 0)))
- (write-string " -- done")
- ((make-primitive-procedure 'invoke-c-thunk) cth)))))))
-
-(define (pc-sample/install-microcode-frobs)
- (cond (*pc-sample/install-verbosity?*
- (newline)
- (display "Installing microcode frobs...")
- (newline)))
- (let ((win? (%pc-sample/install-microcode)))
- (cond ((not win?)
- (error "\nCould not install PC Sample GC synch hooks.\
- \nGame over."))))
- unspecific)
-
-(define (pc-sample/disable-microcode-frobs)
- (cond (*pc-sample/install-verbosity?*
- (newline)
- (display "Disabling microcode frobs...")
- (newline)))
- (let ((win? (%pc-sample/disable-microcode)))
- (cond ((not win?)
- (error "\nCould not disable PC Sample GC synch hooks.\
- \nGame over."))))
- unspecific)
-
-(define (install)
- ;; Dynamically load microcode
- (install-dynamic-microcode)
- (add-event-receiver! event:after-restore install-dynamic-microcode)
- ;; Install runtime stuff...
- (install-indices)
- (install-accessors)
- (install-makers)
- (install-resetters)
- (install-profile-hash-table)
- ;; Install microcode structures
- (pc-sample/install-microcode-frobs)
- (add-event-receiver! event:after-restore pc-sample/install-microcode-frobs)
- (add-event-receiver! event:before-exit pc-sample/disable-microcode-frobs)
- ;; HACK: reinitialize the variable when this code is disk-restored so
- ;; we can post way-cool bands to the Internet News servers.
- (install-current-user-name-promise)
- (add-event-receiver! event:after-restore install-current-user-name-promise)
- ;; Stop sampling at inauspicious occassions...
- (add-event-receiver! event:after-restore pc-sample/stop)
- (add-event-receiver! event:before-exit pc-sample/stop)
- )
-
-;;; fini
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; PC Sample Interrupt Bits (for consistency w/ .../runtime/boot.scm)
-;;; package: (pc-sample interrupt-handler)
-
-(declare (usual-integrations))
-
-(define-integrable interrupt-bit/IPPB-flush #x0200) ; pc-sample
-(define-integrable interrupt-bit/IPPB-extend #x0400) ; pc-sample
-(define-integrable interrupt-bit/PCBPB-flush #x0800) ; pc-sample
-(define-integrable interrupt-bit/PCBPB-extend #x1000) ; pc-sample
-(define-integrable interrupt-bit/HCBPB-flush #x2000) ; pc-sample
-(define-integrable interrupt-bit/HCBPB-extend #x4000) ; pc-sample
-
-
-;;; fini
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* PCSCOBL.C -- PC Sample subroutines for profiling code blocks *\
-\* (a.k.a. compiled procs) within pcsample.c */
-
-/** **\
-|*** BASED VERY HEAVILY ON PCSIPROC.C ***|
-\** **/
-
-/*****************************************************************************/
-#ifdef REALLY_INCLUDE_PROFILE_CODE /* scan_defines concession */
-\f
-/*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*\
- * TODO:
- *
- * - Maybe flatten number of primitives?
- *
-\*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*/
-\f
-/*****************************************************************************\
- * Code Block Profile Buffers are used for code blocks to serve the same end *
- * that the Interp-Proc Profile Buffer serves for interpreted procedures. *
- * See pcsiproc.[ch]. *
-\*****************************************************************************/
-
-/*===========================================================================*\
- *
- * Code Block Profile Buffers consist of vectors of slots and a handfull of
- * state variables...
- *
- * There are two distinct Code Block Profile Buffers:
- *
- * PCBPB - ``Purified'' Code Block Profile Buffer: for code blocks in constant
- * space, hence non-relocating
- * HCBPB - ``Heathen'' Code Block Profile Buffer: for nomadic code blocks
- *
- * Each conceptual buffer actually corresponds to two distinguishable buffers:
- * the first being a buffer of (Scheme) pointers to code block objects and the
- * second being a buffer of corresponding offsets. This is done because we want
- * to record not just the code block we are in but also the offset into it in
- * case a code block contains multiple procedure bodies. We cannot record a
- * CONS pair of code block/offset since the low level signal system must not
- * allocate heap storage. So, we maintain a synch'd pair of vectors, one for
- * what would be the CARs (blocks) and the other for the CDRs (offsets).
- *
- * << C'est la guerre. >>
- *
-\*===========================================================================*/
-
-/* block and offset buffers are synch'd wrt nxt-mt, slack & slack incr */
-
-static struct profile_buffer_state purified_cobl_profile_buffer_state;
-static struct profile_buffer_state heathen_cobl_profile_buffer_state;
-
-static void
-DEFUN_VOID (init_CBPB_profile_buffer_states)
-{
- init_profile_bi_buffer_state (&purified_cobl_profile_buffer_state,
- "PCBPB", /* name */
- PC_Sample_PCB_Block_Buffer, /* ID */
- PC_Sample_PCB_Offset_Buffer, /* ID_aux */
- 8*128, /* slack */
- 128, /* slack_inc */
- INT_PCBPB_Flush, /* flush_INT */
- INT_PCBPB_Extend /* extnd_INT */
- );
-
- init_profile_bi_buffer_state (& heathen_cobl_profile_buffer_state,
- "HCBPB", /* name */
- PC_Sample_HCB_Block_Buffer, /* ID */
- PC_Sample_HCB_Offset_Buffer, /* ID_aux */
- 8*128, /* slack */
- 128, /* slack_inc */
- INT_HCBPB_Flush, /* flush_INT */
- INT_HCBPB_Extend /* extnd_INT */
- );
-}
-
-
-
-/* convenient shorthand for use in primitives below... */
-
-#define PCBPB_name \
- (purified_cobl_profile_buffer_state . name)
-#define HCBPB_name \
- ( heathen_cobl_profile_buffer_state . name)
-#define PCBPB_ID \
- (purified_cobl_profile_buffer_state . ID)
-#define HCBPB_ID \
- ( heathen_cobl_profile_buffer_state . ID)
-#define PCBPB_enabled \
- (purified_cobl_profile_buffer_state . enabled_flag)
-#define HCBPB_enabled \
- ( heathen_cobl_profile_buffer_state . enabled_flag)
-
- /* ... continued on next page ... */
-\f
- /* ... convenient shorthand: continued from previous page ... */
-
-
-#define PCBPB_buffer \
- (purified_cobl_profile_buffer_state . buffer)
-#define HCBPB_buffer \
- ( heathen_cobl_profile_buffer_state . buffer)
-#define PCBPB_buffer_aux \
- (purified_cobl_profile_buffer_state . buffer_aux)
-#define HCBPB_buffer_aux \
- ( heathen_cobl_profile_buffer_state . buffer_aux)
-#define PCBPB_length \
- (purified_cobl_profile_buffer_state . length)
-#define HCBPB_length \
- ( heathen_cobl_profile_buffer_state . length)
-#define PCBPB_next_empty_slot_index \
- (purified_cobl_profile_buffer_state . next_empty_slot_index)
-#define HCBPB_next_empty_slot_index \
- ( heathen_cobl_profile_buffer_state . next_empty_slot_index)
-#define PCBPB_slack \
- (purified_cobl_profile_buffer_state . slack)
-#define HCBPB_slack \
- ( heathen_cobl_profile_buffer_state . slack)
-#define PCBPB_slack_increment \
- (purified_cobl_profile_buffer_state . slack_increment)
-#define HCBPB_slack_increment \
- ( heathen_cobl_profile_buffer_state . slack_increment)
-#define PCBPB_flush_INT \
- (purified_cobl_profile_buffer_state . flush_INT)
-#define HCBPB_flush_INT \
- ( heathen_cobl_profile_buffer_state . flush_INT)
-#define PCBPB_extend_INT \
- (purified_cobl_profile_buffer_state . extend_INT)
-#define HCBPB_extend_INT \
- ( heathen_cobl_profile_buffer_state . extend_INT)
-#define PCBPB_flush_noisy \
- (purified_cobl_profile_buffer_state . flush_noisy_flag)
-#define HCBPB_flush_noisy \
- ( heathen_cobl_profile_buffer_state . flush_noisy_flag)
-#define PCBPB_extend_noisy \
- (purified_cobl_profile_buffer_state . extend_noisy_flag)
-#define HCBPB_extend_noisy \
- ( heathen_cobl_profile_buffer_state . extend_noisy_flag)
-#define PCBPB_overflow_noisy \
- (purified_cobl_profile_buffer_state . overflow_noisy_flag)
-#define HCBPB_overflow_noisy \
- ( heathen_cobl_profile_buffer_state . overflow_noisy_flag)
-#define PCBPB_flush_immediate \
- (purified_cobl_profile_buffer_state . flush_immed_flag)
-#define HCBPB_flush_immediate \
- ( heathen_cobl_profile_buffer_state . flush_immed_flag)
-#define PCBPB_debugging \
- (purified_cobl_profile_buffer_state . debug_flag)
-#define HCBPB_debugging \
- (purified_cobl_profile_buffer_state . debug_flag)
-#define PCBPB_monitoring \
- (purified_cobl_profile_buffer_state . monitor_flag)
-#define HCBPB_monitoring \
- (purified_cobl_profile_buffer_state . monitor_flag)
-#define PCBPB_flush_count \
- (purified_cobl_profile_buffer_state . flush_count)
-#define HCBPB_flush_count \
- (purified_cobl_profile_buffer_state . flush_count)
-#define PCBPB_extend_count \
- (purified_cobl_profile_buffer_state . extend_count)
-#define HCBPB_extend_count \
- (purified_cobl_profile_buffer_state . extend_count)
-#define PCBPB_overflow_count \
- (purified_cobl_profile_buffer_state . overflow_count)
-#define HCBPB_overflow_count \
- (purified_cobl_profile_buffer_state . overflow_count)
-#define PCBPB_extra_info \
- (purified_cobl_profile_buffer_state . extra_buffer_state_info)
-#define HCBPB_extra_info \
- ( heathen_cobl_profile_buffer_state . extra_buffer_state_info)
-\f
-/*---------------------------------------------------------------------------*/
-#define PCBPB_disable() do \
-{ \
- Set_Fixed_Obj_Slot (PC_Sample_PCB_Block_Buffer, SHARP_F); \
- Set_Fixed_Obj_Slot (PC_Sample_PCB_Offset_Buffer, SHARP_F); \
- PCBPB_buffer = SHARP_F ; \
- PCBPB_buffer_aux = SHARP_F ; \
- PCBPB_enabled = false ; \
- PCBPB_next_empty_slot_index = 0 ; \
- PCBPB_length = 0 ; /* Paranoia */ \
-} while (FALSE)
-/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
-DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFERS/DISABLE",
- Prim_PCBPB_disable, 0, 0,
- "()\n\
- Disables the purified code block profile buffers hence disabling purified\n\
- code block profiling (unless and until new buffers are installed).\
- ")
-{
- PRIMITIVE_HEADER(0);
- PCBPB_disable ();
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-/*...........................................................................*/
-#define HCBPB_disable() do \
-{ \
- Set_Fixed_Obj_Slot (PC_Sample_HCB_Block_Buffer, SHARP_F); \
- Set_Fixed_Obj_Slot (PC_Sample_HCB_Offset_Buffer, SHARP_F); \
- HCBPB_buffer = SHARP_F ; \
- HCBPB_buffer_aux = SHARP_F ; \
- HCBPB_enabled = false ; \
- HCBPB_next_empty_slot_index = 0 ; \
- HCBPB_length = 0 ; /* Paranoia */ \
-} while (FALSE)
-/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
-DEFINE_PRIMITIVE ( "HEATHEN-CODE-BLOCK-PROFILE-BUFFERS/DISABLE",
- Prim_HCBPB_disable, 0, 0,
- "()\n\
- Disables the heathen code block profile buffers hence disabling heathen\n\
- code block profiling (unless and until new buffers are installed).\
- ")
-{
- PRIMITIVE_HEADER(0);
- HCBPB_disable ();
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-/*****************************************************************************/
-static void
-DEFUN_VOID (CBPBs_disable)
-{
- PCBPB_disable ();
- HCBPB_disable ();
-}
-\f
-/*---------------------------------------------------------------------------*/
-#define CHECK_VECTORS_SAME_LENGTH_P(v1, v2) do \
-{ \
- if ((VECTOR_LENGTH (v1)) != (VECTOR_LENGTH (v2))) \
- { \
- outf_error ("Vector arguments must be of the same length (%d != %d).\n", \
- (VECTOR_LENGTH (v1)), (VECTOR_LENGTH (v2))) ; \
- outf_flush_error () ; \
- error_external_return () ; \
- } \
-} while (FALSE)
-/*---------------------------------------------------------------------------*/
-/*---------------------------------------------------------------------------*/
-#define PCBPB_install(buffer_arg_1, buffer_arg_2) do \
-{ \
- Set_Fixed_Obj_Slot (PC_Sample_PCB_Block_Buffer, buffer_arg_1) ; \
- Set_Fixed_Obj_Slot (PC_Sample_PCB_Offset_Buffer, buffer_arg_2) ; \
- PCBPB_buffer = buffer_arg_1 ; \
- PCBPB_buffer_aux = buffer_arg_2 ; \
- PCBPB_enabled = true ; \
- PCBPB_length = (VECTOR_LENGTH (buffer_arg_1)) ; \
-} while (FALSE)
-/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
-DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFERS/INSTALL",
- Prim_PCBPB_install, 2, 2,
- "(block-vector offset-vector)\n\
- Installs BLOCK-VECTOR and OFFSET-VECTOR as the purified code block profile\n\
- buffers.\
- ")
-{
- SCHEME_OBJECT buffer_arg_1 ;
- SCHEME_OBJECT buffer_arg_2 ;
-
- PRIMITIVE_HEADER(2);
- CHECK_ARG(1, VECTOR_P);
- CHECK_ARG(2, VECTOR_P);
- buffer_arg_1 = (ARG_REF (1)) ;
- buffer_arg_2 = (ARG_REF (2)) ;
- CHECK_VECTORS_SAME_LENGTH_P(buffer_arg_1, buffer_arg_2) ;
- PCBPB_install(buffer_arg_1, buffer_arg_2) ;
- /* NB: Do NOT reset next_empty_slot_index since may be extending */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-/*...........................................................................*/
-#define HCBPB_install(buffer_arg_1, buffer_arg_2) do \
-{ \
- Set_Fixed_Obj_Slot (PC_Sample_HCB_Block_Buffer, buffer_arg_1) ; \
- Set_Fixed_Obj_Slot (PC_Sample_HCB_Offset_Buffer, buffer_arg_2) ; \
- HCBPB_buffer = buffer_arg_1 ; \
- HCBPB_buffer_aux = buffer_arg_2 ; \
- HCBPB_enabled = true ; \
- HCBPB_length = (VECTOR_LENGTH (buffer_arg_1)) ; \
-} while (FALSE)
-/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
-DEFINE_PRIMITIVE ( "HEATHEN-CODE-BLOCK-PROFILE-BUFFERS/INSTALL",
- Prim_HCBPB_install, 2, 2,
- "(block-vector offset-vector)\n\
- Installs BLOCK-VECTOR and OFFSET-VECTOR as the heathen code block profile\n\
- buffers.\
- ")
-{
- SCHEME_OBJECT buffer_arg_1 ;
- SCHEME_OBJECT buffer_arg_2 ;
-
- PRIMITIVE_HEADER(2);
- CHECK_ARG(1, VECTOR_P);
- CHECK_ARG(2, VECTOR_P);
- buffer_arg_1 = (ARG_REF (1)) ;
- buffer_arg_2 = (ARG_REF (2)) ;
- CHECK_VECTORS_SAME_LENGTH_P(buffer_arg_1, buffer_arg_2) ;
- HCBPB_install(buffer_arg_1, buffer_arg_2);
- /* NB: Do NOT reset next_empty_slot_index since may be extending */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-/*---------------------------------------------------------------------------*/
-/*---------------------------------------------------------------------------*/
-static void
-DEFUN_VOID(resynch_CBPBs_post_gc_hook)
-{
- if PCBPB_enabled
- PCBPB_install ((Get_Fixed_Obj_Slot (PC_Sample_PCB_Block_Buffer)),
- (Get_Fixed_Obj_Slot (PC_Sample_PCB_Offset_Buffer))) ;
- if HCBPB_enabled
- HCBPB_install ((Get_Fixed_Obj_Slot (PC_Sample_HCB_Block_Buffer)),
- (Get_Fixed_Obj_Slot (PC_Sample_HCB_Offset_Buffer))) ;
-}
-/*---------------------------------------------------------------------------*/
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/SLACK", Prim_PCBPB_slack,
- 0, 0,
- "()\n\
- Returns the `slack' by which the near-fullness of the profile buffer for\n\
- purified code blocks is determined and by which increment the buffer is\n\
- extended when full.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (ulong_to_integer(PCBPB_slack));
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/SLACK", Prim_HCBPB_slack,
- 0, 0,
- "()\n\
- Returns the `slack' by which the near-fullness of the profile buffer for\n\
- heathen (i.e., non-purified) code blocks is determined and by which\n\
- increment the buffer is extended when full.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (ulong_to_integer(HCBPB_slack));
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/SET-SLACK",
- Prim_PCBPB_set_slack, 1, 1,
- "(positive-fixnum)\n\
- Sets the `slack' by which the near-fullness of the PCBPB is determined and\n\
- by which increment the buffer is extended when full.\n\
- \n\
- Note that the slack must be a positive fixnum.\
- ")
-{
- PRIMITIVE_HEADER(1);
- CHECK_ARG (1, FIXNUM_POSITIVE_P);
- PCBPB_slack = (integer_to_ulong (ARG_REF (1)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/SET-SLACK",
- Prim_HCBPB_set_slack, 1, 1,
- "(positive-fixnum)\n\
- Sets the `slack' by which the near-fullness of the HCBPB is determined and\n\
- by which increment the buffer is extended when full.\n\
- \n\
- Note that the slack must be a positive fixnum.\
- ")
-{
- PRIMITIVE_HEADER(1);
- CHECK_ARG (1, FIXNUM_POSITIVE_P);
- HCBPB_slack = (integer_to_ulong (ARG_REF (1)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/SLACK-INCREMENT",
- Prim_PCBPB_slack_increment, 0, 0,
- "()\n\
- Returns the amount by which the PCBPB slack is incremented when a buffer\n\
- overflow occurs. In this sense it cuts the slack more slack.\n\
- \n\
- Note that the slack increment will always be a fixnum, but it can be negative\n\
- (in which case it functions as a slack decrement).\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (long_to_integer(PCBPB_slack_increment));
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/SLACK-INCREMENT",
- Prim_HCBPB_slack_increment, 0, 0,
- "()\n\
- Returns the amount by which the HCBPB slack is incremented when a buffer\n\
- overflow occurs. In this sense it cuts the slack more slack.\n\
- \n\
- Note that the slack increment will always be a fixnum, but it can be negative\n\
- (in which case it functions as a slack decrement).\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (long_to_integer(HCBPB_slack_increment));
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/SET-SLACK-INCREMENT",
- Prim_PCBPB_set_slack_increment, 1, 1,
- "(fixnum)\n\
- Sets the amount by which the PCBPB slack is incremented when a buffer\n\
- overflow occurs.\n\
- \n\
- Note that the slack increment must be a fixnum, but it can be negative\n\
- (in which case it functions as a slack decrement).\
- ")
-{
- PRIMITIVE_HEADER(1);
- CHECK_ARG (1, INTEGER_P);
- PCBPB_slack_increment = (integer_to_long (ARG_REF (1)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/SET-SLACK-INCREMENT",
- Prim_HCBPB_set_slack_increment, 1, 1,
- "(fixnum)\n\
- Sets the amount by which the HCBPB slack is incremented when a buffer\n\
- overflow occurs.\n\
- \n\
- Note that the slack increment must be a fixnum, but it can be negative\n\
- (in which case it functions as a slack decrement).\
- ")
-{
- PRIMITIVE_HEADER(1);
- CHECK_ARG (1, INTEGER_P);
- HCBPB_slack_increment = (integer_to_long (ARG_REF (1)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/EXTEND-NOISY?",
- Prim_PCBPB_extend_noisy_p, 0, 0,
- "()\n\
- Specifies whether notification of PCBPB buffer extensions is enabled.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_extend_noisy)) ;
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/EXTEND-NOISY?",
- Prim_HCBPB_extend_noisy_p, 0, 0,
- "()\n\
- Specifies whether notification of HCBPB buffer extensions is enabled.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_extend_noisy)) ;
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/FLUSH-NOISY?",
- Prim_PCBPB_flush_noisy_p, 0, 0,
- "()\n\
- Specifies whether notification of PCBPB buffer extensions is enabled.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_flush_noisy)) ;
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/FLUSH-NOISY?",
- Prim_HCBPB_flush_noisy_p, 0, 0,
- "()\n\
- Specifies whether notification of HCBPB buffer extensions is enabled.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_flush_noisy)) ;
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/OVERFLOW-NOISY?",
- Prim_PCBPB_overflow_noisy_p, 0, 0,
- "()\n\
- Specifies whether notification of PCBPB buffer extensions is enabled.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_overflow_noisy)) ;
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/OVERFLOW-NOISY?",
- Prim_HCBPB_overflow_noisy_p, 0, 0,
- "()\n\
- Specifies whether notification of HCBPB buffer extensions is enabled.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_overflow_noisy)) ;
-}
-\f
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/EXTEND-NOISY?/TOGGLE!",
- Prim_PCBPB_extend_noisy_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether to notify of PCBPB buffer extensions.\n\
- \n\
- It returns the newly installed sense of the flag.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PCBPB_extend_noisy = (! PCBPB_extend_noisy) ;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_flush_noisy)) ;
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/EXTEND-NOISY?/TOGGLE!",
- Prim_HCBPB_extend_noisy_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether to notify of HCBPB buffer extensions.\n\
- \n\
- It returns the newly installed sense of the flag.\
- ")
-{
- PRIMITIVE_HEADER(0);
- HCBPB_extend_noisy = (! HCBPB_extend_noisy) ;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_flush_noisy)) ;
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/FLUSH-NOISY?/TOGGLE!",
- Prim_PCBPB_flush_noisy_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether to notify of PCBPB buffer flushes.\n\
- \n\
- It returns the newly installed sense of the flag.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PCBPB_flush_noisy = (! PCBPB_flush_noisy) ;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_flush_noisy)) ;
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/FLUSH-NOISY?/TOGGLE!",
- Prim_HCBPB_flush_noisy_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether to notify of HCBPB buffer flushes.\n\
- \n\
- It returns the newly installed sense of the flag.\
- ")
-{
- PRIMITIVE_HEADER(0);
- HCBPB_flush_noisy = (! HCBPB_flush_noisy) ;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_flush_noisy)) ;
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/OVERFLOW-NOISY?/TOGGLE!",
- Prim_PCBPB_overflow_noisy_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether to notify of PCBPB buffer overflowes.\n\
- \n\
- It returns the newly installed sense of the flag.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PCBPB_overflow_noisy = (! PCBPB_overflow_noisy) ;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_overflow_noisy)) ;
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/OVERFLOW-NOISY?/TOGGLE!",
- Prim_HCBPB_overflow_noisy_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether to notify of HCBPB buffer overflowes.\n\
- \n\
- It returns the newly installed sense of the flag.\
- ")
-{
- PRIMITIVE_HEADER(0);
- HCBPB_overflow_noisy = (! HCBPB_overflow_noisy) ;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_overflow_noisy)) ;
-}
-\f
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/EMPTY?",
- Prim_PCBPB_empty_p, 0, 0,
- "()\n\
- Returns a boolean indicating whether or not the profile buffer for\n\
- purified code blocks is empty.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN(BOOLEAN_TO_OBJECT (PCBPB_next_empty_slot_index == 0));
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/EMPTY?",
- Prim_HCBPB_empty_p, 0, 0,
- "()\n\
- Returns a boolean indicating whether or not the profile buffer for\n\
- heathen (i.e., unpurified) code blocks is empty.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN(BOOLEAN_TO_OBJECT (HCBPB_next_empty_slot_index == 0));
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX",
- Prim_PCBPB_next_empty_slot_index, 0, 0,
- "()\n\
- Returns the index of the next `free' slot of the profile buffer for\n\
- purified code blocks.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN(ulong_to_integer(PCBPB_next_empty_slot_index));
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX",
- Prim_HCBPB_next_empty_slot_index, 0, 0,
- "()\n\
- Returns the index of the next `free' slot of the profile buffer for\n\
- heathen (i.e., unpurified) code blocks.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN(ulong_to_integer(HCBPB_next_empty_slot_index));
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PURIFIED-CODE-BLOCK-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX/RESET",
- Prim_PCBPB_next_empty_slot_index_reset, 0, 0,
- "()\n\
- Resets the index of the next `free' slot of the profile buffer for\n\
- purified code blocks.\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(0);
- PCBPB_next_empty_slot_index = ((unsigned long) 0);
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("%HEATHEN-CODE-BLOCK-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX/RESET",
- Prim_HCBPB_next_empty_slot_index_reset, 0, 0,
- "()\n\
- Resets the index of the next `free' slot of the profile buffer for\n\
- heathen (i.e., unpurified) code blocks.\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(0);
- HCBPB_next_empty_slot_index = ((unsigned long) 0);
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-\f
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-FLUSH-IMMEDIATE?",
- Prim_pc_sample_PCBPB_flush_immediate_p, 0, 0,
- "()\n\
- Specifies whether the Purified Code Block Profile Buffer is flushed upon\n\
- each entry.\n\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_flush_immediate)) ;
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-FLUSH-IMMEDIATE?",
- Prim_pc_sample_HCBPB_flush_immediate_p, 0, 0,
- "()\n\
- Specifies whether the Heathen Code Block Profile Buffer is flushed upon\n\
- each entry.\n\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_flush_immediate)) ;
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-FLUSH-IMMEDIATE?/TOGGLE!",
- Prim_pc_sample_PCBPB_flush_immediate_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether the Purified Code Block Profile Buffer\n\
- is flushed upon each entry.\n\
- \n\
- It returns the newly installed sense of the flag.\n\
- \n\
- This is for mondo bizarro sampler debugging purposes only.\n\
- \n\
- Only officially designated moby wizards should even think of thinking of\n\
- using this most ultra super duper secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(0);
- IPPB_flush_immediate = (! (PCBPB_flush_immediate)) ;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_flush_immediate)) ;
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-FLUSH-IMMEDIATE?/TOGGLE!",
- Prim_pc_sample_HCBPB_flush_immediate_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether the Heathen Code Block Profile Buffer\n\
- is flushed upon each entry.\n\
- \n\
- It returns the newly installed sense of the flag.\n\
- \n\
- This is for mondo bizarro sampler debugging purposes only.\n\
- \n\
- Only officially designated moby wizards should even think of thinking of\n\
- using this most ultra super duper secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(0);
- IPPB_flush_immediate = (! (HCBPB_flush_immediate)) ;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_flush_immediate)) ;
-}
-\f
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-DEBUGGING?",
- Prim_pc_sample_PCBPB_debugging_p, 0, 0,
- "()\n\
- Specifies whether the Purified Code Block Profile Buffer is in debugging mode.\n\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_debugging)) ;
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-DEBUGGING?",
- Prim_pc_sample_HCBPB_debugging_p, 0, 0,
- "()\n\
- Specifies whether the Heathen Code Block Profile Buffer is in debugging mode.\n\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_debugging)) ;
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-DEBUGGING?/TOGGLE!",
- Prim_pc_sample_PCBPB_debugging_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether the Purified Code Block Profile Buffer\n\
- is in debugging mode.\n\
- \n\
- It returns the newly installed sense of the flag.\n\
- \n\
- This is for mondo bizarro sampler debugging purposes only.\n\
- \n\
- Only officially designated moby wizards should even think of thinking of\n\
- using this most ultra super duper secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(0);
- PCBPB_debugging = (! (PCBPB_debugging)) ;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_debugging)) ;
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-DEBUGGING?/TOGGLE!",
- Prim_pc_sample_HCBPB_debugging_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether the Heathen Code Block Profile Buffer\n\
- is in debugging mode.\n\
- \n\
- It returns the newly installed sense of the flag.\n\
- \n\
- This is for mondo bizarro sampler debugging purposes only.\n\
- \n\
- Only officially designated moby wizards should even think of thinking of\n\
- using this most ultra super duper secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(0);
- HCBPB_debugging = (! (HCBPB_debugging)) ;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_debugging)) ;
-}
-\f
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-MONITORING?",
- Prim_pc_sample_PCBPB_monitoring_p, 0, 0,
- "()\n\
- Specifies whether the PCBPB is in monitoring mode.\n\
- \n\
- This, for instance, is how a count of buffer overflows is accumulated.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_monitoring)) ;
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-MONITORING?",
- Prim_pc_sample_HCBPB_monitoring_p, 0, 0,
- "()\n\
- Specifies whether the HCBPB is in monitoring mode.\n\
- \n\
- This, for instance, is how a count of buffer overflows is accumulated.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_monitoring)) ;
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-MONITORING?/TOGGLE!",
- Prim_pc_sample_PCBPB_monitoring_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether the Purified Code Block Profile Buffer\n\
- is in monitoring mode.\n\
- \n\
- It returns the newly installed sense of the flag.\n\
- \n\
- This is for mondo bizarro sampler monitoring purposes only.\n\
- For instance, toggling this monitor flag to true triggers accumulating\n\
- a count of buffer overflows.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PCBPB_monitoring = (! (PCBPB_monitoring)) ;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PCBPB_monitoring)) ;
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-MONITORING?/TOGGLE!",
- Prim_pc_sample_HCBPB_monitoring_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether the Heathen Code Block Profile Buffer\n\
- is in monitoring mode.\n\
- \n\
- It returns the newly installed sense of the flag.\n\
- \n\
- This is for mondo bizarro sampler monitoring purposes only.\n\
- For instance, toggling this monitor flag to true triggers accumulating\n\
- a count of buffer overflows.\
- ")
-{
- PRIMITIVE_HEADER(0);
- HCBPB_monitoring = (! (HCBPB_monitoring)) ;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (HCBPB_monitoring)) ;
-}
-\f
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-FLUSH-COUNT",
- Prim_pc_sample_PCBPB_flush_count, 0, 0,
- "()\n\
- Returns the number of PCBPB flush requests that have been issued since the\n\
- last PC-SAMPLE/PCBPB-FLUSH-COUNT/RESET was issued (or since booting if no\n\
- resets issued).\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN(ulong_to_integer (PCBPB_flush_count));
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-FLUSH-COUNT",
- Prim_pc_sample_HCBPB_flush_count, 0, 0,
- "()\n\
- Returns the number of HCBPB flush requests that have been issued since the\n\
- last PC-SAMPLE/HCBPB-FLUSH-COUNT/RESET was issued (or since booting if no\n\
- resets issued).\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN(ulong_to_integer (HCBPB_flush_count));
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-FLUSH-COUNT/RESET",
- Prim_pc_sample_PCBPB_flush_count_reset, 0, 0,
- "()\n\
- Resets the PCBPB flush count (obviously... sheesh!).\
- ")
-{
- PRIMITIVE_HEADER(0);
- PCBPB_flush_count = ((unsigned long) 0);
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-FLUSH-COUNT/RESET",
- Prim_pc_sample_HCBPB_flush_count_reset, 0, 0,
- "()\n\
- Resets the HCBPB flush count (obviously... sheesh!).\
- ")
-{
- PRIMITIVE_HEADER(0);
- HCBPB_flush_count = ((unsigned long) 0);
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-\f
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-EXTEND-COUNT",
- Prim_pc_sample_PCBPB_extend_count, 0, 0,
- "()\n\
- Returns the number of PCBPB extend requests that have been issued since the\n\
- last PC-SAMPLE/PCBPB-EXTEND-COUNT/RESET was issued (or since booting if no\n\
- resets issued).\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN(ulong_to_integer (PCBPB_extend_count));
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-EXTEND-COUNT",
- Prim_pc_sample_HCBPB_extend_count, 0, 0,
- "()\n\
- Returns the number of HCBPB extend requests that have been issued since the\n\
- last PC-SAMPLE/HCBPB-EXTEND-COUNT/RESET was issued (or since booting if no\n\
- resets issued).\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN(ulong_to_integer (HCBPB_extend_count));
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-EXTEND-COUNT/RESET",
- Prim_pc_sample_PCBPB_extend_count_reset, 0, 0,
- "()\n\
- Resets the PCBPB extend count (obviously... sheesh!).\
- ")
-{
- PRIMITIVE_HEADER(0);
- PCBPB_extend_count = ((unsigned long) 0);
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-EXTEND-COUNT/RESET",
- Prim_pc_sample_HCBPB_extend_count_reset, 0, 0,
- "()\n\
- Resets the HCBPB extend count (obviously... sheesh!).\
- ")
-{
- PRIMITIVE_HEADER(0);
- HCBPB_extend_count = ((unsigned long) 0);
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-\f
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-OVERFLOW-COUNT",
- Prim_pc_sample_PCBPB_overflow_count, 0, 0,
- "()\n\
- Returns the number of PCBPB overflows that have been issued since the last\n\
- PC-SAMPLE/PCBPB-OVERFLOW-COUNT/RESET was issued (or since booting if no\n\
- resets issued).\n\
- \n\
- Each overflow indicates a sample that was punted into the bit bucket.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN(ulong_to_integer (PCBPB_overflow_count));
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-OVERFLOW-COUNT",
- Prim_pc_sample_HCBPB_overflow_count, 0, 0,
- "()\n\
- Returns the number of HCBPB overflows that have been issued since the last\n\
- PC-SAMPLE/HCBPB-OVERFLOW-COUNT/RESET was issued (or since booting if no\n\
- resets issued).\n\
- \n\
- Each overflow indicates a sample that was punted into the bit bucket.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN(ulong_to_integer (HCBPB_overflow_count));
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-OVERFLOW-COUNT/RESET",
- Prim_pc_sample_PCBPB_overflow_count_reset, 0, 0,
- "()\n\
- Resets the PCBPB overflow count (obviously... sheesh!).\
- ")
-{
- PRIMITIVE_HEADER(0);
- PCBPB_overflow_count = ((unsigned long) 0);
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-OVERFLOW-COUNT/RESET",
- Prim_pc_sample_HCBPB_overflow_count_reset, 0, 0,
- "()\n\
- Resets the HCBPB overflow count (obviously... sheesh!).\
- ")
-{
- PRIMITIVE_HEADER(0);
- HCBPB_overflow_count = ((unsigned long) 0);
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-\f
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/PCBPB-EXTRA-INFO",
- Prim_pc_sample_PCBPB_extra_info, 0, 0,
- "()\n\
- Returns the extra info entry associated with the Purified Code Block\n\
- Profile Buffer.\n\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (PCBPB_extra_info) ;
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/HCBPB-EXTRA-INFO",
- Prim_pc_sample_HCBPB_extra_info, 0, 0,
- "()\n\
- Returns the extra info entry associated with the Heathen Code Block\n\
- Profile Buffer.\n\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (HCBPB_extra_info) ;
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/SET-PCBPB-EXTRA-INFO!",
- Prim_pc_sample_set_PCBPB_extra_info, 1, 1,
- "(object)\n\
- Stores OBJECT in the extra info entry of the Purified Code Block\n\
- Profile Buffer.\n\
- \n\
- This is for mondo bizarro sampler frobnication purposes only.\n\
- \n\
- Only officially designated moby wizards should even think of thinking of\n\
- using this most ultra super duper secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(1);
- PCBPB_extra_info = ARG_REF(1);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/SET-HCBPB-EXTRA-INFO!",
- Prim_pc_sample_set_HCBPB_extra_info, 1, 1,
- "(object)\n\
- Stores OBJECT in the extra info entry of the Heathen Code Block\n\
- Profile Buffer.\n\
- \n\
- This is for mondo bizarro sampler frobnication purposes only.\n\
- \n\
- Only officially designated moby wizards should even think of thinking of\n\
- using this most ultra super duper secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(1);
- HCBPB_extra_info = ARG_REF(1);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-/*---------------------------------------------------------------------------*/
-\f
-/*****************************************************************************/
-#define pc_sample_record_cobl(trinfo, buffer_state) do \
-{ \
- /* pc_info_1 = code block \
- * pc_info_2 = offset into block \
- */ \
- \
- SCHEME_OBJECT block = (trinfo -> pc_info_1) ; \
- SCHEME_OBJECT offset = (trinfo -> pc_info_2) ; \
- \
- /* Hurumph... since the lambda may never have been hashed (and trap \
- * handlers are forbidden to do the CONSing necessary to generate new hash \
- * numbers), and since there is no microcode/scheme interface for hashing \
- * microcode objects (i.e., C data) anyway, we just pass the buck up to the \
- * interrupt handler mechanism: interrupt handlers are called at delicately \
- * perspicatious moments so they are permitted to CONS. This buck is passed \
- * by buffering lambdas until we have enough of them that it is worth issu- \
- * ing a request to spill the buffer into the lambda hashtable. For more \
- * details, see pcsiproc.scm in the runtime directory. \
- */ \
- \
- pc_sample_record_bi_buffer_entry (block, offset, buffer_state) ; \
- \
-} while (FALSE)
-
-/*---------------------------------------------------------------------------*/
-static void
-DEFUN (pc_sample_record_purified_cobl, (trinfo), struct trap_recovery_info * trinfo)
-{
- pc_sample_record_cobl (trinfo, &purified_cobl_profile_buffer_state) ;
-
-#if ( defined(PCS_LOG) /* Sample console logging */ \
- || defined(PCS_LOG_COBL) \
- || defined(PCS_LOG_PURE_COBL) \
- )
- log_cobl_sample (trinfo) ;
-#endif
-
-}
-/*---------------------------------------------------------------------------*/
-static void
-DEFUN (pc_sample_record_heathen_cobl, (trinfo), struct trap_recovery_info * trinfo)
-{
- pc_sample_record_cobl (trinfo, & heathen_cobl_profile_buffer_state) ;
-
-#if ( defined(PCS_LOG) /* Sample console logging */ \
- || defined(PCS_LOG_COBL) \
- || defined(PCS_LOG_HEATHEN_COBL) \
- )
- log_cobl_sample (trinfo) ;
-#endif
-
-}
-
-
-
-
-/*****************************************************************************/
-#endif /* REALLY_INCLUDE_PROFILE_CODE */
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; PC Sampling Code Blocks (i.e., compiled procedure profiling)
-;;; package: (pc-sample code-blocks)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; ;;;
-;;;;; THIS CODE IS HEAVILY SNARFED FROM PCSIPROC.SCM ;;;;;
-;;; ;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;; Of course, this means I really should ;;;;;;;;;
-;;;;;;;;; abstract all this common structure out ;;;;;;;;;
-;;;;;;;;; but first, let's just make it work, OK ;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-#|
- |=============================================================================
- | TODO:
- | - DBG info should be groveled only at display time, not at hash time.
- |
- |=============================================================================
- |#
-
-(declare (usual-integrations))
-\f
-(define (initialize-package!)
- (set! *purified-proc-cobl-profile-table* ( proc-cobl-profile-table/make))
- (set! *heathen-proc-cobl-profile-table* ( proc-cobl-profile-table/make))
- (set! *purified-dbg-cobl-profile-table* ( dbg-cobl-profile-table/make))
- (set! *heathen-dbg-cobl-profile-table* ( dbg-cobl-profile-table/make))
- (set! *purified-raw-cobl-profile-table* ( raw-cobl-profile-table/make))
- (set! *heathen-raw-cobl-profile-table* ( raw-cobl-profile-table/make))
- (set! *purified-trampoline-profile-table* (trampoline-profile-table/make))
- (set! *heathen-trampoline-profile-table* (trampoline-profile-table/make))
- ;; microlevel buffer install
- (install-code-block-profile-buffers/length)
- ;; Bozo test
- (if (not (compiled-code-address? reconstruct-compiled-procedure))
- (warn
- "pcscobl is unhappy: reconstruct-compiled-procedure is interpreted")))
-
-(define-primitives
- (purified-code-block-profile-buffer/empty? 0)
- ( heathen-code-block-profile-buffer/empty? 0)
- (purified-code-block-profile-buffer/next-empty-slot-index 0)
- ( heathen-code-block-profile-buffer/next-empty-slot-index 0)
- (purified-code-block-profile-buffer/slack 0)
- ( heathen-code-block-profile-buffer/slack 0)
- (purified-code-block-profile-buffer/slack-increment 0)
- ( heathen-code-block-profile-buffer/slack-increment 0)
- (purified-code-block-profile-buffer/set-slack 1)
- ( heathen-code-block-profile-buffer/set-slack 1)
- (purified-code-block-profile-buffer/set-slack-increment 1)
- ( heathen-code-block-profile-buffer/set-slack-increment 1)
- (purified-code-block-profile-buffer/extend-noisy? 0)
- ( heathen-code-block-profile-buffer/extend-noisy? 0)
- (purified-code-block-profile-buffer/flush-noisy? 0)
- ( heathen-code-block-profile-buffer/flush-noisy? 0)
- (purified-code-block-profile-buffer/overflow-noisy? 0)
- ( heathen-code-block-profile-buffer/overflow-noisy? 0)
- (purified-code-block-profile-buffer/extend-noisy?/toggle! 0)
- ( heathen-code-block-profile-buffer/extend-noisy?/toggle! 0)
- (purified-code-block-profile-buffer/flush-noisy?/toggle! 0)
- ( heathen-code-block-profile-buffer/flush-noisy?/toggle! 0)
- (purified-code-block-profile-buffer/overflow-noisy?/toggle! 0)
- ( heathen-code-block-profile-buffer/overflow-noisy?/toggle! 0)
- ;; microcode magic: don't look. Fnord!
- (%pc-sample/PCBPB-overflow-count 0)
- (%pc-sample/HCBPB-overflow-count 0)
- (%pc-sample/PCBPB-overflow-count/reset 0)
- (%pc-sample/HCBPB-overflow-count/reset 0)
- (%pc-sample/PCBPB-monitoring? 0)
- (%pc-sample/HCBPB-monitoring? 0)
- (%pc-sample/PCBPB-monitoring?/toggle! 0)
- (%pc-sample/HCBPB-monitoring?/toggle! 0)
- )
-
-(define (profile-buffer/with-mumble-notification! noise? thunk
- x/f-noisy? toggle-noise!)
- (let ((already-noisy? (x/f-noisy?))
- (want-no-noise? (not noise?))) ; coerce to Boolean
- (if (eq? already-noisy? want-no-noise?) ; xor want and got
- (dynamic-wind toggle-noise! thunk toggle-noise!)
- (thunk))))
-
-(define (purified-code-block-profile-buffer/with-extend-notification! noise?
- thunk)
- (profile-buffer/with-mumble-notification! noise? thunk
- purified-code-block-profile-buffer/extend-noisy?
- purified-code-block-profile-buffer/extend-noisy?/toggle!))
-
-(define ( heathen-code-block-profile-buffer/with-extend-notification! noise?
- thunk)
- (profile-buffer/with-mumble-notification! noise? thunk
- heathen-code-block-profile-buffer/extend-noisy?
- heathen-code-block-profile-buffer/extend-noisy?/toggle!))
-
-(define (purified-code-block-profile-buffer/with-flush-notification! noise?
- thunk)
- (profile-buffer/with-mumble-notification! noise? thunk
- purified-code-block-profile-buffer/flush-noisy?
- purified-code-block-profile-buffer/flush-noisy?/toggle!))
-
-(define ( heathen-code-block-profile-buffer/with-flush-notification! noise?
- thunk)
- (profile-buffer/with-mumble-notification! noise? thunk
- heathen-code-block-profile-buffer/flush-noisy?
- heathen-code-block-profile-buffer/flush-noisy?/toggle!))
-
-(define (purified-code-block-profile-buffer/with-overflow-notification! noise?
- thunk)
- (profile-buffer/with-mumble-notification! noise? thunk
- purified-code-block-profile-buffer/overflow-noisy?
- purified-code-block-profile-buffer/overflow-noisy?/toggle!))
-
-(define ( heathen-code-block-profile-buffer/with-overflow-notification! noise?
- thunk)
- (profile-buffer/with-mumble-notification! noise? thunk
- heathen-code-block-profile-buffer/overflow-noisy?
- heathen-code-block-profile-buffer/overflow-noisy?/toggle!))
-\f
-;;; Code Block Profile Buffers buffer up sightings of compiled procs
-;;; that are not yet hashed into the Code Block Profile (Hash) Tables
-;;;
-;;; Purified code blocks are distinguished from non-purified (``heathen'') ones
-;;; because, well, it seemd like the thing to do at the time and I couldn't
-;;; think of a very good reason not to.
-
-(define *purified-code-block-profile-block-buffer* #F) ; software cache o' FOV
-(define *heathen-code-block-profile-block-buffer* #F) ; software cache o' FOV
-
-(define *purified-code-block-profile-offset-buffer* #F) ; software cache o' FOV
-(define *heathen-code-block-profile-offset-buffer* #F) ; software cache o' FOV
-
-(define (code-block-profiling-disabled?)
- (not (or *purified-code-block-profile-block-buffer* ; should all be synch'd
- *heathen-code-block-profile-block-buffer*
- *purified-code-block-profile-offset-buffer*
- *heathen-code-block-profile-offset-buffer*)))
-
-(define *purified-code-block-profile-buffer/length/initial*)
-(define *heathen-code-block-profile-buffer/length/initial*)
-
-(define (install-code-block-profile-buffers/length/initial)
- (set! *purified-code-block-profile-buffer/length/initial*
- (* 4 (purified-code-block-profile-buffer/slack)))
- (set! *heathen-code-block-profile-buffer/length/initial*
- (* 4 ( heathen-code-block-profile-buffer/slack)))
- )
-
-(define *purified-code-block-profile-buffer/length*)
-(define *heathen-code-block-profile-buffer/length*)
-
-(define (install-code-block-profile-buffers/length)
- ( install-code-block-profile-buffers/length/initial)
- (set! *purified-code-block-profile-buffer/length*
- *purified-code-block-profile-buffer/length/initial*)
- (set! *heathen-code-block-profile-buffer/length*
- *heathen-code-block-profile-buffer/length/initial*)
- )
-
-(define (purified-code-block-profile-buffer/length)
- *purified-code-block-profile-buffer/length*)
-(define ( heathen-code-block-profile-buffer/length)
- *heathen-code-block-profile-buffer/length*)
-
-(define (purified-code-block-profile-buffer/length/set! new-value)
- (set! *purified-code-block-profile-buffer/length* new-value))
-(define ( heathen-code-block-profile-buffer/length/set! new-value)
- (set! *heathen-code-block-profile-buffer/length* new-value))
-
-(define (code-block-profile-buffer/status)
- "()\n\
- Returns a list of two elements:\n\
- 0) the purified code block profile buffer status, and\n\
- 1) the heathen code block profile buffer status\n\
- each of which is a dotted pair of buffer length cross buffer slack.\
- "
- (list (purified-code-block-profile-buffer/status)
- ( heathen-code-block-profile-buffer/status)))
-
-(define (purified-code-block-profile-buffer/status)
- "()\n\
- Returns a CONS pair of the length and `slack' of the profile buffer for\n\
- purified code blocks.\
- "
- (cons (purified-code-block-profile-buffer/length)
- (purified-code-block-profile-buffer/slack)))
-(define ( heathen-code-block-profile-buffer/status)
- "()\n\
- Returns a CONS pair of the length and `slack' of the profile buffer for\n\
- heathen code blocks.\
- "
- (cons ( heathen-code-block-profile-buffer/length)
- ( heathen-code-block-profile-buffer/slack)))
-
-
-(define (code-block-profile-buffer/status/previous)
- "()\n\
- Returns the status of the profile buffer before the last modification to\n\
- its length and/or slack.\n\
- \n\
- This status is a list of two elements:\n\
- 0) the purified code block profile buffer status, and\n\
- 1) the heathen code block profile buffer status\n\
- each of which is a dotted pair of buffer length cross buffer slack.\
- "
- (list (purified-code-block-profile-buffer/status/previous)
- ( heathen-code-block-profile-buffer/status/previous)))
-
-(define *purified-code-block-profile-buffer/status/old* '(0 . 0))
-(define (purified-code-block-profile-buffer/status/previous)
- "()\n\
- Returns the status of the profile buffer before the last modification to\n\
- its length and/or slack.\
- "
- *purified-code-block-profile-buffer/status/old*)
-(define *heathen-code-block-profile-buffer/status/old* '(0 . 0))
-(define ( heathen-code-block-profile-buffer/status/previous)
- "()\n\
- Returns the status of the profile buffer before the last modification to\n\
- its length and/or slack.\
- "
- *heathen-code-block-profile-buffer/status/old*)
-\f
-;;; Purified Code Blocks
-
-;;; TODO: flush/reset/spill/extend should all employ double buffering of the
-;;; code block profile buffers.
-
-(define *purified-code-block-profile-buffer/extend-count?* #F)
-(define-integrable (purified-code-block-profile-buffer/extend-count?)
- *purified-code-block-profile-buffer/extend-count?*)
-(define-integrable (purified-code-block-profile-buffer/extend-count?/toggle!)
- (set! *purified-code-block-profile-buffer/extend-count?*
- (not *purified-code-block-profile-buffer/extend-count?*)))
-(define (purified-code-block-profile-buffer/with-extend-count! count?
- thunk)
- (fluid-let ((*purified-code-block-profile-buffer/extend-count?* count?))
- (thunk)))
-(define *purified-code-block-profile-buffer/extend-count* 0)
-(define-integrable (purified-code-block-profile-buffer/extend-count)
- *purified-code-block-profile-buffer/extend-count*)
-(define-integrable (purified-code-block-profile-buffer/extend-count/reset)
- (set! *purified-code-block-profile-buffer/extend-count* 0))
-(define-integrable (purified-code-block-profile-buffer/extend-count/1+)
- (set! *purified-code-block-profile-buffer/extend-count*
- (1+ *purified-code-block-profile-buffer/extend-count*)))
-
-(define (purified-code-block-profile-buffer/extend)
- (let ((stop/restart-sampler? (and (not *pc-sample/sample-sampler?*)
- (pc-sample/started?))))
- ;; stop if need be
- (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
- (pc-sample/stop))))
- ;; count if willed to
- (cond ((purified-code-block-profile-buffer/extend-count?)
- (purified-code-block-profile-buffer/extend-count/1+)))
- ;; No need to disable during extend since we build an extended copy of the
- ;; buffers then install them in one swell foop...
- ;; Of course, any profile samples made during the extend will be discarded.
- ;; For this reason, we go ahead and disable buffering anyway since
- ;; it would be a waste of time.
- (fixed-purified-code-block-profile-buffers/disable)
- (cond ((purified-code-block-profile-buffer/extend-noisy?)
- (with-output-to-port console-output-port ; in case we're in Edwin
- (lambda ()
- (display "\n;> > > > > PCBPB Extend Request being serviced.")))
- (output-port/flush-output console-output-port)))
- (let* ((slack (purified-code-block-profile-buffer/slack ))
- (old-buffer-length (purified-code-block-profile-buffer/length))
- (new-buffer-length (+ old-buffer-length slack) )
- (new-block-buffer
- (vector-grow *purified-code-block-profile-block-buffer*
- new-buffer-length))
- (new-offset-buffer
- (vector-grow *purified-code-block-profile-offset-buffer*
- new-buffer-length)))
- ;; INVARIANT: unused slots o purified-code-block-profile-buffer must = #F
- (do ((index old-buffer-length (1+ index)))
- ((= index new-buffer-length))
- (vector-set! new-block-buffer index #F)
- (vector-set! new-offset-buffer index #F)
- )
- ;; Install new-buffers
- (set! *purified-code-block-profile-block-buffer* new-block-buffer)
- (set! *purified-code-block-profile-offset-buffer* new-offset-buffer)
- ;; synch length cache
- (purified-code-block-profile-buffer/length/set! new-buffer-length))
- ;; Re-enable... synch kludge
- (fixed-purified-code-block-profile-buffers/install
- *purified-code-block-profile-block-buffer*
- *purified-code-block-profile-offset-buffer*)
- ;; restart if need be
- (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
- (pc-sample/start)))))
- unspecific)
-
-(define *purified-code-block-profile-buffer/flush-count?* #F)
-(define-integrable (purified-code-block-profile-buffer/flush-count?)
- *purified-code-block-profile-buffer/flush-count?*)
-(define-integrable (purified-code-block-profile-buffer/flush-count?/toggle!)
- (set! *purified-code-block-profile-buffer/flush-count?*
- (not *purified-code-block-profile-buffer/flush-count?*)))
-(define (purified-code-block-profile-buffer/with-flush-count! count?
- thunk)
- (fluid-let ((*purified-code-block-profile-buffer/flush-count?* count?))
- (thunk)))
-(define *purified-code-block-profile-buffer/flush-count* 0)
-(define-integrable (purified-code-block-profile-buffer/flush-count)
- *purified-code-block-profile-buffer/flush-count*)
-(define-integrable (purified-code-block-profile-buffer/flush-count/reset)
- (set! *purified-code-block-profile-buffer/flush-count* 0))
-(define-integrable (purified-code-block-profile-buffer/flush-count/1+)
- (set! *purified-code-block-profile-buffer/flush-count*
- (1+ *purified-code-block-profile-buffer/flush-count*)))
-
-(define-integrable (purified-code-block-profile-buffer/flush)
- (cond
- ((and *purified-code-block-profile-block-buffer* ; not disabled
- *purified-code-block-profile-offset-buffer* ; (should be synch'd)
- (purified-code-block-profile-buffer/flush?))
- (purified-code-block-profile-buffer/spill-into-code-block-profile-tables)))
- unspecific)
-
-(define (purified-code-block-profile-buffer/reset)
- ;; It is important to disable the buffers during reset so we don't have any
- ;; random ignored samples dangling in the buffer.
- (let ((next-mt-slot-index
- ;; Bletch: need to disable buffers but must sniff next-mt-slot-index
- ;; first, then must ensure nothing new is buffered.
- (without-interrupts
- (lambda ()
- (let ((nmtsi
- (purified-code-block-profile-buffer/next-empty-slot-index)))
- ;; NB: No interrupts between LET rhs and following assignments
- (fixed-purified-code-block-profile-buffers/disable)
- nmtsi)))))
- ;; It is useful to keep a global var as a handle on this object.
- (cond ((and *purified-code-block-profile-block-buffer*
- *purified-code-block-profile-offset-buffer*) ;(should B synchd)
- ;; Already initialized so avoid CONS-ing
- (subvector-fill! *purified-code-block-profile-block-buffer*
- 0 next-mt-slot-index #F)
- (subvector-fill! *purified-code-block-profile-offset-buffer*
- 0 next-mt-slot-index #F)
- )
- (else
- ;; Else initialize them
- (set! *purified-code-block-profile-block-buffer*
- (pc-sample/code-block-buffer/make/purified-blocks))
- (set! *purified-code-block-profile-offset-buffer*
- (pc-sample/code-block-buffer/make/purified-offsets))
- )))
- ;; Re-enable... synch kludge
- (fixed-purified-code-block-profile-buffers/install
- *purified-code-block-profile-block-buffer*
- *purified-code-block-profile-offset-buffer*)
- (cond ((pc-sample/uninitialized?)
- (pc-sample/set-state! 'RESET)))
- 'RESET)
-
-(define (purified-code-block-profile-buffer/flush?)
- (not (purified-code-block-profile-buffer/empty?)))
-
-(define (purified-code-block-profile-buffer/spill-into-code-block-profile-tables)
- (let ((stop/restart-sampler? (and (not *pc-sample/sample-sampler?*)
- (pc-sample/started?))))
- ;; stop if need be
- (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
- (pc-sample/stop))))
- ;; count if willed to
- (cond ((purified-code-block-profile-buffer/flush-count?)
- (purified-code-block-profile-buffer/flush-count/1+)))
- ;; It is important to disable the buffers during spillage so we don't have
- ;; random ignored samples dangling in the buffer.
- (let ((next-mt-slot-index
- ;; Bletch: need to disable buffers but must sniff next-mt-slot-index
- ;; first, then must ensure nothing new is buffered.
- (without-interrupts
- (lambda ()
- (let
- ((nmtsi
- (purified-code-block-profile-buffer/next-empty-slot-index)))
- ;; NB: No interrupts between LET rhs and following assignments
- (fixed-purified-code-block-profile-buffers/disable)
- nmtsi)))))
- (cond ((purified-code-block-profile-buffer/flush-noisy?)
- (with-output-to-port console-output-port ; in case we're in Edwin
- (lambda ()
- (display "\n;> > > > > PCBPB Flush Request being serviced.")))
- (output-port/flush-output console-output-port)))
- (do ((index 0 (1+ index)))
- ((= index next-mt-slot-index))
- ;; copy from buffer into hash table
- (purified-code-block-profile-tables/hash-entry
- (vector-ref *purified-code-block-profile-block-buffer* index)
- (vector-ref *purified-code-block-profile-offset-buffer* index))
- ;; Adios, amigos
- (vector-set! *purified-code-block-profile-block-buffer* index #F)
- (vector-set! *purified-code-block-profile-offset-buffer* index #F)
- ))
- ;; Re-enable... synch kludge
- (fixed-purified-code-block-profile-buffers/install
- *purified-code-block-profile-block-buffer*
- *purified-code-block-profile-offset-buffer*)
- ;; restart if need be
- (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
- (pc-sample/start)))))
- unspecific)
-
-
-
-(define-integrable (purified-code-block-profile-buffer/overflow-count?)
- (%pc-sample/PCBPB-monitoring?))
-(define-integrable (purified-code-block-profile-buffer/overflow-count?/toggle!)
- (%pc-sample/PCBPB-monitoring?/toggle!))
-
-(define (purified-code-block-profile-buffer/with-overflow-count! count? thunk)
- (let ((counting? (purified-code-block-profile-buffer/overflow-count?))
- (want-no-count? (not count?))) ; coerce to Boolean
- (if (eq? counting? want-no-count?) ; xor want and got
- (dynamic-wind purified-code-block-profile-buffer/overflow-count?/toggle!
- thunk
- purified-code-block-profile-buffer/overflow-count?/toggle!)
- (thunk))))
-
-(define-integrable (purified-code-block-profile-buffer/overflow-count )
- (%pc-sample/PCBPB-overflow-count ))
-(define-integrable (purified-code-block-profile-buffer/overflow-count/reset)
- (%pc-sample/PCBPB-overflow-count/reset))
-\f
-;;; Heathen Code Blocks
-
-;;; TODO: flush/reset/spill/extend should all employ double buffering of the
-;;; code block profile buffers.
-
-(define *heathen-code-block-profile-buffer/extend-count?* #F)
-(define-integrable (heathen-code-block-profile-buffer/extend-count?)
- *heathen-code-block-profile-buffer/extend-count?*)
-(define-integrable (heathen-code-block-profile-buffer/extend-count?/toggle!)
- (set! *heathen-code-block-profile-buffer/extend-count?*
- (not *heathen-code-block-profile-buffer/extend-count?*)))
-(define (heathen-code-block-profile-buffer/with-extend-count! count?
- thunk)
- (fluid-let ((*heathen-code-block-profile-buffer/extend-count?* count?))
- (thunk)))
-(define *heathen-code-block-profile-buffer/extend-count* 0)
-(define-integrable (heathen-code-block-profile-buffer/extend-count)
- *heathen-code-block-profile-buffer/extend-count*)
-(define-integrable (heathen-code-block-profile-buffer/extend-count/reset)
- (set! *heathen-code-block-profile-buffer/extend-count* 0))
-(define-integrable (heathen-code-block-profile-buffer/extend-count/1+)
- (set! *heathen-code-block-profile-buffer/extend-count*
- (1+ *heathen-code-block-profile-buffer/extend-count*)))
-
-(define (heathen-code-block-profile-buffer/extend)
- (let ((stop/restart-sampler? (and (not *pc-sample/sample-sampler?*)
- (pc-sample/started?))))
- ;; stop if need be
- (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
- (pc-sample/stop))))
- ;; count if willed to
- (cond ((heathen-code-block-profile-buffer/extend-count?)
- (heathen-code-block-profile-buffer/extend-count/1+)))
- ;; No need to disable during extend since we build an extended copy of the
- ;; buffers then install them in one swell foop...
- ;; Of course, any profile samples made during the extend will be discarded.
- ;; For this reason, we go ahead and disable buffering anyway since
- ;; it would be a waste of time.
- (fixed-heathen-code-block-profile-buffers/disable)
- (cond ((heathen-code-block-profile-buffer/extend-noisy?)
- (with-output-to-port console-output-port ; in case we're in Edwin
- (lambda ()
- (display "\n;> > > > > HCBPB Extend Request being serviced.")))
- (output-port/flush-output console-output-port)))
- (let* ((slack (heathen-code-block-profile-buffer/slack ))
- (old-buffer-length (heathen-code-block-profile-buffer/length))
- (new-buffer-length (+ old-buffer-length slack) )
- (new-block-buffer
- (vector-grow *heathen-code-block-profile-block-buffer*
- new-buffer-length))
- (new-offset-buffer
- (vector-grow *heathen-code-block-profile-offset-buffer*
- new-buffer-length)))
- ;; INVARIANT: unused slots o heathen-code-block-profile-buffer must be #F
- (do ((index old-buffer-length (1+ index)))
- ((= index new-buffer-length))
- (vector-set! new-block-buffer index #F)
- (vector-set! new-offset-buffer index #F)
- )
- ;; Install new-buffers
- (set! *heathen-code-block-profile-block-buffer* new-block-buffer)
- (set! *heathen-code-block-profile-offset-buffer* new-offset-buffer)
- ;; synch length cache
- (heathen-code-block-profile-buffer/length/set! new-buffer-length))
- ;; Re-enable ... synch kludge
- (fixed-heathen-code-block-profile-buffers/install
- *heathen-code-block-profile-block-buffer*
- *heathen-code-block-profile-offset-buffer*)
- ;; restart if need be
- (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
- (pc-sample/start)))))
- unspecific)
-
-(define *heathen-code-block-profile-buffer/flush-count?* #F)
-(define-integrable (heathen-code-block-profile-buffer/flush-count?)
- *heathen-code-block-profile-buffer/flush-count?*)
-(define-integrable (heathen-code-block-profile-buffer/flush-count?/toggle!)
- (set! *heathen-code-block-profile-buffer/flush-count?*
- (not *heathen-code-block-profile-buffer/flush-count?*)))
-(define (heathen-code-block-profile-buffer/with-flush-count! count?
- thunk)
- (fluid-let ((*heathen-code-block-profile-buffer/flush-count?* count?))
- (thunk)))
-(define *heathen-code-block-profile-buffer/flush-count* 0)
-(define-integrable (heathen-code-block-profile-buffer/flush-count)
- *heathen-code-block-profile-buffer/flush-count*)
-(define-integrable (heathen-code-block-profile-buffer/flush-count/reset)
- (set! *heathen-code-block-profile-buffer/flush-count* 0))
-(define-integrable (heathen-code-block-profile-buffer/flush-count/1+)
- (set! *heathen-code-block-profile-buffer/flush-count*
- (1+ *heathen-code-block-profile-buffer/flush-count*)))
-
-(define-integrable (heathen-code-block-profile-buffer/flush)
- (cond
- ((and *heathen-code-block-profile-block-buffer* ; not disabled
- *heathen-code-block-profile-offset-buffer* ; (should be synch'd)
- (heathen-code-block-profile-buffer/flush?))
- (heathen-code-block-profile-buffer/spill-into-code-block-profile-tables)))
- unspecific)
-
-(define (heathen-code-block-profile-buffer/reset)
- ;; It is important to disable the buffers during reset so we don't have any
- ;; random ignored samples dangling in the buffer.
- (let ((next-mt-slot-index
- ;; Bletch: need to disable buffers but must sniff next-mt-slot-index
- ;; first, then must ensure nothing new is buffered.
- (without-interrupts
- (lambda ()
- (let ((nmtsi
- (heathen-code-block-profile-buffer/next-empty-slot-index)))
- ;; NB: No interrupts between LET rhs and following assignments
- (fixed-heathen-code-block-profile-buffers/disable)
- nmtsi)))))
- ;; It is useful to keep a global var as a handle on this object.
- (cond ((and *heathen-code-block-profile-block-buffer*
- *heathen-code-block-profile-offset-buffer*) ;(should B synch'd)
- ;; Already initialized so avoid CONS-ing
- (subvector-fill! *heathen-code-block-profile-block-buffer*
- 0 next-mt-slot-index #F)
- (subvector-fill! *heathen-code-block-profile-offset-buffer*
- 0 next-mt-slot-index #F)
- )
- (else
- ;; Else initialize them
- (set! *heathen-code-block-profile-block-buffer*
- (pc-sample/code-block-buffer/make/heathen-blocks))
- (set! *heathen-code-block-profile-offset-buffer*
- (pc-sample/code-block-buffer/make/heathen-offsets))
- )))
- ;; Re-enable ... synch kludge
- (fixed-heathen-code-block-profile-buffers/install
- *heathen-code-block-profile-block-buffer*
- *heathen-code-block-profile-offset-buffer*)
- (cond ((pc-sample/uninitialized?)
- (pc-sample/set-state! 'RESET)))
- 'RESET)
-
-(define (heathen-code-block-profile-buffer/flush?)
- (not (heathen-code-block-profile-buffer/empty?)))
-
-(define (heathen-code-block-profile-buffer/spill-into-code-block-profile-tables)
- (let ((stop/restart-sampler? (and (not *pc-sample/sample-sampler?*)
- (pc-sample/started?))))
- ;; stop if need be
- (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
- (pc-sample/stop))))
- ;; count if willed to
- (cond ((heathen-code-block-profile-buffer/flush-count?)
- (heathen-code-block-profile-buffer/flush-count/1+)))
- ;; It is important to disable the buffers during spillage so we don't have
- ;; any random ignored samples dangling in the buffer.
- (let ((next-mt-slot-index
- ;; Bletch: need to disable buffers but must sniff next-mt-slot-index
- ;; first, then must ensure nothing new is buffered.
- (without-interrupts
- (lambda ()
- (let
- ((nmtsi
- (heathen-code-block-profile-buffer/next-empty-slot-index)))
- ;; NB: No interrupts between LET rhs and following assignments
- (fixed-heathen-code-block-profile-buffers/disable)
- nmtsi)))))
- (cond ((heathen-code-block-profile-buffer/flush-noisy?)
- (with-output-to-port console-output-port ; in case we're in Edwin
- (lambda ()
- (display "\n;> > > > > HCBPB Flush Request being serviced.")))
- (output-port/flush-output console-output-port)))
- (do ((index 0 (1+ index)))
- ((= index next-mt-slot-index))
- ;; copy from buffer into hash table
- (heathen-code-block-profile-tables/hash-entry
- (vector-ref *heathen-code-block-profile-block-buffer* index)
- (vector-ref *heathen-code-block-profile-offset-buffer* index))
- ;; Siyonara, Banzai!
- (vector-set! *heathen-code-block-profile-block-buffer* index #F)
- (vector-set! *heathen-code-block-profile-offset-buffer* index #F)
- ))
- ;; Re-enable... synch kludge
- (fixed-heathen-code-block-profile-buffers/install
- *heathen-code-block-profile-block-buffer*
- *heathen-code-block-profile-offset-buffer*)
- ;; restart if need be
- (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
- (pc-sample/start)))))
- unspecific)
-
-
-
-(define-integrable (heathen-code-block-profile-buffer/overflow-count?)
- (%pc-sample/HCBPB-monitoring?))
-(define-integrable (heathen-code-block-profile-buffer/overflow-count?/toggle!)
- (%pc-sample/HCBPB-monitoring?/toggle!))
-
-(define (heathen-code-block-profile-buffer/with-overflow-count! count? thunk)
- (let ((counting? (heathen-code-block-profile-buffer/overflow-count?))
- (want-no-count? (not count?))) ; coerce to Boolean
- (if (eq? counting? want-no-count?) ; xor want and got
- (dynamic-wind heathen-code-block-profile-buffer/overflow-count?/toggle!
- thunk
- heathen-code-block-profile-buffer/overflow-count?/toggle!)
- (thunk))))
-
-(define-integrable (heathen-code-block-profile-buffer/overflow-count )
- (%pc-sample/HCBPB-overflow-count ))
-(define-integrable (heathen-code-block-profile-buffer/overflow-count/reset)
- (%pc-sample/HCBPB-overflow-count/reset))
-\f
-;;; Code Block Profile (Hash) Tables are where compiled procs are profiled...
-;;; but the profile trap handler cannot CONS so if the current profiled
-;;; proc is not already hashed, we must buffer it in the Code Block Profile
-;;; Buffer until the GC Daemon gets around to hashing it.
-;;;
-;;; Notice too that we maintain four distinct profile tables for each of the
-;;; two kinds of code blocks (purified and heathen). These four tables
-;;; are:
-;;; proc-cobl - code-block proc was completely isolated and identified
-;;; dbg-cobl - code-block proc not isolated but found debugging info
-;;; raw-cobl - code-block proc was not isolated and no debugging info
-;;; trampoline - trampoline code (e.g., manifest
-;;;
-;;; This is because we may occasionally be unable to determine just which cobl
-;;; proc within a code block we were about to execute (e.g., may have been
-;;; in the head of the code block just when we sampled so did not yet jump
-;;; to proc in the code block). In such cases, we cannot profile the precise
-;;; cobl proc we were about to enter, so we just profile the code block as a
-;;; whole. These instances should be statistically fairly improbable.
-;;; The cases were we could not isolate the proc because the debugging info
-;;; was not available will be nil if all the ducky inf files are around...
-;;; but if some bozo deletes them all, we should at least not crash.
-;;; And until we teach the trampoline code to be more accomodating we will
-;;; keep it around after class to torture it at our leisure.
-
-(define *purified-proc-cobl-profile-table*)
-(define *heathen-proc-cobl-profile-table*)
-(define *purified-dbg-cobl-profile-table*)
-(define *heathen-dbg-cobl-profile-table*)
-(define *purified-raw-cobl-profile-table*)
-(define *heathen-raw-cobl-profile-table*)
-(define *purified-trampoline-profile-table*)
-(define *heathen-trampoline-profile-table*)
-
-(define ( proc-cobl-profile-table/make) (make-profile-hash-table 4096))
-(define ( dbg-cobl-profile-table/make) (make-profile-hash-table 1024))
-(define ( raw-cobl-profile-table/make) (make-profile-hash-table 2048))
-(define (trampoline-profile-table/make) (make-profile-hash-table 512))
-
-(define (code-block-profile-table)
- (vector ( purified-proc-cobl-profile-table)
- ( purified-dbg-cobl-profile-table)
- ( purified-raw-cobl-profile-table)
- (purified-trampoline-profile-table)
- ( heathen-proc-cobl-profile-table)
- ( heathen-dbg-cobl-profile-table)
- ( heathen-raw-cobl-profile-table)
- ( heathen-trampoline-profile-table)
- ))
-
-(define (purified-proc-cobl-profile-table)
- (purified-code-block-profile-buffer/flush)
- (hash-table->alist *purified-proc-cobl-profile-table*))
-(define ( heathen-proc-cobl-profile-table)
- ( heathen-code-block-profile-buffer/flush)
- (hash-table->alist *heathen-proc-cobl-profile-table*))
-
-(define (purified-dbg-cobl-profile-table)
- (purified-code-block-profile-buffer/flush)
- (hash-table->alist *purified-dbg-cobl-profile-table*))
-(define ( heathen-dbg-cobl-profile-table)
- ( heathen-code-block-profile-buffer/flush)
- (hash-table->alist *heathen-dbg-cobl-profile-table*))
-
-(define (purified-raw-cobl-profile-table)
- (purified-code-block-profile-buffer/flush)
- (hash-table->alist *purified-raw-cobl-profile-table*))
-(define ( heathen-raw-cobl-profile-table)
- ( heathen-code-block-profile-buffer/flush)
- (hash-table->alist *heathen-raw-cobl-profile-table*))
-
-(define (purified-trampoline-profile-table)
- (purified-code-block-profile-buffer/flush)
- (hash-table->alist *purified-trampoline-profile-table*))
-(define ( heathen-trampoline-profile-table)
- ( heathen-code-block-profile-buffer/flush)
- (hash-table->alist *heathen-trampoline-profile-table*))
-
-
-(define (code-block-profile-table/old)
- (vector ( purified-proc-cobl-profile-table/old)
- ( purified-dbg-cobl-profile-table/old)
- ( purified-raw-cobl-profile-table/old)
- (purified-trampoline-profile-table/old)
- ( heathen-proc-cobl-profile-table/old)
- ( heathen-dbg-cobl-profile-table/old)
- ( heathen-raw-cobl-profile-table/old)
- ( heathen-trampoline-profile-table/old)
- ))
-
-(define *purified-proc-cobl-profile-table/old* #F)
-(define (purified-proc-cobl-profile-table/old)
- *purified-proc-cobl-profile-table/old*)
-(define *heathen-proc-cobl-profile-table/old* #F)
-(define ( heathen-proc-cobl-profile-table/old)
- *heathen-proc-cobl-profile-table/old*)
-
-(define *purified-dbg-cobl-profile-table/old* #F)
-(define (purified-dbg-cobl-profile-table/old)
- *purified-dbg-cobl-profile-table/old*)
-(define *heathen-dbg-cobl-profile-table/old* #F)
-(define ( heathen-dbg-cobl-profile-table/old)
- *heathen-dbg-cobl-profile-table/old*)
-
-(define *purified-raw-cobl-profile-table/old* #F)
-(define (purified-raw-cobl-profile-table/old)
- *purified-raw-cobl-profile-table/old*)
-(define *heathen-raw-cobl-profile-table/old* #F)
-(define ( heathen-raw-cobl-profile-table/old)
- *heathen-raw-cobl-profile-table/old*)
-
-(define *purified-trampoline-profile-table/old* #F)
-(define (purified-trampoline-profile-table/old)
- *purified-trampoline-profile-table/old*)
-(define *heathen-trampoline-profile-table/old* #F)
-(define ( heathen-trampoline-profile-table/old)
- *heathen-trampoline-profile-table/old*)
-
-
-(define (code-block-profile-tables/reset #!optional disable?)
- (cond ((or (default-object? disable?) (not disable?))
- (purified-code-block-profile-tables/reset)
- ( heathen-code-block-profile-tables/reset))
- (else
- (purified-code-block-profile-tables/reset disable?)
- ( heathen-code-block-profile-tables/reset disable?))))
-
-(define (purified-code-block-profile-tables/reset #!optional disable?)
- (set! *purified-proc-cobl-profile-table/old*
- ( purified-proc-cobl-profile-table))
- (set! *purified-dbg-cobl-profile-table/old*
- (purified-dbg-cobl-profile-table))
- (set! *purified-raw-cobl-profile-table/old*
- (purified-raw-cobl-profile-table))
- (set! *purified-trampoline-profile-table/old*
- (purified-trampoline-profile-table))
- (hash-table/clear! *purified-proc-cobl-profile-table*)
- (hash-table/clear! *purified-dbg-cobl-profile-table*)
- (hash-table/clear! *purified-raw-cobl-profile-table*)
- (hash-table/clear! *purified-trampoline-profile-table*)
- (set! *purified-code-block-profile-buffer/status/old*
- (purified-code-block-profile-buffer/status))
- (cond ((and (not (default-object? disable?)) disable?)
- ;; Disabling buffer disables table
- (set! *purified-code-block-profile-block-buffer* #F)
- (set! *purified-code-block-profile-offset-buffer* #F)
- (fixed-purified-code-block-profile-buffers/disable)
- (if (pc-sample/initialized?)
- 'RESET-AND-DISABLED
- 'STILL-UNINITIALIZED))
- ;; Disabled but wanna enable?
- ((or (not *purified-code-block-profile-block-buffer*);(should B synchd)
- (not *purified-code-block-profile-offset-buffer*))
- (purified-code-block-profile-buffer/reset))
- (else
- 'RESET)))
-
-(define (heathen-code-block-profile-tables/reset #!optional disable?)
- (set! *heathen-proc-cobl-profile-table/old*
- ( heathen-proc-cobl-profile-table))
- (set! *heathen-dbg-cobl-profile-table/old*
- (heathen-dbg-cobl-profile-table))
- (set! *heathen-raw-cobl-profile-table/old*
- (heathen-raw-cobl-profile-table))
- (set! *heathen-trampoline-profile-table/old*
- (heathen-trampoline-profile-table))
- (hash-table/clear! *heathen-proc-cobl-profile-table*)
- (hash-table/clear! *heathen-dbg-cobl-profile-table*)
- (hash-table/clear! *heathen-raw-cobl-profile-table*)
- (hash-table/clear! *heathen-trampoline-profile-table*)
- (set! *heathen-code-block-profile-buffer/status/old*
- (heathen-code-block-profile-buffer/status))
- (cond ((and (not (default-object? disable?)) disable?)
- ;; Disabling buffer disables table
- (set! *heathen-code-block-profile-block-buffer* #F)
- (set! *heathen-code-block-profile-offset-buffer* #F)
- (fixed-heathen-code-block-profile-buffers/disable)
- (if (pc-sample/initialized?)
- 'RESET-AND-DISABLED
- 'STILL-UNINITIALIZED))
- ;; Disabled but wanna enable?
- ((or (not *heathen-code-block-profile-block-buffer*);(should be synchd)
- (not *heathen-code-block-profile-offset-buffer*))
- (heathen-code-block-profile-buffer/reset))
- (else
- 'RESET)))
-
-(define (code-block-profile-tables/enable)
- (purified-code-block-profile-tables/enable)
- ( heathen-code-block-profile-tables/enable))
-
-(define (purified-code-block-profile-tables/enable)
- (purified-code-block-profile-tables/reset))
-(define ( heathen-code-block-profile-tables/enable)
- ( heathen-code-block-profile-tables/reset))
-
-
-(define (code-block-profile-tables/disable)
- (purified-code-block-profile-tables/disable)
- ( heathen-code-block-profile-tables/disable))
-
-(define (purified-code-block-profile-tables/disable)
- (purified-code-block-profile-tables/reset 'DISABLE))
-(define ( heathen-code-block-profile-tables/disable)
- ( heathen-code-block-profile-tables/reset 'DISABLE))
-
-
-;; Following three abstractions belong in udata.scm
-
-(define-integrable (compiled-code-block/trampoline? block)
- (or (not (compiled-code-block/normal? block))
- (trampoline/return-to-interpreter? block)))
-
-(define-integrable (compiled-code-block/normal? block)
- (object-type?
- (ucode-type manifest-vector)
- ;; This combination returns an unsafe object, but since it
- ;; is used as an argument to a primitive, I can get away
- ;; with not turning off the garbage collector.
- ((ucode-primitive primitive-object-ref 2) block 0)))
-
-(define-integrable (trampoline/return-to-interpreter? block)
- ;;
- ;; Format of special magic return_to_interpreter trampoline:
- ;; looks normal at first glance but really isn't... two constants in
- ;; linkage section are small positive integers.. hence typecode 0
- ;;
- (and (fix:zero? (object-type (compiled-code-block/debugging-info block)))
- (fix:zero? (object-type (compiled-code-block/environment block)))))
-
-
-(define (purified-code-block-profile-tables/hash-entry cobl offset)
- "(code-block offset)\n\
- Hashes a purified code block and offset into the purified code block\n\
- profile table (actually, one of four: proc-cobl, dbg-cobl, raw-cobl, or\n\
- trampoline---\n\
- The proc-cobl hashes a compiled-procedure, dbg-cobl hashes debugging-info\n\
- descriptor [see runtime/infutl.scm read-debugging-info], and raw-cobl\n\
- hashes code block objects as does trampoline.\
- "
- ;; ``Purified'' code blocks are those which have been moved into constant
- ;; space and therefore will not be moved by the garbage collector. Thus,
- ;; it is possible to hash them by their absolute address. This can be more
- ;; efficient than resorting to the underlying Scheme object hashing.
- (if (compiled-code-block/trampoline? cobl)
- (profile-hash-table/update-entry cobl
- *purified-trampoline-profile-table*)
- (let ((cobl-dbg-info (compiled-code-block/dbg-info cobl 'demand-load)))
- (if (not cobl-dbg-info) ; Sigh. Debug info not accessible
- (if (not (compiled-code-block/debugging-info? cobl))
- (profile-hash-table/update-entry
- cobl
- *purified-raw-cobl-profile-table*)
- (let ((debugging-key
- ;; NB: Currently, the debugging info is stored in the
- ;; cobl so repeated accesses return EQ structures:
- ;; Hash on it
- (compiled-code-block/debugging-info cobl)))
- (profile-hash-table/update-entry
- debugging-key
- *purified-dbg-cobl-profile-table*)))
- (let* ((cobl-procv (dbg-info/procedures cobl-dbg-info))
- ;; Invariant: cobl-procv is a non-null vector
- (cobl-proc
- (let ((last-index (-1+ (vector-length cobl-procv))))
- (do ((index 0 (1+ index)))
- ((or (= index last-index) ; last proc is it
- (let ((next-proc (vector-ref cobl-procv
- (1+ index))))
- (> (dbg-procedure/label-offset next-proc)
- offset)))
- (vector-ref cobl-procv index))))))
- ;; Paranoia for tracking down renegade samples
-;;; (pp `(((cobl--- ,cobl)
-;;; (datum-- ,(object-datum cobl))
-;;; (offset- ,offset))
-;;; (cprocv- ,cobl-procv)
-;;; (cproc-- ,cobl-proc )
-;;; ))
-;;; (pp (reconstruct-compiled-procedure cobl cobl-proc))
- (profile-hash-table/update-entry
- (reconstruct-compiled-procedure cobl cobl-proc)
- *purified-proc-cobl-profile-table*)
- )))))
-
-(define (heathen-code-block-profile-tables/hash-entry cobl offset)
- "(code-block offset)\n\
- Hashes a heathen code block and offset into the heathen code block\n\
- profile table (actually, one of four: proc-cobl, dbg-cobl, raw-cobl,\n\
- or trampoline---\n\
- The proc-cobl hashes a compiled-procedure, dbg-cobl hashes debugging-info\n\
- descriptor [see runtime/infutl.scm read-debugging-info], and raw-cobl\n\
- hashes code block objects as does trampoline.\
- "
- ;; ``Heathen'' code blocks are those which have not been ``purified'' into
- ;; constant space so they can be moved about by the garbage collector.
- ;; For that reason we cannot hash them off their absolute address because
- ;; that can change. Instead, we use the usual hashing method.
- (if (compiled-code-block/trampoline? cobl)
- (profile-hash-table/update-entry cobl *heathen-trampoline-profile-table*)
- (let ((cobl-dbg-info (compiled-code-block/dbg-info cobl 'demand-load)))
- (if (not cobl-dbg-info) ; Sigh. Debug info not accessible
- (if (not (compiled-code-block/debugging-info? cobl))
- (profile-hash-table/update-entry
- cobl
- *heathen-raw-cobl-profile-table*)
- (let ((debugging-key
- ;; NB: Currently, the debugging info is stored in the
- ;; cobl so repeated accesses return EQ structures:
- ;; Hash on it
- (compiled-code-block/debugging-info cobl)))
- (profile-hash-table/update-entry
- debugging-key
- *heathen-dbg-cobl-profile-table*)))
- (let* ((cobl-procv (dbg-info/procedures cobl-dbg-info))
- ;; Invariant: cobl-procv is a non-null vector
- (cobl-proc
- (let ((last-index (-1+ (vector-length cobl-procv))))
- (do ((index 0 (1+ index)))
- ((or (= index last-index) ; last proc is it
- (let ((next-proc (vector-ref cobl-procv
- (1+ index))))
- (> (dbg-procedure/label-offset next-proc)
- offset)))
- (vector-ref cobl-procv index))))))
- (profile-hash-table/update-entry
- (reconstruct-compiled-procedure cobl cobl-proc)
- *heathen-proc-cobl-profile-table*)
- )))))
-
-;;; *** Warning: This must be compiled to avoid a call to
-;;; *** with-absolutely-no-interrupts
-
-(define (reconstruct-compiled-procedure cobl dbg-proc)
- (let ((offset (dbg-procedure/label-offset dbg-proc)))
- (with-absolutely-no-interrupts
- (lambda ()
- ((ucode-primitive primitive-object-set-type)
- (ucode-type compiled-entry)
- (make-non-pointer-object
- (+ offset (object-datum cobl))))))))
-
-
-(define (profile-hash-table/update-entry entry-key-obj profile-hash-table)
- (cond ((hash-table/get profile-hash-table entry-key-obj false)
- =>
- (lambda (datum) ; found
- (code-block-profile-datum/update! datum)))
- (else ; not found
- (hash-table/put! profile-hash-table
- entry-key-obj
- (code-block-profile-datum/make)))))
-\f
-;;; Code Block Profile Datum
-
-(define-structure (code-block-profile-datum
- (conc-name code-block-profile-datum/)
- (constructor code-block-profile-datum/make
- (#!optional count histogram rank utility)))
- (count (code-block-profile-datum/count/make))
- (histogram (code-block-profile-datum/histogram/make))
- (rank (code-block-profile-datum/rank/make))
- (utility (code-block-profile-datum/utility/make))
- ;... more to come (?)
- )
-
-(define (code-block-profile-datum/count/make) 1.0) ; FLONUM
-(define (code-block-profile-datum/histogram/make) '#())
-(define (code-block-profile-datum/rank/make) 0)
-(define (code-block-profile-datum/utility/make) 0.0) ; FLONUM
-;... more to come (?)
-
-(define (code-block-profile-datum/update! datum)
- (set-code-block-profile-datum/count!
- datum
- (flo:+ 1.0 (code-block-profile-datum/count datum))) ; FLONUM
- ;; histogram not yet implemented
- ;; rank not yet implemented
- ;; utility not yet implemented
-
- ;; NB: returns datum
- datum)
-
-;;; fini
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; PC Sampling Display routines (pre-cursor to PC Sample SWAT frobs)
-;;; package: (pc-sample display)
-
-(declare (usual-integrations))
-\f
-(define (initialize-package!)
- (install))
-
-(define-primitives
- (get-primitive-name 1)
- )
-
-;;; Aesthetics
-
-(define (pc-sample/status/display)
- (pc-sample/status/display/header "")
- (pc-sample/builtin/status/display 'SUBHEADER)
- (pc-sample/utility/status/display 'SUBHEADER)
- (pc-sample/primitive/status/display 'SUBHEADER)
- (pc-sample/code-block/status/display 'SUBHEADER)
- (pc-sample/interp-proc/status/display 'SUBHEADER)
- (pc-sample/prob-comp/status/display 'SUBHEADER)
- (pc-sample/UFO/status/display 'SUBHEADER)
- unspecific)
-
-;; Status Displayers
-
-(define pc-sample/builtin/status/display)
-(define pc-sample/utility/status/display)
-(define pc-sample/primitive/status/display)
-(define pc-sample/code-block/status/display)
-(define pc-sample/interp-proc/status/display)
-(define pc-sample/prob-comp/status/display)
-(define pc-sample/UFO/status/display)
-
-(define (generate:pc-sample/status/displayer header-string display-proc)
- (lambda (#!optional subheader?)
- ((if (or (default-object? subheader?) (not subheader?)) ; display header
- pc-sample/status/display/header
- pc-sample/status/display/subheader)
- header-string)
- (display-proc)
- (pc-sample/status/display/header/delimiter)
- unspecific))
-
-(define-integrable (pc-sample/status/display/header/delimiter)
- (display "\n;============================================================="))
-
-(define-integrable (pc-sample/status/display/subheader/delimiter)
- (display "\n;------------------------------------------------------"))
-
-(define-integrable (pc-sample/status/display/title-root-string)
- (display " PC Sampling status:"))
-
-(define-integrable (pc-sample/status/display/header title-prefix-string)
- (pc-sample/status/display/header/delimiter)
- (display (string-append "\n; " title-prefix-string))
- (pc-sample/status/display/title-root-string)
- (pc-sample/status/display/header/delimiter))
-
-(define-integrable (pc-sample/status/display/subheader subheader-title-string)
- (display (string-append "\n; " subheader-title-string "..."))
- (pc-sample/status/display/subheader/delimiter))
-
-(define (install-status-displayers)
- (set! pc-sample/builtin/status/display (generate:pc-sample/status/displayer
- "Hand Assembled Procedure (a.k.a. ``Built-In'') "
- pc-sample/builtin/display))
-
- (set! pc-sample/utility/status/display (generate:pc-sample/status/displayer
- "Utility System Subroutine "
- pc-sample/utility/display))
-
- (set! pc-sample/primitive/status/display (generate:pc-sample/status/displayer
- "Primitive Procedure "
- pc-sample/primitive/display))
-
- (set! pc-sample/code-block/status/display (generate:pc-sample/status/displayer
- "Compiled Procedure (a.k.a. ``Code Block'') "
- pc-sample/code-block/display))
-
- (set! pc-sample/interp-proc/status/display (generate:pc-sample/status/displayer
- "Interpreted Procedure (a.k.a. ``Interp-Proc'') "
- pc-sample/interp-proc/display))
-
- (set! pc-sample/prob-comp/status/display (generate:pc-sample/status/displayer
- "Probably Compiled Function, Not Observably Residence Designated\n; (a.k.a. ``Prob Comp FNORD!'') "
- pc-sample/prob-comp/display))
-
- (set! pc-sample/UFO/status/display (generate:pc-sample/status/displayer
- "Unidentifiable Function Object (a.k.a. ``UFO'') "
- pc-sample/UFO/display))
- )
-
-;; Structure [table] Displayers
-
-(define pc-sample/builtin/display)
-(define pc-sample/utility/display)
-(define pc-sample/primitive/display)
-(define pc-sample/code-block/display)
-(define pc-sample/interp-proc/display)
-(define pc-sample/prob-comp/display)
-(define pc-sample/UFO/display)
-
-(define (generate:pc-sample/table/displayer display-acater)
- (lambda ()
- (let ((displayee (display-acater)))
- (cond ((string? displayee)
- (newline)
- (display displayee))
- ((vector? displayee) ; spec., #(sample-list BTW-string)
- (display-sample-list (vector-ref displayee 0))
- (display (vector-ref displayee 1)))
- (else
- (display-sample-list displayee))))))
-
-(define (display-sample-list sample-list) ; not integrated so can play w/ it
- ;; for now: just pp as code, but maybe opt for wizzy graphics later
- (parameterize* (list (cons param:pp-default-as-code? #t)
- (lambda () ;
- (pp sample-list))))
-
-(define (install-displayers)
- (set! pc-sample/builtin/display (generate:pc-sample/table/displayer
- pc-sample/builtin/display-acate))
-
- (set! pc-sample/utility/display (generate:pc-sample/table/displayer
- pc-sample/utility/display-acate))
-
- (set! pc-sample/primitive/display (generate:pc-sample/table/displayer
- pc-sample/primitive/display-acate))
-
- (set! pc-sample/code-block/display (generate:pc-sample/table/displayer
- pc-sample/code-block/display-acate))
-
- (set! pc-sample/interp-proc/display (generate:pc-sample/table/displayer
- pc-sample/interp-proc/display-acate))
-
- (set! pc-sample/prob-comp/display (generate:pc-sample/table/displayer
- pc-sample/prob-comp/display-acate))
-
- (set! pc-sample/UFO/display (generate:pc-sample/table/displayer
- pc-sample/UFO/display-acate))
- )
-\f
-;; Display-acaters (i.e., make a widget presentable for human readable display)
-;; All display-acaters are presently *not* integrable so we
-;; can interavtively play with them to explore display options.
-
-(define *display-acation-status* #F) ; FLUID optional arg
-
-(define (with-pc-sample-displayacation-status displayacation-status thunk)
- (fluid-let ((*display-acation-status* displayacation-status))
- (thunk)))
-
-(define (pc-sample/builtin/display-acate)
- (pc-sample/indexed-vector-table/display-acate
- pc-sample/status/builtin-table
- pc-sample/builtin-table
- "Built-Ins"
- 'BUILTIN
- 'BUILTIN-FNORD!
- get-builtin-name))
-
-(define (pc-sample/utility/display-acate)
- (pc-sample/indexed-vector-table/display-acate
- pc-sample/status/utility-table
- pc-sample/utility-table
- "Utilities"
- 'UTILITY
- 'UTILITY-FNORD!
- get-utility-name))
-
-(define (pc-sample/primitive/display-acate)
- (pc-sample/indexed-vector-table/display-acate
- pc-sample/status/primitive-table
- pc-sample/primitive-table
- "Primitives"
- 'PRIMITIVE
- 'PRIMITIVE-FNORD!
- get-primitive-name))
-
-(define (pc-sample/indexed-vector-table/display-acate
- pc-sample/status/mumble-table
- pc-sample/mumble-table
- mumble-string
- mumble-ID
- mumble-ID-fnord!
- get-mumble-name)
- (cond ((if *display-acation-status*
- (pc-sample/status/mumble-table *display-acation-status*)
- (pc-sample/mumble-table))
- =>
- (lambda (mumble-tbl)
- (let ((count-acc 0.)
- (disp-stack '()))
- (do ((index (-1+ (vector-length mumble-tbl)) (-1+ index)))
- ((negative? index)
- (if (null? disp-stack)
- (string-append
- "; ++++ No " mumble-string "s Sampled Yet ++++")
- `(,mumble-ID-fnord!
- ,count-acc
- ,@(sort-sample-list disp-stack))))
- (let ((count (vector-ref mumble-tbl index)))
- (cond ((not (flo:zero? count))
- (set! count-acc (flo:+ count count-acc))
- (set! disp-stack
- `((,count
- ,mumble-ID ,index ,(get-mumble-name index))
- . ,disp-stack)))))))))
- (else
- (string-append "; **** [" mumble-string " Table Uninitialized]."))))
-
-(define (pc-sample/code-block/display-acate)
- (let ((BTW-string
- (string-append
- "\n"
- ";..............................................................\n"
- "; BTW: Code Block Buffer Status --\n"
- "; "
- "((plen . pslk)"
- " (hlen . hslk))\n"
- "; = "
- (write-to-string
- (if *display-acation-status*
- (pc-sample/status/code-block-buffer/status
- *display-acation-status*)
- (pc-sample/code-block-buffer/status))))))
- (if (code-block-profiling-disabled?)
- (no-code-blocks-of-sort "" BTW-string #F)
- (let* ((purified-count-cell (make-cell 0.))
- ( heathen-count-cell (make-cell 0.))
- (display-acated-p&h-lists
- (map (lambda (table label cable) ; 8 tables: 4 purified + 4 not
- (vector->list
- (vector-map (lambda (elt)
- (let* ((coblx (profile-hash-table-car elt))
- (datum (profile-hash-table-cdr elt))
- (count
- (code-block-profile-datum/count datum))
- (name-list
- (code-block/name/display-acate coblx)))
- (set-cell-contents! cable
- (flo:+ count
- (cell-contents cable)))
- `(,count ,label ,coblx ,@name-list)))
- table)))
- (vector->list
- (if *display-acation-status*
- (pc-sample/status/code-block-table
- *display-acation-status*)
- (pc-sample/code-block-table)))
- '((CODE-BLOCK PURIFIED COM-PROC)
- (CODE-BLOCK PURIFIED DBG-INFO)
- (CODE-BLOCK PURIFIED RAW-COBL)
- (CODE-BLOCK PURIFIED TRAMPOLINE)
- (CODE-BLOCK HEATHEN COM-PROC)
- (CODE-BLOCK HEATHEN DBG-INFO)
- (CODE-BLOCK HEATHEN RAW-COBL)
- (CODE-BLOCK HEATHEN TRAMPOLINE)
- )
- `(,purified-count-cell ,purified-count-cell
- ,purified-count-cell ,purified-count-cell
- ,heathen-count-cell ,heathen-count-cell
- ,heathen-count-cell ,heathen-count-cell
- )
- ))
- (display-acated-purified-list
- `(,@(first display-acated-p&h-lists)
- ,@(second display-acated-p&h-lists)
- ,@(third display-acated-p&h-lists)
- ,@(fourth display-acated-p&h-lists)
- ))
- (display-acated-heathen-list
- `(,@(fifth display-acated-p&h-lists)
- ,@(sixth display-acated-p&h-lists)
- ,@(seventh display-acated-p&h-lists)
- ,@(eighth display-acated-p&h-lists)
- )))
- (cond ((and (null? display-acated-purified-list)
- (null? display-acated-heathen-list))
- (no-code-blocks-of-sort "" BTW-string #F))
- ((null? display-acated-heathen-list)
- `#((PURIFIED-FNORD!
- ,(cell-contents purified-count-cell)
- ,@(sort-sample-list display-acated-purified-list))
- ,(no-code-blocks-of-sort "Heathen" BTW-string 'BTW)))
- ((null? display-acated-purified-list)
- `#((HEATHEN-FNORD!
- ,(cell-contents heathen-count-cell)
- ,@(sort-sample-list display-acated-heathen-list))
- ,(no-code-blocks-of-sort "Purified" BTW-string 'BTW)))
- (else
- `#(#((PURIFIED-FNORD!
- ,(cell-contents purified-count-cell)
- ,@(sort-sample-list display-acated-purified-list))
- (HEATHEN-FNORD!
- ,(cell-contents heathen-count-cell)
- ,@(sort-sample-list display-acated-heathen-list)))
- ,BTW-string)))))))
-
-(define (compiled-entry-pointer? object) ; should live in /scheme/src/runtime/udata.scm
- (and (compiled-code-address? object)
- (eq? (compiled-entry-type object) 'COMPILED-ENTRY)))
-
-(define (compiled-procedure-entry? obj) ; should live in /scheme/src/runtime/udata.scm
- (and (compiled-code-address? obj)
- (or (compiled-procedure? obj)
- (compiled-return-address? obj)
- (compiled-entry-pointer? obj))))
-
-(define *announce-trampoline-sightings?* #F)
-
-(define (code-block/name/display-acate coblx) ; not integrable so can frob it
- (with-values
- (lambda ()
- (cond ((compiled-code-block? coblx)
- (if (compiled-code-block/trampoline? coblx)
- (if (trampoline/return-to-interpreter? coblx)
- (values 'RETURN_TO_INTERPRETER 69)
- (values 'ABNORMAL_COMPILED_CODE_BLOCK 42))
- (compiled-code-block/filename-and-index coblx)))
- ((compiled-code-address? coblx)
- (compiled-entry/filename-and-index coblx))
- (else
- (values '<--- '<debugging-info>))))
- (lambda (filename offset)
- `(,(cond ((compiled-procedure-entry? coblx)
- (lambda/name/display-acate (compiled-procedure/lambda coblx)))
- ((compiled-code-block/trampoline? coblx)
- (cond (*announce-trampoline-sightings?*
- (newline)
- (newline)
- (display ";;;; ========== TRAMPOLINE ========== ")(display filename)
- (newline)
- (newline)))
- '-*-TRAMPOLINE-*-)
- (else ; compiled-expr [loading], debugging-info, compclo
- (unsyntax/truthfully/sublist 5 (if (compiled-expression? coblx)
- (compiled-expression/scode coblx)
- coblx))))
- ,(if (null? filename)
- "[Not file-defined (i.e., interactively defined?)]"
- filename)
- ,(if (and (null? filename) (null? offset))
- 235
- offset
- )))))
-
-(define-integrable (no-code-blocks-of-sort ID-string BTW-string BTW?)
- (string-append
- (if BTW? "\n" "")
- (if (string-null? ID-string)
- (if (code-block-profiling-disabled?)
- "; **** [Code Block Profile Buffers Uninitialized]."
- "; +++ No Code Blocks Sampled Yet +++")
- (string-append
- ";~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n"
- "; +++ No " ID-string " Code Blocks Sampled Yet +++"))
- BTW-string))
-
-
-
-(define (pc-sample/purified-trampoline/display-acate)
- (pc-sample/trampoline/display-acate 'PURIFIED 'PURIFIED-FNORD! "Purified" 0))
-
-(define (pc-sample/heathen-trampoline/display-acate)
- (pc-sample/trampoline/display-acate 'HEATHEN 'HEATHEN-FNORD! "Heathen" 1))
-
-(define-integrable (pc-sample/trampoline/display-acate ID ID-fnord! ID-string
- pure/heathen-index)
- ;; Straightforwardly derived from full code-block display-ication...
- (let ((complete-code-block-display-acation
- (pc-sample/code-block/display-acate)))
- (cond ((string? complete-code-block-display-acation)
- (no-trampolines-of-sort ID-string))
- ((vector? complete-code-block-display-acation)
- (let* ((samples (vector-ref complete-code-block-display-acation 0))
- (tramps
- (cond ((vector? samples) ; #(tagged-pures tagged-heathens)
- (filter-sorted-sample-list-by-label
- `(CODE-BLOCK ,ID TRAMPOLINE)
- (cddr (vector-ref samples pure/heathen-index))))
- ;; Invariant: samples is tagged pair
- ((eq? (car samples) ID-fnord!)
- (filter-sorted-sample-list-by-label
- `(CODE-BLOCK ,ID TRAMPOLINE)
- (cddr samples)))
- (else '())))
- ;; tally # samples
- (tramp-tally (apply + (map second tramps))))
-
- (if (null? tramps)
- (no-trampolines-of-sort ID-string)
- `(,ID-fnord! ,tramp-tally ,@tramps))))
- (else
- (error "Unrecognized format from PC-SAMPLE/CODE-BLOCK/DISPLAY-ACATE"
- complete-code-block-display-acation)))))
-
-(define-integrable (filter-sorted-sample-list-by-label label sorted-sample-list)
- (list-transform-positive sorted-sample-list
- (lambda (elt)
- (equal? (second elt) label)))) ; (# label ...)
-
-(define-integrable (no-trampolines-of-sort ID-string)
- (string-append
- ";~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n"
- "; +++ No " ID-string " Trampolines Sampled Yet +++\n"
- ))
-
-
-(define (pc-sample/interp-proc/display-acate)
- (let ((BTW-string
- (string-append
- "\n"
- ";..............................................................\n"
- "; BTW: Interp-Proc Buffer Status (length . slack) = "
- (write-to-string
- (if *display-acation-status*
- (pc-sample/status/interp-proc-buffer/status
- *display-acation-status*)
- (pc-sample/interp-proc-buffer/status))))))
- (if (interp-proc-profiling-disabled?)
- (string-append "; **** [Interp-Proc Profile Buffers Uninitialized]."
- BTW-string)
- (let* ((tally 0.)
- (display-acated-list
- (vector->list
- (vector-map
- (lambda (elt)
- (let* ((lambx (profile-hash-table-car elt))
- (datum (profile-hash-table-cdr elt))
- (count (interp-proc-profile-datum/count datum))
- (name (lambda/name/display-acate lambx)))
- (set! tally (flo:+ count tally))
- `(,count INTERP-PROC ,lambx ,name)))
- (if *display-acation-status*
- (pc-sample/status/interp-proc-table
- *display-acation-status*)
- (pc-sample/interp-proc-table))))))
- (if (null? display-acated-list)
- (string-append "; +++ No Interp-Procs Sampled Yet +++"
- BTW-string)
- `#((INTERP-PROC-FNORD! ,tally
- ,@(sort-sample-list display-acated-list))
- ,BTW-string))))))
-
-(define (lambda/name/display-acate lambx) ; not integrable so can play w/ it
- (if (meaningfully-named-lambda? lambx)
- (lambda-components* lambx
- (lambda (name required optional rest body)
- body ; ignore
- `(,name
- ,@required
- ,@(if (null? optional) '() `(#!OPTIONAL ,@optional))
- . ,(if rest rest '()))))
- (unsyntax/truthfully/sublist 5 lambx)))
-
-(define (unsyntax/truthfully/sublist lngth scode)
- (let ((lst (unsyntax/truthfully scode)))
- (if (not lst)
- '(-?-)
- (sublist lst 0 (-1+ (min lngth (length lst)))))))
-
-(define (unsyntax/truthfully scode)
- (let ((un-env (->environment '(runtime unsyntaxer))))
- (fluid-let (((access unsyntaxer:macroize? un-env) false)
- ((access unsyntaxer:show-comments? un-env) false))
- (unsyntax scode))))
-
-
-
-(define (meaningfully-named-lambda? x) ; not integrated so can play w/ it
- (and (lambda? x)
- (not (nonmeaningful-lambda-name? (lambda-name x)))))
-
-(define *nonmeaningful-procedure-names* ; exported for FLUID-LET-itude
- (list 'LOOP 'DO-LOOP 'ITER 'RECUR 'WALK 'SCAN 'TRAVERSE 'ACCUMULATE 'ACC
- 'FOO 'BAR 'BAZ 'QUUX 'FOOBAR
- 'SNAFU 'FROB 'FROBNITZ 'FROBNICATE
- 'MUMBLE 'GRUMBLE 'FUMBLE 'TUMBLE
- 'F 'G 'H 'J 'K
- 'FNORD 'FNORD! 'IGNORE 'PUNT
- ))
-
-(define (nonmeaningful-lambda-name? raw-name) ; not integrated so can frob
- (or (uninterned-symbol? raw-name)
- (special-form-procedure-name? raw-name)
- (memq raw-name *nonmeaningful-procedure-names*)))
-
-
-(define (pc-sample/prob-comp/display-acate)
- (trivial-ate-table
- (if *display-acation-status*
- (pc-sample/status/prob-comp-table *display-acation-status*)
- (pc-sample/prob-comp-table))
- '(PROB-COMP PURIFIED)
- '(PROB-COMP HEATHEN)
- 'PROB-COMP-FNORD!
- "Probably Compiled FNORD!"
- "; **** [Prob Comp FNORD! Counters Uninitialized]."))
-
-(define (pc-sample/UFO/display-acate)
- (trivial-ate-table
- (if *display-acation-status*
- (pc-sample/status/UFO-table *display-acation-status*)
- (pc-sample/UFO-table))
- '(UFO HYPERSPACE)
- '(UFO CYBERSPACE)
- 'UFO-FNORD!
- "UFO"
- (string-append "; **** [UFO Sightings Uninitialized] "
- "(Project Blue Book Cancelled?).")))
-
-(define (trivial-ate-table count-vector type-0 type-1 widget-ID-fnord!
- widget-ID-string
- uninit-string)
- (if count-vector
- (let* ((count-0 (vector-ref count-vector 0))
- (count-1 (vector-ref count-vector 1))
- (no-0s? (flo:zero? count-0))
- (no-1s? (flo:zero? count-1)))
- (if (and no-0s?
- no-1s?)
- (string-append "; +++ No " widget-ID-string "s Sampled Yet +++")
- (let ((tally (flo:+ count-0 count-1))
- (display-acated-list
- (cond (no-0s? `((,count-1 ,type-1)))
- (no-1s? `((,count-0 ,type-0)))
- (else `((,count-0 ,type-0)
- (,count-1 ,type-1))))))
- `(,widget-ID-fnord! ,tally
- ,@(sort-sample-list display-acated-list)))))
- uninit-string))
-
-(declare (integrate-operator trivial-ate-table))
-
-(define-integrable (sort-sample-list sample-list)
- (sort sample-list ; sample-list := ((flonum ...)...)
- (lambda (sample1 sample2)
- (flo:> (car sample1)
- (car sample2)))))
-\f
-;;; Tabulations
-
-(define (pc-sample/status/table . display-acaters)
- ;; defaulted optional rest args
- (let* ((real-display-acaters
- (if (null? display-acaters) ; no opt rest arg
- (list pc-sample/builtin/display-acate
- pc-sample/utility/display-acate
- pc-sample/primitive/display-acate
- pc-sample/code-block/display-acate
- pc-sample/interp-proc/display-acate
- pc-sample/prob-comp/display-acate
- pc-sample/UFO/display-acate)
- display-acaters))
- ;; Lie: should store sample interval in the table some how. Sigh.
- (sample-interval (pc-sample/sample-interval))
- (tally 0.)
- ;; Do (apply append (map (.\ (dcr-thunk) ...) real-dcrs))
- (display-acatees
- (map (lambda (dcr-thunk)
- (let* ((raw-display-acatee (dcr-thunk))
- (half-baked-display-acatee
- (cond ((string? raw-display-acatee)
- '(FNORD! 0.))
- ((vector? raw-display-acatee)
- ;; spec., #(sample-list BTW-string)
- (vector-ref raw-display-acatee 0))
- (else raw-display-acatee ))))
- ;; Cook half-baked display-acatee
- (cond ((pair? half-baked-display-acatee)
- (set! tally
- (+ (second half-baked-display-acatee) tally))
- (cddr half-baked-display-acatee)) ; de-fnord-ize
- ((vector? half-baked-display-acatee)
- ;; e.g., #((purified...)(heathen...))
- ;; Do (apply append (map cdr lst))
- (cddr (reduce-right
- (lambda (l r)
- (let ((l-count (second l))
- (r-count (second r)))
- (set! tally
- (flo:+ (flo:+ l-count
- r-count) ; Grrr
- tally))
- `(FNORD! 0. ,@(cddr l) ,@(cddr r))))
- '(FNORD!-TO-CDR-IF-NULL-HALF-BAKED-DISPEES)
- (vector->list half-baked-display-acatee))))
- (else
- (error "Unknown display-acatee format"
- half-baked-display-acatee)))))
- real-display-acaters))
- (merged-status (reduce-right append '() display-acatees)) ; flatten
- (sorted-status (sort-sample-list merged-status))
- (percent-sorted-status
- (map (lambda (ntry)
- `(,(percenticate (car ntry) tally)
- ,(relevanticate (car ntry) tally sample-interval)
- ,@ntry))
- sorted-status)))
-#|
- ;; Reality check...
- ;; Do: (apply + (map car lst))... reality check...
- (let ((total-count (apply + (map car sorted-status))))
- (cond ((not (flo:= total-count tally))
- (warn "; Damned total-count != tally. Foo." total-count tally))))
-|#
- (display-sample-list percent-sorted-status)))
-
-
-(define *pc-sample/status/table/decimal-pump* 100000.) ; want 5 decimal places
-
-(define-integrable (percenticate numer denom)
- ;; Standard hack: pump up the numerator, round it, then deflate result.
- (let ((pumped-percentage
- (flo:/ (flo:* (flo:* numer 100.) ; percent-icate
- *pc-sample/status/table/decimal-pump*) ; decimal pump
- denom)))
- (flo:/ (flo:round pumped-percentage)
- *pc-sample/status/table/decimal-pump*)))
-
-(define-integrable (relevanticate numer denom interval)
- `#(,numer ,denom ,(make-rectangular (/ (flo:round->exact numer)
- (flo:round->exact denom))
- interval)))
-
-
-(define-integrable (pc-sample/builtin/status/table)
- (pc-sample/status/table pc-sample/builtin/display-acate))
-
-(define-integrable (pc-sample/utility/status/table)
- (pc-sample/status/table pc-sample/utility/display-acate))
-
-(define-integrable (pc-sample/primitive/status/table)
- (pc-sample/status/table pc-sample/primitive/display-acate))
-
-(define-integrable (pc-sample/code-block/status/table)
- (pc-sample/status/table pc-sample/code-block/display-acate))
-
-(define-integrable (pc-sample/interp-proc/status/table)
- (pc-sample/status/table pc-sample/interp-proc/display-acate))
-
-(define-integrable (pc-sample/prob-comp/status/table)
- (pc-sample/status/table pc-sample/prob-comp/display-acate))
-
-(define-integrable (pc-sample/UFO/status/table)
- (pc-sample/status/table pc-sample/UFO/display-acate))
-
-
-(define-integrable (pc-sample/purified-trampoline/status/table)
- (pc-sample/status/table pc-sample/purified-trampoline/display-acate))
-
-(define-integrable (pc-sample/heathen-trampoline/status/table)
- (pc-sample/status/table pc-sample/heathen-trampoline/display-acate))
-
-
-;;; Default status displayer
-
-(define *pc-sample/default-status-displayer*)
-
-(define (with-pc-sample-default-status-displayer status-displayer thunk)
- (fluid-let ((*pc-sample/default-status-displayer* status-displayer)) (thunk)))
-
-(define (install-default-status-displayer)
- (set! *pc-sample/default-status-displayer* pc-sample/status/table)
- )
-
-;;; Install
-
-(define (install)
- (install-displayers) ; NB: Must load this before status-disp
- (install-status-displayers)
- (install-default-status-displayer)
- )
-
-;;; fini
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* PCSDLD.C -- defines the PC Sample dynamic load interface to Scheme */
-\f
-/*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*\
- * TODO:
- * Get a real job. Find a wife, CONS up some progeny. Write a will. Croak.
- *
-\*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*/
-\f
-/*****************************************************************************
- * Uhm... don't forget to pay the piper... must define prims first so known.
- *****************************************************************************/
-
-#ifndef REALLY_INCLUDE_PROFILE_CODE /* scan_defines concession */
-#define REALLY_INCLUDE_PROFILE_CODE /* scan_defines concession */
-#endif
-
-#include "pcsample.c" /* The PC sampler microcode */
-
-/*****************************************************************************/
-#include <microcode/usrdef.h> /* For declare_primitive */
-
-extern void EXFUN (initialize_pcsample_primitives, (void));
- void
-DEFUN_VOID (initialize_pcsample_primitives)
-{
- /*-------------------------------------------------------------------------*/
- declare_primitive ("PC-SAMPLE/TIMER-CLEAR",
- Prim_pc_sample_timer_clear, 0, 0,
- "()\n\
- Turn off the PC sample timer.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("PC-SAMPLE/TIMER-SET",
- Prim_pc_sample_timer_set, 2, 2,
- "(first interval)\n\
- Set the PC sample timer.\n\
- First arg FIRST says how long to wait until the first interrupt;\n\
- second arg INTERVAL says how long to wait between interrupts after that.\n\
- Both arguments are in units of milliseconds.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/HALTED?",
- Prim_pc_sample_halted_p, 0, 0,
- "()\n\
- Specifies whether PC sampling has been brute forcably disabled.\n\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/HALTED?/TOGGLE!",
- Prim_pc_sample_halted_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether PC sampling is brute forcably disabled.\n\
- \n\
- It returns the newly installed sense of the flag.\n\
- \n\
- -------\n\
- WARNING! If pc-sample/init has not been called (to initialize profiling\n\
- ------- tables) then you will lose big if you naively toggle halted-flag\n\
- to #F because that will start the profile timer.\n\
- \n\
- Only officially designated moby wizards should even think of thinking of\n\
- using this most ultra super duper secret primitive. FNORD!\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/CACHE-GC-PRIMITIVE-INDEX",
- Prim_pc_sample_cache_GC_primitive_index, 0, 0,
- "()\n\
- Signals the microcode to go find the GARBAGE-COLLECT primitive and cache\n\
- away its index into the Primitive Table.\n\
- \n\
- This should be invoked each time the Primitive Table is altered in such a\n\
- way that existing primitives can shift about.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("PC-SAMPLE/SPILL-GC-SAMPLES-INTO-PRIMITIVE-TABLE",
- Prim_pc_sample_spill_GC_samples_into_primitive_table, 0, 0,
- "()\n\
- Make sure all samples taken during GC are present and accounted for in the\n\
- Primitive Sample Table.\
- ");
-\f
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/INSTALL-GC-SYNCH-GC-HOOKS",
- Prim_pc_sample_install_gc_synch_gc_hooks, 0, 0,
- "()\n\
- This must be called once when PC sampling is enabled.\n\
- \n\
- If it returns #F then PC sampling must be disabled. You.lose\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/INSTALL-MICROCODE",
- Prim_pc_sample_install_microcode, 0, 0,
- "()\n\
- Installs the microcode support structures for PC sampling.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/DISABLE-MICROCODE",
- Prim_pc_sample_disable_microcode, 0, 0,
- "()\n\
- Disables the microcode support structures for PC sampling.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("INTERP-PROC-PROFILE-BUFFER/DISABLE",
- Prim_IPPB_disable, 0, 0,
- "()\n\
- Disables the interpreted procedure profile buffer hence disabling profiling\n\
- of interpreted procedures (unless and until a new buffer is installed).\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("INTERP-PROC-PROFILE-BUFFER/INSTALL",
- Prim_IPPB_install, 1, 1,
- "(vector)\n\
- Installs VECTOR as the interpreted procedure profile buffer.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("INTERP-PROC-PROFILE-BUFFER/SLACK",
- Prim_IPPB_slack, 0, 0,
- "()\n\
- Returns the `slack' by which the near-fullness of the interpreted procedure\n\
- profile buffer is determined and by which increment the buffer is extended\n\
- when full.\n\
- \n\
- Note that the slack will always be a positive fixnum.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("INTERP-PROC-PROFILE-BUFFER/SET-SLACK",
- Prim_IPPB_set_slack, 1, 1,
- "(positive-fixnum)\n\
- Sets the `slack' by which the near-fullness of the interpreted procedure\n\
- profile buffer is determined and by which increment the buffer is extended\n\
- when full.\n\
- \n\
- Note that the slack must be a positive fixnum.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("INTERP-PROC-PROFILE-BUFFER/SLACK-INCREMENT",
- Prim_IPPB_slack_increment, 0, 0,
- "()\n\
- Returns the amount by which the interpreted procedure profile buffer slack\n\
- is incremented when a buffer overflow occurs. In this sense it cuts the\n\
- slack some slack.\n\
- \n\
- Note that the slack increment will always be a fixnum, but it can be negative\n\
- (in which case it functions as a slack decrement).\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("INTERP-PROC-PROFILE-BUFFER/SET-SLACK-INCREMENT",
- Prim_IPPB_set_slack_increment, 1, 1,
- "(fixnum)\n\
- Sets the amount by which the interpreted procedure profile buffer slack is\n\
- incremented when a buffer overflow occurs.\n\
- \n\
- Note that the slack increment must be a fixnum, but it can be negative\n\
- (in which case it functions as a slack decrement).\
- ");
-\f
- /*-------------------------------------------------------------------------*/
- declare_primitive ("INTERP-PROC-PROFILE-BUFFER/EXTEND-NOISY?",
- Prim_IPPB_extend_noisy_p, 0, 0,
- "()\n\
- Specifies whether notification of IPPB extensions is enabled.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("INTERP-PROC-PROFILE-BUFFER/FLUSH-NOISY?",
- Prim_IPPB_flush_noisy_p, 0, 0,
- "()\n\
- Specifies whether notification of IPPB extensions is enabled.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("INTERP-PROC-PROFILE-BUFFER/OVERFLOW-NOISY?",
- Prim_IPPB_overflow_noisy_p, 0, 0,
- "()\n\
- Specifies whether notification of IPPB overflows is enabled.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("INTERP-PROC-PROFILE-BUFFER/EXTEND-NOISY?/TOGGLE!",
- Prim_IPPB_extend_noisy_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether to notify of IPPB extensions.\n\
- \n\
- It returns the newly installed sense of the flag.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("INTERP-PROC-PROFILE-BUFFER/FLUSH-NOISY?/TOGGLE!",
- Prim_IPPB_flush_noisy_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether to notify of IPPB flushes.\n\
- \n\
- It returns the newly installed sense of the flag.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("INTERP-PROC-PROFILE-BUFFER/OVERFLOW-NOISY?/TOGGLE!",
- Prim_IPPB_overflow_noisy_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether to notify of IPPB overflows.\n\
- \n\
- It returns the newly installed sense of the flag.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("INTERP-PROC-PROFILE-BUFFER/EMPTY?",
- Prim_IPPB_empty_p, 0, 0,
- "()\n\
- Returns a boolean indicating whether or not the IPPB is empty.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("INTERP-PROC-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX",
- Prim_IPPB_next_empty_slot_index, 0, 0,
- "()\n\
- Returns the index of the next `free' slot of the interp-proc profile buffer.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%INTERP-PROC-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX/RESET",
- Prim_IPPB_next_empty_slot_index_reset, 0, 0,
- "()\n\
- Resets the index of the next `free' slot of the interp-proc profile buffer.\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ");
-\f
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/IPPB-FLUSH-IMMEDIATE?",
- Prim_pc_sample_IPPB_flush_immediate_p, 0, 0,
- "()\n\
- Specifies whether the IPPB is flushed upon each entry.\n\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/IPPB-FLUSH-IMMEDIATE?/TOGGLE!",
- Prim_pc_sample_IPPB_flush_immediate_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether the IPPBuffer is flushed upon each entry.\n\
- \n\
- It returns the newly installed sense of the flag.\n\
- \n\
- This is for mondo bizarro sampler debugging purposes only.\n\
- \n\
- Only officially designated moby wizards should even think of thinking of\n\
- using this most ultra super duper secret primitive. FNORD!\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/IPPB-DEBUGGING?",
- Prim_pc_sample_IPPB_debugging_p, 0, 0,
- "()\n\
- Specifies whether the IPPB is in debugging mode.\n\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/IPPB-DEBUGGING?/TOGGLE!",
- Prim_pc_sample_IPPB_debugging_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether the IPPBuffer is in debugging mode.\n\
- \n\
- It returns the newly installed sense of the flag.\n\
- \n\
- This is for mondo bizarro sampler debugging purposes only.\n\
- \n\
- Only officially designated moby wizards should even think of thinking of\n\
- using this most ultra super duper secret primitive. FNORD!\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/IPPB-MONITORING?",
- Prim_pc_sample_IPPB_monitoring_p, 0, 0,
- "()\n\
- Specifies whether the IPPB is in monitoring mode.\n\
- \n\
- This, for instance, is how a count of buffer overflows is accumulated.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/IPPB-MONITORING?/TOGGLE!",
- Prim_pc_sample_IPPB_monitoring_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether the IPPB is in monitoring mode.\n\
- \n\
- It returns the newly installed sense of the flag.\n\
- \n\
- This is for mondo bizarro sampler monitoring purposes only.\n\
- For instance, toggling this monitor flag to true triggers accumulating\n\
- a count of buffer overflows.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/IPPB-FLUSH-COUNT",
- Prim_pc_sample_IPPB_flush_count, 0, 0,
- "()\n\
- Returns the number of IPPB flush requests that have been issued since the\n\
- last PC-SAMPLE/IPPB-FLUSH-COUNT/RESET was issued (or since booting if no\n\
- resets issued).\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/IPPB-FLUSH-COUNT/RESET",
- Prim_pc_sample_IPPB_flush_count_reset, 0, 0,
- "()\n\
- Resets the IPPB flush count (obviously... sheesh!).\
- ");
-\f
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/IPPB-EXTEND-COUNT",
- Prim_pc_sample_IPPB_extend_count, 0, 0,
- "()\n\
- Returns the number of IPPB extend requests that have been issued since the\n\
- last PC-SAMPLE/IPPB-EXTEND-COUNT/RESET was issued (or since booting if no\n\
- resets issued).\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/IPPB-EXTEND-COUNT/RESET",
- Prim_pc_sample_IPPB_extend_count_reset, 0, 0,
- "()\n\
- Resets the IPPB extend count (obviously... sheesh!).\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/IPPB-OVERFLOW-COUNT",
- Prim_pc_sample_IPPB_overflow_count, 0, 0,
- "()\n\
- Returns the number of IPPB overflows that have been issued since the\n\
- last PC-SAMPLE/IPPB-OVERFLOW-COUNT/RESET was issued (or since booting if no\n\
- resets issued).\n\
- \n\
- Each overflow indicates a sample that was punted into the bit bucket.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/IPPB-OVERFLOW-COUNT/RESET",
- Prim_pc_sample_IPPB_overflow_count_reset, 0, 0,
- "()\n\
- Resets the IPPB overflow count (obviously... sheesh!).\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/IPPB-EXTRA-INFO",
- Prim_pc_sample_IPPB_extra_info, 0, 0,
- "()\n\
- Returns the extra info entry associated with the IPP Buffer.\n\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/SET-IPPB-EXTRA-INFO!",
- Prim_pc_sample_set_IPPB_extra_info_bang, 1, 1,
- "(object)\n\
- Stores OBJECT in the extra info entry of the IPPB.\n\
- \n\
- This is for mondo bizarro sampler frobnication purposes only.\n\
- \n\
- Only officially designated moby wizards should even think of thinking of\n\
- using this most ultra super duper secret primitive. FNORD!\
- ");
- /*-------------------------------------------------------------------------*/
-\f
- /*-------------------------------------------------------------------------*/
- declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFERS/DISABLE",
- Prim_PCBPB_disable, 0, 0,
- "()\n\
- Disables the purified code block profile buffers hence disabling purified\n\
- code block profiling (unless and until new buffers are installed).\
- ");
- /*.........................................................................*/
- declare_primitive ( "HEATHEN-CODE-BLOCK-PROFILE-BUFFERS/DISABLE",
- Prim_HCBPB_disable, 0, 0,
- "()\n\
- Disables the heathen code block profile buffers hence disabling heathen\n\
- code block profiling (unless and until new buffers are installed).\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFERS/INSTALL",
- Prim_PCBPB_install, 2, 2,
- "(block-vector offset-vector)\n\
- Installs BLOCK-VECTOR and OFFSET-VECTOR as the purified code block profile\n\
- buffers.\
- ");
- /*.........................................................................*/
- declare_primitive ( "HEATHEN-CODE-BLOCK-PROFILE-BUFFERS/INSTALL",
- Prim_HCBPB_install, 2, 2,
- "(block-vector offset-vector)\n\
- Installs BLOCK-VECTOR and OFFSET-VECTOR as the heathen code block profile\n\
- buffers.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/SLACK",
- Prim_PCBPB_slack, 0, 0,
- "()\n\
- Returns the `slack' by which the near-fullness of the profile buffer for\n\
- purified code blocks is determined and by which increment the buffer is\n\
- extended when full.\
- ");
- /*.........................................................................*/
- declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/SLACK",
- Prim_HCBPB_slack, 0, 0,
- "()\n\
- Returns the `slack' by which the near-fullness of the profile buffer for\n\
- heathen (i.e., non-purified) code blocks is determined and by which\n\
- increment the buffer is extended when full.\
- ");
-\f
- /*-------------------------------------------------------------------------*/
- declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/SET-SLACK",
- Prim_PCBPB_set_slack, 1, 1,
- "(positive-fixnum)\n\
- Sets the `slack' by which the near-fullness of the PCBPB is determined and\n\
- by which increment the buffer is extended when full.\n\
- \n\
- Note that the slack must be a positive fixnum.\
- ");
- /*.........................................................................*/
- declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/SET-SLACK",
- Prim_HCBPB_set_slack, 1, 1,
- "(positive-fixnum)\n\
- Sets the `slack' by which the near-fullness of the HCBPB is determined and\n\
- by which increment the buffer is extended when full.\n\
- \n\
- Note that the slack must be a positive fixnum.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/SLACK-INCREMENT",
- Prim_PCBPB_slack_increment, 0, 0,
- "()\n\
- Returns the amount by which the PCBPB slack is incremented when a buffer\n\
- overflow occurs. In this sense it cuts the slack more slack.\n\
- \n\
- Note that the slack increment will always be a fixnum, but it can be negative\n\
- (in which case it functions as a slack decrement).\
- ");
- /*.........................................................................*/
- declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/SLACK-INCREMENT",
- Prim_HCBPB_slack_increment, 0, 0,
- "()\n\
- Returns the amount by which the HCBPB slack is incremented when a buffer\n\
- overflow occurs. In this sense it cuts the slack more slack.\n\
- \n\
- Note that the slack increment will always be a fixnum, but it can be negative\n\
- (in which case it functions as a slack decrement).\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/SET-SLACK-INCREMENT",
- Prim_PCBPB_set_slack_increment, 1, 1,
- "(fixnum)\n\
- Sets the amount by which the PCBPB slack is incremented when a buffer\n\
- overflow occurs.\n\
- \n\
- Note that the slack increment must be a fixnum, but it can be negative\n\
- (in which case it functions as a slack decrement).\
- ");
- /*.........................................................................*/
- declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/SET-SLACK-INCREMENT",
- Prim_HCBPB_set_slack_increment, 1, 1,
- "(fixnum)\n\
- Sets the amount by which the HCBPB slack is incremented when a buffer\n\
- overflow occurs.\n\
- \n\
- Note that the slack increment must be a fixnum, but it can be negative\n\
- (in which case it functions as a slack decrement).\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/EXTEND-NOISY?",
- Prim_PCBPB_extend_noisy_p, 0, 0,
- "()\n\
- Specifies whether notification of PCBPB buffer extensions is enabled.\
- ");
- /*.........................................................................*/
- declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/EXTEND-NOISY?",
- Prim_HCBPB_extend_noisy_p, 0, 0,
- "()\n\
- Specifies whether notification of HCBPB buffer extensions is enabled.\
- ");
-\f
- /*-------------------------------------------------------------------------*/
- declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/FLUSH-NOISY?",
- Prim_PCBPB_flush_noisy_p, 0, 0,
- "()\n\
- Specifies whether notification of PCBPB buffer extensions is enabled.\
- ");
- /*.........................................................................*/
- declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/FLUSH-NOISY?",
- Prim_HCBPB_flush_noisy_p, 0, 0,
- "()\n\
- Specifies whether notification of HCBPB buffer extensions is enabled.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/OVERFLOW-NOISY?",
- Prim_PCBPB_overflow_noisy_p, 0, 0,
- "()\n\
- Specifies whether notification of PCBPB buffer extensions is enabled.\
- ");
- /*.........................................................................*/
- declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/OVERFLOW-NOISY?",
- Prim_HCBPB_overflow_noisy_p, 0, 0,
- "()\n\
- Specifies whether notification of HCBPB buffer extensions is enabled.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/EXTEND-NOISY?/TOGGLE!",
- Prim_PCBPB_extend_noisy_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether to notify of PCBPB buffer extensions.\n\
- \n\
- It returns the newly installed sense of the flag.\
- ");
- /*.........................................................................*/
- declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/EXTEND-NOISY?/TOGGLE!",
- Prim_HCBPB_extend_noisy_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether to notify of HCBPB buffer extensions.\n\
- \n\
- It returns the newly installed sense of the flag.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/FLUSH-NOISY?/TOGGLE!",
- Prim_PCBPB_flush_noisy_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether to notify of PCBPB buffer flushes.\n\
- \n\
- It returns the newly installed sense of the flag.\
- ");
- /*.........................................................................*/
- declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/FLUSH-NOISY?/TOGGLE!",
- Prim_HCBPB_flush_noisy_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether to notify of HCBPB buffer flushes.\n\
- \n\
- It returns the newly installed sense of the flag.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/OVERFLOW-NOISY?/TOGGLE!",
- Prim_PCBPB_overflow_noisy_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether to notify of PCBPB buffer overflowes.\n\
- \n\
- It returns the newly installed sense of the flag.\
- ");
- /*.........................................................................*/
- declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/OVERFLOW-NOISY?/TOGGLE!",
- Prim_HCBPB_overflow_noisy_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether to notify of HCBPB buffer overflowes.\n\
- \n\
- It returns the newly installed sense of the flag.\
- ");
-\f
- /*-------------------------------------------------------------------------*/
- declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/EMPTY?",
- Prim_PCBPB_empty_p, 0, 0,
- "()\n\
- Returns a boolean indicating whether or not the profile buffer for\n\
- purified code blocks is empty.\
- ");
- /*.........................................................................*/
- declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/EMPTY?",
- Prim_HCBPB_empty_p, 0, 0,
- "()\n\
- Returns a boolean indicating whether or not the profile buffer for\n\
- heathen (i.e., unpurified) code blocks is empty.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("PURIFIED-CODE-BLOCK-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX",
- Prim_PCBPB_next_empty_slot_index, 0, 0,
- "()\n\
- Returns the index of the next `free' slot of the profile buffer for\n\
- purified code blocks.\
- ");
- /*.........................................................................*/
- declare_primitive ("HEATHEN-CODE-BLOCK-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX",
- Prim_HCBPB_next_empty_slot_index, 0, 0,
- "()\n\
- Returns the index of the next `free' slot of the profile buffer for\n\
- heathen (i.e., unpurified) code blocks.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PURIFIED-CODE-BLOCK-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX/RESET",
- Prim_PCBPB_next_empty_slot_index_reset, 0, 0,
- "()\n\
- Resets the index of the next `free' slot of the profile buffer for\n\
- purified code blocks.\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ");
- /*.........................................................................*/
- declare_primitive ("%HEATHEN-CODE-BLOCK-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX/RESET",
- Prim_HCBPB_next_empty_slot_index_reset, 0, 0,
- "()\n\
- Resets the index of the next `free' slot of the profile buffer for\n\
- heathen (i.e., unpurified) code blocks.\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/PCBPB-FLUSH-IMMEDIATE?",
- Prim_pc_sample_PCBPB_flush_immediate_p, 0, 0,
- "()\n\
- Specifies whether the Purified Code Block Profile Buffer is flushed upon\n\
- each entry.\n\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ");
- /*.........................................................................*/
- declare_primitive ("%PC-SAMPLE/HCBPB-FLUSH-IMMEDIATE?",
- Prim_pc_sample_HCBPB_flush_immediate_p, 0, 0,
- "()\n\
- Specifies whether the Heathen Code Block Profile Buffer is flushed upon\n\
- each entry.\n\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ");
-\f
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/PCBPB-FLUSH-IMMEDIATE?/TOGGLE!",
- Prim_pc_sample_PCBPB_flush_immediate_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether the Purified Code Block Profile Buffer\n\
- is flushed upon each entry.\n\
- \n\
- It returns the newly installed sense of the flag.\n\
- \n\
- This is for mondo bizarro sampler debugging purposes only.\n\
- \n\
- Only officially designated moby wizards should even think of thinking of\n\
- using this most ultra super duper secret primitive. FNORD!\
- ");
- /*.........................................................................*/
- declare_primitive ("%PC-SAMPLE/HCBPB-FLUSH-IMMEDIATE?/TOGGLE!",
- Prim_pc_sample_HCBPB_flush_immediate_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether the Heathen Code Block Profile Buffer\n\
- is flushed upon each entry.\n\
- \n\
- It returns the newly installed sense of the flag.\n\
- \n\
- This is for mondo bizarro sampler debugging purposes only.\n\
- \n\
- Only officially designated moby wizards should even think of thinking of\n\
- using this most ultra super duper secret primitive. FNORD!\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/PCBPB-DEBUGGING?",
- Prim_pc_sample_PCBPB_debugging_p, 0, 0,
- "()\n\
- Specifies whether the Purified Code Block Profile Buffer is in debugging mode.\n\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ");
- /*.........................................................................*/
- declare_primitive ("%PC-SAMPLE/HCBPB-DEBUGGING?",
- Prim_pc_sample_HCBPB_debugging_p, 0, 0,
- "()\n\
- Specifies whether the Heathen Code Block Profile Buffer is in debugging mode.\n\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/PCBPB-DEBUGGING?/TOGGLE!",
- Prim_pc_sample_PCBPB_debugging_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether the Purified Code Block Profile Buffer\n\
- is in debugging mode.\n\
- \n\
- It returns the newly installed sense of the flag.\n\
- \n\
- This is for mondo bizarro sampler debugging purposes only.\n\
- \n\
- Only officially designated moby wizards should even think of thinking of\n\
- using this most ultra super duper secret primitive. FNORD!\
- ");
- /*.........................................................................*/
- declare_primitive ("%PC-SAMPLE/HCBPB-DEBUGGING?/TOGGLE!",
- Prim_pc_sample_HCBPB_debugging_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether the Heathen Code Block Profile Buffer\n\
- is in debugging mode.\n\
- \n\
- It returns the newly installed sense of the flag.\n\
- \n\
- This is for mondo bizarro sampler debugging purposes only.\n\
- \n\
- Only officially designated moby wizards should even think of thinking of\n\
- using this most ultra super duper secret primitive. FNORD!\
- ");
-\f
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/PCBPB-MONITORING?",
- Prim_pc_sample_PCBPB_monitoring_p, 0, 0,
- "()\n\
- Specifies whether the PCBPB is in monitoring mode.\n\
- \n\
- This, for instance, is how a count of buffer overflows is accumulated.\
- ");
- /*.........................................................................*/
- declare_primitive ("%PC-SAMPLE/HCBPB-MONITORING?",
- Prim_pc_sample_HCBPB_monitoring_p, 0, 0,
- "()\n\
- Specifies whether the HCBPB is in monitoring mode.\n\
- \n\
- This, for instance, is how a count of buffer overflows is accumulated.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/PCBPB-MONITORING?/TOGGLE!",
- Prim_pc_sample_PCBPB_monitoring_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether the Purified Code Block Profile Buffer\n\
- is in monitoring mode.\n\
- \n\
- It returns the newly installed sense of the flag.\n\
- \n\
- This is for mondo bizarro sampler monitoring purposes only.\n\
- For instance, toggling this monitor flag to true triggers accumulating\n\
- a count of buffer overflows.\
- ");
- /*.........................................................................*/
- declare_primitive ("%PC-SAMPLE/HCBPB-MONITORING?/TOGGLE!",
- Prim_pc_sample_HCBPB_monitoring_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether the Heathen Code Block Profile Buffer\n\
- is in monitoring mode.\n\
- \n\
- It returns the newly installed sense of the flag.\n\
- \n\
- This is for mondo bizarro sampler monitoring purposes only.\n\
- For instance, toggling this monitor flag to true triggers accumulating\n\
- a count of buffer overflows.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/PCBPB-FLUSH-COUNT",
- Prim_pc_sample_PCBPB_flush_count, 0, 0,
- "()\n\
- Returns the number of PCBPB flush requests that have been issued since the\n\
- last PC-SAMPLE/PCBPB-FLUSH-COUNT/RESET was issued (or since booting if no\n\
- resets issued).\
- ");
- /*.........................................................................*/
- declare_primitive ("%PC-SAMPLE/HCBPB-FLUSH-COUNT",
- Prim_pc_sample_HCBPB_flush_count, 0, 0,
- "()\n\
- Returns the number of HCBPB flush requests that have been issued since the\n\
- last PC-SAMPLE/HCBPB-FLUSH-COUNT/RESET was issued (or since booting if no\n\
- resets issued).\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/PCBPB-FLUSH-COUNT/RESET",
- Prim_pc_sample_PCBPB_flush_count_reset, 0, 0,
- "()\n\
- Resets the PCBPB flush count (obviously... sheesh!).\
- ");
- /*.........................................................................*/
- declare_primitive ("%PC-SAMPLE/HCBPB-FLUSH-COUNT/RESET",
- Prim_pc_sample_HCBPB_flush_count_reset, 0, 0,
- "()\n\
- Resets the HCBPB flush count (obviously... sheesh!).\
- ");
-\f
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/PCBPB-EXTEND-COUNT",
- Prim_pc_sample_PCBPB_extend_count, 0, 0,
- "()\n\
- Returns the number of PCBPB extend requests that have been issued since the\n\
- last PC-SAMPLE/PCBPB-EXTEND-COUNT/RESET was issued (or since booting if no\n\
- resets issued).\
- ");
- /*.........................................................................*/
- declare_primitive ("%PC-SAMPLE/HCBPB-EXTEND-COUNT",
- Prim_pc_sample_HCBPB_extend_count, 0, 0,
- "()\n\
- Returns the number of HCBPB extend requests that have been issued since the\n\
- last PC-SAMPLE/HCBPB-EXTEND-COUNT/RESET was issued (or since booting if no\n\
- resets issued).\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/PCBPB-EXTEND-COUNT/RESET",
- Prim_pc_sample_PCBPB_extend_count_reset, 0, 0,
- "()\n\
- Resets the PCBPB extend count (obviously... sheesh!).\
- ");
- /*.........................................................................*/
- declare_primitive ("%PC-SAMPLE/HCBPB-EXTEND-COUNT/RESET",
- Prim_pc_sample_HCBPB_extend_count_reset, 0, 0,
- "()\n\
- Resets the HCBPB extend count (obviously... sheesh!).\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/PCBPB-OVERFLOW-COUNT",
- Prim_pc_sample_PCBPB_overflow_count, 0, 0,
- "()\n\
- Returns the number of PCBPB overflows that have been issued since the last\n\
- PC-SAMPLE/PCBPB-OVERFLOW-COUNT/RESET was issued (or since booting if no\n\
- resets issued).\n\
- \n\
- Each overflow indicates a sample that was punted into the bit bucket.\
- ");
- /*.........................................................................*/
- declare_primitive ("%PC-SAMPLE/HCBPB-OVERFLOW-COUNT",
- Prim_pc_sample_HCBPB_overflow_count, 0, 0,
- "()\n\
- Returns the number of HCBPB overflows that have been issued since the last\n\
- PC-SAMPLE/HCBPB-OVERFLOW-COUNT/RESET was issued (or since booting if no\n\
- resets issued).\n\
- \n\
- Each overflow indicates a sample that was punted into the bit bucket.\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/PCBPB-OVERFLOW-COUNT/RESET",
- Prim_pc_sample_PCBPB_overflow_count_reset, 0, 0,
- "()\n\
- Resets the PCBPB overflow count (obviously... sheesh!).\
- ");
- /*.........................................................................*/
- declare_primitive ("%PC-SAMPLE/HCBPB-OVERFLOW-COUNT/RESET",
- Prim_pc_sample_HCBPB_overflow_count_reset, 0, 0,
- "()\n\
- Resets the HCBPB overflow count (obviously... sheesh!).\
- ");
-\f
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/PCBPB-EXTRA-INFO",
- Prim_pc_sample_PCBPB_extra_info, 0, 0,
- "()\n\
- Returns the extra info entry associated with the Purified Code Block\n\
- Profile Buffer.\n\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ");
- /*.........................................................................*/
- declare_primitive ("%PC-SAMPLE/HCBPB-EXTRA-INFO",
- Prim_pc_sample_HCBPB_extra_info, 0, 0,
- "()\n\
- Returns the extra info entry associated with the Heathen Code Block\n\
- Profile Buffer.\n\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ");
- /*-------------------------------------------------------------------------*/
- declare_primitive ("%PC-SAMPLE/SET-PCBPB-EXTRA-INFO!",
- Prim_pc_sample_set_PCBPB_extra_info, 1, 1,
- "(object)\n\
- Stores OBJECT in the extra info entry of the Purified Code Block\n\
- Profile Buffer.\n\
- \n\
- This is for mondo bizarro sampler frobnication purposes only.\n\
- \n\
- Only officially designated moby wizards should even think of thinking of\n\
- using this most ultra super duper secret primitive. FNORD!\
- ");
- /*.........................................................................*/
- declare_primitive ("%PC-SAMPLE/SET-HCBPB-EXTRA-INFO!",
- Prim_pc_sample_set_HCBPB_extra_info, 1, 1,
- "(object)\n\
- Stores OBJECT in the extra info entry of the Heathen Code Block\n\
- Profile Buffer.\n\
- \n\
- This is for mondo bizarro sampler frobnication purposes only.\n\
- \n\
- Only officially designated moby wizards should even think of thinking of\n\
- using this most ultra super duper secret primitive. FNORD!\
- ");
- /*-------------------------------------------------------------------------*/
-
-
-
- declare_primitive ("%PC-SAMPLE/SET-ZONE!",
- Prim_pc_sample_set_current_zone, 1, 1,
- "(index)\n\
-Set current pc-sampling zone to INDEX (a small exact integer), returning \
-the previous value if different, else #F if same.");
-
- declare_primitive ("%PC-SAMPLE/MAX-ZONE",
- Prim_pc_sample_get_max_zone, 0, 0, 0);
-
- declare_primitive ("%PC-SAMPLE/CLEAR-ZONES!",
- Prim_pc_sample_clear_zones, 0, 0,
- "()\nZero zone counts.");
-
- declare_primitive ("%PC-SAMPLE/READ-ZONES!", Prim_pc_sample_read_zones, 1, 1,
- "(flonum-vector)\n\
-Copy zone counts into FLONUM-VECTOR. Returns the number copied, which \
-is limited by either the number of zones to the capacity of FLONUM-VECTOR.");
-
-}
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; PC Sample Interrupt System
-;;; package: (pc-sample interrupt-handler)
-
-(declare (usual-integrations))
-\f
-(define (initialize-package!)
- (install))
-
-(define-primitives
- (clear-interrupts! 1)
- set-fixed-objects-vector!
- )
-
-;; Slots 0--8 are reserved by the system (for GC and overflow et al)
-
-(define-integrable IPPB-flush-slot 9) ; pc-sample
-(define-integrable IPPB-extend-slot 10) ; pc-sample
-(define-integrable PCBPB-flush-slot 11) ; pc-sample
-(define-integrable PCBPB-extend-slot 12) ; pc-sample
-(define-integrable HCBPB-flush-slot 13) ; pc-sample
-(define-integrable HCBPB-extend-slot 14) ; pc-sample
-
-;; Slot 15 is the dreaded illegal-interrupt-slot
-
-
-;;;; Miscellaneous PC Sample Interrupts: buffer flush and extend requests
-
-(define (IPPB-flush-request-handler interrupt-code interrupt-enables)
- interrupt-code interrupt-enables
- (interp-proc-profile-buffer/flush)
- (clear-interrupts! interrupt-bit/IPPB-flush))
-
-(define (IPPB-extend-interrupt-handler interrupt-code interrupt-enables)
- interrupt-code interrupt-enables
- (interp-proc-profile-buffer/extend)
- (clear-interrupts! interrupt-bit/IPPB-extend))
-
-(define (PCBPB-flush-request-handler interrupt-code interrupt-enables)
- interrupt-code interrupt-enables
- (purified-code-block-profile-buffer/flush)
- (clear-interrupts! interrupt-bit/PCBPB-flush))
-
-(define (PCBPB-extend-interrupt-handler interrupt-code interrupt-enables)
- interrupt-code interrupt-enables
- (purified-code-block-profile-buffer/extend)
- (clear-interrupts! interrupt-bit/PCBPB-extend))
-
-(define (HCBPB-flush-request-handler interrupt-code interrupt-enables)
- interrupt-code interrupt-enables
- (heathen-code-block-profile-buffer/flush)
- (clear-interrupts! interrupt-bit/HCBPB-flush))
-
-(define (HCBPB-extend-interrupt-handler interrupt-code interrupt-enables)
- interrupt-code interrupt-enables
- (heathen-code-block-profile-buffer/extend)
- (clear-interrupts! interrupt-bit/HCBPB-extend))
-\f
-;;;; Keyboard Interrupts
-
-(define (install)
- (without-interrupts
- (lambda ()
- (let ((system-interrupt-vector
- (vector-ref (get-fixed-objects-vector) index:interrupt-vector))
- (interrupt-mask-vector
- (vector-ref (get-fixed-objects-vector)
- index:interrupt-mask-vector)))
-
- (vector-set! system-interrupt-vector IPPB-flush-slot ; pc-sample
- IPPB-flush-request-handler)
- (vector-set! interrupt-mask-vector IPPB-flush-slot ; pc-sample
- interrupt-mask/gc-ok)
-
- (vector-set! system-interrupt-vector IPPB-extend-slot ; pc-sample
- IPPB-extend-interrupt-handler)
- (vector-set! interrupt-mask-vector IPPB-extend-slot ; pc-sample
- interrupt-mask/gc-ok)
-
- (vector-set! system-interrupt-vector PCBPB-flush-slot ; pc-sample
- PCBPB-flush-request-handler)
- (vector-set! interrupt-mask-vector PCBPB-flush-slot ; pc-sample
- interrupt-mask/gc-ok)
-
- (vector-set! system-interrupt-vector PCBPB-extend-slot ; pc-sample
- PCBPB-extend-interrupt-handler)
- (vector-set! interrupt-mask-vector PCBPB-extend-slot ; pc-sample
- interrupt-mask/gc-ok)
-
- (vector-set! system-interrupt-vector HCBPB-flush-slot ; pc-sample
- HCBPB-flush-request-handler)
- (vector-set! interrupt-mask-vector HCBPB-flush-slot ; pc-sample
- interrupt-mask/gc-ok)
-
- (vector-set! system-interrupt-vector HCBPB-extend-slot ; pc-sample
- HCBPB-extend-interrupt-handler)
- (vector-set! interrupt-mask-vector HCBPB-extend-slot ; pc-sample
- interrupt-mask/gc-ok)
-
- #|
- ;; Nop
- (set-fixed-objects-vector! (get-fixed-objects-vector))
- |#
- ))))
-
-;;; fini
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* PCSIPROC.C -- defines PC Sample subroutines for profiling interp-procs *\
-\* (a.k.a. interpreted procedures) within pcsample.c */
-
-/*****************************************************************************/
-#ifdef REALLY_INCLUDE_PROFILE_CODE /* scan_defines concession */
-
-#include <microcode/lookup.h> /* For AUX_LIST_TYPE */
-\f
-/*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*\
- * TODO:
- *
- * - Maybe flatten number of primitives?
- *
-\*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!*/
-\f
-/*===========================================================================*\
- * Interp-Proc Profile Buffer is for buffering sightings of interpreted procs *
- * (a.k.a. compounds) until they can be spilled into the Interp-Proc Profile *
- * Table. *
- * *
- * This hairy mess is to reduce the overhead of passing interpreted procs up *
- * to Scheme (where they can be entered into a hash table)... only once the *
- * buffer is nearly filled does an interrupt get generated to spill the buffer*
- * contents into the profile hashtable. *
-\*===========================================================================*/
-
-/*****************************************************************************
- * Interp-Proc Profile Buffer consists of a vector of slots and a handfull of
- * state variables...
- */
-
-static struct profile_buffer_state interp_proc_profile_buffer_state;
-
-static void
-DEFUN_VOID (init_IPPB_profile_buffer_state)
-{
- init_profile_uni_buffer_state (&interp_proc_profile_buffer_state,
- " IPPB", /* name */
- PC_Sample_Interp_Proc_Buffer, /* ID */
- 8*128, /* slack */
- 128, /* slack_inc */
- INT_IPPB_Flush, /* flush_INT */
- INT_IPPB_Extend /* extnd_INT */
- );
-}
-
-/* convenient shorthand for use in primitives below... */
-
-#define IPPB_name \
- (interp_proc_profile_buffer_state . name)
-#define IPPB_ID \
- (interp_proc_profile_buffer_state . ID)
-#define IPPB_enabled \
- (interp_proc_profile_buffer_state . enabled_flag)
-#define IPPB_buffer \
- (interp_proc_profile_buffer_state . buffer)
-#define IPPB_length \
- (interp_proc_profile_buffer_state . length)
-#define IPPB_next_empty_slot_index \
- (interp_proc_profile_buffer_state . next_empty_slot_index)
-#define IPPB_slack \
- (interp_proc_profile_buffer_state . slack)
-#define IPPB_slack_increment \
- (interp_proc_profile_buffer_state . slack_increment)
-#define IPPB_flush_INT \
- (interp_proc_profile_buffer_state . flush_INT)
-#define IPPB_extend_INT \
- (interp_proc_profile_buffer_state . extend_INT)
-#define IPPB_flush_noisy \
- (interp_proc_profile_buffer_state . flush_noisy_flag)
-#define IPPB_extend_noisy \
- (interp_proc_profile_buffer_state . extend_noisy_flag)
-#define IPPB_overflow_noisy \
- (interp_proc_profile_buffer_state . overflow_noisy_flag)
-#define IPPB_flush_immediate \
- (interp_proc_profile_buffer_state . flush_immed_flag)
-#define IPPB_debugging \
- (interp_proc_profile_buffer_state . debug_flag)
-#define IPPB_monitoring \
- (interp_proc_profile_buffer_state . monitor_flag)
-#define IPPB_flush_count \
- (interp_proc_profile_buffer_state . flush_count)
-#define IPPB_extend_count \
- (interp_proc_profile_buffer_state . extend_count)
-#define IPPB_overflow_count \
- (interp_proc_profile_buffer_state . overflow_count)
-#define IPPB_extra_info \
- (interp_proc_profile_buffer_state . extra_buffer_state_info)
-\f
-/*---------------------------------------------------------------------------*/
-#define IPPB_disable() do \
-{ \
- Set_Fixed_Obj_Slot (PC_Sample_Interp_Proc_Buffer, SHARP_F ) ; \
- IPPB_buffer = SHARP_F ; \
- IPPB_enabled = false ; \
- IPPB_next_empty_slot_index = 0 ; \
- IPPB_length = 0 ; /* Paranoia */\
-} while (FALSE)
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/DISABLE",
- Prim_IPPB_disable, 0, 0,
- "()\n\
- Disables the interpreted procedure profile buffer hence disabling profiling\n\
- of interpreted procedures (unless and until a new buffer is installed).\
- ")
-{
- PRIMITIVE_HEADER(0);
- IPPB_disable ();
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-/*---------------------------------------------------------------------------*/
-#define IPPB_install(buffer_arg) do \
-{ \
- Set_Fixed_Obj_Slot (PC_Sample_Interp_Proc_Buffer, buffer_arg ) ; \
- IPPB_buffer = buffer_arg ; \
- IPPB_enabled = true ; \
- IPPB_length = (VECTOR_LENGTH (buffer_arg)) ; \
- /* NB: Do NOT reset next_empty_slot_index since may be extending */ \
-} while (FALSE)
-/*...........................................................................*/
-DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/INSTALL",
- Prim_IPPB_install, 1, 1,
- "(vector)\n\
- Installs VECTOR as the interpreted procedure profile buffer.\
- ")
-{
- PRIMITIVE_HEADER(1);
- CHECK_ARG(1, VECTOR_P);
- IPPB_install (ARG_REF (1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-/*---------------------------------------------------------------------------*/
-/*---------------------------------------------------------------------------*/
-static void
-DEFUN_VOID(resynch_IPPB_post_gc_hook)
-{
- if IPPB_enabled
- IPPB_install (Get_Fixed_Obj_Slot (PC_Sample_Interp_Proc_Buffer)) ;
-}
-/*---------------------------------------------------------------------------*/
-/*---------------------------------------------------------------------------*/
-\f
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/SLACK", Prim_IPPB_slack, 0, 0,
- "()\n\
- Returns the `slack' by which the near-fullness of the interpreted procedure\n\
- profile buffer is determined and by which increment the buffer is extended\n\
- when full.\n\
- \n\
- Note that the slack will always be a positive fixnum.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (ulong_to_integer (IPPB_slack));
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/SET-SLACK",
- Prim_IPPB_set_slack, 1, 1,
- "(positive-fixnum)\n\
- Sets the `slack' by which the near-fullness of the interpreted procedure\n\
- profile buffer is determined and by which increment the buffer is extended\n\
- when full.\n\
- \n\
- Note that the slack must be a positive fixnum.\
- ")
-{
- PRIMITIVE_HEADER(1);
- CHECK_ARG (1, FIXNUM_POSITIVE_P);
- IPPB_slack = (integer_to_ulong (ARG_REF (1)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/SLACK-INCREMENT",
- Prim_IPPB_slack_increment, 0, 0,
- "()\n\
- Returns the amount by which the interpreted procedure profile buffer slack\n\
- is incremented when a buffer overflow occurs. In this sense it cuts the\n\
- slack some slack.\n\
- \n\
- Note that the slack increment will always be a fixnum, but it can be negative\n\
- (in which case it functions as a slack decrement).\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (long_to_integer (IPPB_slack_increment));
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/SET-SLACK-INCREMENT",
- Prim_IPPB_set_slack_increment, 1, 1,
- "(fixnum)\n\
- Sets the amount by which the interpreted procedure profile buffer slack is\n\
- incremented when a buffer overflow occurs.\n\
- \n\
- Note that the slack increment must be a fixnum, but it can be negative\n\
- (in which case it functions as a slack decrement).\
- ")
-{
- PRIMITIVE_HEADER(1);
- CHECK_ARG (1, INTEGER_P);
- IPPB_slack_increment = (integer_to_long (ARG_REF (1)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/EXTEND-NOISY?",
- Prim_IPPB_extend_noisy_p, 0, 0,
- "()\n\
- Specifies whether notification of IPPB extensions is enabled.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_extend_noisy)) ;
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/FLUSH-NOISY?",
- Prim_IPPB_flush_noisy_p, 0, 0,
- "()\n\
- Specifies whether notification of IPPB extensions is enabled.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_flush_noisy)) ;
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/OVERFLOW-NOISY?",
- Prim_IPPB_overflow_noisy_p, 0, 0,
- "()\n\
- Specifies whether notification of IPPB overflows is enabled.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_overflow_noisy)) ;
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/EXTEND-NOISY?/TOGGLE!",
- Prim_IPPB_extend_noisy_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether to notify of IPPB extensions.\n\
- \n\
- It returns the newly installed sense of the flag.\
- ")
-{
- PRIMITIVE_HEADER(0);
- IPPB_extend_noisy = (! (IPPB_extend_noisy)) ;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_extend_noisy)) ;
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/FLUSH-NOISY?/TOGGLE!",
- Prim_IPPB_flush_noisy_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether to notify of IPPB flushes.\n\
- \n\
- It returns the newly installed sense of the flag.\
- ")
-{
- PRIMITIVE_HEADER(0);
- IPPB_flush_noisy = (! (IPPB_flush_noisy)) ;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_flush_noisy)) ;
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/OVERFLOW-NOISY?/TOGGLE!",
- Prim_IPPB_overflow_noisy_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether to notify of IPPB overflows.\n\
- \n\
- It returns the newly installed sense of the flag.\
- ")
-{
- PRIMITIVE_HEADER(0);
- IPPB_overflow_noisy = (! (IPPB_overflow_noisy)) ;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_overflow_noisy)) ;
-}
-\f
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/EMPTY?", Prim_IPPB_empty_p, 0, 0,
- "()\n\
- Returns a boolean indicating whether or not the IPPB is empty.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN(BOOLEAN_TO_OBJECT (IPPB_next_empty_slot_index == 0)) ;
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("INTERP-PROC-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX",
- Prim_IPPB_next_empty_slot_index, 0, 0,
- "()\n\
- Returns the index of the next `free' slot of the interp-proc profile buffer.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN(ulong_to_integer (IPPB_next_empty_slot_index));
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%INTERP-PROC-PROFILE-BUFFER/NEXT-EMPTY-SLOT-INDEX/RESET",
- Prim_IPPB_next_empty_slot_index_reset, 0, 0,
- "()\n\
- Resets the index of the next `free' slot of the interp-proc profile buffer.\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(0);
- IPPB_next_empty_slot_index = ((unsigned long) 0);
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-\f
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-FLUSH-IMMEDIATE?",
- Prim_pc_sample_IPPB_flush_immediate_p, 0, 0,
- "()\n\
- Specifies whether the IPPB is flushed upon each entry.\n\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_flush_immediate)) ;
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-FLUSH-IMMEDIATE?/TOGGLE!",
- Prim_pc_sample_IPPB_flush_immediate_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether the IPPBuffer is flushed upon each entry.\n\
- \n\
- It returns the newly installed sense of the flag.\n\
- \n\
- This is for mondo bizarro sampler debugging purposes only.\n\
- \n\
- Only officially designated moby wizards should even think of thinking of\n\
- using this most ultra super duper secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(0);
- IPPB_flush_immediate = (! (IPPB_flush_immediate)) ;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_flush_immediate)) ;
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-DEBUGGING?",
- Prim_pc_sample_IPPB_debugging_p, 0, 0,
- "()\n\
- Specifies whether the IPPB is in debugging mode.\n\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_debugging)) ;
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-DEBUGGING?/TOGGLE!",
- Prim_pc_sample_IPPB_debugging_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether the IPPBuffer is in debugging mode.\n\
- \n\
- It returns the newly installed sense of the flag.\n\
- \n\
- This is for mondo bizarro sampler debugging purposes only.\n\
- \n\
- Only officially designated moby wizards should even think of thinking of\n\
- using this most ultra super duper secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(0);
- IPPB_debugging = (! (IPPB_debugging)) ;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_debugging)) ;
-}
-\f
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-MONITORING?",
- Prim_pc_sample_IPPB_monitoring_p, 0, 0,
- "()\n\
- Specifies whether the IPPB is in monitoring mode.\n\
- \n\
- This, for instance, is how a count of buffer overflows is accumulated.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_monitoring)) ;
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-MONITORING?/TOGGLE!",
- Prim_pc_sample_IPPB_monitoring_p_toggle_bang, 0, 0,
- "()\n\
- Toggles the Boolean sense of whether the IPPB is in monitoring mode.\n\
- \n\
- It returns the newly installed sense of the flag.\n\
- \n\
- This is for mondo bizarro sampler monitoring purposes only.\n\
- For instance, toggling this monitor flag to true triggers accumulating\n\
- a count of buffer overflows.\
- ")
-{
- PRIMITIVE_HEADER(0);
- IPPB_monitoring = (! (IPPB_monitoring)) ;
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (IPPB_monitoring)) ;
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-FLUSH-COUNT",
- Prim_pc_sample_IPPB_flush_count, 0, 0,
- "()\n\
- Returns the number of IPPB flush requests that have been issued since the\n\
- last PC-SAMPLE/IPPB-FLUSH-COUNT/RESET was issued (or since booting if no\n\
- resets issued).\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN(ulong_to_integer (IPPB_flush_count));
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-FLUSH-COUNT/RESET",
- Prim_pc_sample_IPPB_flush_count_reset, 0, 0,
- "()\n\
- Resets the IPPB flush count (obviously... sheesh!).\
- ")
-{
- PRIMITIVE_HEADER(0);
- IPPB_flush_count = ((unsigned long) 0);
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-EXTEND-COUNT",
- Prim_pc_sample_IPPB_extend_count, 0, 0,
- "()\n\
- Returns the number of IPPB extend requests that have been issued since the\n\
- last PC-SAMPLE/IPPB-EXTEND-COUNT/RESET was issued (or since booting if no\n\
- resets issued).\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN(ulong_to_integer (IPPB_extend_count));
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-EXTEND-COUNT/RESET",
- Prim_pc_sample_IPPB_extend_count_reset, 0, 0,
- "()\n\
- Resets the IPPB extend count (obviously... sheesh!).\
- ")
-{
- PRIMITIVE_HEADER(0);
- IPPB_extend_count = ((unsigned long) 0);
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-\f
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-OVERFLOW-COUNT",
- Prim_pc_sample_IPPB_overflow_count, 0, 0,
- "()\n\
- Returns the number of IPPB overflows that have been issued since the\n\
- last PC-SAMPLE/IPPB-OVERFLOW-COUNT/RESET was issued (or since booting if no\n\
- resets issued).\n\
- \n\
- Each overflow indicates a sample that was punted into the bit bucket.\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN(ulong_to_integer (IPPB_overflow_count));
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-OVERFLOW-COUNT/RESET",
- Prim_pc_sample_IPPB_overflow_count_reset, 0, 0,
- "()\n\
- Resets the IPPB overflow count (obviously... sheesh!).\
- ")
-{
- PRIMITIVE_HEADER(0);
- IPPB_overflow_count = ((unsigned long) 0);
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/IPPB-EXTRA-INFO",
- Prim_pc_sample_IPPB_extra_info, 0, 0,
- "()\n\
- Returns the extra info entry associated with the IPP Buffer.\n\
- \n\
- Only officially designated wizards should even think of using this\n\
- super secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(0);
- PRIMITIVE_RETURN (IPPB_extra_info) ;
-}
-/*---------------------------------------------------------------------------*/
-DEFINE_PRIMITIVE ("%PC-SAMPLE/SET-IPPB-EXTRA-INFO!",
- Prim_pc_sample_set_IPPB_extra_info_bang, 1, 1,
- "(object)\n\
- Stores OBJECT in the extra info entry of the IPPB.\n\
- \n\
- This is for mondo bizarro sampler frobnication purposes only.\n\
- \n\
- Only officially designated moby wizards should even think of thinking of\n\
- using this most ultra super duper secret primitive. FNORD!\
- ")
-{
- PRIMITIVE_HEADER(1);
- IPPB_extra_info = ARG_REF(1);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-/*****************************************************************************
- * kludgerous ``hidden arg'' passing mechanism
- */
-
-static SCHEME_OBJECT pc_sample_current_env_frame = UNSPECIFIC ;
-
-/*****************************************************************************/
-static void
-DEFUN (pc_sample_record_interp_proc, (trinfo), struct trap_recovery_info * trinfo)
-{
- /* GJR suggested nabbing the current ENV to find the current PROC,
- * warning that the current ENV may be invalid, e.g. in the middle
- * of a LOAD. Its validity will have been assured by the caller here.
- *
- * Since no real virtual PC is maintained in the interpreter, this ENV
- * frobbing is our only means of mapping a SIGCONTEXT into some unique ID
- * of the interp-proc being interpreted. Specifically, we recover the lambda
- * lurking within the body of the procedure whose arguments gave rise to the
- * current ENV frame.
- *
- * Oh, TRINFO arg is for cutesy diagnostics of Unidentifiable Function Objs.
- */
-
- SCHEME_OBJECT interp_proc_lambda ;
- SCHEME_OBJECT the_procedure = (MEMORY_REF (pc_sample_current_env_frame,
- ENVIRONMENT_FUNCTION));
-
- /* Stutter step to make sure it really *is* a procedure object */
-
- if ((OBJECT_TYPE (the_procedure)) == AUX_LIST_TYPE)
- the_procedure = (MEMORY_REF (the_procedure, ENV_EXTENSION_PROCEDURE));
-
- interp_proc_lambda = (MEMORY_REF (the_procedure, PROCEDURE_LAMBDA_EXPR ));
-
- /* Hurumph... since the lambda may never have been hashed (and trap
- * handlers are forbidden to do the CONSing necessary to generate new hash
- * numbers), and since there is no microcode/scheme interface for hashing
- * microcode objects (i.e., C data) anyway, we just pass the buck up to the
- * interrupt handler mechanism: interrupt handlers are called at delicately
- * perspicatious moments so they are permitted to CONS. This buck is passed
- * by buffering lambdas until we have enough of them that it is worth
- * issuing a request to spill the buffer into the lambda hashtable.
- * For more details, see pcsiproc.scm in the runtime directory.
- */
-
- pc_sample_record_buffer_entry( interp_proc_lambda,
- &interp_proc_profile_buffer_state);
-
-#if ( defined(PCS_LOG) /* Sample console logging */ \
- || defined(PCS_LOG_INTERP_PROC) \
- )
- log_interp_proc_sample (trinfo) ;
-#endif
-
-}
-
-
-
-/*****************************************************************************/
-#endif /* REALLY_INCLUDE_PROFILE_CODE */
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; PC Sampling Interp-Procs (i.e., interpreted procedure profiling)
-;;; package: (pc-sample interp-procs)
-
-(declare (usual-integrations))
-\f
-;;; Interp-Procs (interpreted procedures) are profiled by recording profiling
-;;; info about their associated procedure-lambdas. The reason the procedure
-;;; lambda is used rather than the full procedure object (lambda + environment)
-;;; is we want various dynamic activations of the same lambda to be identified.
-;;; Were we to hash off the procedure object rather than just its lambda, these
-;;; dynamic invocation instances would be distinguished since their associated
-;;; envs would (normally) be distinguishable.
-;;;
-;;; An interesting issue arises when considering generated procedures,
-;;; especially those such as would be generated by the canonical MAKE-COUNTER
-;;; proc below:
-;;;
-;;; (define (make-counter)
-;;; (let ((count -1))
-;;; (lambda (msg)
-;;; (case msg
-;;; ((NEXT) (set! count (1+ count)) count)
-;;; ((RESET) (set! count -1 ) count)
-;;; ))))
-;;;
-;;; (define a (make-counter))
-;;; (define b (make-counter))
-;;;
-;;; At the time of creation of this facility (1993.03.31.04.02.01), under such
-;;; an arrangement, the procedures A and B would share procedure lambdas so,
-;;; for purposes of profiling them while interpreted, they would be indistin-
-;;; guishable. To wit, time spent in either A or B would be attributed as time
-;;; spent in the ``A-or-B'' procedure.
-;;;
-;;; The obvious alternative is to profile interpreted procedures by their full
-;;; procedure object (lambda + environment). Under this approach, A and B
-;;; would indeed be distinguishable. Unfortunately, so too would any two
-;;; activations of the same procedure. This is clearly untenable for purposes
-;;; of collecting useable profiling information. ???
-
-(define (initialize-package!)
- (set! *interp-proc-profile-table* (interp-proc-profile-table/make))
- ;; microlevel buffer install
- (install-interp-proc-profile-buffer/length)
- )
-
-(define-primitives
- (interp-proc-profile-buffer/empty? 0)
- (interp-proc-profile-buffer/next-empty-slot-index 0)
- (interp-proc-profile-buffer/slack 0)
- (interp-proc-profile-buffer/slack-increment 0)
- (interp-proc-profile-buffer/set-slack 1)
- (interp-proc-profile-buffer/set-slack-increment 1)
- (interp-proc-profile-buffer/extend-noisy? 0)
- (interp-proc-profile-buffer/flush-noisy? 0)
- (interp-proc-profile-buffer/overflow-noisy? 0)
- (interp-proc-profile-buffer/extend-noisy?/toggle! 0)
- (interp-proc-profile-buffer/flush-noisy?/toggle! 0)
- (interp-proc-profile-buffer/overflow-noisy?/toggle! 0)
- #|
- (interp-proc-profile-buffer/with-extend-notification! 0)
- (interp-proc-profile-buffer/with-flush-notification! 0)
- (interp-proc-profile-buffer/with-overflow-notification! 0)
- |#
- ;; microcode magic: don't look. Fnord!
- (%pc-sample/IPPB-overflow-count 0)
- (%pc-sample/IPPB-overflow-count/reset 0)
- (%pc-sample/IPPB-monitoring? 0)
- (%pc-sample/IPPB-monitoring?/toggle! 0)
- )
-
-(define (profile-buffer/with-mumble-notification! noise? thunk
- x/f-noisy? toggle-noise!)
- (let ((already-noisy? (x/f-noisy?))
- (want-no-noise? (not noise?))) ; coerce to Boolean
- (if (eq? already-noisy? want-no-noise?) ; xor want and got
- (dynamic-wind toggle-noise! thunk toggle-noise!)
- (thunk))))
-
-(define (interp-proc-profile-buffer/with-extend-notification! noise? thunk)
- (profile-buffer/with-mumble-notification! noise? thunk
- interp-proc-profile-buffer/extend-noisy?
- interp-proc-profile-buffer/extend-noisy?/toggle!))
-
-(define (interp-proc-profile-buffer/with-flush-notification! noise? thunk)
- (profile-buffer/with-mumble-notification! noise? thunk
- interp-proc-profile-buffer/flush-noisy?
- interp-proc-profile-buffer/flush-noisy?/toggle!))
-
-(define (interp-proc-profile-buffer/with-overflow-notification! noise? thunk)
- (profile-buffer/with-mumble-notification! noise? thunk
- interp-proc-profile-buffer/overflow-noisy?
- interp-proc-profile-buffer/overflow-noisy?/toggle!))
-\f
-;;; Interp-Proc Profile Buffer is to buffer up sightings of interpreted procs
-;;; that are not yet hashed into the Interp-Proc Profile (Hash) Table
-
-(define *interp-proc-profile-buffer* #F) ; software cache of fixed obj Ntry
-
-(define (interp-proc-profiling-disabled?)
- (not *interp-proc-profile-buffer*))
-
-(define *interp-proc-profile-buffer/length/initial*)
-
-(define (install-interp-proc-profile-buffer/length/initial)
- (set! *interp-proc-profile-buffer/length/initial*
- (* 4 (interp-proc-profile-buffer/slack))))
-
-(define *interp-proc-profile-buffer/length*)
-
-(define (install-interp-proc-profile-buffer/length)
- ( install-interp-proc-profile-buffer/length/initial)
- (set! *interp-proc-profile-buffer/length*
- *interp-proc-profile-buffer/length/initial*))
-
-(define (interp-proc-profile-buffer/length)
- *interp-proc-profile-buffer/length*)
-(define (interp-proc-profile-buffer/length/set! new-value)
- (set! *interp-proc-profile-buffer/length* new-value))
-
-(define (interp-proc-profile-buffer/status)
- "()\n\
- Returns a CONS pair of the length and `slack' of the\n\
- interpreted procedure profile buffer.\
- "
- (cons (interp-proc-profile-buffer/length)
- (interp-proc-profile-buffer/slack)))
-
-(define *interp-proc-profile-buffer/status/old* '(0 . 0))
-(define (interp-proc-profile-buffer/status/previous)
- "()\n\
- Returns the status of the profile buffer before the last modification to\n\
- its length and/or slack.\
- "
- *interp-proc-profile-buffer/status/old*)
-
-;;; TODO: flush/reset/spill/extend should all employ double buffering of the
-;;; interp-proc profile buffer.
-
-(define *interp-proc-profile-buffer/extend-count?* #F)
-(define-integrable (interp-proc-profile-buffer/extend-count?)
- *interp-proc-profile-buffer/extend-count?*)
-(define-integrable (interp-proc-profile-buffer/extend-count?/toggle!)
- (set! *interp-proc-profile-buffer/extend-count?*
- (not *interp-proc-profile-buffer/extend-count?*)))
-(define (interp-proc-profile-buffer/with-extend-count! count?
- thunk)
- (fluid-let ((*interp-proc-profile-buffer/extend-count?* count?))
- (thunk)))
-(define *interp-proc-profile-buffer/extend-count* 0)
-(define-integrable (interp-proc-profile-buffer/extend-count)
- *interp-proc-profile-buffer/extend-count*)
-(define-integrable (interp-proc-profile-buffer/extend-count/reset)
- (set! *interp-proc-profile-buffer/extend-count* 0))
-(define-integrable (interp-proc-profile-buffer/extend-count/1+)
- (set! *interp-proc-profile-buffer/extend-count*
- (1+ *interp-proc-profile-buffer/extend-count*)))
-
-(define (interp-proc-profile-buffer/extend)
- (let ((stop/restart-sampler? (and (not *pc-sample/sample-sampler?*)
- (pc-sample/started?))))
- ;; stop if need be
- (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
- (pc-sample/stop))))
- ;; count if willed to
- (cond ((interp-proc-profile-buffer/extend-count?)
- (interp-proc-profile-buffer/extend-count/1+)))
- ;; No need to disable during extend since we build an extended copy of the
- ;; buffer then install it in one swell foop...
- ;; Of course, any interp-proc samples made during the extend will be punted.
- ;; For this reason, we go ahead and disable interp-proc buffering anyway
- ;; since it would be a waste of time.
- (fixed-interp-proc-profile-buffer/disable)
- (cond ((interp-proc-profile-buffer/extend-noisy?)
- (with-output-to-port console-output-port ; in case we're in Edwin
- (lambda ()
- (display "\n;> > > > > IPPB Extend Request being serviced.")))
- (output-port/flush-output console-output-port)))
- (let* ((slack (interp-proc-profile-buffer/slack) )
- (old-buffer-length (interp-proc-profile-buffer/length))
- (new-buffer-length (+ old-buffer-length slack) )
- (new-buffer (vector-grow *interp-proc-profile-buffer*
- new-buffer-length)))
- ;; maintain invariant: unused slots of interp-proc-profile-buffer = #F
- (do ((index old-buffer-length (1+ index)))
- ((= index new-buffer-length))
- (vector-set! new-buffer index #F))
- ;; Intall new-buffer...
- (set! *interp-proc-profile-buffer* new-buffer)
- ;; synch length cache
- (interp-proc-profile-buffer/length/set! new-buffer-length))
- ;; Re-enable: synch kludge... one swell foop
- (fixed-interp-proc-profile-buffer/install *interp-proc-profile-buffer*)
- ;; restart if need be
- (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
- (pc-sample/start)))))
- unspecific)
-
-(define *interp-proc-profile-buffer/flush-count?* #F)
-(define-integrable (interp-proc-profile-buffer/flush-count?)
- *interp-proc-profile-buffer/flush-count?*)
-(define-integrable (interp-proc-profile-buffer/flush-count?/toggle!)
- (set! *interp-proc-profile-buffer/flush-count?*
- (not *interp-proc-profile-buffer/flush-count?*)))
-(define (interp-proc-profile-buffer/with-flush-count! count?
- thunk)
- (fluid-let ((*interp-proc-profile-buffer/flush-count?* count?))
- (thunk)))
-(define *interp-proc-profile-buffer/flush-count* 0)
-(define-integrable (interp-proc-profile-buffer/flush-count)
- *interp-proc-profile-buffer/flush-count*)
-(define-integrable (interp-proc-profile-buffer/flush-count/reset)
- (set! *interp-proc-profile-buffer/flush-count* 0))
-(define-integrable (interp-proc-profile-buffer/flush-count/1+)
- (set! *interp-proc-profile-buffer/flush-count*
- (1+ *interp-proc-profile-buffer/flush-count*)))
-
-(define-integrable (interp-proc-profile-buffer/flush)
- (cond ((and *interp-proc-profile-buffer* ; not disabled
- (interp-proc-profile-buffer/flush?))
- (interp-proc-profile-buffer/spill-into-interp-proc-profile-table)))
- unspecific)
-
-(define (interp-proc-profile-buffer/reset)
- ;; It is important to disable the buffer during reset so we don't have any
- ;; random ignored samples dangling in the buffer.
- (let ((next-mt-slot-index
- ;; Bletch: need to disable buffer but must sniff next-mt-slot-index
- ;; first, then must ensure nothing new is buffered.
- (without-interrupts
- (lambda ()
- (let ((nmtsi (interp-proc-profile-buffer/next-empty-slot-index)))
- ;; NB: No interrupts between LET rhs and following assignment
- (fixed-interp-proc-profile-buffer/disable)
- nmtsi)))))
- ;; It is useful to keep a global var as a handle on this object.
- (if *interp-proc-profile-buffer* ; initialized already so avoid CONS-ing
- (subvector-fill! *interp-proc-profile-buffer* 0 next-mt-slot-index #F)
- (set! *interp-proc-profile-buffer*
- (pc-sample/interp-proc-buffer/make))))
- ;; Re-enable: synch kludge... one swell foop
- (fixed-interp-proc-profile-buffer/install *interp-proc-profile-buffer*)
- (cond ((pc-sample/uninitialized?)
- (pc-sample/set-state! 'RESET)))
- 'RESET)
-
-(define (interp-proc-profile-buffer/flush?)
- (not (interp-proc-profile-buffer/empty?)))
-
-(define (interp-proc-profile-buffer/spill-into-interp-proc-profile-table)
- (let ((stop/restart-sampler? (and (not *pc-sample/sample-sampler?*)
- (pc-sample/started?))))
- ;; stop if need be
- (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
- (pc-sample/stop))))
- ;; count if willed to
- (cond ((interp-proc-profile-buffer/flush-count?)
- (interp-proc-profile-buffer/flush-count/1+)))
- ;; It is important to disable the buffer during spillage so we don't have
- ;; any random ignored samples dangling in the buffer.
- (let ((next-mt-slot-index
- ;; Bletch: need to disable buffer but must sniff next-mt-slot-index
- ;; first, then must ensure nothing new is buffered.
- (without-interrupts
- (lambda ()
- (let ((nmtsi (interp-proc-profile-buffer/next-empty-slot-index)))
- ;; NB: No interrupts between LET rhs and following assignment
- (fixed-interp-proc-profile-buffer/disable)
- nmtsi)))))
- (cond ((interp-proc-profile-buffer/flush-noisy?)
- (with-output-to-port console-output-port ; in case we're in Edwin
- (lambda ()
- (display "\n;> > > > > IPPB Flush Request being serviced.")))
- (output-port/flush-output console-output-port)))
- (do ((index 0 (1+ index)))
- ((= index next-mt-slot-index))
- ;; debuggery
- (cond ((not (vector-ref *interp-proc-profile-buffer* index))
- (warn "Damn. Found a #F entry at index = " index)))
- ;; copy from buffer into hash table
- (interp-proc-profile-table/hash-entry
- (vector-ref *interp-proc-profile-buffer* index))
- ;; A rivederci, Baby
- (vector-set! *interp-proc-profile-buffer* index #F)
- ))
- ;; Re-enable: synch kludge... one swell foop
- (fixed-interp-proc-profile-buffer/install *interp-proc-profile-buffer*)
- ;; restart if need be
- (cond (stop/restart-sampler? (fluid-let ((*pc-sample/noisy?* #F))
- (pc-sample/start)))))
- unspecific)
-
-
-
-(define-integrable (interp-proc-profile-buffer/overflow-count?)
- (%pc-sample/IPPB-monitoring?))
-(define-integrable (interp-proc-profile-buffer/overflow-count?/toggle!)
- (%pc-sample/IPPB-monitoring?/toggle!))
-
-(define (interp-proc-profile-buffer/with-overflow-count! count? thunk)
- (let ((counting? (interp-proc-profile-buffer/overflow-count?))
- (want-no-count? (not count?))) ; coerce to Boolean
- (if (eq? counting? want-no-count?) ; xor want and got
- (dynamic-wind interp-proc-profile-buffer/overflow-count?/toggle!
- thunk
- interp-proc-profile-buffer/overflow-count?/toggle!)
- (thunk))))
-
-(define-integrable (interp-proc-profile-buffer/overflow-count )
- (%pc-sample/IPPB-overflow-count ))
-(define-integrable (interp-proc-profile-buffer/overflow-count/reset)
- (%pc-sample/IPPB-overflow-count/reset))
-\f
-;;; Interp-Proc Profile (Hash) Table is where interpreted procs are profiled...
-;;; but the profile trap handler cannot CONS so if the current profiled
-;;; proc is not already hashed, we must buffer it in the Interp-Proc Profile
-;;; Buffer until the GC Daemon gets around to hashing it.
-
-(define *interp-proc-profile-table*)
-(define (interp-proc-profile-table/make) (make-profile-hash-table 4096))
-
-(define (interp-proc-profile-table)
- (interp-proc-profile-buffer/flush)
- (hash-table/entries-vector *interp-proc-profile-table*))
-
-(define *interp-proc-profile-table/old* #F)
-(define (interp-proc-profile-table/old)
- *interp-proc-profile-table/old*)
-
-(define (interp-proc-profile-table/reset #!optional disable?)
- (set! *interp-proc-profile-table/old*
- (interp-proc-profile-table))
- (hash-table/clear! *interp-proc-profile-table*)
- (set! *interp-proc-profile-buffer/status/old*
- (interp-proc-profile-buffer/status))
- (cond ((and (not (default-object? disable?)) disable?)
- (set! *interp-proc-profile-buffer* #F) ; disable buffer disables table
- (fixed-interp-proc-profile-buffer/disable)
- ;; TODO: really should detect if last to be disabled so set overall
- ;; sampling state to disabled
- (if (pc-sample/initialized?)
- 'RESET-AND-DISABLED
- 'STILL-UNINITIALIZED))
- ((not *interp-proc-profile-buffer*) ; disabled but wanna enable?
- (interp-proc-profile-buffer/reset))
- (else
- 'RESET)))
-
-(define (interp-proc-profile-table/enable)
- (interp-proc-profile-table/reset))
-
-(define (interp-proc-profile-table/disable)
- (interp-proc-profile-table/reset 'DISABLE))
-
-(define (interp-proc-profile-table/hash-entry proc-lambda)
- (cond ((hash-table/get *interp-proc-profile-table* proc-lambda false)
- =>
- (lambda (datum) ; found
- (interp-proc-profile-datum/update! datum)))
- (else ; not found
- (hash-table/put! *interp-proc-profile-table*
- proc-lambda
- (interp-proc-profile-datum/make)))))
-\f
-;;; Interp-Proc Profile Datum
-
-(define-structure (interp-proc-profile-datum
- (conc-name interp-proc-profile-datum/)
- (constructor interp-proc-profile-datum/make
- (#!optional count histogram rank utility)))
- (count (interp-proc-profile-datum/count/make))
- (histogram (interp-proc-profile-datum/histogram/make))
- (rank (interp-proc-profile-datum/rank/make))
- (utility (interp-proc-profile-datum/utility/make))
- ;... more to come (?)
- )
-
-(define (interp-proc-profile-datum/count/make) 1.0) ; FLONUM
-(define (interp-proc-profile-datum/histogram/make) '#())
-(define (interp-proc-profile-datum/rank/make) 0)
-(define (interp-proc-profile-datum/utility/make) 0.0) ; FLONUM
-;... more to come (?)
-
-(define (interp-proc-profile-datum/update! datum)
- (set-interp-proc-profile-datum/count!
- datum
- (flo:+ 1.0 (interp-proc-profile-datum/count datum))) ; FLONUM
- ;; histogram not yet implemented
- ;; rank not yet implemented
- ;; utility not yet implemented
-
- ;; NB: returns datum
- datum)
-
-;;; fini
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Primitive, Builtin and Utility support
-;;; package: (pribinut)
-
-(declare (usual-integrations))
-\f
-(define (initialize-package!)
- (install-pribinut))
-
-(define-primitives
- (get-primitive-counts 0)
- (get-primitive-name 1))
-
-
-;; Primitives-- NB: *not* memoizeable since can dynamically load new ucode!
-
-(define (get-primitive-count)
- "()\n\
- Returns the sum of the number of defined and undefined primitive procedures.\
- "
- (let ((defined-dot-undefined (get-primitive-counts)))
- (+ (car defined-dot-undefined)
- (cdr defined-dot-undefined))))
-
-
-;; GJR Hack: given that mumble-get returns #F is nonesuch, we can walk up
-;; through the indices until we find the first failure. Moreover,
-;; Since there is no mechanism for dynacmically loading new builtins
-;; or utilities, this result can be memoized.
-
-(define (count-mumbles mumble-getter)
- (do ((i 0 (1+ i)))
- ((not (mumble-getter i)) ; first index to fail to be gotten is it
- i)))
-
-
-;; Builtins
-
-(define (get-builtin-name index)
- ((ucode-primitive builtin-index->name 1) index))
-
-(define *builtin-count-promise*) ; tba
-(define (get-builtin-count)
- "()\n\
- Returns the number of ``builtin'' hooks defined in the running Scheme system.\
- "
- (force *builtin-count-promise*))
-
-(define (install-builtin-count-promise)
- (set! *builtin-count-promise*
- (delay (count-mumbles get-builtin-name)))
- unspecific)
-
-
-;; Utilities
-
-(define (get-utility-name index)
- ((ucode-primitive utility-index->name 1) index))
-
-(define *utility-count-promise*) ; tba
-(define (get-utility-count)
- "()\n\
- Returns the number of ``utility'' hooks defined in the running Scheme system.\
- "
- (force *utility-count-promise*))
-
-(define (install-utility-count-promise)
- (set! *utility-count-promise*
- (delay (count-mumbles get-utility-name)))
- unspecific)
-
-
-;; Install
-
-(define (install-pribinut)
- (install-builtin-count-promise)
- (install-utility-count-promise)
- ;; re-cache counts in code new frobs have been added to the microcode
- (add-event-receiver! event:after-restore install-pribinut))
-
-
-;;; fini
+++ /dev/null
-(declare (usual-integrations))
-
-(define-structure
- (pc-sample-zone
- (conc-name pc-sample-zone/)
- (constructor %make-pc-sample-zone (name index))
- (print-procedure
- (standard-unparser-method 'PC-SAMPLE-ZONE
- (lambda (zone port)
- (write-char #\space port)
- (write (pc-sample-zone/name zone) port)
- (write-char #\space port)
- (write (pc-sample-zone/count zone) port)))))
-
- name ; user name
- index ; index if user zone
- (with-count 0))
-
-;; List of either (1) weak `zone . index' pairs, (2) available +ve
-;; indexes or (3) unavailable -ve indexes (i.e. during allocation).
-;; Zero is not a valid index and is reserved for the zone `Other'.
-(define zones)
-
-(define zone:other)
-(define counts-cache)
-
-(define (pc-sample-zone/count zone)
- (let ((index (pc-sample-zone/index zone)))
- (if (and (<= 0 index) (< index (flo:vector-length counts-cache)))
- (flo:vector-ref counts-cache index)
- 'COUNT-UNKNOWN)))
-
-(define (make-pc-sample-zone name)
- (define (allocate!)
- (let loop ((pair zones))
- (and (pair? pair)
- (let ((mark (car pair)))
- (cond ((and (fixnum? mark) (> mark 0))
- (set-car! pair (- mark))
- pair)
- ((and (weak-pair? mark) (not (system-pair-car mark)))
- (set-car! pair (- (system-pair-cdr mark)))
- pair)
- (else ;assume -ve fixnum
- (loop (cdr pair))))))))
-
- (let ((pair (without-interrupts allocate!)))
- (if pair
- (let* ((index (- (car pair)))
- (zone (%make-pc-sample-zone name index)))
- (set-car! pair (weak-cons zone index))
- zone)
- (error "Out of free zone indexes"))))
-
-(define (get-zones)
- (let loop ((list zones))
- (cond ((null? list) '())
- ((and (weak-pair? (car list)) (system-pair-car (car list)))
- => (lambda (zone) (cons zone (loop (cdr list)))))
- (else (loop (cdr list))))))
-
-(define (wrap-with-zone procedure zone)
- (define-integrable set-zone! (ucode-primitive %pc-sample/set-zone! 1))
- (if (fixnum? (pc-sample-zone/index zone))
- (let ()
- ;; The following wrappers need to be closed over the zone to stop it
- ;; begin GC-ed.
- (define (default-wrapper . arguments)
- (cond ((set-zone! (pc-sample-zone/index zone))
- => (lambda (previous-zone)
- (let ((result (apply procedure arguments)))
- (set-zone! previous-zone)
- result)))
- (else
- (apply procedure arguments))))
-
- (define (wrapper/1-arg arg-1)
- (cond ((set-zone! (pc-sample-zone/index zone))
- => (lambda (previous-zone)
- (let ((result (procedure arg-1)))
- (set-zone! previous-zone)
- result)))
- (else
- (procedure arg-1))))
-
- (define (wrapper/2-args arg-1 arg-2)
- (cond ((set-zone! (pc-sample-zone/index zone))
- => (lambda (previous-zone)
- (let ((result (procedure arg-1 arg-2)))
- (set-zone! previous-zone)
- result)))
- (else
- (procedure arg-1 arg-2))))
-
- (define (wrapper/3-args arg-1 arg-2 arg-3)
- (cond ((set-zone! (pc-sample-zone/index zone))
- => (lambda (previous-zone)
- (let ((result (procedure arg-1 arg-2 arg-3)))
- (set-zone! previous-zone)
- result)))
- (else
- (procedure arg-1 arg-2 arg-3))))
-
- (let ((arity (procedure-arity procedure)))
- (cond ((equal? arity '(1 . 1)) wrapper/1-arg)
- ((equal? arity '(2 . 2)) wrapper/2-args)
- ((equal? arity '(3 . 3)) wrapper/3-args)
- (else default-wrapper))))
- (error "Cant wrap with" zone)))
-
-
-(define (read-zone-counts!)
- ((ucode-primitive %pc-sample/read-zones! 1) counts-cache))
-
-(define (reset-zone-counts!)
- ((ucode-primitive %pc-sample/clear-zones! 0)))
-
-(define (display-zone-report)
- (read-zone-counts!)
- (let ((zones (get-zones)))
- (let ((total (apply + (map pc-sample-zone/count zones))))
- (let ((pct (if (zero? total)
- (lambda (zone) zone 0)
- (lambda (zone)
- (* 100. (/ (pc-sample-zone/count zone) total))))))
- (pp (sort (map (lambda (zone)
- (list (pct zone) zone))
- zones)
- (lambda (x y) (> (car x) (car y)))))))))
-
-(define (initialize-package!)
- (let* ((max-zone ((ucode-primitive %pc-sample/max-zone 0))))
- (set! zone:other (%make-pc-sample-zone 'other 0))
- (set! zones
- (cons (weak-cons zone:other #f)
- (cdr (make-initialized-list max-zone identity-procedure))))
- (set! counts-cache (flo:vector-cons max-zone))
- (reset-zone-counts!)
- (read-zone-counts!)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-(load-option 'CREF)
-
-(with-working-directory-pathname (directory-pathname (current-load-pathname))
- (lambda ()
- (for-each compile-file '("object" "format" "nparse" "logmer"))
- (cref/generate-constructors "rcs")))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RCS Format
-
-(declare (usual-integrations))
-\f
-(define (rcs/format rcstext)
- (let ((head (rcstext/head rcstext)))
- (write-string "head: ")
- (write-string (delta/number head))
- (write-string "\nlocks: ")
- (if (null? (rcstext/locks rcstext))
- (write-string " ")
- (for-each format/lock (rcstext/locks rcstext)))
- (write-string ";")
- (if (rcstext/strict? rcstext)
- (write-string " strict"))
- (write-string "\naccess list: ")
- (for-each format/user (rcstext/access rcstext))
- (write-string "\nsymbolic names:")
- (for-each format/symbol (rcstext/symbols rcstext))
- (write-string "\ncomment leader: \"")
- (write-string (rcstext/comment rcstext))
- (write-string "\"")
- (write-string "\ndescription:\n")
- (format/delta-trunk head)
- (format/delta-tree head)
- (write-string "=============================================================================\n")))
-
-(define (format/lock lock)
- (write-string " ")
- (write-string (car lock))
- (write-string ": ")
- (write-string (delta/number (cdr lock))))
-
-(define (format/user user)
- (write-string " ")
- (write-string user))
-
-(define (format/symbol symbol)
- (write-string " ")
- (write-string (car symbol))
- (write-string ": ")
- (write-string (delta/number (cdr symbol))))
-
-(define (format/delta-trunk head)
- (let loop ((delta head))
- (if delta
- (begin
- (format/delta delta)
- (loop (delta/next delta))))))
-
-(define (format/delta-tree head)
- (if head
- (begin
- (format/delta-tree (delta/next head))
- (format/delta-forest (delta/branches head)))))
-
-(define (format/delta-forest branches)
- (if (not (null? branches))
- (begin
- (format/delta-forest (cdr branches))
- (format/delta-branch (car branches))
- (format/delta-tree (car branches)))))
-
-(define (format/delta-branch branch)
- (if branch
- (begin
- (format/delta-branch (delta/next branch))
- (format/delta branch))))
-
-(define (format/delta delta)
- (write-string "----------------------------\nrevision ")
- (write-string (delta/number delta))
- (write-string "\ndate: ")
- (format/date (delta/date delta))
- (write-string "; author: ")
- (write-string (delta/author delta))
- (write-string "; state: ")
- (write-string (delta/state delta))
- (newline)
- (write-string (delta/log delta)))
-
-(define (format/date date)
- (write-string (date->string date)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-(load-option 'REGULAR-EXPRESSION)
-(with-loader-base-uri (system-library-uri "rcs/")
- (lambda ()
- (load-package-set "rcs")))
-(add-subsystem-identification! "RCS" '(2 2))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RCS Log Merge
-
-(declare (usual-integrations))
-\f
-(define (rcs-directory-log directory #!optional options)
- (let ((options (if (default-object? options) '() options))
- (port (notification-output-port)))
- (let ((changelog? (find-option options 'CHANGELOG? #f)))
- (let ((output-file
- (merge-pathnames (or (find-option options 'OUTPUT-FILE #f)
- (if changelog? "ChangeLog" "RCS.log"))
- (pathname-as-directory directory))))
- (fresh-line port)
- (write-string "regenerating log for directory: " port)
- (write (->namestring directory))
- (write-string "..." port)
- (let ((pathnames (rcs-directory-read directory)))
- (if (let ((time (file-modification-time-indirect output-file)))
- (or (not time)
- (there-exists? pathnames
- (lambda (w.r)
- (> (file-modification-time-indirect (cdr w.r))
- time)))))
- (begin
- (newline port)
- (write-string "total files: " port)
- (write (length pathnames) port)
- (newline port)
- (let ((entries (read-entries pathnames port)))
- (write-string "total entries: " port)
- (write (length entries) port)
- (newline port)
- (let ((entries
- (if changelog?
- (sort-entries-for-changelog entries)
- (sort-entries-for-rcs.log entries))))
- (write-string "sorting finished" port)
- (newline port)
- (call-with-output-file output-file
- (lambda (port)
- (if changelog?
- (format-changelog entries options port)
- (format-rcs.log entries options port)))))))
- (begin
- (write-string " log is up to date" port)
- (newline port))))))))
-
-(define (find-option options key default)
- (let loop ((options options))
- (if (pair? options)
- (if (eq? key (caar options))
- (cadar options)
- (loop (cdr options)))
- default)))
-\f
-;;;; RCS.log format
-
-(define (format-rcs.log entries options port)
- options
- (let ((groups (group-entries-by-log entries))
- (format-group
- (lambda (group)
- (for-each (lambda (entry)
- (let ((delta (car entry))
- (filename (cdr entry)))
- (write-string "file: " port)
- (write-string filename port)
- (write-string "; revision: " port)
- (write-string (delta/number delta) port)
- (write-string "\ndate: " port)
- (write-string (date->string (delta/date delta)) port)
- (write-string "; author: " port)
- (write-string (delta/author delta) port)
- (newline port)))
- group)
- (newline port)
- (write-string (delta/log (car (car group))) port)
- (newline port))))
- (if (pair? groups)
- (begin
- (format-group (car groups))
- (for-each (lambda (group)
- (write-string "----------------------------" port)
- (newline port)
- (format-group group))
- (cdr groups))))))
-
-(define (sort-entries-for-rcs.log entries)
- (sort entries
- (lambda (x y)
- (date<? (delta/date (car y)) (delta/date (car x))))))
-\f
-;;;; ChangeLog format
-
-(define (format-changelog entries options port)
- (let ((groups
- (group-entries-by-author&day
- (list-transform-negative entries
- (lambda (entry)
- (string-prefix? "#" (delta/log (car entry))))))))
- (if (pair? groups)
- (let ((changelog-map
- (or (find-option options 'CHANGELOG-MAP #f)
- (list (os/hostname)))))
- (format-changelog-group (car groups) changelog-map options port)
- (for-each (lambda (group)
- (newline port)
- (format-changelog-group group changelog-map options
- port))
- (cdr groups))))))
-
-(define (format-changelog-group entries changelog-map options port)
- (write-string (format-date-for-changelog (delta/date (caar entries))) port)
- (write-string " " port)
- (let ((author (delta/author (caar entries))))
- (let ((mentry (assoc author (cdr changelog-map))))
- (write-string (if mentry (cadr mentry) author) port)
- (write-string " <" port)
- (if (and mentry (pair? (cddr mentry)))
- (write-string (caddr mentry) port)
- (begin
- (write-string author port)
- (write-string "@" port)
- (write-string (car changelog-map) port)))
- (write-string ">" port)))
- (newline port)
- (for-each
- (lambda (entries)
- (newline port)
- (write-char #\tab port)
- (write-string "* " port)
- (let ((filenames
- (if (find-option options 'SHOW-VERSIONS #t)
- (map (lambda (entry)
- (string-append (cdr entry)
- "[" (delta/number (car entry)) "]"))
- (sort-group-by-name&date entries))
- (remove-duplicate-strings (sort (map cdr entries) string<?)))))
- (write-string (car filenames) port)
- (let loop
- ((filenames (cdr filenames))
- (column (fix:+ 11 (string-length (car filenames)))))
- (if (pair? filenames)
- (let ((filename (car filenames)))
- (let ((column* (+ column 2 (string-length filename))))
- (if (fix:>= column* 80)
- (begin
- (write-string "," port)
- (newline port)
- (write-char #\tab port)
- (write-string " " port)
- (write-string filename port)
- (loop (cdr filenames)
- (fix:+ 11 (string-length filename))))
- (begin
- (write-string ", " port)
- (write-string filename port)
- (loop (cdr filenames) column*))))))))
- (write-string ":" port)
- (newline port)
- (format-log-for-changelog (delta/log (caar entries)) port))
- (sort-groups-by-date (group-entries-by-log entries))))
-\f
-(define (sort-entries-for-changelog entries)
- (sort entries
- (lambda (x y)
- (or (day>? (delta/date (car x)) (delta/date (car y)))
- (and (day=? (delta/date (car x)) (delta/date (car y)))
- (or (string<? (delta/author (car x))
- (delta/author (car y)))
- (and (string=? (delta/author (car x))
- (delta/author (car y)))
- (string<? (delta/log (car x))
- (delta/log (car y))))))))))
-
-(define (sort-group-by-name&date entries)
- (sort entries
- (lambda (x y)
- (or (string<? (cdr x) (cdr y))
- (and (string=? (cdr x) (cdr y))
- (date>? (delta/date (car x)) (delta/date (car y))))))))
-
-(define (format-date-for-changelog date)
- (let ((dt (date/decoded date)))
- (string-append
- (number->string (decoded-time/year dt))
- "-"
- (string-pad-left (number->string (decoded-time/month dt)) 2 #\0)
- "-"
- (string-pad-left (number->string (decoded-time/day dt)) 2 #\0))))
-
-(define (format-log-for-changelog log port)
- (write-char #\tab port)
- (let ((end (string-length log)))
- (let loop ((start 0))
- (let ((index (substring-find-next-char log start end #\newline)))
- (if index
- (let ((index (fix:+ index 1)))
- (write-substring log start index port)
- (if (fix:< index end)
- (begin
- (write-char #\tab port)
- (loop index))))
- (begin
- (write-substring log start end port)
- (newline port)))))))
-\f
-(define (remove-duplicate-strings strings)
- ;; Assumes that STRINGS is sorted.
- (let loop ((strings strings) (result '()))
- (if (pair? strings)
- (loop (cdr strings)
- (if (and (pair? (cdr strings))
- (string=? (car strings) (cadr strings)))
- result
- (cons (car strings) result)))
- (reverse! result))))
-
-(define (sort-groups-by-date groups)
- (sort-groups groups
- (lambda (entries)
- (let loop
- ((entries (cdr entries))
- (winner (caar entries)))
- (if (pair? entries)
- (loop (cdr entries)
- (if (date<? (delta/date (caar entries))
- (delta/date winner))
- (caar entries)
- winner))
- winner)))
- (lambda (x y)
- (date>? (delta/date x) (delta/date y)))))
-
-(define (sort-groups groups choose-representative predicate)
- (map cdr
- (sort (map (lambda (group)
- (cons (choose-representative group) group))
- groups)
- (lambda (x y)
- (predicate (car x) (car y))))))
-
-(define (group-entries-by-author&day entries)
- (group-entries entries
- (lambda (x y)
- (and (string=? (delta/author (car x)) (delta/author (car y)))
- (day=? (delta/date (car x)) (delta/date (car y)))))))
-
-(define (group-entries-by-log entries)
- (group-entries entries
- (lambda (x y)
- (string=? (delta/log (car x)) (delta/log (car y))))))
-
-(define (group-entries entries predicate)
- (let outer ((entries entries) (groups '()))
- (if (pair? entries)
- (let ((entry (car entries)))
- (let inner ((entries (cdr entries)) (group (list entry)))
- (if (and (pair? entries)
- (predicate entry (car entries)))
- (inner (cdr entries) (cons (car entries) group))
- (outer entries (cons (reverse! group) groups)))))
- (reverse! groups))))
-\f
-(define (read-entries pairs notification-port)
- (let ((prefix (greatest-common-prefix (map car pairs))))
- (append-map!
- (lambda (w.r)
- (map (let ((filename (->namestring (enough-pathname (car w.r) prefix))))
- (lambda (delta)
- (cons delta filename)))
- (read-file (cdr w.r) notification-port)))
- pairs)))
-
-(define (read-file pathname notification-port)
- (if notification-port
- (begin
- (write-string "read-file " notification-port)
- (write-string (->namestring pathname) notification-port)
- (newline notification-port)))
- (let ((deltas (rcstext->deltas (rcs/read-file pathname 'LOG-ONLY))))
- (for-each (lambda (delta)
- (set-delta/log! delta
- (let ((log (string-trim (delta/log delta))))
- (if (string-null? log)
- empty-log-message
- log))))
- deltas)
- (list-transform-negative deltas delta/trivial-log?)))
-
-(define (delta/trivial-log? delta)
- (string=? (delta/log delta) "Initial revision"))
-
-(define empty-log-message "*** empty log message ***")
-
-(define (rcstext->deltas rcstext)
- (let ((head (rcstext/head rcstext)))
- (if (not head)
- '()
- (let loop ((input (list head)) (output '()))
- (if (null? input)
- output
- (let ((input* (append (delta/branches (car input)) (cdr input))))
- (loop (if (delta/next (car input))
- (cons (delta/next (car input)) input*)
- input*)
- (cons (car input) output))))))))
-\f
-(define (rcs-directory-read pathname)
- (let ((files '()))
- (define (scan-directory cvs-mode? directory original-directory)
- (let ((directory (pathname-as-directory directory))
- (original-directory (pathname-as-directory original-directory)))
- (for-each (lambda (pathname)
- (scan-file cvs-mode?
- pathname
- (merge-pathnames (file-pathname pathname)
- original-directory)))
- (directory-read directory #f))))
-
- (define (scan-file cvs-mode? pathname original-pathname)
- (let ((attributes (file-attributes-direct pathname)))
- (if (not attributes)
- (warn "Cannot get attributes. Path might contain stale symlink."
- (error-irritant/noise "\n; ")
- original-pathname
- (error-irritant/noise "\n; points to\n; ")
- pathname)
- (let ((type (file-attributes/type attributes)))
- (cond ((not type)
- (if (not (or (ignored-file-name? cvs-mode? pathname)
- (ignored-file-name? cvs-mode?
- original-pathname)))
- (let ((file (rcs-files cvs-mode? pathname)))
- (if file
- (set! files (cons file files))))))
- ((eq? type #t)
- (if (not (member (file-namestring pathname)
- '("." ".." "CVS" "RCS")))
- (scan-directory cvs-mode?
- pathname original-pathname)))
- ((string? type)
- (scan-file cvs-mode?
- (merge-pathnames type
- (directory-pathname pathname))
- original-pathname)))))))
-
- (define (rcs-files cvs-mode? pathname)
- (let ((directory (directory-pathname pathname))
- (name (file-namestring pathname)))
- (if cvs-mode?
- (and (string-suffix? ",v" name)
- (cons (merge-pathnames
- (string-head name (- (string-length name) 2))
- directory)
- pathname))
- (let* ((name (string-append name ",v"))
- (p
- (merge-pathnames name (merge-pathnames "RCS/" directory))))
- (if (regular-file? p)
- (cons pathname p)
- (let ((p (merge-pathnames name directory)))
- (and (regular-file? p)
- (cons pathname p))))))))
-
- (define (regular-file? pathname)
- (let ((attributes (file-attributes pathname)))
- (and attributes
- (not (file-attributes/type attributes)))))
-
- (define (ignored-file-name? cvs-mode? pathname)
- (let ((name (file-namestring pathname)))
- (or (string-suffix? "~" name)
- (string-prefix? "#" name)
- (and (not cvs-mode?) (string-suffix? ",v" name)))))
-
- (let ((directory (pathname-as-directory pathname)))
- (let ((cvs (merge-pathnames "CVS/" directory)))
- (if (file-directory? cvs)
- (let ((pathname
- (merge-pathnames
- (read-one-line-file (merge-pathnames "Repository" cvs))
- (pathname-as-directory
- (strip-cvs-remote-prefix
- (read-one-line-file (merge-pathnames "Root" cvs)))))))
- (scan-directory #t pathname pathname))
- (scan-directory #f pathname pathname))))
- files))
-\f
-(define (strip-cvs-remote-prefix string)
- (let ((regs
- (re-string-match ":\\(\\(ext\\|.?server\\):[^:]+\\|local\\):"
- string #t)))
- (if regs
- (string-tail string (re-match-end-index 0 regs))
- string)))
-
-(define (read-one-line-file pathname)
- (call-with-input-file pathname read-line))
-
-(define (greatest-common-prefix pathnames)
- (if (null? pathnames)
- (->pathname "")
- (let ((prefix 'NONE))
- (for-each (lambda (pathname)
- (let ((directory (pathname-directory pathname)))
- (set! prefix
- (if (eq? prefix 'NONE)
- directory
- (let common-prefix ((x prefix) (y directory))
- (if (and (pair? x)
- (pair? y)
- (equal? (car x) (car y)))
- (cons (car x)
- (common-prefix (cdr x) (cdr y)))
- '()))))))
- pathnames)
- (pathname-new-directory "" prefix))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Update the RCS log files in the standard Scheme directories.
-
-(let ((changelog-map
- '("zurich.ai.mit.edu"
- ("adams" "Stephen Adams")
- ("arthur" "Arthur Gleckler")
- ("bal" "Brian A. LaMacchia")
- ("boogles" "Brian K. Zuzga")
- ("cph" "Chris Hanson")
- ("gjr" "Guillermo J. Rozas")
- ("gjs" "Gerald Jay Sussman")
- ("hal" "Hal Abelson")
- ("jacob" "Jacob Katzenelson")
- ("jawilson" "Jason Wilson")
- ("jbank" "Joe Bank")
- ("jinx" "Guillermo J. Rozas" "gjr@zurich.ai.mit.edu")
- ("jmiller" "Jim Miller")
- ("jrm" "Joe Marshall")
- ("markf" "Mark Friedman")
- ("mhwu" "Henry M. Wu")
- ("nick" "Nick Papadakis")
- ("pas" "Panayotis Skordos")
- ("thanos" "Thanos Siapas")
- ("ziggy" "Michael R. Blair"))))
- (for-each (lambda (directory)
- (rcs-directory-log directory
- `((CHANGELOG? #t)
- (CHANGELOG-MAP ,changelog-map))))
- '("/scheme/v7/src"
- "/scheme/v7/doc"
- "/scheme/etc")))
-(for-each (lambda (directory)
- (rcs-directory-log directory '()))
- '("/scheme/v8/src/bench"
- "/scheme/v8/src/compiler"
- "/scheme/v8/src/microcode"
- "/scheme/v8/src/runtime"
- "/scheme/v8/src/sf"))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RCS Parser
-
-(declare (usual-integrations))
-\f
-(define (rcs/read-file filename #!optional text?)
- (call-with-input-file filename
- (lambda (port)
- (parse-rcstext port (if (default-object? text?) true text?)))))
-
-(define (rcs/read-head filename)
- (call-with-input-file filename
- (lambda (port)
- (parse-head (make-line-port port)))))
-
-(define (parse-rcstext port text?)
- (let ((line-port (make-line-port port)))
- (let* ((admin (parse-admin line-port))
- (deltas (parse-deltas line-port))
- (description (parse-desc line-port))
- (deltatexts
- (if text? (parse-deltatexts line-port (eq? true text?)) '()))
- (num->delta (make-delta-map deltas deltatexts text?)))
- (make-rcstext (and (vector-ref admin 0)
- (num->delta (vector-ref admin 0) #t))
- (and (vector-ref admin 1)
- (num->delta (vector-ref admin 1) #t))
- (vector-ref admin 2)
- (map (lambda (element)
- (cons (car element)
- (num->delta (cdr element) #f)))
- (vector-ref admin 3))
- (map (lambda (element)
- (cons (car element)
- (num->delta (cdr element) #t)))
- (vector-ref admin 4))
- (vector-ref admin 5)
- (vector-ref admin 6)
- (vector-ref admin 7)
- description))))
-
-(define (make-delta-map deltas deltatexts text?)
- (let ((table (make-string-hash-table)))
- (for-each (lambda (delta)
- (let ((key (vector-ref delta 0)))
- (let ((entry (hash-table/get table key false)))
- (if entry
- (error "duplicate delta entry" delta entry)))
- (hash-table/put! table key
- (make-delta key
- (vector-ref delta 1)
- (vector-ref delta 2)
- (vector-ref delta 3)
- (vector-ref delta 4)
- (vector-ref delta 5)
- false
- false))))
- deltas)
- (for-each (lambda (deltatext)
- (let ((key (vector-ref deltatext 0)))
- (let ((delta (hash-table/get table key false)))
- (if (not delta)
- (error "missing delta entry" deltatext))
- (set-delta/log! delta (vector-ref deltatext 1))
- (set-delta/text! delta (vector-ref deltatext 2)))))
- deltatexts)
- (let ((num->delta
- (lambda (key error?)
- (let ((delta (hash-table/get table key false)))
- (if (and (not delta) error?)
- (error "unknown delta number" key))
- delta))))
- (hash-table/for-each table
- (lambda (key delta)
- key
- (if (and text? (not (delta/log delta)))
- (error "missing deltatext entry" delta))
- (let loop ((branches (delta/branches delta)))
- (if (pair? branches)
- (begin
- (set-car! branches (num->delta (car branches) #t))
- (loop (cdr branches)))))
- (let ((next (delta/next delta)))
- (if next
- (set-delta/next! delta (num->delta next #t))))))
- num->delta)))
-\f
-(define (parse-admin line-port)
- (let* ((head (parse-head line-port))
- (branch (parse-optional line-port "branch" '(num)))
- (access-list (parse-required line-port "access" '(* id)))
- (symbols (parse-required line-port "symbols" '(* id colon num)))
- (locks (parse-required line-port "locks" '(* id colon num)))
- (strict (parse-optional line-port "strict" '()))
- (comment (parse-optional line-port "comment" '(? string)))
- (expand (parse-optional line-port "expand" '(? string))))
- (discard-newphrases line-port)
- (vector head
- (and branch
- (not (null? (cdr branch)))
- (rcs-num-string (cadr branch)))
- (map rcs-id-string (cdr access-list))
- (rcs-id-alist (cdr symbols))
- (rcs-id-alist (cdr locks))
- (and strict true)
- (and comment
- (not (null? (cdr comment)))
- (rcs-string-contents (cadr comment)))
- (and expand
- (not (null? (cdr expand)))
- (rcs-string-contents (cadr expand))))))
-
-(define (parse-head line-port)
- (let ((head (parse-required line-port "head" '(num))))
- (and (not (null? (cdr head)))
- (rcs-num-string (cadr head)))))
-
-(define (rcs-id-alist symbols)
- (if (null? symbols)
- '()
- (cons (cons (rcs-id-string (car symbols))
- (rcs-num-string (caddr symbols)))
- (rcs-id-alist (cdddr symbols)))))
-\f
-(define (parse-deltas line-port)
- (let ((delta (parse-delta line-port)))
- (if delta
- (cons delta (parse-deltas line-port))
- '())))
-
-(define (parse-delta line-port)
- (let ((number (parse-optional line-port 'num '())))
- (and number
- (let* ((date (parse-required line-port "date" '(num)))
- (author (parse-required line-port "author" '(id)))
- (state (parse-required line-port "state" '(? id)))
- (branches (parse-required line-port "branches" '(* num)))
- (next (parse-required line-port "next" '(? num))))
- (discard-newphrases line-port)
- (vector (rcs-num-string (car number))
- (rcs-date (cadr date))
- (rcs-id-string (cadr author))
- (and (not (null? (cdr state)))
- (rcs-id-string (cadr state)))
- (map rcs-num-string (cdr branches))
- (and (not (null? (cdr next)))
- (rcs-num-string (cadr next))))))))
-
-(define-integrable (rcs-date num)
- (apply date/make (number->integer-list (rcs-num-string num))))
-
-(define (number->integer-list string)
- (let ((end (string-length string)))
- (let loop ((start 0) (index 0))
- (cond ((= index end)
- (if (= start end)
- (error "Trailing decimal in number"))
- (list (string->number (substring string start end))))
- ((char=? #\. (string-ref string index))
- (cons (string->number (substring string start index))
- (let ((start (1+ index)))
- (loop start start))))
- (else
- (loop start (1+ index)))))))
-
-(define (parse-desc line-port)
- (rcs-string-contents (cadr (parse-required line-port "desc" '(string)))))
-
-(define (parse-deltatexts line-port text?)
- (let loop ()
- (let ((deltatext (parse-deltatext line-port text?)))
- (if deltatext
- (cons deltatext (loop))
- '()))))
-
-(define (parse-deltatext line-port text?)
- (let ((number (parse-optional line-port 'num '())))
- (and number
- (let ((log (parse-required line-port "log" '(string))))
- (let loop ()
- (let ((text (parse-optional line-port "text" '(string))))
- (if text
- (vector (rcs-num-string (car number))
- (rcs-string-contents (cadr log))
- (and text? (rcs-string-contents (cadr text))))
- (begin
- (parse-required line-port 'id '(* word))
- (loop)))))))))
-\f
-(define (parse-required line-port head tail)
- (let ((line (line-read line-port)))
- (if (not (and (rcs-match head (car line))
- (rcs-match tail (cdr line))))
- (error "ill-formed RCS file" head tail line))
- line))
-
-(define (parse-optional line-port head tail)
- (let ((line (line-peek line-port)))
- (and line
- (rcs-match head (car line))
- (begin
- (line-discard line-port)
- (if (not (rcs-match tail (cdr line)))
- (error "ill-formed RCS file" head tail line))
- line))))
-
-(define (discard-newphrases line-port)
- (let ((line (line-peek line-port)))
- (if (and line
- (rcs-match 'id (car line))
- (not (string=? "desc" (rcs-id-string (car line))))
- (rcs-match '(* word) (cdr line)))
- (begin
- (line-discard line-port)
- (discard-newphrases line-port)))))
-
-(define (rcs-match pattern instance)
- (cond ((string? pattern)
- (and (rcs-id? instance)
- (string=? pattern (rcs-id-string instance))))
- ((symbol? pattern)
- (case pattern
- ((id) (rcs-id? instance))
- ((string) (rcs-string? instance))
- ((num) (rcs-num? instance))
- ((colon) (rcs-colon? instance))
- ((semicolon) (rcs-semicolon? instance))
- ((word) (rcs-word? instance))
- (else (error "ill-formed pattern" pattern))))
- ((list? pattern)
- (if (null? pattern)
- (null? instance)
- (case (car pattern)
- ((?)
- (or (null? instance)
- (rcs-match-list (cdr pattern) instance null?)))
- ((*)
- (let loop ((instance instance))
- (or (null? instance)
- (rcs-match-list (cdr pattern) instance loop))))
- ((+)
- (letrec ((loop
- (lambda (instance)
- (or (null? instance)
- (rcs-match-list (cdr pattern)
- instance
- loop)))))
- (rcs-match-list (cdr pattern) instance loop)))
- (else
- (rcs-match-list pattern instance null?)))))
- (else
- (error "ill-formed pattern" pattern))))
-
-(define (rcs-match-list pattern instance if-match)
- (let loop ((pattern pattern) (instance instance))
- (if (null? pattern)
- (if-match instance)
- (and (pair? instance)
- (rcs-match (car pattern) (car instance))
- (loop (cdr pattern) (cdr instance))))))
-\f
-(define (make-line-port port)
- (cons 'EMPTY port))
-
-(define (line-peek line-port)
- (if (eq? 'EMPTY (car line-port))
- (set-car! line-port (parse-line (cdr line-port))))
- (car line-port))
-
-(define (line-discard line-port)
- (if (car line-port)
- (set-car! line-port 'EMPTY)))
-
-(define (line-read line-port)
- (let ((line (line-peek line-port)))
- (line-discard line-port)
- line))
-
-(define (parse-line port)
- (let ((word (parse-word port)))
- (cond ((null? word)
- false)
- ((rcs-id? word)
- (let ((string (rcs-id-string word)))
- (if (or (string=? "desc" string)
- (string=? "log" string)
- (string=? "text" string))
- (let ((string (parse-word port)))
- (if (not (rcs-string? string))
- (error "illegal word sequence" word string))
- (list word string))
- (cons word
- (let loop ()
- (let ((word (parse-word port)))
- (if (rcs-semicolon? word)
- '()
- (cons word (loop)))))))))
- ((rcs-num? word)
- (list word))
- (else
- (error "illegal line-starting word" word)))))
-\f
-(define (parse-word port)
- (skip-whitespace port)
- (let ((char (input-port/peek-char port)))
- (if (eof-object? char)
- '()
- ((vector-ref parse-word/dispatch-table (char->ascii char)) port))))
-
-(define skip-whitespace
- (let ((delimiters
- (char-set-invert
- (char-set-union (ascii-range->char-set #o010 #o016)
- (ascii-range->char-set #o040 #o041)))))
- (lambda (port)
- (input-port/discard-chars port delimiters))))
-
-(define parse-string
- (let ((delimiters (char-set #\@)))
- (lambda (port)
- (input-port/discard-char port)
- (let ((strings
- (let loop ()
- (let ((head (input-port/read-string port delimiters)))
- (let ((char (input-port/peek-char port)))
- (if (eof-object? char)
- (error "end of file while reading string"))
- (input-port/discard-char port)
- (let ((char* (input-port/peek-char port)))
- (if (eq? char char*)
- (begin
- (input-port/discard-char port)
- (cons head (cons "@" (loop))))
- (list head))))))))
- (make-rcs-string
- (if (null? (cdr strings))
- (car strings)
- (apply string-append strings)))))))
-
-(define parse-id
- (let ((delimiters
- (char-set-invert
- (char-set-difference
- (char-set-union (ascii-range->char-set #o041 #o177)
- (ascii-range->char-set #o240 #o400))
- (char-set #\$ #\, #\. #\: #\; #\@)))))
- (lambda (port)
- (make-rcs-id (input-port/read-string port delimiters)))))
-
-(define parse-num
- (let ((delimiters
- (char-set-invert (char-set-union char-set:numeric (char-set #\.)))))
- (lambda (port)
- (make-rcs-num (input-port/read-string port delimiters)))))
-
-(define (parse-colon port)
- (input-port/discard-char port)
- (make-rcs-colon))
-
-(define (parse-semicolon port)
- (input-port/discard-char port)
- (make-rcs-semicolon))
-
-(define parse-word/dispatch-table)
-
-(define (initialize-dispatch-table!)
- (set! parse-word/dispatch-table
- (make-vector 256
- (lambda (port)
- (error "illegal word-starting character" port))))
- (subvector-fill! parse-word/dispatch-table #o101 #o133 parse-id)
- (subvector-fill! parse-word/dispatch-table #o141 #o173 parse-id)
- (subvector-fill! parse-word/dispatch-table #o300 #o327 parse-id)
- (subvector-fill! parse-word/dispatch-table #o330 #o366 parse-id)
- (subvector-fill! parse-word/dispatch-table #o370 #o400 parse-id)
- (subvector-fill! parse-word/dispatch-table #o060 #o072 parse-num)
- (vector-set! parse-word/dispatch-table (char->ascii #\@) parse-string)
- (vector-set! parse-word/dispatch-table (char->ascii #\:) parse-colon)
- (vector-set! parse-word/dispatch-table (char->ascii #\;) parse-semicolon))
-
-(initialize-dispatch-table!)
-\f
-(define (rcs-word? object)
- (and (pair? object)
- (memq (car object) '(IDENTIFIER STRING NUMBER COLON SEMICOLON))))
-
-(define-integrable (make-rcs-id string)
- (cons 'IDENTIFIER string))
-
-(define (rcs-id? word)
- (and (pair? word)
- (eq? 'IDENTIFIER (car word))))
-
-(define-integrable (rcs-id-string rcs-id)
- (cdr rcs-id))
-
-(define-integrable (make-rcs-string contents)
- (cons 'STRING contents))
-
-(define (rcs-string? word)
- (and (pair? word)
- (eq? 'STRING (car word))))
-
-(define-integrable (rcs-string-contents rcs-string)
- (cdr rcs-string))
-
-(define-integrable (make-rcs-num string)
- (cons 'NUMBER string))
-
-(define (rcs-num? word)
- (and (pair? word)
- (eq? 'NUMBER (car word))))
-
-(define-integrable (rcs-num-string rcs-num)
- (cdr rcs-num))
-
-(define-integrable (make-rcs-colon)
- '(COLON))
-
-(define (rcs-colon? word)
- (and (pair? word)
- (eq? 'COLON (car word))))
-
-(define-integrable (make-rcs-semicolon)
- '(SEMICOLON))
-
-(define (rcs-semicolon? word)
- (and (pair? word)
- (eq? 'SEMICOLON (car word))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RCS Data Structures
-
-(declare (usual-integrations))
-\f
-(define-record-type <rcs-text>
- (make-rcstext head branch access symbols locks strict? comment expand
- description)
- rcstext?
- (head rcstext/head)
- (branch rcstext/branch)
- (access rcstext/access)
- (symbols rcstext/symbols)
- (locks rcstext/locks)
- (strict? rcstext/strict?)
- (comment rcstext/comment)
- (expand rcstext/expand)
- (description rcstext/description))
-
-(define-record-type <rcs-delta>
- (make-delta number date author state branches next log text)
- delta?
- (number delta/number)
- (date delta/date)
- (author delta/author)
- (state delta/state)
- (branches delta/branches)
- (next delta/next set-delta/next!)
- (log delta/log set-delta/log!)
- (text delta/text set-delta/text!))
-
-(set-record-type-unparser-method! <rcs-delta>
- (standard-unparser-method 'RCS-DELTA
- (lambda (delta port)
- (write-char #\space port)
- (write-string (delta/number delta) port))))
-
-(define (date/make year month day hour minute second)
- (let ((year (if (< year 100) (+ 1900 year) year)))
- (let ((dt (make-decoded-time second minute hour day month year 0)))
- (vector dt
- (decoded-time->universal-time dt)
- (decoded-time->universal-time
- (make-decoded-time 0 0 0 day month year 0))))))
-
-(define (date/decoded date) (vector-ref date 0))
-(define (date/universal date) (vector-ref date 1))
-(define (date/day date) (vector-ref date 2))
-
-(define (date->string date) (decoded-time->string (date/decoded date)))
-
-(define (date<? x y) (< (date/universal x) (date/universal y)))
-(define (date=? x y) (= (date/universal x) (date/universal y)))
-(define (date>? x y) (> (date/universal x) (date/universal y)))
-
-(define (day<? x y) (< (date/day x) (date/day y)))
-(define (day=? x y) (= (date/day x) (date/day y)))
-(define (day>? x y) (> (date/day x) (date/day y)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; RCS Packaging
-
-(global-definitions "../runtime/runtime")
-
-(define-package (rcs)
- (files "object")
- (parent ()))
-
-(define-package (rcs format)
- (files "format")
- (parent (rcs))
- (export (rcs)
- rcs/format))
-
-(define-package (rcs parser)
- (files "nparse")
- (parent (rcs))
- (export (rcs)
- rcs/read-file
- rcs/read-head))
-
-(define-package (rcs log-merge)
- (files "logmer")
- (parent (rcs))
- (export ()
- rcs-directory-log))
\ No newline at end of file
+++ /dev/null
-(define (make-bind-script symbol output-file)
- (let ((read-head (access rcs/read-head (->environment '(RCS)))))
- (with-output-to-file output-file
- (lambda ()
- (for-each (lambda (pathname)
- (let ((head (read-head pathname)))
- (write-string
- (string-append "rcs -n" symbol ":" head
- " -sRel:" head " "
- (pathname->string pathname)
- "\n"))))
- (apply append!
- (map (lambda (pathname)
- (list-transform-negative
- (directory-read pathname)
- (lambda (pathname)
- (zero? (string-match-backward
- (->namestring pathname)
- ",v")))))
- (map (lambda (directory)
- (string-append directory "/RCS/"))
- '("microcode"
- "microcode/m"
- "microcode/s"
- "runtime"
- "cref"
- "sf"
- "compiler"
- "compiler/back"
- "compiler/base"
- "compiler/etc"
- "compiler/fggen"
- "compiler/fgopt"
- "compiler/machines/bobcat"
- "compiler/machines/mips"
- "compiler/machines/spectrum"
- "compiler/machines/vax"
- "compiler/rtlbase"
- "compiler/rtlgen"
- "compiler/rtlopt"
- "edwin"
- ;; "documentation"
- ;; "etc"
- )))))))))
\ No newline at end of file
(%entity-extra/apply-hook? (%entity-extra object)))
(define (%entity-extra/apply-hook? extra)
- ;; The wabbit cares about this one.
(and (object-type? (ucode-type hunk3) extra)
(eq? (system-hunk3-cxr0 extra) apply-hook-tag)))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; 6.001 Compatibility Definitions
-
-(declare (usual-integrations))
-\f
-;;; Make rationals print as flonums to create the illusion of not having
-;;; rationals at all, since the Chipmunks don't.
-
-(in-package (->environment '(runtime number))
- (define (rat:->string q radix)
- (if (ratnum? q)
- (let ((divided (flo:/ (int:->flonum (ratnum-numerator q))
- (int:->flonum (ratnum-denominator q)))))
- (if (integer? divided)
- (int:->string divided radix)
- (flo:->string divided radix)))
- (int:->string q radix))))
-
-(define (alphaless? symbol1 symbol2)
- (string<? (symbol->string symbol1) (symbol->string symbol2)))
-
-(define (and* . args)
- (let and-loop ((args args))
- (or (null? args)
- (and (car args)
- (and-loop (cdr args))))))
-
-(define (digit? object)
- (and (exact-nonnegative-integer? object) (<= object 9)))
-
-(define (singleton-symbol? object)
- (and (symbol? object)
- (= (string-length (symbol->string object)) 1)))
-
-(define (ascii object)
- (cond ((singleton-symbol? object)
- (char->ascii (char-upcase (string-ref (symbol->string object) 0))))
- ((digit? object)
- (char->ascii (string-ref (number->string object) 0)))
- (else
- (error:illegal-datum object 'ASCII))))
-
-(define (atom? object)
- (not (pair? object)))
-
-(define (or* . args)
- (let or-loop ((args args))
- (and (not (null? args))
- (or (car args)
- (or-loop (cdr args))))))
-
-(define char ascii->char)
-
-(define nil false)
-(define t true)
-
-(define (nth n l)
- (list-ref l n))
-
-(define (nthcdr n l)
- (list-tail l n))
-
-(define (object->string object)
- (cond ((symbol? object) (symbol->string object))
- ((number? object) (number->string object))
- ((string? object) (string-append "\"" object "\""))
- (else
- (with-output-to-string
- (lambda ()
- (write object))))))
-
-(define (string->object object)
- (with-input-from-string object
- read))
-
-(define (explode object)
- (map (lambda (character)
- (let ((string (char->string character)))
- (or (string->number string)
- (string->symbol string))))
- (string->list
- (object->string object))))
-
-(define (implode list)
- (string->object
- (list->string
- (map (lambda (element)
- (cond ((digit? element)
- (string-ref (number->string element) 0))
- ((singleton-symbol? element)
- (string-ref (symbol->string element) 0))
- (else
- (error "Element neither digit nor singleton symbol"
- element))))
- list))))
-\f
-(define (close-channel port)
- (cond ((input-port? port) (close-input-port port))
- ((output-port? port) (close-output-port port))
- (else (error "CLOSE-CHANNEL: Wrong type argument" port))))
-
-(define (tyi #!optional port)
- (let ((char
- (read-char
- (if (default-object? port)
- (current-input-port)
- (guarantee-input-port port 'TYI)))))
- (if (char? char)
- (char->ascii char)
- char)))
-
-(define (tyipeek #!optional port)
- (let ((char
- (peek-char
- (if (default-object? port)
- (current-input-port)
- (guarantee-input-port port 'TYIPEEK)))))
- (if (char? char)
- (char->ascii char)
- char)))
-
-(define (tyo ascii #!optional port)
- (write-char (ascii->char ascii)
- (if (default-object? port)
- (current-output-port)
- (guarantee-output-port port 'TYO))))
-
-(define (print-depth #!optional newval)
- (let ((newval (if (default-object? newval) false newval)))
- (if (not (or (not newval) (and (exact-integer? newval) (> newval 0))))
- (error:illegal-datum newval 'PRINT-DEPTH))
- (param:unparser-list-depth-limit newval)))
-
-(define (print-breadth #!optional newval)
- (let ((newval (if (default-object? newval) false newval)))
- (if (not (or (not newval) (and (exact-integer? newval) (> newval 0))))
- (error:illegal-datum newval 'PRINT-BREADTH))
- (param:unparser-list-breadth-limit newval)))
-
-(define (ceiling->exact number)
- (inexact->exact (ceiling number)))
-
-(define (floor->exact number)
- (inexact->exact (floor number)))
-
-(define (round->exact number)
- (inexact->exact (round number)))
-
-(define (truncate->exact number)
- (inexact->exact (truncate number)))
-
-(define (vector-cons size fill)
- (make-vector size fill))
-
-(define (read-from-keyboard)
- (let ((input (read)))
- (if (eq? input 'abort)
- (cmdl-interrupt/abort-nearest)
- input)))
-
-(define (student-pp object . args)
- (define (supply what old new)
- (if (eq? old 'NOT-SUPPLIED)
- new
- (error "pp: Overspecified option"
- (list what old new))))
-
- (define (parse-args args port as-code?)
- (cond ((null? args)
- (let ((port
- (if (eq? port 'NOT-SUPPLIED)
- (current-output-port)
- port)))
- (if (eq? as-code? 'NOT-SUPPLIED)
- (pp object port)
- (pp object port as-code?))))
- ((eq? (car args) 'AS-CODE)
- (parse-args (cdr args)
- port
- (supply 'AS-CODE as-code? true)))
- ((output-port? (car args))
- (parse-args (cdr args)
- (supply 'PORT port (car args))
- as-code?))
- (else
- (error "pp: Unknown option" (car args)))))
-
- (if (null? args)
- (pp object)
- (parse-args args 'NOT-SUPPLIED 'NOT-SUPPLIED)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Environment hacking for 6.001
-
-(declare (usual-integrations))
-\f
-(define build-environment)
-
-(define make-unassigned-object
- microcode-object/unassigned)
-
-(let ()
- (define (get-values descriptors frame receiver)
- (define (inner descriptors names values unref)
- (define (do-next name-here name-there)
- (if (or (not (symbol? name-there))
- (lexical-unreferenceable? frame name-there))
- (inner (cdr descriptors)
- (cons name-here names)
- (cons (make-unassigned-object)
- values)
- (if (not (symbol? name-there))
- unref
- (cons name-here unref)))
- (inner (cdr descriptors)
- (cons name-here names)
- (cons (lexical-reference frame name-there)
- values)
- unref)))
-
- (if (null? descriptors)
- (receiver (reverse! names)
- (reverse! values)
- (reverse! unref))
- (let ((this (car descriptors)))
- (cond ((not (pair? this))
- (do-next this this))
- ((null? (cdr this))
- (do-next (car this) (car this)))
- (else
- (do-next (car this) (cdr this)))))))
- (inner descriptors '() '() '()))
-
- (set! build-environment
- (named-lambda (build-environment names source-frame
- #!optional parent-frame
- process receiver)
- (get-values names source-frame
- (lambda (names values unreferenceable)
- (if (default-object? receiver)
- unreferenceable
- (receiver
- (apply (scode-eval (make-lambda lambda-tag:make-environment
- names
- '()
- '()
- '()
- '()
- (make-the-environment))
- (if (default-object? parent-frame)
- source-frame
- parent-frame))
- (map (if (default-object? process)
- unmap-reference-trap
- (lambda (x)
- (unmap-reference-trap (process x))))
- values))
- unreferenceable))))))
- 42)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Student graphics Interface
-;;;; implemented for X Windows/ Win32
-
-(declare (usual-integrations))
-\f
-(define clear-graphics)
-(define clear-point)
-(define draw-line-to)
-(define draw-point)
-(define graphics-available?)
-(define graphics-text)
-(define init-graphics)
-(define position-pen)
-
-(define graphics-package
- (make-environment
-
- (define graphics-device #F)
-
- (define (init-if-necessary)
- (if (not graphics-device)
- (init-graphics)))
-
- (set! clear-graphics
- (lambda ()
- (init-if-necessary)
- (graphics-clear graphics-device)
- (graphics-move-cursor graphics-device 0 0)))
-
- (set! clear-point
- (lambda (x y)
- (init-if-necessary)
- (graphics-erase-point graphics-device x y)))
-
- (set! draw-line-to
- (lambda (x y)
- (init-if-necessary)
- (graphics-drag-cursor graphics-device x y)))
-
- (set! draw-point
- (lambda (x y)
- (init-if-necessary)
- (graphics-draw-point graphics-device x y)))
-
- (set! graphics-available?
- (lambda ()
- (or (graphics-type-available? 'X)
- (graphics-type-available? 'WIN32))))
-
- (set! graphics-text
- (lambda (text x y)
- (init-if-necessary)
- ;; Accepts different parameters on Chipmunks.
- (graphics-draw-text graphics-device x y text)))
-
- (set! init-graphics
- (lambda ()
- (set! graphics-device
- (cond ((graphics-type-available? 'X)
- (make-graphics-device 'X #F "512x388"))
- ((graphics-type-available? 'WIN32)
- (make-graphics-device 'WIN32 512 388))
- (else
- (error "Graphics is not available"))))
- (graphics-set-coordinate-limits graphics-device -256 -195 255 194)
- (graphics-move-cursor graphics-device 0 0)))
-
- (set! position-pen
- (lambda (x y)
- (init-if-necessary)
- (graphics-move-cursor graphics-device x y)))
-
-))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; 6.001 Student Environment
-
-(declare (usual-integrations))
-
-(for-each (lambda (filename)
- (load filename system-global-environment))
- '("compat" "graphics" "strmac" "stream" "genenv" "studen"))
-(add-subsystem-identification! "Student (6.001)" '(14 3))
-
-"Student environment loaded."
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Stream Utilities
-
-(declare (usual-integrations))
-\f
-;;;; General Streams
-
-(define (nth-stream n s)
- (cond ((empty-stream? s)
- (error "Empty stream -- NTH-STREAM" n))
- ((= n 0)
- (head s))
- (else
- (nth-stream (- n 1) (tail s)))))
-
-(define (accumulate combiner initial-value stream)
- (if (empty-stream? stream)
- initial-value
- (combiner (head stream)
- (accumulate combiner
- initial-value
- (tail stream)))))
-
-(define (filter pred stream)
- (cond ((empty-stream? stream)
- the-empty-stream)
- ((pred (head stream))
- (cons-stream (head stream)
- (filter pred (tail stream))))
- (else
- (filter pred (tail stream)))))
-
-(define (map-stream proc stream)
- (if (empty-stream? stream)
- the-empty-stream
- (cons-stream (proc (head stream))
- (map-stream proc (tail stream)))))
-
-(define (map-stream-2 proc s1 s2)
- (if (or (empty-stream? s1)
- (empty-stream? s2))
- the-empty-stream
- (cons-stream (proc (head s1) (head s2))
- (map-stream-2 proc (tail s1) (tail s2)))))
-
-(define (append-streams s1 s2)
- (if (empty-stream? s1)
- s2
- (cons-stream (head s1)
- (append-streams (tail s1) s2))))
-
-(define (enumerate-fringe tree)
- (if (pair? tree)
- (append-streams (enumerate-fringe (car tree))
- (enumerate-fringe (cdr tree)))
- (cons-stream tree the-empty-stream)))
-\f
-;;;; Numeric Streams
-
-(define (add-streams s1 s2)
- (cond ((empty-stream? s1) s2)
- ((empty-stream? s2) s1)
- (else
- (cons-stream (+ (head s1) (head s2))
- (add-streams (tail s1) (tail s2))))))
-
-(define (scale-stream c s)
- (map-stream (lambda (x) (* c x)) s))
-
-(define (enumerate-interval n1 n2)
- (if (> n1 n2)
- the-empty-stream
- (cons-stream n1 (enumerate-interval (1+ n1) n2))))
-
-(define (integers-from n)
- (cons-stream n (integers-from (1+ n))))
-
-(define integers
- (integers-from 1))
-\f
-;;;; Some Hairier Stuff
-
-(define (merge s1 s2)
- (cond ((empty-stream? s1) s2)
- ((empty-stream? s2) s1)
- (else
- (let ((h1 (head s1))
- (h2 (head s2)))
- (cond ((< h1 h2)
- (cons-stream h1
- (merge (tail s1)
- s2)))
- ((> h1 h2)
- (cons-stream h2
- (merge s1
- (tail s2))))
- (else
- (cons-stream h1
- (merge (tail s1)
- (tail s2)))))))))
-\f
-;;;; Printing
-
-(define print-stream
- (let ()
- (define (iter s)
- (if (empty-stream? s)
- (write-string "}")
- (begin (write-string " ")
- (write (head s))
- (iter (tail s)))))
- (lambda (s)
- (newline)
- (write-string "{")
- (if (empty-stream? s)
- (write-string "}")
- (begin (write (head s))
- (iter (tail s)))))))
-\f
-;;;; Support for COLLECT
-
-(define (flatmap f s)
- (flatten (map-stream f s)))
-
-(define (flatten stream)
- (accumulate-delayed interleave-delayed
- the-empty-stream
- stream))
-
-(define (accumulate-delayed combiner initial-value stream)
- (if (empty-stream? stream)
- initial-value
- (combiner (head stream)
- (delay (accumulate-delayed combiner
- initial-value
- (tail stream))))))
-
-(define (interleave-delayed s1 delayed-s2)
- (if (empty-stream? s1)
- (force delayed-s2)
- (cons-stream (head s1)
- (interleave-delayed (force delayed-s2)
- (delay (tail s1))))))
-
-(define ((spread-tuple procedure) tuple)
- (apply procedure tuple))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Stream Macros
-
-(declare (usual-integrations))
-
-(syntax-table/define system-global-environment 'COLLECT
- (let ()
- (define (collect-macro-kernel result bindings filter)
- (if (null? bindings)
- (error "COLLECT: No bindings"))
- (parse-bindings bindings
- (lambda (names sets)
- (define (make-tuple-generator names* sets)
- (if (null? (cdr names*))
- `(MAP-STREAM (LAMBDA (,(car names*))
- (LIST ,@names))
- ,(car sets))
- `(FLATMAP (LAMBDA (,(car names*))
- ,(make-tuple-generator (cdr names*)
- (cdr sets)))
- ,(car sets))))
-
- `(MAP-STREAM (SPREAD-TUPLE (LAMBDA ,names ,result))
- ,(let ((tuple-generator
- (make-tuple-generator names sets)))
- (if (null? filter)
- tuple-generator
- `(FILTER (SPREAD-TUPLE (LAMBDA ,names ,@filter))
- ,tuple-generator)))))))
-
- (define (parse-bindings bindings receiver)
- (if (null? bindings)
- (receiver '() '())
- (begin
- (if (not (pair? bindings))
- (error "COLLECT: Bindings must be a list" bindings))
- (parse-bindings (cdr bindings)
- (lambda (names sets)
- (if (not (and (list? (car bindings))
- (= (length (car bindings)) 2)
- (symbol? (caar bindings))))
- (error "COLLECT: Badly formed binding" (car bindings)))
- (receiver (cons (caar bindings) names)
- (cons (cadar bindings) sets)))))))
-
- (lambda (result bindings . filter)
- (collect-macro-kernel result bindings filter))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Environment, syntax and read table hacking for 6.001 students.
-
-(declare (usual-integrations))
-\f
-;;; Define the #/ syntax.
-
-(in-package (->environment '(runtime parser))
- (define (parse-object/char-forward-quote)
- (discard-char)
- (if (char=? #\/ (peek-char))
- (read-char)
- (name->char
- (let loop ()
- (cond ((char=? #\/ (peek-char))
- (discard-char)
- (string (read-char)))
- ((char-set-member? char-set/char-delimiters (peek-char))
- (string (read-char)))
- (else
- (let ((string (read-string char-set/char-delimiters)))
- (if (let ((char (peek-char/eof-ok)))
- (and char
- (char=? #\- char)))
- (begin (discard-char)
- (string-append string "-" (loop)))
- string))))))))
-
- (define char-set/mit-scheme-atom-delimiters
- char-set/atom-delimiters)
-
- (define char-set/sicp-atom-delimiters
- (char-set-difference
- char-set/mit-scheme-atom-delimiters
- (char-set #\[ #\])))
-
- (define (set-atom-delimiters! kind)
- (set! char-set/atom-delimiters
- (case kind
- ((mit-scheme)
- char-set/mit-scheme-atom-delimiters)
- ((sicp)
- char-set/sicp-atom-delimiters)
- (else
- (error "set-atom-delimiters!: Unknown kind")))))
-
-) ;; end in-package
-
-(parser-table/set-entry! system-global-parser-table
- "#\/"
- (access parse-object/char-forward-quote
- (->environment '(runtime parser))))
-
-(define environment-warning-hook)
-
-(define user-global-environment)
-
-(define student-package
- (make-environment
-\f
-;;;; Syntax Restrictions
-
-(define sicp-parser-table
- (parser-table/copy system-global-parser-table))
-
-(define *student-parser-table*)
-
-(define sicp-syntax-table
- (make-syntax-table))
-
-(define *student-syntax-table*)
-
-(define set-atom-delimiters!
- (access set-atom-delimiters! (->environment '(runtime parser))))
-
-(define (enable-system-syntax)
- (param:parser-table system-global-parser-table)
- (set-atom-delimiters! 'mit-scheme)
- (set-repl/syntax-table! (nearest-repl) system-global-syntax-table))
-
-(define (disable-system-syntax)
- (param:parser-table *student-parser-table*)
- (set-atom-delimiters! 'sicp)
- (set-repl/syntax-table! (nearest-repl) *student-syntax-table*))
-
-(define (initialize-syntax!)
- ;; First hack the parser (reader) table
- ;; Remove backquote and comma
- (let ((undefined-entry
- (access parse-object/undefined-atom-delimiter
- (->environment '(runtime parser)))))
- (parser-table/set-entry! sicp-parser-table "`" undefined-entry)
- (parser-table/set-entry! sicp-parser-table "," undefined-entry))
- ;; Add brackets as extended alphabetic since they are used in book (ugh!)
- (parser-table/entry
- system-global-parser-table
- "@"
- (lambda (parse-object collect-list)
- (parser-table/set-entry! sicp-parser-table "[" parse-object collect-list)
- (parser-table/set-entry! sicp-parser-table "]" parse-object
- collect-list)))
- ;; Now, hack the syntax (special form) table.
- (let ((move
- (lambda (from to)
- (syntax-table/define sicp-syntax-table to
- (or (syntax-table/ref system-global-syntax-table from)
- (error "Missing syntactic keyword" from))))))
- (for-each (lambda (name) (move name name))
- '(
- ;; These special forms are shared.
- COLLECT COND CONS-STREAM DEFINE
- DELAY IF LAMBDA LET MAKE-ENVIRONMENT
- QUOTE SEQUENCE SET! THE-ENVIRONMENT
- ;; The following are needed because some of the above are
- ;; macros and they are not syntactically closed. Yuck!
- ACCESS BEGIN NAMED-LAMBDA))
- (move 'AND 'CONJUNCTION)
- (move 'OR 'DISJUNCTION))
- (set! *student-parser-table* (parser-table/copy sicp-parser-table))
- (set! *student-syntax-table* (syntax-table/copy sicp-syntax-table))
- #T)
-\f
-;;;; Global Environment
-
-(define (global-environment-enabled?)
- (or (eq? user-global-environment system-global-environment)
- (environment-has-parent? user-global-environment)))
-
-(define (in-user-environment-chain? environment)
- (or (eq? environment user-global-environment)
- (and (environment-has-parent? environment)
- (in-user-environment-chain? (environment-parent environment)))))
-
-(define ic-environment/remove-parent!)
-(define ic-environment/set-parent!)
-
-(let ((e (->environment '(runtime environment))))
- (set! ic-environment/remove-parent! (access ic-environment/remove-parent! e))
- (set! ic-environment/set-parent! (access ic-environment/set-parent! e)))
-
-(define (disable-global-environment)
- (ic-environment/remove-parent! user-global-environment)
- 'DISABLED)
-
-(define (enable-global-environment)
- (ic-environment/set-parent! user-global-environment
- system-global-environment)
- 'ENABLED)
-
-(define (student-environment-warning-hook environment)
- (if (not (in-user-environment-chain? environment))
- (begin
- (newline)
- (write-string
- "This environment is part of the Scheme system outside the student system.")
- (newline)
- (write-string
- "Performing side-effects in it may damage to the system."))))
-\f
-;;;; Feature hackery
-
-(define (enable-language-features . prompt)
- prompt
- (without-interrupts
- (lambda ()
- (enable-global-environment)
- (enable-system-syntax)))
- unspecific)
-
-(define (disable-language-features . prompt)
- prompt
- (without-interrupts
- (lambda ()
- (disable-global-environment)
- (disable-system-syntax)))
- unspecific)
-
-(define (language-features-enabled?)
- (global-environment-enabled?))
-\f
-;;;; Clean environment hackery
-
-(define user-global-names
- '(
- (%EXIT)
- (*)
- (*ARGS*)
- (*PROC*)
- (*RESULT*)
- (+)
- (-)
- (-1+)
- (/)
- (1+)
- (<)
- (<=)
- (=)
- (>)
- (>=)
- (ABS)
- (ACCUMULATE)
- (ACCUMULATE-DELAYED)
- (ADD-STREAMS)
- (ADVICE)
- (ADVISE-ENTRY)
- (ADVISE-EXIT)
- (ALPHALESS?)
- (AND . AND*)
- (APPEND)
- (APPEND-STREAMS)
- (APPLICABLE? . PROCEDURE?)
- (APPLY)
- (ASCII)
- (ASSOC)
- (ASSQ)
- (ASSV)
- (ATAN)
- (ATOM?)
- (BKPT)
- (BREAK . BREAK-ENTRY)
- (BREAK-BOTH . BREAK)
- (BREAK-ENTRY)
- (BREAK-EXIT)
- (BREAKPOINT-PROCEDURE)
-\f
- (CAR)
- (CAAAAR)
- (CAAADR)
- (CAAAR)
- (CAADAR)
- (CAADDR)
- (CAADR)
- (CAAR)
- (CADAAR)
- (CADADR)
- (CADAR)
- (CADDAR)
- (CADDDR)
- (CADDR)
- (CADR)
- (CD)
- (CDR)
- (CDAAAR)
- (CDAADR)
- (CDAAR)
- (CDADAR)
- (CDADDR)
- (CDADR)
- (CDAR)
- (CDDAAR)
- (CDDADR)
- (CDDAR)
- (CDDDAR)
- (CDDDDR)
- (CDDDR)
- (CDDR)
- (CEILING . CEILING->EXACT)
- (CHAR)
- (CLEAR-GRAPHICS)
- (CLEAR-POINT)
- (CLOSE-CHANNEL)
- (CONS)
- (CONS*)
- (COPY-FILE)
- (COS)
- (DEBUG)
- (DELETE-FILE)
- (DRAW-LINE-TO)
- (DRAW-POINT)
-\f
- (EIGHTH)
- (EMPTY-STREAM?)
- (ENABLE-LANGUAGE-FEATURES)
- (ENUMERATE-FRINGE)
- (ENUMERATE-INTERVAL)
- (ENVIRONMENT?)
- (EQ?)
- (EQUAL?)
- (EQV?)
- (ERROR)
- (EVAL)
- (EVEN?)
- (EXP)
- (EXPLODE)
- (EXPT)
- (FALSE)
- (FIFTH)
- (FILE-EXISTS?)
- (FILTER)
- (FIRST)
- (FLATMAP)
- (FLATTEN)
- (FLOOR . FLOOR->EXACT)
- (FORCE)
- (FOURTH)
- (GCD)
- (GE)
- (GENERATE-UNINTERNED-SYMBOL)
- (GRAPHICS-AVAILABLE?)
- (GRAPHICS-TEXT)
- (HEAD)
- (IMPLODE)
- (IN)
- (INIT-GRAPHICS)
- (INTEGER-DIVIDE)
- (INTEGER?)
- (INTEGERS-FROM)
- (INTEGERS)
- (INTERLEAVE-DELAYED)
- (LAST . LAST-PAIR)
- (LENGTH)
- (LIST)
- (LIST* . CONS*)
- (LIST-REF)
- (LIST-TAIL)
- (LIST?)
- (LOAD)
- (LOAD-NOISILY)
- (LOG)
-\f
- (MAP-STREAM)
- (MAP-STREAM-2)
- (MAPC . FOR-EACH)
- (MAPCAR . MAP)
- (MAX)
- (MEMBER)
- (MEMQ)
- (MEMV)
- (MERGE)
- (MIN)
- (NEGATIVE?)
- (NEWLINE)
- (NIL)
- (NOT)
- (NTH)
- (NTH-STREAM)
- (NTHCDR)
- (NULL?)
- (NUMBER?)
- (OBJECT-TYPE)
- (ODD?)
- (OPEN-READER-CHANNEL . OPEN-INPUT-FILE)
- (OPEN-PRINTER-CHANNEL . OPEN-OUTPUT-FILE)
- (OR . OR*)
- (OUT)
- (PAIR?)
- (POSITION-PEN)
- (POSITIVE?)
- (PP . STUDENT-PP)
- (PRIN1 . WRITE)
- (PRINC . DISPLAY)
- (PRINT . WRITE-LINE)
- (PRINT-STREAM)
- (PROCEED)
- (QUIT)
- (QUOTIENT)
- (RANDOM)
- (READ)
- (READ-FROM-KEYBOARD)
- (REMAINDER)
- (RESTART)
- (REVERSE)
- (ROUND . ROUND->EXACT)
- (RUNTIME)
- (SCALE-STREAM)
-\f
- (SECOND)
- (SET-CAR!)
- (SET-CDR!)
- (SEVENTH)
- (SIN)
- (SIXTH)
- (SPREAD-TUPLE)
- (SQRT)
- (STRING-LESS?. STRING<?)
- (SYMBOL?)
- (T)
- (TAIL)
- (TAN)
- (THE-EMPTY-STREAM)
- (THIRD)
- (TRACE . TRACE-ENTRY)
- (TRACE-BOTH . TRACE)
- (TRACE-ENTRY)
- (TRACE-EXIT)
- (TRUE)
- (TRUNCATE . TRUNCATE->EXACT)
- (UNADVISE)
- (UNADVISE-ENTRY)
- (UNADVISE-EXIT)
- (UNBREAK)
- (UNBREAK-ENTRY)
- (UNBREAK-EXIT)
- (UNTRACE)
- (UNTRACE-ENTRY)
- (UNTRACE-EXIT)
- (USER-GLOBAL-ENVIRONMENT . #T)
- (USER-INITIAL-ENVIRONMENT . #T)
- (VE)
- (VECTOR)
- (VECTOR-CONS)
- (VECTOR-REF)
- (VECTOR-SET!)
- (VECTOR-SIZE . VECTOR-LENGTH)
- (VECTOR?)
- (WHERE)
- (ZERO?)))
-\f
-;;; Environment setup code
-
-(define (warn-about-missing-objects missing)
- (for-each
- (lambda (name)
- (newline)
- (write-string "Warning -- missing name: ")
- (write name))
- missing))
-
-(define (setup-user-global-environment!)
- (define (copy-if-proc object)
- (if (compound-procedure? object)
- (scode-eval (lambda-components (procedure-lambda object)
- make-lambda)
- (procedure-environment object))
- object))
-
- (build-environment
- user-global-names
- system-global-environment ; Where to look
- system-global-environment ; Parent frame
- copy-if-proc ; What to do to each value
- (lambda (frame missing)
- (scode-eval (scode-quote
- (begin
- (set! user-global-environment (the-environment))
- (set! user-initial-environment (make-environment))))
- frame)
- (set! user-global-environment frame)
- (set! user-initial-environment
- (lexical-reference frame 'user-initial-environment))
- (warn-about-missing-objects missing))))
-\f
-;;;; Saving and restoring the student system
-
-(define student-band-pathname)
-
-(define (initialize-system)
- (set! init-file-pathname
- (let ((old-init-file-pathname (init-file-pathname)))
- (lambda ()
- (merge-pathnames (make-pathname #f #f #f "sicp" #f #f)
- old-init-file-pathname))))
- (set! student-band-pathname
- (merge-pathnames
- (make-pathname #f #f #f "sicp" "bin" #f)
- (system-library-directory-pathname false)))
- (add-event-receiver!
- event:after-restart
- (lambda ()
- (if (language-features-enabled?)
- (disable-language-features))
- (if (not (graphics-available?))
- (begin
- (newline)
- (display "*** Note: no graphics available in this system. ***")))))
- #T)
-
-(define (reload #!optional filename)
- (disk-restore
- (if (default-object? filename)
- student-band-pathname
- (merge-pathnames (->pathname filename)
- student-band-pathname))))
-
-(define (student-band #!optional filename)
- (if (not (default-object? filename))
- (set! student-band-pathname
- (merge-pathnames (->pathname filename)
- student-band-pathname)))
- (disk-save student-band-pathname))
-
-(define (student-dump filename)
- (dump-world filename))
-
-;;; End STUDENT-PACKAGE.
-))
-\f
-;;;; Exports
-
-(define enable-language-features
- (access enable-language-features student-package))
-
-(define disable-language-features
- (access disable-language-features student-package))
-
-(define reload
- (access reload student-package))
-
-(define student-band
- (access student-band student-package))
-
-(define student-dump
- (access student-dump student-package))
-
-;;; Install the student package
-
-((access initialize-syntax! student-package))
-((access setup-user-global-environment! student-package))
-((access initialize-system student-package))
-(set! environment-warning-hook
- (access student-environment-warning-hook student-package))
-(set-repl/environment! (nearest-repl) user-initial-environment)
-(disable-language-features)
\ No newline at end of file
+++ /dev/null
-#_______________________________________________________________________
-#
-# Installation configuration
-#
-# Where the installed version of SWAT lives
-
-INSTALL_DIR=/scheme/8.0/700/lib/swat
-
-# SWAT's own copies of tcl and tk. These definitions are passed down to
-# the compilation of Tk and Tcl and become hard paths in the tcl.sl
-# and tk.sl libraries. DO NOT point these to source directories: the
-# installation cleans them out.
-
-TCL_LIBRARY = $(INSTALL_DIR)/tcl_lib
-TK_LIBRARY = $(INSTALL_DIR)/tk_lib
-
-#_______________________________________________________________________
-
-C_LIBRARIES = c/scxl.sl c/tk.sl c/tcl.sl c/uitk.sl
-
-all:
- echo "No all target."
- echo "Only make install"
- exit 1
-
-install: scheme/compiled
- (cd c; make TCL_LIBRARY=$(TCL_LIBRARY) TK_LIBRARY=$(TK_LIBRARY) all)
- # Remove dynload separatly first: will fail if SWAT is in use.
- rm -rf $(INSTALL_DIR)/dynload
- rm -rf $(INSTALL_DIR) $(TCL_LIBRARY) $(TK_LIBRARY)
- mkdir $(INSTALL_DIR) $(INSTALL_DIR)/dynload \
- $(TCL_LIBRARY) $(TK_LIBRARY)
- cp -p $(C_LIBRARIES) $(INSTALL_DIR)/dynload
- (cd c/tk3.2/library; cp -p *.tcl tclIndex prolog.ps $(TK_LIBRARY))
- (cd c/tk3.2/tcl/library; cp -p *.tcl tclIndex $(TCL_LIBRARY))
- (cd scheme; cp -p load.scm *.com *.bci demo-*.scm $(INSTALL_DIR))
- echo "Installation complete"
-
-
-#$(C_LIBRARIES):
-
-
-scheme/compiled:
- echo "Build Scheme subsystem with scheme compiler"
- exit 1
- (cd scheme; \
- echo '(load "swat.sf") (load "swat.cbf")' | $(SCHEME) -compiler \
- )
-
-clean:
-
-TAGS:
- etags scheme/*.scm c/*.c
+++ /dev/null
-#include "scheme.h"
-#include "prims.h"
-
-extern char *EXFUN (dload_initialize_file, (void));
-
-char *
- DEFUN_VOID (dload_initialize_file)
-{ return "#NoMITSchemePrimitives";
-}
+++ /dev/null
-## WARNING: This makefile is designed to be used only from the master
-## makefile in the parent directory.
-
-#_______________________________________________________________________
-#
-# How this makefile works.
-#
-# This makefile builds four libraries. Two are based directly on
-# Tk/Tcl. The other two are an interface between Scheme, X and
-# Tk/Tcl.
-#
-# The build process works by customizing an off-the-shelf version of tk
-# (currently version 3.2). The SWAT versions of some of the files are
-# copied over the off-the-shelf version. The customized version is
-# compiled to produce the libtk.a and libtcl.a libraries. These
-# libraries are not acutally used but they ensure that all the targets
-# that we are interested in are up to date. Then we construct our own
-# libraries (tk.sl and tcl.sl).
-#
-# The other libraries are more straight-forward.
-#_______________________________________________________________________
-
-# The location of the customized files. The directory structure matches
-# that of tk3.2 and is sparsely populated with customized files:
-
-CUSTOM = tk3.2-custom
-
-# Important: select a microcode source directory with the correct scheme
-# object representation:
-
-SCHEME_INCLUDE_DIRS = -I/scheme/8.0/src/microcode
-
-TK = tk3.2
-TCL = $(TK)/tcl
-
-#UITK_INCLUDE_DIRS = -I $(UITK) -I $(UITK_C) -I $(TK) -I $(TCL) $(SCHEME_INCLUDE_DIRS)
-UITK_INCLUDE_DIRS = -I $(TK) -I $(TCL) $(SCHEME_INCLUDE_DIRS)
-CFLAGS = -DMIT_SCHEME -O -Ae -D_HPUX -I/usr/include/X11R5 +z
-
-XLIB = -L /usr/lib/X11R5 -lX11
-
-# These library paths are overruled by the master makefile.
-
-#TK_LIBRARY = /scheme/8.0/700/swat/c/tk3.2/library
-#TCL_LIBRARY = /scheme/8.0/700/swat/c/tk3.2/tcl/library
-TK_LIBRARY = Built_incorrectly__TK_LIBRARY__not_specified
-TCL_LIBRARY = Built_incorrectly__TCL_LIBRARY__not_specified
-
-TCL_GENERIC_OBJS = \
- $(TCL)/regexp.o $(TCL)/tclAssem.o $(TCL)/tclBasic.o \
- $(TCL)/tclCkalloc.o $(TCL)/tclCmdAH.o $(TCL)/tclCmdIL.o \
- $(TCL)/tclCmdMZ.o $(TCL)/tclExpr.o $(TCL)/tclGet.o \
- $(TCL)/tclHash.o $(TCL)/tclHistory.o $(TCL)/tclParse.o \
- $(TCL)/tclProc.o $(TCL)/tclUtil.o $(TCL)/tclVar.o
-
-TCL_UNIX_OBJS = \
- $(TCL)/panic.o $(TCL)/tclEnv.o $(TCL)/tclGlob.o $(TCL)/tclUnixAZ.o \
- $(TCL)/tclUnixStr.o $(TCL)/tclUnixUtil.o
-
-TCL_OBJS = $(TCL_GENERIC_OBJS) $(TCL_UNIX_OBJS) MITScheme.o
-
-TK_WIDGOBJS = \
- $(TK)/tkButton.o $(TK)/tkEntry.o $(TK)/tkFrame.o $(TK)/tkListbox.o \
- $(TK)/tkMenu.o $(TK)/tkMenubutton.o $(TK)/tkMessage.o $(TK)/tkScale.o \
- $(TK)/tkScrollbar.o
-
-TK_CANVOBJS = \
- $(TK)/tkCanvas.o $(TK)/tkCanvArc.o $(TK)/tkCanvBmap.o \
- $(TK)/tkCanvLine.o $(TK)/tkCanvPoly.o $(TK)/tkCanvPs.o \
- $(TK)/tkCanvText.o $(TK)/tkCanvWind.o $(TK)/tkRectOval.o $(TK)/tkTrig.o
-
-TK_TEXTOBJS = $(TK)/tkText.o $(TK)/tkTextBTree.o $(TK)/tkTextDisp.o \
- $(TK)/tkTextIndex.o $(TK)/tkTextTag.o
-
-TK_OBJS = \
- $(TK)/tk3d.o $(TK)/tkArgv.o $(TK)/tkAtom.o $(TK)/tkBind.o \
- $(TK)/tkBitmap.o $(TK)/tkCmds.o $(TK)/tkColor.o $(TK)/tkConfig.o \
- $(TK)/tkCursor.o $(TK)/tkError.o $(TK)/tkEvent.o $(TK)/tkFocus.o \
- $(TK)/tkFont.o $(TK)/tkGet.o $(TK)/tkGC.o $(TK)/tkGeometry.o \
- $(TK)/tkGrab.o $(TK)/tkOption.o $(TK)/tkPack.o $(TK)/tkPlace.o \
- $(TK)/tkPreserve.o $(TK)/tkSelect.o $(TK)/tkSend.o $(TK)/tkWindow.o \
- $(TK)/tkWm.o $(TK_WIDGOBJS) $(TK_CANVOBJS) $(TK_TEXTOBJS) MITScheme.o
-
-UITK_OBJS = tk-c.o tk-c-mit.o widget-c.o widget-c-mit.o uitk-prims.o
-SCXL_OBJS = scxl.o
-
-# Contents of custom directory structure:
-
-CUSTOM_SRC = \
- $(CUSTOM)/Makefile \
- $(CUSTOM)/tkEvent.c $(CUSTOM)/tkWindow.c \
- $(CUSTOM)/tcl/Makefile $(CUSTOM)/tcl/tclUnix.h \
- $(CUSTOM)/library/emacs.tcl
-
-all: scxl.sl tcl.sl tk.sl uitk.sl
-
-scxl.sl: $(SCXL_OBJS)
- rm -f scxl.sl
- ld -b -o scxl.sl $(SCXL_OBJS) $(XLIB) -lc
-
-tcl.sl: $(TCL)/libtcl.a MITScheme.o
- rm -f tcl.sl
- ld -b -o tcl.sl $(TCL_OBJS) -lc
-
-tk.sl: $(TK)/libtk.a MITScheme.o
- rm -f tk.sl
- ld -b -o tk.sl $(TK_OBJS) $(XLIB) -lm -lc
-
-uitk.sl: $(UITK_OBJS)
- rm -f uitk.sl
- ld -b -o uitk.sl $(UITK_OBJS) -lm -lc
-
-scxl.o MITScheme.o uitk-prims.o:
- $(CC) $(CFLAGS) $(SCHEME_INCLUDE_DIRS) -c $*.c
-
-MITScheme.o: MITScheme.c
-scxl.o: scxl.c
-uitk-prims.o: uitk-prims.c
-
-widget-c.o widget-c-mit.o tk-c-mit.o: $(TK)/tkInt.h $(TK)/default.h
- $(CC) $(CFLAGS) $(UITK_INCLUDE_DIRS) -c $*.c
-
-tk-c.o: tk-c.c $(TK)/tkInt.h $(TK)/default.h
- $(CC) $(CFLAGS) $(UITK_INCLUDE_DIRS) TK_LIBRARY=$(TK_LIBRARY) \
- TCL_LIBRARY=$(TCL_LIBRARY) -c $*.c
-widegt-c.o: widget-c.c
-widget-c-mit.o: widget-c-mit.c
-tk-c-mit.o: tk-c-mit.c
-
-#$(TCL_OBJS) $(TK_OBJS): customization
-$(TCL)/libtcl.a $(TK)/libtk.a: customization
-
-customization: $(CUSTOM_SRC)
- (cd $(TCL); ./config)
- # overwrite standard code with customized files
- cp -f -R tk3.2-custom/* tk3.2
- rm -f $(TK)/libtk.a $(TCL)/libtcl.a
- (cd tk3.2; \
- make -f Makefile TCL_LIBRARY=$(TCL_LIBRARY) TK_LIBRARY=$(TK_LIBRARY) \
- libtk.a tcl/libtcl.a \
- )
- date > customization
-
-
+++ /dev/null
-/* X11 support similar to that in Joel Bartlett's Scheme-To-C xlib (scxl) */
-
-#include "scheme.h"
-#include "prims.h"
-#include "ux.h"
-#include "uxselect.h"
-
-/* Changed 7/95 by Nick in an attempt to fix problem Hal was having with SWAT over PPP (i.e. slow connections) */
-/* commented out 'cause x11.h includes em all
-#include <X11/Xlib.h>
-#include <X11/cursorfont.h>
-#include <X11/keysym.h>
-#include <X11/Xutil.h>
-#include <X11/Xatom.h>
-#include "ansidecl.h" */
-
-#include "x11.h"
-
-extern void EXFUN (block_signals, (void));
-extern void EXFUN (unblock_signals, (void));
-
-/* end nick's changes - but see below for more */
-
-
-/* Operations */
-
-DEFINE_PRIMITIVE ("%XAllocNamedColor", Prim_scxl_allocated_named_color,
- 5, 5, 0)
-{ /* (%XAllocNamedColor display colormap color-string
- return-alloc return-exact)
- */
- PRIMITIVE_HEADER(5);
- CHECK_ARG(4, STRING_P);
- CHECK_ARG(5, STRING_P);
- if (STRING_LENGTH(ARG_REF(4)) < sizeof (XColor))
- error_bad_range_arg(4);
- if (STRING_LENGTH(ARG_REF(5)) < sizeof (XColor))
- error_bad_range_arg(5);
- PRIMITIVE_RETURN
- (long_to_integer
- ((long) XAllocNamedColor((Display *) arg_integer(1),
- (Colormap) arg_integer(2),
- STRING_ARG(3),
- (XColor *) STRING_ARG(4),
- (XColor *) STRING_ARG(5))));
-}
-
-DEFINE_PRIMITIVE ("%XChangeWindowAttributes", Prim_scxl_change_wind_attr,
- 4, 4, 0)
-{ /* (%XChangeWindowAttributes display window mask attributes) */
- /* ATTRIBUTES is a string */
- PRIMITIVE_HEADER(4);
- CHECK_ARG(4, STRING_P);
- if (STRING_LENGTH(ARG_REF(4)) < sizeof (XSetWindowAttributes))
- error_bad_range_arg(4);
- XChangeWindowAttributes((Display *) arg_integer(1),
- (Window) arg_integer(2),
- (unsigned long) arg_integer(3),
- (XSetWindowAttributes *) STRING_ARG(4));
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XCheckMaskEvent", Prim_scxl_check_mask_event, 3, 3, 0)
-{ /* (%XCheckMaskEvent display event-mask return-event) */
- PRIMITIVE_HEADER (3);
- CHECK_ARG(3, STRING_P);
- if (STRING_LENGTH(ARG_REF(3)) < sizeof(XEvent))
- error_bad_range_arg(3);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT
- (XCheckMaskEvent ((Display *) arg_integer(1),
- (long) arg_integer(2),
- (XEvent *) STRING_ARG(3))));
-}
-
-DEFINE_PRIMITIVE ("%XClearArea", Prim_scxl_clear_area, 7, 7, 0)
-{ /* (%XClearArea display window x y width height) */
- PRIMITIVE_HEADER (7);
- XClearArea ((Display *) arg_integer(1),
- (Drawable) arg_integer(2),
- (int) arg_integer(3),
- (int) arg_integer(4),
- (unsigned int) arg_integer(5),
- (unsigned int) arg_integer(6),
- (Bool) BOOLEAN_ARG(7));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XClearWindow", Prim_scxl_clear_window, 2, 2, 0)
-{ /* (%XClearWindow display window) */
- PRIMITIVE_HEADER (2);
- XClearWindow ((Display *) arg_integer(1),
- (Drawable) arg_integer(2));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XCloseDisplay", Prim_scxl_close, 1, 1, 0)
-{ /* (%XCloseDisplay display) */
- PRIMITIVE_HEADER (1);
- XCloseDisplay((Display *) arg_integer(1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XConnectionNumber", Prim_scxl_connection_number, 1, 1, 0)
-{ /* (%XConnectionNumber display) */
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN (long_to_integer
- (XConnectionNumber((Display *) arg_integer(1))));
-}
-
-DEFINE_PRIMITIVE ("%XCreateGC", Prim_scxl_create_gc, 4, 4, 0)
-{ /* (%XCreateGC display window mask values) */
- PRIMITIVE_HEADER(4);
- CHECK_ARG(4, STRING_P);
- if (STRING_LENGTH(ARG_REF(4)) < sizeof(XGCValues))
- error_bad_range_arg(4);
- PRIMITIVE_RETURN
- (long_to_integer
- ((long) XCreateGC((Display *) arg_integer(1),
- (Drawable) arg_integer(2),
- (unsigned long) arg_integer(3),
- (XGCValues *) STRING_ARG(4))));
-}
-
-DEFINE_PRIMITIVE ("%XCreateRegion", Prim_scxl_create_region, 0, 0, 0)
-{ /* (%XCreateRegion) */
- Region Result;
- PRIMITIVE_HEADER(0);
- Result = XCreateRegion();
- PRIMITIVE_RETURN (long_to_integer ((long) Result));
-}
-
-DEFINE_PRIMITIVE ("%XCreateSimpleWindow", Prim_scxl_create_simple_window,
- 9, 9, 0)
-{ /* (%XCreateSimpleWindow display parent-window x y width height
- border-width border-color background-color)
- */
- PRIMITIVE_HEADER(9);
- PRIMITIVE_RETURN
- (long_to_integer
- ((long) XCreateSimpleWindow
- ((Display *) arg_integer(1),
- (Window) arg_integer(2),
- (int) arg_integer(3),
- (int) arg_integer(4),
- (unsigned int) arg_integer(5),
- (unsigned int) arg_integer(6),
- (unsigned int) arg_integer(7),
- (unsigned long) arg_integer(8),
- (unsigned long) arg_integer(9))));
-}
-
-DEFINE_PRIMITIVE ("%XDecodeButtonEvent", prim_scxl_decode_button, 2, 2, 0)
-{ /* (%XDecodeButtonEvent event vector) */
- SCHEME_OBJECT Result = ARG_REF(2);
- SCHEME_OBJECT *Next;
- XButtonEvent *Input;
-
- PRIMITIVE_HEADER (2);
- CHECK_ARG(1, STRING_P);
- if (STRING_LENGTH(ARG_REF(1)) < sizeof(XButtonEvent))
- error_bad_range_arg(1);
- CHECK_ARG(2, VECTOR_P);
- if (VECTOR_LENGTH(Result) < 15)
- error_bad_range_arg(2);
- Input = (XButtonEvent *) STRING_ARG(1);
- Next = VECTOR_LOC(Result, 0);
- *Next++ = long_to_integer ((long) (Input->type)); /* 0 */
- *Next++ = long_to_integer ((long) (Input->serial)); /* 1 */
- *Next++ = BOOLEAN_TO_OBJECT(Input->send_event); /* 2 */
- *Next++ = long_to_integer ((long) (Input->display)); /* 3 */
- *Next++ = long_to_integer ((long) (Input->window)); /* 4 */
- *Next++ = long_to_integer ((long) (Input->root)); /* 5 */
- *Next++ = long_to_integer ((long) (Input->subwindow)); /* 6 */
- *Next++ = long_to_integer ((long) (Input->time)); /* 7 */
- *Next++ = long_to_integer ((long) (Input->x)); /* 8 */
- *Next++ = long_to_integer ((long) (Input->y)); /* 9 */
- *Next++ = long_to_integer ((long) (Input->x_root)); /* 10 */
- *Next++ = long_to_integer ((long) (Input->y_root)); /* 11 */
- *Next++ = long_to_integer ((long) (Input->state)); /* 12 */
- *Next++ = long_to_integer ((long) (Input->button)); /* 13 */
- *Next = BOOLEAN_TO_OBJECT(Input->same_screen); /* 14 */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XDecodeConfigureEvent",
- prim_scxl_decode_config, 2, 2, 0)
-{ /* (%XDecodeConfigureEvent event vector) */
- SCHEME_OBJECT Result = ARG_REF(2);
- SCHEME_OBJECT *Next;
- XConfigureEvent *Input;
-
- PRIMITIVE_HEADER (2);
- CHECK_ARG(1, STRING_P);
- if (STRING_LENGTH(ARG_REF(1)) < sizeof(XConfigureEvent))
- error_bad_range_arg(1);
- CHECK_ARG(2, VECTOR_P);
- if (VECTOR_LENGTH(Result) < 13)
- error_bad_range_arg(2);
- Input = (XConfigureEvent *) STRING_ARG(1);
- Next = VECTOR_LOC(Result, 0);
- *Next++ = long_to_integer ((long) (Input->type)); /* 0 */
- *Next++ = long_to_integer ((long) (Input->serial)); /* 1 */
- *Next++ = BOOLEAN_TO_OBJECT(Input->send_event); /* 2 */
- *Next++ = long_to_integer ((long) (Input->display)); /* 3 */
- *Next++ = long_to_integer ((long) (Input->event)); /* 4 */
- *Next++ = long_to_integer ((long) (Input->window)); /* 5 */
- *Next++ = long_to_integer ((long) (Input->x)); /* 6 */
- *Next++ = long_to_integer ((long) (Input->y)); /* 7 */
- *Next++ = long_to_integer ((long) (Input->width)); /* 8 */
- *Next++ = long_to_integer ((long) (Input->height)); /* 9 */
- *Next++ = long_to_integer ((long) (Input->border_width)); /* 10 */
- *Next++ = long_to_integer ((long) (Input->above)); /* 11 */
- *Next = BOOLEAN_TO_OBJECT(Input->override_redirect); /* 12 */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XDecodeCrossingEvent", prim_scxl_decode_crossing, 2, 2, 0)
-{ /* (%XDecodeCrossingEvent event vector) */
- SCHEME_OBJECT Result = ARG_REF(2);
- SCHEME_OBJECT *Next;
- XCrossingEvent *Input;
-
- PRIMITIVE_HEADER (2);
- CHECK_ARG(1, STRING_P);
- if (STRING_LENGTH(ARG_REF(1)) < sizeof(XCrossingEvent))
- error_bad_range_arg(1);
- CHECK_ARG(2, VECTOR_P);
- if (VECTOR_LENGTH(Result) < 17)
- error_bad_range_arg(2);
- Input = (XCrossingEvent *) STRING_ARG(1);
- Next = VECTOR_LOC(Result, 0);
- *Next++ = long_to_integer ((long) (Input->type)); /* 0 */
- *Next++ = long_to_integer ((long) (Input->serial)); /* 1 */
- *Next++ = BOOLEAN_TO_OBJECT(Input->send_event); /* 2 */
- *Next++ = long_to_integer ((long) (Input->display)); /* 3 */
- *Next++ = long_to_integer ((long) (Input->window)); /* 4 */
- *Next++ = long_to_integer ((long) (Input->root)); /* 5 */
- *Next++ = long_to_integer ((long) (Input->subwindow)); /* 6 */
- *Next++ = long_to_integer ((long) (Input->time)); /* 7 */
- *Next++ = long_to_integer ((long) (Input->x)); /* 8 */
- *Next++ = long_to_integer ((long) (Input->y)); /* 9 */
- *Next++ = long_to_integer ((long) (Input->x_root)); /* 10 */
- *Next++ = long_to_integer ((long) (Input->y_root)); /* 11 */
- *Next++ = long_to_integer ((long) (Input->mode)); /* 12 */
- *Next++ = long_to_integer ((long) (Input->detail)); /* 13 */
- *Next++ = BOOLEAN_TO_OBJECT(Input->same_screen); /* 14 */
- *Next++ = BOOLEAN_TO_OBJECT(Input->focus); /* 15 */
- *Next = long_to_integer ((long) (Input->state)); /* 16 */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XDecodeExposeEvent", prim_scxl_decode_expose, 2, 2, 0)
-{ /* (%XDecodeExposeEvent event vector) */
- SCHEME_OBJECT Result = ARG_REF(2);
- SCHEME_OBJECT *Next;
- XExposeEvent *Input;
-
- PRIMITIVE_HEADER (2);
- CHECK_ARG(1, STRING_P);
- if (STRING_LENGTH(ARG_REF(1)) < sizeof(XExposeEvent))
- error_bad_range_arg(1);
- CHECK_ARG(2, VECTOR_P);
- if (VECTOR_LENGTH(Result) < 10)
- error_bad_range_arg(2);
- Input = (XExposeEvent *) STRING_ARG(1);
- Next = VECTOR_LOC(Result, 0);
- *Next++ = long_to_integer ((long) (Input->type)); /* 0 */
- *Next++ = long_to_integer ((long) (Input->serial)); /* 1 */
- *Next++ = BOOLEAN_TO_OBJECT(Input->send_event); /* 2 */
- *Next++ = long_to_integer ((long) (Input->display)); /* 3 */
- *Next++ = long_to_integer ((long) (Input->window)); /* 4 */
- *Next++ = long_to_integer ((long) (Input->x)); /* 5 */
- *Next++ = long_to_integer ((long) (Input->y)); /* 6 */
- *Next++ = long_to_integer ((long) (Input->width)); /* 7 */
- *Next++ = long_to_integer ((long) (Input->height)); /* 8 */
- *Next = long_to_integer ((long) (Input->count)); /* 9 */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XDecodeKeyEvent", prim_scxl_decode_key, 2, 2, 0)
-{ /* (%XDecodeKeyEvent event vector) */
- SCHEME_OBJECT Result = ARG_REF(2);
- SCHEME_OBJECT *Next;
- XKeyEvent *Input;
-
- PRIMITIVE_HEADER (2);
- CHECK_ARG(1, STRING_P);
- if (STRING_LENGTH(ARG_REF(1)) < sizeof(XKeyEvent))
- error_bad_range_arg(1);
- CHECK_ARG(2, VECTOR_P);
- if (VECTOR_LENGTH(Result) < 15)
- error_bad_range_arg(2);
- Input = (XKeyEvent *) STRING_ARG(1);
- Next = VECTOR_LOC(Result, 0);
- *Next++ = long_to_integer ((long) (Input->type)); /* 0 */
- *Next++ = long_to_integer ((long) (Input->serial)); /* 1 */
- *Next++ = BOOLEAN_TO_OBJECT(Input->send_event); /* 2 */
- *Next++ = long_to_integer ((long) (Input->display)); /* 3 */
- *Next++ = long_to_integer ((long) (Input->window)); /* 4 */
- *Next++ = long_to_integer ((long) (Input->root)); /* 5 */
- *Next++ = long_to_integer ((long) (Input->subwindow)); /* 6 */
- *Next++ = long_to_integer ((long) (Input->time)); /* 7 */
- *Next++ = long_to_integer ((long) (Input->x)); /* 8 */
- *Next++ = long_to_integer ((long) (Input->y)); /* 9 */
- *Next++ = long_to_integer ((long) (Input->x_root)); /* 10 */
- *Next++ = long_to_integer ((long) (Input->y_root)); /* 11 */
- *Next++ = long_to_integer ((long) (Input->state)); /* 12 */
- *Next++ = long_to_integer ((long) (Input->keycode)); /* 13 */
- *Next = BOOLEAN_TO_OBJECT(Input->same_screen); /* 14 */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XDecodeMotionEvent", prim_scxl_decode_motion, 2, 2, 0)
-{ /* (%XDecodeMotionEvent event vector) */
- SCHEME_OBJECT Result = ARG_REF(2);
- SCHEME_OBJECT *Next;
- XMotionEvent *Input;
-
- PRIMITIVE_HEADER (2);
- CHECK_ARG(1, STRING_P);
- if (STRING_LENGTH(ARG_REF(1)) < sizeof(XMotionEvent))
- error_bad_range_arg(1);
- CHECK_ARG(2, VECTOR_P);
- if (VECTOR_LENGTH(Result) < 15)
- error_bad_range_arg(2);
- Input = (XMotionEvent *) STRING_ARG(1);
- Next = VECTOR_LOC(Result, 0);
- *Next++ = long_to_integer ((long) (Input->type)); /* 0 */
- *Next++ = long_to_integer ((long) (Input->serial)); /* 1 */
- *Next++ = BOOLEAN_TO_OBJECT(Input->send_event); /* 2 */
- *Next++ = long_to_integer ((long) (Input->display)); /* 3 */
- *Next++ = long_to_integer ((long) (Input->window)); /* 4 */
- *Next++ = long_to_integer ((long) (Input->root)); /* 5 */
- *Next++ = long_to_integer ((long) (Input->subwindow)); /* 6 */
- *Next++ = long_to_integer ((long) (Input->time)); /* 7 */
- *Next++ = long_to_integer ((long) (Input->x)); /* 8 */
- *Next++ = long_to_integer ((long) (Input->y)); /* 9 */
- *Next++ = long_to_integer ((long) (Input->x_root)); /* 10 */
- *Next++ = long_to_integer ((long) (Input->y_root)); /* 11 */
- *Next++ = long_to_integer ((long) (Input->state)); /* 12 */
- *Next++ = long_to_integer ((long) (Input->is_hint)); /* 13 */
- *Next = BOOLEAN_TO_OBJECT(Input->same_screen); /* 14 */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XDecodeUnknownEvent", Prim_scxl_decode_unknown, 2, 2, 0)
-{ /* (%XDecodeUnknownEvent event vector) */
- SCHEME_OBJECT Result = ARG_REF(2);
- SCHEME_OBJECT *Next;
- XAnyEvent *Input;
-
- PRIMITIVE_HEADER (2);
- CHECK_ARG(1, STRING_P);
- if (STRING_LENGTH(ARG_REF(1)) < sizeof(XAnyEvent))
- error_bad_range_arg(1);
- CHECK_ARG(2, VECTOR_P);
- if (VECTOR_LENGTH(Result) < 5)
- error_bad_range_arg(2);
- Input = (XAnyEvent *) STRING_ARG(1);
- Next = VECTOR_LOC(Result, 0);
- *Next++ = long_to_integer ((long) (Input->type)); /* 0 */
- *Next++ = long_to_integer ((long) (Input->serial)); /* 1 */
- *Next++ = BOOLEAN_TO_OBJECT(Input->send_event); /* 2 */
- *Next++ = long_to_integer ((long) (Input->display)); /* 3 */
- *Next = long_to_integer ((long) (Input->window)); /* 4 */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XDecodeWindowAttributes", Prim_scxl_decode_wind_attr, 2, 2, 0)
-{ /* (%XDecodeWindowAttributes attributes vector) */
- SCHEME_OBJECT Result = ARG_REF(2);
- SCHEME_OBJECT *Next;
- XWindowAttributes *Input;
-
- PRIMITIVE_HEADER (2);
- CHECK_ARG(1, STRING_P);
- if (STRING_LENGTH(ARG_REF(1)) < sizeof(XWindowAttributes))
- error_bad_range_arg(1);
- CHECK_ARG(2, VECTOR_P);
- if (VECTOR_LENGTH(Result) < 23)
- error_bad_range_arg(2);
- Input = (XWindowAttributes *) STRING_ARG(1);
- Next = VECTOR_LOC(Result, 0);
- *Next++ = long_to_integer ((long) (Input->x)); /* 0 */
- *Next++ = long_to_integer ((long) (Input->y)); /* 1 */
- *Next++ = long_to_integer ((long) (Input->width)); /* 2 */
- *Next++ = long_to_integer ((long) (Input->height)); /* 3 */
- *Next++ = long_to_integer ((long) (Input->border_width)); /* 4 */
- *Next++ = long_to_integer ((long) (Input->depth)); /* 5 */
- *Next++ = long_to_integer ((long) (Input->visual)); /* 6 */
- *Next++ = long_to_integer ((long) (Input->root)); /* 7 */
- *Next++ = long_to_integer ((long) (Input->class)); /* 8 */
- *Next++ = long_to_integer ((long) (Input->bit_gravity)); /* 9 */
- *Next++ = long_to_integer ((long) (Input->win_gravity)); /* 10 */
- *Next++ = long_to_integer ((long) (Input->backing_store)); /* 11 */
- *Next++ = long_to_integer ((long) (Input->backing_planes)); /* 12 */
- *Next++ = long_to_integer ((long) (Input->backing_pixel)); /* 13 */
- *Next++ = BOOLEAN_TO_OBJECT(Input->save_under); /* 14 */
- *Next++ = long_to_integer ((long) (Input->colormap)); /* 15 */
- *Next++ = BOOLEAN_TO_OBJECT(Input->map_installed); /* 16 */
- *Next++ = long_to_integer ((long) (Input->map_state)); /* 17 */
- *Next++ = long_to_integer ((long) (Input->all_event_masks)); /* 18 */
- *Next++ = long_to_integer ((long) (Input->your_event_mask)); /* 19 */
- *Next++ = long_to_integer ((long) (Input->do_not_propagate_mask)); /* 20 */
- *Next++ = BOOLEAN_TO_OBJECT(Input->override_redirect); /* 21 */
- *Next = long_to_integer ((long) (Input->screen)); /* 22 */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XDecodeXColor", Prim_scxl_decode_xcolor, 2, 2, 0)
-{ /* (%XDecodeXColor xcolor vector) */
- SCHEME_OBJECT Result = ARG_REF(2);
- SCHEME_OBJECT *Next;
- XColor *Input;
-
- PRIMITIVE_HEADER (2);
- CHECK_ARG(1, STRING_P);
- if (STRING_LENGTH(ARG_REF(1)) != sizeof(XColor))
- error_bad_range_arg(1);
- CHECK_ARG(2, VECTOR_P);
- if (VECTOR_LENGTH(Result) < 5)
- error_bad_range_arg(2);
- Input = (XColor *) STRING_ARG(1);
- Next = VECTOR_LOC(Result, 0);
- *Next++ = long_to_integer ((long) (Input->pixel)); /* 0 */
- *Next++ = long_to_integer ((long) (Input->red)); /* 1 */
- *Next++ = long_to_integer ((long) (Input->green)); /* 2 */
- *Next++ = long_to_integer ((long) (Input->blue)); /* 3 */
- *Next = long_to_integer ((long) (Input->flags)); /* 4 */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XDefaultColormap", Prim_scxl_default_colormap, 2, 2, 0)
-{ /* (%XDefaultColormap display screen) */
- PRIMITIVE_HEADER(2);
- PRIMITIVE_RETURN
- (long_to_integer
- ((long) XDefaultColormap((Display *) arg_integer(1),
- arg_integer(2))));
-}
-
-DEFINE_PRIMITIVE ("%XDefaultRootWindow", Prim_scxl_default_root_window,
- 1, 1, 0)
-{ /* (%XDefaultRootWindow display) */
- PRIMITIVE_HEADER(1);
- PRIMITIVE_RETURN
- (long_to_integer
- ((long) XDefaultRootWindow ((Display *) arg_integer(1))));
-}
-
-DEFINE_PRIMITIVE ("%XDefaultScreen", Prim_scxl_default_screen, 1, 1, 0)
-{ /* (%XDefaultScreen display) */
- PRIMITIVE_HEADER(1);
- PRIMITIVE_RETURN
- (long_to_integer
- ((long) XDefaultScreen((Display *) arg_integer(1))));
-}
-
-DEFINE_PRIMITIVE ("%XDestroyRegion", Prim_scxl_destroy_region, 1, 1, 0)
-{ /* (%XDestroyRegion region) */
- PRIMITIVE_HEADER (1);
- XDestroyRegion ((Region) arg_integer(1));
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XDestroyWindow", Prim_scxl_destroy_window, 2, 2, 0)
-{ /* (%XDestroyWindow display window) */
- PRIMITIVE_HEADER (2);
- XDestroyWindow((Display *) arg_integer(1),
- (Window) arg_integer(2));
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XDrawArc", Prim_scxl_draw_arc, 9, 9, 0)
-{ /* (%XDrawArc display window context
- x y width height angle1 angle2) */
- PRIMITIVE_HEADER (9);
- XDrawArc((Display *) arg_integer(1),
- (Drawable) arg_integer(2),
- (GC) arg_integer(3),
- (int) arg_integer(4),
- (int) arg_integer(5),
- (unsigned int) arg_integer(6),
- (unsigned int) arg_integer(7),
- (unsigned int) arg_integer(8),
- (unsigned int) arg_integer(9));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XDrawLine", Prim_scxl_draw_line, 7, 7, 0)
-{ /* (%XDrawLine display window context x1 y1 x2 y2) */
- PRIMITIVE_HEADER (7);
- XDrawLine((Display *) arg_integer(1),
- (Drawable) arg_integer(2),
- (GC) arg_integer(3),
- (int) arg_integer(4),
- (int) arg_integer(5),
- (int) arg_integer(6),
- (int) arg_integer(7));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XDrawRectangle", Prim_scxl_draw_rectangle, 7, 7, 0)
-{ /* (%XDrawRectangle display window context x y width height) */
- PRIMITIVE_HEADER (7);
- XDrawRectangle((Display *) arg_integer(1),
- (Drawable) arg_integer(2),
- (GC) arg_integer(3),
- (int) arg_integer(4),
- (int) arg_integer(5),
- (unsigned int) arg_integer(6),
- (unsigned int) arg_integer(7));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XFillArc", Prim_scxl_fill_arc, 9, 9, 0)
-{ /* (%XFillArc display window context
- x y width height angle1 angle2) */
- PRIMITIVE_HEADER (9);
- XFillArc((Display *) arg_integer(1),
- (Drawable) arg_integer(2),
- (GC) arg_integer(3),
- (int) arg_integer(4),
- (int) arg_integer(5),
- (unsigned int) arg_integer(6),
- (unsigned int) arg_integer(7),
- (unsigned int) arg_integer(8),
- (unsigned int) arg_integer(9));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XFillRectangle", Prim_scxl_fill_rectangle, 7, 7, 0)
-{ /* (%XFillRectangle display window context x y width height) */
- PRIMITIVE_HEADER (7);
- XFillRectangle((Display *) arg_integer(1),
- (Drawable) arg_integer(2),
- (GC) arg_integer(3),
- (int) arg_integer(4),
- (int) arg_integer(5),
- (unsigned int) arg_integer(6),
- (unsigned int) arg_integer(7));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XFlush", Prim_scxl_flush, 1, 1, 0)
-{ /* (%XFlush display) */
- PRIMITIVE_HEADER (1);
- XFlush((Display *) arg_integer(1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XFreeColormap", Prim_scxl_free_colormap, 2, 2, 0)
-{ /* (%XFreeColormap display colormap) */
- PRIMITIVE_HEADER(2);
- XFreeColormap((Display *) arg_integer(1), (Colormap) arg_integer(2));
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XFreeGC", Prim_scxl_free_gc, 2, 2, 0)
-{ /* (%XFreeGC display graphic-context) */
- PRIMITIVE_HEADER(2);
- XFreeGC((Display *) arg_integer(1), (GC) arg_integer(2));
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XGetDefault", Prim_scxl_get_default, 3, 3, 0)
-{ /* (%XGetDefault display program option) */
- PRIMITIVE_HEADER(3);
- PRIMITIVE_RETURN
- (char_pointer_to_string
- ((unsigned char *) XGetDefault((Display *) arg_integer(1),
- STRING_ARG(2),
- STRING_ARG(3))));
-}
-
-DEFINE_PRIMITIVE ("%XGetWindowAttributes", Prim_scxl_get_wind_attr, 3, 3, 0)
-{ /* (%XGetWindowAttributes display window attributes-to-fill) */
- PRIMITIVE_HEADER(3);
- CHECK_ARG(3, STRING_P);
- if (STRING_LENGTH(ARG_REF(3)) < sizeof(XWindowAttributes))
- error_bad_range_arg(3);
- PRIMITIVE_RETURN
- (long_to_integer
- ((long)
- XGetWindowAttributes((Display *) arg_integer(1),
- (Window) arg_integer(2),
- (XWindowAttributes *) STRING_ARG(3))));
-}
-
-DEFINE_PRIMITIVE ("%XIntersectRegion", Prim_scxl_intersect_reg, 3, 3, 0)
-{ /* (%XIntersectRegion source1 source2 dest) */
- PRIMITIVE_HEADER (3);
- XIntersectRegion((Region) arg_integer(1),
- (Region) arg_integer(2),
- (Region) arg_integer(3));
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XLoadFont", Prim_scxl_load_font, 2, 2, 0)
-{ /* (%XLoadFont display name-string) */
- PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN
- (long_to_integer ((long) XLoadFont((Display *) arg_integer(1),
- STRING_ARG(2))));
-}
-
-DEFINE_PRIMITIVE ("%XMapWindow", Prim_scxl_map_window, 2, 2, 0)
-{ /* (%XMapWindow display window) */
- PRIMITIVE_HEADER(2);
- XMapWindow((Display *) arg_integer(1),
- (Window) arg_integer(2));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XNextEvent", Prim_scxl_next_event, 2, 2, 0)
-{ /* (%XNextEvent display returned-event) */
- PRIMITIVE_HEADER (2);
- CHECK_ARG(2, STRING_P);
- if (STRING_LENGTH(ARG_REF(2)) < sizeof(XEvent))
- error_bad_range_arg(2);
- XNextEvent((Display *) arg_integer(1),
- (XEvent *) STRING_ARG(2));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XOpenDisplay", Prim_scxl_open_display, 1, 1, 0)
-{ /* (%XOpenDisplay string) */
- PRIMITIVE_HEADER (1);
- {
- /* Changed 7/95 by Nick in an attempt to fix problem Hal was having with SWAT over PPP (i.e. slow connections) */
- Display * display;
- block_signals ();
- display = XOpenDisplay(STRING_ARG(1));
- unblock_signals ();
- PRIMITIVE_RETURN (long_to_integer((long) display));
- }
-}
-
-DEFINE_PRIMITIVE ("%XPending", Prim_scxl_pending, 1, 1, 0)
-{ /* (%XPending display) */
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN
- (long_to_integer(XPending ((Display *) arg_integer(1))));
-}
-
-DEFINE_PRIMITIVE ("%XPutBackEvent", Prim_scxl_put_back_event, 2, 2, 0)
-{ /* (%XPutBackEvent display event) */
- PRIMITIVE_HEADER (2);
- CHECK_ARG(2, STRING_P);
- if (STRING_LENGTH(ARG_REF(2)) < sizeof(XEvent))
- error_bad_range_arg(2);
- XPutBackEvent ((Display *) arg_integer(1),
- (XEvent *) STRING_ARG(2));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XQueryPointer", Prim_scxl_query_pointer, 3, 3, 0)
-{ /* (%XQueryPointer display window result-vector) */
- SCHEME_OBJECT Result = ARG_REF(3);
- SCHEME_OBJECT *Next;
- Window Root=0, Child=0;
- int Root_X=0, Root_Y=0, Win_X=0, Win_Y=0;
- unsigned int Keys_Buttons=0;
- Bool result_status;
-
- PRIMITIVE_HEADER (3);
- CHECK_ARG(3, VECTOR_P);
- if (VECTOR_LENGTH(Result) < 8) error_bad_range_arg(3);
- result_status = XQueryPointer((Display *) arg_integer(1),
- (Window) arg_integer(2),
- &Root, &Child, &Root_X, &Root_Y,
- &Win_X, &Win_Y, &Keys_Buttons);
- Next = VECTOR_LOC(Result, 0);
- *Next++ = BOOLEAN_TO_OBJECT(result_status); /* 0 */
- *Next++ = long_to_integer ((long) Root); /* 1 */
- *Next++ = long_to_integer ((long) Child); /* 2 */
- *Next++ = long_to_integer ((long) Root_X); /* 3 */
- *Next++ = long_to_integer ((long) Root_Y); /* 4 */
- *Next++ = long_to_integer ((long) Win_X); /* 5 */
- *Next++ = long_to_integer ((long) Win_Y); /* 6 */
- *Next++ = long_to_integer ((long) Keys_Buttons); /* 7 */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XQueryTree", Prim_query_tree, 2, 2, 0)
-{ /* (%XQueryTree display window)
- returns a vector of #(root parent . kids)
- */
- SCHEME_OBJECT Kid_Return;
- Window Root, Parent, *Kids;
- unsigned int NKids, i;
-
- PRIMITIVE_HEADER (2);
- if (XQueryTree((Display *) arg_integer(1), (Window) arg_integer(2),
- &Root, &Parent, &Kids, &NKids)==0)
- { error_external_return();
- }
- Kid_Return = allocate_marked_vector(TC_VECTOR, NKids+2, true);
- VECTOR_SET(Kid_Return, 0, long_to_integer((long) Root));
- VECTOR_SET(Kid_Return, 1, long_to_integer((long) Parent));
- for (i=0; i < NKids; i++)
- VECTOR_SET(Kid_Return, i+2, long_to_integer((long) Kids[i]));
- XFree(Kids);
- PRIMITIVE_RETURN (Kid_Return);
-}
-
-DEFINE_PRIMITIVE ("%XScreenCount", Prim_scxl_screencount, 1, 1, 0)
-{ /* (%XScreenCount display) */
- PRIMITIVE_HEADER(1);
- PRIMITIVE_RETURN (long_to_integer
- (XScreenCount((Display *) arg_integer(1))));
-}
-
-DEFINE_PRIMITIVE ("%XSetForeground", Prim_scxl_set_foreground, 3, 3, 0)
-{ /* (%XSetForeground display context pixel) */
- PRIMITIVE_HEADER(3);
- XSetForeground((Display *) arg_integer(1),
- (GC) arg_integer(2),
- arg_integer(3));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-
-DEFINE_PRIMITIVE ("%XSetFunction", Prim_scxl_set_function, 3, 3, 0)
-{ /* (%XSetFunction display context function_number) */
- PRIMITIVE_HEADER(3);
- XSetFunction((Display *) arg_integer(1),
- (GC) arg_integer(2),
- arg_integer(3));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-
-DEFINE_PRIMITIVE ("%XSetRegion", Prim_scxl_set_region, 3, 3, 0)
-{ /* (%XSetForeground display gc region) */
- PRIMITIVE_HEADER(3);
- XSetRegion((Display *) arg_integer(1),
- (GC) arg_integer(2),
- (Region) arg_integer(3));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XStoreName", Prim_scxl_store_name, 3, 3, 0)
-{ /* (%XStoreName display window title-string */
- PRIMITIVE_HEADER (3);
- XStoreName((Display *) arg_integer(1),
- (Window) arg_integer(2),
- STRING_ARG(3));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XSubtractRegion", Prim_scxl_subtract_reg, 3, 3, 0)
-{ /* (%XSubtractRegion source1 source2 dest) */
- PRIMITIVE_HEADER (3);
- XSubtractRegion((Region) arg_integer(1),
- (Region) arg_integer(2),
- (Region) arg_integer(3));
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XTranslateCoordinates", Prim_scxl_translate_coords,
- 6, 6, 0)
-{ /* (%XTranslateCoordinates display old-window new-window x y vector)
- */
- int X, Y;
- Window W;
- SCHEME_OBJECT Vect;
- Boolean status;
- PRIMITIVE_HEADER (6);
- Vect = VECTOR_ARG(6);
- if (VECTOR_LENGTH(Vect) < 4) error_bad_range_arg(6);
- status = XTranslateCoordinates((Display *) arg_integer(1),
- (Window) arg_integer(2),
- (Window) arg_integer(3),
- (int) arg_integer(4),
- (int) arg_integer(5),
- &X, &Y, &W);
- VECTOR_SET(Vect, 0, BOOLEAN_TO_OBJECT(status));
- VECTOR_SET(Vect, 1, long_to_integer((long) X));
- VECTOR_SET(Vect, 2, long_to_integer((long) Y));
- VECTOR_SET(Vect, 3, long_to_integer((long) W));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XUnionRegion", Prim_scxl_union_reg, 3, 3, 0)
-{ /* (%XUnionRegion source1 source2 dest) */
- PRIMITIVE_HEADER (3);
- XUnionRegion((Region) arg_integer(1),
- (Region) arg_integer(2),
- (Region) arg_integer(3));
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XUnionRectSpecsWithRegion!", Prim_scxl_union_rectspecs, 6, 6, 0)
-{ /* (%XUnionRectSpecsWithRegion! x y width height inregion outregion) */
- XRectangle Rect;
- PRIMITIVE_HEADER (6);
- Rect.x = arg_integer(1);
- Rect.y = arg_integer(2);
- Rect.width = arg_integer(3);
- Rect.height = arg_integer(4);
- XUnionRectWithRegion(&Rect,
- (Region) (arg_integer (5)),
- (Region) (arg_integer (6)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%XUnloadFont", Prim_scxl_unload_font, 2, 2, 0)
-{ /* (%XUnloadFont display font) */
- PRIMITIVE_HEADER(2);
- XUnloadFont((Display *) arg_integer(1), (Font) arg_integer(2));
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-
-/* Data structure constructors. These are represented as strings to */
-/* circumvent garbage collection */
-
-DEFINE_PRIMITIVE ("%XMake-Color", Prim_scxl_make_color, 0, 0, 0)
-{ /* (%XMake-Color) */
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN(allocate_string(sizeof(XColor)));
-}
-
-DEFINE_PRIMITIVE ("%XMake-Event", Prim_scxl_make_event, 0, 0, 0)
-{ /* (%XMake-Event) */
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN(allocate_string(sizeof(XEvent)));
-}
-
-DEFINE_PRIMITIVE ("%XMake-GCValues", Prim_scxl_make_gc_values, 0, 0, 0)
-{ /* (%XMake-GCValues) */
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN(allocate_string(sizeof(XGCValues)));
-}
-
-DEFINE_PRIMITIVE ("%XMake-GetWindowAttributes", Prim_scxl_make_get_wind_attr,
- 0, 0, 0)
-{ /* (%XMake-GetWindowAttributes) */
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN(allocate_string(sizeof(XWindowAttributes)));
-}
-
-DEFINE_PRIMITIVE ("%XMake-SetWindowAttributes", Prim_scxl_make_set_wind_attr,
- 0, 0, 0)
-{ /* (%XMake-SetWindowAttributes) */
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN(allocate_string(sizeof(XSetWindowAttributes)));
-}
-
-/* Mutators */
-
-#define Mutator(StructType, Field, FieldType, Converter) \
-{ \
- PRIMITIVE_HEADER(2); \
- CHECK_ARG(1, STRING_P); \
- if (STRING_LENGTH(ARG_REF(1)) < sizeof(StructType)) \
- error_bad_range_arg(1); \
- ((StructType *) (STRING_ARG(1)))->Field = \
- ((FieldType) Converter(2)); \
- PRIMITIVE_RETURN (UNSPECIFIC); \
-}
-
-DEFINE_PRIMITIVE ("%XSetWindowAttributes-Event_Mask!",
- Prim_scxl_XSetWindowAttributes_Event_Mask_bang,
- 2, 2, 0)
- Mutator(XSetWindowAttributes, event_mask, long, arg_integer)
-
-static int
-DEFUN (x_io_error_handler, (display),
- Display * display)
-{
- fprintf (stderr, "\nX IO Error on display 0x%x\n", display);
- error_external_return ();
-}
-
-void DEFUN (Scheme_x_error_handler, (display, error_event),
- Display * display AND
- XErrorEvent * error_event)
-{
- char buffer [2048];
- XGetErrorText (display, (error_event -> error_code),
- buffer, (sizeof (buffer)));
- fprintf (stderr, "\nX Error: %s\n", buffer);
- fprintf (stderr, " Request code: %d\n",
- (error_event -> request_code));
- fprintf (stderr, " Error serial: 0x%x\n",
- (error_event -> serial));
- fprintf (stderr, " Display: %d (0x%x)\n",
- error_event->display, error_event->display);
- fprintf (stderr, " Resource ID: %d (0x%x)\n",
- error_event->resourceid, error_event->resourceid);
- fprintf (stderr, " Minor code: %d (0x%x)\n",
- error_event->minor_code, error_event->minor_code);
- fflush (stderr);
-}
-
-static int
-DEFUN (Scheme_low_x_error_handler, (display, error_event),
- Display * display AND
- XErrorEvent * error_event)
-{ Scheme_x_error_handler(display, error_event);
- error_external_return ();
-}
-
-DEFINE_PRIMITIVE("%XInitSCXL!", Prim_scxl_init, 0, 0, 0)
-{ extern int _XDefaultError();
- PRIMITIVE_HEADER (0);
- XSetErrorHandler (Scheme_low_x_error_handler);
- XSetIOErrorHandler (x_io_error_handler);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE("%XSync", Prim_scxl_sync, 2, 2, 0)
-{ PRIMITIVE_HEADER (2);
- XSync((Display *) arg_integer(1), BOOLEAN_ARG(2));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE("%XSynchronize", Prim_scxl_synchronize, 2, 2, 0)
-{ PRIMITIVE_HEADER (2);
- XSynchronize((Display *) arg_integer(1), BOOLEAN_ARG(2));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-SCHEME_OBJECT Debug_State_Flag;
-
-DEFINE_PRIMITIVE("%SetDebugState!", Prim_scxl_state, 1, 1, 0)
-{ PRIMITIVE_HEADER(1);
- Debug_State_Flag = ARG_REF(1);
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-
-extern char *EXFUN (dload_initialize_file, (void));
-
-char *
- DEFUN_VOID (dload_initialize_file)
-{ declare_primitive("%XAllocNamedColor", Prim_scxl_allocated_named_color,
- 5, 5, 0);
- declare_primitive("%XChangeWindowAttributes", Prim_scxl_change_wind_attr,
- 4, 4, 0);
- declare_primitive("%XCheckMaskEvent", Prim_scxl_check_mask_event, 3, 3, 0);
- declare_primitive("%XClearArea", Prim_scxl_clear_area, 7, 7, 0);
- declare_primitive("%XClearWindow", Prim_scxl_clear_window, 2, 2, 0);
- declare_primitive("%XCloseDisplay", Prim_scxl_close, 1, 1, 0);
- declare_primitive("%XConnectionNumber", Prim_scxl_connection_number, 1, 1, 0);
- declare_primitive("%XCreateGC", Prim_scxl_create_gc, 4, 4, 0);
- declare_primitive("%XCreateRegion", Prim_scxl_create_region, 0, 0, 0);
- declare_primitive("%XCreateSimpleWindow", Prim_scxl_create_simple_window,
- 9, 9, 0);
- declare_primitive("%XDecodeButtonEvent", prim_scxl_decode_button, 2, 2, 0);
- declare_primitive("%XDecodeConfigureEvent",
- prim_scxl_decode_config, 2, 2, 0);
- declare_primitive("%XDecodeCrossingEvent", prim_scxl_decode_crossing, 2, 2, 0);
- declare_primitive("%XDecodeExposeEvent", prim_scxl_decode_expose, 2, 2, 0);
- declare_primitive("%XDecodeKeyEvent", prim_scxl_decode_key, 2, 2, 0);
- declare_primitive("%XDecodeMotionEvent", prim_scxl_decode_motion, 2, 2, 0);
- declare_primitive("%XDecodeUnknownEvent", Prim_scxl_decode_unknown, 2, 2, 0);
- declare_primitive("%XDecodeWindowAttributes", Prim_scxl_decode_wind_attr, 2, 2, 0);
- declare_primitive("%XDecodeXColor", Prim_scxl_decode_xcolor, 2, 2, 0);
- declare_primitive("%XDefaultColormap", Prim_scxl_default_colormap, 2, 2, 0);
- declare_primitive("%XDefaultRootWindow", Prim_scxl_default_root_window,
- 1, 1, 0);
- declare_primitive("%XDefaultScreen", Prim_scxl_default_screen, 1, 1, 0);
- declare_primitive("%XDestroyRegion", Prim_scxl_destroy_region, 1, 1, 0);
- declare_primitive("%XDestroyWindow", Prim_scxl_destroy_window, 2, 2, 0);
- declare_primitive("%XDrawArc", Prim_scxl_draw_arc, 9, 9, 0);
- declare_primitive("%XDrawLine", Prim_scxl_draw_line, 7, 7, 0);
- declare_primitive("%XDrawRectangle", Prim_scxl_draw_rectangle, 7, 7, 0);
- declare_primitive("%XFillArc", Prim_scxl_fill_arc, 9, 9, 0);
- declare_primitive("%XFillRectangle", Prim_scxl_fill_rectangle, 7, 7, 0);
- declare_primitive("%XFlush", Prim_scxl_flush, 1, 1, 0);
- declare_primitive("%XFreeColormap", Prim_scxl_free_colormap, 2, 2, 0);
- declare_primitive("%XFreeGC", Prim_scxl_free_gc, 2, 2, 0);
- declare_primitive("%XGetDefault", Prim_scxl_get_default, 3, 3, 0);
- declare_primitive("%XGetWindowAttributes", Prim_scxl_get_wind_attr, 3, 3, 0);
- declare_primitive("%XIntersectRegion", Prim_scxl_intersect_reg, 3, 3, 0);
- declare_primitive("%XLoadFont", Prim_scxl_load_font, 2, 2, 0);
- declare_primitive("%XMapWindow", Prim_scxl_map_window, 2, 2, 0);
- declare_primitive("%XNextEvent", Prim_scxl_next_event, 2, 2, 0);
- declare_primitive("%XOpenDisplay", Prim_scxl_open_display, 1, 1, 0);
- declare_primitive("%XPending", Prim_scxl_pending, 1, 1, 0);
- declare_primitive("%XPutBackEvent", Prim_scxl_put_back_event, 2, 2, 0);
- declare_primitive("%XQueryPointer", Prim_scxl_query_pointer, 3, 3, 0);
- declare_primitive("%XQueryTree", Prim_query_tree, 2, 2, 0);
- declare_primitive("%XScreenCount", Prim_scxl_screencount, 1, 1, 0);
- declare_primitive("%XSetForeground", Prim_scxl_set_foreground, 3, 3, 0);
- declare_primitive("%XSetFunction", Prim_scxl_set_function, 3, 3, 0);
- declare_primitive("%XSetRegion", Prim_scxl_set_region, 3, 3, 0);
- declare_primitive("%XStoreName", Prim_scxl_store_name, 3, 3, 0);
- declare_primitive("%XSubtractRegion", Prim_scxl_subtract_reg, 3, 3, 0);
- declare_primitive("%XTranslateCoordinates", Prim_scxl_translate_coords,
- 6, 6, 0);
- declare_primitive("%XUnionRegion", Prim_scxl_union_reg, 3, 3, 0);
- declare_primitive("%XUnionRectSpecsWithRegion!", Prim_scxl_union_rectspecs, 6, 6, 0);
- declare_primitive("%XUnloadFont", Prim_scxl_unload_font, 2, 2, 0);
- declare_primitive("%XMake-Color", Prim_scxl_make_color, 0, 0, 0);
- declare_primitive("%XMake-Event", Prim_scxl_make_event, 0, 0, 0);
- declare_primitive("%XMake-GCValues", Prim_scxl_make_gc_values, 0, 0, 0);
- declare_primitive("%XMake-GetWindowAttributes", Prim_scxl_make_get_wind_attr,
- 0, 0, 0);
- declare_primitive("%XMake-SetWindowAttributes", Prim_scxl_make_set_wind_attr,
- 0, 0, 0);
- declare_primitive("%XSetWindowAttributes-Event_Mask!",
- Prim_scxl_XSetWindowAttributes_Event_Mask_bang,
- 2, 2, 0);
- declare_primitive("%XInitSCXL!", Prim_scxl_init, 0, 0, 0);
- declare_primitive("%XSync", Prim_scxl_sync, 2, 2, 0);
- declare_primitive("%XSynchronize", Prim_scxl_synchronize, 2, 2, 0);
- declare_primitive("%SetDebugState!", Prim_scxl_state, 1, 1, 0);
- return "#SCXL";
-}
+++ /dev/null
-/* -*- C -*-
-/* Uses tk-c.c - Support routines for Tk Widgets called from Scheme */
-
-#include "scheme.h"
-#include "prims.h"
-#include "ansidecl.h"
-#include "X11/Xlib.h"
-#include "tk.h"
-#include "tkInt.h" /* For TkWindow */
-
-DEFINE_PRIMITIVE ("%tclGlobalEval", Prim_tcl_eval, 2, 2, 0)
-{ /* (%tclGlobalEval TK-main-window string) */
- Tcl_Interp *tclInterp;
-
- PRIMITIVE_HEADER(2);
- tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
- if (Tcl_GlobalEval(tclInterp, STRING_ARG(2)) != TCL_OK)
- { fprintf(stderr, "%tclGlobalEval: error '%s'\n",
- tclInterp->result);
- error_external_return();
- }
- PRIMITIVE_RETURN (char_pointer_to_string
- ((unsigned char *) tclInterp->result));
-}
-
-long TKEvent = true;
-DEFINE_PRIMITIVE ("%tkCompletelyHandlesEvent?",
- Prim_tk_completely_handles_event, 1, 1, 0)
-{ /* (%tkCompletelyHandlesEvent? event) */
- XEvent *Event;
-
- PRIMITIVE_HEADER (1);
-
- /* We return 0 if there is a bad argument rather than generating */
- /* and error. This avoids the need to put a */
- /* dynamic wind around calls to this primitive. */
- /* Error checking is */
- /* done at the next level up, in tk-completely-handles-event? */
-
- if (!STRING_P(ARG_REF(1))) PRIMITIVE_RETURN(LONG_TO_UNSIGNED_FIXNUM(0));
- if (STRING_LENGTH(ARG_REF(1)) < sizeof(XEvent))
- PRIMITIVE_RETURN(LONG_TO_UNSIGNED_FIXNUM(0));
-
-
- Event = (XEvent *) STRING_ARG(1);
- TKEvent = true;
- Tk_HandleEvent(Event);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT(TKEvent));
-}
-
-void OurTopLevelGeometryProc(ClientData CallBackHash, XEvent *Event)
-{ /* Based on the code for PackStructureProc in tkPack.c. That code */
- /* handles four kinds of events: ConfigureNotify, DestroyNotify, */
- /* MapNotify, and UnmapNotify. Here, we consider only the */
- /* ConfigureNotify case and reflect it back into Scheme. */
-
- if (Event->type == ConfigureNotify)
- {
-#include <string.h>
- extern void
- AddSchemeCallBack(int argc, char **argv, long *countv);
- char *argv[2], CallBackNumber[50],
- EventChars[1+sizeof(XConfigureEvent)];
- long Counts[2];
-
- XConfigureEvent *E = (XConfigureEvent *) Event;
- Counts[0] = sprintf(CallBackNumber, "%d", (long) CallBackHash);
- argv[0] = CallBackNumber;
- Counts[1] = sizeof(XConfigureEvent);
- argv[1] = (char *) E;
- AddSchemeCallBack(2, argv, Counts);
- }
-}
-
-DEFINE_PRIMITIVE ("%tkCreateTopLevelWindow", Prim_tk_create_tl_window,
- 3, 3, 0)
-{ /* (%tkCreateTopLevelWindow MainWindow Name CallBackHash) */
- Tk_Window Result;
- Tcl_Interp *tclInterp;
-
- PRIMITIVE_HEADER (3);
- tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
- Result =
- Tk_CreateWindow(tclInterp, (Tk_Window) arg_integer(1),
- STRING_ARG(2), "");
- if (Result == NULL)
- { fprintf(stderr, "%tkCreateTopLevelWindow: error '%s'\n",
- tclInterp->result);
- error_external_return();
- }
- Tk_SetWindowBackground(Result,
- BlackPixelOfScreen(Tk_Screen(Result)));
- Tk_CreateEventHandler(Result,
- StructureNotifyMask,
- OurTopLevelGeometryProc,
- (ClientData) arg_integer(3));
- PRIMITIVE_RETURN (long_to_integer((long) Result));
-}
-\f
-char *TK_CallBack_List;
-long NChars_In_TK_Callbacks = 0;
-
-DEFINE_PRIMITIVE ("%tkDoEvents", Prim_tk_do_events, 0, 0, 0)
-{ /* (%tkDoEvents) */
- extern void DoTkEvents ();
- PRIMITIVE_HEADER (0);
- DoTkEvents();
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%tkDrainCallBacks", Prim_tk_drain, 2, 2, 0)
-{ /* (%tkDrainCallBacks nchar string) */
- /* Returns the number of characters available in the call back */
- /* string if there is NOT enough room in the string to hold all of */
- /* the characters. Otherwise, the characters are written into */
- /* STRING, C variable is cleared, space freed and the primitive */
- /* returns #F. */
-
- long NCharsInString;
- unsigned char *StringSpace;
-
- PRIMITIVE_HEADER (2);
- NCharsInString = arg_integer(1);
- StringSpace = (unsigned char *) STRING_ARG(2);
- if ((NChars_In_TK_Callbacks != 0) &&
- (NCharsInString >= NChars_In_TK_Callbacks))
- { fast unsigned char * scan_result = StringSpace;
- fast unsigned char * end_result = (scan_result + NChars_In_TK_Callbacks);
- fast unsigned char * data = (unsigned char *) TK_CallBack_List;
- while (scan_result < end_result)
- (*scan_result++) = (*data++);
- SET_STRING_LENGTH (ARG_REF(2), NChars_In_TK_Callbacks);
- /* free(TK_CallBack_List); */
- /* TK_CallBack_List = NULL; */
- NChars_In_TK_Callbacks = 0;
- PRIMITIVE_RETURN (SHARP_F);
- }
- else
- { PRIMITIVE_RETURN(long_to_integer(NChars_In_TK_Callbacks));
- }
-}
-
-void OurEventHandler(ClientData ignored_data, XEvent *ignored_event)
-{ TKEvent = false;
-}
-
-DEFINE_PRIMITIVE ("%tkGenerateSchemeEvent",
- Prim_tk_generate_scheme_event, 2, 2, 0)
-{ /* (%tkGenerateSchemeEvent mask TkWindow) */
- PRIMITIVE_HEADER (2);
- if (arg_integer(1) == 0)
- Tk_DeleteEventHandler((Tk_Window) arg_integer(2),
- arg_integer(1),
- OurEventHandler,
- (ClientData) 0);
- else Tk_CreateEventHandler((Tk_Window) arg_integer(2),
- arg_integer(1),
- OurEventHandler,
- (ClientData) 0);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%tkInit", Prim_tk_init, 2, 2, 0)
-{ /* (%tkInit display name) */
- extern long /*Tk_Window*/ InitTkApplication (long /*Display*/ *display,
- char *Name);
- PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN((long_to_integer
- ((long) InitTkApplication
- ((long /*Display*/ *) arg_integer(1),
- STRING_ARG(2)))));
-}
-
-typedef int (*cmdProc) (ClientData clientData, Tcl_Interp *interp,
- int argc, char **argv);
-
-#define NTKCommands 14
-cmdProc TkCommandTable[] =
-{ Tk_AfterCmd, Tk_BindCmd, Tk_DestroyCmd, Tk_FocusCmd, Tk_GrabCmd,
- Tk_OptionCmd, Tk_PackCmd, Tk_PlaceCmd, Tk_SelectionCmd,
- Tk_TkCmd, Tk_TkwaitCmd, Tk_UpdateCmd, Tk_WinfoCmd, Tk_WmCmd
-};
-
-DEFINE_PRIMITIVE ("%tkInvokeCommand", Prim_tk_invoke, 2, LEXPR, 0)
-{ /* (%tkInvokeCommand commandnumber tkmainwindow . argstrings) */
-#include "tkInt.h"
- long WhichCommand, NArgsToPass, i, Result;
- char **Argv;
- SCHEME_OBJECT SchemeResult;
- Tcl_Interp *tclInterp;
-
- PRIMITIVE_HEADER(LEXPR);
- WhichCommand = arg_integer(1);
- tclInterp = (((TkWindow *) arg_integer(2))->mainPtr)->interp;
- if (WhichCommand > NTKCommands) error_bad_range_arg(1);
- NArgsToPass = LEXPR_N_ARGUMENTS() - 1;
- Argv = (char **) malloc((sizeof (char *)) * NArgsToPass);
- Argv[0] = "<InvokedFromScheme>";
- for (i=1; i < NArgsToPass; i++) Argv[i] = STRING_ARG(i+2);
- Result = (TkCommandTable[WhichCommand])((ClientData) arg_integer(2),
- tclInterp,
- NArgsToPass,
- Argv);
- free(Argv);
- if (Result != TCL_OK)
- { fprintf(stderr, "tkInvokeCommand error: %s\n", tclInterp->result);
- error_external_return();
- }
-
- SchemeResult = (char_pointer_to_string
- ((unsigned char *) tclInterp->result));
- Tcl_ResetResult(tclInterp);
- PRIMITIVE_RETURN(SchemeResult);
-}
-
-DEFINE_PRIMITIVE ("%tkKillApplication", Prim_tk_kill_app, 1, 1, 0)
-{ /* (%tkKillApplication TKMainWindow) */
- Tk_Window TKWin;
- Tcl_Interp *Interp;
-
- PRIMITIVE_HEADER (1);
- TKWin = (Tk_Window) arg_integer(1);
- Interp = (((TkWindow *) TKWin)->mainPtr)->interp;
- Tk_DestroyWindow(TKWin);
- Tcl_DeleteInterp(Interp);
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-void Our_Geometry_Manager(ClientData clientData, Tk_Window tkwin)
-{ extern void AddSchemeCallBack(int argc, char **argv, long *countv);
- char *argv[1], CallBackNumber[50];
- long counts[1];
-
- counts[0] = sprintf(CallBackNumber, "%d", (long) clientData);
- argv[0] = CallBackNumber;
- AddSchemeCallBack(1, argv, counts);
-}
-
-DEFINE_PRIMITIVE ("%tkManageGeometry", Prim_tk_manage_geom, 2, 2, 0)
-{ /* (%tkManageGeometry tkwin object-hash) */
- PRIMITIVE_HEADER (2);
- if (ARG_REF(2) == SHARP_F)
- Tk_ManageGeometry((Tk_Window) arg_integer(1), NULL, 0);
- else Tk_ManageGeometry((Tk_Window) arg_integer(1),
- Our_Geometry_Manager,
- (ClientData) arg_integer(2));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%tkMapWidget", Prim_tk_map_widget, 6, 6, 0)
-{ extern char * tk_map_widget (long /*Button*/ *button,
- long /*Tk_Window*/ tkMainWindow,
- char *name,
- long /*Window*/ xwindow,
- int x, int y);
- PRIMITIVE_HEADER(6);
- PRIMITIVE_RETURN(char_pointer_to_string
- ((unsigned char *)
- tk_map_widget((long /*Button*/ *) arg_integer(1),
- (long /*Tk_Window*/) arg_integer(2),
- STRING_ARG(3),
- (long /*Window*/) arg_integer(4),
- arg_integer(5),
- arg_integer(6))));
-
-}
-
-DEFINE_PRIMITIVE ("%tkMapWindow", Prim_tk_map_window, 1, 1, 0)
-{ /* (%tkMapWindow TkWindow) returns X Window ID */
- Tk_Window tkwin;
-
- PRIMITIVE_HEADER(1);
- tkwin = (Tk_Window) arg_integer(1);
- Tk_MapWindow(tkwin);
- PRIMITIVE_RETURN(long_to_integer((long) Tk_WindowId(tkwin)));
-}
-
-DEFINE_PRIMITIVE ("%tkMoveWindow", Prim_tk_move, 3, 3, 0)
-{ /* (%tkMoveWindow tkwin x y) */
- PRIMITIVE_HEADER (3);
- Tk_MoveWindow((Tk_Window) arg_integer(1),
- (int) arg_integer(2),
- (int) arg_integer(3));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%tkMoveResizeWindow", Prim_tk_move_resize, 5, 5, 0)
-{ /* (%tkMoveResizeWindow tkwin x y width height) */
- PRIMITIVE_HEADER (5);
- Tk_MoveResizeWindow((Tk_Window) arg_integer(1),
- (int) arg_integer(2), (int) arg_integer(3),
- (unsigned int) arg_integer(4),
- (unsigned int) arg_integer(5));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%tkNextWakeup", Prim_tk_next_wakeup, 0, 0, 0)
-{ /* (%tkNextWakeup) */
- /* If the call back list isn't empty, wake up right away. */
- extern long tk_GetIntervalToNextEvent();
- long Result =
- (NChars_In_TK_Callbacks != 0) ? 0 : tk_GetIntervalToNextEvent();
-
- if (Result == -1)
- PRIMITIVE_RETURN(SHARP_F);
- else PRIMITIVE_RETURN(long_to_integer(Result));
-}
-
-DEFINE_PRIMITIVE ("%tkResizeWindow", Prim_tk_resize, 3, 3, 0)
-{ /* (%tkResizeWindow tkwin width height) */
- PRIMITIVE_HEADER (3);
- Tk_ResizeWindow((Tk_Window) arg_integer(1),
- (int) arg_integer(2),
- (int) arg_integer(3));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%tkUnmapWindow", Prim_tk_unmap_window, 1, 1, 0)
-{ /* (%tkUnmapWindow tk-win) */
- PRIMITIVE_HEADER (1);
- Tk_UnmapWindow((Tk_Window) arg_integer(1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%tkWinReqHeight", Prim_tk_win_req_height, 1, 1, 0)
-{ /* (%tkwinReqHeight tk-win) */
- PRIMITIVE_HEADER(1);
- PRIMITIVE_RETURN (long_to_integer
- ((long) Tk_ReqHeight (arg_integer(1))));
-}
-
-DEFINE_PRIMITIVE ("%tkWinReqWidth", Prim_tk_win_req_width, 1, 1, 0)
-{ /* (%tkwinReqWidth tk-win) */
- PRIMITIVE_HEADER(1);
- PRIMITIVE_RETURN (long_to_integer
- ((long) Tk_ReqWidth (arg_integer(1))));
-}
-
-DEFINE_PRIMITIVE ("%tkWidget.tkwin", Prim_tk_widget_get_tkwin, 1, 1, 0)
-{ extern long /*Tk_Window*/ tk_tkwin_widget (long /*button*/ *button);
- PRIMITIVE_HEADER(1);
- PRIMITIVE_RETURN(long_to_integer
- ((long) tk_tkwin_widget
- ((long /*Button*/ *) arg_integer(1))));
-}
-
-DEFINE_PRIMITIVE ("%tkWinDisplay", Prim_tk_win_display, 1, 1, 0)
-{ /* (%tkwinDisplay tk-win) */
- PRIMITIVE_HEADER(1);
- PRIMITIVE_RETURN (long_to_integer
- ((long) Tk_Display ((Tk_Window) arg_integer(1))));
-}
-
-DEFINE_PRIMITIVE ("%tkWinIsMapped?", Prim_tk_win_is_mapped, 1, 1, 0)
-{ /* (%tkwinismapped? tk-win) */
- PRIMITIVE_HEADER(1);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT
- (Tk_IsMapped ((Tk_Window) arg_integer(1))));
-}
-
-DEFINE_PRIMITIVE ("%tkWinHeight", Prim_tk_win_height, 1, 1, 0)
-{ /* (%tkwinHeight tk-win) */
- PRIMITIVE_HEADER(1);
- PRIMITIVE_RETURN (long_to_integer
- ((long) Tk_Height ((Tk_Window) arg_integer(1))));
-}
-
-DEFINE_PRIMITIVE ("%tkWinWidth", Prim_tk_win_width, 1, 1, 0)
-{ /* (%tkwinWidth tk-win) */
- PRIMITIVE_HEADER(1);
- PRIMITIVE_RETURN (long_to_integer
- ((long) Tk_Width ((Tk_Window) arg_integer(1))));
-}
-
-DEFINE_PRIMITIVE ("%tkWinWindow", Prim_tk_win_window, 1, 1, 0)
-{ /* (%tkwinWindow tk-win) */
- PRIMITIVE_HEADER(1);
- PRIMITIVE_RETURN (long_to_integer
- ((long) Tk_WindowId ((Tk_Window) arg_integer(1))));
-}
-
-DEFINE_PRIMITIVE ("%tkWinX", Prim_tk_win_x, 1, 1, 0)
-{ /* (%tkwinx tk-win) */
- PRIMITIVE_HEADER(1);
- PRIMITIVE_RETURN (long_to_integer
- ((long) Tk_X ((Tk_Window) arg_integer(1))));
-}
-
-DEFINE_PRIMITIVE ("%tkWinY", Prim_tk_win_y, 1, 1, 0)
-{ /* (%tkwiny tk-win) */
- PRIMITIVE_HEADER(1);
- PRIMITIVE_RETURN (long_to_integer
- ((long) Tk_Y ((Tk_Window) arg_integer(1))));
-}
-
-DEFINE_PRIMITIVE ("%tkWinName", Prim_tk_win_name, 1, 1, 0)
-{ /* (%tkwinname tk-win) */
- PRIMITIVE_HEADER(1);
- PRIMITIVE_RETURN (char_pointer_to_string
- ((unsigned char *) Tk_Name ((Tk_Window) arg_integer(1))));
-}
-
-DEFINE_PRIMITIVE ("%tkWinPathName", Prim_tk_win_pathname, 1, 1, 0)
-{ /* (%tkwinpathname tk-win) */
- PRIMITIVE_HEADER(1);
- PRIMITIVE_RETURN (char_pointer_to_string
- ((unsigned char *) Tk_PathName ((Tk_Window) arg_integer(1))));
-}
-
+++ /dev/null
-/* -*- C -*-
-/* tk-c.c - Support routines for Tk Widgets called from Scheme */
-
-/**********************************************************************
- This file contains the C code shared between MIT CScheme and DEC
- Scheme-To-C for interfacing to general TK things. There are similar
- files for particular widgets, named things like "button-c.c". The
- Scheme implementation specific interface files for this are tk-sc.sc,
- tk-c-mit.c, and tk-mit.scm.
-**********************************************************************/
-
-#include "tk.h"
-#include <tcl/tclInt.h>
-#include <tclHash.h>
-
-/* structure for passing callbacks to the TK Shell */
-
-typedef struct {
- char *name; /* Name of command */
- Tcl_CmdProc *proc; /* Pointer to procedure */
- ClientData data; /* Client data */
-} TKCallbacks, *TKCallbackPtr;
-
-/* shell procedure declaration */
-
-static void TKShell
-(
- Tk_Window, /* Application main window */
- char *, /* Name of shell window */
- char *, /* Class name */
- TKCallbackPtr /* Array of callbacks */
-);
-\f
-/* This procedure is registered with TCL under the name
- "SchemeCallBack". TK widgets are given command lines of the form
- "-command SchemeCallBack n" where "n" is the object ID of the
- Scheme call back procedure. Thus, when TK actually calls this
- procedure, it will pass as argv[1] the Scheme object ID (as a
- string), followed by any TK-supplied arguments.
-
- This procedure side-effects the C global variable TK_CallBack_List
- (in file tk-c-mit.c). The value of this variable is tested in
- %tkOwnsEvent? to generate callbacks int Scheme.
-
- Tk_SchemeCallBack COPIES all of the arguments passed in, since I
- haven't the vaguest idea how TK handles garbage collection.
-*/
-
-static int NDigits(unsigned long N)
-{ register Ans = 1;
- while (N > 9)
- { Ans += 1;
- N = N/10;
- }
- return Ans;
-}
-
-#define TK_CALLBACK_CHUNK_SIZE 256
-static long Size_Of_TK_Callbacks = 0;
-
-void Allocate_TK_Callback(long NChars)
-{ /* Size_Of_TK_Callbacks will always be a multiple of */
- /* TK_CALLBACK_CHUNK_SIZE. It is the total number of bytes */
- /* available, and includes space for the terminating null. */
- /* NChars_In_TK_Callbacks, however, is the number of useful bytes */
- /* and does NOT include the terminating null byte. NChars is the */
- /* number of bytes to be added to the current contents. */
-
- extern char *TK_CallBack_List;
- extern long NChars_In_TK_Callbacks;
-
- Size_Of_TK_Callbacks =
- (((NChars_In_TK_Callbacks+NChars)/TK_CALLBACK_CHUNK_SIZE)+1) *
- TK_CALLBACK_CHUNK_SIZE;
- if (NChars_In_TK_Callbacks == 0)
- TK_CallBack_List = malloc(Size_Of_TK_Callbacks);
- else
- TK_CallBack_List =
- (char *) realloc(TK_CallBack_List, Size_Of_TK_Callbacks);
- return;
-}
-
-extern void AddSchemeCallBack(int argc, char **argv, long *countv)
-{ /* argc is the number of arguments to be transmitted. They start at */
- /* argv[0]. This isn't the usual C convention, but it is more */
- /* sensible. */
- extern char *TK_CallBack_List;
- extern long NChars_In_TK_Callbacks;
- register long ThisEntryLength = 0;
- register long i;
- register char **This;
- register long *Count;
- char *NextEntry;
- long NChars_To_Add;
-
- /* First, calculate how much space we need */
- for (i=0, Count=countv; i < argc; i++)
- { register long N = *Count++;
- ThisEntryLength += N + 2 + NDigits(N); /* 2 for < > */
- }
- NChars_To_Add =
- ThisEntryLength + 2 + NDigits(ThisEntryLength); /* 2 more for < > */
- if ((NChars_In_TK_Callbacks+NChars_To_Add+1) > Size_Of_TK_Callbacks)
- Allocate_TK_Callback(NChars_To_Add);
- NextEntry = &(TK_CallBack_List[NChars_In_TK_Callbacks]);
- NChars_In_TK_Callbacks += NChars_To_Add;
- /* And start putting in the information */
- NextEntry += sprintf(NextEntry, "<%d>", ThisEntryLength);
- for (i=0, This=argv, Count=countv; i < argc; i++, This++, Count++)
- { NextEntry += sprintf(NextEntry, "<%d>", *Count);
- memcpy(NextEntry, *This, *Count);
- NextEntry += *Count;
- }
- if (NextEntry != TK_CallBack_List+(NChars_In_TK_Callbacks))
- fprintf(stderr, "Tk_SchemeCallback %d %s\n",
- NChars_In_TK_Callbacks, TK_CallBack_List);
- *NextEntry = '\0'; /* Null terminate the string */
- return;
-}
-
-int
-Tk_TkError(ClientData clientData,
- Tcl_Interp *interp,
- int argc,
- char **argv)
-{ if (argc==2)
- { fprintf(stderr, "TCL Error: %s\n", argv[1]);
- fputs(Tcl_GetVar(interp, "errorInfo", 0), stderr);
- }
- else
- fprintf(stderr, "TCL Error with argc=%d!\n", argc);
- error_external_return();
-}
-
-int
-Tk_SchemeCallBack(clientData, interp, argc, argv)
- ClientData clientData; /* Main window associated with
- * interpreter. NOT USED. */
- Tcl_Interp *interp; /* Current interpreter. NOT USED. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
-{ /* As usual, argv[0] is *NOT* used for anything! */
- long *Counts = (long *) malloc(argc*sizeof(long));
- register long i, *Count;
- register char **This;
-
- if (Counts == NULL)
- { fprintf(stderr, "Out of space in Tk_SchemeCallBack\n");
- exit (1);
- }
- for (i=1, This=argv+1, Count=Counts+1; i < argc; i++)
- *Count++ = strlen(*This++);
- AddSchemeCallBack(argc-1, argv+1, Counts+1);
- /* Deliberately not changing interp->result, 'cause the TCL manual */
- /* says we don't have to if we don't want to. */
- return TCL_OK;
-}
-\f
-/*
- * External Interface Routines
- */
-
-int Scheme_TK_X_error_handler(ClientData D, XErrorEvent *E)
-{ extern void Scheme_x_error_handler(Display *Disp, XErrorEvent *Event);
-
- fprintf(stderr, "Our Handler for %d 0x%x\n", D, E);
- Scheme_x_error_handler((Display *) D, E);
- return 0;
-}
-
-extern Tk_Window
-InitTkApplication(Display *Disp, char *Name)
-{ Tk_Window Result;
- extern Tk_Window
- Tk_CreateMainWindow_from_display(Tcl_Interp *interp,
- Display *display,
- char *baseName);
- Tcl_Interp *tclInterp = Tcl_CreateInterp();
-/*
- static char initTCLCmd[] =
- "source /scheme/users/jmiller/uitk/tk/tcl/library/init.tcl;";
- static char initTKCmd[] =
- "source /scheme/users/jmiller/uitk/tk/library/tk.tcl";
- static char initEmacsCmd[] =
- "source /scheme/users/jmiller/uitk/tk/library/emacs.tcl";
-*/
-
- static char initTCLCmd[] = "source [info library]/init.tcl;";
- static char initTKCmd[] = "source $tk_library/tk.tcl";
- static char initEmacsCmd[] = "source $tk_library/emacs.tcl";
-
- Result = Tk_CreateMainWindow_from_display(tclInterp, Disp, Name);
- if (Result == (Tk_Window) NULL)
- fprintf(stderr,
- "Error from Tk_CreateMainWindow: %s\n"
- , tclInterp->result);
- if (Tcl_Eval(tclInterp, initTCLCmd, 0, (char **) NULL) != TCL_OK)
- { char * msg = Tcl_GetVar(tclInterp, "errorInfo", TCL_GLOBAL_ONLY);
- if (msg == NULL) msg = tclInterp->result;
- fprintf(stderr, "%s\n", msg);
- return (Tk_Window) NULL;
- }
- /* This must be read for EVERY new main window, since it */
- /* establishes bindings and so forth that use "." implicitly */
- if (Tcl_Eval(tclInterp, initTKCmd, 0, (char **) NULL) != TCL_OK)
- { char * msg = Tcl_GetVar(tclInterp, "errorInfo", TCL_GLOBAL_ONLY);
- if (msg == NULL) msg = tclInterp->result;
- fprintf(stderr, "%s\n", msg);
- return (Tk_Window) NULL;
- }
- if (Tcl_Eval(tclInterp, initEmacsCmd, 0, (char **) NULL) != TCL_OK)
- { char * msg = Tcl_GetVar(tclInterp, "errorInfo", TCL_GLOBAL_ONLY);
- if (msg == NULL) msg = tclInterp->result;
- fprintf(stderr, "%s\n", msg);
- return (Tk_Window) NULL;
- }
- Tcl_CreateCommand(tclInterp,
- "SchemeCallBack",
- Tk_SchemeCallBack,
- (ClientData) 0 /* not used */,
- (void (*)()) NULL); /* Delete Procedure */
- Tcl_CreateCommand(tclInterp,
- "tkerror",
- Tk_TkError,
- (ClientData) 0 /* not used */,
- (void (*) ()) NULL); /* Delete Procedure */
- Tk_CreateErrorHandler(Disp, -1, -1, -1,
- Scheme_TK_X_error_handler, (ClientData) Disp);
- return Result;
-}
-\f
-/*
- * Process all pending Tk events, then return
- */
-
-void
-DoTkEvents ()
-{ while (Tk_DoOneEvent (TK_DONT_WAIT|TK_TIMER_EVENTS|TK_IDLE_EVENTS) > 0)
- { /* fprintf(stderr, "Did TK Event"); */ }
-}
-
-/* Access the Client Data for a command. For widget commands,
- * this is a pointer to the widget data structure.
- */
-
-ClientData
-GetCmdClientData (Tcl_Interp *interp, char *cmd)
-
-{
- Tcl_HashEntry *hPtr;
-
- hPtr = Tcl_FindHashEntry (&((Interp *)interp)->commandTable, cmd);
- return ((Command *) Tcl_GetHashValue (hPtr))->clientData;
-}
-
-/* Window structure routines.
- * These are Macros, so need a functional interface for Scheme
- */
-
-Display *
-tk_display (Tk_Window tkwin)
-
-{
- return Tk_Display (tkwin);
-}
-
-Window
-tk_windowid (Tk_Window tkwin)
-
-{
- return Tk_WindowId (tkwin);
-}
-
-int
-tk_width (Tk_Window tkwin)
-
-{
- return Tk_Width (tkwin);
-}
-
-int
-tk_height (Tk_Window tkwin)
-
-{
- return Tk_Height (tkwin);
-}
-
-void
-tk_set_width (Tk_Window tkwin, long W)
-{ Tk_Width(tkwin) = W;
-}
-
-void
-tk_set_height (Tk_Window tkwin, long H)
-{ Tk_Height(tkwin) = H;
-}
-
-/*****************************************************************/
-/* The following procedures OUGHT to be here, but they require */
-/* internal data structure from tkButton.c to work */
-/* */
-/* void */
-/* tk_map_widget (Button *button, Tk_Window tkMainWindow, */
-/* char *name, Window xwindow, int x, int y) */
-/* Tk_Window */
-/* tk_tkwin_widget (Button *button) */
-/*****************************************************************/
+++ /dev/null
-#
-# This is a simplified Makefile for use in Tk distributions. Before using
-# it to compile Tk, you may wish to reset some of the following variables:
-#
-# TCL_DIR - Name of directory holding tcl.h and tcl.a.
-# XLIB - If your Xlib library isn't in the standard place,
-# you can replace "-lX11" with the name of the file
-# containing your library archive.
-# INSTALL_DIR - Full path name of top-level directory where
-# information is installed.
-# TK_LIBRARY - Full path name of directory to contain scripts
-# and other library files used by Tk. This value
-# is available to applications as the variable
-# $tk_library. If the environment variable
-# TK_LIBRARY is defined by a user, it will override
-# the value specified in this Makefile.
-# LIB_DIR - Directory in which to install the archive libtcl.a
-# BIN_DIR - Directory in which to install executables such as wish.
-# INCLUDE_DIR - Directory in which to install header files.
-# MANx_DIR - Directories in which to install manual entries.
-# RANLIB - If you're using a System-V-based UNIX that doesn't
-# have ranlib, change this definition to "echo" or
-# something else harmless.
-# SHELL - Some versions of make (e.g. SGI's) use this variable
-# to determine which shell to use for executing
-# commands.
-#
-
-TCL_DIR = tcl
-XLIB = -lX11
-INSTALL_DIR = /usr/local
-LIB_DIR = $(INSTALL_DIR)/lib
-TK_LIBRARY = $(INSTALL_DIR)/lib/tk
-BIN_DIR = $(INSTALL_DIR)/bin
-INCLUDE_DIR = $(INSTALL_DIR)/include
-MAN1_DIR = $(INSTALL_DIR)/man/man1
-MAN3_DIR = $(INSTALL_DIR)/man/man3
-MANN_DIR = $(INSTALL_DIR)/man/mann
-RANLIB = ranlib
-SHELL = /bin/sh
-
-# ANSI-C procedure prototypes are turned on by default if supported
-# by the compiler. To turn them off, uncomment the following line:
-
-# NP = -DNO_PROTOTYPE
-
-# To compile under OpenWindows, uncomment the following line:
-
-# OW = -I/usr/openwin/include -L/usr/openwin/lib
-CC = cc
-CFLAGS = -I. -I$(TCL_DIR) -O -DTK_LIBRARY=\"${TK_LIBRARY}\" +z \
- ${NP} ${OW}
-
-LIBS = libtk.a $(TCL_DIR)/libtcl.a
-
-WIDGOBJS = tkButton.o tkEntry.o tkFrame.o tkListbox.o \
- tkMenu.o tkMenubutton.o tkMessage.o tkScale.o \
- tkScrollbar.o
-
-CANVOBJS = tkCanvas.o tkCanvArc.o tkCanvBmap.o tkCanvLine.o \
- tkCanvPoly.o tkCanvPs.o tkCanvText.o tkCanvWind.o \
- tkRectOval.o tkTrig.o
-
-TEXTOBJS = tkText.o tkTextBTree.o tkTextDisp.o tkTextIndex.o tkTextTag.o
-
-OBJS = tk3d.o tkArgv.o tkAtom.o tkBind.o tkBitmap.o tkCmds.o \
- tkColor.o tkConfig.o tkCursor.o tkError.o tkEvent.o \
- tkFocus.o tkFont.o tkGet.o tkGC.o tkGeometry.o tkGrab.o \
- tkOption.o tkPack.o tkPlace.o tkPreserve.o tkSelect.o \
- tkSend.o tkWindow.o tkWm.o $(WIDGOBJS) \
- $(CANVOBJS) $(TEXTOBJS)
-
-WIDGSRCS = tkButton.c tkEntry.c tkFrame.c tkListbox.c \
- tkMenu.c tkMenubutton.c tkMessage.c tkScale.c \
- tkScrollbar.c tkText.c tkTextBTree.c tkTextDisp.c \
- tkTextIndex.c
-
-CANVSRCS = tkCanvas.c tkCanvArc.c tkCanvBmap.c tkCanvLine.c \
- tkCanvPoly.c tkCanvPs.c tkCanvText.c tkCanvWind.c \
- tkRectOval.c tkTrig.c
-
-TEXTSRCS = tkText.c tkTextBTree.c tkTextDisp.c tkTextIndex.c tkTextTag.c
-
-SRCS = tk3d.c tkArgv.c tkAtom.c tkBind.c tkBitmap.c tkCmds.c \
- tkColor.c tkConfig.c tkCursor.c tkError.c tkEvent.c \
- tkFocus.c tkFont.c tkGet.c tkGC.c tkGeometry.c tkGrab.c \
- tkOption.c tkPack.c tkPlace.c tkPreserve.c tkSelect.c \
- tkSend.c tkWindow.c tkWm.c $(WIDGSRCS) \
- $(CANVSRCS) $(TEXTSRCS)
-
-all: libtk.a wish
-
-wish: main.o $(LIBS)
- $(CC) $(CFLAGS) main.o $(LIBS) $(XLIB) -lm -o wish
-
-libtk.a: $(OBJS)
- rm -f libtk.a
- ar cr libtk.a $(OBJS)
- $(RANLIB) libtk.a
-
-$(TCL_DIR)/libtcl.a:
- cd $(TCL_DIR); $(MAKE) $(MFLAGS) TCL_LIBRARY=$(TCL_LIBRARY) libtcl.a
-
-install: libtk.a wish $(TCL_DIR)/libtcl.a
- -if [ ! -d $(LIB_DIR) ] ; then mkdir -p $(LIB_DIR); fi
- -if [ ! -d $(INCLUDE_DIR) ] ; then mkdir -p $(INCLUDE_DIR); fi
- -if [ ! -d $(TK_LIBRARY) ] ; then mkdir -p $(TK_LIBRARY); fi
- -if [ ! -d $(BIN_DIR) ] ; then mkdir -p $(BIN_DIR); fi
- -if [ ! -d $(MAN1_DIR) ] ; then mkdir -p $(MAN1_DIR); fi
- -if [ ! -d $(MAN3_DIR) ] ; then mkdir -p $(MAN3_DIR); fi
- -if [ ! -d $(MANN_DIR) ] ; then mkdir -p $(MANN_DIR); fi
- rm -rf $(TK_LIBRARY)/*
- cp -r library/*.tcl library/tclIndex library/demos $(TK_LIBRARY)
- cp library/prolog.ps $(TK_LIBRARY)
- rm -f $(LIB_DIR)/libtk.a
- cp libtk.a $(LIB_DIR)
- $(RANLIB) $(LIB_DIR)/libtk.a
- rm -f $(BIN_DIR)/wish
- cp wish $(BIN_DIR)
- rm -f $(INCLUDE_DIR)/tk.h
- cp tk.h $(INCLUDE_DIR)
- cd doc; for i in *.1; \
- do \
- rm -f $(MAN1_DIR)/$$i; \
- sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \
- $$i > $(MAN1_DIR)/$$i; \
- done; cd ..
- cd doc; for i in *.3; \
- do \
- rm -f $(MAN3_DIR)/$$i; \
- sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \
- $$i > $(MAN3_DIR)/$$i; \
- done; cd ..
- cd doc; for i in *.n; \
- do \
- rm -f $(MANN_DIR)/$$i; \
- sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \
- $$i > $(MANN_DIR)/$$i; \
- done; cd ..
- cd $(TCL_DIR); $(MAKE) $(MFLAGS) INSTALL_DIR=$(INSTALL_DIR) install
-
-clean:
- rm -f $(OBJS) main.o libtk.a wish
- cd $(TCL_DIR); $(MAKE) $(MFLAGS) clean
-
-$(OBJS): tk.h tkInt.h tkConfig.h
-$(WIDGOBJS): default.h
-$(CANVOBJS): default.h tkCanvas.h
-$(TEXTOBJS): default.h tkText.h
-main.o: tk.h tkInt.h
+++ /dev/null
-#-----------------------------------------------------------------------------
-# Emacs-like bindings for Tk text widgets
-#
-# Andrew C. Payne
-# payne@crl.dec.com
-#
-#-----------------------------------------------------------------------------
-
-set tk_priv(cutbuffer) ""
-
-#-----------------------------------------------------------------------------
-# Keyboard bindings, model after emacs
-#-----------------------------------------------------------------------------
-
-proc emacs-text-move {w where} {
- global tk_priv
-
- $w mark set insert $where
- $w yview -pickplace insert
- if {$tk_priv(selectMode) == "select"} {
- $w tag remove sel 0.0 end
- $w tag add sel anchor insert
- }
-}
-
-proc emacs-twiddle {w} {
- set c [$w get insert-1c]
- $w delete insert-1c
- $w insert insert-1c $c
-}
-
-proc emacs-move-page {w dir} {
- global tk_priv
-
- set height [lindex [$w configure -height] 4]
- $w mark set insert "insert $dir $height lines"
- $w yview -pickplace insert
- if {$tk_priv(selectMode) == "select"} {
- $w tag remove sel 0.0 end
- $w tag add sel anchor insert
- }
-}
-
-#
-# If there is a current selection, delete it. Else, backspace one character
-#
-proc emacs-backspace {w} {
- if {[catch {$w delete sel.first sel.last}]} {
- tk_textBackspace $w
- }
- $w yview -pickplace insert
-}
-
-bind Text <Any-KeyPress> {
- if {%k == 140} {
- set tk_priv(selectMode) {}
- catch {set tk_priv(cutbuffer) [%W get sel.first sel.last]}
- catch {%W delete sel.first sel.last}
- }
- if {"%A" != ""} {
- %W insert insert %A
- }
- %W yview -pickplace insert
-}
-
-# By default, all the control and meta keys are disabled
-bind Text <Control-Key> {
- %W yview -pickplace insert
-}
-bind Text <Meta-Key> {
- %W yview -pickplace insert
-}
-bind Text <Control-Meta-Key> {
- %W yview -pickplace insert
-}
-bind Text <Escape> {
- %W yview -pickplace insert
-}
-
-set tk_last_deleted ""
-bind Text <Control-k> {
- global tk_last_deleted
- set tk_last_deleted [%W get insert {insert lineend}]
- %W delete insert {insert lineend}
-}
-bind Text <Control-y> {
- global tk_last_deleted
- %W insert insert $tk_last_deleted
- %W yview -pickplace insert
-}
-
-bind Text <Up> {emacs-text-move %W insert-1l}
-bind Text <Down> {emacs-text-move %W insert+1l}
-bind Text <Left> {emacs-text-move %W insert-1c}
-bind Text <Right> {emacs-text-move %W insert+1c}
-
-bind Text <Control-a> {emacs-text-move %W {insert linestart}}
-bind Text <Control-b> {emacs-text-move %W insert-1c}
-bind Text <Control-d> {%W delete insert insert+1c}
-bind Text <Control-e> {emacs-text-move %W {insert lineend}}
-bind Text <Control-f> {emacs-text-move %W insert+1c}
-bind Text <Control-h> {emacs-backspace %W}
-bind Text <Control-n> {emacs-text-move %W insert+1l}
-bind Text <Control-o> {%W insert insert "\n"; emacs-text-move %W insert-1c}
-bind Text <Control-p> {emacs-text-move %W insert-1l}
-bind Text <Control-t> {emacs-twiddle %W}
-bind Text <Control-v> {emacs-move-page %W +}
-
-bind Text <Prior> {emacs-move-page %W -}
-bind Text <Next> {emacs-move-page %W +}
-bind Text <Delete> {emacs-backspace %W}
-
-bind Text <Insert> {
- %W insert insert $tk_priv(cutbuffer)
- %W yview -pickplace insert
-}
-
-bind Text <Select> {
- %W tag remove sel 0.0 end
- if {$tk_priv(selectMode) == "select"} {
- set tk_priv(selectMode) {}
- } {
- %W mark set anchor insert
- set tk_priv(selectMode) select
- }
-}
-
-
-#-----------------------------------------------------------------------------
-# Mouse bindings
-#-----------------------------------------------------------------------------
-
-bind Text <1> {
- set tk_priv(selectMode) char
- %W mark set insert @%x,%y
- %W mark set anchor insert
- if {[lindex [%W config -state] 4] == "normal"} {focus %W}
- %W tag remove sel 0.0 end
-}
-
-#
-# Button 2 is used to paste the current X selection, just like many X
-# applications. This is the default Motif binding.
-#
-bind Text <2> {
- catch {
- %W insert insert [selection get]
- %W yview -pickplace insert
- }
-}
-
-bind Text <B2-Motion> {}
-
-#
-# Use button 3 as a drag for window text (just like the old Tk button 2
-# binding.
-#
-bind Text <3> {%W scan mark %y}
-bind Text <B3-Motion> {%W scan dragto %y}
-
-
-#-----------------------------------------------------------------------------
-# Emacs-like bindings for Tk entry widgets
-#-----------------------------------------------------------------------------
-
-# By default, all the control and meta keys are disabled
-bind Entry <Control-Key> {
- tk_entrySeeCaret %W
-}
-bind Entry <Meta-Key> {
- tk_entrySeeCaret %W
-}
-bind Entry <Control-Meta-Key> {
- tk_entrySeeCaret %W
-}
-bind Entry <Escape> {
- tk_entrySeeCaret %W
-}
-
-# need to repeat these because they've just been overwritten
-bind Entry <Control-h> {tk_entryBackspace %W; tk_entrySeeCaret %W}
-bind Entry <Control-u> {%W delete 0 end}
-bind Entry <Control-v> {%W insert insert [selection get]; tk_entrySeeCaret %W}
-bind Entry <Control-w> {tk_entryBackword %W; tk_entrySeeCaret %W}
-
-# Some Emacs bindings
-bind Entry <Control-a> {%W icursor 0; tk_entrySeeCaret %W}
-bind Entry <Control-e> {%W icursor end; tk_entrySeeCaret %W}
-bind Entry <Control-k> {%W delete insert end}
-bind Entry <Control-d> {%W delete insert}
-
-set entry_cursor_index ""
-bind Entry <Control-f> {
- global entry_cursor_index
- set entry_cursor_index [expr {[%W index insert] + 1}]
- %W icursor $entry_cursor_index
-}
-bind Entry <Control-b> {
- global entry_cursor_index
- set entry_cursor_index [expr {[%W index insert] - 1}]
- %W icursor $entry_cursor_index
-}
-
+++ /dev/null
-#
-# This Makefile is for use when distributing Tcl to the outside world.
-# It is normally set up by running the "config" script. Before modifying
-# this file by hand, you should read through the "config" script to see
-# what it does.
-#
-# Some changes you may wish to make here:
-#
-# 1. To compile for non-UNIX systems (so that only the non-UNIX-specific
-# commands are available), change the OBJS line below so it doesn't
-# include ${UNIX_OBJS}. Also, add the switch "-DTCL_GENERIC_ONLY" to
-# CFLAGS. Lastly, you'll have to provide your own replacement for the
-# "panic" procedure (see panic.c for what the current one does).
-
-# 2. ANSI-C procedure prototypes are turned on by default if supported
-# by the compiler. To turn them off, uncomment the following line:
-
-# NP = -DNO_PROTOTYPE
-
-# 3. If you want to put Tcl-related information in non-standard places,
-# change the following definitions below to reflect where you want
-# things (all must be specified as full rooted path names):
-#
-# INSTALL_DIR Top-level directory in which to install; contains
-# each of the other directories below.
-# TCL_LIBRARY Directory in which to install the library of Tcl
-# scripts. Note: if the TCL_LIBRARY environment
-# variable is specified at run-time then Tcl looks
-# there rather than in the place specified here.
-# LIB_DIR Directory in which to install the archive libtcl.a
-# INCLUDE_DIR Directory in which to install include files.
-# MAN3_DIR Directory in which to install manual entries for
-# library procedures such as Tcl_Eval.
-# MANN_DIR Directory in which to install manual entries for
-# miscellaneous things such as the Tcl overview
-# manual entry.
-# RANLIB If you're using a System-V-based UNIX that doesn't
-# have ranlib, change this definition to "echo" or
-# something else harmless.
-# SHELL Some versions of make (e.g. SGI's) use this variable
-# to determine which shell to use for executing
-# commands.
-
-INSTALL_DIR = /usr/local
-TCL_LIBRARY = $(INSTALL_DIR)/lib/tcl
-LIB_DIR = $(INSTALL_DIR)/lib
-INCLUDE_DIR = $(INSTALL_DIR)/include
-MAN3_DIR = $(INSTALL_DIR)/man/man3
-MANN_DIR = $(INSTALL_DIR)/man/mann
-RANLIB = ranlib
-SHELL = /bin/sh
-
-CC = cc
-CFLAGS = -O -I. -DTCL_LIBRARY=\"${TCL_LIBRARY}\" ${NP} +z
-
-GENERIC_OBJS = regexp.o tclAssem.o tclBasic.o tclCkalloc.o \
- tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclExpr.o tclGet.o \
- tclHash.o tclHistory.o tclParse.o tclProc.o tclUtil.o \
- tclVar.o
-
-UNIX_OBJS = panic.o tclEnv.o tclGlob.o tclUnixAZ.o tclUnixStr.o \
- tclUnixUtil.o
-
-COMPAT_OBJS =
-
-OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS}
-
-all: libtcl.a
-
-libtcl.a: ${OBJS}
- rm -f libtcl.a
- ar cr libtcl.a ${OBJS}
- $(RANLIB) libtcl.a
-
-install: libtcl.a
- -if [ ! -d $(LIB_DIR) ] ; then mkdir -p $(LIB_DIR); fi
- -if [ ! -d $(TCL_LIBRARY) ] ; then mkdir -p $(TCL_LIBRARY); fi
- -if [ ! -d $(INCLUDE_DIR) ] ; then mkdir -p $(INCLUDE_DIR); fi
- -if [ ! -d $(MAN3_DIR) ] ; then mkdir -p $(MAN3_DIR); fi
- -if [ ! -d $(MANN_DIR) ] ; then mkdir -p $(MANN_DIR); fi
- rm -rf $(TCL_LIBRARY)/*
- for i in library/*.tcl library/tclIndex; \
- do \
- cp $$i $(TCL_LIBRARY); \
- done
- rm -f $(LIB_DIR)/libtcl.a
- cp libtcl.a $(LIB_DIR)
- $(RANLIB) $(LIB_DIR)/libtcl.a
- rm -f $(INCLUDE_DIR)/tcl.h $(INCLUDE_DIR)/tclHash.h
- cp tcl.h $(INCLUDE_DIR)
- cp tclHash.h $(INCLUDE_DIR)
- cd doc; for i in *.3; \
- do \
- rm -f $(MAN3_DIR)/$$i; \
- sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \
- $$i > $(MAN3_DIR)/$$i; \
- done; cd ..
- cd doc; for i in *.n; \
- do \
- rm -f $(MANN_DIR)/$$i; \
- sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \
- $$i > $(MANN_DIR)/$$i; \
- done; cd ..
-
-tclTest: tclTest.o libtcl.a
- ${CC} ${CFLAGS} tclTest.o libtcl.a -o tclTest
-
-test: tclTest
- ( echo cd tests ; echo source all ) | ./tclTest
-
-configured:
- @echo "The configuration script \"./config\" hasn't been run"
- @echo "successfully yet. Please run it as described in the "
- @echo "README file, then run make again."
- exit 1
-
-clean:
- rm -f ${OBJS} libtcl.a tclTest.o tclTest
-
-# The following target is used during configuration to compile
-# a test program to see if certain facilities are available on
-# the system.
-
-configtest:
- ${CC} ${CFLAGS} test.c
-
-${OBJS}: tcl.h tclHash.h tclInt.h configured
-${UNIX_OBJS}: tclUnix.h
+++ /dev/null
-/*
- * tclUnix.h --
- *
- * This file reads in UNIX-related header files and sets up
- * UNIX-related macros for Tcl's UNIX core. It should be the
- * only file that contains #ifdefs to handle different flavors
- * of UNIX. This file sets up the union of all UNIX-related
- * things needed by any of the Tcl core files. This file
- * depends on configuration #defines in tclConfig.h
- *
- * The material in this file was originally contributed by
- * Karl Lehenbauer, Mark Diekhans and Peter da Silva.
- *
- * Copyright 1991 Regents of the University of California
- * Permission to use, copy, modify, and distribute this
- * software and its documentation for any purpose and without
- * fee is hereby granted, provided that this copyright
- * notice appears in all copies. The University of California
- * makes no representations about the suitability of this
- * software for any purpose. It is provided "as is" without
- * express or implied warranty.
- */
-
-#ifndef _TCLUNIX
-#define _TCLUNIX
-
-/*
- * The following #defines are used to distinguish between different
- * UNIX systems. These #defines are normally set by the "config" script
- * based on information it gets by looking in the include and library
- * areas. The defaults below are for BSD-based systems like SunOS
- * or Ultrix.
- *
- * TCL_GETTOD - 1 means there exists a library procedure
- * "gettimeofday" (e.g. BSD systems). 0 means
- * have to use "times" instead.
- * TCL_GETWD - 1 means there exists a library procedure
- * "getwd" (e.g. BSD systems). 0 means
- * have to use "getcwd" instead.
- * TCL_SYS_ERRLIST - 1 means that the array sys_errlist is
- * defined as part of the C library.
- * TCL_SYS_TIME_H - 1 means there exists an include file
- * <sys/time.h> (e.g. BSD derivatives).
- * TCL_SYS_WAIT_H - 1 means there exists an include file
- * <sys/wait.h> that defines constants related
- * to the results of "wait".
- * TCL_UNION_WAIT - 1 means that the "wait" system call returns
- * a structure of type "union wait" (e.g. BSD
- * systems). 0 means "wait" returns an int
- * (e.g. System V and POSIX).
- * TCL_PID_T - 1 means that <sys/types> defines the type
- * pid_t. 0 means that it doesn't.
- * TCL_UID_T - 1 means that <sys/types> defines the type
- * uid_t. 0 means that it doesn't.
- */
-
-#define TCL_GETTOD 1
-#define TCL_GETWD 1
-#define TCL_SYS_ERRLIST 1
-#define TCL_SYS_TIME_H 1
-#define TCL_SYS_WAIT_H 1
-#define TCL_UNION_WAIT 0
-#define TCL_PID_T 1
-#define TCL_UID_T 1
-
-#include <errno.h>
-#include <fcntl.h>
-#include <limits.h>
-#include <pwd.h>
-#include <signal.h>
-#include <sys/param.h>
-#include <sys/types.h>
-#include <dirent.h>
-#include <sys/file.h>
-#include <sys/stat.h>
-#if TCL_SYS_TIME_H
-# include <sys/time.h>
-#else
-# include <time.h>
-#endif
-#if TCL_SYS_WAIT_H
-# include <sys/wait.h>
-#endif
-
-/*
- * Not all systems declare the errno variable in errno.h. so this
- * file does it explicitly. The list of system error messages also
- * isn't generally declared in a header file anywhere.
- */
-
-extern int errno;
-extern int sys_nerr;
-extern char *sys_errlist[];
-
-/*
- * The type of the status returned by wait varies from UNIX system
- * to UNIX system. The macro below defines it:
- */
-
-#if TCL_UNION_WAIT
-# define WAIT_STATUS_TYPE union wait
-#else
-# define WAIT_STATUS_TYPE int
-#endif
-
-/*
- * Supply definitions for macros to query wait status, if not already
- * defined in header files above.
- */
-
-#ifndef WIFEXITED
-# define WIFEXITED(stat) (((*((int *) &(stat))) & 0xff) == 0)
-#endif
-
-#ifndef WEXITSTATUS
-# define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xff)
-#endif
-
-#ifndef WIFSIGNALED
-# define WIFSIGNALED(stat) (((*((int *) &(stat)))) && ((*((int *) &(stat))) == ((*((int *) &(stat))) & 0x00ff)))
-#endif
-
-#ifndef WTERMSIG
-# define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7f)
-#endif
-
-#ifndef WIFSTOPPED
-# define WIFSTOPPED(stat) (((*((int *) &(stat))) & 0xff) == 0177)
-#endif
-
-#ifndef WSTOPSIG
-# define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xff)
-#endif
-
-/*
- * Supply macros for seek offsets, if they're not already provided by
- * an include file.
- */
-
-#ifndef SEEK_SET
-# define SEEK_SET 0
-#endif
-
-#ifndef SEEK_CUR
-# define SEEK_CUR 1
-#endif
-
-#ifndef SEEK_END
-# define SEEK_END 2
-#endif
-
-/*
- * The stuff below is needed by the "time" command. If this
- * system has no gettimeofday call, then must use times and the
- * CLK_TCK #define (from sys/param.h) to compute elapsed time.
- * Unfortunately, some systems only have HZ and no CLK_TCK, and
- * some might not even have HZ.
- */
-
-#if ! TCL_GETTOD
-# include <sys/times.h>
-# include <sys/param.h>
-# ifndef CLK_TCK
-# ifdef HZ
-# define CLK_TCK HZ
-# else
-# define CLK_TCK 60
-# endif
-# endif
-#endif
-
-/*
- * Define access mode constants if they aren't already defined.
- */
-
-#ifndef F_OK
-# define F_OK 00
-#endif
-#ifndef X_OK
-# define X_OK 01
-#endif
-#ifndef W_OK
-# define W_OK 02
-#endif
-#ifndef R_OK
-# define R_OK 04
-#endif
-
-/*
- * On systems without symbolic links (i.e. S_IFLNK isn't defined)
- * define "lstat" to use "stat" instead.
- */
-
-#ifndef S_IFLNK
-# define lstat stat
-#endif
-
-/*
- * Define macros to query file type bits, if they're not already
- * defined.
- */
-
-#ifndef S_ISREG
-# ifdef S_IFREG
-# define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
-# else
-# define S_ISREG(m) 0
-# endif
-# endif
-#ifndef S_ISDIR
-# ifdef S_IFDIR
-# define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR)
-# else
-# define S_ISDIR(m) 0
-# endif
-# endif
-#ifndef S_ISCHR
-# ifdef S_IFCHR
-# define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR)
-# else
-# define S_ISCHR(m) 0
-# endif
-# endif
-#ifndef S_ISBLK
-# ifdef S_IFBLK
-# define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK)
-# else
-# define S_ISBLK(m) 0
-# endif
-# endif
-#ifndef S_ISFIFO
-# ifdef S_IFIFO
-# define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
-# else
-# define S_ISFIFO(m) 0
-# endif
-# endif
-#ifndef S_ISLNK
-# ifdef S_IFLNK
-# define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
-# else
-# define S_ISLNK(m) 0
-# endif
-# endif
-#ifndef S_ISSOCK
-# ifdef S_IFSOCK
-# define S_ISSOCK(m) (((m) & S_IFMT) == S_IFSOCK)
-# else
-# define S_ISSOCK(m) 0
-# endif
-# endif
-
-/*
- * Make sure that MAXPATHLEN is defined.
- */
-
-#ifndef MAXPATHLEN
-# ifdef PATH_MAX
-# define MAXPATHLEN PATH_MAX
-# else
-# define MAXPATHLEN 2048
-# endif
-#endif
-
-/*
- * Define pid_t and uid_t if they're not already defined.
- */
-
-#if ! TCL_PID_T
-# define pid_t int
-#endif
-#if ! TCL_UID_T
-# define uid_t int
-#endif
-
-/*
- * Variables provided by the C library:
- */
-
-#if defined(_sgi) || defined(__sgi)
-#define environ _environ
-#endif
-extern char **environ;
-
-/*
- * Library procedures used by Tcl but not declared in a header file:
- */
-
-#ifndef _CRAY
-extern int access _ANSI_ARGS_((CONST char *path, int mode));
-extern int chdir _ANSI_ARGS_((CONST char *path));
-extern int close _ANSI_ARGS_((int fd));
-extern int dup2 _ANSI_ARGS_((int src, int dst));
-extern void endpwent _ANSI_ARGS_((void));
-extern int execvp _ANSI_ARGS_((CONST char *name, char **argv));
-extern void _exit _ANSI_ARGS_((int status));
-extern pid_t fork _ANSI_ARGS_((void));
-extern uid_t geteuid _ANSI_ARGS_((void));
-extern pid_t getpid _ANSI_ARGS_((void));
-extern char * getcwd _ANSI_ARGS_((char *buffer, int size));
-extern char * getwd _ANSI_ARGS_((char *buffer));
-extern int kill _ANSI_ARGS_((pid_t pid, int sig));
-extern long lseek _ANSI_ARGS_((int fd, int offset, int whence));
-extern char * mktemp _ANSI_ARGS_((char *template));
-#if !(defined(sparc) || defined(_IBMR2))
-extern int open _ANSI_ARGS_((CONST char *path, int flags, ...));
-#endif
-extern int pipe _ANSI_ARGS_((int *fdPtr));
-extern int read _ANSI_ARGS_((int fd, char *buf, int numBytes));
-extern int readlink _ANSI_ARGS_((CONST char *path, char *buf, int size));
-extern int unlink _ANSI_ARGS_((CONST char *path));
-extern int write _ANSI_ARGS_((int fd, char *buf, int numBytes));
-#endif /* _CRAY */
-
-#endif /* _TCLUNIX */
+++ /dev/null
-/*
- * tkEvent.c --
- *
- * This file provides basic event-managing facilities,
- * whereby procedure callbacks may be attached to
- * certain events.
- *
- * Copyright 1990-1992 Regents of the University of California.
- * Permission to use, copy, modify, and distribute this
- * software and its documentation for any purpose and without
- * fee is hereby granted, provided that the above copyright
- * notice appear in all copies. The University of California
- * makes no representations about the suitability of this
- * software for any purpose. It is provided "as is" without
- * express or implied warranty.
- */
-
-/* ADDED tk_GetIntervalToNextEvent */
-
-#include "tkConfig.h"
-#include "tkInt.h"
-#include <errno.h>
-#include <signal.h>
-
-/*
- * For each timer callback that's pending, there is one record
- * of the following type, chained together in a list sorted by
- * time (earliest event first).
- */
-
-typedef struct TimerEvent {
- struct timeval time; /* When timer is to fire. */
- void (*proc) _ANSI_ARGS_((ClientData clientData));
- /* Procedure to call. */
- ClientData clientData; /* Argument to pass to proc. */
- Tk_TimerToken token; /* Identifies event so it can be
- * deleted. */
- struct TimerEvent *nextPtr; /* Next event in queue, or NULL for
- * end of queue. */
-} TimerEvent;
-
-static TimerEvent *timerQueue; /* First event in queue. */
-
-/*
- * The information below is used to provide read, write, and
- * exception masks to select during calls to Tk_DoOneEvent.
- */
-
-static int readCount; /* Number of files for which we */
-static int writeCount; /* care about each event type. */
-static int exceptCount;
-#define MASK_SIZE ((OPEN_MAX+(8*sizeof(int))-1)/(8*sizeof(int)))
-static int masks[3*MASK_SIZE]; /* Integer array containing official
- * copies of the three sets of
- * masks. */
-static int ready[3*MASK_SIZE]; /* Temporary copy of masks, passed
- * to select and modified by kernel
- * to indicate which files are
- * actually ready. */
-static int *readPtr; /* Pointers to the portions of */
-static int *writePtr; /* *readyPtr for reading, writing, */
-static int *exceptPtr; /* and excepting. Will be NULL if
- * corresponding count (e.g. readCount
- * is zero. */
-static int numFds = 0; /* Number of valid bits in mask
- * arrays (this value is passed
- * to select). */
-
-/*
- * For each file registered in a call to Tk_CreateFileHandler,
- * and for each display that's currently active, there is one
- * record of the following type. All of these records are
- * chained together into a single list.
- */
-
-typedef struct FileEvent {
- int fd; /* Descriptor number for this file. */
- int *readPtr; /* Pointer to word in ready array
- * for this file's read mask bit. */
- int *writePtr; /* Same for write mask bit. */
- int *exceptPtr; /* Same for except mask bit. */
- int mask; /* Value to AND with mask word to
- * select just this file's bit. */
- void (*proc) _ANSI_ARGS_((ClientData clientData, int mask));
- /* Procedure to call. NULL means
- * this is a display. */
- ClientData clientData; /* Argument to pass to proc. For
- * displays, this is a (Display *). */
- struct FileEvent *nextPtr; /* Next in list of all files we
- * care about (NULL for end of
- * list). */
-} FileEvent;
-
-static FileEvent *fileList; /* List of all file events. */
-
-/*
- * There is one of the following structures for each of the
- * handlers declared in a call to Tk_DoWhenIdle. All of the
- * currently-active handlers are linked together into a list.
- */
-
-typedef struct IdleHandler {
- void (*proc) _ANSI_ARGS_((ClientData clientData));
- /* Procedure to call. */
- ClientData clientData; /* Value to pass to proc. */
- int generation; /* Used to distinguish older handlers from
- * recently-created ones. */
- struct IdleHandler *nextPtr;/* Next in list of active handlers. */
-} IdleHandler;
-
-static IdleHandler *idleList = NULL;
- /* First in list of all idle handlers. */
-static IdleHandler *lastIdlePtr = NULL;
- /* Last in list (or NULL for empty list). */
-static int idleGeneration = 0; /* Used to fill in the "generation" fields
- * of IdleHandler structures. Increments
- * each time Tk_DoOneEvent starts calling
- * idle handlers, so that all old handlers
- * can be called without calling any of the
- * new ones created by old ones. */
-
-/*
- * There's a potential problem if a handler is deleted while it's
- * current (i.e. its procedure is executing), since Tk_HandleEvent
- * will need to read the handler's "nextPtr" field when the procedure
- * returns. To handle this problem, structures of the type below
- * indicate the next handler to be processed for any (recursively
- * nested) dispatches in progress. The nextHandler fields get
- * updated if the handlers pointed to are deleted. Tk_HandleEvent
- * also needs to know if the entire window gets deleted; the winPtr
- * field is set to zero if that particular window gets deleted.
- */
-
-typedef struct InProgress {
- XEvent *eventPtr; /* Event currently being handled. */
- TkWindow *winPtr; /* Window for event. Gets set to None if
- * window is deleted while event is being
- * handled. */
- TkEventHandler *nextHandler; /* Next handler in search. */
- struct InProgress *nextPtr; /* Next higher nested search. */
-} InProgress;
-
-static InProgress *pendingPtr = NULL;
- /* Topmost search in progress, or
- * NULL if none. */
-
-/*
- * For each call to Tk_CreateGenericHandler, an instance of the following
- * structure will be created. All of the active handlers are linked into a
- * list.
- */
-
-typedef struct GenericHandler {
- Tk_GenericProc *proc; /* Procedure to dispatch on all X events. */
- ClientData clientData; /* Client data to pass to procedure. */
- int deleteFlag; /* Flag to set when this handler is deleted. */
- struct GenericHandler *nextPtr;
- /* Next handler in list of all generic
- * handlers, or NULL for end of list. */
-} GenericHandler;
-
-static GenericHandler *genericList = NULL;
- /* First handler in the list, or NULL. */
-static GenericHandler *lastGenericPtr = NULL;
- /* Last handler in list. */
-
-/*
- * There's a potential problem if Tk_HandleEvent is entered recursively.
- * A handler cannot be deleted physically until we have returned from
- * calling it. Otherwise, we're looking at unallocated memory in advancing to
- * its `next' entry. We deal with the problem by using the `delete flag' and
- * deleting handlers only when it's known that there's no handler active.
- *
- * The following variable has a non-zero value when a handler is active.
- */
-
-static int genericHandlersActive = 0;
-
-/*
- * Array of event masks corresponding to each X event:
- */
-
-static unsigned long eventMasks[] = {
- 0,
- 0,
- KeyPressMask, /* KeyPress */
- KeyReleaseMask, /* KeyRelease */
- ButtonPressMask, /* ButtonPress */
- ButtonReleaseMask, /* ButtonRelease */
- PointerMotionMask|PointerMotionHintMask|ButtonMotionMask
- |Button1MotionMask|Button2MotionMask|Button3MotionMask
- |Button4MotionMask|Button5MotionMask,
- /* MotionNotify */
- EnterWindowMask, /* EnterNotify */
- LeaveWindowMask, /* LeaveNotify */
- FocusChangeMask, /* FocusIn */
- FocusChangeMask, /* FocusOut */
- KeymapStateMask, /* KeymapNotify */
- ExposureMask, /* Expose */
- ExposureMask, /* GraphicsExpose */
- ExposureMask, /* NoExpose */
- VisibilityChangeMask, /* VisibilityNotify */
- SubstructureNotifyMask, /* CreateNotify */
- StructureNotifyMask, /* DestroyNotify */
- StructureNotifyMask, /* UnmapNotify */
- StructureNotifyMask, /* MapNotify */
- SubstructureRedirectMask, /* MapRequest */
- StructureNotifyMask, /* ReparentNotify */
- StructureNotifyMask, /* ConfigureNotify */
- SubstructureRedirectMask, /* ConfigureRequest */
- StructureNotifyMask, /* GravityNotify */
- ResizeRedirectMask, /* ResizeRequest */
- StructureNotifyMask, /* CirculateNotify */
- SubstructureRedirectMask, /* CirculateRequest */
- PropertyChangeMask, /* PropertyNotify */
- 0, /* SelectionClear */
- 0, /* SelectionRequest */
- 0, /* SelectionNotify */
- ColormapChangeMask, /* ColormapNotify */
- 0, /* ClientMessage */
- 0, /* Mapping Notify */
-};
-
-/*
- * If someone has called Tk_RestrictEvents, the information below
- * keeps track of it.
- */
-
-static Bool (*restrictProc) _ANSI_ARGS_((Display *display, XEvent *eventPtr,
- char *arg)); /* Procedure to call. NULL means no
- * restrictProc is currently in effect. */
-static char *restrictArg; /* Argument to pass to restrictProc. */
-
-/*
- * The following array keeps track of the last TK_NEVENTS X events, for
- * memory dump analysis. The tracing is only done if tkEventDebug is set
- * to 1.
- */
-
-#define TK_NEVENTS 32
-static XEvent eventTrace[TK_NEVENTS];
-static int traceIndex = 0;
-int tkEventDebug = 0;
-\f
-long tk_GetIntervalToNextEvent()
-/* Returns next time event in milliseconds (from now) */
-{ struct timeval curTime, timeout, *timeoutPtr;
-
- if (idleList != NULL) return 0; /* Ready NOW */
- if (timerQueue == NULL) return -1;
- (void) gettimeofday(&curTime, (struct timezone *) NULL);
- if ((timerQueue->time.tv_sec < curTime.tv_sec)
- || ((timerQueue->time.tv_sec == curTime.tv_sec)
- && (timerQueue->time.tv_usec < curTime.tv_usec)))
- return 0; /* Already expired, so do it NOW */
- return (((curTime.tv_sec - timerQueue->time.tv_sec) * 1000) +
- (((curTime.tv_usec - timerQueue->time.tv_usec) + 500) /
- 1000));
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * Tk_CreateEventHandler --
- *
- * Arrange for a given procedure to be invoked whenever
- * events from a given class occur in a given window.
- *
- * Results:
- * None.
- *
- * Side effects:
- * From now on, whenever an event of the type given by
- * mask occurs for token and is processed by Tk_HandleEvent,
- * proc will be called. See the manual entry for details
- * of the calling sequence and return value for proc.
- *
- *--------------------------------------------------------------
- */
-
-void
-Tk_CreateEventHandler(token, mask, proc, clientData)
- Tk_Window token; /* Token for window in which to
- * create handler. */
- unsigned long mask; /* Events for which proc should
- * be called. */
- Tk_EventProc *proc; /* Procedure to call for each
- * selected event */
- ClientData clientData; /* Arbitrary data to pass to proc. */
-{
- register TkEventHandler *handlerPtr;
- register TkWindow *winPtr = (TkWindow *) token;
- int found;
-
- /*
- * Skim through the list of existing handlers to (a) compute the
- * overall event mask for the window (so we can pass this new
- * value to the X system) and (b) see if there's already a handler
- * declared with the same callback and clientData (if so, just
- * change the mask). If no existing handler matches, then create
- * a new handler.
- */
-
- found = 0;
- if (winPtr->handlerList == NULL) {
- handlerPtr = (TkEventHandler *) ckalloc(
- (unsigned) sizeof(TkEventHandler));
- winPtr->handlerList = handlerPtr;
- goto initHandler;
- } else {
- for (handlerPtr = winPtr->handlerList; ;
- handlerPtr = handlerPtr->nextPtr) {
- if ((handlerPtr->proc == proc)
- && (handlerPtr->clientData == clientData)) {
- handlerPtr->mask = mask;
- found = 1;
- }
- if (handlerPtr->nextPtr == NULL) {
- break;
- }
- }
- }
-
- /*
- * Create a new handler if no matching old handler was found.
- */
-
- if (!found) {
- handlerPtr->nextPtr = (TkEventHandler *)
- ckalloc(sizeof(TkEventHandler));
- handlerPtr = handlerPtr->nextPtr;
- initHandler:
- handlerPtr->mask = mask;
- handlerPtr->proc = proc;
- handlerPtr->clientData = clientData;
- handlerPtr->nextPtr = NULL;
- }
-
- /*
- * No need to call XSelectInput: Tk always selects on all events
- * for all windows (needed to support bindings on classes and "all").
- */
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * Tk_DeleteEventHandler --
- *
- * Delete a previously-created handler.
- *
- * Results:
- * None.
- *
- * Side effects:
- * If there existed a handler as described by the
- * parameters, the handler is deleted so that proc
- * will not be invoked again.
- *
- *--------------------------------------------------------------
- */
-
-void
-Tk_DeleteEventHandler(token, mask, proc, clientData)
- Tk_Window token; /* Same as corresponding arguments passed */
- unsigned long mask; /* previously to Tk_CreateEventHandler. */
- Tk_EventProc *proc;
- ClientData clientData;
-{
- register TkEventHandler *handlerPtr;
- register InProgress *ipPtr;
- TkEventHandler *prevPtr;
- register TkWindow *winPtr = (TkWindow *) token;
-
- /*
- * Find the event handler to be deleted, or return
- * immediately if it doesn't exist.
- */
-
- for (handlerPtr = winPtr->handlerList, prevPtr = NULL; ;
- prevPtr = handlerPtr, handlerPtr = handlerPtr->nextPtr) {
- if (handlerPtr == NULL) {
- return;
- }
- if ((handlerPtr->mask == mask) && (handlerPtr->proc == proc)
- && (handlerPtr->clientData == clientData)) {
- break;
- }
- }
-
- /*
- * If Tk_HandleEvent is about to process this handler, tell it to
- * process the next one instead.
- */
-
- for (ipPtr = pendingPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
- if (ipPtr->nextHandler == handlerPtr) {
- ipPtr->nextHandler = handlerPtr->nextPtr;
- }
- }
-
- /*
- * Free resources associated with the handler.
- */
-
- if (prevPtr == NULL) {
- winPtr->handlerList = handlerPtr->nextPtr;
- } else {
- prevPtr->nextPtr = handlerPtr->nextPtr;
- }
- ckfree((char *) handlerPtr);
-
-
- /*
- * No need to call XSelectInput: Tk always selects on all events
- * for all windows (needed to support bindings on classes and "all").
- */
-}
-\f
-/*--------------------------------------------------------------
- *
- * Tk_CreateGenericHandler --
- *
- * Register a procedure to be called on each X event, regardless
- * of display or window. Generic handlers are useful for capturing
- * events that aren't associated with windows, or events for windows
- * not managed by Tk.
- *
- * Results:
- * None.
- *
- * Side Effects:
- * From now on, whenever an X event is given to Tk_HandleEvent,
- * invoke proc, giving it clientData and the event as arguments.
- *
- *--------------------------------------------------------------
- */
-
-void
-Tk_CreateGenericHandler(proc, clientData)
- Tk_GenericProc *proc; /* Procedure to call on every event. */
- ClientData clientData; /* One-word value to pass to proc. */
-{
- GenericHandler *handlerPtr;
-
- handlerPtr = (GenericHandler *) ckalloc (sizeof (GenericHandler));
-
- handlerPtr->proc = proc;
- handlerPtr->clientData = clientData;
- handlerPtr->deleteFlag = 0;
- handlerPtr->nextPtr = NULL;
- if (genericList == NULL) {
- genericList = handlerPtr;
- } else {
- lastGenericPtr->nextPtr = handlerPtr;
- }
- lastGenericPtr = handlerPtr;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * Tk_DeleteGenericHandler --
- *
- * Delete a previously-created generic handler.
- *
- * Results:
- * None.
- *
- * Side Effects:
- * If there existed a handler as described by the parameters,
- * that handler is logically deleted so that proc will not be
- * invoked again. The physical deletion happens in the event
- * loop in Tk_HandleEvent.
- *
- *--------------------------------------------------------------
- */
-
-void
-Tk_DeleteGenericHandler(proc, clientData)
- Tk_GenericProc *proc;
- ClientData clientData;
-{
- GenericHandler * handler;
-
- for (handler = genericList; handler; handler = handler->nextPtr) {
- if ((handler->proc == proc) && (handler->clientData == clientData)) {
- handler->deleteFlag = 1;
- }
- }
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * Tk_HandleEvent --
- *
- * Given an event, invoke all the handlers that have
- * been registered for the event.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Depends on the handlers.
- *
- *--------------------------------------------------------------
- */
-
-void
-Tk_HandleEvent(eventPtr)
- XEvent *eventPtr; /* Event to dispatch. */
-{
- register TkEventHandler *handlerPtr;
- register GenericHandler *genericPtr;
- register GenericHandler *genPrevPtr;
- TkWindow *winPtr;
- register unsigned long mask;
- InProgress ip;
- Window handlerWindow;
-
- /*
- * First off, look for a special trigger event left around by the
- * grab module. If it's found, call the grab module and discard
- * the event.
- */
-
- if ((eventPtr->xany.type == -1) && (eventPtr->xany.window == None)) {
- TkGrabTriggerProc(eventPtr);
- return;
- }
-
- /*
- * Next, invoke all the generic event handlers (those that are
- * invoked for all events). If a generic event handler reports that
- * an event is fully processed, go no further.
- */
-
- for (genPrevPtr = NULL, genericPtr = genericList; genericPtr != NULL; ) {
- if (genericPtr->deleteFlag) {
- if (!genericHandlersActive) {
- GenericHandler *tmpPtr;
-
- /*
- * This handler needs to be deleted and there are no
- * calls pending through the handler, so now is a safe
- * time to delete it.
- */
-
- tmpPtr = genericPtr->nextPtr;
- if (genPrevPtr == NULL) {
- genericList = tmpPtr;
- } else {
- genPrevPtr->nextPtr = tmpPtr;
- }
- (void) ckfree((char *) genericPtr);
- genericPtr = tmpPtr;
- continue;
- }
- } else {
- int done;
-
- genericHandlersActive++;
- done = (*genericPtr->proc)(genericPtr->clientData, eventPtr);
- genericHandlersActive--;
- if (done) {
- return;
- }
- }
- genPrevPtr = genericPtr;
- genericPtr = genPrevPtr->nextPtr;
- }
-
- /*
- * If the event is a MappingNotify event, find its display and
- * refresh the keyboard mapping information for the display.
- * After that there's nothing else to do with the event, so just
- * quit.
- */
-
- if (eventPtr->type == MappingNotify) {
- TkDisplay *dispPtr;
-
- for (dispPtr = tkDisplayList; dispPtr != NULL;
- dispPtr = dispPtr->nextPtr) {
- if (dispPtr->display != eventPtr->xmapping.display) {
- continue;
- }
- XRefreshKeyboardMapping(&eventPtr->xmapping);
- dispPtr->bindInfoStale = 1;
- break;
- }
- return;
- }
-
- /*
- * Events selected by StructureNotify look the same as those
- * selected by SubstructureNotify; the only difference is
- * whether the "event" and "window" fields are the same.
- * Check it out and convert StructureNotify to
- * SubstructureNotify if necessary.
- */
-
- handlerWindow = eventPtr->xany.window;
- mask = eventMasks[eventPtr->xany.type];
- if (mask == StructureNotifyMask) {
- if (eventPtr->xmap.event != eventPtr->xmap.window) {
- mask = SubstructureNotifyMask;
- handlerWindow = eventPtr->xmap.event;
- }
- }
- if (XFindContext(eventPtr->xany.display, handlerWindow,
- tkWindowContext, (caddr_t *) &winPtr) != 0) {
-
- /*
- * There isn't a TkWindow structure for this window.
- * However, if the event is a PropertyNotify event then call
- * the selection manager (it deals beneath-the-table with
- * certain properties).
- */
-
- if (eventPtr->type == PropertyNotify) {
- TkSelPropProc(eventPtr);
- }
- return;
- }
-
- /*
- * Call focus-related code to look at FocusIn, FocusOut, Enter,
- * and Leave events; depending on its return value, ignore the
- * event.
- */
-
- if ((mask & (FocusChangeMask|EnterWindowMask|LeaveWindowMask))
- && !TkFocusFilterEvent(winPtr, eventPtr)) {
- return;
- }
-
- /*
- * Redirect KeyPress and KeyRelease events to the focus window,
- * or ignore them entirely if there is no focus window. Map the
- * x and y coordinates to make sense in the context of the focus
- * window, if possible (make both -1 if the map-from and map-to
- * windows don't share the same screen).
- */
-
- if (mask & (KeyPressMask|KeyReleaseMask)) {
- TkWindow *focusPtr;
- int winX, winY, focusX, focusY;
-
- winPtr->dispPtr->lastEventTime = eventPtr->xkey.time;
- if (winPtr->mainPtr->focusPtr == NULL) {
- return;
- }
- focusPtr = winPtr->mainPtr->focusPtr;
- if ((focusPtr->display != winPtr->display)
- || (focusPtr->screenNum != winPtr->screenNum)) {
- eventPtr->xkey.x = -1;
- eventPtr->xkey.y = -1;
- } else {
- Tk_GetRootCoords((Tk_Window) winPtr, &winX, &winY);
- Tk_GetRootCoords((Tk_Window) focusPtr, &focusX, &focusY);
- eventPtr->xkey.x -= focusX - winX;
- eventPtr->xkey.y -= focusY - winY;
- }
- eventPtr->xkey.window = focusPtr->window;
- winPtr = focusPtr;
- }
-
- /*
- * Call a grab-related procedure to do special processing on
- * pointer events.
- */
-
- if (mask & (ButtonPressMask|ButtonReleaseMask|PointerMotionMask
- |EnterWindowMask|LeaveWindowMask)) {
- if (mask & (ButtonPressMask|ButtonReleaseMask)) {
- winPtr->dispPtr->lastEventTime = eventPtr->xbutton.time;
- } else if (mask & PointerMotionMask) {
- winPtr->dispPtr->lastEventTime = eventPtr->xmotion.time;
- } else {
- winPtr->dispPtr->lastEventTime = eventPtr->xcrossing.time;
- }
- if (TkPointerEvent(eventPtr, winPtr) == 0) {
- return;
- }
- }
-
- /*
- * For events where it hasn't already been done, update the current
- * time in the display.
- */
-
- if (eventPtr->type == PropertyNotify) {
- winPtr->dispPtr->lastEventTime = eventPtr->xproperty.time;
- }
-
- /*
- * There's a potential interaction here with Tk_DeleteEventHandler.
- * Read the documentation for pendingPtr.
- */
-
- ip.eventPtr = eventPtr;
- ip.winPtr = winPtr;
- ip.nextHandler = NULL;
- ip.nextPtr = pendingPtr;
- pendingPtr = &ip;
- if (mask == 0) {
- if ((eventPtr->type == SelectionClear)
- || (eventPtr->type == SelectionRequest)
- || (eventPtr->type == SelectionNotify)) {
- TkSelEventProc((Tk_Window) winPtr, eventPtr);
- } else if ((eventPtr->type == ClientMessage)
- && (eventPtr->xclient.message_type ==
- Tk_InternAtom((Tk_Window) winPtr, "WM_PROTOCOLS"))) {
- TkWmProtocolEventProc(winPtr, eventPtr);
- }
- } else {
- for (handlerPtr = winPtr->handlerList; handlerPtr != NULL; ) {
- if ((handlerPtr->mask & mask) != 0) {
- ip.nextHandler = handlerPtr->nextPtr;
- (*(handlerPtr->proc))(handlerPtr->clientData, eventPtr);
- handlerPtr = ip.nextHandler;
- } else {
- handlerPtr = handlerPtr->nextPtr;
- }
- }
-
- /*
- * Pass the event to the "bind" command mechanism. But, don't
- * do this for SubstructureNotify events. The "bind" command
- * doesn't support them anyway, and it's easier to filter out
- * these events here than in the lower-level procedures.
- */
-
- if ((ip.winPtr != None) && (mask != SubstructureNotifyMask)) {
- TkBindEventProc(winPtr, eventPtr);
- }
- }
- pendingPtr = ip.nextPtr;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * Tk_CreateFileHandler --
- *
- * Arrange for a given procedure to be invoked whenever
- * a given file becomes readable or writable.
- *
- * Results:
- * None.
- *
- * Side effects:
- * From now on, whenever the I/O channel given by fd becomes
- * ready in the way indicated by mask, proc will be invoked.
- * See the manual entry for details on the calling sequence
- * to proc. If fd is already registered then the old mask
- * and proc and clientData values will be replaced with
- * new ones.
- *
- *--------------------------------------------------------------
- */
-
-void
-Tk_CreateFileHandler(fd, mask, proc, clientData)
- int fd; /* Integer identifier for stream. */
- int mask; /* OR'ed combination of TK_READABLE,
- * TK_WRITABLE, and TK_EXCEPTION:
- * indicates conditions under which
- * proc should be called. */
- Tk_FileProc *proc; /* Procedure to call for each
- * selected event. NULL means that
- * this is a display, and that
- * clientData is the (Display *)
- * for it, and that events should
- * be handled automatically. */
- ClientData clientData; /* Arbitrary data to pass to proc. */
-{
- register FileEvent *filePtr;
- int index;
-
- if (fd >= OPEN_MAX) {
- panic("Tk_CreatefileHandler can't handle file id %d", fd);
- }
-
- /*
- * Make sure the file isn't already registered. Create a
- * new record in the normal case where there's no existing
- * record.
- */
-
- for (filePtr = fileList; filePtr != NULL;
- filePtr = filePtr->nextPtr) {
- if (filePtr->fd == fd) {
- break;
- }
- }
- index = fd/(8*sizeof(int));
- if (filePtr == NULL) {
- filePtr = (FileEvent *) ckalloc(sizeof(FileEvent));
- filePtr->fd = fd;
- filePtr->readPtr = &ready[index];
- filePtr->writePtr = &ready[index+MASK_SIZE];
- filePtr->exceptPtr = &ready[index+2*MASK_SIZE];
- filePtr->mask = 1 << (fd%(8*sizeof(int)));
- filePtr->nextPtr = fileList;
- fileList = filePtr;
- } else {
- if (masks[index] & filePtr->mask) {
- readCount--;
- *filePtr->readPtr &= ~filePtr->mask;
- masks[index] &= ~filePtr->mask;
- }
- if (masks[index+MASK_SIZE] & filePtr->mask) {
- writeCount--;
- *filePtr->writePtr &= ~filePtr->mask;
- masks[index+MASK_SIZE] &= ~filePtr->mask;
- }
- if (masks[index+2*MASK_SIZE] & filePtr->mask) {
- exceptCount--;
- *filePtr->exceptPtr &= ~filePtr->mask;
- masks[index+2*MASK_SIZE] &= ~filePtr->mask;
- }
- }
-
- /*
- * The remainder of the initialization below is done
- * regardless of whether or not this is a new record
- * or a modification of an old one.
- */
-
- if (mask & TK_READABLE) {
- masks[index] |= filePtr->mask;
- readCount++;
- }
- readPtr = (readCount == 0) ? (int *) NULL : &ready[0];
-
- if (mask & TK_WRITABLE) {
- masks[index+MASK_SIZE] |= filePtr->mask;
- writeCount++;
- }
- writePtr = (writeCount == 0) ? (int *) NULL : &ready[MASK_SIZE];
-
- if (mask & TK_EXCEPTION) {
- masks[index+2*MASK_SIZE] |= filePtr->mask;
- exceptCount++;
- }
- exceptPtr = (exceptCount == 0) ? (int *) NULL : &ready[2*MASK_SIZE];
-
- filePtr->proc = proc;
- filePtr->clientData = clientData;
-
- if (numFds <= fd) {
- numFds = fd+1;
- }
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * Tk_DeleteFileHandler --
- *
- * Cancel a previously-arranged callback arrangement for
- * a file.
- *
- * Results:
- * None.
- *
- * Side effects:
- * If a callback was previously registered on fd, remove it.
- *
- *--------------------------------------------------------------
- */
-
-void
-Tk_DeleteFileHandler(fd)
- int fd; /* Stream id for which to remove
- * callback procedure. */
-{
- register FileEvent *filePtr;
- FileEvent *prevPtr;
- int index;
-
- /*
- * Find the entry for the given file (and return if there
- * isn't one).
- */
-
- for (prevPtr = NULL, filePtr = fileList; ;
- prevPtr = filePtr, filePtr = filePtr->nextPtr) {
- if (filePtr == NULL) {
- return;
- }
- if (filePtr->fd == fd) {
- break;
- }
- }
-
- /*
- * Clean up information in the callback record.
- */
-
- index = filePtr->fd/(8*sizeof(int));
- if (masks[index] & filePtr->mask) {
- readCount--;
- *filePtr->readPtr &= ~filePtr->mask;
- masks[index] &= ~filePtr->mask;
- }
- if (masks[index+MASK_SIZE] & filePtr->mask) {
- writeCount--;
- *filePtr->writePtr &= ~filePtr->mask;
- masks[index+MASK_SIZE] &= ~filePtr->mask;
- }
- if (masks[index+2*MASK_SIZE] & filePtr->mask) {
- exceptCount--;
- *filePtr->exceptPtr &= ~filePtr->mask;
- masks[index+2*MASK_SIZE] &= ~filePtr->mask;
- }
- if (prevPtr == NULL) {
- fileList = filePtr->nextPtr;
- } else {
- prevPtr->nextPtr = filePtr->nextPtr;
- }
- ckfree((char *) filePtr);
-
- /*
- * Recompute numFds.
- */
-
- numFds = 0;
- for (filePtr = fileList; filePtr != NULL;
- filePtr = filePtr->nextPtr) {
- if (numFds <= filePtr->fd) {
- numFds = filePtr->fd+1;
- }
- }
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * Tk_CreateTimerHandler --
- *
- * Arrange for a given procedure to be invoked at a particular
- * time in the future.
- *
- * Results:
- * The return value is a token for the timer event, which
- * may be used to delete the event before it fires.
- *
- * Side effects:
- * When milliseconds have elapsed, proc will be invoked
- * exactly once.
- *
- *--------------------------------------------------------------
- */
-
-Tk_TimerToken
-Tk_CreateTimerHandler(milliseconds, proc, clientData)
- int milliseconds; /* How many milliseconds to wait
- * before invoking proc. */
- Tk_TimerProc *proc; /* Procedure to invoke. */
- ClientData clientData; /* Arbitrary data to pass to proc. */
-{
- register TimerEvent *timerPtr, *tPtr2, *prevPtr;
- static int id = 0;
-
- timerPtr = (TimerEvent *) ckalloc(sizeof(TimerEvent));
-
- /*
- * Compute when the event should fire.
- */
-
- (void) gettimeofday(&timerPtr->time, (struct timezone *) NULL);
- timerPtr->time.tv_sec += milliseconds/1000;
- timerPtr->time.tv_usec += (milliseconds%1000)*1000;
- if (timerPtr->time.tv_usec > 1000000) {
- timerPtr->time.tv_usec -= 1000000;
- timerPtr->time.tv_sec += 1;
- }
-
- /*
- * Fill in other fields for the event.
- */
-
- timerPtr->proc = proc;
- timerPtr->clientData = clientData;
- id++;
- timerPtr->token = (Tk_TimerToken) id;
-
- /*
- * Add the event to the queue in the correct position
- * (ordered by event firing time).
- */
-
- for (tPtr2 = timerQueue, prevPtr = NULL; tPtr2 != NULL;
- prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) {
- if ((tPtr2->time.tv_sec > timerPtr->time.tv_sec)
- || ((tPtr2->time.tv_sec == timerPtr->time.tv_sec)
- && (tPtr2->time.tv_usec > timerPtr->time.tv_usec))) {
- break;
- }
- }
- if (prevPtr == NULL) {
- timerPtr->nextPtr = timerQueue;
- timerQueue = timerPtr;
- } else {
- timerPtr->nextPtr = prevPtr->nextPtr;
- prevPtr->nextPtr = timerPtr;
- }
- return timerPtr->token;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * Tk_DeleteTimerHandler --
- *
- * Delete a previously-registered timer handler.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Destroy the timer callback identified by TimerToken,
- * so that its associated procedure will not be called.
- * If the callback has already fired, or if the given
- * token doesn't exist, then nothing happens.
- *
- *--------------------------------------------------------------
- */
-
-void
-Tk_DeleteTimerHandler(token)
- Tk_TimerToken token; /* Result previously returned by
- * Tk_DeleteTimerHandler. */
-{
- register TimerEvent *timerPtr, *prevPtr;
-
- for (timerPtr = timerQueue, prevPtr = NULL; timerPtr != NULL;
- prevPtr = timerPtr, timerPtr = timerPtr->nextPtr) {
- if (timerPtr->token != token) {
- continue;
- }
- if (prevPtr == NULL) {
- timerQueue = timerPtr->nextPtr;
- } else {
- prevPtr->nextPtr = timerPtr->nextPtr;
- }
- ckfree((char *) timerPtr);
- return;
- }
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * Tk_DoWhenIdle --
- *
- * Arrange for proc to be invoked the next time the
- * system is idle (i.e., just before the next time
- * that Tk_DoOneEvent would have to wait for something
- * to happen).
- *
- * Results:
- * None.
- *
- * Side effects:
- * Proc will eventually be called, with clientData
- * as argument. See the manual entry for details.
- *
- *--------------------------------------------------------------
- */
-
-void
-Tk_DoWhenIdle(proc, clientData)
- Tk_IdleProc *proc; /* Procedure to invoke. */
- ClientData clientData; /* Arbitrary value to pass to proc. */
-{
- register IdleHandler *idlePtr;
-
- idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler));
- idlePtr->proc = proc;
- idlePtr->clientData = clientData;
- idlePtr->generation = idleGeneration;
- idlePtr->nextPtr = NULL;
- if (lastIdlePtr == NULL) {
- idleList = idlePtr;
- } else {
- lastIdlePtr->nextPtr = idlePtr;
- }
- lastIdlePtr = idlePtr;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tk_CancelIdleCall --
- *
- * If there are any when-idle calls requested to a given procedure
- * with given clientData, cancel all of them.
- *
- * Results:
- * None.
- *
- * Side effects:
- * If the proc/clientData combination were on the when-idle list,
- * they are removed so that they will never be called.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tk_CancelIdleCall(proc, clientData)
- Tk_IdleProc *proc; /* Procedure that was previously registered. */
- ClientData clientData; /* Arbitrary value to pass to proc. */
-{
- register IdleHandler *idlePtr, *prevPtr;
- IdleHandler *nextPtr;
-
- for (prevPtr = NULL, idlePtr = idleList; idlePtr != NULL;
- prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) {
- while ((idlePtr->proc == proc)
- && (idlePtr->clientData == clientData)) {
- nextPtr = idlePtr->nextPtr;
- ckfree((char *) idlePtr);
- idlePtr = nextPtr;
- if (prevPtr == NULL) {
- idleList = idlePtr;
- } else {
- prevPtr->nextPtr = idlePtr;
- }
- if (idlePtr == NULL) {
- lastIdlePtr = prevPtr;
- return;
- }
- }
- }
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * Tk_DoOneEvent --
- *
- * Process a single event of some sort. If there's no
- * work to do, wait for an event to occur, then process
- * it.
- *
- * Results:
- * The return value is 1 if the procedure actually found
- * an event to process. If no event was found then 0 is
- * returned.
- *
- * Side effects:
- * May delay execution of process while waiting for an
- * X event, X error, file-ready event, or timer event.
- * The handling of the event could cause additional
- * side effects. Collapses sequences of mouse-motion
- * events for the same window into a single event by
- * delaying motion event processing.
- *
- *--------------------------------------------------------------
- */
-
-int
-Tk_DoOneEvent(flags)
- int flags; /* Miscellaneous flag values: may be any
- * combination of TK_DONT_WAIT, TK_X_EVENTS,
- * TK_FILE_EVENTS, TK_TIMER_EVENTS, and
- * TK_IDLE_EVENTS. */
-{
- register FileEvent *filePtr;
- struct timeval curTime, timeout, *timeoutPtr;
- int numFound;
- static XEvent delayedMotionEvent; /* Used to hold motion events that
- * are being saved until later. */
- static int eventDelayed = 0; /* Non-zero means there is an event
- * in delayedMotionEvent. */
-
- if ((flags & TK_ALL_EVENTS) == 0) {
- flags |= TK_ALL_EVENTS;
- }
-
- /*
- * Phase One: see if there's already something ready
- * (either a file or a display) that was left over
- * from before (i.e don't do a select, just check the
- * bits from the last select).
- */
-
- checkFiles:
- for (filePtr = fileList; filePtr != NULL;
- filePtr = filePtr->nextPtr) {
- int mask;
-
- /*
- * Displays: flush output, check for queued events,
- * and read events from the server if display is ready.
- * If there are any events, process one and then
- * return.
- */
-
- if ((filePtr->proc == NULL) && (flags & TK_X_EVENTS)) {
- Display *display = (Display *) filePtr->clientData;
- XEvent event;
-
- XFlush(display);
- if ((*filePtr->readPtr) & filePtr->mask) {
- *filePtr->readPtr &= ~filePtr->mask;
- if (XEventsQueued(display, QueuedAfterReading) == 0) {
-
- /*
- * Things are very tricky if there aren't any events
- * readable at this point (after all, there was
- * supposedly data available on the connection).
- * A couple of things could have occurred:
- *
- * One possibility is that there were only error events
- * in the input from the server. If this happens,
- * we should return (we don't want to go to sleep
- * in XNextEvent below, since this would block out
- * other sources of input to the process).
- *
- * Another possibility is that our connection to the
- * server has been closed. This will not necessarily
- * be detected in XEventsQueued (!!), so if we just
- * return then there will be an infinite loop. To
- * detect such an error, generate a NoOp protocol
- * request to exercise the connection to the server,
- * then return. However, must disable SIGPIPE while
- * sending the event, or else the process will die
- * from the signal and won't invoke the X error
- * function to print a nice message.
- */
-
- void (*oldHandler)();
-
- oldHandler = (void (*)()) signal(SIGPIPE, SIG_IGN);
- XNoOp(display);
- XFlush(display);
- (void) signal(SIGPIPE, oldHandler);
- return 1;
- }
- if (restrictProc != NULL) {
- if (!XCheckIfEvent(display, &event, restrictProc,
- restrictArg)) {
- return 1;
- }
- } else {
- XNextEvent(display, &event);
- }
- } else {
- if (QLength(display) == 0) {
- continue;
- }
- if (restrictProc != NULL) {
- if (!XCheckIfEvent(display, &event, restrictProc,
- restrictArg)) {
- continue;
- }
- } else {
- XNextEvent(display, &event);
- }
- }
-
- /*
- * Got an event. Deal with mouse-motion-collapsing and
- * event-delaying here. If there's already an event delayed,
- * then process that event if it's incompatible with the new
- * event (new event not mouse motion, or window changed, or
- * state changed). If the new event is mouse motion, then
- * don't process it now; delay it until later in the hopes
- * that it can be merged with other mouse motion events
- * immediately following.
- */
-
- if (tkEventDebug) {
- eventTrace[traceIndex] = event;
- traceIndex = (traceIndex+1) % TK_NEVENTS;
- }
-
- if (eventDelayed) {
- if (((event.type != MotionNotify)
- && (event.type != GraphicsExpose)
- && (event.type != NoExpose)
- && (event.type != Expose))
- || (event.xmotion.display
- != delayedMotionEvent.xmotion.display)
- || (event.xmotion.window
- != delayedMotionEvent.xmotion.window)) {
- XEvent copy;
-
- /*
- * Must copy the event out of delayedMotionEvent before
- * processing it, in order to allow recursive calls to
- * Tk_DoOneEvent as part of the handler.
- */
-
- copy = delayedMotionEvent;
- eventDelayed = 0;
- Tk_HandleEvent(©);
- }
- }
- if (event.type == MotionNotify) {
- delayedMotionEvent = event;
- eventDelayed = 1;
- } else {
- Tk_HandleEvent(&event);
- }
- return 1;
- }
-
- /*
- * Not a display: if the file is ready, call the
- * appropriate handler.
- */
-
- if (((*filePtr->readPtr | *filePtr->writePtr
- | *filePtr->exceptPtr) & filePtr->mask) == 0) {
- continue;
- }
- if (!(flags & TK_FILE_EVENTS)) {
- continue;
- }
- mask = 0;
- if (*filePtr->readPtr & filePtr->mask) {
- mask |= TK_READABLE;
- *filePtr->readPtr &= ~filePtr->mask;
- }
- if (*filePtr->writePtr & filePtr->mask) {
- mask |= TK_WRITABLE;
- *filePtr->writePtr &= ~filePtr->mask;
- }
- if (*filePtr->exceptPtr & filePtr->mask) {
- mask |= TK_EXCEPTION;
- *filePtr->exceptPtr &= ~filePtr->mask;
- }
- (*filePtr->proc)(filePtr->clientData, mask);
- return 1;
- }
-
- /*
- * Phase Two: get the current time and see if any timer
- * events are ready to fire. If so, fire one and return.
- */
-
- checkTime:
- if ((timerQueue != NULL) && (flags & TK_TIMER_EVENTS)) {
- register TimerEvent *timerPtr = timerQueue;
-
- (void) gettimeofday(&curTime, (struct timezone *) NULL);
- if ((timerPtr->time.tv_sec < curTime.tv_sec)
- || ((timerPtr->time.tv_sec == curTime.tv_sec)
- && (timerPtr->time.tv_usec < curTime.tv_usec))) {
- timerQueue = timerPtr->nextPtr;
- (*timerPtr->proc)(timerPtr->clientData);
- ckfree((char *) timerPtr);
- return 1;
- }
- }
-
-
- /*
- * Phase Three: if there is a delayed motion event, process it
- * now, before any DoWhenIdle handlers. Better to process before
- * idle handlers than after, because the goal of idle handlers is
- * to delay until after all pending events have been processed.
- * Must free up delayedMotionEvent *before* calling Tk_HandleEvent,
- * so that the event handler can call Tk_DoOneEvent recursively
- * without infinite looping.
- */
-
- if ((eventDelayed) && (flags & TK_X_EVENTS)) {
- XEvent copy;
-
- copy = delayedMotionEvent;
- eventDelayed = 0;
- Tk_HandleEvent(©);
- return 1;
- }
-
- /*
- * Phase Four: if there are DoWhenIdle requests pending (or
- * if we're not allowed to block), then do a select with an
- * instantaneous timeout. If a ready file is found, then go
- * back to process it.
- */
-
- if (((idleList != NULL) && (flags & TK_IDLE_EVENTS))
- || (flags & TK_DONT_WAIT)) {
- if (flags & (TK_X_EVENTS|TK_FILE_EVENTS)) {
- memcpy((VOID *) ready, (VOID *) masks, 3*MASK_SIZE*sizeof(int));
- timeout.tv_sec = timeout.tv_usec = 0;
- do {
- numFound = select(numFds, (SELECT_MASK *) readPtr,
- (SELECT_MASK *) writePtr, (SELECT_MASK *) exceptPtr,
- &timeout);
- } while ((numFound == -1) && (errno == EINTR));
- if (numFound > 0) {
- goto checkFiles;
- }
- }
- }
-
- /*
- * Phase Five: process all pending DoWhenIdle requests.
- */
-
- if ((idleList != NULL) && (flags & TK_IDLE_EVENTS)) {
- register IdleHandler *idlePtr;
- int oldGeneration;
-
- oldGeneration = idleList->generation;
- idleGeneration++;
-
- /*
- * The code below is trickier than it may look, for the following
- * reasons:
- *
- * 1. New handlers can get added to the list while the current
- * one is being processed. If new ones get added, we don't
- * want to process them during this pass through the list (want
- * to check for other work to do first). This is implemented
- * using the generation number in the handler: new handlers
- * will have a different generation than any of the ones currently
- * on the list.
- * 2. The handler can call Tk_DoOneEvent, so we have to remove
- * the hander from the list before calling it. Otherwise an
- * infinite loop could result.
- * 3. Tk_CancelIdleCall can be called to remove an element from
- * the list while a handler is executing, so the list could
- * change structure during the call.
- */
-
- for (idlePtr = idleList;
- ((idlePtr != NULL) && (idlePtr->generation == oldGeneration));
- idlePtr = idleList) {
- /* fprintf(stderr, "Phase5A"); Here is where it is looping */
- idleList = idlePtr->nextPtr;
- if (idleList == NULL) {
- lastIdlePtr = NULL;
- }
- (*idlePtr->proc)(idlePtr->clientData);
- ckfree((char *) idlePtr);
- }
- return 1;
- }
-
- /*
- * Phase Six: do a select to wait for either one of the
- * files to become ready or for the first timer event to
- * fire. Then go back to process the event.
- */
-
- if ((flags & TK_DONT_WAIT)
- || !(flags & (TK_TIMER_EVENTS|TK_FILE_EVENTS|TK_X_EVENTS))) {
- return 0;
- }
- if ((timerQueue == NULL) || !(flags & TK_TIMER_EVENTS)) {
- timeoutPtr = NULL;
- } else {
- timeoutPtr = &timeout;
- timeout.tv_sec = timerQueue->time.tv_sec - curTime.tv_sec;
- timeout.tv_usec = timerQueue->time.tv_usec - curTime.tv_usec;
- if (timeout.tv_usec < 0) {
- timeout.tv_sec -= 1;
- timeout.tv_usec += 1000000;
- }
- }
- memcpy((VOID *) ready, (VOID *) masks, 3*MASK_SIZE*sizeof(int));
- do {
- numFound = select(numFds, (SELECT_MASK *) readPtr,
- (SELECT_MASK *) writePtr, (SELECT_MASK *) exceptPtr,
- timeoutPtr);
- } while ((numFound == -1) && (errno == EINTR));
- if (numFound == 0) {
- goto checkTime;
- }
- goto checkFiles;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * Tk_MainLoop --
- *
- * Call Tk_DoOneEvent over and over again in an infinite
- * loop as long as there exist any main windows.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Arbitrary; depends on handlers for events.
- *
- *--------------------------------------------------------------
- */
-
-void
-Tk_MainLoop()
-{
- while (tk_NumMainWindows > 0) {
- Tk_DoOneEvent(0);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tk_Sleep --
- *
- * Delay execution for the specified number of milliseconds.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Time passes.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tk_Sleep(ms)
- int ms; /* Number of milliseconds to sleep. */
-{
- static struct timeval delay;
-
- delay.tv_sec = ms/1000;
- delay.tv_usec = (ms%1000)*1000;
- (void) select(0, (SELECT_MASK *) 0, (SELECT_MASK *) 0,
- (SELECT_MASK *) 0, &delay);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tk_RestrictEvents --
- *
- * This procedure is used to globally restrict the set of events
- * that will be dispatched. The restriction is done by filtering
- * all incoming X events through a procedure that determines
- * whether they are to be processed immediately or deferred.
- *
- * Results:
- * The return value is the previous restriction procedure in effect,
- * if there was one, or NULL if there wasn't.
- *
- * Side effects:
- * From now on, proc will be called to determine whether to process
- * or defer each incoming X event.
- *
- *----------------------------------------------------------------------
- */
-
-Tk_RestrictProc *
-Tk_RestrictEvents(proc, arg, prevArgPtr)
- Tk_RestrictProc *proc; /* X "if" procedure to call for each
- * incoming event. See "XIfEvent" doc.
- * for details. */
- char *arg; /* Arbitrary argument to pass to proc. */
- char **prevArgPtr; /* Place to store information about previous
- * argument. */
-{
- Bool (*prev) _ANSI_ARGS_((Display *display, XEvent *eventPtr, char *arg));
-
- prev = restrictProc;
- *prevArgPtr = restrictArg;
- restrictProc = proc;
- restrictArg = arg;
- return prev;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * TkEventDeadWindow --
- *
- * This procedure is invoked when it is determined that
- * a window is dead. It cleans up event-related information
- * about the window.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Various things get cleaned up and recycled.
- *
- *--------------------------------------------------------------
- */
-
-void
-TkEventDeadWindow(winPtr)
- TkWindow *winPtr; /* Information about the window
- * that is being deleted. */
-{
- register TkEventHandler *handlerPtr;
- register InProgress *ipPtr;
-
- /*
- * While deleting all the handlers, be careful to check for
- * Tk_HandleEvent being about to process one of the deleted
- * handlers. If it is, tell it to quit (all of the handlers
- * are being deleted).
- */
-
- while (winPtr->handlerList != NULL) {
- handlerPtr = winPtr->handlerList;
- winPtr->handlerList = handlerPtr->nextPtr;
- for (ipPtr = pendingPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
- if (ipPtr->nextHandler == handlerPtr) {
- ipPtr->nextHandler = NULL;
- }
- if (ipPtr->winPtr == winPtr) {
- ipPtr->winPtr = None;
- }
- }
- ckfree((char *) handlerPtr);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * TkCurrentTime --
- *
- * Try to deduce the current time. "Current time" means the time
- * of the event that led to the current code being executed, which
- * means the time in the most recently-nested invocation of
- * Tk_HandleEvent.
- *
- * Results:
- * The return value is the time from the current event, or
- * CurrentTime if there is no current event or if the current
- * event contains no time.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-Time
-TkCurrentTime(dispPtr)
- TkDisplay *dispPtr; /* Display for which the time is desired. */
-{
- register XEvent *eventPtr;
-
- if (pendingPtr == NULL) {
- return dispPtr->lastEventTime;
- }
- eventPtr = pendingPtr->eventPtr;
- switch (eventPtr->type) {
- case ButtonPress:
- case ButtonRelease:
- return eventPtr->xbutton.time;
- case KeyPress:
- case KeyRelease:
- return eventPtr->xkey.time;
- case MotionNotify:
- return eventPtr->xmotion.time;
- case EnterNotify:
- case LeaveNotify:
- return eventPtr->xcrossing.time;
- case PropertyNotify:
- return eventPtr->xproperty.time;
- }
- return dispPtr->lastEventTime;
-}
+++ /dev/null
-/**************************
- Changes on April 1, 1993 to support Scheme UITK:
- 1) Added Tk_CreateMainWindow_from_display.
- 2) Renamed GetScreen to GetScreenByName. Added GetScreenByDisplay.
- 3) Rewrote Tk_CreateMainWindow into Tk_CreateMainWindow_from_data,
- which takes both a lookup procedure for finding a Screen and the
- data necessary for the lookup. Rewrite Tk_CreateMainWindow in
- terms of this.
- 4) Changed the signature of CreateTopLevelWindow to accept a lookup
- procedure and data.
- 5) Made NameWindow public for reparenting widgets when mapped by UITK
- 6) Added external entry point Tk_DestroyDisplayByNumber.
-**************************/
-
-/*
- * tkWindow.c --
- *
- * This file provides basic window-manipulation procedures,
- * which are equivalent to procedures in Xlib (and even
- * invoke them) but also maintain the local Tk_Window
- * structure.
- *
- * Copyright 1989-1992 Regents of the University of California.
- * Permission to use, copy, modify, and distribute this
- * software and its documentation for any purpose and without
- * fee is hereby granted, provided that the above copyright
- * notice appear in all copies. The University of California
- * makes no representations about the suitability of this
- * software for any purpose. It is provided "as is" without
- * express or implied warranty.
- */
-
-#include "tkConfig.h"
-#include "tkInt.h"
-
-/*
- * Count of number of main windows currently open in this process.
- */
-
-int tk_NumMainWindows;
-
-/*
- * List of all displays currently in use.
- */
-
-TkDisplay *tkDisplayList = NULL;
-
-/*
- * Have statics in this module been initialized?
- */
-
-static initialized = 0;
-
-/*
- * Context information used to map from X window id's to
- * TkWindow structures (during event handling, for example):
- */
-
-XContext tkWindowContext;
-
-/*
- * The variables below hold several uid's that are used in many places
- * in the toolkit.
- */
-
-Tk_Uid tkDisabledUid = NULL;
-Tk_Uid tkActiveUid = NULL;
-Tk_Uid tkNormalUid = NULL;
-
-/*
- * Default values for "changes" and "atts" fields of TkWindows. Note
- * that Tk always requests all events for all windows, except StructureNotify
- * events on internal windows: these events are generated internally.
- */
-
-static XWindowChanges defChanges = {
- 0, 0, 1, 1, 0, 0, Above
-};
-#define ALL_EVENTS_MASK \
- KeyPressMask|KeyReleaseMask|ButtonPressMask|ButtonReleaseMask| \
- EnterWindowMask|LeaveWindowMask|PointerMotionMask|ExposureMask| \
- VisibilityChangeMask|SubstructureNotifyMask| \
- FocusChangeMask|PropertyChangeMask|ColormapChangeMask
-static XSetWindowAttributes defAtts= {
- None, /* background_pixmap */
- 0, /* background_pixel */
- CopyFromParent, /* border_pixmap */
- 0, /* border_pixel */
- ForgetGravity, /* bit_gravity */
- NorthWestGravity, /* win_gravity */
- NotUseful, /* backing_store */
- ~0, /* backing_planes */
- 0, /* backing_pixel */
- False, /* save_under */
- ALL_EVENTS_MASK, /* event_mask */
- 0, /* do_not_propagate_mask */
- False, /* override_redirect */
- CopyFromParent, /* colormap */
- None /* cursor */
-};
-
-/*
- * The following structure defines all of the commands supported by
- * Tk, and the C procedures that execute them.
- */
-
-typedef struct {
- char *name; /* Name of command. */
- int (*cmdProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp,
- int argc, char **argv));
- /* Command procedure. */
-} TkCmd;
-
-TkCmd commands[] = {
- /*
- * Commands that are part of the intrinsics:
- */
-
- {"after", Tk_AfterCmd},
- {"bind", Tk_BindCmd},
- {"destroy", Tk_DestroyCmd},
- {"focus", Tk_FocusCmd},
- {"grab", Tk_GrabCmd},
- {"option", Tk_OptionCmd},
- {"pack", Tk_PackCmd},
- {"place", Tk_PlaceCmd},
- {"selection", Tk_SelectionCmd},
- {"tk", Tk_TkCmd},
- {"tkwait", Tk_TkwaitCmd},
- {"update", Tk_UpdateCmd},
- {"winfo", Tk_WinfoCmd},
- {"wm", Tk_WmCmd},
-
- /*
- * Widget-creation commands.
- */
- {"button", Tk_ButtonCmd},
- {"canvas", Tk_CanvasCmd},
- {"checkbutton", Tk_ButtonCmd},
- {"entry", Tk_EntryCmd},
- {"frame", Tk_FrameCmd},
- {"label", Tk_ButtonCmd},
- {"listbox", Tk_ListboxCmd},
- {"menu", Tk_MenuCmd},
- {"menubutton", Tk_MenubuttonCmd},
- {"message", Tk_MessageCmd},
- {"radiobutton", Tk_ButtonCmd},
- {"scale", Tk_ScaleCmd},
- {"scrollbar", Tk_ScrollbarCmd},
- {"text", Tk_TextCmd},
- {"toplevel", Tk_FrameCmd},
- {(char *) NULL, (int (*)()) NULL}
-};
-
-/*
- * Forward declarations to procedures defined later in this file:
- */
-
-static Tk_Window CreateTopLevelWindow
- _ANSI_ARGS_((Tcl_Interp *interp,
- Tk_Window parent,
- char *name,
- TkDisplay *LookupProcedure(Tcl_Interp *interp,
- char *data,
- int *screenPtr),
- char *data));
-static void DoConfigureNotify _ANSI_ARGS_((TkWindow *winPtr));
-static TkDisplay * GetScreenByName _ANSI_ARGS_((Tcl_Interp *interp,
- char *screenName,
- int *screenPtr));
-static TkDisplay * GetScreenByDisplay _ANSI_ARGS_((Tcl_Interp *interp,
- char /*Display*/ *disp,
- int *screenPtr));
-extern int NameWindow _ANSI_ARGS_((Tcl_Interp *interp,
- TkWindow *winPtr, TkWindow *parentPtr,
- char *name));
-static TkWindow * NewWindow _ANSI_ARGS_((TkDisplay *dispPtr,
- int screenNum, TkWindow *parentPtr));
-
-extern void Tk_DestroyDisplayByNumber _ANSI_ARGS_ ((Display *disp));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * CreateTopLevelWindow --
- *
- * Make a new window that will be at top-level (its parent will
- * be the root window of a screen).
- *
- * Results:
- * The return value is a token for the new window, or NULL if
- * an error prevented the new window from being created. If
- * NULL is returned, an error message will be left in
- * interp->result.
- *
- * Side effects:
- * A new window structure is allocated locally. An X
- * window is NOT initially created, but will be created
- * the first time the window is mapped.
- *
- *----------------------------------------------------------------------
- */
-
-static Tk_Window
-CreateTopLevelWindow(interp, parent, name, LookupProcedure, data)
- Tcl_Interp *interp; /* Interpreter to use for error reporting. */
- Tk_Window parent; /* Token for logical parent of new window
- * (used for naming, options, etc.). May
- * be NULL. */
- char *name; /* Name for new window; if parent is
- * non-NULL, must be unique among parent's
- * children. */
- TkDisplay *(*LookupProcedure) _ANSI_ARGS_ ((Tcl_Interp *interp, char *data, int *screenPtr));
- /* Lookup a display structure, either */
- /* by name or by display connection */
- char *data; /* Data supplied to LookupProcedure: */
- /* either a screen name or a display */
- /* connection */
-{
- register TkWindow *winPtr;
- register TkDisplay *dispPtr;
- int screenId;
-
- if (!initialized) {
- initialized = 1;
- tkWindowContext = XUniqueContext();
- tkActiveUid = Tk_GetUid("active");
- tkDisabledUid = Tk_GetUid("disabled");
- tkNormalUid = Tk_GetUid("normal");
- }
-
- if ((LookupProcedure==GetScreenByName) && (parent != NULL) &&
- (data != NULL) && (data[0] == '\0'))
- { dispPtr = ((TkWindow *) parent)->dispPtr;
- screenId = Tk_ScreenNumber(parent);
- }
- else
- { dispPtr = LookupProcedure(interp, data, &screenId);
- if (dispPtr == NULL) return (Tk_Window) NULL;
- }
-
- winPtr = NewWindow(dispPtr, screenId, (TkWindow *) parent);
-
- /*
- * Internal windows don't normally ask for StructureNotify events,
- * since we can generate them internally. However, for top-level
- * windows we need to as for the events because the window could
- * be manipulated externally.
- */
-
- winPtr->atts.event_mask |= StructureNotifyMask;
-
- /*
- * (Need to set the TK_TOP_LEVEL flag immediately here; otherwise
- * Tk_DestroyWindow will core dump if it is called before the flag
- * has been set.)
- */
-
- winPtr->flags |= TK_TOP_LEVEL;
- if (parent != NULL) {
- if (NameWindow(interp, winPtr, (TkWindow *) parent, name) != TCL_OK) {
- Tk_DestroyWindow((Tk_Window) winPtr);
- return (Tk_Window) NULL;
- }
- }
- TkWmNewWindow(winPtr);
- return (Tk_Window) winPtr;
-}
-\f
-TkDisplay * MakeTkDisplay(display, NameLength, screenName)
- Display *display;
- int NameLength;
- char* screenName;
-{
- register TkDisplay *dispPtr = (TkDisplay *) ckalloc(sizeof(TkDisplay));
- register long i;
-
- dispPtr->display = display;
- dispPtr->nextPtr = tkDisplayList;
- dispPtr->name = (char *) ckalloc((unsigned) (NameLength+1));
- dispPtr->lastEventTime = CurrentTime;
- strncpy(dispPtr->name, screenName, NameLength);
- dispPtr->focusTopLevelPtr = NULL;
- dispPtr->focussedOnEnter = 0;
- dispPtr->name[NameLength] = '\0';
- dispPtr->bindInfoStale = 1;
- dispPtr->errorPtr = NULL;
- dispPtr->deleteCount = 0;
- dispPtr->commWindow = NULL;
- dispPtr->selectionOwner = NULL;
- dispPtr->selectionSerial = 0;
- dispPtr->multipleAtom = None;
- dispPtr->atomInit = 0;
- dispPtr->cursorFont = None;
- dispPtr->grabWinPtr = NULL;
- dispPtr->eventualGrabWinPtr = NULL;
- dispPtr->buttonWinPtr = NULL;
- dispPtr->serverWinPtr = NULL;
- dispPtr->firstGrabEventPtr = NULL;
- dispPtr->lastGrabEventPtr = NULL;
- dispPtr->grabFlags = 0;
- dispPtr->colorModels =
- (Tk_ColorModel *) ckalloc((unsigned)
- (ScreenCount(display)*
- sizeof(Tk_ColorModel)));
- for (i = ScreenCount(display)-1; i >= 0; i--) {
- if (DisplayPlanes(display, i) <= 4) {
- dispPtr->colorModels[i] = TK_MONO;
- } else {
- dispPtr->colorModels[i] = TK_COLOR;
- }
- }
- tkDisplayList = dispPtr;
- Tk_CreateFileHandler(ConnectionNumber(display),
- TK_READABLE, (void (*)()) NULL,
- (ClientData) display);
- return dispPtr;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * GetScreenByName --
- *
- * Given a string name for a display-plus-screen, find the
- * TkDisplay structure for the display and return the screen
- * number too.
- *
- * Results:
- * The return value is a pointer to information about the display,
- * or NULL if the display couldn't be opened. In this case, an
- * error message is left in interp->result. The location at
- * *screenPtr is overwritten with the screen number parsed from
- * screenName.
- *
- * Side effects:
- * A new connection is opened to the display if there is no
- * connection already. A new TkDisplay data structure is also
- * setup, if necessary.
- *
- *----------------------------------------------------------------------
- */
-
-static TkDisplay *
-GetScreenByName(interp, screenName, screenPtr)
- Tcl_Interp *interp; /* Place to leave error message. */
- char *screenName; /* Name for screen. NULL or empty means
- * use DISPLAY envariable. */
- int *screenPtr; /* Where to store screen number. */
-{
- register TkDisplay *dispPtr;
- char *p;
- int length, screenId, i;
-
- /*
- * Separate the screen number from the rest of the display
- * name. ScreenName is assumed to have the syntax
- * <display>.<screen> with the dot and the screen being
- * optional.
- */
-
- if ((screenName == NULL) || (screenName[0] == '\0')) {
- screenName = getenv("DISPLAY");
- if (screenName == NULL) {
- interp->result =
- "no display name and no $DISPLAY environment variable";
- return (TkDisplay *) NULL;
- }
- }
- length = strlen(screenName);
- screenId = 0;
- p = screenName+length-1;
- while (isdigit(*p) && (p != screenName)) {
- p--;
- }
- if ((*p == '.') && (p[1] != '\0')) {
- length = p - screenName;
- screenId = strtoul(p+1, (char **) NULL, 10);
- }
-
- /*
- * See if we already have a connection to this display. If not,
- * then open a new connection.
- */
-
- for (dispPtr = tkDisplayList; ; dispPtr = dispPtr->nextPtr)
- { if (dispPtr == NULL)
- { Display *display;
- /* block and unblock added by Hal -- 7/22/95 in an attempt to fix a problem
- with making this work over PPP (i.e. slow) connections */
- block_signals ();
- display = XOpenDisplay(screenName);
- unblock_signals ();
- if (display == NULL)
- { Tcl_AppendResult(interp, "couldn't connect to display \"",
- screenName, "\"", (char *) NULL);
- return (TkDisplay *) NULL;
- }
- dispPtr = MakeTkDisplay(display, length, screenName);
- break;
- }
- if ((strncmp(dispPtr->name, screenName, length) == 0)
- && (dispPtr->name[length] == '\0'))
- {
- break;
- }
- }
- if (screenId >= ScreenCount(dispPtr->display)) {
- sprintf(interp->result, "bad screen number \"%d\"", screenId);
- return (TkDisplay *) NULL;
- }
- *screenPtr = screenId;
- return dispPtr;
-}
-
-static TkDisplay *GetScreenByDisplay(interp, disp, screenPtr)
- Tcl_Interp *interp;
- char *disp;
- int *screenPtr;
-/* GetScreenByDisplay assumes screen 0! */
-{ Display *Disp = (Display *) disp;
- register TkDisplay *dispPtr;
-
- for (dispPtr = tkDisplayList; ; dispPtr = dispPtr->nextPtr)
- { if (dispPtr == NULL)
- { dispPtr = MakeTkDisplay(Disp, 0, "");
- break;
- }
- if (Disp==(dispPtr->display)) break;
- }
- *screenPtr = 0;
- return dispPtr;
-}
-
-void Tk_DestroyDisplayByNumber(Disp)
- Display *Disp;
-/* Tk_DestroyDisplayByNumber assumes screen 0! */
-{ register TkDisplay *dispPtr, *Prev=(TkDisplay *) NULL;
-
- for (dispPtr = tkDisplayList; dispPtr != NULL;
- Prev=dispPtr, dispPtr = dispPtr->nextPtr)
- { if (Disp==(dispPtr->display))
- { if (Prev==(TkDisplay *) NULL)
- tkDisplayList = dispPtr->nextPtr;
- else Prev->nextPtr = dispPtr->nextPtr;
- ckfree(dispPtr->name);
- ckfree(dispPtr->colorModels);
- ckfree(dispPtr);
- Tk_DeleteFileHandler(ConnectionNumber(Disp));
- return;
- }
- }
- return;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * NewWindow --
- *
- * This procedure creates and initializes a TkWindow structure.
- *
- * Results:
- * The return value is a pointer to the new window.
- *
- * Side effects:
- * A new window structure is allocated and all its fields are
- * initialized.
- *
- *--------------------------------------------------------------
- */
-
-static TkWindow *
-NewWindow(dispPtr, screenNum, parentPtr)
- TkDisplay *dispPtr; /* Display associated with new window. */
- int screenNum; /* Index of screen for new window. */
- TkWindow *parentPtr; /* Parent from which this window should
- * inherit visual inforamtion. NULL means
- * use screen defaults instead of
- * inheriting. */
-{
- register TkWindow *winPtr;
-
- winPtr = (TkWindow *) ckalloc(sizeof(TkWindow));
- winPtr->display = dispPtr->display;
- winPtr->dispPtr = dispPtr;
- winPtr->screenNum = screenNum;
- if (parentPtr != NULL) {
- winPtr->visual = parentPtr->visual;
- winPtr->depth = parentPtr->depth;
- } else {
- winPtr->visual = DefaultVisual(dispPtr->display, screenNum);
- winPtr->depth = DefaultDepth(dispPtr->display, screenNum);
- }
- winPtr->window = None;
- winPtr->childList = NULL;
- winPtr->parentPtr = NULL;
- winPtr->nextPtr = NULL;
- winPtr->mainPtr = NULL;
- winPtr->pathName = NULL;
- winPtr->nameUid = NULL;
- winPtr->classUid = NULL;
- winPtr->changes = defChanges;
- winPtr->dirtyChanges = CWX|CWY|CWWidth|CWHeight|CWBorderWidth;
- winPtr->atts = defAtts;
- if (parentPtr != NULL) {
- winPtr->atts.colormap = parentPtr->atts.colormap;
- } else {
- winPtr->atts.colormap = DefaultColormap(dispPtr->display, screenNum);
- }
- winPtr->dirtyAtts = CWEventMask|CWColormap;
- winPtr->flags = 0;
- winPtr->handlerList = NULL;
- winPtr->focusProc = NULL;
- winPtr->focusData = NULL;
- winPtr->optionLevel = -1;
- winPtr->selHandlerList = NULL;
- winPtr->selClearProc = NULL;
- winPtr->selClearData = NULL;
- winPtr->geomProc = NULL;
- winPtr->geomData = NULL;
- winPtr->reqWidth = winPtr->reqHeight = 0;
- winPtr->internalBorderWidth = 0;
- winPtr->wmInfoPtr = NULL;
-
- return winPtr;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * NameWindow --
- *
- * This procedure is invoked to give a window a name and insert
- * the window into the hierarchy associated with a particular
- * application.
- *
- * Results:
- * A standard Tcl return value.
- *
- * Side effects:
- * See above.
- *
- *----------------------------------------------------------------------
- */
-
-int
-NameWindow(interp, winPtr, parentPtr, name)
- Tcl_Interp *interp; /* Interpreter to use for error reporting. */
- register TkWindow *winPtr; /* Window that is to be named and inserted. */
- TkWindow *parentPtr; /* Pointer to logical parent for winPtr
- * (used for naming, options, etc.). */
- char *name; /* Name for winPtr; must be unique among
- * parentPtr's children. */
-{
-#define FIXED_SIZE 200
- char staticSpace[FIXED_SIZE];
- char *pathName;
- int new;
- Tcl_HashEntry *hPtr;
- int length1, length2;
-
- /*
- * Setup all the stuff except name right away, then do the name stuff
- * last. This is so that if the name stuff fails, everything else
- * will be properly initialized (needed to destroy the window cleanly
- * after the naming failure).
- */
- winPtr->parentPtr = parentPtr;
- winPtr->nextPtr = parentPtr->childList;
- parentPtr->childList = winPtr;
- winPtr->mainPtr = parentPtr->mainPtr;
- winPtr->nameUid = Tk_GetUid(name);
-
- /*
- * Don't permit names that start with an upper-case letter: this
- * will just cause confusion with class names in the option database.
- */
-
- if (isupper(name[0])) {
- Tcl_AppendResult(interp,
- "window name starts with an upper-case letter: \"",
- name, "\"", (char *) NULL);
- return TCL_ERROR;
- }
-
- /*
- * To permit names of arbitrary length, must be prepared to malloc
- * a buffer to hold the new path name. To run fast in the common
- * case where names are short, use a fixed-size buffer on the
- * stack.
- */
-
- length1 = strlen(parentPtr->pathName);
- length2 = strlen(name);
- if ((length1+length2+2) <= FIXED_SIZE) {
- pathName = staticSpace;
- } else {
- pathName = (char *) ckalloc((unsigned) (length1+length2+2));
- }
- if (length1 == 1) {
- pathName[0] = '.';
- strcpy(pathName+1, name);
- } else {
- strcpy(pathName, parentPtr->pathName);
- pathName[length1] = '.';
- strcpy(pathName+length1+1, name);
- }
- hPtr = Tcl_CreateHashEntry(&parentPtr->mainPtr->nameTable, pathName, &new);
- if (pathName != staticSpace) {
- ckfree(pathName);
- }
- if (!new) {
- Tcl_AppendResult(interp, "window name \"", name,
- "\" already exists in parent", (char *) NULL);
- return TCL_ERROR;
- }
- Tcl_SetHashValue(hPtr, winPtr);
- winPtr->pathName = Tcl_GetHashKey(&parentPtr->mainPtr->nameTable, hPtr);
- return TCL_OK;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tk_CreateMainWindow --
- *
- * Make a new main window. A main window is a special kind of
- * top-level window used as the outermost window in an
- * application.
- *
- * Results:
- * The return value is a token for the new window, or NULL if
- * an error prevented the new window from being created. If
- * NULL is returned, an error message will be left in
- * interp->result.
- *
- * Side effects:
- * A new window structure is allocated locally; "interp" is
- * associated with the window and registered for "send" commands
- * under "baseName". BaseName may be extended with an instance
- * number in the form "#2" if necessary to make it globally
- * unique. Tk-related commands are bound into interp. An X
- * window is NOT initially created, but will be created the
- * first time the window is mapped.
- *
- *----------------------------------------------------------------------
- */
-
-Tk_Window
-Tk_CreateMainWindow_from_data(interp, baseName, LookupProcedure, data)
- Tcl_Interp *interp; /* Interpreter to use for error reporting. */
- char *baseName; /* Base name for application; usually of the
- * form "prog instance". */
- TkDisplay *(*LookupProcedure) _ANSI_ARGS_ ((Tcl_Interp *interp, char *data, int *screenPtr));
- /* Lookup a display structure, either */
- /* by name or by display connection */
- char *data; /* Data supplied to LookupProcedure */
-{
- Tk_Window tkwin;
- int result, dummy;
- Tcl_HashEntry *hPtr;
- register TkMainInfo *mainPtr;
- register TkWindow *winPtr;
- register TkCmd *cmdPtr;
- char *libDir;
-
- /*
- * Create the basic TkWindow structure.
- */
-
- tkwin = CreateTopLevelWindow(interp, (Tk_Window) NULL, baseName,
- LookupProcedure, data);
- if (tkwin == NULL) {
- return NULL;
- }
-
- /*
- * Create the TkMainInfo structure for this application, and set
- * up name-related information for the new window.
- */
-
- winPtr = (TkWindow *) tkwin;
- mainPtr = (TkMainInfo *) ckalloc(sizeof(TkMainInfo));
- mainPtr->winPtr = winPtr;
- mainPtr->interp = interp;
- Tcl_InitHashTable(&mainPtr->nameTable, TCL_STRING_KEYS);
- mainPtr->bindingTable = Tk_CreateBindingTable(interp);
- mainPtr->focusPtr = winPtr;
- mainPtr->focusDefaultPtr = NULL;
- mainPtr->optionRootPtr = NULL;
- winPtr->mainPtr = mainPtr;
- hPtr = Tcl_CreateHashEntry(&mainPtr->nameTable, ".", &dummy);
- Tcl_SetHashValue(hPtr, winPtr);
- winPtr->pathName = Tcl_GetHashKey(&mainPtr->nameTable, hPtr);
-
- /*
- * Register the interpreter for "send" purposes. If baseName isn't
- * already unique, find a unique suffix to add to it to make it
- * unique. Change the window's name to contain the suffix.
- */
-
- result = Tk_RegisterInterp(interp, baseName, tkwin);
- if (result == TCL_OK) {
- winPtr->nameUid = Tk_GetUid(baseName);
- } else {
- char newName[110];
- int i;
-
- for (i = 2; ; i++) {
- sprintf(newName, "%.100s #%d", baseName, i);
- Tcl_SetResult(interp, (char *) NULL, TCL_STATIC);
- result = Tk_RegisterInterp(interp, newName, tkwin);
- if (result == TCL_OK) {
- break;
- }
- if (i >= 100) {
- Tcl_SetResult(interp,
- "couldn't generate unique name to register application",
- TCL_STATIC);
- Tk_DestroyWindow(tkwin);
- }
- }
- winPtr->nameUid = Tk_GetUid(newName);
- }
-
- /*
- * Bind in Tk's commands.
- */
-
- for (cmdPtr = commands; cmdPtr->name != NULL; cmdPtr++) {
- Tcl_CreateCommand(interp, cmdPtr->name, cmdPtr->cmdProc,
- (ClientData) tkwin, (void (*)()) NULL);
- }
-
- /*
- * Set variables for the intepreter.
- */
-
- libDir = getenv("TK_LIBRARY");
- if (libDir == NULL) {
- libDir = TK_LIBRARY;
- }
- Tcl_SetVar(interp, "tk_library", libDir, TCL_GLOBAL_ONLY);
- Tcl_SetVar(interp, "tk_version", TK_VERSION, TCL_GLOBAL_ONLY);
- Tcl_SetVar(interp, "tkVersion", TK_VERSION, TCL_GLOBAL_ONLY);
-
- tk_NumMainWindows++;
- return tkwin;
-}
-
-Tk_Window
- Tk_CreateMainWindow(interp, screenName, baseName)
- Tcl_Interp *interp; /* Interpreter to use for error reporting. */
- char *screenName; /* Name of screen on which to create
- * window. Empty or NULL string means
- * use DISPLAY environment variable. */
- char *baseName; /* Base name for application; usually of the
- * form "prog instance". */
-{ return Tk_CreateMainWindow_from_data(interp, baseName,
- GetScreenByName, screenName);
-}
-
-Tk_Window
-Tk_CreateMainWindow_from_display(interp, display, baseName)
- Tcl_Interp *interp; /* Interpreter to use for error reporting. */
- Display *display; /* X Display connection */
- char *baseName; /* Base name for application; usually of the
- * form "prog instance". */
-{ return Tk_CreateMainWindow_from_data(interp, baseName,
- GetScreenByDisplay,
- (char *) display);
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * Tk_CreateWindow --
- *
- * Create a new internal or top-level window as a child of an
- * existing window.
- *
- * Results:
- * The return value is a token for the new window. This
- * is not the same as X's token for the window. If an error
- * occurred in creating the window (e.g. no such display or
- * screen), then an error message is left in interp->result and
- * NULL is returned.
- *
- * Side effects:
- * A new window structure is allocated locally. An X
- * window is not initially created, but will be created
- * the first time the window is mapped.
- *
- *--------------------------------------------------------------
- */
-
-Tk_Window
-Tk_CreateWindow(interp, parent, name, screenName)
- Tcl_Interp *interp; /* Interpreter to use for error reporting.
- * Interp->result is assumed to be
- * initialized by the caller. */
- Tk_Window parent; /* Token for parent of new window. */
- char *name; /* Name for new window. Must be unique
- * among parent's children. */
- char *screenName; /* If NULL, new window will be internal on
- * same screen as its parent. If non-NULL,
- * gives name of screen on which to create
- * new window; window will be a top-level
- * window. */
-{
- TkWindow *parentPtr = (TkWindow *) parent;
- TkWindow *winPtr;
-
- if (screenName == NULL)
- { winPtr = NewWindow(parentPtr->dispPtr, parentPtr->screenNum,
- parentPtr);
- if (NameWindow(interp, winPtr, parentPtr, name) != TCL_OK)
- { Tk_DestroyWindow((Tk_Window) winPtr);
- return NULL;
- }
- else
- { return (Tk_Window) winPtr;
- }
- }
- else
- { return CreateTopLevelWindow(interp, parent, name,
- GetScreenByName, screenName);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tk_CreateWindowFromPath --
- *
- * This procedure is similar to Tk_CreateInternalWindow except
- * that it uses a path name to create the window, rather than
- * a parent and a child name.
- *
- * Results:
- * The return value is a token for the new window. This
- * is not the same as X's token for the window. If an error
- * occurred in creating the window (e.g. no such display or
- * screen), then an error message is left in interp->result and
- * NULL is returned.
- *
- * Side effects:
- * A new window structure is allocated locally. An X
- * window is not initially created, but will be created
- * the first time the window is mapped.
- *
- *----------------------------------------------------------------------
- */
-
-Tk_Window
-Tk_CreateWindowFromPath(interp, tkwin, pathName, screenName)
- Tcl_Interp *interp; /* Interpreter to use for error reporting.
- * Interp->result is assumed to be
- * initialized by the caller. */
- Tk_Window tkwin; /* Token for any window in application
- * that is to contain new window. */
- char *pathName; /* Path name for new window within the
- * application of tkwin. The parent of
- * this window must already exist, but
- * the window itself must not exist. */
- char *screenName; /* If NULL, new window will be on same
- * screen as its parent. If non-NULL,
- * gives name of screen on which to create
- * new window; window will be a top-level
- * window. */
-{
-#define FIXED_SPACE 5
- char fixedSpace[FIXED_SPACE+1];
- char *p;
- Tk_Window parent;
- int numChars;
-
- /*
- * Strip the parent's name out of pathName (it's everything up
- * to the last dot). There are two tricky parts: (a) must
- * copy the parent's name somewhere else to avoid modifying
- * the pathName string (for large names, space for the copy
- * will have to be malloc'ed); (b) must special-case the
- * situation where the parent is ".".
- */
-
- p = strrchr(pathName, '.');
- if (p == NULL) {
- Tcl_AppendResult(interp, "bad window path name \"", pathName,
- "\"", (char *) NULL);
- return NULL;
- }
- numChars = p-pathName;
- if (numChars > FIXED_SPACE) {
- p = (char *) ckalloc((unsigned) (numChars+1));
- } else {
- p = fixedSpace;
- }
- if (numChars == 0) {
- *p = '.';
- p[1] = '\0';
- } else {
- strncpy(p, pathName, numChars);
- p[numChars] = '\0';
- }
-
- /*
- * Find the parent window.
- */
-
- parent = Tk_NameToWindow(interp, p, tkwin);
- if (p != fixedSpace) {
- ckfree(p);
- }
- if (parent == NULL) {
- return NULL;
- }
-
- /*
- * Create the window.
- */
-
- if (screenName == NULL) {
- TkWindow *parentPtr = (TkWindow *) parent;
- TkWindow *winPtr;
-
- winPtr = NewWindow(parentPtr->dispPtr, parentPtr->screenNum,
- parentPtr);
- if (NameWindow(interp, winPtr, parentPtr, pathName+numChars+1)
- != TCL_OK) {
- Tk_DestroyWindow((Tk_Window) winPtr);
- return NULL;
- } else
- { return (Tk_Window) winPtr;
- }
- } else {
- return CreateTopLevelWindow(interp, parent, pathName+numChars+1,
- GetScreenByName, screenName);
- }
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * Tk_DestroyWindow --
- *
- * Destroy an existing window. After this call, the caller
- * should never again use the token.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The window is deleted, along with all of its children.
- * Relevant callback procedures are invoked.
- *
- *--------------------------------------------------------------
- */
-
-void
-Tk_DestroyWindow(tkwin)
- Tk_Window tkwin; /* Window to destroy. */
-{
- register TkWindow *winPtr = (TkWindow *) tkwin;
- XEvent event;
-
- if (winPtr->flags & TK_ALREADY_DEAD) {
- /*
- * An destroy event binding caused the window to be destroyed
- * again. Ignore the request.
- */
-
- return;
- }
-
- /*
- * Recursively destroy children. The TK_RECURSIVE_DESTROY
- * flags means that the child's window needn't be explicitly
- * destroyed (the destroy of the parent already did it), nor
- * does it need to be removed from its parent's child list,
- * since the parent is being destroyed too.
- */
-
- while (winPtr->childList != NULL) {
- winPtr->childList->flags |= TK_RECURSIVE_DESTROY;
- Tk_DestroyWindow((Tk_Window) winPtr->childList);
- }
-
- /*
- * Generate a DestroyNotify event. In order for the DestroyNotify
- * event to be processed correctly, need to make sure the window
- * exists. This is a bit of a kludge, and may be unnecessarily
- * expensive, but without it no event handlers will get called for
- * windows that don't exist yet.
- */
-
- if (winPtr->window == None) {
- Tk_MakeWindowExist(tkwin);
- }
- winPtr->flags |= TK_ALREADY_DEAD;
- event.type = DestroyNotify;
- event.xdestroywindow.serial =
- LastKnownRequestProcessed(winPtr->display);
- event.xdestroywindow.send_event = False;
- event.xdestroywindow.display = winPtr->display;
- event.xdestroywindow.event = winPtr->window;
- event.xdestroywindow.window = winPtr->window;
- Tk_HandleEvent(&event);
-
- /*
- * Cleanup the data structures associated with this window.
- * No need to destroy windows during recursive destroys, since
- * that will happen automatically when the parent window is
- * destroyed (not true for top-level windows: must destroy
- * them explicitly).
- */
-
- if (winPtr->window != None) {
- if (!(winPtr->flags & TK_RECURSIVE_DESTROY)
- || (winPtr->flags & TK_TOP_LEVEL)) {
- XDestroyWindow(winPtr->display, winPtr->window);
- }
- XDeleteContext(winPtr->display, winPtr->window, tkWindowContext);
- winPtr->window = None;
- }
- if (winPtr->parentPtr != NULL) {
- if (winPtr->parentPtr->childList == winPtr) {
- winPtr->parentPtr->childList = winPtr->nextPtr;
- } else {
- register TkWindow *winPtr2;
-
- for (winPtr2 = winPtr->parentPtr->childList; ;
- winPtr2 = winPtr2->nextPtr) {
- if (winPtr2 == NULL) {
- panic("Tk_DestroyWindow couldn't find child in parent (deleted twice?)");
- break;
- }
- if (winPtr2->nextPtr == winPtr) {
- winPtr2->nextPtr = winPtr->nextPtr;
- break;
- }
- }
- }
- }
- TkEventDeadWindow(winPtr);
- TkFocusDeadWindow(winPtr);
- TkOptionDeadWindow(winPtr);
- TkSelDeadWindow(winPtr);
- if (winPtr->flags & TK_TOP_LEVEL) {
- TkWmDeadWindow(winPtr);
- }
- TkGrabDeadWindow(winPtr);
- if (winPtr->mainPtr != NULL) {
- Tk_DeleteAllBindings(winPtr->mainPtr->bindingTable,
- (ClientData) winPtr->pathName);
- if (winPtr->pathName != NULL) {
- Tcl_DeleteHashEntry(Tcl_FindHashEntry(&winPtr->mainPtr->nameTable,
- winPtr->pathName));
- }
- if (winPtr->mainPtr->winPtr == winPtr) {
- register TkCmd *cmdPtr;
-
- /*
- * Deleting a main window. Delete the TkMainInfo structure too
- * and replace all of Tk's commands with dummy commands that
- * return errors. Also delete the "send" command to unregister
- * the interpreter.
- */
-
- for (cmdPtr = commands; cmdPtr->name != NULL; cmdPtr++) {
- Tcl_CreateCommand(winPtr->mainPtr->interp, cmdPtr->name,
- TkDeadAppCmd, (ClientData) NULL, (void (*)()) NULL);
- }
- Tcl_CreateCommand(winPtr->mainPtr->interp, "send",
- TkDeadAppCmd, (ClientData) NULL, (void (*)()) NULL);
- Tcl_DeleteHashTable(&winPtr->mainPtr->nameTable);
- Tk_DeleteBindingTable(winPtr->mainPtr->bindingTable);
- ckfree((char *) winPtr->mainPtr);
- tk_NumMainWindows--;
- }
- }
- ckfree((char *) winPtr);
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * Tk_MapWindow --
- *
- * Map a window within its parent. This may require the
- * window and/or its parents to actually be created.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The given window will be mapped. Windows may also
- * be created.
- *
- *--------------------------------------------------------------
- */
-
-void
-Tk_MapWindow(tkwin)
- Tk_Window tkwin; /* Token for window to map. */
-{
- register TkWindow *winPtr = (TkWindow *) tkwin;
- XEvent event;
-
- if (winPtr->flags & TK_MAPPED) {
- return;
- }
- if (winPtr->window == None) {
- Tk_MakeWindowExist(tkwin);
- }
- if (winPtr->flags & TK_TOP_LEVEL) {
- /*
- * Lots of special processing has to be done for top-level
- * windows. Let tkWm.c handle everything itself.
- */
-
- TkWmMapWindow(winPtr);
- return;
- }
- winPtr->flags |= TK_MAPPED;
- XMapWindow(winPtr->display, winPtr->window);
- event.type = MapNotify;
- event.xmap.serial = LastKnownRequestProcessed(winPtr->display);
- event.xmap.send_event = False;
- event.xmap.display = winPtr->display;
- event.xmap.event = winPtr->window;
- event.xmap.window = winPtr->window;
- event.xmap.override_redirect = winPtr->atts.override_redirect;
- Tk_HandleEvent(&event);
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * Tk_MakeWindowExist --
- *
- * Ensure that a particular window actually exists. This
- * procedure shouldn't normally need to be invoked from
- * outside the Tk package, but may be needed if someone
- * wants to manipulate a window before mapping it.
- *
- * Results:
- * None.
- *
- * Side effects:
- * When the procedure returns, the X window associated with
- * tkwin is guaranteed to exist. This may require the
- * window's ancestors to be created also.
- *
- *--------------------------------------------------------------
- */
-
-void
-Tk_MakeWindowExist(tkwin)
- Tk_Window tkwin; /* Token for window. */
-{
- register TkWindow *winPtr = (TkWindow *) tkwin;
- Window parent;
-
- if (winPtr->window != None) {
- return;
- }
-
- if (winPtr->flags & TK_TOP_LEVEL) {
- parent = XRootWindow(winPtr->display, winPtr->screenNum);
- } else {
- if (winPtr->parentPtr->window == None) {
- Tk_MakeWindowExist((Tk_Window) winPtr->parentPtr);
- }
- parent = winPtr->parentPtr->window;
- }
-
- winPtr->window = XCreateWindow(winPtr->display, parent,
- winPtr->changes.x, winPtr->changes.y,
- winPtr->changes.width, winPtr->changes.height,
- winPtr->changes.border_width, winPtr->depth,
- InputOutput, winPtr->visual, winPtr->dirtyAtts,
- &winPtr->atts);
- XSaveContext(winPtr->display, winPtr->window, tkWindowContext,
- (caddr_t) winPtr);
- winPtr->dirtyAtts = 0;
- winPtr->dirtyChanges &= ~(CWX|CWY|CWWidth|CWHeight|CWBorderWidth);
- if (winPtr->dirtyChanges != 0) {
- XConfigureWindow(winPtr->display, winPtr->window,
- winPtr->dirtyChanges, &winPtr->changes);
- winPtr->dirtyChanges = 0;
- }
-
- /*
- * Issue a ConfigureNotify event if there were deferred configuration
- * changes.
- */
-
- if (winPtr->flags & TK_NEED_CONFIG_NOTIFY) {
- winPtr->flags &= ~TK_NEED_CONFIG_NOTIFY;
- DoConfigureNotify(winPtr);
- }
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * Tk_UnmapWindow, etc. --
- *
- * There are several procedures under here, each of which
- * mirrors an existing X procedure. In addition to performing
- * the functions of the corresponding procedure, each
- * procedure also updates the local window structure and
- * synthesizes an X event (if the window's structure is being
- * managed internally).
- *
- * Results:
- * See the manual entries.
- *
- * Side effects:
- * See the manual entries.
- *
- *--------------------------------------------------------------
- */
-
-void
-Tk_UnmapWindow(tkwin)
- Tk_Window tkwin; /* Token for window to unmap. */
-{
- register TkWindow *winPtr = (TkWindow *) tkwin;
-
- if (!(winPtr->flags & TK_MAPPED)) {
- return;
- }
- winPtr->flags &= ~TK_MAPPED;
- XUnmapWindow(winPtr->display, winPtr->window);
- if (!(winPtr->flags & TK_TOP_LEVEL)) {
- XEvent event;
-
- event.type = UnmapNotify;
- event.xunmap.serial = LastKnownRequestProcessed(winPtr->display);
- event.xunmap.send_event = False;
- event.xunmap.display = winPtr->display;
- event.xunmap.event = winPtr->window;
- event.xunmap.window = winPtr->window;
- event.xunmap.from_configure = False;
- Tk_HandleEvent(&event);
- }
-}
-
-void
-Tk_ConfigureWindow(tkwin, valueMask, valuePtr)
- Tk_Window tkwin; /* Window to re-configure. */
- unsigned int valueMask; /* Mask indicating which parts of
- * *valuePtr are to be used. */
- XWindowChanges *valuePtr; /* New values. */
-{
- register TkWindow *winPtr = (TkWindow *) tkwin;
-
- if (valueMask & CWX) {
- winPtr->changes.x = valuePtr->x;
- }
- if (valueMask & CWY) {
- winPtr->changes.y = valuePtr->y;
- }
- if (valueMask & CWWidth) {
- winPtr->changes.width = valuePtr->width;
- }
- if (valueMask & CWHeight) {
- winPtr->changes.height = valuePtr->height;
- }
- if (valueMask & CWBorderWidth) {
- winPtr->changes.border_width = valuePtr->border_width;
- }
- if (valueMask & CWSibling) {
- winPtr->changes.sibling = valuePtr->sibling;
- }
- if (valueMask & CWStackMode) {
- winPtr->changes.stack_mode = valuePtr->stack_mode;
- }
-
- if (winPtr->window != None) {
- XConfigureWindow(winPtr->display, winPtr->window,
- valueMask, valuePtr);
- if (!(winPtr->flags & TK_TOP_LEVEL)) {
- DoConfigureNotify(winPtr);
- }
- } else {
- winPtr->dirtyChanges |= valueMask;
- winPtr->flags |= TK_NEED_CONFIG_NOTIFY;
- }
-}
-
-void
-Tk_MoveWindow(tkwin, x, y)
- Tk_Window tkwin; /* Window to move. */
- int x, y; /* New location for window (within
- * parent). */
-{
- register TkWindow *winPtr = (TkWindow *) tkwin;
-
- winPtr->changes.x = x;
- winPtr->changes.y = y;
- if (winPtr->window != None) {
- XMoveWindow(winPtr->display, winPtr->window, x, y);
- if (!(winPtr->flags & TK_TOP_LEVEL)) {
- DoConfigureNotify(winPtr);
- }
- } else {
- winPtr->dirtyChanges |= CWX|CWY;
- winPtr->flags |= TK_NEED_CONFIG_NOTIFY;
- }
-}
-
-void
-Tk_ResizeWindow(tkwin, width, height)
- Tk_Window tkwin; /* Window to resize. */
- unsigned int width, height; /* New dimensions for window. */
-{
- register TkWindow *winPtr = (TkWindow *) tkwin;
-
- winPtr->changes.width = width;
- winPtr->changes.height = height;
- if (winPtr->window != None) {
- XResizeWindow(winPtr->display, winPtr->window, width, height);
- if (!(winPtr->flags & TK_TOP_LEVEL)) {
- DoConfigureNotify(winPtr);
- }
- } else {
- winPtr->dirtyChanges |= CWWidth|CWHeight;
- winPtr->flags |= TK_NEED_CONFIG_NOTIFY;
- }
-}
-
-void
-Tk_MoveResizeWindow(tkwin, x, y, width, height)
- Tk_Window tkwin; /* Window to move and resize. */
- int x, y; /* New location for window (within
- * parent). */
- unsigned int width, height; /* New dimensions for window. */
-{
- register TkWindow *winPtr = (TkWindow *) tkwin;
-
- winPtr->changes.x = x;
- winPtr->changes.y = y;
- winPtr->changes.width = width;
- winPtr->changes.height = height;
- if (winPtr->window != None) {
- XMoveResizeWindow(winPtr->display, winPtr->window,
- x, y, width, height);
- if (!(winPtr->flags & TK_TOP_LEVEL)) {
- DoConfigureNotify(winPtr);
- }
- } else {
- winPtr->dirtyChanges |= CWX|CWY|CWWidth|CWHeight;
- winPtr->flags |= TK_NEED_CONFIG_NOTIFY;
- }
-}
-
-void
-Tk_SetWindowBorderWidth(tkwin, width)
- Tk_Window tkwin; /* Window to modify. */
- int width; /* New border width for window. */
-{
- register TkWindow *winPtr = (TkWindow *) tkwin;
-
- winPtr->changes.border_width = width;
- if (winPtr->window != None) {
- XSetWindowBorderWidth(winPtr->display, winPtr->window, width);
- if (!(winPtr->flags & TK_TOP_LEVEL)) {
- DoConfigureNotify(winPtr);
- }
- } else {
- winPtr->dirtyChanges |= CWBorderWidth;
- winPtr->flags |= TK_NEED_CONFIG_NOTIFY;
- }
-}
-
-void
-Tk_ChangeWindowAttributes(tkwin, valueMask, attsPtr)
- Tk_Window tkwin; /* Window to manipulate. */
- unsigned long valueMask; /* OR'ed combination of bits,
- * indicating which fields of
- * *attsPtr are to be used. */
- register XSetWindowAttributes *attsPtr;
- /* New values for some attributes. */
-{
- register TkWindow *winPtr = (TkWindow *) tkwin;
-
- if (valueMask & CWBackPixmap) {
- winPtr->atts.background_pixmap = attsPtr->background_pixmap;
- }
- if (valueMask & CWBackPixel) {
- winPtr->atts.background_pixel = attsPtr->background_pixel;
- }
- if (valueMask & CWBorderPixmap) {
- winPtr->atts.border_pixmap = attsPtr->border_pixmap;
- }
- if (valueMask & CWBorderPixel) {
- winPtr->atts.border_pixel = attsPtr->border_pixel;
- }
- if (valueMask & CWBitGravity) {
- winPtr->atts.bit_gravity = attsPtr->bit_gravity;
- }
- if (valueMask & CWWinGravity) {
- winPtr->atts.win_gravity = attsPtr->win_gravity;
- }
- if (valueMask & CWBackingStore) {
- winPtr->atts.backing_store = attsPtr->backing_store;
- }
- if (valueMask & CWBackingPlanes) {
- winPtr->atts.backing_planes = attsPtr->backing_planes;
- }
- if (valueMask & CWBackingPixel) {
- winPtr->atts.backing_pixel = attsPtr->backing_pixel;
- }
- if (valueMask & CWOverrideRedirect) {
- winPtr->atts.override_redirect = attsPtr->override_redirect;
- }
- if (valueMask & CWSaveUnder) {
- winPtr->atts.save_under = attsPtr->save_under;
- }
- if (valueMask & CWEventMask) {
- winPtr->atts.event_mask = attsPtr->event_mask;
- }
- if (valueMask & CWDontPropagate) {
- winPtr->atts.do_not_propagate_mask
- = attsPtr->do_not_propagate_mask;
- }
- if (valueMask & CWColormap) {
- winPtr->atts.colormap = attsPtr->colormap;
- }
- if (valueMask & CWCursor) {
- winPtr->atts.cursor = attsPtr->cursor;
- }
-
- if (winPtr->window != None) {
- XChangeWindowAttributes(winPtr->display, winPtr->window,
- valueMask, attsPtr);
- } else {
- winPtr->dirtyAtts |= valueMask;
- }
-}
-
-void
-Tk_SetWindowBackground(tkwin, pixel)
- Tk_Window tkwin; /* Window to manipulate. */
- unsigned long pixel; /* Pixel value to use for
- * window's background. */
-{
- register TkWindow *winPtr = (TkWindow *) tkwin;
-
- winPtr->atts.background_pixel = pixel;
-
- if (winPtr->window != None) {
- XSetWindowBackground(winPtr->display, winPtr->window, pixel);
- } else {
- winPtr->dirtyAtts = (winPtr->dirtyAtts & ~CWBackPixmap)
- | CWBackPixel;
- }
-}
-
-void
-Tk_SetWindowBackgroundPixmap(tkwin, pixmap)
- Tk_Window tkwin; /* Window to manipulate. */
- Pixmap pixmap; /* Pixmap to use for window's
- * background. */
-{
- register TkWindow *winPtr = (TkWindow *) tkwin;
-
- winPtr->atts.background_pixmap = pixmap;
-
- if (winPtr->window != None) {
- XSetWindowBackgroundPixmap(winPtr->display,
- winPtr->window, pixmap);
- } else {
- winPtr->dirtyAtts = (winPtr->dirtyAtts & ~CWBackPixel)
- | CWBackPixmap;
- }
-}
-
-void
-Tk_SetWindowBorder(tkwin, pixel)
- Tk_Window tkwin; /* Window to manipulate. */
- unsigned long pixel; /* Pixel value to use for
- * window's border. */
-{
- register TkWindow *winPtr = (TkWindow *) tkwin;
-
- winPtr->atts.border_pixel = pixel;
-
- if (winPtr->window != None) {
- XSetWindowBorder(winPtr->display, winPtr->window, pixel);
- } else {
- winPtr->dirtyAtts = (winPtr->dirtyAtts & ~CWBorderPixmap)
- | CWBorderPixel;
- }
-}
-
-void
-Tk_SetWindowBorderPixmap(tkwin, pixmap)
- Tk_Window tkwin; /* Window to manipulate. */
- Pixmap pixmap; /* Pixmap to use for window's
- * border. */
-{
- register TkWindow *winPtr = (TkWindow *) tkwin;
-
- winPtr->atts.border_pixmap = pixmap;
-
- if (winPtr->window != None) {
- XSetWindowBorderPixmap(winPtr->display,
- winPtr->window, pixmap);
- } else {
- winPtr->dirtyAtts = (winPtr->dirtyAtts & ~CWBorderPixel)
- | CWBorderPixmap;
- }
-}
-
-void
-Tk_DefineCursor(tkwin, cursor)
- Tk_Window tkwin; /* Window to manipulate. */
- Cursor cursor; /* Cursor to use for window (may be None). */
-{
- register TkWindow *winPtr = (TkWindow *) tkwin;
-
- winPtr->atts.cursor = cursor;
-
- if (winPtr->window != None) {
- XDefineCursor(winPtr->display, winPtr->window, cursor);
- } else {
- winPtr->dirtyAtts = winPtr->dirtyAtts | CWCursor;
- }
-}
-
-void
-Tk_UndefineCursor(tkwin)
- Tk_Window tkwin; /* Window to manipulate. */
-{
- Tk_DefineCursor(tkwin, None);
-}
-
-void
-Tk_SetWindowColormap(tkwin, colormap)
- Tk_Window tkwin; /* Window to manipulate. */
- Colormap colormap; /* Colormap to use for window. */
-{
- register TkWindow *winPtr = (TkWindow *) tkwin;
-
- winPtr->atts.colormap = colormap;
-
- if (winPtr->window != None) {
- XSetWindowColormap(winPtr->display, winPtr->window, colormap);
- } else {
- winPtr->dirtyAtts |= CWColormap;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tk_SetWindowVisual --
- *
- * This procedure is called to specify a visual to be used
- * for a Tk window when it is created. This procedure, if
- * called at all, must be called before the X window is created
- * (i.e. before Tk_MakeWindowExist is called).
- *
- * Results:
- * The return value is 1 if successful, or 0 if the X window has
- * been already created.
- *
- * Side effects:
- * The information given is stored for when the window is created.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tk_SetWindowVisual(tkwin, visual, depth, colormap)
- Tk_Window tkwin; /* Window to manipulate. */
- Visual *visual; /* New visual for window. */
- unsigned int depth; /* New depth for window. */
- Colormap colormap; /* An appropriate colormap for the visual. */
-{
- register TkWindow *winPtr = (TkWindow *) tkwin;
-
- if( winPtr->window != None ){
- /* Too late! */
- return 0;
- }
-
- winPtr->visual = visual;
- winPtr->depth = depth;
- winPtr->atts.colormap = colormap;
-
- /*
- * The following code is needed to make sure that the window doesn't
- * inherit the parent's border pixmap, which would result in a BadMatch
- * error.
- */
-
- if (!(winPtr->dirtyAtts & CWBorderPixmap)) {
- winPtr->dirtyAtts |= CWBorderPixel;
- }
- return 1;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * DoConfigureNotify --
- *
- * Generate a ConfigureNotify event describing the current
- * configuration of a window.
- *
- * Results:
- * None.
- *
- * Side effects:
- * An event is generated and processed by Tk_HandleEvent.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-DoConfigureNotify(winPtr)
- register TkWindow *winPtr; /* Window whose configuration
- * was just changed. */
-{
- XEvent event;
-
- event.type = ConfigureNotify;
- event.xconfigure.serial = LastKnownRequestProcessed(winPtr->display);
- event.xconfigure.send_event = False;
- event.xconfigure.display = winPtr->display;
- event.xconfigure.event = winPtr->window;
- event.xconfigure.window = winPtr->window;
- event.xconfigure.x = winPtr->changes.x;
- event.xconfigure.y = winPtr->changes.y;
- event.xconfigure.width = winPtr->changes.width;
- event.xconfigure.height = winPtr->changes.height;
- event.xconfigure.border_width = winPtr->changes.border_width;
- if (winPtr->changes.stack_mode == Above) {
- event.xconfigure.above = winPtr->changes.sibling;
- } else {
- event.xconfigure.above = None;
- }
- event.xconfigure.override_redirect = winPtr->atts.override_redirect;
- Tk_HandleEvent(&event);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tk_SetClass --
- *
- * This procedure is used to give a window a class.
- *
- * Results:
- * None.
- *
- * Side effects:
- * A new class is stored for tkwin, replacing any existing
- * class for it.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tk_SetClass(tkwin, className)
- Tk_Window tkwin; /* Token for window to assign class. */
- char *className; /* New class for tkwin. */
-{
- register TkWindow *winPtr = (TkWindow *) tkwin;
-
- winPtr->classUid = Tk_GetUid(className);
- if (winPtr->flags & TK_TOP_LEVEL) {
- TkWmSetClass(winPtr);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tk_NameToWindow --
- *
- * Given a string name for a window, this procedure
- * returns the token for the window, if there exists a
- * window corresponding to the given name.
- *
- * Results:
- * The return result is either a token for the window corresponding
- * to "name", or else NULL to indicate that there is no such
- * window. In this case, an error message is left in interp->result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-Tk_Window
-Tk_NameToWindow(interp, pathName, tkwin)
- Tcl_Interp *interp; /* Where to report errors. */
- char *pathName; /* Path name of window. */
- Tk_Window tkwin; /* Token for window: name is assumed to
- * belong to the same main window as tkwin. */
-{
- Tcl_HashEntry *hPtr;
-
- hPtr = Tcl_FindHashEntry(&((TkWindow *) tkwin)->mainPtr->nameTable,
- pathName);
- if (hPtr == NULL) {
- Tcl_AppendResult(interp, "bad window path name \"",
- pathName, "\"", (char *) NULL);
- return NULL;
- }
- return (Tk_Window) Tcl_GetHashValue(hPtr);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tk_DisplayName --
- *
- * Return the textual name of a window's display.
- *
- * Results:
- * The return value is the string name of the display associated
- * with tkwin.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-char *
-Tk_DisplayName(tkwin)
- Tk_Window tkwin; /* Window whose display name is desired. */
-{
- return ((TkWindow *) tkwin)->dispPtr->name;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tk_SetColorModel --
- *
- * This procedure changes the current color model for a window
- * (actually, for the window's screen).
- *
- * Results:
- * None.
- *
- * Side effects:
- * The color model for tkwin's screen is set to "model".
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tk_SetColorModel(tkwin, model)
- Tk_Window tkwin; /* Token for window; this selects a screen
- * whose color model is to be modified. */
- Tk_ColorModel model; /* New model for tkwin's screen. */
-{
- TkWindow *winPtr = (TkWindow *) tkwin;
- winPtr->dispPtr->colorModels[winPtr->screenNum] = model;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tk_GetColorModel --
- *
- * This procedure returns the current color model for a window
- * (actually, for the window's screen).
- *
- * Results:
- * A color model.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-Tk_ColorModel
-Tk_GetColorModel(tkwin)
- Tk_Window tkwin; /* Token for window; this selects a screen
- * whose color model is returned. */
-{
- TkWindow *winPtr = (TkWindow *) tkwin;
- return winPtr->dispPtr->colorModels[winPtr->screenNum];
-
-}
+++ /dev/null
-#include "scheme.h"
-#include "prims.h"
-
-#define External_Primitive(fn_name) \
- extern SCHEME_OBJECT EXFUN (fn_name, (void))
-
-External_Primitive(Prim_tcl_eval);
-External_Primitive(Prim_tk_completely_handles_event);
-External_Primitive(Prim_tk_create_tl_window);
-External_Primitive(Prim_tk_do_events);
-External_Primitive(Prim_tk_drain);
-External_Primitive(Prim_tk_generate_scheme_event);
-External_Primitive(Prim_tk_init);
-External_Primitive(Prim_tk_invoke);
-External_Primitive(Prim_tk_kill_app);
-External_Primitive(Prim_tk_manage_geom);
-External_Primitive(Prim_tk_map_widget);
-External_Primitive(Prim_tk_map_window);
-External_Primitive(Prim_tk_move);
-External_Primitive(Prim_tk_move_resize);
-External_Primitive(Prim_tk_next_wakeup);
-External_Primitive(Prim_tk_resize);
-External_Primitive(Prim_tk_unmap_window);
-External_Primitive(Prim_tk_win_req_height);
-External_Primitive(Prim_tk_win_req_width);
-External_Primitive(Prim_tk_widget_get_tkwin);
-External_Primitive(Prim_tk_win_display);
-External_Primitive(Prim_tk_win_is_mapped);
-External_Primitive(Prim_tk_win_height);
-External_Primitive(Prim_tk_win_width);
-External_Primitive(Prim_tk_win_window);
-External_Primitive(Prim_tk_win_x);
-External_Primitive(Prim_tk_win_y);
-External_Primitive(Prim_tk_win_name);
-External_Primitive(Prim_tk_win_pathname);
-External_Primitive(Prim_tk_delete_display);
-External_Primitive(Prim_tk_destroy_widget);
-External_Primitive(Prim_tk_make_button);
-External_Primitive(Prim_tk_make_canvas);
-External_Primitive(Prim_tk_make_check_button);
-External_Primitive(Prim_tk_make_entry);
-External_Primitive(Prim_tk_make_label);
-External_Primitive(Prim_tk_make_listbox);
-External_Primitive(Prim_tk_make_menu);
-External_Primitive(Prim_tk_make_menu_button);
-External_Primitive(Prim_tk_make_message);
-External_Primitive(Prim_tk_make_radio_button);
-External_Primitive(Prim_tk_make_scale);
-External_Primitive(Prim_tk_make_scrollbar);
-External_Primitive(Prim_tk_make_text);
-
-extern char *EXFUN (dload_initialize_file, (void));
-
-char *
- DEFUN_VOID (dload_initialize_file)
-{ /* Primitives in tk-c-mit.c */
- declare_primitive ("%tclGlobalEval", Prim_tcl_eval, 2, 2, 0);
- declare_primitive ("%tkCompletelyHandlesEvent?",
- Prim_tk_completely_handles_event, 1, 1, 0);
- declare_primitive ("%tkCreateTopLevelWindow",
- Prim_tk_create_tl_window, 3, 3, 0);
- declare_primitive ("%tkDoEvents", Prim_tk_do_events, 0, 0, 0);
- declare_primitive ("%tkDrainCallBacks", Prim_tk_drain, 2, 2, 0);
- declare_primitive ("%tkGenerateSchemeEvent",
- Prim_tk_generate_scheme_event, 2, 2, 0);
- declare_primitive ("%tkInit", Prim_tk_init, 2, 2, 0);
- declare_primitive ("%tkInvokeCommand", Prim_tk_invoke, 2, LEXPR, 0);
- declare_primitive ("%tkKillApplication", Prim_tk_kill_app, 1, 1, 0);
- declare_primitive ("%tkManageGeometry", Prim_tk_manage_geom, 2, 2, 0);
- declare_primitive ("%tkMapWidget", Prim_tk_map_widget, 6, 6, 0);
- declare_primitive ("%tkMapWindow", Prim_tk_map_window, 1, 1, 0);
- declare_primitive ("%tkMoveWindow", Prim_tk_move, 3, 3, 0);
- declare_primitive ("%tkMoveResizeWindow", Prim_tk_move_resize, 5, 5, 0);
- declare_primitive ("%tkNextWakeup", Prim_tk_next_wakeup, 0, 0, 0);
- declare_primitive ("%tkResizeWindow", Prim_tk_resize, 3, 3, 0);
- declare_primitive ("%tkUnmapWindow", Prim_tk_unmap_window, 1, 1, 0);
- declare_primitive ("%tkWinReqHeight", Prim_tk_win_req_height, 1, 1, 0);
- declare_primitive ("%tkWinReqWidth", Prim_tk_win_req_width, 1, 1, 0);
- declare_primitive ("%tkWidget.tkwin", Prim_tk_widget_get_tkwin, 1, 1, 0);
- declare_primitive ("%tkWinDisplay", Prim_tk_win_display, 1, 1, 0);
- declare_primitive ("%tkWinIsMapped?", Prim_tk_win_is_mapped, 1, 1, 0);
- declare_primitive ("%tkWinHeight", Prim_tk_win_height, 1, 1, 0);
- declare_primitive ("%tkWinWidth", Prim_tk_win_width, 1, 1, 0);
- declare_primitive ("%tkWinWindow", Prim_tk_win_window, 1, 1, 0);
- declare_primitive ("%tkWinX", Prim_tk_win_x, 1, 1, 0);
- declare_primitive ("%tkWinY", Prim_tk_win_y, 1, 1, 0);
- declare_primitive ("%tkWinName", Prim_tk_win_name, 1, 1, 0);
- declare_primitive ("%tkWinPathName", Prim_tk_win_pathname, 1, 1, 0);
- /* Primitive in widget-c-mit.c */
- declare_primitive ("%tkDeleteDisplay", Prim_tk_delete_display, 1, 1, 0);
- declare_primitive ("%tkDestroyWidget", Prim_tk_destroy_widget, 1, 1, 0);
- declare_primitive ("%tkMakeButton", Prim_tk_make_button, 2, 2, 0);
- declare_primitive ("%tkMakeCanvas", Prim_tk_make_canvas, 2, 2, 0);
- declare_primitive ("%tkMakeCheckButton", Prim_tk_make_check_button, 2, 2, 0);
- declare_primitive ("%tkMakeEntry", Prim_tk_make_entry, 2, 2, 0);
- declare_primitive ("%tkMakeLabel", Prim_tk_make_label, 2, 2, 0);
- declare_primitive ("%tkMakeListbox", Prim_tk_make_listbox, 2, 2, 0);
- declare_primitive ("%tkMakeMenu", Prim_tk_make_menu, 2, 2, 0);
- declare_primitive ("%tkMakeMenuButton", Prim_tk_make_menu_button, 2, 2, 0);
- declare_primitive ("%tkMakeMessage", Prim_tk_make_message, 2, 2, 0);
- declare_primitive ("%tkMakeRadioButton", Prim_tk_make_radio_button, 2, 2, 0);
- declare_primitive ("%tkMakeScale", Prim_tk_make_scale, 2, 2, 0);
- declare_primitive ("%tkMakeScrollBar", Prim_tk_make_scrollbar, 2, 2, 0);
- declare_primitive ("%tkMakeText", Prim_tk_make_text, 2, 2, 0);
- return "#UITK";
-}
+++ /dev/null
-/* Cover routines to make MIT/GNU Scheme primitives out of the procedures */
-/* in button-c.c. */
-
-#include "scheme.h"
-#include "prims.h"
-#include "ansidecl.h"
-#include "X11/Xlib.h"
-
-DEFINE_PRIMITIVE ("%tkDeleteDisplay", Prim_tk_delete_display, 1, 1, 0)
-{ /* (%tkDeleteDisplay XDisplayNumber) */
- extern void tk_delete_display (Display *disp);
- PRIMITIVE_HEADER(1);
- tk_delete_display((Display *) arg_integer(1));
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%tkDestroyWidget", Prim_tk_destroy_widget, 1, 1, 0)
-{ /* (%tkDestroyWidget tk-handle ) */
- extern void tk_destroy_widget(long /*Button **/ button);
- PRIMITIVE_HEADER(1);
- tk_destroy_widget((long /*Button **/) arg_integer(1));
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("%tkMakeButton", Prim_tk_make_button, 2, 2, 0)
-{ /* (%tkMakeButton ParentTKWindow name-string)
- */
- extern int *MakeButton(long /*Tk_Window*/ parent_window, char *name);
- PRIMITIVE_HEADER(2);
- PRIMITIVE_RETURN
- (long_to_integer
- ((long) MakeButton((long /*Tk_Window*/) arg_integer(1),
- STRING_ARG(2))));
-}
-
-DEFINE_PRIMITIVE ("%tkMakeCanvas", Prim_tk_make_canvas, 2, 2, 0)
-{ /* (%tkMakeCanvas ParentTKWindow name-string)
- */
- extern int *MakeCanvas(long /*Tk_Window*/ parent_window, char *name);
- PRIMITIVE_HEADER(2);
- PRIMITIVE_RETURN
- (long_to_integer
- ((long) MakeCanvas((long /*Tk_Window*/) arg_integer(1),
- STRING_ARG(2))));
-}
-
-DEFINE_PRIMITIVE ("%tkMakeCheckButton", Prim_tk_make_check_button, 2, 2, 0)
-{ /* (%tkMakeCheckButton ParentTKWindow name-string)
- */
- extern int *MakeCheckButton(long /*Tk_Window*/ parent_window, char *name);
- PRIMITIVE_HEADER(2);
- PRIMITIVE_RETURN
- (long_to_integer
- ((long) MakeCheckButton((long /*Tk_Window*/) arg_integer(1),
- STRING_ARG(2))));
-
-}
-
-DEFINE_PRIMITIVE ("%tkMakeEntry", Prim_tk_make_entry, 2, 2, 0)
-{ /* (%tkMakeEntry ParentTKWindow name-string)
- */
- extern int *MakeEntry(long /*Tk_Window*/ parent_window, char *name);
- PRIMITIVE_HEADER(2);
- PRIMITIVE_RETURN
- (long_to_integer
- ((long) MakeEntry((long /*Tk_Window*/) arg_integer(1),
- STRING_ARG(2))));
-}
-
-DEFINE_PRIMITIVE ("%tkMakeLabel", Prim_tk_make_label, 2, 2, 0)
-{ /* (%tkMakeLabel ParentTKWindow name-string)
- */
- extern int *MakeLabel(long /*Tk_Window*/ parent_window, char *name);
- PRIMITIVE_HEADER(2);
- PRIMITIVE_RETURN
- (long_to_integer
- ((long) MakeLabel((long /*Tk_Window*/) arg_integer(1),
- STRING_ARG(2))));
-}
-
-DEFINE_PRIMITIVE ("%tkMakeListbox", Prim_tk_make_listbox, 2, 2, 0)
-{ /* (%tkMakeListbox ParentTKWindow name-string)
- */
- extern int *MakeListbox(long /*Tk_Window*/ parent_window, char *name);
- PRIMITIVE_HEADER(2);
- PRIMITIVE_RETURN
- (long_to_integer
- ((long) MakeListbox((long /*Tk_Window*/) arg_integer(1),
- STRING_ARG(2))));
-}
-
-DEFINE_PRIMITIVE ("%tkMakeMenu", Prim_tk_make_menu, 2, 2, 0)
-{ /* (%tkMakeMenu ParentTKWindow name-string)
- */
- extern int *MakeMenu(long /*Tk_Window*/ parent_window, char *name);
- PRIMITIVE_HEADER(2);
- PRIMITIVE_RETURN
- (long_to_integer
- ((long) MakeMenu((long /*Tk_Window*/) arg_integer(1),
- STRING_ARG(2))));
-
-}
-
-DEFINE_PRIMITIVE ("%tkMakeMenuButton", Prim_tk_make_menu_button, 2, 2, 0)
-{ /* (%tkMakeMenuButton ParentTKWindow name-string)
- */
- extern int *MakeMenuButton(long /*Tk_Window*/ parent_window, char *name);
- PRIMITIVE_HEADER(2);
- PRIMITIVE_RETURN
- (long_to_integer
- ((long) MakeMenuButton((long /*Tk_Window*/) arg_integer(1),
- STRING_ARG(2))));
-
-}
-
-DEFINE_PRIMITIVE ("%tkMakeMessage", Prim_tk_make_message, 2, 2, 0)
-{ /* (%tkMakeMessage ParentTKWindow name-string)
- */
- extern int *MakeMessage(long /*Tk_Window*/ parent_window, char *name);
- PRIMITIVE_HEADER(2);
- PRIMITIVE_RETURN
- (long_to_integer
- ((long) MakeMessage((long /*Tk_Window*/) arg_integer(1),
- STRING_ARG(2))));
-}
-
-DEFINE_PRIMITIVE ("%tkMakeRadioButton", Prim_tk_make_radio_button, 2, 2, 0)
-{ /* (%tkMakeRadioButton ParentTKWindow name-string)
- */
- extern int *MakeRadioButton(long /*Tk_Window*/ parent_window, char *name);
- PRIMITIVE_HEADER(2);
- PRIMITIVE_RETURN
- (long_to_integer
- ((long) MakeRadioButton((long /*Tk_Window*/) arg_integer(1),
- STRING_ARG(2))));
-
-}
-
-DEFINE_PRIMITIVE ("%tkMakeScale", Prim_tk_make_scale, 2, 2, 0)
-{ /* (%tkMakeScale ParentTKWindow name-string)
- */
- extern int *MakeScale(long /*Tk_Window*/ parent_window, char *name);
- PRIMITIVE_HEADER(2);
- PRIMITIVE_RETURN
- (long_to_integer
- ((long) MakeScale((long /*Tk_Window*/) arg_integer(1),
- STRING_ARG(2))));
-}
-
-DEFINE_PRIMITIVE ("%tkMakeScrollBar", Prim_tk_make_scrollbar, 2, 2, 0)
-{ /* (%tkMakeScrollBar ParentTKWindow name-string)
- */
- extern int *MakeScrollBar(long /*Tk_Window*/ parent_window, char *name);
- PRIMITIVE_HEADER(2);
- PRIMITIVE_RETURN
- (long_to_integer
- ((long) MakeScrollBar((long /*Tk_Window*/) arg_integer(1),
- STRING_ARG(2))));
-}
-
-DEFINE_PRIMITIVE ("%tkMakeText", Prim_tk_make_text, 2, 2, 0)
-{ /* (%tkMakeText ParentTKWindow name-string)
- */
- extern int *MakeText(long /*Tk_Window*/ parent_window, char *name);
- PRIMITIVE_HEADER(2);
- PRIMITIVE_RETURN
- (long_to_integer
- ((long) MakeText((long /*Tk_Window*/) arg_integer(1),
- STRING_ARG(2))));
-
-}
+++ /dev/null
-#include <stdio.h>
-#include "tk.h"
-#include "default.h"
-#include "tkInt.h"
-
-typedef struct
-{ Tk_Window tkwin;
- Display *display;
- Tcl_Interp *interp;
-} All_Widgets;
-
-
-int *
-MakeButton(Tk_Window tkMainWindow, char *name)
-{ char *argv [2];
- Tcl_Interp *tclInterp;
-
- argv [0] = "button";
- argv [1] = name;
- tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
- if (Tk_ButtonCmd ((ClientData) tkMainWindow,
- tclInterp, 2, argv) != TCL_OK)
- { fprintf (stderr, tclInterp->result);
- exit (1);
- }
- return (int *) GetCmdClientData (tclInterp, name);
-}
-
-int *
-MakeCanvas(Tk_Window tkMainWindow, char *name)
-{ char *argv [2];
- Tcl_Interp *tclInterp;
-
- argv [0] = "canvas";
- argv [1] = name;
- tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
- if (Tk_CanvasCmd ((ClientData) tkMainWindow,
- tclInterp, 2, argv) != TCL_OK)
- { fprintf (stderr, tclInterp->result);
- exit (1);
- }
- return (int *) GetCmdClientData (tclInterp, name);
-}
-
-int *
-MakeCheckButton(Tk_Window tkMainWindow, char *name)
-{ char *argv [2];
- Tcl_Interp *tclInterp;
-
- argv [0] = "checkbutton";
- argv [1] = name;
- tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
- if (Tk_ButtonCmd ((ClientData) tkMainWindow,
- tclInterp, 2, argv) != TCL_OK)
- { fprintf (stderr, tclInterp->result);
- exit (1);
- }
- return (int *) GetCmdClientData (tclInterp, name);
-}
-
-int *
-MakeEntry(Tk_Window tkMainWindow, char *name)
-{ char *argv [2];
- Tcl_Interp *tclInterp;
-
- argv [0] = "entry";
- argv [1] = name;
- tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
- if (Tk_EntryCmd ((ClientData) tkMainWindow,
- tclInterp, 2, argv) != TCL_OK)
- { fprintf (stderr, tclInterp->result);
- exit (1);
- }
- return (int *) GetCmdClientData (tclInterp, name);
-}
-
-int *
-MakeLabel(Tk_Window tkMainWindow, char *name)
-{ char *argv [2];
- Tcl_Interp *tclInterp;
-
- argv [0] = "label";
- argv [1] = name;
- tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
- if (Tk_ButtonCmd ((ClientData) tkMainWindow,
- tclInterp, 2, argv) != TCL_OK)
- { fprintf (stderr, tclInterp->result);
- exit (1);
- }
- return (int *) GetCmdClientData (tclInterp, name);
-}
-
-int *
-MakeListbox(Tk_Window tkMainWindow, char *name)
-{ char *argv [2];
- Tcl_Interp *tclInterp;
-
- argv [0] = "listbox";
- argv [1] = name;
- tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
- if (Tk_ListboxCmd ((ClientData) tkMainWindow,
- tclInterp, 2, argv) != TCL_OK)
- { fprintf (stderr, tclInterp->result);
- exit (1);
- }
- return (int *) GetCmdClientData (tclInterp, name);
-}
-
-int *
-MakeMenu(Tk_Window tkMainWindow, char *name)
-{ char *argv [2];
- Tcl_Interp *tclInterp;
-
- argv [0] = "menu";
- argv [1] = name;
- tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
- if (Tk_MenuCmd ((ClientData) tkMainWindow,
- tclInterp, 2, argv) != TCL_OK)
- { fprintf (stderr, tclInterp->result);
- exit (1);
- }
- return (int *) GetCmdClientData (tclInterp, name);
-}
-
-int *
-MakeMenuButton(Tk_Window tkMainWindow, char *name)
-{ char *argv [2];
- Tcl_Interp *tclInterp;
-
- argv [0] = "menubutton";
- argv [1] = name;
- tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
- if (Tk_MenubuttonCmd ((ClientData) tkMainWindow,
- tclInterp, 2, argv) != TCL_OK)
- { fprintf (stderr, tclInterp->result);
- exit (1);
- }
- return (int *) GetCmdClientData (tclInterp, name);
-}
-
-int *
-MakeMessage(Tk_Window tkMainWindow, char *name)
-{ char *argv [2];
- Tcl_Interp *tclInterp;
-
- argv [0] = "message";
- argv [1] = name;
- tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
- if (Tk_MessageCmd ((ClientData) tkMainWindow,
- tclInterp, 2, argv) != TCL_OK)
- { fprintf (stderr, tclInterp->result);
- exit (1);
- }
- return (int *) GetCmdClientData (tclInterp, name);
-}
-
-int *
-MakeRadioButton(Tk_Window tkMainWindow, char *name)
-{ char *argv [2];
- Tcl_Interp *tclInterp;
-
- argv [0] = "radiobutton";
- argv [1] = name;
- tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
- if (Tk_ButtonCmd ((ClientData) tkMainWindow,
- tclInterp, 2, argv) != TCL_OK)
- { fprintf (stderr, tclInterp->result);
- exit (1);
- }
- return (int *) GetCmdClientData (tclInterp, name);
-}
-
-int *
-MakeScale(Tk_Window tkMainWindow, char *name)
-{ char *argv [2];
- Tcl_Interp *tclInterp;
-
- argv [0] = "scale";
- argv [1] = name;
- tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
- if (Tk_ScaleCmd ((ClientData) tkMainWindow,
- tclInterp, 2, argv) != TCL_OK)
- { fprintf (stderr, tclInterp->result);
- exit (1);
- }
-
- return (int *) GetCmdClientData (tclInterp, name);
-}
-
-int *
-MakeScrollBar(Tk_Window tkMainWindow, char *name)
-{ char *argv [2];
- Tcl_Interp *tclInterp;
-
- argv [0] = "scrollbar";
- argv [1] = name;
- tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
- if (Tk_ScrollbarCmd ((ClientData) tkMainWindow,
- tclInterp, 2, argv) != TCL_OK)
- { fprintf (stderr, tclInterp->result);
- exit (1);
- }
- return (int *) GetCmdClientData (tclInterp, name);
-}
-
-int *
-MakeText(Tk_Window tkMainWindow, char *name)
-{ char *argv [2];
- Tcl_Interp *tclInterp;
-
- argv [0] = "text";
- argv [1] = name;
- tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
- if (Tk_TextCmd ((ClientData) tkMainWindow,
- tclInterp, 2, argv) != TCL_OK)
- { fprintf (stderr, tclInterp->result);
- exit (1);
- }
- return (int *) GetCmdClientData (tclInterp, name);
-}
-
-/* These ought to be in tk-c.c but need internal data structures to work */
-
-char *
-tk_map_widget (All_Widgets *Widget, Tk_Window tkMainWindow, char *name,
- Window xwindow, int x, int y)
-/* This better work for all TK widgets or there's trouble */
-/* "name" is the name originally given to this widget. */
-{ TkWindow *win;
-
- win = ((TkWindow *) (Widget->tkwin));
- if ((xwindow != (Window) NULL) &&
- (((win->parentPtr)->window) != xwindow))
- { extern int NameWindow _ANSI_ARGS_((Tcl_Interp *interp,
- TkWindow *winPtr,
- TkWindow *parentPtr,
- char *name));
- char *argv [3];
- Tcl_Interp *tclInterp = (((TkWindow *) tkMainWindow)->mainPtr)->interp;
- Tk_Window InternalWindow =
- Tk_CreateWindow(tclInterp, tkMainWindow, name, (char *) NULL);
-
- ((TkWindow *) InternalWindow)->window = xwindow;
- if (((win->parentPtr)->window) != (Window) NULL)
- fprintf(stderr, "tk_map_widget: changing parent window!\n");
- NameWindow(tclInterp, (TkWindow *) win,
- (TkWindow *) InternalWindow, name);
- argv[0] = "rename";
- argv[1] = name;
- argv[2] = Tk_PathName((Tk_Window) win);
- if (Tcl_RenameCmd((ClientData) 0, tclInterp, 3, argv) != TCL_OK)
- { fprintf(stderr, "Failed. %s\n", tclInterp->result);
- }
- }
- Tk_MoveWindow ((Tk_Window) win, x, y);
- if (xwindow == (Window) NULL) Tk_UnmapWindow((Tk_Window) win);
- else Tk_MapWindow ((Tk_Window) win);
- return Tk_PathName((Tk_Window) win);
-}
-
-Tk_Window
-tk_tkwin_widget (All_Widgets *Widget)
-/* This better work for all TK widgets or there's trouble */
-{
- return Widget->tkwin;
-}
-
-void
-tk_destroy_widget (All_Widgets *Widget)
-{ /* This better work for all TK widgets or there's trouble */
- Tk_DestroyWindow(Widget->tkwin);
- return;
-}
-
-void
- tk_delete_display (Display *disp)
-{ Tk_DestroyDisplayByNumber(disp);
- return;
-}
+++ /dev/null
-;;;;; -*- Scheme -*-
-;;;;; Basic objects for the Scheme User Interface Tool Kit
-;;;; MIT/GNU Scheme Version derived from Scheme-To-C version 1.2
-
-;;;; Application objects
-
-(define (application->TKMainWindow obj) (Application%.TKMainWindow obj))
-(define (application->Display obj) (Application%.Xdisplay obj))
-
-(define (valid-color-for-application? app color-string)
- ((string->color (application->display app)) color-string))
-
-(define (valid-color? color-string)
- ;; For default application
- ((string->color (application->display *the-default-application*))
- color-string))
-
-(define (make-top-level-geometry-callback kid)
- ;; Is the TK-TOP-LEVEL-WINDOW required any more? --Jim
- (let ((my-screen-area #f))
- (lambda (configure-event)
- (Decode-Configure-Event
- Configure-Event
- (lambda (type serial send_event display event window x y width
- height border-width above override-redirect)
- type serial send_event display event window x y
- border-width above override-redirect ; Not used
- (let ((new-area (make-UITKRectangle
- ; (make-point x y)
- (make-point 0 0)
- (make-size width height))))
- (if (not (screen-area= new-area my-screen-area))
- (begin
- (%XClearWindow display window)
- (assign-screen-area! kid #F)
- (assign-screen-area! kid new-area)))
- (set! my-screen-area new-area))
- 'DONE)))))
-
-(define (valid-child? object)
- (or (interactor%? object)
- (box%? object)
- (arraybox%? object)
- (shape%? object)
- (tkwidget%? object)))
-
-(define (application-add-child! application to-be-managed . child-name)
- ;; Name is an optional string that overrides the application's
- ;; name for providing a title to the child window
- (if (not (valid-child? to-be-managed))
- (error "APPLICATION-ADD-CHILD!: Bad UIObj" to-be-managed))
- (one-parent-only! to-be-managed application)
- (let ((really-adding? #F)
- (new-entry (cons to-be-managed 'TK-Top-Level-Window)))
- (update-locked-list!
- (Application%.%child-windows application)
- (lambda (kids)
- (if (assq to-be-managed kids)
- kids
- (begin
- (set! really-adding? #T)
- (cons new-entry kids)))))
- (if really-adding?
- (let ((Xdisplay (Application%.Xdisplay application))
- (context (Application%.context application))
- (top-level-geometry-callback
- (make-top-level-geometry-callback to-be-managed))
- (TKMainW
- (application->TKMainWindow application))
- (TKW (make-ToolKitWindow application #F #F)))
- (let* ((drawing-surface (make-DrawingSurface TKW #F))
- (tlwindow
- (tk-create-top-level-window
- TKMainW
- (hash top-level-geometry-callback *our-hash-table*))))
- (set-cdr! new-entry tlwindow)
- (set-ToolKitWindow.TK-Window! TKW tlwindow)
- (set-ToolKitWindow.Top-Level-Geometry-Callback!
- TKW top-level-geometry-callback)
- (set-context! to-be-managed context)
- (assign-drawing-surface! to-be-managed drawing-surface)
- (let ((desired-size (get-desired-size to-be-managed))
- (window-name (tkwin.pathname tlwindow)))
- (tk-invoke-command
- 'WM TKMainW
- (list "title" window-name
- (if (and (pair? child-name)
- (string? (car child-name)))
- (car child-name)
- (Application%.application-name application))))
- (let ((tlwindow-width
- (number->string (or (size.width desired-size) 0)))
- (tlwindow-height
- (number->string (or (size.height desired-size) 0))))
-
- #|
- (tk-invoke-command
- 'WM TKMainW
- (list "minsize" window-name "1" "1"))
- |#
-
- (tk-invoke-command
- 'WM TKMainW
- (list "minsize" window-name tlwindow-width tlwindow-height))
- ;;X signals errors if we don't do this, but I'm damned if I know why
- (tk-invoke-command
- 'WM TKMainW
- (list "geometry" window-name
- (string-append tlwindow-width "x" tlwindow-height)))
- )
- (let ((kill-me
- (lambda ()
- (application-remove-destroyed-child! application to-be-managed)
- )))
- (tk-invoke-command
- 'BIND TKMainW
- (list window-name "<Destroy>"
- (string-append
- "SchemeCallBack "
- (number->string (hash kill-me *our-hash-table*)))))
- (UIObj-protect-from-gc! to-be-managed kill-me))
- ;; Events start being generated and handled in
- ;; the other thread as soon as we map this
- ;; window! We must map the window before doing
- ;; the MAKE-UITKWINDOW below, because TK
- ;; doesn't create the X window until the widget
- ;; is mapped.
- (our-with-thread-mutex-locked
- 'add-child-locks-out-others
- *event-processing-mutex*
- (lambda ()
- (tk-map-window tlwindow)
- (let ((UITKWindow
- (make-uitkwindow
- Xdisplay
- (wrap-window Xdisplay
- (tkwin.window tlwindow)))))
- (set-DrawingSurface.UITKWindow!
- drawing-surface UITKWindow)
- (assign-drawing-surface!
- to-be-managed drawing-surface))
- ;; UITKWindow changed and some objects will
- ;; need that rather than just the TK top
- ;; level window.
- (assign-screen-area!
- to-be-managed
- (make-UITKRectangle (make-point 0 0)
- (tkwin->size tlwindow)))
- ))))
- #|
- ;;let window resize when kid requests resize
- ;;but this means that size is determined by kid -- not WM
- ;;do we want both kinds of windows??
- (on-geometry-change!
- to-be-managed 'APPLICATION
- (lambda (old-screen-area new-screen-area)
- old-screen-area ;not used
- (if (eq? new-screen-area #T) ;instigated by child
- (let* ((desired-size (get-desired-size to-be-managed))
- (tlwindow-width
- (number->string (or (size.width desired-size) 0)))
- (tlwindow-height
- (number->string (or (size.height desired-size) 0)))
- (window-name
- (tkwin.pathname
- (ToolkitWindow.TK-window
- (DrawingSurface.ToolkitWindow
- (drawing-surface to-be-managed))))))
- (tk-invoke-command
- 'WM TKMainW
- (list "minsize" window-name tlwindow-width tlwindow-height))
- (tk-invoke-command
- 'WM TKMainW
- (list "geometry" window-name
- (string-append tlwindow-width "x" tlwindow-height)))))))
-
- |#
-
- (on-death! to-be-managed 'APPLICATION
- (lambda ()
- (application-remove-child! application to-be-managed)))))
- 'ADDED))
-;;; More methods for Applications below
- \f
-;;; More methods for Applications objects
-
-(define (application-remove-child! Application to-be-unmanaged)
- ;; This is called by the generic REMOVE-CHILD! procedure.
- (let ((entry (with-locked-list
- (application%.%child-windows application)
- (lambda (kids) (assq to-be-unmanaged kids)))))
- (if (not entry)
- 'NOT-A-CHILD
- (let ((tlwindow (cdr entry)))
- ;; Just kill the TK Top Level window. This will cause us to get a
- ;; <Destroy> back from TK, which we process with
- ;; Application-Remove-Destroyed-Child!, below.
- (tk-invoke-command 'DESTROY
- (Application->TKMainWindow Application)
- (list (tkwin.pathname tlwindow)))
- 'REMOVED))))
-
-(define (application-remove-destroyed-child! Application to-be-unmanaged)
- (if (not (valid-child? to-be-unmanaged))
- (error "APPLICATION-REMOVE-DESTROYED-CHILD!: Bad UIObj" to-be-unmanaged))
- (if (let ((OK? #T))
- (update-locked-list! (Application%.%child-windows Application)
- (lambda (kids)
- (if (assq to-be-unmanaged kids)
- (del-assq! to-be-unmanaged kids)
- (begin (set! OK? #F)
- kids))))
- OK?)
- (begin
- (assign-drawing-surface! to-be-unmanaged 'RETRACTED)
- (forget! Application to-be-unmanaged)
- 'REMOVED)
- 'NOT-A-CHILD))
-
-(define (make-destroy-<application>-related-objects disp registration mainwindow)
- ;; This code should not have lexical reference to the
- ;; Application, since it will run only after the Application
- ;; has vanished.
- (lambda ()
- (destroy-registration registration)
- (destroy-associated-tk-widgets (->xdisplay disp))
- (destroy-all-sensitive-surfaces-from-display disp)
- (tk-kill-application mainwindow)
- 'done))
-
-(define (application-maker application-name dsp TKmain context children code)
- ;; Can't be nested in MAKE-APPLICATION because it would lexically
- ;; capture the list of kids!
- (make-application%
- (make-UIObjInternals application-add-child!
- application-remove-child!
- UIObj-set-context!
- 'invalid-application-1 ; UIObj-assign-screen-area!
- 'invalid-application-2 ; UIObj-assign-drawing-surface!
- 'invalid-application-3 ; UIObj-point-within?
- 'invalid-application-4 ; UIObj-rectangle-overlaps?
- 'invalid-application-5 ; UIObj-handle-event
- 'invalid-application-6 ; UIObj-get-desired-size
- 'invalid-application-7 ; UIObj-assigned-screen-area
- 'invalid-application-8 ; UIObj-used-screen-area
- 'invalid-application-9 ; UIObj-set-assigned-screen-area!
- 'invalid-application-10 ; UIObj-set-used-screen-area!
- 'invalid-application-11); UIObj-assign-glue!
- children
- code
- application-name
- dsp
- TKMain
- context))
-
-(define (make-application application-name . kids)
- (let* ((dsp (open-display))
- (context (create-default-context application-name dsp))
- (me 'later)
- (event-string (%XMake-Event)))
- (define (service-display-connection)
- ;; This code is run asynchronously when data arrives from
- ;; the display connection
- (define (process-event event)
- (for-each
- (lambda (kid) (handle-event kid event))
- (with-locked-list (Application%.%child-windows me)
- (lambda (kids)
- (let loop ((rest kids)
- (handled-by '()))
- (cond ((null? rest) (reverse handled-by))
- ((event-within? (caar rest) event)
- (loop (cdr rest)
- (cons (caar rest) handled-by)))
- (else (loop (cdr rest) handled-by))))))))
- (let loop ((nextevent (get-x-event dsp event-string)))
- (if nextevent
- (begin
- (set! EVENT-COUNTER (+ 1 EVENT-COUNTER))
-
- (our-with-thread-mutex-locked
- 'process-event *event-processing-mutex*
- (lambda ()
- (if (not (tk-completely-handles-event? nextevent))
- (process-event (XEvent-><Event> nextevent)))))
-
- (do-tk-callbacks)
-
- (loop (get-x-event dsp event-string)))
- 'done))
- )
- (define (idle-work)
- ; Not actually used by MIT version
- (debug-print 'idle-work 'never called!!!!)
- (flush-queued-output dsp)
- (tk-doevents))
- (let ((TKMainWindow (tk-init dsp)))
- (set! me (application-maker application-name dsp TKMainWindow
- context (make-locked-list)
- service-display-connection))
- (add-widget-list-for-display-number! (->xdisplay dsp))
- (for-each (lambda (kid) (add-child! me kid)) kids)
- (when-unreferenced
- me
- (make-destroy-<application>-related-objects
- dsp
- (fork-to-wait-on dsp service-display-connection idle-work)
- TKMainWindow))
- me))
- )
-\f
-;;;; Interactive Geometry handlers ... low level version
-
-(define (interactor-add-child! interact to-be-managed)
- (define (find-handler event-type handlers)
- ;; Returns a list of all handlers for this event-type
- (let loop ((rest handlers))
- (cond ((null? rest) '())
- ((eq? event-type (caar rest))
- (cons (cadr (car rest)) (loop (cdr rest))))
- (else (loop (cdr rest))))))
-
- (if (not (valid-child? to-be-managed))
- (error "INTERACTOR-ADD-CHILD!: Bad UIObj" to-be-managed))
- (let ((sensitive-surfaces (Interactor%.sensitive-surface-map interact)))
- (if (not (assq to-be-managed sensitive-surfaces))
- (let* ((ss (create-sensitive-surface to-be-managed
- (Interactor%.handlers interact)))
- (entry `(,to-be-managed ,ss)))
- (set-Interactor%.sensitive-surface-map! interact
- (cons entry sensitive-surfaces))
- (on-event! to-be-managed interact
- (lambda (event)
- (let* ((handlers (Interactor%.handlers interact))
- (applicable-handlers
- (find-handler (event.type event) handlers)))
- (cond ((not (null? applicable-handlers))
- (for-each (lambda (handler) (handler event))
- applicable-handlers))
- ((assq #T handlers)
- => (lambda (entry) ((cadr entry) event)))
- (else #F)))
- (event! interact event)))
- (on-geometry-change! to-be-managed interact
- (lambda (old-screen-area new-screen-area)
- (if (and (not old-screen-area)
- (not new-screen-area))
- ;; When a drawing surface is set.
- (set! ss
- (change-sensitive-surface!
- ss
- to-be-managed))
- (set-car! (cdr entry) ss))))))))
-
-(define (interactor-remove-child! interact was-managed)
- (if (not (valid-child? was-managed))
- (error "INTERACTOR-REMOVE-CHILD!: Bad UIObj" to-be-managed))
- (forget! was-managed interact)
- (let ((ss (assq was-managed (Interactor%.sensitive-surface-map interact))))
- (if ss (destroy-sensitive-surface was-managed (cadr ss)))))
-
-;; Interactor Maker
-(define (interactor-maker alist-of-handlers)
- (make-Interactor%
- (make-UIObjInternals interactor-add-child!
- interactor-remove-child!
- UIObj-set-context! ; Defaults
- UIObj-assign-screen-area!
- UIObj-assign-drawing-surface!
- UIObj-point-within?
- UIObj-rectangle-overlaps?
- UIObj-handle-event
- UIObj-get-desired-size
- UIObj-assigned-screen-area
- UIObj-used-screen-area
- UIObj-set-assigned-screen-area!
- UIObj-set-used-screen-area!
- 'invalid)
- alist-of-handlers))
-
-(define (make-interactor objects alist-of-handlers)
- ;; Constructor for interactors
- (let ((me (interactor-maker alist-of-handlers)))
- (for-each (lambda (object) (add-child! me object)) objects)
- me)
- )
-\f
-;;;; Higher level interactors
-
-(define (handle-exposure object receiver)
- ;; Receiver will be called with the exposed rectangle
- (make-interactor
- (list object)
- `((EXPOSURE
- ,(lambda (event)
- (receiver
- (Make-UITKRectangle (Event.Offset Event)
- (Make-Size (Event.Width Event)
- (Event.Height Event))))))))
- 'OK)
-
-(define (handle-button-grab object which-buttons receiver)
- ;; Receiver is called with the buttons that were actually down and a
- ;; "while-grabbed" procedure which is expected to be tail-called by
- ;; receiver, specifying how to handle subsequent motion events and
- ;; motion termination.
- (make-interactor
- (list object)
- `((BUTTON-PRESS
- ,(lambda (event)
- (decode-button-event
- (Event.OS-Event event)
- (lambda (type serial sent? display window root
- subwindow time x y RootX RootY state
- button SameScreen?)
- type serial sent? display window root
- subwindow time x y RootX RootY state
- button SameScreen?
- (if (or (= which-buttons ANYBUTTON)
- (memv button which-buttons))
- (let* ((should-be-result (list 'foo))
- (result
- (receiver event
- (lambda (on-motion at-end)
- (mouse-drag (drawing-surface object)
- on-motion)
- (at-end)
- should-be-result))))
- (if (eq? result should-be-result)
- 'OK
- (error "HANDLE-BUTTON-GRAB: Must tail call"))))))))
- (POINTER-MOTION ,(lambda (e) e 'IGNORE))
- (BUTTON-RELEASE ,(lambda (e) e 'IGNORE)))))
-\f
-;;;; Support code for interaction managers:
-;;;; Maps from DrawingSurface to Interactor to event masks
-
-;; The global map ds->(<interactor>->eventmasks)
-(define *all-sensitive-surfaces* '())
-
-;; A Surface-Sensitivity specifies for a given drawing surface the
-;; total event-generation mask for that surface and a list of
-;; Sensitivity data structures. The mask here is the inclusive-OR of
-;; all the masks in the Sensitivity data structures.
-
-;; A Sensitivity maps a single handler to the list of event types it
-;; is intended to handle. For GC reasons, it only weakly holds the
-;; handler itself, since these are included in the global
-;; *all-sensitive-surfaces* list.
-
-(define find-sensitivity
- ;; (find-sensitivity <interactor> list-of-sensitivities) =>
- ;; sensitivity or #F
- ;; Or, in layman's terms, given a list of handler/description pairs
- ;; and a specific handler, find the description of that handler.
- (make-lookup
- (lambda (obj) (weak-car (Sensitivity.%weak-<interactor> obj)))))
-
-(define find-ss
- ;; (find-ss drawing-surface list-of-Surface-Sensitivity)
- ;; returns a specific Surface-Sensitivity or #F
- (make-lookup
- (lambda (x) (weak-car (Surface-Sensitivity.Weak-Surface x)))))
-
-(define (record-surface-sensitivity! surface interactor mask)
- (define (record-<interactor>-sensitivity! ss)
- (let* ((sensitivities (surface-sensitivity.sensitivities ss))
- (entry (find-sensitivity interactor sensitivities)))
- (if entry
- (set-sensitivity.masks! entry (cons mask (sensitivity.masks entry)))
- (set-surface-sensitivity.sensitivities! ss
- `(,(make-sensitivity (weak-cons interactor '()) (list mask))
- ,@sensitivities))))
- ;; Now tell the window system to set the event generation for this
- ;; particular drawing surface
- (reset-sensitivity! ss))
- (let ((sensitivity-of-surface
- (or (find-ss surface *all-sensitive-surfaces*)
- (let ((new-entry
- (make-surface-sensitivity (weak-cons surface 'ignore)
- NoEventMask '())))
- (set! *all-sensitive-surfaces*
- (cons new-entry *all-sensitive-surfaces*))
- new-entry))))
- (record-<interactor>-sensitivity! sensitivity-of-surface)))
-
-(define delete-<interactor>!
- (let ((del-sensitivity!
- (del-op! (lambda (obj)
- (weak-car (sensitivity.%weak-<interactor> obj)))))
- (del-ss! (del-op! surface-sensitivity.sensitivities)))
- (lambda (surface interactor)
- (let ((ss (find-ss surface *all-sensitive-surfaces*)))
- (if ss
- (let ((new (del-sensitivity!
- interactor
- (surface-sensitivity.sensitivities ss))))
- (if (null? new)
- (set! *all-sensitive-surfaces*
- (del-ss! surface *all-sensitive-surfaces*))
- (begin
- (set-surface-sensitivity.sensitivities! ss new)
- ;; Now tell the window system to set the event
- ;; generation for this particular drawing surface
- (reset-sensitivity! ss)))))))))
-
-;;;; Continued ...
-\f
-;;;; Support code for interactive geometry managers, continued
-
-;;; When a surface is asked to generate events, we ask the toolkit to
-;;; generate events if it is a toolkit window. Otherwise, we ask the
-;;; window system directly. WE DO NOT DO BOTH.
-;;;
-;;; This lets people create windows from Scheme which don't have
-;;; related toolkit windows, even though we haven't done that yet.
-
-(define (reset-sensitivity! surface-sensitivity)
- ;; This tells the window system to actually update the event
- ;; generation mask for a given drawing surface.
- ;; NOTE: Whoever calls this is responsible for guaranteeing that the
- ;; surface (which is weakly held) still exists.
- (let ((original (surface-sensitivity.mask surface-sensitivity)))
- (let loop ((s 0)
- (rest (surface-sensitivity.sensitivities
- surface-sensitivity)))
- (if (null? rest)
- (begin
- (set-surface-sensitivity.mask! surface-sensitivity s)
- (if (not (= s original))
- (let ((Surface
- (weak-car
- (surface-sensitivity.Weak-Surface
- surface-sensitivity))))
- (if Surface
- (let ((TKWindow (DrawingSurface.ToolKitWindow Surface))
- (UITKWindow (DrawingSurface.UITKWindow Surface)))
- (if TKWindow
- (tk-generate-Scheme-event
- s
- (ToolKitWindow.TK-Window TKWindow))
- (Generate-Events! UITKWindow s)))))))
- (loop (apply bit-or s (sensitivity.masks (car rest)))
- (cdr rest))))))
-
-(define (create-sensitive-surface UIObject handlers)
- ;; Given an object, return the Sensitive-Surface that will generate
- ;; these events.
- (let ((surface (Drawing-Surface UIObject)))
- (if (DrawingSurface? surface)
- (begin
- (record-surface-sensitivity! surface UIObject
- (if (null? handlers)
- 0
- (apply bit-or (map handler->sensitivity handlers))))
- (make-sensitive-surface surface handlers))
- (make-sensitive-surface #F handlers))))
-
-(define (change-sensitive-surface! sensitive-surface UIObject)
- ;; If the drawing surface for an object changes, remove the old
- ;; record of handlers for that object (recorded on the old drawing
- ;; surface) and enter a new record on the current drawing surface.
- (let ((surface (Drawing-Surface UIObject))
- (old-surface
- (sensitive-surface.DrawingSurface sensitive-surface)))
- (if (eq? surface old-surface)
- sensitive-surface
- (begin
- (if (DrawingSurface? old-surface)
- (destroy-sensitive-surface UIObject sensitive-surface))
- (create-sensitive-surface
- UIObject (sensitive-surface.handlers sensitive-surface))))))
-
-(define (destroy-sensitive-surface interactor sensitive-surface)
- (let ((surface
- (sensitive-surface.DrawingSurface sensitive-surface)))
- (delete-<interactor>! surface interactor)))
-
-(define (destroy-all-sensitive-surfaces-from-display display)
- (set! *all-sensitive-surfaces*
- ((list-deletor!
- (lambda (surface-sensitivity)
- (let ((surface
- (weak-car (surface-sensitivity.Weak-Surface
- surface-sensitivity))))
- (or (not surface)
- (eq? display
- (Application->display
- (ToolKitWindow.Application
- (drawingsurface.ToolKitWindow surface))))))))
- *all-sensitive-surfaces*)))
-\f
-;;;; Support for simplified user interface building. We provide a
-;;;; default application, and a procedure for adding new children to
-;;;; it.
-
-(define *the-default-application*
- (make-application "SWAT"))
-
-;;; (Swat-Open obj1 ['-title "title1"] obj2 ['-title "title2"] ...)
-;;; adds obj1, obj2, ... to the default application with the window
-;;; titled by the string specified with the -title option.
-;;; If no title option is specified, the window title will be the
-;;; title of the application
-
-(define (swat-open . objects-and-title-options)
- (apply swat-open-in-application
- *the-default-application*
- objects-and-title-options))
-
-;;; (SWAT-OPEN-IN-APPLICATION app obj1 ['-title "title1"] obj2 ['-title "title2"] ...)
-;;; is like swat-open, except for the speficifed application.
-
-(define (swat-open-in-application app . objects-and-title-options)
- (let loop ((more-to-show objects-and-title-options))
- (if (null? more-to-show)
- 'OK
- (let ((next-obj (car more-to-show))
- (after-next (if (null? (cdr more-to-show))
- #F
- (cadr more-to-show))))
- ;;look for -title following the object to show
- (if (eq? after-next '-title)
- (let ((specified-title
- (if (null? (cddr more-to-show))
- (error
- "-title option given and no title specified -- SWAT-OPEN"
- objects-and-title-options)
- (caddr more-to-show))))
- ;;if -title is there, next thing must be a string
- (if (string? specified-title)
- (add-child! app
- next-obj
- specified-title)
- (error "specified title is not a string -- SWAT-OPEN"
- specified-title))
- (loop (cdddr more-to-show)))
- ;;no -title specified -- use default naming
- (begin (add-child! app next-obj)
- (loop (cdr more-to-show))))))))
-
-(define (swat-close . objs)
- (for-each (lambda (obj) (remove-child! *the-default-application* obj))
- objs)
- 'closed)
\ No newline at end of file
+++ /dev/null
-;;; -*- Scheme -*-
-
-;;; Canvases can be scrollable: we can create them with two scrollbars,
-;;; one on the right and one on the bottom.
-
-(define (make-scrollable-canvas . options)
- (let ((canvas (apply make-canvas options))
- (vscroll (make-scrollbar '(-orient vert)))
- (hscroll (make-scrollbar '(-orient horiz))))
- (let ((v-command
- (lambda ()
- (ask-widget
- vscroll
- `(configure -command
- ,(string-append (tk-widget->pathname canvas) " yview")))))
- (h-command
- (lambda ()
- (ask-widget
- hscroll
- `(configure -command
- ,(string-append (tk-widget->pathname canvas) " xview")))))
- (c-command
- (lambda ()
- (maybe-defer
- vscroll
- (lambda ()
- (ask-widget
- canvas
- `(configure
- -xscroll
- ,(string-append (tk-widget->pathname hscroll) " set")
- -yscroll
- ,(string-append (tk-widget->pathname vscroll) " set"))))))))
- (defer canvas v-command)
- (defer canvas h-command)
- (defer hscroll c-command)
- (make-vbox (make-hbox canvas vscroll) hscroll))))
-
-(define (scrollable-canvas-canvas scrollable-canvas)
- (let ((top-row (car (box-children scrollable-canvas))))
- (car (box-children top-row))))
-
-(define (scrollable-canvas-vscroll scrollable-canvas)
- (let ((top-row (car (box-children scrollable-canvas))))
- (cadr (box-children top-row))))
-
-(define (scrollable-canvas-hscroll scrollable-canvas)
- (cadr (box-children scrollable-canvas)))
-
-
-;;; Canvas has special protect-from-gc! procedures
-
-(define (canvas-protect-from-gc! canvas stuff)
- (let ((crud (crud-that-I-dont-want-to-gc-away canvas)))
- (set-cdr! crud (cons stuff (cdr crud))))
- 'done)
-
-(define (canvas-unprotect-from-gc! canvas stuff)
- (let ((crud (crud-that-I-dont-want-to-gc-away canvas)))
- (set-cdr! crud (delq! stuff (cdr crud))))
- 'done)
-
-(define (canvas-flush-protect-list! canvas)
- (let ((crud (crud-that-I-dont-want-to-gc-away canvas)))
- (set-cdr! crud '()))
- 'done)
-
-
-;;; CanvasItem structure
-
-(define (make-canvas-item name canvas)
- (if (not (TKWidget%.handle canvas))
- (error "You must OPEN the canvas before you can make an item on it"))
- (let ((item (make-canvasitem canvasitem-ask-widget
- canvasitem-add-event-handler!
- 'invalid
- name
- canvas
- '())))
- (canvas-protect-from-gc! canvas item)
- item))
-
-(define (canvasitem-add-event-handler! item event handler substitutions)
- (let ((canvas (CanvasItem.canvas item))
- (handler (proc-with-transformed-args handler substitutions)))
- (set-canvasitem.%binding-callbacks!
- item
- (cons handler (canvasitem.%binding-callbacks item)))
- (ask-widget canvas
- `(bind
- ,(CanvasItem.name item)
- ,event
- ("SchemeCallBack" ,(hash handler *our-hash-table*)
- ,@substitutions)))))
-
-;;; The following assumes that the commands which explicitly mention
-;;; canvas items mention them only as their second argument. This is
-;;; true for most of the commands (e.g., itemconfigure, move, raise);
-;;; but select, for example, is an exception. Do we care about those,
-;;; anyway? Same is true for the <CanvasItemGroup> version.
-
-(define (canvasitem-ask-widget me arg-list)
- (let* ((name (CanvasItem.name me))
- (canvas (CanvasItem.canvas me))
- (command (car arg-list))
- (new-arg-list (cons (if (eq? command 'configure)
- 'itemconfigure
- command)
- (cons name (cdr arg-list)))))
- (let ((result (ask-widget canvas new-arg-list)))
- (if (eq? command 'delete)
- (canvas-unprotect-from-gc! canvas me))
- result)))
-
-
-;;; CanvasItemGroup structure, for grouping (tagging) canvas items together.
-
-(define (make-canvas-item-group canvas list-of-canvas-items)
- (let ((tag (tk-gen-name "CanvasItemGroup")))
- (for-each (lambda (item)
- (if (eq? canvas (CanvasItem.canvas item))
- (ask-widget item `(configure -tags ,tag))
- (error "MAKE-CANVAS-ITEM-GROUP: not a canvas item on canvas"
- canvas item)))
- list-of-canvas-items)
- (let ((CanvasItemGroup (make-CanvasItemGroup CanvasItemGroup-ask-widget
- CanvasItemGroup-add-event-handler!
- 'invalid
- tag
- canvas
- '())))
- (canvas-protect-from-gc! canvas CanvasItemGroup)
- CanvasItemGroup)))
-
-
-(define (add-to-canvas-item-group tag new-item)
- (if (eq? (CanvasItem.canvas new-item)
- (CanvasItemGroup.canvas tag))
- (ask-widget new-item `(configure -tags ,(CanvasItemGroup.tag tag)))
- (error "ADD-TO-CANVAS-ITEM-GROUP: not a canvas item on canvas"
- canvas new-item)))
-
-(define (merge-canvas-item-groups canvas destructive? . tags)
- (let ((new-tag (tk-gen-name "CanvasItemGroup")))
- (for-each
- (lambda (tag)
- (cond ((eq? (CanvasItemGroup.canvas tag) canvas)
- (let ((tk-tag (CanvasItemGroup.tag tag)))
- (ask-widget canvas `(addtag ,new-tag withtag ,tk-tag))
- ;; If destructive? is true, the old tags are
- ;; destroyed. Otherwise, they are kept. The old tags
- ;; take precedence in case of conflicting event handlers.
- (if destructive?
- (begin
- (ask-widget canvas `(dtag ,tk-tag))
- (canvas-unprotect-from-gc! canvas tag)))))
- (else
- (error "MERGE-CANVAS-ITEM-GROUPS: not a canvas tag on canvas"
- canvas tag))))
- tags)
- (let ((CanvasItemGroup (make-CanvasItemGroup CanvasItemGroup-ask-widget
- CanvasItemGroup-add-event-handler!
- 'invalid
- new-tag
- canvas
- '())))
- (canvas-protect-from-gc! canvas CanvasItemGroup)
- CanvasItemGroup)))
-
-(define (CanvasItemGroup-add-event-handler! tag event handler substitutions)
- ;; to handle tagged canvas items
- (let ((canvas (CanvasItemGroup.canvas tag))
- (handler (proc-with-transformed-args handler substitutions)))
- (set-CanvasItemGroup.%binding-callbacks!
- tag
- (cons handler (CanvasItemGroup.%binding-callbacks tag)))
- (ask-widget canvas
- `(bind
- ,(CanvasItemGroup.tag tag)
- ,event
- ("SchemeCallBack" ,(hash handler *our-hash-table*)
- ,@substitutions)))))
-
-(define (CanvasItemGroup-ask-widget tag arg-list)
- ;; to handle tagged canvas items
- (let* ((tag-name (CanvasItemGroup.tag tag))
- (canvas (CanvasItemGroup.canvas tag))
- (command (car arg-list))
- (new-arg-list (cons (if (eq? command 'configure)
- 'itemconfigure
- command)
- (cons tag-name (cdr arg-list)))))
- (let ((result (ask-widget canvas new-arg-list)))
- (if (eq? command 'delete)
- (canvas-unprotect-from-gc! canvas tag))
- result)))
-
-
-;;; This is how the user creates canvas items, e.g.
-;;; (define george (make-arc-on-canvas c 200 200 250 250))
-
-(define (make-arc-on-canvas canvas x1 y1 x2 y2 . options)
- (let ((configure-options (if (null? options) '() (car options))))
- (make-canvas-item
- (ask-widget canvas `(create arc ,x1 ,y1 ,x2 ,y2 ,@configure-options))
- canvas)))
-
-(define (make-bitmap-on-canvas canvas bitmap-filename-string x y . options)
- (if (not (file-exists? bitmap-filename-string))
- (error "MAKE-BITMAP-ON-CANVAS: Bad file name" bitmap-filename-string))
- (let ((configure-options (if (null? options) '() (car options))))
- (make-canvas-item
- (ask-widget canvas
- `(create bitmap ,x ,y
- -bitmap ,(string-append "@" bitmap-filename-string)
- ,@configure-options))
- canvas)))
-
-(define (make-line-on-canvas canvas x1 y1 x2 y2 . opt-args)
- (let loop ((opt-args opt-args) (xy-list '()) (configure-options '()))
- (if (null? opt-args)
- (if (odd? (length xy-list))
- (error "MAKE-LINE: Missing a y coordinate"
- (append (list x1 y1 x2 y2) xy-list))
- (make-canvas-item
- (ask-widget canvas `(create line ,x1 ,y1 ,x2 ,y2 ,@xy-list
- ,@configure-options))
- canvas))
- (let ((next-arg (car opt-args)))
- (if (list? next-arg)
- (loop (cdr opt-args) xy-list next-arg)
- (loop (cdr opt-args)
- (append xy-list (list next-arg))
- configure-options))))))
-
-(define (make-oval-on-canvas canvas x1 y1 x2 y2 . options)
- (let ((configure-options (if (null? options) '() (car options))))
- (make-canvas-item
- (ask-widget canvas `(create oval ,x1 ,y1 ,x2 ,y2 ,@configure-options))
- canvas)))
-
-(define (make-polygon-on-canvas canvas x1 y1 x2 y2 x3 y3 . opt-args)
- (let loop ((opt-args opt-args) (xy-list '()) (configure-options '()))
- (if (null? opt-args)
- (if (odd? (length xy-list))
- (error "MAKE-POLYGON: Missing a y coordinate"
- (append (list x1 y1 x2 y2 x3 y3) xy-list))
- (make-canvas-item
- (ask-widget canvas `(create polygon ,x1 ,y1 ,x2 ,y2 ,x3 ,y3
- ,@xy-list ,@configure-options))
- canvas))
- (let ((next-arg (car opt-args)))
- (if (list? next-arg)
- (loop (cdr opt-args) xy-list next-arg)
- (loop (cdr opt-args)
- (append xy-list (list next-arg))
- configure-options))))))
-
-(define (make-rectangle-on-canvas canvas x1 y1 x2 y2 . options)
- (let ((configure-options (if (null? options) '() (car options))))
- (make-canvas-item
- (ask-widget canvas `(create rectangle ,x1 ,y1 ,x2 ,y2 ,@configure-options))
- canvas)))
-
-(define (make-text-on-canvas canvas x y . options)
- (let ((configure-options (if (null? options) '() (car options))))
- (make-canvas-item
- (ask-widget canvas `(create text ,x ,y ,@configure-options))
- canvas)))
-
-(define (make-widget-on-canvas canvas widget x y . options)
- (let ((configure-options (if (null? options) '() (car options))))
- (add-child! canvas widget)
- (make-canvas-item
- (ask-widget
- canvas
- `(create window ,x ,y
- -window ,(lambda () (tk-widget->pathname widget))
- ,@configure-options))
- canvas)))
-
+++ /dev/null
-;;; -*-Scheme-*-
-
-#|
- (set-floating-error-mask! <fixnum>)
-
- sets the floating-point enables to the bottom 5 bits of fixnum.
- returns a fixnum with the old floating-point enables in the bottom 5 bits.
-
- Warning: This does not check the argument type.
-
- Flags: V valid operation 16
- Z zero divide 8
- O overflow 4
- U underflow 2
- I inexact 1
-
- This version is long because it compiles under both 7.4 and 8.0
-|#
-
-(declare (usual-integrations))
-
-(define-syntax deflap
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (let ((name (cadr form))
- (lap (cddr form)))
- `(DEFINE ,name
- (SCODE-EVAL ',((access lap->code
- (->environment '(COMPILER TOP-LEVEL)))
- name lap)
- SYSTEM-GLOBAL-ENVIRONMENT))))))
-
-(define set-floating-error-mask!
- (let ()
- (deflap set-floating-error-mask/8.0!
- (entry-point set-floating-error-mask/8.0!)
- (scheme-object CONSTANT-0 #F)
- (scheme-object CONSTANT-1 0)
- (external-label () #x202 (@pcr set-floating-error-mask/8.0!))
-
- (LABEL set-floating-error-mask/8.0!)
- ; arg = 2, cont = 19
- (fstws () 0 (offset 0 0 21)) ; flags to free
- (ldw () (offset 0 0 21) 6) ; flags to reg 6
- (copy () 6 7) ; copy flags to 7
- (dep () 2 31 5 7) ; arg merged with flags in 7
- (stw () 7 (offset 0 0 21)) ; new flags to free
- (dep () 6 31 5 2) ; flags merged with arg in 2
- (fldws () (offset 0 0 21) 0) ; store flags
- (bv (n) 0 19) ; return
- )
-
- (deflap set-floating-error-mask/7.4!
- (entry-point set-floating-error-mask/7.4!)
- (scheme-object CONSTANT-0 #F)
- (scheme-object CONSTANT-1 0)
- (external-label () #x202 (@pcr set-floating-error-mask/7.4!))
-
- (LABEL set-floating-error-mask/7.4!)
-
- (fstws () 0 (offset 0 0 21)) ; flags to free
- (ldw () (offset 0 0 #x16) 2) ; arg to reg 2
- (ldw () (offset 0 0 21) 6) ; flags to reg 6
- (copy () 6 7) ; copy flags to 7
- (dep () 2 31 5 7) ; arg merged with flags in 7
- (stw () 7 (offset 0 0 21)) ; new flags to free
- (dep () 6 31 5 2) ; flags merged with arg in 2
- (fldws () (offset 0 0 21) 0) ; store flags
- (ldo () (offset 4 0 #x16) #x16) ; pop arg
- (ldwm () (offset 4 0 #x16) 6) ; pop ret add
- (dep () 5 5 6 6) ; remove tag
- (bv (n) 0 6) ; return
- )
-
- (if (object-type? 0 0) ; untagged fixnums?
- set-floating-error-mask/8.0!
- set-floating-error-mask/7.4!)))
\ No newline at end of file
+++ /dev/null
-;;; -*- Scheme -*-
-
-(declare (usual-integrations))
-
-;;;; Plotting Package for Scheme Widget Application Toolkit
-
-;;; Working from the Scheme Prompt
-
-;;;(PLOTTER)
-;;; Creates a new plotter.
-;;;
-;;; Example: (define p (plotter))
-;;;
-;;;(PLOT plotter . options)
-;;; The options list sequentially describes one or more curves to be
-;;; plotted, in the following manner:
-;;;
-;;; (PLOT plotter
-;;; <function1> '<option> <value> '<option> <value> ... ;first curve
-;;; <function2> '<option> <value> ... ;second curve
-;;; ...
-;;; ...)
-;;; Returns a single curve if only one function is specified, and a
-;;; list of curves if more than one function is supplied.
-;;;
-;;; Example: (define c0 (plot p sin 'xmin -10 'xmax 5))
-;;; (define c1&2 (plot p cos 'pt-style 0 tan 'pt-style 5))
-;;;
-;;; The first parameter to PLOT after plotter must always be a
-;;; function. Curve-specific options affect only the function they
-;;; follow, and thus can and should be repeated. Any instance of a
-;;; global option after the first will be ignored.
-;;;
-;;; Global options and arguments:
-;;; 'XMIN: The minimum value of x to be displayed on the plot.
-;;; The default is 0.
-;;; 'XMAX: The maximum value of x to be displayed on the plot.
-;;; The default is 1.
-;;; 'YMIN: The minimum value of y to be displayed on the plot.
-;;; If not specified, the plot will be automatically scaled.
-;;; 'YMAX: The maximum value of y to be displayed on the plot.
-;;; If not specified, the plot will be automatically scaled.
-;;; 'AXIS-X: The value of x at which the y-axis will be drawn.
-;;; The default is 0.
-;;; 'AXIS-Y: The value of y at which the x-axis will be drawn.
-;;; The default is 0.
-;;; 'XTICKS: A list of pairs describing ticks on the x axis. The
-;;; car of each pair is the value of x at which to make
-;;; the tick. The cdr is a string to be displayed as a
-;;; label. The procedure MAKE-VALS can be used to return
-;;; a list of values for labels at regular intervals. If
-;;; not specified, only the extreme values will be labeled.
-;;; 'YTICKS: A list of pairs describing ticks on the y axis. Same
-;;; format as XTICKS. If not specified, only the extreme
-;;; values will be labeled.
-;;;
-;;; Curve-specific options and arguments
-;;; 'NUM-PTS: The number of points to be calculated for the curve.
-;;; The default is one for every 10 pixels.
-;;; 'PT-STYLE: A number representing the style in which the curve
-;;; will be drawn:
-;;; 0 -- lines to the x-axis
-;;; 1 -- large unfilled circles
-;;; 2 -- large unfilled squares
-;;; 3 -- x's
-;;; 4 -- +'s
-;;; 5 -- small filled circles
-;;; 6 -- small filled squares
-;;; 7 -- dots
-;;; 10 -- large unfilled circles with lines to the x-axis
-;;; 20 -- large unfilled squares with lines to the x-axis
-;;; 30 -- x's with lines to the x-axis
-;;; 40 -- +'s with lines to the x-axis
-;;; 50 -- small filled circles with lines to the x-axis
-;;; 60 -- small filled squares with lines to the x-axis
-;;; 100 -- lines between successive points
-;;; The default for the first curve is 0, and for all
-;;; others 100.
-;;; 'COLOR: The color of the curve, as a string or color-value.
-;;; The default for the first curve is black, and for all
-;;; others gray.
-;;; 'SHOW-VALS: A list of values of x at which to label the
-;;; corresponding value of y. The procedure
-;;; MAKE-VALS can be used to return a list of values
-;;; at regular intervals. The default is null.
-;;;
-;;;
-;;;(SET-PLOTTER-PARAMS plotter '<option> <value> ... '<option> <value>)
-;;; Options are the same as global options in PLOT. This does
-;;; basically the same thing as PLOT, but no *new* curve is drawn.
-;;; Parameters are reset and all the existing (non-cleared) curves
-;;; are redrawn. Thus, an alternative way to write the example above
-;;; is:
-;;;
-;;; Example: (set-plotter-params p 'xmin -10 'xmax 5)
-;;; (define c0 (plot p sin))
-;;;
-;;;(RESET-PLOTTER-PARAMS plotter)
-;;; Resets plotter's parameters to default params (the ones you see
-;;; when the plotter first comes up).
-;;;
-;;;
-;;;(MAKE-VALS min max spacing . centered?)
-;;; Returns a list of pairs that can be used for 'XTICKS 'YTICKS, or
-;;; 'SHOW-VALS. If centered? is #t, the ticks will be centered about
-;;; 0, with a tick at 0. Otherwise, the ticks will begin at the min
-;;; value.
-;;;
-;;; Example: (define c0 (plot p sin 'xmin -5 'xmax 5
-;;; 'xticks (make-vals -5 5 1)))
-;;;
-;;;(CHANGE-COLOR curve color)
-;;; Changes the color of the given curve and replots the curve.
-;;; Replots the curve if it's not cleared.
-;;;
-;;;(CHANGE-PT-STYLE curve pt-style)
-;;; Changes the point style of the given curve and replots the curve.
-;;; Replots the curve if it's not cleared.
-;;;
-;;;(CHANGE-NUM-PTS curve num-pts)
-;;; Changes the number of points calculated for the given curve and
-;;; replots the curve. Replots the curve if it's not cleared.
-;;;
-;;;
-;;;(CLEAR-CURVE curve)
-;;; Clears the given curve from the screen without deleting the curve
-;;; from the plotter.
-;;;
-;;;(PLOT-CURVE curve)
-;;; Replots the curve that has been cleared.
-;;;
-;;;(DELETE-CURVE curve)
-;;; Deletes the given curve from the plotter.
-;;;
-;;;(ADD-SHOW-VALS curve show-vals)
-;;; Add show-vals to a curve.
-;;;
-;;;(CLEAR-SHOW-VALS curve)
-;;; Clears all the curve's show vals, w/o deleting them from the curve.
-;;;
-;;;(DRAW-SHOW-VALS curve)
-;;; Redraws the cleared show-vals.
-;;;
-;;;(DELETE-SHOW-VALS curve)
-;;; Clears the curve's show-vals and deletes them from a curve.
-;;;
-;;;
-;;;(ADD-XTICKS plotter xticks)
-;;; Adds the specified xticks.
-;;;
-;;;(ADD-YTICKS plotter yticks)
-;;; Adds the specified yticks.
-;;;
-;;;(CLEAR-TICKS plotter)
-;;; Clears ticks from the axes of the plotter, without deleting them
-;;; from the plotter.
-;;;
-;;;(DRAW-TICKS plotter)
-;;; Redraws the cleared ticks.
-;;;
-;;;(DELETE-TICKS plotter)
-;;; Clears ticks from the axes of the plotter and deletes them from
-;;; the plotter.
-;;;
-;;;
-;;;(CLEAR-PLOTTER plotter)
-;;; Clears all plotter's curves and ticks.
-;;;
-;;;(REPLOT plotter)
-;;; Redraws all plotter's curves and ticks (including the cleared ones).
-;;;
-;;;(RESET-PLOTTER plotter)
-;;; Deletes all plotter's curves and ticks.
-
-
-\f
-;;;-------------------
-;;; Interface Monster
-;;;-------------------
-
-;;; Customizable Variables
-
-(define button-background-color "yellow")
-(define button-active-background-color "red")
-(define button-active-foreground-color "white")
-(define canvas-background-color "white")
-(define canvas-width 500)
-(define canvas-height 300)
-(define canvas-border-size 15)
-(define font "-Adobe-Helvetica-Bold-R-Normal--*-100-*")
-
-(define tick-precision 2)
-(define vals-precision 2)
-
-(define curve-max-num-pts 200)
-
-(define plotter-default-num-pts 50)
-(define plotter-default-pt-style 100)
-(define plotter-default-curve-color "black")
-(define plotter-default-xmin -5)
-(define plotter-default-xmax 5)
-(define plotter-default-ymin -1)
-(define plotter-default-ymax 1)
-(define plotter-default-axis-x 0)
-(define plotter-default-axis-y 0)
-(define plotter-default-xticks '())
-(define plotter-default-yticks '())
-
-\f
-(define (plotter)
- (let* ((plot-app (make-application "Plotter"))
- (plotter
- (make-plot-canvas canvas-width canvas-height canvas-background-color))
- (plot-canvas (plotter 'the-canvas))
- (func-button (make-button '(-text "Function")))
- (func-box #f)
- (options-menu (make-menu))
- (options-button (make-menubutton options-menu '(-text "Options")))
- (precision (add-to-menu options-menu 'command '-label "Precision"))
- (prec-box #f)
- (range (add-to-menu options-menu 'command '-label "Range"))
- (range-box #f)
- (plot-button (make-button '(-text "Plot")))
- (reset-button (make-button '(-text "Reset")))
- (button-box (make-hbox func-button options-button plot-button reset-button))
- (interface (make-vbox plot-canvas button-box)))
-
- (for-each (lambda (button)
- (ask-widget
- button
- `(configure -background ,button-background-color
- -activebackground ,button-active-background-color
- -activeforeground ,button-active-foreground-color)))
- (list func-button options-button plot-button reset-button))
-
- (for-each (lambda (button)
- (ask-widget
- button
- `(configure -background ,button-background-color
- -activebackground ,button-background-color)))
- (list range precision))
-
- (add-event-handler! plot-canvas "<Configure>" (plotter 'handle-resize))
-
- (set-callback!
- func-button
- (lambda ()
- (if (not func-box)
- (let ((new-func-box (make-func-box plot-app plotter)))
- (on-death! new-func-box 'func-dead (lambda () (set! func-box #f)))
- (set! func-box new-func-box)))))
-
- (set-callback!
- precision
- (lambda ()
- (if (not prec-box)
- (let ((new-prec-box (make-prec-box plot-app plotter)))
- (on-death! new-prec-box 'prec-dead (lambda () (set! prec-box #f)))
- (set! prec-box new-prec-box)))))
-
- (set-callback!
- range
- (lambda ()
- (if (not range-box)
- (let ((new-range-box (make-range-box plot-app plotter)))
- (on-death! new-range-box 'range-dead (lambda () (set! range-box #f)))
- (set! range-box new-range-box)))))
-
- (set-callback! plot-button (lambda () (plotter 'plot-current-func)))
- (set-callback! reset-button (lambda () (plotter 'clear-curves)))
-
- (on-death! interface 'interface-dead
- (lambda ()
- (if func-box (remove-child! plot-app func-box))
- (if range-box (remove-child! plot-app range-box))
- (if prec-box (remove-child! plot-app prec-box))))
-
- (swat-open-in-application plot-app interface)
- plotter))
-
-(define (make-func-box plot-app plotter)
- (let* ((func-entry (make-entry `(-width 40 -background ,canvas-background-color)))
- (func-ok-button
- (make-button
- `(-text "Ok" -background ,button-background-color
- -activebackground ,button-active-background-color
- -activeforeground ,button-active-foreground-color)))
- (func-box (make-hbox func-entry func-ok-button)))
- (define (function-callback)
- (let ((exp (ask-widget func-entry '(get))))
- (if (not (string-null? exp))
- ;; Of course, this could get an error while evaling; maybe
- ;; need something more clever.
- (let ((proc (eval (with-input-from-string exp read)
- user-initial-environment)))
- (if (not (procedure? proc))
- (error "Not a procedure" proc)
- ((plotter 'set-function) proc))))))
- (add-event-handler! func-entry "<KeyPress> <Return>" function-callback)
- (set-callback! func-ok-button function-callback)
- (swat-open-in-application plot-app func-box '-title "Enter a function of x")
- func-box))
-
-(define (make-prec-box plot-app plotter)
- (let* ((prec-scale
- (make-scale `(-from 0 -to ,curve-max-num-pts -orient horizontal
- -length ,(inexact->exact (* 1.5 curve-max-num-pts))
- -background ,canvas-background-color
- -sliderforeground ,button-background-color
- -activeforeground ,button-active-background-color)))
- (prec-redraw
- (make-button `(-text "Redraw Curves" -background ,button-background-color
- -activebackground ,button-active-background-color
- -activeforeground ,button-active-foreground-color)))
- (prec-box (make-vbox prec-scale prec-redraw)))
- (ask-widget prec-scale `(set ,(plotter 'default-num-pts)))
- (add-event-handler!
- prec-scale
- "<ButtonRelease-1>"
- (lambda ()
- ((plotter 'set-default-num-pts)
- (string->number (ask-widget prec-scale '(get))))))
- (set-callback! prec-redraw (lambda () (plotter 'plot-curves)))
- (swat-open-in-application plot-app prec-box '-title "Number of points:")
- prec-box))
-
-(define (make-range-box plot-app plotter)
- (let* ((range-ok-button
- (make-button `(-text "Ok" -background ,button-background-color
- -activebackground ,button-active-background-color
- -activeforeground ,button-active-foreground-color)))
- (xmin-text (make-active-variable plot-app))
- (xmax-text (make-active-variable plot-app))
- (ymin-text (make-active-variable plot-app))
- (ymax-text (make-active-variable plot-app))
- (xmin-entry (make-entry `(-textvariable ,xmin-text)))
- (xmax-entry (make-entry `(-textvariable ,xmax-text)))
- (ymin-entry (make-entry `(-textvariable ,ymin-text)))
- (ymax-entry (make-entry `(-textvariable ,ymax-text)))
- (x-label (make-label '(-text "Values of x:")))
- (xmin-label (make-label '(-text "From")))
- (xmax-label (make-label '(-text "To")))
- (y-label (make-label '(-text "Values of y:")))
- (ymin-label (make-label '(-text "From")))
- (ymax-label (make-label '(-text "To")))
- (x-box
- (make-vbox x-label
- (make-hbox xmin-label xmin-entry xmax-label xmax-entry)))
- (y-box
- (make-vbox y-label
- (make-hbox ymin-label ymin-entry ymax-label ymax-entry)))
- (range-box (make-hbox (make-vbox x-box y-box) range-ok-button)))
- (for-each (lambda (label)
- (ask-widget label `(configure -background ,canvas-background-color)))
- (list x-label xmin-label xmax-label y-label ymin-label ymax-label))
- (for-each (lambda (entry)
- ;; background color?
- (ask-widget entry `(configure -width 5)))
- (list xmin-entry xmax-entry ymin-entry ymax-entry))
- (set-callback!
- range-ok-button
- (lambda ()
- (let ((xmin (plotter 'xmin))
- (xmax (plotter 'xmax))
- (ymin (plotter 'ymin))
- (ymax (plotter 'ymax))
- (new-xmin (string->number (ask-widget xmin-entry '(get))))
- (new-xmax (string->number (ask-widget xmax-entry '(get))))
- (new-ymin (string->number (ask-widget ymin-entry '(get))))
- (new-ymax (string->number (ask-widget ymax-entry '(get)))))
- (if (not (and (eqv? xmin new-xmin)
- (eqv? xmax new-xmax)
- (eqv? ymin new-ymin)
- (eqv? ymax new-ymax)))
- (begin
- ((plotter 'set-xmin) new-xmin)
- ((plotter 'set-xmax) new-xmax)
- ((plotter 'set-ymin) new-ymin)
- ((plotter 'set-ymax) new-ymax)
- (plotter 'clear)
- (draw-axes plotter)
- (plotter 'plot-curves))))))
- (swat-open-in-application plot-app range-box '-title "Range")
- (set-active-variable! xmin-text (plotter 'xmin))
- (set-active-variable! xmax-text (plotter 'xmax))
- (set-active-variable! ymin-text (plotter 'ymin))
- (set-active-variable! ymax-text (plotter 'ymax))
- range-box))
-
-\f
-;;;-------------
-;;; The Plotter
-;;;-------------
-
-(define (make-plot-canvas hsize vsize bgrnd-color)
- (let ((default-num-pts plotter-default-num-pts)
- (default-pt-style plotter-default-pt-style)
- (default-color plotter-default-curve-color)
- (xmin plotter-default-xmin)
- (xmax plotter-default-xmax)
- (ymin plotter-default-ymin)
- (ymax plotter-default-ymax)
- (yaxis.xval plotter-default-axis-x)
- (xaxis.yval plotter-default-axis-y)
- (xticks plotter-default-xticks)
- (yticks plotter-default-yticks)
- (current-func #f)
- (current-func-curve #f)
- (curve-list '())
- (resize-flag #f))
- (let* ((the-canvas (make-canvas `(-width ,hsize -height ,vsize
- -background ,bgrnd-color)))
- (axes-tag (make-canvas-item-group the-canvas '()))
- (ticks-tag (make-canvas-item-group the-canvas '())))
- (define (plotter messg)
- (case messg
- ((hsize) hsize)
- ((vsize) vsize)
- ((the-canvas) the-canvas)
- ((curve-list) curve-list)
- ((default-num-pts) default-num-pts)
- ((set-default-num-pts)
- (lambda (new-num-pts) (set! default-num-pts new-num-pts)))
- ((default-pt-style) default-pt-style)
- ((set-default-pt-style)
- (lambda (new-pt-style) (set! default-pt-style new-pt-style)))
- ((default-color) default-color)
- ((set-default-color)
- (lambda (new-color) (set! default-color new-color)))
- ((function) current-func)
- ((set-function)
- (lambda (func)
- (set! current-func-curve #f)
- (set! current-func func)))
- ((xmin) xmin)
- ((set-xmin) (lambda (new-xmin) (set! xmin new-xmin)))
- ((xmax) xmax)
- ((set-xmax) (lambda (new-xmax) (set! xmax new-xmax)))
- ((ymin) ymin)
- ((set-ymin) (lambda (new-ymin) (set! ymin new-ymin)))
- ((ymax) ymax)
- ((set-ymax) (lambda (new-ymax) (set! ymax new-ymax)))
- ((xaxis.yval) xaxis.yval)
- ((yaxis.xval) yaxis.xval)
- ((xaxis.y)
- (let ((y-range (- ymax ymin)))
- (if (= y-range 0)
- (error "ymin and ymax are the same--MAKE-PLOT-CANVAS" ymin)
- (+ (* (exact->inexact (/ (- (* canvas-border-size 2) vsize)
- y-range))
- (- xaxis.yval ymin))
- vsize
- (- canvas-border-size)))))
- ((yaxis.x)
- (let ((x-range (- xmax xmin)))
- (if (= x-range 0)
- (error "xmin and xmax are the same--MAKE-PLOT-CANVAS" xmin)
- (+ (* (exact->inexact (/ (- hsize (* canvas-border-size 2))
- (- xmax xmin)))
- (- yaxis.xval xmin))
- canvas-border-size))))
- ((xticks) xticks)
- ((set-xticks) (lambda (new-xticks) (set! xticks new-xticks)))
- ((yticks) yticks)
- ((set-yticks) (lambda (new-yticks) (set! yticks new-yticks)))
- ((axes-tag) axes-tag)
- ((ticks-tag) ticks-tag)
- ((set-params)
- (lambda (new-xmin new-xmax new-ymin new-ymax
- new-yaxis.xval new-xaxis.yval new-xticks new-yticks)
- (set! xmin new-xmin)
- (set! xmax new-xmax)
- (set! ymin new-ymin)
- (set! ymax new-ymax)
- (set! yaxis.xval new-yaxis.xval)
- (set! xaxis.yval new-xaxis.yval)
- (set! xticks new-xticks)
- (set! yticks new-yticks)
- 'set))
- ((x:val->pix) (x:val->pix xmin xmax hsize))
- ((y:val->pix) (y:val->pix ymin ymax vsize))
- ((add-curve)
- (lambda (curve) (set! curve-list (append curve-list (list curve)))))
- ((plot-current-func)
- (if (and current-func (not current-func-curve))
- (let ((new-curve
- (make-curve plotter current-func default-pt-style
- default-num-pts default-color #f)))
- (set! current-func-curve new-curve)
- (set! curve-list (cons new-curve curve-list))
- (new-curve 'plot))))
- ((plot-curves)
- (for-each (lambda (curve)
- (if (not (curve 'cleared?))
- (curve 'plot)))
- curve-list)
- 'plotted)
- ((clear)
- (ask-widget the-canvas '(delete all))
- 'cleared)
- ((clear-curves)
- (for-each (lambda (curve) (curve 'clear)) curve-list)
- 'cleared)
- ((delete-curve)
- (lambda (curve)
- (curve 'clear)
- (set! curve-list (delq curve curve-list))
- 'deleted))
- ((delete-curves)
- (for-each (lambda (curve) (curve 'clear)) curve-list)
- (set! curve-list #f)
- 'deleted)
- ((clear-axes)
- (ask-widget axes-tag '(delete))
- 'cleared)
- ((clear-ticks)
- (ask-widget ticks-tag '(delete))
- 'cleared)
- ((delete-ticks)
- (set! xticks '())
- (set! yticks '())
- (ask-widget ticks-tag '(delete))
- 'deleted)
- ((handle-resize)
- (lambda ()
- ;; For some reason, the "<Configure>" event gets generated
- ;; twice per window resize -- so skip one of them.
- (if (not resize-flag)
- (set! resize-flag #t)
- (begin
- (set! resize-flag #f)
- (ask-widget the-canvas '(delete all))
- (let ((old-width hsize)
- (width (UITKRectangle.width
- (assigned-screen-area the-canvas)))
- (height (UITKRectangle.height
- (assigned-screen-area the-canvas))))
- (set! hsize width)
- (set! vsize height)
- (set! default-num-pts (round (* default-num-pts
- (/ width old-width))))
- (draw-axes plotter)
- (for-each
- (lambda (curve)
- (curve-scale-num-pts!
- curve (exact->inexact (/ width old-width)))
- (if (not (curve 'cleared?))
- (begin (curve 'clear)
- (curve 'plot))))
- curve-list))))))
- (else (error "Bad message--PLOTTER" messg))))
- plotter)))
-\f
-(define ((x:val->pix xmin xmax hsize) x)
- (+ (* (exact->inexact
- (/ (- hsize (* canvas-border-size 2))
- (- xmax xmin)))
- (- x xmin))
- canvas-border-size))
-
-(define ((y:val->pix ymin ymax vsize) y)
- (+ (* (exact->inexact
- (/ (- (* canvas-border-size 2) vsize)
- (- ymax ymin)))
- (- y ymin))
- vsize
- (- canvas-border-size)))
-
-(define (draw-xticks plotter)
- (let ((xticks (plotter 'xticks)))
- (if xticks
- (let ((plot-canvas (plotter 'the-canvas))
- (x:val->pix (plotter 'x:val->pix))
- (xmin (plotter 'xmin))
- (xmax (plotter 'xmax))
- (xaxis.y (plotter 'xaxis.y))
- (ticks-tag (plotter 'ticks-tag))
- (factor (expt 10 tick-precision)))
- (for-each
- (lambda (tick)
- (if (> xmax tick xmin)
- (let ((val (x:val->pix tick))
- (tag (swat:number->string
- (/ (truncate (* factor tick)) factor))))
- (add-to-canvas-item-group
- ticks-tag
- (make-line-on-canvas plot-canvas
- val (- xaxis.y 4)
- val (+ xaxis.y 4)))
- (add-to-canvas-item-group
- ticks-tag
- (make-text-on-canvas plot-canvas
- val (- xaxis.y 9)
- `(-text ,tag -font ,font))))))
- xticks))))
- 'drawn)
-
-(define (draw-yticks plotter)
- (let ((yticks (plotter 'yticks)))
- (if yticks
- (let ((plot-canvas (plotter 'the-canvas))
- (y:val->pix (plotter 'y:val->pix))
- (ymin (plotter 'ymin))
- (ymax (plotter 'ymax))
- (yaxis.x (plotter 'yaxis.x))
- (ticks-tag (plotter 'ticks-tag))
- (factor (expt 10 tick-precision)))
- (for-each
- (lambda (tick)
- (if (> ymax tick ymin)
- (let ((val (y:val->pix tick))
- (tag (swat:number->string
- (/ (truncate (* factor tick)) factor))))
- (add-to-canvas-item-group
- ticks-tag
- (make-line-on-canvas plot-canvas
- (- yaxis.x 4) val
- (+ yaxis.x 4) val))
- (add-to-canvas-item-group
- ticks-tag
- (make-text-on-canvas plot-canvas
- (+ yaxis.x 6) val
- `(-text ,tag -anchor w
- -font ,font))))))
- yticks))))
- 'drawn)
-
-(define (draw-axes plotter)
- (let* ((plot-canvas (plotter 'the-canvas))
- (hsize (plotter 'hsize))
- (vsize (plotter 'vsize))
- (xmin (plotter 'xmin))
- (xmax (plotter 'xmax))
- (ymin (plotter 'ymin))
- (ymax (plotter 'ymax))
- (xaxis.yval (plotter 'xaxis.yval))
- (yaxis.xval (plotter 'yaxis.xval))
- (xaxis.y (plotter 'xaxis.y))
- (yaxis.x (plotter 'yaxis.x))
- (axes-tag (plotter 'axes-tag))
- (trim 3)
- (x-.x trim)
- (x+.x (- hsize trim))
- (y-.y trim)
- (y+.y (- vsize trim)))
- (if (>= ymax xaxis.yval ymin)
- (begin
- (add-to-canvas-item-group
- axes-tag
- (make-line-on-canvas plot-canvas x+.x xaxis.y x-.x xaxis.y '(-arrow both)))
- (draw-xticks plotter)
- (make-text-on-canvas plot-canvas
- (- hsize trim) (- xaxis.y trim)
- `(-text ,(swat:number->string xmax) -anchor se)) ;
- (make-text-on-canvas plot-canvas
- trim (- xaxis.y trim)
- `(-text ,(swat:number->string xmin) -anchor sw))))
- (if (>= xmax yaxis.xval xmin)
- (begin
- (add-to-canvas-item-group
- axes-tag
- (make-line-on-canvas plot-canvas yaxis.x y+.y yaxis.x y-.y '(-arrow both)))
- (draw-yticks plotter)
- (let ((factor (expt 10 tick-precision)))
- (make-text-on-canvas plot-canvas
- (+ yaxis.x 8) trim
- `(-text ,(swat:number->string
- (/ (round (* ymax factor)) factor))
- -anchor nw))
- (make-text-on-canvas plot-canvas
- (+ yaxis.x 8) vsize
- `(-text ,(swat:number->string
- (/ (round (* ymin factor)) factor))
- -anchor sw)))))
- 'done))
-\f
-;;;--------
-;;; Curves
-;;;--------
-
-(define (make-curve plotter function pt-style num-pts color show-vals)
- (let* ((plot-canvas (plotter 'the-canvas))
- (curve-tag (make-canvas-item-group plot-canvas '()))
- (outline-tag (make-canvas-item-group plot-canvas '()))
- (vals-tag (make-canvas-item-group plot-canvas '()))
- (cleared? #f))
- (lambda (messg)
- (case messg
- ((plotter) plotter)
- ((num-pts) num-pts)
- ((set-num-pts) (lambda (new-num-pts) (set! num-pts new-num-pts)))
- ((show-vals) show-vals)
- ((set-show-vals) (lambda (new-vals) (set! show-vals new-vals)))
- ((cleared?) cleared?)
- ((change-pt-style)
- (lambda (new-pt-style)
- (cond ((pt-style? new-pt-style)
- (set! pt-style new-pt-style))
- (else (write-line "Not a style--MAKE-CURVE") pt-style))))
- ((change-color)
- (lambda (new-color)
- (set! color new-color)
- (if (not cleared?)
- (begin
- (ask-widget curve-tag `(configure -fill ,color))
- (ask-widget outline-tag `(configure -outline ,color))
- (ask-widget vals-tag `(configure -fill ,color))))))
- ((get-extreme-vals)
- (lambda (min max)
- (get-extreme-vals function min max num-pts)))
- ((plot)
- (graph function plotter curve-tag outline-tag pt-style num-pts color)
- (if show-vals
- (graph-vals function plotter show-vals vals-tag color))
- (set! cleared? #f)
- 'plotted)
- ((draw-vals)
- (if show-vals
- (graph-vals function plotter show-vals vals-tag color))
- 'drawn)
- ((clear-vals)
- (ask-widget vals-tag '(delete))
- 'cleared)
- ((delete-vals)
- (ask-widget vals-tag '(delete))
- (set! show-vals #f)
- 'removed)
- ((clear)
- (ask-widget curve-tag '(delete))
- (ask-widget outline-tag '(delete))
- (ask-widget vals-tag '(delete))
- (set! cleared? #t)
- 'cleared)
- (else (error "Bad message--MAKE-CURVE" messg))))))
-
-(define (get-extreme-vals function min max num-pts)
- (let* ((factor (expt 10 vals-precision))
- (first-val (function min))
- (min-val first-val)
- (max-val first-val)
- (step (exact->inexact (/ (- max min) num-pts))))
- (define (calculate x)
- (let ((val (function x)))
- (cond ((> x max)
- (list (/ (round (* min-val factor)) factor)
- (/ (round (* max-val factor)) factor)))
- ((< val min-val) (set! min-val val)
- (calculate (+ x step)))
- ((> val max-val) (set! max-val val)
- (calculate (+ x step)))
- (else (calculate (+ x step))))))
- (calculate (+ min step))))
-
-(define (pt-style? val)
- (memv val '(0 1 2 3 4 5 6 7 10 20 30 40 50 60 100)))
-
-(define (curve-scale-num-pts! curve factor)
- ((curve 'set-num-pts) (round (* (curve 'num-pts) factor))))
-
-(define (maybe-replot-curve curve)
- (if (not (curve 'cleared?))
- (begin (curve 'clear)
- (curve'plot))))
-\f
-(define (graph function plotter curve-tag outline-tag pt-style num-pts color)
- (let ((plot-canvas (plotter 'the-canvas))
- (xmin (plotter 'xmin))
- (xmax (plotter 'xmax))
- (xaxis.yval (plotter 'xaxis.yval))
- (x:val->pix (plotter 'x:val->pix))
- (y:val->pix (plotter 'y:val->pix)))
- (let ((xaxis.y (y:val->pix xaxis.yval)))
-
- (define (draw-0 x y)
- (add-to-canvas-item-group
- curve-tag (make-line-on-canvas plot-canvas x xaxis.y x y)))
- (define (draw-1 x y)
- (add-to-canvas-item-group
- outline-tag
- (make-oval-on-canvas plot-canvas (- x 3) (- y 3) (+ x 3) (+ y 3))))
- (define (draw-2 x y)
- (add-to-canvas-item-group
- outline-tag
- (make-rectangle-on-canvas plot-canvas (- x 3) (- y 3) (+ x 3) (+ y 3))))
- (define (draw-3 x y)
- (add-to-canvas-item-group
- curve-tag
- (make-line-on-canvas plot-canvas (- x 2) (- y 2) (+ x 3) (+ y 3)))
- (add-to-canvas-item-group
- curve-tag
- (make-line-on-canvas plot-canvas (+ x 2) (- y 2) (- x 2) (+ y 2))))
- (define (draw-4 x y)
- (add-to-canvas-item-group
- curve-tag (make-line-on-canvas plot-canvas x (- y 2) x (+ y 3)))
- (add-to-canvas-item-group
- curve-tag (make-line-on-canvas plot-canvas (- x 2) y (+ x 3) y)))
- (define (draw-5 x y)
- (let ((seg (make-oval-on-canvas plot-canvas
- (- x 2) (- y 2) (+ x 2) (+ y 2))))
- (add-to-canvas-item-group curve-tag seg)
- (add-to-canvas-item-group outline-tag seg)))
- (define (draw-6 x y)
- (let ((seg (make-rectangle-on-canvas plot-canvas
- (- x 2) (- y 2) (+ x 2) (+ y 2))))
- (add-to-canvas-item-group curve-tag seg)
- (add-to-canvas-item-group outline-tag seg)))
- (define (draw-7 x y)
- (add-to-canvas-item-group
- curve-tag (make-text-on-canvas plot-canvas x (- y 2) '(-text "."))))
- (define (draw-10 x y)
- (add-to-canvas-item-group
- curve-tag (make-line-on-canvas plot-canvas x xaxis.y x (+ y 3)))
- (add-to-canvas-item-group
- outline-tag (make-oval-on-canvas
- plot-canvas (- x 3) (- y 3) (+ x 3) (+ y 3))))
- (define (draw-20 x y)
- (add-to-canvas-item-group
- curve-tag (make-line-on-canvas plot-canvas x xaxis.y x (+ y 2)))
- (add-to-canvas-item-group
- outline-tag
- (make-rectangle-on-canvas plot-canvas
- (- x 3) (- y 3) (+ x 3) (+ y 3))))
- (define (draw-30 x y)
- (add-to-canvas-item-group
- curve-tag (make-line-on-canvas plot-canvas
- (- x 2) (- y 2) (+ x 3) (+ y 3)))
- (add-to-canvas-item-group
- curve-tag (make-line-on-canvas plot-canvas
- (+ x 2) (- y 2) (- x 2) (+ y 2)))
- (add-to-canvas-item-group
- curve-tag (make-line-on-canvas plot-canvas x xaxis.y x y)))
- (define (draw-40 x y)
- (add-to-canvas-item-group
- curve-tag (make-line-on-canvas plot-canvas x (- y 2) x xaxis.y))
- (add-to-canvas-item-group
- curve-tag (make-line-on-canvas plot-canvas (- x 2) y (+ x 3) y)))
- (define (draw-50 x y)
- (let ((seg1 (make-oval-on-canvas plot-canvas
- (- x 2) (- y 2) (+ x 2) (+ y 2)))
- (seg2 (make-line-on-canvas plot-canvas x xaxis.y x (+ y 2))))
- (add-to-canvas-item-group outline-tag seg1)
- (add-to-canvas-item-group curve-tag seg1)
- (add-to-canvas-item-group curve-tag seg2)))
- (define (draw-60 x y)
- (let ((seg1 (make-rectangle-on-canvas plot-canvas
- (- x 2) (- y 2) (+ x 2) (+ y 2)))
- (seg2 (make-line-on-canvas plot-canvas x xaxis.y x (+ y 2))))
- (add-to-canvas-item-group outline-tag seg1)
- (add-to-canvas-item-group curve-tag seg1)
- (add-to-canvas-item-group curve-tag seg2)))
-
- (define (draw-dispatch pt-style)
- (cond ((= pt-style 0) draw-0)
- ((= pt-style 1) draw-1)
- ((= pt-style 2) draw-2)
- ((= pt-style 3) draw-3)
- ((= pt-style 4) draw-4)
- ((= pt-style 5) draw-5)
- ((= pt-style 6) draw-6)
- ((= pt-style 7) draw-7)
- ((= pt-style 10) draw-10)
- ((= pt-style 20) draw-20)
- ((= pt-style 30) draw-30)
- ((= pt-style 40) draw-40)
- ((= pt-style 50) draw-50)
- ((= pt-style 60) draw-60)))
-
- (let* ((draw (draw-dispatch pt-style))
- (xstep (exact->inexact (/ (- xmax xmin) num-pts))))
- (define (calc-100 last-x last-y x y)
- (if (not (> x xmax))
- (let ((segment
- (make-line-on-canvas plot-canvas
- (x:val->pix last-x)
- (y:val->pix last-y)
- (x:val->pix x)
- (y:val->pix y))))
- (add-to-canvas-item-group curve-tag segment)
- (calc-100 x y (+ x xstep) (function (+ x xstep))))))
- (define (calculate x y)
- (if (not (> x xmax))
- (begin (draw (x:val->pix x) (y:val->pix y))
- (calculate (+ x xstep) (function (+ x xstep))))))
-
- (if (= pt-style 100)
- (calc-100 xmin (function xmin) (+ xmin xstep) (function (+ xmin xstep)))
- (calculate xmin (function xmin)))
- (ask-widget curve-tag `(configure -fill ,color))
- (ask-widget outline-tag `(configure -outline ,color))))))
-
-(define (graph-vals function plotter show-vals vals-tag color)
- (let ((factor (expt 10 vals-precision))
- (x:val->pix (plotter 'x:val->pix))
- (y:val->pix (plotter 'y:val->pix))
- (plot-canvas (plotter 'the-canvas)))
- (let marker ((show-vals show-vals))
- (if (not (null? show-vals))
- (let* ((x-val (car show-vals))
- (x (x:val->pix x-val))
- (y-val (function x-val))
- (y (y:val->pix y-val))
- (pos-y? (>= y-val (plotter 'xaxis.yval))))
- (add-to-canvas-item-group
- vals-tag
- (make-text-on-canvas
- plot-canvas x (if pos-y? (- y 3) (+ y 6))
- `(-text ,(swat:number->string (/ (round (* y-val factor)) factor))
- -anchor ,(if pos-y? 's 'n))))
- (add-to-canvas-item-group
- vals-tag
- (make-text-on-canvas plot-canvas x y '(-text "|")))
- (marker (cdr show-vals)))))
- (ask-widget vals-tag `(configure -fill ,color))))
-
-\f
-;;;-------------------------
-;;; Scheme-prompt Interface
-;;;-------------------------
-
-(define (plot plotter . spec-list)
- (define (package-curves arg-list)
- (let package-loop ((result (list (car arg-list)))
- (rest (cdr arg-list)))
- (cond ((null? rest) (list (reverse result)))
- ((procedure? (car rest))
- (cons (reverse result) (package-curves rest)))
- (else (package-loop (cons (car rest) result) (cdr rest))))))
- (if (not (null? spec-list))
- (let* ((curve-desc-list (package-curves spec-list))
- (old-xmin (plotter 'xmin))
- (old-xmax (plotter 'xmax))
- (old-ymin (plotter 'ymin))
- (old-ymax (plotter 'ymax))
- (old-axis-y (plotter 'xaxis.yval))
- (old-axis-x (plotter 'yaxis.xval))
- (old-xticks (plotter 'xticks))
- (old-yticks (plotter 'yticks))
- (xmin~ #f) (axis-x~ #f) (num-pts~ #f)
- (xmax~ #f) (axis-y~ #f) (pt-style~ #f)
- (ymin~ #f) (xticks~ #f) (color~ #f)
- (ymax~ #f) (yticks~ #f) (show-vals~ #f)
- (default-num-pts (plotter 'default-num-pts))
- (default-pt-style (plotter 'default-pt-style))
- (default-color (plotter 'default-color))
- (curve-list '()))
-
- (define (process-next-curve curve-desc)
- (let ((f (car curve-desc))
- (curve-options (cdr curve-desc)))
- (let curve-loop ((curve-options curve-options))
- (if (not (null? curve-options))
- (let ((option-name (car curve-options)))
- (cond ((not (symbol? option-name))
- (error "Bad option--PLOT" option-name))
- ((null? (cdr curve-options))
- (error "PLOT: No value specified for option"
- option-name))
- (else
- (let ((option-value (cadr curve-options)))
- (process-option option-name option-value)
- (curve-loop (cddr curve-options))))))))
- (make-curve plotter
- f
- (or pt-style~ default-pt-style)
- (or num-pts~ default-num-pts)
- (or color~ default-color)
- show-vals~)))
-
- (define (process-option name value)
- (case name
- ;; global options
- ((xmin) (if (not xmin~) (set! xmin~ value)))
- ((xmax) (if (not xmax~) (set! xmax~ value)))
- ((ymin) (if (not ymin~) (set! ymin~ value)))
- ((ymax) (if (not ymax~) (set! ymax~ value)))
- ((axis-x) (if (not axis-x~) (set! axis-x~ value)))
- ((axis-y) (if (not axis-y~) (set! axis-y~ value)))
- ((xticks) (if (not xticks~) (set! xticks~ value)))
- ((yticks) (if (not yticks~) (set! xticks~ value)))
- ;; curve-specific options
- ((num-pts) (set! num-pts~ value))
- ((pt-style) (set! pt-style~ value))
- ((color) (set! color~ value))
- ((show-vals) (set! show-vals~ value))
- (else (error "Illegal option--PLOT" name))))
-
- (define (reset-options!)
- (set! num-pts~ #f)
- (set! pt-style~ #f)
- (set! color~ #f)
- (set! show-vals~ #f))
-
- (let process-loop ((curve-desc-list (reverse curve-desc-list)))
- (if (not (null? curve-desc-list))
- (let ((new-curve (process-next-curve (car curve-desc-list))))
- ((plotter 'add-curve) new-curve)
- (set! curve-list (cons new-curve curve-list))
- (reset-options!)
- (process-loop (cdr curve-desc-list)))))
-
- (let* ((xmin (or xmin~ old-xmin))
- (xmax (or xmax~ old-xmax))
- (get-extremes
- (lambda (xmin xmax)
- (map (lambda (curve) ((curve 'get-extreme-vals) xmin xmax))
- curve-list)))
- (extremes #f)
- (ymin
- (or ymin~
- (min
- old-ymin
- (let ((xtremes (get-extremes xmin xmax)))
- (set! extremes xtremes)
- (apply min (cons 0 (map (lambda (e) (car e)) xtremes)))))))
- (ymax
- (or ymax~
- (max
- old-ymax
- (let ((xtremes
- (if extremes extremes (get-extremes xmin xmax))))
- (apply max (cons 0 (map (lambda (e) (cadr e)) xtremes)))))))
- (axis-y (or axis-y~ old-axis-y))
- (axis-x (or axis-x~ old-axis-x)))
-
- (if (and (= xmin old-xmin)
- (= xmax old-xmax)
- (= ymin old-ymin)
- (= ymax old-ymax)
- (= axis-x old-axis-x)
- (= axis-y old-axis-y)
- (equal? xticks~ old-xticks)
- (equal? yticks~ old-yticks))
- ;; only plot the new curves
- (for-each (lambda (new-curve) (new-curve 'plot))
- curve-list)
- ;; if a global param changed, replot everything
- (begin
- ((plotter 'set-params)
- xmin xmax ymin ymax axis-x axis-y xticks~ yticks~)
- (plotter 'clear)
- (draw-axes plotter)
- (plotter 'plot-curves)))
-
- ;; return the curve if there's only one, list of curves if more.
- (and (pair? curve-list)
- (if (= (length curve-list) 1)
- (car curve-list)
- curve-list))))))
-
-(define (set-plotter-params plotter . spec-list)
- (let ((xmin (plotter 'xmin))
- (xmax (plotter 'xmax))
- (ymin (plotter 'ymin))
- (ymax (plotter 'ymax))
- (axis-x (plotter 'yaxis.xval))
- (axis-y (plotter 'xaxis.yval))
- (xticks (plotter 'xticks))
- (yticks (plotter 'yticks)))
- (define (process-option name value)
- (case name
- ;; global options
- ((xmin) (set! xmin value))
- ((xmax) (set! xmax value))
- ((ymin) (set! ymin value))
- ((ymax) (set! ymax value))
- ((axis-x) (set! axis-x value))
- ((axis-y) (set! axis-y value))
- ((xticks) (set! xticks value))
- ((yticks) (set! xticks value))
- (else (error "Illegal option--SET-PLOTTER-PARAMS" name))))
- (let process-loop ((options spec-list))
- (if (not (null? options))
- (let ((option-name (car options)))
- (cond ((not (symbol? option-name))
- (error "Bad option--PLOT" option-name))
- ((null? (cdr options))
- (error "SET-PLOTTER-PARAMS: No value specified for option"
- option-name))
- (else
- (let ((option-value (cadr options)))
- (process-option option-name option-value)
- (process-loop (cddr options))))))))
- ((plotter 'set-params) xmin xmax ymin ymax axis-x axis-y xticks yticks)
- (plotter 'clear)
- (draw-axes plotter)
- (plotter 'plot-curves)))
-
-(define (reset-plotter-params plotter)
- (apply set-plotter-params
- (list 'xmin plotter-default-xmin
- 'xmax plotter-default-xmax
- 'ymin plotter-default-ymin
- 'ymax plotter-default-ymax
- 'axis-x plotter-default-axis-x
- 'axis-y plotter-default-axis-y
- 'xticks plotter-default-xticks
- 'yticks plotter-default-yticks)))
-
-\f
-(define (make-vals min max spacing . center?)
- (let ((min (if center? (* spacing (round (/ min spacing))) min)))
- (define (tick-maker val)
- (if (> val max)
- '()
- (cons val (tick-maker (+ val spacing)))))
- (tick-maker min)))
-
-
-(define (change-color curve color)
- ((curve 'change-color) color))
-
-(define (change-pt-style curve pt-style)
- ((curve 'change-pt-style) pt-style)
- (maybe-replot-curve curve))
-
-(define (change-num-pts curve num-pts)
- ((curve 'set-num-pts) num-pts)
- (maybe-replot-curve curve))
-
-(define (clear-curve curve)
- (curve 'clear))
-
-(define (plot-curve curve)
- (if (curve 'cleared?)
- (curve 'plot)))
-
-(define (delete-curve curve)
- (((curve 'plotter) 'delete-curve) curve))
-
-(define (add-show-vals curve show-vals)
- (curve 'clear-vals)
- ((curve 'set-show-vals)
- (append (curve 'show-vals) show-vals))
- (curve 'draw-vals))
-
-(define (clear-show-vals curve)
- (curve 'clear-vals))
-
-(define (draw-show-vals curve)
- (curve 'draw-vals))
-
-(define (delete-show-vals curve)
- (curve 'delete-vals))
-
-
-(define (add-xticks plotter xticks)
- ((plotter 'set-xticks)
- (append (plotter 'xticks) xticks))
- (plotter 'clear-axes)
- (draw-axes plotter))
-
-(define (add-yticks plotter yticks)
- ((plotter 'set-yticks)
- (append (plotter 'xticks) yticks))
- (plotter 'clear-axes)
- (draw-axes plotter))
-
-(define (clear-ticks plotter)
- (plotter 'clear-ticks))
-
-(define (draw-ticks plotter)
- (draw-xticks plotter)
- (draw-yticks plotter))
-
-(define (delete-ticks plotter)
- (plotter 'delete-ticks))
-
-(define (clear-plotter plotter)
- (plotter 'clear-curves)
- (plotter 'clear-ticks))
-
-(define (replot plotter)
- (draw-ticks plotter)
- (for-each plot-curve (plotter 'curve-list))
- 'replotted)
-
-(define (reset-plotter plotter)
- (plotter 'delete-curves)
- (plotter 'delete-ticks)
- (plotter 'clear)
- (draw-axes plotter)
- 'reset)
-
+++ /dev/null
-;;; -*- Scheme -*-
-
-(define-integrable (uiobjinternals uiobj)
- (vector-ref uiobj uiobjinternals-index))
-
-;;; Generic operations:
-;;; ADD-CHILD!, REMOVE-CHILD!, SET-CONTEXT!, ASSIGN-SCREEN-AREA!,
-;;; ASSIGN-DRAWING-SURFACE!, HANDLE-EVENT,
-;;; GET-DESIRED-SIZE, GET-DESIRED-SIZE, EVENT-WITHIN?
-
-(define (add-child! object child . others)
- (if (null? others)
- ((UIObjInternals.Add-Child!-Procedure (uiobjinternals object))
- object
- child)
- (apply
- (UIObjInternals.Add-Child!-Procedure (uiobjinternals object))
- object child others)))
-
-(define (REMOVE-CHILD! Object Child)
- ((UIObjInternals.Remove-Child!-Procedure (uiobjinternals object))
- Object
- child))
-
-(define (SET-CONTEXT! Object Context)
- ((UIObjInternals.Set-Context!-Procedure (uiobjinternals object))
- Object Context))
-
-(define (ASSIGN-SCREEN-AREA! Object Screen-area)
- ((UIObjInternals.Assign-Screen-Area!-Procedure (uiobjinternals object))
- Object Screen-Area))
-
-(define (weak-delq! item items)
- ;; Cleans out #F entries in the list as it goes
- (let loop ((previous #F)
- (items* items))
- (cond ((weak-pair? items*)
- (if (or (null? (weak-car items*))
- (eq? (weak-car items*) item))
- (begin
- (if previous
- (weak-set-cdr! previous (weak-cdr items*))
- (set! items (weak-cdr items*)))
- (loop previous (weak-cdr items*)))
- (loop items* (weak-cdr items*))))
- ((null? items*) items)
- (else
- (error:wrong-type-argument items "weak pair" 'weak-delq!)))))
-
-(define (ASSIGN-DRAWING-SURFACE! Object Surface)
- (let ((old (drawing-surface object)))
- ((UIObjInternals.Assign-Drawing-Surface!-Procedure (uiobjinternals object))
- Object Surface)
- (if (eq? Surface 'RETRACTED)
- (begin
- (set-assigned-screen-area! Object #F)
- (set-used-screen-area! Object #F)))
- (if (not (eq? old Surface))
- (begin
- (if (DrawingSurface? old)
- (set-DrawingSurface.Weak-List-of-Widgets!
- old
- (weak-delq! object (DrawingSurface.Weak-List-of-Widgets old))))
- (if (DrawingSurface? Surface)
- (set-DrawingSurface.Weak-List-of-Widgets!
- Surface (weak-cons object
- (DrawingSurface.Weak-List-of-Widgets
- Surface))))))
- 'OK))
-
-(define (POINT-WITHIN? Object Point)
- ((UIObjInternals.Point-Within?-Procedure (uiobjinternals object))
- Object Point))
-
-(define (RECTANGLE-OVERLAPS? Object Point Width Height)
- ((UIObjInternals.Rectangle-Overlaps?-Procedure (uiobjinternals object))
- Object Point Width Height))
-
-(define (HANDLE-EVENT Object Event)
- ((UIObjInternals.Handle-Event-Procedure (uiobjinternals object))
- Object Event))
-
-(define (GET-DESIRED-SIZE Object)
- ((UIObjInternals.Get-Desired-Size-Procedure (uiobjinternals object))
- Object))
-
-(define (ASSIGNED-SCREEN-AREA Object)
- ((UIObjInternals.ASSIGNED-SCREEN-AREA-Procedure (uiobjinternals object))
- Object))
-
-(define (USED-SCREEN-AREA Object)
- ((UIObjInternals.Used-SCREEN-AREA-Procedure (uiobjinternals object))
- Object))
-
-(define (SET-ASSIGNED-SCREEN-AREA! Object Screen-area)
- ((UIObjInternals.Set-ASSIGNED-SCREEN-AREA!-Procedure (uiobjinternals object))
- Object Screen-area))
-
-(define (SET-USED-SCREEN-AREA! Object Screen-area)
- ((UIObjInternals.Set-Used-SCREEN-AREA!-Procedure (uiobjinternals object))
- Object Screen-Area))
-
-(define (ASSIGN-GLUE! Object)
- ((UIObjInternals.Assign-Glue!-Procedure (uiobjinternals object))
- Object))
-
-
-(define (%geometry-alerts UIObj)
- (UIObjInternals.%geometry-alerts (UIObjInternals UIObj)))
-
-(define (set-%geometry-alerts! UIObj new-value)
- (set-UIObjInternals.%geometry-alerts! (UIObjInternals UIObj)
- new-value))
-
-(define (%event-alerts UIObj)
- (UIObjInternals.%event-alerts (UIObjInternals UIObj)))
-
-(define (set-%event-alerts! UIObj new-value)
- (set-UIObjInternals.%event-alerts! (UIObjInternals UIObj)
- new-value))
-
-(define (%context-alerts UIObj)
- (UIObjInternals.%context-alerts (UIObjInternals UIObj)))
-
-(define (set-%context-alerts! UIObj new-value)
- (set-UIObjInternals.%context-alerts! (UIObjInternals UIObj)
- new-value))
-
-(define (%death-alerts UIObj)
- (UIObjInternals.%death-alerts (UIObjInternals UIObj)))
-
-(define (set-%death-alerts! UIObj new-value)
- (set-UIObjInternals.%death-alerts! (UIObjInternals UIObj)
- new-value))
-
-(define (clip-region UIObj)
- (UIObjInternals.clip-region (UIObjInternals UIObj)))
-
-(define (set-clip-region! UIObj new-value)
- (set-UIObjInternals.clip-region! (UIObjInternals UIObj)
- new-value))
-
-(define (drawing-surface UIObj)
- (UIObjInternals.drawing-surface (UIObjInternals UIObj)))
-
-(define (set-drawing-surface! UIObj new-value)
- (set-UIObjInternals.drawing-surface! (UIObjInternals UIObj)
- new-value))
-
-(define (%desired-size UIObj)
- (UIObjInternals.%desired-size (UIObjInternals UIObj)))
-
-(define (set-%desired-size! UIObj new-value)
- (set-UIObjInternals.%desired-size! (UIObjInternals UIObj)
- new-value))
-
-(define (%vglue UIObj)
- (UIObjInternals.%vglue (UIObjInternals UIObj)))
-
-(define (set-%vglue! UIObj new-value)
- (set-UIObjInternals.%vglue! (UIObjInternals UIObj) new-value))
-
-(define (%hglue UIObj)
- (UIObjInternals.%hglue (UIObjInternals UIObj)))
-
-(define (set-%hglue! UIObj new-value)
- (set-UIObjInternals.%hglue! (UIObjInternals UIObj) new-value))
-
-(define (crud-that-I-dont-want-to-gc-away UIObj)
- (UIObjInternals.crud-that-I-dont-want-to-gc-away (UIObjInternals UIObj)))
-
-(define (set-crud-that-I-dont-want-to-gc-away! UIObj new-value)
- (set-UIObjInternals.crud-that-I-dont-want-to-gc-away!
- (UIObjInternals UIObj) new-value))
-
-
-;;; procedures that are generic over CanvasItem, CanvasItemGroup, MenuItem,
-;;; TextTag, and TKWidget
-
-(define (valid-non-widget? obj)
- (or (CanvasItem? obj)
- (CanvasItemGroup? obj)
- (MenuItem? obj)
- (TextTag? obj)))
-
-(define (ASK-WIDGET Object Command)
- (cond ((TkWidget%? Object)
- ((TKwidget%.ask-widget-procedure Object) Object Command))
- ((valid-non-widget? Object)
- ((vector-ref object ask-widget-procedure-index) object command))
- (else (error "ASK-WIDGET: Not a valid Tk widget" Object))))
-
-(define (ADD-EVENT-HANDLER! Object Event-type Handler . Substitutions)
- (cond ((TkWidget%? Object)
- ((TKwidget%.add-event-handler!-procedure Object)
- Object Event-type Handler substitutions))
- ((valid-non-widget? Object)
- ((vector-ref object add-event-handler!-procedure-index)
- Object Event-type Handler substitutions))
- (else (error "ADD-EVENT-HANDLER!: Can't add an event handler to" Object))))
-
-;;; set-callback! is also generic over active variables
-
-(define (SET-CALLBACK! Object Callback)
- (cond ((TkWidget%? Object)
- ((TKWidget%.set-callback!-procedure Object) Object Callback))
- ((TK-variable? Object)
- (set-active-variable-callback! Object Callback))
- ((valid-non-widget? Object)
- ((vector-ref object set-callback!-procedure-index) Object Callback))
- (else (error "SET-CALLBACK!: Can't set a callback for" Object))))
-
-
-
+++ /dev/null
-;;;;; -*- Scheme -*-
-;;;;;
-;;;;; derived from geometry.sc,v 1.1 1993/02/16 14:04:09 jmiller Exp $
-
-;; The box makers - one for horizontal, one for vertical
-
-(define (make-hbox . kids)
- (make-box h-size h-arrange h-get-hglue h-get-vglue kids))
-
-(define (make-vbox . kids)
- (make-box v-size v-arrange v-get-hglue v-get-vglue kids))
-
-;; user-level accessor
-(define (box-children box)
- (cond ((box%? box)
- (box%.kids box))
- ((arraybox%? box)
- (arraybox%.kids-lists box))
- (else (error "not a box -- BOX-CHILDREN" box))))
-
-;; Vertical sizer
-
-(define (v-size kids)
- (make-size
- (apply max (cons 0
- (map (lambda (kid)
- (Size.Width (get-desired-size kid)))
- kids)))
- (apply + (map (lambda (kid)
- (Size.Height (get-desired-size kid)))
- kids))))
-
-;; Horizontal sizer
-
-(define (h-size kids)
- (make-size
- (apply + (map (lambda (kid)
- (Size.Width (get-desired-size kid)))
- kids))
- (apply max (cons 0
- (map (lambda (kid)
- (Size.Height (get-desired-size kid)))
- kids)))))
-
-;; Vertical arranger
-
-(define (v-arrange kids my-screen-area)
- (let* ((my-height (UITKRectangle.Height my-screen-area))
- (full-width (UITKRectangle.Width my-screen-area))
- (my-offset (UITKRectangle.Offset my-screen-area))
- (Y (point.Y my-offset))
- (vglues (map %vglue kids)))
- (conquer-space
- my-height
- vglues
- (lambda (positions-vector)
- (let loop ((n 0) (rest kids))
- (if (null? rest)
- #F
- (let* ((kid (car rest))
- (kid-y-offset (vector-ref positions-vector n))
- (height (- (vector-ref positions-vector (+ n 1))
- kid-y-offset))
- (desired-size (get-desired-size kid))
- (desired-width (Size.Width Desired-Size))
- (hglue (%hglue kid))
- (width (cond ((or (fil-glue? hglue)
- (fill-glue? hglue))
- full-width)
- ((rigid-glue? hglue) desired-width)
- ;;((percent-glue? hglue)
- ;;(max desired-width
- ;;(inexact->exact
- ;;(ceiling (* .01 (glue.value hglue) height)))))
- (else (error "Unknown glue class"
- (glue.class hglue)))))
- (X (+ (Point.X my-offset)
- (ceiling
- (/ (- (UITKRectangle.Width my-screen-area) width)
- 2)))))
- (assign-screen-area!
- kid
- (make-UITKRectangle (make-point X (+ Y kid-y-offset))
- (make-size width height)))
- (loop (+ n 1) (cdr rest)))))))))
-
-
-;; Horizontal arranger
-
-(define (h-arrange kids my-screen-area)
- (let* ((my-width (UITKRectangle.Width my-screen-area))
- (full-height (UITKRectangle.Height my-screen-area))
- (my-offset (UITKRectangle.Offset my-screen-area))
- (X (point.X my-offset))
- (hglues (map %hglue kids)))
- (conquer-space
- my-width
- hglues
- (lambda (positions-vector)
- (let loop ((n 0) (rest kids))
- (if (null? rest)
- #F
- (let* ((kid (car rest))
- (kid-x-offset (vector-ref positions-vector n))
- (width (- (vector-ref positions-vector (+ n 1))
- kid-x-offset))
- (desired-size (get-desired-size kid))
- (desired-height (Size.Height Desired-Size))
- (vglue (%vglue kid))
- (height (cond ((or (fil-glue? vglue)
- (fill-glue? vglue))
- full-height)
- ((rigid-glue? vglue) desired-height)
- ;;((percent-glue? vglue)
- ;;(max desired-height
- ;;(inexact->exact
- ;;(ceiling (* .01 (glue.value vglue) width)))))
- (else (error "Unknown glue class"
- (glue.class vglue)))))
- (Y (+ (Point.Y my-offset)
- (ceiling
- (/ (- (UITKRectangle.Height my-screen-area) height)
- 2)))))
- (assign-screen-area!
- kid
- (make-UITKRectangle (make-point (+ X kid-x-offset) Y)
- (make-size width height)))
- (loop (+ n 1) (cdr rest)))))))))
-
-
-;;; Calculate hglue and vglue for hboxes...
-
-(define (h-get-hglue kids)
- (series-compose-glues (map %hglue kids)))
-
-(define (h-get-vglue kids)
- (parallel-compose-glues (map %vglue kids)))
-
-;;; ... and vboxes.
-
-(define (v-get-hglue kids)
- (parallel-compose-glues (map %hglue kids)))
-
-(define (v-get-vglue kids)
- (series-compose-glues (map %vglue kids)))
-
-
-;; Generic arranger
-
-(define (retract-area objects)
- (for-each (lambda (obj) (assign-screen-area! obj #F))
- objects))
-
-(define (box-add-child! me kid)
- (if (not (valid-child? kid))
- (error "BOX-ADD-CHILD!: Bad UIObj" kid))
- (one-parent-only! kid me)
- (set-Box%.kids! me (append (Box%.kids me) (list kid)))
- (on-geometry-change!
- kid 'BOX
- (lambda (old-screen-area new-screen-area)
- old-screen-area ; Not used
- (if (eq? new-screen-area #T) ; Instigated by child, not manager
- (box:rearrange me))))
- (on-death! kid 'BOX (lambda () (box-remove-child! me kid)))
- (assign-drawing-surface! kid (drawing-surface me))
- (box:rearrange me))
-
-(define (box-remove-child! me kid)
- (if (not (valid-child? kid))
- (error "BOX-REMOVE-CHILD!: Bad UIObj" kid))
- (set-Box%.kids! me (delq! kid (Box%.kids me)))
- (forget! kid 'BOX)
- (assign-drawing-surface! kid 'RETRACTED)
- (box:rearrange me))
-
-(define (box-assign-drawing-surface! me surface)
- (check-drawing-surface! me surface)
- (for-each (lambda (kid)
- (if (eq? surface 'RETRACTED)
- (forget! kid 'BOX))
- (assign-drawing-surface! kid surface))
- (Box%.kids me))
- (if (DrawingSurface? surface)
- (set-%desired-size! me ((Box%.sizer me) (Box%.kids me))))
- (if (eq? Surface 'RETRACTED)
- (death! me)
- (geometry-change! me #F #F))
- 'OK)
-
-(define (box-assign-screen-area! me screen-area)
- (cond ((vector? screen-area)
- (set-assigned-screen-area! me screen-area)
- (let ((old (used-screen-area me)))
- (if (not (screen-area= old screen-area))
- (begin
- (set-used-screen-area! me screen-area)
- (box:rearrange me)
- (geometry-change! me old screen-area))))
- screen-area)
- ((not screen-area)
- (set-assigned-screen-area! me screen-area)
- (let ((old (used-screen-area me)))
- (if (not (screen-area= old screen-area))
- (begin
- (set-used-screen-area! me screen-area)
- (retract-area (Box%.kids me))
- (geometry-change! me old screen-area))))
- screen-area)
- (else
- (error "BOX-ASSIGN-SCREEN-AREA!: Bad screen-area" screen-area))))
-
-(define (box-assign-glue! me)
- (let ((kids (Box%.kids me)))
- (for-each assign-glue! kids)
- (set-%hglue! me ((Box%.get-hglue me) kids))
- (set-%vglue! me ((Box%.get-vglue me) kids))))
-
-;; Box Maker
-(define (box-maker size-proc screen-area-proc get-hglue get-vglue)
- (make-Box%
- (make-UIObjInternals box-add-child!
- 'invalid
- UIObj-set-context!
- box-assign-screen-area!
- box-assign-drawing-surface!
- UIObj-point-within?
- UIObj-rectangle-overlaps?
- UIObj-handle-event
- UIObj-get-desired-size
- UIObj-assigned-screen-area
- UIObj-used-screen-area
- UIObj-set-assigned-screen-area!
- UIObj-set-used-screen-area!
- box-assign-glue!)
- size-proc
- screen-area-proc
- get-hglue
- get-vglue))
-
-(define (box:rearrange me)
- (let ((screen-area (used-screen-area me))
- (arrange (Box%.arranger me))
- (size (Box%.sizer me))
- (kids (Box%.kids me)))
- (if screen-area
- (let ((new-size (size kids)))
- (set-%desired-size! me new-size)
- (if (size= new-size (UITKRectangle.Size screen-area))
- (begin (assign-glue! me)
- (arrange kids screen-area))
- (begin
- (set-%desired-size! me new-size)
- (geometry-change! me screen-area #T)
- (if (eq? screen-area (used-screen-area me))
- (begin (assign-glue! me)
- (arrange kids screen-area)))))))))
-
-(define (box:event-propagator box)
- (lambda (event)
- (for-each (lambda (kid)
- (if (event-within? kid event)
- (handle-event kid event)))
- (Box%.kids box))))
-
-
-(define (make-box size-proc screen-area-proc get-hglue get-vglue children)
- (let ((me (box-maker size-proc screen-area-proc get-hglue get-vglue)))
- (on-event! me 'BOX
- (box:event-propagator me))
- (for-each (lambda (kid) (add-child! me kid)) children)
- me))
-
-;;; Glue Mechanism snarfed from Halstead
-
-;;; Glue abstraction, captures a minimum size (horizontal or vertical,
-;;; depending on usage) below which the object really ought not to shrink.
-;;; Also specifies a stretchability value (glue-value) and a stretchability
-;;; class (glue-class). Space is divided between two series-composed
-;;; glues as follows:
-;;;
-;;; 1. If the total is less than the sum of the glues' minimum sizes
-;;; then divide the space in proportion to the minimum sizes (everybody
-;;; has to give up the same percentage of their minimum size).
-;;;
-;;; 2. Else, if both glues have the same glue-class, then divide the excess
-;;; of available space (over the sum of their minimum sizes)
-;;; in proportion to their glue-values.
-;;;
-;;; 3. If the glue-classes differ, then the glue with the smaller glue-class
-;;; gets its minimum size, and the glue with the larger glue-class gets
-;;; all the rest (thus glue of a given glue-class is "infinitely" more
-;;; stretchable than any glue from a lower glue-class -- this is useful
-;;; for filling out to a boundary without stretching the item before the
-;;; fill).
-
-;;; Conventional glue classes:
-
-(define *rigid-glue-class* -1) ; for things that really don't want to stretch
-(define *percent-glue-class* 0) ; for proportionally allocating space
-(define *fill-glue-class* 1) ; for things intended to be infinitely stretchable
-(define *fil-glue-class* 2) ; even stretchier!
-
-(define (make-rigid-glue minsize value)
- (make-glue minsize *rigid-glue-class* value))
-
-(define (make-percent-glue minsize percent)
- (make-glue minsize *percent-glue-class* percent))
-
-(define (make-fill-glue minsize value)
- (make-glue minsize *fill-glue-class* value))
-
-(define (make-fil-glue minsize value)
- (make-glue minsize *fil-glue-class* value))
-
-(define (rigid-glue? glue)
- (= (glue.class glue) *rigid-glue-class*))
-
-(define (percent-glue? glue)
- (= (glue.class glue) *percent-glue-class*))
-
-(define (fill-glue? glue)
- (= (glue.class glue) *fill-glue-class*))
-
-(define (fil-glue? glue)
- (= (glue.class glue) *fil-glue-class*))
-
-(define *fil-glue* (make-fil-glue 0 1))
-(define *rigid-glue* (make-rigid-glue 0 1))
-
-
-;;; Compose two glues laid end-to-end -- sum their minimum sizes
-;;; and their glue values (which implies that if the glue-classes
-;;; differ, then the resulting glue-class and glue-value are those
-;;; of the input glue with the larger glue-class).
-
-(define (series-compose-glue g1 g2)
- (let ((c1 (glue.class g1))
- (c2 (glue.class g2)))
- (if (< c2 c1)
- (series-compose-glue g2 g1)
- (make-glue (+ (glue.minsize g1) (glue.minsize g2))
- c2
- (if (= c1 c2)
- (+ (glue.value g1) (glue.value g2))
- (glue.value g2))))))
-
-;;; Compose two glues laid in parallel -- use the max of their
-;;; minimum sizes and the min of their stretchabilities (which
-;;; implies using the stretchability of the glue with the smaller
-;;; glue-class, or the smaller glue-value if the glue-classes are
-;;; equal).
-
-(define (parallel-compose-glue g1 g2)
- (let ((c1 (glue.class g1))
- (c2 (glue.class g2)))
- (if (< c2 c1)
- (parallel-compose-glue g2 g1)
- (make-glue (max (glue.minsize g1) (glue.minsize g2))
- c1
- (if (= c1 c2)
- (min (glue.value g1) (glue.value g2))
- (glue.value g1))))))
-
-;;; Support > 2 glues as arguments
-
-(define (compose-glues fcn list-of-glues)
- ;; If there's no glue at all, make it be fil glue.
- (if (null? list-of-glues)
- *fil-glue*
- (let loop ((cumulative-glue (car list-of-glues))
- (rest (cdr list-of-glues)))
- (if (null? rest)
- cumulative-glue
- (let ((next-glue (car rest)))
- (loop (fcn cumulative-glue next-glue)
- (cdr rest)))))))
-
-(define (series-compose-glues list-of-glues)
- (compose-glues series-compose-glue list-of-glues))
-
-(define (parallel-compose-glues list-of-glues)
- (compose-glues parallel-compose-glue list-of-glues))
-
-
-;;; Choose the less restrictive (in terms of minimum size) of two
-;;; glues. This procedure is used for implementing the "orbox" combiner:
-
-(define (choose-minimum-glue list-of-glues)
- (define (min-glue g1 g2)
- (let ((min1 (glue.minsize g1))
- (min2 (glue.minsize g2)))
- (cond ((< min1 min2) g1)
- ((> min1 min2) g2)
- (else g1)))) ; arbitrary choice
- (let ((g1 (car list-of-glues)))
- (let loop ((list-of-glues list-of-glues) (g g1))
- (if (null? (cdr list-of-glues))
- (min-glue g (car list-of-glues))
- (let* ((next-glue (car list-of-glues)))
- (loop (cdr list-of-glues) (min-glue g next-glue)))))))
-
-(define (choose-maximum-glue list-of-glues)
- (define (max-glue g1 g2)
- (let ((max1 (glue.minsize g1))
- (max2 (glue.minsize g2)))
- (cond ((< max1 max2) g2)
- ((> max1 max2) g1)
- (else g1)))) ; arbitrary choice
- (let ((g1 (car list-of-glues)))
- (let loop ((list-of-glues list-of-glues) (g g1))
- (if (null? list-of-glues)
- g
- (let* ((next-glue (car list-of-glues)))
- (loop (cdr list-of-glues) (max-glue g next-glue)))))))
-
-#|
-;;; Magnify the minsize and stretchability of a glue by a factor:
-
-(define (magnify-glue g factor)
- (make-glue (* factor (glue.minsize g))
- (glue.class g)
- (* factor (glue.value g))))
-
-;;; Decide whether the given glue fits happily into the given space:
-
-(define (glue-fits-space? g space)
- (<= (glue.minsize g) space))
-|#
-
-;;; Divide a given amount of space between two glues, according to the
-;;; rules given above. Returns the amounts of space allocated to the
-;;; two glues to the continuation k.
-
-(define (divide-space space g1 g2 k)
- (let ((m1 (glue.minsize g1))
- (m2 (glue.minsize g2)))
- (let ((msum (+ m1 m2)))
- (if (and (<= space msum) (> msum 0))
- (let ((x1 (inexact->exact
- (floor
- (quotient (+ (* 2 m1 space) msum)
- (* 2 msum)))))) ; round off space allocation
- (k x1 (- space x1)))
- (let ((c1 (glue.class g1))
- (c2 (glue.class g2)))
- (cond ((< c1 c2) (k m1 (- space m1)))
- ((> c1 c2) (k (- space m2) m2))
- (else (let ((v1 (glue.value g1))
- (v2 (glue.value g2)))
- (let ((vsum (+ v1 v2)))
- (let ((x1 (+ m1
- (inexact->exact
- (floor
- (quotient
- (+ (* 2 v1 (- space msum))
- vsum)
- (* 2 vsum)))))))
- (k x1 (- space x1))))))))))))
-
-
-;;; Given a space (width or height), a list of glues (assuming the
-;;; order of glues provided is left to right), and a receiver, divides
-;;; the space between the glues according to their properties.
-;;; Receiver is applied to the resulting vector of positions which are
-;;; offsets into the space.
-
-(define (conquer-space space list-of-glues receiver)
- (let* ((num-glues (length list-of-glues))
- (glues (list->vector list-of-glues))
- (cum-glues (compute-cumulative-glues list-of-glues))
- (positions-vector (make-vector (+ num-glues 1))))
- (let loop ((s space) (n (- num-glues 1)))
- (vector-set! positions-vector (+ n 1) s)
- (if (> n 0)
- (divide-space
- s (vector-ref cum-glues (- n 1)) (vector-ref glues n)
- (lambda (s1 s2)
- s2 ; ignore
- (loop s1 (- n 1))))))
- (vector-set! positions-vector 0 0)
- (receiver positions-vector)))
-
-
-;;; Given a list of glues, returns a vector of cumulative glues --
-;;; glues obtained by series composition of g1, g1&g2, (g1&g2)&g3, and
-;;; so on. For example,
-;;;
-;;; (compute-cumulative-glues (list g1 g2 g3)) is equivalent to:
-;;;
-;;; (let* ((g12 (series-compose-glue g1 g2))
-;;; (g123 (series-compose-glue g12 g3)))
-;;; `#(,g1 ,g12 ,g123))
-
-(define (compute-cumulative-glues list-of-glues)
- ;; If there's no glue at all, make it be fil glue.
- (if (null? list-of-glues)
- *fil-glue*
- (let* ((num-glues (length list-of-glues))
- (cum-glues (make-vector num-glues))
- (g1 (car list-of-glues)))
- (vector-set! cum-glues 0 g1)
- (let loop ((n 1) (old-glue g1) (glues (cdr list-of-glues)))
- (if (= n num-glues)
- cum-glues
- (let* ((g (car glues))
- (new-glue (series-compose-glue old-glue g)))
- (vector-set! cum-glues n new-glue)
- (loop (+ n 1) new-glue (cdr glues))))))))
-
-
-;;; A space is basically a "piece of glue." It is of class fil, so it
-;;; is very stretchable (more so than anything else). It can be used
-;;; to fill in spaces between widgets in a box.
-;;; This would probably be better off if implemented as a shape
-;;; instead of a canvas, but for now (till shapes are working
-;;; right)...
-
-(define (make-space . options)
- (let* ((configure-options (if options (car options) '()))
- (space (make-canvas `(-width 0 -height 0 ,@configure-options))))
- (set-%hglue! space *fil-glue*)
- (set-%vglue! space *fil-glue*)
- space))
-
-
-
-;;; Build a tabular array of boxes. Each argument is a list of kids that
-;;; are to be arranged left-to-right, in hbox fashion. These rows of boxes
-;;; are in turn stacked vertically, in vbox fashion; however, the sizes of
-;;; the boxes in different rows interact so that columns, as well as rows,
-;;; of boxes are kept aligned. Thus (array-box '(A B C) '(D E F) '(G H J))
-;;; will generate the following arrangement of kids A-J:
-;;;
-;;; A B C
-;;;
-;;; D E F
-;;;
-;;; G H J
-;;;
-;;; regardless of the individual sizes of the component boxes. Instead of
-;;; boxes, the following symbols may also appear as elements of an argument:
-;;;
-;;; skip -- indicates the corresponding cell is to be left empty.
-;;; left -- indicates the box to the left spans into this cell as well.
-;;; up -- indicates the box above spans into this cell as well.
-;;;
-;;; If the argument lists are not all of the same length, they are considered
-;;; to be padded out at the end with as many occurrences of the symbol "left"
-;;; as needed to make their lengths all equal.
-
-(define (kids-lists->complete-kids-lists kids-lists)
- (let ((num-cols (apply max (map length kids-lists))))
- (define (kids-list->complete-kids-list kids-list)
- (let loop ((col 0) (complete-kids-list '()) (rest-kids kids-list))
- (if (= col num-cols)
- complete-kids-list
- (let* ((next-kid
- (if (null? rest-kids)
- 'left
- (car rest-kids)))
- (rest-kids
- (if (null? rest-kids)
- '()
- (cdr rest-kids)))
- (next-complete-list
- (append complete-kids-list (list next-kid))))
- (loop (+ col 1) next-complete-list rest-kids)))))
-
- (let loop ((complete-kids-lists '()) (rest-kids-lists kids-lists))
- (if (null? rest-kids-lists)
- complete-kids-lists
- (let ((next-list (car rest-kids-lists)))
- (loop (append complete-kids-lists
- (list (kids-list->complete-kids-list next-list)))
- (cdr rest-kids-lists)))))))
-
-
-(define (row-lists->col-lists kids-lists)
- (let ((kids-lists (kids-lists->complete-kids-lists kids-lists)))
- (let loop ((col 0) (col-lists '()))
- (if (= col (apply max (map length kids-lists)))
- col-lists
- (let ((col-list
- (let loop ((row 0) (col-list '()))
- (if (= row (length kids-lists))
- col-list
- (loop (+ row 1)
- (cons (list-ref (list-ref kids-lists row) col)
- col-list))))))
- (loop (+ col 1) (cons col-list col-lists)))))))
-
-(define (array-size kids-lists)
- (let ((col-lists (row-lists->col-lists kids-lists)))
- (make-size
- (apply +
- (map (lambda (col-list)
- (apply max
- (map (lambda (kid)
- (if (symbol? kid)
- 0
- (size.width (get-desired-size kid))))
- col-list)))
- col-lists))
- (apply +
- (map (lambda (row-list)
- (apply max
- (map (lambda (kid)
- (if (symbol? kid)
- 0
- (size.height (get-desired-size kid))))
- row-list)))
- kids-lists)))))
-
-(define (array-arrange kids-lists my-screen-area)
- (let* ((my-width (UITKRectangle.Width my-screen-area))
- (my-height (UITKRectangle.Height my-screen-area))
- (my-offset (UITKRectangle.Offset my-screen-area))
- (X (point.X my-offset))
- (Y (point.Y my-offset))
- (kids-lists (kids-lists->complete-kids-lists kids-lists))
- )
-
- (define (kids-lists->kids-array kids-lists)
- (let loop ((kids-lists kids-lists) (kids-array-list '()))
- (if (null? kids-lists)
- (list->vector kids-array-list)
- (loop (cdr kids-lists)
- (append kids-array-list
- (list (list->vector (car kids-lists))))))))
-
- (let* ((kids-array (kids-lists->kids-array kids-lists))
- (num-rows (vector-length kids-array))
- (num-cols (vector-length (vector-ref kids-array 0))))
-
- (define (aref array row col)
- (vector-ref (vector-ref array row) col))
-
- (define (aset! array row col value)
- (vector-set! (vector-ref array row) col value))
-
- (define (kids-column-hglue col)
- (define (get-hglue kid)
- (if (symbol? kid)
- *fil-glue*
- (%hglue kid)))
- (let* ((kid1 (aref kids-array 0 col))
- (g1 (get-hglue kid1)))
- (let loop ((row 1) (g g1))
- (if (< row num-rows)
- (let* ((next-kid (aref kids-array row col))
- (next-glue (get-hglue next-kid)))
- (loop (+ row 1) (parallel-compose-glue g next-glue)))
- g))))
-
- (define (kids-row-vglue row)
- (define (get-vglue kid)
- (if (symbol? kid)
- *fil-glue*
- (%vglue kid)))
- (let* ((kid1 (aref kids-array row 0))
- (g1 (get-vglue kid1)))
- (let loop ((col 1) (g g1))
- (if (< col num-cols)
- (let* ((next-kid (aref kids-array row col))
- (next-glue (get-vglue next-kid)))
- (loop (+ col 1) (parallel-compose-glue g next-glue)))
- g))))
-
- (define (enumerate-interval from to)
- (if (> from to)
- '()
- (cons from (enumerate-interval (+ from 1) to))))
-
- (define (instantiate-kids h-positions-vector v-positions-vector)
- (let loop-rows ((row 0))
- (if (= row num-rows)
- 'done
- (let loop-cols ((col 0))
- (if (= col num-cols)
- (loop-rows (+ row 1))
- (let ((kid (aref kids-array row col)))
- (if (symbol? kid)
- (cond ((eq? kid 'skip)
- (loop-cols (+ col 1)))
- ((or (eq? kid 'left) (eq? kid 'up))
- ;; wasn't to the right or below a
- ;; valid child, so it's either been
- ;; taken care of already, or needs to
- ;; be 'skip.
- (aset! kids-array row col 'skip)
- (loop-cols (+ col 1)))
- (else
- (error
- "Illegal symbol in array box:"
- "Must be 'skip, 'left, or 'up." kid)))
- (let* ((kid-x-offset
- (vector-ref h-positions-vector col))
- (kid-y-offset
- (vector-ref v-positions-vector row))
- (width (- (vector-ref h-positions-vector
- (+ col 1))
- kid-x-offset))
- (height (- (vector-ref v-positions-vector
- (+ row 1))
- kid-y-offset)))
-
- (let expand-h-loop ((col+ 1) (wid width))
- (let ((new-col (+ col+ col)))
- (if (= new-col num-cols)
- (set! width wid)
- (let ((next-h-kid (aref kids-array row new-col)))
- (if (symbol? next-h-kid)
- (cond
- ((eq? next-h-kid 'left)
- (let* ((x-offset
- (vector-ref h-positions-vector
- new-col))
- (new-wid
- (+ wid
- (- (vector-ref
- h-positions-vector
- (+ new-col 1))
- x-offset))))
- (aset! kids-array row new-col 'skip)
- (expand-h-loop (+ col+ 1) new-wid)))
- ((eq? next-h-kid 'skip)
- (set! width wid))
- ((eq? next-h-kid 'up)
- (set! width wid))
- (else
- (error "Illegal symbol in array box:"
- "Must be 'skip, 'left, or 'up."
- next-h-kid)))
- (set! width wid))))))
-
- (let expand-v-loop ((row+ 1) (ht height))
- (let ((new-row (+ row+ row)))
- (if (= new-row num-rows)
- (set! height ht)
- (let ((next-v-kid (aref kids-array new-row col)))
- (if (symbol? next-v-kid)
- (cond
- ((eq? next-v-kid 'up)
- (let* ((y-offset
- (vector-ref v-positions-vector
- new-row))
- (new-ht
- (+ ht (- (vector-ref
- v-positions-vector
- (+ new-row 1))
- y-offset))))
- (aset! kids-array new-row col 'skip)
- (expand-v-loop (+ row+ 1) new-ht)))
- ((eq? next-v-kid 'skip)
- (set! height ht))
- ((eq? next-v-kid 'left)
- (set! height ht))
- (else
- (error "Illegal symbol in array box:"
- "Must be 'skip, 'left, or 'up."
- next-v-kid)))
- (set! height ht))))))
-
- (assign-screen-area!
- kid
- (make-UITKRectangle (make-point (+ X kid-x-offset)
- (+ Y kid-y-offset))
- (make-size width height)))
- (loop-cols (+ col 1))))))))))
-
- (let ((cols-hglues (map kids-column-hglue (enumerate-interval 0 (- num-cols 1))))
- (rows-vglues (map kids-row-vglue (enumerate-interval 0 (- num-rows 1)))))
- (conquer-space
- my-width
- cols-hglues
- (lambda (h-positions-vector)
- (conquer-space
- my-height
- rows-vglues
- (lambda (v-positions-vector)
- (instantiate-kids h-positions-vector v-positions-vector))))))
- )))
-
-(define (array-get-hglue kids-lists)
- ;; or minimum?
- (choose-maximum-glue
- (map (lambda (kids-list)
- (series-compose-glues
- (map (lambda (kid)
- (if (symbol? kid)
- *rigid-glue*
- (%hglue kid)))
- kids-list)))
- kids-lists)))
-
-(define (array-get-vglue kids-lists)
- (choose-maximum-glue
- (map (lambda (kids-list)
- (series-compose-glues
- (map (lambda (kid)
- (if (symbol? kid)
- *rigid-glue*
- (%vglue kid)))
- kids-list)))
- (row-lists->col-lists kids-lists))))
-
-
-(define (find-real-array-box-children kids-lists)
- (let loop-lists ((kids-lists kids-lists)
- (valid-kids-list '()))
- (if (null? kids-lists)
- valid-kids-list
- (let loop-list ((kids-list (car kids-lists))
- (valid-kids '()))
- (if (null? kids-list)
- (loop-lists (cdr kids-lists)
- (append valid-kids-list valid-kids))
- (let ((kid (car kids-list)))
- (if (symbol? kid)
- (loop-list (cdr kids-list) valid-kids)
- (loop-list (cdr kids-list)
- (append valid-kids (list kid))))))))))
-
-(define (array:rearrange me)
- (let ((screen-area (used-screen-area me))
- (kids-lists (ArrayBox%.kids-lists me)))
- (if screen-area
- (let ((new-size (array-size kids-lists)))
- (set-%desired-size! me new-size)
- (if (size= new-size (UITKRectangle.Size screen-area))
- (begin (assign-glue! me)
- (array-arrange kids-lists screen-area))
- (begin
- (set-%desired-size! me new-size)
- (geometry-change! me screen-area #T)
- (if (eq? screen-area (used-screen-area me))
- (begin (assign-glue! me)
- (array-arrange kids-lists screen-area)))))))))
-
-(define (array-box-add-child! me kid)
- (if (not (valid-child? kid))
- (error "ARRAY-BOX-ADD-CHILD!: Bad UIObj" kid))
- (one-parent-only! kid me)
- (set-ArrayBox%.kids! me (append (ArrayBox%.kids me) (list kid)))
- (on-geometry-change!
- kid 'ARRAY-BOX
- (lambda (old-screen-area new-screen-area)
- old-screen-area ; Not used
- (if (eq? new-screen-area #T) ; Instigated by child, not manager
- (array:rearrange me))))
- (on-death! kid 'ARRAY-BOX ; Die horribly ....
- (lambda ()
- (assign-drawing-surface! me 'RETRACTED)))
- (assign-drawing-surface! kid (drawing-surface me))
- (array:rearrange me))
-
-(define (array-box-assign-drawing-surface! me surface)
- (check-drawing-surface! me surface)
- (for-each (lambda (kid)
- (if (eq? surface 'RETRACTED)
- (forget! kid 'ARRAY-BOX))
- (assign-drawing-surface! kid surface))
- (ArrayBox%.kids me))
- (if (DrawingSurface? surface)
- (set-%desired-size! me (array-size (ArrayBox%.kids-lists me))))
- (if (eq? surface 'RETRACTED)
- (death! me)
- (geometry-change! me #F #F))
- 'OK)
-
-(define (array-box-assign-screen-area! me screen-area)
- (cond ((vector? screen-area)
- (set-assigned-screen-area! me screen-area)
- (let ((old (used-screen-area me)))
- (if (not (screen-area= old screen-area))
- (begin
- (set-used-screen-area! me screen-area)
- (array:rearrange me)
- (geometry-change! me old screen-area))))
- screen-area)
- ((not screen-area)
- (set-assigned-screen-area! me screen-area)
- (let ((old (used-screen-area me)))
- (if (not (screen-area= old screen-area))
- (begin
- (set-used-screen-area! me screen-area)
- (retract-area (ArrayBox%.kids me))
- (geometry-change! me old screen-area))))
- screen-area)
- (else
- (error "ARRAY-BOX-ASSIGN-SCREEN-AREA!: Bad screen-area" screen-area))))
-
-(define (array-box-assign-glue! me)
- (let ((kids-lists (ArrayBox%.kids-lists me)))
- (for-each assign-glue! (ArrayBox%.kids me))
- (set-%hglue! me (array-get-hglue kids-lists))
- (set-%vglue! me (array-get-vglue kids-lists))))
-
-;; Box Maker
-(define (array-box-maker kids-lists)
- (make-ArrayBox%
- (make-UIObjInternals 'invalid-arraybox-1 ; array-box-add-child!
- 'invalid-arraybox-2 ; array-box-remove-child!
- UIObj-set-context!
- array-box-assign-screen-area!
- array-box-assign-drawing-surface!
- UIObj-point-within?
- UIObj-rectangle-overlaps?
- UIObj-handle-event
- UIObj-get-desired-size
- UIObj-assigned-screen-area
- UIObj-used-screen-area
- UIObj-set-assigned-screen-area!
- UIObj-set-used-screen-area!
- array-box-assign-glue!)
- kids-lists))
-
-(define (array-box-propagator box)
- (lambda (event)
- (for-each (lambda (kid)
- (if (event-within? kid event)
- (handle-event kid event)))
- (array-box%.kids box))))
-
-(define (make-array-box . kids-lists)
- (let ((kids (find-real-array-box-children kids-lists)))
- (let ((me (array-box-maker kids-lists)))
- (on-event! me 'ARRAY-BOX
- (array-box-propagator me))
- (for-each (lambda (kid) (array-box-add-child! me kid))
- kids)
- me)))
+++ /dev/null
-#|
-(with-working-directory-pathname (directory-pathname (current-load-pathname))
- (lambda ()
- ;; Dynamically load the microcode. Order important.
- (load "dynload/scxl")
- (load "dynload/tcl")
- (load "dynload/tk")
- (load "dynload/uitk")
-
- ((access with-directory-rewriting-rule
- (->environment '(RUNTIME COMPILER-INFO)))
- (working-directory-pathname)
- (pathname-as-directory "lib/swat")
- (lambda ()
- (load-package-set "swat")))
- (add-subsystem-identification! "SWAT" '(1 0))))
-|#
-
-
-
-(let ((swat-env (extend-top-level-environment system-global-environment)))
-
- (package/add-child! (find-package '()) 'SWAT swat-env)
-
- (for-each (lambda (name)
- (environment-define swat-env name 'UNASSIGNED)
- (link-variables system-global-environment name
- swat-env name))
- ;; All of SWAT's exported names. This list need pruning
- '(
- *-alert-structure-size-*
- *-alert.function-*
- *-alert.reason-*
- *-canvasitem-structure-size-*
- *-canvasitem.add-event-handler!-procedure-*
- *-canvasitem.ask-widget-procedure-*
- *-canvasitem.canvas-*
- *-canvasitem.name-*
- *-canvasitem.set-callback!-procedure-*
- *-canvasitemgroup-structure-size-*
- *-canvasitemgroup.add-event-handler!-procedure-*
- *-canvasitemgroup.ask-widget-procedure-*
- *-canvasitemgroup.canvas-*
- *-canvasitemgroup.set-callback!-procedure-*
- *-canvasitemgroup.tag-*
- *-context-structure-size-*
- *-context.activebackground-*
- *-context.activeforeground-*
- *-context.anchor-*
- *-context.background-*
- *-context.border-*
- *-context.borderwidth-*
- *-context.foreground-*
- *-context.relief-*
- *-drawingsurface-structure-size-*
- *-drawingsurface.toolkitwindow-*
- *-drawingsurface.uitkwindow-*
- *-drawingsurface.weak-list-of-widgets-*
- *-event-structure-size-*
- *-event.height-*
- *-event.offset-*
- *-event.os-event-*
- *-event.point-or-rectangle?-*
- *-event.type-*
- *-event.width-*
- *-event.window-*
- *-glue-structure-size-*
- *-glue.class-*
- *-glue.minsize-*
- *-glue.value-*
- *-locked-list-structure-size-*
- *-menuitem-structure-size-*
- *-menuitem.add-event-handler!-procedure-*
- *-menuitem.ask-widget-procedure-*
- *-menuitem.index-*
- *-menuitem.menurecord-*
- *-menuitem.set-callback!-procedure-*
- *-menurecord-structure-size-*
- *-menurecord.items-*
- *-menurecord.menu-*
- *-point-structure-size-*
- *-point.x-*
- *-point.y-*
- *-queue-structure-size-*
- *-scxl-wrapper-structure-size-*
- *-scxl-wrapper.other-stuff-*
- *-scxl-wrapper.strong-dependents-*
- *-scxl-wrapper.type-*
- *-scxl-wrapper.wrapped-object-*
- *-sensitive-surface-structure-size-*
- *-sensitive-surface.drawingsurface-*
- *-sensitive-surface.handlers-*
- *-sensitivity-structure-size-*
- *-sensitivity.masks-*
- *-size-structure-size-*
- *-size.height-*
- *-size.width-*
- *-surface-sensitivity-structure-size-*
- *-surface-sensitivity.mask-*
- *-surface-sensitivity.sensitivities-*
- *-surface-sensitivity.weak-surface-*
- *-texttag-structure-size-*
- *-texttag.add-event-handler!-procedure-*
- *-texttag.ask-widget-procedure-*
- *-texttag.callbacks-*
- *-texttag.name-*
- *-texttag.set-callback!-procedure-*
- *-texttag.text-*
- *-tk-variable-structure-size-*
- *-tk-variable.application-*
- *-tk-variable.callback-*
- *-tk-variable.tk-name-*
- *-toolkitwindow-structure-size-*
- *-toolkitwindow.application-*
- *-toolkitwindow.tk-window-*
- *-toolkitwindow.top-level-geometry-callback-*
- *-uiobjinternals-structure-size-*
- *-uiobjinternals.add-child!-procedure-*
- *-uiobjinternals.already-have-a-parent?-*
- *-uiobjinternals.assign-drawing-surface!-procedure-*
- *-uiobjinternals.assign-glue!-procedure-*
- *-uiobjinternals.assign-screen-area!-procedure-*
- *-uiobjinternals.assigned-screen-area-*
- *-uiobjinternals.assigned-screen-area-procedure-*
- *-uiobjinternals.clip-region-*
- *-uiobjinternals.crud-that-i-dont-want-to-gc-away-*
- *-uiobjinternals.drawing-surface-*
- *-uiobjinternals.get-desired-size-procedure-*
- *-uiobjinternals.handle-event-procedure-*
- *-uiobjinternals.point-within?-procedure-*
- *-uiobjinternals.rectangle-overlaps?-procedure-*
- *-uiobjinternals.remove-child!-procedure-*
- *-uiobjinternals.set-assigned-screen-area!-procedure-*
- *-uiobjinternals.set-context!-procedure-*
- *-uiobjinternals.set-used-screen-area!-procedure-*
- *-uiobjinternals.used-screen-area-*
- *-uiobjinternals.used-screen-area-procedure-*
- *-uitkrectangle-structure-size-*
- *-uitkrectangle.offset-*
- *-uitkrectangle.size-*
- *-uitkwindow-structure-size-*
- *-uitkwindow.xdisplay-*
- *-uitkwindow.xwindow-*
- *all-menus*
- *all-sensitive-surfaces*
- *event-processing-mutex*
- *fil-glue*
- *fil-glue-class*
- *fill-glue-class*
- *our-hash-table*
- *percent-glue-class*
- *rigid-glue*
- *rigid-glue-class*
- *synchronizing?*
- *the-default-application*
- *uitk-interval*
- *uitk:gc-has-occurred?*
- *xclosedisplaycallbacks*
- ->widget
- ->xcolormap
- ->xdisplay
- ->xgc
- ->xpixel
- ->xregion
- ->xwindow
- ;;add-to-protection-list!
- ;;canvas-flush-protect-list!
- ;;canvas-protect-from-gc!
- ;;canvas-unprotect-from-gc!
- ;;clean-lost-protected-objects
- ;;del-assq!
- ;;del-assv!
- ;;del-op!
- ;;dequeue!
- ;;display-protection-list
- ;;enqueue!
- ;;find-in-protection-list
- ;;find-tk-protection-list
- ;;find-tk-protection-list-from-number
- ;;make-protection-list
- ;;make-queue
- ;;make-weak-del-op!
- ;;make-weak-lookup
- ;;protection-list-all-elements
- ;;protection-list-referenced-elements
- ;;queue?
- ;;region-protection-list
- ;;remove-from-protection-list!
- ;;search-protection-list
- ;;text-flush-protect-list!
- ;;text-protect-from-gc!
- ;;text-unprotect-from-gc!
- ;;uiobj-protect-from-gc!
- ;;uiobj-unprotect-from-gc!
- ;;uitk-protection-list
- ;;weak-delq!
- active-variable-value
- add-child!
- add-event-handler!
- add-event-handler!-procedure-index
- add-sub-menu
- add-to-agenda!
- add-to-canvas-item-group
- add-to-menu
- add-vectors
- add-widget-list-for-display-number!
- after-delay
- after-last-space
- alert.function
- alert.reason
- alert/pp
- alert?
- allow-free-trace?
- application->display
- application->tkmainwindow
- application-add-child!
- application-maker
- application-remove-child!
- application-remove-destroyed-child!
- array-arrange
- array-box-add-child!
- array-box-assign-drawing-surface!
- array-box-assign-glue!
- array-box-assign-screen-area!
- array-box-maker
- array-box-propagator
- array-get-hglue
- array-get-vglue
- array-size
- array:rearrange
- ask-widget
- ask-widget-procedure-index
- assign-drawing-surface!
- assign-geometry!
- assign-glue!
- assign-location!
- assign-screen-area!
- assigned-screen-area
- atomic-read-and-clear-cell!
- bit-or
- box-add-child!
- box-assign-drawing-surface!
- box-assign-glue!
- box-assign-screen-area!
- box-children
- box-maker
- box-remove-child!
- box:event-propagator
- box:rearrange
- button-stretch
- canvas-stretch
- canvasitem-add-event-handler!
- canvasitem-ask-widget
- canvasitem.add-event-handler!-procedure
- canvasitem.ask-widget-procedure
- canvasitem.canvas
- canvasitem.name
- canvasitem.set-callback!-procedure
- canvasitem/pp
- canvasitem?
- canvasitemgroup-add-event-handler!
- canvasitemgroup-ask-widget
- canvasitemgroup.add-event-handler!-procedure
- canvasitemgroup.ask-widget-procedure
- canvasitemgroup.canvas
- canvasitemgroup.set-callback!-procedure
- canvasitemgroup.tag
- canvasitemgroup/pp
- canvasitemgroup?
- change-sensitive-surface!
- check-drawing-surface!
- checkbutton-variable-on?
- choose-maximum-glue
- choose-minimum-glue
- clean-lost-celled-objects
- cleanup-vanished-objects-for-display
- clear-counters!
- cleararea
- clip-region
- close-lost-displays-daemon
- color?
- colormap/colormap
- colormap/pixel-list
- compose-glues
- compute-cumulative-glues
- conquer-space
- context-change!
- context.activebackground
- context.activeforeground
- context.anchor
- context.background
- context.border
- context.borderwidth
- context.foreground
- context.relief
- context/pp
- context?
- copy-free-traces
- copy-rectangle
- copyxregion
- create-default-context
- create-sensitive-surface
- crud-that-i-dont-want-to-gc-away
- current-size
- current-time
- death!
- debug-print
- debug-surface
- debugging-port
- decode-button-event
- decode-configure-event
- decode-crossing-event
- decode-expose-event
- decode-key-event
- decode-motion-event
- decode-unknown-event
- decode-window-attributes
- defer
- define-constant ;macro
- define-in-line ;macro
- delete-<interactor>!
- delete-menuitem!
- destroy-all-sensitive-surfaces-from-display
- destroy-associated-tk-widgets
- destroy-registration
- destroy-sensitive-surface
- display->tk-widgets
- display/colormap-list
- display/default-root-window
- display/display
- display/font-list
- display/gc-list
- display/screen/default-color-map
- display/window-list
- divide-space
- do-tk-callbacks
- do-tk-callbacks-from-string
- drawarc
- drawing-surface
- drawingsurface.application
- drawingsurface.toolkitwindow
- drawingsurface.uitkwindow
- drawingsurface.weak-list-of-widgets
- drawingsurface/pp
- drawingsurface?
- drawline
- drawrectangle
- empty-agenda?
- empty-queue?
- empty-segments?
- ensure-graphics-context
- entry-height-stretch
- event!
- event-counter
- event-within?
- event.height
- event.offset
- event.os-event
- event.point-or-rectangle?
- event.type
- event.width
- event.window
- event/pp
- event?
- fil-glue?
- fill-glue?
- fillarc
- fillrectangle
- finalize-uitk-objects
- finalize-uitk-objects-later
- find-menu-record
- find-real-array-box-children
- find-sensitivity
- find-ss
- first-segment
- flush-display-hook
- flush-queued-output
- forget!
- forget-context-change!
- forget-death-notification!
- forget-event!
- forget-geometry-change!
- fork-to-wait-on
- gc/gc
- gc/region
- generate-events!
- generate-graphics-context!
- geometry-change!
- get-desired-size
- get-interval-to-next-delayed-event
- get-interval-to-tk-wakeup
- get-tk-widget-orientation
- get-uitkwindow
- get-window-attributes
- get-x-event
- getdefaultvalue
- glue.class
- glue.minsize
- glue.value
- glue/pp
- glue?
- h-arrange
- h-get-hglue
- h-get-vglue
- h-size
- handle-button-grab
- handle-event
- handle-exposure
- handler->sensitivity
- idle-queue
- ignore-repl
- init-alert
- init-canvasitem
- init-canvasitemgroup
- init-context
- init-drawingsurface
- init-event
- init-glue
- init-locked-list
- init-menuitem
- init-menurecord
- init-point
- init-queue
- init-scxl-wrapper
- init-sensitive-surface
- init-sensitivity
- init-size
- init-surface-sensitivity
- init-texttag
- init-tk-variable
- init-toolkitwindow
- init-uiobjinternals
- init-uitkrectangle
- init-uitkwindow
- initial-thread-state
- initialize-mit-widgets!
- initialize-scxl!
- initialize-uitk!
- initialize-widgets!
- insert-new-time!
- interactor-add-child!
- interactor-maker
- interactor-remove-child!
- intersectxregions
- is-type-wrapped-object
- kick-uitk-thread
- kids-lists->complete-kids-lists
- locked-list/pp
- locked-list?
- loop-counter
- loop-trace
- make-active-variable
- make-add-alert!
- make-agenda
- make-alert
- make-alert!
- make-application
- make-arc-on-canvas
- make-arg-transformers
- make-array-box
- make-bitmap-on-canvas
- make-box
- make-button
- make-canvas
- make-canvas-item
- make-canvas-item-group
- make-canvasitem
- make-canvasitemgroup
- make-checkbutton
- make-colored-graphics-context
- make-context
- make-del-op!
- make-destroy-<application>-related-objects
- make-drawingsurface
- make-drop-rubber-rectangle-surface
- make-enqueueable-thunk
- make-entry
- make-event
- make-fil-glue
- make-fill-glue
- make-filled-circle
- make-filled-oval
- make-filled-rectangle
- make-free-trace
- make-glue
- make-hbox
- make-interactor
- make-label
- make-line
- make-line-on-canvas
- make-listbox
- make-locked-list
- make-lookup
- make-menu
- make-menubutton
- make-menuitem
- make-menurecord
- make-message
- make-oval
- make-oval-on-canvas
- make-percent-glue
- make-point
- make-point-event
- make-polygon-on-canvas
- make-radiobutton
- make-rect
- make-rectangle-event
- make-rectangle-on-canvas
- make-remove-alert!
- make-rigid-glue
- make-scale
- make-scaling-line
- make-scaling-oval
- make-scaling-rect
- make-scrollable-canvas
- make-scrollable-text
- make-scrollbar
- make-scxl-wrapper
- make-self-painting-circle
- make-self-painting-rectangle
- make-self-painting-unfilled-rectangle
- make-sensitive-surface
- make-sensitivity
- make-shape
- make-shape-surface
- make-simple-graphics-context
- make-size
- make-space
- make-surface-sensitivity
- make-text
- make-text-on-canvas
- make-text-tag
- make-texttag
- make-time-segment
- make-tk-variable
- make-tk-widget
- make-toolkitwindow
- make-top-level-geometry-callback
- make-uiobjinternals
- make-uitk-thread
- make-uitkrectangle
- make-uitkwindow
- make-unfilled-circle
- make-unfilled-oval
- make-unfilled-rectangle
- make-unknown-event
- make-vbox
- make-widget-on-canvas
- makexregion
- maybe-defer
- menuitem-ask-widget
- menuitem-set-callback!
- menuitem.add-event-handler!-procedure
- menuitem.ask-widget-procedure
- menuitem.index
- menuitem.menu
- menuitem.menurecord
- menuitem.set-callback!-procedure
- menuitem/pp
- menuitem?
- menurecord.items
- menurecord.menu
- menurecord/pp
- menurecord?
- merge-canvas-item-groups
- more-counter
- more-work-to-do
- mouse-drag
- on-context-change!
- on-death!
- on-event!
- on-geometry-change!
- one-parent-only!
- open-display
- our-with-thread-mutex-locked
- parallel-compose-glue
- parallel-compose-glues
- percent-glue?
- pixel/pixel
- point-event-within?
- point-event?
- point-in-rectangle?
- point-within?
- point.x
- point.y
- point/pp
- point=
- point?
- proc-with-transformed-args
- queue/pp
- read-and-empty-agenda!
- read-and-empty-queue!
- read-queue-trace
- record-free-pointer
- record-surface-sensitivity!
- rectangle->xregion
- rectangle-event-within?
- rectangle-event?
- rectangle-overlaps-rectangle?
- rectangle-overlaps?
- rectangle=
- region/region
- remember-on-canvas!
- remove-child!
- reset-sensitivity!
- rest-segments
- restart-uitk
- retract-area
- rigid-glue?
- row-lists->col-lists
- run-queue-trace
- scc-define-structure ;macro
- screen-area=
- scrollable-canvas-canvas
- scrollable-canvas-hscroll
- scrollable-canvas-vscroll
- scrollable-text-text
- scrollable-text-vscroll
- scxl-destroy!
- scxl-destroyed?
- scxl-display?
- scxl-install-xclosedisplay-callback
- scxl-unwrap
- scxl-wrap
- scxl-wrapped?
- scxl-wrapper.other-stuff
- scxl-wrapper.strong-dependents
- scxl-wrapper.type
- scxl-wrapper.wrapped-object
- scxl-wrapper/pp
- scxl-wrapper?
- segment-queue
- segment-time
- segments
- self-paint!
- sensitive-surface.drawingsurface
- sensitive-surface.handlers
- sensitive-surface/pp
- sensitive-surface?
- sensitivity.masks
- sensitivity/pp
- sensitivity?
- series-compose-glue
- series-compose-glues
- set-active-variable!
- set-active-variable-callback!
- set-alert.function!
- set-alert.reason!
- set-assigned-screen-area!
- set-callback!
- set-callback!-procedure-index
- set-canvasitem.add-event-handler!-procedure!
- set-canvasitem.ask-widget-procedure!
- set-canvasitem.canvas!
- set-canvasitem.name!
- set-canvasitem.set-callback!-procedure!
- set-canvasitemgroup.add-event-handler!-procedure!
- set-canvasitemgroup.ask-widget-procedure!
- set-canvasitemgroup.canvas!
- set-canvasitemgroup.set-callback!-procedure!
- set-canvasitemgroup.tag!
- set-clip-region!
- set-context!
- set-context.activebackground!
- set-context.activeforeground!
- set-context.anchor!
- set-context.background!
- set-context.border!
- set-context.borderwidth!
- set-context.foreground!
- set-context.relief!
- set-crud-that-i-dont-want-to-gc-away!
- set-drawing-surface!
- set-drawingsurface.toolkitwindow!
- set-drawingsurface.uitkwindow!
- set-drawingsurface.weak-list-of-widgets!
- set-event.height!
- set-event.offset!
- set-event.os-event!
- set-event.point-or-rectangle?!
- set-event.type!
- set-event.width!
- set-event.window!
- set-floating-error-mask!
- set-gc/region!
- set-glue.class!
- set-glue.minsize!
- set-glue.value!
- set-menuitem.add-event-handler!-procedure!
- set-menuitem.ask-widget-procedure!
- set-menuitem.index!
- set-menuitem.menurecord!
- set-menuitem.set-callback!-procedure!
- set-menurecord.items!
- set-menurecord.menu!
- set-point.x!
- set-point.y!
- set-scxl-wrapper.other-stuff!
- set-scxl-wrapper.strong-dependents!
- set-scxl-wrapper.type!
- set-scxl-wrapper.wrapped-object!
- set-segments!
- set-sensitive-surface.drawingsurface!
- set-sensitive-surface.handlers!
- set-sensitivity.masks!
- set-size.height!
- set-size.width!
- set-surface-sensitivity.mask!
- set-surface-sensitivity.sensitivities!
- set-surface-sensitivity.weak-surface!
- set-texttag.add-event-handler!-procedure!
- set-texttag.ask-widget-procedure!
- set-texttag.callbacks!
- set-texttag.name!
- set-texttag.set-callback!-procedure!
- set-texttag.text!
- set-tk-variable.application!
- set-tk-variable.callback!
- set-tk-variable.tk-name!
- set-toolkitwindow.application!
- set-toolkitwindow.tk-window!
- set-toolkitwindow.top-level-geometry-callback!
- set-uiobjinternals.add-child!-procedure!
- set-uiobjinternals.already-have-a-parent?!
- set-uiobjinternals.assign-drawing-surface!-procedure!
- set-uiobjinternals.assign-glue!-procedure!
- set-uiobjinternals.assign-screen-area!-procedure!
- set-uiobjinternals.assigned-screen-area!
- set-uiobjinternals.assigned-screen-area-procedure!
- set-uiobjinternals.clip-region!
- set-uiobjinternals.crud-that-i-dont-want-to-gc-away!
- set-uiobjinternals.drawing-surface!
- set-uiobjinternals.get-desired-size-procedure!
- set-uiobjinternals.handle-event-procedure!
- set-uiobjinternals.point-within?-procedure!
- set-uiobjinternals.rectangle-overlaps?-procedure!
- set-uiobjinternals.remove-child!-procedure!
- set-uiobjinternals.set-assigned-screen-area!-procedure!
- set-uiobjinternals.set-context!-procedure!
- set-uiobjinternals.set-used-screen-area!-procedure!
- set-uiobjinternals.used-screen-area!
- set-uiobjinternals.used-screen-area-procedure!
- set-uitkrectangle.offset!
- set-uitkrectangle.size!
- set-uitkwindow.xdisplay!
- set-uitkwindow.xwindow!
- set-used-screen-area!
- setclipxregion
- shape-assign-glue!
- shape-assign-screen-area!
- shape-copy
- shape-draw
- shape-draw-function
- shape-erase-maybe
- shape-maker
- shape-point-within?
- shape-rectangle-overlaps?
- shape-set-color!
- shape-set-erase-function!
- shape-set-gc-function!
- show-counters
- shut-down-event-server
- size.height
- size.width
- size/pp
- size=
- size?
- string->color
- stringify-for-tk
- sub-vectors
- subtractxregions
- surface-sensitivity.mask
- surface-sensitivity.sensitivities
- surface-sensitivity.weak-surface
- surface-sensitivity/pp
- surface-sensitivity?
- suspend-counter
- swat-close
- swat-open
- swat-open-in-application
- swat:number->string
- tcl-global-eval
- texttag-add-event-handler!
- texttag-ask-widget
- texttag.add-event-handler!-procedure
- texttag.ask-widget-procedure
- texttag.callbacks
- texttag.name
- texttag.set-callback!-procedure
- texttag.text
- texttag/pp
- texttag?
- the-agenda
- thread-start
- tk-completely-handles-event?
- tk-create-top-level-window
- tk-delete-display
- tk-doevents
- tk-gen-name
- tk-generate-scheme-event
- tk-has-requested-new-size
- tk-init
- tk-invoke-command
- tk-kill-application
- tk-make-button
- tk-make-canvas
- tk-make-checkbutton
- tk-make-entry
- tk-make-label
- tk-make-listbox
- tk-make-menu
- tk-make-menubutton
- tk-make-message
- tk-make-radiobutton
- tk-make-scale
- tk-make-scrollbar
- tk-make-text
- tk-manage-geometry
- tk-map-window
- tk-move-resize-widget
- tk-op
- tk-unmap-window
- tk-variable.application
- tk-variable.callback
- tk-variable.tk-name
- tk-variable/pp
- tk-variable?
- tk-widget->pathname
- tk-widget-destroy
- tk-widget.tkwin
- tkwidget-add-child!
- tkwidget-add-event-handler!
- tkwidget-ask-widget
- tkwidget-assign-drawing-surface!
- tkwidget-assign-glue!
- tkwidget-assign-screen-area!
- tkwidget-assigned-screen-area
- tkwidget-get-desired-size
- tkwidget-maker
- tkwidget-set-assigned-screen-area!
- tkwidget-set-callback!
- tkwidget-set-used-screen-area!
- tkwidget-used-screen-area
- tkwin->requested-size
- tkwin->size
- tkwin.display
- tkwin.height
- tkwin.ismapped?
- tkwin.name
- tkwin.pathname
- tkwin.req-height
- tkwin.req-width
- tkwin.width
- tkwin.window
- tkwin.x
- tkwin.y
- toolkitwindow.application
- toolkitwindow.tk-window
- toolkitwindow.top-level-geometry-callback
- toolkitwindow/pp
- toolkitwindow?
- translate-rectangle
- type-check-wrapped-object
- uiobj-assign-drawing-surface!
- uiobj-assign-screen-area!
- uiobj-assigned-screen-area
- uiobj-get-desired-size
- uiobj-handle-event
- uiobj-point-within?
- uiobj-rectangle-overlaps?
- uiobj-set-assigned-screen-area!
- uiobj-set-context!
- uiobj-set-used-screen-area!
- uiobj-used-screen-area
- uiobjinternals
- uiobjinternals-index
- uiobjinternals.add-child!-procedure
- uiobjinternals.already-have-a-parent?
- uiobjinternals.assign-drawing-surface!-procedure
- uiobjinternals.assign-glue!-procedure
- uiobjinternals.assign-screen-area!-procedure
- uiobjinternals.assigned-screen-area
- uiobjinternals.assigned-screen-area-procedure
- uiobjinternals.clip-region
- uiobjinternals.crud-that-i-dont-want-to-gc-away
- uiobjinternals.drawing-surface
- uiobjinternals.get-desired-size-procedure
- uiobjinternals.handle-event-procedure
- uiobjinternals.point-within?-procedure
- uiobjinternals.rectangle-overlaps?-procedure
- uiobjinternals.remove-child!-procedure
- uiobjinternals.set-assigned-screen-area!-procedure
- uiobjinternals.set-context!-procedure
- uiobjinternals.set-used-screen-area!-procedure
- uiobjinternals.used-screen-area
- uiobjinternals.used-screen-area-procedure
- uiobjinternals/pp
- uiobjinternals?
- uitk-queue
- uitk-thread
- uitk-thread-main-loop
- uitk-timer
- uitkrectangle.height
- uitkrectangle.offset
- uitkrectangle.size
- uitkrectangle.width
- uitkrectangle/pp
- uitkrectangle?
- uitkwindow.xdisplay
- uitkwindow.xwindow
- uitkwindow/pp
- uitkwindow?
- unionxregions
- unwrap-display
- update-locked-list!
- used-screen-area
- v-arrange
- v-get-hglue
- v-get-vglue
- v-size
- valid-child?
- valid-color-for-application?
- valid-color?
- valid-non-widget?
- when-idle!
- when-unreferenced
- widget->screen-area
- widget->size
- widget/widget
- window/window
- with-clipping!
- with-locked-list
- with-uitk-thread-errors-captured
- wrap-colormap
- wrap-display
- wrap-graphics-context
- wrap-pixel
- wrap-region
- wrap-tk-widget
- wrap-window
- wrap-with-scxl-destroy!
- xallocnamedcolor
- xchangewindowattributes
- xcheckmaskevent!?
- xcleararea
- xclearwindow
- xclosedisplay
- xclosedisplaybynumber
- xcolor.pixel
- xconnectionnumber
- xcopy-event
- xcreategc
- xcreateregion
- xcreatesimplewindow
- xdecodebuttonevent
- xdecodeconfigureevent
- xdecodecrossingevent
- xdecodeexposeevent
- xdecodekeyevent
- xdecodemotionevent
- xdecodeunknownevent
- xdecodewindowattributes
- xdecodexcolor
- xdefaultcolormap
- xdefaultrootwindow
- xdefaultscreen
- xdestroyregion
- xdestroywindow
- xdrawarc
- xdrawline
- xdrawrectangle
- xevent-><event>
- xevent-type
- xfillarc
- xfillrectangle
- xflush
- xfreecolormap
- xfreegc
- xgetdefault
- xgetwindowattributes
- xintersectregion!
- xloadfont
- xmake-color
- xmake-event
- xmake-gcvalues
- xmake-setwindowattributes
- xmapwindow
- xnextevent
- xnextevent!
- xopendisplay
- xpending
- xputbackevent
- xquerypointer
- xquerytree
- xscreencount
- xsetforeground
- xsetfunction
- xsetregion
- xsetwindowattributes-event_mask!
- xstorename
- xsubtractregion!
- xtranslatecoordinates
- xunionrectspecswithregion!
- xunionregion!
- xunloadfont
- )))
-
-
-(with-working-directory-pathname
- (directory-pathname (current-load-pathname))
- (lambda ()
-
- (let ((swat-env (->environment '(SWAT))))
- ;; These get overriden when TK is loaded
- (environment-define-name swat-env 'TK-DOEVENTS (lambda () 'TK-DOEVENTS))
- (environment-define-name swat-env 'TK-INIT (lambda () 'TK-INIT)))
-
- ;; Dynamically load the microcode. Order important.
- (load "dynload/scxl")
- (load "dynload/tcl")
- (load "dynload/tk")
- (load "dynload/uitk")
-
- ;; And now the Scheme level
- ;;(load "scc-macros")
- ;;(load "uitk-macros")
-
- ((access with-directory-rewriting-rule
- (->environment '(RUNTIME COMPILER-INFO)))
- (working-directory-pathname)
- (pathname-as-directory "lib/swat")
- (lambda ()
- (let ((load
- (lambda (file)
- (load file '(SWAT)))))
- (load "control-floating-errors")
- (load "structures")
- (load "structures2")
- (load "generics")
- (load "uitk")
- (load "xlibCONSTANTS")
- (load "mit-xlib")
- (load "tk-mit")
- (load "mit-xhooks")
- (load "widget-mit")
- (load "baseobj")
- (load "widget")
- (load "geometry")
- (load "simple")
- (load "canvas")
- (load "menu")
- (load "text")
- ;;(load "rtest")
- ;;(load "btest")
- )))))
+++ /dev/null
-;;; -*- Scheme -*-
-
-;;; <MenuItem> class
-
-(define *all-menus* '())
-
-(define (MenuItem.Menu item)
- (MenuRecord.Menu (MenuItem.MenuRecord item)))
-
-(define (find-menu-record menu)
- (let loop ((prev #F)
- (rest *all-menus*))
- (cond ((null? rest)
- (error "Find-Menu-Record: Can't find record" menu))
- ((null? (weak-car rest))
- (if prev
- (weak-set-cdr! prev (weak-cdr rest))
- (set! *all-menus* (weak-cdr rest)))
- (loop prev (weak-cdr rest)))
- ((eq? (MenuRecord.Menu (weak-car rest)) menu)
- (weak-car rest))
- (else (loop rest (weak-cdr rest))))))
-
-(define (add-sub-menu menu sub-menu . options)
- (set-TKWidget%.do-not-gc-protect! sub-menu #T)
- (UIObj-protect-from-gc! sub-menu menu) ; Keep daddy alive ...
- ;; Above must happen *before* add-child!, since the menu may already
- ;; have a drawing surface and then the sub-menu would get it
- ;; immediately and the protection wouldn't be removed. Get it?
- (add-child! menu sub-menu)
- (apply add-to-menu menu 'cascade
- '-menu (lambda () (tk-widget->pathname sub-menu))
- options))
-
-(define (menuitem-set-callback! me proc)
- (if (not (MenuItem.Index me))
- (error "SET-CALLBACK!: menu item deleted!" me))
- (set-MenuItem.%callback! me proc)
- (ask-widget (MenuItem.Menu me)
- `(entryconfigure
- ,(MenuItem.Index me)
- -command
- ,(string-append "SchemeCallBack "
- (number->string
- (hash proc *our-hash-table*))))))
-
-(define (delete-menuitem! item)
- (let ((menu-record (MenuItem.MenuRecord item))
- (index (MenuItem.Index item)))
- (let loop ((rest (MenuRecord.Items menu-record))
- (count 0)
- (prev #F))
- (cond ((null? rest)
- (ask-widget (MenuRecord.Menu menu-record)
- `(delete ,(MenuItem.index item)))
- (set-MenuItem.index! item #F)
- 'DONE)
- ((eq? (car rest) item)
- (if (not (= count Index))
- (error "Delete-MenuItem!: Inconsistent count"
- count index me))
-
- (if prev
- (set-cdr! prev (cdr rest))
- (set-MenuRecord.Items! menu-record (cdr rest)))
- (loop (cdr rest) (+ count 1) prev))
- ((= count index)
- (error "Delete-MenuItem!: Missing item" count index me))
- (else
- (if (> count index)
- (Set-MenuItem.Index! (car rest) (- count 1)))
- (loop (cdr rest) (+ count 1) rest))))))
-
-(define (menuitem-ask-widget me command)
- ;; For example:
- ;; (Ask-Widget me `(configure -label "George"))
- ;; becomes
- ;; (Ask-Widget menu `(entryconfigure index -label "George"))
- (if (or (eq? (car command) 'configure)
- (string=? (car command) "configure"))
- (ask-widget (MenuItem.Menu me)
- `(entryconfigure ,(MenuItem.Index me)
- ,@(cdr command)))
- (error "MenuItem-Ask-Widget: must be configure command"
- me command)))
-
-(define (add-to-menu menu which-kind . options)
- ;; Which-Kind should be 'CHECKBUTTON, 'COMMAND,
- ;; 'RADIOBUTTON, or 'SEPARATOR. Cascades are made using
- ;; Add-Sub-Menu, above
- (let ((menu-record (find-menu-record menu)))
- (let ((items (MenuRecord.Items Menu-Record)))
- (let ((new-item
- (make-menuitem menuitem-ask-widget
- 'invalid
- menuitem-set-callback!
- menu-record
- '()
- (length items))))
- (ask-widget menu `(add ,which-kind ,@options))
- (set-MenuRecord.Items! Menu-Record
- (append! items (list new-item)))
- new-item))))
-
+++ /dev/null
-;;; -*- Scheme -*-
-
-#| ******************************
-
-MIT-XHOOKS defines the level of the system that handles event
-processing, and the manipulation of UITK objects just above the X
-level (defined in MIT-XLIB). This layer will differ between
-MIT-Scheme and Scheme-to-C
-
-This file tries to include all the functions that actually call X so
-that the other parts of the system can be rebuilt on a different
-substrate.
-
- ****************************** |#
-
-#|
-Not used?
-
-(define (with-window display title desired-size context receiver)
- ;; Call RECEIVER with UITKwindow and actual size
- (let* ((window (create-top-level-x-window
- display title desired-size context)))
- (XMapWindow display window)
- (report-window-size display window receiver)))
-
-(define (report-window-size display window receiver)
- (get-window-attributes display window
- (lambda (x y width height . others)
- others
- (receiver (make-uitkwindow display window)
- (make-size width height)
- x
- y))))
-
-
-(define (create-top-level-x-window display title desired-size context)
- (let ((window
- (XCreateSimpleWindow
- display
- (XDefaultRootWindow display) ; Parent is root window
- 0 ; X
- 0 ; Y
- (size.width desired-size) ; Width
- (size.height desired-size) ; Height
- (context.BorderWidth context)
- (context.Border context)
- (context.Background context))))
- (XStoreName display window title)
- window))
-
-
-(define (destroy-window w)
- (let ((Xwindow (UITKWindow.XWindow w)))
- (XDestroyWindow (UITKWindow.XDisplay w) Xwindow)))
-
-
-
-
-
-|#
-
-\f
-;;;;UITK main loop
-
-#| In general, the system will have two threads running -- the
-ordinary REP and the UITK thread, which processes events for the
-widgets.
-
-When an event is signalled, it is placed (at interrupt level) on a
-queue, which is processed at user level by the UITK thread main loop
-|#
-
-;;;UITK thread will wake up at at least this interval, since it needs
-;;;to clean up objects labelld for destruction by the GC, even if
-;;;there are no events to process.
-
-(define *UITK-INTERVAL* (* 30 1000)) ; 30 seconds, in milliseconds
-
-(define uitk-queue 'later) ;code that processes events
-(define idle-queue 'later) ;not used in MIT version
-(define the-agenda 'later) ;processing scheduled by AFTER-DELAY
-(define uitk-thread 'later)
-(define more-work-to-do #F)
-(define uitk-timer #F)
-
-#| #############################################################
-This is some debugging stuff for probing the space usage.
-|#
-
-
-(DEFINE LOOP-COUNTER 0)
-(DEFINE EVENT-COUNTER 0)
-(DEFINE MORE-COUNTER 0)
-(DEFINE SUSPEND-COUNTER 0)
-(DEFINE LOOP-TRACE)
-(DEFINE READ-QUEUE-TRACE)
-(DEFINE RUN-QUEUE-TRACE)
-(define ALLOW-FREE-TRACE? #T)
-
-(define (clear-counters!)
- (SET! LOOP-COUNTER 0)
- (SET! EVENT-COUNTER 0)
- (SET! MORE-COUNTER 0)
- (SET! SUSPEND-COUNTER 0)
- 0)
-
-(define ignore-repl #F)
-
-(define (show-counters)
- (pp
- `(events: , event-counter loop: ,loop-counter more: ,more-counter suspend: ,suspend-counter)))
-
-(define (make-free-trace n)
- (cons 0 (make-vector n #f)))
-
-(define (copy-free-traces)
- (fluid-let ((allow-free-trace? #f))
- (vector (cons (car loop-trace) (vector-copy (cdr loop-trace)))
- (cons (car read-queue-trace) (vector-copy (cdr read-queue-trace)))
- (cons (car run-queue-trace) (vector-copy (cdr run-queue-trace))))))
-
-(define (record-free-pointer trace)
- (if allow-free-trace?
- (let-syntax ((ucode-primitive
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply make-primitive-procedure (cdr form))))))
- (vector-set! (cdr trace)
- (car trace)
- ((ucode-primitive primitive-get-free 1) 26))
- (set-car! trace
- (if (fix:= (fix:+ (car trace) 1) (vector-length (cdr trace)))
- 0
- (fix:+ (car trace) 1))))))
-
-#| #############################################
-end of debugging stuff
-
-|#
-
-
-(define (make-uitk-thread)
- (set! uitk-thread
- (create-thread (create-thread-continuation) thread-start))
- (kick-uitk-thread))
-
-(define initial-thread-state 'later)
-
-(define (thread-start)
- (call-with-current-continuation
- (lambda (start-up)
- (set! initial-thread-state start-up)
- (uitk-thread-main-loop))))
-
-(define (restart-uitk)
- (restart-thread uitk-thread #T (lambda () (initial-thread-state 'go))))
-
-(let-syntax ((last-reference
- (sc-macro-transformer
- (lambda (form environment)
- (let ((variable (close-syntax (cadr form) environment)))
- `(LET ((FOO ,variable))
- (SET! ,variable #F)
- FOO))))))
-
- (define (uitk-thread-main-loop)
- (define (flush-all-displays)
- (for-each flush-queued-output
- (protection-list-referenced-elements
- display-protection-list)))
- (define (run thunk) (thunk))
- (SET! LOOP-COUNTER 0)
- (SET! EVENT-COUNTER 0)
- (SET! MORE-COUNTER 0)
- (SET! SUSPEND-COUNTER 0)
- (let process-loop ()
- (SET! LOOP-COUNTER (+ 1 LOOP-COUNTER))
- (block-thread-events)
- (set! more-work-to-do #F)
- ;; Read out the event/idle/delayed thunks
- (let ((events (read-and-empty-queue! uitk-queue))
- (idle (read-and-empty-queue! idle-queue))
- (delayed (read-and-empty-agenda! the-agenda))
- )
- (unblock-thread-events)
- ;;process the thinks that were read, and clear the variables so
- ;; the thunks can GC away after they are run.
- (for-each run (last-reference events))
- (for-each run (last-reference idle))
- (for-each run (last-reference delayed))
- ;; Allow tk to do its pending events (includes handling callbacks)
- (tk-doevents)
- ;;check if a GC has occurred (the GC daemon sets the flag) and
- ;;finalize the GC'd objects.
- (if (with-absolutely-no-interrupts
- (lambda ()
- (let ((result *UITK:GC-HAS-OCCURRED?*))
- (set! *UITK:GC-HAS-OCCURRED?* #F)
- result)))
- (begin ; Clean up after GC
- (finalize-uitk-objects)
- (close-lost-displays-daemon)))
- (let ((more? (begin (block-thread-events) more-work-to-do)))
- ;; MORE? is #T if work arrived while we were handling the
- ;; previously grabbed event/idle thunks
- (flush-all-displays)
- (IF (OR MORE? IGNORE-REPL)
- (begin
- (unblock-thread-events)
- (SET! MORE-COUNTER (+ 1 MORE-COUNTER))
- (process-loop)) ; Don't give up CPU yet
- (begin
- (let ((tk-wake-up (get-interval-to-tk-wakeup))
- (delayed-wake-up (get-interval-to-next-delayed-event)))
- ;;get time to wake up to for next TK event or
- ;;delayed event
- (let ((wake-up (if tk-wake-up
- (if delayed-wake-up
- (min tk-wake-up delayed-wake-up)
- tk-wake-up)
- delayed-wake-up)))
- ;;flush the current timer event if there is one
- ;;and register the next actual time to wake up
- (if uitk-timer (deregister-timer-event uitk-timer))
- (set! uitk-timer
- (register-timer-event (if wake-up
- (min wake-up *UITK-INTERVAL*)
- *UITK-INTERVAL*)
- (lambda () (set! uitk-timer #F))))))
- ;;now go to sleep. The timer event, or an X event,
- ;;will wake us up. We suspend with events still
- ;;blocked to avoid an interrupt hole, whereby an
- ;;event is delivered but doesn't wake us up.
- ;;Suspending atomically unblocks events in the right
- ;;way to prevent this.
- (suspend-current-thread)
- (SET! SUSPEND-COUNTER (+ SUSPEND-COUNTER 1))
- ;;(allow-thread-event-delivery)
- (unblock-thread-events)
- (process-loop))))))
- ))
-
-(define (with-uitk-thread-errors-captured thunk)
- (define newline-string "
-")
- (call-with-current-continuation
- (lambda (exit-continuation)
- (fluid-let
- ((standard-error-handler
- (lambda (error-condition)
- (fluid-let ((standard-error-handler standard-error-handler))
- (newline)
- (newline)
- (display
- (string-append
- ";Error in UITK thread:" newline-string
- ";" (condition/report-string error-condition)
- newline-string
- ";To debug, type (debug (unhash "
- (number->string
- (hash (condition/continuation error-condition)))
- "))"))
- (newline)
- (newline)
- (exit-continuation 'punt-o-rama)))))
- (thunk)))))
-
-;;;This forces the UITK thread to wake up
-(define kick-uitk-thread
- (let ((*uitk-thread-kicked?* #F))
- (lambda ()
- (if (not *uitk-thread-kicked?*)
- (begin
- (set! *uitk-thread-kicked?* #T)
- (when-idle!
- ;; When-Idle! will make the thread awaken
- (lambda ()
- (set! *uitk-thread-kicked?* #F))))))))
-
-;;; Redefine hook found in mit-xlib. Running the UITK loop will flush
-;;; all displays.
-(define flush-display-hook kick-uitk-thread)
-
-(define (when-idle! thunk)
- (signal-thread-event
- uitk-thread
- (lambda ()
- ;; Interrupt level
- (set! more-work-to-do #T)
- (enqueue! idle-queue thunk))))
-
-\f
-;;; Registering events for processing
-
-#| For each display connection, we have a permanently
- registered request to process input from a particular file.
- FORK-TO-WAIT-ON creates such a registration. When events come in
- on the display connection, the CHILD-WORK-CODE is enqueued for
- user-level execution. If the CHILD-WORK-CODE has been GCed away,
- then code to deregister the handler is executed.
-|#
-
-(define fork-to-wait-on
- (let ()
- ;; This group of procedures can NOT be lexically nested inside of
- ;; fork-to-wait-on because we want the link from the enqueued
- ;; thunk to child-work-code to be a weak pointer.
- ;; Thus child-work-code should not be lexically visible to
- ;; these procedures. If we had a strong pointer, then the
- ;; registry would point to the child work code and hence to the
- ;; application, so applications could never be GCd.
- (define (try-to-run weak)
- (lambda ()
- (let ((code (weak-car weak))
- (wcdr (weak-cdr weak)))
- (if (and code (not (scxl-destroyed? (weak-car wcdr))))
- (begin
- ;; Reinstall interrupt handler, then run user code
- (register-io-thread-event
- (XConnectionNumber (weak-car wcdr))
- 'READ
- uitk-thread
- (lambda (mode)
- mode
- ((weak-cdr wcdr))))
- (code))))))
- (define (call-if-still-there weak)
- ;; WEAK is a weak-list:
- ;; (desired-code-thunk display #F)
- ;; In normal use, desired-code-thunk is #F iff the application
- ;; has vanished. This code creates a procedure to run at
- ;; interrupt level, replaces the #F with the handler, and
- ;; returns the handler to the caller.
- (let ((result
- (lambda ()
- ;; Interrupt level
- (let ((code (weak-car weak)))
- (if code
- (begin
- (set! more-work-to-do #T)
- (enqueue! uitk-queue (try-to-run weak))
- 'done
- ))))))
- (weak-set-cdr! (weak-cdr weak) result)
- result))
- (lambda (display child-work-code child-idle-code)
- child-idle-code ; Not used by MIT/GNU Scheme
- (let ((file (XConnectionNumber display))
- (weak (weak-cons child-work-code (weak-cons display #F))))
- (without-interrupts
- (lambda ()
- (register-io-thread-event
- file
- 'READ
- uitk-thread
- (lambda (mode)
- mode
- (call-if-still-there weak)))))))))
-
-(define (destroy-registration registration)
- (deregister-io-thread-event registration)
- 'OK)
-
-(define (shut-down-event-server display-number)
- (deregister-io-descriptor-events (%XConnectionNumber display-number) 'READ))
-\f
-
-;;;Delayed events
-
-;;; Schedule an action to be done later in the UITK thread
-;;; Implementation uses agendas from the 6.001 book
-
-
-(define (after-delay delay action-thunk) ; delay in secs
- (let ((now (real-time-clock)))
- (signal-thread-event
- uitk-thread
- (lambda ()
- ;; Interrupt level
- (set! more-work-to-do #T)
- (add-to-agenda! (+ (* delay 1000) now) ; in msecs
- action-thunk
- the-agenda)))))
-
-(define (make-agenda)
- (list '*agenda*))
-
-(define (segments agenda) (cdr agenda))
-(define (first-segment agenda) (car (segments agenda)))
-(define (rest-segments agenda) (cdr (segments agenda)))
-(define (set-segments! agenda segments) (set-cdr! agenda segments))
-(define (empty-segments? agenda)
- (null? (segments agenda)))
-
-(define (add-to-agenda! time action agenda)
- (define (add-to-segments! segments)
- (if (= (segment-time (car segments)) time)
- (enqueue! (segment-queue (car segments))
- action)
- (let ((rest (cdr segments)))
- (if (or (null? rest)
- (> (segment-time (car rest)) time))
- (insert-new-time! time action agenda)
- (add-to-segments! rest)))))
- (without-interrupts
- (lambda ()
- (let ((segs (segments agenda)))
- (if (null? segs)
- (insert-new-time! time action agenda)
- (add-to-segments! segs))))))
-
-
-(define (insert-new-time! time action agenda)
- (let ((segs (segments agenda))
- (q (make-queue)))
- (enqueue! q action)
- (let ((new-segment (make-time-segment time q)))
- (if (null? segs)
- (set-segments! agenda (list new-segment))
- (set-cdr! segs
- (cons new-segment (cdr segs)))))))
-
-(define (read-and-empty-agenda! agenda)
- (let ((now (real-time-clock)))
- (define (find-all-events-up-to-now events)
- (if (empty-segments? agenda)
- events
- (let ((current-segment (first-segment agenda)))
- (if (> (segment-time current-segment) now)
- events
- (let ((q (segment-queue current-segment)))
- (if (empty-queue? q)
- (begin (set-segments! agenda (rest-segments agenda))
- (find-all-events-up-to-now events))
- (find-all-events-up-to-now
- (append events (list (dequeue! q))))))))))
- (without-interrupts
- (lambda ()
- (find-all-events-up-to-now '())))))
-
-(define (empty-agenda? agenda)
- (without-interrupts
- (lambda ()
- (or (empty-segments? agenda)
- (and (empty-queue? (segment-queue (first-segment agenda)))
- (null? (rest-segments agenda)))))))
-
-(define (make-time-segment time queue)
- (cons time queue))
-
-(define (segment-time s) (car s))
-(define (segment-queue s) (cdr s))
-
-(define (current-time agenda)
- (without-interrupts
- (lambda ()
- (and (not (null? (segments agenda)))
- (segment-time (first-segment agenda))))))
-
-(define (get-interval-to-next-delayed-event)
- (let ((agenda-time (current-time the-agenda)))
- (and agenda-time
- (- agenda-time (real-time-clock)))))
-
-;;; make-enqueueable-thunk is unused. Part of an alternate
-;;; implementation, where the thunk doesn't hold on to the
-;;; application, so that the application can GC away even if there are
-;;; events scheduled.
-
-(define make-enqueueable-thunk
- (let ()
- (define (try-to-run weak)
- (lambda ()
- (let ((code (weak-car weak)))
- (if code
- (debug-print code)
- (debug-print 'vanished))
- (if code (code)))))
- (lambda (thunk)
- (try-to-run (weak-cons thunk 'IGNORED)))))
-
-\f
-;;;; UITK objects. We almost never work with bare X objects.
-
-
-
-;;;convert an Xevent (string) to a UITK event structure. This defines
-;;;the dispatch only. The actual make-event procedures for the
-;;;various event types are defined in UITK.scm
-
-(define XEvent-><Event>
- (let ((X-Event-Converters
- (make-vector LASTEVENT
- (lambda (event)
- (decode-unknown-event event
- (lambda (type serial sent? display window)
- type serial sent? display
- (make-unknown-event 'UNUSUAL event window)))))))
-
- (define (key name)
- (lambda (e)
- (decode-key-event e
- (lambda (type serial sent? display window root subwindow
- time x y RootX RootY state keycode SameScreen?)
- type serial sent? display root subwindow
- time RootX RootY state keycode SameScreen?
- (make-point-event name e window (Make-Point X Y))))))
- (vector-set! X-Event-Converters KeyPress (key 'KEY-PRESS))
- (vector-set! X-Event-Converters KeyRelease (key 'KEY-RELEASE))
-
- (define (button name)
- (lambda (e)
- (decode-button-event e
- (lambda (type serial sent? display window root subwindow
- time x y RootX RootY state button SameScreen?)
- type serial sent? display root subwindow
- time RootX RootY state button SameScreen?
- (make-point-event name e window (Make-Point X Y))))))
- (vector-set! X-Event-Converters ButtonPress (button 'BUTTON-PRESS))
- (vector-set! X-Event-Converters ButtonRelease (button 'BUTTON-RELEASE))
-
- (define (motion name)
- (lambda (e)
- (decode-motion-event e
- (lambda (type serial sent? display window root subwindow
- time x y RootX RootY state IsHint SameScreen?)
- type serial sent? display window root
- subwindow time RootX RootY state IsHint SameScreen?
- (make-point-event name e window (Make-Point X Y))))))
- (vector-set! X-Event-Converters MotionNotify (motion 'POINTER-MOTION))
-
- (define (crossing name)
- (lambda (e)
- (decode-crossing-event
- e
- (lambda (type serial sent? display window root subwindow
- time x y RootX RootY mode detail SameScreen?
- Focus? state)
- type serial sent? display root subwindow
- time RootX RootY mode detail SameScreen? Focus? state
- (make-point-event name e window (Make-Point X Y))))))
- (vector-set! X-Event-Converters EnterNotify (crossing 'ENTER))
- (vector-set! X-Event-Converters LeaveNotify (crossing 'LEAVE))
-
- ; (vector-set! X-Event-Converters ConfigureNotify ...)
- ; (vector-set! X-Event-Converters FocusIn ...)
- ; (vector-set! X-Event-Converters FocusOut ...)
- ; (vector-set! X-Event-Converters KeymapNotify ...)
-
- (define (expose-fn type-name)
- (lambda (e)
- (decode-expose-event
- e
- (lambda (type serial sent? display
- window x y width height count)
- type serial sent? display count width height
- (make-rectangle-event
- type-name e window (Make-Point x y)
- width height)))))
- (vector-set! X-Event-Converters Expose (expose-fn 'EXPOSURE))
-
- ; (vector-set! X-Event-Converters GraphicsExpose ...)
- ; (vector-set! X-Event-Converters NoExpose ...)
- ; (vector-set! X-Event-Converters VisibilityNotify ...)
- ; (vector-set! X-Event-Converters CreateNotify ...)
- ; (vector-set! X-Event-Converters DestroyNotify ...)
- ; (vector-set! X-Event-Converters UnmapNotify ...)
- ; (vector-set! X-Event-Converters MapNotify ...)
- ; (vector-set! X-Event-Converters MapRequest ...)
- ; (vector-set! X-Event-Converters ReparentNotify ...)
- ; (vector-set! X-Event-Converters ConfigureNotify ...)
- ; (vector-set! X-Event-Converters ConfigureRequest ...)
- ; (vector-set! X-Event-Converters GravityNotify ...)
- ; (vector-set! X-Event-Converters ResizeRequest ...)
- ; (vector-set! X-Event-Converters CirculateNotify ...)
- ; (vector-set! X-Event-Converters CirculateRequest ...)
- ; (vector-set! X-Event-Converters PropertyNotify ...)
- ; (vector-set! X-Event-Converters SelectionClear ...)
- ; (vector-set! X-Event-Converters SelectionRequest ...)
- ; (vector-set! X-Event-Converters SelectionNotify ...)
- ; (vector-set! X-Event-Converters ColormapNotify ...)
- ; (vector-set! X-Event-Converters ClientMessage ...)
- ; (vector-set! X-Event-Converters MappingNotify ...)
- (lambda (XEvent)
- ((vector-ref X-Event-Converters (xevent-type XEvent))
- XEvent))))
-
-;;This places the XEvent in the given string. It uses the side effect
-;;to avoid allocating a new string and generating garbage in the inner
-;;event processing loop
-
-(define (get-x-event display event-string)
- (if (zero? (XPending display))
- #F
- (XNextEvent! display event-string)))
-
-
-\f
-;;; open a display and return the numeric hook
-
-(define (open-display)
- (let ((xdisplay (XOpenDisplay "")))
- (if (or (and (number? xdisplay) (zero? xdisplay))
- (and (pair? xdisplay) (number? (cdr xdisplay))
- (zero? (cdr xdisplay))))
- (error 'OPEN-DISPLAY "Could not open display")
- xdisplay)))
-
-(define (string->color display)
- (lambda (string)
- (let ((result
- (XAllocNamedColor display
- (XDefaultColormap display
- (XDefaultScreen display))
- string)))
- ;; Result is (Status ScreenColor ExactColor)
- (if (zero? (car result))
- #F ; Error status
- (list-ref result 1)))))
-
-
-#| Fonts don't work yet
-(define (string->font display)
- (lambda (string)
- (XLoadFont display string)))
-|#
-
-\f
-;;;; Event-sensitive windows.
-
-(define (Generate-Events! UITKWindow mask)
- (let ((attributes (XMake-SetWindowAttributes))
- (window (UITKWindow.XWindow UITKWindow))
- (display (UITKWindow.XDisplay UITKWindow)))
- (XSetWindowAttributes-Event_Mask! attributes mask)
- (XChangeWindowAttributes display window CWEventMask attributes))
- (let ((result (XGetWindowAttributes display window)))
- (if (= (list-ref result 0) 0)
- (error 'GENERATE-EVENTS!
- "XGetWindowAttributes failed ~A" result)
- (list-ref result 1))))
-
-
-(define (handler->sensitivity handler)
- (case (car handler)
- ((#T) NoEventMask)
- ((KEY-PRESS) KeyPressMask)
- ((KEY-RELEASE) KeyReleaseMask)
- ((BUTTON-PRESS) ButtonPressMask)
- ((BUTTON-RELEASE) ButtonReleaseMask)
- ((ENTER) EnterWindowMask)
- ((CONFIGURE-NOTIFY) StructureNotifyMask)
- ((LEAVE) LeaveWindowMask)
- ((POINTER-MOTION) PointerMotionMask)
- ; (bit-or PointerMotionMask PointerMotionHintMask)
- ((BUTTON-1-MOTION) Button1MotionMask)
- ((BUTTON-2-MOTION) Button2MotionMask)
- ((BUTTON-3-MOTION) Button3MotionMask)
- ((BUTTON-4-MOTION) Button4MotionMask)
- ((BUTTON-5-MOTION) Button5MotionMask)
- ((BUTTON-MOTION) ButtonMotionMask)
- ; (bit-or ButtonMotionMask PointerMotionHintMask)
- ((KEYMAP-STATE) KeyMapStateMask)
- ((EXPOSURE) ExposureMask)
- ((VISIBITY-CHANGE) VisibilityChangeMask)
- ((STRUCTURE-NOTIFY) StructureNotifyMask)
- ;; I don't understand ResizeRedirect or substructure stuff
- ((FOCUS-CHANGE) FocusChangeMask)
- ((PROPERTY) PropertyChangeMask)
- ;; Ignoring colormap and owner grab
- (else (error 'HANDLER->SENSITIVITY "Unknown event type ~A" (car handler)))
- ))
-
-(define (bit-or . integers)
- (bit-string->unsigned-integer
- (reduce bit-string-or (unsigned-integer->bit-string 32 0)
- (map (lambda (n) (unsigned-integer->bit-string 32 n))
- integers))))
-\f
-;;;; UITK level "X" calls.
-
-#| In UITK, we almost never work with bare X objects. Rather there
-are two levels of embedding. The first is the "wrapper" which is used
-for garbage collection (see MIT-Xlib). This wrapped object is then
-embedded in a UITK structure that bundles together associated
-information. (For example, a UITKWindow holds both an X window and
-its associated X display.) Thus, a user-level procedure such as
-Drawline, operates on UITK windows. It is defined in terms of a lower
-level XDrawline (which operates on wrapped windows) which in tern is
-defined in terms of the X primitive %XDrawline. |#
-
-
-;;;; Graphics contexts
-
-(define (make-simple-graphics-context uitkwindow)
- (let ((dpy (UITKWindow.XDisplay uitkwindow))
- (win (UITKWindow.XWindow uitkwindow)))
- (XCreateGC dpy win 0 (xmake-gcvalues))))
-
-(define (make-colored-graphics-context uitkwindow color-string)
- (let ((gc (make-simple-graphics-context uitkwindow))
- (dpy (UITKWindow.XDisplay uitkwindow)))
- (let ((color ((string->color dpy) color-string)))
- (if (color? color)
- (begin
- (XSetForeground dpy gc color)
- gc)
- (error 'make-colored-graphics-context
- "Can't convert color name to value ~A"
- color-string)))))
-
-(define (DrawArc uitkwindow gc X Y Width Height angle1 angle2)
- (XDrawArc (UITKWindow.XDisplay uitkwindow)
- (UITKWindow.XWindow uitkwindow)
- gc x y width height angle1 angle2))
-
-(define (DrawLine uitkwindow gc X1 Y1 X2 Y2)
- (XDrawLine (UITKWindow.XDisplay uitkwindow)
- (UITKWindow.XWindow uitkwindow)
- gc x1 y1 x2 y2))
-
-(define (DrawRectangle uitkwindow gc X Y Width Height)
- (XDrawRectangle (UITKWindow.XDisplay uitkwindow)
- (UITKWindow.XWindow uitkwindow)
- gc x y width height))
-
-
-(define (FillRectangle uitkwindow gc X Y Width Height)
- (XFillRectangle (UITKWindow.XDisplay uitkwindow)
- (UITKWindow.XWindow uitkwindow)
- gc x y width height))
-
-(define (FillArc uitkwindow gc X Y Width Height angle1 angle2)
- (XFillArc (UITKWindow.XDisplay uitkwindow)
- (UITKWindow.XWindow uitkwindow)
- gc x y width height angle1 angle2))
-
-(define (ClearArea uitkwindow X Y width height exposures?)
- (XClearArea (UITKWindow.XDisplay uitkwindow)
- (UITKWindow.XWindow uitkwindow)
- x y width height exposures?))
-
-(define (flush-queued-output display)
- (xflush display))
-
-(define (GetDefaultValue display application-name variable)
- (XGetDefault display application-name variable))
-
-(define (Decode-Button-Event event receiver)
- (let ((vect (make-vector 15)))
- (XDecodeButtonEvent event vect)
- (apply receiver (vector->list vect))))
-
-(define (Decode-Configure-Event event receiver)
- (let ((vect (make-vector 13)))
- (XDecodeConfigureEvent event vect)
- (apply receiver (vector->list vect))))
-
-(define (Decode-Crossing-Event event receiver)
- (let ((vect (make-vector 17)))
- (XDecodeCrossingEvent event vect)
- (apply receiver (vector->list vect))))
-
-(define (Decode-Expose-Event event receiver)
- (let ((vect (make-vector 10)))
- (XDecodeExposeEvent event vect)
- (apply receiver (vector->list vect))))
-
-(define (Decode-Key-Event event receiver)
- (let ((vect (make-vector 15)))
- (XDecodeKeyEvent event vect)
- (apply receiver (vector->list vect))))
-
-(define (Decode-Motion-Event event receiver)
- (let ((vect (make-vector 15)))
- (XDecodeMotionEvent event vect)
- (apply receiver (vector->list vect))))
-
-(define (Decode-Unknown-Event event receiver)
- (let ((vect (make-vector 5)))
- (XDecodeUnknownEvent event vect)
- (apply receiver (vector->list vect))))
-
-(define (XEvent-Type xevent)
- (Decode-Unknown-Event xevent
- (lambda (type . others)
- others ; Ignored
- type)))
-
-(define (Decode-Window-Attributes attributes receiver)
- (let ((vect (make-vector 23)))
- (XDecodeWindowAttributes attributes vect)
- (apply receiver (vector->list vect))))
-
-(define (Get-Window-Attributes display window receiver)
- (let ((attributes (list-ref (XGetWindowAttributes display window) 1)))
- (Decode-Window-Attributes attributes receiver)))
-
-(define (Rectangle->XRegion rectangle)
- (MakeXRegion (Point.X (UITKRectangle.Offset rectangle))
- (Point.Y (UITKRectangle.Offset rectangle))
- (UITKRectangle.Width rectangle)
- (UITKRectangle.Height rectangle)))
-
-(define (MakeXRegion x y width height)
- (let ((region (XCreateRegion)))
- (XUnionRectSpecsWithRegion! x y width height region region)
- region))
-
-(define (IntersectXRegions x-region-1 x-region-2)
- (let ((region (XCreateRegion)))
- (XIntersectRegion! x-region-1 x-region-2 region)
- region))
-
-(define (UnionXRegions x-region-1 x-region-2)
- (let ((region (XCreateRegion)))
- (XUnionRegion! x-region-1 x-region-2 region)
- region))
-
-(define (CopyXRegion region)
- (UnionXRegions (XCreateRegion) region))
-
-(define (SubtractXRegions x-region-1 x-region-2)
- (let ((region (XCreateRegion)))
- (XSubtractRegion! x-region-1 x-region-2 region)
- region))
-
-(define (SetClipXRegion window graphics-context XRegion)
- (XSetRegion (UITKWindow.XDisplay window)
- graphics-context
- XRegion))
-\f
-;;;process a mouse drag.
-;;;keep reading motion events and process them
-;;;stop when there is a button release
-
-;;;This procedure is included here because of the X calls.
-
-(define (mouse-drag surface on-motion)
- ;; *** Maybe this should take an "other events handler" ***
- (let* ((UITKWindow (DrawingSurface.UITKWindow surface))
- (xdisplay (uitkwindow.xdisplay UITKWindow)))
- (without-interrupts
- (lambda ()
- (let loop ()
- (let* ((x-event (XNextEvent xdisplay))) ;**blocks?
- (Decode-Unknown-Event
- x-event
- (lambda (type serial sent? display window)
- serial sent? display window
- (cond ((eq? type MotionNotify)
- (decode-motion-event x-event
- (lambda (type serial sent? display window root subwindow
- time x y RootX RootY state IsHint SameScreen?)
- type serial sent? display window root subwindow
- time RootX RootY state IsHint SameScreen?
- (on-motion (make-point x y))))
- (loop))
- ((eq? type ButtonRelease) 'endloop)
- (else (loop)))))))))))
-\f
-;;; GC of UITK objects
-;;; this uses the protrction list mechanism implemented in MIT-Xlib
-
-(define uitk-protection-list 'later)
-
-(define (when-unreferenced obj thunk)
- (add-to-protection-list! uitk-protection-list obj thunk))
-
-(define (finalize-uitk-objects)
- (clean-lost-protected-objects uitk-protection-list
- (lambda (thunk) (thunk))))
-
-(define (finalize-uitk-objects-later)
- (set! *UITK:GC-HAS-OCCURRED?* #T)
- ;; (when-idle! finalize-uitk-objects)
- ;; Handled in the main UITK thread loop. Also calls the scxl daemon
- ;; there.
- )
-
-;;; In generating hash numbers for callbacks, etc., we use a private
-;;; hash table, separate from the system one.
-
-(define *our-hash-table* 'later)
-(define *UITK:GC-HAS-OCCURRED?* #F)
-
-#|
-
-Shutting down the event server may be necessary in UITK even though
-the event server is shut down as soon as the UITK application is
-destroyed, because the applcation and display may vanish on the same
-GC.
-
-We must explicitly destroy the tk-widgets for this display (since Xlib
-doesn't know about them). The TK widgets must be destroyed BEFORE the
-display is closed.
-
-|#
-
-(define (initialize-uitk!)
- (set! uitk-protection-list (make-protection-list))
- ;; THIS SHOULD BE PUT BACK WHEN remove-gc-daemon! GETS WRITTEN
- ;; (remove-gc-daemon! close-lost-displays-daemon)
- (add-gc-daemon! finalize-uitk-objects-later)
- (set! uitk-queue (make-queue))
- (set! idle-queue (make-queue))
- (set! the-agenda (make-agenda))
- (make-uitk-thread)
- (SCXL-Install-XCloseDisplay-Callback shut-down-event-server)
- (set! *our-hash-table* (hash-table/make 4001))
- )
-
-(initialize-uitk!)
+++ /dev/null
-;;; -*- Scheme -*-
-
-#| This file defines the SCXL library for interfacing with X. It is
-similar to Joel Bartlett's Scheme-to-C X library, except that it also
-provides support for cleaning up X objects when the corresponding
-Scheme objects are garbage collected. The low-level primitives (e.g.
-%XDrawline, %XPending) are Scheme entries to the corresponding X
-library rooutines. Microcode support for these is defined in the file
-scxl.c. Users should almost never call these routines directly, but
-instead use the SCXL level routines (e.g., XDrawline, XPending), which
-operate on Scheme objects rather than bare addresses.
-
-We are writing this library for use in UITK (called from mit-xhooks).
-We have tried to organize it so that it can be used as a general X
-library, but this has not been really tested. |#
-
-;;;; Hooks that the library calls -- these should be redefined by
-;;;; systems that use the library
-
-#| FLUSH-DISPLAY-HOOK is called at the end of every SCXL command that
-might require a display flush. In this file, it is defined as a
-no-op. The UITK library redefines it to wake the thread responsible
-for handling this stuff. |#
-
-(define (flush-display-hook)
- '(when not under UITK this does nothing)
- '(replaced by mit-xhooks))
-
-#| *XCLOSEDISPLAYCALLBACKS* is a list of thunks that should be run
-before a display is closed. |#
-
-\f
-#| SCXL Primitives operate on Scheme objects that are "wrapped around"
-cells containing the bare numbers that represent X server objects, via
-a call to SCXL-WRAP. This permits us to perform finalization of X
-objects when the Scheme representatives are garbage-collected using
-the protection list mechanism described below. We use cells containing
-the numbers, rather than the numbers themselves, to permit these "bare
-objects" to be shared (e.g., in protection lists) and mutated (e.g.,
-marked as destroyed).
-
-One exception to the wrapping convention is that X events are
-represented at the lowest level as Scheme strings, and so we needn't
-worry about their garbage collection. These low-level events (called
-OS-events in UITK) are components in higher-level UITK event structures.
-
-We maintain a list of strong dependents for these objects to represent
-facts like "if you are holding on to this graphics context, then you
-must also hold on to its display." This prevents the GC from
-prematurely releasing displays (and other objects).
-
-|#
-
-;;;; SCXL Wrapping and Unwrapping
-
-;;; create a wrapped object and (optionally) place it on a protection
-;;; list for GC finalization. The wrapped object may also have
-;;; additional stuff associated with it (for example, a display will
-;;; contain information used to clean up its windows and fonts)
-;;; The "bare object" kept on the protection list is held in a cell to
-;;; allow for mutation (in particular, to mark things as being destroyed).
-
-(define (SCXL-WRAP protection-list type object strong-dependents . rest)
- (let* ((cell (make-cell object))
- (result (make-scxl-wrapper type cell strong-dependents rest)))
- (if protection-list
- (add-to-protection-list! protection-list result cell))
- result))
-
-(define (SCXL-WRAPPED? obj) (scxl-wrapper? obj))
-
-(define (type-check-wrapped-object type object)
- (if (SCXL-DESTROYED? object)
- (error "attempt to reference destroyed object" object)
- (if (and (SCXL-WRAPPED? object)
- (eq? (scxl-wrapper.type object) type))
- 'OK
- (error "wrong type wrapped-object" type object))))
-
-(define (is-type-wrapped-object type)
- (lambda (object)
- (if (SCXL-DESTROYED? object)
- (error "attempt to reference destroyed object" object)
- (and (SCXL-WRAPPED? object)
- (eq? (scxl-wrapper.type object) type)))))
-
-;;; (SCXL-UNWRAP
-;;; (SCXL-WRAP protection-list type object dependents data1 data2 ...)
-;;; (lambda (object . data-values) ....))
-
-(define (SCXL-UNWRAP wrapped receiver)
- ;; Note: this doesn't return the strong dependents
- (apply receiver (cell-contents (scxl-wrapper.wrapped-object wrapped))
- (scxl-wrapper.other-stuff wrapped)))
-
-#| A destroyed object is the Scheme representitive of an X object that
-has been destroyed. It is generally an error to attempt to use a
-destroyed object any SCXL primitive that has the effect of destroying
-a resource on the server will call SCXL-DESTROY! on the corresponding
-Scheme representative |#
-
-(define (SCXL-DESTROY! obj)
- (if (scxl-destroyed? obj)
- 'done
- (begin
- (set-cell-contents! (scxl-wrapper.wrapped-object obj) #F)
- (set-scxl-wrapper.other-stuff!
- obj
- (make-list (length (scxl-wrapper.other-stuff obj))
- #F))
- (set-scxl-wrapper.strong-dependents! obj '()))))
-
-(define (SCXL-DESTROYED? obj)
- (and (scxl-wrapped? obj)
- (eq? (cell-contents (scxl-wrapper.wrapped-object obj)) #F)))
-
-#| wrap-with-SCXL-DESTROY! runs some core procedure on a wrapped
-object and then destroys the object. The procedure will not be run if
-the object is already destroyed. The procedure may also have
-arguments other than the object to be destroyed. Nargs is the number
-of args to the core procedure. Arg-num is the number of the arg that
-is the object to be destroyed. |#
-
-(define (wrap-with-SCXL-DESTROY! nargs arg-num core)
- ;; (declare (integrable core))
- (cond ((= nargs 1)
- (lambda (arg)
- arg-num ; Not used
- (if (not (SCXL-WRAPPED? arg))
- (error "not a wrapped object: wrap-with-SCXL-DESTROY" arg))
- (if (not (SCXL-DESTROYED? arg))
- (begin
- (core arg)
- (SCXL-DESTROY! arg))
- #T)))
- ((= nargs 2)
- (lambda (arg1 arg2)
- (define interesting-arg (if (= arg-num 0) arg1 arg2))
- (if (not (SCXL-WRAPPED? interesting-arg))
- (error "not a wrapped object: wrap-with-SCXL-DESTROY" interesting-arg))
- (if (not (SCXL-DESTROYED? interesting-arg))
- (begin (core arg1 arg2)
- (SCXL-DESTROY! interestring-arg))
- #T)))
- ((= nargs 3)
- (lambda (arg1 arg2 arg3)
- (define interesting-arg
- (cond ((= arg-num 0) arg1)
- ((= arg-num 1) arg2)
- (else arg3)))
- (if (not (SCXL-WRAPPED? interesting-arg))
- (error "not a wrapped object: wrap-with-SCXL-DESTROY" interesting-arg))
- (if (not (SCXL-DESTROYED? interesting-arg))
- (begin (core arg1 arg2 arg3)
- (SCXL-DESTROY! interestring-arg))
- #T)))
- (else
- (lambda args
- (define interesting-arg
- (list-ref args arg-num))
- (if (not (SCXL-WRAPPED? interesting-arg))
- (error "not a wrapped object: wrap-with-SCXL-DESTROY" interesting-arg))
- (if (not (SCXL-DESTROYED? interesting-arg))
- (begin (apply core args)
- (SCXL-DESTROY! interestring-arg))
- #T)))))
-\f
-;;;; Protection lists
-
-#| A protection list is a list of weak pairs (scheme-object . microcode-object)
-the list is scanned at GC time so the system can finalize the
-microcode objects whose associated Scheme objects have been GC'd away |#
-
-(define (make-protection-list)
- (list 'PROTECTION-LIST))
-
-(define (add-to-protection-list! list scheme-object microcode-object)
- (with-absolutely-no-interrupts
- (lambda ()
- (set-cdr! list
- (cons (weak-cons scheme-object microcode-object)
- (cdr list))))))
-
-(define (remove-from-protection-list! list scheme-object)
- (with-absolutely-no-interrupts
- (lambda ()
- (let loop ((associations (cdr list)) (previous list))
- (if (not (null? associations))
- (if (eq? scheme-object (weak-pair/car? (car associations)))
- (set-cdr! previous (cdr associations))
- (loop (cdr associations) associations)))))))
-
-(define (clean-lost-protected-objects list cleaner)
- (let ((to-be-cleaned
- (with-absolutely-no-interrupts
- (lambda ()
- (let loop ((result '())
- (associations (cdr list))
- (previous list))
- (if (null? associations)
- result
- (if (weak-pair/car? (car associations))
- (loop result (cdr associations) associations)
- (let ((next (cdr associations)))
- (set-cdr! previous next)
- ;; Re-use associations so we don't CONS
- (set-car! associations (weak-cdr (car associations)))
- (set-cdr! associations result)
- (loop associations next previous)))))))))
- (for-each cleaner to-be-cleaned)))
-
-;;; In general, the microcode objects in SCXL are held in cells.
-;;; clean-lost-celled-objects clears the cell and runs the cleaner on the
-;;; object in the cell.
-
-(define (clean-lost-celled-objects protection-list fn)
- (clean-lost-protected-objects
- protection-list
- (lambda (cell)
- (let ((obj (atomic-read-and-clear-cell! cell)))
- (if obj (fn obj))))))
-
-(define (atomic-read-and-clear-cell! cell)
- (with-absolutely-no-interrupts
- (lambda ()
- (let ((result (cell-contents cell)))
- (set-cell-contents! cell #F)
- result))))
-
-(define (search-protection-list list predicate)
- (with-absolutely-no-interrupts
- (lambda ()
- (let loop ((associations (cdr list)))
- (and (not (null? associations))
- (let ((scheme-object (weak-car (car associations))))
- (if (and scheme-object (predicate scheme-object))
- scheme-object
- (loop (cdr associations)))))))))
-
-(define (find-in-protection-list list scheme-element)
- ;; Returns the pair whose weak-car is scheme-element
- (with-absolutely-no-interrupts
- (lambda ()
- (let loop ((associations (cdr list)))
- (and (not (null? associations))
- (let ((scheme-object (weak-car (car associations))))
- (if (and scheme-object (eq? scheme-element scheme-object))
- (car associations)
- (loop (cdr associations)))))))))
-
-(define (protection-list-referenced-elements list)
- ;; Returns a list of the Scheme-visible objects which are still
- ;; referenced
- (with-absolutely-no-interrupts
- (lambda ()
- (let loop ((associations (cdr list)))
- (cond ((null? associations)
- '())
- ((weak-pair/car? (car associations))
- (cons (weak-car (car associations))
- (loop (cdr associations))))
- (else
- (loop (cdr associations))))))))
-
-(define (protection-list-all-elements
- list dereference-ucode-object-fn)
- ;; Returns a mixed list: returns the Scheme-visible object if it
- ;; is still referenced. Otherwise returns the associated microcode
- ;; reference.
- (with-absolutely-no-interrupts
- (lambda ()
- (let loop ((associations (cdr list)))
- (cond ((null? associations)
- '())
- ((weak-pair/car? (car associations))
- (cons (weak-car (car associations))
- (loop (cdr associations))))
- (else
- (cons (dereference-ucode-object-fn
- (weak-cdr (car associations)))
- (loop (cdr associations)))))))))
-
-;;; Protection lists for SCXL objects
-
-(define display-protection-list 'INITIALIZED-LATER)
-(define region-protection-list 'INITIALIZED-LATER)
-
-\f
-;;;; Standard wrapping procedures
-
-;;; A display is wrapped along with protection lists for its windows,
-;;; fonts, etc. We need to keep track of these because when the
-;;; display is closed, these objects will be destroyed, soe need to
-;;; mark the Scheme representitives as destroyed.
-
-(define (wrap-display xdisplay)
- (define (find-default-colormaps wrapped-display)
- (let ((nscreens (%XScreenCount xdisplay)))
- (let ((vect (make-vector (+ nscreens 1) #F)))
- (do ((this-screen 0 (+ this-screen 1)))
- ((= this-screen nscreens) vect)
- (vector-set! vect this-screen
- (wrap-colormap
- wrapped-display
- (%XDefaultColormap xdisplay this-screen)))))))
- (let ((me
- (SCXL-WRAP display-protection-list
- 'scxl-display
- xdisplay
- '() ; No strong dependents
- (make-protection-list) ; Windows
- (make-protection-list) ; Fonts (not used now)
- (make-protection-list) ; Colormaps
- (make-protection-list) ; GCs
- #F ; Later ...
- #F))) ; Later ...
- (let ((stuff (scxl-wrapper.other-stuff me)))
- (set-cdr! (list-tail stuff 3)
- (list
- (wrap-window me (%XDefaultRootWindow xdisplay))
- (Find-Default-Colormaps me))))
- me))
-
-(define (scxl-display? object)
- (and (SCXL-WRAPPED? object)
- (eq? (scxl-wrapper.type object) 'scxl-display)))
-
-(define (unwrap-display dsp receiver)
- ;; Anyone who uses this must know the order of the protection lists
- ;; within a display object!
- (type-check-wrapped-object 'scxl-display dsp)
- (SCXL-UNWRAP dsp receiver))
-
-(define (display/display user-visible-display)
- (type-check-wrapped-object 'scxl-display user-visible-display)
- (SCXL-UNWRAP user-visible-display
- (lambda (display window-list font-list colormap-list gc-list
- default-root-window default-colormaps)
- window-list font-list colormap-list gc-list
- default-root-window default-colormaps ; Not used
- display)))
-
-(define (display/window-list user-visible-display)
- (type-check-wrapped-object 'scxl-display user-visible-display)
- (SCXL-UNWRAP user-visible-display
- (lambda (display window-list font-list colormap-list gc-list
- default-root-window default-colormaps)
- display font-list colormap-list gc-list
- default-root-window default-colormaps ; Not used
- window-list)))
-
-(define (display/font-list user-visible-display)
- (type-check-wrapped-object 'scxl-display user-visible-display)
- (error "display/font-list: Fonts aren't implemented yet."))
-
-(define (display/colormap-list user-visible-display)
- (type-check-wrapped-object 'scxl-display user-visible-display)
- (SCXL-UNWRAP user-visible-display
- (lambda (display window-list font-list colormap-list gc-list
- default-root-window default-colormaps)
- display window-list font-list gc-list
- default-root-window default-colormaps ; Not used
- colormap-list)))
-
-(define (display/gc-list user-visible-display)
- (type-check-wrapped-object 'scxl-display user-visible-display)
- (SCXL-UNWRAP user-visible-display
- (lambda (display window-list font-list colormap-list gc-list
- default-root-window default-colormaps)
- display window-list font-list colormap-list
- default-root-window default-colormaps ; Not used
- gc-list)))
-
-(define (display/screen/default-color-map user-visible-display)
- (type-check-wrapped-object 'scxl-display user-visible-display)
- (SCXL-UNWRAP user-visible-display
- (lambda (display window-list font-list colormap-list gc-list
- default-root-window default-colormaps)
- display window-list font-list colormap-list gc-list
- default-root-window ; Not used
- default-colormaps)))
-
-(define (display/default-root-window user-visible-display)
- (type-check-wrapped-object 'scxl-display user-visible-display)
- (SCXL-UNWRAP user-visible-display
- (lambda (display window-list font-list colormap-list gc-list
- default-root-window default-colormaps)
- display window-list font-list colormap-list gc-list
- default-colormaps ; Not used
- default-root-window)))
-
-;;; alternate name
-;;; in general, these ->names are used to extract the bare X pointers
-;;; from the SCXL objects
-(define ->xdisplay display/display)
-
-;;; notice that windows, fonts, etc. are wrapped with a protection
-;;; list for their associated displays. We are not making a separate
-;;; protection list for windows, because we aren't keeping track of
-;;; the window hierarchy pointers that X maintains. Therefore we
-;;; cannot safely destroy a window just because its Scheme
-;;; representitive disappears. On the other other hand, when the
-;;; display is closed, all the wondows go away, so we destroy their
-;;; Scheme represeatitives.
-
-(define (wrap-window display window)
- (SCXL-WRAP (display/window-list display)
- 'scxl-window
- window
- display)) ; Strong dependent
-
-(define (window/window user-visible-window)
- (type-check-wrapped-object 'scxl-window user-visible-window)
- (SCXL-UNWRAP user-visible-window (lambda (window) window)))
-
-(define ->xwindow window/window)
-
-#| Fonts aren't implemented yet. They have to be protected both on
- the display and the graphics context to correctly reflect the
- pointers maintained by X.
-
-(define (wrap-font display font)
- (SCXL-WRAP (display/font-list display) 'scxl-font
- font
- display)) ; Strong dependent
-
-(define font? (is-type-wrapped-object 'scxl-font))
-
-(define (font/font font)
- (type-check-wrapped-object 'scxl-font font)
- (SCXL-UNWRAP font (lambda (font) font)))
-
-(define ->xfont font/font)
-
-|#
-
-;;; NOTE: GCs maintain a lot of state in C. Their Scheme shadows
-;;; should have strong dependencies on these things, like the XRegion,
-;;; Foreground and Background Pixel, font, etc.
-
-(define (wrap-graphics-context display gc)
- (SCXL-WRAP (display/gc-list display)
- 'scxl-graphics-context
- GC
- display ; Strong dependent
- (make-cell #F))) ; No region
-
-(define (gc/gc gc)
- (type-check-wrapped-object 'scxl-graphics-context gc)
- (SCXL-UNWRAP gc (lambda (gc region-cell) region-cell gc)))
-
-(define (gc/region gc)
- (type-check-wrapped-object 'scxl-graphics-context gc)
- ;; Note gc/region returns a wrapped object
- (cell-contents (SCXL-UNWRAP gc
- (lambda (gc region-cell)
- gc ; Unused
- region-cell))))
-
-(define (set-gc/region! gc region)
- (type-check-wrapped-object 'scxl-graphics-context gc)
- (set-cell-contents!
- (SCXL-UNWRAP gc
- (lambda (gc region-cell)
- gc ; Unused
- region-cell))
- region)
- 'MUNGED)
-
-(define (->xgc user-visible-gc)
- (type-check-wrapped-object 'scxl-graphics-context user-visible-gc)
- (cond ((SCXL-WRAPPED? user-visible-gc)
- (gc/gc user-visible-gc))
- ((number? user-visible-gc) user-visible-gc)
- (else (error "->XGc: not a gc" user-visible-gc))))
-
-(define (wrap-colormap display colormap)
- (SCXL-WRAP (display/colormap-list display)
- 'scxl-colormap
- colormap
- display ; Strong dependent
- (make-protection-list))) ; Pixel list
-
-(define (colormap/colormap colormap)
- (type-check-wrapped-object 'scxl-colormap colormap)
- (SCXL-UNWRAP colormap
- (lambda (colormap pixels)
- pixels ; Not used
- colormap)))
-
-(define (colormap/pixel-list colormap)
- (type-check-wrapped-object 'scxl-colormap colormap)
- (SCXL-UNWRAP colormap
- (lambda (colormap pixels)
- colormap ; Not used
- pixels)))
-
-(define ->xcolormap colormap/colormap)
-
-(define (wrap-pixel display colormap pixel)
- (SCXL-WRAP (colormap/pixel-list colormap)
- 'scxl-color
- pixel
- (list display colormap))) ; Strong dependents
-
-(define color? (is-type-wrapped-object 'scxl-color))
-
-(define (pixel/pixel pixel)
- (type-check-wrapped-object 'scxl-color pixel)
- (SCXL-UNWRAP pixel (lambda (pixel) pixel)))
-
-(define ->xpixel pixel/pixel)
-
-(define (wrap-region region)
- (SCXL-WRAP region-protection-list
- 'scxl-region
- region
- #F)) ; No strong dependents
-
-(define (region/region region)
- (type-check-wrapped-object 'scxl-region region)
- (SCXL-UNWRAP region (lambda (region) region)))
-
-(define ->xregion region/region)
-\f
-#| *****************************
-Debugging kludge
-This will print a whole lot of crap. Break glass in case of emergency only.
-
-(define D_EVAL 0)
-(define D_HEX_INPUT 1)
-(define D_FILE_LOAD 2)
-(define D_RELOC 3)
-(define D_INTERN 4)
-(define D_CONT 5)
-(define D_PRIMITIVE 6)
-(define D_LOOKUP 7)
-(define D_DEFINE 8)
-(define D_GC 9)
-(define D_UPGRADE 10)
-(define D_DUMP 11)
-(define D_TRACE_ON_ERROR 12)
-(define D_PER_FILE 13)
-(define D_BIGNUM 14)
-(define D_FLUIDS 15)
-
-(define *spew-crap-out?* #T)
-
-
-(define check-space
- (let ((set-debug-flags! (make-primitive-procedure 'set-debug-flags!)))
- (lambda ()
- (let* ((status (gc-space-status))
- (free (vector-ref status 5))
- (top (vector-ref status 6))
- (space (- top free)))
- (write-line `(space ,space))
- (if (< space 2800000)
- (if *spew-crap-out?*
- (with-absolutely-no-interrupts
- (lambda ()
- (debug-print 'space-low!)
- (set-debug-flags! D_EVAL #T)
- (set! *spew-crap-out?* #F)
- 'OK))
- (begin
- (debug-print 'end 'print)
- (set-debug-flags! D_EVAL #F)
- 'OK)))))))
-
-*****************************************|#
-
-
-#| Finalization of SCXL objects. In UITK, this is scheduled to be
-done by the UITK thread. Other systems may schedule it to be done
-differently, or done immediately. If this is scheduled in the GC, the
-assumptions about (not) interrupt locking the protection lists may be
-incorrect. WATCH OUT!
-
-Note that this daemon has to call the lowest level % primitives rather
-than the wrapped version for lost objects in the cases where the
-wrappers have been lost and we have only the X pointers remianing.
-|#
-
-(define (close-lost-displays-daemon)
- ;; Step one: clean up any displays that have GCed away
- (clean-lost-celled-objects display-protection-list XCloseDisplayByNumber)
- ;; Step two: clean up any regions that have GCed away
- (clean-lost-celled-objects region-protection-list %XDestroyRegion)
- ;; Step three: run through all displays that we DO have
- ;; handles on, and release fonts/colomaps/gcs that we do
- ;; NOT have handles on.
- ;; *NOTE*: We do >>not<< close windows that we've lost handles on,
- ;; because X maintains gazillions of pointers to them that we aren't
- ;; tracking.
- (for-each
- cleanup-vanished-objects-for-display
- (protection-list-referenced-elements display-protection-list)))
-
-(define (cleanup-vanished-objects-for-display display)
- (if (not (SCXL-DESTROYED? display))
- (unwrap-display
- display
- (lambda (display-number windows fonts colormaps gcs
- default-root-window default-colormaps)
- windows fonts default-root-window default-colormaps ; Don't GC these!
- (clean-lost-celled-objects
- colormaps
- (lambda (colormap-number)
- (%XFreeColorMap display-number colormap-number)))
- #| ****************************************
- By rights, we should release unused colors from all
- of the allocated color maps *and* the default color
- map of each screen. However, this would require us
- to keep track of the foreground and background
- color in graphics contexts since X keeps these
- pointers for us.
- When we fix this, it should use the protection list iterators
- (if colormaps
- (do ((associations (cdr colormaps) (cdr associations)))
- ((null? associations))
- (let* ((colormap (weak-car (car associations)))
- (pixels (colormap/pixel-list colormap)))
- (if (not (null? pixels))
- (clean-lost-celled-objects
- pixels
- (lambda (pixel)
- (%XFreeColor display-number **doens't work
- (->colormap colormap)
- (-> pixel pixel))))))))
- ******************************************** |#
- (clean-lost-celled-objects
- gcs
- (lambda (gc-number) (%XFreeGC display-number gc-number)))))))
-
-
-\f
-;;;; Primitives written in C
-
-(define-primitives ; X Operations
- (%XAllocNamedColor 5)
- (%XChangeWindowAttributes 4)
- (%XCheckMaskEvent 3)
- (%XClearArea 7)
- (%XClearWindow 2)
- (%XCloseDisplay 1)
- (%XConnectionNumber 1)
- (%XCreateGC 4)
- (%XCreateRegion 0)
- (%XCreateSimpleWindow 9)
- (%XDecodeButtonEvent 2)
- (%XDecodeConfigureEvent 2)
- (%XDecodeCrossingEvent 2)
- (%XDecodeExposeEvent 2)
- (%XDecodeKeyEvent 2)
- (%XDecodeMotionEvent 2)
- (%XDecodeUnknownEvent 2)
- (%XDecodeWindowAttributes 2)
- (%XDecodeXColor 2)
- (%XDefaultColormap 2)
- (%XDefaultRootWindow 1)
- (%XDefaultScreen 1)
- (%XDestroyRegion 1)
- (%XDestroyWindow 2)
- (%XDrawArc 9)
- (%XDrawLine 7)
- (%XDrawRectangle 7)
- (%XFillArc 9)
- (%XFillRectangle 7)
- (%XFlush 1)
- (%XFreeColormap 2)
- (%XFreeGC 2)
- (%XGetDefault 3)
- (%XGetWindowAttributes 3)
- (%XInitSCXL! 0)
- (%XIntersectRegion 3)
- (%XLoadFont 2)
- (%XMapWindow 2)
- (%XNextEvent 2)
- (%XOpenDisplay 1)
- (%XPending 1)
- (%XPutBackEvent 2)
- (%XQueryPointer 3)
- (%XQueryTree 2)
- (%XScreenCount 1)
- (%XSetForeground 3)
- (%XSetFunction 3)
- (%XSetRegion 3)
- (%XStoreName 3)
- (%XSubtractRegion 3)
- (%XSync 2)
- (%XSynchronize 2)
- (%XTranslateCoordinates 6)
- (%XUnionRegion 3)
- (%XUnionRectSpecsWithRegion! 6)
- (%XUnloadFont 2))
-
-(define-primitives ; X Data Structure constructors
- (%XMake-Color 0)
- (%XMake-Event 0)
- (%XMake-GCValues 0)
- (%XMake-GetWindowAttributes 0)
- (%XMake-SetWindowAttributes 0)
- (%XMake-Window 0) ; Hold a window identifier
- (%XMake-XY 0)) ; Hold an X/Y value
-
-(define-primitives ; X data structure mutators
- (%XSetWindowAttributes-Event_Mask! 2))
-\f
-(define (XColor.Pixel xcolor)
- (let ((components (make-vector 5)))
- ;; Returns #(pixel, red, green, blue, flags)
- (XDecodeXColor xcolor components)
- (vector-ref components 0)))
-
-;;;; SCXL-level calls to the X primitives
-
-(define (XAllocNamedColor display colormap color-string)
- ;; Returns list: (Status Color-Allocated Exact-Color)
- ;; where color-allocated and exact-color are each the cons of a
- ;; wrapped pixel and a string that is the direct coding of the X
- ;; color structure.
- (let ((allocated (%XMake-Color))
- (exact (%XMake-Color)))
- (let ((result
- (%XAllocNamedColor (->XDisplay display)
- (->XColormap colormap)
- color-string
- allocated
- exact)))
- (list result
- (wrap-pixel display colormap (XColor.Pixel allocated))
- (wrap-pixel display colormap (XColor.Pixel exact))))))
-
-(define (XChangeWindowAttributes display window mask attributes)
- (%XChangeWindowAttributes (->XDisplay display)
- (->XWindow window)
- mask
- attributes)
- (flush-display-hook))
-
-(define (XCheckMaskEvent!? display event-mask returned-event)
- (%XCheckMaskEvent (->XDisplay display)
- event-mask
- returned-event))
-
-(define (XClearArea display window x y width height exposures?)
- (%XClearArea (->XDisplay display)
- (->XWindow window)
- x y width height exposures?)
- (flush-display-hook))
-
-(define (XClearWindow display window)
- (%XClearWindow (->XDisplay display)
- (->XWindow window))
- (flush-display-hook))
-
-#| XCloseDisplay closes the display and destroys the Scheme shadows of
-the associated server objects, and closes tk objects (which aren't
-automatically closed by X). In UITK, XCloseDisplay is NEVER called. The
-lower-level XCloseDisplayByNumber is called from the GC. Anyone who
-writes programs that call XCloseDisplay needs to think carefully about the
-dependencies (on both the Scheme and C side) of objects and processes
-involved in calling destroy operations. Tread carefully here. |#
-
-(define XCloseDisplay
- (wrap-with-SCXL-DESTROY!
- 1 0
- (lambda (dsp)
- (define (kill-protected-objects protection-list)
- (for-each SCXL-DESTROY!
- (protection-list-referenced-elements protection-list)))
- ;;SCXL-destroy the Scheme representitives of the X objects associated
- ;;to the display (which are killed by X when the
- ;;display is closed).
- (unwrap-display
- dsp
- (lambda (xdisplay windows fonts colormaps gcs
- defaultwindow defaultcolormaps)
- defaultwindow defaultcolormaps ; Should be, but aren't, used
- (for-each kill-protected-objects (list windows fonts colormaps gcs))
- ;;do someting about the default window and colormap
- (XCloseDisplayByNumber xdisplay))))))
-
-#| *********************************************
-
-XCloseDisplayByNumber is scheduled to be called by the gc-daemon when
-all references to the Scheme display have been lost.
-
-Closing the display will close the (C) windows, GC's, fonts, etc. But
-we do NOT need to destroy their Scheme-side reflections, because we
-have arranged for these to point to the display. Therefore, they
-cannot be around if the Scheme display object has been lost.
-
-*XclosedisplayCallBacks is a list of thinks that should be called when
-a display is closed. In UITK, for example, we need to
-shut down the even server for the display.
-
- ************************************************ |#
-
-(define *XCloseDisplayCallBacks* '())
-
-(define (XCloseDisplayByNumber display-number)
- (for-each (lambda (proc) (proc display-number))
- *XCloseDisplayCallBacks*)
- (%XCloseDisplay display-number))
-
-(define (SCXL-Install-XCloseDisplay-Callback proc)
- (set! *XCloseDisplayCallbacks*
- (cons proc *XCloseDisplayCallBacks*)))
-
-(define (XConnectionNumber display)
- (%XConnectionNumber (->XDisplay display)))
-
-(define (XCreateGC display window mask gcvalues)
- (wrap-graphics-context display
- (%XCreateGC (->XDisplay display)
- (->XWindow window)
- mask
- gcvalues)))
-
-(define (XCreateRegion)
- (wrap-region (%XCreateRegion)))
-
-(define (XCreateSimpleWindow
- display parent x y width height
- border-width border-pixel background-pixel)
- (wrap-window display
- (%XCreateSimpleWindow (->XDisplay display)
- (->XWindow parent)
- x y width height border-width
- (->XPixel border-pixel)
- (->XPixel background-pixel))))
-
-(define (XDecodeButtonEvent event vect)
- (%XDecodeButtonEvent event vect))
-
-(define (XDecodeConfigureEvent event vect)
- (%XDecodeConfigureEvent event vect))
-
-(define (XDecodeCrossingEvent event vect)
- (%XDecodeCrossingEvent event vect))
-
-(define (XDecodeExposeEvent event vect)
- (%XDecodeExposeEvent event vect))
-
-(define (XDecodeKeyEvent event vect)
- (%XDecodeKeyEvent event vect))
-
-(define (XDecodeMotionEvent event vect)
- (%XDecodeMotionEvent event vect))
-
-(define (XDecodeUnknownEvent event vect)
- (%XDecodeUnknownEvent event vect))
-
-(define (XDecodeWindowAttributes attributes vect)
- (%XDecodeWindowAttributes attributes vect))
-
-(define (XDecodeXColor XColor vect)
- (%XDecodeXColor xcolor vect))
-
-(define (XDefaultColormap display screen)
- (vector-ref (display/screen/default-color-map display) screen))
-
-(define (XDefaultRootWindow display)
- (display/default-root-window display))
-
-;;; Screens are not wrapped -- they are just integers, because there
-;;; is no real resource that is being allocated here.
-
-(define (XDefaultScreen display)
- (%XDefaultScreen (->XDisplay display)))
-
-(define XDestroyRegion
- (wrap-with-SCXL-DESTROY! 1 0
- (lambda (region)
- (%XDestroyRegion (->XRegion region)))))
-
-(define XDestroyWindow
- (wrap-with-SCXL-DESTROY! 2 1
- (lambda (display window)
- (%XDestroyWindow (->XDisplay display) (->XWindow window)))))
-
-(define (XDrawArc display window graphics-context
- x y width height angle1 angle2)
- (%XDrawArc (->XDisplay display)
- (->XWindow window)
- (->XGC graphics-context)
- x y width height angle1 angle2)
- (flush-display-hook))
-
-(define (XDrawLine display window graphics-context x1 y1 x2 y2)
- (%XDrawLine (->XDisplay display)
- (->XWindow window)
- (->XGC graphics-context)
- x1 y1 x2 y2)
- (flush-display-hook))
-
-(define (XDrawRectangle display window graphics-context x y width height)
- (%XDrawRectangle (->XDisplay display)
- (->XWindow window)
- (->XGC graphics-context)
- x y width height)
- (flush-display-hook))
-
-(define (XFillArc display window graphics-context
- x y width height angle1 angle2)
- (%XFillArc (->XDisplay display)
- (->XWindow window)
- (->XGC graphics-context)
- x y width height angle1 angle2)
- (flush-display-hook))
-
-(define (XFillRectangle display window graphics-context x y width height)
- (%XFillRectangle (->XDisplay display)
- (->XWindow window)
- (->XGC graphics-context)
- x y width height)
- (flush-display-hook))
-
-(define (XFlush display)
- (%XFlush (->XDisplay display)))
-
-;;; When we free a colormap, we have to destroy the Scheme
-;;; representitives of the pixels allocated in it.
-
-(define XFreeColormap
- (wrap-with-SCXL-DESTROY! 2 1
- (lambda (display colormap)
- (%XFreeColormap (->XDisplay display) (->XColormap colormap))
- (if (SCXL-WRAPPED? font)
- (for-each SCXL-DESTROY!
- (protection-list-referenced-elements
- (colormap/pixel-list colormap)))))))
-
-(define XFreeGC
- (wrap-with-SCXL-DESTROY! 2 1
- (lambda (display gc)
- (%XFreeGC (->XDisplay display) (->XGC gc)))))
-
-;;; XGetDefault returns a bare X pointer. Anyone who calls it needs to know
-;;; what is expected and wrap it at the next level up.
-
-(define (XGetDefault display program option)
- (%XGetDefault (->XDisplay display) program option))
-
-(define (XGetWindowAttributes display window)
- ;; Returns a list of (Status Attributes)
- (let ((attributes (%XMake-GetWindowAttributes)))
- (list (%XGetWindowAttributes (->XDisplay display)
- (->XWindow window)
- attributes)
- attributes)))
-
-(define (XIntersectRegion! source-1 source-2 dest)
- (%XIntersectRegion
- (->XRegion source-1)
- (->XRegion source-2)
- (->XRegion dest)))
-
-(define (XLoadFont display name)
- (wrap-font display
- (%XLoadFont (->Xdisplay display) name)))
-
-(define (XMapWindow display window)
- (%XMapWindow (->XDisplay display) (->XWindow window))
- (flush-display-hook))
-
-(define (XNextEvent display)
- (let ((event (%XMake-Event)))
- (%XNextEvent (->XDisplay display) event)
- event))
-
-;;;This is a version that doesn't build up garbage
-(define (XNextEvent! display event-string)
- (%XNextEvent (->XDisplay display) event-string)
- event-string)
-
-;;;This is a flag that forces the X server into synchronous mode. It is
-;;;useful for debugging, but slows things down alot.
-
-(define *Synchronizing?* #f)
-
-(define (XOpenDisplay string)
- (wrap-display
- (let ((result (%XOpenDisplay string)))
- (%XSynchronize result *Synchronizing?*)
- result)))
-
-(define (XPending display)
- (%XPending (->XDisplay display)))
-
-(define (XPutBackEvent display event)
- (%XPutBackEvent (->XDisplay display) event))
-
-(define (XQueryTree display window)
- (%XQueryTree (->XDisplay display)
- (->XWindow window)))
-
-(define (XQueryPointer display window)
- (let ((result (make-vector 8)))
- (%XQueryPointer (->XDisplay display)
- (->XWindow window)
- result)
- result))
-
-(define (XScreenCount display)
- (%XScreenCount (->XDisplay display)))
-
-(define (XSetForeground display graphics-context pixel-value)
- (%XSetForeground (->XDisplay display)
- (->XGC graphics-context)
- (->XPixel pixel-value))
- (flush-display-hook))
-
-
-(define (XSetFunction display graphics-context function-number)
- (%XSetFunction (->XDisplay display)
- (->XGC graphics-context)
- function-number))
-
-(define (XSetRegion display graphics-context region)
- (%XSetRegion (->XDisplay display)
- (->XGC graphics-context)
- (->XRegion region))
- (if (SCXL-WRAPPED? graphics-context)
- (set-gc/region! graphics-context region)))
-
-(define (XStoreName display window title)
- (%XStoreName (->XDisplay display)
- (->XWindow window)
- title))
-
-(define (XSubtractRegion! source-1 source-2 dest)
- (%XSubtractRegion
- (->XRegion source-1)
- (->XRegion source-2)
- (->XRegion dest)))
-
-(define (XTranslateCoordinates display from-window to-window x y)
- ;; Returns a vector (Status X Y Child-Window)
- (let ((return-vector (make-vector 4)))
- (%XTranslateCoordinates (->XDisplay display)
- (->XWindow from-window)
- (->XWindow to-window)
- x y return-vector)
- return-vector))
-
-(define (XUnionRegion! source-1 source-2 dest)
- (%XUnionRegion
- (->XRegion source-1)
- (->XRegion source-2)
- (->XRegion dest)))
-
-(define (XUnionRectSpecsWithRegion! x y width height in-region out-region)
- (%XUnionRectSpecsWithRegion! x y width height
- (->XRegion in-region)
- (->XRegion out-region)))
-
-(define XUnloadFont
- (wrap-with-SCXL-DESTROY! 2 1
- (lambda (display font)
- (%XUnloadFont (->XDisplay display) (->XFont font)))))
-
-;;;; Constructors
-
-(define (XMake-Color) (%XMake-Color))
-(define (XMake-Event) (%XMake-Event))
-(define (XMake-GCValues) (%XMake-GCValues))
-(define (XMake-SetWindowAttributes) (%XMake-SetWindowAttributes))
-
-;;;; Mutators
-
-(define (XSetWindowAttributes-Event_Mask! object value)
- (%XSetWindowAttributes-Event_Mask! object value))
-
-;;;; Auxilliary
-
-(define (XCopy-Event event)
- (string-copy event))
-\f
-(define (initialize-scxl!)
- (%XInitSCXL!)
- (set! display-protection-list (make-protection-list))
- (set! region-protection-list (make-protection-list))
- ;; Warning: UITK (in mit-xhooks.scm) knows that
- ;; close-lost-displays-daemon is *the* daemon associated with scxl.
- ;; It arranges to run it in another thread and removes it from the
- ;; gc-daemon list.
- ;;
- ;; THIS SHOULD BE PUT BACK!
- ;; (add-gc-daemon! close-lost-displays-daemon)
- )
-
-(initialize-scxl!)
-
+++ /dev/null
-;;; -*- Scheme -*-
-
-;; Test direct to TCL
-
-(define (do* args)
- (tcl-global-eval *the-default-application* (car args) (cdr args)))
-
-(define (many arg-list) (for-each do* arg-list))
-
-;; Test the Button widget
-
-(define but1)
-(define (btest1)
- (set! but1 (make-button '(-text "Hello Jim"
- -foreground blue -activeforeground black
- -background yellow -activebackground orange)))
- (set-callback! but1
- (lambda ()
- (display "Ouch!")
- (newline)))
- (swat-open but1 '-title "Test Scheme Application"))
-
-(define v1)
-(define v2)
-(define v3)
-(define h1)
-(define h2)
-(define h3)
-(define leftframe)
-(define rightframe)
-(define frame)
-(define (btest2)
- (set! v1 (make-button '(-text "Hello Jim"
- -foreground blue
- -activeforeground "hot pink")))
- (set! v2 (make-button '(-text "Goodbye and Good Luck")))
- (set! v3 (make-button '(-text "Jane")))
-
- (set! leftframe (make-vbox v1 v2 v3))
-
- (set! h1 (make-button '(-text "Button 1")))
- (set! h2 (make-button '(-text "Button 2")))
- (set! h3 (make-button '(-text "Button 3")))
-
- (set! rightframe (make-hbox h1 h2 h3))
-
- (set! frame (make-hbox leftframe rightframe))
-
- (set-callback! v1 (lambda ()
- (display "First button in Vbox")
- (newline)))
- (set-callback! h1
- (lambda ()
- (display "First button in Hbox")
- (newline)))
- (swat-open frame '-title "Test Scheme Application"))
-
-
-(define but3)
-(define (btest3)
- (set! but3 (make-button '(-text "hello there" -background yellow)))
- (set-callback!
- but3
- (lambda ()
- (after-delay 2
- (lambda ()
- (ask-widget but3 '(configure -background red))))
- (after-delay 4
- (lambda ()
- (ask-widget but3 '(configure -background yellow))))))
- (swat-open but3 '-title "btest3"))
-
-(define (show-window-attributes uitkwindow)
- (let ((attributes (list-ref (XGetWindowAttributes
- (uitkwindow.xdisplay uitkwindow)
- (uitkwindow.xwindow uitkwindow)) 1)))
- (Decode-Window-Attributes attributes
- (lambda (x y width height border_width depth visual root class
- bit_gravity win_gravity backing_store backing_planes
- backing_pixel save_under colormap map_installed
- map_state all_event_masks your_event_mask
- do_not_propogate_mask override_redirect screen)
- depth visual root class bit_gravity win_gravity backing_store
- backing_planes backing_pixel save_under colormap map_installed
- map_state override_redirect screen
- (write-line (list 'x x 'y y 'width width
- 'height height 'b-width border_width))
- (write-line (list 'all (number->string all_event_masks 16)
- 'event (number->string your_event_mask 16)
- 'do-not-prop do_not_propogate_mask))))))
-
-(define scale1)
-(define (stest1)
- (set! scale1 (make-scale '(-from 0 -to 99
- -foreground blue -activeforeground red
- -background yellow -length 500 -orient horiz)))
-#| (set-callback! scale1
- (lambda (value)
- (display (list "Ouch!" value))
- (newline)))
-|#
- (swat-open scale1 '-title "Scale Test Scheme Application"))
-
-(define scale2)
-(define (stest2)
- (set! scale2 (make-scale '(-from 0 -to 99 -length 500 -orient horiz
- -foreground blue -activeforeground red
- -background yellow)))
- (set-callback! scale2 (lambda (value) 'ignore))
- (swat-open scale2 '-title "Scale Test Scheme Application"))
-
-(define e)
-(define (etest1)
- (set! e (make-entry '(-width 30 -relief sunken
- -foreground blue -background yellow)))
- (swat-open e '-title "Entry Test"))
-
-(define sb)
-(define (sbtest1)
- (set! sb (make-scrollbar '(-width 20 -orient vertical -relief sunken
- -foreground blue -background yellow)))
- (swat-open sb '-title "Scrollbar Test"))
-
-(define (sbtest2)
- (let* ((scroll (make-scrollbar '(-width 30 -orient horizontal -relief sunken
- -foreground blue -background yellow)))
- (entry (make-entry '(-width 45)))
- (me (make-vbox entry scroll)))
- (swat-open me '-title "Scrollbar Test")
- me))
-
-(define (suicide-button)
- (let ((sbut (make-button '(-text "Kill Me"))))
- (set-callback! sbut
- (lambda ()
- (swat-close sbut)))
- (swat-open sbut)))
-
-
-;;;scheduling the update for when-idle makes things a littel better, but not much.
-;;;GC still interferes
-
-(define (sbtest3)
- ;; A "better" version is in sbtest4
- (let ((app (make-application "Play")))
- (let ((hscroll (make-scrollbar '(-width 20 -orient horizontal)))
- (vscroll (make-scrollbar '(-width 20 -orient vertical)))
- (big (make-rect 500 600 "blue"))
- (small (make-oval 30 40 "yellow"))
- (scrolly 0)
- (scrollx 0)
- (x 0)
- (y 0))
- (define (update-vert)
- (if (not (= y scrolly))
- (begin (set! y scrolly)
- (shape-draw big)
- (assign-location! small (make-point x y))
- (shape-draw small)
- (ask-widget vscroll `(set 600 40 ,y ,(+ y 40))))))
- (define (update-horiz)
- (if (not (= x scrollx))
- (begin (set! x scrollx)
- (shape-draw big)
- (assign-location! small (make-point x y))
- (shape-draw small)
- (ask-widget hscroll `(set 500 30 ,x ,(+ x 30))))))
-
- (ask-widget vscroll '(set 600 40 0 40))
- (ask-widget hscroll '(set 500 30 0 30))
- (let ((hb (make-hbox big vscroll)))
- (let ((vb (make-vbox hb hscroll)))
- (add-child! app vb)
- ))
-
- (set-callback! vscroll
- (lambda (value)
- (let* ((n (string->number value))
- ;;keep small bar totally on screen
- (n (max 0 n))
- (n (min 560 n)))
- (set! scrolly n)
- (when-idle! update-vert))))
- (set-callback! hscroll
- (lambda (value)
- (let* ((n (string->number value))
- ;;keep small bar totally on screen
- (n (max 0 n))
- (n (min 470 n)))
- (set! scrollx n)
- (when-idle! update-horiz))))
- (on-geometry-change!
- big
- 'ignore
- (lambda (old-screen-area new-screen-area)
- (assign-geometry! small
- (drawing-surface big)
- (if new-screen-area
- (copy-rectangle new-screen-area)
- new-screen-area))
- (shape-draw big)
- (shape-draw small)))
- (handle-exposure big (lambda (rect)
- (shape-draw big (rectangle->xregion rect))
- (shape-draw small)))
- (when-idle! (lambda () (shape-draw small)))
- `((app ,app)
- (hscroll ,hscroll)
- (vscroll ,vscroll)
- (big ,big)
- (small ,small)))))
-
-(define (compress-deferred-processing on-callback at-idle)
- (let ((scheduled? #F))
- (lambda args
- (if (not scheduled?)
- (begin
- (when-idle!
- (lambda ()
- (set! scheduled? #F)
- (at-idle)))
- (set! scheduled? #T)))
- (apply on-callback args))))
-
-(define (sbtest4)
- (let ((app (make-application "Play")))
- (let ((hscroll (make-scrollbar '(-width 20 -orient horizontal)))
- (vscroll (make-scrollbar '(-width 20 -orient vertical)))
- (big (make-rect 500 600 "blue"))
- (small (make-oval 30 40 "yellow"))
- (scrolly 0)
- (scrollx 0)
- (x 0)
- (y 0))
-
- (define (update-vert)
- (if (not (= y scrolly))
- (begin (set! y scrolly)
- (shape-draw big)
- (assign-location! small (make-point x y))
- (shape-draw small)
- (ask-widget vscroll `(set 600 40 ,y ,(+ y 40))))))
-
- (define (update-horiz)
- (if (not (= x scrollx))
- (begin (set! x scrollx)
- (shape-draw big)
- (assign-location! small (make-point x y))
- (shape-draw small)
- (ask-widget hscroll `(set 500 30 ,x ,(+ x 30))))))
-
- (ask-widget vscroll '(set 600 40 0 40))
- (ask-widget hscroll '(set 500 30 0 30))
- (add-child! app (make-vbox (make-hbox big vscroll)
- hscroll))
- (set-callback! vscroll
- (compress-deferred-processing
- (lambda (value)
- (let* ((n (string->number value))
- ;;keep small bar totally on screen
- (n (max 0 n))
- (n (min 560 n)))
- (set! scrolly n)))
- update-vert))
-
- (set-callback! hscroll
- (compress-deferred-processing
- (lambda (value)
- (let* ((n (string->number value))
- ;;keep small bar totally on screen
- (n (max 0 n))
- (n (min 470 n)))
- (set! scrollx n)))
- update-horiz))
-
- (on-geometry-change!
- big
- 'ignore
- (lambda (old-screen-area new-screen-area)
- (assign-geometry! small
- (drawing-surface big)
- (if new-screen-area
- (copy-rectangle new-screen-area)
- new-screen-area))
- (shape-draw big)
- (shape-draw small)))
-
- (handle-exposure big (lambda (rect)
- (shape-draw big (rectangle->xregion rect))
- (shape-draw small)))
-
- (when-idle! (lambda () (shape-draw small)))
- `((app ,app)
- (hscroll ,hscroll)
- (vscroll ,vscroll)
- (big ,big)
- (small ,small)))))
-
-;;; canvas tests
-(define (canvas-test)
- (let ((c (make-canvas '(-width 400 -height 300 -background "light gray"))))
- (swat-open c)
- (let ((george
- (make-arc-on-canvas c 200 200 250 250
- `(-fill pink -outline black
- -width 2 -start 0 -extent 300)))
- (message (make-text-on-canvas c 100 100 '(-text "Hello there")))
- (last-x #F)
- (last-y #F)
- (start 0))
- (add-event-handler! george "<Enter>"
- (lambda () (ask-widget george '(configure -fill yellow))))
- (add-event-handler! george "<Leave>"
- (lambda () (ask-widget george '(configure -fill pink))))
- (add-event-handler! george "<ButtonPress-1>"
- (lambda (x y)
- (ask-widget message
- `(configure -text "OUCH!"
- -font "-Adobe-Helvetica-Bold-R-Normal--*-240-*"))
- (set! start (modulo (+ start 30) 360))
- (ask-widget george `(configure -start ,start))
- (set! last-x x)
- (set! last-y y))
- "%x" "%y")
- (add-event-handler! george "<ButtonRelease-1>"
- (lambda ()
- (ask-widget message
- '(configure -text "Hello there"
- -font "-Adobe-Helvetica-Bold-R-Normal--*-120-*"))))
- (add-event-handler! george "<Button1-Motion>"
- (lambda (x y)
- (ask-widget george `(move ,(- x last-x) ,(- y last-y)))
- (set! last-x x)
- (set! last-y y))
- "%x" "%y")
- )))
-
-
-(define (doodle-test)
- (let ((c (make-canvas '(-width 400 -height 300
- -background "light gray")))
- (last-x 0)
- (last-y 0))
- (add-event-handler! c
- "<ButtonPress-1>"
- (lambda (x y)
- (ask-widget c `(delete all))
- (set! last-x x)
- (set! last-y y))
- "%x" "%y")
- (add-event-handler! c
- "<B1-Motion>"
- (lambda (x y)
- (let ((line (make-line-on-canvas c last-x last-y x y)))
- (ask-widget line '(configure -width 1))
- (set! last-x x)
- (set! last-y y)))
- "%x" "%y")
- (swat-open c '-title "Canvas Drawing")))
-
-
-(define (ctest)
- (let ((a (make-application "Canvas Items: IQ Test")))
- (let ((c (make-canvas '(-width 400 -height 300))))
- (ask-widget c '(configure -background "light gray"))
- (add-child! a c)
-
- (let* ((r1 (make-rectangle-on-canvas c 20 20 60 60))
- (r2 (make-rectangle-on-canvas c 40 40 80 80))
- (r3 (make-rectangle-on-canvas c 60 60 100 100))
-
- (m1 (make-text-on-canvas c 300 20 '(-text "CANVAS EVENTS:")))
- (m2 (make-text-on-canvas c 300 40 '(-text "B1: east")))
- (m3 (make-text-on-canvas c 300 60 '(-text "B3: west")))
- (m4 (make-text-on-canvas c 300 80 '(-text "B2,B1: south")))
- (m5 (make-text-on-canvas c 300 100 '(-text "B2,B3: north")))
- (m6 (make-text-on-canvas c 300 140 '(-text "TAG EVENTS:")))
- (m7 (make-text-on-canvas c 300 160 '(-text "B1: red")))
- (m8 (make-text-on-canvas c 300 180 '(-text "B2: green")))
- (m9 (make-text-on-canvas c 300 200 '(-text "B3: blue")))
-
- (t1 (make-canvas-item-group c (list r1 r2 r3)))
- (t2 (make-canvas-item-group c (list m2 m3 m4 m5 m7 m8 m9)))
- )
- (ask-widget r1 '(configure -fill red))
- (ask-widget r2 '(configure -fill green))
- (ask-widget r3 '(configure -fill blue))
- (ask-widget t2 '(configure -anchor n -fill maroon))
-
-
- (add-event-handler! c
- "<ButtonPress-1>"
- (lambda ()
- (ask-widget t1 `(move 10 0))))
- (add-event-handler! c
- "<ButtonPress-3>"
- (lambda ()
- (ask-widget t1 `(move -10 0))))
- (add-event-handler! c
- "<ButtonPress-2><ButtonPress-1>"
- (lambda ()
- (ask-widget t1 `(move 0 10))))
- (add-event-handler! c
- "<ButtonPress-2><ButtonPress-3>"
- (lambda ()
- (ask-widget t1 `(move 0 -10))))
-
- (add-event-handler! t1
- "<ButtonPress-1>"
- (lambda ()
- (ask-widget r1 `(move 10 10))))
- (add-event-handler! t1
- "<ButtonPress-2>"
- (lambda ()
- (ask-widget r2 `(move 10 10))))
- (add-event-handler! t1
- "<ButtonPress-3>"
- (lambda ()
- (ask-widget r3 `(move 10 10))))
-
- (add-event-handler! r1
- "<Enter>"
- (lambda ()
- (ask-widget r1 `(raise))))
- (add-event-handler! r2
- "<Enter>"
- (lambda ()
- (ask-widget r2 `(raise))))
- (add-event-handler! r3
- "<Enter>"
- (lambda ()
- (ask-widget r3 `(raise))))
-
- (add-event-handler! t2
- "<Enter>"
- (lambda ()
- (ask-widget t2 `(configure -fill violetred))))
- (add-event-handler! t2
- "<Leave>"
- (lambda ()
- (ask-widget t2 `(configure -fill maroon))))
-
- c))))
-
-(define (ctest1)
- (let* ((app (make-application "Canvas Widget"))
- (canvas (make-canvas '(-width 300 -height 300)))
- (button1 (make-button '(-text "Toggle background color")))
- (vbox (make-vbox canvas button1)))
- (ask-widget canvas '(configure -background yellow))
- (ask-widget button1 '(configure -background cyan
- -activebackground "light blue"))
- (add-child! app vbox)
- (set-callback!
- button1
- (lambda ()
- (let* ((button2 (make-button '(-text "Yellow")))
- (button3 (make-button '(-text "Red"))))
- (ask-widget button2 '(configure -background "light blue"
- -activebackground cyan))
- (ask-widget button3 '(configure -background "light blue"
- -activebackground cyan))
- (let* ((cb2 (make-widget-on-canvas canvas button2 200 250))
- (cb3 (make-widget-on-canvas canvas button3 250 250))
- (both (make-canvas-item-group canvas (list cb2 cb3))))
- (set-callback! button2
- (lambda ()
- (ask-widget canvas '(configure -background yellow))
- (ask-widget both '(delete))))
- (set-callback! button3
- (lambda ()
- (ask-widget canvas '(configure -background red))
- (ask-widget both '(delete))))))))
- (list app vbox)))
-
-
-(define (menu-test)
- ;; No menu button
- (let ((application (make-application "Menu Test")))
- (define start-button (make-button '(-text "Go!")))
- (define main (make-menu))
- (define sub (make-menu))
- (define button-1 (add-to-menu main 'command '-background "blue" '-label "Close"))
- (define button-2 (add-to-menu main 'command '-background "yellow" '-label "Two"))
- (define button-3 (add-sub-menu main sub '-background "blue" '-label "More..."))
- (define sub-1 (add-to-menu sub 'command '-background "blue" '-label "A"))
- (define sub-2 (add-to-menu sub 'command '-background "blue" '-label "B"))
- (define sub-3 (add-to-menu sub 'command '-background "blue" '-label "C"))
- (define sub-4 (add-to-menu sub 'command '-background "blue" '-label "D"))
- (ask-widget start-button
- '(configure -background yellow
- -font
- "-adobe-helvetica-bold-r-normal--34-240-100-100-p-182-iso8859-1"))
- (add-child! application start-button)
- (add-child! start-button main)
- (set-callback! button-1 (lambda () (ask-widget main '(unpost))))
- (set-callback! button-2 (lambda () (write-line 'Two)))
- (set-callback! button-3 (lambda () (write-line 'Three)))
- (set-callback! sub-1 (lambda () (write-line 'A)))
- (set-callback! sub-2 (lambda () (write-line 'B)))
- (set-callback! sub-3 (lambda () (write-line 'C)))
- (set-callback! sub-4 (lambda () (write-line 'D)))
- (set-callback! start-button (lambda () (ask-widget main '(post 10 20))))
- (lambda ()
- (list application start-button main sub
- button-1 button-2 button-3
- sub-1 sub-2 sub-3 sub-4))))
-
-(define (menu-test2)
- (let ((application (make-application "Menu Test")))
- (define main (make-menu))
- (define start-button (make-menubutton main '(-text "Go!")))
- (define sub (make-menu))
- (define button-1 (add-to-menu main 'command '-background "blue" '-label "Close"))
- (define button-2 (add-to-menu main 'command '-background "yellow" '-label "Two"))
- (define button-3 (add-sub-menu main sub '-background "blue" '-label "More..."))
- (define sub-1 (add-to-menu sub 'command '-background "blue" '-label "A"))
- (define sub-2 (add-to-menu sub 'command '-background "blue" '-label "B"))
- (define sub-3 (add-to-menu sub 'command '-background "blue" '-label "C"))
- (define sub-4 (add-to-menu sub 'command '-background "blue" '-label "D"))
- (add-child! application start-button)
- (set-callback! button-1 (lambda () (ask-widget main '(unpost))))
- (set-callback! button-2 (lambda () (write-line 'Two)))
- (set-callback! button-3 (lambda () (write-line 'Three)))
- (set-callback! sub-1 (lambda () (write-line 'A)))
- (set-callback! sub-2 (lambda () (write-line 'B)))
- (set-callback! sub-3 (lambda () (write-line 'C)))
- (set-callback! sub-4 (lambda () (write-line 'D)))
- (lambda ()
- (list application start-button main sub
- button-1 button-2 button-3
- sub-1 sub-2 sub-3 sub-4))))
-
-(define (menu-test3)
- (let ((application (make-application "Menu Test")))
- (define main (make-menu))
- (define start-button (make-menubutton main '(-text "Go!")))
- (define button-1 (add-to-menu main 'command '-background "blue" '-label "Close"))
- (define button-2 (add-to-menu main 'command '-background "yellow" '-label "Two"))
- (add-child! application start-button)
- (set-callback! button-1 (lambda () (ask-widget main '(unpost))))
- (set-callback! button-2 (lambda () (write-line 'Two)))
- (lambda ()
- (list application start-button main
- button-1 button-2))))
-
-
-(define (mac)
- (let* ((a (make-application "Microslop Word"))
- (t (make-text))
- (sb (make-scrollbar '(-width 20 -orient vertical)))
- (file-menu (make-menu))
- (file-mb (make-menubutton file-menu '(-text "File")))
- (save-menu (make-menu))
- (edit-menu (make-menu))
- (edit-mb (make-menubutton edit-menu '(-text "Edit")))
- (tools-menu (make-menu))
- (tools-mb (make-menubutton tools-menu '(-text "Tools")))
- )
-
- (for-each (lambda (m)
- (ask-widget m '(configure -background white
- -activebackground red)))
- (list file-menu save-menu edit-menu tools-menu
- file-mb edit-mb tools-mb))
- (for-each (lambda (b)
- (ask-widget b '(configure -relief raised)))
- (list file-mb edit-mb tools-mb))
-
- (ask-widget t '(configure -background white -wrap word -width 40))
- (ask-widget sb '(configure -background red))
- (ask-widget sb '(set 1000 400 0 400))
-
- (set-callback!
- sb
- (lambda (value)
- (let* ((n (string->number value)))
- (when-idle!
- (lambda () (ask-widget sb `(set 1000 400 ,n ,(+ n 400))))))))
-
- (let ((me (make-vbox (make-hbox file-mb edit-mb tools-mb)
- (make-hbox t sb))))
- (add-child! a me)
-
- (add-to-menu file-menu 'command '-label "Open")
- (add-to-menu file-menu 'command '-label "Close")
- (add-sub-menu file-menu save-menu '-label "Save...")
- (add-to-menu save-menu 'command '-label "There is no salvation")
- (add-to-menu save-menu 'command '-label "Jesus saves")
- (add-to-menu file-menu 'command '-label "Exit")
-
- (let ((paste-button (add-to-menu edit-menu 'command '-label "Paste"))
- (cut-button (add-to-menu edit-menu 'command '-label "Cut"))
- (deleted-text #F))
- (set-callback! cut-button
- (lambda ()
- (set! deleted-text
- (ask-widget t '(get sel.first sel.last)))
- (ask-widget t '(delete sel.first sel.last))))
- (set-callback! paste-button
- (lambda ()
- (if deleted-text
- (ask-widget t `(insert insert ,deleted-text))))))
-
- (add-to-menu edit-menu 'command '-label "Staple")
- (add-to-menu edit-menu 'command '-label "Mutilate")
-
- (add-to-menu tools-menu 'command '-label "Hammer")
- (add-to-menu tools-menu 'command '-label "Saw")
-
- me)))
-
-(define all-tags '())
-(define all-demos '())
-(define (browser)
- (let* ((a (make-application "Demo Browser"))
- (t (make-text))
- (sb (make-scrollbar '(-width 20 -orient vertical)))
- (m (make-menu))
- (mb (make-menubutton m '(-text "Widgets"))))
-
- (define (switch-to-widget-demos list-of-demos)
- (for-each (lambda (tag) (ask-widget tag '(delete))) all-tags)
- (set! all-tags '())
- (ask-widget t '(delete "1.0" end))
- (for-each
- (lambda (demo-thunk-name)
- (ask-widget t `(insert insert ,demo-thunk-name))
- (ask-widget t '(insert insert " "))
- (let ((tag (make-text-tag t "insert linestart" "insert-1c")))
- ;; gc protect
- (set! all-tags (cons tag all-tags))
- (add-event-handler!
- tag "<Enter>"
- (lambda () (ask-widget tag '(configure -foreground violetred))))
- (add-event-handler!
- tag "<Leave>"
- (lambda () (ask-widget tag '(configure -foreground blue))))
- (add-event-handler!
- tag
- "<Button-1>"
- (lambda ()
- (ask-widget tag '(configure -underline 1))
- (let ((demo-thunk
- (ask-widget
- t
- `(get ,(string-append (TextTag.name tag) ".first")
- ,(string-append (TextTag.name tag) ".last")))))
- ;; gc protect
- (set! all-demos (cons ((eval (string->symbol demo-thunk)
- user-initial-environment))
- all-demos))
- ))))
- (ask-widget t '(insert insert "\n")))
- list-of-demos))
-
- (ask-widget t `(configure -width 20 -height 10
- -background "white" -foreground blue))
- (for-each (lambda (x)
- (ask-widget x '(configure -background blue -foreground white
- -activebackground white
- -activeforeground blue)))
- (list m mb))
- #|
- (set-callback! sb
- (lambda (n)
- (ask-widget t `(yview -pickplace ,n))))
-
- |#
-
- (let ((me (make-vbox mb (make-hbox t sb))))
- (add-child! a me)
-
- (ask-widget t `(configure -yscrollcommand
- ,(string-append (tk-widget->pathname sb) " set")))
- (ask-widget sb `(configure
- -command
- ,(string-append
- (tk-widget->pathname t)
- " yview -pickplace")))
-
- (let* ((picture-button (add-to-menu m 'command '-label "Picture"))
- (button-button (add-to-menu m 'command '-label "Button"))
- (scale-button (add-to-menu m 'command '-label "Scale"))
- (entry-button (add-to-menu m 'command '-label "Entry"))
- (scrollbar-button (add-to-menu m 'command '-label "Scrollbar"))
- (canvas-button (add-to-menu m 'command '-label "Canvas"))
- (menu-button (add-to-menu m 'command '-label "Menu"))
- (text-button (add-to-menu m 'command '-label "Text Widget"))
- (animation-button (add-to-menu m 'command '-label "Animation")))
-
- (set-callback! picture-button
- (lambda () (switch-to-widget-demos
- (list "test1" "test1a" "test2" "test3"))))
- (set-callback! button-button
- (lambda () (switch-to-widget-demos
- (list "btest1" "btest2" "btest3"))))
- (set-callback! scale-button
- (lambda () (switch-to-widget-demos (list "stest1" "stest2"))))
- (set-callback! entry-button
- (lambda () (switch-to-widget-demos (list "etest1"))))
- (set-callback! scrollbar-button
- (lambda () (switch-to-widget-demos
- (list "sbtest1" "sbtest2" "sbtest3"))))
- (set-callback! canvas-button
- (lambda () (switch-to-widget-demos
- (list "canvas-test" "doodle-test"
- "ctest" "ctest1"))))
- (set-callback! menu-button
- (lambda () (switch-to-widget-demos
- (list "menu-test" "menu-test2"))))
- (set-callback! text-button
- (lambda () (switch-to-widget-demos (list "mac" "browser"))))
- (set-callback! animation-button
- (lambda () (switch-to-widget-demos
- (list "btest3" "animation" "biff" "melt"
- "balls"))))
-
- me))))
-
-
-(define app4)
-(define c4)
-(define but4)
-(define (animation)
- (set! app4 (make-application "Animation"))
- (set! c4 (make-canvas '(-background white -width 200 -height 200)))
- (set! but4 (make-button '(-text "START" -background maroon -foreground white
- -activebackground "hot pink")))
- (add-child! app4 c4)
- (make-widget-on-canvas c4 but4 25 185)
- (set-callback!
- but4
- (lambda ()
- (let ((rect (make-rectangle-on-canvas c4 10 10 40 40)))
- (ask-widget rect '(configure -fill red))
- (let loop ((position 10))
- (if (> position 200)
- (ask-widget rect '(delete))
- (begin (ask-widget rect '(move 1 1))
- (after-delay .05 (lambda () (loop (1+ position))))))))))
- c4)
-
-
-(define app5)
-(define c5)
-(define (biff)
- (set! app5 (make-application "biff"))
- (set! c5 (make-canvas '(-background black -width 70 -height 70)))
- (add-child! app5 c5)
- (let* ((file1 "/usr/local/lib/tk/demos/bitmaps/flagdown")
- (file2 "/usr/local/lib/tk/demos/bitmaps/flagup")
- (current-bitmap-filename file1)
- (current-bknd "black")
- (current-fgnd "cyan"))
- (define (toggle-bitmap)
- (let ((old-bknd current-bknd)
- (old-fgnd current-fgnd))
- (set! current-bknd old-fgnd)
- (set! current-fgnd old-bknd))
- (if (equal? current-bitmap-filename file1)
- (set! current-bitmap-filename file2)
- (set! current-bitmap-filename file1)))
- (define (make-flag)
- (let ((flag (make-bitmap-on-canvas c5 current-bitmap-filename 35 35)))
- (ask-widget flag `(configure -background ,current-bknd
- -foreground ,current-fgnd))
- flag))
-
- (let ((flag (make-flag)))
- (define (toggle)
- (ask-widget flag '(delete))
- (toggle-bitmap)
- (ask-widget c5 `(configure -background ,current-bknd))
- (set! flag (make-flag)))
- (after-delay
- 1
- (lambda ()
- (let loop ((count 0))
- (if (> count 10)
- 'done
- (after-delay 1
- (lambda ()
- (toggle)
- (loop (1+ count))))))))
- (add-event-handler! c5 "<Any-ButtonPress>" toggle))))
-
-
-(define app6)
-(define c6)
-(define but6)
-(define (melt)
- (define (generate-vertical-line x)
- (let* ((length (random 30))
- (start (- (random 30) 30))
- (end (+ start length))
- (line (make-line-on-canvas c6 x start x end)))
- (ask-widget line `(configure -fill white))
- line))
-
- (set! app6 (make-application "Mind Melt"))
- (set! c6 (make-canvas '(-background black -width 200 -height 200)))
- (set! but6 (make-button '(-text "MELT"
- -background black -foreground red
- -activebackground black -activeforeground red)))
- (let ((me (make-vbox c6 but6)))
- (add-child! app6 me)
- (set-callback!
- but6
- (lambda ()
- (let* ((lines (let loop ((x 0) (lines '()))
- (if (> x 200)
- lines
- (loop (+ x 2) (cons (generate-vertical-line x) lines)))))
- (tag (make-canvas-item-group c6 lines)))
- (let loop ((position 0))
- (if (> position 230)
- (ask-widget tag '(delete))
- (after-delay .000005
- (lambda ()
- (for-each (lambda (line)
- (ask-widget line `(move 0 ,(random 10))))
- lines)
- (loop (1+ position)))))))))
- me))
-
-
-(define (balls)
- (define canvas-width 300)
- (define canvas-height 300)
- (define min-ball-size 1)
- (define max-ball-size 30)
- (define min-delta 1)
- (define max-delta 8)
- (define a (/ (- min-delta max-delta) (- max-ball-size min-ball-size)))
- (define b (- min-delta (* a max-ball-size)))
- (define (pick-random-color)
- (define list-of-colors
- '("green" "yellow" "red" "blue" "hot pink" "orange" "cyan"
- "maroon" "skyblue" "firebrick" "aquamarine" "violet"
- "violetred" "navyblue" "darkslateblue" "pink"))
- (list-ref list-of-colors (random (length list-of-colors))))
-
- (define (pick-true-or-false)
- (list-ref '(#T #F) (random 2)))
-
- (define (make-ball canvas diameter startx starty)
- (let* ((radius (round->exact (/ diameter 2)))
- (centerx (+ startx radius))
- (centery (+ starty radius))
- (the-ball
- (make-oval-on-canvas canvas startx starty
- (+ startx diameter)
- (+ starty diameter)))
- (increasing-x? (pick-true-or-false))
- (increasing-y? (pick-true-or-false))
- (speed-factor (round->exact (+ (* a diameter) b))))
- (lambda (m)
- (case m
- ((the-ball) the-ball)
- ((centerx) centerx)
- ((centery) centery)
- ((set-centerx!) (lambda (x) (set! centerx x)))
- ((set-centery!) (lambda (y) (set! centery y)))
- ((+x?) increasing-x?)
- ((+y?) increasing-y?)
- ((set+x?!) (lambda (boolean) (set! increasing-x? boolean)))
- ((set+y?!) (lambda (boolean) (set! increasing-y? boolean)))
- ((diameter) diameter)
- ((speed-factor) speed-factor)))))
-
- (define (generate-ball canvas)
- (let* ((diameter (+ min-ball-size (random (- max-ball-size min-ball-size))))
- (startx (min (random canvas-width) (- canvas-width diameter)))
- (starty (min (random canvas-height) (- canvas-height diameter)))
- (ball (make-ball canvas diameter startx starty)))
- (ask-widget (ball 'the-ball) `(configure -fill ,(pick-random-color)))
- ball))
-
- (define (generate-move ball)
- (let* ((centerx (ball 'centerx))
- (centery (ball 'centery))
- (diameter (ball 'diameter))
- (radius (round->exact (/ diameter 2)))
- (startx (- centerx radius))
- (endx (+ centerx radius))
- (starty (- centery radius))
- (endy (+ centery radius))
- (dx-sign (cond ((<= startx 0)
- ((ball 'set+x?!) #T)
- 1)
- ((>= endx canvas-width)
- ((ball 'set+x?!) #F)
- -1)
- ((ball '+x?) 1)
- (else -1)))
- (dy-sign (cond ((<= starty 0)
- ((ball 'set+y?!) #T)
- 1)
- ((>= endy canvas-height)
- ((ball 'set+y?!) #F)
- -1)
- ((ball '+y?) 1)
- (else -1)))
- (dx (* dx-sign (max 1 (random (ball 'speed-factor)))))
- (dy (* dy-sign (max 1 (random (ball 'speed-factor))))))
- ((ball 'set-centerx!) (+ centerx dx))
- ((ball 'set-centery!) (+ centery dy))
- `(move ,dx ,dy)))
-
- (let ((app7 (make-application "Bouncing Balls"))
- (c7 (make-canvas `(-background black -width ,canvas-width
- -height ,canvas-height))))
- (add-child! app7 c7)
-
- (let ((balls
- (let loop ((num 0) (balls '()))
- (if (> num (+ 10 (random 10)))
- balls
- (loop (1+ num) (cons (generate-ball c7) balls))))))
- (let ((go
- (lambda ()
- (let loop ()
- (for-each
- (lambda (ball)
- (ask-widget (ball 'the-ball) (generate-move ball)))
- balls)
- (after-delay 0.0005 loop)))))
- (after-delay 1 go)
- (list app7 c7 balls go)))))
-
-
-(define (canvas-sb-test)
- (let ((sc (make-scrollable-canvas
- '(-width 500 -height 500
- -scrollregion (0 0 1000 1000)))))
- (swat-open sc)
- (ask-widget (scrollable-canvas-hscroll sc)
- `(configure -foreground "yellow"))
- (ask-widget (scrollable-canvas-vscroll sc)
- `(configure -foreground "yellow"))
- (make-rectangle-on-canvas (scrollable-canvas-canvas sc)
- 100 100 400 400
- '(-fill red))
- sc))
-
-
-
-(define (text-sb-test)
- (let ((st (make-scrollable-text)))
- (swat-open st)
- (ask-widget (scrollable-text-vscroll st)
- '(configure -foreground red))
- st))
-
-
-
-
-
-
+++ /dev/null
-;;; -*- Scheme -*-
-
-(declare (usual-integrations))
-
-;;;; This is a very simple application written in Scheme, withous any
-;;;; TK wigets. It is a surface on which you cna sketch a path with
-;;;; the mouse.
-
-;;;Some geometric shape drawers:
-;;;This might be generally useful -- it saves the higher level from
-;;;worrying about the graphics context.
-
-;;;this doesn't handle clipping. should we create a line-drawer with a
-;;;specified clip region??
-
-(define (geometry-drawer-for-shape shape color drawproc)
- ;;also set line style, thickness, etc.
- (let* ((window #F)
- (gc #F))
- (lambda args
- ;;need to init the window and GC and keep it up to date if the
- ;;window changes
- ;;is there some way to used cached info for the shape to speed
- ;;up these tests?
- (if (not (used-screen-area shape))
- (error "attempt to draw on background with no screen area"
- shape))
- (if (not (eq? window (get-uitkwindow shape)))
- (begin (set! window (get-uitkwindow shape))
- (set! gc (make-colored-graphics-context window color))))
- (apply drawproc (cons window (cons gc args))))))
-
-(define (line-drawer-for-shape shape color)
- (geometry-drawer-for-shape
- shape color
- (lambda (window gc p1 p2)
- (drawline window gc
- (point.X p1) (point.Y p1)
- (point.X p2) (point.Y p2)))))
-
-(define (arc-drawer-for-shape shape color)
- (geometry-drawer-for-shape
- shape color
- (lambda (window gc p w h a1 a2)
- (drawarc window gc (point.X p) (point.Y p) w h a1 a2))))
-
-(define (rectangle-drawer-for-shape shape color)
- (geometry-drawer-for-shape
- shape color
- (lambda (window gc p w h)
- (drawrectangle window gc (point.X p) (point.Y p) w h))))
-
-
-
-(define (setup-doodle)
- (let ((d (make-doodle-surface 400 400 "light gray")))
- (add-child! (make-application "doodle") d)
- d))
-
-(define (make-doodle-surface width height background-color)
- (let* ((line-color "black")
- (background (make-rect width height background-color))
- (draw-line (line-drawer-for-shape background line-color))
- (path '()))
- (define (collect-points first-event while-grabbed)
- (shape-draw background) ;clear and erase path
- (set! path (list (event.offset first-event)))
- (while-grabbed
- (lambda (point)
- (if (point-within? background point)
- (begin (draw-line (car path) point)
- (set! path (cons point path)))))
- (lambda () 'done))) ;nothing to do at end of grab
- (define (draw-path)
- (if (not (null? path))
- (let loop ((path path))
- (if (null? (cdr path))
- 'done
- (begin (draw-line (car path) (cadr path))
- (loop (cdr path)))))))
- (handle-exposure
- background
- (lambda (exposed-rectangle)
- (shape-draw background (rectangle->XRegion exposed-rectangle))
- ;;should clip to exposed rectangle. What's a nice way to do this?
- (draw-path)))
- (handle-button-grab
- background ANYBUTTON
- (lambda (e while-grabbed)
- (collect-points e while-grabbed)))
- (on-geometry-change!
- background
- 'ignore
- (lambda (old-screen-area new-screen-area)
- old-screen-area
- (if (UITKRectangle? new-screen-area)
- (shape-draw background))))
- background))
-
-
-
-
-
+++ /dev/null
-;; Make export list
-
-(define (make-export-list candidates)
- ;; Call this on the names in the SWAT load environmnet to discover the
- ;; useful names.
- (define xlib-names (map second (read-file "xlibCONSTANTS.scm")))
-
- (define (xlib-name? n) (memq n xlib-names))
- (define (internal-name? n)
- (let ((s (symbol-name n)))
- (or (string-find-next-char s #\%))))
-
- (sort (list-transform-negative candidates
- (lambda (name)
- (or (internal-name? name)
- (xlib-name? name))))
- symbol<?))
+++ /dev/null
-;;; -*- Scheme -*-
-
-(declare (usual-integrations))
-
-;;;; Plotting Package for Scheme Widget Application Toolkit
-
-;;; Working from the Scheme Prompt
-
-;;;(PLOTTER)
-;;; Creates a new plotter.
-;;;
-;;; Example: (define p (plotter))
-;;;
-;;;(PLOT plotter . options)
-;;; The options list sequentially describes one or more curves to be
-;;; plotted, in the following manner:
-;;;
-;;; (PLOT plotter
-;;; <function1> '<option> <value> '<option> <value> ... ;first curve
-;;; <function2> '<option> <value> ... ;second curve
-;;; ...
-;;; ...)
-;;; Returns a single curve if only one function is specified, and a
-;;; list of curves if more than one function is supplied.
-;;;
-;;; Example: (define c0 (plot p sin 'xmin -10 'xmax 5))
-;;; (define c1&2 (plot p cos 'pt-style 0 tan 'pt-style 5))
-;;;
-;;; The first parameter to PLOT after plotter must always be a
-;;; function. Curve-specific options affect only the function they
-;;; follow, and thus can and should be repeated. Any instance of a
-;;; global option after the first will be ignored.
-;;;
-;;; Global options and arguments:
-;;; 'XMIN: The minimum value of x to be displayed on the plot.
-;;; The default is 0.
-;;; 'XMAX: The maximum value of x to be displayed on the plot.
-;;; The default is 1.
-;;; 'YMIN: The minimum value of y to be displayed on the plot.
-;;; If not specified, the plot will be automatically scaled.
-;;; 'YMAX: The maximum value of y to be displayed on the plot.
-;;; If not specified, the plot will be automatically scaled.
-;;; 'AXIS-X: The value of x at which the y-axis will be drawn.
-;;; The default is 0.
-;;; 'AXIS-Y: The value of y at which the x-axis will be drawn.
-;;; The default is 0.
-;;; 'XTICKS: A list of pairs describing ticks on the x axis. The
-;;; car of each pair is the value of x at which to make
-;;; the tick. The cdr is a string to be displayed as a
-;;; label. The procedure MAKE-VALS can be used to return
-;;; a list of values for labels at regular intervals. If
-;;; not specified, only the extreme values will be labeled.
-;;; 'YTICKS: A list of pairs describing ticks on the y axis. Same
-;;; format as XTICKS. If not specified, only the extreme
-;;; values will be labeled.
-;;;
-;;; Curve-specific options and arguments
-;;; 'NUM-PTS: The number of points to be calculated for the curve.
-;;; The default is one for every 10 pixels.
-;;; 'PT-STYLE: A number representing the style in which the curve
-;;; will be drawn:
-;;; 0 -- lines to the x-axis
-;;; 1 -- large unfilled circles
-;;; 2 -- large unfilled squares
-;;; 3 -- x's
-;;; 4 -- +'s
-;;; 5 -- small filled circles
-;;; 6 -- small filled squares
-;;; 7 -- dots
-;;; 10 -- large unfilled circles with lines to the x-axis
-;;; 20 -- large unfilled squares with lines to the x-axis
-;;; 30 -- x's with lines to the x-axis
-;;; 40 -- +'s with lines to the x-axis
-;;; 50 -- small filled circles with lines to the x-axis
-;;; 60 -- small filled squares with lines to the x-axis
-;;; 100 -- lines between successive points
-;;; The default for the first curve is 0, and for all
-;;; others 100.
-;;; 'COLOR: The color of the curve, as a string or color-value.
-;;; The default for the first curve is black, and for all
-;;; others gray.
-;;; 'SHOW-VALS: A list of values of x at which to label the
-;;; corresponding value of y. The procedure
-;;; MAKE-VALS can be used to return a list of values
-;;; at regular intervals. The default is null.
-;;;
-;;;
-;;;(SET-PLOTTER-PARAMS plotter '<option> <value> ... '<option> <value>)
-;;; Options are the same as global options in PLOT. This does
-;;; basically the same thing as PLOT, but no *new* curve is drawn.
-;;; Parameters are reset and all the existing (non-cleared) curves
-;;; are redrawn. Thus, an alternative way to write the example above
-;;; is:
-;;;
-;;; Example: (set-plotter-params p 'xmin -10 'xmax 5)
-;;; (define c0 (plot p sin))
-;;;
-;;;(RESET-PLOTTER-PARAMS plotter)
-;;; Resets plotter's parameters to default params (the ones you see
-;;; when the plotter first comes up).
-;;;
-;;;
-;;;(MAKE-VALS min max spacing . centered?)
-;;; Returns a list of pairs that can be used for 'XTICKS 'YTICKS, or
-;;; 'SHOW-VALS. If centered? is #t, the ticks will be centered about
-;;; 0, with a tick at 0. Otherwise, the ticks will begin at the min
-;;; value.
-;;;
-;;; Example: (define c0 (plot p sin 'xmin -5 'xmax 5
-;;; 'xticks (make-vals -5 5 1)))
-;;;
-;;;(CHANGE-COLOR curve color)
-;;; Changes the color of the given curve and replots the curve.
-;;; Replots the curve if it's not cleared.
-;;;
-;;;(CHANGE-PT-STYLE curve pt-style)
-;;; Changes the point style of the given curve and replots the curve.
-;;; Replots the curve if it's not cleared.
-;;;
-;;;(CHANGE-NUM-PTS curve num-pts)
-;;; Changes the number of points calculated for the given curve and
-;;; replots the curve. Replots the curve if it's not cleared.
-;;;
-;;;
-;;;(CLEAR-CURVE curve)
-;;; Clears the given curve from the screen without deleting the curve
-;;; from the plotter.
-;;;
-;;;(PLOT-CURVE curve)
-;;; Replots the curve that has been cleared.
-;;;
-;;;(DELETE-CURVE curve)
-;;; Deletes the given curve from the plotter.
-;;;
-;;;(ADD-SHOW-VALS curve show-vals)
-;;; Add show-vals to a curve.
-;;;
-;;;(CLEAR-SHOW-VALS curve)
-;;; Clears all the curve's show vals, w/o deleting them from the curve.
-;;;
-;;;(DRAW-SHOW-VALS curve)
-;;; Redraws the cleared show-vals.
-;;;
-;;;(DELETE-SHOW-VALS curve)
-;;; Clears the curve's show-vals and deletes them from a curve.
-;;;
-;;;
-;;;(ADD-XTICKS plotter xticks)
-;;; Adds the specified xticks.
-;;;
-;;;(ADD-YTICKS plotter yticks)
-;;; Adds the specified yticks.
-;;;
-;;;(CLEAR-TICKS plotter)
-;;; Clears ticks from the axes of the plotter, without deleting them
-;;; from the plotter.
-;;;
-;;;(DRAW-TICKS plotter)
-;;; Redraws the cleared ticks.
-;;;
-;;;(DELETE-TICKS plotter)
-;;; Clears ticks from the axes of the plotter and deletes them from
-;;; the plotter.
-;;;
-;;;
-;;;(CLEAR-PLOTTER plotter)
-;;; Clears all plotter's curves and ticks.
-;;;
-;;;(REPLOT plotter)
-;;; Redraws all plotter's curves and ticks (including the cleared ones).
-;;;
-;;;(RESET-PLOTTER plotter)
-;;; Deletes all plotter's curves and ticks.
-
-
-\f
-;;;-------------------
-;;; Interface Monster
-;;;-------------------
-
-;;; Customizable Variables
-
-(define button-background-color "yellow")
-(define button-active-background-color "red")
-(define button-active-foreground-color "white")
-(define canvas-background-color "white")
-(define canvas-width 500)
-(define canvas-height 300)
-(define canvas-border-size 15)
-(define font "-Adobe-Helvetica-Bold-R-Normal--*-100-*")
-
-(define tick-precision 2)
-(define vals-precision 2)
-
-(define curve-max-num-pts 200)
-
-(define plotter-default-num-pts 50)
-(define plotter-default-pt-style 100)
-(define plotter-default-curve-color "black")
-(define plotter-default-xmin -5)
-(define plotter-default-xmax 5)
-(define plotter-default-ymin -1)
-(define plotter-default-ymax 1)
-(define plotter-default-axis-x 0)
-(define plotter-default-axis-y 0)
-(define plotter-default-xticks '())
-(define plotter-default-yticks '())
-
-\f
-(define (plotter)
- (let* ((plot-app (make-application "Plotter"))
- (plotter
- (make-plot-canvas canvas-width canvas-height canvas-background-color))
- (plot-canvas (plotter 'the-canvas))
- (func-button (make-button '(-text "Function")))
- (func-box #f)
- (options-menu (make-menu))
- (options-button (make-menubutton options-menu '(-text "Options")))
- (precision (add-to-menu options-menu 'command '-label "Precision"))
- (prec-box #f)
- (range (add-to-menu options-menu 'command '-label "Range"))
- (range-box #f)
- (plot-button (make-button '(-text "Plot")))
- (reset-button (make-button '(-text "Reset")))
- (button-box (make-hbox func-button options-button plot-button reset-button))
- (interface (make-vbox plot-canvas button-box)))
-
- (for-each (lambda (button)
- (ask-widget
- button
- `(configure -background ,button-background-color
- -activebackground ,button-active-background-color
- -activeforeground ,button-active-foreground-color)))
- (list func-button options-button plot-button reset-button))
-
- (for-each (lambda (button)
- (ask-widget
- button
- `(configure -background ,button-background-color
- -activebackground ,button-background-color)))
- (list range precision))
-
- (add-event-handler! plot-canvas "<Configure>" (plotter 'handle-resize))
-
- (set-callback!
- func-button
- (lambda ()
- (if (not func-box)
- (let ((new-func-box (make-func-box plot-app plotter)))
- (on-death! new-func-box 'func-dead (lambda () (set! func-box #f)))
- (set! func-box new-func-box)))))
-
- (set-callback!
- precision
- (lambda ()
- (if (not prec-box)
- (let ((new-prec-box (make-prec-box plot-app plotter)))
- (on-death! new-prec-box 'prec-dead (lambda () (set! prec-box #f)))
- (set! prec-box new-prec-box)))))
-
- (set-callback!
- range
- (lambda ()
- (if (not range-box)
- (let ((new-range-box (make-range-box plot-app plotter)))
- (on-death! new-range-box 'range-dead (lambda () (set! range-box #f)))
- (set! range-box new-range-box)))))
-
- (set-callback! plot-button (lambda () (plotter 'plot-current-func)))
- (set-callback! reset-button (lambda () (plotter 'clear-curves)))
-
- (on-death! interface 'interface-dead
- (lambda ()
- (if func-box (remove-child! plot-app func-box))
- (if range-box (remove-child! plot-app range-box))
- (if prec-box (remove-child! plot-app prec-box))))
-
- (swat-open-in-application plot-app interface)
- plotter))
-
-(define (make-func-box plot-app plotter)
- (let* ((func-entry (make-entry `(-width 40 -background ,canvas-background-color)))
- (func-ok-button
- (make-button
- `(-text "Ok" -background ,button-background-color
- -activebackground ,button-active-background-color
- -activeforeground ,button-active-foreground-color)))
- (func-box (make-hbox func-entry func-ok-button)))
- (define (function-callback)
- (let ((exp (ask-widget func-entry '(get))))
- (if (not (string-null? exp))
- ;; Of course, this could get an error while evaling; maybe
- ;; need something more clever.
- (let ((proc (eval (with-input-from-string exp read)
- user-initial-environment)))
- (if (not (procedure? proc))
- (error "Not a procedure" proc)
- ((plotter 'set-function) proc))))))
- (add-event-handler! func-entry "<KeyPress> <Return>" function-callback)
- (set-callback! func-ok-button function-callback)
- (swat-open-in-application plot-app func-box '-title "Enter a function of x")
- func-box))
-
-(define (make-prec-box plot-app plotter)
- (let* ((prec-scale
- (make-scale `(-from 0 -to ,curve-max-num-pts -orient horizontal
- -length ,(inexact->exact (* 1.5 curve-max-num-pts))
- -background ,canvas-background-color
- -sliderforeground ,button-background-color
- -activeforeground ,button-active-background-color)))
- (prec-redraw
- (make-button `(-text "Redraw Curves" -background ,button-background-color
- -activebackground ,button-active-background-color
- -activeforeground ,button-active-foreground-color)))
- (prec-box (make-vbox prec-scale prec-redraw)))
- (ask-widget prec-scale `(set ,(plotter 'default-num-pts)))
- (add-event-handler!
- prec-scale
- "<ButtonRelease-1>"
- (lambda ()
- ((plotter 'set-default-num-pts)
- (string->number (ask-widget prec-scale '(get))))))
- (set-callback! prec-redraw (lambda () (plotter 'plot-curves)))
- (swat-open-in-application plot-app prec-box '-title "Number of points:")
- prec-box))
-
-(define (make-range-box plot-app plotter)
- (let* ((range-ok-button
- (make-button `(-text "Ok" -background ,button-background-color
- -activebackground ,button-active-background-color
- -activeforeground ,button-active-foreground-color)))
- (xmin-text (make-active-variable plot-app))
- (xmax-text (make-active-variable plot-app))
- (ymin-text (make-active-variable plot-app))
- (ymax-text (make-active-variable plot-app))
- (xmin-entry (make-entry `(-textvariable ,xmin-text)))
- (xmax-entry (make-entry `(-textvariable ,xmax-text)))
- (ymin-entry (make-entry `(-textvariable ,ymin-text)))
- (ymax-entry (make-entry `(-textvariable ,ymax-text)))
- (x-label (make-label '(-text "Values of x:")))
- (xmin-label (make-label '(-text "From")))
- (xmax-label (make-label '(-text "To")))
- (y-label (make-label '(-text "Values of y:")))
- (ymin-label (make-label '(-text "From")))
- (ymax-label (make-label '(-text "To")))
- (x-box
- (make-vbox x-label
- (make-hbox xmin-label xmin-entry xmax-label xmax-entry)))
- (y-box
- (make-vbox y-label
- (make-hbox ymin-label ymin-entry ymax-label ymax-entry)))
- (range-box (make-hbox (make-vbox x-box y-box) range-ok-button)))
- (for-each (lambda (label)
- (ask-widget label `(configure -background ,canvas-background-color)))
- (list x-label xmin-label xmax-label y-label ymin-label ymax-label))
- (for-each (lambda (entry)
- ;; background color?
- (ask-widget entry `(configure -width 5)))
- (list xmin-entry xmax-entry ymin-entry ymax-entry))
- (set-callback!
- range-ok-button
- (lambda ()
- (let ((xmin (plotter 'xmin))
- (xmax (plotter 'xmax))
- (ymin (plotter 'ymin))
- (ymax (plotter 'ymax))
- (new-xmin (string->number (ask-widget xmin-entry '(get))))
- (new-xmax (string->number (ask-widget xmax-entry '(get))))
- (new-ymin (string->number (ask-widget ymin-entry '(get))))
- (new-ymax (string->number (ask-widget ymax-entry '(get)))))
- (if (not (and (eqv? xmin new-xmin)
- (eqv? xmax new-xmax)
- (eqv? ymin new-ymin)
- (eqv? ymax new-ymax)))
- (begin
- ((plotter 'set-xmin) new-xmin)
- ((plotter 'set-xmax) new-xmax)
- ((plotter 'set-ymin) new-ymin)
- ((plotter 'set-ymax) new-ymax)
- (plotter 'clear)
- (draw-axes plotter)
- (plotter 'plot-curves))))))
- (swat-open-in-application plot-app range-box '-title "Range")
- (set-active-variable! xmin-text (plotter 'xmin))
- (set-active-variable! xmax-text (plotter 'xmax))
- (set-active-variable! ymin-text (plotter 'ymin))
- (set-active-variable! ymax-text (plotter 'ymax))
- range-box))
-
-\f
-;;;-------------
-;;; The Plotter
-;;;-------------
-
-(define (make-plot-canvas hsize vsize bgrnd-color)
- (let ((default-num-pts plotter-default-num-pts)
- (default-pt-style plotter-default-pt-style)
- (default-color plotter-default-curve-color)
- (xmin plotter-default-xmin)
- (xmax plotter-default-xmax)
- (ymin plotter-default-ymin)
- (ymax plotter-default-ymax)
- (yaxis.xval plotter-default-axis-x)
- (xaxis.yval plotter-default-axis-y)
- (xticks plotter-default-xticks)
- (yticks plotter-default-yticks)
- (current-func #f)
- (current-func-curve #f)
- (curve-list '())
- (resize-flag #f))
- (let* ((the-canvas (make-canvas `(-width ,hsize -height ,vsize
- -background ,bgrnd-color)))
- (axes-tag (make-canvas-item-group the-canvas '()))
- (ticks-tag (make-canvas-item-group the-canvas '())))
- (define (plotter messg)
- (case messg
- ((hsize) hsize)
- ((vsize) vsize)
- ((the-canvas) the-canvas)
- ((curve-list) curve-list)
- ((default-num-pts) default-num-pts)
- ((set-default-num-pts)
- (lambda (new-num-pts) (set! default-num-pts new-num-pts)))
- ((default-pt-style) default-pt-style)
- ((set-default-pt-style)
- (lambda (new-pt-style) (set! default-pt-style new-pt-style)))
- ((default-color) default-color)
- ((set-default-color)
- (lambda (new-color) (set! default-color new-color)))
- ((function) current-func)
- ((set-function)
- (lambda (func)
- (set! current-func-curve #f)
- (set! current-func func)))
- ((xmin) xmin)
- ((set-xmin) (lambda (new-xmin) (set! xmin new-xmin)))
- ((xmax) xmax)
- ((set-xmax) (lambda (new-xmax) (set! xmax new-xmax)))
- ((ymin) ymin)
- ((set-ymin) (lambda (new-ymin) (set! ymin new-ymin)))
- ((ymax) ymax)
- ((set-ymax) (lambda (new-ymax) (set! ymax new-ymax)))
- ((xaxis.yval) xaxis.yval)
- ((yaxis.xval) yaxis.xval)
- ((xaxis.y)
- (let ((y-range (- ymax ymin)))
- (if (= y-range 0)
- (error "ymin and ymax are the same--MAKE-PLOT-CANVAS" ymin)
- (+ (* (exact->inexact (/ (- (* canvas-border-size 2) vsize)
- y-range))
- (- xaxis.yval ymin))
- vsize
- (- canvas-border-size)))))
- ((yaxis.x)
- (let ((x-range (- xmax xmin)))
- (if (= x-range 0)
- (error "xmin and xmax are the same--MAKE-PLOT-CANVAS" xmin)
- (+ (* (exact->inexact (/ (- hsize (* canvas-border-size 2))
- (- xmax xmin)))
- (- yaxis.xval xmin))
- canvas-border-size))))
- ((xticks) xticks)
- ((set-xticks) (lambda (new-xticks) (set! xticks new-xticks)))
- ((yticks) yticks)
- ((set-yticks) (lambda (new-yticks) (set! yticks new-yticks)))
- ((axes-tag) axes-tag)
- ((ticks-tag) ticks-tag)
- ((set-params)
- (lambda (new-xmin new-xmax new-ymin new-ymax
- new-yaxis.xval new-xaxis.yval new-xticks new-yticks)
- (set! xmin new-xmin)
- (set! xmax new-xmax)
- (set! ymin new-ymin)
- (set! ymax new-ymax)
- (set! yaxis.xval new-yaxis.xval)
- (set! xaxis.yval new-xaxis.yval)
- (set! xticks new-xticks)
- (set! yticks new-yticks)
- 'set))
- ((x:val->pix) (x:val->pix xmin xmax hsize))
- ((y:val->pix) (y:val->pix ymin ymax vsize))
- ((add-curve)
- (lambda (curve) (set! curve-list (append curve-list (list curve)))))
- ((plot-current-func)
- (if (and current-func (not current-func-curve))
- (let ((new-curve
- (make-curve plotter current-func default-pt-style
- default-num-pts default-color #f)))
- (set! current-func-curve new-curve)
- (set! curve-list (cons new-curve curve-list))
- (new-curve 'plot))))
- ((plot-curves)
- (for-each (lambda (curve)
- (if (not (curve 'cleared?))
- (curve 'plot)))
- curve-list)
- 'plotted)
- ((clear)
- (ask-widget the-canvas '(delete all))
- 'cleared)
- ((clear-curves)
- (for-each (lambda (curve) (curve 'clear)) curve-list)
- 'cleared)
- ((delete-curve)
- (lambda (curve)
- (curve 'clear)
- (set! curve-list (delq curve curve-list))
- 'deleted))
- ((delete-curves)
- (for-each (lambda (curve) (curve 'clear)) curve-list)
- (set! curve-list #f)
- 'deleted)
- ((clear-axes)
- (ask-widget axes-tag '(delete))
- 'cleared)
- ((clear-ticks)
- (ask-widget ticks-tag '(delete))
- 'cleared)
- ((delete-ticks)
- (set! xticks '())
- (set! yticks '())
- (ask-widget ticks-tag '(delete))
- 'deleted)
- ((handle-resize)
- (lambda ()
- ;; For some reason, the "<Configure>" event gets generated
- ;; twice per window resize -- so skip one of them.
- (if (not resize-flag)
- (set! resize-flag #t)
- (begin
- (set! resize-flag #f)
- (ask-widget the-canvas '(delete all))
- (let ((old-width hsize)
- (width (UITKRectangle.width
- (assigned-screen-area the-canvas)))
- (height (UITKRectangle.height
- (assigned-screen-area the-canvas))))
- (set! hsize width)
- (set! vsize height)
- (set! default-num-pts (round (* default-num-pts
- (/ width old-width))))
- (draw-axes plotter)
- (for-each
- (lambda (curve)
- (curve-scale-num-pts!
- curve (exact->inexact (/ width old-width)))
- (if (not (curve 'cleared?))
- (begin (curve 'clear)
- (curve 'plot))))
- curve-list))))))
- (else (error "Bad message--PLOTTER" messg))))
- plotter)))
-\f
-(define ((x:val->pix xmin xmax hsize) x)
- (+ (* (exact->inexact
- (/ (- hsize (* canvas-border-size 2))
- (- xmax xmin)))
- (- x xmin))
- canvas-border-size))
-
-(define ((y:val->pix ymin ymax vsize) y)
- (+ (* (exact->inexact
- (/ (- (* canvas-border-size 2) vsize)
- (- ymax ymin)))
- (- y ymin))
- vsize
- (- canvas-border-size)))
-
-(define (draw-xticks plotter)
- (let ((xticks (plotter 'xticks)))
- (if xticks
- (let ((plot-canvas (plotter 'the-canvas))
- (x:val->pix (plotter 'x:val->pix))
- (xmin (plotter 'xmin))
- (xmax (plotter 'xmax))
- (xaxis.y (plotter 'xaxis.y))
- (ticks-tag (plotter 'ticks-tag))
- (factor (expt 10 tick-precision)))
- (for-each
- (lambda (tick)
- (if (> xmax tick xmin)
- (let ((val (x:val->pix tick))
- (tag (swat:number->string
- (/ (truncate (* factor tick)) factor))))
- (add-to-canvas-item-group
- ticks-tag
- (make-line-on-canvas plot-canvas
- val (- xaxis.y 4)
- val (+ xaxis.y 4)))
- (add-to-canvas-item-group
- ticks-tag
- (make-text-on-canvas plot-canvas
- val (- xaxis.y 9)
- `(-text ,tag -font ,font))))))
- xticks))))
- 'drawn)
-
-(define (draw-yticks plotter)
- (let ((yticks (plotter 'yticks)))
- (if yticks
- (let ((plot-canvas (plotter 'the-canvas))
- (y:val->pix (plotter 'y:val->pix))
- (ymin (plotter 'ymin))
- (ymax (plotter 'ymax))
- (yaxis.x (plotter 'yaxis.x))
- (ticks-tag (plotter 'ticks-tag))
- (factor (expt 10 tick-precision)))
- (for-each
- (lambda (tick)
- (if (> ymax tick ymin)
- (let ((val (y:val->pix tick))
- (tag (swat:number->string
- (/ (truncate (* factor tick)) factor))))
- (add-to-canvas-item-group
- ticks-tag
- (make-line-on-canvas plot-canvas
- (- yaxis.x 4) val
- (+ yaxis.x 4) val))
- (add-to-canvas-item-group
- ticks-tag
- (make-text-on-canvas plot-canvas
- (+ yaxis.x 6) val
- `(-text ,tag -anchor w
- -font ,font))))))
- yticks))))
- 'drawn)
-
-(define (draw-axes plotter)
- (let* ((plot-canvas (plotter 'the-canvas))
- (hsize (plotter 'hsize))
- (vsize (plotter 'vsize))
- (xmin (plotter 'xmin))
- (xmax (plotter 'xmax))
- (ymin (plotter 'ymin))
- (ymax (plotter 'ymax))
- (xaxis.yval (plotter 'xaxis.yval))
- (yaxis.xval (plotter 'yaxis.xval))
- (xaxis.y (plotter 'xaxis.y))
- (yaxis.x (plotter 'yaxis.x))
- (axes-tag (plotter 'axes-tag))
- (trim 3)
- (x-.x trim)
- (x+.x (- hsize trim))
- (y-.y trim)
- (y+.y (- vsize trim)))
- (if (>= ymax xaxis.yval ymin)
- (begin
- (add-to-canvas-item-group
- axes-tag
- (make-line-on-canvas plot-canvas x+.x xaxis.y x-.x xaxis.y '(-arrow both)))
- (draw-xticks plotter)
- (make-text-on-canvas plot-canvas
- (- hsize trim) (- xaxis.y trim)
- `(-text ,(swat:number->string xmax) -anchor se)) ;
- (make-text-on-canvas plot-canvas
- trim (- xaxis.y trim)
- `(-text ,(swat:number->string xmin) -anchor sw))))
- (if (>= xmax yaxis.xval xmin)
- (begin
- (add-to-canvas-item-group
- axes-tag
- (make-line-on-canvas plot-canvas yaxis.x y+.y yaxis.x y-.y '(-arrow both)))
- (draw-yticks plotter)
- (let ((factor (expt 10 tick-precision)))
- (make-text-on-canvas plot-canvas
- (+ yaxis.x 8) trim
- `(-text ,(swat:number->string
- (/ (round (* ymax factor)) factor))
- -anchor nw))
- (make-text-on-canvas plot-canvas
- (+ yaxis.x 8) vsize
- `(-text ,(swat:number->string
- (/ (round (* ymin factor)) factor))
- -anchor sw)))))
- 'done))
-\f
-;;;--------
-;;; Curves
-;;;--------
-
-(define (make-curve plotter function pt-style num-pts color show-vals)
- (let* ((plot-canvas (plotter 'the-canvas))
- (curve-tag (make-canvas-item-group plot-canvas '()))
- (outline-tag (make-canvas-item-group plot-canvas '()))
- (vals-tag (make-canvas-item-group plot-canvas '()))
- (cleared? #f))
- (lambda (messg)
- (case messg
- ((plotter) plotter)
- ((num-pts) num-pts)
- ((set-num-pts) (lambda (new-num-pts) (set! num-pts new-num-pts)))
- ((show-vals) show-vals)
- ((set-show-vals) (lambda (new-vals) (set! show-vals new-vals)))
- ((cleared?) cleared?)
- ((change-pt-style)
- (lambda (new-pt-style)
- (cond ((pt-style? new-pt-style)
- (set! pt-style new-pt-style))
- (else (write-line "Not a style--MAKE-CURVE") pt-style))))
- ((change-color)
- (lambda (new-color)
- (set! color new-color)
- (if (not cleared?)
- (begin
- (ask-widget curve-tag `(configure -fill ,color))
- (ask-widget outline-tag `(configure -outline ,color))
- (ask-widget vals-tag `(configure -fill ,color))))))
- ((get-extreme-vals)
- (lambda (min max)
- (get-extreme-vals function min max num-pts)))
- ((plot)
- (graph function plotter curve-tag outline-tag pt-style num-pts color)
- (if show-vals
- (graph-vals function plotter show-vals vals-tag color))
- (set! cleared? #f)
- 'plotted)
- ((draw-vals)
- (if show-vals
- (graph-vals function plotter show-vals vals-tag color))
- 'drawn)
- ((clear-vals)
- (ask-widget vals-tag '(delete))
- 'cleared)
- ((delete-vals)
- (ask-widget vals-tag '(delete))
- (set! show-vals #f)
- 'removed)
- ((clear)
- (ask-widget curve-tag '(delete))
- (ask-widget outline-tag '(delete))
- (ask-widget vals-tag '(delete))
- (set! cleared? #t)
- 'cleared)
- (else (error "Bad message--MAKE-CURVE" messg))))))
-
-(define (get-extreme-vals function min max num-pts)
- (let* ((factor (expt 10 vals-precision))
- (first-val (function min))
- (min-val first-val)
- (max-val first-val)
- (step (exact->inexact (/ (- max min) num-pts))))
- (define (calculate x)
- (let ((val (function x)))
- (cond ((> x max)
- (list (/ (round (* min-val factor)) factor)
- (/ (round (* max-val factor)) factor)))
- ((< val min-val) (set! min-val val)
- (calculate (+ x step)))
- ((> val max-val) (set! max-val val)
- (calculate (+ x step)))
- (else (calculate (+ x step))))))
- (calculate (+ min step))))
-
-(define (pt-style? val)
- (memv val '(0 1 2 3 4 5 6 7 10 20 30 40 50 60 100)))
-
-(define (curve-scale-num-pts! curve factor)
- ((curve 'set-num-pts) (round (* (curve 'num-pts) factor))))
-
-(define (maybe-replot-curve curve)
- (if (not (curve 'cleared?))
- (begin (curve 'clear)
- (curve'plot))))
-\f
-(define (graph function plotter curve-tag outline-tag pt-style num-pts color)
- (let ((plot-canvas (plotter 'the-canvas))
- (xmin (plotter 'xmin))
- (xmax (plotter 'xmax))
- (xaxis.yval (plotter 'xaxis.yval))
- (x:val->pix (plotter 'x:val->pix))
- (y:val->pix (plotter 'y:val->pix)))
- (let ((xaxis.y (y:val->pix xaxis.yval)))
-
- (define (draw-0 x y)
- (add-to-canvas-item-group
- curve-tag (make-line-on-canvas plot-canvas x xaxis.y x y)))
- (define (draw-1 x y)
- (add-to-canvas-item-group
- outline-tag
- (make-oval-on-canvas plot-canvas (- x 3) (- y 3) (+ x 3) (+ y 3))))
- (define (draw-2 x y)
- (add-to-canvas-item-group
- outline-tag
- (make-rectangle-on-canvas plot-canvas (- x 3) (- y 3) (+ x 3) (+ y 3))))
- (define (draw-3 x y)
- (add-to-canvas-item-group
- curve-tag
- (make-line-on-canvas plot-canvas (- x 2) (- y 2) (+ x 3) (+ y 3)))
- (add-to-canvas-item-group
- curve-tag
- (make-line-on-canvas plot-canvas (+ x 2) (- y 2) (- x 2) (+ y 2))))
- (define (draw-4 x y)
- (add-to-canvas-item-group
- curve-tag (make-line-on-canvas plot-canvas x (- y 2) x (+ y 3)))
- (add-to-canvas-item-group
- curve-tag (make-line-on-canvas plot-canvas (- x 2) y (+ x 3) y)))
- (define (draw-5 x y)
- (let ((seg (make-oval-on-canvas plot-canvas
- (- x 2) (- y 2) (+ x 2) (+ y 2))))
- (add-to-canvas-item-group curve-tag seg)
- (add-to-canvas-item-group outline-tag seg)))
- (define (draw-6 x y)
- (let ((seg (make-rectangle-on-canvas plot-canvas
- (- x 2) (- y 2) (+ x 2) (+ y 2))))
- (add-to-canvas-item-group curve-tag seg)
- (add-to-canvas-item-group outline-tag seg)))
- (define (draw-7 x y)
- (add-to-canvas-item-group
- curve-tag (make-text-on-canvas plot-canvas x (- y 2) '(-text "."))))
- (define (draw-10 x y)
- (add-to-canvas-item-group
- curve-tag (make-line-on-canvas plot-canvas x xaxis.y x (+ y 3)))
- (add-to-canvas-item-group
- outline-tag (make-oval-on-canvas
- plot-canvas (- x 3) (- y 3) (+ x 3) (+ y 3))))
- (define (draw-20 x y)
- (add-to-canvas-item-group
- curve-tag (make-line-on-canvas plot-canvas x xaxis.y x (+ y 2)))
- (add-to-canvas-item-group
- outline-tag
- (make-rectangle-on-canvas plot-canvas
- (- x 3) (- y 3) (+ x 3) (+ y 3))))
- (define (draw-30 x y)
- (add-to-canvas-item-group
- curve-tag (make-line-on-canvas plot-canvas
- (- x 2) (- y 2) (+ x 3) (+ y 3)))
- (add-to-canvas-item-group
- curve-tag (make-line-on-canvas plot-canvas
- (+ x 2) (- y 2) (- x 2) (+ y 2)))
- (add-to-canvas-item-group
- curve-tag (make-line-on-canvas plot-canvas x xaxis.y x y)))
- (define (draw-40 x y)
- (add-to-canvas-item-group
- curve-tag (make-line-on-canvas plot-canvas x (- y 2) x xaxis.y))
- (add-to-canvas-item-group
- curve-tag (make-line-on-canvas plot-canvas (- x 2) y (+ x 3) y)))
- (define (draw-50 x y)
- (let ((seg1 (make-oval-on-canvas plot-canvas
- (- x 2) (- y 2) (+ x 2) (+ y 2)))
- (seg2 (make-line-on-canvas plot-canvas x xaxis.y x (+ y 2))))
- (add-to-canvas-item-group outline-tag seg1)
- (add-to-canvas-item-group curve-tag seg1)
- (add-to-canvas-item-group curve-tag seg2)))
- (define (draw-60 x y)
- (let ((seg1 (make-rectangle-on-canvas plot-canvas
- (- x 2) (- y 2) (+ x 2) (+ y 2)))
- (seg2 (make-line-on-canvas plot-canvas x xaxis.y x (+ y 2))))
- (add-to-canvas-item-group outline-tag seg1)
- (add-to-canvas-item-group curve-tag seg1)
- (add-to-canvas-item-group curve-tag seg2)))
-
- (define (draw-dispatch pt-style)
- (cond ((= pt-style 0) draw-0)
- ((= pt-style 1) draw-1)
- ((= pt-style 2) draw-2)
- ((= pt-style 3) draw-3)
- ((= pt-style 4) draw-4)
- ((= pt-style 5) draw-5)
- ((= pt-style 6) draw-6)
- ((= pt-style 7) draw-7)
- ((= pt-style 10) draw-10)
- ((= pt-style 20) draw-20)
- ((= pt-style 30) draw-30)
- ((= pt-style 40) draw-40)
- ((= pt-style 50) draw-50)
- ((= pt-style 60) draw-60)))
-
- (let* ((draw (draw-dispatch pt-style))
- (xstep (exact->inexact (/ (- xmax xmin) num-pts))))
- (define (calc-100 last-x last-y x y)
- (if (not (> x xmax))
- (let ((segment
- (make-line-on-canvas plot-canvas
- (x:val->pix last-x)
- (y:val->pix last-y)
- (x:val->pix x)
- (y:val->pix y))))
- (add-to-canvas-item-group curve-tag segment)
- (calc-100 x y (+ x xstep) (function (+ x xstep))))))
- (define (calculate x y)
- (if (not (> x xmax))
- (begin (draw (x:val->pix x) (y:val->pix y))
- (calculate (+ x xstep) (function (+ x xstep))))))
-
- (if (= pt-style 100)
- (calc-100 xmin (function xmin) (+ xmin xstep) (function (+ xmin xstep)))
- (calculate xmin (function xmin)))
- (ask-widget curve-tag `(configure -fill ,color))
- (ask-widget outline-tag `(configure -outline ,color))))))
-
-(define (graph-vals function plotter show-vals vals-tag color)
- (let ((factor (expt 10 vals-precision))
- (x:val->pix (plotter 'x:val->pix))
- (y:val->pix (plotter 'y:val->pix))
- (plot-canvas (plotter 'the-canvas)))
- (let marker ((show-vals show-vals))
- (if (not (null? show-vals))
- (let* ((x-val (car show-vals))
- (x (x:val->pix x-val))
- (y-val (function x-val))
- (y (y:val->pix y-val))
- (pos-y? (>= y-val (plotter 'xaxis.yval))))
- (add-to-canvas-item-group
- vals-tag
- (make-text-on-canvas
- plot-canvas x (if pos-y? (- y 3) (+ y 6))
- `(-text ,(swat:number->string (/ (round (* y-val factor)) factor))
- -anchor ,(if pos-y? 's 'n))))
- (add-to-canvas-item-group
- vals-tag
- (make-text-on-canvas plot-canvas x y '(-text "|")))
- (marker (cdr show-vals)))))
- (ask-widget vals-tag `(configure -fill ,color))))
-
-\f
-;;;-------------------------
-;;; Scheme-prompt Interface
-;;;-------------------------
-
-(define (plot plotter . spec-list)
- (define (package-curves arg-list)
- (let package-loop ((result (list (car arg-list)))
- (rest (cdr arg-list)))
- (cond ((null? rest) (list (reverse result)))
- ((procedure? (car rest))
- (cons (reverse result) (package-curves rest)))
- (else (package-loop (cons (car rest) result) (cdr rest))))))
- (if (not (null? spec-list))
- (let* ((curve-desc-list (package-curves spec-list))
- (old-xmin (plotter 'xmin))
- (old-xmax (plotter 'xmax))
- (old-ymin (plotter 'ymin))
- (old-ymax (plotter 'ymax))
- (old-axis-y (plotter 'xaxis.yval))
- (old-axis-x (plotter 'yaxis.xval))
- (old-xticks (plotter 'xticks))
- (old-yticks (plotter 'yticks))
- (xmin~ #f) (axis-x~ #f) (num-pts~ #f)
- (xmax~ #f) (axis-y~ #f) (pt-style~ #f)
- (ymin~ #f) (xticks~ #f) (color~ #f)
- (ymax~ #f) (yticks~ #f) (show-vals~ #f)
- (default-num-pts (plotter 'default-num-pts))
- (default-pt-style (plotter 'default-pt-style))
- (default-color (plotter 'default-color))
- (curve-list '()))
-
- (define (process-next-curve curve-desc)
- (let ((f (car curve-desc))
- (curve-options (cdr curve-desc)))
- (let curve-loop ((curve-options curve-options))
- (if (not (null? curve-options))
- (let ((option-name (car curve-options)))
- (cond ((not (symbol? option-name))
- (error "Bad option--PLOT" option-name))
- ((null? (cdr curve-options))
- (error "PLOT: No value specified for option"
- option-name))
- (else
- (let ((option-value (cadr curve-options)))
- (process-option option-name option-value)
- (curve-loop (cddr curve-options))))))))
- (make-curve plotter
- f
- (or pt-style~ default-pt-style)
- (or num-pts~ default-num-pts)
- (or color~ default-color)
- show-vals~)))
-
- (define (process-option name value)
- (case name
- ;; global options
- ((xmin) (if (not xmin~) (set! xmin~ value)))
- ((xmax) (if (not xmax~) (set! xmax~ value)))
- ((ymin) (if (not ymin~) (set! ymin~ value)))
- ((ymax) (if (not ymax~) (set! ymax~ value)))
- ((axis-x) (if (not axis-x~) (set! axis-x~ value)))
- ((axis-y) (if (not axis-y~) (set! axis-y~ value)))
- ((xticks) (if (not xticks~) (set! xticks~ value)))
- ((yticks) (if (not yticks~) (set! xticks~ value)))
- ;; curve-specific options
- ((num-pts) (set! num-pts~ value))
- ((pt-style) (set! pt-style~ value))
- ((color) (set! color~ value))
- ((show-vals) (set! show-vals~ value))
- (else (error "Illegal option--PLOT" name))))
-
- (define (reset-options!)
- (set! num-pts~ #f)
- (set! pt-style~ #f)
- (set! color~ #f)
- (set! show-vals~ #f))
-
- (let process-loop ((curve-desc-list (reverse curve-desc-list)))
- (if (not (null? curve-desc-list))
- (let ((new-curve (process-next-curve (car curve-desc-list))))
- ((plotter 'add-curve) new-curve)
- (set! curve-list (cons new-curve curve-list))
- (reset-options!)
- (process-loop (cdr curve-desc-list)))))
-
- (let* ((xmin (or xmin~ old-xmin))
- (xmax (or xmax~ old-xmax))
- (get-extremes
- (lambda (xmin xmax)
- (map (lambda (curve) ((curve 'get-extreme-vals) xmin xmax))
- curve-list)))
- (extremes #f)
- (ymin
- (or ymin~
- (min
- old-ymin
- (let ((xtremes (get-extremes xmin xmax)))
- (set! extremes xtremes)
- (apply min (cons 0 (map (lambda (e) (car e)) xtremes)))))))
- (ymax
- (or ymax~
- (max
- old-ymax
- (let ((xtremes
- (if extremes extremes (get-extremes xmin xmax))))
- (apply max (cons 0 (map (lambda (e) (cadr e)) xtremes)))))))
- (axis-y (or axis-y~ old-axis-y))
- (axis-x (or axis-x~ old-axis-x)))
-
- (if (and (= xmin old-xmin)
- (= xmax old-xmax)
- (= ymin old-ymin)
- (= ymax old-ymax)
- (= axis-x old-axis-x)
- (= axis-y old-axis-y)
- (equal? xticks~ old-xticks)
- (equal? yticks~ old-yticks))
- ;; only plot the new curves
- (for-each (lambda (new-curve) (new-curve 'plot))
- curve-list)
- ;; if a global param changed, replot everything
- (begin
- ((plotter 'set-params)
- xmin xmax ymin ymax axis-x axis-y xticks~ yticks~)
- (plotter 'clear)
- (draw-axes plotter)
- (plotter 'plot-curves)))
-
- ;; return the curve if there's only one, list of curves if more.
- (and (pair? curve-list)
- (if (= (length curve-list) 1)
- (car curve-list)
- curve-list))))))
-
-(define (set-plotter-params plotter . spec-list)
- (let ((xmin (plotter 'xmin))
- (xmax (plotter 'xmax))
- (ymin (plotter 'ymin))
- (ymax (plotter 'ymax))
- (axis-x (plotter 'yaxis.xval))
- (axis-y (plotter 'xaxis.yval))
- (xticks (plotter 'xticks))
- (yticks (plotter 'yticks)))
- (define (process-option name value)
- (case name
- ;; global options
- ((xmin) (set! xmin value))
- ((xmax) (set! xmax value))
- ((ymin) (set! ymin value))
- ((ymax) (set! ymax value))
- ((axis-x) (set! axis-x value))
- ((axis-y) (set! axis-y value))
- ((xticks) (set! xticks value))
- ((yticks) (set! xticks value))
- (else (error "Illegal option--SET-PLOTTER-PARAMS" name))))
- (let process-loop ((options spec-list))
- (if (not (null? options))
- (let ((option-name (car options)))
- (cond ((not (symbol? option-name))
- (error "Bad option--PLOT" option-name))
- ((null? (cdr options))
- (error "SET-PLOTTER-PARAMS: No value specified for option"
- option-name))
- (else
- (let ((option-value (cadr options)))
- (process-option option-name option-value)
- (process-loop (cddr options))))))))
- ((plotter 'set-params) xmin xmax ymin ymax axis-x axis-y xticks yticks)
- (plotter 'clear)
- (draw-axes plotter)
- (plotter 'plot-curves)))
-
-(define (reset-plotter-params plotter)
- (apply set-plotter-params
- (list 'xmin plotter-default-xmin
- 'xmax plotter-default-xmax
- 'ymin plotter-default-ymin
- 'ymax plotter-default-ymax
- 'axis-x plotter-default-axis-x
- 'axis-y plotter-default-axis-y
- 'xticks plotter-default-xticks
- 'yticks plotter-default-yticks)))
-
-\f
-(define (make-vals min max spacing . center?)
- (let ((min (if center? (* spacing (round (/ min spacing))) min)))
- (define (tick-maker val)
- (if (> val max)
- '()
- (cons val (tick-maker (+ val spacing)))))
- (tick-maker min)))
-
-
-(define (change-color curve color)
- ((curve 'change-color) color))
-
-(define (change-pt-style curve pt-style)
- ((curve 'change-pt-style) pt-style)
- (maybe-replot-curve curve))
-
-(define (change-num-pts curve num-pts)
- ((curve 'set-num-pts) num-pts)
- (maybe-replot-curve curve))
-
-(define (clear-curve curve)
- (curve 'clear))
-
-(define (plot-curve curve)
- (if (curve 'cleared?)
- (curve 'plot)))
-
-(define (delete-curve curve)
- (((curve 'plotter) 'delete-curve) curve))
-
-(define (add-show-vals curve show-vals)
- (curve 'clear-vals)
- ((curve 'set-show-vals)
- (append (curve 'show-vals) show-vals))
- (curve 'draw-vals))
-
-(define (clear-show-vals curve)
- (curve 'clear-vals))
-
-(define (draw-show-vals curve)
- (curve 'draw-vals))
-
-(define (delete-show-vals curve)
- (curve 'delete-vals))
-
-
-(define (add-xticks plotter xticks)
- ((plotter 'set-xticks)
- (append (plotter 'xticks) xticks))
- (plotter 'clear-axes)
- (draw-axes plotter))
-
-(define (add-yticks plotter yticks)
- ((plotter 'set-yticks)
- (append (plotter 'xticks) yticks))
- (plotter 'clear-axes)
- (draw-axes plotter))
-
-(define (clear-ticks plotter)
- (plotter 'clear-ticks))
-
-(define (draw-ticks plotter)
- (draw-xticks plotter)
- (draw-yticks plotter))
-
-(define (delete-ticks plotter)
- (plotter 'delete-ticks))
-
-(define (clear-plotter plotter)
- (plotter 'clear-curves)
- (plotter 'clear-ticks))
-
-(define (replot plotter)
- (draw-ticks plotter)
- (for-each plot-curve (plotter 'curve-list))
- 'replotted)
-
-(define (reset-plotter plotter)
- (plotter 'delete-curves)
- (plotter 'delete-ticks)
- (plotter 'clear)
- (draw-axes plotter)
- 'reset)
-
+++ /dev/null
-;;; -*- Scheme -*-
-
-(declare (usual-integrations))
-
-;;;Demo of DT frequency response by frobbing poles and zeros
-
-(define half-window-size 200)
-(define zero-size 5)
-(define pole-size 4)
-(define trim 10)
-(define zero-color "violetred")
-(define pole-color "blue")
-(define canvas-color "white")
-(define text-font "CourR12")
-
-
-(define symbol-font
- "-adobe-symbol-medium-r-normal--14-100-100-100-p-85-adobe-fontspecific")
-
-(define tracking-coords? #F)
-(define time-to-update-plot? #F)
-(define LOCATION 'later) ; active variable
-(define all-zeros '()) ; alist of zeros(objects)/coords
-(define all-poles '()) ; alist of poles(objects)/coords
-
-(define number-of-points 100)
-(define max-w 3.14159)
-
-;;hack to print numbers to three decimals
-(define (unsigned->string n)
- (let* ((int-part (floor n))
- (frac-part (- n int-part))
- (dec (floor->exact (* frac-part 1000)))
- (string-dec (number->string dec))
- (padded-string-dec
- (cond ((< dec 10) (string-append "00" string-dec))
- ((< dec 100) (string-append "0" string-dec))
- (else string-dec))))
- (string-append (number->string (floor->exact int-part))
- "."
- padded-string-dec)))
-
-(define (our-cx->string z)
- (let* ((r (real-part z))
- (i (imag-part z))
- (rs (unsigned->string (abs r)))
- (is (unsigned->string (abs i)))
- (signed-r
- (if (< r 0)
- (string-append "-" rs)
- rs))
- (signed-i
- (if (< i 0)
- (string-append "-" is)
- (string-append "+" is))))
- (string-append signed-r signed-i "j")))
-
-(define (our-real->string r)
- (let* ((rs (unsigned->string (abs r)))
- (signed-r
- (if (< r 0)
- (string-append "-" rs)
- rs)))
- signed-r))
-
-
-(define (z->canvas-coords z)
- (let ((x (real-part z))
- (y (imag-part z)))
- (list
- (round->exact
- (+ (* x (- half-window-size (* 2 trim)))
- half-window-size))
- (round->exact
- (+ (* y (- (* 2 trim) half-window-size))
- half-window-size)))))
-
-(define (canvas-coords->z xy)
- (let ((x (exact->inexact (car xy)))
- (y (exact->inexact (cadr xy))))
- (let ((real (/ (- x half-window-size)
- (- half-window-size (* 2 trim))))
- (imag (/ (- y half-window-size)
- (- (* 2 trim) half-window-size))))
- (+ real (* imag +i)))))
-
-;;; Pole/Zero Movement
-(define (move-with-conjugate-pair pole-zero obj1 obj2)
- (let ((last-x 'later)
- (last-y 'later))
- (define (keep-track-of-coords x y)
- (set! last-x x)
- (set! last-y y)
- (if tracking-coords?
- (let ((z (canvas-coords->z (list last-x last-y))))
- (set-active-variable! LOCATION (our-cx->string z)))))
- (define (store-coords)
- (let* ((zero-entry (assq obj1 all-zeros))
- (obj1-entry
- (if zero-entry zero-entry (assq obj1 all-poles)))
- (obj2-entry
- (if zero-entry
- (assq obj2 all-zeros)
- (assq obj2 all-poles)))
- (z (canvas-coords->z (list last-x last-y))))
- (set-cdr! obj1-entry z)
- (set-cdr! obj2-entry (conjugate z))))
- (add-event-handler!
- obj1
- "<ButtonPress-1>"
- (lambda (x y)
- (set! time-to-update-plot? #F)
- (keep-track-of-coords x y))
- "%x" "%y")
- (add-event-handler!
- obj1
- "<ButtonRelease-1>"
- (lambda ()
- (store-coords)
- (maybe-update-plot (pole-zero 'graph-canvas))
- ))
- (add-event-handler!
- obj1
- "<B1-Motion>"
- (lambda (x y)
- (ask-widget obj1 `(move ,(- x last-x) ,(- y last-y)))
- (ask-widget obj2 `(move ,(- x last-x) ,(- last-y y)))
- (keep-track-of-coords x y))
- "%x" "%y")))
-
-(define (move-by-itself pole-zero obj)
- (let ((last-x 'later))
- (define (keep-track-of-coords x)
- (set! last-x x)
- (let ((z (canvas-coords->z (list last-x half-window-size))))
- (if tracking-coords?
- (set-active-variable! LOCATION (our-real->string z)))))
- (define (store-coords)
- (let ((entry
- (let ((zero (assq obj all-zeros)))
- (if zero zero (assq obj all-poles))))
- (z (real-part (canvas-coords->z (list last-x 0)))))
- (set-cdr! entry z)))
- (add-event-handler!
- obj
- "<ButtonPress-1>"
- (lambda (x)
- (set! time-to-update-plot? #F)
- (keep-track-of-coords x))
- "%x")
- (add-event-handler!
- obj
- "<ButtonRelease-1>"
- (lambda ()
- (store-coords)
- (maybe-update-plot (pole-zero 'graph-canvas))
- ))
- (add-event-handler!
- obj
- "<B1-Motion>"
- (lambda (x)
- (ask-widget obj `(move ,(- x last-x) 0))
- (keep-track-of-coords x))
- "%x")))
-
-
-;;; This isn't quite right. Time-to-update-plot? might be set to #F
-;;; and then back to #T inside the 2 sec interval, so the update will
-;;; come too soon.
-(define (maybe-update-plot graph-canvas)
- (set! time-to-update-plot? #T)
- (after-delay
- 2
- (lambda ()
- (if time-to-update-plot?
- (plot-pole-zero graph-canvas)))))
-
-
-;;; Zeros
-(define (make-zero canvas xy)
- (let ((x (car xy))
- (y (cadr xy)))
- (let ((zero
- (make-oval-on-canvas canvas
- (- x zero-size) (- y zero-size)
- (+ x zero-size) (+ y zero-size))))
- (set! all-zeros (cons (cons zero (canvas-coords->z xy))
- all-zeros))
- (ask-widget zero `(configure -outline ,zero-color -fill ,canvas-color -width 2))
- zero)))
-
-(define (make-single-zero pole-zero x)
- (let ((canvas (pole-zero 'diagram-canvas)))
- (let ((z (make-zero canvas (list x half-window-size))))
- (move-by-itself pole-zero z)
- z)))
-
-(define (make-zero-pair pole-zero x y)
- (let ((canvas (pole-zero 'diagram-canvas)))
- (let ((zero (canvas-coords->z (list x y))))
- (let ((other-pos
- (z->canvas-coords (conjugate zero))))
- (let ((z1 (make-zero canvas (list x y)))
- (z2 (make-zero canvas other-pos)))
- (move-with-conjugate-pair pole-zero z1 z2)
- (move-with-conjugate-pair pole-zero z2 z1))))))
-
-
-;;; Poles
-(define (make-pole canvas xy)
- (let ((x (car xy))
- (y (cadr xy)))
- (let* ((line1
- (make-line-on-canvas canvas
- (- x pole-size) (- y pole-size)
- (+ x pole-size) (+ y pole-size)))
- (line2
- (make-line-on-canvas canvas
- (- x pole-size) (+ y pole-size)
- (+ x pole-size) (- y pole-size)))
- (pole (make-canvas-item-group canvas (list line1 line2))))
- (set! all-poles (cons (cons pole (canvas-coords->z xy))
- all-poles))
- (ask-widget pole `(configure -fill ,pole-color -width 2))
- pole)))
-
-(define (make-single-pole pole-zero x)
- (let ((canvas (pole-zero 'diagram-canvas)))
- (let ((p (make-pole canvas (list x half-window-size))))
- (move-by-itself pole-zero p)
- p)))
-
-(define (make-pole-pair pole-zero x y)
- (let ((canvas (pole-zero 'diagram-canvas)))
- (let ((pole (canvas-coords->z (list x y))))
- (let ((other-pos
- (z->canvas-coords (conjugate pole))))
- (let ((p1 (make-pole canvas (list x y)))
- (p2 (make-pole canvas other-pos)))
- (move-with-conjugate-pair pole-zero p1 p2)
- (move-with-conjugate-pair pole-zero p2 p1))))))
-
-;;; Button that switches from one label to another
-
-(define (make-switch color to-switch)
- ;;to-switch is list ((text command) (text command))
- (let ((n (length to-switch))
- (button (make-button))
- (state #F))
- (define (switch-to-state i)
- (set! state i)
- ((cadr (list-ref to-switch i)))
- (ask-widget button `(configure -text ,(car (list-ref to-switch i)))))
- (ask-widget button `(configure -background ,color))
- (switch-to-state 0)
- (set-callback! button
- (lambda ()
- (switch-to-state (modulo (+ state 1) n))))
- button))
-
-;;; Demo
-(define (make-pole-zero)
- (set! all-zeros '())
- (set! all-poles '())
- (let ((diagram-canvas (make-canvas `(-width ,(* 2 half-window-size)
- -height ,(* 2 half-window-size))))
- (graph-canvas #F)
- (pz 'later)
- (shape-size 'later)
- (single-maker 'later)
- (pair-maker 'later))
-
- (define (switch-to-zeros)
- (set! shape-size zero-size)
- (set! single-maker make-single-zero)
- (set! pair-maker make-zero-pair))
-
- (define (switch-to-poles)
- (set! shape-size pole-size)
- (set! single-maker make-single-pole)
- (set! pair-maker make-pole-pair))
-
- (let* ((maker-button (make-switch "yellow"
- `(("Zeros" ,switch-to-zeros)
- ("Poles" ,switch-to-poles))))
- (clear-button (make-button '(-text "Clear")))
- (show-coords? (make-active-variable))
- (coords-button
- (make-checkbutton `(-text "Show Coords?" -variable ,show-coords?)))
- (coords-display (make-label))
- (plot-button (make-button '(-text "Plot"))))
-
- (set! LOCATION (make-active-variable))
- (ask-widget coords-display `(configure -width 13 -background ,canvas-color
- -relief sunken -textvariable ,LOCATION
- -font ,text-font))
- (for-each (lambda (b)
- (ask-widget b `(configure -background "yellow" -font ,text-font)))
- (list maker-button clear-button coords-button plot-button))
- (ask-widget diagram-canvas `(configure -background ,canvas-color))
- (on-death! diagram-canvas 'little-brother-canvas
- (lambda () (if graph-canvas (swat-close graph-canvas))))
-
- (set-callback!
- clear-button
- (lambda ()
- (for-each (lambda (entry) (ask-widget (car entry) '(delete)))
- all-zeros)
- (for-each (lambda (entry) (ask-widget (car entry) '(delete)))
- all-poles)
- (set-active-variable! LOCATION "")
- (cond (graph-canvas
- (ask-widget graph-canvas '(delete all))
- (draw-axes graph-canvas)))
- (set! all-zeros '())
- (set! all-poles '())))
-
- (set-callback!
- coords-button
- (lambda ()
- (if (checkbutton-variable-on? show-coords?)
- (set! tracking-coords? #T)
- (begin
- (set-active-variable! LOCATION "")
- (set! tracking-coords? #F)))))
- (set-callback!
- plot-button
- (lambda ()
- (cond ((not graph-canvas)
- (set! graph-canvas
- (make-canvas `(-width ,(* 2 half-window-size)
- -height ,(* 2 half-window-size))))
- (ask-widget graph-canvas `(configure -background ,canvas-color))
- (swat-open graph-canvas '-title "Magnitude of Frequency Response")
- (on-death! graph-canvas 'big-brother-canvas
- (lambda () (set! graph-canvas #F)))))
- (plot-pole-zero graph-canvas)))
- (add-event-handler!
- diagram-canvas
- "<Double-ButtonPress-1>"
- (lambda (x y)
- (set! time-to-update-plot? #F)
- (if (< (abs (- y half-window-size)) shape-size)
- (single-maker pz x)
- (pair-maker pz x y)))
- "%x" "%y")
-
- (let ((me (make-vbox diagram-canvas
- (make-hbox maker-button clear-button coords-button
- coords-display plot-button))))
- (swat-open me '-title "Pole-Zero Diagram")
- (let ((x-axis (make-line-on-canvas
- diagram-canvas
- trim half-window-size
- (- (* 2 half-window-size) trim) half-window-size))
- (y-axis (make-line-on-canvas
- diagram-canvas
- half-window-size trim
- half-window-size (- (* 2 half-window-size) trim)))
- (unit-circle (make-oval-on-canvas
- diagram-canvas
- (* 2 trim) (* 2 trim)
- (* 2 (- half-window-size trim))
- (* 2 (- half-window-size trim)))))
- (ask-widget x-axis '(configure -arrow last))
- (ask-widget y-axis '(configure -arrow first))
- (ask-widget unit-circle '(configure -outline "gray")))
-
- (set! pz
- (lambda (message)
- (case message
- ((graph-canvas) graph-canvas)
- ((diagram-canvas) diagram-canvas)
- ((add-zero)
- (lambda (z)
- (let ((xy (z->canvas-coords z)))
- (if (= (imag-part z) 0)
- (make-single-zero pz (car xy))
- (make-zero-pair pz (car xy) (cadr xy))))))
- ((add-pole)
- (lambda (p)
- (let ((xy (z->canvas-coords p)))
- (if (= (imag-part p) 0)
- (make-single-pole pz (car xy))
- (make-pole-pair pz (car xy) (cadr xy))))))
- (else "Unknown message -- MAKE-POLE-ZERO" message))))
- pz))))
-
-
-(define (add-butterworth-poles pole-zero-diagram n)
- (define pi (* (atan 1 1) 4))
- (define (make-index-list n start)
- (if (> start n)
- '()
- (cons start (make-index-list n (+ start 1)))))
- (let ((index-list (make-index-list n (+ (ceiling->exact (/ n 2)) 1)))
- (w (exp (/ (* 2 +i pi) (* 2 n)))))
- (for-each (lambda (pole)
- ((pole-zero-diagram 'add-pole) pole))
- (map (lambda (s)
- (let ((t 1))
- (/ (+ 1 (* (/ t 2) s))
- (- 1 (* (/ t 2) s)))))
- (map (lambda (k) (expt w (- k .5)))
- index-list)))
- (let loop ((z 1))
- (if (> z n)
- 'done
- (begin ((pole-zero-diagram 'add-zero) -1)
- (loop (1+ z)))))
- (plot-pole-zero (pole-zero-diagram 'graph-canvas))))
-
-
-(define (plot-pole-zero graph-canvas)
- (cond (graph-canvas
- (ask-widget graph-canvas '(delete all))
- (draw-axes graph-canvas)
- (plot-magnitude graph-canvas))))
-
-(define (plot-magnitude graph-canvas)
- (let ((zero-locations (map cdr all-zeros))
- (pole-locations (map cdr all-poles)))
- (let ((fcn
- (lambda (x)
- (let ((jw (exp (* x +i))))
- (let ((numer
- (apply * (map (lambda (z) (magnitude (- jw z)))
- zero-locations)))
- (denom
- (apply * (map (lambda (z) (magnitude (- jw z)))
- pole-locations))))
- (if (< denom 1.e-10)
- 1.e5
- (/ numer denom)))))))
- (plot-graph-on-canvas
- graph-canvas
- (let loop ((index 0) (points '()))
- (if (> index number-of-points)
- points
- (let ((w (* index (/ max-w number-of-points))))
- (loop (+ index 1)
- (cons (cons w (fcn w)) points)))))))))
-
-(define (plot-graph-on-canvas canvas graph)
- (let* ((maxval (apply max (map cdr graph)))
- (canvas-points
- (map (lambda (graph-point)
- (magnitude-coords->canvas-coords graph-point maxval))
- graph)))
- (let loop ((rest-points (cdr canvas-points))
- (this-point (car canvas-points)))
- (if (null? rest-points)
- 'done
- (let ((next-point (car rest-points)))
- (make-line-on-canvas canvas
- (car this-point)
- (cdr this-point)
- (car next-point)
- (cdr next-point))
- (loop (cdr rest-points)
- (car rest-points)))))
- (let ((maxval-display
- (make-text-on-canvas
- canvas (* 3 trim) (* 2 trim) `(-text ,(our-real->string maxval)))))
- (ask-widget maxval-display
- `(configure -anchor sw -font ,symbol-font)))))
-
-
-(define (magnitude-coords->canvas-coords xy max-mag)
- (let ((x (car xy))
- (y (cdr xy)))
- (cons (round->exact (+ (* x (/ (- (* 2 half-window-size) (* 4 trim)) max-w))
- (* 2 trim)))
- (round->exact (+ (* y (/ (- (* 4 trim) (* 2 half-window-size)) max-mag))
- (* 2 (- half-window-size trim)))))))
-
-
-(define (draw-axes graph-canvas)
- (let ((x-axis (make-line-on-canvas
- graph-canvas
- trim (* 2 (- half-window-size trim))
- (- (* 2 half-window-size) trim)
- (* 2 (- half-window-size trim))))
- (y-axis (make-line-on-canvas
- graph-canvas
- (* 2 trim) trim
- (* 2 trim) (- (* 2 half-window-size) trim)))
- (pi (make-text-on-canvas
- graph-canvas
- (* 2 (- half-window-size trim)) (- (* 2 half-window-size) trim)
- '(-text "p"))))
- (ask-widget x-axis '(configure -arrow last))
- (ask-widget y-axis '(configure -arrow first))
- (ask-widget pi `(configure -anchor e -font ,symbol-font))))
-
+++ /dev/null
-;;; -*- Scheme -*-
-
-;; to make this possible to debug
-
-; (param:unparser-list-breadth-limit 10)
-; (param:unparser-list-depth-limit 10)
-
-
-;; GC stress test
-
-(define (a)
- (gc-flip)
- (gc-flip)
- (kick-uitk-thread)
- (gc-flip)
- (gc-flip)
- (kick-uitk-thread))
-
-(define (foo test n)
- (if (> n 0)
- (begin
- (test)
- (foo test (- n 1)))))
-
-(define (foo2 test n)
- (if (> n 0)
- (begin
- (display n)
- (test)
- (gc-flip)
- (foo2 test (- n 1)))))
-
-
-;; Support for GC debugging
-
-(define gctr (make-primitive-procedure 'gc-trace-references))
-(define refs (make-vector 40))
-
-(define (go obj)
- (gctr obj refs)
- (gc-flip)
- (write-line (list (vector-ref refs 0) (map object-type (vector->list refs)))))
-
-(define (get n) (vector-ref refs n))
-
-
-;; Test the Rectangle widget
-
-;; (define application (make-application "Test Scheme Application"))
-
-(define (make-picture)
- (define v1 (make-self-painting-rectangle 50 30 "yellow"))
- (define v2 (make-self-painting-rectangle 100 10 "blue"))
- (define v3 (make-self-painting-rectangle 10 100 "orange"))
-
- (define topframe (make-vbox v1 v2 v3))
-
- (define h1 (make-self-painting-rectangle 10 10 "white"))
- (define h2 (make-self-painting-rectangle 20 20 "gold"))
- (define h3 (make-self-painting-rectangle 30 30 "green"))
-
- (define bottomframe (make-hbox h1 h2 h3))
-
- (make-hbox topframe bottomframe))
-
-(define (make-bad-picture)
- (define v1 (make-rect 50 30 "yellow"))
- (define v2 (make-rect 100 10 "blue"))
- (define v3 (make-rect 10 100 "orange"))
-
- (define topframe (make-vbox v1 v2 v3))
-
- (define h1 (make-rect 10 10 "white"))
- (define h2 (make-rect 20 20 "gold"))
- (define h3 (make-rect 30 30 "green"))
- (set! green h3)
-
- (define bottomframe (make-hbox h1 h2 h3))
-
- (make-hbox topframe bottomframe))
-
-(define (simple-picture)
- (swat-open (make-self-painting-rectangle 50 30 "yellow")))
-
-(define (test0)
- (simple-picture)
- 3)
-
-(define (test1)
- (swat-open (make-picture))
- 3)
-
-(define (test1a)
- (swat-open (make-picture))
- (swat-open (make-picture))
- 3)
-
-(define app2)
-(define (test2)
- (set! app2 (make-application "Test2-2 "))
- (add-child! app2 (make-picture))
- (swat-open (make-picture))
- (swat-open (make-picture))
- (swat-open (make-picture))
- (swat-open (make-picture))
- (swat-open (make-picture))
- (swat-open (make-picture))
- (add-child! app2 (make-picture))
- (add-child! app2 (make-picture))
- (add-child! app2 (make-picture))
- (add-child! app2 (make-picture))
- 3)
-
-(define (make-switch color to-switch)
- ;;to-switch is list ((text command) (text command))
- (let ((n (length to-switch))
- (button (make-button))
- (state #F))
- (define (switch-to-state i)
- (set! state i)
- ((cadr (list-ref to-switch i)))
- (ask-widget button `(configure -text ,(car (list-ref to-switch i)))))
- (ask-widget button `(configure -background ,color))
- (switch-to-state 0)
- (set-callback! button
- (lambda ()
- (switch-to-state (modulo (+ state 1) n))))
- button))
-
-(define debug-test3)
-(define (test3)
- (let* ((surface (make-shape-surface 600 600 "white" "red"))
- (button1 (make-button '(-text "PANIC!")))
- (button2 (make-button '(-text "SET COLOR")))
- (button3 (make-switch
- "yellow"
- `(("Ovals" ,(lambda () (surface 'ovals)))
- ("Rectangles" ,(lambda () (surface 'rectangles))))))
- (button4 (make-switch
- "yellow"
- `(("Outlined" ,(lambda () (surface 'outlined)))
- ("Filled" ,(lambda () (surface 'filled))))))
- (e (make-entry '(-width 10))))
- (define (handle-bad-color)
- (ask-widget button2 '(configure -background red))
- (ask-widget button2 '(flash))
- (ask-widget button2 '(flash))
- (ask-widget e `(delete 0 end))
- (ask-widget e `(insert 0 red))
- ((surface 'set-color!) "red"))
- (define (change-color)
- (let ((new-color (ask-widget e '(get))))
- (if (valid-color? new-color)
- (begin ((surface 'set-color!) new-color)
- (ask-widget button2
- `(configure -background ,new-color)))
- (handle-bad-color))))
- (set! debug-test3 (lambda () #f))
- (ask-widget button1 '(configure
- -background green -activebackground red
- -font "-adobe-helvetica-bold-r-normal--34-240-100-100-p-182-iso8859-1"))
- (ask-widget button2 '(configure -background red -activebackground white))
- (ask-widget e '(configure -background white -foreground black -relief sunken))
- (ask-widget e '(insert 0 red))
- (set-callback! button1 (lambda () (surface 'clear)))
- (set-callback! button2 change-color)
- (let ((me (make-vbox (surface 'the-surface)
- (make-hbox button1 e
- button2 button3 button4))))
- (swat-open me '-title "Featureless Drawing Program")
- me)))
+++ /dev/null
-; These get overriden when TK is loaded
-(define (tk-doevents) 'tk-doevents)
-(define (tk-init dsp) 'tk-init)
-
-(with-working-directory-pathname
- "/scheme/8.0/700/swat2/scheme"
- (lambda ()
- ; Dynamically load the microcode
- (load "../c/scxl")
- (load "../c/uitk")
-
- ; And now the Scheme level
- ;;(load "scc-macros")
- ;;(load "uitk-macros")
- (load "control-floating-errors")
- (load "structures")
- (load "structures2")
- (load "generics")
- (load "uitk")
- (load "xlibCONSTANTS")
- (load "mit-xlib")
- (load "tk-mit")
- (load "mit-xhooks")
- (load "widget-mit")
- (load "baseobj")
- (load "widget")
- (load "geometry")
- (load "simple")
- (load "canvas")
- (load "menu")
- (load "text")
- ;;(load "rtest")
- ;;(load "btest")
- ))
+++ /dev/null
- (define b1 (make-button '(-text "button1")))
- (define b2 (make-button '(-text "button2")))
- (define b3 (make-button '(-text "button3")))
- (define b4 (make-button '(-text "button4")))
- (define b5 (make-button '(-text "button5")))
- (define b6 (make-button '(-text "very very long button6")))
- (define b7 (make-button '(-text "b7")))
- (define b8 (make-button '(-text "b8")))
- (define b9 (make-button '(-text "b9")))
- (define s (make-space))
-
- (define a (make-application "test"))
- (define ab (make-array-box (list b1 'left b3)
- (list 'up 'up b6)
- (list b7 b8 b9)))
- (add-child! a ab)
-
-(define (test2)
- (define c (make-canvas '(-width 300 -height 300 -background white)))
- (define b1 (make-button '(-text "button1" -background red)))
- (define b2 (make-button '(-text "button2" -background red)))
- (define b3 (make-button '(-text "button3" -background red)))
- (define s1 (make-space '(-background red)))
- (define s2 (make-space '(-background red)))
- (define hb (make-hbox s1 b1 b2 s2 b3))
- (define vb (make-vbox c hb))
- (define a (make-application "test"))
- (add-child! a vb)
- a)
-
-#|
-(define c (make-canvas '(-width 200 -height 200)))
-(define b1 (make-button '(-text "button1")))
-(define b2 (make-button '(-text "button2")))
-(define box1 (make-hbox b1 b2))
-(define box2 (make-vbox c box1))
-(define a (make-application "test"))
-(add-child! a box2)
-
-|#
\ No newline at end of file
+++ /dev/null
-;;; -*- Scheme -*-
-
-(declare (usual-integrations)
- (integrate-external "/scheme/700/runtime/hash"))
-
-(define foo-1 'invalid-rehash)
-(define foo-2 'invalid-bucket)
-(define foo-3 'unhash-table)
-(define (foo)
- (set! foo-1 3)
- (set! foo-2 3)
- (set! foo-3 3))
-
-(define *do-validation?* #T)
-
- (define (count-unhash-table uht)
- (let ((count 0))
- (do ((i 0 (+ i 1)))
- ((= i (vector-length uht)) count)
- (set! count (+ count (length (cdr (vector-ref uht i))))))))
-
- (define (valid-bucket-contents? table when y full?)
- (define (valid? x)
- (and (list? x)
- (or (null? x)
- (and (pair? x)
- (weak-pair? (car x))
- (let ((hash-number (weak-cdr (car x))))
- (and (number? hash-number)
- (or (not full?)
- (not (weak-car (car x)))
- (= hash-number (hash (weak-car (car x)) table))
- (let ((table (car (cons table #f)))
- (x (car (cons x #f)))
- (y (car (cons y #f)))
- (forty-two (car (cons 42 #f))))
- (write-line
- (list "invalid rehash" when table hash-number (car x)))
- (table)
- (list table x y forty-two)))))
- (valid? (cdr x))))))
- (or (valid? y)
- (begin
- (write-line (list "Invalid unhash bucket" table when))
- (+ 2 foo-2))))
-
- (define (validate table when full?)
- (if *Do-Validation?*
- (fluid-let ((*Do-Validation?* #F))
- (let ((uht (hash-table/unhash-table table)))
- (for-each
- (lambda (bucket)
- (valid-bucket-contents? table when (cdr bucket) full?))
- (vector->list uht))))
- 'OK))
-
- (define (show-unhash-table uht)
- (for-each
- (lambda (x) (if (not (number? x))
- (begin
- (write-line (list "show-unhash-table: not a number" x))
- (+ 3 foo-3)))
- (display x)
- (display #\space))
- (reduce append '()
- (map (lambda (bucket)
- (map weak-cdr (cdr bucket)))
- (vector->list uht))))
- (newline))
-
- (define (our-rehash-all-gc-daemon)
- (let loop ((l all-hash-tables)
- (n (weak-cdr all-hash-tables)))
- (cond ((null? n)
- (weak-set-cdr! l n))
- ((not (weak-pair/car? n))
- (loop l (weak-cdr n)))
- (else
- (weak-set-cdr! l n)
- (let* ((table (weak-car n)))
- (validate table 'before #F)
- ; (write-line (list 'before (count-unhash-table uht)))
- (hash-table/rehash table)
- (validate table 'after #T)
- ; (write-line (list 'after (count-unhash-table uht)))
- ; (show-unhash-table uht)
- (loop n (weak-cdr n)))))))
-
- (delq! rehash-all-gc-daemon
- (access gc-daemons (->environment '(runtime gc-daemons))))
- (add-gc-daemon! our-rehash-all-gc-daemon)
-
- (let ((old-hash object-hash))
- (set! object-hash
- (lambda (object #!optional table insert?)
- (let ((table
- (if (default-object? table)
- default-hash-table
- (begin
- (if (not (hash-table? table))
- (error:wrong-type-argument table
- "object-hash table"
- 'OBJECT-HASH))
- table)))
- (insert? (or (default-object? insert?) insert?)))
- (let ((result (old-hash object table insert?)))
- (validate table 'hash #F)
- result)))))
-
- (let ((old-unhash object-unhash))
- (set! object-unhash
- (lambda (number #!optional table)
- (let ((table
- (if (default-object? table)
- default-hash-table
- (begin
- (if (not (hash-table? table))
- (error:wrong-type-argument table
- "object-hash table"
- 'OBJECT-UNHASH))
- table))))
- (let ((result (old-unhash number table)))
- (validate table 'unhash #T)
- result)))))
\ No newline at end of file
+++ /dev/null
-;;;; -*-Scheme-*-
-
-(define-syntax define-constant
- define-integrable)
-
-(define-syntax define-in-line
- define-integrable)
-
-(define-integrable *running-in-mit-scheme* #t)
\ No newline at end of file
+++ /dev/null
-;;;;; -*- Scheme -*-
-;;;;; Simple objects for UITK
-;;;; derived from simple.sc,v 1.1 1993/02/16 14:04:09 jmiller Exp $
-
-;;;; Simplest drawing object
-
-;;;This is meant to be the external interface. We need to implement these
-;;;in some standard way.
-
-
-(define (with-clipping! shape user-fn Clip-to-XRegion)
- (let ((screen-area (Used-Screen-Area shape))
- (window (Get-UITKWindow shape))
- (gc (Shape%.graphics-context shape)))
- (if (and window screen-area)
- (let ((clip (rectangle->xregion screen-area)))
- (define (intersect! xregion)
- (if xregion
- (XIntersectRegion! xregion clip clip)))
- (if (not (null? Clip-to-XRegion))
- (intersect! (car Clip-to-XRegion)))
- (intersect! (clip-region shape))
- (SetClipXRegion window gc clip)
- (user-fn window gc (UITKRectangle.Offset screen-area))
- (XDestroyRegion clip)))))
-
-(define (shape-draw shape . Clip-to-XRegion)
- (ensure-graphics-context shape)
- (with-clipping! shape (Shape%.x-draw shape) Clip-to-XRegion))
-
-(define (shape-erase-maybe shape . Clip-to-XRegion)
- (ensure-graphics-context shape)
- (let ((e (Shape%.x-erase shape)))
- (and e
- (begin (with-clipping! shape e Clip-to-XRegion)
- #T))))
-
-(define (shape-copy shape)
- (let ((new (make-shape
- (Shape%.x-draw shape)
- (Shape%.calculate-used-screen-area shape)
- (shape%.point-within? shape)
- (Shape%.rectangle-overlaps? shape)
- (%desired-size shape)
- (Shape%.color shape))))
- (set-clip-region! new (clip-region shape))
- (assign-geometry! new
- (drawing-surface shape)
- (copy-rectangle (used-screen-area shape)))
- new))
-
-(define (shape-set-color! shape color)
- (set-Shape%.color! shape color)
- (set-Shape%.graphics-context! shape false))
-
-(define (shape-draw-function shape)
- (Shape%.x-draw shape))
-
-(define (shape-set-gc-function! shape function-number)
- (set-Shape%.gc-function! shape function-number)
- (set-Shape%.graphics-context! shape false))
-
-(define (shape-set-erase-function! shape fcn)
- (set-Shape%.x-erase! shape fcn))
-
-(define (shape-point-within? Shape Offset)
- (if (not (vector? Offset))
- (error "SHAPE-POINT-WITHIN?: Bad offset" Offset))
- (let ((screen-area (used-screen-area shape)))
- (and screen-area
- ((Shape%.point-within? shape)
- (UITKRectangle.Offset screen-area)
- Offset))))
-
-(define (shape-rectangle-overlaps? Shape Offset W H)
- (if (not (vector? Offset))
- (error "SHAPE-RECTANGLE-OVERLAPS?: Bad offset" Offset))
- (if (not (number? W))
- (error "SHAPE-RECTANGLE-OVERLAPS?: Bad width" W))
- (if (not (number? H))
- (error "SHAPE-RECTANGLE-OVERLAPS?: Bad height" H))
- (let ((screen-area (used-screen-area shape)))
- (and screen-area
- ((Shape%.rectangle-overlaps? shape)
- (UITKRectangle.Offset screen-area)
- offset w h))))
-
-(define (generate-graphics-context! shape)
- ;; (define-primitives (set-debug-flags! 2))
- (let ((window (Get-UITKWindow shape)))
- (if window
- (begin
- (set-Shape%.graphics-context!
- shape
- (make-colored-graphics-context window (Shape%.color shape)))
- (let ((Xdisplay (UITKWindow.XDisplay
- (DrawingSurface.UITKWindow
- (Drawing-Surface shape)))))
- (XSetFunction Xdisplay
- (Shape%.graphics-context shape)
- (Shape%.gc-function shape)))
- 'OK)
- #F)))
-
-(define (ensure-graphics-context shape)
- (if (not (Shape%.graphics-context shape))
- (let ((gc (generate-graphics-context! shape)))
- (or gc
- (begin (debug-print 'error)
- (error "cannot make graphics context"))))))
-
-(define (shape-assign-screen-area! shape screen-area)
- (cond ((vector? screen-area)
- (let ((old (used-screen-area shape))
- (used ((Shape%.calculate-used-screen-area shape)
- screen-area))) ; Calculate bounding box, etc.
- (set-used-screen-area! shape used)
- (set-assigned-screen-area! shape screen-area)
- (geometry-change! shape old used)
- used))
- ((not screen-area)
- ;; Screen-Area is #F to retract the area.
- ;; Just inform any objects interested and don't draw
- ;; anything.
- (let ((old (used-screen-area shape)))
- (if old
- (begin
- (set-used-screen-area! shape #F)
- (set-assigned-screen-area! shape #F)
- (geometry-change! shape old #F)
- #F))))
- (error "SHAPE-ASSIGN-SCREEN-AREA!: Bad screen-area" screen-area)))
-
-;; Use default ASSIGN-DRAWING-SURFACE!
-
-(define (shape-assign-glue! me)
- ;; infinitely stretchable
- (let* ((size (get-desired-size me))
- (my-width (size.width size))
- (my-height (size.height size)))
- (set-%hglue! me (make-fill-glue my-width 1))
- (set-%vglue! me (make-fill-glue my-height 1))))
-
-;; Shape Maker
-(define (shape-maker x-drawing-routine calculate-used-screen-area
- point-within? rectangle-overlaps? color-string)
- (make-Shape%
- (make-UIObjInternals 'invalid
- 'invalid
- UIObj-set-context! ; Defaults
- shape-assign-screen-area!
- UIObj-assign-drawing-surface!
- shape-point-within?
- shape-rectangle-overlaps?
- UIObj-handle-event
- UIObj-get-desired-size
- UIObj-assigned-screen-area
- UIObj-used-screen-area
- UIObj-set-assigned-screen-area!
- UIObj-set-used-screen-area!
- shape-assign-glue!)
- x-drawing-routine
- calculate-used-screen-area
- color-string
- point-within?
- rectangle-overlaps?
- GXCOPY))
-
-(define (make-shape x-drawing-routine calculate-used-screen-area
- point-within? rectangle-overlaps?
- desired-size color-string)
- (let ((me (shape-maker x-drawing-routine
- calculate-used-screen-area
- point-within?
- rectangle-overlaps?
- color-string)))
- (set-%desired-size! me desired-size)
- me))
-\f
-(define (make-rect width height color-string . filled?)
- ;;defaults to filled
- (let* ((width (round->exact width))
- (height (round->exact height))
- (Width-1 (- width 1))
- (Height-1 (- height 1))
- (Xdraw (if (or (null? filled?) (car filled?))
- (lambda (uitkw gc x y)
- (FillRectangle uitkw gc x y width height))
- (lambda (uitkw gc x y)
- ;;!!@%$^$^$$#@#@#!! X!!
- (DrawRectangle uitkw gc x y Width-1 Height-1)))))
- (make-shape
- (lambda (UITKWindow graphics-context offset) ; Draw
- (XDraw UITKWindow graphics-context
- (Point.X offset) (Point.Y offset)))
- (lambda (assigned-screen-area) ; Calculate-Used-Screen-Area
- (make-UITKRectangle (UITKRectangle.offset assigned-screen-area)
- (make-size width height)))
- (lambda (My-Offset Offset) ; Point within?
- (point-in-rectangle? Offset My-Offset Width Height))
- (lambda (My-Offset Offset W H) ; Rectangle overlaps?
- (rectangle-overlaps-rectangle?
- My-Offset Width Height Offset W H))
- (make-size width height) ; Desired-Size
- color-string)))
-
-(define (make-scaling-rect color-string . filled?)
- ;;defaults to filled
- (let* ((Width #F)
- (Height #F)
- (Width-1 #F)
- (Height-1 #F)
- (Xdraw (if (or (null? filled?) (car filled?))
- (lambda (uitkw gc x y)
- (FillRectangle uitkw gc x y width height))
- (lambda (uitkw gc x y)
- ;;!!@%$^$^$$#@#@#!! X!!
- (DrawRectangle uitkw gc x y Width-1 Height-1)))))
- (make-shape
- (lambda (UITKWindow graphics-context offset) ; Draw
- (XDraw UITKWindow graphics-context
- (Point.X offset) (Point.Y offset)))
- (lambda (assigned-screen-area) ; Calculate-Used-Screen-Area
- (set! height (UITKRectangle.Height assigned-screen-area))
- (set! width (UITKRectangle.Width assigned-screen-area))
- (set! height-1 (- height 1))
- (set! width-1 (- width 1))
- assigned-screen-area)
- (lambda (My-Offset Offset) ; Point within?
- (point-in-rectangle? Offset My-Offset Width Height))
- (lambda (My-Offset Offset W H) ; Rectangle overlaps?
- (rectangle-overlaps-rectangle?
- My-Offset Width Height Offset W H))
- (make-size width height) ; Desired-Size
- color-string)))
-
-(define (make-filled-rectangle width height color-string)
- (make-rect width height color-string #T))
-
-(define (make-unfilled-rectangle width height color-string)
- (make-rect width height color-string #F))
-
-(define (make-oval width height color-string . filled?)
- (let* ((width (round->exact width))
- (height (round->exact height))
- (Width-1 (- width 1))
- (Height-1 (- height 1))
- (angle (* 360 64)) ; X uses degrees/64
- (Xdraw (if (or (null? filled?) (car filled?))
- (lambda (uitkw gc x y)
- (FillArc uitkw gc x y width height 0 angle))
- (lambda (uitkw gc x y)
- (DrawArc uitkw gc x y width-1 height-1 0 angle))))
- (a (/ width 2.0))
- (b (/ height 2.0))
- (center (make-point a b)))
- (make-shape
- (lambda (UITKWindow graphics-context offset) ; Draw
- (Xdraw UITKWindow graphics-context
- (Point.X offset) (Point.Y offset)))
- (lambda (assigned-screen-area) ; Calculate-Used-Screen-Area
- (make-UITKRectangle (UITKRectangle.Offset assigned-screen-area)
- (make-size width height)))
- (lambda (My-Offset Offset) ; Point within?
- (and (point-in-rectangle? Offset My-Offset width height)
- (let* ((dv (sub-vectors (add-vectors my-offset center) offset))
- (dx/a (/ (point.x dv) a))
- (dy/b (/ (point.y dv) b)))
- (< (+ (* dx/a dx/a) (* dy/b dy/b)) 1.0))))
- (lambda (My-Offset Offset W H) ; Rectangle overlaps?
- (rectangle-overlaps-rectangle?
- My-Offset diameter diameter Offset W H))
- (make-size width height) ; Desired-Size
- color-string)))
-
-(define (make-scaling-oval color-string . filled?)
- (let ((width #F)
- (height #F)
- (width-1 #F)
- (height-1 #F)
- (a #F)
- (b #F)
- (center #F))
- (let* ((angle (* 360 64)) ; X uses degrees/64
- (Xdraw (if (or (null? filled?) (car filled?))
- (lambda (uitkw gc x y)
- (FillArc uitkw gc x y width height 0 angle))
- (lambda (uitkw gc x y)
- (DrawArc uitkw gc x y width-1 height-1 0 angle)))))
- (make-shape
- (lambda (UITKWindow graphics-context offset) ; Draw
- (Xdraw UITKWindow graphics-context
- (Point.X offset) (Point.Y offset)))
- (lambda (assigned-screen-area) ; Calculate-Used-Screen-Area
- (set! width (UITKRectangle.Width assigned-screen-area))
- (set! height (UITKRectangle.Height assigned-screen-area))
- (set! width-1 (- width 1))
- (set! height-1 (- height 1))
- (set! a (/ width 2.0))
- (set! b (/ height 2.0))
- (set! center (make-point a b))
- assigned-screen-area)
- (lambda (My-Offset Offset) ; Point within?
- (and (point-in-rectangle? Offset My-Offset width height)
- (let* ((dv (sub-vectors (add-vectors my-offset center) offset))
- (dx/a (/ (point.x dv) a))
- (dy/b (/ (point.y dv) b)))
- (< (+ (* dx/a dx/a) (* dy/b dy/b)) 1.0))))
- (lambda (My-Offset Offset W H) ; Rectangle overlaps?
- (rectangle-overlaps-rectangle?
- My-Offset width height Offset W H))
- (make-size width height) ; Desired-Size
- color-string))))
-
-(define (make-filled-oval width height color-string)
- (make-oval width height color-string #T))
-
-(define (make-unfilled-oval width height color-string)
- (make-oval width height color-string #F))
-
-(define (make-filled-circle radius color-string)
- (make-filled-oval (* radius 2) (* radius 2) color-string))
-
-(define (make-unfilled-circle radius color-string)
- (make-unfilled-oval (* radius 2) (* radius 2) color-string))
-
-;;;not right? do lines need to be oriented (from to)
-
-(define (make-line width height color-string . filled?)
- filled? ;ignore
- (let ((width (round->exact width))
- (height (round->exact height)))
- (make-shape
- (lambda (UITKWindow graphics-context offset) ; Draw
- (DrawLine UITKWindow graphics-context
- (Point.X offset) (Point.Y offset)
- (+ width (Point.X offset)) (+ height (Point.Y offset))))
- (lambda (assigned-screen-area) ; Calculate-Used-Screen-Area
- (make-UITKRectangle (UITKRectangle.offset assigned-screen-area)
- (make-size width height)))
- (lambda (My-Offset Offset) ; Point within?!!FIX
- (point-in-rectangle? Offset My-Offset Width Height))
- (lambda (My-Offset Offset W H) ; Rectangle overlaps?!!FIX
- (rectangle-overlaps-rectangle?
- My-Offset Width Height Offset W H))
- (make-size width height) ; Desired-Size
- color-string)))
-
-
-;;;*******Still not right for rubber-banding (I think)
-
-(define (make-scaling-line color-string . filled?)
- filled? ;ignore
- (let ((width #F)
- (height #F))
- (make-shape
- (lambda (UITKWindow graphics-context offset) ; Draw
- (DrawLine UITKWindow graphics-context
- (Point.X offset) (Point.Y offset)
- (+ width (Point.X offset)) (+ height (Point.Y offset))))
- (lambda (assigned-screen-area) ; Calculate-Used-Screen-Area
- (set! height (UITKRectangle.Height assigned-screen-area))
- (set! width (UITKRectangle.Width assigned-screen-area))
- assigned-screen-area)
- (lambda (My-Offset Offset) ; Point within?!!FIX
- (point-in-rectangle? Offset My-Offset Width Height))
- (lambda (My-Offset Offset W H) ; Rectangle overlaps?!!FIX
- (rectangle-overlaps-rectangle?
- My-Offset Width Height Offset W H))
- (make-size width height) ; Desired-Size
- color-string)))
-
-
-
-#|
-;;; points is a list of points. The offset of a path is the upper left-most
-;;; corner of the bounding box of the path. Make-path comes born with
-;;; a used screen area
-(define (make-path points color)
- (if (null? points)
- (error "no points in path -- MAKE-PATH"))
- (let* ((xcors (map point.x points))
- (ycors (map point.y points))
- (xmin (apply min xcors))
- (xmax (apply max xcors))
- (ymin (apply min ycors))
- (ymax (apply max ycors))
- (width (- xmax xmin))
- (height (- ymax ymin))
- ;;adjust points so relative to upper-left
- (xpoints (map (lambda (x) (- x xmin)) xcors))
- (ypoints (map (lambda (y) (- y ymin)) ycors))
- (shape
- (make-shape
- (lambda (UITKWindow graphics-context offset)
- (let* ((ox (point.x offset))
- (oy (point.y offset))
- (xs (map (lambda (x) (+ x ox)) xpoints))
- (ys (map (lambda (y) (+ y oy)) ypoints)))
- (let loop ((fx (car xs))
- (fy (car ys))
- (restx (cdr xs))
- (resty (cdr ys)))
- (if (null? restx)
- 'done
- (begin (DrawLine UITKWindow graphics-context
- fx fy (car restx) (car resty))
- (loop (car restx) (car resty)
- (cdr restx) (cdr resty)))))))
- (lambda (assigned-screen-area)
- ??????)
- (lambda (point) ())
- (lambda (rect) ())
- desired-size
- color)))
- set up the used screen-area???
- shape))
-
-FOO do just a line first
-
-
-or maybe just do draw path and draw line given some shape for which to
-use the uitkwindow.
-
-
-|#
-
-
-(define (self-paint! shape)
- (handle-exposure shape
- (lambda (exposed-rectangle)
- (shape-draw shape (Rectangle->XRegion exposed-rectangle))))
- (on-geometry-change! shape 'REASON
- (lambda (old-screen-area new-screen-area)
- old-screen-area new-screen-area ; Not used
- (if new-screen-area (shape-draw shape))))
- 'done)
-
-(define (make-self-painting-rectangle width height color)
- (let ((me (make-rect width height color)))
- (self-paint! me)
- me))
-
-(define (make-self-painting-unfilled-rectangle width height color)
- (let ((me (make-unfilled-rectangle width height color)))
- (self-paint! me)
- me))
-
-(define (make-self-painting-circle radius color)
- (let ((me (make-circle radius color)))
- (self-paint! me)
- me))
-
-
-;;; This is a surface that generates rectangles or ovals when you click on it.
-;;; Shapes grow with rubber banding.
-;;; After a shape is generated, it can be moved around.
-;;; You can choose either solid or outline mode for moving the shapes.
-;;;This is a little ugly, because I want to make sure that
-;;;make-rect is never called with negative width or height.
-
-(define (make-shape-surface width height background-color new-shape-color)
- (let ((rubber-from #F)
- (move-offset #F) ;offset of moving shape relative to mouse
- (shadow-shape #F)
- (fill-shadow-shapes? #F)
- (shape-maker make-rect)
- (rubber-shape-maker make-scaling-rect)
- (shapes-and-areas '())
- (shape->maker-map '())
- (outer-rectangle (make-rect width height background-color)))
-
- (define (shape->shape-and-area shape)
- (cons shape (used-screen-area shape)))
- (define (shape-and-area->shape s-and-a) (car s-and-a))
- (define (shape-and-area->area s-and-a) (cdr s-and-a))
- (define (set-shape-and-area-area! s-and-a area)
- (let ((shape (shape-and-area->shape s-and-a)))
- (assign-screen-area! shape area)
- (set-cdr! s-and-a (used-screen-area shape))))
-
- (define (process-click-on-shape shape-and-area e while-grabbed)
- (let ((shape (shape-and-area->shape shape-and-area))
- (area (shape-and-area->area shape-and-area)))
- (set! move-offset
- (sub-vectors (Event.Offset e)
- (UITKRectangle.offset area)))
- ;;;put shape at top
- (set! shapes-and-areas
- (append (delq! shape-and-area shapes-and-areas)
- (list shape-and-area)))
- (shape-draw shape)
- (set! shadow-shape (shape->moving-shape shape))
- (shape-erase shape) ;because shadow draws in XOR
- (shape-draw shadow-shape)
- (while-grabbed
- (lambda (point) ; Motion procedure
- (if (point-within? outer-rectangle point)
- (begin
- (shape-erase shadow-shape)
- (assign-location! shadow-shape
- (sub-vectors point move-offset))
- (shape-draw shadow-shape))))
- (lambda () ;finalization procedure
- (set-shape-and-area-area! shape-and-area
- (used-screen-area shadow-shape))
- (shape-erase shadow-shape)
- (shape-draw shape)))))
-
- (define (process-click-on-background e while-grabbed)
- (set! rubber-from (Event.Offset e))
- (set! shadow-shape (make-rubber-shape))
- (shape-draw shadow-shape)
- (while-grabbed
- (lambda (point) ; Motion procedure
- (if (point-within? outer-rectangle point)
- (grow-shadow-shape point)))
- instantiate-shadow-shape)) ;finalization procedure
-
- (define (instantiate-shadow-shape)
- (let ((new-shape (screen-area->shape
- shape-maker
- (used-screen-area shadow-shape)
- new-shape-color
- #T))) ;always fill
- (shape-erase shadow-shape)
- (shape-draw new-shape)
- (set! shapes-and-areas
- (append shapes-and-areas
- (list (shape->shape-and-area new-shape))))
- ;;remember proc that shape was made with
- (set! shape->maker-map
- (cons (cons new-shape shape-maker)
- shape->maker-map))))
-
- (define (shape->moving-shape shape)
- (let ((entry (assq shape shape->maker-map)))
- (if (null? entry)
- (error "shape not in shape->maker-map" shape))
- (let ((moving-shape
- (screen-area->shape (cdr entry)
- (used-screen-area shape)
- background-color
- fill-shadow-shapes?)))
- (set-xor-draw! moving-shape)
- moving-shape)))
-
- (define (screen-area->shape maker screen-area color fill?)
- (let ((new-shape (maker (UITKRectangle.Width screen-area)
- (UITKRectangle.Height screen-area)
- color
- fill?)))
- (set-clip-region! new-shape
- (rectangle->XRegion
- (used-screen-area outer-rectangle)))
- (assign-geometry! new-shape
- (drawing-surface outer-rectangle)
- (copy-rectangle screen-area))
- new-shape))
-
- (define (make-rubber-shape)
- (let ((new-shape
- (rubber-shape-maker new-shape-color fill-shadow-shapes?)))
- (set-clip-region! new-shape
- (rectangle->XRegion
- (used-screen-area outer-rectangle)))
- (set-shape-geometry! new-shape rubber-from rubber-from)
- (set-xor-draw! new-shape)
- new-shape))
-
- (define (set-shape-geometry! shape from to)
- (let ((x1 (point.x from))
- (y1 (point.y from))
- (x2 (point.x to))
- (y2 (point.y to)))
- (let* ((dx (- x2 x1))
- (dy (- y2 y1))
- (x-left (if (>= dx 0) x1 x2))
- (y-top (if (>= dy 0) y1 y2)))
- (assign-geometry! shape
- (drawing-surface outer-rectangle)
- (make-UITKRectangle (make-point x-left y-top)
- (make-size (abs dx) (abs dy))))
- 'DONE)))
-
- (define (grow-shadow-shape to)
- (shape-erase shadow-shape)
- (set-shape-geometry! shadow-shape rubber-from to)
- (shape-draw shadow-shape))
-
- (define (find-shape-under-event event)
- (let loop ((more-shapes (reverse shapes-and-areas)))
- (cond ((null? more-shapes) #F)
- ((event-within?
- (shape-and-area->shape (car more-shapes)) event)
- (car more-shapes))
- (else (loop (cdr more-shapes))))))
-
- (define (shape-erase shape)
- (or (shape-erase-maybe shape)
- (redraw-surface-except
- shape
- (rectangle->Xregion (used-screen-area shape)))))
-
- (define (set-xor-draw! shape)
- (shape-set-gc-function! shape GXXOR)
- (shape-set-erase-function! shape (shape-draw-function shape))
- (shape-set-color! shape background-color))
-
- (define (redraw-surface-except shape clip-region)
- (shape-draw outer-rectangle clip-region)
- (for-each
- (lambda (shape) (shape-draw shape clip-region))
- (map shape-and-area->shape
- (list-transform-negative shapes-and-areas
- (lambda (shape-and-area)
- (eq? shape (shape-and-area->shape shape-and-area)))))))
-
- (define (redraw-surface clip-region)
- (shape-draw outer-rectangle clip-region)
- (for-each (lambda (shape) (shape-draw shape clip-region))
- (map shape-and-area->shape shapes-and-areas)))
-
- (handle-exposure outer-rectangle
- (lambda (exposed-rectangle)
- (redraw-surface (Rectangle->XRegion exposed-rectangle))))
-
- (handle-button-grab
- outer-rectangle ANYBUTTON
- (lambda (e while-grabbed) ; When the button goes down
- (let ((shape (find-shape-under-event e)))
- (cond (shape (process-click-on-shape shape e while-grabbed))
- ((event-within? outer-rectangle e)
- (process-click-on-background e while-grabbed))
- (else
- (while-grabbed
- (lambda (point) point 'OK) ; Nothing to do
- (lambda () 'OK)))))))
-
- (on-geometry-change!
- outer-rectangle 'ignore
- (lambda (old-screen-area new-screen-area)
- (if (not (screen-area= old-screen-area new-screen-area))
- (if (UITKRectangle? new-screen-area)
- (let ((Clip (rectangle->XRegion new-screen-area)))
- (for-each
- (lambda (shape-and-area)
- (let ((shape (shape-and-area->shape shape-and-area))
- (area (shape-and-area->area shape-and-area)))
- (set-clip-region! shape clip)
- (set-shape-and-area-area!
- shape-and-area
- (make-UITKRectangle
- (UITKRectangle.offset area)
- (UITKRectangle.Size new-screen-area)))))
- shapes-and-areas)
- (redraw-surface clip))
- (for-each (lambda (shape-and-area)
- (let ((shape
- (shape-and-area->shape shape-and-area)))
- (set-clip-region! shape #F)
- (assign-screen-area! shape #F)))
- shapes-and-areas)))))
- (lambda (message)
- (case message
- ((the-surface) outer-rectangle)
- ((set-color!)
- (lambda (string)
- (set! new-shape-color string)))
- ((rectangles)
- (set! rubber-shape-maker make-scaling-rect)
- (set! shape-maker make-rect))
- ((ovals)
- (set! rubber-shape-maker make-scaling-oval)
- (set! shape-maker make-oval))
- ((lines)
- (set! rubber-shape-maker make-scaling-line)
- (set! shape-maker make-line))
- ((outlined) (set! fill-shadow-shapes? #F))
- ((filled) (set! fill-shadow-shapes? #T))
- ((clear)
- (begin (set! shapes-and-areas '())
- (set! shape->maker-map '())
- (redraw-surface
- (rectangle->XRegion
- (used-screen-area outer-rectangle)))))
- (else (error "unknown message"))))))
-
-
-
-
-;;;;******This isn't working. I don't understand how to manage the
-;;;;event queue
-
-(define debug-surface)
-
-(define (make-drop-rubber-rectangle-surface app width height color shape-color)
- (let ((rubber-from #F) ; X,Y of click relative to dragging shape
- (rubber-to #F)
- (active-shape #F)
- (shadow-shape #F)
- (fill-rubber-shapes? #F)
- (shape-maker make-rect)
- (shadow-shape-maker make-scaling-rect)
- (shapes '())
- (outer-rectangle (make-rect width height color)))
- (set! debug-surface (lambda () 'foo))
- (define (pick-random-shape)
- (let ((l (length shapes)))
- (list-ref shapes (random l))))
- (define (drop)
- (if (not (null? shapes))
- (let* ((s (pick-random-shape)))
- (redraw-surface-except s (rectangle->Xregion (used-screen-area s)))
- (let* ((p (UITKRectangle.offset (used-screen-area s)))
- (x (point.x p))
- (y (point.y p)))
- (if (> y (+ (point.y (UITKRectangle.offset
- (used-screen-area outer-rectangle)))
- height))
- (begin (set! shapes (delq! s shapes))
- 'OK)
- (begin (assign-location! s (make-point x (+ y 5)))
- (shape-draw s))))
- (when-idle! app drop))))
- (define (find-shape event)
- (let loop ((more-shapes (reverse shapes)))
- (cond ((null? more-shapes) #F)
- ((event-within? (car more-shapes) event)
- (let ((this (car more-shapes)))
- (set! shapes (append (delq! this shapes) (list this)))
- this))
- (else (loop (cdr more-shapes))))))
- (define (process-click-on-active-shape e while-grabbed)
- (let ((Click (Event.Offset e))
- (screen-area (used-screen-area active-shape)))
- (set! rubber-from (sub-vectors Click
- (UITKRectangle.offset screen-area)))
- ;;bring active shape to top
- (shape-draw active-shape)
- (while-grabbed
- (lambda (point) ; Motion procedure ...
- (if (point-within? outer-rectangle point) ; maybe
- (move-active-shape (sub-vectors point rubber-from))))
- (lambda () (set! active-shape #F)) ;finalize
- )))
- (define (process-click-on-background e while-grabbed)
- (let ((Click (Event.Offset e)))
- (initialize-rubber-rectangle Click)
- (while-grabbed
- (lambda (point) ; Motion procedure ...
- (if (point-within? outer-rectangle point) ; maybe
- (grow-rubber-rectangle point)))
- instantiate-rubber-rectangle))) ;finalize
-
- (define (instantiate-rubber-rectangle)
- (let* ((used (used-screen-area shadow-shape))
- (new-shape (shape-maker (UITKRectangle.Width used)
- (UITKRectangle.Height used)
- new-shape-color)))
- (shape-erase shadow-shape)
- (set! shadow-shape #F)
- (set-clip-region! new-shape
- (rectangle->XRegion
- (used-screen-area outer-rectangle)))
- (set-shape-geometry! new-shape)
- (shape-draw new-shape)
- (set! shapes (append shapes (list new-shape)))
- (when-idle! app drop)))
-
- (define (initialize-rubber-rectangle Click)
- (set! rubber-from Click)
- (make-rubber-rectangle Click))
-
- (define (make-rubber-rectangle to)
- (set! rubber-to to)
- (set! shadow-shape (shadow-shape-maker "white" fill-rubber-shapes?))
- (set-clip-region! shadow-shape
- (rectangle->XRegion
- (used-screen-area outer-rectangle)))
- (set-shape-geometry! shadow-shape)
- (shape-set-gc-function! shadow-shape GXXOR)
- (shape-set-erase-function! shadow-shape
- (shape-draw-function shadow-shape))
- (shape-draw shadow-shape))
-
- (define (set-shape-geometry! shape)
- (let ((x1 (point.x rubber-from))
- (y1 (point.y rubber-from))
- (x2 (point.x rubber-to))
- (y2 (point.y rubber-to)))
- (let* ((dx (- x2 x1))
- (dy (- y2 y1))
- (x-left (if (>= dx 0) x1 x2))
- (y-top (if (>= dy 0) y1 y2)))
- (assign-geometry! shape
- (drawing-surface outer-rectangle)
- (make-UITKRectangle (make-point x-left y-top)
- (make-size (abs dx) (abs dy))))
- 'DONE)))
-
- (define (grow-rubber-rectangle point)
- (set! rubber-to point)
- (shape-erase shadow-shape) ; Can't fail!
- (set-shape-geometry! shadow-shape)
- (shape-draw shadow-shape))
-
- (define (redraw-surface-except shape clip-region)
- (shape-draw outer-rectangle clip-region)
- (for-each (lambda (shape) (shape-draw shape clip-region))
- (delq shape shapes)))
- (define (redraw-surface clip-region)
- (shape-draw outer-rectangle clip-region)
- (for-each (lambda (shape) (shape-draw shape clip-region))
- shapes))
- (define (move-active-shape to-point)
- (let ((screen-area (used-screen-area active-shape)))
- (redraw-surface-except active-shape
- (rectangle->XRegion screen-area))
- (assign-location! active-shape to-point)
- (shape-draw active-shape)))
-
- (handle-exposure outer-rectangle
- (lambda (exposed-rectangle)
- (redraw-surface (Rectangle->XRegion exposed-rectangle))))
-
- (handle-button-grab
- outer-rectangle ANYBUTTON
- (lambda (e while-grabbed) ; When the button goes down
- (set! active-shape (find-shape e))
- (cond (active-shape (process-click-on-active-shape e while-grabbed))
- ((event-within? outer-rectangle e)
- (process-click-on-background e while-grabbed))
- (else
- (while-grabbed
- (lambda (point) point 'OK) ; Nothing to do
- (lambda () (set! active-shape #F)))))))
-
- (on-geometry-change!
- outer-rectangle 'ignore
- (lambda (old-screen-area new-screen-area)
- old-screen-area
- (let ((ds (drawing-surface outer-rectangle)))
- (if (UITKRectangle? new-screen-area)
- (let ((Clip (rectangle->XRegion new-screen-area)))
- (for-each
- (lambda (shape)
- (set-clip-region! shape clip)
- (assign-geometry! shape ds new-screen-area))
- shapes)
- (redraw-surface clip))
- (for-each (lambda (shape)
- (set-clip-region! shape #F)
- (assign-screen-area! shape #F))
- shapes)))))
- (when-idle! app drop)
- (lambda (message)
- (case message
- ((the-surface) outer-rectangle)
- ((set-color!)
- (lambda (new-shape-color-name)
- (let* ((dsp (UITKWindow.XDisplay
- (DrawingSurface.UITKWindow
- (Drawing-Surface outer-rectangle))))
- (color ((string->color dsp) new-shape-color-name)))
- (if color
- (begin
- (set! new-shape-color new-color-name)
- 'OK)
- #F))))
- ((rectangles)
- (set! shadow-shape-maker make-scaling-rect)
- (set! shape-maker make-rect))
- ((ovals)
- (set! shadow-shape-maker make-scaling-oval)
- (set! shape-maker make-oval))
- ((outlined) (set! fill-rubber-shapes? #F))
- ((filled) (set! fill-rubber-shapes? #T))
- ((clear)
- (begin (set! shapes '())
- (redraw-surface
- (rectangle->XRegion
- (used-screen-area outer-rectangle)))))
- (else (error "unknown message"))))))
+++ /dev/null
-;;;;; -*- Scheme -*-
-;;;;;
-;;;;; derived from uitk.scm at MIT on April 24, 1993
-
-;;;; Commonly used structure definitions. They are here so that the
-;;;; macro versions can be loaded to improve performance.
-
-(scc-define-structure UITKWindow
- xdisplay ; X display connection
- xwindow) ; X window ID
-
-(scc-define-structure ToolKitWindow ; For TK or whatever
- Application ; For GC protection of TK Widgets
- Top-Level-Geometry-Callback ; From TK to us (for GC, too)
- TK-Window) ; *Un*wrapped!
-
-(scc-define-structure DrawingSurface
- ToolKitWindow
- UITKWindow
- (Weak-List-of-Widgets '())) ; Ones that use this surface
-
-(scc-define-structure Point X Y)
-
-(scc-define-structure UITKRectangle Offset Size)
-
-(scc-define-structure Size Width Height)
-
-(scc-define-structure context
- activebackground activeforeground anchor background
- border borderwidth
- ;; cursor
- ;; font
- foreground relief)
-
-(scc-define-structure alert reason function)
-
-(scc-define-structure queue
- (%head #F)
- (%tail #F))
-
-(scc-define-structure locked-list
- (%mutex (make-thread-mutex))
- (%data '()))
-
-(scc-define-structure surface-sensitivity
- Weak-Surface
- Mask
- Sensitivities)
-
-(scc-define-structure sensitivity
- %weak-<interactor>
- Masks)
-
-(scc-define-structure sensitive-surface
- DrawingSurface
- Handlers)
-
-(scc-define-structure TK-variable
- application
- tk-name
- callback ;on writes
- )
-
-(scc-define-structure scxl-wrapper
- type
- wrapped-object
- strong-dependents
- other-stuff)
-
-
-(scc-define-structure Event
- Point-or-rectangle?
- Type
- OS-Event
- Window
- Offset
- Width
- Height)
-
-(scc-define-structure Glue
- minsize
- class
- value)
-
-;;; Applications, interactors, boxes, shapes, tkwidgets
-;;; all share these internals. These slots will be the first thing in
-;;; the structure.
-
-(scc-define-structure UIObjInternals
- Add-Child!-procedure
- Remove-Child!-procedure
- Set-Context!-procedure
- Assign-Screen-Area!-procedure
- Assign-Drawing-Surface!-procedure
- Point-Within?-procedure
- Rectangle-Overlaps?-procedure
- Handle-Event-procedure
- Get-Desired-Size-procedure
- Assigned-Screen-Area-procedure
- Used-Screen-Area-procedure
- Set-Assigned-Screen-Area!-procedure
- Set-Used-Screen-Area!-procedure
- Assign-Glue!-procedure
- (%geometry-alerts '())
- (%event-alerts '())
- (%context-alerts '())
- (%death-alerts '())
- (Assigned-Screen-Area #F)
- (Used-Screen-Area #F)
- (clip-region #F)
- (drawing-surface 'UNASSIGNED)
- (%desired-size #F)
- (%vglue #F) ; for boxes, shapes
- (%hglue #F) ; and tkwidgets only
- ;; Hal says:
- ;; "Success has many parents, but a UIObj has only one"
- (already-have-a-parent? #F)
- ;; Second '() is a special list for canvas and text items, that
- ;; might need to be un-gc-protected all at once.
- (crud-that-I-dont-want-to-gc-away (cons '() '()))
- )
-
-;;;Generic procedures on objects that have UIObj internals
-
-(define-integrable uiobjinternals-index 1)
-
-
+++ /dev/null
-;;; -*- Scheme -*-
-
-;;; More structures. With all this macro expansion, the compiler runs
-;;; out of space if they are all in one file.
-
-(scc-define-structure Application%
- UIObjInternals
- %child-windows ; Locked list of all children
- %%%code%%% ; Asynchronous code to be
- ; executed when data arrives
- ; from the display connection
- application-name
- Xdisplay ; A SCXL-wrapped display
- TKMainWindow
- context)
-
-(scc-define-structure Interactor%
- UIObjInternals
- handlers
- ;; Map from children of the interactor -- things it manages --
- ;; to Sensitive-Surface data structures. These are implemented
- ;; at the end of the file and maintain the correspondence
- ;; between drawing surfaces, event generation masks, and
- ;; <interactor> objects.
- (sensitive-surface-map '()))
-
-(scc-define-structure Shape%
- UIObjInternals
- x-draw
- calculate-used-screen-area
- color
- point-within?
- rectangle-overlaps?
- (x-erase #F)
- gc-function
- (graphics-context #F))
-
-(scc-define-structure Box%
- UIObjInternals
- sizer
- arranger
- get-hglue
- get-vglue
- (kids '()))
-
-(scc-define-structure ArrayBox%
- UIObjInternals
- kids-lists
- (kids '()))
-
-(scc-define-structure TKWidget%
- UIObjInternals
- Ask-Widget-procedure
- Add-Event-Handler!-procedure
- Set-Callback!-procedure
- (deferred-ask-widget-commands '())
- (how-to-make-me 'later)
- ;; Parent-Window -- stored as assigned screen area
- (Set-Glue!-procedure 'later)
- (%c-callback 'later)
- (%binding-callbacks '())
- (%scheme-geometry-manager 'later)
- (%scheme-callback-hash 'later)
- (%callback #F)
- (%callback-command #F)
- (%children '())
- (handle #F)
- (do-screen-area? 'later)
- ;; The following is weird. TK does finalization of some TK objects
- ;; (sub-menus bit us ...) and we can *not* destroy these on our own.
- ;; We simply reflect the ownership (via add-child!) to prevent them
- ;; from being GCed away if the TK parent exists. And the child
- ;; better hold on to the parent, too.
- (do-not-gc-protect #F))
-
-(scc-define-structure CanvasItem
- Ask-Widget-procedure
- Add-Event-Handler!-procedure
- Set-Callback!-procedure
- Name
- Canvas
- %binding-callbacks)
-
-(scc-define-structure CanvasItemGroup
- Ask-Widget-procedure
- Add-Event-Handler!-procedure
- Set-Callback!-procedure
- Tag
- Canvas
- %binding-callbacks)
-
-(scc-define-structure MenuRecord Menu Items)
-
-(scc-define-structure MenuItem
- ask-widget-procedure
- Add-event-handler!-procedure
- Set-callback!-procedure
- MenuRecord
- %callback
- index)
-
-(scc-define-structure TextTag
- ask-widget-procedure
- Add-event-handler!-procedure
- Set-callback!-procedure
- Name
- Text
- Callbacks)
-
-;;; procedures that are generic over CanvasItem, CanvasTag, MenuItem,
-;;; TextTag, and TKWidget
-
-(define-integrable ask-widget-procedure-index 1)
-(define-integrable add-event-handler!-procedure-index 2)
-(define-integrable set-callback!-procedure-index 3)
-
-
-
+++ /dev/null
-;;; -*-Scheme-*-
-
-;;(define (cf-conditionally filename)
-;; (sf-conditionally filename)
-;; (if (not (file-processed? filename "bin" "com"))
-;; (compile-bin-file filename)))
-;;
-;;
-;;(fluid-let ((sf/default-syntax-table (->environment '(RUNTIME)))
-;; (sf/default-declarations (cons '(usual-integrations)
-;; sf/default-declarations)))
-;; (cf-conditionally "scc-macros")
-;; (load "scc-macros")
-;; (cf-conditionally "uitk-macros")
-;; (load "uitk-macros")
-;; (cf-conditionally "control-floating-errors")
-;; (cf-conditionally "structures")
-;; (cf-conditionally "structures2")
-;; (cf-conditionally "generics")
-;; (cf-conditionally "widget-mit")
-;; (cf-conditionally "tk-mit")
-;; (cf-conditionally "uitk")
-;; (cf-conditionally "xlibCONSTANTS")
-;; (cf-conditionally "mit-xlib")
-;; (cf-conditionally "mit-xhooks")
-;; (cf-conditionally "baseobj")
-;; (cf-conditionally "widget")
-;; (cf-conditionally "geometry")
-;; (cf-conditionally "simple")
-;; (cf-conditionally "canvas")
-;; (cf-conditionally "menu")
-;; (cf-conditionally "text")
-;;
-;; )
-;;
-
-
-
-(compile-directory ".")
-
-;; For `make install':
-
-(with-output-to-file "compiled"
- (lambda ()
- (write "Scheme compiled")))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; SWAT build process: syntaxing.
-
-(declare (usual-integrations))
-
-(fluid-let ((sf/default-syntax-table (->environment '(RUNTIME)))
- (sf/default-declarations
- `((usual-integrations) ,@sf/default-declarations)))
-
- (sf-conditionally "scc-macros")
- (load "scc-macros")
- (sf-conditionally "uitk-macros")
- (load "uitk-macros")
- (sf-conditionally "structures")
- (sf-conditionally "structures2")
- (sf-conditionally "xlibCONSTANTS")
- (sf-conditionally "load")
-
- (fluid-let ((sf/default-declarations
- `((integrate-external "structures")
- (integrate-external "structures2")
- (integrate-external "xlibCONSTANTS")
- ,@sf/default-declarations)))
- (sf-conditionally "control-floating-errors")
- (sf-conditionally "generics")
- (sf-conditionally "widget-mit")
- (sf-conditionally "tk-mit")
- (sf-conditionally "uitk")
- (sf-conditionally "mit-xlib")
- (sf-conditionally "mit-xhooks")
- (sf-conditionally "baseobj")
- (sf-conditionally "widget")
- (sf-conditionally "geometry")
- (sf-conditionally "simple")
- (sf-conditionally "canvas")
- (sf-conditionally "menu")
- (sf-conditionally "text")))
-
-;;(load-option 'CREF)
-;;(cref/generate-constructors "swat")
\ No newline at end of file
+++ /dev/null
-;;; -*- Scheme -*-
-
-;;; Scrollable text widgets (only vertical scrollbar makes sense,
-;;; since text can't be extended horizontally without changing the
-;;; size of the top level window).
-
-#|
-(define (make-scrollable-text . options)
- (let ((text (apply make-text options))
- (vscroll (make-scrollbar '(-orient vert))))
- (let ((sb-command
- (lambda ()
- (ask-widget
- vscroll
- `(configure -command
- ,(string-append (tk-widget->pathname text)
- " yview")))))
- (c-command
- (lambda ()
- (ask-widget
- text
- `(configure -yscrollcommand
- ,(string-append (tk-widget->pathname vscroll) " set"))))))
- (defer text sb-command)
- (defer vscroll c-command)
- (make-hbox text vscroll))))
-|#
-
-(define (make-scrollable-text . options)
- (let ((text (apply make-text options))
- (vscroll (make-scrollbar '(-orient vert))))
- (let ((c-command
- (lambda ()
- (ask-widget
- text
- `(configure -yscrollcommand
- ,(string-append (tk-widget->pathname vscroll) " set"))))))
- (defer vscroll c-command)
- (set-callback!
- vscroll
- (lambda (n)
- (let ((n (string->number n)))
- (ask-widget text `(yview -pickplace ,n)))))
- (make-hbox text vscroll))))
-
-(define (scrollable-text-text scrollable-text)
- (car (box-children scrollable text)))
-
-(define (scrollable-text-vscroll scrollable-text)
- (cadr (box-children scrollable-text)))
-
-
-
-;;; Text has special protect-from-gc! procedures
-
-(define (text-protect-from-gc! text stuff)
- (let ((crud (crud-that-I-dont-want-to-gc-away text)))
- (set-cdr! crud (cons stuff (cdr crud))))
- 'done)
-
-(define (text-unprotect-from-gc! text stuff)
- (let ((crud (crud-that-I-dont-want-to-gc-away text)))
- (set-cdr! crud (delq! stuff (cdr crud))))
- 'done)
-
-(define (text-flush-protect-list! text)
- (let ((crud (crud-that-I-dont-want-to-gc-away text)))
- (set-cdr! crud '()))
- 'done)
-
-
-
-;;; TextTags
-
-(define (make-text-tag text index1 . index2)
- (let ((name (tk-gen-name "texttag")))
- (ask-widget text `(tag add ,name ,index1 ,@index2))
- (let ((texttag (make-texttag texttag-ask-widget
- texttag-add-event-handler!
- 'invalid
- name
- text
- '())))
- (text-protect-from-gc! text texttag)
- texttag)))
-
-(define (texttag-add-event-handler! tag event handler substitutions)
- (let ((text (TextTag.text tag))
- (handler (proc-with-transformed-args handler substitutions)))
- (set-texttag.callbacks! tag
- (cons handler (texttag.callbacks tag)))
- (ask-widget text
- `(tag bind
- ,(TextTag.name tag)
- ,event
- ("SchemeCallBack" ,(object-hash handler *our-hash-table*)
- ,@substitutions)))))
-
-(define (texttag-ask-widget tag arg-list)
- (let* ((tag-name (TextTag.name tag))
- (text (TextTag.text tag))
- (command (car arg-list))
- (new-arg-list (cons "tag"
- (cons command
- (cons tag-name (cdr arg-list))))))
- (let ((result (ask-widget text new-arg-list)))
- (if (eq? command 'delete)
- (text-unprotect-from-gc! text tag))
- result)))
-
+++ /dev/null
-; -*- Scheme -*-
-;;;;; C external interfaces to Tk procedures not associated with
-;;;;; a particular widget.
-
-;;;; This is the lowest level Scheme interface to general TK/TCL data
-;;;; structures. Primitives are defined in tk-mit.c and tk.c
-
-(define-primitives
- (%tclGlobalEval 2)
- (%tkCompletelyHandlesEvent? 1)
- (%tkCreateTopLevelWindow 3)
- (%tkDoEvents 0)
- (%tkDrainCallBacks 2)
- (%tkGenerateSchemeEvent 2)
- (%tkInit 2)
- (%tkInvokeCommand -1)
- (%tkKillApplication 1)
- (%tkManageGeometry 2)
- (%tkMapWindow 1)
- (%tkMoveResizeWindow 5)
- (%tkMoveWindow 3)
- (%tkNextWakeup 0)
- (%tkResizeWindow 3)
- (%tkUnmapWindow 1)
- (%tkWidget.tkwin 1)
- (%tkWinDisplay 1)
- (%tkWinReqHeight 1)
- (%tkWinReqWidth 1)
- (%tkWinHeight 1)
- (%tkWinIsMapped? 1)
- (%tkWinName 1)
- (%tkWinPathName 1)
- (%tkWinWidth 1)
- (%tkWinWindow 1)
- (%tkWinX 1)
- (%tkWinY 1)
-)
-
-;;;; Support code
-
-(define tk-gen-name
- (let ((count 0))
- (lambda (name)
- (set! count (+ 1 count))
- (string-append name (number->string count)))))
-\f
-;;;; Entry points in alphabetical order
-
-(define (get-interval-to-tk-wakeup)
- (%tkNextWakeup))
-
-
-;; A not-so-precise number->string that is faster and more than
-;; sufficient for our purposes. Note that the output always has a
-;; leading digit to prevent tk from thinking that .7 is a name and
-;; not a number.
-
-(define (swat:number->string x)
-
- (define (digits x n tail)
- (define (next* ch x*)
- (cons ch (digits x* (fix:- n 1) tail)))
- (define-integrable (next ch delta)
- (next* ch (flo:* (flo:- x delta) 10.0)))
- (cond ((< n 0) tail)
- ((flo:< x 1.e-10) tail)
- ((flo:< x 1.0) (next #\0 0.0))
- ((flo:< x 2.0) (next #\1 1.0))
- ((flo:< x 3.0) (next #\2 2.0))
- ((flo:< x 4.0) (next #\3 3.0))
- ((flo:< x 5.0) (next #\4 4.0))
- ((flo:< x 6.0) (next #\5 5.0))
- ((flo:< x 7.0) (next #\6 6.0))
- ((flo:< x 8.0) (next #\7 7.0))
- ((flo:< x 9.0) (next #\8 8.0))
- (else (next #\9 9.0))))
-
- (define (format-exponent e)
- (define (format-integer n tail)
- (define (+digit k) (cons (ascii->char (fix:+ k 48)) tail))
- (if (fix:< n 10)
- (+digit n)
- (let ((front (fix:quotient n 10))
- (back (fix:remainder n 10)))
- (format-integer front (+digit back)))))
- (cond ((fix:= e 0) '())
- ((fix:< e 0)
- (cons* #\e #\- (format-integer (fix:- 0 e) '())))
- (else
- (cons* #\e (format-integer e '())))))
-
- (define (scale x e)
- (cond ((flo:< x 1.0e-30) '(#\0 #\. #\0))
- ((flo:< x 1.0) (scale (flo:* x 1000.0) (- e 3)))
- ((flo:< x 10.0)
- (let* ((tail (format-exponent e))
- (ds (digits x 8 tail)))
- (if (eq? (cdr ds) tail)
- (cons* (car ds) #\. #\0 (cdr ds))
- (cons* (car ds) #\. (cdr ds)))))
- (else (scale (flo:* x 0.1) (+ e 1)))))
-
- (if (flo:flonum? x)
- (list->string
- (if (flo:< x 0.0)
- (cons #\- (scale (flo:- 0.0 x) 0))
- (scale x 0)))
- (number->string x 10)))
-\f
-(define (stringify-for-tk arg)
- (define (->string arg)
- (cond ((string? arg) arg)
- ((number? arg) (swat:number->string arg))
- ((symbol? arg) (symbol-name arg))
- ((TK-variable? arg) (TK-variable.tk-name arg))
- ((pair? arg) (apply string-append (map stringify-for-tk arg)))
- ((procedure? arg) (->string (arg)))
- (else (error "tcl-global-eval: Unknown argument type" arg))))
-
- (string-append "{" (->string arg) "} "))
-
-(define (tk-op thunk)
- (let ((result (thunk)))
- (kick-uitk-thread)
- result))
-
-(define (tcl-global-eval application command-name args)
- (tk-op
- (lambda ()
- (%tclGlobalEval
- (application->TKMainWindow application)
- (apply string-append (map stringify-for-tk (cons command-name args)))))))
-
-
-;;;turn off all floating errors around TK processing
-;;;Note that we don't need a dynamic wind because
-;;;%tkCompletelyHandlesEvent? always completes. If the argument is
-;;;bad it returns a 0.
-
-(define (tk-completely-handles-event? os-event)
- (let ((old-mask (set-floating-error-mask! 0)))
- (let ((result (%tkCompletelyHandlesEvent? os-event)))
- (set-floating-error-mask! old-mask)
- (if (eqv? result 0)
- (error "bad argument to tk-completely-handles-event?" os-event)
- result))))
-
-(define (tk-create-top-level-window main-window callbackhash)
- (tk-op
- (lambda ()
- (%tkCreateTopLevelWindow main-window
- (tk-gen-name "top-level-window")
- callbackhash))))
-
-(define (tk-doevents)
- ;; Turn off floating errors
- (let ((old-mask (set-floating-error-mask! 0)))
- ;; Do all pending Tk events, which should only be do-when-idles
- (%tkDoEvents)
- (set-floating-error-mask! old-mask))
- (do-tk-callbacks))
-
-(define (tk-generate-Scheme-event event-mask unwrapped-tk-window)
- ;; Cause TK to signal us that Scheme wants to know about these kinds
- ;; of events on this window.
- (%tkGenerateSchemeEvent event-mask unwrapped-tk-window))
-\f
-(define (tk-init xdisplay)
- ;; Set up an initial environment with a Tcl interpreter
- (tk-op
- (lambda ()
- (%tkInit (->xdisplay xdisplay)
- (tk-gen-name
- (string-append "main-window-for-display-"
- (number->string (->xdisplay xdisplay))))))))
-
-(define (tk-invoke-command command-name main-window arg-strings)
- (define commands
- `((After . 0)
- (Bind . 1)
- (Destroy . 2)
- (Focus . 3)
- (Grab . 4)
- (Option . 5)
- (Pack . 6)
- (Place . 7)
- (Selection . 8)
- (Tk . 9)
- (Tkwait . 10)
- (Update . 11)
- (Winfo . 12)
- (Wm . 13)))
- (tk-op
- (lambda ()
- (apply %tkInvokeCommand (cdr (assq command-name commands))
- main-window
- arg-strings))))
-
-(define (tk-kill-application main-window)
- ;; main-window is an integer, not wrapped
- (%tkKillApplication main-window))
-
-(define (tk-manage-geometry widget manager-procedure)
- ;; Arrange for manager-procedure to be called with no arguments
- ;; whenever TK requests geometry operations on widget.
- (tk-op
- (lambda ()
- (%tkManageGeometry (tk-widget.tkwin widget)
- (and manager-procedure
- (hash manager-procedure
- *our-hash-table*))))))
-
-(define (tk-map-window tkwin)
- (tk-op (lambda () (%tkmapwindow tkwin))))
-
-(define (tk-move-resize-widget widget screen-area)
- (tk-op
- (lambda ()
- (%tkMoveResizeWindow (tk-widget.tkwin widget)
- (Point.X (UITKRectangle.Offset screen-area))
- (Point.Y (UITKRectangle.Offset screen-area))
- (UITKRectangle.Width screen-area)
- (UITKRectangle.Height screen-area)))))
-\f
-(define (TK-Unmap-Window tkwin)
- (tk-op (lambda () (%tkUnmapWindow tkwin))))
-
-(define (tk-widget.tkwin widget)
- (%tkWidget.tkwin (->widget widget)))
-
-(define (tkwin.display tkwin)
- (%tkWinDisplay tkwin))
-
-(define (tkwin.req-height tkwin)
- (%tkWinReqHeight tkwin))
-
-(define (tkwin.req-width tkwin)
- (%tkWinReqWidth tkwin))
-
-(define (tkwin.height tkwin)
- (%tkWinHeight tkwin))
-
-(define (tkwin.IsMapped? tkwin)
- (%tkWinIsMapped? tkwin))
-
-(define (tkwin.width tkwin)
- (%tkWinWidth tkwin))
-
-(define (tkwin.window tkwin)
- ;; Deliberately don't do a wrap-window. Instead, allow a higher
- ;; level to do it, since the server maintains the window hierarchy
- ;; and effectively keeps pointers for us.
- (%tkWinWindow tkwin))
-
-(define (tkwin.name tkwin)
- (%tkWinName tkwin))
-
-(define (tkwin.pathname tkwin)
- (%tkWinPathName tkwin))
-
-(define (tkwin.x tkwin)
- (%tkWinX tkwin))
-
-(define (tkwin.y tkwin)
- (%tkWinY tkwin))
-\f
-;;;; TK Callback handling
-
-(define (do-tk-callbacks-from-string string)
- ;; The string has the following format:
- ;; <char. count>
- ;; <nchars>chars
- ;; <nchars>chars
- ;; ...
- ;; where <char. count> is the number of characters in the object ID
- ;; and its associated string arguments. The "<" and ">" are NOT
- ;; meta-characters; they are used for separating the entries and
- ;; error detection.
- (define (split-string-by-number string receiver)
- ;; Expects a character count in angle brackets. Calls receiver
- ;; with the counted string and the rest, or #F/#F if the string is
- ;; empty.
- (cond
- ((string-null? string) (receiver #F #F))
- ((not (char=? (string-ref string 0) #\<))
- (error "Split-String-By-Number: Badly formed entry"
- string))
- (else
- (let ((break-at (string-find-next-char string #\>)))
- (if (not break-at)
- (error "Split-String-By-Number: entry not terminated"
- string)
- (let ((count (string->number (substring string 1 break-at)))
- (after-count (+ break-at 1))
- (slength (string-length string)))
- (cond
- ((not count)
- (error "Split-String-By-Number: non-numeric count" string))
- ((> (+ after-count count) slength)
- (error "Split-String-By-Number: count too big" string))
- (else
- (let ((end (+ after-count count)))
- (receiver (substring string after-count end)
- (substring string end slength)))))))))))
- (define (parse-entry string receiver)
- ;; Entry starts with a character count in angle brackets
- ;; Receiver is called with an object, a vector of strings, and the
- ;; remaining string.
- (split-string-by-number string
- (lambda (entry after-entry)
- (let loop ((rest entry)
- (strings '()))
- (split-string-by-number rest
- (lambda (this-string rest-of-strings)
- (if this-string
- (loop rest-of-strings
- (cons this-string strings))
- (let ((all-strings (reverse strings)))
- (if (null? all-strings)
- (error "Parse-Entry: no entries" string))
- (let* ((Object-Name (car all-strings))
- (Object-ID (string->number object-name)))
- (if (not object-id)
- (error "Parse-Entry: non-number object ID"
- string object-name))
- ;; Note that the object associated with object-id
- ;; may have been GCed away!
- (receiver (object-unhash object-id *our-hash-table*)
- (cdr all-strings)
- after-entry))))))))))
- (if string
- (let callback-loop ((string string))
- (if (string-null? string)
- 'done
- (parse-entry string
- (lambda (callback list-of-string-args rest-of-string)
- ;; "callback" will be #F if it GC'ed away
- (if callback
- (our-with-thread-mutex-locked
- 'do-tk-callback
- *event-processing-mutex*
- (lambda ()
- (apply-callback callback list-of-string-args))))
- (callback-loop rest-of-string))))))
- 'OK)
-
-(define (apply-callback callback arglist)
- (cond ((ignore-errors
- (lambda () (apply callback arglist)))
- => (lambda (result)
- (if (condition? result)
- (let ((port (notification-output-port)))
- (newline port)
- (write-string ";Error in callback " port)
- (display callback port)
- (newline port)
- (write-string ";" port)
- (write-condition-report result port)
- (newline port)
- (write-string ";To debug, type (debug #@" port)
- (write (hash result) port)
- (write-string ")" port)
- (newline port)))))))
-
-
-(define *event-processing-mutex* (make-thread-mutex))
-
-(define do-tk-callbacks
- (let ((nchars 0)
- (string (make-string 0)))
- (lambda ()
- (let ((nchars-ready (%tkDrainCallBacks nchars string)))
- (if nchars-ready
- (if
- (positive? nchars-ready)
- (begin
- (set! nchars nchars-ready)
- (set! string (make-string nchars-ready))
- (do-tk-callbacks))
- 'OK)
- (do-tk-callbacks-from-string string))))))
-
+++ /dev/null
-;;;; -*-Scheme-*-
-;;; derived from macros.sc,v 1.1 1993/02/16 14:04:09 jmiller Exp $
-;;; Primitive X toolkit for Scheme->C.
-;;; RHH, September, 1989.
-;;; Macro definitions.
-
-;;; Stolen on January 17, 1993 by Jim Miller for use with UITK
-;;; Updated on June 27, 1993 by a bunch of us to use records instead
-;;; of vectors.
-
-;;;; SCC-DEFINE-STRUCTURE
-
-;;;; Components can be:
-;;;; a symbol (name of structure component)
-;;;; a pair (name and default value)
-;;;; Produces (in-lined)
-;;;; predicate procedure: (<name>? object)
-;;;; accessor procedures: (<name>.<component> object)
-;;;; mutator procedures: (SET-<name>.<component>! object new-value)
-;;;; internal constants: *-<name>.<component>-*
-;;;; internal contant: *-<name>.STRUCTURE-SIZE-*
-;;;; (re-)initialization procedure: (INIT-<name> object comp1 ...)
-;;;; creator procedure: (MAKE-<name> comp1 ...)
-
-;;;; Note: The MAKE- and INIT- procedures have required arguments
-;;;; for all components that do not have default values.
-
-;;;; Example:
-;;;; (scc-define-structure dot x y (color 'black))
-;;;; (define a-dot (make-dot 3 4))
-;;;; (set-dot.color! a-dot 'green)
-;;;; (list (dot.x a-dot) (dot.color a-dot)) -> (3 green)
-
-(define-syntax scc-define-structure
- (non-hygienic-macro-transformer
- (lambda (name . components)
- (define (symbol-format . args)
- (string->symbol
- (apply string-append
- (map (lambda (object)
- (cond ((string? object) object)
- ((symbol? object) (symbol->string object))
- (else (error
- 'SYMBOL-FORMAT
- "Neither symbol nor string ~A"
- object))))
- args))))
- (let ((size-name (symbol-format "*-" name '-STRUCTURE-SIZE "-*"))
- (self-varname (lambda (fn-name)
- (symbol-format 'SELF "/" name "/" fn-name)))
- (predicate-name (symbol-format name "?")))
-
- (define (component-name component)
- (if (pair? component) (car component) component))
-
- (define (accessor-name component)
- (symbol-format name "." (component-name component)))
-
- (define (set-symbol component)
- (symbol-format 'SET "-" name "." (component-name component) "!"))
-
- (define (gen-accessors components counter)
- (if (null? components)
- `((DEFINE-CONSTANT ,size-name ,counter))
- (let ((cname (component-name (car components))))
- (let ((offset-name (symbol-format "*-" name "." cname "-*"))
- (self (self-varname cname)))
- `((DEFINE-CONSTANT ,offset-name ,counter)
- (DEFINE-IN-LINE (,(accessor-name cname) ,self)
- (IF (,predicate-name ,self)
- (VECTOR-REF ,self ,offset-name)
- (ERROR ',(accessor-name cname)
- "Object not correct type ~A" ,self)))
- (DEFINE-IN-LINE (,(set-symbol cname) ,self NEW-VALUE)
- (IF (,predicate-name ,self)
- (BEGIN
- (VECTOR-SET! ,self ,offset-name NEW-VALUE)
- 'MODIFIED!)
- (ERROR ',(set-symbol cname)
- "Object not correct type ~A" ,self)))
- ,@(if *running-in-mit-scheme*
- '()
- `((DEFINE (,(accessor-name cname) ,self)
- (IF (,predicate-name ,self)
- (VECTOR-REF ,self ,offset-name)
- (ERROR ',(accessor-name cname)
- "Object not correct type ~A" ,self)))
- (DEFINE (,(set-symbol cname) ,self NEW-VALUE)
- (IF (,predicate-name ,self)
- (BEGIN
- (VECTOR-SET! ,self ,offset-name NEW-VALUE)
- 'MODIFIED!)
- (ERROR ',(set-symbol cname)
- "Object not correct type ~A" ,self)))))
- ,@(gen-accessors (cdr components) (+ counter 1)))))))
-
- (define (make-bvl components)
- (cond ((null? components) '())
- ((pair? (car components)) (make-bvl (cdr components)))
- (else (cons (car components) (make-bvl (cdr components))))))
-
- (define (gen-structure-initialization self-name components)
- (if (null? components)
- '()
- `((,(set-symbol (car components))
- ,self-name
- ,@(if (pair? (car components))
- (cdar components)
- (list (car components))))
- ,@(gen-structure-initialization self-name (cdr components)))))
-
- (let ((init-name (symbol-format 'INIT "-" name))
- (init-self-name (self-varname 'INIT))
- (init-bvl (make-bvl components))
- (accessors (gen-accessors components 1))
- (tag (symbol-format "#[" name "]")))
- `(begin
- (if ,*running-in-mit-scheme*
- (ADD-UNPARSER-SPECIAL-OBJECT!
- ',tag
- (lambda (obj)
- (display "#[scc-object ")
- (display ',name)
- (display " ")
- (display (hash obj))
- (display "]"))))
- ,@accessors
- (DEFINE (,(symbol-format name '/pp) OBJ)
- (IF (NUMBER? OBJ) (SET! OBJ (UNHASH OBJ)))
- (FOR-EACH (LAMBDA (FIELD-NAME ACCESSOR)
- (PP (LIST FIELD-NAME (ACCESSOR OBJ))))
- ',(map component-name components)
- (LIST ,@(map accessor-name components))))
- (DEFINE (,predicate-name OBJ)
- (AND (VECTOR? OBJ)
- (= (VECTOR-LENGTH OBJ) ,size-name)
- (EQ? (VECTOR-REF OBJ 0) ',tag)))
- (DEFINE (,init-name ,init-self-name ,@init-bvl)
- (VECTOR-SET! ,init-self-name 0 ',tag)
- ,@(gen-structure-initialization init-self-name components)
- ,init-self-name)
- (DEFINE (,(symbol-format 'MAKE "-" name) ,@init-bvl)
- (,init-name (make-vector ,size-name) ,@init-bvl))))))))
+++ /dev/null
-;;;;; -*- scheme -*-
-;;;;;
-;;;;; derived from uitk.sc,v 1.2 1993/02/25 14:13:22 jmiller exp $
-;;;;; $id: uitk.scm,v 1.11 1993/02/26 15:10:23 jmiller exp jmiller $
-
-(define debugging-port #f)
-
-(define (debug-print . args)
- (let ((port (or debugging-port (current-output-port)))
- (string (with-output-to-string
- (lambda ()
- (display (cons 'debugging (cons (current-thread) args)))))))
- (without-interrupts
- (lambda () (display string port) (newline port)))))
-
-;;;; notes
-
-;;;; message flows define relationships. normally, an operation that
-;;;; changes state on an object will use one of these relationships to
-;;;; alert other objects of the change. this permits an external
-;;;; constraint satisfaction system to propagate changes through the
-;;;; system. here are the flows currently
-;;;; assumed:
-;;;; (1) geometry. all object can report a desired size which
-;;;; includes stretch, shrink, and minimum size. this is a
-;;;; pure query and does not establish a relationship. the
-;;;; relationship commences with a call to either
-;;;; assign-screen-area! or assign-geometry!. these
-;;;; specify an area to be used and alert any object
-;;;; monitoring for geometry changes.
-;;;; (2) events. an object may have children to whom it reports
-;;;; events. event directors take an event and a list of
-;;;; children and propagate the event to the correct child
-;;;; or take a default action. this is a one-way interaction
-;;;; (i.e. children don't know about parents).
-;;;; (3) contexts.
-
-;;;; i'd like to use tiny clos as a means for handling the private
-;;;; slot in UIObj. this allows the common operations to be as fast
-;;;; as possible (i.e. not using generic dispatch) while still
-;;;; permitting extensibility. for the moment, however, i'm using
-;;;; simple structures and type-specific operations.
-
-;;;; when assign-screen-area! is called with #f instead of a screen
-;;;; area it means that it has had its area retracted. this happens
-;;;; when the geometric parent is told to remove it as a child. if it
-;;;; has been using the parent's window, it better clean up -- this
-;;;; may mean reparenting its own window to the root, i guess.
-\f
-(define (sub-vectors point-1 point-2)
- (make-point
- (- (point.x point-1) (point.x point-2))
- (- (point.y point-1) (point.y point-2))))
-
-(define (add-vectors point-1 point-2)
- (make-point
- (+ (point.x point-1) (point.x point-2))
- (+ (point.y point-1) (point.y point-2))))
-
-(define (point= point1 point2)
- (or (eq? point1 point2)
- (and
- (= (point.x point1) (point.x point2))
- (= (point.y point1) (point.y point2)))))
-
-(define (size= size1 size2)
- (or (eq? size1 size2)
- (and
- (= (size.width size1) (size.width size2))
- (= (size.height size1) (size.height size2)))))
-
-(define (copy-rectangle rect)
- (vector-copy rect))
-
-(define (UITKRectangle.Width rect)
- (size.width (UITKRectangle.Size rect)))
-
-(define (UITKRectangle.Height rect)
- (size.height (UITKRectangle.Size rect)))
-
-(define (rectangle= rect1 rect2)
- (or (eq? rect1 rect2)
- (and (point= (UITKRectangle.offset rect1) (UITKRectangle.offset rect2))
- (size= (UITKRectangle.Size rect1) (UITKRectangle.Size rect2)))))
-
-(define (screen-area= sa1 sa2)
- (or (and sa1 sa2 (rectangle= sa1 sa2))
- (and (not sa1) (not sa2))))
-
-(define (translate-rectangle rect point)
- (and rect
- (make-UITKRectangle point (UITKRectangle.Size rect))))
-
-\f
-;;;; event objects
-
-(define (make-point-event type os-event window offset)
- (make-event 'point type os-event window offset 'invalid 'invalid))
-
-(define (make-rectangle-event type os-event window offset width height)
- (make-event 'rectangle type os-event window offset width height))
-
-(define (make-unknown-event type os-event window)
- (make-event 'unknown type os-event window 'invalid 'invalid 'invalid))
-
-(define (point-event? obj)
- (and (event? obj)
- (eq? (event.point-or-rectangle? obj) 'point)))
-
-(define (rectangle-event? obj)
- (and (event? obj)
- (eq? (event.point-or-rectangle? obj) 'rectangle)))
-
-\f
-;;;; General support procedures
-
-(define (make-lookup key-fn)
- (lambda (object list)
- (let loop ((list list))
- (cond ((null? list) #F)
- ((eq? object (key-fn (car list))) (car list))
- (else (loop (cdr list)))))))
-
-(define (make-del-op! test?)
- (lambda (op)
- (lambda (key op-list)
- (define (loop previous current)
- (cond ((null? current) op-list)
- ((test? (op (car current)) key)
- (set-cdr! previous (cdr current))
- op-list)
- (else (loop current (cdr current)))))
- (cond ((null? op-list) '())
- ((test? (op (car op-list)) key)
- (cdr op-list))
- (else (loop op-list (cdr op-list)))))))
-
-(define del-op! (make-del-op! eq?))
-
-(define del-assq! (del-op! car))
-(define del-assv! ((make-del-op! eqv?) car))
-
-(define (make-weak-lookup key-fn)
- (lambda (object list)
- (let loop ((list list))
- (cond ((null? list) #F)
- ((eq? object (key-fn (weak-car list))) (weak-car list))
- (else (loop (weak-cdr list)))))))
-
-(define (make-weak-del-op! test?)
- (lambda (op)
- (lambda (key op-list)
- (define (loop previous current)
- (cond ((null? current) op-list)
- ((test? (op (weak-car current)) key)
- (weak-set-cdr! previous (weak-cdr current))
- op-list)
- (else (loop current (weak-cdr current)))))
- (cond ((null? op-list) '())
- ((test? (op (weak-car op-list)) key)
- (weak-cdr op-list))
- (else (loop op-list (weak-cdr op-list)))))))
-\f
-;;;; UI Objects
-
-(define (one-parent-only! child object)
- (let ((child-guts (uiobjinternals child)))
- (if (UIObjInternals.already-have-a-parent? child-guts)
- (error
- "ADD-CHILD!: Hal says 'success has many parents, but a UIObj has only one'"
- object child)
- (set-UIObjInternals.already-have-a-parent?! child-guts #T))))
-
-(define (get-UITKWindow obj)
- (let ((surface (drawing-surface obj)))
- (and (DrawingSurface? surface)
- (DrawingSurface.UITKWindow surface))))
-
-(define (DrawingSurface.Application ds)
- (ToolKitWindow.Application (DrawingSurface.ToolKitWindow ds)))
-
-
-;;; The alerts are stored as alists with the key being, typically, the
-;;; reason the alert was added. This allows the alert to be removed
-;;; if/when the reason is retracted. The alert function is called
-;;; with the reason as its argument.
-
-(define make-add-alert!
- (let ((find-alert (make-lookup alert.reason)))
- (lambda (accessor mutator!)
- (lambda (object key alert-fn)
- (let* ((previous (accessor object))
- (old-value (find-alert key previous)))
- (if old-value
- (begin
- ;;(set-alert.function! old-value alert)
- ;; (bkpt "gottcha in make-add-alert!")
- (debug-print 'gottcha!))
- (mutator! object `(,(make-alert key alert-fn) ,@previous)))
- 'added)))))
-
-(define make-remove-alert!
- (let ((del-alert! (del-op! alert.reason)))
- (lambda (accessor mutator!)
- (lambda (object key)
- (mutator! object (del-alert! key (accessor object)))
- 'removed))))
-
-(define (make-alert! arity accessor)
- ;; Arity is the arity expected of the alert function. Some alerts
- ;; pass additional information -- geometry, for example, passes both
- ;; the previous screen-area and the new screen-area. The alert
- ;; function can generally be assumed to have lexical access to both
- ;; the reason for the alert (specified when the alert is created)
- ;; and the object that generated the alert.
- (case arity
- ((0) (lambda (object)
- (for-each (lambda (alert) ((alert.function alert)))
- (accessor object))))
- ((1) (lambda (object arg)
- (for-each (lambda (alert) ((alert.function alert) arg))
- (accessor object))))
- ((2) (lambda (object arg1 arg2)
- (for-each (lambda (alert) ((alert.function alert) arg1 arg2))
- (accessor object))))
- (else (lambda (object . args)
- (for-each (lambda (alert) (apply (alert.function alert) args))
- (accessor object))))))
-\f
-;;; Geometry alerts:
-;;; Initiated when ASSIGN-SCREEN-AREA! is acted on by an object, by
-;;; calling
-;;; (GEOMETRY-CHANGE! object
-;;; old-used-screen-area new-used-screen-area)
-;;; An alert is added by calling
-;;; (ON-GEOMETRY-CHANGE! object reason
-;;; (lambda (old new) ...))
-;;; The new-used-screen-area may be #T indicating that an object is
-;;; requesting a new area, or it may be #F or an actual area
-;;; indicating that it has been given (via ASSIGN-SCREEN-AREA!) a
-;;; specific area to use.
-(define on-geometry-change!
- (make-add-alert! %geometry-alerts set-%geometry-alerts!))
-(define forget-geometry-change!
- (make-remove-alert! %geometry-alerts set-%geometry-alerts!))
-(define geometry-change! (make-alert! 2 %geometry-alerts))
-
-;;; Event alerts:
-;;; Initiated when HANDLE-EVENT is acted on by an object, by calling
-;;; (EVENT! object event)
-;;; An alert is added by calling
-;;; (ON-EVENT! object reason
-;;; (lambda (event) ...))
-(define on-event!
- (make-add-alert! %event-alerts set-%event-alerts!))
-(define forget-event!
- (make-remove-alert! %event-alerts set-%event-alerts!))
-(define event! (make-alert! 1 %event-alerts))
-
-;;; Context alerts:
-;;; Initiated when SET-CONTEXT! is acted on by an object, by calling
-;;; (CONTEXT-CHANGE! object new-context)
-;;; An alert is added by calling
-;;; (ON-CONTEXT-CHANGE! object reason
-;;; (lambda (new-context) ...))
-;;; NOTE: This protocol is not well worked out.
-(define on-context-change!
- (make-add-alert! %context-alerts set-%context-alerts!))
-(define forget-context-change!
- (make-remove-alert! %context-alerts set-%context-alerts!))
-(define context-change! (make-alert! 1 %context-alerts))
-
-;;; Death alerts:
-;;; Initiated when an object has decided it is dead by calling
-;;; (DEATH! object)
-;;; An alert is added by calling
-;;; (ON-DEATH! object reason (lambda () ...))
-(define on-death!
- (make-add-alert! %death-alerts set-%death-alerts!))
-(define forget-death-notification!
- (make-remove-alert! %death-alerts set-%death-alerts!))
-(define death! (make-alert! 0 %death-alerts))
-
-(define (forget! reporter reason)
- (forget-geometry-change! reporter reason)
- (forget-event! reporter reason)
- (forget-death-notification! reporter reason)
- (forget-context-change! reporter reason))
-\f
-;;;; Queues for communication between interrupt level and user level
-
-(define (empty-queue? queue)
- (without-interrupts
- (lambda ()
- (not (queue.%head queue)))))
-
-(define (enqueue! queue value)
- (let ((element (list value)))
- (without-interrupts
- (lambda ()
- (if (queue.%head queue)
- (set-cdr! (queue.%tail queue) element)
- (set-queue.%head! queue element))
- (set-queue.%tail! queue element)))))
-
-(define (dequeue! queue)
- ;; Not safe to use if the queue is empty!
- (without-interrupts
- (lambda ()
- (let* ((head (queue.%head queue))
- (next (cdr head)))
- (if (null? next)
- (begin
- (set-queue.%head! queue #F)
- (set-queue.%tail! queue #F))
- (set-queue.%head! queue next))
- (car head)))))
-
-(define (read-and-empty-queue! queue)
- ;; Returns a list of items, and leaves the queue empty
- (let ((quick-result
- (without-interrupts
- (lambda ()
- (let ((result (queue.%head queue)))
- (set-queue.%head! queue #F)
- (set-queue.%tail! queue #F)
- result)))))
- (or quick-result '())))
-\f
-
-(define (update-locked-list! locked-list receiver)
- ;; Receiver gets the contents and returns a replacement
- (our-with-thread-mutex-locked
- 'update-locked-list!
- (locked-list.%mutex locked-list)
- (lambda ()
- (set-locked-list.%data!
- locked-list
- (receiver (locked-list.%data locked-list)))
- ))
- 'DONE)
-
-(define (with-locked-list locked-list receiver)
- ;; Receiver gets the contents
- (our-with-thread-mutex-locked
- 'with-locked-list
- (locked-list.%mutex locked-list)
- (lambda ()
- (receiver (locked-list.%data locked-list))
- )))
-
-(define (our-with-thread-mutex-locked reason mutex thunk)
- reason
- (with-thread-mutex-locked mutex thunk))
-\f
-
-;;; The default for these is just to do information propagation
-;;; through the alert mechanism.
-
-(define (UIObj-set-context! UIObj Context)
- (if (vector? Context)
- (context-change! UIObj Context)
- (error "UIOBJ-SET-CONTEXT!: Bad context" Context)))
-
-(define (UIObj-assign-screen-area! UIObj Screen-Area)
- (if (or (UITKRectangle? Screen-Area)
- (eq? #F Screen-Area))
- (begin
- (set-assigned-screen-area! UIObj Screen-Area)
- (let ((old (used-screen-area UIObj)))
- (set-used-screen-area! UIObj screen-area)
- (geometry-change! UIObj old screen-area))
- screen-area)
- (error "UIOBJ-ASSIGN-SCREEN-AREA!: Bad screen area" Screen-Area)))
-
-(define (assign-location! object point)
- ;; There may be a better way to do this by making it part of the
- ;; geometry protocol.
- (assign-screen-area! object
- (translate-rectangle (used-screen-area object) point)))
-
-(define (UIObj-assign-drawing-surface! UIObj Surface)
- (check-drawing-surface! UIObj Surface)
- (geometry-change! UIObj #F #F)
- 'OK)
-
-(define (check-drawing-surface! UIObj Surface)
- ;; Surface should be one of 'UNASSIGNED, 'RETRACTED, or a
- ;; DrawingSurface
- ;; This is used by internal routines that want to do the default
- ;; operation (UIObj-assign-drawing-surface!) but don't want to
- ;; announce the geometry change yet.
- (let ((old (Drawing-Surface UIObj)))
- (cond ((eq? old Surface) 'UNCHANGED)
- ((or (eq? Surface 'RETRACTED)
- (eq? old 'UNASSIGNED))
- (set-drawing-surface! UIObj Surface)
- 'CHANGED)
- (else
- (error "UIOBJ-ASSIGN-DRAWING-SURFACE!: Can't change surface"
- UIObj old surface)))))
-
-(define (assign-geometry! UIObj Surface Rectangle)
- (assign-drawing-surface! UIObj surface)
- (assign-screen-area! UIObj rectangle))
-\f
-(define (point-in-rectangle? point rect-offset width height)
- (let ((rect-x (Point.X rect-offset))
- (rect-y (Point.Y rect-offset))
- (x (Point.X point))
- (y (Point.Y point)))
- (and (<= rect-x X)
- (< X (+ rect-x Width))
- (<= rect-Y Y)
- (< Y (+ rect-Y Height)))))
-
-(define (rectangle-overlaps-rectangle? p w h p2 w2 h2)
- (define (rectangles-overlap? LowEdge LowDelta HighEdge)
- (<= HighEdge (+ LowEdge LowDelta)))
- (let ((x (Point.X p))
- (y (Point.Y p))
- (x2 (Point.X p2))
- (y2 (Point.Y p2)))
- (and (if (< X X2)
- (rectangles-overlap? X W X2)
- (rectangles-overlap? X2 W2 X))
- (if (< Y Y2)
- (rectangles-overlap? Y H Y2)
- (Rectangles-Overlap? Y2 H2 Y)))))
-
-(define (uiobj-point-within? UIObj Point)
- (if (vector? Point)
- (let ((screen-area (Used-Screen-Area UIObj)))
- (and screen-area
- (let ((Offset (UITKRectangle.Offset screen-area))
- (Height (UITKRectangle.Height screen-area))
- (Width (UITKRectangle.Width screen-area)))
- (point-in-rectangle? Point Offset Width Height))))
- (error "UIOBJ-POINT-WITHIN?: Bad point" point)))
-
-(define (UIObj-rectangle-overlaps? UIObj P1 W1 H1)
- (if (not (vector? P1))
- (error "UIOBJ-RECTANGLE-OVERLAPS?: Bad point" P1))
- (if (not (number? W1))
- (error "UIOBJ-RECTANGLE-OVERLAPS?: Bad width" W1))
- (if (not (number? H1))
- (error "UIOBJ-RECTANGLE-OVERLAPS?: Bad height" H1))
- (let ((screen-area (Used-Screen-Area UIObj)))
- (and
- screen-area
- (let ((P2 (UITKRectangle.Offset screen-area))
- (H2 (UITKRectangle.Height screen-area))
- (W2 (UITKRectangle.Width screen-area)))
- (rectangle-overlaps-rectangle? p1 w1 h1 p2 w2 h2)))))
-
-
-(define (event-within? UIObj Event)
- (cond ((point-event? event)
- (point-event-within? UIObj event))
- ((rectangle-event? event)
- (rectangle-event-within? UIObj event))
- (else (error "EVENT-WITHIN?: Bad event" event))))
-
-(define (point-event-within? UIObj Event)
- (let ((window (Get-UITKWindow UIObj)))
- (and window
- (= (->XWindow (UITKWindow.xwindow window))
- (Event.Window Event))
- (point-within? UIObj (event.Offset event)))))
-
-(define (rectangle-event-within? UIObj Event)
- (let ((window (Get-UITKWindow UIObj)))
- (and window
- (= (->XWindow (UITKWindow.xwindow window))
- (Event.Window Event))
- (Rectangle-Overlaps? UIObj
- (event.Offset event)
- (event.Width event)
- (event.Height event)))))
-\f
-(define (UIObj-handle-event UIObj Event)
- (if (event? event)
- (if (event-within? UIObj event)
- (event! UIObj event))
- (error "UIOBJ-HANDLE-EVENT: Bad event" event)))
-
-(define (UIObj-get-desired-size object)
- (define (->size datum)
- (or datum (make-size 0 0)))
- (->size (%desired-size object)))
-
-
-;;; Default assigned-screen-area and used-screen-area (accessors and
-;;; mutators) simply look in or modify the appropriate slots in the
-;;; structure.
-(define (UIObj-assigned-screen-area UIObj)
- (UIObjInternals.assigned-screen-area (UIObjInternals UIObj)))
-
-(define (UIObj-set-assigned-screen-area! UIObj Screen-area)
- (set-UIObjInternals.assigned-screen-area! (UIObjInternals UIObj)
- Screen-Area))
-
-(define (UIObj-used-screen-area UIObj)
- (UIObjInternals.used-screen-area (UIObjInternals UIObj)))
-
-(define (UIObj-set-used-screen-area! UIObj Screen-Area)
- (set-UIObjInternals.used-screen-area! (UIObjInternals UIObj)
- Screen-Area))
-
-(define (UIObj-protect-from-gc! UIObj stuff)
- (let ((crud (crud-that-I-dont-want-to-gc-away UIObj)))
- (set-car! crud (cons stuff (car crud))))
- 'done)
-
-(define (UIObj-unprotect-from-gc! UIObj stuff)
- (let ((crud (crud-that-I-dont-want-to-gc-away UIObj)))
- (set-car! crud (delq! stuff (car crud))))
- 'done)
-
-
-\f
-;;;; Context procedures
-
-(define (create-default-context name display)
- ;; Looks in appropriate customization locations to create a default
- ;; context for the application specified by NAME
- (define (convert converter predicate)
- (lambda (default)
- (define (get-default)
- (cond ((procedure? default) (default))
- ((string? default) (converter default))
- (else default)))
- (lambda (string)
- (if (and (string? string) (not (zero? (string-length string))))
- (let ((result (converter string)))
- (if (predicate result)
- result
- (get-default)))
- (get-default)))))
- ;;;**** this doesn't make sense to me. What are the predicates testing, really?
- ;;; changed XLoadFont to return a wrapped object,so string->font will also
-
- (let ((->symbol (convert string->symbol symbol?))
- (->number (convert string->number number?))
- (->color (convert (string->color display) color?))
- ;; (->font (convert (string->font display) font?))
- ;; (->cursor (convert string->cursor cursor?))
- )
- (apply make-context
- (map (lambda (entry)
- (let ((converter (car entry))
- (string (cadr entry)))
- ;;;;********beware: getdefaultvalue is returning an unwrapped object!!
- ;;;; fix this to add the wrappers
- (converter (GetDefaultValue display name string))))
- `((,(->color "White") "ActiveBackground")
- (,(->color "Black") "ActiveForeground")
- (,(->symbol 'nw) "Anchor")
- (,(->color "Black") "Background")
- (,(->color "White") "Border")
- (,(->number 0) "BorderWidth")
- ;; (,(->cursor "Block") "Cursor")
- ;; (,(->font #F) "Font")
- (,(->color "White") "Foreground")
- (,(->symbol 'raised) "Relief"))))))
+++ /dev/null
-; -*- Scheme -*-
-;;;;; Tk interface code for a button
-
-;;; Lowest-level makers for various kinds of TK widgets. These call C
-;;; primitives in widget-c-mit.c, and are called by the higher-level
-;;; widget object makers in widget.scm
-
-
-(define-primitives
- (%tkDeleteDisplay 1)
- (%tkDestroyWidget 1)
- (%tkMakeButton 2)
- (%tkMakeCanvas 2)
- (%tkMakeCheckbutton 2)
- (%tkMakeEntry 2)
- (%tkMakeLabel 2)
- (%tkMakeListbox 2)
- (%tkMakeMenu 2)
- (%tkMakeMenubutton 2)
- (%tkMakeMessage 2)
- (%tkMakeRadiobutton 2)
- (%tkMakeScale 2)
- (%tkMakeScrollBar 2)
- (%tkMakeText 2)
- )
-
-#| Widgets hold strong pointers to the display and the application.
-Therefore, when we GC away the display or applcation, we can assume
-that there are no pointers to the widgets still around. However, the
-C end may need to be closed |#
-
-;;; display->tk-widgets is a map that associates to each display a
-;;; protection list of the tk-widgets for the display
-(define display->tk-widgets 'INITIALIZED-LATER)
-
-(define (add-widget-list-for-display-number! display-number)
- (set! display->tk-widgets
- (cons (cons display-number (make-protection-list))
- display->tk-widgets)))
-
-(define (find-tk-protection-list display)
- (find-tk-protection-list-from-number (->xdisplay display)))
-
-(define (find-tk-protection-list-from-number number)
- (let ((list (assv number display->tk-widgets)))
- (and (pair? list)
- (cdr list))))
-
-;;; The item on the protection list is a cell containing the widget
-;;; pointer. This permits us to mark the cell when the C object is
-;;; destroyed so we don't try to destroy it twice.
-
-(define (Wrap-TK-widget surface name maker)
- (let ((ToolKitParent (DrawingSurface.ToolKitWindow surface)))
- ;; Note that the DrawingSurface's UITKWindow may not yet exist.
- (let ((parent-tk-window (ToolKitWindow.TK-window ToolKitParent))
- (application (ToolKitWindow.Application ToolKitParent)))
- (let ((display (Application->Display application)))
- (let ((new-window-name
- (string-append
- (tkwin.pathname parent-tk-window) "." name)))
- (let ((wrapped-object #F))
- (define (kill-me)
- ;; Called when the object is destroyed
- (SCXL-DESTROY! wrapped-object))
- (set! wrapped-object
- (SCXL-WRAP
- (or (find-tk-protection-list display)
- (error "No tk-protection-list for this display" display))
- 'tk-widget
- (tk-op
- (lambda ()
- (maker parent-tk-window new-window-name)))
- (list display surface kill-me) ;strong dependents
- ))
- (tk-invoke-command
- 'BIND (Application->TKMainWindow application)
- (list new-window-name "<Destroy>"
- (string-append "SchemeCallBack "
- (number->string
- (hash kill-me *our-hash-table*)))))
- wrapped-object))))))
-
-(define (widget/widget widget)
- (type-check-wrapped-object 'tk-widget widget)
- (SCXL-UNWRAP widget (lambda (w) w)))
-
-(define ->widget widget/widget)
-
-(define (%tk-really-destroy-widget handle)
- ;; Given a lowest-level TK handle or #F
- (if handle (tk-op (lambda() (%TkDestroyWidget handle))))
- 'destroyed)
-
-(define tk-widget-destroy
- ;; This will actually close the TK widget only if the wrapper isn't
- ;; already marked destroyed. But that should be OK -- we shouldn't
- ;; be able to find a wrapper that's destroyed if the contents
- ;; haven't been closed.
- (wrap-with-SCXL-DESTROY! 1 0
- (lambda (scxl-wrapped-widget)
- (tk-op (lambda ()
- (%tkDestroyWidget (->widget scxl-wrapped-widget)))))))
-
-(define (tk-delete-display disp)
- (tk-op (lambda () (%tkDeleteDisplay (->Xdisplay disp)))))
-
-(define (tk-make-button drawing-surface name)
- (Wrap-TK-widget drawing-surface name
- (lambda (parent-tk-window real-name)
- (%tkMakeButton parent-tk-window real-name))))
-
-(define (tk-make-canvas drawing-surface name)
- (Wrap-TK-widget drawing-surface name
- (lambda (parent-tk-window real-name)
- (%tkMakeCanvas parent-tk-window real-name))))
-
-(define (tk-make-checkbutton drawing-surface name)
- (Wrap-TK-widget drawing-surface name
- (lambda (parent-tk-window real-name)
- (%tkMakeCheckButton parent-tk-window real-name))))
-
-(define (tk-make-entry drawing-surface name)
- (Wrap-TK-widget drawing-surface name
- (lambda (parent-tk-window real-name)
- (%tkMakeEntry parent-tk-window real-name))))
-
-(define (tk-make-label drawing-surface name)
- (Wrap-TK-widget drawing-surface name
- (lambda (parent-tk-window real-name)
- (%tkMakeLabel parent-tk-window real-name))))
-
-(define (tk-make-listbox drawing-surface name)
- (Wrap-TK-widget drawing-surface name
- (lambda (parent-tk-window real-name)
- (%tkMakeListbox parent-tk-window real-name))))
-
-(define (tk-make-menu drawing-surface name)
- (Wrap-TK-widget drawing-surface name
- (lambda (parent-tk-window real-name)
- (%tkMakeMenu parent-tk-window real-name))))
-
-(define (tk-make-menubutton drawing-surface name)
- (Wrap-TK-widget drawing-surface name
- (lambda (parent-tk-window real-name)
- (%tkMakeMenuButton parent-tk-window real-name))))
-
-(define (tk-make-message drawing-surface name)
- (Wrap-TK-widget drawing-surface name
- (lambda (parent-tk-window real-name)
- (%tkMakeMessage parent-tk-window real-name))))
-
-(define (tk-make-radiobutton drawing-surface name)
- (Wrap-TK-widget drawing-surface name
- (lambda (parent-tk-window real-name)
- (%tkMakeRadioButton parent-tk-window real-name))))
-
-(define (tk-make-scale drawing-surface name)
- (Wrap-TK-widget drawing-surface name
- (lambda (parent-tk-window real-name)
- (%tkMakeScale parent-tk-window real-name))))
-
-(define (tk-make-scrollbar drawing-surface name)
- (Wrap-TK-widget drawing-surface name
- (lambda (parent-tk-window real-name)
- (%tkMakeScrollBar parent-tk-window real-name))))
-
-(define (tk-make-text drawing-surface name)
- (Wrap-TK-widget drawing-surface name
- (lambda (parent-tk-window real-name)
- (%tkMakeText parent-tk-window real-name))))
-
-(define (initialize-mit-widgets!)
- (set! display->tk-widgets '()))
-
-(initialize-mit-widgets!)
+++ /dev/null
-;;;;; -*- Scheme -*-
-;;;;; derived from button.sc,v 1.2 1993/02/26 00:49:36 jmiller Exp $
-
-;;;;;;;;;; Widget Definitions
-
-(define tk-widget->pathname
- (let ((->handle (lambda (widget)
- (if (not (tkwidget%? widget))
- (pp `(tkh 2 ,widget)))
- (TKWidget%.handle widget))))
- (lambda (tk-widget)
- (tkwin.pathname (tk-widget.tkwin (->handle tk-widget))))))
-
-(define (tkwin->size tkwindow)
- (make-size (tkwin.width tkwindow) (tkwin.height tkwindow)))
-
-#| display->tk-widgets maps a display-number to a protection list,
- which is a list of weak-pairs. Each pair is <WRAPPED-OBJ or #F .
- cell with (handle or #F)> #F on the left means that the Scheme
- object has been lost. #F on the right means that the TK widget has
- been closed. In UITK, both the wrapped object and the TK object
- should be destroyed when the Scheme reference is lost. However,
- when we close a display the TK objects may still be around. The
- Scheme objects should not be around if we close the display from
- GC, but (brave) users may wish to close displays explicitly. |#
-
-(define (destroy-associated-tk-widgets display-number)
- (let ((tk-widgets (find-tk-protection-list-from-number display-number)))
- (if tk-widgets
- (begin
- ;;canonical Lisp bug #27: we need to do the set! here
- (set! display->tk-widgets
- (del-assv! display-number display->tk-widgets))
- (for-each
- (lambda (entry)
- ;; An entry is either the left side of the pair described
- ;; above, or the (former) contents of the cell on the
- ;; right.
- (if (SCXL-WRAPPED? entry)
- (tk-widget-destroy entry)
- (%tk-really-destroy-widget entry)))
- (protection-list-all-elements tk-widgets
- atomic-read-and-clear-cell!)))))
- (%tkDeleteDisplay display-number) ; Make TK forget the display exists
- 'done)
-
-(define (TKWidget-assign-drawing-surface! me Surface)
- (let ((old (Drawing-Surface me))
- (kids (TKWidget%.%children me)))
- (cond
- ;; Three kinds of Surface: 'RETRACTED, 'UNASSIGNED, or DrawingSurface?
- ;; The default is 'UNASSIGNED and this is NOT a legal value to
- ;; assign later!
- ((and (eq? Surface 'UNASSIGNED)
- (eq? old 'UNASSIGNED))
- 'nothing-to-do)
- ((eq? Surface 'RETRACTED)
- (set-drawing-surface! me 'RETRACTED)
- (if (DrawingSurface? old)
- (tk-widget-destroy (TKWidget%.handle me)))
- (if (not (eq? old 'RETRACTED)) (death! me)))
- ((not (DrawingSurface? Surface))
- (error "TKWIDGET-ASSIGN-DRAWING-SURFACE!: Bad surface" Surface))
- ;; All of the kids need to receive a drawing surface now. It
- ;; should be on the same application and XDisplay as me, but
- ;; should use my own XWindow for the parent, and my TK Window as
- ;; the TK Parent window. Drawing surfaces are assigned TWICE:
- ;; first with a valid ToolKitWindow, and then with both a
- ;; ToolKitWindow and a UITKWindow (see baseobj.scm). We mimic
- ;; that here.
- ((eq? old 'UNASSIGNED)
- ;; Create the widget drawing surface is first assigned
- (set-drawing-surface! me Surface)
- (let ((wrapped-tk-widget ((TKWidget%.how-to-make-me me) Surface))
- (application (DrawingSurface.Application Surface)))
-#|
- (define (kill-me)
- (debug-print '<destroy> 'call 'back me)
- (set-drawing-surface! me 'RETRACTED)
- (death! me))
- (UIObj-Protect-From-GC! me kill-me)
- (tk-invoke-command
- 'BIND (Application->TKMainWindow application)
- (list (tk-widget->pathname me) "<Destroy>"
- (string-append "+SchemeCallBack "
- (number->string
- (hash kill-me *our-hash-table*)))))
-|#
- (set-TKWidget%.handle! me wrapped-tk-widget)
- (if (TKWidget%.do-not-gc-protect me)
- (remove-from-protection-list!
- (find-tk-protection-list-from-number
- (->xdisplay
- (Application->Display Application)))
- wrapped-tk-widget)))
- (let ((kid-surface (make-DrawingSurface
- (make-ToolKitWindow
- (DrawingSurface.Application Surface)
- #F
- (tk-widget.tkwin (TKWidget%.handle me)))
- #F)))
- (for-each (lambda (kid) (ASSIGN-DRAWING-SURFACE! kid kid-surface))
- kids))
- (for-each (lambda (thunk) (thunk))
- (reverse
- (TKWidget%.deferred-ask-widget-commands me)))
- (set-TKWidget%.deferred-ask-widget-commands! me '())
- (geometry-change! me #F #F))
- ((eq? old Surface)
- ;; 2nd pass now modifies that drawing surface to reflect a
- ;; possibly updated UITK window
- (if (not (null? kids))
- (let ((new (drawing-surface (car kids))))
- (set-DrawingSurface.UITKWindow!
- new
- (make-UITKWindow
- (UITKWindow.XDisplay (DrawingSurface.UITKWindow Surface))
- (tkwin.window (tk-widget.tkwin (TKWidget%.handle me)))))
- (for-each (lambda (kid) (ASSIGN-DRAWING-SURFACE! kid new))
- kids)))
- (geometry-change! me #F #F))
- (else
- (error "TKWIDGET-ASSIGN-DRAWING-SURFACE!: Can't change surface"
- old Surface))))
- 'OK)
-
-(define (TKWidget-add-child! me kid)
- (one-parent-only! kid me)
- (let ((current-kids (TKWidget%.%children me)))
- (if (not (null? current-kids))
- (assign-drawing-surface! kid (drawing-surface (car current-kids)))
- (let ((Surface (drawing-surface me)))
- (if (not (DrawingSurface? Surface))
- (assign-drawing-surface! kid Surface)
- (let* ((parent-tkwin (tk-widget.tkwin (TKWidget%.handle me)))
- (kid-surface
- (make-DrawingSurface
- (make-ToolKitWindow
- (DrawingSurface.Application Surface)
- #F ; Top-level geometry callback
- parent-tkwin)
- (make-UITKWindow
- (UITKWindow.XDisplay (DrawingSurface.UITKWindow Surface))
- (tkwin.window parent-tkwin)))))
- (assign-drawing-surface! kid kid-surface)))))
- (set-TKWidget%.%children! me (cons kid current-kids))))
-
-(define (TKWidget-assign-screen-area! me screen-area)
- (cond ((vector? screen-area)
- (if (TKWidget%.do-screen-area? me)
- (let ((tk-handle (TKWidget%.handle me)))
- (if (not (assigned-screen-area me))
- (begin
- (tk-map-window (tk-widget.tkwin tk-handle))
- (tk-manage-geometry tk-handle
- (TKWidget%.%scheme-geometry-manager me))))
- (tk-move-resize-widget tk-handle screen-area)))
- (geometry-change! me screen-area screen-area)
- screen-area)
- ((not Screen-Area)
- (if (TKWidget%.do-screen-area? me)
- (let ((tk-handle (TKWidget%.handle me)))
- (TK-Unmap-Window (tk-widget.tkwin tk-handle))
- (tk-manage-geometry tk-handle #F)))
- (geometry-change! me screen-area screen-area)
- screen-area)
- (else
- (error "TKWIDGET-ASSIGN-SCREEN-AREA!: Bad screen-area" screen-area))))
-
-(define (widget->screen-area widget)
- (let ((tkwin (tk-widget.tkwin (TKWidget%.handle widget))))
- (and (tkwin.ismapped? tkwin)
- (make-UITKRectangle
- (make-point (tkwin.x tkwin) (tkwin.y tkwin))
- (make-size (tkwin.width tkwin)
- (tkwin.height tkwin))))))
-
-(define (TKWidget-assigned-screen-area me)
- (widget->screen-area me))
-(define (TKWidget-used-screen-area me)
- (widget->screen-area me))
-
-(define (TKWidget-set-assigned-screen-area! me anything)
- (if (and (eq? (drawing-surface me) 'RETRACTED)
- (eq? anything #F))
- 'OK
- (error "You can't set the screen area for a TK Widget" me anything)))
-(define (TkWidget-set-used-screen-area! me anything)
- (if (and (eq? (drawing-surface me) 'RETRACTED)
- (eq? anything #F))
- 'OK
- (error "You can't set the screen area for a TK Widget" me anything)))
-
-(define (TKWidget-get-desired-size object)
- (widget->size object tkwin->requested-size))
-
-(define (TKWidget-assign-glue! me)
- (let* ((size (get-desired-size me))
- (my-width (size.Width size))
- (my-height (size.Height size)))
- ((TKWidget%.set-glue!-procedure me) me my-width my-height)))
-
-(define (maybe-defer me command)
- (if (not (tkwidget%? me))
- (pp `(tkh 3 ,me)))
- (if (TKWidget%.handle me)
- (command)
- (defer me command)))
-
-(define (defer me command)
- (set-TKWidget%.deferred-ask-widget-commands!
- me
- (cons command (TKWidget%.deferred-ask-widget-commands me)))
- #F)
-
-(define (TKWidget-add-event-handler! object event handler substitutions)
- ;;for example
- ;; (add-event-handler! obj "<ButtonPress>"
- ;; (lambda (path button) ....)
- ;; "%W" "%b")
- ;; see TK manual (bind) for what these %frobs mean
- ;;hang this on the widget to GC protect it
- (let ((handler (proc-with-transformed-args handler substitutions)))
- (set-TKWidget%.%binding-callbacks!
- object
- (cons handler (TKWidget%.%binding-callbacks object)))
- (let ((command
- (lambda ()
- (tk-invoke-command
- 'bind
- (application->TKMainWindow
- (DrawingSurface.Application
- (Drawing-Surface object)))
- (list
- (tk-widget->pathname object)
- event
- ;; "event" should be a string because TCL is
- ;; case sensitive, (e.g. <ButtonPress>)
- (apply
- string-append
- "SchemeCallBack "
- (number->string (hash handler *our-hash-table*))
- (map (lambda (s)
- (string-append " " s))
- substitutions)))))))
- (maybe-defer object command))))
-
-(define (TKWidget-ask-widget me arg-list)
- ;; If the widget doesn't have a drawing surface yet, then the TK
- ;; object hasn't been created and we can't actually execute the
- ;; command.
- (let ((command
- (lambda ()
- (if (not (tkwidget%? me))
- (pp `(tkh 1 ,me)))
- (if (SCXL-DESTROYED? (tkwidget%.handle me))
- 'punt
- (tcl-global-eval
- (ToolKitWindow.Application
- (DrawingSurface.ToolKitWindow (drawing-surface me)))
- (tk-widget->pathname me)
- arg-list)))))
- (maybe-defer me command)))
-
-
-(define (current-size widget)
- (widget->size widget tkwin->size))
-
-(define (widget->size widget ->size)
- (let ((h (TKWidget%.handle widget)))
- (if h
- (->size (tk-widget.tkwin h))
- (error "widget->size: widget not instantiated" widget))))
-
-(define (tk-has-requested-new-size object)
- (let ((old-size (current-size object))
- (new-size (get-desired-size object)))
- (if (and (= (size.height old-size) (size.height new-size))
- (= (size.width old-size) (size.width new-size)))
- 'OK
- (geometry-change! object (used-screen-area object) #T))))
-
-;; method to attach callback to the widget
-(define (TKWidget-set-callback! me proc)
- (set-TKWidget%.%callback! me proc)
- (if (TKWidget%.%callback-command me)
- ((TKWidget%.%callback-command me) me (TKWidget%.%scheme-callback-hash me))
- (error "SET-CALLBACK!: not allowed" me proc)))
-
-;; TKWidget Maker
-(define (TKWidget-maker)
- (make-tkwidget%
- (make-UIObjInternals TKWidget-add-child!
- 'invalid ; Remove-Child!-procedure
- UIObj-set-context!
- TKWidget-assign-screen-area!
- TKWidget-assign-drawing-surface!
- UIObj-point-within?
- UIObj-rectangle-overlaps?
- UIObj-handle-event
- TKWidget-get-desired-size
- TKWidget-assigned-screen-area
- TKWidget-used-screen-area
- TKWidget-set-assigned-screen-area!
- TKWidget-set-used-screen-area!
- TKWidget-assign-glue!)
- TKWidget-ask-widget
- TKWidget-add-event-handler!
- TKWidget-set-callback!))
-
-(define (tkwin->requested-size tkwindow)
- (make-size (tkwin.req-width tkwindow)
- (tkwin.req-height tkwindow)))
-
-(define (make-TK-widget type widget-maker callback-command do-screen-area? set-glue!)
- ;; The Main widget-maker
- (lambda args
- (let ((me (TKWidget-maker)))
- (let ((geometry-callback
- (lambda () (tk-has-requested-new-size me)))
- (the-real-callback
- (lambda args
- (apply (TKWidget%.%callback me) args))))
- (let ((%scheme-callback-hash
- (hash the-real-callback *our-hash-table*)))
- (set-TKWidget%.%c-callback! me the-real-callback)
- (set-TKWidget%.%scheme-geometry-manager! me geometry-callback)
- (set-TKWidget%.%scheme-callback-hash! me %scheme-callback-hash)
- (set-TKWidget%.%callback-command! me callback-command)
- (set-TKWidget%.how-to-make-me!
- me
- (lambda (parent-drawing-surface)
- (apply widget-maker parent-drawing-surface (tk-gen-name type) args)))
- (set-TKWidget%.do-screen-area?! me do-screen-area?)
- (set-TKWidget%.set-glue!-procedure! me set-glue!)
- me))))
- )
-
-(define (make-arg-transformers argspecs)
- (let ((id (lambda (x) x)))
- (map (lambda (spec)
- (if (member spec
- '("%b" "%c" "%h" "%k" "%t" "%w" "%x" "%y" "%X" "%Y"))
- string->number
- id))
- argspecs)))
-
-(define (proc-with-transformed-args proc argspecs)
- (let ((transformers
- (make-arg-transformers argspecs)))
- (lambda args
- (apply proc (map (lambda (t a) (t a))
- transformers args)))))
-
-\f
-
-(define button-stretch 2)
-(define canvas-stretch 20)
-(define entry-height-stretch 1)
-
-(define make-button
- (let ((maker (make-tk-widget
- "button" tk-make-button
- (lambda (button scheme-callback-hash-number)
- (ask-widget
- button
- `(configure -command
- ,(string-append
- "SchemeCallBack "
- (number->string
- scheme-callback-hash-number)))))
- #T
- (lambda (button button-width button-height)
- (set-%hglue! button (make-fill-glue button-width button-stretch))
- (set-%vglue! button (make-fill-glue button-height button-stretch))
- ))))
- (lambda options ;but don't use -callback!
- (let ((configure-options
- (if (null? options)
- '()
- (car options))))
- (let ((button (maker)))
- (ask-widget button `(configure ,@configure-options))
- button)))))
-
-(define remember-on-canvas!
- (let ((fix! (lambda (widget value)
- (set-TKWidget%.%binding-callbacks! widget value)))
- (fetch (lambda (widget) (TKWidget%.%binding-callbacks widget))))
- (lambda (canvas thing-to-remember)
- (fix! canvas (cons thing-to-remember (fetch canvas))))))
-
-(define make-canvas
- (let ((maker (make-tk-widget
- "canvas" tk-make-canvas #F #T
- (lambda (canvas canvas-width canvas-height)
- (set-%hglue! canvas (make-fill-glue canvas-width canvas-stretch))
- (set-%vglue! canvas (make-fill-glue canvas-height canvas-stretch))))))
- (lambda options
- (let ((configure-options
- (if (null? options)
- '()
- (car options))))
- (let ((canvas (maker)))
- (ask-widget canvas `(configure ,@configure-options))
- canvas)))))
-
-(define make-checkbutton
- (let ((maker (make-tk-widget
- "checkbutton" tk-make-checkbutton
- (lambda (checkbutton scheme-callback-hash-number)
- (ask-widget
- checkbutton
- `(configure -command
- ,(string-append
- "SchemeCallBack "
- (number->string
- scheme-callback-hash-number)))))
- #T
- (lambda (checkbutton cb-width cb-height)
- (set-%hglue! checkbutton (make-fill-glue cb-width button-stretch))
- (set-%vglue! checkbutton (make-fill-glue cb-height button-stretch))))))
- (lambda options
- (let ((configure-options
- (if (null? options)
- '()
- (car options))))
- (let ((checkbutton (maker)))
- (ask-widget checkbutton `(configure ,@configure-options))
- checkbutton)))))
-
-(define make-entry
- (let ((maker
- (make-tk-widget
- "entry"
- tk-make-entry
- (lambda (entry scheme-callback-hash-number)
- (ask-widget
- entry
- `(configure -Scrollcommand
- ,(string-append "SchemeCallBack "
- (number->string
- scheme-callback-hash-number)))))
- #T
- (lambda (entry entry-width entry-height)
- (set-%hglue! entry (make-fill-glue entry-width button-stretch))
- (set-%vglue! entry (make-fill-glue entry-height entry-height-stretch))))))
- (lambda options
- (let ((configure-options
- (if (null? options)
- '()
- (car options))))
- (let ((entry (maker)))
- (ask-widget entry `(configure ,@configure-options))
- entry)))))
-
-(define make-label
- (let ((maker (make-tk-widget
- "label" tk-make-label
- #F ; No callbacks allowed
- #T ; Normal screen-area handling
- (lambda (label label-width label-height)
- (set-%hglue! label (make-fill-glue label-width button-stretch))
- (set-%vglue! label (make-fill-glue label-height button-stretch))))))
- (lambda options
- (let ((configure-options
- (if (null? options)
- '()
- (car options))))
- (let ((label (maker)))
- (ask-widget label `(configure ,@configure-options))
- label)))))
-
-(define make-listbox
- (let ((maker (make-tk-widget
- "listbox" tk-make-listbox
- #F ; No callbacks allowed
- #T ; Normal screen-area handling
- (lambda (listbox listbox-width listbox-height)
- (set-%hglue! listbox (make-fill-glue listbox-width button-stretch))
- (set-%vglue! listbox (make-fill-glue listbox-height button-stretch))))))
- (lambda options
- (let ((configure-options
- (if (null? options)
- '()
- (car options))))
- (let ((listbox (maker)))
- (ask-widget listbox `(configure ,@configure-options))
- listbox)))))
-
-(define make-menu
- (let ((maker (make-tk-widget
- "menu" tk-make-menu
- #F ; No callbacks allowed
- #F ; No screen area assignment code
- (lambda (menu menu-width menu-height)
- (set-%hglue! menu (make-fill-glue menu-width button-stretch))
- (set-%vglue! text (make-fill-glue menu-height button-stretch))))))
- (lambda options
- (let ((configure-options
- (if (null? options)
- '()
- (car options))))
- (let* ((menu (maker))
- (mr (make-menurecord menu '())))
- (set! *all-menus* (weak-cons mr *all-menus*))
- (uiobj-protect-from-gc! menu mr)
- (ask-widget menu `(configure ,@configure-options))
- menu)))))
-
-(define make-menubutton
- (let ((maker (make-tk-widget
- "menubutton"
- tk-make-menubutton
- #F ; No callbacks allowed
- #T ; Normal screen-area handling
- (lambda (menubutton mb-width mb-height)
- (set-%hglue! menubutton (make-fill-glue mb-width button-stretch))
- (set-%vglue! menubutton (make-fill-glue mb-height button-stretch))))))
- (lambda (menu . options) ; options can't include -menu
- (let ((configure-options
- (if (null? options)
- '()
- (car options))))
- (let ((menubutton (maker)))
- (add-child! menubutton menu)
- (ask-widget menubutton `(configure ,@configure-options))
- (ask-widget menubutton
- `(configure -menu
- ,(lambda () (tk-widget->pathname menu))))
- menubutton)))))
-
-(define make-message
- (let ((maker (make-tk-widget
- "message" tk-make-message
- #F ; No callbacks allowed
- #T ; Normal screen-area handling
- (lambda (message message-width message-height)
- (set-%hglue! message (make-fill-glue message-width button-stretch))
- (set-%vglue! message (make-fill-glue message-height button-stretch))))))
- (lambda options
- (let ((configure-options
- (if (null? options)
- '()
- (car options))))
- (let ((message (maker)))
- (ask-widget message `(configure ,@configure-options))
- message)))))
-
-(define make-radiobutton
- (let ((maker (make-tk-widget
- "radiobutton" tk-make-radiobutton
- (lambda (radiobutton scheme-callback-hash-number)
- (ask-widget
- radiobutton
- `(configure -command
- ,(string-append
- "SchemeCallBack "
- (number->string
- scheme-callback-hash-number)))))
- #T
- (lambda (radiobutton rb-width rb-height)
- (set-%hglue! radiobutton (make-fill-glue rb-width button-stretch))
- (set-%vglue! radiobutton (make-fill-glue rb-height button-stretch))))))
- (lambda options
- (let ((configure-options
- (if (null? options)
- '()
- (car options))))
- (let ((radiobutton (maker)))
- (ask-widget radiobutton `(configure ,@configure-options))
- radiobutton)))))
-
-(define (after-last-space string)
- (let ((index (string-find-previous-char string #\Space)))
- (if index
- (substring string (+ index 1) (string-length string))
- (error "String does not contain a space" string))))
-
-(define (get-tk-widget-orientation tk-widget)
- ;; returns 'v or 'h.
- (string->symbol
- (string-downcase
- (substring
- (after-last-space
- (ask-widget tk-widget '(configure -orient)))
- 0
- 1))))
-
-(define make-scale
- (let ((maker
- (make-tk-widget
- "scale"
- tk-make-scale
- (lambda (scale scheme-callback-hash-number)
- (ask-widget scale
- `(configure -command
- ,(string-append
- "SchemeCallBack "
- (number->string
- scheme-callback-hash-number)))))
- #T
- (lambda (scale scale-width scale-height)
- (let ((orientation (get-tk-widget-orientation scale)))
- (cond ((eq? orientation 'v)
- (set-%hglue! scale (make-rigid-glue scale-width 1))
- (set-%vglue! scale (make-fill-glue scale-height button-stretch)))
- ((eq? orientation 'h)
- (set-%hglue! scale (make-fill-glue scale-width button-stretch))
- (set-%vglue! scale (make-rigid-glue scale-height 1)))
- (else (error "Bad orientation: Must be 'h or 'v" orientation))))))))
- (lambda options
- (let ((configure-options
- (if (null? options)
- '()
- (car options))))
- (let ((scale (maker)))
- (ask-widget scale `(configure ,@configure-options))
- scale)))))
-
-(define make-scrollbar
- (let ((maker
- (make-tk-widget
- "scrollbar"
- tk-make-scrollbar
- (lambda (scrollbar scheme-callback-hash-number)
- (ask-widget
- scrollbar
- `(configure -command
- ,(string-append "SchemeCallBack "
- (number->string
- scheme-callback-hash-number)))))
- #T
- (lambda (scrollbar scrollbar-width scrollbar-height)
- (let ((orientation (get-tk-widget-orientation scrollbar)))
- (cond ((eq? orientation 'v)
- (set-%hglue! scrollbar (make-rigid-glue scrollbar-width 1))
- (set-%vglue! scrollbar (make-fil-glue scrollbar-height 1)))
- ((eq? orientation 'h)
- (set-%hglue! scrollbar (make-fil-glue scrollbar-width 1))
- (set-%vglue! scrollbar (make-rigid-glue scrollbar-height 1)))
- (else (error "Bad orientation: must be 'h or 'v" orientation))))))))
- (lambda options
- (let ((configure-options
- (if (null? options)
- '()
- (car options))))
- (let ((scrollbar (maker)))
- (ask-widget scrollbar `(configure ,@configure-options))
- scrollbar)))))
-
-(define make-text
- (let ((maker (make-tk-widget
- "text"
- tk-make-text
- #F ; No callbacks allowed
- #T ; Normal screen-area handling
- (lambda (text text-width text-height)
- (set-%hglue! text (make-fill-glue text-width canvas-stretch))
- (set-%vglue! text (make-fill-glue text-height canvas-stretch))))))
- (lambda options
- (let ((configure-options
- (if (null? options)
- '()
- (car options))))
- (let ((text (maker)))
- (ask-widget text `(configure ,@configure-options))
- text)))))
-\f
-;;; TK has "active variables"
-
-;;; Ask-widget should be changed so that TK-variables get replaced by
-;;; their names [WHAT DOES THIS MEAN?? -- Hal]
-
-(define (make-active-variable . application)
- (let ((application (if (null? application)
- *the-default-application*
- (car application))))
- (let* ((tk-name (tk-gen-name "variable"))
- (variable (make-TK-variable application tk-name #F)))
- (UIObj-protect-from-gc! application variable)
- variable)))
-
-(define (active-variable-value var)
- (tcl-global-eval
- (TK-variable.application var)
- "expr"
- (list (string-append "$" (TK-variable.tk-name var)))))
-
-(define (set-active-variable! var value)
- (tcl-global-eval
- (TK-variable.application var)
- "set"
- (list (TK-variable.tk-name var) value)))
-
-(define (set-active-variable-callback! var thunk)
- (let ((app (TK-variable.application var))
- (name (TK-variable.tk-name var))
- (cb (TK-variable.callback var)))
- (if cb
- (tcl-global-eval
- app "trace"
- (list "vdelete" name "w" `("SchemeCallBack"
- ,(object-hash cb *our-hash-table*)))))
- (let ((the-callback
- (lambda (arg1 arg2 arg3) ;tcl generates these
- arg1 arg2 arg3 ;but we'll ignore them
- (thunk))))
- (tcl-global-eval
- app "trace"
- (list "variable" name "w"
- `("SchemeCallBack"
- ,(object-hash the-callback *our-hash-table*))
- ))
- (set-TK-variable.callback! var the-callback))))
-
-(define (checkbutton-variable-on? var)
- (equal? (active-variable-value var) "1"))
-
-\f
-(define (initialize-widgets!)
- (SCXL-Install-XCloseDisplay-Callback
- destroy-associated-tk-widgets))
-
-(initialize-widgets!)
+++ /dev/null
-(define-constant X_PROTOCOL 11)
-(define-constant X_PROTOCOL_REVISION 0)
-(define-constant NONE 0)
-(define-constant PARENTRELATIVE 1)
-(define-constant COPYFROMPARENT 0)
-(define-constant POINTERWINDOW 0)
-(define-constant INPUTFOCUS 1)
-(define-constant POINTERROOT 1)
-(define-constant ANYPROPERTYTYPE 0)
-(define-constant ANYKEY 0)
-(define-constant ANYBUTTON 0)
-(define-constant ALLTEMPORARY 0)
-(define-constant CURRENTTIME 0)
-(define-constant NOSYMBOL 0)
-(define-constant NOEVENTMASK 0)
-(define-constant KEYPRESSMASK 1)
-(define-constant KEYRELEASEMASK 2)
-(define-constant BUTTONPRESSMASK 4)
-(define-constant BUTTONRELEASEMASK 8)
-(define-constant ENTERWINDOWMASK 16)
-(define-constant LEAVEWINDOWMASK 32)
-(define-constant POINTERMOTIONMASK 64)
-(define-constant POINTERMOTIONHINTMASK 128)
-(define-constant BUTTON1MOTIONMASK 256)
-(define-constant BUTTON2MOTIONMASK 512)
-(define-constant BUTTON3MOTIONMASK 1024)
-(define-constant BUTTON4MOTIONMASK 2048)
-(define-constant BUTTON5MOTIONMASK 4096)
-(define-constant BUTTONMOTIONMASK 8192)
-(define-constant KEYMAPSTATEMASK 16384)
-(define-constant EXPOSUREMASK 32768)
-(define-constant VISIBILITYCHANGEMASK 65536)
-(define-constant STRUCTURENOTIFYMASK 131072)
-(define-constant RESIZEREDIRECTMASK 262144)
-(define-constant SUBSTRUCTURENOTIFYMASK 524288)
-(define-constant SUBSTRUCTUREREDIRECTMASK 1048576)
-(define-constant FOCUSCHANGEMASK 2097152)
-(define-constant PROPERTYCHANGEMASK 4194304)
-(define-constant COLORMAPCHANGEMASK 8388608)
-(define-constant OWNERGRABBUTTONMASK 16777216)
-(define-constant KEYPRESS 2)
-(define-constant KEYRELEASE 3)
-(define-constant BUTTONPRESS 4)
-(define-constant BUTTONRELEASE 5)
-(define-constant MOTIONNOTIFY 6)
-(define-constant ENTERNOTIFY 7)
-(define-constant LEAVENOTIFY 8)
-(define-constant FOCUSIN 9)
-(define-constant FOCUSOUT 10)
-(define-constant KEYMAPNOTIFY 11)
-(define-constant EXPOSE 12)
-(define-constant GRAPHICSEXPOSE 13)
-(define-constant NOEXPOSE 14)
-(define-constant VISIBILITYNOTIFY 15)
-(define-constant CREATENOTIFY 16)
-(define-constant DESTROYNOTIFY 17)
-(define-constant UNMAPNOTIFY 18)
-(define-constant MAPNOTIFY 19)
-(define-constant MAPREQUEST 20)
-(define-constant REPARENTNOTIFY 21)
-(define-constant CONFIGURENOTIFY 22)
-(define-constant CONFIGUREREQUEST 23)
-(define-constant GRAVITYNOTIFY 24)
-(define-constant RESIZEREQUEST 25)
-(define-constant CIRCULATENOTIFY 26)
-(define-constant CIRCULATEREQUEST 27)
-(define-constant PROPERTYNOTIFY 28)
-(define-constant SELECTIONCLEAR 29)
-(define-constant SELECTIONREQUEST 30)
-(define-constant SELECTIONNOTIFY 31)
-(define-constant COLORMAPNOTIFY 32)
-(define-constant CLIENTMESSAGE 33)
-(define-constant MAPPINGNOTIFY 34)
-(define-constant LASTEVENT 35)
-(define-constant SHIFTMASK 1)
-(define-constant LOCKMASK 2)
-(define-constant CONTROLMASK 4)
-(define-constant MOD1MASK 8)
-(define-constant MOD2MASK 16)
-(define-constant MOD3MASK 32)
-(define-constant MOD4MASK 64)
-(define-constant MOD5MASK 128)
-(define-constant SHIFTMAPINDEX 0)
-(define-constant LOCKMAPINDEX 1)
-(define-constant CONTROLMAPINDEX 2)
-(define-constant MOD1MAPINDEX 3)
-(define-constant MOD2MAPINDEX 4)
-(define-constant MOD3MAPINDEX 5)
-(define-constant MOD4MAPINDEX 6)
-(define-constant MOD5MAPINDEX 7)
-(define-constant BUTTON1MASK 256)
-(define-constant BUTTON2MASK 512)
-(define-constant BUTTON3MASK 1024)
-(define-constant BUTTON4MASK 2048)
-(define-constant BUTTON5MASK 4096)
-(define-constant ANYMODIFIER 32768)
-(define-constant BUTTON1 1)
-(define-constant BUTTON2 2)
-(define-constant BUTTON3 3)
-(define-constant BUTTON4 4)
-(define-constant BUTTON5 5)
-(define-constant NOTIFYNORMAL 0)
-(define-constant NOTIFYGRAB 1)
-(define-constant NOTIFYUNGRAB 2)
-(define-constant NOTIFYWHILEGRABBED 3)
-(define-constant NOTIFYHINT 1)
-(define-constant NOTIFYANCESTOR 0)
-(define-constant NOTIFYVIRTUAL 1)
-(define-constant NOTIFYINFERIOR 2)
-(define-constant NOTIFYNONLINEAR 3)
-(define-constant NOTIFYNONLINEARVIRTUAL 4)
-(define-constant NOTIFYPOINTER 5)
-(define-constant NOTIFYPOINTERROOT 6)
-(define-constant NOTIFYDETAILNONE 7)
-(define-constant VISIBILITYUNOBSCURED 0)
-(define-constant VISIBILITYPARTIALLYOBSCURED 1)
-(define-constant VISIBILITYFULLYOBSCURED 2)
-(define-constant PLACEONTOP 0)
-(define-constant PLACEONBOTTOM 1)
-(define-constant FAMILYINTERNET 0)
-(define-constant FAMILYDECNET 1)
-(define-constant FAMILYCHAOS 2)
-(define-constant PROPERTYNEWVALUE 0)
-(define-constant PROPERTYDELETE 1)
-(define-constant COLORMAPUNINSTALLED 0)
-(define-constant COLORMAPINSTALLED 1)
-(define-constant GRABMODESYNC 0)
-(define-constant GRABMODEASYNC 1)
-(define-constant GRABSUCCESS 0)
-(define-constant ALREADYGRABBED 1)
-(define-constant GRABINVALIDTIME 2)
-(define-constant GRABNOTVIEWABLE 3)
-(define-constant GRABFROZEN 4)
-(define-constant ASYNCPOINTER 0)
-(define-constant SYNCPOINTER 1)
-(define-constant REPLAYPOINTER 2)
-(define-constant ASYNCKEYBOARD 3)
-(define-constant SYNCKEYBOARD 4)
-(define-constant REPLAYKEYBOARD 5)
-(define-constant ASYNCBOTH 6)
-(define-constant SYNCBOTH 7)
-(define-constant REVERTTONONE 0)
-(define-constant REVERTTOPOINTERROOT 1)
-(define-constant REVERTTOPARENT 2)
-(define-constant SUCCESS 0)
-(define-constant BADREQUEST 1)
-(define-constant BADVALUE 2)
-(define-constant BADWINDOW 3)
-(define-constant BADPIXMAP 4)
-(define-constant BADATOM 5)
-(define-constant BADCURSOR 6)
-(define-constant BADFONT 7)
-(define-constant BADMATCH 8)
-(define-constant BADDRAWABLE 9)
-(define-constant BADACCESS 10)
-(define-constant BADALLOC 11)
-(define-constant BADCOLOR 12)
-(define-constant BADGC 13)
-(define-constant BADIDCHOICE 14)
-(define-constant BADNAME 15)
-(define-constant BADLENGTH 16)
-(define-constant BADIMPLEMENTATION 17)
-(define-constant FIRSTEXTENSIONERROR 128)
-(define-constant LASTEXTENSIONERROR 255)
-(define-constant INPUTOUTPUT 1)
-(define-constant INPUTONLY 2)
-(define-constant CWBACKPIXMAP 1)
-(define-constant CWBACKPIXEL 2)
-(define-constant CWBORDERPIXMAP 4)
-(define-constant CWBORDERPIXEL 8)
-(define-constant CWBITGRAVITY 16)
-(define-constant CWWINGRAVITY 32)
-(define-constant CWBACKINGSTORE 64)
-(define-constant CWBACKINGPLANES 128)
-(define-constant CWBACKINGPIXEL 256)
-(define-constant CWOVERRIDEREDIRECT 512)
-(define-constant CWSAVEUNDER 1024)
-(define-constant CWEVENTMASK 2048)
-(define-constant CWDONTPROPAGATE 4096)
-(define-constant CWCOLORMAP 8192)
-(define-constant CWCURSOR 16384)
-(define-constant CWX 1)
-(define-constant CWY 2)
-(define-constant CWWIDTH 4)
-(define-constant CWHEIGHT 8)
-(define-constant CWBORDERWIDTH 16)
-(define-constant CWSIBLING 32)
-(define-constant CWSTACKMODE 64)
-(define-constant FORGETGRAVITY 0)
-(define-constant NORTHWESTGRAVITY 1)
-(define-constant NORTHGRAVITY 2)
-(define-constant NORTHEASTGRAVITY 3)
-(define-constant WESTGRAVITY 4)
-(define-constant CENTERGRAVITY 5)
-(define-constant EASTGRAVITY 6)
-(define-constant SOUTHWESTGRAVITY 7)
-(define-constant SOUTHGRAVITY 8)
-(define-constant SOUTHEASTGRAVITY 9)
-(define-constant STATICGRAVITY 10)
-(define-constant UNMAPGRAVITY 0)
-(define-constant NOTUSEFUL 0)
-(define-constant WHENMAPPED 1)
-(define-constant ALWAYS 2)
-(define-constant ISUNMAPPED 0)
-(define-constant ISUNVIEWABLE 1)
-(define-constant ISVIEWABLE 2)
-(define-constant SETMODEINSERT 0)
-(define-constant SETMODEDELETE 1)
-(define-constant DESTROYALL 0)
-(define-constant RETAINPERMANENT 1)
-(define-constant RETAINTEMPORARY 2)
-(define-constant ABOVE 0)
-(define-constant BELOW 1)
-(define-constant TOPIF 2)
-(define-constant BOTTOMIF 3)
-(define-constant OPPOSITE 4)
-(define-constant RAISELOWEST 0)
-(define-constant LOWERHIGHEST 1)
-(define-constant PROPMODEREPLACE 0)
-(define-constant PROPMODEPREPEND 1)
-(define-constant PROPMODEAPPEND 2)
-(define-constant GXCLEAR 0)
-(define-constant GXAND 1)
-(define-constant GXANDREVERSE 2)
-(define-constant GXCOPY 3)
-(define-constant GXANDINVERTED 4)
-(define-constant GXNOOP 5)
-(define-constant GXXOR 6)
-(define-constant GXOR 7)
-(define-constant GXNOR 8)
-(define-constant GXEQUIV 9)
-(define-constant GXINVERT 10)
-(define-constant GXORREVERSE 11)
-(define-constant GXCOPYINVERTED 12)
-(define-constant GXORINVERTED 13)
-(define-constant GXNAND 14)
-(define-constant GXSET 15)
-(define-constant LINESOLID 0)
-(define-constant LINEONOFFDASH 1)
-(define-constant LINEDOUBLEDASH 2)
-(define-constant CAPNOTLAST 0)
-(define-constant CAPBUTT 1)
-(define-constant CAPROUND 2)
-(define-constant CAPPROJECTING 3)
-(define-constant JOINMITER 0)
-(define-constant JOINROUND 1)
-(define-constant JOINBEVEL 2)
-(define-constant FILLSOLID 0)
-(define-constant FILLTILED 1)
-(define-constant FILLSTIPPLED 2)
-(define-constant FILLOPAQUESTIPPLED 3)
-(define-constant EVENODDRULE 0)
-(define-constant WINDINGRULE 1)
-(define-constant CLIPBYCHILDREN 0)
-(define-constant INCLUDEINFERIORS 1)
-(define-constant UNSORTED 0)
-(define-constant YSORTED 1)
-(define-constant YXSORTED 2)
-(define-constant YXBANDED 3)
-(define-constant COORDMODEORIGIN 0)
-(define-constant COORDMODEPREVIOUS 1)
-(define-constant COMPLEX 0)
-(define-constant NONCONVEX 1)
-(define-constant CONVEX 2)
-(define-constant ARCCHORD 0)
-(define-constant ARCPIESLICE 1)
-(define-constant GCFUNCTION 1)
-(define-constant GCPLANEMASK 2)
-(define-constant GCFOREGROUND 4)
-(define-constant GCBACKGROUND 8)
-(define-constant GCLINEWIDTH 16)
-(define-constant GCLINESTYLE 32)
-(define-constant GCCAPSTYLE 64)
-(define-constant GCJOINSTYLE 128)
-(define-constant GCFILLSTYLE 256)
-(define-constant GCFILLRULE 512)
-(define-constant GCTILE 1024)
-(define-constant GCSTIPPLE 2048)
-(define-constant GCTILESTIPXORIGIN 4096)
-(define-constant GCTILESTIPYORIGIN 8192)
-(define-constant GCFONT 16384)
-(define-constant GCSUBWINDOWMODE 32768)
-(define-constant GCGRAPHICSEXPOSURES 65536)
-(define-constant GCCLIPXORIGIN 131072)
-(define-constant GCCLIPYORIGIN 262144)
-(define-constant GCCLIPMASK 524288)
-(define-constant GCDASHOFFSET 1048576)
-(define-constant GCDASHLIST 2097152)
-(define-constant GCARCMODE 4194304)
-(define-constant GCLASTBIT 22)
-(define-constant FONTLEFTTORIGHT 0)
-(define-constant FONTRIGHTTOLEFT 1)
-(define-constant FONTCHANGE 255)
-(define-constant XYBITMAP 0)
-(define-constant XYPIXMAP 1)
-(define-constant ZPIXMAP 2)
-(define-constant ALLOCNONE 0)
-(define-constant ALLOCALL 1)
-(define-constant DORED 1)
-(define-constant DOGREEN 2)
-(define-constant DOBLUE 4)
-(define-constant CURSORSHAPE 0)
-(define-constant TILESHAPE 1)
-(define-constant STIPPLESHAPE 2)
-(define-constant AUTOREPEATMODEOFF 0)
-(define-constant AUTOREPEATMODEON 1)
-(define-constant AUTOREPEATMODEDEFAULT 2)
-(define-constant LEDMODEOFF 0)
-(define-constant LEDMODEON 1)
-(define-constant KBKEYCLICKPERCENT 1)
-(define-constant KBBELLPERCENT 2)
-(define-constant KBBELLPITCH 4)
-(define-constant KBBELLDURATION 8)
-(define-constant KBLED 16)
-(define-constant KBLEDMODE 32)
-(define-constant KBKEY 64)
-(define-constant KBAUTOREPEATMODE 128)
-(define-constant MAPPINGSUCCESS 0)
-(define-constant MAPPINGBUSY 1)
-(define-constant MAPPINGFAILED 2)
-(define-constant MAPPINGMODIFIER 0)
-(define-constant MAPPINGKEYBOARD 1)
-(define-constant MAPPINGPOINTER 2)
-(define-constant DONTPREFERBLANKING 0)
-(define-constant PREFERBLANKING 1)
-(define-constant DEFAULTBLANKING 2)
-(define-constant DISABLESCREENSAVER 0)
-(define-constant DISABLESCREENINTERVAL 0)
-(define-constant DONTALLOWEXPOSURES 0)
-(define-constant ALLOWEXPOSURES 1)
-(define-constant DEFAULTEXPOSURES 2)
-(define-constant SCREENSAVERRESET 0)
-(define-constant SCREENSAVERACTIVE 1)
-(define-constant HOSTINSERT 0)
-(define-constant HOSTDELETE 1)
-(define-constant ENABLEACCESS 1)
-(define-constant DISABLEACCESS 0)
-(define-constant STATICGRAY 0)
-(define-constant GRAYSCALE 1)
-(define-constant STATICCOLOR 2)
-(define-constant PSEUDOCOLOR 3)
-(define-constant TRUECOLOR 4)
-(define-constant DIRECTCOLOR 5)
-(define-constant LSBFIRST 0)
-(define-constant MSBFIRST 1)
-(define-constant XA_PRIMARY 1)
-(define-constant XA_SECONDARY 2)
-(define-constant XA_ARC 3)
-(define-constant XA_ATOM 4)
-(define-constant XA_BITMAP 5)
-(define-constant XA_CARDINAL 6)
-(define-constant XA_COLORMAP 7)
-(define-constant XA_CURSOR 8)
-(define-constant XA_CUT_BUFFER0 9)
-(define-constant XA_CUT_BUFFER1 10)
-(define-constant XA_CUT_BUFFER2 11)
-(define-constant XA_CUT_BUFFER3 12)
-(define-constant XA_CUT_BUFFER4 13)
-(define-constant XA_CUT_BUFFER5 14)
-(define-constant XA_CUT_BUFFER6 15)
-(define-constant XA_CUT_BUFFER7 16)
-(define-constant XA_DRAWABLE 17)
-(define-constant XA_FONT 18)
-(define-constant XA_INTEGER 19)
-(define-constant XA_PIXMAP 20)
-(define-constant XA_POINT 21)
-(define-constant XA_RECTANGLE 22)
-(define-constant XA_RESOURCE_MANAGER 23)
-(define-constant XA_RGB_COLOR_MAP 24)
-(define-constant XA_RGB_BEST_MAP 25)
-(define-constant XA_RGB_BLUE_MAP 26)
-(define-constant XA_RGB_DEFAULT_MAP 27)
-(define-constant XA_RGB_GRAY_MAP 28)
-(define-constant XA_RGB_GREEN_MAP 29)
-(define-constant XA_RGB_RED_MAP 30)
-(define-constant XA_STRING 31)
-(define-constant XA_VISUALID 32)
-(define-constant XA_WINDOW 33)
-(define-constant XA_WM_COMMAND 34)
-(define-constant XA_WM_HINTS 35)
-(define-constant XA_WM_CLIENT_MACHINE 36)
-(define-constant XA_WM_ICON_NAME 37)
-(define-constant XA_WM_ICON_SIZE 38)
-(define-constant XA_WM_NAME 39)
-(define-constant XA_WM_NORMAL_HINTS 40)
-(define-constant XA_WM_SIZE_HINTS 41)
-(define-constant XA_WM_ZOOM_HINTS 42)
-(define-constant XA_MIN_SPACE 43)
-(define-constant XA_NORM_SPACE 44)
-(define-constant XA_MAX_SPACE 45)
-(define-constant XA_END_SPACE 46)
-(define-constant XA_SUPERSCRIPT_X 47)
-(define-constant XA_SUPERSCRIPT_Y 48)
-(define-constant XA_SUBSCRIPT_X 49)
-(define-constant XA_SUBSCRIPT_Y 50)
-(define-constant XA_UNDERLINE_POSITION 51)
-(define-constant XA_UNDERLINE_THICKNESS 52)
-(define-constant XA_STRIKEOUT_ASCENT 53)
-(define-constant XA_STRIKEOUT_DESCENT 54)
-(define-constant XA_ITALIC_ANGLE 55)
-(define-constant XA_X_HEIGHT 56)
-(define-constant XA_QUAD_WIDTH 57)
-(define-constant XA_WEIGHT 58)
-(define-constant XA_POINT_SIZE 59)
-(define-constant XA_RESOLUTION 60)
-(define-constant XA_COPYRIGHT 61)
-(define-constant XA_NOTICE 62)
-(define-constant XA_FONT_NAME 63)
-(define-constant XA_FAMILY_NAME 64)
-(define-constant XA_FULL_NAME 65)
-(define-constant XA_CAP_HEIGHT 66)
-(define-constant XA_WM_CLASS 67)
-(define-constant XA_WM_TRANSIENT_FOR 68)
-(define-constant XA_LAST_PREDEFINED 68)
-(define-constant QUEUEDALREADY 0)
-(define-constant QUEUEDAFTERREADING 1)
-(define-constant QUEUEDAFTERFLUSH 2)
-(define-constant ALLPLANES -1)
-(define-constant NULL 0)
-(define-constant NULLQUARK 0)
-(define-constant NULLSTRING 0)
-(define-constant XRMBINDTIGHTLY 0)
-(define-constant XRMBINDLOOSELY 1)
-(define-constant XRMOPTIONNOARG 0)
-(define-constant XRMOPTIONISARG 1)
-(define-constant XRMOPTIONSTICKYARG 2)
-(define-constant XRMOPTIONSEPARG 3)
-(define-constant XRMOPTIONRESARG 4)
-(define-constant XRMOPTIONSKIPARG 5)
-(define-constant XRMOPTIONSKIPLINE 6)
-(define-constant NOVALUE 0)
-(define-constant XVALUE 1)
-(define-constant YVALUE 2)
-(define-constant WIDTHVALUE 4)
-(define-constant HEIGHTVALUE 8)
-(define-constant ALLVALUES 15)
-(define-constant XNEGATIVE 16)
-(define-constant YNEGATIVE 32)
-(define-constant USPOSITION 1)
-(define-constant USSIZE 2)
-(define-constant PPOSITION 4)
-(define-constant PSIZE 8)
-(define-constant PMINSIZE 16)
-(define-constant PMAXSIZE 32)
-(define-constant PRESIZEINC 64)
-(define-constant PASPECT 128)
-(define-constant PALLHINTS 252)
-(define-constant INPUTHINT 1)
-(define-constant STATEHINT 2)
-(define-constant ICONPIXMAPHINT 4)
-(define-constant ICONWINDOWHINT 8)
-(define-constant ICONPOSITIONHINT 16)
-(define-constant ICONMASKHINT 32)
-(define-constant WINDOWGROUPHINT 64)
-(define-constant ALLHINTS 127)
-(define-constant DONTCARESTATE 0)
-(define-constant NORMALSTATE 1)
-(define-constant ZOOMSTATE 2)
-(define-constant ICONICSTATE 3)
-(define-constant INACTIVESTATE 4)
-(define-constant RECTANGLEOUT 0)
-(define-constant RECTANGLEIN 1)
-(define-constant RECTANGLEPART 2)
-(define-constant VISUALNOMASK 0)
-(define-constant VISUALIDMASK 1)
-(define-constant VISUALSCREENMASK 2)
-(define-constant VISUALDEPTHMASK 4)
-(define-constant VISUALCLASSMASK 8)
-(define-constant VISUALREDMASKMASK 16)
-(define-constant VISUALGREENMASKMASK 32)
-(define-constant VISUALBLUEMASKMASK 64)
-(define-constant VISUALCOLORMAPSIZEMASK 128)
-(define-constant VISUALBITSPERRGBMASK 256)
-(define-constant VISUALALLMASK 511)
-(define-constant BITMAPSUCCESS 0)
-(define-constant BITMAPOPENFAILED 1)
-(define-constant BITMAPFILEINVALID 2)
-(define-constant BITMAPNOMEMORY 3)
-(define-constant XCSUCCESS 0)
-(define-constant XCNOMEM 1)
-(define-constant XCNOENT 2)
-(define-constant XK_BACKSPACE 65288)
-(define-constant XK_TAB 65289)
-(define-constant XK_LINEFEED 65290)
-(define-constant XK_CLEAR 65291)
-(define-constant XK_RETURN 65293)
-(define-constant XK_PAUSE 65299)
-(define-constant XK_ESCAPE 65307)
-(define-constant XK_DELETE 65535)
-(define-constant XK_MULTI_KEY 65312)
-(define-constant XK_KANJI 65313)
-(define-constant XK_HOME 65360)
-(define-constant XK_LEFT 65361)
-(define-constant XK_UP 65362)
-(define-constant XK_RIGHT 65363)
-(define-constant XK_DOWN 65364)
-(define-constant XK_PRIOR 65365)
-(define-constant XK_NEXT 65366)
-(define-constant XK_END 65367)
-(define-constant XK_BEGIN 65368)
-(define-constant XK_SELECT 65376)
-(define-constant XK_PRINT 65377)
-(define-constant XK_EXECUTE 65378)
-(define-constant XK_INSERT 65379)
-(define-constant XK_UNDO 65381)
-(define-constant XK_REDO 65382)
-(define-constant XK_MENU 65383)
-(define-constant XK_FIND 65384)
-(define-constant XK_CANCEL 65385)
-(define-constant XK_HELP 65386)
-(define-constant XK_BREAK 65387)
-(define-constant XK_MODE_SWITCH 65406)
-(define-constant XK_SCRIPT_SWITCH 65406)
-(define-constant XK_NUM_LOCK 65407)
-(define-constant XK_KP_SPACE 65408)
-(define-constant XK_KP_TAB 65417)
-(define-constant XK_KP_ENTER 65421)
-(define-constant XK_KP_F1 65425)
-(define-constant XK_KP_F2 65426)
-(define-constant XK_KP_F3 65427)
-(define-constant XK_KP_F4 65428)
-(define-constant XK_KP_EQUAL 65469)
-(define-constant XK_KP_MULTIPLY 65450)
-(define-constant XK_KP_ADD 65451)
-(define-constant XK_KP_SEPARATOR 65452)
-(define-constant XK_KP_SUBTRACT 65453)
-(define-constant XK_KP_DECIMAL 65454)
-(define-constant XK_KP_DIVIDE 65455)
-(define-constant XK_KP_0 65456)
-(define-constant XK_KP_1 65457)
-(define-constant XK_KP_2 65458)
-(define-constant XK_KP_3 65459)
-(define-constant XK_KP_4 65460)
-(define-constant XK_KP_5 65461)
-(define-constant XK_KP_6 65462)
-(define-constant XK_KP_7 65463)
-(define-constant XK_KP_8 65464)
-(define-constant XK_KP_9 65465)
-(define-constant XK_F1 65470)
-(define-constant XK_F2 65471)
-(define-constant XK_F3 65472)
-(define-constant XK_F4 65473)
-(define-constant XK_F5 65474)
-(define-constant XK_F6 65475)
-(define-constant XK_F7 65476)
-(define-constant XK_F8 65477)
-(define-constant XK_F9 65478)
-(define-constant XK_F10 65479)
-(define-constant XK_F11 65480)
-(define-constant XK_L1 65480)
-(define-constant XK_F12 65481)
-(define-constant XK_L2 65481)
-(define-constant XK_F13 65482)
-(define-constant XK_L3 65482)
-(define-constant XK_F14 65483)
-(define-constant XK_L4 65483)
-(define-constant XK_F15 65484)
-(define-constant XK_L5 65484)
-(define-constant XK_F16 65485)
-(define-constant XK_L6 65485)
-(define-constant XK_F17 65486)
-(define-constant XK_L7 65486)
-(define-constant XK_F18 65487)
-(define-constant XK_L8 65487)
-(define-constant XK_F19 65488)
-(define-constant XK_L9 65488)
-(define-constant XK_F20 65489)
-(define-constant XK_L10 65489)
-(define-constant XK_F21 65490)
-(define-constant XK_R1 65490)
-(define-constant XK_F22 65491)
-(define-constant XK_R2 65491)
-(define-constant XK_F23 65492)
-(define-constant XK_R3 65492)
-(define-constant XK_F24 65493)
-(define-constant XK_R4 65493)
-(define-constant XK_F25 65494)
-(define-constant XK_R5 65494)
-(define-constant XK_F26 65495)
-(define-constant XK_R6 65495)
-(define-constant XK_F27 65496)
-(define-constant XK_R7 65496)
-(define-constant XK_F28 65497)
-(define-constant XK_R8 65497)
-(define-constant XK_F29 65498)
-(define-constant XK_R9 65498)
-(define-constant XK_F30 65499)
-(define-constant XK_R10 65499)
-(define-constant XK_F31 65500)
-(define-constant XK_R11 65500)
-(define-constant XK_F32 65501)
-(define-constant XK_R12 65501)
-(define-constant XK_R13 65502)
-(define-constant XK_F33 65502)
-(define-constant XK_F34 65503)
-(define-constant XK_R14 65503)
-(define-constant XK_F35 65504)
-(define-constant XK_R15 65504)
-(define-constant XK_SHIFT_L 65505)
-(define-constant XK_SHIFT_R 65506)
-(define-constant XK_CONTROL_L 65507)
-(define-constant XK_CONTROL_R 65508)
-(define-constant XK_CAPS_LOCK 65509)
-(define-constant XK_SHIFT_LOCK 65510)
-(define-constant XK_META_L 65511)
-(define-constant XK_META_R 65512)
-(define-constant XK_ALT_L 65513)
-(define-constant XK_ALT_R 65514)
-(define-constant XK_SUPER_L 65515)
-(define-constant XK_SUPER_R 65516)
-(define-constant XK_HYPER_L 65517)
-(define-constant XK_HYPER_R 65518)
-(define-constant XK_SPACE 32)
-(define-constant XK_EXCLAM 33)
-(define-constant XK_QUOTEDBL 34)
-(define-constant XK_NUMBERSIGN 35)
-(define-constant XK_DOLLAR 36)
-(define-constant XK_PERCENT 37)
-(define-constant XK_AMPERSAND 38)
-(define-constant XK_QUOTERIGHT 39)
-(define-constant XK_PARENLEFT 40)
-(define-constant XK_PARENRIGHT 41)
-(define-constant XK_ASTERISK 42)
-(define-constant XK_PLUS 43)
-(define-constant XK_COMMA 44)
-(define-constant XK_MINUS 45)
-(define-constant XK_PERIOD 46)
-(define-constant XK_SLASH 47)
-(define-constant XK_0 48)
-(define-constant XK_1 49)
-(define-constant XK_2 50)
-(define-constant XK_3 51)
-(define-constant XK_4 52)
-(define-constant XK_5 53)
-(define-constant XK_6 54)
-(define-constant XK_7 55)
-(define-constant XK_8 56)
-(define-constant XK_9 57)
-(define-constant XK_COLON 58)
-(define-constant XK_SEMICOLON 59)
-(define-constant XK_LESS 60)
-(define-constant XK_EQUAL 61)
-(define-constant XK_GREATER 62)
-(define-constant XK_QUESTION 63)
-(define-constant XK_AT 64)
-(define-constant XK_A 65)
-(define-constant XK_B 66)
-(define-constant XK_C 67)
-(define-constant XK_D 68)
-(define-constant XK_E 69)
-(define-constant XK_F 70)
-(define-constant XK_G 71)
-(define-constant XK_H 72)
-(define-constant XK_I 73)
-(define-constant XK_J 74)
-(define-constant XK_K 75)
-(define-constant XK_L 76)
-(define-constant XK_M 77)
-(define-constant XK_N 78)
-(define-constant XK_O 79)
-(define-constant XK_P 80)
-(define-constant XK_Q 81)
-(define-constant XK_R 82)
-(define-constant XK_S 83)
-(define-constant XK_T 84)
-(define-constant XK_U 85)
-(define-constant XK_V 86)
-(define-constant XK_W 87)
-(define-constant XK_X 88)
-(define-constant XK_Y 89)
-(define-constant XK_Z 90)
-(define-constant XK_BRACKETLEFT 91)
-(define-constant XK_BACKSLASH 92)
-(define-constant XK_BRACKETRIGHT 93)
-(define-constant XK_ASCIICIRCUM 94)
-(define-constant XK_UNDERSCORE 95)
-(define-constant XK_QUOTELEFT 96)
-(define-constant XK_LCA 97)
-(define-constant XK_LCB 98)
-(define-constant XK_LCC 99)
-(define-constant XK_LCD 100)
-(define-constant XK_LCE 101)
-(define-constant XK_LCF 102)
-(define-constant XK_LCG 103)
-(define-constant XK_LCH 104)
-(define-constant XK_LCI 105)
-(define-constant XK_LCJ 106)
-(define-constant XK_LCK 107)
-(define-constant XK_LCL 108)
-(define-constant XK_LCM 109)
-(define-constant XK_LCN 110)
-(define-constant XK_LCO 111)
-(define-constant XK_LCP 112)
-(define-constant XK_LCQ 113)
-(define-constant XK_LCR 114)
-(define-constant XK_LCS 115)
-(define-constant XK_LCT 116)
-(define-constant XK_LCU 117)
-(define-constant XK_LCV 118)
-(define-constant XK_LCW 119)
-(define-constant XK_LCX 120)
-(define-constant XK_LCY 121)
-(define-constant XK_LCZ 122)
-(define-constant XK_BRACELEFT 123)
-(define-constant XK_BAR 124)
-(define-constant XK_BRACERIGHT 125)
-(define-constant XK_ASCIITILDE 126)
-(define-constant XK_NOBREAKSPACE 160)
-(define-constant XK_EXCLAMDOWN 161)
-(define-constant XK_CENT 162)
-(define-constant XK_STERLING 163)
-(define-constant XK_CURRENCY 164)
-(define-constant XK_YEN 165)
-(define-constant XK_BROKENBAR 166)
-(define-constant XK_SECTION 167)
-(define-constant XK_DIAERESIS 168)
-(define-constant XK_COPYRIGHT 169)
-(define-constant XK_ORDFEMININE 170)
-(define-constant XK_GUILLEMOTLEFT 171)
-(define-constant XK_NOTSIGN 172)
-(define-constant XK_HYPHEN 173)
-(define-constant XK_REGISTERED 174)
-(define-constant XK_MACRON 175)
-(define-constant XK_DEGREE 176)
-(define-constant XK_PLUSMINUS 177)
-(define-constant XK_TWOSUPERIOR 178)
-(define-constant XK_THREESUPERIOR 179)
-(define-constant XK_ACUTE 180)
-(define-constant XK_MU 181)
-(define-constant XK_PARAGRAPH 182)
-(define-constant XK_PERIODCENTERED 183)
-(define-constant XK_CEDILLA 184)
-(define-constant XK_ONESUPERIOR 185)
-(define-constant XK_MASCULINE 186)
-(define-constant XK_GUILLEMOTRIGHT 187)
-(define-constant XK_ONEQUARTER 188)
-(define-constant XK_ONEHALF 189)
-(define-constant XK_THREEQUARTERS 190)
-(define-constant XK_QUESTIONDOWN 191)
-(define-constant XK_AGRAVE 192)
-(define-constant XK_AACUTE 193)
-(define-constant XK_ACIRCUMFLEX 194)
-(define-constant XK_ATILDE 195)
-(define-constant XK_ADIAERESIS 196)
-(define-constant XK_ARING 197)
-(define-constant XK_AE 198)
-(define-constant XK_CCEDILLA 199)
-(define-constant XK_EGRAVE 200)
-(define-constant XK_EACUTE 201)
-(define-constant XK_ECIRCUMFLEX 202)
-(define-constant XK_EDIAERESIS 203)
-(define-constant XK_IGRAVE 204)
-(define-constant XK_IACUTE 205)
-(define-constant XK_ICIRCUMFLEX 206)
-(define-constant XK_IDIAERESIS 207)
-(define-constant XK_ETH 208)
-(define-constant XK_NTILDE 209)
-(define-constant XK_OGRAVE 210)
-(define-constant XK_OACUTE 211)
-(define-constant XK_OCIRCUMFLEX 212)
-(define-constant XK_OTILDE 213)
-(define-constant XK_ODIAERESIS 214)
-(define-constant XK_MULTIPLY 215)
-(define-constant XK_OOBLIQUE 216)
-(define-constant XK_UGRAVE 217)
-(define-constant XK_UACUTE 218)
-(define-constant XK_UCIRCUMFLEX 219)
-(define-constant XK_UDIAERESIS 220)
-(define-constant XK_YACUTE 221)
-(define-constant XK_THORN 222)
-(define-constant XK_SSHARP 223)
-(define-constant XK_LCAGRAVE 224)
-(define-constant XK_LCAACUTE 225)
-(define-constant XK_LCACIRCUMFLEX 226)
-(define-constant XK_LCATILDE 227)
-(define-constant XK_LCADIAERESIS 228)
-(define-constant XK_LCARING 229)
-(define-constant XK_LCAE 230)
-(define-constant XK_LCCCEDILLA 231)
-(define-constant XK_LCEGRAVE 232)
-(define-constant XK_LCEACUTE 233)
-(define-constant XK_LCECIRCUMFLEX 234)
-(define-constant XK_LCEDIAERESIS 235)
-(define-constant XK_LCIGRAVE 236)
-(define-constant XK_LCIACUTE 237)
-(define-constant XK_LCICIRCUMFLEX 238)
-(define-constant XK_LCIDIAERESIS 239)
-(define-constant XK_LCETH 240)
-(define-constant XK_LCNTILDE 241)
-(define-constant XK_LCOGRAVE 242)
-(define-constant XK_LCOACUTE 243)
-(define-constant XK_LCOCIRCUMFLEX 244)
-(define-constant XK_LCOTILDE 245)
-(define-constant XK_LCODIAERESIS 246)
-(define-constant XK_DIVISION 247)
-(define-constant XK_OSLASH 248)
-(define-constant XK_LCUGRAVE 249)
-(define-constant XK_LCUACUTE 250)
-(define-constant XK_LCUCIRCUMFLEX 251)
-(define-constant XK_LCUDIAERESIS 252)
-(define-constant XK_LCYACUTE 253)
-(define-constant XK_LCTHORN 254)
-(define-constant XK_YDIAERESIS 255)
-(define-constant DXK_RING_ACCENT 268500656)
-(define-constant DXK_CIRCUMFLEX_ACCENT 268500574)
-(define-constant DXK_CEDILLA_ACCENT 268500524)
-(define-constant DXK_ACUTE_ACCENT 268500519)
-(define-constant DXK_GRAVE_ACCENT 268500576)
-(define-constant DXK_TILDE 268500606)
-(define-constant DXK_DIAERESIS 268500514)
-(define-constant DXK_REMOVE 268500736)
-(define-constant XC_NUM_GLYPHS 154)
-(define-constant XC_X_CURSOR 0)
-(define-constant XC_ARROW 2)
-(define-constant XC_BASED_ARROW_DOWN 4)
-(define-constant XC_BASED_ARROW_UP 6)
-(define-constant XC_BOAT 8)
-(define-constant XC_BOGOSITY 10)
-(define-constant XC_BOTTOM_LEFT_CORNER 12)
-(define-constant XC_BOTTOM_RIGHT_CORNER 14)
-(define-constant XC_BOTTOM_SIDE 16)
-(define-constant XC_BOTTOM_TEE 18)
-(define-constant XC_BOX_SPIRAL 20)
-(define-constant XC_CENTER_PTR 22)
-(define-constant XC_CIRCLE 24)
-(define-constant XC_CLOCK 26)
-(define-constant XC_COFFEE_MUG 28)
-(define-constant XC_CROSS 30)
-(define-constant XC_CROSS_REVERSE 32)
-(define-constant XC_CROSSHAIR 34)
-(define-constant XC_DIAMOND_CROSS 36)
-(define-constant XC_DOT 38)
-(define-constant XC_DOTBOX 40)
-(define-constant XC_DOUBLE_ARROW 42)
-(define-constant XC_DRAFT_LARGE 44)
-(define-constant XC_DRAFT_SMALL 46)
-(define-constant XC_DRAPED_BOX 48)
-(define-constant XC_EXCHANGE 50)
-(define-constant XC_FLEUR 52)
-(define-constant XC_GOBBLER 54)
-(define-constant XC_GUMBY 56)
-(define-constant XC_HAND1 58)
-(define-constant XC_HAND2 60)
-(define-constant XC_HEART 62)
-(define-constant XC_ICON 64)
-(define-constant XC_IRON_CROSS 66)
-(define-constant XC_LEFT_PTR 68)
-(define-constant XC_LEFT_SIDE 70)
-(define-constant XC_LEFT_TEE 72)
-(define-constant XC_LEFTBUTTON 74)
-(define-constant XC_LL_ANGLE 76)
-(define-constant XC_LR_ANGLE 78)
-(define-constant XC_MAN 80)
-(define-constant XC_MIDDLEBUTTON 82)
-(define-constant XC_MOUSE 84)
-(define-constant XC_PENCIL 86)
-(define-constant XC_PIRATE 88)
-(define-constant XC_PLUS 90)
-(define-constant XC_QUESTION_ARROW 92)
-(define-constant XC_RIGHT_PTR 94)
-(define-constant XC_RIGHT_SIDE 96)
-(define-constant XC_RIGHT_TEE 98)
-(define-constant XC_RIGHTBUTTON 100)
-(define-constant XC_RTL_LOGO 102)
-(define-constant XC_SAILBOAT 104)
-(define-constant XC_SB_DOWN_ARROW 106)
-(define-constant XC_SB_H_DOUBLE_ARROW 108)
-(define-constant XC_SB_LEFT_ARROW 110)
-(define-constant XC_SB_RIGHT_ARROW 112)
-(define-constant XC_SB_UP_ARROW 114)
-(define-constant XC_SB_V_DOUBLE_ARROW 116)
-(define-constant XC_SHUTTLE 118)
-(define-constant XC_SIZING 120)
-(define-constant XC_SPIDER 122)
-(define-constant XC_SPRAYCAN 124)
-(define-constant XC_STAR 126)
-(define-constant XC_TARGET 128)
-(define-constant XC_TCROSS 130)
-(define-constant XC_TOP_LEFT_ARROW 132)
-(define-constant XC_TOP_LEFT_CORNER 134)
-(define-constant XC_TOP_RIGHT_CORNER 136)
-(define-constant XC_TOP_SIDE 138)
-(define-constant XC_TOP_TEE 140)
-(define-constant XC_TREK 142)
-(define-constant XC_UL_ANGLE 144)
-(define-constant XC_UMBRELLA 146)
-(define-constant XC_UR_ANGLE 148)
-(define-constant XC_WATCH 150)
-(define-constant XC_XTERM 152)
+++ /dev/null
-@c -*- TeXInfo -*-
-
-This is file: src/wabbit/README
-
-@node Top
-
-What's up, Doc?
----------------
-
- The MIT C-Scheme garbage collector has been extended w/ an alternative gc-loop
-which supports ``wabbit hunting'' and ``headhunting'' garbage collection.
-
-
-To enable wabbit hunting, evaluate: (load-option 'wabbit) [@xref{Wabbit Hunt}]
-
-``Wabbit hunting'' is when you have a reference to an object and you want to
-collect all other references to that same object. For instance, several data
-structures may share (alias) the same sub-datum. Wabbit hunting allows you to
-collect all such sharers, presumably to update them all in an interesting way
-or just to collect sharing statistics or a sharing histogram.
-
-
-To enable headhunting, evaluate: (load-option 'headhunt) [@xref{Headhunt}]
-
-``Headhunting'' is when you wish to reify all ``headed'' objects in storage
-(heap *and* constant space) into one moby vector. Note that base objects such
-as fixnums, booleans, characters, etc are not ``headed'': they are not
-referenced by an object pointer. Presumably, it is interesting to go
-headhunting to gather usage statistics and histograms and to do delicate memory
-surgery. For this reason, great care must be taken in groveling over a
-``headhunt collection'' (the result of a headhunting GC).
-
-
-
-@menu
-
-* Wabbit Descwiptor:: Data abstraction: descriptor of target wabbits
-
-* Wabbit Buffer:: The buffer for recording wabbit sightings
-
-* Wabbit Hole:: The format of wabbit sighting records
-
-* Fudd Thunk:: A thunk to invoke after rabbit holes are gathered
-
-* Headhunt Collection:: The format of headhunt results
-
-* Swabbing Wabbit Descwiptors:: Automagic swabbing upon return from the hunt
-
-* Procedures Summary:: Utilities for wabbit hunting and headhunting
-
-* Examples:: A few sample wabbit hunts and headhunts.
-
-@end menu
-
-
-@node Wabbit Descwiptor
-
-A ``Wabbit Descwiptor'' is a 4-element vector:
-
- ------------------------------------------------------------------------
- 0. Boolean hunt disable flag -- (a.k.a. ``duck season'' flag)
- avoid wabbit hunting and/or headhunting
- upon the next GC flip.
- (@pxref{Wabbit Season and Duck Season,
- Duck Season})
-
- 1. Wabbit vector -- vector of object references to target objects
- (a.k.a. ``wabbits'')
-
- 2. Wabbit buffer -- vector into which wabbit sightings are recorded.
- This must be of length (2 + twice wabbit vect len).
- (For details of wabbit sightings, @pxref{Wabbit Holes})
-
- 3. Boolean headhunt enable flag -- if FALSE, no headhunt is performed.
- else this slot will be replaced by a
- headhunt collection upon completion
- of the headhunting wabbit hunt.
- (@xref{Headhunt Collection})
- ------------------------------------------------------------------------
-
- ****
- NB a) Both the WABBIT-VECTOR and the WABBIT-BUFFER must reside in the heap
- **** i.e., they may *not* reside in constant space or on the stack.
-
- b) Both the wabbit buffer and the headhunt collection slots are zeroed
- upon return, since they may contain unsafe pointers. Moreover, it
- is unsafe for the FUDD-THUNK (@ref{Fudd Thunk}) return them or
- otherwise close over them. Consider them only to be very fluid
- parameter sources for the FUDD-THUNK.
-
-
-@node Fudd Thunk
-
-What's a Fudd Thunk?
---------------------
-
- After the hunt has concluded, all the target wabbits (if any) will reside in
-the wabbit buffer of the wabbit descwiptor and all heads collected (if any)
-will reside in the headhunt-collection slot of the wabbit descwiptor. It is at
-this point that the FUDD-THUNK is invoked.
-
- A ``FUDD-THUNK'' is a procedure of no arguments. Whatever result it returns
-is the result of the call to WABBIT-HUNT or HEADHUNT, whichever was called. It
-is therefore imperative that the FUDD-THUNK not return unsafe values (wabbit
-holes that might reference the stack).
-
- Normally, you will write Fudd thunks which use (GET-WABBIT-DESCWIPTOR) and the
-wabbit buffer and headhunt collection accessors on wabbit descwiptors. See the
-example section below for a few samples of how the Fudd thunks are used. Most
-important, note the upon exit from a call to WABBIT-HUNT or HEADHUNT, the
-wabbit buffer and headhunt collection in the wabbit descwiptor are ``swabbed''
-soas to release wascally wabit holes and the moby headhunt collection. See the
-``swabbing'' section below.
-
-
-Default Fudd Thunks
--------------------
-
- The default Fudd-thunk for wabbit hunting is fluid-bound to the global
-variable *DEFAULT-FUDD-THUNK*. The default Fudd thunk merely returns the
-wabbit buffer, which will have been swabbed in the return process. That is, its
-wabbit holes will have been nullified.
-
- The default Fudd-thunk for headhunting is fluid-bound to the global variable
-*DEFAULT-HEADHUNT-FUDD-THUNK* The default headhunt Fudd thunk returns the
-headhunt collection. This will *not* have been swabbed out (but the headhunt
-collection slot in the wabbit descwiptor will have been swabbed), so you must
-be careful what you do with the result of HEADHUNT called with the default
-headhunt Fudd thunk. It is best to simply drop it, being careful not to let the
-printer hash it as the result of an interactive REPL call.
-
- @xref{Default Fudd Thunks} for more details.
-
-
-@node Wabbit Buffer
-
- The ``Wabbit Buffer'' should be a vector of FALSEs before the wabbit hunting
-is initiated. At the end of the wabbit hunt, the wabbit buffer contents will
-be laid out as follows:
-
- --------------------------------------------------------------------------
- slot 0 = Boolean flag: TRUE if all wabbit sightings were recorded in the
- wabbit buffer
- FALSE if the wabbit buffer was too small to accomo-
- date a record for each wabbit sighting.
- (In this case, the FUDD-THUNK should do a
- bit of cleanup work so the same wabbit
- hunt can be re-initiated later.)
-
- slot 1 = Fixnum: number of wabbit sightings recorded in the wabbit buffer
-
- slot 2 = Object reference: cite of first wabbit sighting (``wabbit hole'')
-
- slot 3 = Number: offset into first sighting object where wabbit is hiding
- --------------------------------------------------------------------------
-
-...and so on, with even-index slots containing wabbit holes and odd-index
-slots, indices. Note that slot 1 should hold the index of the first even
-slot that holds FALSE and all slots thereafter should likewise hold FALSE.
-
-It is not really essential that the wabbit buffer be cleared before a hunt
-since the slot 1 indicates the index of the first garbage slot. Nonetheless, it
-is poor form to supply a populated vector.
-
-Note also that the wabbit buffer will be ``swabbed'' upon return from the hunt.
-(@xref{Swabbing Wabbit Descwiptors}).
-
-
-@node Wabbit Hole
-
- A ``Wabbit Hole'' is normally a headed object reference (a pointer) but it
-may in very rare circumstances be a ``wascally wabbit hole''. There are only
-three kinds of wascally wabbit holes:
-
- ---------------------------------------------------------------------------
- 1. Characters: these indicate references to wabbit holes in constant space.
- To reify the character into a cell whose contents holds the
- wabbit, apply CELLIFY (@ref{Cellify}) to the slot ref that
- holds the char.
-
- (NB: the char as printed holds only part of the addr; you
- must vector-ref into the wabbit buffer to get all the
- addr bits. This is incredible magic.)
-
- 2. Null Refs: these indicate headless objects. They should never appear.
-
- 3. Stack Refs: these indicate objects on the control stack. Since we reify
- the stack into the heap as part of the call to WABBIT-HUNT and
- HEADHUNT, these too should never appear unless you are doing
- something painfully obscure (and dangerous!).
- ---------------------------------------------------------------------------
-
-If you ever encounter Null or Stack wabbit holes, you may want to file a
-friendly bug report (?) at
-@url{http://savannah.gnu.org/mit-scheme/bugs/?group=mit-scheme}
-with a reproducable
-test script. (If we cannot reproduce it, we cannot fix it.)
-
-
-@node Headhunt Collection
-
-The ``Headhunt Collection'' is a vector of arbitrary (fixnum) length. It is
-intended to contain a pointer to the head of every object in the heap which has
-an object header (spec., numbers, Booleans, etc not included). If all headed
-heap objects fit in the space available after the GC flip, then slot 0 of this
-headhunt collection is TRUE. If not, slot 0 is FALSE and the vector contains as
-many object head references as actually did fit.
-
-
-************ Be verwy verwy careful when headhunting... if you are not careful
-** CAVEAT ** to release the headhunt collection (e.g., don't let it escape) or
-************ if you gobble up too much intermediate state in traversing it, you
- will exhaust the available heap space and go down in flames. This
- is a very fragile system memory feature intended for only the
- most ginger-fingered discriminating systems wizards. For instance
- it may someday lead to a post-GC garbage scavenger. Nonetheless,
- it readily lends itself to self abuse if not treated reverently.
-
-
-@node Swabbing Wabbit Descwiptors
-
-Swabbing Wabbit Descwiptors
----------------------------
-
- Upon exit from WABBIT-HUNT or HEADHUNT, the wabbit descwiptor with respect to
-which the hunt was performed will be ``swabbed'' so as to release the wabbit
-holes and the headhunt collection. Specifically, the all-found? and
-index-of-first-null slots of the WABBIT-BUFFER are left
-unmolested. The remainder of the WABBIT-BUFFER is cleared back to all #Fs.
-This way no dangerous wabbit holes (e.g., stack refs) will be left dangling in
-the wabbit descwiptor after the hunt. In addition, the HEADHUNT-COLLECTION slot
-of the wabbit descwiptor is set to the number of heads collected, which is then
-negated if not all heads were accomodated by the heap. That is, if say
-314159264 were found but more heads existed but could not fit in the
-headhunt-collection, then the headhunt-collection slot of the wabbit
-descwiptor will be set to -314159264.
-
- Note that the HEADHUNT-COLLECTION vector itself is not cleared: this could
-waste a lot of time and would not really free up significant space since the
-vector would still exist in the heap. It is therefore important that you not
-carelessly return the HEADHUNT-COLLECTION from the thunk since this could allow
-its subsequent capture, from instance by the hashing printer in the interactive
-REPL. Moreover, this HEADHUNT-COLLECTION may contain entries that were moved
-into the heap from the stack by the nature of the WABBIT-HUNT/HEADHUNT calls
-(they do a call-with-current-continuation to reify the control stack onto the
-heap). Thus, the HEADHUNT-COLLECTION may contain dangerous pointers after the
-return from the hunt call. You can crash your Scheme in a very nasty way if you
-do not take heed of this danger.
-
-[Implementors' note: this swabbing is accomplished via an unwind protect which
- calls gc-wabbit::%swab-wad upon exit from the hunt.]
-
-
-@node Procedures Summary
-
-@menu
-
-* Wabbit Hunt::
-* Wabbit Season and Duck Season::
-* Wabbit Descwiptors::
-* Default Fudd Thunks::
-* Cellify::
-* Headhunt::
-
-@end menu
-
-
-@node Wabbit Hunt
-
-(WABBIT-HUNT WABBIT-DESCWIPTOR #!optional FUDD-THUNK)
-
- Open wabbit season on wabbits matching WABBIT-DESCWIPTOR (@ref{Wabbit
- Descwiptor}) and go wabbit hunting. Once all the wabbits have been wounded
- up, invoke FUDD-THUNK (@ref{Fudd Thunk}), weturning the wesult of FUDD-THUNK
- as the wesult of the wabbit hunt.
-
- The optional FUDD-THUNK pawameter defaults to the value of the fluid
- vawiable: *DEFAULT-FUDD-THUNK* (@ref{Default Fudd Thunks}), which defaults
- to just weturning the wabbit buffer (which will have been swabbed upon
- return!).
-
-
-@node Wabbit Season and Duck Season
-
-(WABBIT-SEASON! WABBIT-DESCWIPTOR)
-
- Declare open season on wabbits matching our target descwiptor.
- Returns the old wabbit descwiptor (possibly FALSE).
-
-(DUCK-SEASON!)
-
- Disable wabbit hunting... returns descwiptor from latest wabbit hunt.
-
-****
- NB WABBIT/DUCK-SEASON! both mutate the system wabbit descwiptor accessed via
-**** calls to (GET-WABBIT-DESCWIPTOR).
-
-
-(WABBIT-SEASON?)
-( DUCK-SEASON?)
-
- It is wabbit season if the value returned by (GET-WABBIT-DESCWIPTOR) is a
-valid wabbit descwiptor with the hunt-disable flag disabled (i.e., hunt is
-enabled). Otherwise, it is duck season.
-
-
-@node Wabbit Descwiptors
-
-(GET-WABBIT-DESCWIPTOR)
-
- Returns the current wabbit descwiptor as installed by WABBIT/DUCK-SEASON!
-(which are implicitly called from WABBIt-HUNT and HEADHUNT). This may *not*
-always be a valid instance of a WABBIT-DESCWIPTOR so it is best to check the
-result using (WABBIT-DESCWIPTOR object).
-
-
-(WABBIT-DESCWIPTOR? object)
-
- Returns TRUE if OBJECT is a 4-element vector; FALSE otherwise. That is, the
-WABBIT-DESCWIPTOR is a transparent type (non-opaque).
-
-
-The painfully obvious creator, selectors and mutators are as follows:
-
-(MAKE-WABBIT-DESCWIPTOR hunt-disable-flag
- wabbit-vector
- wabbit-buffer
- headhunt-enable-flag)
-
-
- (WABBIT-DESCWIPTOR/HUNT-DISABLE-FLAG wabbit-descwiptor)
- (WABBIT-DESCWIPTOR/WABBIT-VECTOR wabbit-descwiptor)
- (WABBIT-DESCWIPTOR/WABBIT-BUFFER wabbit-descwiptor)
- (WABBIT-DESCWIPTOR/HEADHUNT-ENABLE-FLAG wabbit-descwiptor)
-
-(SET-WABBIT-DESCWIPTOR/HUNT-DISABLE-FLAG! wabbit-descwiptor new-value)
-(SET-WABBIT-DESCWIPTOR/WABBIT-VECTOR! wabbit-descwiptor new-value)
-(SET-WABBIT-DESCWIPTOR/WABBIT-BUFFER! wabbit-descwiptor new-value)
-(SET-WABBIT-DESCWIPTOR/HEADHUNT-ENABLE-FLAG! wabbit-descwiptor new-value)
-
-
-In addition, the following aliases were thought to be handy:
-
- WABBIT-DESCWIPTOR/HEADHUNT-COLLECTION =
- WABBIT-DESCWIPTOR/HEADHUNT-ENABLE-FLAG
-
- SET-WABBIT-DESCWIPTOR/HEADHUNT-COLLECTION! =
- SET-WABBIT-DESCWIPTOR/HEADHUNT-ENABLE-FLAG!
-
-
-@xref{Wabbit Descwiptor} for details of the components' types and formats.
-
-
-@node Default Fudd Thunks
-
-The default Fudd thunks (@ref{Fudd Thunk}) for the various hunts are as follows:
-
-Wabbit Hunting
---------------
-
-*DEFAULT-FUDD-THUNK*
-
-Global fluid variable bound to a procedure of no arguments that is called upon
-collection of all the wabbit holes into the wabbit buffer (and heads into the
-HEADHUNT-COLLECTION if headhunting is enabled)
-
-
-
-Headhunting
------------
-
-*DEFAULT-HEADHUNT-FUDD-THUNK*
-
-Global fluid variable bound to a procedure of no arguments that is called upon
-collection of all heads during HEADHUNTing (and upon collection of all wabbit
-holes into the wabbit buffer if the wabbit vector is non-empty).
-
-
-*DEFAULT-HEADHUNT-WABBIT-DESCWIPTOR*
-
-The default wabbit descwiptor used by calls to HEADHUNT. It contains a null
-wabbit-vector and a wabbit buffer of only two slots (for the flag and index).
-This is a global variable that can be fluid bound to any valid wabbit
-descwiptor instance.
-
-
-@node Cellify
-
-(CELLIFY CONSTANTSPACE-WABBIT-HOLE) ;; c-space wabbit holes print as characters
-
- This is a *very* precarious hack. It returns a cell whose contents point to
-the wabbit hole in constant space (@xref{Wabbit Hole}). This cell should not be
-permitted to escape from the Fudd thunk where (presumably) it was created, else
-a spurious pointer into constant space would result and who knows how it might
-piss off the garbage collector. Specifically, don't go pretty-printing these
-cells 'cause the printer hashes output so the display hashtable will capture
-the cell.
-
- In general, you should go have a nice calm discussion with a system wizard
-before frobbing with CELLIFY. It can save you a *lot* of trouble, believe me.
-
-
-@node Headhunt
-
-(HEADHUNT #!optional HEADHUNT-FUDD-THUNK HEADHUNT-WABBIT-DESCWIPTOR)
-
-The HEADHUNT-WABBIT-DESCWIPTOR is installed, which declares open season on no
-wabbits but does call for headhunting to commence. Afterward, the
-HEADHUNT-FUDD-THUNK is invoked (on no arguments) and its result it the result
-of the call to HEADHUNT.
-
-The optional HEADHUNT-FUDD-THUNK parameter default to the value of
-*DEFAULT-HEADHUNT-FUDD-THUNK* (@ref{Default Fudd Thunks}. Similarly for
-HEADHUNT-WABBIT-DESCWIPTOR.
-
-As with WABBIT-HUNTing Fudd thunks, the HEADHUNT-FUDD-THUNK is free to access
-the wabbit descwiptors wabbit-buffer and headhunt-collection slots, but should
-be careful in doing so. Letting dangerous bits escape can be treacherous.
-
-Also, as with WABBIT-HUNTing, the wabbit descwiptor is swabbed (@ref{Swabbing
-Wabbit Descwiptors}) upon completion of the hunt. (In fact, this is just an
-alternative caller interface to the WABBIT-HUNT procedure for those more
-interested in headhunting than in wabbit hunting. To each his own.)
-
-
-
-@node Examples
-
-;;;
-;;; Sample usage (and mis-usage)
-;;;
-
-@menu
-
-* Wreckless:: Wabbit Hunt - mis-use / abuse
-* Non-Wreckless:: Wabbit Hunt - good use
-* Dangerous:: Wabbit Hunt - poor use
-* Semi-Wreckless:: Headhunt - fair use
-
-@end menu
-
-
-@node Wreckless
-
-#| Sample wreckless wabbit hunt... (does not swab the wabbit buffer)
- --------------------------------
-(define foobarbaz (cons 'a 'b))
-
-(begin
- (wabbit-season!
- (make-wabbit-descwiptor false ; hunt disable flag disabled
- (vector foobarbaz) ; wabbit vector
- (make-vector 10 #f) ; wabbit buffer
- false ; headhunt enable flag disabled
- ))
- 'be-careful!)
-
-(gc-flip)
-
-(define done (duck-season!))
-
-(pp done) ; lookin' for trouble
-
-;returns: #(#t #((a . b)) #(#t 4 (foobarbaz a . b) 1 () () () () () ()) ())
-|#
-
-
-@node Non-Wreckless
-
-#| Sample non-wreckless wabbit hunt... (safe wabbit hole count)
- ------------------------------------
-(wabbit-hunt
- (make-wabbit-descwiptor false ; hunt disable flag disabled
- (vector foobarbaz) ; wabbit vector
- (make-vector 10 #f) ; wabbit buffer
- false ; headhunt enable flag disabled
- ))
-
-; evaluated repeatedly... (stable wabbit hole count... holes swabbed upon exit)
-;
-;Value 31: #(#t 6 () () () () () () () ()) ; - 6 = wabbit hole count + 2
-;Value 32: #(#t 6 () () () () () () () ())
-;Value 33: #(#t 6 () () () () () () () ())
-|#
-
-
-@node Dangerous
-
-#| Sample dangerous wabbit hunt... (fudd thunk exposes the wabbit holes...hash)
- -----------------------------
-(wabbit-hunt
- (make-wabbit-descwiptor false ; hunt disable flag disabled
- (vector foobarbaz) ; wabbit vector
- (make-vector 10 #f) ; wabbit buffer
- false ; headhunt enable flag disabled
- )
- (named-lambda (exposing-fudd-thunk)
- (let* ((wabbuf (wabbit-descwiptor/wabbit-buffer (get-wabbit-descwiptor)))
- (got-em-all? (vector-ref wabbuf 0))
- (last-hole-index (vector-ref wabbuf 1)))
- (display "\n; #(")
- (do ((index 2 (1+ index)))
- ((>= index last-hole-index)
- (if got-em-all?
- (display ")\n; Th-th-th-that's all folks!")
- (display ")\n; And many more.... maybe?!?"))
- (newline))
- (write (vector-ref wabbuf index)) ; DANGER! WRITE hashes output.
- (write-char #\Space)))))
-
-; evaluated repeatedly... (stable display)
-
-; #((foobarbaz a . b) 1 #((a . b)) 1 )
-; Th-th-th-that's all folks!
-;No value
-
-; #((foobarbaz a . b) 1 #((a . b)) 1 )
-; Th-th-th-that's all folks!
-;No value
-
-; #((foobarbaz a . b) 1 #((a . b)) 1 )
-; Th-th-th-that's all folks!
-;No value
-
-; #((foobarbaz a . b) 1 #((a . b)) 1 )
-; Th-th-th-that's all folks!
-;No value
-|#
-
-
-@node Semi-Wreckless
-
-#| Sample semi-wreckless headhunt... (default headhunt-fudd-thunk exposes coll)
- -------------------------------
-
-(begin (headhunt)
- (wabbit-descwiptor/headhunt-enable-flag (get-wabbit-descwiptor)))
-
-; evaluated repeatedly... (stable head count... if negative, partial count)
-;
-;Value: 23648
-;Value: 23648
-;Value: 23648
-|#
-
-
-@c Local Variables:
-@c compile-command: "simple-make-info /scheme/documentation/README.wabbit wabbit"
-@c End:
+++ /dev/null
-[File ~ziggy/Thesis/PhD/BreakPoint/headhunt.text]
------
-Goal: Find all Scheme objects that point to any element of a target vector of
- objects, returning the result in a specified buffer. If there are more
- pointing objects than slots in the buffer, return a status flag
- indicating that there may be more pointing objects (so the caller can
- frob the pointers already found then call findptrs again).
-
-----------
-Interface:
-
- Given: TARGET-VECTOR - a vector of target objects, and
- POINTER-BUFFER - a buffer for accumulating objects that point to
- elements of the TARGET-VECTOR
- [RTN-AGG-VECT? - optional flag requesting ptr to vector of all
- aggregates live after GC]
-
- Effect: Fills POINTER-BUFFER with objects that point to elements of
- TARGET-VECTOR.
-
- Returns: Three values
- - A flag indicates whether all pointers to TARGET-VECTOR elements
- could fit in POINTER-BUFFER.
- - A flag indicating if more pointers to TARGET-VECTOR elements may
- exist but could not be isolated in this GC pass. Next pass may
- succeed in isolating them all (? compression after-effect) or it
- may always fail into more objects are released.
- - Either false when RTN-AGG-VECT? is false (i.e., not requested)
- otherwise it is a vector of all aggregates or false if the
- vector was too big to fit in available memory.
--------------
-Idea [Jinx's]
-
-Embed hack in a copying GC-like memory sweep as follows:
-
- FROM SPACE: .-----------------------------.
- | | FROM TOP (hi addr)
- `-----------------------------'
-
- TO SPACE: .-----------------------------.
- | | TO TOP (hi addr)
- `-----------------------------'
- ^ ^ ^
- | -> | -> <- |
- | | |
- Scan Free Heads
-
- Scan and Free move as w/ a normal copying GC.
- Each aggregate datum [e.g., pair, vector, cell, code block, closure, etc] that
- is encountered has a pointer to its head copied into Heads. Whenever one of
- the elements in the TARGET-VECTOR is encountered, some object whose head is
- right of Heads must have pointed to it. Scan through head space to find it.
- NB: This Scan through head space can be conducted as a binary search since the
- pointers to aggregate heads (in TO space) are in order R->L monotonically
- increasing (because they are copied as Free drifts to the right). When
- a target datum is sighted, the aggregate pointing to that target has To-space
- address that is the lesser of the two consecutive entries in head space which
- straddle the Scan pointer.
- If Free collides w/ Heads, continue the copying GC as normal, abandonning any
- further findptr hackery, but set the ALL-FIT-IN-PTR-BUFF flag to false (to
- return).
- Extra boon: if the GC completes w/o encrouchment then Heads points to
- the first element of a L->R consecutive array containing ptrs to all
- aggregate objects in TO space. By plopping down a VECTOR header left of Head
- (if there is a free slot to the left of Heads), this array can be instantly
- reified into a Scheme vector. Free cells are then those between Free and
- Heads (or the Heads vector could be btblt'd left into the Free cells. Such a
- vector handle may be useful for various statistics and bookkeeping frobs, so
- it could be returned to the user if a handle on this vector is requested
- (otherwise, the array can just be abandonned in TO space and treated as free
- cells). Naturally, such a vector should not be retained long, however, since
- it stands to consume a fair fraction of space in TO space. If not desired,
- Heads can be set to TO-space TOP when the GC completes, and again the free
- cells are those between Free and Heads.
-
- --*--
-
- Ziggy observation 1: actually, even after Free has encroached on Heads, we can
- still keep an eye out for TARGET-VECTOR elts and scan from right of Free
- into remaining heads. If we find the head we seek, we win and keep going. We
- need set the MAYBE-MORE flag only if/when we scan through all heads and
- fail to find the appropriate head. If we are moby lucky, we may just win when
- we might otherwise have wimped out... though it may be hard to anticipate or
- otherwise characterize under what conditions this extension may pay off.
- Nevertheless, it somewhat simplifies the algorithm: if Free encroaches Heads
- then scan right of Free to end; otherwise scan right of Heads to end. Never
- give up the hunt.
-
- Ziggy observation 2: even when Free is about to encrouch on Heads, we may be
- able to safely shift all Heads entries to the right (dropping rightmost head
- space elements) as follows: binary search for the head space object left of
- the Scan straddle. The next smaller head space entry is already fully scanned
- so it cannot possibly be needed any longer to locate pointing aggr heads.
- Thus every elt to the right of the lesser Scan straddle head are no longer
- needed in head space so head space elts can be shifted right to truncate head
- space. This hack, however, obliterates head space as a potential reified
- vector of ALL-AGGS-VECT, but then again if the encroachment were not avoided
- then the obliteration already occurs by virtue of the Free/Heads encroachment
- anyway, so nothing is lost. Upshot: always do the right shift truncation so
- we don't lose potential pointing obj isolations due to head space overflow.
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; System Packaging
-
-(declare (usual-integrations))
-\f
-(cond ((name->package '(gc-wabbits))
- (display "\n; Package already loaded under some other alias")
- 'ok)
- (else
- (load-package-set "wabbit")
- (add-subsystem-identification! "Wabbit Hunting / Headhunting GC" '(1 0))
-
- (let ()
- (define (package-initialize package-name
- #!optional procedure-name mandatory?)
- (let ((procedure-name
- (if (default-object? procedure-name)
- 'INITIALIZE-PACKAGE!
- procedure-name))
- (mandatory?
- (or (default-object? mandatory?) mandatory?)))
- (define (print-name string)
- (display "\n")
- (display string)
- (display " (")
- (let loop ((name package-name))
- (if (not (null? name))
- (begin
- (if (not (eq? name package-name))
- (display " "))
- (display (system-pair-car (car name)))
- (loop (cdr name)))))
- (display ")"))
-
- (define (package-reference name)
- (package/environment (find-package name)))
-
- (let ((env (package-reference package-name)))
- (cond ((not procedure-name))
- ((not (lexical-unreferenceable? env procedure-name))
- (print-name "initialize:")
- (if (not (eq? procedure-name 'INITIALIZE-PACKAGE!))
- (begin
- (display " [")
- (display (system-pair-car procedure-name))
- (display "]")))
- ((lexical-reference env procedure-name)))
- ((not mandatory?)
- (print-name "* skipping:"))
- (else
- ;; Missing mandatory package! Report it and die.
- (print-name "Package")
- (display " is missing initialization procedure ")
- (display (system-pair-car procedure-name))
- (error "Could not initialize a required package."))))))
-
- (package-initialize '(gc-wabbits)))))
-
-;;; fini
+++ /dev/null
-;;; -*- Scheme -*-
-
-(DECLARE (USUAL-INTEGRATIONS)) ; MIT Scheme-ism: promise not to redefine prims
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ;;
-;; TEST-WABBIT -- Harey test of wabbit hunting / headhunting g.c. ;;
-;; ;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-#|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;|
- | |
- | Uses: |
- | tons o' stuff not yet documented as dependencies |
- | |
- |#;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;|
-
-;; TODO:
-;;
-;; - Document dependencies
-;; - [SCREWS] see last page
-\f
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ;;
-;; TEST-WABBIT -- Harey test of wabbit hunting / headhunting g.c. ;;
-;; ;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define *muobj-wabbit-vector* '--TBA--)
-
-(define (muobj-wabbit-vector/install!)
-
- (define muobj-pair (cons make-unique-object
- (make-unique-object)))
- (define muobj-vector (vector 'make 'nique 'bject
- make-unique-object))
-#|
- (define muobj-promise (delay make-unique-object))
-|#
-
- (define-structure (muos (conc-name muos/)
- (constructor make-muos ()))
- ( uobj-slot (make-unique-object))
- ( cuobj-slot (make-unique-object) read-only #T)
- ( muobj-slot make-unique-object)
- (cmuobj-slot make-unique-object read-only #T))
-
- (define muobj-struct1 (make-muos))
- (define muobj-struct2 (make-muos))
-
- (define muobj-cell (make-cell make-unique-object))
- (define muobj-weak-pair (weak-cons (make-unique-object)
- make-unique-object ))
-
- (define muobj-weak-car (weak-car muobj-weak-pair)) ; made UObj
- (define muobj-weak-cdr (weak-cdr muobj-weak-pair)) ; make-UObj
-
- (define muobj-apply-hook (make-apply-hook muobj-weak-car
- make-unique-object))
- (define muobj-entity (make-entity muobj-weak-car
- make-unique-object))
- (define muobj-forced-promise (let ((p (delay make-unique-object)))
- (force p)
- p))
-
- (define muobj-wabbit-vector
- `#(
- ,muobj-weak-car ; Made UObj
- ,muobj-weak-cdr ; Make-UObj
-
- ,muobj-pair
- ,muobj-vector
-#|
- ,muobj-promise
-|#
- ;;
- ;; (define-structure (muos (conc-name muos/)
- ;; (constructor make-muos ()))
- ;; (muobj-slot (make-unique-object))
- ;; (cmuobj-slot (make-unique-object) read-only true)
- ;; (muos-slot make-unique-object)
- ;; (cmuso-slot make-unique-object read-only true))
- ;;
- ,muobj-struct1
- ,muobj-struct2
-
- ,muobj-cell
- ,muobj-weak-pair
- ,muobj-forced-promise
- ,muobj-apply-hook
- ,muobj-entity
- ))
-
- (set! *muobj-wabbit-vector* muobj-wabbit-vector)
-
- (pp (cons 42 make-unique-object)) ; Random un-named pair for pp hashing
-
- 'DONE)
-\f
-(define (forced-promise? x) (and (promise? x) (promise-forced? x)))
-
-(define (muobj-wabbit-hunt)
- (wabbit-hunt
- (make-wabbit-descwiptor false ; hunt disable flag disabled
- *muobj-wabbit-vector* ; targets of the hunt
- (make-vector 100 #f) ; wabbit buffer
- false ; headhunt enable flag disabled
- )
- (named-lambda (exposing-fudd-thunk)
- (let* ((wabbuf (wabbit-descwiptor/wabbit-buffer (get-wabbit-descwiptor)))
- (got-em-all? (vector-ref wabbuf 0))
- (last-hole-index (vector-ref wabbuf 1)))
- (display "\n; #(")
- (do ((index 2 (1+ index)))
- ((>= index last-hole-index)
- (if got-em-all?
- (display ")\n; Th-th-th-that's all folks!")
- (display ")\n; And many more.... maybe?!?"))
- (newline))
-\f
- (let ((next-elt (vector-ref wabbuf index)))
- (if (odd? index)
- (write next-elt) ; write index of non-skipped elt
- (let ()
- (define (space-write-and-skip! object)
- (space-out!) (write object) (skip!))
- (define (space-in-write! object)
- (space-in!) (write object) )
- (define (space-out!)
- (write-char #\Space) (write-char #\=) (write-char #\Space))
- (define (space-in!)
- (write-char #\Space) (write-char #\-) (write-char #\Space))
- (define (skip!) (set! index (1+ index)))
- (define (offset) (vector-ref wabbuf (1+ index)))
-
- (write-char #\[) (write index) (write-char #\])
- (write-char #\Space)
- (write (microcode-type-name next-elt))
-
- (cond ((pair? next-elt)
- (space-write-and-skip! (if (zero? (offset))
- (car next-elt)
- (cdr next-elt))))
- ((vector? next-elt)
- (space-write-and-skip! (vector-ref next-elt
- (-1+ (offset)))))
- ((record? next-elt)
- (space-write-and-skip! (%record-ref next-elt
- (-1+ (offset)))))
- ;;
- ;; MIT Scheme specific extensions...
- ;;
- ((cell? next-elt)
- (space-write-and-skip! (cell-contents next-elt)))
- ((weak-pair? next-elt)
- (space-write-and-skip! (if (zero? (offset))
- (weak-car next-elt)
- (weak-cdr next-elt))))
- ((forced-promise? next-elt)
- (space-write-and-skip! (force next-elt)))
- ((promise? next-elt) ; Must follow forced-promise
- (space-write-and-skip! next-elt ))
- ((%entity-extra/apply-hook? next-elt)
- (space-write-and-skip! (case (offset)
- ((0) (system-hunk3-cxr0 next-elt))
- ((1) (system-hunk3-cxr1 next-elt))
- ((2) (system-hunk3-cxr2 next-elt)))))
- ((apply-hook? next-elt) ; SIGH: hunk3/triple hack uproc
- (space-write-and-skip! (if (zero? (offset))
- (apply-hook-procedure next-elt)
- (apply-hook-extra next-elt))))
- ((entity? next-elt)
- (space-write-and-skip! (if (zero? (offset))
- (entity-procedure next-elt)
- (entity-extra next-elt))))
- ((environment? next-elt)
- (space-write-and-skip! (system-vector-ref next-elt
- (-1+ (offset)))))
- ((and (compiled-code-block? next-elt)
- (compiled-code-block/manifest-closure? next-elt))
- (space-write-and-skip! (system-vector-ref next-elt
- (-1+ (offset)))))
- ;;
- ;; Normal compiled code blocks are unsafe since may ref
- ;; into the R/W/X cache of the linkage section.
- (else
- (space-in-write! next-elt))))))
- ;(display "\n; #(") ; From above
- (display "\n; ")))))
- )
-\f
-(define (test-wabbit-go-for-it)
- (muobj-wabbit-vector/install!)
- (muobj-wabbit-hunt)
- )
-
-#| Until somebody builds the newest Scheme band...
-
-(define %entity-extra/apply-hook?
- (access %entity-extra/apply-hook? (->environment '(runtime procedure))))
-|#
-
-(let-syntax
- ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (microcode-type (cadr form))))))
-
- (define apply-hook-tag
- (access apply-hook-tag (->environment '(runtime procedure))))
-
- (define (%entity-extra/apply-hook? extra)
- ;; Ziggy cares about this one.
- (and (object-type? (ucode-type hunk3) extra)
- (eq? apply-hook-tag (system-hunk3-cxr0 extra))))
- )
-
-
-
-;;; fini
-
-(provide "Test Wabbit")
-
-;;; Complete dependencies (desire = run-time require (not load-time require))
-
-(begin
-
- (with-working-directory-pathname "Utils/"
- (named-lambda (acknowledge-Utils-desiderata)
- (desire "Unique Objects" "unique-objects")
- ))
-
- (load-option 'wabbit )
- (load-option 'pc-sample)
-
- (with-working-directory-pathname "../ObjectType/"
- (named-lambda (acknowledge-ObjType-desiderata)
- (desire "Object Structural Types" "objtype")
- ))
- )
-\f
-#| Example run...
-
-;; First time...
-(test-wabbit-go-for-it)
-
-;; Thereafter...
-(muobj-wabbit-hunt)
-
-(42 . #[compiled-closure 31 ("unique-objects") #xD0 #x7B6D24 #x79276C])
-
-|#
-
-; #([2] pair = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
-; [4] vector = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
-; [6] record = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
-; [8] record = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
-; [10] record = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
-; [12] record = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
-; [14] cell = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
-; [16] weak-cons = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
-; [18] promise = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
-; [20] entity = #[compiled-closure 32 ("unique-objects") #x1A8 #x145801C #x1457C44]
-; [22] entity = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
-; [24] compiled-code-block = #[compiled-closure 32 ("unique-objects") #x1A8 #x145801C #x1457C44]
-; [26] triple = #[compiled-closure 32 ("unique-objects") #x1A8 #x145801C #x1457C44]
-; [28] triple = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
-; [30] compiled-code-block - #[compiled-code-block 33]
-; 602
-; [32] quad - #[quad 34]
-; 0
-; [34] weak-cons = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
-; [36] weak-cons = #[compiled-closure 32 ("unique-objects") #x1A8 #x145801C #x1457C44]
-; )
-; Th-th-th-that's all folks!
-;No value
-\f
-
-(begin
- (load "/scheme/700/compiler/etc/disload")
- (load-disassembler))
-
-#|
-(compiler:disassemble #@33)
-
-Disassembly of #[compiled-code-block 33] (Block 2 in /sw/ziggy/Projects/Descartes/Wabbit/test-wabbit.inf):
-Code:
-
-14DFD24 8 (ble () (offset 0 4 3))
-14DFD28 C (ldi () #x1A #x1C)
-14DFD2C 10 (external-label () #x101 (@pco #x14))
-14DFD30 14 (combf (<) #x15 #x14 (@pco #x-14))
-.
-.
-.
-
-Constants:
-
-14E0608 8EC #[LINKAGE-SECTION #x21]
-14E060C 8F0 2 argument procedure cache to #[compiled-entry 35 () #xC #x1501DF0]
-14E0618 8FC 2 argument procedure cache to #[compiled-entry 36 () #xC #x1501E10]
-14E0624 908 3 argument procedure cache to #[compiled-procedure 37 ("uproc" #x1D) #x14 #x392160]
-14E0630 914 3 argument procedure cache to #[compiled-procedure 38 ("uproc" #x24) #x14 #x3923D0]
-14E063C 920 2 argument procedure cache to #[compiled-procedure 39 ("list" #x14) #x14 #x394808]
-14E0648 92C 3 argument procedure cache to #[compiled-procedure 40 ("list" #xF) #x14 #x3945B0]
-14E0654 938 2 argument procedure cache to #[compiled-procedure 41 ("list" #x12) #x14 #x3946E8]
-14E0660 944 2 argument procedure cache to #[compiled-entry 42 () #xC #x1501E28]
-14E066C 950 3 argument procedure cache to #[compiled-entry 43 () #xC #x1501E40]
-14E0678 95C 5 argument procedure cache to #[compiled-entry 44 () #xC #x1501E58]
-14E0684 968 1 argument procedure cache to #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
-14E0690 974 #[LINKAGE-SECTION #x10001]
-14E0694 978 Reference cache to make-unique-object
-14E0698 97C #[LINKAGE-SECTION #x20001]
-14E069C 980 Assignment cache to *muobj-wabbit-vector*
-14E06A0 984 #[LINKAGE-SECTION #x30003]
-14E06A4 988 3 argument procedure cache to #[compiled-entry 45 () #xC #x1501E78]
-14E06B0 994 done
-14E06B4 998 "muos"
-14E06B8 99C (uobj-slot cuobj-slot muobj-slot cmuobj-slot)
-14E06BC 9A0 make
-14E06C0 9A4 nique
-14E06C4 9A8 bject
-14E06C8 9AC (#[dbg-info 46] "/sw/ziggy/Projects/Descartes/Wabbit/wabbit-
-14E06CC 9B0 #[environment 47]
-
-;No value
-|#
-
-;;
-;; [SCREWS]: Environments (system-vector-ref (-1+ index))
-;; Compiled code blocks -- appear in linkage section. Indir thru env.
-;; Quads - what a ref trap points to in a linkage section.
-;; ...don't sweat it... will lexical-assign w/in env.
-;; Quotations [scode.scm --- %singleton-set-car!]
-;;
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-(fluid-let ((compiler:coalescing-constant-warnings? #f))
- (compile-directory "."))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Wabbit Hunting / Headhunting System Packaging
-
-(global-definitions "../runtime/runtime")
-
-
-(define-package (gc-wabbits)
- (files "wabbit")
- (parent ())
- (export ()
- wabbit-hunt
- wabbit-season!
- wabbit-season?
- duck-season!
- duck-season?
- cellify
- get-wabbit-descwiptor
- make-wabbit-descwiptor
- wabbit-descwiptor?
- wabbit-descwiptor/hunt-disable-flag
- wabbit-descwiptor/wabbit-vector
- wabbit-descwiptor/wabbit-buffer
- wabbit-descwiptor/headhunt-enable-flag
- wabbit-descwiptor/headhunt-collection
- set-wabbit-descwiptor/hunt-disable-flag!
- set-wabbit-descwiptor/wabbit-vector!
- set-wabbit-descwiptor/wabbit-buffer!
- set-wabbit-descwiptor/headhunt-enable-flag!
- set-wabbit-descwiptor/headhunt-collection!
- headhunt
- *default-fudd-thunk*
- *default-headhunt-fudd-thunk*
- *default-headhunt-wabbit-descwiptor*)
- (initialization (initialize-package!)))
+++ /dev/null
-#| -*- Scheme -*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Wabbit Hunting and Headhunting GC
-;;; package: (gc-wabbit)
-
-(declare (usual-integrations))
-\f
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; ;;;
-;;; WABBIT -- Wabbit hunting and headhunting frobbery. ;;;
-;;; ;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (initialize-package!)
- (set! index:gc-wabbit-descwiptor
- (fixed-objects-vector-slot 'GC-WABBIT-DESCWIPTOR))
- (install))
-
-
-(define (wabbit-hunt wabbit-descwiptor #!optional fudd-thunk)
- "(WABBIT-DESCWIPTOR #!optional FUDD-THUNK)
-
- Procedure behavior:
- ------------------
-
- Open wabbit season on wabbits matching WABBIT-DESCWIPTOR and go wabbit
- hunting. Once all the wabbits have been wounded up, invoke FUDD-THUNK,
- weturning the wesult of FUDD-THUNK as the wesult of the wabbit hunt.
-
- The optional FUDD-THUNK pawameter defaults to the value of the fluid
- vawiable: *DEFAULT-FUDD-THUNK*, which defaults to just weturning the
- wabbit buffer (which will have been swabbed upon return!).
-
- Explanation of parameters:
- -------------------------
-
- A ``wabbit descwiptor'' is a 4-element vector:
- ------------------------------------------------------------------------
- 0. Boolean hunt disable flag -- (a.k.a. ``duck season'' flag)
- avoid wabbit hunting and/or headhunting
- upon the next GC flip.
-
- 1. Wabbit vector -- vector of object references to target objects
- (a.k.a. ``wabbits'')
-
- 2. Wabbit buffer -- vector into which wabbit sightings are recorded.
- This must be of length (2 + twice wabbit vect len).
-
- 3. Boolean headhunt enable flag -- if FALSE, no headhunt is performed.
- else this slot will be replaced by a
- headhunt collection upon completion
- of the headhunting wabbit hunt.
- ------------------------------------------------------------------------
- ****
- NB a) Both the WABBIT-VECTOR and the WABBIT-BUFFER must reside in the heap
- **** i.e., they may *not* reside in constant space or on the stack.
- b) Both the wabbit buffer and the headhunt collection slots are zeroed
- upon return, since they may contain unsafe pointers. Moreover, it
- is unsafe for the FUDD-THUNK to return them or otherwise close over
- them. Consider them only to be very fluid parameter sources for the
- FUDD-THUNK.
-
- The ``wabbit buffer'' should be a vector of FALSEs before the wabbit hunting
- is initiated. At the end of the wabbit hunt, the wabbit buffer contents will
- be laid out as follows:
- --------------------------------------------------------------------------
- slot 0 = Boolean flag: TRUE if all wabbit sightings were recorded in the
- wabbit buffer
- FALSE if the wabbit buffer was too small to accomo-
- date a record for each wabbit sighting.
- (In this case, the FUDD-THUNK should do a
- bit of cleanup work so the same wabbit
- hunt can be re-initiated later.)
- slot 1 = Fixnum: number of wabbit sightings recorded in the wabbit buffer
- slot 2 = Object reference: cite of first wabbit sighting (``wabbit hole'')
- slot 3 = Number: offset into first sighting object where wabbit is hiding
- --------------------------------------------------------------------------
- ...and so on, with even-index slots containing wabbit holes and odd-index
- slots, indices. Note that slot 1 should hold the index of the first even
- slot that holds FALSE and all slots thereafter should likewise hold FALSE.
-\f
- A ``wabbit hole'' is normally a headed object reference (a pointer) but it
- may in very rare circumstances be a ``wascally wabbit hole''. There are only
- three kinds of wascally wabbit holes:
- ---------------------------------------------------------------------------
- 1. Characters: these indicate references to wabbit holes in constant space.
- To reify the character into a cell whose contents holds the
- wabbit, apply CELLIFY to the slot ref that holds the char.
- (NB: the char as printed holds only part of the addr; you
- must vector-ref into the wabbit buffer to get all the
- addr bits. This is incredible magic.)
- 2. Null Refs: these indicate headless objects. They should never appear.
- 3. Stack Refs: these indicate objects on the control stack. Since we reify
- the stack into the heap as part of the call to WABBIT-HUNT,
- these too should never appear unless you are doing something
- painfully obscure (and dangerous!).
-
- If you ever encounter Null or Stack wabbit holes, you may want to send a
- friendly bug report (?) to bug-cscheme@zurich.ai.mit.edu with a repeatable
- test script.
- ---------------------------------------------------------------------------
-
- The ``headhunt collection'' is a vector of arbitrary (fixnum) length. It is
- intended to contain a pointer to the head of every object in the heap which
- has an object header (spec., numbers, Booleans, etc not included). If all
- headed heap objects fit in the space available after the GC flip, then slot
- 0 of this headhunt collection is TRUE. If not, slot 0 is FALSE and the vec-
- tor contains as many object head references as actually did fit.
-
- ************ Be verwy verwy careful when headhunting... if you are not careful
- ** CAVEAT ** to release the headhunt collection (e.g., SET! it to FALSE) or if
- ************ you gobble up too much intermediate state in traversing it, you
- will exhaust the available heap space and go down in flames. This
- is a very fragile system memory feature intended for only the
- most ginger-fingered discriminating systems wizards. For instance
- it may some day lead to a post-GC garbage scavenger. Nonetheless,
- it readily lends itself to self abuse if not treated reverently.
- "
-\f
- (cond ((or (default-object? fudd-thunk)
- (not fudd-thunk))
- (set! fudd-thunk
- *default-fudd-thunk*)))
- (let (;;
- ;; Uhm... force stack refs into heap during wabbit season; undo at exit
- ;; and should be careful not to hunt wabbits out of season
- ;;
- (call-within-wabbit-season-with-duck-season-return-continuation
- call-with-current-continuation)
- ;;
- ;; gc-flip is the raw low-level wabbit hunt mechanism... the hunt flag
- ;; enabled in the wabbit-descwiptor forces an alternative
- ;; ucode gc-loop which goes a-huntin' varmits.
- (%waw-wabbit-hunt gc-flip)
- )
- (wabbit-season! wabbit-descwiptor)
- (call-within-wabbit-season-with-duck-season-return-continuation
- (lambda (return-to-duck-season)
- (%waw-wabbit-hunt)
- (let ((killed-da-wittle-bunny-wabbits
- (dynamic-wind
- (lambda () 'unwind-protect)
- fudd-thunk
- ;;
- ;; Make sure unsafe buffers are cleared before returning...
- ;;
- (lambda () (%swab-wad wabbit-descwiptor)))))
- (return-to-duck-season killed-da-wittle-bunny-wabbits))))))
-
-
-(define *default-fudd-thunk*) ; See install below
-(define (default-fudd-thunk)
- (wabbit-descwiptor/wabbit-buffer (get-wabbit-descwiptor)))
-
-
-(define-integrable (%swab-wad wad) ; swab the wabbit descwiptor but good
- ;;
- ;; Nullify wabbit buffer, leaving found-all-flag and first-null-index intact
- ;;
- (let ((wabbit-buffer (wabbit-descwiptor/wabbit-buffer wad)))
- (cond ((vector? wabbit-buffer)
- (let ((buflen (vector-length wabbit-buffer)))
- (subvector-fill! wabbit-buffer
- (min 2 buflen) ; fuddge
- buflen
- false)))))
- ;;
- ;; Drop headhunt collection by replacing it w/ the length of the collection,
- ;; negated if not a complete headhunt collection.
- ;;
- (let ((headhunt-coll (wabbit-descwiptor/headhunt-collection wad)))
- (cond ((vector? headhunt-coll)
- (let ((head-len (vector-length headhunt-coll))
- (complete? (vector-ref headhunt-coll 0)))
- (set-wabbit-descwiptor/headhunt-collection! wad
- (if complete?
- head-len
- (- head-len)))))))
- unspecific)
-\f
-;; Wabbit Season and Duck Season
-
-(define (wabbit-season! wabbit-descwiptor)
- "(WABBIT-DESCWIPTOR)
- Declare open season on wabbits matching our target descwiptor.
- Returns the old wabbit descwiptor (possibly FALSE).
- "
- (%stuff-gc-wabbit-descwiptor! wabbit-descwiptor))
-
-(define (duck-season!)
- "()
- Disable wabbit hunting... returns descwiptor from latest wabbit hunt.
- "
- (let ((current-wd (get-wabbit-descwiptor)))
- (cond ((wabbit-descwiptor? current-wd)
- (set-wabbit-descwiptor/hunt-disable-flag! current-wd true)
- current-wd)
- (else
- (%stuff-gc-wabbit-descwiptor! false)))))
-
-;; Misc
-
-(define (duck-season?)
- (let ((current-wd (get-wabbit-descwiptor)))
- (or (false? current-wd)
- (not (wabbit-descwiptor? current-wd)) ; should not arise, but guard
- (wabbit-descwiptor/hunt-disable-flag current-wd))))
-
-(define (wabbit-season?)
- (not (duck-season?)))
-
-
-;; Low-level bits
-
-(define index:gc-wabbit-descwiptor) ; See initialize-package! above
-
-(define-integrable (get-wabbit-descwiptor)
- (vector-ref (get-fixed-objects-vector) index:gc-wabbit-descwiptor))
-
-(define-integrable (%stuff-gc-wabbit-descwiptor! value)
- (let* ((fov (get-fixed-objects-vector))
- (old (vector-ref fov index:gc-wabbit-descwiptor)))
- (vector-set! fov index:gc-wabbit-descwiptor value)
- old))
-
-
-;; Very precarious indeed!
-
-(define (cellify object)
- ((ucode-primitive primitive-object-set-type 2) (ucode-type cell)
- object))
-\f
-;;;
-;;; Wabbit descwiptor data abstraction-- NB: 4-elt vector rep (ucode depend'cy)
-;;;
-
-(define-integrable (wabbit-descwiptor? object)
- (and (vector? object) (fix:= (vector-length object) 4)))
-
-(define-structure
- ( wabbit-descwiptor
- (conc-name wabbit-descwiptor/)
- ;;(name 'wabbit-descriptor) ;; unnamed [i.e., not tagged]
- (type vector))
- (hunt-disable-flag true READ-ONLY false TYPE boolean)
- (wabbit-vector (vector) READ-ONLY false TYPE vector)
- (wabbit-buffer (vector false 2) READ-ONLY false TYPE vector)
- (headhunt-enable-flag false READ-ONLY false TYPE boolean)
- )
-
-;; Structure accessor aliases...
-
-;; after the hunt, the flag is replaced by a headhunt collection
-
-(define-integrable
- (wabbit-descwiptor/headhunt-collection wabbit-descwiptor)
- (wabbit-descwiptor/headhunt-enable-flag wabbit-descwiptor))
-
-(define-integrable
- (set-wabbit-descwiptor/headhunt-collection! wabbit-descwiptor new-value)
- (set-wabbit-descwiptor/headhunt-enable-flag! wabbit-descwiptor new-value))
-\f
-;;;
-;;; Headhunting frobbery... special case of wabbit hunting: no wascally wabbits
-;;;
-
-(define (headhunt #!optional headhunt-fudd-thunk headhunt-wabbit-descwiptor)
- (cond ((or (default-object? headhunt-fudd-thunk)
- (not headhunt-fudd-thunk))
- (set! headhunt-fudd-thunk
- *default-headhunt-fudd-thunk*))
- )
- (cond ((or (default-object? headhunt-wabbit-descwiptor)
- (not headhunt-wabbit-descwiptor))
- (set! headhunt-wabbit-descwiptor
- *default-headhunt-wabbit-descwiptor*))
- )
- (wabbit-hunt headhunt-wabbit-descwiptor
- headhunt-fudd-thunk))
-
-
-(define *default-headhunt-fudd-thunk*) ; See install below
-(define (default-headhunt-fudd-thunk)
- ;; ,
- ;; Tres unsafe raven... lets headhunt collection escape the headhunt!
- ;;
- (wabbit-descwiptor/headhunt-collection (get-wabbit-descwiptor)))
-
-(define *default-headhunt-wabbit-descwiptor*) ; See install below
-(define (default-headhunt-wabbit-descwiptor)
- (make-wabbit-descwiptor false ; hunt disable flag disabled
- (vector) ; wabbit descwiptor null
- (vector '? 'N) ; wabbit buffer null-ish
- true ; headhunt enable flag enabled
- ))
-
-
-
-;;; fini
-
-(define (install)
- (set! *default-fudd-thunk*
- default-fudd-thunk)
- (set! *default-headhunt-fudd-thunk*
- default-headhunt-fudd-thunk)
- (set! *default-headhunt-wabbit-descwiptor*
- (default-headhunt-wabbit-descwiptor))
- )
-\f
-;;;
-;;; Sample usage (and mis-usage)
-;;;
-
-;; handy util for debuggery
-;;
-;;(define memory-ref (make-primitive-procedure 'primitive-object-ref))
-
-
-#| Sample wreckless wabbit hunt... (does not swab the wabbit buffer)
- --------------------------------
-(define foobarbaz (cons 'a 'b))
-
-(begin
- (wabbit-season!
- (make-wabbit-descwiptor false ; hunt disable flag disabled
- (vector foobarbaz) ; wabbit vector
- (make-vector 10 #f) ; wabbit buffer
- false ; headhunt enable flag disabled
- ))
- 'be-careful!)
-
-(gc-flip)
-
-(define done (duck-season!))
-
-(pp done) ; lookin' for trouble
-
-;returns: #(#t #((a . b)) #(#t 4 (foobarbaz a . b) 1 () () () () () ()) ())
-|#
-
-
-#| Sample non-wreckless wabbit hunt... (safe wabbit hole count)
- ------------------------------------
-(wabbit-hunt
- (make-wabbit-descwiptor false ; hunt disable flag disabled
- (vector foobarbaz) ; wabbit vector
- (make-vector 10 #f) ; wabbit buffer
- false ; headhunt enable flag disabled
- ))
-
-; evaluated repeatedly... (stable wabbit hole count... holes swabbed upon exit)
-;
-;Value 31: #(#t 6 () () () () () () () ()) ; - 6 = wabbit hole count + 2
-;Value 32: #(#t 6 () () () () () () () ())
-;Value 33: #(#t 6 () () () () () () () ())
-|#
-\f
-#| Sample dangerous wabbit hunt... (fudd thunk exposes the wabbit holes...hash)
- -----------------------------
-(wabbit-hunt
- (make-wabbit-descwiptor false ; hunt disable flag disabled
- (vector foobarbaz) ; wabbit vector
- (make-vector 10 #f) ; wabbit buffer
- false ; headhunt enable flag disabled
- )
- (named-lambda (exposing-fudd-thunk)
- (let* ((wabbuf (wabbit-descwiptor/wabbit-buffer (get-wabbit-descwiptor)))
- (got-em-all? (vector-ref wabbuf 0))
- (last-hole-index (vector-ref wabbuf 1)))
- (display "\n; #(")
- (do ((index 2 (1+ index)))
- ((>= index last-hole-index)
- (if got-em-all?
- (display ")\n; Th-th-th-that's all folks!")
- (display ")\n; And many more.... maybe?!?"))
- (newline))
- (write (vector-ref wabbuf index)) ; DANGER! WRITE hashes output.
- (write-char #\Space)))))
-
-; evaluated repeatedly... (stable display)
-
-; #((foobarbaz a . b) 1 #((a . b)) 1 )
-; Th-th-th-that's all folks!
-;No value
-
-; #((foobarbaz a . b) 1 #((a . b)) 1 )
-; Th-th-th-that's all folks!
-;No value
-
-; #((foobarbaz a . b) 1 #((a . b)) 1 )
-; Th-th-th-that's all folks!
-;No value
-
-; #((foobarbaz a . b) 1 #((a . b)) 1 )
-; Th-th-th-that's all folks!
-;No value
-|#
-
-#| Sample semi-wreckless headhunt... (default headhunt-fudd-thunk exposes coll)
- -------------------------------
-
-(begin (headhunt)
- (wabbit-descwiptor/headhunt-enable-flag (get-wabbit-descwiptor)))
-
-; evaluated repeatedly... (stable head count... if negative, partial count)
-;
-;Value: 23648
-;Value: 23648
-;Value: 23648
-|#
+++ /dev/null
-;;; -*- Scheme -*-
-
-(DECLARE (USUAL-INTEGRATIONS)) ; MIT Scheme-ism: promise not to redefine prims
-
-;;
-;; Serious monkey-ing around with the Wabbit hunting / Headhunting facility...
-;;
-
-(define (wabbit-setup)
- (begin
-
- (ge '(pc-sample code-blocks)) ; for losing imports
-
- (load-option 'wabbit)
- (load-option 'pc-sample)
-
- )
- )
-
-;; handy utils
-
-(define dbg-procedure/source-code
- (access dbg-procedure/source-code (->environment '(runtime compiler-info))))
-
-(define (code-block/lambda cobl)
- (dbg-procedure/source-code
- (vector-ref (dbg-info/procedures (compiled-code-block/dbg-info cobl
- 'load))
- 0)))
-
-#| Hunt a wascally wabbit... [used to generate null refs... now some constants]
- -----------------------
-
-(wabbit-setup)
-
-(define lnda
- (access lambda/name/display-acate (->environment '(pc-sample display))))
-
-(begin
- (wabbit-season!
- (make-wabbit-descwiptor false ; punt flag
- (vector lnda) ; wabbit vector
- (make-vector 100 false) ; wabbit buffer
- false ; headhunt flag
- ))
- 'be-careful!)
-
-(gc-flip)
-
-(define done (duck-season!))
-
-(pp (vector-ref done 0))
-(pp (vector-ref done 1))
-
-(define xx (vector-ref done 2))
-
-|#
-
-#| Frob the result ...
-
-(vector-ref xx 0)
-(vector-ref xx 1)
-(vector-ref xx 2)
-(vector-ref xx 3)
-(vector-ref xx 4)
-(vector-ref xx 5)
-
-|#
-\f
-#| was this ......
-
-lnda
-;Value 31: #[compiled-procedure 31 ("pcsdisp" #x1D) #x14 #x55D678]
-
-(pp xx)
-#(#t
- 22
- #[compiled-code-block 32] ; [ref is in linkage section]
- 212
- #[compiled-code-block 33] ; [ref is in linkage section] >>>-----.
- 346
- #\M-S-T-DC4
- 0
- #\C-H-DC4
- 0
- #\C-H-<
- 0
- #(#[compiled-code-block 116]
- #[compiled-code-block 115]
- #[compiled-code-block 114]
- #[compiled-code-block 113]
- #[compiled-code-block 112]
- #[compiled-code-block 111]
- #[compiled-code-block 110]
- #[compiled-code-block 109]
- #[compiled-code-block 108]
- #[compiled-code-block 107]
- #[compiled-code-block 106]
- #[compiled-code-block 105]
- #[compiled-code-block 104]
- #[compiled-code-block 103]
- #[compiled-code-block 102]
- #[compiled-code-block 101]
- #[compiled-code-block 100]
- #[compiled-code-block 99]
- #[compiled-code-block 98]
- #[compiled-code-block 97]
- #[compiled-code-block 96]
- #[compiled-code-block 95]
- #[compiled-code-block 94]
- #[compiled-code-block 93]
- #[compiled-code-block 33] ; [ref is in linkage section] <<<-----'
- #[compiled-code-block 92]
- #[compiled-code-block 91]
- #[compiled-code-block 90]
- #[compiled-code-block 89]
- #[compiled-code-block 88]
- #[compiled-code-block 87]
- #[compiled-code-block 32]
- #[compiled-code-block 86]
- #[compiled-code-block 85]
- #[compiled-code-block 84]
- #[compiled-code-block 83]
- #[compiled-code-block 82]
- #[compiled-code-block 81]
- #[compiled-code-block 80]
- #[compiled-code-block 79]
- #[compiled-code-block 78]
- #[compiled-code-block 77]
- #[compiled-code-block 76]
- #[compiled-code-block 75]
- #[compiled-code-block 74]
- #[compiled-code-block 73]
- #[compiled-code-block 72]
- #[compiled-code-block 71]
- #[compiled-code-block 70]
- #[compiled-code-block 69]
- #[compiled-code-block 68]
- #[compiled-code-block 67])
- 24
-\f
- #(#[compiled-procedure 66 ("pcsdisp" #x1) #x14 #x5587C8]
- get-primitive-name
- #[compiled-procedure 65 ("pcsdisp" #x2) #x14 #x558800]
- #[reference-trap #x0]
- #[reference-trap #x0]
- #[reference-trap #x0]
- #[reference-trap #x0]
- #[reference-trap #x0]
- #[reference-trap #x0]
- #[reference-trap #x0]
- #[compiled-procedure 64 ("pcsdisp" #x3) #x14 #x558B08]
- #[compiled-procedure 63 ("pcsdisp" #x4) #x14 #x558D10]
- #[compiled-procedure 62 ("pcsdisp" #x5) #x14 #x558D58]
- #[compiled-procedure 61 ("pcsdisp" #x6) #x14 #x558DA0]
- #[compiled-procedure 60 ("pcsdisp" #x7) #x14 #x558DE8]
- #[compiled-procedure 59 ("pcsdisp" #x8) #x14 #x558F10]
- #[compiled-procedure 58 ("pcsdisp" #x9) #x14 #x558FE0]
- #[reference-trap #x0]
- #[reference-trap #x0]
- #[reference-trap #x0]
- #[reference-trap #x0]
- #[reference-trap #x0]
- #[reference-trap #x0]
- #[reference-trap #x0]
- #[compiled-procedure 57 ("pcsdisp" #xA) #x14 #x559578]
- #[compiled-procedure 56 ("pcsdisp" #xB) #x14 #x559708]
- #[compiled-procedure 55 ("pcsdisp" #xC) #x14 #x559A40]
- ()
- #[compiled-procedure 54 ("pcsdisp" #xD) #x14 #x559F68]
- #[compiled-procedure 53 ("pcsdisp" #xE) #x14 #x55A290]
- #[compiled-procedure 52 ("pcsdisp" #xF) #x14 #x55A3A8]
- #[compiled-procedure 51 ("pcsdisp" #x10) #x14 #x55A4C0]
- #[compiled-procedure 50 ("pcsdisp" #x11) #x14 #x55A5A8]
- #[compiled-procedure 49 ("pcsdisp" #x12) #x14 #x55AA50]
- #[compiled-procedure 48 ("pcsdisp" #x13) #x14 #x55BB58]
- #[compiled-procedure 47 ("pcsdisp" #x14) #x14 #x55BC48]
- #[compiled-procedure 46 ("pcsdisp" #x15) #x14 #x55BD88]
- #[compiled-procedure 45 ("pcsdisp" #x16) #x14 #x55C158]
- #[compiled-procedure 44 ("pcsdisp" #x17) #x14 #x55C2D8]
- #[compiled-procedure 43 ("pcsdisp" #x18) #x14 #x55C6B0]
- #[compiled-procedure 42 ("pcsdisp" #x19) #x14 #x55CA88]
- #[compiled-procedure 41 ("pcsdisp" #x1A) #x14 #x55CEE0]
- #[compiled-procedure 40 ("pcsdisp" #x1B) #x14 #x55CFB8]
- #[compiled-procedure 39 ("pcsdisp" #x1C) #x14 #x55D020]
- #[compiled-procedure 31 ("pcsdisp" #x1D) #x14 #x55D678] ; <<<<
- #[compiled-procedure 38 ("pcsdisp" #x1E) #x14 #x55D818]
- #[compiled-procedure 37 ("pcsdisp" #x1F) #x14 #x55D960]
- #[compiled-procedure 36 ("pcsdisp" #x20) #x14 #x55DD78])
- 45
- (lnda . #[compiled-procedure 31 ("pcsdisp" #x1D) #x14 #x55D678])
- 1
- #[weak-cons 35]
- 0
- #[weak-cons 34]
- 0
- () ; 23rd elt [@ index 22]
- ()
- ()
- ()
- ()
- ()
- ()
- ()
- ()
- ()
- ()
- ()
- ()
- ()
- ()
- ()
- ()
- .
- .
- .
- ())
-;No value
-|#
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-(fluid-let ((sf/default-syntax-table (->environment '(RUNTIME))))
- (sf-directory "."))
-
-(load-option 'CREF)
-(cref/generate-constructors "wabbit")
\ No newline at end of file
projects / mit-scheme.git / commitdiff